diff -auBN ./r1/A1CKC10.m ./r2/r/A1CKC10.m --- ./r1/A1CKC10.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC10.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,4 +0,0 @@ -A1CKC10 ; ;07/02/04 - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) - I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff -auBN ./r1/A1CKC11.m ./r2/r/A1CKC11.m --- ./r1/A1CKC11.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC11.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,177 +0,0 @@ -A1CKC11 ; ;07/02/04 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(6)=% - I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(12)=% S %=$P(%Z,U,13) S:%]"" DE(15)=% S %=$P(%Z,U,14) S:%]"" DE(9)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="A1CKC11",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,D=0 K DE(1) ;.3721 - S DIFLD=.3721,DGO="^A1CKC12",DC="3^2.04P^.372^",DV="2.04MP31'X",DW="0;1",DOW="RATED DISABILITIES (VA)",DLB="Select "_DOW S:D DC=DC_D - S DU="DIC(31," - G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY(",1)="" X DSC(2.04) S D=$O(^(0)) S:D="" D=-1 G M1 - S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) -M1 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(1)=$P(^(0),U,1) - S X="`"_ISC - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -R1 D DE - G A - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 S Y="@31" - Q -3 S DQ=4 ;@39 -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -5 S DQ=6 ;@100 -6 S DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025 - S DE(DW)="C6^A1CKC11" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=CP - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C6 G C6S:$D(DE(6))[0 K DB - S X=DE(6),DIC=DIE - X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4) - S X=DE(6),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4) -C6S S X="" G:DG(DQ)=X C6F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4) -C6F1 Q -X6 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1 - Q - ; -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -8 S DQ=9 ;@200 -9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 - S DE(DW)="C9^A1CKC11" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=PE - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C9 G C9S:$D(DE(9))[0 K DB - S X=DE(9),DIC=DIE - X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) - S X=DE(9),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(9),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) - S X=DE(9),DIC=DIE - D AUTOUPD^DGENA2(DA) -C9S S X="" G:DG(DQ)=X C9F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) -C9F1 Q -X9 S DFN=DA D MV^DGLOCK - Q - ; -10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X10 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -11 S DQ=12 ;@300 -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 - S DE(DW)="C12^A1CKC11" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=AA - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C12 G C12S:$D(DE(12))[0 K DB - S X=DE(12),DIC=DIE - X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) - S X=DE(12),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(12),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) - S X=DE(12),DIC=DIE - D AUTOUPD^DGENA2(DA) -C12S S X="" G:DG(DQ)=X C12F1 K DB - D ^A1CKC13 -C12F1 Q -X12 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK - Q - ; -13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X13 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -14 S DQ=15 ;@400 -15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 - S DE(DW)="C15^A1CKC11" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=HB - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C15 G C15S:$D(DE(15))[0 K DB - D ^A1CKC14 -C15S S X="" G:DG(DQ)=X C15F1 K DB - D ^A1CKC15 -C15F1 Q -X15 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK - Q - ; -16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X16 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -17 S DQ=18 ;@999 -18 G 0^DIE17 diff -auBN ./r1/A1CKC12.m ./r2/r/A1CKC12.m --- ./r1/A1CKC12.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC12.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,77 +0,0 @@ -A1CKC12 ; ;07/02/04 - D DE G BEGIN -DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="A1CKC12",DQ=1+D G B -1 S DW="0;1",DV="MP31'X",DU="",DLB="RATED DISABILITIES (VA)",DIFLD=.01 - S DU="DIC(31," - S X="`"_ISC - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X1 I $D(X) D EK^DGLOCK Q - Q - ; -2 S DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFLD=2 - S X=+SCI(ISC) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^DGLOCK - Q - ; -3 S DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFLD=3 - S DU="0:NO;1:YES;" - S Y="1" - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK - Q - ; -4 G 1^DIE17 diff -auBN ./r1/A1CKC13.m ./r2/r/A1CKC13.m --- ./r1/A1CKC13.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC13.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,9 +0,0 @@ -A1CKC13 ; ;07/02/04 - S X=DG(DQ),DIC=DIE - X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) diff -auBN ./r1/A1CKC14.m ./r2/r/A1CKC14.m --- ./r1/A1CKC14.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC14.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,9 +0,0 @@ -A1CKC14 ; ;07/02/04 - S X=DE(15),DIC=DIE - X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) - S X=DE(15),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(15),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) - S X=DE(15),DIC=DIE - D AUTOUPD^DGENA2(DA) diff -auBN ./r1/A1CKC15.m ./r2/r/A1CKC15.m --- ./r1/A1CKC15.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC15.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,9 +0,0 @@ -A1CKC15 ; ;07/02/04 - S X=DG(DQ),DIC=DIE - X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) diff -auBN ./r1/A1CKC1.m ./r2/r/A1CKC1.m --- ./r1/A1CKC1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC1.m 2003-03-21 10:31:18.000000000 -0500 @@ -1,12 +1,185 @@ -A1CKC1 ; ;07/02/04 +A1CKC1 ; ;06/28/99 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(2)=% + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(4)=% S %=$P(%Z,U,13) S:%]"" DE(5)=% S %=$P(%Z,U,14) S:%]"" DE(3)=% + I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(1)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="A1CKC1",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 + S DE(DW)="C1^A1CKC1" + S DU="Y:YES;N:NO;" + S Y="Y" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(1),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + Q:$D(DE(1))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q +X1 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 + S DE(DW)="C2^A1CKC1" + S DU="Y:YES;N:NO;" + S Y="N" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE + ; + S X=DE(2),DIC=DIE + ; + S X=DE(2),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(2),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) + S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET +C2S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4) S X=DG(DQ),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" + X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) + D AUTOUPD^DGENA2(DA) S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) + Q:$D(DE(2))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q +X2 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK + Q ; +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 + S DE(DW)="C3^A1CKC1" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=$S(PE="Y":"Y",1:"N") + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE + X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) + S X=DE(3),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(3),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) + S X=DE(3),DIC=DIE + D AUTOUPD^DGENA2(DA) +C3S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DG(DQ),DIC=DIE - S ^DPT("AEL",DA,+X)="" + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) - I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q +X3 S DFN=DA D MV^DGLOCK + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 + S DE(DW)="C4^A1CKC1" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=$S(AA="Y":"Y",1:"N") + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE + X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) + S X=DE(4),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(4),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) + S X=DE(4),DIC=DIE + D AUTOUPD^DGENA2(DA) +C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + Q +X4 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 + S DE(DW)="C5^A1CKC1" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=$S(HB="Y":"Y",1:"N") + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C5 G C5S:$D(DE(5))[0 K DB S X=DE(5),DIC=DIE + X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) + S X=DE(5),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(5),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) + S X=DE(5),DIC=DIE + D AUTOUPD^DGENA2(DA) +C5S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + Q +X5 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +6 D:$D(DG)>9 F^DIE17 G ^A1CKC2 diff -auBN ./r1/A1CKC2.m ./r2/r/A1CKC2.m --- ./r1/A1CKC2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC2.m 2003-03-21 10:31:18.000000000 -0500 @@ -1,4 +1,189 @@ -A1CKC2 ; ;07/02/04 +A1CKC2 ; ;06/28/99 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(15)=% + I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(1)=% + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,14) S:%]"" DE(18)=% + I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(2)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="A1CKC2",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361 + S DE(DW)="C1^A1CKC2" + S DU="DIC(8," + S X=ELIG + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK + S X=DE(1),DIC=DIE + X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" + S X=DE(1),DIC=DIE + K ^DPT("AEL",DA,+X) + S X=DE(1),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X "S DFN=DA D EN^DGMTR K DGREQF" S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) + S X=DG(DQ),DIC=DIE + ; + S X=DG(DQ),DIC=DIE + S ^DPT("AEL",DA,+X)="" + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + Q:$D(DE(1))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q +X1 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391 + S DE(DW)="C2^A1CKC2" + S DU="DG(391," + S X=DZT2 + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) + S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET +C2S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) - I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q:$D(DE(2))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q +X2 Q +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X3 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +4 S DQ=5 ;@30 +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 I 'SCI S Y="@39" + Q +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 S ISC=0 + Q +7 S DQ=8 ;@31 +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X8 S ISC=$O(SCI(ISC)) + Q +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 I 'ISC S Y="@39" + Q +10 D:$D(DG)>9 F^DIE17,DE S DQ=10,D=0 K DE(1) ;.3721 + S DIFLD=.3721,DGO="^A1CKC3",DC="3^2.04P^.372^",DV="2.04MP31'X",DW="0;1",DOW="RATED DISABILITIES (VA)",DLB="Select "_DOW S:D DC=DC_D + S DU="DIC(31," + G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY(",1)="" X DSC(2.04) S D=$O(^(0)) S:D="" D=-1 G M10 + S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) +M10 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(10)=$P(^(0),U,1) + S X="`"_ISC + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +R10 D DE + G A + ; +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 S Y="@31" + Q +12 S DQ=13 ;@39 +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +14 S DQ=15 ;@100 +15 S DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025 + S DE(DW)="C15^A1CKC2" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=CP + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C15 G C15S:$D(DE(15))[0 K DB S X=DE(15),DIC=DIE + X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4) + S X=DE(15),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4) +C15S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4) + Q +X15 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1 + Q + ; +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X16 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +17 S DQ=18 ;@200 +18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 + S DE(DW)="C18^A1CKC2" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=PE + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C18 G C18S:$D(DE(18))[0 K DB S X=DE(18),DIC=DIE + X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) + S X=DE(18),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(18),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) + S X=DE(18),DIC=DIE + D AUTOUPD^DGENA2(DA) +C18S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + Q +X18 S DFN=DA D MV^DGLOCK + Q + ; +19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X19 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +20 S DQ=21 ;@300 +21 D:$D(DG)>9 F^DIE17 G ^A1CKC4 diff -auBN ./r1/A1CKC3.m ./r2/r/A1CKC3.m --- ./r1/A1CKC3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC3.m 2003-03-21 10:31:18.000000000 -0500 @@ -1,12 +1,71 @@ -A1CKC3 ; ;07/02/04 - S X=DE(10),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(10),DIC=DIE +A1CKC3 ; ;06/28/99 + D DE G BEGIN +DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% + K %Z Q ; - S X=DE(10),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(10),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) - S X=DE(10),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(10),DIIX=2_U_DIFLD D AUDIT^DIET +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="A1CKC3",DQ=1+D G B +1 S DW="0;1",DV="MP31'X",DU="",DLB="RATED DISABILITIES (VA)",DIFLD=.01 + S DU="DIC(31," + S X="`"_ISC + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X1 I $D(X) D EK^DGLOCK Q + Q + ; +2 S DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFLD=2 + S X=+SCI(ISC) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^DGLOCK + Q + ; +3 S DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFLD=3 + S DU="0:NO;1:YES;" + S Y="1" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK + Q + ; +4 G 1^DIE17 diff -auBN ./r1/A1CKC4.m ./r2/r/A1CKC4.m --- ./r1/A1CKC4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC4.m 2003-03-21 10:31:18.000000000 -0500 @@ -1,12 +1,108 @@ -A1CKC4 ; ;07/02/04 +A1CKC4 ; ;06/28/99 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(4)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="A1CKC4",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 + S DE(DW)="C1^A1CKC4" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=AA + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE + X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) + S X=DE(1),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(1),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) + S X=DE(1),DIC=DIE + D AUTOUPD^DGENA2(DA) +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) S X=DG(DQ),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DG(DQ),DIC=DIE - X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) + Q +X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +3 S DQ=4 ;@400 +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 + S DE(DW)="C4^A1CKC4" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=HB + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE + X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) + S X=DE(4),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(4),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) + S X=DE(4),DIC=DIE + D AUTOUPD^DGENA2(DA) +C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(10))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + D AUTOUPD^DGENA2(DA) + Q +X4 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +6 S DQ=7 ;@999 +7 G 0^DIE17 diff -auBN ./r1/A1CKC5.m ./r2/r/A1CKC5.m --- ./r1/A1CKC5.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC5.m 2003-03-21 10:31:18.000000000 -0500 @@ -1,10 +1,7 @@ -A1CKC5 ; ;07/02/04 +A1CKC5 ; ;01/20/98 D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(1)=% - I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(5)=% - I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(3)=% S %=$P(%Z,U,13) S:%]"" DE(4)=% S %=$P(%Z,U,14) S:%]"" DE(2)=% - I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(6)=% +DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -17,17 +14,17 @@ A K DQ(DQ) S DQ=DQ+1 B G @DQ RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +N I X="" G A:DV'["R",X:'DV,X:D'>0,A RD G QS:X?."?" I X["^" D D G ^DIE17 I X="@" D D G Z^DIE2 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 S X="?BAD" QS S DZ=X D D,QQ^DIEQ G B @@ -45,170 +42,30 @@ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 D ^DIR I 'DDER S %=Y(0),X=Y Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="A1CKC5",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 - S DE(DW)="C1^A1CKC5" - S DU="Y:YES;N:NO;" - S Y="N" - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - ; - S X=DE(1),DIC=DIE - ; - S X=DE(1),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(1),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) - S X=DE(1),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET -C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4) - S X=DG(DQ),DIC=DIE - X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C1F1 Q -X1 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 - S DE(DW)="C2^A1CKC5" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=$S(PE="Y":"Y",1:"N") +BEGIN S DNM="A1CKC5",DQ=1+D G B +1 S DW="0;1",DV="MP31'X",DU="",DLB="RATED DISABILITIES (VA)",DIFLD=.01 + S DU="DIC(31," + S X="`"_ISC S Y=X S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE - X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) - S X=DE(2),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(2),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) - S X=DE(2),DIC=DIE - D AUTOUPD^DGENA2(DA) -C2S S X="" G:DG(DQ)=X C2F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) -C2F1 Q -X2 S DFN=DA D MV^DGLOCK +X1 I $D(X) D EK^DGLOCK Q Q ; -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 - S DE(DW)="C3^A1CKC5" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=$S(AA="Y":"Y",1:"N") +2 S DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFLD=2 + S X=+SCI(ISC) S Y=X S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) - S X=DE(3),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(3),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) - S X=DE(3),DIC=DIE - D AUTOUPD^DGENA2(DA) -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) -C3F1 Q -X3 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK +X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^DGLOCK Q ; -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 - S DE(DW)="C4^A1CKC5" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=$S(HB="Y":"Y",1:"N") - S Y=X +3 S DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFLD=3 + S DU="0:NO;1:YES;" + S Y="1" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE - X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) - S X=DE(4),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(4),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) - S X=DE(4),DIC=DIE - D AUTOUPD^DGENA2(DA) -C4S S X="" G:DG(DQ)=X C4F1 K DB - D ^A1CKC6 -C4F1 Q -X4 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK +X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK Q ; -5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361 - S DE(DW)="C5^A1CKC5" - S DU="DIC(8," - S X=ELIG - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C5 G C5S:$D(DE(5))[0 K DB - D ^A1CKC7 -C5S S X="" G:DG(DQ)=X C5F1 K DB - D ^A1CKC8 -C5F1 Q -X5 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 - Q - ; -6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391 - S DE(DW)="C6^A1CKC5" - S DU="DG(391," - S X=DZT2 - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C6 G C6S:$D(DE(6))[0 K DB - D ^A1CKC9 -C6S S X="" G:DG(DQ)=X C6F1 K DB - D ^A1CKC10 -C6F1 Q -X6 Q -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -8 S DQ=9 ;@30 -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 I 'SCI S Y="@39" - Q -10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X10 S ISC=0 - Q -11 S DQ=12 ;@31 -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X12 S ISC=$O(SCI(ISC)) - Q -13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X13 I 'ISC S Y="@39" - Q -14 D:$D(DG)>9 F^DIE17 G ^A1CKC11 +4 G 1^DIE17 diff -auBN ./r1/A1CKC6.m ./r2/r/A1CKC6.m --- ./r1/A1CKC6.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC6.m 2003-03-21 10:31:18.000000000 -0500 @@ -1,9 +1,108 @@ -A1CKC6 ; ;07/02/04 +A1CKC6 ; ;01/20/98 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(4)=% S %=$P(%Z,U,14) S:%]"" DE(1)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="A1CKC6",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 + S DE(DW)="C1^A1CKC6" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=PE + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE + X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) + S X=DE(1),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(1),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) + S X=DE(1),DIC=DIE + D AUTOUPD^DGENA2(DA) +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DG(DQ),DIC=DIE - X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + Q +X1 S DFN=DA D MV^DGLOCK + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +3 S DQ=4 ;@300 +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 + S DE(DW)="C4^A1CKC6" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=AA + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE + X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) + S X=DE(4),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(4),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) + S X=DE(4),DIC=DIE + D AUTOUPD^DGENA2(DA) +C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) S X=DG(DQ),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) + Q +X4 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +6 S DQ=7 ;@400 +7 D:$D(DG)>9 F^DIE17 G ^A1CKC7 diff -auBN ./r1/A1CKC7.m ./r2/r/A1CKC7.m --- ./r1/A1CKC7.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC7.m 2003-03-21 10:31:18.000000000 -0500 @@ -1,12 +1,77 @@ -A1CKC7 ; ;07/02/04 - S X=DE(5),DIC=DIE +A1CKC7 ; ;01/20/98 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,13) S:%]"" DE(1)=% + K %Z Q ; - S X=DE(5),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK - S X=DE(5),DIC=DIE - X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" - S X=DE(5),DIC=DIE - K ^DPT("AEL",DA,+X) - S X=DE(5),DIC=DIE +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="A1CKC7",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 + S DE(DW)="C1^A1CKC7" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=HB + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE + X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) + S X=DE(1),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(1),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) + S X=DE(1),DIC=DIE D AUTOUPD^DGENA2(DA) - S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + Q +X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +3 S DQ=4 ;@999 +4 G 0^DIE17 diff -auBN ./r1/A1CKC8.m ./r2/r/A1CKC8.m --- ./r1/A1CKC8.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC8.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,12 +0,0 @@ -A1CKC8 ; ;07/02/04 - S X=DG(DQ),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - S ^DPT("AEL",DA,+X)="" - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff -auBN ./r1/A1CKC9.m ./r2/r/A1CKC9.m --- ./r1/A1CKC9.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC9.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,4 +0,0 @@ -A1CKC9 ; ;07/02/04 - S X=DE(6),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) - S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET diff -auBN ./r1/A1CKC.m ./r2/r/A1CKC.m --- ./r1/A1CKC.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/A1CKC.m 2003-03-21 10:31:18.000000000 -0500 @@ -1,10 +1,10 @@ -A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#1505), FILE 2;07/02/04 +A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#1505), FILE 2;06/28/99 D DE G BEGIN DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(4)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(6)=% I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(7)=% - I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(3)=%,DE(10)=% + I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(3)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -17,17 +17,17 @@ A K DQ(DQ) S DQ=DQ+1 B G @DQ RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +N I X="" G A:DV'["R",X:'DV,X:D'>0,A RD G QS:X?."?" I X["^" D D G ^DIE17 I X="@" D D G Z^DIE2 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 S X="?BAD" QS S DZ=X D D,QQ^DIEQ G B @@ -45,17 +45,9 @@ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 D ^DIR I 'DDER S %=Y(0),X=Y Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="A1CKC",DQ=1 - N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1("DIEZ") - M DIEZAR=^DIE(1505,"AR") S DICRREC="TRIG^DIE17" - S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=1505,U="^" -1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 + S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=1505,U="^" +1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X1 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) Q 2 S DQ=3 ;@10 @@ -65,8 +57,7 @@ S Y="Y" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE +C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DE(3),DIC=DIE ; @@ -74,11 +65,8 @@ D AUTOUPD^DGENA2(DA) S X=DE(3),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) - S X=DE(3),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE +C3S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DG(DQ),DIC=DIE X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) @@ -86,10 +74,8 @@ D AUTOUPD^DGENA2(DA) S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C3F1 Q + Q:$D(DE(3))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q X3 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK Q ; @@ -99,8 +85,7 @@ S Y="Y" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE +C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE ; S X=DE(4),DIC=DIE ; @@ -108,11 +93,8 @@ D AUTOUPD^DGENA2(DA) S X=DE(4),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) - S X=DE(4),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET -C4S S X="" G:DG(DQ)=X C4F1 K DB - S X=DG(DQ),DIC=DIE +C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4) S X=DG(DQ),DIC=DIE X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) @@ -120,10 +102,8 @@ D AUTOUPD^DGENA2(DA) S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C4F1 Q + Q:$D(DE(4))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q X4 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK Q ; @@ -133,20 +113,16 @@ S Y=X S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C5 G C5S:$D(DE(5))[0 K DB - S X=DE(5),DIC=DIE +C5 G C5S:$D(DE(5))[0 K DB S X=DE(5),DIC=DIE ; S X=DE(5),DIC=DIE D AUTOUPD^DGENA2(DA) S X=DE(5),DIC=DIE - ; + X "S DFN=DA D EN^DGMTR K DGREQF" S X=DE(5),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA) - S X=DE(5),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET -C5S S X="" G:DG(DQ)=X C5F1 K DB - S X=DG(DQ),DIC=DIE +C5S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE ; S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) @@ -154,10 +130,8 @@ X "S DFN=DA D EN^DGMTR K DGREQF" S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C5F1 Q + Q:$D(DE(5))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q X5 S DFN=DA D EV^DGLOCK Q:'$D(X) K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X),$D(^DPT(DA,.3)),$P(^(.3),U,1)'="Y" W !?4,*7,"Only applies to service-connected applicants." K X Q ; @@ -168,8 +142,7 @@ S Y=X S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C6 G C6S:$D(DE(6))[0 K DB - S X=DE(6),DIC=DIE +C6 G C6S:$D(DE(6))[0 K DB S X=DE(6),DIC=DIE ; S X=DE(6),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK @@ -180,9 +153,18 @@ S X=DE(6),DIC=DIE D AUTOUPD^DGENA2(DA) S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET -C6S S X="" G:DG(DQ)=X C6F1 K DB - D ^A1CKC1 -C6F1 Q +C6S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + X "S DFN=DA D EN^DGMTR K DGREQF" + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) + S X=DG(DQ),DIC=DIE + ; + S X=DG(DQ),DIC=DIE + S ^DPT("AEL",DA,+X)="" + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + Q:$D(DE(6))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q X6 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 Q ; @@ -193,30 +175,16 @@ S Y=X S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C7 G C7S:$D(DE(7))[0 K DB - S X=DE(7),DIC=DIE +C7 G C7S:$D(DE(7))[0 K DB S X=DE(7),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET -C7S S X="" G:DG(DQ)=X C7F1 K DB - D ^A1CKC2 -C7F1 Q +C7S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) + Q:$D(DE(7))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + Q X7 Q -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X8 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) Q 9 S DQ=10 ;@20 -10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 - S DE(DW)="C10^A1CKC" - S DU="Y:YES;N:NO;" - S Y="Y" - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C10 G C10S:$D(DE(10))[0 K DB - D ^A1CKC3 -C10S S X="" G:DG(DQ)=X C10F1 K DB - D ^A1CKC4 -C10F1 Q -X10 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK - Q - ; -11 D:$D(DG)>9 F^DIE17 G ^A1CKC5 +10 D:$D(DG)>9 F^DIE17 G ^A1CKC1 diff -auBN ./r1/ABSVM1.m ./r2/r/ABSVM1.m --- ./r1/ABSVM1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVM1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,48 +0,0 @@ -ABSVM1 ;OAKLANDFO/DPC - VSS MIGRATION;10/9/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33**;JUL 1994 -SEND ; - ;Entry point for the Send Data option - N ABSRECIP,ABSSDA,ABSIEN - N DIR,Y - W @IOF - D ABSIEN^ABSVMUT1 Q:'ABSIEN - W "You are about to send VTK data to the new VSS application." - W !!,"DO NOT RUN THIS OPTION UNTIL DIRECTED BY SYSTEM IMPLEMENTATION." - ;W !!,"VTK OPTIONS MUST BE OUT OF SERVICE BEFORE RUNNING THIS OPTION." - ; - S DIR(0)="Y" - S DIR("A")="Do you want to proceed" - S DIR("??")="If you answer NO, you can migrate the data later." - D ^DIR - I 'Y W !!,"Data migration can be done later. Bye." Q - ; - N DIR,OUT - S OUT=0 - W ! - F Q:OUT D - . S DIR(0)="FAO" - . S DIR("A")="Enter a Recipient Address for the Migrated Data: " - . S DIR("?")="See the Install Instructions for the recipients e-mail address." - . S DIR("?",1)="Network e-mail addresses must contain '@'." - . D ^DIR - . I $G(DIRUT) S OUT=1 Q - . S ABSRECIP(X)="" - . Q - I '$D(ABSRECIP) W !!,"Migrate the VTK data when you have obtained the proper e-mail address. Bye." Q - W ! - ; - D SENDPROC^ABSVMS1(.ABSRECIP,.ABSSDA) - W !!,"Data is being sent." - ; - W !! - S DIR(0)="Y" - S DIR("A")="Do you want to print the error lists now" - S DIR("??")="If you answer NO, you can print the errors later." - D ^DIR - I Y D PRINTRES^ABSVM(.ABSSDA,ABSIEN) - ; - W !!,"You will be notified when the data has been received and filed." - W !,"Your office may then begin to use the new system." - W !!,?20,"ENJOY THE NEW VOLUNTARY SERVICE SYSTEM" - Q - ; diff -auBN ./r1/ABSVMHV1.m ./r2/r/ABSVMHV1.m --- ./r1/ABSVMHV1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMHV1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,126 +0,0 @@ -ABSVMHV1 ;OAKLANDFO/DPC-VSS MIGRATION;7/26/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33,35**;Jul 1994 - ; -OHRSVAL(FLAG,VALRES,START,END) ; - ;Validate occasional hours data. - N OCCIEN,OCC0,OCCIDEN - N DATE,ORGPTR,SRVPTR - S VALRES("ERRCNT")=0 - S VALRES("DA")=$$CRERRLOG^ABSVMUT1("O",$G(FLAG)) - I VALRES("DA")=0 W !,"There was an error creating VALIDATION RESULTS entry for Occasional Hours." Q - S OCCIEN=$G(START,0) - F S OCCIEN=$O(^ABS(503336,OCCIEN)) Q:'OCCIEN D - . N ERRS S ERRS=0 - . S OCC0=$G(^ABS(503336,OCCIEN,0)) - . I $P(OCC0,U,3)]"" Q:$D(EXSITES($P(OCC0,U,3))) ;check for excluded sites - . S OCCIDEN="Occasional Vol Time Sheet rec #"_OCCIEN_" at "_$P(OCC0,U,3) - . I OCC0="" D ADDERR^ABSVMVV1(OCCIDEN_" does not exist.",.ERRS) Q - . ;DATE - . S DATE=$P($P(OCC0,U,8),".") - . I DATE<2961001 Q ;too early - . I $L(DATE)'=7!('+$E(DATE,4,5))!('+$E(DATE,6,7)) D ADDERR^ABSVMVV1(OCCIDEN_" has an improper Date field.",.ERRS) Q - . ;TRANSMISSION STATUS - . I $P(OCC0,U,9)=0 D ADDERR^ABSVMVV1(OCCIDEN_" has a transmission status of SUSPENDED.",.ERRS) Q - . I $P(OCC0,U,9)=2 D ADDERR^ABSVMVV1(OCCIDEN_" has a transmission status of ERROR - NOT TRANSMITTED.",.ERRS) Q - . ;FACILITY - . I $P(OCC0,U,3)="" D ADDERR^ABSVMVV1(OCCIDEN_" is missing a Facility.",.ERRS) - . I $L($P(OCC0,U,3))>7 D ADDERR^ABSVMVV1(OCCIDEN_" has a Facility Number longer than 7 characters.",.ERRS) - . ;NAME/ORG NAME - . I $L($P(OCC0,U,14))>40 D ADDERR^ABSVMVV1(OCCIDEN_" has a Name Or Organization Name longer than 40 characters.",.ERRS) - . ;SERVICE - . S SRVPTR=$P(OCC0,U,5) - . I SRVPTR="" D ADDERR^ABSVMVV1(OCCIDEN_" is missing a Service.",.ERRS) - . I SRVPTR'="",'$D(SCDS(SRVPTR)) D ADDERR^ABSVMVV1(OCCIDEN_" has an incorrect Service Code.",.ERRS) - . ;ORG - . S ORGPTR=$P(OCC0,U,4) - . I ORGPTR'="",'$D(OCDS(ORGPTR)) D ADDERR^ABSVMVV1(OCCIDEN_" has an incorrect Organization Code.",.ERRS) - . ;GROUP - . I $P(OCC0,U,6)="" D ADDERR^ABSVMVV1(OCCIDEN_" is missing the Number In Group.",.ERRS) - . I $P(OCC0,U,6)'?.N D ADDERR^ABSVMVV1(OCCIDEN_" has an invalid Number in Group.",ERRS) - . ;HOURS - . I $P(OCC0,U,7)="" D ADDERR^ABSVMVV1(OCCIDEN_" is missing Total Hours.",.ERRS) - . I $P(OCC0,U,7)'?.N D ADDERR^ABSVMVV1(OCCIDEN_" has an invalid Total Hours.",.ERRS) - . I ERRS>0 D RECERR^ABSVMUT1(.VALRES,.ERRS) Q - . I $G(FLAG)["S" S ^XTMP("ABSVMOHRS","IEN",OCCIEN)="" - . Q - D ERRCNT^ABSVMUT1(.VALRES) - Q - ; -RHRSVAL(FLAG,VALRES,START,END) ; - ;Validate regular volunteer hours data. - N REGIEN,REG0,REGIDEN - N DATE,ORGPTR,SRVPTR,VOLPTR,SCHD - S VALRES("ERRCNT")=0 - S VALRES("DA")=$$CRERRLOG^ABSVMUT1("R",$G(FLAG)) - I VALRES("DA")=0 W !,"There was an error creating VALIDATION RESULTS entry for Regular Hours." Q - S REGIEN=$G(START,0) - F S REGIEN=$O(^ABS(503331,REGIEN)) Q:'REGIEN D - . N ERRS S ERRS=0 - . S REG0=$G(^ABS(503331,REGIEN,0)) - . I $P(REG0,U,7)]"" Q:$D(EXSITES($P(REG0,U,7))) ;check for excluded sites - . S REGIDEN="Vol Daily Time rec #"_REGIEN_" at "_$P(REG0,U,7) - . I REG0="" D ADDERR^ABSVMVV1(REGIDEN_" does not exist.",.ERRS) Q - . ;DATE - . S DATE=$P($P(REG0,U,3),".") - . I DATE<2961001 Q ;too early - . I $L(DATE)'=7!('+$E(DATE,4,5))!('+$E(DATE,6,7)) D ADDERR^ABSVMVV1(REGIDEN_" has an improper Date field.",.ERRS) Q - . ;FACILITY - . I $P(REG0,U,7)="" D ADDERR^ABSVMVV1(REGIDEN_" is missing a Facility.",.ERRS) - . I $L($P(REG0,U,7))>7 D ADDERR^ABSVMVV1(REGIDEN_" has a Facility Number longer than 7 characters.",.ERRS) - . ;VOLUNTEER - . S VOLPTR=$P(REG0,U) - . I VOLPTR="" D ADDERR^ABSVMVV1(REGIDEN_" is missing a Volunteer.",.ERRS) - . I VOLPTR'="",$G(FLAG)["S",'$D(^XTMP("ABSVMVOL","IEN",VOLPTR)) Q ;D ADDERR^ABSVMVV1(REGIDEN_" has an incorrect Volunteer pointer.",.ERRS) - . I VOLPTR'="",$G(FLAG)'["S",$G(^ABS(503330,VOLPTR,0))="" D ADDERR^ABSVMVV1(REGIDEN_" has an incorrect Volunteer pointer.",.ERRS) - . ;SERVICE - . S SRVPTR=$P(REG0,U,8) - . I SRVPTR="" D ADDERR^ABSVMVV1(REGIDEN_" is missing a Service.",.ERRS) - . I SRVPTR'="",'$D(SCDS(SRVPTR)) D ADDERR^ABSVMVV1(REGIDEN_" has an incorrect Service Code.",.ERRS) - . ;ORG - . S ORGPTR=$P(REG0,U,4) - . I ORGPTR="" D ADDERR^ABSVMVV1(REGIDEN_" is missing an Organization Code.",.ERRS) - . I ORGPTR'="",'$D(OCDS(ORGPTR)) D ADDERR^ABSVMVV1(REGIDEN_" has an incorrect Organization Code.",.ERRS) - . ;SCHEDULE - . S SCHD=$E($P(REG0,U,6),4) - . I SCHD="" D ADDERR^ABSVMVV1(REGIDEN_" is missing a Work Schedule Code in its Combination Code.",.ERRS) - . I SCHD'="",'$D(WCDS("CD",SCHD)) D ADDERR^ABSVMVV1(REGIDEN_" has an incorrect Work Schedule Code.",.ERRS) - . ;HOURS - . I $P(REG0,U,5)="" D ADDERR^ABSVMVV1(REGIDEN_" is missing Total Hours.",.ERRS) - . I $P(REG0,U,5)'?.N D ADDERR^ABSVMVV1(REGIDEN_" has an invalid Total Hours.",.ERRS) - . I ERRS>0 D RECERR^ABSVMUT1(.VALRES,.ERRS) Q - . I $G(FLAG)["S" D - . . ;Putting data into FY Quarters arrays in prep for sending. - . . I DATE<2970101 S ^XTMP("ABSVMRHRS","IEN","97Q1",REGIEN)="" Q - . . I DATE<2970401 S ^XTMP("ABSVMRHRS","IEN","97Q2",REGIEN)="" Q - . . I DATE<2970701 S ^XTMP("ABSVMRHRS","IEN","97Q3",REGIEN)="" Q - . . I DATE<2971001 S ^XTMP("ABSVMRHRS","IEN","97Q4",REGIEN)="" Q - . . I DATE<2980101 S ^XTMP("ABSVMRHRS","IEN","98Q1",REGIEN)="" Q - . . I DATE<2980401 S ^XTMP("ABSVMRHRS","IEN","98Q2",REGIEN)="" Q - . . I DATE<2980701 S ^XTMP("ABSVMRHRS","IEN","98Q3",REGIEN)="" Q - . . I DATE<2981001 S ^XTMP("ABSVMRHRS","IEN","98Q4",REGIEN)="" Q - . . I DATE<2990101 S ^XTMP("ABSVMRHRS","IEN","99Q1",REGIEN)="" Q - . . I DATE<2990401 S ^XTMP("ABSVMRHRS","IEN","99Q2",REGIEN)="" Q - . . I DATE<2990701 S ^XTMP("ABSVMRHRS","IEN","99Q3",REGIEN)="" Q - . . I DATE<2991001 S ^XTMP("ABSVMRHRS","IEN","99Q4",REGIEN)="" Q - . . I DATE<3000101 S ^XTMP("ABSVMRHRS","IEN","00Q1",REGIEN)="" Q - . . I DATE<3000401 S ^XTMP("ABSVMRHRS","IEN","00Q2",REGIEN)="" Q - . . I DATE<3000701 S ^XTMP("ABSVMRHRS","IEN","00Q3",REGIEN)="" Q - . . I DATE<3001001 S ^XTMP("ABSVMRHRS","IEN","00Q4",REGIEN)="" Q - . . I DATE<3010101 S ^XTMP("ABSVMRHRS","IEN","01Q1",REGIEN)="" Q - . . I DATE<3010401 S ^XTMP("ABSVMRHRS","IEN","01Q2",REGIEN)="" Q - . . I DATE<3010701 S ^XTMP("ABSVMRHRS","IEN","01Q3",REGIEN)="" Q - . . I DATE<3011001 S ^XTMP("ABSVMRHRS","IEN","01Q4",REGIEN)="" Q - . . I DATE<3020101 S ^XTMP("ABSVMRHRS","IEN","02Q1",REGIEN)="" Q - . . I DATE<3020401 S ^XTMP("ABSVMRHRS","IEN","02Q2",REGIEN)="" Q - . . I DATE<3020701 S ^XTMP("ABSVMRHRS","IEN","02Q3",REGIEN)="" Q - . . I DATE<3021001 S ^XTMP("ABSVMRHRS","IEN","02Q4",REGIEN)="" Q - . . I DATE<3030101 S ^XTMP("ABSVMRHRS","IEN","03Q1",REGIEN)="" Q - . . I DATE<3030401 S ^XTMP("ABSVMRHRS","IEN","03Q2",REGIEN)="" Q - . . I DATE<3030701 S ^XTMP("ABSVMRHRS","IEN","03Q3",REGIEN)="" Q - . . I DATE<3031001 S ^XTMP("ABSVMRHRS","IEN","03Q4",REGIEN)="" Q - . . I DATE<3040101 S ^XTMP("ABSVMRHRS","IEN","04Q1",REGIEN)="" Q - . . Q - . Q - D ERRCNT^ABSVMUT1(.VALRES) - Q - ; diff -auBN ./r1/ABSVMLC1.m ./r2/r/ABSVMLC1.m --- ./r1/ABSVMLC1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMLC1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,310 +0,0 @@ -ABSVMLC1 ;OAKLANDFO/DPC-VSS MIGRATION;8/20/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33**;Jul 1994 - ; -SAVE ;Saves the list of orgs to Organization Code multiple in Migration Log file - ; - N ABSFDA,ABSIEN,ABSIENS,ORGCD - D ABSIEN^ABSVMUT1 Q:'ABSIEN - F I=1:1 S ORGCD=$P($T(ORGS+I),";;",2) Q:ORGCD="" D - . S ABSFDA(503339.53,"+"_I_","_ABSIEN_",",.01)=ORGCD - D UPDATE^DIE("E","ABSFDA","ABSIENS") - Q - ;Loads IENS for national codes. -LDORGS ; - N ABSIEN,ORGCD,I - D ABSIEN^ABSVMUT1 Q:'ABSIEN - K OCDS ;Array of IENs of valid org codes. - S ORGCD="" - F S ORGCD=$O(^ABS(503339.5,ABSIEN,3,"B",ORGCD)) Q:ORGCD="" D - . N ORGIEN,FOUNDIEN - . D FIND^DIC(503334,,"@","X",ORGCD,,"B",,,"FOUNDIEN") - . F I=1:1 S ORGIEN=$G(FOUNDIEN("DILIST",2,I)) Q:ORGIEN="" D - . . S OCDS(ORGIEN)="" - . . Q - . Q - Q - ; -ORGS ; - ;;100 - ;;101 - ;;102 - ;;103 - ;;104 - ;;105 - ;;106 - ;;107 - ;;108 - ;;109 - ;;110 - ;;111 - ;;112 - ;;113 - ;;114 - ;;115 - ;;116 - ;;117 - ;;118 - ;;119 - ;;120 - ;;121 - ;;122 - ;;123 - ;;124 - ;;126 - ;;127 - ;;128 - ;;129 - ;;130 - ;;131 - ;;132 - ;;133 - ;;134 - ;;135 - ;;136 - ;;137 - ;;138 - ;;139 - ;;140 - ;;141 - ;;142 - ;;143 - ;;144 - ;;145 - ;;146 - ;;147 - ;;148 - ;;149 - ;;150 - ;;151 - ;;152 - ;;153 - ;;154 - ;;155 - ;;156 - ;;157 - ;;158 - ;;159 - ;;160 - ;;161 - ;;162 - ;;163 - ;;164 - ;;165 - ;;166 - ;;167 - ;;168 - ;;169 - ;;170 - ;;171 - ;;172 - ;;173 - ;;174 - ;;175 - ;;176 - ;;177 - ;;178 - ;;179 - ;;180 - ;;181 - ;;182 - ;;183 - ;;184 - ;;185 - ;;186 - ;;187 - ;;188 - ;;189 - ;;190 - ;;191 - ;;192 - ;;193 - ;;194 - ;;195 - ;;196 - ;;197 - ;;198 - ;;199 - ;;200 - ;;201 - ;;202 - ;;203 - ;;204 - ;;205 - ;;206 - ;;207 - ;;208 - ;;209 - ;;210 - ;;211 - ;;212 - ;;213 - ;;214 - ;;215 - ;;216 - ;;217 - ;;218 - ;;220 - ;;221 - ;;222 - ;;223 - ;;224 - ;;225 - ;;226 - ;;227 - ;;228 - ;;229 - ;;230 - ;;231 - ;;232 - ;;233 - ;;234 - ;;235 - ;;236 - ;;237 - ;;238 - ;;239 - ;;240 - ;;241 - ;;242 - ;;243 - ;;244 - ;;245 - ;;246 - ;;247 - ;;248 - ;;249 - ;;250 - ;;251 - ;;252 - ;;253 - ;;254 - ;;255 - ;;256 - ;;257 - ;;258 - ;;259 - ;;260 - ;;261 - ;;262 - ;;263 - ;;264 - ;;265 - ;;266 - ;;267 - ;;268 - ;;269 - ;;270 - ;;271 - ;;272 - ;;274 - ;;275 - ;;276 - ;;277 - ;;278 - ;;279 - ;;280 - ;;281 - ;;282 - ;;283 - ;;284 - ;;286 - ;;301 - ;;303 - ;;305 - ;;307 - ;;309 - ;;311 - ;;313 - ;;315 - ;;317 - ;;318 - ;;319 - ;;320 - ;;321 - ;;322 - ;;323 - ;;324 - ;;325 - ;;400 - ;;401 - ;;001 - ;;002 - ;;003 - ;;004 - ;;005 - ;;006 - ;;007 - ;;008 - ;;009 - ;;010 - ;;011 - ;;012 - ;;013 - ;;014 - ;;015 - ;;016 - ;;017 - ;;018 - ;;019 - ;;020 - ;;021 - ;;022 - ;;023 - ;;024 - ;;025 - ;;026 - ;;027 - ;;028 - ;;029 - ;;030 - ;;031 - ;;032 - ;;033 - ;;034 - ;;035 - ;;036 - ;;037 - ;;038 - ;;039 - ;;040 - ;;041 - ;;042 - ;;043 - ;;044 - ;;045 - ;;046 - ;;057 - ;;058 - ;;059 - ;;060 - ;;061 - ;;062 - ;;063 - ;;064 - ;;065 - ;;066 - ;;067 - ;;078 - ;;079 - ;;080 - ;;081 - ;;082 - ;;083 - ;;084 - ;;085 - ;;086 - ;;087 - ;;088 - ;;089 - ;;090 - ;;091 - ;;092 - ;;093 - ;;094 - ;;095 - ;;096 - ;;097 - ;;098 - ;;099 - ;; - ;END OF ORG CODES diff -auBN ./r1/ABSVMLC2.m ./r2/r/ABSVMLC2.m --- ./r1/ABSVMLC2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMLC2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,157 +0,0 @@ -ABSVMLC2 ;OAKLAND/DPC-VSS MIGRATION;8/20/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33**;Jul 1994 - ; -SAVE ;Saves the list of codes to Service Code multiple in Migration Log file - ; - N ABSFDA,ABSIEN,ABSIENS,SRVCD - D ABSIEN^ABSVMUT1 Q:'ABSIEN - F I=1:1 S SRVCD=$P($T(SRVS+I),";;",2) Q:SRVCD="" D - . S ABSFDA(503339.54,"+"_I_","_ABSIEN_",",.01)=SRVCD - D UPDATE^DIE("E","ABSFDA","ABSIENS") - Q - ;Loads IENs for national Service codes -LDSRVS ; - N ABSIEN,SRVCD,I - D ABSIEN^ABSVMUT1 Q:'ABSIEN - K SCDS ;Array of IENs of service codes - S SRVCD="" - F S SRVCD=$O(^ABS(503339.5,ABSIEN,4,"B",SRVCD)) Q:SRVCD="" D - . N SRVIEN,FOUNDIEN - . D FIND^DIC(503332,,"@","X",SRVCD,,"B",,,"FOUNDIEN") - . F I=1:1 S SRVIEN=$G(FOUNDIEN("DILIST",2,I)) Q:SRVIEN="" D - . . S SCDS(SRVIEN)="" - . . Q - . Q - Q - ; -SRVS ; - ;;100 - ;;108 - ;;111 - ;;112 - ;;113 - ;;113 - ;;114 - ;;115 - ;;116 - ;;117 - ;;118 - ;;119 - ;;120 - ;;121 - ;;122 - ;;123 - ;;126 - ;;127 - ;;128 - ;;129 - ;;132 - ;;133 - ;;134 - ;;135 - ;;136 - ;;137 - ;;138 - ;;139 - ;;142 - ;;143 - ;;151 - ;;160 - ;;170 - ;;181 - ;;182 - ;;190 - ;;199 - ;;200 - ;;250 - ;;260 - ;;270 - ;;771 - ;;772 - ;;773 - ;;774 - ;;775 - ;;776 - ;;777 - ;;000 - ;;000T - ;;004 - ;;004T - ;;005 - ;;005T - ;;011 - ;;011C - ;;011T - ;;041 - ;;100T - ;;108E - ;;108T - ;;111T - ;;112T - ;;113T - ;;114T - ;;115T - ;;116H - ;;116T - ;;116V - ;;117A - ;;117B - ;;117D - ;;117E - ;;117F - ;;117T - ;;118E - ;;118H - ;;118T - ;;119T - ;;120T - ;;121T - ;;122S - ;;122T - ;;123T - ;;126T - ;;127T - ;;128T - ;;129T - ;;132T - ;;133T - ;;134B - ;;134C - ;;134D - ;;134E - ;;134T - ;;135A - ;;135B - ;;135E - ;;135M - ;;135R - ;;135T - ;;135V - ;;136A - ;;136B - ;;136C - ;;136D - ;;136F - ;;136T - ;;136Z - ;;137T - ;;138T - ;;139T - ;;142T - ;;143T - ;;151T - ;;160T - ;;170A - ;;170T - ;;190T - ;;250A - ;;250D - ;;250H - ;;270A - ;;270B - ;;270C - ;;270D - ;;270E - ;;500T - ;; - ;End of Service Codes diff -auBN ./r1/ABSVMLC3.m ./r2/r/ABSVMLC3.m --- ./r1/ABSVMLC3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMLC3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,115 +0,0 @@ -ABSVMLC3 ;OAKLAND/DPC-VSS MIGRATION;8/20/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;*31*;Jul 1994 - ; - ;Loads codes for Scheduled Workdays. -LDWKS ; - N WKCD,I,J - K WCDS - ;Array of valid work codes. - ;At WCDS(ien), IEN in file #503333 - ;At WCDS("CD",code), actual code. - F I=1:1 S WKCD=$P($T(WKS+I),";;",2) Q:WKCD="" D - . N WKIEN,FOUNDIEN - . D FIND^DIC(503333,,"@","X",WKCD,,"B",,,"FOUNDIEN") - . F J=1:1 S WKIEN=$G(FOUNDIEN("DILIST",2,J)) Q:WKIEN="" D - . . S WCDS(WKIEN)="" - . . Q - . S WCDS("CD",WKCD)="" - . Q - Q - ; -WKS ; - ;;0 - ;;1 - ;;2 - ;;3 - ;;4 - ;;5 - ;;6 - ;;7 - ;;8 - ;;9 - ;;# - ;;% - ;;& - ;;& - ;;* - ;;+ - ;;/ - ;;A - ;;B - ;;C - ;;D - ;;E - ;;F - ;;G - ;;H - ;;I - ;;J - ;;K - ;;L - ;;M - ;;N - ;;O - ;;P - ;;Q - ;;R - ;;S - ;;T - ;;U - ;;V - ;;W - ;;X - ;;Y - ;;Z - ;; - ; End of work schedule codes -LDAWDS ; - N AWDCD,I,J - K ACDS ;Array of IENs of valid award codes. - F I=1:1 S AWDCD=$P($T(AWDS+I),";;",2) Q:AWDCD="" D - . N AWDIEN,FOUNDIEN - . D FIND^DIC(503337,,"@","X",AWDCD,,"C",,,"FOUNDIEN") - . F J=1:1 S AWDIEN=$G(FOUNDIEN("DILIST",2,J)) Q:AWDIEN="" D - . . S ACDS(AWDIEN)="" - . . Q - . Q - Q - ; -AWDS ; - ;;00 - ;;16 - ;;14 - ;;24 - ;;02 - ;;04 - ;;06 - ;;07 - ;;08 - ;;12 - ;;18 - ;;20 - ;;22 - ;;15 - ;;17 - ;;21 - ;;25 - ;;19 - ;;23 - ;;50 - ;;03 - ;;05 - ;;26 - ;;27 - ;;28 - ;;29 - ;;30 - ;;31 - ;;32 - ;;33 - ;;34 - ;;35 - ;;36 - ;; - ;End of award codes - Q diff -auBN ./r1/ABSVM.m ./r2/r/ABSVM.m --- ./r1/ABSVM.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVM.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,266 +0,0 @@ -ABSVM ;OAKLANDFO/DPC - VSS MIGRATION;8/23/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33**;Jul 1994 - ; - ; -PREP ; - ;Entry point for the Prepare For Transition option. - ;Accomplishes the initial setup. - N ABSSITE,SITENUM,DIR,I,DIERR,ABSFDA,ABSIEN - N ABSSITES ;This array is created in BLDVOLLT^ABSVMUT1. - W @IOF - ;Check for existing entries. - D LIST^DIC(503339.5) - I ^TMP("DILIST",$J,0) D Q - . W !!,"This option has already been run. The Migration Process is started." - . W !,"Continue the Migration process with another option." - . W !,"Contact the System Implementation team if you need additional instructions." - . Q - ; - W "You are starting the process that will move " - W !,"Voluntary Timekeeping data to the new " - W !,"Voluntary Service System application." - W !!,"First, information about your site will be collected." - ;this get the Station Number from Institution file - S ABSSITE=$P($G(^DIC(4,+$$KSP^XUPARAM("INST"),99)),U) - I ABSSITE="" W !!,"There is no Station Number for your site, Contact System Implementation team!!!" Q - W !,"Your Volunteer Daily Time file will be scanned to find " - W !,"all sites referenced. This will take some time.",! - D BLDVOLLT^ABSVMUT1("S") - W !,"Done." - W !!,"Your primary site number is "_ABSSITE_"." - W !,"Volunteer Hours are recorded for the following sites:" - S SITENUM=0 - F I=0:1 S SITENUM=$O(ABSSITES(SITENUM)) Q:SITENUM="" W !,?20,SITENUM - W !!,"The next section will allow you to designate which of the above sites",!,"you want data sent from. Your primary site will default to 'YES' ",! - I I W "Any Games site,(700, 701, 702, or 575W), will default to 'NO'.",! - S DIR(0)="Y" - S DIR("A")="Do you want to continue" - S DIR("??")="If the information is not correct, answer NO. The preparation process will be stopped for now." - D ^DIR - W !! - I 'Y W "CONTACT THE IMPLEMENTATION TEAM. PROCESS STOPPED FOR NOW." Q - W "Making an entry in the Voluntary Migration Log file." - S ABSFDA(503339.5,"+1,",.01)=ABSSITE,SITENUM=0 - F I=2:1 S SITENUM=$O(ABSSITES(SITENUM)) Q:SITENUM="" D - . S ABSFDA(503339.51,"+"_I_",+1,",.01)=SITENUM - . ;setup games site for no sending of data - . S:"^700^701^702^575W^"[(U_SITENUM_U) ABSFDA(503339.51,"+"_I_",+1,",.02)="N" - D UPDATE^DIE("E","ABSFDA","ABSIEN") - I $D(DIERR) W ! D MSG^DIALOG() Q - D SITEINFO(ABSIEN(1)) - W ! - D SENDMSG(ABSIEN(1)) - Q - ; -SITEINFO(ABSIEN) ; - ;User Inputs data for sites - N ABSROOT,I,DIE,DA,DR,DIERR,SITENUM - D LIST^DIC(503339.51,","_ABSIEN_",",1,,,,,,,,"ABSROOT") - I $D(DIERR) W ! D MSG^DIALOG() Q - F I=1:1:+ABSROOT("DILIST",0) D - . S DIE="^ABS(503339.5,"_ABSIEN_",1,",SITENUM=ABSROOT("DILIST",1,I) - . S DA=ABSROOT("DILIST",2,I),DA(1)=ABSIEN - . D - .. ;check for primary or games site - .. I SITENUM=ABSSITE S DR="W ""Send this Station's Data?: YES"";.02///YES;1:11" Q - .. I "^700^701^702^575W^"[(U_SITENUM_U) S DR="W ""Send this Station's Data?: NO"";.02///NO" Q - .. S DR=".02//YES;S:X=""N"" Y=0;1:11" - .. Q - . S DIE("NO^")="BACK" - . W !!,?20,"Add information for Station Number "_SITENUM,! - . D ^DIE - . Q - ;save codes - W !!,"Saving information...",! - D SAVE^ABSVMLC1,SAVE^ABSVMLC2 - Q - ; -SENDMSG(NEWIEN) ; - N ABSMSG,OUT,ABSRECIP,DIR,DIRUT,X,Y - N MSGNUM,ABSSUBJ,ABSMSG,ABSRECIP - S OUT=0 - W !,"Sending a message containing information about your site." - F Q:OUT D - . S DIR(0)="FAO" - . S DIR("A")="Enter a Recipient of the Institution Creation message: " - . S DIR("?")="See the Install Instructions for the recipients e-mail address." - . S DIR("?",1)="Network e-mail addresses must contain '@'." - . D ^DIR - . I $G(DIRUT) D - . . I $D(ABSRECIP) S OUT=1 Q ;At least 1 recipient selected. - . . N DIR,X,Y,DIRUT,DIK,DA - . . W !!,"You must enter at least one recipient of the message." - . . W !,"If you do not, you will need to run the Preparation option again" - . . W !,"and re-enter all information.",! - . . S DIR(0)="Y" - . . S DIR("A")="Do you want to exit the Preparation option and run it again later" - . . S DIR("B")="No" - . . D ^DIR - . . I Y D - . . . W !!,"Rerun Preparation later. BYE." - . . . ;Delete entry in Migration Log. - . . . S DIK="^ABS(503339.5,",DA=NEWIEN - . . . D ^DIK - . . . S OUT=1 - . . . Q - . . Q - . E S ABSRECIP(X)="" - . Q - I '$D(ABSRECIP) Q ;No recipients selected. - S ABSSUBJ="VSS: Institution Creation Message from: "_$P($G(^DIC(4,+$$KSP^XUPARAM("INST"),99)),U) - D BLDMSG(.ABSMSG,NEWIEN) - D SENDMSG^XMXAPI(DUZ,ABSSUBJ,"ABSMSG",.ABSRECIP,,.MSGNUM) - W !,"Message sent. Message number: "_MSGNUM - Q - ; -BLDMSG(MSGBODY,NEWIEN) ; - N I,LNCNT,TEXT - S LNCNT=0 - S TEXT="This is a VSS migration message." - D ADDLN(TEXT,.MSGBODY,.LNCNT) - S TEXT="It contains information needed to create an entry in the VtkInstitutions table." - D ADDLN(TEXT,.MSGBODY,.LNCNT,1) - S TEXT="The message is sent from Station Number: "_$P($G(^DIC(4,+$$KSP^XUPARAM("INST"),99)),U)_"." - D ADDLN(TEXT,.MSGBODY,.LNCNT,1) - S TEXT="The sender is "_$$GET1^DIQ(200,DUZ_",",.01)_" (DUZ= "_DUZ_")." - D ADDLN(TEXT,.MSGBODY,.LNCNT) - ;GET the list of station numbers. - N FLDNUM,ABSIEN,VALUE,FIELD - D LIST^DIC(503339.51,","_NEWIEN_",",1,,,"X",,"SN",,,"ABSROOT") - I $D(DIERR) W ! D MSG^DIALOG() Q - ;Assemble the message for each site. - F I=1:1:+ABSROOT("DILIST",0) D - . S TEXT=" INFORMATION FOR STATION NUMBER: "_ABSROOT("DILIST","ID",I,.01) - . D ADDLN(TEXT,.MSGBODY,.LNCNT,1) - . S ABSIEN=ABSROOT("DILIST",2,I)_","_NEWIEN_"," - . ;Fieldnames and values are obtained for Voluntary Migration Log. - . ;Note changes to the DD will require changes to this code. - . F FLDNUM=1:1:11 D - . . S FIELD=$$GET1^DID(503339.51,FLDNUM,,"LABEL") - . . S VALUE=$$GET1^DIQ(503339.51,ABSIEN,FLDNUM) - . . S TEXT=FIELD_": "_VALUE - . . D ADDLN(TEXT,.MSGBODY,.LNCNT,1) - . . Q - . Q - Q - ; -ADDLN(LINE,BODY,COUNT,SKIP) ; - I $G(SKIP) S COUNT=COUNT+1,BODY(COUNT)=" " - S COUNT=COUNT+1 - S BODY(COUNT)=LINE - Q - ; -VAL ; - ;Entry point for Validate Existing Data Option - ;Checks all data that will be migrated and creates log entries - ;containing entries with problems. - ;Optionally, you can print results. - N DIR,Y,ABSRES,ABSRESDA,ABSIEN,EXSITES - W @IOF - ;Check to assure entry exists in Migration Log file. - D ABSIEN^ABSVMUT1 Q:'ABSIEN - W "Data that will be moved to the new Voluntary Service System database" - W !," will now be checked for consistency." - W !!,"The result will be recorded in the Voluntary Migration Log File." - W !,"You will have the opportunity to print these results." - W !! - ; - S DIR(0)="Y" - S DIR("A")="Do you want to proceed" - S DIR("??")="If you answer NO, you can check the data at a later time." - D ^DIR - I 'Y W !!,"Data checking can be done at a later time. Bye." Q - ; - W !!,"Creating list of all Volunteers with hours after Sept. 30, 1996." - D EXSITES^ABSVMUT1 - D BLDVOLLT^ABSVMUT1() - W !,"Done." - ; - W !!,"Creating lists of valid Organization, Service, Schedule, and Award Codes." - D LDCDS^ABSVMUT1 - W !,"Done." - ; - W !!,"Validating entries in the Volunteer Organization Codes File." - D ORGVAL^ABSVMRV1(,.ABSRES) - W !,"Errors Found in Organization Codes: "_ABSRES("ERRCNT") - S ABSRESDA(ABSRES("DA"))="" - ; - W !!,"Validating entries in the Service Assignment Codes File." - D SRVVAL^ABSVMRV1(,.ABSRES) - W !,"Errors found in Service Assignment Codes: "_ABSRES("ERRCNT") - S ABSRESDA(ABSRES("DA"))="" - ; - W !!,"Validating Occasional Hours." - D OHRSVAL^ABSVMHV1(,.ABSRES) - W !,"Errors found in Occasional Hours: "_ABSRES("ERRCNT") - S ABSRESDA(ABSRES("DA"))="" - ; - W !!,"Validating Regular Hours." - W !,"THIS WILL TAKE SOME TIME." - D RHRSVAL^ABSVMHV1(,.ABSRES) - W !,"Errors found in Regular Hours: "_ABSRES("ERRCNT") - S ABSRESDA(ABSRES("DA"))="" - ; - W !!,"Validating Volunteer data." - W !,"THIS WILL TAKE SOME TIME." - D VALVOL^ABSVMVV1(,.ABSRES) - W !,"Errors found in Volunteer data: "_ABSRES("ERRCNT") - S ABSRESDA(ABSRES("DA"))="" - ; - W !!,"The data checking on your system is complete!" - D CLEANCDS^ABSVMUT1 ;Kills arrays of National Codes - ; - W !! - S DIR(0)="Y" - S DIR("A")="Do you want to print the results now" - S DIR("??")="If you answer NO, you can print the results later." - D ^DIR - I Y D PRINTRES(.ABSRESDA,ABSIEN) - Q - ; -PRINT ; - ;Prints entries from the VALIDATION RESULTS multiple of Voluntary Migration Log file. - N DIC,Y,DA - N ABSI,ABSVDA,DIR,ABSIEN - N OUT S OUT=0 - W @IOF - ;Check to assure entry exists in Migration Log file. - D ABSIEN^ABSVMUT1 Q:'ABSIEN - W "You can print results of the Examination of Existing Data " - W !,"by selecting the date/time that the examination was done." - W ! - F ABSI=1:1 D Q:OUT - . S DIC="^ABS(503339.5,"_ABSIEN_",2," - . S DIC(0)="AE" - . D ^DIC - . I Y=-1 S OUT=1 Q - . S ABSVDA(+Y)="" - . W ! - . S DIR(0)="Y" - . S DIR("A")="Do you want to select another result to print" - . D ^DIR - . I 'Y S OUT=1 Q - . W ! - . Q - I $D(ABSVDA) D PRINTRES(.ABSVDA,ABSIEN) - Q - ; -PRINTRES(ABSVMDA,ABSMIEN) ; - ;Prints preselected subentries in the VALIDATION RESULTS multiple - ;passed in by the input parameter (passed by reference). - N ABSI,POP,DA,DIC - D ^%ZIS - Q:$G(POP) - U IO - S ABSI=0 - F S ABSI=$O(ABSVMDA(ABSI)) Q:ABSI="" D - . W @IOF - . W "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" - . S DIC="^ABS(503339.5,"_ABSMIEN_",2," - . S DA(1)=1 - . S DA=ABSI - . D EN^DIQ - . Q - D ^%ZISC - Q - ; diff -auBN ./r1/ABSVMRV1.m ./r2/r/ABSVMRV1.m --- ./r1/ABSVMRV1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMRV1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,79 +0,0 @@ -ABSVMRV1 ;OAKLANDFO/DPC-VSS MIGRATION;7/23/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;*31*;Jul 1994 - ; - ;Reference file validation -ORGVAL(FLAG,VALRES) ; - N ORGIEN,ORG0,ORGIDEN - N CODE - K ^TMP("ABSVM",$J,"ORGCODES") - S VALRES("ERRCNT")=0 - S VALRES("DA")=$$CRERRLOG^ABSVMUT1("G",$G(FLAG)) - I VALRES("DA")=0 W !,"There was an error creating VALIDATION RESULTS entry for Organizations." Q - S ORGIEN=899 - F S ORGIEN=$O(^ABS(503334,ORGIEN)) Q:ORGIEN="" D - . N ERRS - . S ERRS=0 - . S ORG0=$G(^ABS(503334,ORGIEN,0)) - . S ORGIDEN="Volunteer Organizations Codes record #"_ORGIEN - . I ORG0="" D ADDERR^ABSVMVV1(ORGIDEN_" does not exist.",.ERRS) Q - . ;CODE - . D - . . S CODE=$P(ORG0,U) - . . I CODE="" D ADDERR^ABSVMVV1(ORGIDEN_" is missing a Code.",.ERRS) Q - . . I CODE'?3N D ADDERR^ABSVMVV1(ORGIDEN_" has an incorrect Code.",.ERRS) Q - . . I $D(^TMP("ABSVM",$J,"ORGCODES",CODE)) D ADDERR^ABSVMVV1(ORGIDEN_" has a duplicate Code of "_CODE_" with record #"_$G(^TMP("ABSVM",$J,"ORGOCDES",CODE))_".",.ERRS) Q - . . S ^TMP("ABSVM",$J,"ORGCODES",CODE)=ORGIEN ;array of local org codes. - . . S OCDS(ORGIEN)="" ;array of acceptable Org Code entries. - . ;ORG NAME - . I $P(ORG0,U,2)="" D ADDERR^ABSVMVV1(ORGIDEN_" is missing an organization name.",.ERRS) - . I $L($P(ORG0,U,2))>35 D ADDERR^ABSVMVV1(ORGIDEN_" has an Organization Name that is longer than 35 characters.",.ERRS) - . ;ABBREV. - . I $L($P(ORG0,U,3))>6!($L($P(ORG0,U,4))>6) D ADDERR^ABSVMVV1(ORGIDEN_" has an Abbreviation longer than 6 characters.",.ERRS) - . ;INACTIVE - . I ",0,1,,"'[(","_$P(ORG0,U,5)_",") D ADDERR^ABSVMVV1(ORGIDEN_" has an invalid Inactive Code.",.ERRS) - . I ERRS>0 D RECERR^ABSVMUT1(.VALRES,.ERRS) Q - . S OCDS(ORGIEN)="" ;Array of good org IENS for validating hours. - . I $G(FLAG)["S" S ^XTMP("ABSVMORG","IEN",ORGIEN)="" - . Q - D ERRCNT^ABSVMUT1(.VALRES) - K ^TMP("ABSVM",$J,"ORGCODE") - Q - ; -SRVVAL(FLAG,VALRES) ; - N SRVIEN,SRV0,SRVIDEN - N CODE,SRVNAME - K ^TMP("ABSVM",$J,"SRVCODES") - S VALRES("ERRCNT")=0 - S VALRES("DA")=$$CRERRLOG^ABSVMUT1("S",$G(FLAG)) - I VALRES("DA")=0 W !,"There was an error creating VALIDATION RESULTS entry for Services." Q - S SRVIEN=0 - F S SRVIEN=$O(^ABS(503332,SRVIEN)) Q:SRVIEN="" D - . N ERRS,LOWCODE - . S ERRS=0 - . S SRV0=$G(^ABS(503332,SRVIEN,0)) - . S SRVIDEN="Voluntary Service Assignment Codes record #"_SRVIEN - . I SRV0="" D ADDERR^ABSVMVV1(SRVIDEN_" does not exist.",.ERRS) Q - . ;CODE - . D Q:LOWCODE - . . S LOWCODE=0 - . . S CODE=$P(SRV0,U) - . . I CODE="" D ADDERR^ABSVMVV1(SRVIDEN_" is missing a Code.",.ERRS) Q - . . I CODE'?3N.1A D ADDERR^ABSVMVV1(SRVIDEN_" has an incorrect Code.",.ERRS) Q - . . I CODE<800 S LOWCODE=1 Q - . . I $D(^TMP("ABSVM",$J,"SRVCODES",CODE)) D ADDERR^ABSVMVV1(SRVIDEN_" has a duplicate Code of "_CODE_" with record #"_^TMP("ABSVM",$J,"SRVCODES",CODE)_".",.ERRS) Q - . . S ^TMP("ABSVM",$J,"SRVCODES",CODE)=SRVIEN ;Array of local service codes. - . . S SCDS(SRVIEN)="" ;Array of usable service code IENs - . ;SERVICE NAME - . S SRVNAME=$P(SRV0,U,2) - . I SRVNAME="" D ADDERR^ABSVMVV1(SRVIDEN_" is missing service name.",.ERRS) - . I $L($P(SRVNAME,"-"))>35 D ADDERR^ABSVMVV1(SRVIDEN_" has Service Name that is longer than 35 characters.",.ERRS) - . I $L($P(SRVNAME,"-",2))>30 D ADDERR^ABSVMVV1(SRVIDEN_" has a Service Subdivision longer than 30 characters.",.ERRS) - . ;ABBREV. - . I $L($P(SRV0,U,3))>7 D ADDERR^ABSVMVV1(SRVIDEN_" has an Abbreviation longer than 6 characters.",.ERRS) - . I ERRS>0 D RECERR^ABSVMUT1(.VALRES,.ERRS) Q - . S SCDS(SRVIEN)="" ;Array of good service IENS used in hours' validation. - . I $G(FLAG)="S" S ^XTMP("ABSVMSERV","IEN",SRVIEN)="" - . Q - D ERRCNT^ABSVMUT1(.VALRES) - K ^TMP("ABSVM",$J,"SRVCODE") - Q diff -auBN ./r1/ABSVMS1.m ./r2/r/ABSVMS1.m --- ./r1/ABSVMS1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMS1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,275 +0,0 @@ -ABSVMS1 ;OAKLAND/DPC-VSS MIGRATION;7/31/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33**;Jul 1994 - ; -SENDPROC(ABSVMTO,ABSSDA) ; - ;Driver for sending data to SQL database. - D CLEANXTP^ABSVMUT1 - D SETUPXTP^ABSVMUT1 - D LDCDS^ABSVMUT1 - D SERVSP(.ABSVMTO,.ABSSDA) - D ORGSP(.ABSVMTO,.ABSSDA) - D VOLSP(.ABSVMTO,.ABSSDA) - D OHRSSP(.ABSVMTO,.ABSSDA) - D RHRSSP(.ABSVMTO,.ABSSDA) - D CLEANXTP^ABSVMUT1 - Q - ; -SERVSP(ABSVMWHO,ABSSDA) ; - ;Process for sending Services. Includes Validation. - N FL,EXPORT,TOSEND,TXTFILE - N ABSSRES - ; - W !,"Validating Services" - D SRVVAL^ABSVMRV1("S",.ABSSRES) - W !,"Errors found in Service Codes: "_ABSSRES("ERRCNT") - S ABSSDA(ABSSRES("DA"))="" - ; - S FL=503332 - S EXPORT="ABSVM SERVICE CODES EXPORT" - S TOSEND="ABSVM SERVICES TOSEND" - S TXTFILE="VtkServices" - W !,"Sending Services.." - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - W ! - Q - ; -ORGSP(ABSVMWHO,ABSSDA) ; - ;Send Process for Organizations. - N FL,EXPORT,TOSEND,TXTFILE - N ABSSRES - W !,"Validating Organizations" - D ORGVAL^ABSVMRV1("S",.ABSSRES) - W !,"Errors found in Organization Codes: "_ABSSRES("ERRCNT") - S ABSSDA(ABSSRES("DA"))="" - ; - W !,"Sending Organizations.." - S FL=503334 - S EXPORT="ABSVM ORGANIZATION EXPORT" - S TOSEND="ABSVM ORGANIZATIONS TOSEND" - S TXTFILE="VtkOrganizations" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - W ! - Q - ; -VOLSP(ABSVMWHO,ABSSDA) ; - ;Send Process for Volunteers - N FL,EXPORT,TOSEND,TXTFILE - N ABSSRES,EXSITES - D EXSITES^ABSVMUT1 - W !,"Building List of Volunteers with Hours" - D BLDVOLLT^ABSVMUT1() - W !,"Validating Volunteers" - D VALVOL^ABSVMVV1("S",.ABSSRES) - W !,"Errors found in Volunteer data: "_ABSSRES("ERRCNT") - S ABSSDA(ABSSRES("DA"))="" - ; - S FL=503330 - ; Volunteer Master - S EXPORT="ABSVM VOL MASTER EXPORT" - S TOSEND="ABSVM VOLUNTEER TOSEND" - S TXTFILE="VtkVolunteers" - W !,"Sending Volunteer Master Information.." - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;CONTACTS - S EXPORT="ABSVM VOL CONTACT EXPORT" - S TOSEND="ABSVM VOLUNTEER TOSEND" - S TXTFILE="VtkVolContacts" - W !,"Sending Volunteer Contact Information.." - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;COMBINATION CODES - N COMBDIS - S EXPORT="ABSVM VOL COMBINATIONS EXPORT" - S TOSEND="" - S COMBDIS(0)="I $D(^XTMP(""ABSVMVOLCB"",""IEN"",D0))" - S TXTFILE="VtkVolCombinations" - W !,"Sending Combination code Information.." - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,,.COMBDIS) - ;PROFILES - N PROFDIS - S EXPORT="ABSVM PROFILES EXPORT" - S TOSEND="" - S TXTFILE="VtkVolProfiles" - S PROFDIS(0)="I $D(^XTMP(""ABSVMVOLP"",""IEN"",D0))" - W !,"Sending Volunteer Profile Information.." - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,,.PROFDIS) - ;PARKING STICKERS - N PARKDIS - S EXPORT="ABSVM PARKING EXPORT" - S TOSEND="" - S TXTFILE="VtkVolParking" - S PARKDIS(0)="I $D(^XTMP(""ABSVMVOLPK"",""IEN"",D0))" - W !,"Sending Parking Sticker Information.." - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,,.PARKDIS) - W ! - Q - ; -OHRSSP(ABSVMWHO,ABSSDA) ; - ;Occasional Hours Processing. - N FL,EXPORT,TOSEND,TXTFILE - N ABSSRES,EXSITES - D EXSITES^ABSVMUT1 - W !,"Validating Occasional Hours" - D OHRSVAL^ABSVMHV1("S",.ABSSRES) - W !,"Errors found in Occasional Hours: "_ABSSRES("ERRCNT") - S ABSSDA(ABSSRES("DA"))="" - ; - S FL=503336 - S EXPORT="ABSVM OCCASIONAL EXPORT" - S TOSEND="ABSVM OCCASIONAL HOURS TOSEND" - S TXTFILE="VtkOccHours" - W !,"Sending Occasional Hours.." - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - W ! - Q - ; -RHRSSP(ABSVMWHO,ABSSDA) ; - ;Regular hours processing. - N FL,EXPORT,TOSEND,TXTFILE - N ABSSRES,EXSITES - D EXSITES^ABSVMUT1 - W !,"Validating Regular Hours" - D RHRSVAL^ABSVMHV1("S",.ABSSRES) - W !,"Errors found in Regular Hours: "_ABSSRES("ERRCNT") - S ABSSDA(ABSSRES("DA"))="" - ; - S FL=503331 - S EXPORT="ABSVM REGULAR HOURS EXPORT" - W !,"Sending Regular Hours.." - ;97 - S TOSEND="ABSVM REG HOURS 97Q1 TOSEND" - S TXTFILE="VtkRegHours97Q1" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;97Q2 - S TOSEND="ABSVM REG HOURS 97Q2 TOSEND" - S TXTFILE="VtkRegHours97Q2" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;97Q3 - S TOSEND="ABSVM REG HOURS 97Q3 TOSEND" - S TXTFILE="VtkRegHours97Q3" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;97Q4 - S TOSEND="ABSVM REG HOURS 97Q4 TOSEND" - S TXTFILE="VtkRegHours97Q4" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;98 - S TOSEND="ABSVM REG HOURS 98Q1 TOSEND" - S TXTFILE="VtkRegHours98Q1" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;98Q2 - S TOSEND="ABSVM REG HOURS 98Q2 TOSEND" - S TXTFILE="VtkRegHours98Q2" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;98Q3 - S TOSEND="ABSVM REG HOURS 98Q3 TOSEND" - S TXTFILE="VtkRegHours98Q3" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;98Q4 - S TOSEND="ABSVM REG HOURS 98Q4 TOSEND" - S TXTFILE="VtkRegHours98Q4" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;99 - S TOSEND="ABSVM REG HOURS 99Q1 TOSEND" - S TXTFILE="VtkRegHours99Q1" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;99Q2 - S TOSEND="ABSVM REG HOURS 99Q2 TOSEND" - S TXTFILE="VtkRegHours99Q2" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;99Q3 - S TOSEND="ABSVM REG HOURS 99Q3 TOSEND" - S TXTFILE="VtkRegHours99Q3" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;99Q4 - S TOSEND="ABSVM REG HOURS 99Q4 TOSEND" - S TXTFILE="VtkRegHours99Q4" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;00 - S TOSEND="ABSVM REG HOURS 00Q1 TOSEND" - S TXTFILE="VtkRegHours00Q1" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;00Q2 - S TOSEND="ABSVM REG HOURS 00Q2 TOSEND" - S TXTFILE="VtkRegHours00Q2" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;00Q3 - S TOSEND="ABSVM REG HOURS 00Q3 TOSEND" - S TXTFILE="VtkRegHours00Q3" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;00Q4 - S TOSEND="ABSVM REG HOURS 00Q4 TOSEND" - S TXTFILE="VtkRegHours00Q4" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;01 - S TOSEND="ABSVM REG HOURS 01Q1 TOSEND" - S TXTFILE="VtkRegHours01Q1" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;01Q2 - S TOSEND="ABSVM REG HOURS 01Q2 TOSEND" - S TXTFILE="VtkRegHours01Q2" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;01Q3 - S TOSEND="ABSVM REG HOURS 01Q3 TOSEND" - S TXTFILE="VtkRegHours01Q3" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;01Q4 - S TOSEND="ABSVM REG HOURS 01Q4 TOSEND" - S TXTFILE="VtkRegHours01Q4" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;02 - S TOSEND="ABSVM REG HOURS 02Q1 TOSEND" - S TXTFILE="VtkRegHours02Q1" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;02Q2 - S TOSEND="ABSVM REG HOURS 02Q2 TOSEND" - S TXTFILE="VtkRegHours02Q2" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;02Q3 - S TOSEND="ABSVM REG HOURS 02Q3 TOSEND" - S TXTFILE="VtkRegHours02Q3" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;02Q4 - S TOSEND="ABSVM REG HOURS 02Q4 TOSEND" - S TXTFILE="VtkRegHours02Q4" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;03 - S TOSEND="ABSVM REG HOURS 03Q1 TOSEND" - S TXTFILE="VtkRegHours03Q1" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;03Q2 - S TOSEND="ABSVM REG HOURS 03Q2 TOSEND" - S TXTFILE="VtkRegHours03Q2" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;03Q3 - S TOSEND="ABSVM REG HOURS 03Q3 TOSEND" - S TXTFILE="VtkRegHours03Q3" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;03Q4 - S TOSEND="ABSVM REG HOURS 03Q4 TOSEND" - S TXTFILE="VtkRegHours03Q4" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - ;04 - S TOSEND="ABSVM REG HOURS 04Q1 TOSEND" - S TXTFILE="VtkRegHours04Q1" - D SEND(TXTFILE,.ABSVMWHO,FL,EXPORT,TOSEND) - Q - ; -SEND(TEXTFILE,ABSVMWHO,FILE,XPTEMP,SORTTEMP,SCREEN) ; - ;Sending data. - N ABSVHFS,ABSVDEL,XMDUZ,XMY,XMSUB,XMTEXT,XMZ,%ZIS,IOP,Y - ;set MailMan variables - M XMY=ABSVMWHO - S XMDUZ=DUZ,XMSUB="$Station$ "_$P($G(^DIC(4,+$$KSP^XUPARAM("INST"),99)),U)_" :"_TEXTFILE_" -- "_$$FMTE^XLFDT($$NOW^XLFDT) - ;set device handler variables - S ABSVHFS="ABSVMIGRATION.DAT",IOP="HFS",%ZIS="",%ZIS("HFSMODE")="W",%ZIS("HFSNAME")=ABSVHFS - D EXPORT^DDXP(FILE,XPTEMP,0,$G(SORTTEMP),,,.SCREEN,,IOP) - ;create message and get message number - F D XMZ^XMA2 Q:XMZ>0 H 1 - ;import from HFS to message global - S Y=$$FTG^%ZISH("",ABSVHFS,$NA(^XMB(3.9,XMZ,2,1,0)),4) - ;send message - S XMDUZ=DUZ - D ENT1^XMD - ;delete HFS file - S ABSVDEL(ABSVHFS)="",Y=$$DEL^%ZISH("",$NA(ABSVDEL)) - W !," Message #",XMZ - Q diff -auBN ./r1/ABSVMUT1.m ./r2/r/ABSVMUT1.m --- ./r1/ABSVMUT1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMUT1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,133 +0,0 @@ -ABSVMUT1 ;OAKLANDFO/DPC-VSS MIGRATIOIN;8/3/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33**;Jul 1994 - ; -BLDVOLLT(FLAG) ; - ; - ;FLAG="S" -- Only need site data into ABSSITES() - N REGIEN,VOLPTR,SITE,REG0,SRTDATE,ENTRY,TERM - K ^TMP("ABSVM","VOLWHRS",$J),ABSSITES - S REGIEN=0 - F S REGIEN=$O(^ABS(503331,REGIEN)) Q:'REGIEN D - . S REG0=$G(^ABS(503331,REGIEN,0)) - . I $P(REG0,U,3)<2961001 Q - . S VOLPTR=$P(REG0,U) - . S SITE=$P(REG0,U,7) - . ;check for excluded sites - . Q:(VOLPTR="")!(SITE="") Q:$D(EXSITES(SITE)) - . I $G(FLAG)="S" S ABSSITES(SITE)="" Q - . S ^TMP("ABSVM","VOLWHRS",$J,VOLPTR,SITE)="" - . Q - ;check for new volunteer's, less than 90 days, with no hours - S VOLPTR=0,SRTDATE=$$HTFM^XLFDT($$HADD^XLFDT($H,-90)) - F S VOLPTR=$O(^ABS(503330,VOLPTR)) Q:VOLPTR="" D - . S REGIEN=0 - . F S REGIEN=$O(^ABS(503330,VOLPTR,4,REGIEN)) Q:'REGIEN D - .. S REG0=$G(^ABS(503330,VOLPTR,4,REGIEN,0)) - .. Q:REG0="" - .. ;check for excluded sites - .. S SITE=$P(REG0,U,12) Q:SITE="" Q:$D(EXSITES(SITE)) - .. S ENTRY=$P(REG0,U,2),TERM=$P(REG0,U,8) - .. I ENTRY>SRTDATE,TERM="",'$D(^TMP("ABSVM","VOLWHRS",$J,VOLPTR,REGIEN)) S ^(REGIEN)="" - .. Q - Q - ; -EXSITES ;get exclude sites and put in EXSITES array - ; - N I,J,X - K EXSITES - ;there should only be one entry at top level - S I=$O(^ABS(503339.5,"IN","N",0)),J=0 Q:I="" - F S J=$O(^ABS(503339.5,"IN","N",I,J)) Q:J="" D - . S X=$P($G(^ABS(503339.5,I,1,J,0)),U) - . S:X]"" EXSITES(X)="" - Q - ; -ABSIEN ;get the ien of Migration Log file - ;returns ABSIEN=IEN or 0 if failed - S ABSIEN=0 - D LIST^DIC(503339.5) - I '^TMP("DILIST",$J,0) D Q - . W "You must run the Prepare for Transition to VSS option first." - . W !,"If you have any questions, contact the System Implementation team." - . Q - I ^TMP("DILIST",$J,0)>1 D Q - . W "You have multiple entries in the Voluntary Migration Log." - . W !,"Contact System Implementation." - S ABSIEN=^TMP("DILIST",$J,2,1) - ; -SETUPXTP ; - ;Sets up 0-nodes in XTMP - S ^XTMP("ABSVMORG",0)=$$NOW^XLFDT_U_$$HTFM^XLFDT($$HADD^XLFDT($H,30))_U_"Voluntary Organizations to be migrated." - S ^XTMP("ABSVMSERV",0)=$$NOW^XLFDT_U_$$HTFM^XLFDT($$HADD^XLFDT($H,30))_U_"Voluntary Services to be migrated." - S ^XTMP("ABSVMOHRS",0)=$$NOW^XLFDT_U_$$HTFM^XLFDT($$HADD^XLFDT($H,30))_U_"Voluntary Occasional Hours to be migrated." - S ^XTMP("ABSVMRHRS",0)=$$NOW^XLFDT_U_$$HTFM^XLFDT($$HADD^XLFDT($H,30))_U_"Voluntary Regular Hours to be migrated." - S ^XTMP("ABSVMVOL",0)=$$NOW^XLFDT_U_$$HTFM^XLFDT($$HADD^XLFDT($H,30))_U_"Volunteers to be migrated." - S ^XTMP("ABSVMVOLP",0)=$$NOW^XLFDT_U_$$HTFM^XLFDT($$HADD^XLFDT($H,30))_U_"Volunteer Profiles to be migrated." - S ^XTMP("ABSVMVOLCB",0)=$$NOW^XLFDT_U_$$HTFM^XLFDT($$HADD^XLFDT($H,30))_U_"Volunteer Combination Codes to be migrated." - S ^XTMP("ABSVMVOLPK",0)=$$NOW^XLFDT_U_$$HTFM^XLFDT($$HADD^XLFDT($H,30))_U_"Volunteer Parking Stickers to be migrated." - Q - ; -CLEANXTP ; - ;Empties all the XTMP()s and TMP holding IENs to Export. - K ^XTMP("ABSVMSERV"),^XTMP("ABSVMORG") - K ^XTMP("ABSVMRHRS"),^XTMP("ABSVMOHRS") - K ^XTMP("ABSVMVOL"),^XTMP("ABSVMVOLP") - K ^XTMP("ABSVMVOLCB"),^XTMP("ABSVMVOLPK") - K ^TMP("ABSVM","VOLWHRS"),^TMP("ABSVM",$J) - Q - ; -LDCDS ; - ;Call routines that Load codes for orgs, services, - ;work schedules and awards into Local arrays. - D LDORGS^ABSVMLC1 ;Organizations into OCDS() - D LDSRVS^ABSVMLC2 ;Services into SCDS() - D LDWKS^ABSVMLC3 ; Work Schedules into WCDS() - D LDAWDS^ABSVMLC3 ;Awards into ACDS() - Q - ; -CLEANCDS ; - ;Kills local arrays of national codes - K OCDS,SCDS,WCDS,ACDS - Q - ; -CRERRLOG(RUNTYPE,SEND) ; - ;Function that creates an entry in the VALIDATION RESULTS multiple. - ;Returns the DA of the subentry. - N ABSVMFDA,ABSVMIEN,DIERR,ABSIEN - ;Get IEN of Migration Log entry. - D ABSIEN Q:'ABSIEN - ;Set TIME RUN = NOW - S ABSVMFDA(503339.52,"+1,"_ABSIEN_",",.01)=$$NOW^XLFDT - ;Set VALIDATED DATA = Type passed in. - S ABSVMFDA(503339.52,"+1,"_ABSIEN_",",1)=RUNTYPE - I $G(SEND)["S" S ABSVMFDA(503339.52,"+1,"_ABSIEN_",",2)="Y" - E S ABSVMFDA(503339.52,"+1,"_ABSIEN_",",2)="N" - D UPDATE^DIE(,"ABSVMFDA","ABSVMIEN") - I $G(DIERR)="" Q ABSVMIEN(1) ;Successful creation - D MSG^DIALOG() - Q 0 - ; -RECERR(VALRESUL,ERRORS) ; - ;Records errors in the VALIDATION RESULTS multiple. - ;Also, increments the error count. - ;Get IEN of Migration Log entry. - I $G(VALRESUL("ERRIEN"))="" D - . N ABSIEN - . D ABSIEN Q:'ABSIEN - . S VALRESUL("ERRIEN")=ABSIEN - . Q - D WP^DIE(503339.52,VALRESUL("DA")_","_VALRESUL("ERRIEN")_",",4,"A","ERRORS") - S VALRESUL("ERRCNT")=$G(VALRESUL("ERRCNT"))+1 - Q - ; -ERRCNT(VALRESUL) ; - ;Records the number of errors during a run. - N ABSVMFDA,ABSIEN - I $G(VALRESUL("ERRIEN"))="" D - . D ABSIEN Q:'ABSIEN - . S VALRESUL("ERRIEN")=ABSIEN - . Q - S ABSVMFDA(503339.52,VALRESUL("DA")_","_VALRESUL("ERRIEN")_",",3)=VALRESUL("ERRCNT") - D FILE^DIE(,"ABSVMFDA") - Q - ; diff -auBN ./r1/ABSVMVV1.m ./r2/r/ABSVMVV1.m --- ./r1/ABSVMVV1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMVV1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,125 +0,0 @@ -ABSVMVV1 ;OAKLANDFO/DPC-VSS MIGRATION;7/9/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33**;Jul 1994 - ; - ; -VALVOL(FLAG,VALRES,START,END) ;Beginning of validation of volunteer data - ;FLAG=S Send mode; so, build sort template array in XTMP. - N VOLIEN - N VOLCNT - ; - K ^TMP("ABSVM",$J) - S VALRES("ERRCNT")=0 - S VALRES("DA")=$$CRERRLOG^ABSVMUT1("V",$G(FLAG)) - I VALRES("DA")=0 W !,"There was an error creating VALIDATION RESULTS entry for Volunteers." Q - S VOLIEN=$G(START,0),END=$G(END,999999999999999),VOLCNT=0 - F S VOLIEN=$O(^ABS(503330,VOLIEN)) Q:VOLIEN=""!(VOLIEN>END) D - . S VOLCNT=VOLCNT+1 - . D VOLVAL($G(FLAG),VOLIEN) - . Q - D ERRCNT^ABSVMUT1(.VALRES) - Q - ; -VOLVAL(FLAG,VOLIEN) ; - N VOL0,VOLIDEN,ERRS,VOL3 - N VOLNAME,SSN,AD1,CITY,DOB,LANG,SEX,STPTR,ZIP - ;Check if Volunteer had hours. If not, don't process. - ;Need to add exception for brand new volunteers (entry < 3 mos.) - I '$D(^TMP("ABSVM","VOLWHRS",$J,VOLIEN)) Q - S ERRS=0 - S VOL0=$G(^ABS(503330,VOLIEN,0)) - S VOL3=$G(^ABS(503330,VOLIEN,3)) - ;IEN - I VOL0="" D ADDERR("Volunteer record #"_VOLIEN_" does not exist",.ERRS) D RECERR^ABSVMUT1(.VALRES,.ERRS) Q - ;NAME - S VOLNAME=$P(VOL0,U,1) - I VOLNAME="" D ADDERR("Volunteer record #"_VOLIEN_" does not have a volunteer name.",.ERRS) - S VOLIDEN="Volunteer record #"_VOLIEN_" with Name "_VOLNAME_" " - D STDNAME^XLFNAME(.VOLNAME,"C") - I VOLNAME("FAMILY")="" D ADDERR(VOLIDEN_"is missing a last name.",.ERRS) - I $L(VOLNAME("FAMILY"))>30 D ADDERR(VOLIDEN_"has a last name longer than 30 characters.",.ERRS) - I VOLNAME("GIVEN")="" D ADDERR(VOLIDEN_"is missing a first name.",.ERRS) - I $L(VOLNAME("GIVEN"))>30 D ADDERR(VOLIDEN_"has a first name longer than 30 characters.",.ERRS) - I $L(VOLNAME("MIDDLE"))>20 D ADDERR(VOLIDEN_"has a middle name longer than 20 characters.",.ERRS) - I $L(VOLNAME("SUFFIX"))>10 D ADDERR(VOLIDEN_"has a name suffix longer than 10 characters.",.ERRS) - ;SSN - D - . S SSN=$P(VOL0,U,2) - . I SSN="" D ADDERR(VOLIDEN_"is missing a Social Security Number.",.ERRS) Q - . I SSN'?9N D ADDERR(VOLIDEN_" has an incorrect SSN: "_SSN_".",.ERRS) Q - . I $D(^TMP("ABSVM",$J,"SSN",SSN)) D Q - .. N ERRORS - .. S ERRORS(1)="Warning: "_VOLIDEN_"has a duplicate SSN with record "_^TMP("ABSVM",$J,"SSN",SSN) - .. I $G(VALRES("ERRIEN"))="" D - ... N ABSIEN - ... D ABSIEN^ABSVMUT1 Q:'ABSIEN - ... S VALRES("ERRIEN")=ABSIEN - ... Q - .. D WP^DIE(503339.52,VALRES("DA")_","_VALRES("ERRIEN")_",",4,"A","ERRORS") - .. Q - . S ^TMP("ABSVM",$J,"SSN",SSN)=VOLIEN - ;ADDR #1 - S AD1=$P(VOL0,U,3) - I AD1="" D ADDERR(VOLIDEN_"is missing first line of address.",.ERRS) - I $L(AD1)>35 D ADDERR(VOLIDEN_"has a first line of address longer than 35 characters.",.ERRS) - ;CITY - S CITY=$P(VOL0,U,4) - I CITY="" D ADDERR(VOLIDEN_"is missing a city.",.ERRS) - I $L(CITY)>30 D ADDERR(VOLIDEN_"has a city longer than 30 characters.",ERRS) - ;STATE - ;MAY NEED CHECK ABBREVIATION AGAINST AN ACCEPTABLE LIST. - S STPTR=$P(VOL0,U,5) - I STPTR="" D ADDERR(VOLIDEN_"is missing a state.",.ERRS) - I STPTR'="",$L($P($G(^DIC(5,STPTR,0)),U,2))'=2 D ADDERR(VOLIDEN_"has incorrect state data.",.ERRS) - ;ZIP - S ZIP=$P(VOL0,U,6) - I ZIP="" D ADDERR(VOLIDEN_"is missing a zip code.",.ERRS) - I $L(ZIP)>10 D ADDERR(VOLIDEN_"has a zip code longer than 10 characters.",.ERRS) - ;SEX - S SEX=$P(VOL0,U,7) - I SEX="" D ADDERR(VOLIDEN_"is missing a gender designation.",.ERRS) - I ",M,F,B,G,"'[(","_SEX_",") D ADDERR(VOLIDEN_"has incorrect sex data.",.ERRS) - ;DOB - D - . S DOB=$P(VOL0,U,8) - . I DOB="" D ADDERR(VOLIDEN_"is missing a data of birth.",.ERRS) Q - . N RES D DT^DILF("",DOB,.RES) - . I $L($P(DOB,"."))'=7!(RES=-1) D ADDERR(VOLIDEN_"has incorrect date of birth date.",.ERRS) - . Q - ;NICK NAME - I $L($P(VOL0,U,9))>20 D ADDERR(VOLIDEN_"has a nick name longer than 20 characters.",.ERRS) - ;ADDR #2 - I $L($P(VOL0,U,10))>35 D ADDERR(VOLIDEN_"has a second line of address longer than 35 characters.",.ERRS) - ;LANGUAGE - S LANG=$P(VOL0,U,11) - I LANG'="",",1,2,"'[(","_LANG_",") D ADDERR(VOLIDEN_"has an incorrect preferred language code.",.ERRS) - ;PSEUDO SSN - I $P(VOL0,U,18)'="P",$P(VOL0,1,18)'="" D ADDERR(VOLIDEN_"has an incorect psuedo SSN indicator",.ERRS) - ;CODE - I $L($P(VOL0,U,22))>5 D ADDERR(VOLIDEN_"has a Code longer than 5 characters.",.ERRS) - ;NOK - I $L($P(VOL3,U,1))>30 D ADDERR(VOLIDEN_"has a Next of Kin longer than 30 characters.",.ERRS) - ;PHONE - I $L($P(VOL3,U,2))>30 D ADDERR(VOLIDEN_"has a Telephone Number longer than 30 characters.",.ERRS) - ;NOK RELATIONSHIP - I $L($P(VOL3,U,3))>15 D ADDERR(VOLIDEN_"has a Kin's Relationship longer than 15 characters.",.ERRS) - ;NOK TELEPHONE - I $L($P(VOL3,U,4))>30 D ADDERR(VOLIDEN_"has a Kin's Telephone longer than 30 characters.",.ERRS) - ;NOK ALT PHONE - I $L($P(VOL3,U,5))>30 D ADDERR(VOLIDEN_"has a Kin's Alternate Phone longer than 30 characters.") - ;ALT PHONE - I $L($P(VOL3,U,7))>30 D ADDERR(VOLIDEN_"has an Alternate Phone longer than 30 characters.",.ERRS) - ;Record errors - I ERRS>0 D RECERR^ABSVMUT1(.VALRES,.ERRS) - ;If no errors, proceed and add to sort template. - I $G(FLAG)["S",'ERRS S ^XTMP("ABSVMVOL","IEN",VOLIEN)="" - ;STATION PROFILE - D PROF^ABSVMVV2(VOLIEN,VOLIDEN,$G(FLAG),.VALRES) - ;COMBINATIONS - D COMBVAL^ABSVMVV3(VOLIEN,VOLIDEN,$G(FLAG),.VALRES) - ; - Q - ; -ADDERR(ERRMSG,ERRS,ABSVIEN) ; - S ERRS=ERRS+1 - S ERRS(ERRS)=ERRMSG - Q diff -auBN ./r1/ABSVMVV2.m ./r2/r/ABSVMVV2.m --- ./r1/ABSVMVV2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMVV2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,93 +0,0 @@ -ABSVMVV2 ;OAKLANDFO/DPC-VSS MIGRATION;7/18/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33,35**;Jul 1994 - ; -PROF(VOLIEN,VOLIDEN,FLAG,VALRESP) ; - ; - N PROFIEN,PROF0,ERRS,OUT - N AWARD,AWCDPTR,ENTRY,STATION,STATPTR,TERM - S PROFIEN=0 - F S PROFIEN=$O(^ABS(503330,VOLIEN,4,PROFIEN)) Q:PROFIEN="" D - . N ERRS S ERRS=0 - . S OUT=0 - . S PROF0=$G(^ABS(503330,VOLIEN,4,PROFIEN,0)) - . ; if no zero node, clean up children nodes and 'B' cross-ref - . I PROF0="" K ^ABS(503330,VOLIEN,4,"B",PROFIEN,PROFIEN),^ABS(503330,VOLIEN,4,PROFIEN) Q - . ;STATION NUMBER - . D - . . S STATPTR=$P(PROF0,U) - . . I STATPTR="" D ADDERR^ABSVMVV1(VOLIDEN_"is missing Station information.",.ERRS,VOLIEN) S OUT=1 Q - . . S STATION=$P($G(^ABS(503338,STATPTR,0)),U,9) - . . Q:$D(EXSITES(STATION)) ;check for excluded sites - . . I $L(STATION)>7!(STATION="") D ADDERR^ABSVMVV1(VOLIDEN_"has incorrect Station Number information.",.ERRS,VOLIEN) S OUT=1 Q - . . ; if no station number, then set it. This field should alway be there, it is set in a trigger on .01 field - . . I $P(PROF0,U,12)="" S $P(PROF0,U,12)=STATION,^ABS(503330,VOLIEN,4,PROFIEN,0)=PROF0 Q - . ;ENTRY DATE, if no error then do - . D:'OUT - . . N DA,DIK - . . S ENTRY=$P(PROF0,U,2),DIK="^ABS(503330,"_VOLIEN_",4," - . . ;if no entry date, then delete this station multiple - . . I ENTRY="" S DA=PROFIEN,DA(1)=VOLIEN D ^DIK S OUT=1 Q - . . ;D ADDERR^ABSVMVV1(VOLIDEN_"is missing Entry Date information.",.ERRS,VOLIEN) Q - . . ;Check if hours recorded for that station. Ok if entry date new. - . . I '$D(^TMP("ABSVM","VOLWHRS",$J,VOLIEN,STATION))&(+ENTRY<$$HTFM^XLFDT($$HADD^XLFDT($H,-90))) S OUT=1 Q - . . N RES D DT^DILF("",ENTRY,.RES) - . . I $L($P(ENTRY,"."))'=7!(RES=-1) D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect Entry Date.",.ERRS,VOLIDEN) - . ;If OUT, Station Profile should not be sent, record error and QUIT - . I OUT D:ERRS>0 RECERR^ABSVMUT1(.VALRESP,.ERRS) Q - . ;YEARS - . I $P(PROF0,U,3)'?.N D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect value for Years At Station.",ERRS,VOLIEN) - . ;PRIOR HOURS - . I $P(PROF0,U,20)'?.N D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect value for Prior Years Hours Served.",.ERRS,VOLIEN) - . ;CURRENT HOURS - . I $P(PROF0,U,21)'?.N D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect value for Current Year Hours Served.",.ERRS,VOLIEN) - . ;LAST AWARD HOURS - . I $P(PROF0,U,5)'?.N D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect value for Hours Last Award.",.ERRS,VOLIEN) - . ;LAST AWARD DATE - . S AWARD=$P(PROF0,U,6) - . D:AWARD'="" - . . N RES D DT^DILF("",AWARD,.RES) - . . I $L($P(AWARD,"."))'=7!(RES=-1) D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect Last Award Date.",.ERRS,VOLIDEN) - . ;AWARD CODE - . S AWCDPTR=$P(PROF0,U,7) - . I AWCDPTR'="",'$D(ACDS(AWCDPTR)) D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect Award Code.",.ERRS,.VOLIEN) - . ;TERM DATE - . S TERM=$P(PROF0,U,8) - . D:TERM'="" - . . N RES D DT^DILF("",TERM,.RES) - . . I $L($P(TERM,"."))'=7!(RES=-1) D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect Termination Date.",.ERRS,VOLIDEN) - . ;REMARKS - . ;Only 160 characters can be sent. See ABSVM VOLREMARKS function. - . D - .. N D0,D1,REM,ERRORS - .. S D0=VOLIEN,D1=PROFIEN,REM=$$GETREM() - .. I $L(REM)>160 D - ... S ERRORS(1)="Warning: "_VOLIDEN_"has Remarks greater than 160 characters." - ... I $G(VALRES("ERRIEN"))="" D - .... N ABSIEN - .... D ABSIEN^ABSVMUT1 Q:'ABSIEN - .... S VALRES("ERRIEN")=ABSIEN - ... D WP^DIE(503339.52,VALRES("DA")_","_VALRES("ERRIEN")_",",4,"A","ERRORS") - . ;MEALS? - . I ",,0,1,"'[(","_$P(PROF0,U,24)_",") D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect Eligible For Meals code.",.ERRS,VOLIEN) - . ;TRANSPORT - . I ",,1,2,3,4,"'[(","_$P(PROF0,U,23)_",") D ADDERR^ABSVMVV1(VOLIDEN_"has an incorrect Method of Transportation code.",.ERRS,VOLIEN) - . ; Check for errors - . I ERRS>0 D RECERR^ABSVMUT1(.VALRESP,.ERRS) Q - . ; No errors and got this far; add to send list if FLAG=S - . I $G(FLAG)["S" S ^XTMP("ABSVMVOLP","IEN",VOLIEN)="" - . ;PARKING STICKERS - . D PARKVAL^ABSVMVV3(VOLIEN,PROFIEN,VOLIDEN,$G(FLAG),.VALRESP) - Q - ; -GETREM() ;Function to return Remarks field from Voluntary Master - N MYIENS,MYROOT,WPREM,REMARKS,I - S MYIENS=D1_","_D0_"," - S MYROOT=$$GET1^DIQ(503330.01,MYIENS,18,,"WPREM") - I MYROOT="" Q "" - S I=0,REMARKS="" - F S I=$O(WPREM(I)) Q:I="" D - . ;Avoid string too long error. - . I $L(REMARKS)+$L(WPREM(I))>511 S I=99999 Q - . S REMARKS=REMARKS_$S($L(REMARKS)>0:" ",1:"")_WPREM(I) - Q REMARKS - ; diff -auBN ./r1/ABSVMVV3.m ./r2/r/ABSVMVV3.m --- ./r1/ABSVMVV3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ABSVMVV3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,55 +0,0 @@ -ABSVMVV3 ;OAKLANDFO/DPC-VSS MIGRATION;7/19/2002 - ;;4.0;VOLUNTARY TIMEKEEPING;**31,33**;Jul 1994 - ; -PARKVAL(VOLIEN,PROFIEN,VOLIDEN,FLAG,VALRESPK) ; - ;Validate Parking Sticker Information. - N PARKIEN,PARK0 - N STPTR - S PARKIEN=0 - F S PARKIEN=$O(^ABS(503330,VOLIEN,4,PROFIEN,2,PARKIEN)) Q:PARKIEN="" D - . N ERRS S ERRS=0 - . S PARK0=$G(^ABS(503330,VOLIEN,4,PROFIEN,2,PARKIEN,0)) - . I PARK0="" Q - . ;STICKER# - . I $P(PARK0,U)="" D ADDERR^ABSVMVV1(VOLIDEN_"is missing a Parking Sticker.",.ERRS,VOLIEN) - . I $L($P(PARK0,U))>13 D ADDERR^ABSVMVV1(VOLIDEN_"has a Parking Sticker longer than 13 characters.",.ERRS,VOLIEN) - . ;REG STATE - . S STPTR=$P(PARK0,U,2) - . I STPTR'="",$L($P($G(^DIC(5,STPTR,0)),U,2))'=2 D ADDERR^ABSVMVV1(VOLIDEN_"has incorrect State data for a Parking Sticker.",.ERRS,VOLIEN) - . ;PLATE# - . I $L($P(PARK0,U,3))>12 D ADDERR^ABSVMVV1(VOLIDEN_"has a License Plate Number longer than 12 characters.",.ERRS,VOLIEN) - . I ERRS>0 D RECERR^ABSVMUT1(.VALRESPK,.ERRS) Q - . ;If got this far and FLAG=S, add to Parking Sort Template - . I $G(FLAG)["S" S ^XTMP("ABSVMVOLPK","IEN",VOLIEN)="" - . Q - Q - ; -COMBVAL(VOLIEN,VOLIDEN,FLAG,VALRESC) ; - ;Validate combination data. - N COMBIEN,COMB0,COMB - N ORGPTR,SCHDPTR,SRVPTR - S COMBIEN=0 - F S COMBIEN=$O(^ABS(503330,VOLIEN,1,COMBIEN)) Q:COMBIEN="" D - . N ERRS S ERRS=0 - . S COMB0=$G(^ABS(503330,VOLIEN,1,COMBIEN,0)) - . I COMB0="" Q - . I $P($P(COMB0,U),"-")]"" Q:$D(EXSITES($P($P(COMB0,U),"-"))) ;check for excluded sites - . ;ORGANIZATION - . S ORGPTR=$P(COMB0,U,2),COMB=$P(COMB0,U) - . I ORGPTR="" D ADDERR^ABSVMVV1(VOLIDEN_"has Combination, "_COMB_" missing an Organization.",.ERRS,VOLIEN) - . I ORGPTR'="",'$D(OCDS(ORGPTR)) D ADDERR^ABSVMVV1(VOLIDEN_"has Combination, "_COMB_" with an incorrect Organization Code.",.ERRS,VOLIEN) - . ;SCHEDULE - . S SCHDPTR=$P(COMB0,U,3) - . I SCHDPTR="" D ADDERR^ABSVMVV1(VOLIDEN_"has Combination, "_COMB_" missing a Schedule.",.ERRS,VOLIEN) - . I SCHDPTR'="",'$D(WCDS(SCHDPTR)) D ADDERR^ABSVMVV1(VOLIDEN_"has Combination, "_COMB_" with an incorrect Schedule Code.",.ERRS,VOLIEN) - . ;SERVICE - . S SRVPTR=$P(COMB0,U,4) - . I SRVPTR="" D ADDERR^ABSVMVV1(VOLIDEN_"has Combination, "_COMB_" missing a Service.",.ERRS,VOLIEN) - . I SRVPTR'="",'$D(SCDS(SRVPTR)) D ADDERR^ABSVMVV1(VOLIDEN_"has Combination, "_COMB_" with an incorrect Service Code.",.ERRS,VOLIEN) - . ;INACTIVE - . I ",0,1,"'[","_$P(COMB0,U,6)_"," D ADDERR^ABSVMVV1(VOLIDEN_"Has Combination, "_COMB_" with an incorrect Active/Inactive value.",.ERRS,VOLIEN) - . I ERRS>0 D RECERR^ABSVMUT1(.VALRESC,.ERRS) Q - . I $G(FLAG)["S" S ^XTMP("ABSVMVOLCB","IEN",VOLIEN)="" - . Q - Q - ; diff -auBN ./r1/ACKQAG01.m ./r2/r/ACKQAG01.m --- ./r1/ACKQAG01.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQAG01.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,194 +0,0 @@ -ACKQAG01 ;DDC/PJU - Get data for Audiogram(s) Display from 509850.9 ;11/01/02 - ;;3.0;QUASAR AUDIOMETRIC MODULE;**3**;11/01/02 - ;input: ref to array and DFN - ;return: array of VALUES in ACKQARR array transformed to input array reference - ;returns: value of variable ACKQERR in 8th pc of 0 node,if an error was found - ;Series 1&3 Right Ear - Series 2&4 Left Ear - ;ACKQARR(0)= pieces - ; 1= # audiograms[0-2] - ; 2= name of patient - ; 3= first audiogram date seen - ; 4= first tester name - ; 5= age of patient at first audiogram - ; 6= title of tester for first audiogram - ; 7= SSN of patient - ; 8= second audiogram date(or error msg if an error exists) - ; 9= tester name for second audiogram - ; 10= age of patient at second audiogram - ; 11= title of tester for second audiogram - ; 12= station name of site - ;ACKQARR(ctr) pieces for subscripts 1-24 and 26-50 - ; 1= X value(Hz) being tested - ; 2= ACKQI - internal record number - ; 3= ear[L,R] - ; 4= air Y(dB) val - ; 5= airMask[0-6] - ; 6* airMaskLevel - ; 7*= bone Y(dB) value - ; 8*= boneMask[0-6] - ; 9*= boneMaskLevel - ; 10*= IAR - ; 11*= CAR - ;in addition ACKQARR(24/50) - ; ^31= SRT- R1 - ; ^32= SRT- R2 - ; ^33= SRT- L1 - ; ^34= SRT- L2 - ; ^35= MaskLevel initial - ; ^36= MaskLevel final - ;ACKQARR(25/51 PC'S) - ; 1R^2R^3R^4R^5R^1L^2L^3L^4L^5L^R MAX^R PIPB^R CONSIS^L MAX^L PIPB^L CONSIS - ;ACKQARR(array nodes:26/52 PC'S from 120/121 nodes in file) - ; Rmip^Rstat^Rveq^R IAR 5^R IAR 1^R IAR 2^R IAR 4^R CAR 5^R CAR 1^R CAR 2^R CAR 4^R ARD 5^R ARD 10^R HL 5^R HL 1^ - ; Lmip^Lstat^Lveq^L IAR 5^L IAR 1^L IAR 2^L IAR 4^L CAR 5^L CAR 1^L CAR 2^L CAR 4^L ARD 5^L ARD 10^L HL 5^L HL 1 - ;will return to the Delphi app as subscripted array - ; Results() subscripts: - ; 1-12(1st audiogram R ear) - ; 13-24(1st audiogram L ear) - ; 25 is speech recog 1st audiogram - ; 26 is the 120/121 nodes 1st - ; 27-38(2nd audiogram R ear) - ; 39-50(2nd audiogram L ear) - ; 51 is speech recog 2nd audiogram - ; 52 is the 120/121 nodes for 2nd -START(ACKQARR,DFN,IEN) ;;array name(.reference) and pointer to Patient file (#2) - ;include IEN in 509850.9 if want just one, otherwise put 0 - ; see flow chart GetData.vsd - ;ACKQARR=array name **passed by reference** - ;ACKI,ACKQT=array subscript values - ;ACKQ=number of graphs ; killed at end - ;ACKQERR = ERR msg ; returned to calling ap and killed at end - ;BD=dob, S0=file node, TD=test date - ;TU=DUZ of tester, TT=title of tester - ;ACKQDAT = fileman date from end of file; killed at end - ;ACKQ1IEN = first entry used ; killed at end - ;ACKQ2IEN = second entry used ; killed at end - K ACKQARR ;make sure does not have previous entries - N ACKT,BD,S0,S1,SSN,TD,TT,TU - S (ACKQARR(0),ACKI,ACKQ)=0 - S ACKQERR="" - I '$G(DFN) D G END - .S ACKQERR="**ERROR** Must have a DFN to run routine ACKQAG01 " - I '$D(^ACK(509850.9,0)) D G END - .S ACKQERR="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available" - I '$D(^ACK(509850.9,"DFN",DFN)) D G END - .S ACKQERR="**ERROR** patient not in audiogram file" - D DEM^VADPT ; - demographic variables - I $G(VAERR) S ACKQERR="**ERROR** Problem in retrieving Demographic values" G END - S SSN=$P(VADM(2),U,1),BD=VADM(3) - ;determine if 1 or 2 audiograms - set flag - S ACKQDAT="A",(ACKQ1IEN,ACKQ2IEN)="" - I $G(IEN) D G S3 - .S (ACKQ1IEN,ACKQI)=IEN - .S ACKQDAT=$P($G(^ACK(509850.9,IEN,0)),U) - .S ACKQ=1 -S1 S ACKQDAT=$O(^ACK(509850.9,"DFN",DFN,ACKQDAT),-1) - ;set up array for 1st - I 'ACKQ,'ACKQDAT D G END - .S ACKQERR="**ERROR** No current audiograms for patient in file" - I ACKQ=1,'ACKQDAT G END ;only 1 - I ACKQ>0 S ACKI=ACKI+1 ;,ACKQARR(ACKI)="*****" ;MARKER for END OF 1ST AUDIOGRAM - S ACKQI=0 -S2 S ACKQI=$O(^ACK(509850.9,"DFN",DFN,ACKQDAT,ACKQI)) - I 'ACKQ,'ACKQI D G S1 - .S ACKQERR="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQDAT) - G:'ACKQI S1 - ;W !,"Entry number found: ",ACKQI - for testing - I '$D(^ACK(509850.9,ACKQI,0)) D G END - .S ACKQERR="**ERROR** Node missing in file for this visit" - S ACKQ=ACKQ+1 ;set flag for Number of Audiograms available -S3 ;record 1st then See if another ACKQI exists for patient - S S0=$G(^ACK(509850.9,ACKQI,0)) - I $P(S0,U,2)'=DFN D G END - .S ACKQERR="***URGENT** Actual Patient in Exam File entry:"_ACKQI_" is different than DFN cross-ref, notify IRM" - I ACKQ=1 D G:'$G(IEN) S2 G:$G(IEN) END - .S ACKQ1IEN=ACKQI,TD=$P(S0,U,1) - .S X=$P($$FMTE^XLFDT(TD),"@",1) - .S ACKQARR(0)=1_U_VADM(1)_U_X ;initial setup - .I $P(S0,U,3) D ;DUZ of tester - ..S TU=$P(S0,U,3) D:TU>0 - ...S TT=$$TITLE(TU) - ...S $P(ACKQARR(0),U,4)=$P(TT,U,1) ;tester1 name - ...S $P(ACKQARR(0),U,6)=$P(TT,U,2) ;title of tester1 - .S $P(ACKQARR(0),U,5)=$P(S0,U,5) ;age at test1 - .S $P(ACKQARR(0),U,7)=SSN - .S S1=$P(S0,U,10) D:S1 - ..K AK S DIC=4,DA=S1,DIQ="AK",DR=".01" D EN^DIQ1 ; - ..S $P(ACKQARR(0),U,12)=AK(4,S1,.01) ;Station name - ..K AK,DIC,DA,DIQ,DR - .D GETDATA^ACKQAG06(ACKQI,.ACKI) - .S ACKT=ACKQ1IEN ;fill (26) - .S S0=$G(^ACK(509850.9,ACKT,120)) ;R - .F X=1:1:15 S $P(ACKQARR(26),U,X)=$P(S0,U,X) - .S S0=$G(^ACK(509850.9,ACKT,121)) ;L - .F X=1:1:15 S $P(ACKQARR(26),U,(X+15))=$P(S0,U,X) - .;Modify (24) 12000 not used in 2364 display - .S S0=$G(^ACK(509850.9,ACKT,110)),J=4 ;R ear,start after what would be the 12000 Y - .F X=6:5:26 D - ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X) ;pre lev R - ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,(X+1)) ;followed by mask lev R - .S S0=$G(^ACK(509850.9,ACKT,111)) ;L ear - .F X=6:5:26 D - ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X) ;pre lev L - ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,(X+1)) ;followed by mask lev L - .S S0=$G(^ACK(509850.9,ACKT,1)),J=24 - .F X=5,3,1 D ;R AVG'S 4,3,2 - ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X) - .F X=6,4,2 D ;L AVG'S 4,3,2 - ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X) - ; - I ACKQ=2 D - .S ACKQ2IEN=ACKQI - .S $P(ACKQARR(0),U,1)=2 - .S TD=$P(S0,U,1) - .S $P(ACKQARR(0),U,8)=$P($$FMTE^XLFDT(TD),"@",1) - .I $P(S0,U,3) D ;tester2 duz - ..S TU=$P(S0,U,3),TT=$$TITLE(TU) - ..S $P(ACKQARR(0),U,9)=$P(TT,U,1),$P(ACKQARR(0),U,11)=$P(TT,U,2) - .I '$P(S0,U,3) S $P(ACKQARR(0),U,9)="Unknown",$P(ACKQARR(0),U,11)="Unknown" - .S $P(ACKQARR(0),U,10)=$P(S0,U,5) ;age at test2 - .D GETDATA^ACKQAG06(ACKQI,.ACKI) - .S ACKT=ACKQ2IEN ;fill (52) - .S S0=$G(^ACK(509850.9,ACKT,120)) ;R - .F X=1:1:15 S $P(ACKQARR(52),U,X)=$P(S0,U,X) - .S S0=$G(^ACK(509850.9,ACKT,121)) ;L - .F X=1:1:15 S $P(ACKQARR(52),U,(X+15))=$P(S0,U,X) - .;Modify (50) 12000 not used in 2364 display - .S S0=$G(^ACK(509850.9,ACKT,110)),J=4 ;start after what would be the 12000 Y - .F X=6:5:26 D - ..S J=J+1,$P(ACKQARR(50),U,J)=$P(S0,U,X) ;pre lev R - ..S J=J+1,$P(ACKQARR(50),U,J)=$P(S0,U,(X+1)) ;followed by mask lev R - .S S0=$G(^ACK(509850.9,ACKT,111)) - .F X=6:5:26 D - ..S J=J+1,$P(ACKQARR(50),U,J)=$P(S0,U,X) ;pre lev L - ..S J=J+1,$P(ACKQARR(50),U,J)=$P(S0,U,(X+1)) ;followed by mask lev L - .S S0=$G(^ACK(509850.9,ACKT,1)),J=24 - .F X=5,3,1 D ;R AVG'S 4,3,2 - ..S J=J+1,$P(ACKQARR(50),U,J)=$P(S0,U,X) - .F X=6,4,2 D ;L AVG'S 4,3,2 - ..S J=J+1,$P(ACKQARR(50),U,J)=$P(S0,U,X) -END ;if 0-1 charts and errors, then kill 1st, & pass error - ;if 2 charts and errors then - ; return JUST 1st audiogram, kill 2nd & pass error - I $G(ACKQERR)'="",$G(ACKQ)=1 D D WRTERR - .S $P(ACKQARR(0),U,1)=0 F J=3:1:11 S $P(ACKQARR(0),U,J)="" - .F ACKI=1:1:26 S ACKQARR(ACKI)="" - I $G(ACKQERR)'="",$G(ACKQ)=2 D D WRTERR - .S $P(ACKQARR(0),U,1)=1 F J=9:1:11 S $P(ACKQARR(0),U,J)="" - .F ACKI=27:1:52 S ACKQARR(ACKI)="" - K ACKI,ACKQERR,ACKQDAT,ACKQ,ACKQI,ACKQ1IEN,ACKQ2IEN,J,X - Q - ; -WRTERR ; Record error & write out if testing - I $L($G(ACKQERR)) D - .;W !!,?10,ACKQERR ;used for direct call testing - .S $P(ACKQARR(0),U,8)=ACKQERR ;error for display in Delphi - Q - ; -TITLE(ACKUSER) ;input DUZ returns printable name and title - N T1,T2,ACK,DIC,DA,DR,DIQ S (T1,T2)="Unknown" G:'$G(ACKUSER) ENDT - S DIC=200,DA=ACKUSER,DIQ="ACK",DR=".01;8" D EN^DIQ1 - S T1=$G(ACK(200,ACKUSER,.01)) - S T2=$G(ACK(200,ACKUSER,8)) - S:T1="" T1="Unknown" S:T2="" T2="Unknown" -ENDT Q T1_U_T2 diff -auBN ./r1/ACKQAG02.m ./r2/r/ACKQAG02.m --- ./r1/ACKQAG02.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQAG02.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,182 +0,0 @@ -ACKQAG02 ;DDC/PJU - Module to get data for Audiogram E/E and Transmit to DDC ;11/01/02 - ;;3.0;QUASAR AUDIOMETRIC MODULE;**3**;11/01/02 - ;input: ref to array and DFN - ;return: array of VALUES in ACKQARR, ACKQERR if an error was found - ;This is not used for the Audiogram Display, just the E/E - One Audiogram at a time - ;IEN needed in 1st pc for the Enter/edit program - ;ACKQARR(1)=audiogram local ien^name of patient^last date seen^tester1^error msg - ;ACKQARR(ctr)=pcs in rest of counter nodes - ; 1=Xvalue - ; 2=ear[L,R] - ; 3= - ; 4=iairY - ; 5=iairMask[0-6] - ; 6=iairMaskL - ; 7=iboneY - ; 8=iboneMask[0-1] - ; 9=iboneMaskL - ; 10=IAR - ; 11=CAR - ; 12=rairY - ; 13=rairMask[0-6] - ; 14=rairMaskL - ; 15=rboneY - ; 16=rboneMask[0-1] - ; 17=rboneMaskL - ; 18=AR DECAY - ; 19=HALF LF - ;will return to the Delphi app as subscripted array - ;subscripts: 1(gen), 2-13(R), 14-25(L), 26(gen) -START(ACKQARR,DFN) ;written description of process at end of routine - K ACKQERR - ;ACKQN is a number counter, S0 is a node holder - ;ACKQERR is an error holder - ;ACKQFMD hold dates, ACKQ1IEN holds the entry number - I '$G(DFN) D G END - .S ACKQERR="**ERROR** Must have a DFN to run routine RMPFRPC2 " - I '$D(^ACK(509850.9,0)) D G END - .S ACKQERR="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available" - ;look up DFN in file - I '$D(^ACK(509850.9,"DFN",DFN)) D G END - .S ACKQERR="**ERROR** patient not in audiogram file" - ;determine if 1 or 2 audiograms - set flag - S ACKQFMD="A",ACKQ1IEN="" -S1 S ACKQFMD=$O(^ACK(509850.9,"DFN",DFN,ACKQFMD),-1) - ;set up array for latest one in file - I 'ACKQFMD D G END - .S ACKQERR="**ERROR** No current audiograms for patient in file" - S ACKQIEN=0 -S2 S ACKQIEN=$O(^ACK(509850.9,"DFN",DFN,ACKQFMD,ACKQIEN)) - I 'ACKQIEN D G S1 - .S ACKQERR="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQFMD) - I '$D(^ACK(509850.9,ACKQIEN,0)) D G S1 - .S ACKQERR="**ERROR** Node missing in file for this visit" - G EN2 ;to skip following line -EN(ACKQARR,ACKQIEN,DFN) ; -EN2 ;from S2 - N ACK,ACKD,ACKDF,ACKT - S ACKQARR(1)=0 - K ACKQERR F I=2:1:25 S ACKQARR(I)="" - S S0=$G(^ACK(509850.9,ACKQIEN,0)) - I $P(S0,U,2)'=DFN D G S2 ;should be already checked in calling routine - .S ACKQERR="***URGENT ERROR*** File error - wrong DFN in xref DFN or record: "_DFN - S DIC=2,DA=DFN,DIQ="AK",DR=".01" D EN^DIQ1 S ACKD=AK(2,DFN,.01) ;DFN name - K DIC,DA,DIQ,DR,AK - ;(1)=ien^patient^FM date seen^tester - S ACKDF=$P(^ACK(509850.9,ACKQIEN,0),U,1) - S ACKQARR(1)=ACKQIEN_U_ACKD_U_ACKDF - I '$P(S0,U,3) S $P(ACKQARR(1),U,4)="Unknown" - E D - .S Y=$P(S0,U,3),X=$$TITLE^ACKQAG01(Y) K Y - .S $P(ACKQARR(1),U,4)=$P(X,U,1) ;tester name - D GETDATA(ACKQIEN) -END ;if errors, then handle errors and stop - S:'$D(ACKQARR(1)) ACKQARR(1)=0 - I $G(ACKQERR)'="" D D WRTERR ;5th pc of 0 node is err msg - .F I=2:1:25 S ACKQARR(I)="" - K ACKQERR,ACKQFMD,I,S0 - Q - ; -GETDATA(ACKQIEN) ; - ;input the entry number in the Audiometic Exam Data file (ACKQIEN) - ;and current return array subscript value(ACKQN) - N ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQA1L,ACKQA2L ;air initial & repeat values, air tags initial & repeat, air Mask Levels - N ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQB1L,ACKQB2L ;bone initial & repeat values, bone masking init & repeat - N P,P1 ;P is the piece of the air nodes, P1 is the piece of the bone nodes - N X ;X is the Hz - S ACKQN=1 ;counter subscript for array - subsc 1 filled in above - ;START R ear - ; Air - F P=1:1:12 D ;set pcs in ACKQARR node - .S ACKQN=ACKQN+1 - .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"") - .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"") - .S ACKQARR(ACKQN)=X_U_"R"_U_"" ;X^ear^ien^Y - .S ACKQA1=$P($G(^ACK(509850.9,ACKQIEN,10)),U,P) ;init Y val - .S ACKQA1T=$P($G(^ACK(509850.9,ACKQIEN,11)),U,P) ;init tag - .S ACKQA1L=$P($G(^ACK(509850.9,ACKQIEN,50)),U,P) ;init tag level - .S ACKQA2=$P($G(^ACK(509850.9,ACKQIEN,20)),U,P) ;repeat val - .S ACKQA2T=$P($G(^ACK(509850.9,ACKQIEN,21)),U,P) ;repeat tag - .S ACKQA2L=$P($G(^ACK(509850.9,ACKQIEN,51)),U,P) ;repeat tag level - .S $P(ACKQARR(ACKQN),U,4)=ACKQA1,$P(ACKQARR(ACKQN),U,5)=ACKQA1T ;default - .S $P(ACKQARR(ACKQN),U,6)=ACKQA1L,$P(ACKQARR(ACKQN),U,12)=ACKQA2 - .S $P(ACKQARR(ACKQN),U,13)=ACKQA2T,$P(ACKQARR(ACKQN),U,14)=ACKQA2L - .; bone conduction - .I X>125,X<7000 D - ..S P1=P-1 ;125 not a bone reading so pc's 1 less - ..S ACKQB1=$P($G(^ACK(509850.9,ACKQIEN,70)),U,P1) ;init bone - ..S ACKQB1T=$P($G(^ACK(509850.9,ACKQIEN,71)),U,P1) ;init bone TAG - ..S ACKQB1L=$P($G(^ACK(509850.9,ACKQIEN,90)),U,P1) ;init bone level - ..S ACKQB2=$P($G(^ACK(509850.9,ACKQIEN,75)),U,P1) ;repeat bone - ..S ACKQB2T=$P($G(^ACK(509850.9,ACKQIEN,76)),U,P1) ;repeat bone TAG - ..S ACKQB2L=$P($G(^ACK(509850.9,ACKQIEN,91)),U,P1) ;repeat bone mask - ..S $P(ACKQARR(ACKQN),U,7)=ACKQB1,$P(ACKQARR(ACKQN),U,8)=ACKQB1T - ..S $P(ACKQARR(ACKQN),U,9)=ACKQB1L,$P(ACKQARR(ACKQN),U,15)=ACKQB2 - ..S $P(ACKQARR(ACKQN),U,16)=ACKQB2T,$P(ACKQARR(ACKQN),U,17)=ACKQB2L - .;IAR/CAR AR-DECAY AR-HALFLIFE - .I (X=500) D - ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,4) - ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,8) - ..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,12) - ..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,14) - .I (X=1000) D - ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,5) - ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,9) - ..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,13) - ..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,15) - .I (X=2000) D - ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,6) - ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,10) - .I (X=4000) D - ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,7) - ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,11) - ;start L ear - ; air - F P=1:1:12 D - .S ACKQN=ACKQN+1 ;counter subscript for array - .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,1:"") - .S:X="" X=$S(P=7:2000,P=8:3000,P=9:4000,P=10:6000,P=11:8000,1:12000) - .S ACKQARR(ACKQN)=X_U_"L"_U_"" ; X^ear^IEN^Y - .S ACKQA1=$P($G(^ACK(509850.9,ACKQIEN,30)),U,P) ;initial read null - .S ACKQA1T=$P($G(^ACK(509850.9,ACKQIEN,31)),U,P) ;init tag - .S ACKQA1L=$P($G(^ACK(509850.9,ACKQIEN,60)),U,P) ;init level - .S ACKQA2=$P($G(^ACK(509850.9,ACKQIEN,40)),U,P) ;repeat val - .S ACKQA2T=$P($G(^ACK(509850.9,ACKQIEN,41)),U,P) ;repeat tag - .S ACKQA2L=$P($G(^ACK(509850.9,ACKQIEN,61)),U,P) ;repeat level - .S $P(ACKQARR(ACKQN),U,4)=ACKQA1,$P(ACKQARR(ACKQN),U,5)=ACKQA1T - .; bone conduction - .I X>125,X<7000 D - ..S P1=P-1 ;125 not a bone reading so pc's 1 less - ..S ACKQB1=$P($G(^ACK(509850.9,ACKQIEN,80)),U,P1) ;init val - ..S ACKQB1T=$P($G(^ACK(509850.9,ACKQIEN,81)),U,P1) ;init tag - ..S ACKQB1L=$P($G(^ACK(509850.9,ACKQIEN,100)),U,P1) ;init mask level - ..S ACKQB2=$P($G(^ACK(509850.9,ACKQIEN,85)),U,P1) ;repeat val - ..S ACKQB2T=$P($G(^ACK(509850.9,ACKQIEN,86)),U,P1) ;repeat tag - ..S ACKQB2L=$P($G(^ACK(509850.9,ACKQIEN,101)),U,P1) ;repeat mask level - ..S $P(ACKQARR(ACKQN),U,7)=ACKQB1,$P(ACKQARR(ACKQN),U,8)=ACKQB1T ;default - ..S $P(ACKQARR(ACKQN),U,9)=ACKQB1L,$P(ACKQARR(ACKQN),U,15)=ACKQB2 - ..S $P(ACKQARR(ACKQN),U,16)=ACKQB2T,$P(ACKQARR(ACKQN),U,17)=ACKQB2L - .; IAR/CAR AR-DECAY AR-HALFLIFE - .I (X=500) D - ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,4) - ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,8) - ..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,12) - ..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,14) - .I (X=1000) D - ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,5) - ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,9) - ..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,12) - ..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,14) - .I (X=2000) D - ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,6) - ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,10) - .I (X=4000) D - ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,7) - ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,11) - Q - ; -WRTERR ; - I $L($G(ACKQERR)) D - .S $P(ACKQARR(1),U,5)=ACKQERR ; - ;W !!,?10,ACKQERR ;used for direct call testing - Q diff -auBN ./r1/ACKQAG03.m ./r2/r/ACKQAG03.m --- ./r1/ACKQAG03.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQAG03.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,75 +0,0 @@ -ACKQAG03 ;DDC/PJU - SEND AUDIOGRAM DATA TO DDC ;11/01/02 - ;;3.0;QUASAR AUDIOMETRIC MODULE;**3**;11/01/02 - ;contains logic for utilities in ACKQAG04 & ACKQAG05 - ;ACKQFA = result of a function - ;ACKQRMI = entry in file 509850.9 - ;XMZ is the message file entry(1st DDC, then to user) - ;ACKQMSG is the message to DDC file entry - ;ACKQER is the text of an error - ;ACKQARR is the array that holds the data in specific subscripts -START(RESULT,DFN,IEN,ACKQSTNU,ACKQUSNM,ACKQUSSR) ; (DFN & IEN need to be known before call ) - N ACKQER,ACKQERR,ACKQFA,ACKQHSSN,ACKQMSG,ACKQRMI,ACKQVT,SSN,ST,ICN - K ACKQARR S ACKQARR(0)="" - N XMTEXT,XMDUZ,XMRESTR,XMY,XMSUB - ;check existance and get entry - S ACKQFA=$$ACKEXIST^ACKQAG05() ;file exist - I 'ACKQFA S ACKQER=$$ERRTEXT(1) G END - S ACKQRMI=$$DFNIN^ACKQAG05(DFN) ;DFN in Exam file - I 'ACKQRMI S ACKQER=$$ERRTEXT(2) G END - I $G(IEN),(ACKQRMI'=IEN),'$D(^ACK(509850.9,IEN,0)) S ACKQER=$$ERRTEXT(8) G END - S ST=$G(^ACK(509850.9,IEN,0)) - I $G(IEN),$P(ST,U,2)'=DFN S ACKQER=$$ERRTEXT(9) G END - I $G(IEN),(ACKQRMI'=IEN) S ACKQRMI=IEN - ;create stub and address to S.RMROES3@DDC.VA.GOV - S (ACKQMSG,XMZ)=$$NEWMSG^ACKQAG05() - ;get data into array ACKQARR - D EN^ACKQAG04(.ACKQARR,ACKQRMI,DFN) ;load data into array - ;new ACKQA(1)=BGN^ACKQRMI^DFNname^DFNssn^err^DFNdob^tester^SignDate^ExamDate^Vet^DFNType^age - S SSN=$P($G(ACKQARR(1)),U,4) - S ACKQHSSN=$$ENCRYP^XUSRB1(SSN) - S $P(ACKQARR(1),U,4)=ACKQHSSN ;send encrypted SSN - S ACKQVT=$P($G(ACKQARR(1)),U,11),ACKQVT=$E(ACKQVT,1,25) ;DFN type - S X="MPIF001" X ^%ZOSF("TEST") - I S ICN=$$GETICN^MPIF001(DFN),ICN=$E(ICN,1,10) - E S ICN="" - S I=$O(ACKQARR("A"),-1),I=I+1 ;ADD AFTER LAST SUBSCRIPT - S ACKQARR(I)="DDCINFO"_U_ACKQSTNU_U_ACKQUSNM_U_ACKQUSSR_U_ACKQRMI_U_ACKQHSSN_U_U_ACKQVT_U_ICN ;26th node - S XMTEXT="ACKQARR(",XMDUZ=DUZ,XQDATE=DT,XMSUB="AUDIOGRAM DATA" - D CHKLINES^XMXSEC1(XMDUZ,XMZ,.XMRESTR) - I $D(XMRESTR("NONET")) S ACKQER="Message too long for network. Limit "_XMRESTR("NONET") G END - D EN1^XMD ;add text and send - ;notify user - S XMSUB="AUDIOGRAM DATA SENT" - S XMY(DUZ)="",XMDUZ=DUZ - K ACKQARR - S ACKQARR(1)="MESSAGE TO DDC SENT IS:"_ACKQMSG_" ON: "_$$FMTE^XLFDT(DT) - S ACKQARR(2)="DATA SENT IS FROM AUDIOMETRIC EXAM FILE ENTRY:"_ACKQRMI - S XMTEXT="ACKQARR(",XQDATE=DT - D ^XMD ;returns XMZ - ;put the date sent to DDC and the msg number into the Audiogram Data file - S DIE="^ACK(509850.9,",DA=ACKQRMI,DR=".12///"_DT_";.13///"_ACKQMSG - D ^DIE K DIE,DR,DA -END D:$G(ACKQER) WRITEER K ACKQARR,I - ;XMMG is the failure msg if there is one - S RESULT=$G(XMZ)_U_$G(ACKQMSG)_U_$G(ACKQER)_U_$G(XMMG) - Q ;$G(XMZ)_U_$G(ACKQMSG)_U_$G(ACKQER)_U_$G(XMMG) - ; -ERRTEXT(ACKQERR) ;error msg's, input error # - N ACKQER1 ;ERROR TEXT - S ACKQER1=$P($T(@(ACKQERR_"^ACKQAG03")),";",3) G ENDE -1 ;;THE AUDIOMETRIC DATA FILE CANNOT BE ACCESSED -2 ;;THERE IS NOT A VALID ENTRY FOR THIS PATIENT -3 ;;THE MESSAGE COULD NOT BE SET UP -4 ;;THE ADDRESS COULD NOT BE SET UP -5 ;;THERE HAS BEEN AN ERROR IN COLLECTING THE AUDIOMETRIC DATA -6 ;;ONE OF THE MESSAGE LINES WAS TOO LONG -7 ;;AN ERROR OCCURRED WHILE PLACING THE DATA INTO THE TRANSMISSION -8 ;;THE ENTRY FOUND IS NOT THE SAME ENTRY THAT IS BEING EDITED -9 ;;THERE IS A CONFLICT BETWEEN THE PATIENT AND THE FILE ENTRY - ;; -ENDE Q ACKQER1 - ; -WRITEER ;W !!,"*****",ACKQER,"*****" ;for testing - S:$L($G(XMMG)) ACKQER="MSG FAILURE" - S ACKQER="*****"_ACKQER_"*****" - Q diff -auBN ./r1/ACKQAG04.m ./r2/r/ACKQAG04.m --- ./r1/ACKQAG04.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQAG04.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,203 +0,0 @@ -ACKQAG04 ;DDC/PJU - Utility for ACKQAG03 - Transmission from 509850.9 to DDC ;11/01/02 - ;;3.0;QUASAR AUDIOMETRIC MODULE;**3**;4/01/03 - ;;ACKQAG03 calls entry point EN with array ref, record number and DFN - ;input: ref to array and DFN - ;;return: array of VALUES in ACKQA(), ACKQE if an error was found - ;This routine is used by RPC ACKQAUD2 for the E/E data only - NOT for the display - ;new ACKQA(1)=BGN^ACKQRMI^DFNname^DFNssn^err^DFNdob^tester^SignDate^ExamDate^Vet^DFNType^AGE - ;ACKQA(ctr)=pcs in rest of counter nodes. - ; 1=Xvalue - ; 2=ear[L,R] - ; 3= - ; 4=iairY - ; 5=iairMask[0-6] - ; 6=iairMaskL - ; 7=iboneY - ; 8=iboneMask[0-1] - ; 9=iboneMaskL - ; 10=IAR - ; 11=CAR - ; 12=fairY - ; 13=fairMask[0-6] - ; 14=fairMaskL - ; 15=fboneY - ; 16=fboneMask[0-1] - ; 17=fboneMaskL - ; 18=AR DECAY - ; 19=HALF LF - ;was "DDCINFO"_U_SN_U_SU_U_SR_U_RMI_U_SSN_U_SD_U_VT - ;ACKQA(26)="DDCINFO"_U_STANUM_U_USRNM_U_USRSER_U_ACKQRMI_U_?SC%_U_?SigDt_U_VisitTyp - ;will return to the Delphi app as subscripted array - ;subscripts: 1(gen), 2-13(R), 14-25(L), 26(gen) - ;WORD TESTING MISSING YET - ;MCL & UCL & SSN, freq avg's - ;R & L reliability - ;REF SRC, ELIG STATUS -START(ACKQA,DFN) ; - K ACKQE - ;ACKQN is a number counter, S0 is a node holder - ;ACKQRMPF is the # of audiograms = 1 for transfer - ;ACKQE is an error holder - ;ACKQDATE hold dates, ACKQ1IEN holds the entry number - I '$G(DFN) D G END - .S ACKQE="**ERROR** Must have a DFN to run routine RMPFRPC2 " - I '$D(^ACK(509850.9,0)) D G END - .S ACKQE="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available" - ;look up DFN in file - I '$D(^ACK(509850.9,"DFN",DFN)) D G END - .S ACKQE="**ERROR** patient not in audiogram file" - ;determine if 1 or 2 audiograms - set flag - S ACKQDATE="A",ACKQ1IEN="" -S1 S ACKQDATE=$O(^ACK(509850.9,"DFN",DFN,ACKQDATE),-1) - ;set up array for latest one in file - I 'ACKQDATE D G END - .S ACKQE="**ERROR** No current audiograms for patient in file" - ;W !,"Last Audiogram Date: ",ACKQDATE - S ACKQ1IEN=0 -S2 S ACKQ1IEN=$O(^ACK(509850.9,"DFN",DFN,ACKQDATE,ACKQ1IEN)) - I 'ACKQ1IEN D G S1 - .S ACKQE="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQDATE) - ;W !,"Entry number found: ",ACKQ1IEN - I '$D(^ACK(509850.9,ACKQ1IEN,0)) D G S1 - .S ACKQE="**ERROR** Node missing in file for this visit" - G EN2 -EN(ACKQA,ACKQ1IEN,DFN) ;entry point called from ACKQAG03 for data transmission -EN2 ;entry from S2 to skip EN - K ACKQE N SSN,SD,X,NM,DOB,AGE F I=1:1:25 S ACKQA(I)="" - S ACKQA(1)=0,ACKQN=0 - S S0=$G(^ACK(509850.9,ACKQ1IEN,0)) - I $P(S0,U,2)'=DFN D G END ;already checked in calling routine - .S ACKQE="***URGENT AUDIOGRAM FILE ERROR*** wrong DFN in Cross Reference or record: "_DFN - ;new ACKQA(1)=BGN^ACKQRMI^DFNname^DFNssn^err^DFNdob^tester^SignDate^ExamDate^Vet^DFNType - S SD=$P(S0,U,1) ;DATE SEEN - S AGE=$P(S0,U,5) - S ACKQA(1)="BGN"_U_ACKQ1IEN - D DEM^VADPT I $G(VAERR) D G END - .S ACKQE="***UNABLE TO ACCESS PATIENT DEMOGRAPHICS***" - D ELIG^VADPT I $G(VAERR) D G END - .S ACKQE="***UNABLE TO ACCESS PATIENT ELIGIBILITY***" - S NM=VADM(1),NM=$E(NM,1,30),SSN=$P(VADM(2),U,1),DOB=$P(VADM(3),U,1) - S $P(ACKQA(1),U,3)=NM - S $P(ACKQA(1),U,4)=SSN - S $P(ACKQA(1),U,6)=DOB - ;5th pc is error msg, if any - I $P(S0,U,3) D - .S Y=$P(S0,U,3),X=$$TITLE^ACKQAG01(Y),X=$E($P(X,U,1),1,30) - .S $P(ACKQA(1),U,7)=X ;tester name - E S $P(ACKQA(1),U,7)="Unknown" ;tester - S $P(ACKQA(1),U,8)=$P(S0,U,9) ;date signed - S $P(ACKQA(1),U,9)=SD ;FM exam date - S $P(ACKQA(1),U,10)=$S(VAEL(4):"Y",1:"N") ;vet Y/N - S $P(ACKQA(1),U,11)=$P(VAEL(6),U,2) ;DFN Type - S $P(ACKQA(1),U,12)=AGE - D GETDATA(ACKQ1IEN) ;sets up array of test results -END ;if errors, then handle errors and stop - S:'$D(ACKQA(1)) ACKQA(1)=0 - I $G(ACKQE)'="" D D WRTERR ;5th pc of 0 node is FOR err msg - .F I=2:1:25 S ACKQA(I)="" - K ACKQE,ACKQDATE,S0,VADM,VAEL,I - Q - ; -GETDATA(ACKQRMI) ; - ;input: entry number in the Audiometic Exam Data file (ACKQRMI) - ;output: set up rest of array ACKQA() subscripts 2-25 - N ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQA1L,ACKQA2L ;air initial & repeat values, air tags initial & repeat, air Mask Levels - N ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQB1L,ACKQB2L ;bone initial & repeat values, bone masking init & repeat - N P,P1,S0 ;P is the piece of the air nodes, P1 is the piece of the bone nodes, S0 is a node holder - N X ;X is the Hz - N ACKQN S ACKQN=1 ;counter subscript for array - F P=1:1:12 D ;START R ear Air - .S ACKQN=ACKQN+1 - .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"") - .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"") - .S ACKQA(ACKQN)=X_U_"R"_U_"" ;X^ear^ien^Y - .S ACKQA1=$P($G(^ACK(509850.9,ACKQRMI,10)),U,P) ;init Y val - .S ACKQA1T=$P($G(^ACK(509850.9,ACKQRMI,11)),U,P) ;init tag - .S ACKQA1L=$P($G(^ACK(509850.9,ACKQRMI,50)),U,P) ;init tag level - .S ACKQA2=$P($G(^ACK(509850.9,ACKQRMI,20)),U,P) ;repeat val - .S ACKQA2T=$P($G(^ACK(509850.9,ACKQRMI,21)),U,P) ;repeat tag - .S ACKQA2L=$P($G(^ACK(509850.9,ACKQRMI,51)),U,P) ;repeat tag level - .S $P(ACKQA(ACKQN),U,4)=ACKQA1,$P(ACKQA(ACKQN),U,5)=ACKQA1T ;default - .S $P(ACKQA(ACKQN),U,6)=ACKQA1L,$P(ACKQA(ACKQN),U,12)=ACKQA2 - .S $P(ACKQA(ACKQN),U,13)=ACKQA2T,$P(ACKQA(ACKQN),U,14)=ACKQA2L - .; R bone conduction - .I X>125,X<7000 D - ..S P1=P-1 ;125 not a bone reading so pc's 1 less - ..S ACKQB1=$P($G(^ACK(509850.9,ACKQRMI,70)),U,P1) ;init bone - ..S ACKQB1T=$P($G(^ACK(509850.9,ACKQRMI,71)),U,P1) ;init bone TAG - ..S ACKQB1L=$P($G(^ACK(509850.9,ACKQRMI,90)),U,P1) ;init bone level - ..S ACKQB2=$P($G(^ACK(509850.9,ACKQRMI,75)),U,P1) ;repeat bone - ..S ACKQB2T=$P($G(^ACK(509850.9,ACKQRMI,76)),U,P1) ;repeat bone TAG - ..S ACKQB2L=$P($G(^ACK(509850.9,ACKQRMI,91)),U,P1) ;repeat bone mask - ..S $P(ACKQA(ACKQN),U,7)=ACKQB1,$P(ACKQA(ACKQN),U,8)=ACKQB1T - ..S $P(ACKQA(ACKQN),U,9)=ACKQB1L,$P(ACKQA(ACKQN),U,15)=ACKQB2 - ..S $P(ACKQA(ACKQN),U,16)=ACKQB2T,$P(ACKQA(ACKQN),U,17)=ACKQB2L - .;IAR/CAR AR-DECAY AR-HALFLIFE - .S S0=$G(^ACK(509850.9,ACKQRMI,120)) - .I (X=500) D - ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,4) - ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,8) - ..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,12) - ..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,14) - .I (X=1000) D - ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,5) - ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,9) - ..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,13) - ..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,15) - .I (X=2000) D - ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,6) - ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,10) - .I (X=4000) D - ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,7) - ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,11) - ; - F P=1:1:12 D ;start L ear air - .S ACKQN=ACKQN+1 ;counter subscript for array - .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,1:"") - .S:X="" X=$S(P=7:2000,P=8:3000,P=9:4000,P=10:6000,P=11:8000,1:12000) - .S ACKQA(ACKQN)=X_U_"L"_U_"" ; X^ear^IEN^Y - .S ACKQA1=$P($G(^ACK(509850.9,ACKQRMI,30)),U,P) ;initial value - .S ACKQA1T=$P($G(^ACK(509850.9,ACKQRMI,31)),U,P) ;init tag - .S ACKQA1L=$P($G(^ACK(509850.9,ACKQRMI,60)),U,P) ;init level - .S ACKQA2=$P($G(^ACK(509850.9,ACKQRMI,40)),U,P) ;repeat val - .S ACKQA2T=$P($G(^ACK(509850.9,ACKQRMI,41)),U,P) ;repeat tag - .S ACKQA2L=$P($G(^ACK(509850.9,ACKQRMI,61)),U,P) ;repeat level - .S $P(ACKQA(ACKQN),U,4)=ACKQA1,$P(ACKQA(ACKQN),U,5)=ACKQA1T ;defaults - .S $P(ACKQA(ACKQN),U,6)=ACKQA1L,$P(ACKQA(ACKQN),U,12)=ACKQA2 - .S $P(ACKQA(ACKQN),U,13)=ACKQA2T,$P(ACKQA(ACKQN),U,14)=ACKQA2L - .;L ear bone conduction - .I X>125,X<7000 D - ..S P1=P-1 ;125 not a bone reading so pc's 1 less - ..S ACKQB1=$P($G(^ACK(509850.9,ACKQRMI,80)),U,P1) ;init val - ..S ACKQB1T=$P($G(^ACK(509850.9,ACKQRMI,81)),U,P1) ;init tag - ..S ACKQB1L=$P($G(^ACK(509850.9,ACKQRMI,100)),U,P1) ;init mask level - ..S ACKQB2=$P($G(^ACK(509850.9,ACKQRMI,85)),U,P1) ;repeat val - ..S ACKQB2T=$P($G(^ACK(509850.9,ACKQRMI,86)),U,P1) ;repeat tag - ..S ACKQB2L=$P($G(^ACK(509850.9,ACKQRMI,101)),U,P1) ;repeat mask level - ..S $P(ACKQA(ACKQN),U,7)=ACKQB1,$P(ACKQA(ACKQN),U,8)=ACKQB1T ;default - ..S $P(ACKQA(ACKQN),U,9)=ACKQB1L,$P(ACKQA(ACKQN),U,15)=ACKQB2 - ..S $P(ACKQA(ACKQN),U,16)=ACKQB2T,$P(ACKQA(ACKQN),U,17)=ACKQB2L - .; IAR/CAR AR-DECAY AR-HALFLIFE - .S S0=$G(^ACK(509850.9,ACKQRMI,121)) - .I (X=500) D - ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,4) - ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,8) - ..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,12) - ..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,14) - .I (X=1000) D - ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,5) - ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,9) - ..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,13) - ..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,15) - .I (X=2000) D - ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,6) - ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,10) - .I (X=4000) D - ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,7) - ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,11) - Q - ; -WRTERR ; - I $L($G(ACKQE)) D - .S $P(ACKQA(1),U,5)=ACKQE - Q diff -auBN ./r1/ACKQAG05.m ./r2/r/ACKQAG05.m --- ./r1/ACKQAG05.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQAG05.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,28 +0,0 @@ -ACKQAG05 ;DDC/PJU - UTILITY USED BY ACKQAG03 - TRANSMISSION ;11/01/02 - ;;3.0;QUASAR AUDIOMETRIC MODULE;**3**;4/01/03 - ; -ACKEXIST() ;returns 1 if 509850.9 exists, else 0 - N ACKQANS - I $D(^ACK(509850.9)),$O(^ACK(509850.9,0)) S ACKQANS=1 - E S ACKQANS=0 -ENDA Q ACKQANS - ; -DFNIN(DFN) ;input DFN of patient - ;return last entry in 509850.9 for DFN or 0 if none - N ACKQANS,ACKQI,ACKQL - S ACKQANS=0 - I $D(^ACK(509850.9,"DFN",DFN)) D - .S ACKQL="A" - .S ACKQL=$O(^ACK(509850.9,"DFN",DFN,ACKQL),-1) Q:'ACKQL ;last date - .S ACKQI=0 - .S ACKQI=$O(^ACK(509850.9,"DFN",DFN,ACKQL,ACKQI)) Q:'ACKQI ;entry - .I ACKQI>0 I $G(^ACK(509850.9,ACKQI,0))'="" S ACKQANS=ACKQI -ENDD Q ACKQANS - ; -NEWMSG() ;return entry in ^XMB(3.9 ;checked - ; requires DUZ, sets up XMDUZ, XMSUB - ;outputs XMZ - S XMSUB="AUDIOGRAM DATA TRANSMISSION",XMDUZ=DUZ - S XMY("S.RMROES3@DDC.VA.GOV")="" - D XMZ^XMA2 ;returns XMZ - Q XMZ diff -auBN ./r1/ACKQAG06.m ./r2/r/ACKQAG06.m --- ./r1/ACKQAG06.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQAG06.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,169 +0,0 @@ -ACKQAG06 ;DDC/PJU - AUDIOGRAM UTILITY FOR ACKQAG01 ;11/01/02 - ;;3.0;QUASAR AUDIOMETRIC MODULE;**3**;11/01/02 -GETDATA(ACKQI,ACKI) ;called from ACKQAG01- Puts values in ACKQARR() - ;input the entry number in the Audiometic Exam Data file (ACKQI) - ;and current return array subscript value by reference(.ACKI) - ;ACKQA1=air initial threshold - ;ACKQA1T=air initial tag - ;ACKQA1L=air initial level - ;ACKQA2=air repeat threshold - ;ACKQA2T=air repeat tag - ;ACKQA2L=air repeat level - ;ACKQB1=bone initial threshold - ;ACKQB1T=bone initial tag - ;ACKQB1L=bone initial level - ;ACKQB2=bone repeat threshold - ;ACKQB2T=bone repeat tag - ;ACKQB2L=bone repeat level - ;P=piece of the air nodes, P1=piece of the bone nodes - ;SB=Bone node, X is the Hz reading - N ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQA1L,ACKQA2L - N ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQB1L,ACKQB2L - N I,P,P1,S0,SB,X,X1 -RA F P=1:1:12 D ;R ear Air - .S (ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQA1L,ACKQA2L,ACKQB1L,ACKQB2L)="" - .S ACKI=ACKI+1 ;counter subscript for array - .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"") - .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"") - .S ACKQARR(ACKI)=X_U_ACKQI_U_"R"_U ; - .S ACKQA1=$P($G(^ACK(509850.9,ACKQI,10)),U,P) ;init val - .S ACKQA2=$P($G(^ACK(509850.9,ACKQI,20)),U,P) ;retest val - .S ACKQA1T=$P($G(^ACK(509850.9,ACKQI,11)),U,P) ;init tag - .S:ACKQA1T="" ACKQA1T=0 - .S ACKQA1L=$P($G(^ACK(509850.9,ACKQI,50)),U,P) ;init level - .S ACKQA2T=$P($G(^ACK(509850.9,ACKQI,21)),U,P) ;final tag - .S:ACKQA2T="" ACKQA2T=0 - .S ACKQA2L=$P($G(^ACK(509850.9,ACKQI,51)),U,P) ;final level - .S $P(ACKQARR(ACKI),U,4)=ACKQA1,$P(ACKQARR(ACKI),U,5)=0,$P(ACKQARR(ACKI),U,6)="" ;default w/o masking - .D LOGIC(ACKQA1,ACKQA1T,ACKQA2,ACKQA2T,"A",ACKQA1L,ACKQA2L) ;Air Conduction - .; -RB .I X>125,X<7000 D ;R bone conduction - ..S P1=P-1 ;125 not a bone reading so pc's 1 less - ..S ACKQB1=$P($G(^ACK(509850.9,ACKQI,70)),U,P1) ;init bone - ..S ACKQB2=$P($G(^ACK(509850.9,ACKQI,75)),U,P1) ;retest bone - ..S ACKQB1T=$P($G(^ACK(509850.9,ACKQI,71)),U,P1) ;init bone mask - ..S:ACKQB1T="" ACKQB1T=0 - ..S ACKQB1L=$P($G(^ACK(509850.9,ACKQI,90)),U,P1) ;init bone level - ..S ACKQB2T=$P($G(^ACK(509850.9,ACKQI,76)),U,P1) ;final bone mask - ..S:ACKQB2T="" ACKQB2T=0 - ..S ACKQB2L=$P($G(^ACK(509850.9,ACKQI,91)),U,P1) ;final bone level - ..S $P(ACKQARR(ACKI),U,7)=ACKQB1,$P(ACKQARR(ACKI),U,8)=0,$P(ACKQARR(ACKI),U,9)="" ;default - ..D LOGIC(ACKQB1,ACKQB1T,ACKQB2,ACKQB2T,"B",ACKQB1L,ACKQB2L) ;bone conduction rules -RIAR .;IAR R - .S SB=$G(^ACK(509850.9,ACKQI,120)) - .I (X=500) D - ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,4) - .E I (X=1000) D - ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,5) - .E I (X=2000) D - ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,6) - .E I (X=4000) D - ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,7) -RCAR .;CAR R - .S SB=$G(^ACK(509850.9,ACKQI,121)) - .I (X=500) D - ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,8) - .E I (X=1000) D - ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,9) - .E I (X=2000) D - ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,10) - .E I (X=4000) D - ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,11) - ; -LA F P=1:1:12 D ;L ear air - .S (ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQA1L,ACKQA2L,ACKQB1L,ACKQB2L)="" - .S ACKI=ACKI+1 ;counter subscript for array - .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,1:"") - .S:X="" X=$S(P=7:2000,P=8:3000,P=9:4000,P=10:6000,P=11:8000,1:12000) - .S ACKQARR(ACKI)=X_U_ACKQI_U_"L"_U - .S ACKQA1=$P($G(^ACK(509850.9,ACKQI,30)),U,P) ;initial read air - .S ACKQA2=$P($G(^ACK(509850.9,ACKQI,40)),U,P) ;retest val - .S ACKQA1T=$P($G(^ACK(509850.9,ACKQI,31)),U,P) ;init tag - .S:ACKQA1T="" ACKQA1T=0 - .S ACKQA1L=$P($G(^ACK(509850.9,ACKQI,60)),U,P) ;init level - .S ACKQA2T=$P($G(^ACK(509850.9,ACKQI,41)),U,P) ;final tag - .S:ACKQA2T="" ACKQA2T=0 - .S ACKQA2L=$P($G(^ACK(509850.9,ACKQI,61)),U,P) ;final level - .S $P(ACKQARR(ACKI),U,4)=ACKQA1,$P(ACKQARR(ACKI),U,5)=0,$P(ACKQARR(ACKI),U,6)="" ;default - .D LOGIC(ACKQA1,ACKQA1T,ACKQA2,ACKQA2T,"A",ACKQA1L,ACKQA2L) ;Air Conduction - .;L bone conduction -LB .I X>125,X<7000 D - ..S P1=P-1 ;125 not a bone reading so pc's 1 less - ..S ACKQB1=$P($G(^ACK(509850.9,ACKQI,80)),U,P1) - ..S ACKQB2=$P($G(^ACK(509850.9,ACKQI,85)),U,P1) ;retest val - ..S ACKQB1T=$P($G(^ACK(509850.9,ACKQI,81)),U,P1) ;init tag - ..S:ACKQB1T="" ACKQB1T=0 - ..S ACKQB1L=$P($G(^ACK(509850.9,ACKQI,100)),U,P1) ;init level - ..S ACKQB2T=$P($G(^ACK(509850.9,ACKQI,86)),U,P1) ;final tag - ..S:ACKQB2T="" ACKQB2T=0 - ..S ACKQB2L=$P($G(^ACK(509850.9,ACKQI,101)),U,P1) ;final level - ..S $P(ACKQARR(ACKI),U,7)=ACKQB1,$P(ACKQARR(ACKI),U,8)=0,$P(ACKQARR(ACKI),U,9)="" ;default - ..D LOGIC(ACKQB1,ACKQB1T,ACKQB2,ACKQB2T,"B",ACKQB1L,ACKQB2L) ;bone conduction -LIAR .;IAR L - .S SB=$G(^ACK(509850.9,ACKQI,121)) - .I (X=500) D - ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,4) - .I (X=1000) D - ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,5) - .I (X=2000) D - ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,6) - .I (X=4000) D - ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,7) -LCAR .;CAR L - .S SB=$G(^ACK(509850.9,ACKQI,120)) - .I (X=500) D - ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,8) - .I (X=1000) D - ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,9) - .I (X=2000) D - ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,10) - .I (X=4000) D - ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,11) -SPCH ;next lines are only done 1 time for each table (2364) - S ACKI=ACKI+1 ;first 10 pc's of 25&51 nodes are word% - S S0=$G(^ACK(509850.9,ACKQI,110)) D ;R speech - .F I=1:1:5 S $P(ACKQARR(ACKI),U,I)=$P(S0,U,(4+(5*(I-1)))) - S S0=$G(^ACK(509850.9,ACKQI,111)) D ;L Speech - .F I=1:1:5 D - ..S J=I+5 S $P(ACKQARR(ACKI),U,J)=$P(S0,U,(4+(5*(I-1)))) - S S0=$G(^ACK(509850.9,ACKQI,115)) - S $P(ACKQARR(ACKI),U,11)=$P(S0,U,9),$P(ACKQARR(ACKI),U,12)=$P(S0,U,11) ;R MAX & PIPB - S $P(ACKQARR(ACKI),U,14)=$P(S0,U,12),$P(ACKQARR(ACKI),U,15)=$P(S0,U,14) ;L MAX & PIPB -SRT ;next section lines go in array nodes 24 and 50 only - S $P(ACKQARR(ACKI-1),U,31)=$P(S0,U,1) ;SRT R1 - S $P(ACKQARR(ACKI-1),U,32)=$P(S0,U,2) ;SRT R2 - S $P(ACKQARR(ACKI-1),U,33)=$P(S0,U,5) ;SRT L1 - S $P(ACKQARR(ACKI-1),U,34)=$P(S0,U,6) ;SRT L2 - S X=$P(S0,U,3) ;R init SRT Mask Lev - S X1=$P(S0,U,4) ;R final SRT Mask Lev - S $P(ACKQARR(ACKI-1),U,35)=$S((X&'X1):X,('X&X1):X1,(X&X1&(X0 S @ACKAPI@("DX/PL",1,"PRIMARY")=1 ; ; -----------------procedures---------------- @@ -196,7 +195,7 @@ . S ACKCPT=@ACKFDA@(509850.61,ACKIEN,.01,"I") ; CPT IEN . S ACKVOL=@ACKFDA@(509850.61,ACKIEN,.03,"I") ; Volume . S ACKPROCP=@ACKFDA@(509850.61,ACKIEN,.05,"I") ; Provider - . I ACKPROCP'="" S ACKPROCP=$$CONVERT1^ACKQUTL4(ACKPROCP) ; Convert from QSR to Vista + . I ACKPROCP'="" S ACKPROCP=$$CONVERT1^ACKQUTL4(ACKPROCP) ; Covert fom QSR to Vista . S ACKCT=ACKCT+1,@ACKAPI@("PROCEDURE",ACKCT,"PROCEDURE")=ACKCPT . S @ACKAPI@("PROCEDURE",ACKCT,"QTY")=$S(ACKVOL:ACKVOL,1:1) . I ACKPROCP'="" S @ACKAPI@("PROCEDURE",ACKCT,"ENC PROVIDER")=ACKPROCP diff -auBN ./r1/ACKQR2.m ./r2/r/ACKQR2.m --- ./r1/ACKQR2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQR2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ ACKQR2 ;AUG/JLTP BIR/PTD HCIOFO/AG -Statistics by Procedure ; [ 12/07/95 9:52 AM ] - ;;3.0;QUASAR;**1,8**;Feb 11, 2000 + ;;3.0;QUASAR;**1**;Feb 11, 2000 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. ; OPTN W @IOF,!,"This option produces a report listing clinic visits for a date range" @@ -96,9 +96,8 @@ Q GETCPT(ACKCPTN) ; Get Proc code data & put in ^TMP N ACKTMP,ACKCPT S ACKTMP=$NA(^TMP("ACKQR2",$J,"CPT",1)) - D GETS^DIQ(81,ACKCPTN_",",".01","",ACKTMP,"ACKMSG") + D GETS^DIQ(81,ACKCPTN_",",".01;2","",ACKTMP,"ACKMSG") S ACKCPT=^TMP("ACKQR2",$J,"CPT",1,81,ACKCPTN_",",.01) - S ^TMP("ACKQR2",$J,"CPT",1,81,ACKCPTN_",",2)=$$PROCTXT^ACKQUTL8(ACKCPTN,"") S ^TMP("ACKQR2",$J,"CPT",2,ACKCPT)=ACKCPTN Q CPTDESC(ACKCPT) ; Get Proc desc diff -auBN ./r1/ACKQR3.m ./r2/r/ACKQR3.m --- ./r1/ACKQR3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQR3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ ACKQR3 ;AUG/JLTP BIR/PTD HCIOFO/AG-Visits by Diagnosis ; [ 03/27/99 10:02 AM ] - ;;3.0;QUASAR;**8**;Feb 11, 2000 + ;;3.0;QUASAR;;Feb 11, 2000 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. ; OPTN ;Introduce option. @@ -92,12 +92,10 @@ . S ACKT2(ACKSORT)=$G(ACKT2(ACKSORT))+1,ACKT2=$G(ACKT2)+1 Q GETDIAG(ACKICDN) ; get Diagnosis data and place in ^TMP - N ACKTMP,ACKMSG,ACKICD9,ACKQDTXT + N ACKTMP,ACKMSG,ACKICD9 S ACKTMP=$NA(^TMP("ACKQR3",$J,"ICD9",1)) - D GETS^DIQ(80,ACKICDN_",",".01","",ACKTMP,"ACKMSG") + D GETS^DIQ(80,ACKICDN_",",".01;3","",ACKTMP,"ACKMSG") S ACKICD9=^TMP("ACKQR3",$J,"ICD9",1,80,ACKICDN_",",.01) - S ACKQDTXT=$$DIAGTXT^ACKQUTL8(ACKICDN,"") - S ^TMP("ACKQR3",$J,"ICD9",1,80,ACKICDN_",",3)=ACKQDTXT S ^TMP("ACKQR3",$J,"ICD9",2,ACKICD9)=ACKICDN Q ICDDESC(ACKICD9) ; get the description of an ICD9 from the ^TMP file diff -auBN ./r1/ACKQR4.m ./r2/r/ACKQR4.m --- ./r1/ACKQR4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQR4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ ACKQR4 ;AUG/JLTP BIR/PTD-Procedure Cost Statistics ; [ 12/07/95 9:52 AM ] - ;;3.0;QUASAR;**8**;Feb 11, 2000 + ;;3.0;QUASAR;;Feb 11, 2000 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. OPTN ; Introduce option. W @IOF,!,"This option produces a report of all CPT-4 codes used within a selected date",!,"range and their associated costs.",! @@ -17,10 +17,7 @@ U IO D SORT,PRINT G EXIT SORT ; - N ACKTME - K ^TMP("ACKQR4",$J) S ACKPG=0 - D NOW^%DTC - S ACKXDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKTME=$P(%,".",1) + K ^TMP("ACKQR4",$J) S ACKPG=0 D NOW^%DTC S ACKXDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%) F ACKD=ACKBD:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKED) S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D .S ACKHDR5=^ACK(509850.6,ACKV,5) .; get division and make sure it was selected @@ -29,11 +26,15 @@ .I ACKCSC'="A",ACKCSC'="AT",ACKCSC'="S",ACKCSC'="ST" Q .S ACKP=0 F S ACKP=$O(^ACK(509850.6,ACKV,3,ACKP)) Q:'ACKP D ..S ACKPD=^ACK(509850.6,ACKV,3,ACKP,0),ACKPP=+ACKPD - ..S ACKPN=$P($G(^ICPT(ACKPP,0)),U) Q:ACKPN="" S ACKPDSC=$$PROCTXT^ACKQUTL8(ACKPP,ACKTME) + ..S ACKPN=$P($G(^ICPT(ACKPP,0)),U) Q:ACKPN="" S ACKPDSC=$P(^(0),U,2) ..S ACKPC=$P(^ACK(509850.4,ACKPP,0),U,6) ..; Get the Volume of times the Procedure was administered ..S ACKVOL=$P(ACKPD,U,3) I ACKVOL="" S ACKVOL=1 - ..S ACKM=0 + ..; Has the procedure ben allocated a Modifier + ..S ACKM=$P(ACKPD,U,2) S:ACKM="" ACKM=0 + ..I ACKM]0 S ACKMP=$O(^ACK(509850.4,ACKPP,1,"B",ACKM,0)) D + ...I 'ACKMP S ACKPDSC="" Q + ...S ACKPDSC=$P(^ACK(509850.4,ACKPP,1,ACKMP,0),U,2),ACKPC=$P(^(0),U,3) ..S:'$D(^TMP("ACKQR4",$J,0,ACKVDIV,ACKPP,ACKM)) ^(ACKM)=ACKPN_U_ACKPDSC_U_ACKPC ..S ^TMP("ACKQR4",$J,1,ACKVDIV,ACKCSC,ACKPP,ACKM)=$G(^TMP("ACKQR4",$J,1,ACKVDIV,ACKCSC,ACKPP,ACKM))+ACKVOL K ACKVDIV diff -auBN ./r1/ACKQTE10.m ./r2/r/ACKQTE10.m --- ./r1/ACKQTE10.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE10.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE10 ; ;07/15/03 +ACKQTE10 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,D0,3,",DIC=DIE,DP=509850.61,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,D0,3,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(6)=% S %=$P(%Z,U,4) S:%]"" DE(8)=% @@ -60,14 +60,14 @@ X "D SEND^ACKQUTL5(DA(1))" S X=DE(1),DIC=DIE X "D KILLEC^ACKQUTL5(DA,DA(1))" -C1S S X="" G:DG(DQ)=X C1F1 K DB +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ^ACK(509850.6,DA(1),3,"B",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" S X=DG(DQ),DIC=DIE ; -C1F1 Q + Q X1 S DIC("S")="I $D(ACKCSC),'$G(ACKEVENT),($P(^(0),U,2)[$E(ACKCSC)),($P(^(0),U,4)=1)" S DIC("W")="" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; @@ -98,12 +98,12 @@ X "D SEND^ACKQUTL5(DA(1))" S X=DE(6),DIC=DIE X "D CPVOLPRV^ACKQUTL5(DA,DA(1),X,""V"",""D"")" -C6S S X="" G:DG(DQ)=X C6F1 K DB +C6S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" S X=DG(DQ),DIC=DIE X "D CPVOLPRV^ACKQUTL5(DA,DA(1),X,""V"",""S"")" -C6F1 Q + Q X6 K:+X'=X!(X>99)!(X<1)!(X?.E1"."1N.N) X Q ; @@ -119,12 +119,12 @@ X "D SEND^ACKQUTL5(DA(1))" S X=DE(8),DIC=DIE X "D CPVOLPRV^ACKQUTL5(DA,DA(1),X,""P"",""D"")" -C8S S X="" G:DG(DQ)=X C8F1 K DB +C8S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" S X=DG(DQ),DIC=DIE X "D CPVOLPRV^ACKQUTL5(DA,DA(1),X,""P"",""S"")" -C8F1 Q + Q X8 S DIC("S")="I $D(ACKVD) S ACKVALSC=$$STACT^ACKQUTL(+Y,ACKVD) I ACKVALSC=""0""!(ACKVALSC=""-6"")" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; diff -auBN ./r1/ACKQTE11.m ./r2/r/ACKQTE11.m --- ./r1/ACKQTE11.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE11.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE11 ; ;07/15/03 +ACKQTE11 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,D0,7,",DIC=DIE,DP=509850.615,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,D0,7,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(4)=% @@ -60,14 +60,14 @@ X "D SEND^ACKQUTL5(DA(1))" S X=DE(1),DIC=DIE X "D KILLCPT^ACKQUTL5(DA,DA(1))" -C1S S X="" G:DG(DQ)=X C1F1 K DB +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ^ACK(509850.6,DA(1),7,"B",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" S X=DG(DQ),DIC=DIE X "D SETCPT^ACKQUTL5(DA,DA(1),X)" -C1F1 Q + Q X1 S DIC("S")="I $D(ACKVD),$D(ACKCSC),$G(ACKEVENT),$$CHK^ACKQUTL5(+Y,ACKVD,ACKCSC)" S DIC("W")="W ?42,"" ""_$P(^EC(725,+Y,0),U,2)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; @@ -81,12 +81,12 @@ X "D SEND^ACKQUTL5(DA(1))" S X=DE(2),DIC=DIE X "D ECVOLPRV^ACKQUTL5(DA,DA(1),X,""V"",""D"")" -C2S S X="" G:DG(DQ)=X C2F1 K DB +C2S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" S X=DG(DQ),DIC=DIE X "D ECVOLPRV^ACKQUTL5(DA,DA(1),X,""V"",""S"")" -C2F1 Q + Q X2 K:+X'=X!(X>99)!(X<1)!(X?.E1"."1N.N) X Q ; @@ -102,12 +102,12 @@ X "D SEND^ACKQUTL5(DA(1))" S X=DE(4),DIC=DIE X "D ECVOLPRV^ACKQUTL5(DA,DA(1),X,""P"",""D"")" -C4S S X="" G:DG(DQ)=X C4F1 K DB +C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" S X=DG(DQ),DIC=DIE X "D ECVOLPRV^ACKQUTL5(DA,DA(1),X,""P"",""S"")" -C4F1 Q + Q X4 S DIC("S")="I $D(ACKVD) S ACKVALSC=$$STACT^ACKQUTL(+Y,ACKVD) I ACKVALSC=""0""!(ACKVALSC=""-6"")" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; diff -auBN ./r1/ACKQTE12.m ./r2/r/ACKQTE12.m --- ./r1/ACKQTE12.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE12.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE12 ; ;07/15/03 +ACKQTE12 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,D0,3,D1,1,",DIC=DIE,DP=509850.64,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,D0,3,D1,1,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% @@ -61,12 +61,12 @@ K ^ACK(509850.6,DA(2),3,DA(1),1,"B",$E(X,1,30),DA) S X=DE(2),DIC=DIE X "D SEND^ACKQUTL5(DA(2))" -C2S S X="" G:DG(DQ)=X C2F1 K DB +C2S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ^ACK(509850.6,DA(2),3,DA(1),1,"B",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(2))" -C2F1 Q + Q X2 S DIC("S")="D:'$D(ACKMOD(ACKPC)) MOD^ACKQUTL5 I $D(ACKMOD(ACKPC,Y))" D MODW^ACKQUTL5 D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; diff -auBN ./r1/ACKQTE1.m ./r2/r/ACKQTE1.m --- ./r1/ACKQTE1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE1 ; ;07/15/03 +ACKQTE1 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.2,",DIC=DIE,DP=509850.2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^ACK(509850.2,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(4)=% diff -auBN ./r1/ACKQTE2.m ./r2/r/ACKQTE2.m --- ./r1/ACKQTE2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,3 +1,3 @@ -ACKQTE2 ; ;07/15/03 +ACKQTE2 ; ;04/12/01 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACK(509850.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV D TRIGCP^ACKQUTL X ^DD(509850.6,2.5,1,1,1.4) diff -auBN ./r1/ACKQTE3.m ./r2/r/ACKQTE3.m --- ./r1/ACKQTE3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE3 ; ;07/15/03 +ACKQTE3 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,",DIC=DIE,DP=509850.6,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,8) S:%]"" DE(1)=% @@ -59,10 +59,10 @@ C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE K ^ACK(509850.6,"ALCP",$E(X,1,30),DA) -C1S S X="" G:DG(DQ)=X C1F1 K DB +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ^ACK(509850.6,"ALCP",$E(X,1,30),DA)="" -C1F1 Q + Q X1 Q 2 S DQ=3 ;@40 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 @@ -112,10 +112,10 @@ C14 G C14S:$D(DE(14))[0 K DB S X=DE(14),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C14S S X="" G:DG(DQ)=X C14F1 K DB +C14S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C14F1 Q + Q X14 S DIC("S")="I $D(ACKELDIS(Y))",DIC("W")="W """"" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; @@ -139,10 +139,10 @@ C19 G C19S:$D(DE(19))[0 K DB S X=DE(19),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C19S S X="" G:DG(DQ)=X C19F1 K DB +C19S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C19F1 Q + Q X19 Q 20 S DQ=21 ;@60 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 @@ -160,10 +160,10 @@ C23 G C23S:$D(DE(23))[0 K DB S X=DE(23),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C23S S X="" G:DG(DQ)=X C23F1 K DB +C23S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C23F1 Q + Q X23 Q 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X24 I ACKPCE'=1 S Y="@100" diff -auBN ./r1/ACKQTE4.m ./r2/r/ACKQTE4.m --- ./r1/ACKQTE4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE4 ; ;07/15/03 +ACKQTE4 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,D0,1,",DIC=DIE,DP=509850.63,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,D0,1,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% S %=$P(%Z,U,3) S:%]"" DE(8)=% S %=$P(%Z,U,4) S:%]"" DE(11)=% @@ -58,12 +58,12 @@ K ^ACK(509850.6,DA(1),1,"B",$E(X,1,30),DA) S X=DE(1),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" -C1S S X="" G:DG(DQ)=X C1F1 K DB +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ^ACK(509850.6,DA(1),1,"B",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" -C1F1 Q + Q X1 S DIC("S")="I $D(ACKCSC),($P(^(0),U,4)[$E(ACKCSC)),($P(^(0),U,6)=1)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; @@ -85,16 +85,16 @@ C5 G C5S:$D(DE(5))[0 K DB S X=DE(5),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" -C5S S X="" G:DG(DQ)=X C5F1 K DB +C5S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" -C5F1 Q + Q X5 I X=1,$$PRIMARY^ACKQASU5(DA(1),"") K X Q ; 6 S DQ=7 ;@45 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 I '$$PROB^ACKQUTL4(ACKPCE,ACKDIV)!(+$$PLIST^ACKQUTL6(ACKPAT,ACKDC)=2) S Y="@49" +X7 I '$$PROB^ACKQUTL4(ACKPCE,ACKDIV) S Y="@49" Q 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;3",DV="RS",DU="",DLB="Update PCE Problem List with Diag. code ?",DIFLD=.13 S DU="1:YES;0:NO;" @@ -106,7 +106,7 @@ X9 I X=0 S Y="@49" Q 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X10 I '$$PROB^ACKQUTL4(ACKPCE,ACKDIV)!(+$$PLIST^ACKQUTL6(ACKPAT,ACKDC)=2) S Y="@49" +X10 I '$$PROB^ACKQUTL4(ACKPCE,ACKDIV) S Y="@49" Q 11 S DW="0;4",DV="R*P509850.3'X",DU="",DLB="DIAGNOSIS PROVIDER",DIFLD=.14 S DE(DW)="C11^ACKQTE4" @@ -115,10 +115,10 @@ C11 G C11S:$D(DE(11))[0 K DB S X=DE(11),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" -C11S S X="" G:DG(DQ)=X C11F1 K DB +C11S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" -C11F1 Q + Q X11 S DIC("S")="I $D(ACKVD) S ACKVALSC=$$STACT^ACKQUTL(+Y,ACKVD) I ACKVALSC=""0""!(ACKVALSC=""-6"")" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; diff -auBN ./r1/ACKQTE5.m ./r2/r/ACKQTE5.m --- ./r1/ACKQTE5.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE5.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE5 ; ;07/15/03 +ACKQTE5 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,",DIC=DIE,DP=509850.6,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,DA,""))="" I $D(^(2)) S %Z=^(2) S %=$P(%Z,U,2) S:%]"" DE(18)=% S %=$P(%Z,U,9) S:%]"" DE(15)=% @@ -59,10 +59,10 @@ C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C1S S X="" G:DG(DQ)=X C1F1 K DB +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C1F1 Q + Q X1 Q 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X2 S ACKAO=$S(ACKAO=0:0,ACKSC'=1:ACKAO,X=1:2,1:1) @@ -83,10 +83,10 @@ C6 G C6S:$D(DE(6))[0 K DB S X=DE(6),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C6S S X="" G:DG(DQ)=X C6F1 K DB +C6S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C6F1 Q + Q X6 Q 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X7 S ACKRAD=$S(ACKRAD=0:0,ACKSC'=1:ACKRAD,X=1:2,1:1) @@ -107,10 +107,10 @@ C11 G C11S:$D(DE(11))[0 K DB S X=DE(11),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C11S S X="" G:DG(DQ)=X C11F1 K DB +C11S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C11F1 Q + Q X11 Q 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X12 S ACKENV=$S(ACKENV=0:0,ACKSC'=1:ACKENV,X=1:2,1:1) @@ -128,10 +128,10 @@ C15 G C15S:$D(DE(15))[0 K DB S X=DE(15),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C15S S X="" G:DG(DQ)=X C15F1 K DB +C15S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C15F1 Q + Q X15 Q 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X16 I '$$MST^ACKQUTL4(ACKPCE,ACKVD,ACKPAT) D CLEAR^ACKQUTL4(ACKVIEN,"90") @@ -150,14 +150,14 @@ S ACKCDR=+^ACK(509850,X,0),ACKMO=$E(^ACK(509850.6,DA,0),1,5)_"00" S:$D(^ACK(509850.6,"ATCDR",ACKMO,ACKCDR)) $P(^(ACKCDR),U)=^(ACKCDR)-1 K:$S($D(^(ACKCDR)):'^(ACKCDR),1:0) ^(ACKCDR) K ACKMO,ACKCDR S X=DE(18),DIC=DIE K ^ACK(509850.6,"ADCI",$E($P(^ACK(509850.6,DA,0),U),1,5)_"00",X,DA) -C18S S X="" G:DG(DQ)=X C18F1 K DB +C18S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ACKCAT=$E(^ACK(509850,X,0),1,2),ACKMO=$E(^ACK(509850.6,DA,0),1,5)_"00",$P(^(ACKCAT),U)=$S($D(^ACK(509850.6,"ATCAT",ACKMO,ACKCAT)):^(ACKCAT)+1,1:1) S X=DG(DQ),DIC=DIE S ACKCDR=+^ACK(509850,X,0),ACKMO=$E(^ACK(509850.6,DA,0),1,5)_"00",$P(^(ACKCDR),U)=$S($D(^ACK(509850.6,"ATCDR",ACKMO,ACKCDR)):^(ACKCDR)+1,1:1) K ACKMO,ACKCDR S X=DG(DQ),DIC=DIE S ^ACK(509850.6,"ADCI",$E($P(^ACK(509850.6,DA,0),U),1,5)_"00",X,DA)="" -C18F1 Q + Q X18 S DIC("S")="I $P(^(0),U,5)=1" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; diff -auBN ./r1/ACKQTE6.m ./r2/r/ACKQTE6.m --- ./r1/ACKQTE6.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE6.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE6 ; ;07/15/03 +ACKQTE6 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,",DIC=DIE,DP=509850.6,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,DA,""))="" I $D(^(4)) S %Z=^(4) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(4)=% S %=$P(%Z,U,3) S:%]"" DE(7)=% S %=$P(%Z,U,4) S:%]"" DE(10)=% S %=$P(%Z,U,5) S:%]"" DE(13)=% S %=$P(%Z,U,7) S:%]"" DE(16)=% S %=$P(%Z,U,8) S:%]"" DE(19)=% @@ -56,10 +56,10 @@ C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE S X1=^ACK(509850.6,DA,0) K ^ACK(509850.6,"AMD",+$P(X1,U,2),9999999-$P(X1,U),DA),X1 -C1S S X="" G:DG(DQ)=X C1F1 K DB +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S X1=^ACK(509850.6,DA,0) S:'$D(ACKNAMD) ^ACK(509850.6,"AMD",+$P(X1,U,2),9999999-$P(X1,U),DA)="" K X1 -C1F1 Q + Q X1 K:+X'=X!(X>105)!(X<-10)!(X?.E1"."1N.N) X Q ; diff -auBN ./r1/ACKQTE7.m ./r2/r/ACKQTE7.m --- ./r1/ACKQTE7.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE7.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE7 ; ;07/15/03 +ACKQTE7 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,",DIC=DIE,DP=509850.6,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,DA,""))="" I $D(^(2)) S %Z=^(2) S %=$P(%Z,U,3) S:%]"" DE(32)=% @@ -141,12 +141,12 @@ K ^ACK(509850.6,"ST",X,DA) S X=DE(32),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C32S S X="" G:DG(DQ)=X C32F1 K DB +C32S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ^ACK(509850.6,"ST",X,DA)=1 S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C32F1 Q + Q X32 S DIC("S")="I $D(ACKVD),'$$STACT^ACKQUTL(+Y,ACKVD)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; diff -auBN ./r1/ACKQTE8.m ./r2/r/ACKQTE8.m --- ./r1/ACKQTE8.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE8.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE8 ; ;07/15/03 +ACKQTE8 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,D0,2.7,",DIC=DIE,DP=509850.66,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,D0,2.7,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% @@ -60,14 +60,14 @@ K ^ACK(509850.6,"ST",X,DA(1)) S X=DE(1),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" -C1S S X="" G:DG(DQ)=X C1F1 K DB +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ^ACK(509850.6,DA(1),2.7,"B",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE S ^ACK(509850.6,"ST",X,DA(1))=2 S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA(1))" -C1F1 Q + Q X1 S DIC("S")="I $D(ACKVD) S ACKVALSC=$$STACT^ACKQUTL(+Y,ACKVD) I ACKVALSC=""0""!(ACKVALSC=""-6"")" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; diff -auBN ./r1/ACKQTE9.m ./r2/r/ACKQTE9.m --- ./r1/ACKQTE9.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE9.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE9 ; ;07/15/03 +ACKQTE9 ; ;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,",DIC=DIE,DP=509850.6,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,7) S:%]"" DE(17)=% @@ -60,12 +60,12 @@ K ^ACK(509850.6,"ST",X,DA) S X=DE(1),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C1S S X="" G:DG(DQ)=X C1F1 K DB +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S ^ACK(509850.6,"ST",X,DA)=3 S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C1F1 Q + Q X1 S DIC("S")="I $D(ACKVD),$$STACT^ACKQUTL(+Y,ACKVD)=-2" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; @@ -144,10 +144,10 @@ C22 G C22S:$D(DE(22))[0 K DB S X=DE(22),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACK(509850.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV D TRIGCP^ACKQUTL X ^DD(509850.6,4.17,1,1,2.4) -C22S S X="" G:DG(DQ)=X C22F1 K DB +C22S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACK(509850.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV D TRIGCP^ACKQUTL X ^DD(509850.6,4.17,1,1,1.4) -C22F1 Q + Q X22 Q 23 D:$D(DG)>9 F^DIE17,DE S DQ=23,DW="4;18",DV="D",DU="",DLB="DATE SIGNED",DIFLD=4.18 S X=DT diff -auBN ./r1/ACKQTE.m ./r2/r/ACKQTE.m --- ./r1/ACKQTE.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQTE.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -ACKQTE ; GENERATED FROM 'ACKQAS VISIT ENTRY' INPUT TEMPLATE(#1338), FILE 509850.6;07/15/03 +ACKQTE ; GENERATED FROM 'ACKQAS VISIT ENTRY' INPUT TEMPLATE(#1338), FILE 509850.6;04/12/01 D DE G BEGIN DE S DIE="^ACK(509850.6,",DIC=DIE,DP=509850.6,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ACK(509850.6,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(13)=% S %=$P(%Z,U,5) S:%]"" DE(18)=% @@ -87,12 +87,12 @@ X "D SEND^ACKQUTL5(DA)" S X=DE(10),DIC=DIE X "D KILLREF^ACKQUTL5(X,DA,""T"")" -C10S S X="" G:DG(DQ)=X C10F1 K DB +C10S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" S X=DG(DQ),DIC=DIE X "D SETREF^ACKQUTL5(X,DA,""T"")" -C10F1 Q + Q X10 K:$L(X)>8!($L(X)<1) X I $D(X) S X=$$DATACHEK^ACKQUTL6(X,DA) K:'X X I $D(X) I '$$DUPECHK^ACKQUTL6(X,DA,$G(ACKPAT)) S ACKITME=X K X I $D(X),X'?.ANP K X Q @@ -125,7 +125,7 @@ X "D KILLREF^ACKQUTL5(X,DA,""P"")" S X=DE(13),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C13S S X="" G:DG(DQ)=X C13F1 K DB +C13S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACK(509850.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(509850.6,1,1,1,1.1) X ^DD(509850.6,1,1,1,1.4) S X=DG(DQ),DIC=DIE @@ -142,7 +142,7 @@ X "D SETREF^ACKQUTL5(X,DA,""P"")" S X=DG(DQ),DIC=DIE X "D SEND^ACKQUTL5(DA)" -C13F1 Q + Q X13 Q 14 S DQ=15 ;@16 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 S I(0,0)=D0 S Y(1)=$S($D(^ACK(509850.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S D(0)=+X S X=$S(D(0)>0:D(0),1:"") @@ -161,9 +161,9 @@ C18 G C18S:$D(DE(18))[0 K DB S X=DE(18),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^ACK(509850.6,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV D TRIGCP^ACKQUTL X ^DD(509850.6,2.5,1,1,2.4) -C18S S X="" G:DG(DQ)=X C18F1 K DB +C18S S X="" Q:DG(DQ)=X K DB D ^ACKQTE2 -C18F1 Q + Q X18 Q 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X19 S ACKCP=X diff -auBN ./r1/ACKQUT1.m ./r2/r/ACKQUT1.m --- ./r1/ACKQUT1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQUT1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,42 +0,0 @@ -ACKQUT1 ;HCIOFO/BH-Quasar utilities routine ; 04/01/03 - ;;3.0;QUASAR;**6**;Feb 11, 2000 - ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. - ; -ACKCPT(CODE) ; Validate CPT code using today's date - ; - N ACKPARAM,DTE,X,Y - D NOW^%DTC S DTE=$P(%,".",1) - S ACKPARAM=$P($$CPT^ICPTCOD(CODE,DTE),"^",7) - I 'ACKPARAM D - . W !! - . W "The selected code is not valid for today's date.",!! - Q ACKPARAM - ; -ACKICD(CODE) ; Validate ICD code using today's date - ; - N ACKPARAM,DTE,X,Y - D NOW^%DTC S DTE=$P(%,".",1) - S ACKPARAM=$P($$ICDDX^ICDCODE(CODE,DTE),"^",10) - I 'ACKPARAM D - . W !! - . W "The selected code is not valid for today's date.",!! - ; - Q ACKPARAM - ; - ; -CPT(CODE,ACKVD,ACKCSC) ; screen for active CPT codes - N ACKPARAM - I $P(^ACK(509850.4,CODE,0),U,2)'[$E(ACKCSC) Q 0 - I $P(^ACK(509850.4,CODE,0),U,4)'=1 Q 0 - S ACKPARAM=$P($$CPT^ICPTCOD(CODE,ACKVD),"^",7) - Q ACKPARAM - ; - ; -ICD(CODE,ACKVD,ACKCSC) ; screen for active ICD codes - N ACKPARAM - I $P(^ACK(509850.1,CODE,0),U,4)'[$E(ACKCSC) Q 0 - I $P(^ACK(509850.1,CODE,0),U,6)'=1 Q 0 - S ACKPARAM=$P($$ICDDX^ICDCODE(CODE,ACKVD),"^",10) - Q ACKPARAM - ; - ; diff -auBN ./r1/ACKQUTL3.m ./r2/r/ACKQUTL3.m --- ./r1/ACKQUTL3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQUTL3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -ACKQUTL3 ;HCIOFO/AG - QUASAR Utility Routine ; 12/13/02 3:51pm - ;;3.0;QUASAR;**5**;Feb 11, 2000 +ACKQUTL3 ;HCIOFO/AG -QUASAR Utility Routine ; [ 04/25/96 10:03 ] + ;;3.0;QUASAR;;Feb 11, 2000 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. ; PCECHKV(ACKVIEN) ; is PCE Visit still same patient etc. @@ -24,7 +24,7 @@ ; points to. ; inputs:- ACKPCE - PCE Visit IEN (reqd) ; ACKDT - date of visit (reqd) (fileman internal) - ; ACKTM - time of visit (reqd) (qsr time .n[nnnnn]) + ; ACKTM - time of vsit (reqd) (qsr time .n[nnnnn]) ; ACKPAT - patient (reqd) ; ACKCLN - clinic (reqd) ; outputs:- string @@ -38,7 +38,7 @@ N PCEDTTM,PCEDT,PCETM,PCEPAT,PCECLN,ACKSTR K ^TMP("PXKENC",$J) ; - ; get the visit data from PCE (places it in ^TMP("PXKENC",$J) + ; get the visit data from PCE (places it in ^TMP("PXKENC",$j) D ENCEVENT^PXAPI(ACKPCE) S PCEDTTM=$P($G(^TMP("PXKENC",$J,ACKPCE,"VST",ACKPCE,0)),U,1) S PCEDT=PCEDTTM\1,PCETM=PCEDTTM#1 @@ -134,7 +134,7 @@ ; Inquiry option and the Delete Visit function. ; inputs:- ACKPAT - patient DFN ; ACKECHO - whether to display progress - N ACKTMP,ACKVIEN,ACKDT,ACKDT1,ACKIVDT,ACKDIEN,ACKICD,ACKARR + N ACKTMP,ACKVIEN,ACKDT,ACKIVDT,ACKDIEN,ACKICD,ACKARR ; I '+$G(ACKPAT) Q S ACKECHO=+$G(ACKECHO) @@ -152,8 +152,7 @@ . S ACKDIEN="" F S ACKDIEN=$O(@ACKTMP@(1,509850.63,ACKDIEN)) Q:ACKDIEN="" D . . I $P(ACKDIEN,",",2)'=ACKVIEN Q . . S ACKICD=@ACKTMP@(1,509850.63,ACKDIEN,.01,"I") - . . S ACKDT1=$G(@ACKTMP@(2,ACKICD)) - . . I ('ACKDT1)!(ACKDT1>ACKDT) S @ACKTMP@(2,ACKICD)=ACKDT + . . S @ACKTMP@(2,ACKICD,ACKDT)="" ; ICD list including date entered . . I ('ACKIVDT)!(ACKIVDT>ACKDT) S ACKIVDT=ACKDT ; earliest visit date ; ; update initial visit date for the patient @@ -173,17 +172,14 @@ I ACKECHO,$O(@ACKTMP@(2,""))="" D G PROBLISX . W !!,"No Diagnosis was found in the A&SP CLINIC VISIT file for this patient.",! ; - ; sort new diagnosis list by date - S ACKICD="" F S ACKICD=$O(@ACKTMP@(2,ACKICD)) Q:ACKICD="" D - . S ACKDT=@ACKTMP@(2,ACKICD) S @ACKTMP@(3,ACKDT,ACKICD)="" - ; - ; update diagnosis history + ; update diagnosis history I ACKECHO W !!,"Now updating diagnostic history.",! - S (ACKDT,ACKICD)="" F S ACKDT=$O(@ACKTMP@(3,ACKDT)) Q:ACKDT="" F S ACKICD=$O(@ACKTMP@(3,ACKDT,ACKICD)) Q:ACKICD="" D - . K ACKARR - . S ACKARR(509850.22,"?+1,"_ACKPAT_",",.01)=ACKICD - . S ACKARR(509850.22,"?+1,"_ACKPAT_",",1)=ACKDT - . D UPDATE^DIE("","ACKARR","","") + S ACKICD="" F S ACKICD=$O(@ACKTMP@(2,ACKICD)) Q:ACKICD="" D + . S ACKDT="" F S ACKDT=$O(@ACKTMP@(2,ACKICD,ACKDT)) Q:ACKDT="" D + . . K ACKARR + . . S ACKARR(509850.22,"+1,"_ACKPAT_",",.01)=ACKICD + . . S ACKARR(509850.22,"+1,"_ACKPAT_",",1)=ACKDT + . . D UPDATE^DIE("","ACKARR","","") ; PROBLISX ; all done K ^TMP("ACKQUTL3",$J,"PROBLIST") diff -auBN ./r1/ACKQUTL4.m ./r2/r/ACKQUTL4.m --- ./r1/ACKQUTL4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQUTL4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ ACKQUTL4 ;HCIOFO/BH-NEW/EDIT Visit Template Utilities for QUASAR ; 04/01/99 - ;;3.0;QUASAR;**1,8**;Feb 11, 2000 + ;;3.0;QUASAR;**1**;Feb 11, 2000 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. ; CHK(Y,ACKVD) ; @@ -40,11 +40,8 @@ ; N ACKX,ACKD0 ; - S (ICPTVDT,ICDVDT)=ACKVD - ; S ACKPCE=$$PCE(ACKDIV,ACKVD) ; Sets PCE indicator ; - S ACKEVENT=1 S ACKEVENT=$$EVENT^ACKQUTL5(ACKDIV,ACKVD) ; Use EC Codes or CPT ; Indicates whether local clinic #'s are in use S ACKCLNO=$$GET1^DIQ(509850.83,ACKDIV_",1",".04","I") @@ -217,7 +214,7 @@ . . ; Loop through Modifier Array . . S ACKKEY="" . . F S ACKKEY=$O(ACKTMOD("DILIST",1,ACKKEY)) Q:ACKKEY="" D - . . . W ?19,$$MODTXT^ACKQUTL8(ACKTMOD("DILIST",1,ACKKEY),ACKVD),! + . . . W ?19,$$GET1^DIQ(81.3,ACKTMOD("DILIST",1,ACKKEY),.02),! . . K ACKTMOD W ! Q @@ -232,7 +229,7 @@ F S ACKK3=$O(ACKDIAGD("DILIST",1,ACKK3)) Q:ACKK3="" D . S ACKK4=ACKDIAGD("DILIST",1,ACKK3) . S ACKI=$$GET1^DIQ(80,ACKK4,.01) - . S ACKD($S(ACKI?.NP:+ACKI,1:ACKI))=ACKI_$E(" ",1,7-$L(ACKI))_"- "_$E($$DIAGTXT^ACKQUTL8(ACKK4,ACKVD)_ACKSP,1,35)_$S($G(ACKDIAGD("DILIST","ID",ACKK3,".12"))=1:" * Primary Diagnosis *",1:" * Secondary Diagnosis *") + . S ACKD($S(ACKI?.NP:+ACKI,1:ACKI))=ACKI_$E(" ",1,7-$L(ACKI))_"- "_$E($$GET1^DIQ(80,ACKK4,3)_ACKSP,1,35)_$S($G(ACKDIAGD("DILIST","ID",ACKK3,".12"))=1:" * Primary Diagnosis *",1:" * Secondary Diagnosis *") ; S ACK1="" F S ACK1=$O(ACKD(ACK1)) Q:ACK1="" D @@ -255,7 +252,7 @@ ; Enter Edit. S ACK1="0" F S ACK1=$O(^ACK(509850.5,ACK1)) Q:'+ACK1 D - . W !," "_$$GET1^DIQ(81.3,ACK1,.01),?5,$$MODTXT^ACKQUTL8(ACK1,""),?53,$$GET1^DIQ(81.3,ACK1,.04) + . W !," "_$$GET1^DIQ(81.3,ACK1,.01),?5,$$GET1^DIQ(81.3,ACK1,.02),?53,$$GET1^DIQ(81.3,ACK1,.04) W ! Q ; CONVERT(ACKPRV) ; Converts the QSR Prov Code into a name string from file 200. diff -auBN ./r1/ACKQUTL5.m ./r2/r/ACKQUTL5.m --- ./r1/ACKQUTL5.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQUTL5.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ ACKQUTL5 ;HCIOFO/BH-Quasar utilities routine ; 04/01/99 - ;;3.0;QUASAR;**1,4,6,8**;Feb 11, 2000 + ;;3.0;QUASAR;**1,4**;Feb 11, 2000 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. SETREF(X,ACKVIEN,ACKTYPE) ; ; Maintains APCE xRef When 3 of the 4 entries are present & the 4TH @@ -118,27 +118,18 @@ Q MODW ; Called from x ref of Modfr field within 509850.6 I X'["?" Q - N ACKQDDD - S ACKQDDD=$G(ACKVD) - S DIC("W")="W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_"),?48,$$GET1^DIQ(81.3,Y,.04)" + S DIC("W")="W "" "",$$GET1^DIQ(81.3,Y,.02),?48,$$GET1^DIQ(81.3,Y,.04)" Q - ; - ; MODS ; Screen for Modfrs input within Modifrs field of Modfrs File - N ACKQDDD - S ACKQDDD=$G(ACKVD) S DIC("S")="D GETS^DIQ(81.3,Y,"".04;5"",""I"",""ACKARR"",""ACKMSG"") I ACKARR(81.3,Y_"","",.04,""I"")=""C""!(ACKARR(81.3,Y_"","",.04,""I"")=""H""),ACKARR(81.3,Y_"","",5,""I"")'=1" - S DIC("W")="W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_")" + S DIC("W")="W "" "",$$GET1^DIQ(81.3,Y,.02)" Q - ; - ; CHK(Y,ACKVD,ACKCSC) ; Screen for EC codes - N ACKQCD,ACKQQD,ACKQQCPT,ACKPARAM + N ACKQCD,ACKQQD,ACKQQCPT I $E($P(^EC(725,+Y,0),"^",2),1,2)'="SP" Q 0 S ACKQQCPT=$$GET1^DIQ(725,+Y_",",4,"I") I ACKQQCPT="" Q 0 ;S ACKQCD=$$CONVERT(ACKQQCPT) I ACKQCD="" Q 0 S ACKQCD=ACKQQCPT - S ACKPARAM=$P($$CPT^ICPTCOD(ACKQCD,ACKVD),"^",7) I 'ACKPARAM Q 0 I '$D(^ACK(509850.4,ACKQCD,0)) Q 0 I $P(^ACK(509850.4,ACKQCD,0),U,2)'[$E(ACKCSC) Q 0 I $P(^ACK(509850.4,ACKQCD,0),U,4)'=1 Q 0 diff -auBN ./r1/ACKQUTL6.m ./r2/r/ACKQUTL6.m --- ./r1/ACKQUTL6.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ACKQUTL6.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -ACKQUTL6 ;HCIOFO/BH-A&SP Utilities routine ; 5/6/03 11:07am - ;;3.0;QUASAR;**1,7**;Feb 11, 2000 +ACKQUTL6 ;HCIOFO/BH-A&SP Utilities routine ; 04/01/99 + ;;3.0;QUASAR;**1**;Feb 11, 2000 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. ; DATACHEK(X,ACKVIEN) ; Checks that the input (X) is a valid time also checks that @@ -18,7 +18,7 @@ ; ; TTIME(X) ; Time input validation used within input transform of - ; the Appointment time field (#55) of the visit file. + ; the Appopintment time field (#55) of the visit file. ; ; X=Time entered by the user ; Return value either O if input was invalid or formatted @@ -90,7 +90,7 @@ Q 1 ; DUPCHK ; Called from xecutable help of Appointment Time field when ACKITME is - ; defined. This will only be defined if DUPECHK returned false + ; defined. This will onl be defined if DUPECHK returned false W !!,"Quasar already has a Visit entry for this Patient, within the same Clinic," W !,"on the same date at the same time." W !!,"Please re-enter a new Appointment Time.",!! @@ -133,7 +133,7 @@ Q ; ; -IDATE(D0,Y) ; Checks that the entered Inactive date falls after the +IDATE(D0,Y) ; Checks the the entered Inactive date falls after the ; Active date (if one has been entered). I Y="" Q 1 ; Its valid to not enter an inactivation date. N ACKACT @@ -141,7 +141,7 @@ I YIOSL D Q:AXABORT - . . I $E(IOST,1,2)="C-" D PAGE^XMXUTIL(.AXABORT) Q:AXABORT - . . D LHDR(AXWHICH,.AXLEN) - . S AXDATE=$$DATE^XMXUTIL2(AXREC) - . S AXCNT=AXCNT+1,AXLIST(AXCNT)=AXMZ - . W !,$J(AXCNT,AXLEN("#"))," ",AXDATE," ",$E(AXSUBJ,11,AXLEN("S")) - Q -LHDR(AXWHICH,AXLEN) ; - W @IOF,$S(AXWHICH="Y":"Your",1:"All")," NHE Results" - W !," #",?AXLEN("#")+2,"Date Sent Subject" - W !,$$REPEAT^XLFSTR("=",79) - Q -CHOOSE(AXLIST,AXCNT) ; - N DIR,X,Y,AXMZ,DIC,D,AXCOMP,AXABORT - S AXABORT=0 - W ! - S DIR(0)="NO^1:"_AXCNT - S DIR("A")="Select the report you'd like to print" - D ^DIR I $D(DIRUT) S AXABORT=1 Q - S AXMZ=AXLIST(Y) - F D Q:AXABORT - . K DIC,X,Y,D - . W ! - . S DIC("A")="Select Component: " - . S DIC(0)="AEQZ",D="C" ; Lookup using only the C xref (upper-case) - . S DIC="^AFJ(537015," - . D IX^DIC I Y<0 S AXABORT=1 Q - . S AXCOMP=Y(0,0) - . N AXSAVE,I,ZTSK - . W ! - . F I="AXCOMP","AXMZ" S AXSAVE(I)="" - . D EN^XUTMDEVQ("PRINT^AFJXMABX","AFJX Print Completed NHE Results by Component",.AXSAVE,,1) - . I $D(ZTSK) W !,"Print queued. Task number: ",ZTSK - Q -PRINT ; We assume that there may be more than 1 of the same component, - ; and that they are not necessarily consecutive. - N AXI,AXTXT,AXPAGE,AXABORT,AXFOUND,AXDASH - S (AXI,AXPAGE,AXABORT)=0,AXI=3,AXFOUND=0,AXDASH=$$REPEAT^XLFSTR("-",56) - D PHDR(AXMZ,.AXPAGE) W ! - F S AXI=$O(^XMB(3.9,AXMZ,2,AXI)) Q:'AXI S AXTXT=$G(^(AXI,0)) D Q:AXABORT - . Q:AXTXT'[AXCOMP Q:$E(AXTXT,71,78)'["------" - . S AXFOUND=1 - . F D Q:'AXI!AXABORT I $E(AXTXT,71,78)["------",AXTXT'[AXCOMP,AXTXT'[AXDASH Q - . . I $Y+3+($E(IOST,1,2)="C-")>IOSL D Q:AXABORT - . . . I $E(IOST,1,2)="C-" W ! D PAGE^XMXUTIL(.AXABORT) Q:AXABORT - . . . D PHDR(AXMZ,.AXPAGE) W ! - . . W !,AXTXT - . . S AXI=$O(^XMB(3.9,AXMZ,2,AXI)),AXTXT=$G(^(+AXI,0)) - I 'AXFOUND W !,"Component '",AXCOMP,"' is not in this request." - Q - ; We assume that there may be more than 1 of the same component, - ; and if so, that they are consecutive. - ;N AXI,AXTXT,AXPAGE,AXABORT - ;S (AXI,AXPAGE,AXABORT)=0,AXI=3 - ;D PHDR(AXMZ,.AXPAGE) W ! - ;F S AXI=$O(^XMB(3.9,AXMZ,2,AXI)) Q:'AXI S AXTXT=$G(^(AXI,0)) I AXTXT[AXCOMP,$E(AXTXT,71,78)["------" Q - ;I 'AXI W !,"Component '",AXCOMP,"' is not in this request." Q - ;W !,AXTXT - ;F S AXI=$O(^XMB(3.9,AXMZ,2,AXI)) Q:'AXI S AXTXT=$G(^(AXI,0)) Q:AXTXT?10."-"1" "1.5E1" - ".E1" "10."-"&(AXTXT'[AXCOMP) D Q:AXABORT - ;. I $Y+3+($E(IOST,1,2)="C-")>IOSL D Q:AXABORT - ;. . I $E(IOST,1,2)="C-" W ! D PAGE^XMXUTIL(.AXABORT) Q:AXABORT - ;. . D PHDR(AXMZ,.AXPAGE) W ! - ;. W !,AXTXT - ;Q -PHDR(AXMZ,AXPAGE) ; - N AXI - S AXPAGE=AXPAGE+1 - I $E(IOST,1,2)="C-"!$D(AXPAGE(0)) W @IOF - E D ; Don't eject when printing first page to printer. - . W $C(13) - . S AXPAGE(0)="" - W "NHE Results for ",$$NAME^XMXUTIL(DUZ),?70,$J("PAGE "_AXPAGE,9) - F AXI=2,3 I $G(^XMB(3.9,AXMZ,2,AXI,0))'="" W !,^(0) - W !,$$REPEAT^XLFSTR("=",79) - Q +AFJXMABX ;FJ/CWS;PRINT BY SECTION NETWORK HEALTH EX's;11/8/95 ;6/25/96 12:42 + ;;5.1;Network Health Exchange;**1,2,10,11,15**;Jan 23, 1996 +FIRST U IO(0) W @IOF R !!,"Which requests would you like Y) Your Own A) All ^) None Y// ",ANS:DTIME Q:ANS["^" S:ANS="a" ANS="A" S:ANS="y" ANS="Y" + S:ANS="" ANS="Y" + D:ANS["Y" YOUR^AFJXMABX D:ANS["A" HERE^AFJXMABX D:ANS["N" EXIT^AFJXMABX + G FIRST + Q +HERE S CT=0 D START,HEAD,PART2,TEXT,EXIT + Q +START ; BEGINNING + ; 612/fyb - remove hard sets, use HOME^%ZIS + D HOME^%ZIS S:'$D(DTIME) DTIME=300 S U="^",(BEND,EMS)="" ; 612/fyb + S NPX="" F S NPX=$O(^VA(200,"B","NETWORK,HEALTH EXCHANGE",NPX)) Q:NPX="" S NHXU=NPX + Q +HEAD1 Q:BEND>0 I IOST["C-" R !!,"Press return to continue or ""^"" to quit: ",X:DTIME I X["^" S BEND=BEND+1 Q + ; +HEAD W @IOF,?10,"THIS REPORT CAN BE SENT TO A PRINTER OR READ ON THE SCREEN",! F K=1:1:80 W "@" Q:K=80 + W !,"Message #",?20,"Subject",?60,"Date Sent",! S J=0 F J=1:1:80 W "=" + Q +PART2 S MES="" F I=MES:0 S MES=$O(^XMB(3.7,NHXU,2,1,1,MES)),NUM=0 Q:(MES="")!(BEND>0) D DAT + Q +DAT S MESSA=$P($G(^XMB(3.9,MES,0)),U,1),SNDR=$P($G(^XMB(3.9,MES,0)),U,2),DAT=$E($P($G(^(0)),U,3),1,15) Q:$E(MESSA,19,19)'?1A D HEAD1:$Y+6>IOSL D WRITE + Q +WRITE I $E(DAT,4,4)?1A S X=$P(DAT," ",1,3) D ^%DT S DAT=Y,DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3) G WDT + S:DAT'["@" DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3)_"@"_$E(DAT,9,12) +WDT Q:(MESSA'["<")!($G(BEND)'="") S CT=CT+1,CT(CT)=MES W !,CT,?15,$E(MESSA,11,50),?60,DAT ;CFB 12/15/95 + Q +TEXT R !!,"Type the number of the report you would like to review",!,"or print: ",EMS:DTIME Q:EMS["^"!(EMS="") G TEXT:EMS>CT ;CFB 12/15/95 + I EMS'?.N W !,"PLEASE TYPE THE NUMBER DISPLAYED" G TEXT ;CFB AFJX*5.1*1 + S MESSA=$P($G(^XMB(3.9,CT(EMS),0)),U,1) ;CFB 12/15/95 + I MESSA'["<" W !,"This does not appear to be a Network Request message..printing not allowed" H 2 Q ;G FIRST ; 612/fyb +TY S END=$P($G(^XMB(3.9,CT(EMS),2,0)),U,3) K TYPE,WD +ONE W !! S DIC("A")="Choose type: ",DIC="^AFJ(537015,",DIC(0)="AQMEZ" D ^DIC Q:Y<1 K DIC S WD=$S(Y<0:"",1:$P(Y,U,1)) Q:$D(DTOUT)!$D(DTOUT)!(Y<0) S PTY=$P($G(^AFJ(537015,+WD,0)),U) Q:PTY="" D BEGIN G ONE ; 612/fyb + Q +BEGIN N %A,%E,%X D DT^DICRW S %ZIS="MFQ" D ^%ZIS Q:POP + ; 612/fyb - thru BEGIN+8 - Queueing/Browser support + I $D(IO("Q")) K IO("Q"),ZTI,ZTSK D Q + . S ZTIO=ION_";"_IOST,ZTSAVE("*")="",ZTRTN="PRINT^AFJXMABX",ZTDESC="PRINT NETWORK HEALTH BY SECTION" + . D ^%ZTLOAD I $D(ZTSK) W !,"Queued as Task #",ZTSK + . K ZTDESC,ZTIO,ZTSAVE,ZTSK + U IO D PRINT,^%ZISC ; G ONE Q; 612/fyb + Q +SECO S MES="" F I=MES:0 S MES=$O(^XMB(3.7,NHXU,2,1,1,MES)),NUM=0 Q:(MES="")!(BEND>0) D FDAT + Q +FDAT S MESSA=$P($G(^XMB(3.9,MES,0)),U,1),SNDR=$P($G(^XMB(3.9,MES,0)),U,2),DAT=$E($P($G(^(0)),U,3),1,15) Q:$E(MESSA,19,19)'?1A S ITR=$G(^XMB(3.9,MES,2,1,0)),YOU=$P(ITR,U,2) D HEAD1:$Y+6>IOSL D FRIT + Q +FRIT Q:YOU'=DUZ + I $E(DAT,4,4)?1A S X=$P(DAT," ",1,3) D ^%DT S DAT=Y,DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3) G FWDT + S:DAT'["@" DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3)_"@"_$E(DAT,9,12) +FWDT Q:(MESSA'["<")!($G(BEND)'="") S CT=CT+1,CT(CT)=MES W !,CT,?15,$E(MESSA,11,50),?60,DAT ;CFB 12/15/95 + Q +PRINT S (FLAGYES,PAGE)=0 F I=4:1:END S REC=$G(^XMB(3.9,CT(EMS),2,I,0)) D PRT2 ; 612/fyb ;CFB/TUSC/SF AFJX*5.1*2 HEADER CORRECTION + I FLAGYES=0 W !!," Sorry! That component not contained in this Request" + Q +PRT2 Q:(REC'[PTY)!(I=END) + D HD3 + F I=I:1:END S REC=$G(^XMB(3.9,CT(EMS),2,I,0)) Q:$E(REC,1,79)'["----------------------------------------------"&($E(REC,71,78)["------"&(REC'[PTY)) D HEAD2:$Y+6>IOSL Q:X="^" W !,REC + S FLAGYES=1 + Q +HEAD2 I IOST["C-" R !!!,"Press return to continue or ""^"" to quit: ",X:DTIME I X["^" Q +HD3 S PAGE=PAGE+1 W @IOF,?70,"PAGE ",PAGE,! I $G(CT(EMS)),$G(^XMB(3.9,CT(EMS),2,2,0))'="" W $$TRIM(^(0),79),! I $G(^XMB(3.9,CT(EMS),2,3,0))'="" W $$TRIM(^(0),79),! ;CFB/TUSC/SF AFJX*5.1*2 ADD RECORD INFO IN HDR + Q +EXIT K YOU,BEND,CT,DAT,EMS,END,FLAGYES,MES,MESSA,NUM,PAGE,PTY,REC,SNDR,WD,X Q +YOUR S CT=0 D START,HEAD,SECO,TEXT,EXIT + Q +TRIM(X,Y) ;CFB/TUSC/SF ENSURE NO LINE LONGER THAN Y + Q $E(X,$L(X)-Y+1,$L(X)) + ; diff -auBN ./r1/AFJXMBOX.m ./r2/r/AFJXMBOX.m --- ./r1/AFJXMBOX.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AFJXMBOX.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,52 +1,62 @@ -AFJXMBOX ;FO-OAKLAND/GMB-SEARCH for PREVIOUSLY COMPLETED NETWORK HEALTH EX's ;03/17/2003 07:46 - ;;5.1;Network Health Exchange;**2,11,34**;Jan 23, 1996 - ; Totally rewritten 3/2003. (Previously FJ/CWS.) - ; Called from ^AFJXWCP1 & ^AFJXWCPM -ENTER ; - N AXNHEDUZ,AXABORT - S AXABORT=0 - S AXNHEDUZ=$$FIND1^DIC(200,"","X","NETWORK,HEALTH EXCHANGE","B") - F D Q:AXABORT - . N DIR,X,Y,AXLIST,AXCNT - . W @IOF - . S DIR(0)="SO^Y:Your Own;A:All" - . S DIR("A")="Select the requests to list" - . S DIR("B")="Your Own" - . D ^DIR I $D(DIRUT) S AXABORT=1 Q - . D LIST^AFJXMABX(AXNHEDUZ,Y,.AXLIST,.AXCNT) Q:'AXCNT - . D CHOOSE(.AXLIST,AXCNT) - Q -CHOOSE(AXLIST,AXCNT) ; - N DIR,X,Y,AXWHICH - W ! - S DIR(0)="LCO^1:"_AXCNT - S DIR("A")="Select the reports you'd like to print" - D ^DIR Q:$D(DIRUT) - S AXWHICH=Y - N AXSAVE,I,ZTSK - W ! - F I="AXLIST(","AXWHICH" S AXSAVE(I)="" - D EN^XUTMDEVQ("PRINT^AFJXMBOX","AFJX Print Completed NHE Results",.AXSAVE,,1) - Q:'$D(ZTSK) - W !,"Print queued. Task number: ",ZTSK - D WAIT^XMXUTIL - Q -PRINT ; - N AXI,AXRANGE,AXJ,AXMZ,AXPAGE,AXABORT - S AXABORT=0 - F AXI=1:1:$L(AXWHICH,",")-1 D Q:AXABORT - . S AXRANGE=$P(AXWHICH,",",AXI) - . F AXJ=$P(AXRANGE,"-",1):1:$S(AXRANGE["-":$P(AXRANGE,"-",2),1:AXRANGE) D Q:AXABORT - . . D REPORT(AXLIST(AXJ),.AXPAGE,.AXABORT) - Q -REPORT(AXMZ,AXPAGE,AXABORT) ; - N AXI,AXTXT - S (AXI,AXPAGE)=0,AXI=3 - D PHDR^AFJXMABX(AXMZ,.AXPAGE) - F S AXI=$O(^XMB(3.9,AXMZ,2,AXI)) Q:'AXI S AXTXT=$G(^(AXI,0)) D Q:AXABORT - . I $Y+3+($E(IOST,1,2)="C-")>IOSL D Q:AXABORT - . . I $E(IOST,1,2)="C-" W ! D PAGE^XMXUTIL(.AXABORT) Q:AXABORT - . . D PHDR^AFJXMABX(AXMZ,.AXPAGE) - . W !,AXTXT - I 'AXABORT,$E(IOST,1,2)="C-" D PAGE^XMXUTIL(.AXABORT) +AFJXMBOX ;FJ/CWS;SEARCH for PREVIOUSLY COMPLETED NETWORK HEALTH EX's;11/8/95 ;1/18/96 13:10 + ;;5.1;Network Health Exchange;**2,11**;Jan 23, 1996 + ; 612/fyb +FIRST W @IOF R !!,"Which requests would you like Y) Your Own A) All ^) None Y// ",ANS:DTIME Q:ANS["^" S:ANS="a" ANS="A" S:ANS="y" ANS="Y" + S:ANS="" ANS="Y" + D:ANS["Y" ^AFJXPNHF D:ANS["A" HERE^AFJXMBOX D:ANS["N" EXIT^AFJXMBOX + G FIRST Q +HERE S CT=0 D START,HEAD,PART2,TEXT,EXIT + Q +START ; BEGINNING + ; 612/fyb - remove hard sets, use HOME^%ZIS + D HOME^%ZIS S:'$D(DTIME) DTIME=300 S U="^",(BEND,EMS)="" ; 612/fyb + S NPX="" F S NPX=$O(^VA(200,"B","NETWORK,HEALTH EXCHANGE",NPX)) Q:NPX="" S NHXU=NPX + Q +HEAD1 Q:BEND>0 I IOST["C-" R !!,"Press return to continue or ""^"" to quit: ",X:DTIME I X="^" S BEND=BEND+1 Q +HEAD W @IOF,?10,"THIS REPORT CAN BE SENT TO A PRINTER OR READ ON THE SCREEN",! F K=1:1:80 W "@" Q:K=80 + W !,"Message #",?20,"Subject",?60,"Date Sent",! S J=0 F J=1:1:80 W "=" + Q +PART2 S MSG="" F I=MSG:0 S MSG=$O(^XMB(3.7,NHXU,2,1,1,MSG)),NUM=0 Q:(MSG="")!(BEND>0) D DAT + Q +DAT ; + S MESSA=$P($G(^XMB(3.9,MSG,0)),U,1),SNDR=$P($G(^XMB(3.9,MSG,0)),U,2),DAT=$E($P($G(^(0)),U,3),1,15) Q:$E(MESSA,19,19)'?1A D HEAD1:$Y+6>IOSL D WRITE + Q +WRITE I $E(DAT,4,4)?1A S X=$P(DAT," ",1,3) D ^%DT S DAT=Y,DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3) G WDT + S:DAT'["@" DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3)_"@"_$E(DAT,9,12) +WDT Q:(MESSA'["<")!($G(BEND)'="") S CT=CT+1,CT(CT)=MSG W !,CT,?15,$E(MESSA,11,50),?60,DAT ;CFB 12/15/95 MOD ADD CT + Q +TEXT W ! S DIR("A")="Type one number eg. 1 or up to ten numbers separated by commas eg. 1,2,3,4,5,6,7,8,9,10: ",DIR("?")="Enter number(s) to print report(s)",DIR(0)="LA^1:999" D ^DIR Q:Y["^" S EMS=Y ;CFB MOD 12/15/95 + ;S ONE=$P(EMS,",",1),TWO=$P(EMS,",",2),THR=$P(EMS,",",3),FUR=$P(EMS,",",4),FIV=$P(EMS,",",5),SIX=$P(EMS,",",6),SEV=$P(EMS,",",7),EIG=$P(EMS,",",8),NIN=$P(EMS,",",9),TEN=$P(EMS,",",10) ;CFB 12/15/95 + S Y=0 F X="ONE","TWO","THR","FUR","FIV","SIX","SEV","EIG","NIN","TEN" S Y=Y+1,@X="",Z=$P(EMS,",",Y) I +Z,Z'>CT S @X=CT(Z) ;CFB 12/15/95 + S:ONE'="" ^TMP("NHMP",$J,ONE)="" S:TWO'="" ^TMP("NHMP",$J,TWO)="" S:THR'="" ^TMP("NHMP",$J,THR)="" S:FUR'="" ^TMP("NHMP",$J,FUR)="" S:FIV'="" ^TMP("NHMP",$J,FIV)="" S:SIX'="" ^TMP("NHMP",$J,SIX)="" + S:SEV'="" ^TMP("NHMP",$J,SEV)="" S:EIG'="" ^TMP("NHMP",$J,EIG)="" S:NIN'="" ^TMP("NHMP",$J,NIN)="" S:TEN'="" ^TMP("NHMP",$J,TEN)="" + ; +BEGIN N %A,%E,%X D DT^DICRW S %ZIS="MFQ" D ^%ZIS Q:POP + ; 612/fyb - through BEGIN+8. Queueing/Browser Support + I $D(IO("Q")) K IO("Q"),ZTI,ZTSK D Q + . S ZTIO=ION_";"_IOST,ZTSAVE("*")="",ZTRTN="PRINT^AFJXMBOX",ZTDESC="PRINT COMPLETED NETWORK HEALTH EXCHANGE" + . D ^%ZTLOAD I $D(ZTSK) W !,"Queued as Task #",ZTSK + . K ZTDESC,ZTIO,ZTSAVE,ZTSK + U IO D PRINT,^%ZISC ;G FIRST Q ; 612/fyb - GOTO FIRST stacks the DO + Q +PRINT I ONE'="" S MES=ONE D SPTS + I TWO'="" S MES=TWO D SPTS + I THR'="" S MES=THR D SPTS + I FUR'="" S MES=FUR D SPTS + I FIV'="" S MES=FIV D SPTS + I SIX'="" S MES=SIX D SPTS + I SEV'="" S MES=SEV D SPTS + I EIG'="" S MES=EIG D SPTS + I NIN'="" S MES=NIN D SPTS + I TEN'="" S MES=TEN D SPTS + Q + ; +SPTS S MESSA=$P($G(^XMB(3.9,MES,0)),U,1) + I MESSA'["<" W !,"This does not appear to be a Network Request message..printing not allowed" H 2 ;G FIRST + Q:'$D(^XMB(3.9,MES,2,1,0)) S PAGE=1 W @IOF,?70,"PAGE ",PAGE S I=1 F S I=$O(^XMB(3.9,MES,2,I)) Q:I'>0 S REC=^(I,0) D HEAD2:$Y+6>IOSL Q:X="^" W !,REC ; 612/fyb - don't quit on null line ;CFB/TUSC/SF AFJX*5.1*2 + Q +HEAD2 I IOST["C-" R !!!,"Press return to continue or ""^"" to quit: ",X:DTIME I X="^" Q + S PAGE=PAGE+1 W @IOF,?70,"PAGE ",PAGE I $G(MES),$G(^XMB(3.9,MES,2,2,0))'="" W !,$$TRIM^AFJXMABX(^(0),79),! I $G(^XMB(3.9,MES,2,3,0))'="" W $$TRIM^AFJXMABX(^(0),79),! ;CFB/TUSC/SF AFJX*5.1*2 ADD HEADER INFO TO PRINTOUT. + Q +EXIT K ^TMP("NHMP",$J),CT,DAT,DIR,EIG,EMS,FIV,FUR,MES,MESSA,NIN,NUM,ONE,PAGE,REC,SEV,SIX,SNDR,TEN,TWO,THR Q diff -auBN ./r1/AFJXPNHF.m ./r2/r/AFJXPNHF.m --- ./r1/AFJXPNHF.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/AFJXPNHF.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,59 @@ +AFJXPNHF ;FJ/CWS;PRINT NETWORK HEALTH EX's FOR INDIVIDUAL;11/8/95 ;12/15/95 08:59 + ;;5.1;Network Health Exchange;**2,11**;Jan 23, 1996 + ; 612/fyb +FIRST S CT=0 D START,HEAD,PART2,TEXT,EXIT + Q +START ; BEGINNING + ; 612/fyb - remove hard sets, use HOME^%ZIS + D HOME^%ZIS S:'$D(DTIME) DTIME=300 S U="^",(BEND,EMS)="" ; 612/fyb + S NPX="" F S NPX=$O(^VA(200,"B","NETWORK,HEALTH EXCHANGE",NPX)) Q:NPX="" S NHXU=NPX + Q +HEAD1 Q:BEND>0 I IOST["C-" R !!,"Press return to continue or ""^"" to quit: ",X:DTIME I X="^" S BEND=BEND+1 Q +HEAD W @IOF,?10,"THIS REPORT CAN BE SENT TO A PRINTER OR READ ON THE SCREEN",! F K=1:1:80 W "@" Q:K=80 + W !,"Message #",?20,"Subject",?60,"Date Sent",! S J=0 F J=1:1:80 W "=" + Q +PART2 S MSG="" F I=MSG:0 S MSG=$O(^XMB(3.7,NHXU,2,1,1,MSG)),NUM=0 Q:(MSG="")!(BEND>0) D DAT + Q +DAT ; + S MESSA=$P($G(^XMB(3.9,MSG,0)),U,1),SNDR=$P($G(^XMB(3.9,MSG,0)),U,2),DAT=$E($P($G(^(0)),U,3),1,15) Q:$E(MESSA,19,19)'?1A S ITR=$G(^XMB(3.9,MSG,2,1,0)),YOU=$P(ITR,U,2) D HEAD1:$Y+6>IOSL D WRITE + Q +WRITE Q:YOU'=DUZ + I $E(DAT,4,4)?1A S X=$P(DAT," ",1,3) D ^%DT S DAT=Y,DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3) G WDT + S:DAT'["@" DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3)_"@"_$E(DAT,9,12) +WDT Q:(MESSA'["<")!($G(BEND)'="") S CT=CT+1,CT(CT)=MSG W !,CT,?15,$E(MESSA,11,50),?60,DAT + Q + ; +TEXT W ! S DIR("A")="Type a message by number eg. 1 or up to ten numbers separated by commas eg. 1,2,3,4,5,6,7,8,9,10:",DIR("?")="Enter number(s) to print report(s)",DIR(0)="LA^1:999" D ^DIR Q:Y["^" S EMS=Y ;CFB 12/15/96 + ;S ONE=$P(EMS,",",1),TWO=$P(EMS,",",2),THR=$P(EMS,",",3),FUR=$P(EMS,",",4),FIV=$P(EMS,",",5),SIX=$P(EMS,",",6),SEV=$P(EMS,",",7),EIG=$P(EMS,",",8),NIN=$P(EMS,",",9),TEN=$P(EMS,",",10) ;CFB 12/15/96 + S Y=0 F X="ONE","TWO","THR","FUR","FIV","SIX","SEV","EIG","NIN","TEN" S Y=Y+1,@X="",Z=$P(EMS,",",Y) I +Z,Z'>CT S @X=CT(Z) ;CFB 12/15/95 + S:ONE'="" ^TMP("NHMP",$J,ONE)="" S:TWO'="" ^TMP("NHMP",$J,TWO)="" S:THR'="" ^TMP("NHMP",$J,THR)="" S:FUR'="" ^TMP("NHMP",$J,FUR)="" S:FIV'="" ^TMP("NHMP",$J,FIV)="" S:SIX'="" ^TMP("NHMP",$J,SIX)="" + S:SEV'="" ^TMP("NHMP",$J,SEV)="" S:EIG'="" ^TMP("NHMP",$J,EIG)="" S:NIN'="" ^TMP("NHMP",$J,NIN)="" S:TEN'="" ^TMP("NHMP",$J,TEN)="" + ; +BEGIN N %A,%E,%X D DT^DICRW S %ZIS="MFQ" D ^%ZIS Q:POP + ; 612/fyb - Through BEGIN+8. Queueing/Browser Support + I $D(IO("Q")) K IO("Q"),ZTI,ZTSK D Q + . S ZTIO=ION_";"_IOST,ZTSAVE("*")="",ZTRTN="PRINT^AFJXPNHF",ZTDESC="PRINT INDIVIDUAL NETWORK HEALTH EXCHANGE" + . D ^%ZTLOAD I $D(ZTSK) W !,"Queued as Task #",ZTSK + . K ZTDESC,ZTIO,ZTSAVE,ZTSK + U IO D PRINT,^%ZISC ;G FIRST Q ; 612/fyb - GOTO FIRST stacks the DO + Q +PRINT I ONE'="" S MES=ONE D SPTS + I TWO'="" S MES=TWO D SPTS + I THR'="" S MES=THR D SPTS + I FUR'="" S MES=FUR D SPTS + I FIV'="" S MES=FIV D SPTS + I SIX'="" S MES=SIX D SPTS + I SEV'="" S MES=SEV D SPTS + I EIG'="" S MES=EIG D SPTS + I NIN'="" S MES=NIN D SPTS + I TEN'="" S MES=TEN D SPTS + Q + ; +SPTS S MESSA=$P($G(^XMB(3.9,MES,0)),U,1) + I MESSA'["<" W !,"This does not appear to be a Network Request message..printing not allowed" H 2 ;G FIRST + Q:'$D(^XMB(3.9,MES,2,1,0)) S PAGE=1 W @IOF,?70,"PAGE ",PAGE S I=1 F S I=$O(^XMB(3.9,MES,2,I)) Q:I'>0 S REC=^(I,0) D HEAD2:$Y+6>IOSL Q:X="^" W !,REC ; 612/fyb - don't quit on a null line ;CFB/TUSC/SF AFJX*5.1*2 ADD HEADER INFO + Q +HEAD2 I IOST["C-" R !!!,"Press return to continue or ""^"" to quit: ",X:DTIME I X="^" Q + S PAGE=PAGE+1 W @IOF,?70,"PAGE ",PAGE I $G(MES),$G(^XMB(3.9,MES,2,2,0))'="" W !,$$TRIM^AFJXMABX(^(0),79),! I $G(^XMB(3.9,MES,2,3,0))'="" W $$TRIM^AFJXMABX(^(0),79),! ;CFB/TUSC/SF AFJX*5.1*2 ADD HEADER INFO + Q +EXIT K DAT,DIR,EMS,MES,MESSA,NUM,PAGE,REC,SNDR Q diff -auBN ./r1/AFJXPNHI.m ./r2/r/AFJXPNHI.m --- ./r1/AFJXPNHI.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/AFJXPNHI.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,3 @@ +AFJXPNHI ;FJ/CWS; * OBSOLETE * ;11/8/95 ;12/13/95 12:36 + ;;5.1;Network Health Exchange;**2,7,33**;Jan 23, 1996 + Q diff -auBN ./r1/AFJXREW.m ./r2/r/AFJXREW.m --- ./r1/AFJXREW.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/AFJXREW.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,3 @@ +AFJXREW ;CIOFO-SF/AAA; * OBSOLETE * ;1/25/01 14:25 + ;;5.1;Network Health Exchange;**15,17,18,23,26,29,31**;Jan 23, 1996 + Q diff -auBN ./r1/AFJXSFAL.m ./r2/r/AFJXSFAL.m --- ./r1/AFJXSFAL.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AFJXSFAL.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ AFJXSFAL ;FO-OAKLAND/GMB-ALERT & VIEW PT INQUIRY ;1/17/96 13:16 - ;;5.1;Network Health Exchange;**31,32,33,34**;Jan 23, 1996 + ;;5.1;Network Health Exchange;**31,32,33**;Jan 23, 1996 ; Totally rewritten 11/2001. (Previously FJ/CWS.) ; Entry points: ; ENTER - Invoked by server option AFJXNHDONE @@ -26,25 +26,25 @@ N ZTSAVE,AXMZ S AXMZ=XQADATA S ZTSAVE("AXMZ")="" - D EN^XUTMDEVQ("PRINT^AFJXSFAL","AFJX Print NHE Inquiry Results",.ZTSAVE) + D EN^XUTMDEVQ("PRINT^AFJXSFAL","AFJX Print Network Health Exchange Inquiry Results",.ZTSAVE) Q PRINT ; N AXPAGE,AXHDR,AXI,AXREC,AXABORT - S AXI=3,(AXABORT,AXPAGE)=0 + S (AXI,AXABORT)=0,AXPAGE=1 I $G(^XMB(3.9,AXMZ,2,2,0))'="" S AXHDR(1)=^(0),AXI=2 I $G(^XMB(3.9,AXMZ,2,3,0))'="" S AXHDR(2)=^(0),AXI=3 - I $E(IOST,1,2)="C-" W @IOF + I $G(IOST)["C-" W @IOF E W $C(13) D HDR F S AXI=$O(^XMB(3.9,AXMZ,2,AXI)) Q:'AXI S AXREC=^(AXI,0) D Q:AXABORT - . I $Y+3+($E(IOST,1,2)="C-")>IOSL D Q:AXABORT - . . I $E(IOST,1,2)="C-" W ! D PAGE^XMXUTIL(.AXABORT) Q:AXABORT + . I $Y+3+($G(IOST)["C-")>IOSL D Q:AXABORT + . . I $G(IOST)["C-" W ! D PAGE^XMXUTIL(.AXABORT) Q:AXABORT . . W @IOF D HDR . W !,AXREC Q HDR ; - S AXPAGE=AXPAGE+1 - W "NHE Results for ",$$NAME^XMXUTIL(DUZ),?70,$J("Page "_AXPAGE,9) - N I S I=0 F S I=$O(AXHDR(I)) Q:'I W !,AXHDR(I) - W !,$$REPEAT^XLFSTR("=",79) + N I + W "NHE Results for ",$$NAME^XMXUTIL(DUZ),?70,"Page ",AXPAGE + S I=0 F S I=$O(AXHDR(I)) Q:'I W !,AXHDR(I) + W !,$$REPEAT^XLFSTR("-",79) Q diff -auBN ./r1/AFJXWCBP.m ./r2/r/AFJXWCBP.m --- ./r1/AFJXWCBP.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/AFJXWCBP.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,3 @@ +AFJXWCBP ;FJ/CWS; * OBSOLETE * ;4/11/96 05:36 + ;;5.1;Network Health Exchange;**1,31**;Jan 23, 1996 + Q diff -auBN ./r1/AFJXWCP1.m ./r2/r/AFJXWCP1.m --- ./r1/AFJXWCP1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AFJXWCP1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ AFJXWCP1 ;FO-OAKLAND/GMB-REQUEST PATIENT INFORMATION ;4/11/96 05:36 - ;;5.1;Network Health Exchange;**1,31,34**;Jan 23, 1996 + ;;5.1;Network Health Exchange;**1,31**;Jan 23, 1996 ; Totally rewritten 11/2001. (Previously FJ/CWS.) ; Called from ^AFJXWCPM REQUEST(AXTYPE) ; Request data @@ -38,7 +38,7 @@ S DIR("A")="Would you like to look for any previous requests on file" S DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S AXABORT=1 Q - D:Y ENTER^AFJXMBOX + D:Y FIRST^AFJXMBOX Q SITES(AXTO,AXABORT) ; Choose station(s) N AXFINIS,AXDOMIEN,AX25IEN,DIR,X,Y,DIRUT diff -auBN ./r1/AFJXWCPB.m ./r2/r/AFJXWCPB.m --- ./r1/AFJXWCPB.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/AFJXWCPB.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,3 @@ +AFJXWCPB ;FJ/CWS; * OBSOLETE * ;11/8/95 + ;;5.1;Network Health Exchange;**1,2,31**;Jan 23, 1996 + Q diff -auBN ./r1/AFJXWCPD.m ./r2/r/AFJXWCPD.m --- ./r1/AFJXWCPD.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/AFJXWCPD.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,3 @@ +AFJXWCPD ;FJ/CWS; * OBSOLETE * ;11/8/95 ;1/9/96 14:49 + ;;5.1;Network Health Exchange;**32**;Jan 23, 1996 + Q diff -auBN ./r1/AFJXWCPM.m ./r2/r/AFJXWCPM.m --- ./r1/AFJXWCPM.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AFJXWCPM.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ AFJXWCPM ;FO-OAKLAND/GMB-REQUEST PATIENT INFO MENU ;11/8/95 - ;;5.1;Network Health Exchange;**6,22,31,33,34**;Jan 23, 1996 + ;;5.1;Network Health Exchange;**6,22,31,33**;Jan 23, 1996 ; Totally rewritten 11/2001. (Previously FJ/CWS.) ; Entry point: ; EN - Invoked by option AFJXNHEX REQUEST @@ -36,10 +36,12 @@ D REQUEST^AFJXWCP1("R") Q 5 ; Print (Completed Requests Only) - D ENTER^AFJXMBOX + D ^AFJXMBOX + K ANS,BEND,I,J,K,MSG,NHXU,NPX,X,Y,Z,ZTRTN Q 6 ; Print By Type of Information (Completed Requests) - D ENTER^AFJXMABX + D ^AFJXMABX + K J,K,NHXU,NPX,ANS,I,ITR,ZTRTN Q HDR ; Print page header N AX1,AX2 diff -auBN ./r1/AFJXWCPY.m ./r2/r/AFJXWCPY.m --- ./r1/AFJXWCPY.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/AFJXWCPY.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,3 @@ +AFJXWCPY ;FJ/CWS; * OBSOLETE * ;11/8/95 + ;;5.1;Network Health Exchange;**1,31**;Jan 23, 1996 + Q diff -auBN ./r1/ALPBBK.m ./r2/r/ALPBBK.m --- ./r1/ALPBBK.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBBK.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,176 +0,0 @@ -ALPBBK ;OIFO-DALLAS MW,SED,KC,KCF PRINT BLANK MAR BCMA FOR SELECTED PATIENT ;04/25/03 - ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 - ; - ; NOTE: this routine is designed for hard-copy output. - ; Output is formatted for 132-column printing. - ; - F D Q:$D(DIRUT) - .W !!,"Inpatient Pharmacy Orders for a selected patient" - .S DIR(0)="PAO^53.7:QEMZ" - .S DIR("A")="Select PATIENT NAME: " - .D ^DIR K DIR - .I $D(DIRUT) K X,Y Q - .S ALPBIEN=+Y - .S ALPBPTN=Y(0,0) - .S %ZIS="Q" - .S %ZIS("B")=$$DEFPRT^ALPBUTL() - .I %ZIS("B")="" K %ZIS("B") - .; print how many days MAR?... - .S DIR(0)="NA^3:7" - .S DIR("A")="Print how many days MAR? " - .S DIR("B")=$$DEFDAYS^ALPBUTL() - .S DIR("?")="The default is shown; you may select 3 or 7." - .W ! D ^DIR K DIR - .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q - .S ALPBDAYS=+Y - .; - .W ! D ^%ZIS K %ZIS - .I POP D Q - ..K ALPBIEN,ALPBPTN,POP - .; - .; output not queued... - .I '$D(IO("Q")) D - ..U IO - ..D DQ - ..I IO'=IO(0) D ^%ZISC - .; - .; set up the Task... - .I $D(IO("Q")) D - ..S ZTRTN="DQ^ALPBBK" - ..S ZTIO=ION - ..S ZTDESC="PSB INPT PHARM ORDERS FOR "_ALPBPTN - ..S ZTSAVE("ALPBDAYS")="" - ..S ZTSAVE("ALPBIEN")="" - ..S ZTSAVE("ALPBMLOG")="" - ..S ZTSAVE("ALPBOTYP")="" - ..D ^%ZTLOAD - ..D HOME^%ZIS - ..W !!,$S(+$G(ZTSK):"Task "_ZTSK_" queued.",1:"ERROR: NOT QUEUED!") - ..K IO("Q"),ZTSK - .; - .K ALPBDAYS,ALPBIEN,ALPBMLOG,ALPBOTYP,ALPBPTN,X,Y - K DIRUT,DTOUT,X,Y - Q - ; -DQ ; output entry point... - K ^TMP($J) - ; - ; set report date... - S ALPBRDAT=$$DT^XLFDT() - S ALPBPT(0)=$G(^ALPB(53.7,ALPBIEN,0)) - M ALPBPT(1)=^ALPB(53.7,ALPBIEN,1) - S ALPBPG=1 - D HDR^ALPBFRMU(.ALPBPT,ALPBPG,.ALPBHDR) - F I=1:1:ALPBHDR(0) W !,ALPBHDR(I) - K ALPBHDR - S FOOT=0 - S DAY=ALPBDAYS - S FOOT=FOOT+1 S MST=$S(DAY=3:83,DAY=7:105,DAY=14:140) - S NST=$S(DAY=3:95,DAY=7:120,DAY=14:135) - W !?61,"Admin" D MON^ALPBUTL3(DAY) W ?74,MON D ARRAY^ALPBUTL3(DAY) - W !,?2,"Order",?13,"Start",?35,"Stop",?61,"Times" D START^ALPBUTL3(DAY) W ?NST,"Notes" - W ! F J=1:1:142 W "-" - S ADM(7)="" - F JY=1:0:5 DO Q:JY=6 - .W !,"____________|______________________|___________________",?59," |",ADM(7),?72,"|" F J=72:5:MST W ?J,"_____|" - .W !?60,"|",ADM(7),?72,"|" F J=72:5:MST W ?J,"_____|" - .W !?60,"|",ADM(7),?72,"|" F J=72:5:MST W ?J,"_____|" - .W !?60,"|",ADM(7),?72,"|" F J=72:5:MST W ?J,"_____|" - .W !?60,"|",ADM(7),?72,"|" F J=72:5:MST W ?J,"_____|" - .W !?60,"|",ADM(7),?72,"|" F J=72:5:MST W ?J,"_____|" - .W !!!,?5,"RPH Verify:___________ Nurse Verify:____________" - .W ! F J=1:1:142 W "-" - .S JY=JY+1 - D STOP - Q -STOP D FOOT - K PTNAME,WARD,SSN,BED,ST,ROOM,Y,DOB,J,IENM,DFN,NST,ANS,FOOT,SEX,ADMIN(7),PCOUNT,CURRENT,MST - Q -FOOT ;FOOTER TO FROMS - W !,"|",?13,"SIGNATURE/TITLE",?40,"| INIT",?48,"|",?60,"INJECTION SITES",?87,"|",?92,"MED/DOSE OMITTED",?115,"|",?120,"REASON",?132,"|",?135,"INIT",?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" F J=49:1:84 W "-" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?52,"Indicate RIGHT (R) or LEFT (L)" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?87,"|" F J=88:1:112 W "-" - W ?115,"|" F J=116:1:129 W "-" - W ?132,"|" F J=133:1:137 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?53,"(IM)",?75,"(SUB Q)" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?49,"1. DELTOID",?73,"6. UPPER ARM" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?49,"2. VENTRAL GLUTEAL",?73,"7. ABDOMEN" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?49,"3. GLUTEUS MEDIUS",?73,"8. THIGH" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?49,"4. MED (ANTERIOR) THIGH",?73,"9. BUTTOCK" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?49,"5. VASTUS LATERALIS",?73,"10. UPPER BACK" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W !,"|" F J=2:1:39 W "-" - W ?40,"|" F J=41:1:47 W "-" - W ?48,"|" - W ?50," PRN: E=Effective N=Not Effective" - W ?87,"|" F J=88:1:114 W "-" - W ?115,"|" F J=116:1:131 W "-" - W ?132,"|" F J=133:1:139 W "-" - W ?140,"|" - W ! F J=1:1:140 W "-" - W ?140,"|" - K ALPBDAYS,DAY,ALPBOIEN,ALPBORDN,ALPBOST,ALPBOTYP,ALPBPG,ALPBPT,ALPBRDAT,^TMP($J) - I $D(ZTQUEUED) S ZTREQ="@" - ; - ; write form feed at end if output device is a printer... - I $E(IOST)="P" W @IOF - Q diff -auBN ./r1/ALPBCBU.m ./r2/r/ALPBCBU.m --- ./r1/ALPBCBU.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBCBU.m 2003-04-25 11:54:54.000000000 -0400 @@ -1,18 +1,16 @@ -ALPBCBU ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 ;5/2/2002 +ALPBCBU ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 ;5/2/2002 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ;This is the main routine for the BCBU software. ;It handles all the entries points for the BCBU software. ;It also handles error checking. IPH(ALPMSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY - N ALPRSLT Q:'$D(ALPMSG) ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0 S ALPRSLT=$$IPH^ALPBINP(.ALPMSG) - ;I $P(ALPRSLT,U,2)'="" D ERRLG + I $P(ALPRSLT,U,2)'="" D ERRLG Q MEDL(ALPML) ;Use this entry to send MedLog messages - N ALPRSLT ;ALPML is the IEN of the MedLog for file #53.79 Q:'$D(ALPML) ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL @@ -20,30 +18,7 @@ S ALPRSLT=$$MEDL^ALPBINP(ALPML) I $P(ALPRSLT,U,2)'="" D ERRLG Q -NURV(ALDFN,ALPORD) ;Use this entry to send verifying nursing. - N ALPRSLT - ;ALDFN is the IEN of the patient - ;ALPORDR is the order number - Q:'$D(ALDFN) - Q:'$D(ALPORD) - ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL - Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0 - K ALPB - D EN^PSJBCBU(ALDFN,ALPORD,.ALPB) - S ALPBI=0 - F S ALPBI=$O(ALPB(ALPBI)) Q:ALPBI'>0 D - . I $E(ALPB(ALPBI),1,3)="MSH" S MSH=ALPBI - . I $E(ALPB(ALPBI),1,3)="PID" S PID=ALPBI - . I $E(ALPB(ALPBI),1,3)="PV1" S PV1=ALPBI - . I $E(ALPB(ALPBI),1,3)="ORC" S ORC=ALPBI - I +MSH'>0 Q ;MISSING MSH SEGMENT BAD MESSAGE - S MSCTR=$E(ALPB(MSH),4,8) - S ALPRSLT=$$INI^ALPBINP() - ;I $P(ALPRSLT,U,2)'="" D ERRLG - K ALPB,ALPBI - Q PMOV ;Entry Point to send patient movement - N ALPRSLT ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0 Q:'$D(DFN)!'$D(DGPMTYP)!'$D(DGPMUC) @@ -54,7 +29,7 @@ ;Alert K XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG S XQA("G.PSB BCBU ERRORS")="" - S XQAMSG="BCBU Contingency Error" + S XQAMSG="BCBU Contingecy Error" S XQADATA=ALPRSLT S XQAROU="PERR^ALPBCBU" ;S XQAOPT="PSB BCBU ERROR LOG" @@ -64,6 +39,6 @@ D SETUP^XQALERT Q PERR ;Process the error - W @IOF,!,"PSB BCBU Contingency Error",! + W @IOF,!,"PSB BCBU Contingecy Error",! W ?10,$P(XQADATA,U,2)_" / "_$P(XQADATA,U,3) Q diff -auBN ./r1/ALPBELOG.m ./r2/r/ALPBELOG.m --- ./r1/ALPBELOG.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBELOG.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBELOG ;OIFO-DALLAS MW,SED,KC - BCBU LOG PROCESSOR ;01/01/03 +ALPBELOG ;emc,ets/mw,sd,kc-error log processor ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; This utility processes error log entries from the @@ -19,20 +19,18 @@ .S ^TMP("ALPBELOG",$J,1,0)="BCMA BACKUP PARAMETERS FILE IS NOT SET UP CORRECTLY." .K ALPBPARM .S VALMCNT=1 - I $O(^ALPB(53.71,"C",""))="" D Q + I +$O(^ALPB(53.71,"C",0))'>0 D Q .S ^TMP("ALPBELOG",$J,1,0)="There are no errors in the log." .S VALMCNT=1 ; - S ALPBLINE=0 - S ALPBIEN="" - F S ALPBIEN=$O(^ALPB(53.71,"C",ALPBIEN)) Q:ALPBIEN="" D - .I ALPBIEN>0 D CLEAN^ALPBUTL1(ALPBIEN) - .I ALPBIEN>0&('$D(^ALPB(53.7,ALPBIEN,0))) Q + S (ALPBIEN,ALPBLINE)=0 + F S ALPBIEN=$O(^ALPB(53.71,"C",ALPBIEN)) Q:'ALPBIEN D + .D CLEAN^ALPBUTL1(ALPBIEN) + .I '$D(^ALPB(53.7,ALPBIEN,0)) Q .S ALPBPDAT=$G(^ALPB(53.7,ALPBIEN,0)) - .I ALPBPDAT="" S ALPBPDAT="SYSTEM/FILER ERROR^" + .I ALPBPDAT="" K ALPBPDAT Q .S ALPBLINE=ALPBLINE+1 - .S ALPBDATA(ALPBLINE,0)=" "_$P(ALPBPDAT,U) - .I $P(ALPBPDAT,U,2)'="" S ALPBDATA(ALPBLINE,0)=ALPBDATA(ALPBLINE,0)_$P(ALPBPDAT,U,2) + .S ALPBDATA(ALPBLINE,0)=" "_$P(ALPBPDAT,U)_" (SSN: "_$P(ALPBPDAT,U,2)_")" .S ALPBX=0 .F S ALPBX=$O(^ALPB(53.71,"C",ALPBIEN,ALPBX)) Q:'ALPBX D ..S ALPBEIEN=0 diff -auBN ./r1/ALPBFRM1.m ./r2/r/ALPBFRM1.m --- ./r1/ALPBFRM1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBFRM1.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBFRM1 ;OIFO-DALLAS MW,SED,KC -STANDARD PRINT FORMATTING UTILITIES;01/01/03 +ALPBFRM1 ;emc,ets/mw,sd,kc-standard print formatting utilities ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; F132(DATA,DAYS,MLDATE,RESULTS) ; format 53.7 order data into a 132-column output array... @@ -9,20 +9,12 @@ ; this is usually a 3-day MAR, but a 7-day MAR could be ; returned from this format utility) ; MLDATE = a date from which med log entries will start - ; RESULTS = an array passed by reference into which the formatted - ; entry is set up returns a formatted array in RESULTS + ; RESULTS = an array passed by reference into which the formated + ; entry is set up returns a formated array in RESULTS ; (note: total line count is returned at RESULTS(0)) I $D(DATA)="" Q ; - N ALPBADM,ALPBDAYS,ALPBDRUG,ALPBIBOX,ALPBNBOX,ALPBPBOX,ALPBSTOP,ALPBTEXT,ALPBTIME,ALPBX,DATE,LINE,BOLDON,BOLDOFF,X,ALPBPRNG,ALPBFLG,ALPBPRN - ; to use BOLD, comment out the next line and remove comments from - ; the following five lines... - S BOLDON="<<",BOLDOFF=">>" - ;S X="IOINHI;IOINORM" - ;D ENDR^%ZISS - ;S BOLDON=$G(IOINHI) - ;S BOLDOFF=$G(IOINORM) - ;D KILL^%ZISS + N ALPBADM,ALPBDAYS,ALPBIBOX,ALPBNBOX,ALPBPBOX,ALPBSTOP,ALPBTEXT,ALPBTIME,ALPBX,DATE,LINE I $G(DAYS)="" S DAYS=3 I DAYS>7 S DAYS=7 S DATE=$$DT^XLFDT() @@ -43,26 +35,28 @@ S RESULTS(2)=$$PAD^ALPBUTL(RESULTS(2),25)_"Stop" S RESULTS(2)=$$PAD^ALPBUTL(RESULTS(2),66)_"Times" S RESULTS(2)=$$PAD^ALPBUTL(RESULTS(2),74)_ALPBDAYS(0) - I DAYS=3 S RESULTS(2)=RESULTS(2)_" Notes" + ;I ALPBADM<16&(DAYS=3) S RESULTS(2)=RESULTS(2)_" Notes" ; line 3... S RESULTS(3)=$$REPEAT^XLFSTR("-",132) ; line 4... ; start and stop date/times... S RESULTS(4)=$S($P($G(DATA(1)),"^")'="":$$FMTE^XLFDT($P(DATA(1),"^")),1:"Not on file") S RESULTS(4)=$$PAD^ALPBUTL(RESULTS(4),25)_$S($P($G(DATA(1)),"^",2)'="":$$FMTE^XLFDT($P(DATA(1),"^",2)),1:"Not on file") + ; line 5... + ; order number and type... + S RESULTS(5)=" Order #: "_$P(DATA(0),"^") + S RESULTS(5)=$$PAD^ALPBUTL(RESULTS(5),25)_"Type: "_$$OTYP^ALPBUTL($P($G(DATA(3)),"^")) + S RESULTS(6)=" Status: "_$P(DATA(0),"^",3) ; ; end of fixed line format, continue... - S LINE=4 + S LINE=6 ; get drug(s)... I +$O(DATA(7,0)) D .S LINE=LINE+1 .S RESULTS(LINE)="" .S ALPBX=0 .F S ALPBX=$O(DATA(7,ALPBX)) Q:'ALPBX D - ..S ALPBDRUG=$G(BOLDON)_$P(DATA(7,ALPBX,0),"^",2)_$G(BOLDOFF) - ..;S RESULTS(LINE)=$G(RESULTS(LINE))_$P(DATA(7,ALPBX,0),"^",2) - ..S RESULTS(LINE)=$G(RESULTS(LINE))_ALPBDRUG - ..K ALPBDRUG + ..S RESULTS(LINE)=$G(RESULTS(LINE))_$P(DATA(7,ALPBX,0),"^",2) ..I +$O(DATA(7,ALPBX)) S LINE=LINE+1 ; any additives... I +$O(DATA(8,0)) D @@ -70,12 +64,9 @@ .S RESULTS(LINE)=" Additive(s): " .S ALPBX=0 .F S ALPBX=$O(DATA(8,ALPBX)) Q:'ALPBX D - ..S ALPBDRUG=$P(DATA(8,ALPBX,0),"^",2) + ..S RESULTS(LINE)=RESULTS(LINE)_$P(DATA(8,ALPBX,0),"^",2) ..; if UNITS is not already contained in ADDITIVE NAME, add it... - ..I $P(DATA(8,ALPBX,0),"^",3)'=""&(ALPBDRUG'[$P(DATA(8,ALPBX,0),"^",3)) S ALPBDRUG=ALPBDRUG_" "_$P(DATA(8,ALPBX,0),"^",3) - ..S ALPBDRUG=$G(BOLDON)_ALPBDRUG_$G(BOLDOFF) - ..S RESULTS(LINE)=RESULTS(LINE)_ALPBDRUG - ..K ALPBDRUG + ..I $P(DATA(8,ALPBX,0),"^",3)'=""&($P(DATA(8,ALPBX,0),"^",2)'[$P(DATA(8,ALPBX,0),"^",3)) S RESULTS(LINE)=RESULTS(LINE)_" "_$P(DATA(8,ALPBX,0),"^",3) ..I +$O(DATA(8,ALPBX)) D ...S LINE=LINE+1 ...S RESULTS(LINE)=" " @@ -87,12 +78,9 @@ .S RESULTS(LINE)=" Solution(s): " .S ALPBX=0 .F S ALPBX=$O(DATA(9,ALPBX)) Q:'ALPBX D - ..S ALPBDRUG=$P(DATA(9,ALPBX,0),"^",2) + ..S RESULTS(LINE)=RESULTS(LINE)_$P(DATA(9,ALPBX,0),"^",2) ..; if UNITS is not already contained in SOLUTION NAME, add it... - ..I $P(DATA(9,ALPBX,0),"^",3)'=""&(ALPBDRUG'[$P(DATA(9,ALPBX,0),"^",3)) S ALPBDRUG=ALPBDRUG_" "_$P(DATA(9,ALPBX,0),"^",3) - ..S ALPBDRUG=$G(BOLDON)_ALPBDRUG_$G(BOLDOFF) - ..S RESULTS(LINE)=RESULTS(LINE)_ALPBDRUG - ..K ALPBDRUG + ..I $P(DATA(9,ALPBX,0),"^",3)'=""&($P(DATA(9,ALPBX,0),"^",2)'[$P(DATA(9,ALPBX,0),"^",3)) S RESULTS(LINE)=RESULTS(LINE)_" "_$P(DATA(9,ALPBX,0),"^",3) ..I +$O(DATA(9,ALPBX)) D ...S LINE=LINE+1 ...S RESULTS(LINE)=" " @@ -101,9 +89,6 @@ ; give ($P(DATA(4),"^",1)=DOSAGE $P(DATA(4),"^",2)=ROUTE $P(DATA(4),"^",3)=SCHEDULE)... S LINE=LINE+1 S RESULTS(LINE)=" Give: "_$P($G(DATA(4)),"^")_" "_$P($G(DATA(4)),"^",2)_" "_$P($G(DATA(4)),"^",3) - ;Set PRN Flag - S ALPBPRNG=0 - S:$P($G(DATA(4)),"^",3)["PRN" ALPBPRNG=1 ; provider, pharmacist or entry person, and verifier... S LINE=LINE+1 S RESULTS(LINE)=" Provider: "_$P($G(DATA(2)),"^") @@ -112,13 +97,6 @@ I $P($G(DATA(2)),"^",3)'="" D .S LINE=LINE+1 .S RESULTS(LINE)=" Verified by: "_$P(DATA(2),"^",3) - ; order number and type... - S LINE=LINE+1 - S RESULTS(LINE)=" Order #: "_$P(DATA(0),"^") - S RESULTS(LINE)=$$PAD^ALPBUTL(RESULTS(LINE),25)_"Type: "_$$OTYP^ALPBUTL($P($G(DATA(3)),"^")) - ; order status... - S LINE=LINE+1 - S RESULTS(LINE)=" Status: "_$P($P(DATA(0),"^",3),"~",2) ; ; provider comments, special instructions, and other print info... I +$O(DATA(5,0)) D @@ -169,10 +147,8 @@ S ALPBIBOX="______|" S ALPBNBOX="******|" I +$G(ALPBADM)=0 S ALPBADM=8 - ;S ALPBPRN=ALPBADM+4 S ALPBSTOP=$P($G(DATA(1)),"^",2) F I=1:1:ALPBADM D - .S ALPBPRN=I+3 .S ALPBADMT=$G(ALPBADM(I)) .I ALPBADMT="" S ALPBADMT=" " .I '$D(RESULTS(I+3)) D @@ -188,12 +164,6 @@ ..S RESULTS(I+3)=RESULTS(I+3)_ALPBPBOX .K ALPBADMT,ALPBPBOX,ALPBDAY K ALPBIBOX,ALPBNBOX - ; if PRN med, add line for documenting effectiveness... - I +ALPBPRNG D - .S ALPBFLG=0,ALPBPRN=ALPBPRN+1 - .S:'$D(RESULTS(ALPBPRN)) RESULTS(ALPBPRN)=" ",ALPBFLG=1 - .S RESULTS(ALPBPRN)=$$PAD^ALPBUTL(RESULTS(ALPBPRN),63)_" PRN Effectiveness:_____________" - .S:ALPBFLG LINE=LINE+1 S LINE=LINE+1 S RESULTS(LINE)=$$REPEAT^XLFSTR("-",132) S RESULTS(0)=LINE diff -auBN ./r1/ALPBFRM2.m ./r2/r/ALPBFRM2.m --- ./r1/ALPBFRM2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBFRM2.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBFRM2 ;OIFO-DALLAS MW,SED,KC-STANDARD SCREEN DISPLAY FORMATTING UTILITIES ;01/01/03 +ALPBFRM2 ;emc,ets/mw,sd,kc-standard screen display formatting utilities ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; F80(DATA,MLDATE,RESULTS) ; format basic output for screen (80-column) display... @@ -13,7 +13,7 @@ S RESULTS(2)=" Type: "_$$OTYP^ALPBUTL($P(DATA(3),"^")) S RESULTS(2)=$$PAD^ALPBUTL(RESULTS(2),51)_"Stop: " S RESULTS(2)=RESULTS(2)_$S($P($G(DATA(1)),"^",2)'="":$$FMTE^XLFDT($P(DATA(1),"^",2)),1:"") - S RESULTS(3)=" Status: "_$P($P(DATA(0),"^",3),"~",2) + S RESULTS(3)=" Status: "_$P(DATA(0),"^",3) S LINE=3 ; drug(s)... I +$O(DATA(7,0)) D @@ -123,7 +123,7 @@ S RESULTS(2)=$P($G(DATA(0)),"^") S RESULTS(2)=$$PAD^ALPBUTL(RESULTS(2),32)_"SSN: "_$P($G(DATA(0)),"^",2) S RESULTS(2)=$$PAD^ALPBUTL(RESULTS(2),48)_"Ward: "_$P($G(DATA(0)),"^",5) - S RESULTS(3)="This record last updated: "_$S($P(DATA(0),"^",8)'="":$$FMTE^XLFDT($P(DATA(0),"^",8)),1:"") + S RESULTS(3)="BCBU Record Last Updated: "_$S($P(DATA(0),"^",8)'="":$$FMTE^XLFDT($P(DATA(0),"^",8)),1:"") S RESULTS(3)=$$PAD^ALPBUTL(RESULTS(3),48)_"Room: "_$P(DATA(0),"^",6)_" Bed: "_$P(DATA(0),"^",7) S LINE=3 I +$O(DATA(1,0)) D diff -auBN ./r1/ALPBFRMU.m ./r2/r/ALPBFRMU.m --- ./r1/ALPBFRMU.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBFRMU.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBFRMU ;OIFO-DALLAS MW,SED,KC-STANDARD PRINT FORMATTING UTILITIES;01/01/03 +ALPBFRMU ;emc,ets/mw,sd,kc-standard print formatting utilities ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; FTEXT(COL,TEXT,RESULTS) ; format TEXT array... @@ -37,13 +37,13 @@ Q ; HDR(DATA,PG,RESULTS) ; print page header... - ; DATA = an array passed by reference containing the nodes in - ; a patient's record in ^ALPB(53.7,...) - ; PG = page number to use + ; DATA = an array passed by reference containing the info that will + ; be formated + ; PG = page number to use ; RESULTS = an array passed by reference that will be used to return ; the formated data ; returns data in formated 132-column output - N ALPBALG,ALPBALGL,ALPBALGX,ALPBX,LINE + N ALPBCNT,ALPBX,LINE I $G(PG)="" S PG=0 S RESULTS(1)="MAR Ran: "_$$FMTE^XLFDT($$NOW^XLFDT()) S RESULTS(1)=$$PAD^ALPBUTL(RESULTS(1),32)_"Inpatient Pharmacy Orders (Backup)" @@ -56,26 +56,22 @@ S RESULTS(3)=$$PAD^ALPBUTL(RESULTS(3),32)_"Room: "_$P($G(DATA(0)),"^",6) S RESULTS(3)=$$PAD^ALPBUTL(RESULTS(3),50)_"Bed: "_$P($G(DATA(0)),"^",7) S RESULTS(4)="" - S RESULTS(4)=$$PAD^ALPBUTL(RESULTS(4),12)_"This record last updated: " + S RESULTS(4)=$$PAD^ALPBUTL(RESULTS(4),12)_"BCBU Record Last Updated: " S RESULTS(4)=RESULTS(4)_$S($P(DATA(0),"^",8)'="":$$FMTE^XLFDT($P(DATA(0),"^",8)),1:"") S LINE=4 ; report allergies... I +$O(DATA(1,0)) D .S LINE=LINE+1 - .S RESULTS(LINE)="" - .S ALPBALGX="Allergies: " - .S ALPBALGL=$L(ALPBALGX)-1 + .S RESULTS(LINE)="Allergies: " .S (ALPBCNT,ALPBX)=0 .F S ALPBX=$O(DATA(1,ALPBX)) Q:'ALPBX D - ..S ALPBALG=$P($G(DATA(1,ALPBX,0)),"^",2) - ..I ALPBALG="" K ALPBALG Q - ..I $L(ALPBALGX_ALPBALG_"; ")>90 D + ..S ALPBCNT=ALPBCNT+1 + ..I ALPBCNT>5 D ...S LINE=LINE+1 - ...S RESULTS(LINE)="" - ...S ALPBALGX="" - ...S ALPBALGX=$$PAD^ALPBUTL(ALPBALGX,ALPBALGL) - ..S ALPBALGX=ALPBALGX_ALPBALG_$S(+$O(DATA(1,ALPBX)):"; ",1:"") - ..S RESULTS(LINE)=ALPBALGX + ...S RESULTS(LINE)=" " + ...S RESULTS(LINE)=$$PAD^ALPBUTL(RESULTS(LINE),12) + ..S RESULTS(LINE)=RESULTS(LINE)_$P($G(DATA(1,ALPBX,0)),"^",2) + ..I +$O(DATA(1,ALPBX)) S RESULTS(LINE)=RESULTS(LINE)_"; " S RESULTS(0)=LINE Q ; diff -auBN ./r1/ALPBGEN1.m ./r2/r/ALPBGEN1.m --- ./r1/ALPBGEN1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBGEN1.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003 07:59 +ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/16/2003 14:45 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 Q ; @@ -19,10 +19,12 @@ F X HLNEXT Q:$G(HLQUIT)'>0 D . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2) . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF + ;I "B01B02"'[$G(ALPBMT) G PERR Q PSTF ;Process STF segment S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA" S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D + . ;Verify SSN . S ALPBSSN=$TR(ALPBSSN,"-","") . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE" . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE" @@ -90,6 +92,6 @@ K I,J,K,L,X Q ST PERR ;PROCESSING ERRORS - H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR + H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU","APPLICATION",DATE)=ALERR K ALERR Q diff -auBN ./r1/ALPBGEN2.m ./r2/r/ALPBGEN2.m --- ./r1/ALPBGEN2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBGEN2.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBGEN2 ;SFVAMC/JC - Init New Person Data on Workstations ;05/12/2003 07:40 +ALPBGEN2 ;SFVAMC/JC - Init New Person Data on Workstations ;04/23/2003 08:42 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 INIT ;Initial Load N DIR,DTOUT,DUOUT,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK @@ -17,8 +17,8 @@ Q ; N ALPBI,ALPBJ,ALPBK S DTS=$$FMTE^XLFDT($$NOW^XLFDT) - S (ALPBK)=0,ALPBJ="" F S ALPBJ=$O(^VA(200,ALPBJ)) Q:ALPBJ="" D - . Q:+ALPBJ<1 + S (ALPBK,ALPBJ)=0 F S ALPBJ=$O(^VA(200,ALPBJ)) Q:ALPBJ<.1 D + . Q:ALPBJ<1 . I $$ISBCMA(ALPBJ)>0 D . . I '$D(ZTSK) W !,ALPBJ_" "_$P(^VA(200,ALPBJ,0),U) . . D DEQUE^XUSERP(ALPBJ,1) diff -auBN ./r1/ALPBGEN.m ./r2/r/ALPBGEN.m --- ./r1/ALPBGEN.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBGEN.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,18 +1,11 @@ -ALPBGEN ;SFVAMC/JC - Build HL7 PMU messages ;10/08/2003 14:10 - ;;3.0;BAR CODE MED ADMIN;**7**;May 2002 +ALPBGEN ;SFVAMC/JC - Build HL7 PMU messages ;04/18/2003 12:40 + ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 HL7(XUIEN,XUFLG,XUSR) ;GENERATE MESSAGE - For Subscriber to XUSER DATA REQUEST (BCBU PMU MESSAGE BUILDER) ;Build HL7 PMU~B01 or B02 message from array XUSR() and XUNAME() ;B01=Personnel Add/Create event type ;B02=Personnel Update event type - ; - ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL - Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0 Q:'$D(XUSR) ;Array of user data from Kernel Q:'$D(XUIEN) ;Internal entry of user required - ; - ;SFVAMC/JC - 10/8/03 ADD CHECK FOR BCMA USER STATUS - Q:+$$ISBCMA^ALPBGEN2(XUIEN)<1 - ; N ALPBEVN,MT,FS,EC,CS,RS,ESC,SS,N,ALERR,ALPBDIV,ALPBRCV,ECS,EEC,EFS,ERS,ESS,HLA,HLMTIENS,HLNEXT,HLNODE,HLQUIT,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK S ALPBEVN=$S(XUFLG=1:"PSB BCBU PMU_B01 EVENT",1:"PSB BCBU PMU_B02 EVENT") S ALPBRCV=$S(XUFLG=1:"PSB BCBU PMU_B01 RECV",1:"PSB BCBU PMU_B02 RECV") @@ -21,25 +14,25 @@ S N=0 S MT=$S(XUFLG=1:"B01",1:"B02") S FS=$G(HL("FS")) Q:FS="" ;Field separator - S EC=$G(HL("ECH")) Q:EC="" ;Encoding Characters + S EC=$G(HL("ECH")) Q:EC="" ;Encoding Charaters S CS=$E(EC) ;Component separator - S RS=$E(EC,2) ;Repetition separator + S RS=$E(EC,2) ;Repitition separator S ESC=$E(EC,3) ;Escape character S SS=$E(EC,4) ;Subcomponent separator S EEC=ESC_"E"_ESC ;escaped escape character - S EFS=ESC_"F"_ESC ;escaped field separator - S ECS=ESC_"S"_ESC ;escaped component separator - S ERS=ESC_"R"_ESC ; escaped Repetition separator + S EFS=ESC_"F"_ESC ;escaped field sep + S ECS=ESC_"S"_ESC ;escaped component sep + S ERS=ESC_"R"_ESC ; escaped repitition sep S ESS=ESC_"T"_ESC ;escaped subcomponent separator EVN ;EVN segment S N=N+1 S HLA("HLS",N)="EVN"_FS_MT_FS_$$FMTHL7^XLFDT($$NOW^XLFDT) GSTF ;Generate Staff Detail Segment - N ALPBSSN,STF S STF="STF" + N SSN,STF S STF="STF" S $P(STF,FS,2)=XUIEN_CS_200_CS_"VISTA" ;Primary Key ;Staff ID Code - S ALPBSSN=$TR($G(XUSR("ALPBSSN")),"-","") S:+ALPBSSN ALPBSSN=$$M10^HLFNC(ALPBSSN,EC) S:'+ALPBSSN ALPBSSN=ALPBSSN_CS_""_CS_"LOCAL" - S $P(STF,FS,3)=ALPBSSN_CS_"USSSA"_CS_"SS"_RS_$$ESC($G(XUSR("ACCESS CODE")))_RS_$$ESC($G(XUSR("VERIFY CODE"))) + S SSN=$TR($G(XUSR("SSN")),"-","") S:+SSN SSN=$$M10^HLFNC(SSN,EC) S:'+SSN SSN=SSN_CS_""_CS_"LOCAL" + S $P(STF,FS,3)=SSN_CS_"USSSA"_CS_"SS"_RS_$$ESC($G(XUSR("ACCESS CODE")))_RS_$$ESC($G(XUSR("VERIFY CODE"))) ;Staff Name N SN S SN="" I $D(XUSR("HL7NAME")) D @@ -58,13 +51,9 @@ Q:'$D(HLA) ;Check user's divisions SEND K HLL S ALPBDIV="" F S ALPBDIV=$O(XUSR("DIV",ALPBDIV)) Q:ALPBDIV="" D - . K DIC,D,X,Y - . S DIC="^DG(40.8,",D="AD",X=ALPBDIV,DIC(0)="XN" - . D IX^DIC - . Q:+Y'>0 - . S ALPBDIV1=+Y - . K DIC,D,X,Y - . D GET^ALPBPARM(.HLL,ALPBDIV1) + . Q:'$D(^DG(40.8,"AD",ALPBDIV)) ;does institution live in 40.8? + . S ALPBDIV1=$O(^DG(40.8,"AD",ALPBDIV,0)) ;MC Div ien + . K HLL D GET^ALPBPARM(.HLL,ALPBDIV1) . I $D(HLL) S I=0 F S I=$O(HLL("LINKS",I)) Q:I<1 S $P(HLL("LINKS",I),"^",1)=ALPBRCV ;If no division assoc. use defaults I $O(XUSR("DIV",0))=""!('$D(HLL)) D GET^ALPBPARM(.HLL,"","",ALPBRCV) diff -auBN ./r1/ALPBHL1.m ./r2/r/ALPBHL1.m --- ./r1/ALPBHL1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBHL1.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,5 +1,5 @@ -ALPBHL1 ;OIFO-DALLAS MW,SED,KC - BCBU main HL7 message processor ;01/01/03 - ;;3.0;BAR CODE MED ADMIN;**7**;May 2002 +ALPBHL1 ;emc,ets/mw,sd,kc-main HL7 message processor ;01/01/03 + ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; S ALPBECH=HL("ECH") S ALPBCS=$E(ALPBECH) @@ -37,13 +37,17 @@ .D CLEAN K ALPBMTXT("PID") ; - ; using patient's DFN, get BCBU record number... - S ALPBIEN=0 - I $D(^ALPB(53.7,ALPBPDFN)) S ALPBIEN=ALPBPDFN + ; using patient's SSN, get patient's record number... + S DIC="^ALPB(53.7," + S DIC(0)="MZ" + S X=ALPBPSSN + D ^DIC K DIC + S ALPBIEN=+Y ; create new record?... I ALPBIEN'>0 D .S DIC="^ALPB(53.7," .S DIC(0)="LZ" + .S DIC("DR")="1///^S X=ALPBPSSN;2///^S X=ALPBPDOB;3///^S X=ALPBPSEX" .S DINUM=ALPBPDFN .S DLAYGO=53.7 .S X=ALPBPNAM @@ -63,15 +67,6 @@ .D DELPT^ALPBUTL(+$G(ALPBIEN)) .D CLEAN ; - ; file/update patient demographic data... - S ALPBFILE(53.7,ALPBIEN_",",.01)=ALPBPNAM - S ALPBFILE(53.7,ALPBIEN_",",1)=ALPBPSSN - S ALPBFILE(53.7,ALPBIEN_",",2)=ALPBPDOB - S ALPBFILE(53.7,ALPBIEN_",",3)=ALPBPSEX - D FILE^DIE("","ALPBFILE","ALPBFERR") - I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),0,$G(ALPBHREC),"PID","Demographics update failed",.ALPBFERR) - K ALPBFERR,ALPBFILE - ; ; if the allergies flag is set (ALPBMTXT("AL1")), delete any ; allergies on file (they will be rebuilt by this message)... I +$G(ALPBMTXT("AL1")) D DELALG^ALPBUTL2(ALPBIEN) @@ -110,9 +105,10 @@ K ALPBOIEN S ALPBOIEN=+$O(^ALPB(53.7,ALPBIEN,2,"B",ALPBORDN,0)) ; if this isn't a Med Log update, and this order is already on - ; file, delete its drug(s), additive(s) and/or solution(s) -- - ; they will be rebuilt by the other segments in this message... - I +$G(ALPBMLOG)=0&(ALPBOIEN>0) D CLORD^ALPBUTL2(ALPBIEN,ALPBOIEN) + ; file, delete it so that it can be rebuilt... + I '+$G(ALPBMLOG)&(ALPBOIEN>0) D + .D DELORD^ALPBUTL(ALPBIEN,ALPBOIEN) + .S ALPBOIEN=0 ; create new order record?... I +$G(ALPBOIEN)=0 D .S ALPBOIEN=+$O(^ALPB(53.7,ALPBIEN,2," "),-1)+1 @@ -155,8 +151,6 @@ ..I $G(ALPBDATA)="" Q ..; if this is a Pending order, check to see if a drug is included in this RXE seg. if not, let's try to add the one that may be in the RXO seg... ..I +$P($P(ALPBDATA,ALPBFS,3),ALPBCS,4)=0 S $P(ALPBDATA,ALPBFS,3)=$P($G(ALPBMTXT("RXO")),ALPBFS,2) - ..;chech for any continuation lines - ..S J=0 F S J=$O(ALPBMTXT(I,J)) Q:'J S ALPBDATA=ALPBDATA_ALPBMTXT(I,J) ..D RXE^ALPBHL1U(+$G(ALPBIEN),+$G(ALPBOIEN),ALPBDATA,$G(ALPBFS),$G(ALPBCS),$G(ALPBECH),.ALPBFERR) ..I +$G(ALPBFERR("DIERR")) D ERRLOG^ALPBUTL1(+$G(ALPBIEN),+$G(ALPBOIEN),$G(ALPBHREC),"RXE",ALPBDATA,.ALPBFERR) ..K ALPBFERR diff -auBN ./r1/ALPBHL1U.m ./r2/r/ALPBHL1U.m --- ./r1/ALPBHL1U.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBHL1U.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,5 +1,5 @@ -ALPBHL1U ;OIFO-DALLAS MW,SED,KC -HL7 MESSAGE SEGMENT PARSER AND UPDATE;01/01/03 - ;;3.0;BAR CODE MED ADMIN;**7**;May 2002 +ALPBHL1U ;emc,ets/mw,sd,kc-HL7 message segment parser and data update functions ;01/01/03 + ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; passed parameters common to all functions: ; IEN = patient's internal entry number in file 53.7 @@ -46,7 +46,7 @@ .D UPDATE^DIE("","ALPBFILE","","ERR") .; if this is a pending order, add special instructions... .I $P($P(DATA,FS,6),CS,1)="IP" D - ..S ALPBTEXT(1)="CAUTION! THIS IS A PENDING ORDER :: CHECK WITH PROVIDER OR PHARMACIST!" + ..S ALPBTEXT(1)="CAUTION! THIS IS A PENDING ORDER :: CHECK WITH PROVIDER!" ..D WP^DIE(53.702,ALPBFIEN,8,"A","ALPBTEXT","ERR") ..K ALPBTEXT ; ORC segment with specific MedLog data... @@ -139,12 +139,12 @@ ; dosage... S ALPBFILE(53.702,ALPBFIEN,7)=$P(ALPBX,CS,8) ; schedule... - S ALPBSCHD=$P(ALPBX,CS,2) + S ALPBSCHD=$P($P(ALPBX,CS,2),SCS) I $P(DATA,FS,24)'="" S ALPBSCHD=ALPBSCHD_" "_$P(DATA,FS,24) I $P($P(DATA,FS,25),CS,5)'="" S ALPBSCHD=ALPBSCHD_" "_$P($P(DATA,FS,25),CS,5) S ALPBFILE(53.702,ALPBFIEN,7.2)=ALPBSCHD ; timing... - S ALPBFILE(53.702,ALPBFIEN,7.3)=$P($P(DATA,FS,22),CS,2) + S ALPBFILE(53.702,ALPBFIEN,7.3)=$P($P(ALPBX,CS,2),SCS,2) D UPDATE^DIE("","ALPBFILE","","ERR") Q ; diff -auBN ./r1/ALPBIND.m ./r2/r/ALPBIND.m --- ./r1/ALPBIND.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBIND.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBIND ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 INIT ;5/2/2002 +ALPBIND ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 INIT ;5/2/2002 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; Reference/IA @@ -16,6 +16,7 @@ ;D:'$D(DIRUT) QUE D QUE G EXIT + Q ; ALLWKS ;If no then set allow the user to select the workstation K DTOUT,DUOUT,DIRUT,DIROUT,DIR @@ -99,14 +100,14 @@ K ALPB,ALPBI,ALPBJ,ALPCN,ALDFN,ALPMDT,ALPML,ALPORDR,MSCTR,MSH,ORC K PID,PV1,ALPHLL,ALPALL,DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,ALPDIV K ALPTST,ALPSTOP,ALPOK,ZTSAVE,ALPCNI,ALPCNT,ALP,ALPDVN,ALPSLT,ALPWKS - K PID,PV1,^TMP("PSJ",$J),^TMP("PSJBU",$J) + K PID,PV1,^TMP("PSJ",$J),^TMP("PSJBU") ; Q MLOG ;Need to loop though the Med log file to get all med logs ;associated with the order Q:'$D(^PSB(53.79,"AORDX",ALDFN,ALPORDR)) S X=+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP MEDLG",1,"Q") - S X=$S(X>0:"T-"_X,1:"T-30") + S X=$S(X>0:"T-"_X,1:"T-90") D ^%DT Q:+Y'>0 ;Cannot get a valid date S ALPMDT=Y @@ -127,7 +128,7 @@ . I $E(ALPB(ALPBI),1,3)="PV1" S PV1=ALPBI . I $E(ALPB(ALPBI),1,3)="ORC" S ORC=ALPBI I +MSH'>0 Q ;MISSING MSH SEGMENT BAD MESSAGE - S MSCTR=$E(ALPB(MSH),4,8),ALPORD=ALPORDR + S MSCTR=$E(ALPB(MSH),4,8) S X=$$INI^ALPBINP() Q SNDPT ;Send a Single Patient @@ -143,7 +144,7 @@ PAT ; K ^TMP("PSJBU",$J) S X=+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP IPH",1,"Q") - S X=$S(X>0:"T-"_X,1:"T-15") + S X=$S(X>0:"T-"_X,1:"T-30") D ^%DT Q:+Y'>0 ;Cannot get a valid date D EN2^PSJBCBU(ALDFN,Y) diff -auBN ./r1/ALPBIN.m ./r2/r/ALPBIN.m --- ./r1/ALPBIN.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBIN.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBIN ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 INIT ;5/2/2002 +ALPBIN ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 INIT ;5/2/2002 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; Reference/IA @@ -53,8 +53,8 @@ . S ALPSCRN($P(ALPHLL("LINKS",ALP),U,2),ALP)=ALPHLL("LINKS",ALP) K ALPHLL F D LP Q:$D(DIRUT) - ;I $D(DIRUT)!$D(ALPHLL) W !!,"No Selected Workstations" G ALLWKS - I '$D(ALPBANS)!$D(ALPHLL) W !!,"No Selected Workstations" G ALLWKS + ;I $D(DIRUT)!$D(ALPHLL) W !!,"No Selected Workstaions" G ALLWKS + I '$D(ALPBANS)!$D(ALPHLL) W !!,"No Selected Workstaions" G ALLWKS Q:'$D(ALPBANS) S ALP="",ALPCNT=1 F S ALP=$O(ALPBANS(ALP)) Q:ALP="" D diff -auBN ./r1/ALPBINP.m ./r2/r/ALPBINP.m --- ./r1/ALPBINP.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBINP.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002 +ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 ;5/2/2002 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ;This routine will intercept the HL7 message that it sent from Pharmacy ;to CPRS to update order information. The message is then parsed and @@ -27,11 +27,11 @@ S PID=0 F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID" I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message" - ;Also the patient must have an inpatient status + ;Also the patient must have a inpatient status S PV1=0 F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1" I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message" - I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message" + I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not a Inpatient Pharmacy Message" S ORC=0 F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC" I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message" @@ -42,7 +42,7 @@ I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC" K ALPB D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB) -SEED ;Entry point for ^ALPBIND +SEED ;Entry point for ^ALPBINT D INIT S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D . ;convert and move the message to the HLA array for transport @@ -51,16 +51,9 @@ . S SUB1=0 . F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1)) - . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB - . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB - . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB K HLA("HLS",MSH) - I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message" + S HLA("HLS",PID)=$$EN^VAFHLPID($P(HLA("HLS",PID),HLFS,4),"2,7,8,19") S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1) - I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" - S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") - ;Fix RXE segement for Administration Type - D RXE ;Get the Division that the patient is associated with D PDIV I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV @@ -105,10 +98,8 @@ Q:'$D(GMRAL) S ALPI=0,ALPC=1,ALPSYM="" F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D - . S ALPADR="" - . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** " . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7) - . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8" + . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_$E($P(GMRAL(ALPI),U,2),1,30)_HLCS_"VA120.8" . ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS . ;S $P(ALPDATA,HLFS,6)=ALPSYM @@ -116,23 +107,6 @@ . S ALPC=ALPC+1 K GMRAL Q -RXE ; - Q:+$G(RXE)'>0 - K ^TMP("PSJ1",$J) - Q:'$D(HLA("HLS",RXE)) - S DATA=HLA("HLS",RXE) - D EN^PSJBCMA1(ALPDFN,ALPORD,1) - S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2) - Q:TYP="CONTINUOUS" - Q:TYP="FILL ON REQUEST" - S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2) - I ALP1[TYP Q - I ALP2[TYP Q - S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP - S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1 - S HLA("HLS",RXE)=DATA - K TYP,ALP1,ALP2,^TMP("PSJ1",$J) - Q PDIV ;PATIENT DIVISION S ALPDIV=$$DIV^ALPBUTL1(ALPDFN) ;Now do I send the Message or not Based of Division @@ -154,7 +128,7 @@ I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log" S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9) S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7) - S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6) + S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,4) S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1) S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1) S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non") @@ -173,16 +147,6 @@ ;The Message is ready to send D SEND Q ALPRSLT - ; -ADMQ ;Need to que a single patient init for admissions - S ALDFN=ALPDFN - S ZTDTH=$$NOW^XLFDT - S ZTRTN="PAT^ALPBIND" - S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation" - S ZTIO="",ZTSAVE("ALDFN")="" - D ^%ZTLOAD - K ZTIO,ZTDESC,ZTRTN,ZTSK - Q PMOV(ALPDFN,ALPTYP,ALPTT) ;Entry Point to send patient movement N VAIN Q:+$G(ALPDFN)'>0 @@ -194,5 +158,4 @@ S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP) D SEND - I $G(ALPTT)="ADMISSION" D ADMQ Q ALPRSLT diff -auBN ./r1/ALPBPALL.m ./r2/r/ALPBPALL.m --- ./r1/ALPBPALL.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBPALL.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBPALL ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BACLUP REPORT FOR ALL WARDS ;01/01/03 +ALPBPALL ;emc/MW,SD,KC-print 3-day MAR BCMA backup report for all wards ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; based on original code by FD@NJHCS, May 2002 diff -auBN ./r1/ALPBPARM.m ./r2/r/ALPBPARM.m --- ./r1/ALPBPARM.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBPARM.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBPARM ;SFVAMC/JC - Parameter Definitions ;05/02/2003 15:24 +ALPBPARM ;SFVAMC/JC - Parameter Definitions ;03/07/2003 11:15 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 N DEF,OPR,ZLNK N ALPBSCRN,ALPBPARM,ALPBDIVE,ALPBDIVI,ALPBDIVP,ALPBINST,LNK,ERR,DIC,DIE,DA,DR,DIR @@ -99,8 +99,6 @@ . D GET(.HLL,"") ;Try to use default list if no results. GET1 ; I $O(LST(0)),ERR=0 N X S X=0 F S X=$O(LST(X)) Q:X<1 D - . Q:$P(LST(X),U,2)']"" - . N LNK870 S LNK870=$P(LST(X),U,2) Q:$E(LNK870,1,2)="VA" ;don't init hospital . S HLL("LINKS",X)=PR_U_$P(LST(X),U,2) Q DV(DV) ;take internal or external division and return institution diff -auBN ./r1/ALPBPPAT.m ./r2/r/ALPBPPAT.m --- ./r1/ALPBPPAT.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBPPAT.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBPPAT ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCBU BACKUP REPORT FOR A SELECTED PATIENT ;01/01/03 +ALPBPPAT ;emc/mw,sd,kc-print 3-day MAR BCMA backup report for a selected patient ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; NOTE: this routine is designed for hard-copy output. Output is formatted diff -auBN ./r1/ALPBPWRD.m ./r2/r/ALPBPWRD.m --- ./r1/ALPBPWRD.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBPWRD.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03 +ALPBPWRD ;emc/MW,SD,KC-print 3-day MAR BCMA backup report for a selected ward ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; NOTE: this routine is designed for hard-copy output. Output is formatted @@ -82,7 +82,7 @@ .; .; set up the Task... .I $D(IO("Q")) D - ..S ZTRTN="DQ^ALPBPWRD" + ..S ZTRTN="DQ^ALPBHL2" ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD ..S ZTSAVE("ALPBDAYS")="" ..S ZTSAVE("ALPBWARD")="" diff -auBN ./r1/ALPBSID.m ./r2/r/ALPBSID.m --- ./r1/ALPBSID.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/ALPBSID.m 2003-04-17 10:15:24.000000000 -0400 @@ -0,0 +1,25 @@ +ALPBSID ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 ;12/13/2002 14:15 + ;;1.0;BCBU;**;May 02, 2002 + S ALPBDFN=999 + S ALPRSLT="0^PID^tHIS IS A TEST" + D TEST^ALPBTST + S ALPBFERR("DIERR",1)=9999 + M ALPBFERR("DIERR",1,"TEXT")=HLA("HLS") + D ERRLG + Q +ERRLG ;Error Log Message + ;Alert + K XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG + S XQA("G.PSB BCBU ERRORS")="" + S XQAMSG="BCBU Contingecy Error" + S XQADATA=ALPRSLT + S XQAROU="PERR^ALPBCBU" + ;D ERRBLD^ALPBUTL1($P(XQADATA,U,2),$P(XQADATA,U,3),.ALPBFERR) + D ERRLOG^ALPBUTL1(ALPBDFN,0,0,$P(XQADATA,U,2),$P(XQADATA,U,3),.ALPBFERR) + D SETUP^XQALERT + ;Add error to error log + Q +PERR ;Process the error + W @IOF,!,"PSB BCBU Contingecy Error",! + W ?10,$P(XQADATA,U,2)_" / "_$P(XQADATA,U,3) + Q diff -auBN ./r1/ALPBSP1.m ./r2/r/ALPBSP1.m --- ./r1/ALPBSP1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBSP1.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBSP1 ;OIFO-DALLAS MW,SED,KC-LIST AND SELECT PATIENT'S ORDERS ;01/01/03 +ALPBSP1 ;emc,ets/mw,sd,kc-list and select patient's orders ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; **NOTE: THIS ROUTINE IS CALLED BY A LIST MANAGER @@ -29,8 +29,7 @@ I $G(ALPBLTYP)="" S ALPBLTYP="Active" S ALPBX=0 F S ALPBX=$O(ALPBORDS(ALPBX)) Q:'ALPBX D - .I $G(ALPBORDS(ALPBX,2))="" S ALPBORDS(ALPBX,2)="XX" - .S ALPBORDS("B",ALPBORDS(ALPBX,2),ALPBORDS(ALPBX),ALPBX)="" + .S ALPBORDS("B",$G(ALPBORDS(ALPBX,2),"XX"),ALPBORDS(ALPBX),ALPBX)="" S ALPBLINE=0 S ALPBSTAT="" F S ALPBSTAT=$O(ALPBORDS("B",ALPBSTAT)) Q:ALPBSTAT="" D @@ -47,11 +46,6 @@ ...S ALPBDATA=$$PAD^ALPBUTL(ALPBDATA,21)_ALPBORDS(ALPBX,1) ...I +$G(ALPBORDS(ALPBX,3,0)) D ....S ALPBDATA=$$PAD^ALPBUTL(ALPBDATA,26)_ALPBORDS(ALPBX,3,1) - ...I $G(ALPBORDS(ALPBX,4))'="" D - ....S ALPBY=$P(ALPBORDS(ALPBX,4),"^",1,3) - ....S ALPBY=$TR(ALPBY,"^"," ") - ....S ALPBDATA=ALPBDATA_" ("_ALPBY_")" - ....K ALPBY ...S ^TMP("ALPBORDS",$J,ALPBLINE,0)=ALPBDATA ...K ALPBDATA ...S ALPBY=1 diff -auBN ./r1/ALPBSP2.m ./r2/r/ALPBSP2.m --- ./r1/ALPBSP2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBSP2.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBSP2 ;OIFO-DALLAS MW,SED,KC-SHOW SELECTED PATIENT ORDERS(S) ;01/01/03 +ALPBSP2 ;emc,ets/mw,sd,kc-show selected patient order(s) ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; EN ; -- main entry point for ALPB SHOW ORDERS diff -auBN ./r1/ALPBSPAT.m ./r2/r/ALPBSPAT.m --- ./r1/ALPBSPAT.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBSPAT.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBSPAT ;OIFO-DALLAS MW,SED,KC-SELECT AND SHOW PATIENT ORDER(S) ;01/01/03 +ALPBSPAT ;emc,ets/mw,sd,kc-select and show patient orders ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; EN ; -- main entry point for ALPB SELECT PATIENT diff -auBN ./r1/ALPBSWRD.m ./r2/r/ALPBSWRD.m --- ./r1/ALPBSWRD.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBSWRD.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBSWRD ;OIFO-DALLAS MW,SED,KC - display BCBU records for patients on a selected ward ;01/01/03 +ALPBSWRD ;emc/MW,SD,KC-display BCMA records for patients on a selected ward ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; F D Q:$D(DIRUT) diff -auBN ./r1/ALPBT1.m ./r2/r/ALPBT1.m --- ./r1/ALPBT1.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/ALPBT1.m 2003-04-17 10:15:24.000000000 -0400 @@ -0,0 +1,69 @@ +ALPBT1 ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 ;12/13/2002 14:15 + ;;1.0;BCBU;**;May 02, 2002 +HLCM ;SFVAMC/JC - HL7 CAPACITY MANAGEMENT DATA COLLECTION + ;SETS DATA INTO ^TMP("TOTALS",$J) + K ^TMP("TOTALS") + N START,END,NODE + D DRNG(.START,.END) + W $$CM2^HLUCM(START,END,1,1,"TOTALS","EITHER",.RESULT) +OUT ; + W !,"Protocol",?25,"Chars",?35,"Messages",?45,"Seconds",?60,"Char/Sec" + W !,"--------",?25,"-----",?35,"--------",?45,"-------",?60,"-------" + N P,C,M,S + W !,"SYSTEM TOTAL" S X=^TMP("TOTALS",$J),C=$P(X,U),M=$P(X,U,2),S=$P(X,U,3) + W ?25,C,?35,M,?45,S I +S>0 W ?60,$J((C/S),4,4) + S NODE=$NA(^TMP("TOTALS",$J,"PROT","PR","P")) + S P="" F S P=$O(@NODE@(P)) Q:P="" W !,$E(P,1,24) D + . S X=@NODE@(P),C=$P(X,U),M=$P(X,U,2),S=$P(X,U,3) + . W ?25,C,?35,M,?45,S,?55 I +S>0 W ?60,$J((C/S),4,4) + Q +DRNG(ST,END) ;Ask for a range of dates + ;SUBMIT ST, END DATES IN INTERNAL OR EXTERNAL FORMAT, RETURN START/END IN INTERNAL + ;INPUT PASSED BY REFERENCE + ;ST-DEFAULT start date + ;END-DEFAULT end date + N X S X="",STOP=0 + I $G(ST)']"" S ST="T-90" + I $G(END)']"" S END="T" + I '+$G(ST) S X=ST D ^%DT S ST=Y + I '+$G(END) S X=END D ^%DT S END=Y + W !,"Date to start with: "_$$FMTE^XLFDT(ST)_"//" R X:DTIME + S:X["^" STOP=1 Q:STOP S:X="" X=ST S ST=$$DT(X) W " ",$$FMTE^XLFDT(ST) + S X="" W !,"Date to end with: "_$$FMTE^XLFDT(END)_"//" R X:DTIME + S:X["^" STOP=1 Q:STOP S:X="" X=END S END=$$DT(X) W " ",$$FMTE^XLFDT(END) + Q +DT(D) ;Return Internal Date + ;Input external Fileman date only + N ARJDATE + I D']"" Q "" + D DT^DILF("ETS",D,.ARJDATE) + Q ARJDATE +TEST ;JC/GENERATE TEST MESSAGES + K HLA + N CNT,HLFS,HLCS S CNT=0 + D INIT^HLFNC2("PSB BCBU ORM SEND",.HL) + I $G(HL) W !,"ERROR IN INIT: "_$P(HL,2) Q + S HLFS=$G(HL("FS")) Q:HLFS']"" + S HLCS=$E(HL("ECH")) Q:HLCS']"" + ;S HLA("HLS",1)="MSH|^~\&|PHARMACY|662|||||ORM|||||||||" + S HLA("HLS",2)="PID^^000-00-6667~~^435855~2~M10^^DEMOPATIENT~SIX^^19480000^M^^^^^^^^^^^000006667" + S HLA("HLS",3)="PV1^^I^1351~2B10-1^^^^^^^^^^^^^^^^712607^^^^^^^^" + S HLA("HLS",4)="ORC^XX^11545682~OR^71U~PS^^ZE^^^^200302081046-0700^104~GENERIC,PHARMACIST^^7567~NO,MD^^^200302081046-0700^~~99ORN~~~" + S HLA("HLS",5)="RXO^~~~210~CAPTOPRIL TAB~99PSP^^^^^^^^^" + S HLA("HLS",6)="RXE^~TID~~200302081046-0700~200303101300-0700~~~37.5MG^^^^^^^^^^^^^1022775~DANE,SID E~99NP^^^^^^^^" + S HLA("HLS",7)="NTE^21^L^TEST" + S HLA("HLS",8)="RXR^~~~1~ORAL~99PSR^^^" + Q +ONE ;SEND A SINGLE MESSAGE + D TEST + D GET^ALPBPARM(.HLL,1) + D GENERATE^HLMA("PSB BCBU ORM SEND","LM",1,.RSLT,"",.OPTS) + K CNT,HL,HLA,HLFS,HLCS,RSLT,OPTS + Q +MANY ;SEND MANY MESSAGES + N MSGS S MSGS=0 + R !,"Send how many messages to target? ",MSGS + S I=0 Q:$G(MSGS)'>0 + F S I=I+1 D ONE Q:I>MSGS W "." + W !,"Done..." + Q diff -auBN ./r1/ALPBTST.m ./r2/r/ALPBTST.m --- ./r1/ALPBTST.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/ALPBTST.m 2003-04-17 10:15:24.000000000 -0400 @@ -0,0 +1,72 @@ +ALPBTST ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 ;12/13/2002 14:15 + ;;1.0;BCBU;**;May 02, 2002 +HLCM ;SFVAMC/JC - HL7 CAPACITY MANAGEMENT DATA COLLECTION + ;SETS DATA INTO ^TMP("TOTALS",$J) + K ^TMP("TOTALS") + N START,END,NODE + D DRNG(.START,.END) + W $$CM2^HLUCM(START,END,1,1,"TOTALS","EITHER",.RESULT) +OUT ; + W !,"Protocol",?25,"Chars",?35,"Messages",?45,"Seconds",?60,"Char/Sec" + W !,"--------",?25,"-----",?35,"--------",?45,"-------",?60,"-------" + N P,C,M,S + W !,"SYSTEM TOTAL" S X=^TMP("TOTALS",$J),C=$P(X,U),M=$P(X,U,2),S=$P(X,U,3) + W ?25,C,?35,M,?45,S I +S>0 W ?60,$J((C/S),4,4) + S NODE=$NA(^TMP("TOTALS",$J,"PROT","PR","P")) + S P="" F S P=$O(@NODE@(P)) Q:P="" W !,$E(P,1,24) D + . S X=@NODE@(P),C=$P(X,U),M=$P(X,U,2),S=$P(X,U,3) + . W ?25,C,?35,M,?45,S,?55 I +S>0 W ?60,$J((C/S),4,4) + Q +DRNG(ST,END) ;Ask for a range of dates + ;SUBMIT ST, END DATES IN INTERNAL OR EXTERNAL FORMAT, RETURN START/END IN INTERNAL + ;INPUT PASSED BY REFERENCE + ;ST-DEFAULT start date + ;END-DEFAULT end date + N X S X="",STOP=0 + I $G(ST)']"" S ST="T-90" + I $G(END)']"" S END="T" + I '+$G(ST) S X=ST D ^%DT S ST=Y + I '+$G(END) S X=END D ^%DT S END=Y + W !,"Date to start with: "_$$FMTE^XLFDT(ST)_"//" R X:DTIME + S:X["^" STOP=1 Q:STOP S:X="" X=ST S ST=$$DT(X) W " ",$$FMTE^XLFDT(ST) + S X="" W !,"Date to end with: "_$$FMTE^XLFDT(END)_"//" R X:DTIME + S:X["^" STOP=1 Q:STOP S:X="" X=END S END=$$DT(X) W " ",$$FMTE^XLFDT(END) + Q +DT(D) ;Return Internal Date + ;Input external Fileman date only + N ARJDATE + I D']"" Q "" + D DT^DILF("ETS",D,.ARJDATE) + Q ARJDATE +TEST ;JC/GENERATE TEST MESSAGES + K HLA + N CNT,HLFS,HLCS S CNT=0 + D INIT^HLFNC2("PSB BCBU ORM SEND",.HL) + I $G(HL) W !,"ERROR IN INIT: "_$P(HL,2) Q + S HLFS=$G(HL("FS")) Q:HLFS']"" + S HLCS=$E(HL("ECH")) Q:HLCS']"" + S CNT=CNT+1,HLA("HLS",CNT)="PID^^123-45-6789~~^184698~9~M10^^MONK~THELONIOUS~E^^19590602^M^^^^^^^^^^^431132115" + S CNT=CNT+1,HLA("HLS",CNT)="PV1^^I^1888~B218-A-CO^^^^^^^^^^^^^^^^536249^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^" + S CNT=CNT+1,HLA("HLS",CNT)="ORC^SC^8547310;2~OR^7U~PS^^CM~finished/verified by pharmacist(active)^^^^200211271105-0400^24105~MCCREA,CARMEN^^31251~BIEDERBECK,BIX^^^200211271105-0400^S~Service Correction~99ORN~~~^^" + S CNT=CNT+1,HLA("HLS",CNT)="RXO^~~~2648~MILK OF MAGNESIA SUSP,ORAL~99PSP^^^^^^^^^^^^^^^" + S CNT=CNT+1,HLA("HLS",CNT)="RXE^&32&1&~Q6H PRN~~200211271105-0400~200212101400-0400~~~1 TEASPOONFUL^2206.13598~MILK OF MAGNESIA,30ML~99NDF~2186~MILK OF MAGNESIA 30ML" D + . S HLA("HLS",CNT)=HLA("HLS",CNT)_"~99NDF~2186~MILK OF MAGNESIA 30ML (UD)~99PSD^^^~~~32~MG/5ML~99PSU^~~~205~SUSP,ORAL~99PSF^^^^^^^^24105~MCCREA,CARMEN~99NP^^^^^^^^^^^^~~~32~MG/" + S CNT=CNT+1,HLA("HLS",CNT)="NTE^21^L^FOR CONSTIPATION" + S HLA("HLS",CNT,1)=" AND DIARRHEA" + S CNT=CNT+1,HLA("HLS",CNT)="RXR^~~~1~ORAL~99PSR^^^" + S CNT=CNT+1,HLA("HLS",CNT)="ZRX^8547310;1^S^E^^24105~MCCREA,CARMEN~99NP^" + S CNT=CNT+1,HLA("HLS",CNT)="AL1^1^D^46679~PENICILLIN~VA120.8^^" + Q +ONE ;SEND A SINGLE MESSAGE + D TEST + D GET^ALPBPARM(.HLL,1) + D GENERATE^HLMA("PSB BCBU ORM SEND","LM",1,.RSLT,"",.OPTS) + K CNT,HL,HLA,HLFS,HLCS,RSLT,OPTS + Q +MANY ;SEND MANY MESSAGES + N MSGS S MSGS=0 + R !,"Send how many messages to target? ",MSGS + S I=0 Q:$G(MSGS)'>0 + F S I=I+1 D ONE Q:I>MSGS W "." + W !,"Done..." + Q diff -auBN ./r1/ALPBUTL1.m ./r2/r/ALPBUTL1.m --- ./r1/ALPBUTL1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBUTL1.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,4 +1,4 @@ -ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03 +ALPBUTL1 ;emc,ets/maw,sd,kc-BCMA backup report functions and utilities ;01/01/03 ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; ; Reference/IA @@ -145,7 +145,7 @@ Q ; STAT(ST) ;This will return the value of a status code for pharmacy - I $G(ST)="" Q "" + I ST="" Q "" I $L($T(@ST)) G @ST Q "" IP Q "pending" diff -auBN ./r1/ALPBUTL2.m ./r2/r/ALPBUTL2.m --- ./r1/ALPBUTL2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBUTL2.m 2003-04-25 11:54:56.000000000 -0400 @@ -1,5 +1,5 @@ -ALPBUTL2 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03 - ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 +ALPBUTL2 ;emc,ets/maw,sd,kc-BCBU functions and utilities ;01/01/03 + ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; DELALG(IEN) ; delete allergies... ; IEN = the patient's record number in file 53.7 @@ -90,22 +90,3 @@ .I $A(Z)>122 S NEWX=Y .S NEWSTR=NEWSTR_NEWX Q NEWSTR - ; -CLORD(IEN,OIEN) ; delete drug(s), additive(s) and/or solution(s) entries - ; for a specified order... - ; IEN = patient's record number in file 53.7 - ; OIEN = order's sub-record number in file 53.7 - ; returns nothing - I +$G(IEN)=0!(+$G(OIEN)=0) Q - N DA,DIK,SUB,X,XIEN,Y - F SUB=7,8,9 D - .S XIEN=0 - .F S XIEN=$O(^ALPB(53.7,IEN,2,OIEN,SUB,XIEN)) Q:'XIEN D - ..S DA=XIEN - ..S DA(1)=OIEN - ..S DA(2)=IEN - ..S DIK="^ALPB(53.7,"_DA(2)_",2,"_DA(1)_","_SUB_"," - ..D ^DIK - ..K DA,DIK - .K XIEN - Q diff -auBN ./r1/ALPBUTL3.m ./r2/r/ALPBUTL3.m --- ./r1/ALPBUTL3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ALPBUTL3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,61 +0,0 @@ -ALPBUTL3 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03 - ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 -START(DAY) ;Get current date - D NOW^%DTC - S Y=X - S STARD=%I(2) - D DD^%DT - S MON=$E(Y,1,3) - S LD=$S(MON="JAN":31,MON="FEB":29,MON="MAR":31,MON="APR":30,MON="MAY":31,MON="JUN":30,MON="JUL":31,MON="AUG":31,MON="SEP":30,MON="OCT":31,MON="NOV":30,MON="DEC":31) - S LDD=LD+1 - S SP=69,CNT=0 - S SS=STARD+DAY - I SS>LDD S SS=LDD - I SSLDD S SS=LDD - I SS12 S MON1=1 - .S MON=$$MONN(MON1),RESULT=RESULT_MON - .S DIM=$$DIM($E(START,1,3)_$S(MON1<10:"0"_MON1,1:MON1)),TODAY=0 + .S MON=$$MONN(MON1) + .S RESULT=RESULT_MON + .S DIM=$$DIM($E(START,1,3)_$S(MON1<10:"0"_MON1,1:MON1)) + .S TODAY=0 F I=$L(RESULT):-1 Q:$E(RESULT,I)'="*"!(I=0) - S RESULT=$E(RESULT,1,I),RESULT=$TR(RESULT,XSPACE,XSTRIP) + S RESULT=$E(RESULT,1,I) + S RESULT=$TR(RESULT,XSPACE,XSTRIP) Q RESULT ; FDATES(START,DAYS,RESULTS) ; N I,X,X1,X2 - S RESULTS(0)=" "_$E(START,4,5)_"/"_$E(START,6,7)_" ",RESULTS(1)=START + S RESULTS(0)=" "_$E(START,4,5)_"/"_$E(START,6,7)_" " + S RESULTS(1)=START F I=1:1:DAYS-1 D - .S X1=START,X2=I + .S X1=START + .S X2=I .D C^%DTC - .S RESULTS(I+1)=X,RESULTS(0)=RESULTS(0)_" "_$E(X,4,5)_"/"_$E(X,6,7)_" " + .S RESULTS(I+1)=X + .S RESULTS(0)=RESULTS(0)_" "_$E(X,4,5)_"/"_$E(X,6,7)_" " .K X,X1,X2 Q ; @@ -151,9 +162,11 @@ S ALPBWARD="" F S ALPBWARD=$O(^ALPB(53.7,"AW",ALPBWARD)) Q:ALPBWARD="" D .I ALPBWARD=WARD D Q - ..S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBWARD + ..S RESULTS(0)=RESULTS(0)+1 + ..S RESULTS(RESULTS(0))=ALPBWARD .I ALPBWARD[WARD D - ..S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBWARD + ..S RESULTS(0)=RESULTS(0)+1 + ..S RESULTS(RESULTS(0))=ALPBWARD ; if a straight lookup failed, let's try making any alphas ; entered by the user uppercase and try it once more... I RESULTS(0)=0 D @@ -161,9 +174,11 @@ .S ALPBWARD="" .F S ALPBWARD=$O(^ALPB(53.7,"AW",ALPBWARD)) Q:ALPBWARD="" D ..I ALPBWARD=WARD D Q - ...S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBWARD + ...S RESULTS(0)=RESULTS(0)+1 + ...S RESULTS(RESULTS(0))=ALPBWARD ..I ALPBWARD[WARD D - ...S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBWARD + ...S RESULTS(0)=RESULTS(0)+1 + ...S RESULTS(RESULTS(0))=ALPBWARD Q ; OTYP(CODE) ; expand order type for printing... @@ -187,7 +202,6 @@ .S ORDERDAT(0)=$G(^ALPB(53.7,IEN,2,ORDERIEN,0)) .S ORDERDAT(1)=$G(^ALPB(53.7,IEN,2,ORDERIEN,1)) .S ORDERDAT(3)=$G(^ALPB(53.7,IEN,2,ORDERIEN,3)) - .S ORDERDAT(4)=$G(^ALPB(53.7,IEN,2,ORDERIEN,4)) .S ORDERST=$P($P(ORDERDAT(0),"^",3),"~") .; is this order current?... .I $G(DATE)'=""&($P(ORDERDAT(1),"^",2)<$G(DATE)) K ORDERDAT Q @@ -199,8 +213,6 @@ .S RESULTS(ORDERIEN,1)=$S($P(ORDERDAT(3),"^")="V":"IV",$P(ORDERDAT(3),"^")="U":"UD",1:$P(ORDERDAT(3),"^")) .S RESULTS(ORDERIEN,2)=ORDERST .S RESULTS(ORDERIEN,3,0)=0 - .;S RESULTS(ORDERIEN,4)=$P($G(ORDERDAT(4)),"^",3) - .S RESULTS(ORDERIEN,4)=$G(ORDERDAT(4)) .I +$O(^ALPB(53.7,IEN,2,ORDERIEN,7,0)) D ..S ALPBX=0 ..F S ALPBX=$O(^ALPB(53.7,IEN,2,ORDERIEN,7,ALPBX)) Q:'ALPBX D @@ -224,7 +236,8 @@ DELPT(IEN) ; delete a patient's entire record... ; IEN = patient's record number in file 53.7 N DA,DIK,X,Y - S DA=IEN,DIK="^ALPB(53.7," + S DA=IEN + S DIK="^ALPB(53.7," D ^DIK ; after deleting the patient, check for any error log ; entries and delete them... @@ -235,7 +248,9 @@ ; IEN = patient's record number in file 53.7 ; OIEN = order number's record number N DA,DIK,X,Y - S DA=OIEN,DA(1)=IEN,DIK="^ALPB(53.7,"_DA(1)_",2," + S DA=OIEN + S DA(1)=IEN + S DIK="^ALPB(53.7,"_DA(1)_",2," D ^DIK Q ; diff -auBN ./r1/ANRVOA.m ./r2/r/ANRVOA.m --- ./r1/ANRVOA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ANRVOA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,202 +0,0 @@ -ANRVOA ; HOIFO/CED - User, Patient and Parameter specifics for Patient Review. ; [01-07-2003 12:19] - ;;4.0;VISUAL IMPAIRMENT SERVICE TEAM;**5**;AUG 21, 2003 -ADD(X) ; [Procedure] Adds to RESULTS - S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X - Q - ; -DELLST ; [Procedure] Delete list of parameters - D NDEL^XPAR(ENT,PAR,.ERR) - S:'$G(ERR) @RESULTS@(0)="1^All Instances Removed" - Q - ; -DELPAR ; [Procedure] Delete single parameter value - D DEL^XPAR(ENT,PAR,INST,.ERR) - S:'$G(ERR) @RESULTS@(0)="1^Instance Deleted" - Q - ; -ELECSIG ; [Procedure] Check Electronic Signature - N X - S X=DATA - S X1=$S($D(DUZ)[0:"",$D(^VA(200,DUZ,20))[0:"",1:$P(^(20),U,4)) - I X1="" S @RESULTS@(0)="-1^Electronic Signature Not Found." Q - D HASH^XUSHSHP - I X1'=X S @RESULTS@(0)="0^Electronic Signature Incorrect." Q - S @RESULTS@(0)="1^Electronic Signature Verified." - Q - ; -ENTVAL ; [Procedure] Return value of the entity - I ENT="SYS" S ENT=$$KSP^XUPARAM("WHERE") - E I ENT="DIV" S ENT=$$GET1^DIQ(4,DUZ(2)_",",.01) - E I ENT="USR" S ENT=$$GET1^DIQ(200,DUZ_",",.01) - E S ENT=$$GET1^DIQ(+$P(ENT,"(",2),+ENT_",",.01) - S @RESULTS@(0)=ENT - Q - ; -FULLSSN(LST,ID) ; [Procedure] Return a list of patients matching Full SSN entered - N I,IEN - S (I,IEN)=0 - F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D - . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249 - Q - ; -GETHDR ; [Procedure] Returns common header format - S X=$$FIND1^DIC(8989.51,,"QX",PAR) - I X S @RESULTS@(0)=X_";8989.51^"_PAR - E S @RESULTS@(0)="-1^No such parameter ["_PAR_"]" - Q - ; -GETLST ; [Procedure] Return all instances of a parameter - D GETLST^XPAR(.RET,ENT,PAR,"E",.ERR) - Q:$G(ERR,0) - S TMP="RET" - F S TMP=$Q(@TMP) Q:TMP="" D - .S @RESULTS@($O(@RESULTS@(""),-1)+1)=@TMP - S @RESULTS@(0)=$O(@RESULTS@(""),-1) - Q - ; -GETPAR ; [Procedure] Returns external value for a parameter - S @RESULTS@(0)=$$GET^XPAR(ENT,PAR,INST,"E") - Q - ; -GETWP ; [Procedure] Returns WP text for a parameter - D GETWP^XPAR(.RET,ENT,PAR,INST,.ERR) - Q:$G(ERR,0) - S TMP="RET" - F S TMP=$Q(@TMP) Q:TMP="" D - .S @RESULTS@($O(@RESULTS@(""),-1)+1)=@TMP - S @RESULTS@(0)=$O(@RESULTS@(""),-1)_U_INST - Q - ; -LAST5(RESULTS,PTID) ; [Procedure] Get patients using last 5 - N I,IEN,XREF - S (I,IEN)=0,XREF=$S($L(PTID)=5:"BS5",1:"BS") - F S IEN=$O(^DPT(XREF,PTID,IEN)) Q:'IEN D - .S I=I+1,RESULTS(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249 - Q - ; -LISTALL(RESULTS,FROM,DIR) ; [Procedure] Pt List - N I,IEN,CNT S CNT=44,I=0 - F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT - .S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT - ..S I=I+1 S RESULTS(I)=IEN_"^"_FROM - Q - ; -LOGSEC ; [Procedure] Logs secure and restricted record access - D NOTICE^DGSEC4(.ANRVRET,DFN,DATA,1) - S @RESULTS@(0)=$S(ANRVRET:"1^Logged",1:"-1^Unable to log") - Q - ; -PINF(RESULTS,PTDFN) ; [Procedure] Patient Information for verification - N Y,GX,GE,NC,Z,X,I - D GETS^DIQ(2,+PTDFN,".03;391;1901;.01;.02;.09;.301;.14;","","GX","GE") - I $D(GE("DIERR",1)) S RESULTS="0^"_GE("DIERR",1,"TEXT",1) Q - S NC=+PTDFN_",",Z="1^" - F I=.03,391,1901,.01,.02,.09,.301,.14 D - .S X=GX(2,NC,I) S Z=Z_X_"^" - S RESULTS=Z - Q - ; -RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC Call Tag - S RESULTS=$NA(^TMP($J)) K @RESULTS - D:$T(@OPTION)]"" @OPTION - D:'$D(@RESULTS) - .S @RESULTS@(0)="-1^No results returned" - D CLEAN^DILF - Q - ; -RPCA(RESULTS,OPTION,ENT,PAR,INST,VAL) ; [Procedure] Main RPC entry - N ERR,TMP,RET,TXT,IEN,IENS,ROOT - S INST=$G(INST,1) - S PAR=$G(PAR,"ANRV") - S RESULTS=$NA(^TMP($J)) K @RESULTS - I PAR'?1"ANRV".E S ^TMP($J,0)="-1^Non VIST Outcomes Parameter" Q - D:$T(@OPTION)]"" @OPTION - I +$G(ERR) K @RESULTS S @RESULTS@(0)="-1^Error: "_(+ERR)_" "_$P(ERR,U,2) - I '$D(^TMP($J)) S @RESULTS@(0)="-1^No data returned" - D CLEAN^DILF - Q - ; -SELECT ; [Procedure] Select Patient - NEW IENS,ANRVDFN,ANRVFLD,ANRVID,ANRVRET,ANRVX - I '$D(^DPT(+$G(DFN),0))#2 S @RESULTS@(0)="-1^No such patient" Q - S @RESULTS@(0)="1^Required Identifiers & messages" - S IENS=DFN_"," - D FILE^DID(2,,"REQUIRED IDENTIFIERS","ANRVIDS") - F ANRVX=0:0 S ANRVX=$O(ANRVIDS("REQUIRED IDENTIFIERS",ANRVX)) Q:'ANRVX D - .S ANRVFLD=ANRVIDS("REQUIRED IDENTIFIERS",ANRVX,"FIELD") - .S ANRVID="$$PTID^"_$$GET1^DID(2,ANRVFLD,"","LABEL") - .S ANRVID=ANRVID_U_$$GET1^DIQ(2,IENS,ANRVFLD) - .D:ANRVFLD=.03 - ..S ANRVID=ANRVID_" ("_$$GET1^DIQ(2,IENS,.033)_")" - ..S ANRVID=ANRVID_U_$$DOB^DPTLK1(+IENS) - .D:ANRVFLD=.09 - ..S X=$P(ANRVID,U,3),X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10) - ..S $P(ANRVID,U,3)=X,$P(ANRVID,U,4)=$$SSN^DPTLK1(+IENS) - .S @RESULTS@($O(@RESULTS@(""),-1)+1)=ANRVID - K ANRVRET - D GUIBS5A^DPTLK6(.ANRVRET,DFN) D:ANRVRET(1)=1 - .D ADD("$$MSGHDR^2^SAME LAST NAME AND LAST 4") - .S ANRVX=1 - .F S ANRVX=$O(ANRVRET(ANRVX)) Q:'ANRVX!(+$G(ANRVRET(ANRVX))) D - ..D ADD($P(ANRVRET(ANRVX),U,2)) - .D ADD(" ") - .S ANRVX=1 - .F S ANRVX=$O(ANRVRET(ANRVX)) Q:'ANRVX D:+ANRVRET(ANRVX) - ..S ANRVDFN=+$P(ANRVRET(ANRVX),U,2) - ..D ADD($$GET1^DIQ(2,ANRVDFN_",",.01)_" "_$$DOB^DPTLK1(ANRVDFN)_" "_$$SSN^DPTLK1(ANRVDFN)) - .D ADD(" ") - .D ADD("Please review carefully before continuing") - .D ADD("$$MSGEND") - K ANRVRET - D PTSEC^DGSEC4(.ANRVRET,DFN) D:ANRVRET(1)'=0 - .D:ANRVRET(1)=3 - ..D ADD("$$MSGHDR^0^CAN'T ACCESS YOUR OWN RECORD!!") - .D:ANRVRET(1)=-1 - ..D ADD("$$MSGHDR^0^INCOMPLETE INFORMATION - CAN'T PROCEED") - .D:ANRVRET(1)=1 - ..D ADD("$$MSGHDR^1^SENSITIVE RECORD ACCESS") - .D:ANRVRET(1)'=-1&(ANRVRET(1)'=3)&(ANRVRET(1)'=1) - ..D ADD("$$MSGHDR^3^SENSITIVE RECORD ACCESS") - .S ANRVX=1 - .F S ANRVX=$O(ANRVRET(ANRVX)) Q:'ANRVX D ADD($TR(ANRVRET(ANRVX),"*"," ")) - .D ADD("$$MSGEND") - D GUIMTD^DPTLK6(.ANRVRET,DFN) D:ANRVRET(1)=1 - .D ADD("$$MSGHDR^1^NOTICE") - .F ANRVX=1:0 S ANRVX=$O(ANRVRET(ANRVX)) Q:'ANRVX D ADD(ANRVRET(ANRVX)) - .D ADD("$$MSGEND") - Q - ; -SETLST ; [Procedure] Set single value into a parameter - N ANRVINS ; Instance Counter - D DELLST(ENT,PAR) - S ANRVINS="" - F S ANRVINS=$O(VAL(ANRVINS)) Q:ANRVINS="" D - .D EN^XPAR(ENT,PAR,ANRVINS,VAL(ANRVINS),.ERR) - S:'$G(ERR) @RESULTS@(0)="1^List "_PAR_" rebuilt" - Q - ; -SETPAR ; [Procedure] Set single value into a parameter - D EN^XPAR(ENT,PAR,INST,VAL,.ERR) - S:'$G(ERR) @RESULTS@(0)="1^Parameter updated" - Q - ; -SETWP ; [Procedure] Set WP text into a parameter - S TXT=INST,TMP="" - F S TMP=$O(VAL(TMP)) Q:TMP="" D - .S TXT($O(TXT(""),-1)+1,0)=VAL(TMP) - D EN^XPAR(ENT,PAR,INST,.TXT,.ERR) - S:'$G(ERR) @RESULTS@(0)="1^WP Text Saved" - Q - ; -SIGNON ; [Procedure] Return signon information for user. - S @RESULTS@(0)=DUZ - S @RESULTS@(1)=$$GET1^DIQ(200,DUZ_",",.01) ; Name - S @RESULTS@(2)=+$$FIND1^DIC(4.2,"","QX",$$KSP^XUPARAM("WHERE")) ;Domain - S @RESULTS@(3)=$$KSP^XUPARAM("WHERE") ; Domain Name - S @RESULTS@(4)=+$G(DUZ(2)) ; Division IEN - S @RESULTS@(5)=$S(+$G(DUZ(2)):$$GET1^DIQ(4,DUZ(2)_",",.01),1:"UNKNOWN") - S @RESULTS@(6)=$$GET1^DIQ(200,DUZ_",",8) - S @RESULTS@(7)="" - S @RESULTS@(8)=$G(DTIME,300) - Q - ; diff -auBN ./r1/ANRVOB.m ./r2/r/ANRVOB.m --- ./r1/ANRVOB.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/ANRVOB.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,166 +0,0 @@ -ANRVOB ; HOIFO/CED - Supports VIST GUI OUTCOMES ; [01-07-2003 12:20] - ;;4.0;VISUAL IMPAIRMENT SERVICE TEAM;**5**;JUN 03, 2002 -ADDTXT(RESULTS,SUBREC,TOPREC,STATUS,OTCTXT) ; [Procedure] Uploads section text - ; Input parameters - ; 1. RESULTS [Literal/Required] No description - ; 2. SUBREC [Literal/Required] No description - ; 3. TOPREC [Literal/Required] No description - ; 4. STATUS [Literal/Required] No description - ; 5. OTCTXT [Literal/Required] No description - ; - N UPSTAT - K ^TMP("OTC",$J) - M ^TMP("OTC",$J,"OTCTXT")=OTCTXT - D WP^DIE(2048.01,SUBREC_","_TOPREC_",",1,"K",$NA(^TMP("OTC",$J,"OTCTXT"))) - S ^ANRV(2048,TOPREC,1,SUBREC,0)=SUBREC_U_STATUS ; update status - I $DATA(DIERR) S RESULTS(0)="-1^"_DIERR - E S RESULTS(0)="1^Section Updated" - K ^TMP("OTC",$J) - Q - ; -GETREC(RESULTS,PTDFN) ; [Procedure] Get top record and sub records - ; Input parameters - ; 1. RESULTS [Literal/Required] No description - ; 2. PTDFN [Literal/Required] No description - ; - N X,Y,IEN,IDATE,DATE,TIME,STATUS,TYPE,S1,S1STAT,S2,S2STAT,S3,S3STAT,S4,S4STAT,S5,S5STAT,S6,S6STAT - K ^TMP($J) - I '$D(^ANRV(2048,"B",PTDFN)) S RESULTS(0)="^0^No Outcome's On Record" Q - F IEN=0:0 S IEN=$O(^ANRV(2048,"B",PTDFN,IEN)) Q:'IEN D - .S IDATE=$P($G(^ANRV(2048,IEN,0)),U,2,2) ;internal date - .S STATUS=$P($G(^ANRV(2048,IEN,0)),U,3,3) ;status(incomplete,complete,partial) - .S TYPE=$P($G(^ANRV(2048,IEN,0)),U,4,4) ;type(Pre or Post) - .S TIME=$E(IDATE,9,10)_":"_$E(IDATE,11,12) ;time top record created - .S:TIME=":" TIME="00:00" ;put it in readable format for user - .S Y=IDATE X ^DD("DD") S DATE=Y ;convertinator - .S S1=$P($G(^ANRV(2048,IEN,1,1,0)),U,1) ;section 1 - .S S1STAT=$P($G(^ANRV(2048,IEN,1,1,0)),U,2) ;section 1 status - .S S2=$P($G(^ANRV(2048,IEN,1,2,0)),U,1) ;section 2 - .S S2STAT=$P($G(^ANRV(2048,IEN,1,2,0)),U,2) ;section 2 status - .S S3=$P($G(^ANRV(2048,IEN,1,3,0)),U,1) ;section 3 - .S S3STAT=$P($G(^ANRV(2048,IEN,1,3,0)),U,2) ;section 3 status - .S S4=$P($G(^ANRV(2048,IEN,1,4,0)),U,1) ;section 4 - .S S4STAT=$P($G(^ANRV(2048,IEN,1,4,0)),U,2) ;section 4 status - .S S5=$P($G(^ANRV(2048,IEN,1,5,0)),U,1) ;section 5 - .S S5STAT=$P($G(^ANRV(2048,IEN,1,5,0)),U,2) ;section 5 status - .S S6=$P($G(^ANRV(2048,IEN,1,6,0)),U,1) ;section 6 - .S S6STAT=$P($G(^ANRV(2048,IEN,1,6,0)),U,2) ;section 6 status - .S RESULTS(IEN)=1_U_IEN_U_IDATE_U_DATE_U_STATUS_U_TYPE_U_S1_U_S1STAT_U_S2_U_S2STAT_U_S3_U_S3STAT_U_S4_U_S4STAT_U_S5_U_S5STAT_U_S6_U_S6STAT - I $DATA(DIERR) S @RESULTS@(0)="-1^"_DIERR - Q - ; -GETSEC(RESULTS,RECORD) ; [Procedure] Get Outcome Section - ; Input parameters - ; 1. RESULTS [Literal/Required] No description - ; 2. RECORD [Literal/Required] No description - ; - D GETS^DIQ(2048,+RECORD,".01;.02","","RESULTS","DIERR") - I $DATA(DIERR) S @RESULTS@(0)="-1^["_DIERR_"]" - Q - ; -GETTXT(RESULTS,SUBREC,TOPREC) ; [Procedure] Gets the Outcome Text - ; Input parameters - ; 1. RESULTS [Literal/Required] No description - ; 2. SUBREC [Literal/Required] No description - ; 3. TOPREC [Literal/Required] No description - ; - S RESULTS=$$GET1^DIQ(2048.01,SUBREC_","_TOPREC_",",1,"","RESULTS") - Q - ; -MKREC(RESULTS,PTDFN,STATUS,TYPE) ; [Procedure] Creates Outcome record - ; Input parameters - ; 1. RESULTS [Literal/Required] No description - ; 2. PTDFN [Literal/Required] No description - ; 3. STATUS [Literal/Required] No description - ; 4. TYPE [Literal/Required] No description - ; - K ^TMP($J) - N X,Y,I,NEWREC,NOW,NEWIEN,ERR - D NOW^%DTC S NOW=% - S NEWREC(2048,"+1,",.01)=PTDFN ; patient ien - S NEWREC(2048,"+1,",.02)=NOW ; date and time - S NEWREC(2048,"+1,",.03)=STATUS ; I=inpatient, O=outpatient, Z=other - S NEWREC(2048,"+1,",.04)=TYPE ; R=Pre or O=Post Outcome - D UPDATE^DIE("","NEWREC","NEWIEN") - S ^ANRV(2048,NEWIEN(1),1,0)="^2048.01,.01P^^" - F X=0:0 S X=$O(^ANRV(2048.1,X)) Q:'X D - .S ^ANRV(2048,NEWIEN(1),1,X,0)=X - .S ^ANRV(2048,NEWIEN(1),1,"B",X,X)="" - S RESULTS(0)="1"_U_NEWIEN(1) - I $DATA(DIERR) S RESULTS(0)="-1^"_U_DIERR - Q - ; -RPC(RESULTS,OPTION,DATA) ; [Procedure] Main RPC Entry. - ; Input parameters - ; 1. RESULTS [Literal/Required] No description - ; 2. OPTION [Literal/Required] No description - ; 3. DATA [Literal/Required] No description - ; - S RESULTS=$NA(^TMP("ANRVUSER",$J)) K @RESULTS - D:$T(@OPTION)]"" @OPTION - S:'$D(@RESULTS) @RESULTS@(0)="-1^No results returned" - D CLEAN^DILF - Q - ; -SNDTXT(RESULTS,ANRVCMD,DATA) ; [Procedure] Send completed Outcome - ; Input parameters - ; 1. RESULTS [Literal/Required] No description - ; 2. ANRVCMD [Literal/Required] No description - ; 3. DATA [Literal/Required] No description - ; - S RESULTS=$NA(^TMP($J)),^TMP($J,0)="-1^Unknown Error" - D:ANRVCMD="CREATE" - .K ^TMP("ANRVMAIL",$J) - .S ^TMP($J,0)="1^Message '"_$J_"' created." - D:ANRVCMD="APPEND" - .D:$G(DATA)]"" - ..S Y=$O(^TMP("ANRVMAIL",$J,"TEXT",""),-1)+1 - ..S ^TMP("ANRVMAIL",$J,"TEXT",Y,0)=DATA - .S X="DATA" - .F S X=$Q(@X) Q:X="" D - ..S Y=$O(^TMP("ANRVMAIL",$J,"TEXT",""),-1)+1 - ..S ^TMP("ANRVMAIL",$J,"TEXT",Y,0)=@X - .S Y=+$O(^TMP("ANRVMAIL",$J,"TEXT",""),-1) - .S ^TMP("ANRVMAIL",$J,"TEXT",0)="^^"_Y - .S ^TMP($J,0)="1^Text appended." - D:ANRVCMD="SUBJECT" - .S ^TMP("ANRVMAIL",$J,"SUBJECT")=DATA - .S ^TMP($J,0)="1^Message subject set to '"_DATA_"'" - D:ANRVCMD="SENDTO" - .D:$G(DATA)]"" - ..S Y=$O(^TMP("ANRVMAIL",$J,"SENDTO",""),-1)+1 - ..S ^TMP("ANRVMAIL",$J,"SENDTO",Y)=DATA - .S X="DATA" - .F S X=$Q(@X) Q:X="" D - ..S Y=$O(^TMP("ANRVMAIL",$J,"SENDTO",""),-1)+1 - ..S ^TMP("ANRVMAIL",$J,"SENDTO",Y)=@X - .S ^TMP($J,0)="1^Recipients Added." - D:ANRVCMD="EXECUTE" - .S XMSUB=$G(^TMP("ANRVMAIL",$J,"SUBJECT"),"No subject") - .S XMTEXT="^TMP(""ANRVMAIL"",$J,""TEXT""," - .F X=0:0 S X=$O(^TMP("ANRVMAIL",$J,"SENDTO",X)) Q:'X D - ..S XMY(^(X))="" - .D ^XMD - .S ^TMP($J,0)="1^Message Sent. ID: "_+$G(XMZ) - Q - ; -UPREC(RESULTS,TOPREC,STATUS) ; [Procedure] Update Top Record Status - ; Input parameters - ; 1. RESULTS [Literal/Required] No description - ; 2. TOPREC [Literal/Required] No description - ; 3. STATUS [Literal/Required] No description - ; - N MYFDA - S MYFDA(2048,TOPREC_",",.03)=STATUS - D FILE^DIE("","MYFDA") - I $DATA(DIERR) S RESULTS="-1^"_DIERR - E S RESULTS="1^SECTION UPDATED" - Q - ; -ADD(X) ; [Function] Adds data to @Results@ - ; Input parameters - ; 1. X [Literal/Required] No description - ; - S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X - Q - ; diff -auBN ./r1/AUPNSICD.m ./r2/r/AUPNSICD.m --- ./r1/AUPNSICD.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AUPNSICD.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,17 +1,13 @@ -AUPNSICD ;OHPRD/LAB - Screen Purpose of Visit/ICD9 codes ; 5/1/03 11:52am - ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149**;Aug 12, 1996 +AUPNSICD ;OHPRD/LAB - Screen Purpose of Visit/ICD9 codes ;6/20/96 + ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996 ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993 ; - N ICDSTR,ICDVDT - ;S ICDSTR=$$ICDDX^ICDCODE(Y,$P(^AUPNVSIT(PXCEVIEN,0),"^",2)) - S ICDSTR=$$ICDDX^ICDCODE(Y,+^AUPNVSIT(PXCEVIEN,0)),ICDVDT=+^AUPNVSIT(PXCEVIEN,0) G:$G(DUZ("AG"))="V" VAIN ; ;I 1 Q:$G(DUZ("AG"))'="I" EIN ; SCREEN OUT E CODES AND INACTIVE CODES ;I $E(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)="" - ;I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)="" - I $P(ICDSTR,U,2)'="E",$P(ICDSTR,U,10)=1 + I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)="" G:'$T XIT SEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX G:'$D(AUPNSEX) AGE @@ -28,7 +24,6 @@ ; VAIN ;SCREEN OUT INACTIVE CODES ; E codes are ok in the VA - ;I $P(^ICD9(Y,0),U,9)'=1 - I $P(ICDSTR,U,10)=1 + I $P(^ICD9(Y,0),U,9)'=1 Q ; diff -auBN ./r1/AWCMCPR1.m ./r2/r/AWCMCPR1.m --- ./r1/AWCMCPR1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMCPR1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,181 +0,0 @@ -AWCMCPR1 ;VISN 7/THM-CPRS MONITOR ;Feb 27, 2004 - ;;7.3;TOOLKIT;**84,86**;Jan 09, 2004 - ; - W !!,$C(7),"You cannot run this program directly.",!,"Application use only !!",!! H 2 Q ;enter properly - ; -STRT1 ; tiu - N AWCDTA S AWCDTA=$G(^AWC(177100.12,1,0)) - I $P(AWCDTA,U,17)'=1 G ENDQ ;master switch - I $P(AWCDTA,U,2)'=1 G ENDQ ;tiu - S AWCTYPE=1,AWCSTRT=$H - Q - ; -STRT2 ; lab - N AWCDTA S AWCDTA=$G(^AWC(177100.12,1,0)) - I $P(AWCDTA,U,17)'=1 G ENDQ ;master switch - I $P(AWCDTA,U,3)'=1 G ENDQ ;lab - S AWCTYPE=2,AWCSTRT=$H - Q - ; -STRT3 ; reminders - N AWCDTA S AWCDTA=$G(^AWC(177100.12,1,0)) - I $P(AWCDTA,U,17)'=1 G ENDQ ;master switch - I $P(AWCDTA,U,4)'=1 G ENDQ ;reminders - S AWCTYPE=3,AWCSTRT=$H - K AWCDTA - Q - ; -END ; record the data - ; quit if turning on/back on in middle of transaction (AWCTYPE or AWCSTRT missing) - I '$D(AWCTYPE)!('$D(AWCSTRT)) G ENDQ - S AWCDTA=$G(^AWC(177100.12,1,0)) - I $P(AWCDTA,U,17)'=1 G ENDQ ;master switch - I $P(AWCDTA,U,2)'=1 G ENDQ ;tiu - I $P(AWCDTA,U,3)'=1 G ENDQ ;lab - I $P(AWCDTA,U,4)'=1 G ENDQ ;reminder - S AWCEND=$H - L +^XTMP("AWCCPRS",.5):1 G:'$T ENDQ - S AWCDA=+$G(^XTMP("AWCCPRS",.5)) - I AWCDA>50000000 S AWCDA=0 ; reset to zero at fifty million entries - S AWCDA=AWCDA+1,^XTMP("AWCCPRS",.5)=AWCDA - L -^XTMP("AWCCPRS",.5) - S AWCFMDT=$$HTFM^XLFDT(AWCSTRT) - S ^XTMP("AWCCPRS",AWCFMDT,AWCDA,0)=AWCSTRT_U_AWCEND_U_DUZ_U_(+$G(DUZ(2)))_U_AWCTYPE - ; -ENDQ K AWCDTA,AWCSEC,AWCFMDT,AWCTYPE,AWCSTRT,AWCEND,DO,DD,DIC,DIE,AWCDA - Q - ; -PPAGE ; entry point to create updated .htm file - ; possible values for AWCX are VMS, VMSC, or NT - S AWCX="",AWCOS=$P(^%ZOSF("OS"),U) - I AWCOS["VAX DSM" S AWCX="VMS" - I AWCOS["OpenM-VMS" S AWCX="VMSC" - I AWCOS["OpenM" S AWCX="VMSC" - ; To double check for OS - I $T(OS^%ZOSV)'="" D - . I $$OS^%ZOSV()="VMS" S AWCX="VMSC" - . I $$OS^%ZOSV()="NT" S AWCX="NT" - ; - K TMP("AWC") D DT^DICRW - Q:'$D(^AWC(177100.12,1,0)) ;param file not set up - ; extract the parameters - S AWCDTA=$G(^AWC(177100.12,1,0)) - S AWCDTA1=$G(^AWC(177100.12,1,1)) - S AWCDHRS=$P(AWCDTA,U,7) I AWCDHRS="" S AWCDHRS=8 ;# hours to display - S X=$P(AWCDTA,U,8) S AWCMXSEC=$S(X]"":X,1:30) ;number of seconds to display - S X=$P(AWCDTA,U,9) S AWCTIULN=$S(X]"":X,1:"192,0,0") ;rgb code tiu line - S X=$P(AWCDTA,U,10) S AWCLABLN=$S(X]"":X,1:"0,192,0") ;rgb code lab line - S X=$P(AWCDTA,U,11) S AWCREMLN=$S(X]"":X,1:"0,0,192") ;rgb code reminder line - S X=$P(AWCDTA,U,12) S AWCGRDON=$S(X="y":"true",X="n":"false",1:"true") - S X=$P(AWCDTA,U,13) S AWCBKGRN=$S(X]"":X,1:"230,230,230") ;rgb code - S X=$P(AWCDTA1,U,3) S AWCMSRV=$S(X]"":X,1:"") ;server - S X=$P(AWCDTA1,U,4) S AWCMUSR=$S(X]"":X,1:"") ;user - S X=$P(AWCDTA1,U,5) S AWCMPW=$S(X]"":X,1:"") ;passwd - ; - K AWCDTA D NOW^%DTC S (AWCENDDT,AWCCURTM)=%,AWCTSEC=3600*AWCDHRS - S AWCI1=$P(%H,",",1),AWCI2=$P(%H,",",2) - S AWCI2=(AWCI2-AWCTSEC) I AWCI2<0 S AWCI2=AWCI2+86400,AWCI1=AWCI1-1 - S %H=AWCI1_","_AWCI2 D YMD^%DTC S AWCBEGDT=X_% - S X=$E(%,2,4),X=X_"0",X=$S($L(X)<4:X_"0",1:X) ;format to four digits, including any leading zeros - S AWCBEGTM=+X - S X=$P(AWCCURTM,".",2),X=($E(X,1,3)_"0"),X=$S($L(X)<4:X_"0",1:X) ;format to four digits as above - S AWCENDTM=+X K ^TMP("AWCTTIM",$J) - ; This loop skips 60 due to adding 10 to starting number. These two lines - ; cause it to print 0-50 min, skipping 60, like this: 210 220,230,240,250,300 - I AWCBEGTM>AWCENDTM F X=AWCBEGTM:10:2350 S ^TMP("AWCTTIM",$J,(-9999+X))="" S:$E(X,($L(X)-1),$L(X))=50 X=X+40 S:X=2360 X="0" ;before midnight - I AWCBEGTM>AWCENDTM F X=0:10:AWCENDTM S ^TMP("AWCTTIM",$J,X)="" S:$E(X,($L(X)-1),$L(X))=50 X=X+40 ;after midnight - I AWCENDTM>AWCBEGTM F X=AWCBEGTM:10:AWCENDTM S ^TMP("AWCTTIM",$J,X)="" I $E(X,($L(X)-1),($L(X)))=50 S X=X+40 ;normal times - ; -SORT ; sort the data into a TMP file - K ^TMP($J) - F AWCSRTDT=(AWCBEGDT-.000001):0 S AWCSRTDT=$O(^XTMP("AWCCPRS",AWCSRTDT)) Q:AWCSRTDT=""!(AWCSRTDT>AWCENDDT) DO - .F DA=0:0 S DA=$O(^XTMP("AWCCPRS",AWCSRTDT,DA)) Q:DA="" DO - ..S AWCDTA=$G(^XTMP("AWCCPRS",AWCSRTDT,DA,0)),AWCDIV=$P(AWCDTA,U,4),AWCTYPE=$P(AWCDTA,U,5) - ..I AWCDIV="" S AWCDIV=+$$SITE^VASITE ;for people without division assignments - ..S ^TMP($J,AWCDIV,AWCTYPE,AWCSRTDT,DA)="" - ; -DIVS ; count the divisions for drop-down box on web page (used in AWCMCPR2) - I '$D(^TMP($J)) D NODATA G PPAGE ;no data yet for time frame being processed - S AWCDCNTR=0 - F AWCDIV=0:0 S AWCDIV=$O(^TMP($J,AWCDIV)) Q:AWCDIV="" DO - .S AWCFDIV(AWCDIV)=$P(^DIC(4,AWCDIV,0),U)_U_$P($G(^DIC(4,+AWCDIV,99)),U)_U - .S AWCDCNTR=AWCDCNTR+1 - ; if only one division no drop-down box is needed - I AWCDCNTR=1 K AWCFDIV - ; generate one HTML page per facility -DIVPG F AWCDIV=0:0 S AWCDIV=$O(^TMP($J,AWCDIV)) Q:AWCDIV="" DO G:POP EXIT - .S AWCDEV=$P($G(^AWC(177100.12,1,0)),U,5) I AWCDEV="" S POP=1 Q ;no HFS device in param file - .S (AWCDIVNM,AWCDIVN1)=$P(^DIC(4,AWCDIV,0),U) - .S AWCDIVNM=$P($G(^DIC(4,+AWCDIV,99)),U) Q:AWCDIVNM="" - .S AWCFILE=$P(^AWC(177100.12,1,0),U,6)_"_"_AWCDIVNM_".htm" ;web page name with division number - .Q:AWCFILE=("_"_AWCDIV)!(AWCDEV="") ;webpage or device is missing in parameter file - .; Check VMS or NT before you put the \ in the file name - .I AWCX="NT" D - ..S AWCZ=$L(AWCDEV) I $E(AWCDEV,AWCZ,AWCZ)'="\" S AWCDEV=AWCDEV_"\" ;add \ if missing - .D OPEN^%ZISH("AWCCPR1",AWCDEV,AWCFILE,"W") Q:POP - .S AWCHFIL1=AWCDEV_AWCFILE ;needed for AWCMFTP at end - .U IO D PART1^AWCMCPR2 ;part 1 of web page - .; -TMPALL .; make the TMP("AWC", array with all possible hours, increments of ten, for all types 1,2,3, with zero values - .F T=1:1:3 F X=-99999:0 S X=$O(^TMP("AWCTTIM",$J,X)) Q:X="" S TMP("AWC",T,X)="0^0" - .; -DVALS .; count the number of data values to display on graph - .S AWCVCNTR=0 F X=0:0 S X=$O(TMP("AWC",X)) Q:X="" F Y=0:0 S Y=$O(TMP("AWC",X,Y)) Q:Y="" S AWCVCNTR=AWCVCNTR+1 - .S AWCVCNTR=AWCVCNTR/3 ;divide by 3 graph lines - .; get the data by date range provided and sort the data - .F AWCTYPE=0:0 S AWCTYPE=$O(^TMP($J,AWCDIV,AWCTYPE)) Q:AWCTYPE="" DO - ..F AWCDATE=(AWCBEGDT-.000001):0 S AWCDATE=$O(^TMP($J,AWCDIV,AWCTYPE,AWCDATE)) Q:AWCDATE=""!(AWCDATE>AWCENDDT) DO - ...F DA=0:0 S DA=$O(^TMP($J,AWCDIV,AWCTYPE,AWCDATE,DA)) Q:DA="" DO - ....S AWCDTA=$G(^XTMP("AWCCPRS",AWCDATE,DA,0)),AWCXSTRT=$P(AWCDTA,U),AWCXEND=$P(AWCDTA,U,2) - ....S AWCSEC=$$HDIFF^XLFDT(AWCXEND,AWCXSTRT,2) - ....S Y=AWCDATE X ^DD("DD") S X=$P(Y,"@",2),X=$TR(X,":","") - ....; sort the times ; AWCX1 is the hours ;AWCX3 is the minutes - ....; use 10-minute intervals and put with interval - ....S AWCX1=$E(X,1,2),AWCX3=$E(X,3,4) ;strip hours and minutes, no seconds although they are there - ....I "^00^01^02^03^04^05^"[(U_AWCX3_U) S AWCX3="00" - ....I "^06^07^08^09^10^11^12^13^14^15^"[(U_AWCX3_U) S AWCX3="10" - ....I "^16^17^18^19^20^21^22^23^24^25^"[(U_AWCX3_U) S AWCX3="20" - ....I "^26^27^28^29^30^31^32^33^34^35^"[(U_AWCX3_U) S AWCX3="30" - ....I "^36^37^38^39^40^41^42^43^44^45^"[(U_AWCX3_U) S AWCX3="40" - ....I "^46^47^48^49^50^51^52^53^54^55^"[(U_AWCX3_U) S AWCX3="50" - ....I "^56^57^58^59^"[(U_AWCX3_U) S AWCX3="60" - ....I AWCX3=60 S AWCX3="00",AWCX1=AWCX1+1 - ....I AWCX1=24 S AWCX1="00" - ....S AWCTIME=+(AWCX1_AWCX3) - ....; -SETTMP ....; set in TMP("AWC", array ONLY if within our selected range - ....I $D(TMP("AWC",AWCTYPE,(-9999+AWCTIME))) DO - .....S $P(TMP("AWC",AWCTYPE,(-9999+(+AWCTIME))),U)=$P($G(TMP("AWC",AWCTYPE,-9999+(+AWCTIME))),U)+AWCSEC - .....S $P(TMP("AWC",AWCTYPE,(-9999+(+AWCTIME))),U,2)=$P($G(TMP("AWC",AWCTYPE,(-9999+(+AWCTIME)))),U,2)+1 - ....I $D(TMP("AWC",AWCTYPE,+AWCTIME)) DO - .....S $P(TMP("AWC",AWCTYPE,+AWCTIME),U)=$P($G(TMP("AWC",AWCTYPE,+AWCTIME)),U)+AWCSEC - .....S $P(TMP("AWC",AWCTYPE,+AWCTIME),U,2)=$P($G(TMP("AWC",AWCTYPE,+AWCTIME)),U,2)+1 - .; -PART2 .D PART2^AWCMCPR2 ;part II of the HTML code - .; ftp the file - .D EN^AWCMFTP - I AWCX="NT" S CMD="S AWCVAR=$ZF(-1,"_"""erase ftpawc.txt"_""""_")" X CMD - I AWCX="VMS"!(AWCX="VMSC") D PURDEL^AWCMFTP - ; -EXIT D ^%ZISC - K %,%H,AWCC,AWCAVG,AWCCNT,AWCDATE,AWCDEV,AWCDHRS,AWCDIV,AWCDT,AWCDTA,AWCEND,AWCFILE,AWCFMDT,AWCSEC,AWCY,AWCX - K AWCSTRT,AWCTIME,AWCTYPE,AWCZ,AWCBEGTM,DA,DD,DIC,DIE,DO,DR,AWCENDDT,AWCENDTM,AWCLBCNT,AWCPARAM,AWCPCNTR,AWCFDIVN - K POP,AWCTTIM,AWCVCNTR,X,AWCX1,AWCX3,Y,AWCBEGDT,AWCCURTM,AWCI1,AWCI2,T,AWCTSEC,Z,AWCDIVNM,AWCWL,AWCDVDTA - K AWCTIULN,AWCLABLN,AWCREMLN,AWCMXSEC,AWCGRDON,AWCBKGRN,AWCDIVN1,AWCFDIV,AWCDVNM,AWCDVNB,AWCWEBRT,AWCDCNTR,AWCFXDTA - K AWCOS,AWCDTA1,AWCHFIL1,AWCMPW,AWCMSRV,AWCMUSR,AWCMCP,AWCSITE,AWCSITEN,AWCVMSP,AWCOS,AWCSRTDT,AWCXDIV,YYY - K %I,%ZISHO,%ZISUB,%ZISHF,AWCWBFLD,CMD,AWC,AWCDIR,AWCDIRL,AWCHFILE,AWCHFILL,AWCOS,AWCVAR,Y,%SUBMIT,VMSC,AWCXDA - K ^TMP("AWCTTIM",$J),^TMP($J),TMP("AWC"),AWCXSTRT,AWCXEND,XDUZ,TMP - Q - ; -NODATA ; handle no data for the day-create a zero, dummy record for the home facility. - ; this only occurs when a page is due to be run but no activity yet. - S (AWCSTRT,AWCEND)=$H - S AWCXDIV=$P($G(^AWC(177100.12,1,1)),U,2),AWCXDA=$O(^DIC(4,"D",AWCXDIV,0)) Q:AWCXDA="" - S AWCXDIV=$P($G(^DIC(4,AWCXDA,99)),U) Q:AWCXDIV="" - S XDUZ=.5,XDUZ(2)=AWCXDIV,AWCTYPE=1 - L +^XTMP("AWCCPRS",.5):1 Q:'$T - S AWCDA=+$G(^XTMP("AWCCPRS",.5)),AWCDA=AWCDA+1,^XTMP("AWCCPRS",.5)=AWCDA - L -^XTMP("AWCCPRS",.5) - S AWCFMDT=$$HTFM^XLFDT(AWCSTRT) - S ^XTMP("AWCCPRS",AWCFMDT,AWCDA,0)=AWCSTRT_U_AWCEND_U_XDUZ_U_(+$G(XDUZ(2)))_U_AWCTYPE - Q diff -auBN ./r1/AWCMCPR2.m ./r2/r/AWCMCPR2.m --- ./r1/AWCMCPR2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMCPR2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,85 +0,0 @@ -AWCMCPR2 ;VISN7/THM-CPRS MONITOR HTML CODE [07-07-2003] ; 09 Jan 2004 3:43 PM - ;;7.3;TOOLKIT;**84**;Jan 9, 2004 - ; -PART1 ; HTML section that creates java applet data - ; Variables are killed in calling program - ; - W "",! - W "",! - W "CPRS Response Time Monitor - "_AWCDIVN1_"",! - W "",! - S AWCY99=$P(^AWC(177100.12,1,0),U),AWCY99=$P($G(^DIC(4,+AWCY99,0)),U) - W "

"_AWCY99_"

" - W "

","CPRS Response Time Monitor for facility -- "_AWCDIVN1,!,"

" - D MENU1 - W "",! - Q - ; -PART2 ; - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - W "",! - F AWCTYPE=0:0 S AWCTYPE=$O(TMP("AWC",AWCTYPE)) Q:AWCTYPE="" S AWCPCNTR=0 F AWCTIME=-9999:0 S AWCTIME=$O(TMP("AWC",AWCTYPE,AWCTIME)) Q:AWCTIME="" DO - .S AWCPCNTR=AWCPCNTR+1,AWCPARAM="VAL"_AWCPCNTR_"_L"_AWCTYPE - .W "0:$J(AWCSEC/AWCCNT,0,2),1:0) - .I AWCAVG>AWCMXSEC S AWCAVG=AWCMXSEC ;if average is greater than max, set to max - .I AWCAVG<0 S AWCAVG=0 ;no values <0 - .W +AWCAVG,""">",! ;finish the HTML line - .; add the time values for the x-axis - S AWCLBCNT=1 - F YYY=-99999:0 S YYY=$O(^TMP("AWCTTIM",$J,YYY)) Q:YYY="" DO - .S Y=YYY - .I Y<0 S Y=9999+Y - .; format the time, if necessary - .I $L(Y)=1 S Y="000"_Y - .I $L(Y)=2 S Y="00"_Y - .I $L(Y)=3 S Y="0"_Y - .W "",! S AWCLBCNT=AWCLBCNT+1 - ; add the remaining values - S (AWCLBCNT,AWCVCNTR)=(AWCLBCNT-1) ;label count and value count - W !,"",! - W "",! - W "",!! - W "",! - W "",! - W "","

Response Time In Seconds for the last "_AWCDHRS_" hours

","
",! - W "
Last updated: " D NOW^%DTC S Y=% X ^DD("DD") W Y,!,"
",! - D CLOSE^%ZISH("AWCCPR1"),^%ZISC - K AWCY99 - Q - ; -MENU1 ; java script - makes drop-down menu - ; goes in portion of page - Q:$O(AWCFDIV(0))="" ;only one division at facility - S AWCWEBRT=$P(^AWC(177100.12,1,0),U,15) Q:AWCWEBRT="" ;not set up in param file - S AWCWL=$L(AWCWEBRT) I $E(AWCWEBRT,AWCWL,AWCWL)'="/" S AWCWEBRT=AWCWEBRT_"/" - W "
",! - W "",! - W "",! - W "
",! - Q diff -auBN ./r1/AWCMCPR3.m ./r2/r/AWCMCPR3.m --- ./r1/AWCMCPR3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMCPR3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,103 +0,0 @@ -AWCMCPR3 ;VISN 7/THM-CPRS MONITOR - ROLLUP TO NATIONAL SERVER ;Feb 27, 2004 - ;;7.3;TOOLKIT;**84,86**;Jan 09, 2004 - ; - Q ;enter properly - ; -GENSTAT ;; possible values for AWCX are VMS, VMSC, or NT - N AWCDTA S AWCDTA=$G(^AWC(177100.12,1,0)) - I $P(AWCDTA,U,17)'="1" G EXIT ;master switch - S AWCX="",AWCOS=$P(^%ZOSF("OS"),U) - I AWCOS["VAX DSM" S AWCX="VMS" - I AWCOS["OpenM-VMS" S AWCX="VMSC" - I AWCOS["OpenM" S AWCX="VMSC" - ; VMS FOR CACHE MODS TO DOUBLE CHECK FOR OS - I $T(OS^%ZOSV)'="" D - . I $$OS^%ZOSV()="VMS" S AWCX="VMSC" - . I $$OS^%ZOSV()="NT" S AWCX="NT" - ; - Q:'$D(^AWC(177100.12,1,0)) ;no parameter file set up - K ^TMP("AWC",$J),^TMP("AWCTTIM",$J) D DT^DICRW - I '$D(AWCMANL) S X="T-1",%DT="" D ^%DT S AWCBEGDT=Y - S AWCENDDT=AWCBEGDT+.2359 - S AWCBEGD1=17000000+AWCBEGDT ;yyyymmdd - S AWCTTIM="",AWCBEGTM=0,AWCENDTM=2400 - ;This loop skips 60 due to adding 10 to starting number. These two lines - ;cause it to print 0-50 min, skipping 60, like this: 210 220,230,240,250,300 - F X=0:10:AWCENDTM S ^TMP("AWCTTIM",$J,X)="" S:$E(X,($L(X)-1),$L(X))=50 X=X+40 ;previous day - ;make the ^TMP("AWC",$J, array with all possible hours, increments of ten for all types 1,2,3, with zero values - S AWCCNTR=0 F T=1:1:3 F X=-1:0 S X=$O(^TMP("AWCTTIM",$J,X)) Q:X="" S ^TMP("AWC",$J,T,X)="0^0" - S AWCDEV=$P($G(^AWC(177100.12,1,0)),U,5) - S AWCDIVNM=$P($G(^AWC(177100.12,1,1)),U,2) ;facility number - S AWCDIVN1=$P($G(^DIC(4,AWCDIVNM,0)),U) Q:AWCDIVN1="" ;division name - S AWCFILE="CPRSstats_"_AWCBEGD1_"_"_AWCDIVNM_".txt" ;text file division number - Q:AWCFILE=("_"_AWCDIVNM)!(AWCDEV="") ;webpage or device is missing in parameter file - ; CHECK VMS OR NT BEFORE YOU PUT THE \ IN FILE NAME - I AWCX="NT" D - .S AWCZ=$L(AWCDEV) I $E(AWCDEV,AWCZ,AWCZ)'="\" S AWCDEV=AWCDEV_"\" ;add \ if missing - ; - D OPEN^%ZISH("AWCMCPR3",AWCDEV,AWCFILE,"W") Q:$G(POP)=1 - S AWCHFIL1=AWCDEV_AWCFILE ;needed for AWCMFTP at end - U IO -DVALS ;get the data values - S AWCDATE=(AWCBEGDT-.000001) - F S AWCDATE=$O(^AWC(177100.13,"C",AWCDATE)) Q:AWCDATE=""!(AWCDATE>AWCENDDT) DO G:$G(POP)=1 EXIT - .F DA=0:0 S DA=$O(^AWC(177100.13,"C",AWCDATE,DA)) Q:DA="" DO - ..S AWCDTA=^AWC(177100.13,DA,0),AWCSEC=$P(AWCDTA,U,2),AWCTYPE=$P(AWCDTA,U,6) - ..S Y=AWCDATE X ^DD("DD") S X=$P(Y,"@",2),X=$TR(X,":","") - ..;sort the times ; AWCX1 is the hours ;AWCX3 is the minutes ;use 10-minute intervals - ..S AWCX1=$E(X,1,2),AWCX3=$E(X,3,99) - ..I "^00^01^02^03^04^05^"[(U_AWCX3_U) S AWCX3="00" - ..I "^06^07^08^09^10^11^12^13^14^15^"[(U_AWCX3_U) S AWCX3="10" - ..I "^16^17^18^19^20^21^22^23^24^25^"[(U_AWCX3_U) S AWCX3="20" - ..I "^26^27^28^29^30^31^32^33^34^35^"[(U_AWCX3_U) S AWCX3="30" - ..I "^36^37^38^39^40^41^42^43^44^45^"[(U_AWCX3_U) S AWCX3="40" - ..I "^46^47^48^49^50^51^52^53^54^55^"[(U_AWCX3_U) S AWCX3="50" - ..I "^56^57^58^59^"[(U_AWCX3_U) S AWCX3="60" - ..I AWCX3=60 S AWCX3="00",AWCX1=AWCX1+1 - ..I AWCX1=24 S AWCX1="00" - ..S AWCTIME=+(AWCX1_AWCX3) - ..; -SETTMP ..I $D(^TMP("AWC",$J,AWCTYPE,(-9999+AWCTIME))) DO - ...S $P(^TMP("AWC",$J,AWCTYPE,(-9999+(+AWCTIME))),U)=$P($G(^TMP("AWC",$J,AWCTYPE,-9999+(+AWCTIME))),U)+AWCSEC - ...S $P(^TMP("AWC",$J,AWCTYPE,(-9999+(+AWCTIME))),U,2)=$P($G(^TMP("AWC",$J,AWCTYPE,(-9999+(+AWCTIME)))),U,2)+1 - ..I $D(^TMP("AWC",$J,AWCTYPE,+AWCTIME)) DO - ...S $P(^TMP("AWC",$J,AWCTYPE,+AWCTIME),U)=$P($G(^TMP("AWC",$J,AWCTYPE,+AWCTIME)),U)+AWCSEC - ...S $P(^TMP("AWC",$J,AWCTYPE,+AWCTIME),U,2)=$P($G(^TMP("AWC",$J,AWCTYPE,+AWCTIME)),U,2)+1 - K AWCTOTX - F AWCTYPE=0:0 S AWCTYPE=$O(^TMP("AWC",$J,AWCTYPE)) Q:AWCTYPE="" S AWCPCNTR=0 F AWCTIME=-9999:0 S AWCTIME=$O(^TMP("AWC",$J,AWCTYPE,AWCTIME)) Q:AWCTIME="" DO - .S AWCDTA=$G(^TMP("AWC",$J,AWCTYPE,AWCTIME)),AWCSEC=$P(AWCDTA,U),AWCCNT=$P(AWCDTA,U,2) - .I $L(AWCTIME)=1 S AWCTIME="000"_AWCTIME - .I $L(AWCTIME)=2 S AWCTIME="00"_AWCTIME - .I $L(AWCTIME)=3 S AWCTIME="0"_AWCTIME - .I +AWCTIME<759 S $P(AWCTOTX(AWCTYPE,1),U,1)=$P($G(AWCTOTX(AWCTYPE,1)),U,1)+AWCSEC DO Q - ..S $P(AWCTOTX(AWCTYPE,1),U,2)=$P(AWCTOTX(AWCTYPE,1),U,2)+AWCCNT - .I +AWCTIME>759&(+AWCTIME<1600) S $P(AWCTOTX(AWCTYPE,2),U,1)=$P($G(AWCTOTX(AWCTYPE,2)),U,1)+AWCSEC DO Q - ..S $P(AWCTOTX(AWCTYPE,2),U,2)=$P(AWCTOTX(AWCTYPE,2),U,2)+AWCCNT - .I +AWCTIME'<1600&(+AWCTIME'>2359) S $P(AWCTOTX(AWCTYPE,3),U,1)=$P($G(AWCTOTX(AWCTYPE,3)),U,1)+AWCSEC DO Q - ..S $P(AWCTOTX(AWCTYPE,3),U,2)=$P(AWCTOTX(AWCTYPE,3),U,2)+AWCCNT - F X=1:1:3 S AWCTOTX(X,1)=$S($P(AWCTOTX(X,1),U,2)>0:$P(AWCTOTX(X,1),U,1)/$P(AWCTOTX(X,1),U,2),1:0) - F X=1:1:3 S AWCTOTX(X,2)=$S($P(AWCTOTX(X,2),U,2)>0:$P(AWCTOTX(X,2),U,1)/$P(AWCTOTX(X,2),U,2),1:0) - F X=1:1:3 S AWCTOTX(X,3)=$S($P(AWCTOTX(X,3),U,2)>0:$P(AWCTOTX(X,3),U,1)/$P(AWCTOTX(X,3),U,2),1:0) - F X=0:0 S X=$O(AWCTOTX(X)) Q:X="" S Y="" F S Y=$O(AWCTOTX(X,Y)) Q:Y="" W X,$C(9),Y,$C(9),$J(AWCTOTX(X,Y),5,2)_$C(9)_AWCBEGD1,! - ; -SENDIT ; send it - D CLOSE^%ZISH("AWCMCPR3"),^%ZISC - D EN^AWCMFTP1 - I AWCX["NT" DO - .S CMD="S AWCVAR=$ZF(-1,"_"""erase ftpstatawc.txt"_""""_")" X CMD - .S CMD="S AWCVAR=$ZF(-1,"_"""erase "_AWCHFILE_""""_")" X CMD - ; -EXIT K %DT,AWCAVB,AWCBEGDT,AWCBEGTM,AWCCNT,AWCCNTR,AWCDEV,AWCDIV,AWCDIVN1,AWCDIVNM,AWCDTA,AWCENDDT,AWCX,AWCY - K AWCENDTM,AWCFILE,AWCPCNTR,AWCSEC,AWCTIME,AWCTTIM,AWCTYPE,AWCVCNTR,AWCZ,DA,T,X,AWCX1,AWCX3,Y - K AWC,AWCDIR,AWCDIRL,AWCHFILE,AWCHFILL,AWCOS,AWCVAR,Y,%SUBMIT,VMSC,CMD,AWCHFIL1 - K ^TMP("AWC",$J),^TMP("AWCTTIM",$J),AWCAVG,AWCBEGD1,AWCDATE,TMP,AWCMANL - K ZTSK,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTDTH,AWCHDR1 - Q - ; -MANUAL S IOP="HOME" D ^%ZIS K IOP - S AWCHDR1="Re-run National CPRS Monitors" W @IOF,!,AWCHDR1,!! - S %DT="AE",%DT("A")="What day do you want to re-run ? " D ^%DT G:Y<0 EXIT - S X=$O(^AWC(177100.13,"C",(Y-.000001))) I X=""!(X>(Y_.2359)) W $C(7),!!,"There is no data in the permanent file for that day.",!! H 2 G MANUAL - S AWCBEGDT=Y,AWCMANL=1 - S ZTSAVE("AWC*")="",ZTIO="",ZTRTN="GENSTAT^AWCMCPR3",ZTDESC=AWCHDR1,ZTDTH=$H D ^%ZTLOAD - W:$D(ZTSK) !!,"Queued as task# ",ZTSK,!! H 2 G EXIT diff -auBN ./r1/AWCMCPR4.m ./r2/r/AWCMCPR4.m --- ./r1/AWCMCPR4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMCPR4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,28 +0,0 @@ -AWCMCPR4 ;VISN7/THM-NIGHT TIME MOVEMENT OF DATA ; 09 Jan 2004 3:43 PM - ;;7.3;TOOLKIT;**84**;Jan 9, 2004 - ; -EN ;This should be run after midnight so it processes the previous day. - S X="T-1",%DT="" D ^%DT S AWCSDT=Y,AWCX=(AWCSDT-.000001),AWCEDT=(Y+.2359) - F AWCX=AWCX:0 S AWCX=$O(^XTMP("AWCCPRS",AWCX)) Q:AWCX>AWCEDT!(AWCX="") F AWCDA=0:0 S AWCDA=$O(^XTMP("AWCCPRS",AWCX,AWCDA)) Q:AWCDA="" DO - .S AWCD1=$G(^XTMP("AWCCPRS",AWCX,AWCDA,0)) - .S AWCSTRT=$P(AWCD1,U),AWCEND=$P(AWCD1,U,2),AWCDUZ=$P(AWCD1,U,3),AWCDUZ(2)=$P(AWCD1,U,4),AWCTYPE=$P(AWCD1,U,5) - .I AWCDUZ(2)="" S AWCDUZ(2)=+$$SITE^VASITE ;for people without division assignments - .S AWCSEC=$$HDIFF^XLFDT(AWCEND,AWCSTRT,2) - .S AWCFMDT=$$HTFM^XLFDT(AWCSTRT) - .L +^AWC(177100.13,0):1 Q:'$T - .S AWCDATA=^AWC(177100.13,0) - .S $P(AWCDATA,"^",3)=$P(AWCDATA,"^",3)+1,AWCIEN(1)=$P(AWCDATA,"^",3) - .S ^AWC(177100.13,0)=AWCDATA - .L -^AWC(177100.13,0) - .K AWCDATA - .S AWCDATA(177100.13,"+1,",.01)=AWCIEN(1) - .S AWCDATA(177100.13,"+1,",1)=AWCSEC - .S AWCDATA(177100.13,"+1,",2)=AWCDUZ - .S AWCDATA(177100.13,"+1,",3)=AWCFMDT - .S AWCDATA(177100.13,"+1,",4)=AWCDUZ(2) - .S AWCDATA(177100.13,"+1,",5)=AWCTYPE - .D UPDATE^DIE("","AWCDATA","AWCIEN") - .K AWCDATA,AWCIEN - K AWCSDT,AWCX,AWCDA,AWCD1,AWCSTRT,AWCEND,AWCDUZ,AWCTYPE - K AWCFMDT,AWCDATA,AWCIEN,AWCSEC,AWCEDT,%DT,X,Y - Q diff -auBN ./r1/AWCMCPS2.m ./r2/r/AWCMCPS2.m --- ./r1/AWCMCPS2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMCPS2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,14 +0,0 @@ -AWCMCPS2 ;VISN7/THM-RE-INDEX PARAMETER FILE ; Feb 27, 2004 - ;;7.3;TOOLKIT;**86**;Jan 09, 2004 - ; - S IOP="HOME" D ^%ZIS K IOP - ; -EN W @IOF,!!,"Re-index the CPRS Monitor Parameter file (177100.12)",!! - W !,"Please wait . . . " H 2 - ; re-index .01 field - K ^AWC(177100.12,"B") - S DIK="^AWC(177100.12,",DA=1,DIK(1)=".01" D EN^DIK - W "Finished.",! - ; -EXIT K %,AWCMTPL,DA,AWCMOPT,DIK - Q diff -auBN ./r1/AWCMCPST.m ./r2/r/AWCMCPST.m --- ./r1/AWCMCPST.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMCPST.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,44 +0,0 @@ -AWCMCPST ;VISN 7/THM-POST-INIT FOR CPRS MONITOR ; Feb 27, 2004 - ;;7.3;TOOLKIT;**84,86**;Jan 09, 2004 - ; -EN ; set up ^XTMP nodes first - N AWCPGDT,X,Y - D DT^DICRW - S X="T+10",%DT="" D ^%DT Q:Y<0 S AWCPGDT=Y - ; locks applied even though nodes do not exist yet - I '$D(^XTMP("AWCCPRS",0)) DO - .L +^XTMP("AWCCPRS",0):1 - .S ^XTMP("AWCCPRS",0)=AWCPGDT_U_DT_U_"CPRS Monitor temporary global" ;zero node - .L -^XTMP("AWCCPRS",0) - I '$D(^XTMP("AWCCPRS",.5)) DO - .L +^XTMP("AWCCPRS",.5):1 - .S ^XTMP("AWCCPRS",.5)=0 ;node that supplies IEN - .L -^XTMP("AWCCPRS",.5) - ; -PARAM ; set up parameter file; all settings off initially - S AWCX=$$SITE^VASITE,AWCDIV=+AWCX,AWCDNAME=$P(AWCX,U,2),AWCMSTA=$P(AWCX,U,3) - ; Output= Institution file pointer^Institution name^station number with suffix - I AWCDIV="" W !!,$C(7),"Unable to resolve the site's station number",!! H 3 - G:AWCDIV="" EXIT - ; Beta test sites have it already, so update it for consistency - I $D(^AWC(177100.12,1,0)) DO G EXIT - .S (DIC,DIE)="^AWC(177100.12,",DIC(0)="QLM",DA=1 - .; set the first piece manually; can't edit a DINUMed field - .; field 1.5 will be triggered on new entries at non-beta sites, but not for existing beta sites - .S $P(^AWC(177100.12,DA,0),U)=AWCDIV - .S DR="1///0;1.2///0;1.5////"_AWCMSTA_";2///0;3///0;5////cprsmonitor"_AWCMSTA - .S DR=DR_";6///8;7///30;8///192,0,0;9///0,192,0;10///0,0,192;11///1;12///230,230,230" - .S DR=DR_";13///7;20///vaftp.va.gov;21////itmuser;22////Padfoot1;23///0;24///1" - .D ^DIE - . ;now re-index .01 field because it changed (DIK executes KILL and then SET) - .S DIK="^AWC(177100.12,",DA=1,DIK(1)=".01" D EN^DIK - ; section for new sites - field 1.5 is triggered - I '$D(^AWC(177100.12,1,0)) DO - .S X=AWCDIV,DIC("DR")="1///0;1.2///0;2///0;3///0;5///cprsmonitor"_AWCMSTA - .S DIC("DR")=DIC("DR")_";6///8;7///30;8///192,0,0;9///0,192,0;10///0,0,192;11///YES;12///230,230,230" - .S DIC("DR")=DIC("DR")_";13///7;20///vaftp.va.gov;21///itmuser;22///Padfoot1;23///0;24///1" - .S (DIC,DIE)="^AWC(177100.12,",DIC(0)="EQLM" K DO,DD D FILE^DICN - ; -EXIT K AWCDIV,AWCDA,AWCDNAME,AWCMSTA,DO,DD,DIC,DIE,DR,%DT,AWCPGDT,X,Y - K AWCX,DA - Q diff -auBN ./r1/AWCMCPUR.m ./r2/r/AWCMCPUR.m --- ./r1/AWCMCPUR.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMCPUR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,20 +0,0 @@ -AWCMCPUR ;VISN 7/THM-Purge CPRS Monitor data file and ^XTMP("AWC" global ; 09 Jan 2004 3:43 PM - ;;7.3;TOOLKIT;**84**;Jan 9, 2004 - ; -EN D DT^DICRW - ; number of days to keep data in param file - S AWCPDAYS=$P(^AWC(177100.12,1,0),U,14) - I +AWCPDAYS=0 S AWCPDAYS=30 ;if no limit set, keep minimum of 30 days - S X1=DT,X2=-AWCPDAYS D C^%DTC S AWCEND=X+.2359,AWCDTX="" - F S AWCDTX=$O(^AWC(177100.13,"C",AWCDTX)) Q:(AWCDTX>AWCEND)!(AWCDTX="") DO - .F DA=0:0 S DA=$O(^AWC(177100.13,"C",AWCDTX,DA)) Q:DA="" DO - ..S DIK="^AWC(177100.13," D ^DIK - ; - ; now purge the XTMP global -PGXTMP S AWCDTX="" F S AWCDTX=$O(^XTMP("AWCCPRS",AWCDTX)) Q:(AWCDTX>AWCEND)!(AWCDTX="") DO - .F DA=0:0 S DA=$O(^XTMP("AWCCPRS",AWCDTX,DA)) Q:DA="" K ^XTMP("AWCCPRS",AWCDTX,DA,0) - ; reset zero node purge date - S X="T+10",%DT="" D ^%DT Q:Y<0 S AWCPGDT=Y - S $P(^XTMP("AWCCPRS",0),U)=AWCPGDT - K DIK,DA,AWCEND,AWCPGDT,AWCDTX,AWCPDAYS,X1,X2,X,%,%H,%T,%DT,Y - Q diff -auBN ./r1/AWCMFTP1.m ./r2/r/AWCMFTP1.m --- ./r1/AWCMFTP1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMFTP1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,84 +0,0 @@ -AWCMFTP1 ;VISN7/THM-FTP FILES TO NATIONAL ROLL-UP SERVER from VISTA ; Feb 27, 2004 - ;;7.3;TOOLKIT;**84,86**;Jan 09, 2004 - ; - W *7,!,"Enter at line EN^AWCMFTP1.",! - Q -EN ; variables killed in calling program - S VMSC="" ;INIT THE VAR - S AWCHFILE="AWCMOVESTAT.COM" ;COM file name - I AWCX="NT" S AWCHFILE=AWCFILE - S AWCDTAX=$G(^AWC(177100.12,1,0)) - S AWCDIR=$P(AWCDTAX,U,5) ;Parameter file - S:AWCDIR="" AWCDIR="SYS$SYSDEVICE:[DSMMGR]" ;DEFAULT - S AWCSITE=$$SITE^VASITE,AWCSITE=$P(AWCSITE,U,2) ;site Name - S AWCSITEN=+$$SITE^VASITE ;3 dig number - S AWCDIRL=$$LOW^XLFSTR(AWCDIR),AWCHFILL=$$LOW^XLFSTR(AWCHFILE) - S AWCDTX=$G(^AWC(177100.12,1,1)) - S AWCWBFLD=$P(^AWC(177100.12,1,0),U,15),AWCWBFLD=$$LOW^XLFSTR(AWCWBFLD) ;web page folder - S AWCMVMSL=$P(AWCDTAX,U,16) ;VMS logging on or off - S AWCMVMSD=$P(AWCDTAX,U,18) ;DELETE COM files on or off - S AWCWBFLD=$P(AWCWBFLD,"/",2) - S AWCDIRCH=+$P(AWCDTAX,U,19) ;use change dir command? - S AWCMSRV=$P(AWCDTX,U,6),AWCMUSR=$P(AWCDTX,U,7),AWCMPW=$P(AWCDTX,U,8) - D @AWCX - Q - ; -NT S AWCC=1 - K ^TMP("AWCMFTP1",$J) - S ^TMP("AWCMFTP1",$J,AWCC,0)="open "_AWCMSRV,AWCC=AWCC+1 ;server ip address - S ^TMP("AWCMFTP1",$J,AWCC,0)=AWCMUSR,AWCC=AWCC+1 ; ftp user - S ^TMP("AWCMFTP1",$J,AWCC,0)=AWCMPW,AWCC=AWCC+1 ;ftp password - S ^TMP("AWCMFTP1",$J,AWCC,0)="ascii",AWCC=AWCC+1 - S ^TMP("AWCMFTP1",$J,AWCC,0)="put "_AWCDIRL_"\"_AWCHFILE,AWCC=AWCC+1 - S ^TMP("AWCMFTP1",$J,AWCC,0)="bye" - ; write it to the NT directory - S Y=$$GTF^%ZISH($NA(^TMP("AWCMFTP1",$J,1,0)),3,AWCDIRL,"ftpstatawc.txt") - ; send command to NT to execute this batch file - S CMD="S AWCVAR=$ZF(-1,""ftp -s:"_AWCDIRL_"\ftpstatawc.txt"")" X CMD - G EXIT - ; -VMSC ; VMS FOR CACHE MODS TO DOUBLE CHECK FOR OS - S VMSC=1 - ; -VMS K ^TMP("AWCMFTP1",$J) - S AWC=1,^TMP("AWCMFTP1",$J,AWC,0)="$ set noon" - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ set proc/priv = all" - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ assign sys$command sys$input " - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ set verify" - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ a=""''f$user()'""" - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ set def "_AWCDIR - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ set prot=(w:rwed,g:rwed,o:rwed,s:rwed) "_AWCDIR_AWCHFILE - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ ftp "_AWCMSRV - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)=AWCMUSR - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)=AWCMPW - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="ascii" - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="put "_AWCHFIL1 - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="bye" - ; purge or keep log files after FTP - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ wait 00:01" - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ set prot=(w:rwed,g:rwed,o:rwed,s:rwed) "_AWCDIR_AWCHFILE_";*" - I AWCMVMSL=1 S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ purge/keep=1 "_AWCDIR_"AWCMOVESTAT.LOG" - I AWCMVMSL=0 S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ delete "_AWCDIR_"AWCMOVESTAT.LOG;*" - ; purge or delete all web page versions after FTP - I AWCMVMSD=1 S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ delete "_AWCDIR_AWCHFILE_";*" - I AWCMVMSD=0 S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ purge/keep=1 "_AWCDIR_AWCHFILE - ; delete the stat text file - automatic,not user controlled - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ delete CPRSstats*.*;*" - S AWC=AWC+1,^TMP("AWCMFTP1",$J,AWC,0)="$ exit" - ; send to VMS - S Y=$$GTF^%ZISH($NA(^TMP("AWCMFTP1",$J,1,0)),3,AWCDIR,AWCHFILE) - G:VMSC VMSC1 - ; USE $&ZLIB EXTERNAL CALLS FOR DSM - S CMD="S %SUBMIT=$&ZLIB.%SUBMIT"_"("""_AWCDIR_AWCHFILE_""""_","_"""/NOPRINT"_$S(AWCMVMSL=1:"/LOG="_AWCDIR_"AWCMOVESTAT.LOG"""_")",1:"/NOLOG"""_")") - X CMD - G EXIT -VMSC1 ; - ; vms cache - ; USE $ZF CALLS FOR OS COMMANDS IN CACHE - S CMD="S AWCVAR=$ZF(-1,AWCVAR)" - S AWCVAR="SUBMIT "_AWCDIR_AWCHFILE_"/NOPRINT"_$S(AWCMVMSL=1:"/LOG="_AWCDIR_"AWCMOVESTAT.LOG",1:"/NOLOG") - X CMD - ; -EXIT ; - K CMD,^TMP("AWCMFTP1",$J),AWCMVMSL,AWCMVMSD,AWCDTAX,AWCDTX,AWC,AWCMANL - Q diff -auBN ./r1/AWCMFTP.m ./r2/r/AWCMFTP.m --- ./r1/AWCMFTP.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/AWCMFTP.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,116 +0,0 @@ -AWCMFTP ;VISN 7/THM-FTP FILES TO SERVER from VISTA ; Feb 27, 2004 - ;;7.3;TOOLKIT;**84,86**;Jan 09, 2004 - ; - W *7,!,"Enter at line EN^AWCMFTP.",! - Q -EN ; variables killed in calling program - S VMSC="" ;INIT THE VAR - ; AWCHFIL1= whole VMS path - S AWCHFILE="AWCMOVEHTM.COM" ;COM file name - I AWCX="NT" S AWCHFILE=AWCFILE - S AWCDTAX=$G(^AWC(177100.12,1,0)) - S AWCDIR=$P(AWCDTAX,U,5) ;Parameter file - S:AWCDIR="" AWCDIR="SYS$SYSDEVICE:[DSMMGR]" ;DEFAULT - S AWCSITE=$$SITE^VASITE,AWCSITE=$P(AWCSITE,U,2) ;site Name - S AWCSITEN=+$$SITE^VASITE ;3 dig number - S AWCDIRL=$$LOW^XLFSTR(AWCDIR),AWCHFILL=$$LOW^XLFSTR(AWCHFILE) - S AWCWBFLD=$P(AWCDTAX,U,15),AWCWBFLD=$$LOW^XLFSTR(AWCWBFLD) ;web page folder - ; Note: file deletion is not a problem for NT/Cache since it overwrites the files - S AWCMVMSL=+$P(AWCDTAX,U,16) ;VMS logging - S AWCMVMSD=+$P(AWCDTAX,U,18) ;VMS delete - S AWCDIRCH=+$P(AWCDTAX,U,19) ;use change dir command? - S AWCWBFLD=$P(AWCWBFLD,"/",2) - D @AWCX - Q - ; -NT ; NT script - S AWCC=1 - K ^TMP("AWCMFTP",$J) - S ^TMP("AWCMFTP",$J,AWCC,0)="open "_AWCMSRV,AWCC=AWCC+1 ;server ip address - S ^TMP("AWCMFTP",$J,AWCC,0)=AWCMUSR,AWCC=AWCC+1 ; ftp user - S ^TMP("AWCMFTP",$J,AWCC,0)=AWCMPW,AWCC=AWCC+1 ;ftp password - S ^TMP("AWCMFTP",$J,AWCC,0)="ascii",AWCC=AWCC+1 - I $G(AWCDIRCH)=1 S ^TMP("AWCMFTP",$J,AWCC,0)="cd "_AWCWBFLD,AWCC=AWCC+1 ;**** - S ^TMP("AWCMFTP",$J,AWCC,0)="put "_AWCDIRL_"\"_AWCHFILE,AWCC=AWCC+1 ;**** - S ^TMP("AWCMFTP",$J,AWCC,0)="bye" - ; write it to the NT directory - S Y=$$GTF^%ZISH($NA(^TMP("AWCMFTP",$J,1,0)),3,AWCDIRL,"ftpawc.txt") - ; send command to NT to execute this batch file - S CMD="S AWCVAR=$ZF(-1,""ftp -s:""_AWCDIRL_""\ftpawc.txt"")" - X CMD G EXIT - ; -VMSC ; VMS FOR CACHE MODS TO DOUBLE CHECK FOR OS - S VMSC=1 - ; -VMS ; VMS com file script - ; Captive process so we give full privs - S AWC=1 - K ^TMP("AWCMFTP",$J) - S ^TMP("AWCMFTP",$J,AWC,0)="$ set proc/priv = all" - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="$ set noon" - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="$ assign sys$command sys$input " - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="$ set verify" - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="$ a=""''f$user()'""" - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="$ set def "_AWCDIR - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="$ set prot=(w:rwed,g:rwed,o:rwed,s:rwed) "_AWCDIR_AWCHFILE - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="$ ftp "_AWCMSRV - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)=AWCMUSR - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)=AWCMPW - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="ascii" - I $G(AWCDIRCH)=1 S ^TMP("AWCMFTP",$J,AWC,0)="cd "_AWCWBFLD ;**** - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="put "_AWCHFIL1 - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="bye" - S AWC=AWC+1,^TMP("AWCMFTP",$J,AWC,0)="$ exit" - ; send to VMS - S Y=$$GTF^%ZISH($NA(^TMP("AWCMFTP",$J,1,0)),3,AWCDIR,AWCHFILE) - G:VMSC VMSC1 - ; - ; USE $&ZLIB EXTERNAL CALLS FOR DSM/VMS - S CMD="S %SUBMIT=$&ZLIB.%SUBMIT"_"("""_AWCDIR_AWCHFILE_""""_","_"""/NOPRINT"_$S(AWCMVMSL=1:"/LOG="_AWCDIR_$P(AWCHFILE,".",1)_".LOG"""_")",1:"/NOLOG"""_")") - X CMD - G EXIT -VMSC1 ; - ; VMS Cache - use $ZF(-1 calls for OS commands - S CMD="S AWCVAR=$ZF(-1,AWCVAR)" - S AWCVAR="SUBMIT "_AWCDIR_AWCHFILE_"/NOPRINT"_$S(AWCMVMSL=1:"/LOG="_AWCDIR_$P(AWCHFILE,".",1)_".LOG",1:"/NOLOG") - X CMD - ; -EXIT K CMD,^TMP("AWCMFTP"),^TMP("AWCMFTPD"),AWCMVMSL,AWCMVMSD,AWCDTAX,AWC,AWCDIRCH - Q - ; -PURDEL ; purging/deletion script - whether this occurs is controlled in file 177100.12 - ; this part creates a com file to purge or delete files we have created and then it deletes itself - ; - S AWCDTAX=$G(^AWC(177100.12,1,0)) - S AWCMVMSL=+$P(AWCDTAX,U,16) ;VMS logging - S AWCMVMSD=+$P(AWCDTAX,U,18) ;VMS delete - S AWCHFILE="AWCPURGE.COM" - ; captive process again so we give full privs - K ^TMP("AWCMFTPD",$J) - S AWC=1,^TMP("AWCMFTPD",$J,AWC,0)="$ wait 00:05" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ set proc/priv = all" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ set noon" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ assign sys$command sys$input " - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ set verify" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ a=""''f$user()'""" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ set def "_AWCDIR - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ set prot=(w:rwed,g:rwed,o:rwed,s:rwed) "_AWCDIR_"AWCMOVEHTM.LOG;*" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ set prot=(w:rwed,g:rwed,o:rwed,s:rwed) "_AWCDIR_"AWCMOVEHTM.COM;*" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ set prot=(w:rwed,g:rwed,o:rwed,s:rwed) "_AWCHFIL1_";*" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ set prot=(w:rwed,g:rwed,o:rwed,s:rwed) "_AWCDIR_"AWCPURGE.COM;*" - ; purge or keep log files - 0 deletes all, 1 leaves one copy - I AWCMVMSL=1 S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ purge/keep=1 "_AWCDIR_"AWCMOVEHTM.LOG" - I AWCMVMSL=0 S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ delete "_AWCDIR_"AWCMOVEHTM.LOG;*" - ; purge or delete all COM versions - 0 deletes all, 1 leaves one copy - I AWCMVMSD=1 S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ delete "_AWCDIR_"AWCMOVEHTM.COM;*" - I AWCMVMSD=0 S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ purge/keep=1 "_AWCDIR_"AWCMOVEHTM.COM;*" - ; delete the web pages - automatic, not user controlled - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ delete "_$P(AWCHFIL1,"_",1)_"*.*;*" - S AWC=AWC+1,^TMP("AWCMFTPD",$J,AWC,0)="$ exit" - ; send to VMS - S Y=$$GTF^%ZISH($NA(^TMP("AWCMFTPD",$J,1,0)),3,AWCDIR,AWCHFILE) - I AWCX="VMS" S CMD="S %SUBMIT=$&ZLIB.%SUBMIT"_"("""_AWCDIR_AWCHFILE_""""_","_"""/DELETE /NOPRINT /NOLOG"""_")" - I AWCX="VMSC" S CMD="S AWCVAR=$ZF(-1,AWCVAR)" - I AWCX="VMSC" S AWCVAR="SUBMIT "_AWCDIR_AWCHFILE_"/DELETE /NOPRINT /NOLOG" - X CMD - Q diff -auBN ./r1/BPSECA1.m ./r2/r/BPSECA1.m --- ./r1/BPSECA1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECA1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,169 +0,0 @@ -BPSECA1 ;BHAM ISC/FCS/DRS/VA/DLF - Assemble formatted claim ;05/14/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;Assemble ASCII formatted claim submission record - ; - ;Input Variables: CLAIMIEN - pointer into 9002313.02 - ; The claim must be complete and well-constructed; - ; we do some paranoical checks below. - ; - ; $$ Returns: - Formatted NCPDP ASCII record - ;---------------------------------------------------------------------- - ; - ;IHS/SD/lwj 8/1/02 NCPDP 5.1 changes - ; These is major differences in 3.2 vs 5.1 in the actual creation - ; of the claim. Of significance: - ; 3.2 had 4 claim segments (hdr req, hdr opt, det req, det opt) - ; 5.1 has 14 claim segments (header, patient, insurance, claim - ; pharmacy provider, prescriber, - ; COB, workers comp, DUR, Pricing, - ; coupon, compound, prior auth, - ; clinical) - ; - ; 3.2 required only field identifiers and separtors on optional - ; fields - ; 5.1 requires field identifiers and separators on all fields - ; other than the header - ; - ; 3.2 there were no segment separators - ; 5.1 segment separators are required prior to each segment - ; following the header - ; - ; 3.2/5.1 Group seperators appear at the end of each - ; transaction (prescription) - ; - ; The first thing added to this routine is the retrieval of the - ; version from the claim file. If the version is 3.2, we will - ; process just like we used to. If it is 5.1, we will alter the - ; creation of the claim to include the above differences. - ; - ; Adjustments were also made to the reversal logic as well. - ; - ; - ; -ASCII(CLAIMIEN) ;EP - from BPSOSQH from BPSOSQG from BPSOSQ2 - N IEN,MBPS,RECORD,BPS,REVERSAL,UERETVAL,CLMV,DET51,RTRNCD - I '$D(^BPSC(CLAIMIEN,0)) D G QERR ; check for good parameter - . S UERETVAL=$$IMPOSS^BPSOSUE("DB,P","T",CLAIMIEN,,1,$T(+0)) - ; - ;Setup IEN variables (used when executing format code) - S IEN(9002313.02)=CLAIMIEN - ; Point to BPS INSURER - S IEN(9002313.4)=$P($G(^BPSC(IEN(9002313.02),0)),U,2) - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ D - . S IEN(9002313.4)=$S($G(ENTRY):$G(^BPS(9002313.31,ENTRY,4)),1:64) - ;I $G(CERTIFY) S IEN(9002313.4)=$G(^BPS(9002313.31,ENTRY,4)) - I 'IEN(9002313.4) D G QERR ; claim must have an insurer - . S UERETVAL=$$IMPOSS^BPSOSUE("DB,P","T",CLAIMIEN,,2,$T(+0)) - ; Point to format - I '$G(VARX) S IEN(9002313.92)=$P($G(^BPSEI(IEN(9002313.4),100)),U,1) ;LJE;7/9/03 - E S IEN(9002313.92)=IEN(9002313.4) ;LJE;7/9/03 - I IEN(9002313.02)["^" S (BPS(9002313.02),IEN(9002313.02))=$P(IEN(9002313.02),"^",1) ;LJE - I '$G(VARX) I 'IEN(9002313.92) D G QERR ; insurer must have an e-format - . S UERETVAL=$$IMPOSS^BPSOSUE("DB","T",CLAIMIEN,,3,$T(+0)) - ; - ; - ; But if it's a reversal claim, get the format for the reversal - ; IHS/SD/lwj 08/15/02 NCPDP 5.1 needed to adjust reversal a little - ; RTRNCD added - original IF stmt remarked out - new one added - ; 5.1 transaction code for reversal is now B2 not 11 - ; - S RTRNCD=$P(^BPSC(IEN(9002313.02),100),U,3) - ;I $P(^BPSC(IEN(9002313.02),100),U,3)="11" D - I (RTRNCD=11)!(RTRNCD="B2") D - . S REVERSAL=1 - . S IEN(9002313.92)=$P($G(^BPSF(9002313.92,+IEN(9002313.92),"REVERSAL")),U) - . I 'IEN(9002313.92) D G QERR ; format must point to a reversal format - . . S UERETVAL=$$IMPOSS^BPSOSUE("DB","T",CLAIMIEN,,4,$T(+0)) - E S REVERSAL=0 - ; - I '$D(^BPSF(9002313.92,+IEN(9002313.92),0)) D G QERR - . S UERETVAL=$$IMPOSS^BPSOSUE("P","T",CLAIMIEN,,5,$T(+0)) - ; - ;IHS/SD/lwj 8/1/02 - ; retrieve the version number from the claim file so we know which - ; way we have to process - S CLMV=$P($G(^BPSC(IEN(9002313.02),100)),U,2) - ; - ;Retrieve claim submission record (used when executing format code) - D GETBPS2^BPSECX0(IEN(9002313.02),.BPS) - ;W $T(+0)," we have:",! ZW BPS R ">>>",%,! - ; - ;Assember claim header required and optional format sections - S RECORD="" - K VARECORD S VARECORD="" - ; - ;IHS/SD/lwj 8/1/02 nxt line remvd, following 2 lines added for 5.1 chgs - ;D XLOOP^BPSECA2("10^20",.IEN,.BPS,.RECORD) - D:CLMV[3 XLOOP^BPSECA2("10^20",.IEN,.BPS,.RECORD) ;3.2 clms - D:CLMV[5 XLOOP^BPSOSH2("100^110^120",.IEN,.BPS,.RECORD) ;5.1 clms - ;LJE; had to do this because of HL7 control char constraints - ; - ;IHS/SD/lwj 8/1/02 NCPDP 5.1 create chain of segments - S DET51="130^140^150^160^170^180^190^200^210^220^230" - ; - ;Loop through prescription multiple - S IEN(9002313.01)=0 - F D Q:'IEN(9002313.01) - .S IEN(9002313.01)=$O(^BPSC(IEN(9002313.02),400,IEN(9002313.01))) - .Q:'IEN(9002313.01) - .; - .;Retrieve prescription information (used when executing format code) - .K BPS(9002313.0201) - .D GETBPS3^BPSECX0(IEN(9002313.02),IEN(9002313.01),.BPS) - .; - .;IHS/SD/lwj 8/22/02 NCPDP 5.1 handle at least the DUR repeating flds - .D DURVALUE - .; - .;W $T(+0)," we have:",! ZW BPS R ">>>",%,! - .; - .;Append group seperator character (but not in a reversal format) - . I 'REVERSAL S RECORD=RECORD_$C(29) - .;IHS/SD/lwj 08/15/02 NCPDP 5.1 - requires GS on reversal - . I (REVERSAL)&(CLMV[5) S RECORD=RECORD_$C(29) - .; - .;Assemble claim information required and optional sections - .;IHS/SD/lwj 8/1/02 nxt ln rmkd out - following 2 lines added - .;D XLOOP^BPSECA2("30^40",.IEN,.BPS,.RECORD) - .D:CLMV[3 XLOOP^BPSECA2("30^40",.IEN,.BPS,.RECORD) - .D:CLMV[5 XLOOP^BPSOSH2(DET51,.IEN,.BPS,.RECORD) - ; - I VARX D VASTORE - Q RECORD - ; -VASTORE ;LJE; Need to store by segment for VA due to HL7 constraints. Had to changed field, group, and segment separators to control - ; ; characters for Vitria/AAC processing as well as shortening the length of the xmit. - N NNODES,INDEX,ONE,TWO,OREC - S NNODES=0,INDEX=1 F S NNODES=$O(RECORD(NNODES)) Q:NNODES="" D - . I RECORD(NNODES)[$C(29) - . I RECORD(NNODES)[$C(30) S (ONE,TWO)="",ONE=$P(RECORD(NNODES),($C(30)_$C(28)),1),TWO=$P(RECORD(NNODES),($C(30)_$C(28)),2) D - . . S RECORD(OREC)=RECORD(OREC)_ONE_$C(30)_$C(28),RECORD(NNODES)=TWO - . S OREC=NNODES - ; - S NNODES="" - S INDEX=1 F S NNODES=$O(RECORD(NNODES)) Q:NNODES="" D - . S ^BPSECX($J,"C",CLAIMIEN,INDEX)=RECORD(NNODES) - . ;N WP,I F I=1:100:$L(RECORD(NNODES)) S WP(I/100+1,0)=$E(RECORD(NNODES),I,I+99) - . S WP(INDEX/100+1,0)=RECORD(NNODES) - . S INDEX=INDEX+1 - D WP^DIE(9002313.02,CLAIMIEN_",",9999,"","WP") - S ^BPSECX($J,"C",CLAIMIEN,0)=INDEX-1 - S RECORD=1 - Q - ; -QERR Q - ; -DURVALUE ;NCPDP 5.1 - this subroutine will loop through the DUR/PPS repeating - ; fields and load their values into the BPS array for the claim - ; generation process - ; - N DURCNT,DUR - ; - K BPS(9002313.1001) - ; - ;we depend on the "count" since we set it when we created the clm entry - S DURCNT=$P($G(^BPSC(IEN(9002313.02),400,IEN(9002313.01),473.01,0)),U,4) - F DUR=1:1:DURCNT D - . D GETBPS4^BPSECX0(IEN(9002313.02),IEN(9002313.01),DUR,.BPS) - ; - Q diff -auBN ./r1/BPSECA2.m ./r2/r/BPSECA2.m --- ./r1/BPSECA2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECA2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,44 +0,0 @@ -BPSECA2 ;BHAM ISC/FCS/DRS/VA/DLF - Assemble formatted claim ;05/14/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Put together ascii formatted record via NCPDP Record definition - ; - ;Input Variables: NODES - (10^20 or 30^40) - ; .IEN - Internal Entry Number array - ; .BPS - Formatted Data Array with claim and - ; prescription data - ; .REC - Formatted Ascii record (result) - ;---------------------------------------------------------------------- -XLOOP(NODES,IEN,BPS,REC) ;EP - from BPSECA1 - ;Manage local variables - N ORDER,RECMIEN,MDATA,FLDIEN,PMODE,FLAG,NODE,FDATA,FLDNUM,FLDDATA - N INDEX,FLDID - ; - ;Loop through the NODES defined in NODES variable parsed by U - F INDEX=1:1:$L(NODES,U) D - .S NODE=$P(NODES,U,INDEX) - .Q:NODE="" - .Q:'$D(^BPSF(9002313.92,+IEN(9002313.92),NODE,0)) - .; - .S ORDER="" - .F D Q:'ORDER - ..S ORDER=$O(^BPSF(9002313.92,+IEN(9002313.92),NODE,"B",ORDER)) - ..Q:'ORDER - ..S RECMIEN="" - ..S RECMIEN=$O(^BPSF(9002313.92,+IEN(9002313.92),NODE,"B",ORDER,RECMIEN)) - ..Q:RECMIEN="" - ..S MDATA=$G(^BPSF(9002313.92,+IEN(9002313.92),NODE,RECMIEN,0)) - ..Q:MDATA="" - ..S FLDIEN=$P(MDATA,U,2) - ..Q:FLDIEN="" - ..S FDATA=$G(^BPSF(9002313.91,FLDIEN,0)) - ..Q:FDATA="" - ..S FLDNUM=$P(FDATA,U,1) - ..S FLDID=$P(FDATA,U,2) - ..Q:FLDNUM="" - ..S:NODE=10!(NODE=20) FLDDATA=$G(BPS(9002313.02,IEN(9002313.02),FLDNUM,"I")) - ..;I FLDNUM=402 S FLDDATA=$G(BPS(9002313.0201,1,FLDNUM,"I")) ;for REVERSAL TYPE OF CLAIM. Added by GTI. 06-14-96 - ..S:NODE=30!(NODE=40) FLDDATA=$G(BPS(9002313.0201,IEN(9002313.01),FLDNUM,"I")) - ..S REC=REC_$S(FLDID="":"",1:$C(28))_FLDDATA - Q diff -auBN ./r1/BPSECA4.m ./r2/r/BPSECA4.m --- ./r1/BPSECA4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECA4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,227 +0,0 @@ -BPSECA4 ;BHAM ISC/FCS/DRS/VA/DLF - Parse Claim Response ;05/14/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Parse ASCII Response Claim Record and Sup FDATA() Array - ; - ;Parameters: RREC - Ascii Response Record - ; RESPIEN - Claim Response IEN (90023130.03) - ;---------------------------------------------------------------------- - ; Calls BPSECA5 - ; - ;---------------------------------------------------------------------- - ; IHS/SD/lwj 8/6/02 NCPDP 5.1 changes - ; NCPDP 5.1 response segments are completely different than the - ; 3.2 response. Of significant importance are: - ; In 3.2, there were 4 basic repsonse segments (header required, - ; header option, information required, information optional.) - ; In 5.1, there are 8 possible segments (header, message, insurance, - ; status, claim, pricing, DUR/PPS, and prior authorization) - ; - ; In 5.1, for all segments following the header, a segment separator - ; is used. - ; - ; In 5.1, field separators, and field identifiers are used for all - ; fields not appearing on the header segment. - ; - ; To adjust to these changes, this routine has been modified. The - ; first thing we will try to establish is which version of response - ; we are working with. A new subroutine was created to hold the - ; 3.2 basic parsing of claim information, and a new routine - ; (BPSOSH4) was created to perform the parsing of a 5.1 claim. - ;---------------------------------------------------------------------- -PARSE(RREC,RESPIEN) ;EP - from BPSOSQL from BPSOSQ4 - N GS,FS,RHEADER,RHEADERR,RHEADERO,MEDN,RDATA,RDATAR,RDATAO - N INDEX,FDATA,ID,XDATA,RINFO - ; - ;Make sure input varaibles are defined - Q:$G(RREC)="" - Q:$G(RESPIEN)="" - Q:'$D(^BPSR(RESPIEN,0)) - ; - ;group and field separator characters - S GS=$C(29),FS=$C(28) - ; - ; Special handling for what appears to be a corrupt response - ; from First Health for Alaska Medicaid. It's missing a GS. - I RREC'[GS D AKMEDFIX - ; - ;Parse response header section from ascii record - S RHEADER=$P(RREC,GS,1) - S RHEADERR=$P(RHEADER,FS,1) - ; - ;IHS/SD/lwj 8/6/02 NCPDP 5.1 changes - begin changes - ; Need to split out the parsing of 3.2 and 5.1 claims - we will - ; check the version, and if it is 3.2, we will call the PARSE32 - ; subroutine - if it's 5.1, we will call the BPSOSH4 routine. - ; - S FDATA(102)=$E(RHEADERR,1,2) - I FDATA(102)[3 D PARSE32 - I FDATA(102)[5 D PARSE51^BPSOSH4(RREC,RESPIEN) - ; - ;IHS/SD/lwj 8/6/02 NCPDP 5.1 end changes other than subroutine - ; PARSE32 tag - ; - Q - ; - ; -PARSE32 ;IHS/SD/lwj 8/6/02 NCPDP 5.1 forced the splitting of the parsing - - ; this subroutine is the original code that will parse 3.2 still - ; - S RHEADERO=$P(RHEADER,FS,2) - ; - ;Parse required response header fields - S FDATA(102)=$E(RHEADERR,1,2) - S FDATA(103)=$E(RHEADERR,3,4) - S FDATA(501)=$E(RHEADERR,5,5) - ; - ; Reversal response: doesn't have the GS, though it does have - ; some prescription-multiple-type fields. Fake it out. - ; Right now, this works only for PCS REVERSAL format. - ; May learn more as other reversals come along. - I FDATA(103)=11 D PCSREV G AROUND - ; - ;Parse optional response header fields - S FDATA(524)=RHEADERO - ; - ;Parse repsonse information section from ascii record - S RINFO=$P(RREC,GS,2,999) - ; - ;Parse response information sections for each medication - F MEDN=1:1:$L(RINFO,GS) D - .S RDATA=$P(RINFO,GS,MEDN) - .S RDATAR=$P(RDATA,FS,1) - .S RDATAO=$P(RDATA,FS,2,999) - .; - .;Parse required response information section - .S FDATA("M",MEDN,501)=$E(RDATAR,1,1) - .; - .;Duplicate claim response information fields - .I FDATA("M",MEDN,501)="D" D - ..S FDATA("M",MEDN,1000)=$E(RDATAR,2,85) - ..; Was it a duplicate Paid or Captured claim? - ..N X S X=$S($$PAID^BPSECA7($E(RDATAR,2,85)):"P",1:"C") - ..S FDATA("M",MEDN,501)="D"_X - .; - .;Payable claim response information fields - .I FDATA("M",MEDN,501)="P"!(FDATA("M",MEDN,501)="DP") D - ..S FDATA("M",MEDN,505)=$E(RDATAR,2,7) - ..S FDATA("M",MEDN,506)=$E(RDATAR,8,13) - ..S FDATA("M",MEDN,507)=$E(RDATAR,14,19) - ..S FDATA("M",MEDN,508)=$E(RDATAR,20,25) - ..S FDATA("M",MEDN,509)=$E(RDATAR,26,31) - ..S FDATA("M",MEDN,503)=$E(RDATAR,32,45) - ..S FDATA("M",MEDN,504)=$E(RDATAR,46,85) - .; - .;Caputured claim response information fields - .I FDATA("M",MEDN,501)="C"!(FDATA("M",MEDN,501)="DC") D - ..S FDATA("M",MEDN,503)=$E(RDATAR,2,15) - ..S FDATA("M",MEDN,504)=$E(RDATAR,16,85) - .; - .;Rejected claim response information fields - .I FDATA("M",MEDN,501)="R" D - ..S FDATA("M",MEDN,510)=$E(RDATAR,2,3) - ..S FDATA("M",MEDN,511,1)=$E(RDATAR,4,5) - ..S FDATA("M",MEDN,511,2)=$E(RDATAR,6,7) - ..S FDATA("M",MEDN,511,3)=$E(RDATAR,8,9) - ..S FDATA("M",MEDN,511,4)=$E(RDATAR,10,11) - ..S FDATA("M",MEDN,511,5)=$E(RDATAR,12,13) - ..S FDATA("M",MEDN,511,6)=$E(RDATAR,14,15) - ..S FDATA("M",MEDN,511,7)=$E(RDATAR,16,17) - ..S FDATA("M",MEDN,511,8)=$E(RDATAR,18,19) - ..S FDATA("M",MEDN,511,9)=$E(RDATAR,20,21) - ..S FDATA("M",MEDN,511,10)=$E(RDATAR,22,23) - ..S FDATA("M",MEDN,511,11)=$E(RDATAR,24,25) - ..S FDATA("M",MEDN,511,12)=$E(RDATAR,26,27) - ..S FDATA("M",MEDN,511,13)=$E(RDATAR,28,29) - ..S FDATA("M",MEDN,511,14)=$E(RDATAR,30,31) - ..S FDATA("M",MEDN,511,15)=$E(RDATAR,32,33) - ..S FDATA("M",MEDN,511,16)=$E(RDATAR,34,35) - ..S FDATA("M",MEDN,511,17)=$E(RDATAR,36,37) - ..S FDATA("M",MEDN,511,18)=$E(RDATAR,38,39) - ..S FDATA("M",MEDN,511,19)=$E(RDATAR,40,41) - ..S FDATA("M",MEDN,511,20)=$E(RDATAR,42,43) - ..S FDATA("M",MEDN,504)=$E(RDATAR,44,85) - .; - .;Parse optional response information section - .D OPTR(MEDN,RDATAO) - ; -AROUND ; - ;File FDATA() in Claim Response File (9002313.03) - D FILE^BPSECA5(RESPIEN) - Q -PCSREV ; split off of PCS REVERSAL processing - RHEADER has everything - ; Make it look like a prescription multiple - ; It has no GS or FS stuff, so everything is in RHEADERR - N X S X=RHEADERR - I FDATA(501)="A" D ; accepted reversal - .S FDATA("M",1,503)=$E(X,6,19) - .S FDATA("M",1,504)=$E(X,20,$L(X)) - E I FDATA(501)="R" D ; rejected reversal - .S FDATA("M",1,510)=$E(X,6,7) - .N I F I=8:2:26 D - ..S FDATA("M",1,511,I-8/2+1)=$E(X,I,I+1) - .S FDATA("M",1,504)=$E(X,28,100) - E D ; corrupt - .S FDATA("M",1,504)=X - S MEDN=1 - Q - ;--------------------------------------------------------------------- - ;Process Optional Response Information Section - ; - ;Parameters: MEDN - Current medication sequence # - ; RDATAO - Optional response information section - ;--------------------------------------------------------------------- -OPTR(MEDN,RDATAO) ; - ;Manage local variables - N INDEX,ID,XDATA - ; - ;Make sure input variables are defined - Q:$G(MEDN)="" - Q:$G(RDATAO)="" - ; - F INDEX=1:1:$L(RDATAO,FS) D - .S FDATA=$P(RDATAO,FS,INDEX) - .Q:FDATA="" - .; - .S ID=$E(FDATA,1,2) - .S XDATA=$E(FDATA,3,$L(FDATA)) - .I ID="F9" S FDATA("M",MEDN,509)=XDATA Q ; PCS 1997 Packet Emulator Test #2 sends Patient Pay Amount here - mistakenly? Let's record it anyhow. - .I ID="FC" S FDATA("M",MEDN,512)=XDATA Q - .I ID="FD" S FDATA("M",MEDN,513)=XDATA Q - .I ID="FE" S FDATA("M",MEDN,514)=XDATA Q - .I ID="FH" S FDATA("M",MEDN,517)=XDATA Q - .I ID="FI" S FDATA("M",MEDN,518)=XDATA Q - .I ID="FJ" S FDATA("M",MEDN,519)=XDATA Q - .I ID="FK" S FDATA("M",MEDN,520)=XDATA Q - .I ID="FL" S FDATA("M",MEDN,521)=XDATA Q - .I ID="FM" S FDATA("M",MEDN,522)=XDATA Q - .I ID="FN" S FDATA("M",MEDN,523)=XDATA Q - .I ID="FP" D Q - . . I XDATA?159" "1N Q ; no DUR data, just the overflow flag - . . S FDATA("M",MEDN,525)=XDATA - .I ID="FQ" S FDATA("M",MEDN,526)=XDATA Q - Q -AKMEDFIX ; as noted, above ; Alaska Medicaid while sleeping - you get - ; this corrupt message. May be true of other insurers, too. - ; This looks like it might be an NDC message. - ; We'll find out as time goes on. - ; Here - we make sure that it's one of those packets, - ; and we insert GS characters so that it parses correctly. - I $E(RREC,7,21)'="FO R0199" Q - I $E(RREC,1,5)'?1"3C0"1N1"A" Q - I $E(RREC,6)'=FS Q - I $E(RREC,22,59)'?." " Q - I $E(RREC,60,99)'="PRT010 CARRIER DISABLED -B1ON99CR" Q - N NPIECES S NPIECES=$L(RREC,"R0199") ; = header + 1 for each claim - I NPIECES-1'=$E(RREC,4) Q - ; Length requirement: don't be so strict if it's only one piece - ; We have seen this packet be 439 bytes on day, but 421 the next - ; (See ANMC devel. system 9002313.03, `249; 11/04/2000 - 421 bytes. - ; Compare with `247 from 11/03/2000 - 439 bytes) - I NPIECES>1,NPIECES-1*423+16'=$L(RREC) Q - ; Okay, we're pretty sure this is it! Insert the GS characters. - N X S X=$E(RREC,1,16) - N I F I=17:423:$L(RREC) S X=X_GS_$E(RREC,I,I+423-1) - S RREC=X - Q diff -auBN ./r1/BPSECA5.m ./r2/r/BPSECA5.m --- ./r1/BPSECA5.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECA5.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,99 +0,0 @@ -BPSECA5 ;BHAM ISC/FCS/DRS/VA/DLF - Parse Claim Response ;05/14/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;File FDATA() Array Data in Claim Response File (9002313.03) - ; - ;Parameters: RESPIEN - Claim Response Record IEN (9002313.03) - ;--------------------------------------------------------------------- - ; Called from BPSECA4 from BPSOSQL from BPSOSQ4 - ; - ; IHS/DSD/lwj 9/26/01 added one more quit condition to response - ; section. For some odd reason BC/BS if Alabama sent across - ; response code with nulls in them - this caused error at the - ; Poarch Creek site. No other sites reported the problem, but - ; the change was made and included in Patch 1 as a safe guard. - ; - ; -FILE(RESPIEN) ;EP - from BPSECA4 - I 'RESPIEN Q:$$IMPOSS^BPSOSUE("P",,,,,$T(+0)) - N MEDN,COUNT,INDEX,RJTN,RJTCOUNT,RJTCODE,NEXT,CLAIMIEN - ; - ;Clean up FDATA() array - S NEXT=0 - F D Q:'NEXT - .S NEXT=$O(FDATA(NEXT)) Q:'NEXT - .S FDATA(NEXT)=$$CLIP^BPSOSU9($G(FDATA(NEXT))) - S MEDN="" - F D Q:MEDN="" - .S MEDN=$O(FDATA("M",MEDN)) - .Q:MEDN="" - .S NEXT=0 - .F D Q:'+NEXT - ..S NEXT=$O(FDATA("M",MEDN,NEXT)) - ..Q:'+NEXT - ..S FDATA("M",MEDN,NEXT)=$$CLIP^BPSOSU9($G(FDATA("M",MEDN,NEXT))) - ; - S ^BPSR(RESPIEN,100)=U_$G(FDATA(102))_U_$G(FDATA(103)) - S $P(^BPSR(RESPIEN,500),U,1)=$G(FDATA(501)) - S $P(^BPSR(RESPIEN,500),U,24)=$G(FDATA(524)) - ; - S CLAIMIEN=$P($G(^BPSR(RESPIEN,0)),U,1) - S INDEX=$S(CLAIMIEN="":0,1:$O(^BPSC(CLAIMIEN,400,0))-1) - S:INDEX<0 INDEX=0 - S COUNT=0 - S MEDN="" - F D Q:MEDN="" - .S MEDN=$O(FDATA("M",MEDN)) - .Q:MEDN="" - .; - .S COUNT=COUNT+1 - .S INDEX=INDEX+1 - .; - .S ^BPSR(RESPIEN,1000,INDEX,0)=INDEX - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,1)=$G(FDATA("M",MEDN,501)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,3)=$G(FDATA("M",MEDN,503)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,5)=$G(FDATA("M",MEDN,505)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,6)=$G(FDATA("M",MEDN,506)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,7)=$G(FDATA("M",MEDN,507)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,8)=$G(FDATA("M",MEDN,508)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,9)=$G(FDATA("M",MEDN,509)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,10)=$G(FDATA("M",MEDN,510)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,12)=$G(FDATA("M",MEDN,512)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,13)=$G(FDATA("M",MEDN,513)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,14)=$G(FDATA("M",MEDN,514)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,17)=$G(FDATA("M",MEDN,517)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,18)=$G(FDATA("M",MEDN,518)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,19)=$G(FDATA("M",MEDN,519)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,20)=$G(FDATA("M",MEDN,520)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,21)=$G(FDATA("M",MEDN,521)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,22)=$G(FDATA("M",MEDN,522)) - .S $P(^BPSR(RESPIEN,1000,INDEX,500),U,23)=$G(FDATA("M",MEDN,523)) - .S $P(^BPSR(RESPIEN,1000,INDEX,504),U,1)=$G(FDATA("M",MEDN,504)) - .S $P(^BPSR(RESPIEN,1000,INDEX,525),U,1)=$G(FDATA("M",MEDN,525)) - .S $P(^BPSR(RESPIEN,1000,INDEX,526),U,1)=$G(FDATA("M",MEDN,526)) - .S $P(^BPSR(RESPIEN,1000,INDEX,1000),U,1)=$G(FDATA("M",MEDN,1000)) - .; - .;S "AC" cross-reference - .D:'($G(FDATA("M",MEDN,501))="") - ..S ^BPSR("AC",$G(FDATA("M",MEDN,501)),RESPIEN,INDEX)="" - .;File Reject CODEs - .S RJTN="",RJTCOUNT=0 - .F D Q:RJTN="" - ..S RJTN=$O(FDATA("M",MEDN,511,RJTN)) - ..Q:RJTN="" - ..; - ..S RJTCODE=$G(FDATA("M",MEDN,511,RJTN)) - ..Q:RJTCODE=" " - ..Q:RJTCODE="00" - ..Q:RJTCODE="" ;IHS/DSD/lwj 9/26/01 no nulls allowed - ..S RJTCOUNT=RJTCOUNT+1 - ..; - ..S ^BPSR(RESPIEN,1000,INDEX,511,RJTCOUNT,0)=RJTCODE - ..S ^BPSR(RESPIEN,1000,INDEX,511,"B",RJTCODE,RJTCOUNT)="" - .S ^BPSR(RESPIEN,1000,INDEX,511,0)="^9002313.03511A^"_RJTCOUNT_"^"_RJTCOUNT - .; - .S ^BPSR(RESPIEN,1000,"B",INDEX,INDEX)="" - ; - S ^BPSR(RESPIEN,1000,0)="^9002313.0301A^"_INDEX_"^"_COUNT - Q diff -auBN ./r1/BPSECA7.m ./r2/r/BPSECA7.m --- ./r1/BPSECA7.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECA7.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,35 +0,0 @@ -BPSECA7 ;BHAM ISC/FCS/DRS/VA/DLF - Parse Claim Response ;05/14/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Determine if the duplicate record has been paid or captured - ;Returns: 0 if Captured - ; 1 if PAID - ;---------------------------------------------------------------------- -PAID(TEXT) ;EP - from BPSCA4 - N X,CHARS - S CHARS="ABCDEFGHIJKLMNOPQR{}" - S X=$E(TEXT,1,30) - Q:'($E(X,1,5)?5N) 0 - Q:'($E(X,7,11)?5N) 0 - Q:'($E(X,13,17)?5N) 0 - Q:'($E(X,19,23)?5N) 0 - Q:'($E(X,25,29)?5N) 0 - Q:'(CHARS[$E(X,6)) 0 - Q:'(CHARS[$E(X,12)) 0 - Q:'(CHARS[$E(X,18)) 0 - Q:'(CHARS[$E(X,24)) 0 - Q:'(CHARS[$E(X,30)) 0 - Q 1 - ;---------------------------------------------------------------------- - ; This is not called from anywhere, as far as I can tell -PARSETXT(DA,DA1,TEXT) ; - S $P(^BPSR(DA,1000,DA1,500),U,1)="P" - S $P(^BPSR(DA,1000,DA1,500),U,5)=$E(TEXT,1,6) - S $P(^BPSR(DA,1000,DA1,500),U,6)=$E(TEXT,7,12) - S $P(^BPSR(DA,1000,DA1,500),U,7)=$E(TEXT,13,18) - S $P(^BPSR(DA,1000,DA1,500),U,8)=$E(TEXT,19,24) - S $P(^BPSR(DA,1000,DA1,500),U,9)=$E(TEXT,25,30) - S $P(^BPSR(DA,1000,DA1,500),U,3)=$E(TEXT,31,44) - S $P(^BPSR(DA,1000,DA1,500),U,4)=$E(TEXT,45,$L(TEXT)) - Q diff -auBN ./r1/BPSECA8.m ./r2/r/BPSECA8.m --- ./r1/BPSECA8.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECA8.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,129 +0,0 @@ -BPSECA8 ;BHAM ISC/FCS/DRS/VA/DLF - construct a claim reversal ;05/17/04 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; The way we build the claim reversal is to take the source data - ; from the original claim (IEN) and position therein (RX). - ; $$ returns pointer to 9002313.02 of the new entry. - ; - ; Future: want to use new database server calls to create the - ; 9002313.02 entry. It would be soooo much cleaner. - ; - ; Remember, you have two 401 fields - one in header, one in prescript. - ; - ;IHS/SD/lwj 08/15/02 NCPDP 5.1 changes - ; There are new fields to consider in the 5.1 reversal process, in - ; addition to a new value for the transaction code (noe B2 as opposed - ; to 11 in 3.2). - ; Changes made as needed. - ; - ;IHS/SD/lwj 10/23/02 NCPDP 5.1 changes - ; New code added to account for a mixed reversal. A mixed reversal is - ; a claim that was created in 3.x format & needs to be reversed in 5.1 - ; format. This requires field reformatting. - ; -REVERSE(IEN,RX) ;EP - from BPSOS6D, BPSOSC2 - ; IEN=original claim, RX = prescription # subscript therein - ; returns IEN of the reversal claim created - ; - ; extract needed data - I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) S VARX=1 ;LJE;08/02/03 - N CLAIM,RXMULT S CLAIM=9002313.02,RXMULT=9002313.0201 ; file #s - N DIC,DR,DA,DIQ,TMP,I,X - ; This field list is repeated below. - S DIC=CLAIM - ; - ;IHS/SD/lwj 8/15/02 NCPDP 5.1 new fields need to be used - ; nxt line remarked out, following 2 lines added - ;S DR=".01;.02;.03;1.01;1.02;1.03;101;102;103;104;201;400;401",DA=IEN - S DR=".01;.02;.03;1.01;1.02;1.03;101;102;103;104;109;110;201;202;400;401" - S DA=IEN - S DIQ="TMP",DIQ(0)="I" - ; This field list is repeated below. - ; It needs to include all the fields that are used in any reversal - ; format anywhere. - ; - ;IHS/SD/lwj 8/15/02 NCPDP 5.1 new fields need to be used - ; nxt line remarked out, following 2 lines added - ;S DR(RXMULT)=".01;401;402;418;438;439;440;441",DA(RXMULT)=RX - S DR(RXMULT)=".01;.05;308;401;402;403;407;418;420;436;438;439;440;441;455" - S DA(RXMULT)=RX - ;ZW DIC,DR,DA,DIQ - D EN^DIQ1 - ; - ;IHS/SD/lwj 10/23/02 NCPDP 5.1 changes - ; check for a mixed claim (3.x claim - 5.1 reversal)-reformat if needed - ; - D:TMP(CLAIM,IEN,102,"I")[3!($G(VARX)) CKVERS ;LJE;8/2/03 - ; - ;IHS/SD/lwj 10/23/02 end mixed claim check - ; - ;ZW TMP - ; create a new 9002313.02 record - N DIC,X,DLAYGO,REVIEN,Y,UERETVAL -R2 S DIC=9002313.02,DIC(0)="LX",X=TMP(9002313.02,IEN,.01,"I")_"R"_RX - S DLAYGO=CLAIM - D ^DIC S REVIEN=+Y I REVIEN<1 D G:UERETVAL R2 - . S UERETVAL=$$IMPOSS^BPSOSUE("FM,P",,"call to ^DIC",,,$T(+0)) - ;ZW REVIEN -R4 ; create a new prescription multiple therein - S DIC="^BPSC("_REVIEN_",400,",DIC(0)="LX" - S DIC("P")=$P(^DD(CLAIM,400,0),U,2) - S DA(1)=REVIEN,DLAYGO=RXMULT - S X=1 D ^DIC I +Y'=1 D G:UERETVAL R4 - . S UERETVAL=$$IMPOSS^BPSOSUE("FM,P",,"call to ^DIC","for multiple",,$T(+0)) - ;ZW Y - ; set data values - N DIE - S DIE=CLAIM,DA=REVIEN - S TMP(CLAIM,IEN,103,"I")=11 ; change transaction code to REVERSAL - ; - ;IHS/SD/lwj 8/15/02 NCPDP 5.1 changes - ; if the version is 5.1, the transaction code needs to be B2 not 11 - ; following line added - S:TMP(CLAIM,IEN,102,"I")[5 TMP(CLAIM,IEN,103,"I")="B2" - ; Must agree with field list above. - ;IHS/SD/lwj 8/15/02 NCPDP 5.1 new fields need to be used - ; nxt line remarked out, following 2 lines added - ; - ;S DR="" N I F I=.02,.03,1.01,1.02,1.03,101,102,103,104,201,401 D - S DR="" N I - F I=.02,.03,1.01,1.02,1.03,101,102,103,104,109,110,201,202,401 D - .S DR=DR_I_"////"_TMP(CLAIM,IEN,I,"I")_";" - S DR=DR_".04////2" ; transmit flag - it's 2 for POS - D ^DIE - S DIE="^BPSC("_REVIEN_",400," - S DA(1)=REVIEN,DA=1,DR="" - ; Must agree with field list above - ;IHS/SD/lwj 8/15/02 NCPDP 5.1 new fields need to be used - ; nxt line remarked out, following 2 lines added - ; - ;F I=401,402,418,438,439,440,441 D - F I=.05,308,401,402,403,407,418,420,436,438,439,440,441,455 D - .S DR=DR_I_"////"_TMP(RXMULT,RX,I,"I")_";" - S DR=$E(DR,1,$L(DR)-1) ; get rid of extra trailing ";" - D ^DIE - ; - Q REVIEN - ; -CKVERS ;check the version of the current format - if it's 5.1 then we've hit a - ; "mixed claim." (Originally created in 3.2 - reverse in 5.1) - ; - N BPSINS,BPSFORM,BPSVER,BPSCFRM - S (BPSINS,BPSFORM,BPSVER,BPSCFRM)="" - ; - S BPSINS=TMP(9002313.02,IEN,.02,"I") - Q:BPSINS="" - ; - I '$G(VARX) S BPSCFRM=$P($G(^BPSEI(BPSINS,100)),U) ;claim format - E S BPSCFRM=TMP(CLAIM,IEN,.02,"I") ;LJE;8/2/03 - Q:BPSCFRM="" - ; - S BPSFORM=$P($G(^BPSF(9002313.92,BPSCFRM,"REVERSAL")),U) - Q:BPSFORM="" - ; - S BPSVER=$P($G(^BPSF(9002313.92,BPSFORM,1)),U,2) - I BPSVER[5 D - . S TMP(9002313.02,IEN,102,"I")=51 - . D REFORM^BPSOSHR(BPSFORM) - ; - Q diff -auBN ./r1/BPSECA9.m ./r2/r/BPSECA9.m --- ./r1/BPSECA9.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECA9.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,129 +0,0 @@ -BPSECA9 ;BHAM ISC/FCS/DRS/VA/DLF - pretty print pharm claim packet ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; Development utility; not hooked into any option - ; DO PRINT^BPSECA9(record,format) ;format defaults based on Bin # - ; DO PRINTN^BPSECA9(IEN,JOB) for ^BPSEC(job,"C",ien,n) - ; (job defaults to $J) - Q -TESTING ;O 51:("TEMP.OUT":"W") U 51 - D PRINTN(17636,4,1) - ;C 51 - Q -PRINTN(IEN,JOB,DUMP) ; print from ^BPSEC(job,"C",ien,n) - N REC S REC="" - I $G(JOB)="" S JOB=$J - N I F I=1:1:^BPSECX(JOB,"C",IEN,0) S REC=REC_^(I) ; reconstruct - I $G(DUMP) D - .N I,J F I=1:20:$L(REC) D - ..W $J(I,4),"/ " - ..F J=0:1:19 D - ...I J=10 W " | " - ...N X S X=$E(REC,I+J) - ...I X?.ANP W "'",X," " - ...E W $J($A(X),3) - ..W ! - . - ; Find Bin number - N BIN S BIN=$E(REC,4,9) - N FMT S FMT=$$FINDFMT(BIN) - I FMT="" W "Cannot find format for Bin# ",BIN,! - D PRINT(REC,FMT) - Q -FINDFMT(BIN) ; given BIN, lookup format and return it - ; This will work, but beware cases like MedImpact, where you might - ; have multiple formats using the same bin. In the Medimpact case, - ; the only difference between the formats is the Processor Control - ; Number that is sent in the NDC packet. - ;W "FINDFMT(",BIN,")",! - N STOP - N A S A="" F S A=$O(^BPSF(9002313.92,A)) Q:A="" D Q:$G(STOP) - .N B S B=$G(^BPSF(9002313.92,A,1)),B=$P(B,U) - .I B=BIN S STOP=1 ; found it - Q A -PRINT(REC,FMT) ; FMT pointer into ^BPSF(9002313.92,ien) ; defaultable - ; REC = the assembled record - ; Caller takes care of IO device, we just write - N ECME S POS=1 ; position in record - I $E(REC,1,2)="HN" D - .N X S X=$E(REC,3) - .I X="*" W "Production mode" - .E I X="." W "Test mode" - .E W "Mode ",X," unknown?" - .W ! - .S POS=POS+3 - N TRANCODE ; transaction code - I '$D(FMT) N FMT S FMT=$$FINDFMT($E(REC,POS,POS+5)) - I '$G(FMT) W "Format unknown",! Q - N X S X=^BPSF(9002313.92,FMT,0) - W "Format: ",$P(X,U),! - N SECTION F SECTION=10,20 D PRINT1 - N TRANNUM F TRANNUM=1:1:TRANCODE F SECTION=30,40 DO PRINT1 - I $L(REC)+1'=ECME W "Mismatch; length of record = ",$L(REC) - I W "; +1 = ",$L(REC)+1," '= position ",POS,! - Q -NAME(X) I X=10 Q "Claim Header - Required" - I X=20 Q "Claim Header - Optional" - I X=30 Q "Claim Information "_$S(TRANCODE>1:"#"_TRANNUM_" of "_TRANCODE_")",1:"")_" - Required" - I X=40 Q "Claim Information - Optional" - W "X=",X,! ; invalid - D IMPOSS^BPSOSUE("P","TI",X,,"NAME",$T(+0)) - Q -PRINT1 ; printing one section - W " - - - ",$$NAME(SECTION)," - - - at position ",POS," - - -",! - I SECTION=30 D - .I $A(REC,POS)=29 S POS=POS+1 - .E W "Expected $C(29) separator was not found",! - N FIELD,ORDER S (FIELD,ORDER)="" - F D NEXT Q:FIELD="" D PRINT2 - Q -NEXT ; given SECTION and previous ORDER, - ; advance ORDER and return the ncpdp FIELD number - S ORDER=$O(^BPSF(9002313.92,FMT,SECTION,"B",ORDER)) - I ORDER="" S FIELD="" Q - N IEN S IEN=$O(^BPSF(9002313.92,FMT,SECTION,"B",ORDER,"")) - I 'IEN D IMPOSS^BPSOSUE("DB","TI",,,"NEXT",$T(+0)) - N X S X=^BPSF(9002313.92,FMT,SECTION,IEN,0) ; order^field^mode - N Y S Y=$P(X,U,2) ; ien in the field file - S FIELD=Y - Q -PRINT2 ; printing one FIELD - N Z S Z=^BPSF(9002313.91,FIELD,0) ;Number^ID^Name^Format^Length - N NUMBER S NUMBER=$P(Z,U) - N ID S ID=$P(Z,U,2) - N NAME S NAME=$P(Z,U,3) - N ANFORMAT S ANFORMAT=$P(Z,U,4) ;N,A/N,D - N LENGTH S LENGTH=$P(Z,U,5) - W NUMBER ; NCPDP field number - I ID]"" W "-",ID - E W " " - N VALUE S VALUE=$$PICKOFF - I VALUE]"" D - .W " ",$J($P(VALUE,U),3),"-",$J($P(VALUE,U,2),3),": " - .S VALUE=$P(VALUE,U,3,$L(VALUE,U)) - W " ",NAME - I VALUE]"" D - .W "=" - .I VALUE?.E1" " S VALUE=$$QUOTE(VALUE) - .W VALUE - .I VALUE?.E1C.E W " (contains control character(s)!)" - E W " not present" - I NUMBER=103 S TRANCODE=VALUE - W ! - Q -QUOTE(X) Q """"_X_"""" -PICKOFF() ;given REC and ECME within it, pick off data - ; also given: field's ID and LENGTH and ANFORMAT - ; Delimiter is $C(28) - pick it off too, but don't return it - I $A(REC,POS)=28,$E(REC,POS+1,POS+2)'=ID Q "" - I $A(REC,POS)=28,$E(REC,POS+1,POS+2)=ID S POS=POS+3 - N FIXED S FIXED=LENGTH ; is it fixed length? - N END - I FIXED S END=POS+FIXED-1 - E D - .N X F END=POS:1:POS+LENGTH-1 S X=$A(REC,END) Q:X=-1!(X=28)!(X=29) - N RET S RET=$E(REC,POS,END) ; return up to but not including delimiter - ;ZW FIXED,LENGTH,POS,END,RET - ;R ">>>",%,! - S RET=POS_U_END_U_RET - S POS=END+1 - Q RET diff -auBN ./r1/BPSECFM.m ./r2/r/BPSECFM.m --- ./r1/BPSECFM.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECFM.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,127 +0,0 @@ -BPSECFM ;BHAM ISC/FCS/DRS/VA/DLF - NCPDP Field Format Functions ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;NCPDP Field Format Functions - ; These are all $$ functions called from lots of places. - ;-------------------------------------------------------- - ; IHS/SD/lwj 8/28/02 NCPDP 5.1 changes - ; Added a new subroutine to translate the rejection code - ; Added a new subroutine to translate the reason for service code - ; Used for AdvancePCS certification process - ;-------------------------------------------------------- - ;Numeric Format Function -NFF(X,L) ;EP - - Q $E($TR($J("",L-$L(X))," ","0")_X,1,L) - ;---------------------------------------------------------------------- - ;Signed Numeric Field Format -DFF(X,L) ; - N FNUMBER,DOLLAR,CENTS,SVALUE - Q:X="" $TR($J("",L)," ","0") - S DOLLAR=+$TR($P(X,".",1),"-","") - S CENTS=$E($P(X,".",2),1,2) - S:$L(CENTS)=0 CENTS="00" - S:$L(CENTS)=1 CENTS=CENTS_"0" - S SVALUE=$S(X<0:"}JKLMNOPQR",1:"{ABCDEFGHI") - S $E(CENTS,2)=$E(SVALUE,$E(CENTS,2)+1) - Q $E($TR($J("",L-$L(DOLLAR_CENTS))," ","0")_DOLLAR_CENTS,1,L) - ;---------------------------------------------------------------------- - ;Converts Signed Numeric Field to Decimal Value -DFF2EXT(X) ;EP - - N LCHAR - S LCHAR=$E(X,$L(X)) - S X=$TR(X,"{ABCDEFGHI","0123456789") - S X=$TR(X,"}JKLMNOPQR","0123456789") - S X=X*.01 - I "}JKLMNOPQR"[LCHAR S X=X*-1 - Q $J(+X,$L(+X),2) - ;---------------------------------------------------------------------- - ;Alpha-Numeric Field Format -ANFF(X,L) ;EP - Q $E(X_$J("",L-$L(X)),1,L) - ;---------------------------------------------------------------------- - ;Numerics Field Format - ; DUPLICATE TAGS! commented out this one - ; The other one appears to zero fill. - ; NFF(X,L) - ; Q $E(X_$J("",L-$L(X)),1,L) - ;---------------------------------------------------------------------- - ;Convert FileManager date into CCYYMMDD format -DTF1(X) ;EP - - N Y,%DT - Q:X'["." X - S X=$P(X,".",1) - Q:X="" "00000000" - S Y=X D DD^%DT - S X=Y,%DT="X" D ^%DT - Q:Y=-1 "00000000" - S X=Y+17000000 - Q X - ;---------------------------------------------------------------------- - ;Reformats NDC number -NDCF(X) ;EP - - I X?11N Q X ; no reformatting needed - I X?9N S X="00"_X S:X'["-" X=$E(X,1,5)_"-"_$E(X,6,9)_"-"_$E(X,10,11) ;LJE;VA;put in 5-4-2 format - I X?12N S X=$E(X,2,12),X=$E(X,1,5)_"-"_$E(X,6,9)_"-"_$E(X,10,11) ;LJE - I $L(X)<11 F I=1:1:(11-$L(X)) S X="0"_X - I $L($TR(X,"-"))>11 S X=$E(X,2,20) - N Y,I - F I=1:1:3 S Y(I)=$P(X,"-",I) - S X=$$RJZF(Y(1),5)_$$RJZF(Y(2),4)_$$RJZF(Y(3),2) - Q X - ;---------------------------------------------------------------------- - ;Right justify and zero fill X in a string of length L -RJZF(X,L) ; - I $L(X)@TMP@(...) - ;------------------------ - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 changes - ; added the NCPDP field to decipher the version - this will help - ; in the data translation - ;------------------------- - N SRC S SRC="^UTILITY(""DIQ1"",$J)" - N EFORMAT,INSURER,FILE,DA,FIELD - N NCPDP51 ;IHS/SD/lwj 10/08/02 NCPDP 5.1 change - S NCPDP51=0 ;IHS/SD/lwj 10/08/02 NCPDP 5.1 change - S DA=$O(@SRC@(9002313.02,0)) - S INSURER=$G(@SRC@(9002313.02,DA,.02,"I")) - ;CHECK SITE TYPE 0 IS VA, 1 IS IHS, SET INSURER ACCORDINGLY DLF 7/29/2003 - ; - I ^BPS(9002313.99,1,"SITE TYPE")=0,INSURER S EFORMAT=INSURER - I ^BPS(9002313.99,1,"SITE TYPE")=1,INSURER S EFORMAT=$P($G(^BPSEI(INSURER,100)),U) - E S EFORMAT=0 - I 'EFORMAT W "Internal error - no FORMAT for INSURER=",INSURER,! Q - ; - S:$G(@SRC@(9002313.02,DA,102,"I"))=51 NCPDP51=1 - ; - ;ZW EFORMAT - S FILE="" F S FILE=$O(@SRC@(FILE)) Q:'FILE D - .S DA="" F S DA=$O(@SRC@(FILE,DA)) Q:'DA D - ..N FIELD S FIELD="" F S FIELD=$O(@SRC@(FILE,DA,FIELD)) Q:'FIELD D - ...I EFORMAT,'$$INCLUDE(EFORMAT,FILE,FIELD) D Q - ....;W "FORMAT+n^",$T(+0)," excludes EFORMAT=",EFORMAT,", FIELD=",FIELD,! - ...D FMTFIELD - Q -INCLUDE(EFORMAT,FILE,FIELD) ; is the field part of this protocol? - ; returns 1 or 10 or 20 or 30 or 40 maybe with ^ID appended - ;-------------------------------- - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 changes - need to include all - ; the new segments - ; - ;-------------------------------- - ; - N START,END - S START=10,END=40 - I NCPDP51 S START=100,END=230 - ; - I FILE=9002313.03 Q 1 ; always yes for response fields - I FILE=9002313.0301 Q 1 ; always yes for response fields - I FIELD<101!(FIELD>600) Q 1 ; yes for fields outside protocol range - N FIELDIEN S FIELDIEN=$O(^BPSF(9002313.91,"B",FIELD,0)) - I FIELDIEN="" Q 0 ; should never happen? - ; - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 nxt line remarked out, following added - ;N I,FIND S FIND=0 F I=10,20,30,40 D Q:$G(FIND) - N I,FIND S FIND=0 F I=START:10:END D Q:$G(FIND) - .N J S J=0 - .F S J=$O(^BPSF(9002313.92,EFORMAT,I,J)) Q:'J D Q:$G(FIND) - ..I $P(^BPSF(9002313.92,EFORMAT,I,J,0),U,2)=FIELDIEN D - ...S FIND=I - ...S FIND=FIND_U_$$FIELDID(FIELD) - Q FIND -FIELDID(FIELD) ; the two character field ID, given the external field # - ;-------------------------------------- - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 changes - ; With 5.1 all the fields will have a field identifier, except for the - ; header segment. Must adjust this routine to account for that. - ; (NCPDP51 is defined in the FORMAT subroutine and is based on fld 102) - ; - ;-------------------------------------- - N ID - N FIELDIEN S FIELDIEN=$O(^BPSF(9002313.91,"B",FIELD,0)) - I FIELDIEN="" Q "" - ; - S:'NCPDP51 ID=$P(^BPSF(9002313.91,FIELDIEN,0),U,2) - S:NCPDP51 ID=$P($G(^BPSF(9002313.91,FIELDIEN,5)),U) - ; - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 nxt line remarked out - following added - ;Q $P(^BPSF(9002313.91,FIELDIEN,0),U,2) - Q ID - ; -ISVARFLD(EFORMAT,FILE,FIELD) ; is it a variable length field? - ;--------------------------------- - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 changes - ; if we are working with a 5.1 format, and it's any segment other - ; than 100, return the field id. - ;--------------------------------- - ; returns 2-char field ID if it is - N X S X=$$INCLUDE(EFORMAT,FILE,FIELD) - Q:(NCPDP51)&(X>100) $P(X,U,2) ;IHS/SD/lwj 10/08/02 NCPDP 5.1 - I +X=20!(+X=40) Q $P(X,U,2) - E Q "" -FMTFIELD ; given FILE,DA,FIELD,@SRC@(FILE,DA,FIELD,"E" and "I"), set @TMP - ; given INSURER and EFORMAT, too - ; Fetch the INT and EXT values - ;----------------------------------------- - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 changes - ; needed to format a couple of the newer field a little different - ;----------------------------------------- - ; - N INT S INT=$G(@SRC@(FILE,DA,FIELD,"I")) - N EXT S EXT=$G(@SRC@(FILE,DA,FIELD,"E")) - ; If it's a variable field, remove the field ID - N VARFIELD - ; - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 fields need more formatting - N CKFLD,FLDLST - S FLDLST=",409,448,449,477,480,481,482,483,487,558,562,566," - ; - I FIELD=524 S VARFIELD="FO" ; have to hardcode response cases - E S VARFIELD=$$ISVARFLD(EFORMAT,FILE,FIELD) - I VARFIELD]"" D - .I $E(INT,1,2)=VARFIELD S INT=$E(INT,3,$L(INT)) - .I $E(EXT,1,2)=VARFIELD S EXT=$E(EXT,3,$L(EXT)) - ;I FIELD=422 ZW VARFIELD,EFORMAT,FILE,FIELD,INT,EXT - ; Trailing spaces, leading zeroes - F Q:$E(EXT,$L(EXT))'=" " S EXT=$E(EXT,1,$L(EXT)-1) - I FIELD'=407,FIELD'=302 D - .F Q:$E(EXT)'=0 Q:$L(EXT)=1 S EXT=$E(EXT,2,$L(EXT)) - I FIELD=426!(FIELD=430) D ; for some reason they're missed - .S EXT="$"_$J($$DFF2EXT^BPSECFM(EXT),7,2) - ; - ;IHS/SD/lWJ 10/08/02 NCPDP 5.1 some more signed fields - S CKFLD=","_FIELD_"," - S:FLDLST[CKFLD EXT="$"_$J($$DFF2EXT^BPSECFM(EXT),7,2) - ; - I FIELD=103 S EXT=$$TCODE^BPSECP2(EXT) - ; Get the field name - N FLDNAME S FLDNAME=$P(^DD(FILE,FIELD,0),U) - ; If it's a date field that didn't get formatted, format it - I FLDNAME["Date",EXT?8N D - .N Y S Y=EXT-17000000 X ^DD("DD") S EXT=Y - ; Other enumerated fields - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 field now include "Patient" - I FLDNAME="Patient Relationship Code" D - .S EXT=$S(EXT=1:"Cardholder",EXT=2:"Spouse",EXT=3:"Child",EXT=4:"Other Dependent",1:EXT) - I FLDNAME="Compound Code" D - .S EXT=$S(EXT=1:"Not a compound",EXT=2:"Compound",1:EXT) - I FLDNAME="Dispense As Written" S EXT=$$DAW^BPSECP2(EXT) - I FLDNAME="Basis of Reimb Determination" S EXT=$$REIMB^BPSECP2(EXT) - ; Store it - I EXT="",'$$INCLUDE(EFORMAT,FILE,FIELD) Q - I FILE=9002313.02 D - .S @DEST@("C",FLDNAME)=EXT - E I FILE=9002313.0201 D - .S @DEST@("C",FLDNAME,"RX",DA)=EXT - E I FILE=9002313.03 D - .S @DEST@("R",FLDNAME)=EXT - E I FILE=9002313.0301 D - .I FLDNAME="Additional Message Information" S FLDNAME="Message (more)" - .S @DEST@("R",FLDNAME,"RX",DA)=EXT - E D IMPOSS^BPSOSUE("P","TI",,,"FMTFIELD",$T(+0)) - Q -FM1 N DIC,DR,DA,DIQ,SUBFILE - I '$D(FIELDS) S FIELDS=".01:99999999" - I '$D(RX) - I '$D(RXFIELDS) S RXFIELDS=".01:99999999" - ; Safety - make sure if DEST is global, it's probably a scratch global - I DEST?1"^".E I DEST'?1"^TMP("1E.E,DEST'?1"^UTILITY("1E.E D IMPOSS^BPSOSUE("P","TI","Bad DEST",DEST,"FM1",$T(+0)) - D FETCH ; gives ^UTILITY("DIQ1",$J,file,DA,field,"E") and ^("I") - Q -FETCH ; - I '$D(RX) N RX S RX=0 D Q - .; RX not yet determined: recurse - .N GLO S GLO="^BPS"_$S(FILE=9002313.02:"C",FILE=9002313.03:"R") - .N SUB S SUB=$S(FILE=9002313.02:400,FILE=9002313.03:1000) - .F S RX=$O(@GLO@(FILE,IEN,SUB,RX)) Q:'RX D - ..D 2 -2 ; with RX determined - I FILE=9002313.03 D ; Reject Code(s) done manually - .N X S X=0 F S X=$O(^BPSR(IEN,1000,RX,511,X)) Q:'X D - ..;ZW X W ^(X,0),! - ..N Y S Y=^BPSR(IEN,1000,RX,511,X,0),Y=$P(Y,U) - ..N Z S Z=$O(^BPSF(9002313.93,"B",Y,0)) - ..;W Y," -> ",Z,! - ..I Z,$D(^BPSF(9002313.93,Z,0)) S Z=$P(^(0),U,2) - ..S @DEST@("R","Reject Code","RX",RX,$S(Y?1"0"1N:+Y,1:Y))=Y_" "_Z - ..;ZW @DEST@("R","Reject Code","RX") R ">>",%,! - S DIC=FILE,DA=IEN,DR=FIELDS,DIQ(0)="IEN" - S SUBFILE=FILE+.0001 ; as it happens to work out - S DA(SUBFILE)=RX - S DR(SUBFILE)=RXFIELDS - D EN^DIQ1 - Q diff -auBN ./r1/BPSECP2.m ./r2/r/BPSECP2.m --- ./r1/BPSECP2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECP2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,72 +0,0 @@ -BPSECP2 ;BHAM ISC/FCS/DRS - NO DESCRIPTION PROVIDED ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ;--------------------------------- - ;IHS/SD/lwj 10/09/02 NCPDP 5.1 changes - ; Needed to adjust the translation of the transaction code - ; to account for 5.1 values. - ; - ;--------------------------------- - ; - Q - ; Lots of $$functions called from other BPSECP* - ; BPSOS6G calls $$DUR - ; -DUR(X) ;EP - DUR code - I X="DA" Q "Drug-Allergy Alert" - I X="DC" Q "Drug-Disease Conflicts" - I X="DD" Q "Drug-Drug Interactions" - I X="ER" Q "Excessive Utilization" - I X="HD" Q "Excessive Drug Doses (Over Utilization)" - I X="ID" Q "Therapeutic Duplication (Same Ingredients)" - I X="LD" Q "Insufficient Drug Doses (Under Utilization)" - I X="LR" Q "Underuse Precaution (Non-compliance)" - I X="MC" Q "Drug Disease Alert (Drug/diagnosis matching)" - I X="MX" Q "Excessive Duration Alert" - I X="PA" Q "Drug-Age Conflicts" - I X="PG" Q "Drug-Pregnancy Conflicts" - I X="SX" Q "Drug-Gender Alert" - I X="TD" Q "Therapeutic Duplications (Same Drug Class)" -DUR8 I X[" " S X=$P(X," ")_""_$P(X," ",2,$L(X)) G DUR8 - Q "DUR code "_X_" ? " -OTHPHARM(X) ;EP - Other Pharmacy Indicator (within DUR data) - I X=1 Q "Same Pharmacy" - I X=2 Q "Different Pharmacy Same Chain" - I X=3 Q "Different Pharmacy Different Chain" - Q X -OTHPRESC(X) ;EP - Other Prescriber (within DUR data) - I X=1 Q "Same Physician" - I X=2 Q "Different Physician" - Q X -TCODE(X) ;EP - Transaction code - ;----------------------------------------- - ;IHS/SD/lwj 10/08/02 NCPDP 5.1 changes - ; For 5.1 the transaction code will be either B1 or B2 - ;----------------------------------------- - I X'<1,X'>4 Q X_" prescription claim"_$S(X>1:"s",1:"") - I (X=11)!(X="B2") Q "Claim Reversal" ;IHS/SD/lwj 10/09/02 - I X="B1" Q X_" prescription claim" ;IHS/SD/lwj 10/09/02 - Q "Unknown transaction code "_X -REIMB(X) ;EP - Basis of reimbursement - I +X=0 Q "Not specified" - I +X=1 Q "Ingredient cost paid as submitted" - I +X=2 Q "Ingredient cost reduced to AWP pricing" - I +X=3 Q "Ingredient cost reduced to AWP less %" - I +X=4 Q "Usual and Customary paid as submitted" - I +X=5 Q "Paid lower of ingredient cost plus fees versus usual and customary" - I +X=6 Q "MAC Pricing - Ingredient cost paid at MAC price" - I +X=7 Q "MAC Pricing - Ingredient cost reduced to MAC pricing" - I +X=8 Q "Contract Pricing" - Q X -DAW(X) ;EP - - I X=0 Q "No product selection indicated." - I X=1 Q "Substitution not allowed by prescriber." - I X=2 Q "Substitution allowed - patient requested product dispensed." - I X=3 Q "Substitution allowed - pharmacist selected product dispensed." - I X=4 Q "Substitution allowed - generic not in stock." - I X=5 Q "Substitution allowed - brand dispensed as generic." - I X=6 Q "Override" - I X=7 Q "Substitution not allowed - brand drug mandated by law." - I X=8 Q "Substitution allowed - generic drug not available in marketplace." - I X=9 Q "Unspecified" - Q X diff -auBN ./r1/BPSECP3.m ./r2/r/BPSECP3.m --- ./r1/BPSECP3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECP3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,265 +0,0 @@ -BPSECP3 ;BHAM ISC/FCS/DRS/VA/DLF - Receipts ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ;----------------------------------------------------------------- - ;IHS/SD/lwj 9/19/02 NCPDP 5.1 changes - ; There were many, many changes with the coming of NCPDP 5.1. One - ; is that 42% of the existing claim fields, and 50% of the existing - ; result fields changed field type, value types, and field names. - ; The changes in field names cause this program a little grief - ; so adjustments were made accordingly. - ; - ; - ;----------------------------------------------------------------- - ; - Q - ; TMP("C",field)=value for claim header - ; TMP("C",field,"RX",n)=values for claim medication - ; TMP("R",field)=values for claim response - ; TMP("R",field,"RX",n)=values for medication responses - Q - ; - ; * BEGIN * for file 9002313.99, Field RECEIPT STYLE -RECEIPT ;EP - from BPSECP0, RECEIPT^BPSOS6E - N SRC S SRC="TMP" - D FULL() Q -FULL0 ;EP - from BPSECP0 - W " - RECEIPT -",! - D PRINT("TMP","PCS1") Q -ANMC ; - ; Write any kind of page header here - D PRINT("TMP","ANMC1") - Q - ; * END * of receipt styles - ; -TEST ;O 51:("TMP.OUT":"W") U 51 S SRC="TMP" D FULL() C 51 Q -FULL(DIV,LEV,RX) ; print it all - ; WHAT YOU'RE LOOKING FOR PROBABLY IS NOT HERE - ; LOOK BELOW, AT "PRINTSEG" INSTEAD!!!!!!!!!!! - ; recurse, filling in parameters - I '$D(DIV) D FULL("C"),FULL("R") Q - I '$D(LEV) D D FULL(DIV,0) Q ; header, then prescription come at end - .W " = = = = = ",$S(DIV="C":"CLAIM",DIV="R":"RESPONSE")," = = = = =",! - ; - ;IHS/SD/lwj 9/19/02 NCPDP 5.1 Prescription Number is now called - ; Prescription/Service Ref Num - within the do loop one line - ; was commented out and the next 2 lines were added to adjust for chg. - ; - I $G(LEV)=1,'$D(RX) D Q - .;S RX=0 F S RX=$O(@SRC@("C","Prescription Number","RX",RX)) Q:'RX D - .S RX=0 - .F S RX=$O(@SRC@("C","Prescription/Service Ref Num","RX",RX)) Q:'RX D - ..;W " * TMP * Prescription Number ",RX," * TMP * ",! - ..D FULL(DIV,LEV,RX) - I '$D(IOM) N IOM S IOM=80 - N FIELD,TITLE,VALUE - S FIELD="" F S FIELD=$O(@SRC@(DIV,FIELD)) Q:FIELD="" D - .;W "LEV=",LEV,",FIELD=",FIELD,! - .I LEV=0,$D(@SRC@(DIV,FIELD))>9 Q ; header skips prescription fields - .I LEV=1,$D(@SRC@(DIV,FIELD))<9 Q ; prescription skips header fields - .; Specialized titles are done here - .I 0 - .E S TITLE=FIELD_": " - .N OUTPUT - .I LEV=0 S VALUE=@SRC@(DIV,FIELD),OUTPUT=1 - .;I LEV=1 ZW DIV,FIELD,RX R ">>",%,! - .I LEV=1 D - ..I FIELD="Reject Code" D S OUTPUT=0 Q - ...N X,I S X="" F I=0:1 S X=$O(@SRC@(DIV,FIELD,"RX",RX,X)) Q:X="" D - ....S VALUE=@SRC@(DIV,FIELD,"RX",RX,X) - ....S TITLE="Reject code: " - ....D OUTPUT - ..I FIELD="NDC Number" D S OUTPUT=0 Q - ...S VALUE=$$FORMTNDC^BPSOS9($TR(@SRC@(DIV,FIELD,"RX",RX),"-","")) - ...D OUTPUT - ..I FIELD="DUR Response Data" D S OUTPUT=0 Q - ...N X S X=@SRC@(DIV,FIELD,"RX",RX) - ...S VALUE="" D OUTPUT ; "DUR Response Data:" - ...N FIELD - ...D DUROUT(X) - ..S VALUE=@SRC@(DIV,FIELD,"RX",RX),OUTPUT=1 - .I OUTPUT D OUTPUT - I LEV=0 W " - - Prescription - -",! D FULL(DIV,1) - Q -OUTPUT ; TITLE,VALUE,! - W TITLE - N X S X=VALUE - N Y S Y=IOM-$X-1 W $E(X,1,Y) S X=$E(X,Y+1,$L(X)) - F W ! Q:X="" W $E(X,1,IOM) S X=$E(X,IOM+1,$L(X)) - Q -DUROUT(X) ; output of DUR string - N I,L,Y S L=53 F I=0:1:2 D - .N Y S Y=$E(X,I*L+1,I*L+L) - .I Y?." " Q ; blank section - .I $E(Y,1,2)=" 0" Q ; PCS test has this - .I $E(Y,1,2)=" " Q ; PCS test has this - .I $E(Y,1,2)="0 " Q ; PCS test has this (?) - .I I W " - - - DUR response data, part ",I+1," - - -",! - .D DUROUT1(Y) - Q -DUROUT1(X) ; output of one substring of DUR string - N Y - S TITLE=" Drug Conflict Code: ",VALUE=$$DUR^BPSECP2($E(X,1,2)) - D OUTPUT - S TITLE=" Severity Index Code: ",VALUE=$E(X,3) D OUTPUT - S TITLE=" Other Pharmacy Indicator: " - S VALUE=$$OTHPHARM^BPSECP2($E(X,4)) D OUTPUT - S TITLE=" Previous Date of Fill: ",VALUE=$E(X,5,12) - I VALUE?8N,VALUE>19900000 S Y=VALUE-17000000 X ^DD("DD") S VALUE=Y - D OUTPUT - S TITLE=" Qty. of Previous Fill: ",VALUE=+$E(X,13,17) D OUTPUT - S TITLE=" Database Indicator: ",VALUE=$E(X,18) D OUTPUT - S TITLE=" Other Prescriber Indicator: " - S VALUE=$$OTHPRESC^BPSECP2($E(X,19)) D OUTPUT - S TITLE=" Message: ",VALUE=$E(X,20,49) D OUTPUT - ; bytes 50-53 reserved - Q -PRINT(SRC,FORMAT) ; - D PRINTSEG("C0"_FORMAT) - D PRINTSEG("R0"_FORMAT) - N RX S RX=0 - F S RX=$O(@SRC@("C","Prescription Number","RX",RX)) Q:'RX D - .D PRINTSEG("C1"_FORMAT) - .D PRINTSEG("R1"_FORMAT) - Q -PRINTSEG(SEG) ; - N DIV S DIV=$E(SEG) - N LINE,STOP F LINE=0:1 D Q:$G(STOP) - .N X S X=$T(@SEG+LINE) I X'[";;" D IMPOSS^BPSOSUE("P","TI",SEG,,"PRINTSEG",$T(+0)) ; internal error ; missing "*" - .N FIELD S FIELD=$P(X,";",3) - .I FIELD="*" S STOP=1 Q - .F Q:$E(FIELD)'=" " S FIELD=$E(FIELD,2,$L(FIELD)) ; leading sp okay - .Q:FIELD="" ; empty entry is okay - .I FIELD="Reject Code" D Q - . .N X,I S X="" F I=0:1 S X=$O(@SRC@(DIV,FIELD,"RX",RX,X)) Q:X="" D - . . .S VALUE=@SRC@(DIV,FIELD,"RX",RX,X) - . . .S TITLE=FIELD_":" - . . .D OUTPUT - .I FIELD="DUR Response Data" D Q - . .S X=$G(@SRC@(DIV,FIELD,"RX",RX)) - . .S TITLE=FIELD_":",VALUE="" - . .I X="" S TITLE="No "_FIELD D OUTPUT Q - . .S VALUE="" D OUTPUT ; "DUR Response Data" - . .N FIELD D DUROUT(X) - .N VALUE D GETVALUE - .N TITLE S TITLE=$P(X,";",4) - .;ZW TITLE R ">>",%,! ZW VALUE R ">>",%,! - .I TITLE="" S TITLE=FIELD_": " - .E X TITLE - .;ZW TITLE R ">>",%,! - .I FORMAT'="PCS",VALUE=""!(VALUE?." ") Q - .D OUTPUT - Q -GETVALUE ; given SEG,FIELD,RX - I $E(SEG,2)=0 D ; a header field - .S VALUE=$G(@SRC@($E(SEG),FIELD)) - E I $E(SEG,2)=1 D ; a prescription field - .S VALUE=$G(@SRC@($E(SEG),FIELD,"RX",RX)) - E D IMPOSS^BPSOSUE("P","TI",SEG,,"GETVALUE",$T(+0)) ; internal error - Q - ; Piece 3 - field name - ; Piece 4 - execute to set TITLE=something based on FIELD and VALUE - ;Cn is for the claim, Rn is for the response - ;x0 is for the header, x1 is for the prescription - ;xxPCS1 is for the receipt for the PCS certification testing - ;xxANMC1 is for the ANMC receipt -C0ANMC1 ;;Patient Name;S TITLE="" - ;;Cardholder ID Number - ;;Electronic Payor - ;;Claim ID - ;;* - ;; -C0PCS1 ;;Patient Name;S TITLE="" - ;;Group Number - ;;Cardholder ID Number - ;;Electronic Payor - ;;Pharmacy Number - ;;Claim ID - ;;Transaction Code - ;;* -C1ANMC1 ;;Medication Name;S TITLE="" - ;;Metric Quantity;S TITLE="Quantity: " - ;;NDC Number - ;;Date Filled - ;;Prescription Number - ;;Transmitted On;S TITLE="Claim sent " - ;;* -C1PCS1 ;;Medication Name;S TITLE="" - ;;Date Filled - ;;Metric Quantity - ;;Prescription Number - ;;NDC Number - ;;DUR Response Data - ;;Reject Code - ;;* -R0ANMC1 ;; - ;;* -R0PCS1 ;; - ;;* -R1ANMC1 ;;Response Status (Prescription);S TITLE="Prescription Status:" - ;;Authorization Number - ;;DUR Response Data - ;;Reject Code - ;;Message - ;;Message (more) - ;;* -R1PCS1 ;; - ;;Response Status (Prescription);S TITLE="" - ;;Authorization Number - ;;Patient Pay Amount;S TITLE=$J(FIELD,21) - ;;Ingredient Cost Paid;S TITLE=$J(FIELD,21) - ;;Contract Fee Paid;S TITLE=$J(FIELD,21) - ;;Sales Tax Paid;S TITLE=$J(FIELD,21) - ;;Total Amount Paid;S TITLE=$J(FIELD,21) - ;;* -C0ALL ;;Claim ID - ;;Electronic Payor - ;;Billing Item IEN - ;;Transmit Flag - ;;Transmitted On - ;;Created On - ;;Patient Name - ;;Billing Item PCN # - ;;Billing Item VCN # - ;;BIN Number - ;;Version/Release Number - ;;Transaction Code - ;;Processor Control Number - ;;Pharmacy Number - ;;Group Number - ;;Cardholder ID Number - ;;Person Code - ;;Date of Birth - ;;Sex Code - ;;Relationship Code - ;;Customer Location - ;;Other Coverage Code - ;;Eligibility Clarification Code - ;;Patient First Name - ;;Patient Last Name - ;;* -C1ALL ;;Date Filled - ;;Prescription Number - ;;New/Refill Code - ;;Metric Quantity - ;;Days Supply - ;;Compound Code - ;;NDC Number - ;;Dispense As Written - ;;Ingredient Cost - ;;Sales Tax - ;;Prescriber ID - ;;Dispensing Fee Submitted - ;;Date Prescription Written - ;;Number Refills Authorized - ;;PA/MC Code & Number - ;;Level of Service - ;;Prescription Origin Code - ;;Prescription Clarification - ;;Primary Prescriber - ;;Clinic ID N - ;;* -R0ALL ;; - ;;* -R1ALL ;; - ;;* diff -auBN ./r1/BPSECR0.m ./r2/r/BPSECR0.m --- ./r1/BPSECR0.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECR0.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,75 +0,0 @@ -BPSECR0 ;BHAM ISC/FCS/DRS/VA/DLF - NCPDP FIELD Definitions Print-Out ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ; Development utility: - ;NCPDP FIELD Definitions Print-Out - ;---------------------------------------------------------------------- -EN ; - N FIELD,GCODE,GETN,NEXTIEN,NEXTCODE,RDATA - D ^%ZIS - U IO - W "NCPDP FIELD Definitions:",! - W $TR($J("",IOM)," ","-"),! - S NEXTIEN=0,NEXTCODE="" - F D Q:NEXTCODE="" - .S NEXTCODE=$O(^BPSF(9002313.91,"B",NEXTCODE)) Q:NEXTCODE="" - .S NEXTIEN=$O(^BPSF(9002313.91,"B",NEXTCODE,0)) - .Q:'+NEXTIEN - .S RDATA=$G(^BPSF(9002313.91,NEXTIEN,0)) - .Q:RDATA="" - .S FIELD=$P(RDATA,U,1) - .W !,$J(FIELD,3) - .I $P(RDATA,U,2)]"" W "-",$P(RDATA,U,2) - .W ?15,$P(RDATA,U,3) - .W " Length: ",$P(RDATA,U,5) - .W ! - .; - .; "Get" code - .; - .W ?6,"Get:" - .S GETN=0 - .F D Q:'+GETN - ..S GETN=$O(^BPSF(9002313.91,NEXTIEN,10,GETN)) - ..Q:'+GETN - ..S GCODE=$G(^BPSF(9002313.91,NEXTIEN,10,GETN,0)) - ..D PRINT - .; - .; "Format" code - .; - .W ?3,"Format:" - .S GETN=0 - .F D Q:'+GETN - ..S GETN=$O(^BPSF(9002313.91,NEXTIEN,20,GETN)) - ..Q:'+GETN - ..S GCODE=$G(^BPSF(9002313.91,NEXTIEN,20,GETN,0)) - ..D PRINT - .; - .; "Set" code - .; - .W ?6,"Set:" - .S GETN=0 - .F D Q:'+GETN - ..S GETN=$O(^BPSF(9002313.91,NEXTIEN,30,GETN)) - ..Q:'+GETN - ..S GCODE=$G(^BPSF(9002313.91,NEXTIEN,30,GETN,0)) - ..;W ?10,"S",GETN,": ",GCODE,! - ..D PRINT - W !!,"Index",!! - N X S X="" - F S X=$O(^BPSF(9002313.91,"C",X)) Q:X="" D - . N Y S Y=$O(^BPSF(9002313.91,"C",X,0)) - . S Y=$P(^BPSF(9002313.91,Y,0),U) - . W X," ",Y,! - D ^%ZISC - ;U $P - Q -PRINT ; - I '$G(IOM)<40 N IOM S IOM=80 - N C S C=IOM-11-2 - W ?11,$E(GCODE,1,C),! - I $L(GCODE)>C N I F I=1:1:$L(GCODE)\C D - . W ?7,"..." - . W ?11,$E(GCODE,C*I+1,C*I+C) - . W ! - Q diff -auBN ./r1/BPSECR1.m ./r2/r/BPSECR1.m --- ./r1/BPSECR1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECR1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,78 +0,0 @@ -BPSECR1 ;BHAM ISC/FCS/DRS/VA/DLF - NCPDP Record Print-Out ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;NCPDP Record Print-Out - ; EN to print all formats - ; R2^BPSECR1(ien) to print just one format - ;---------------------------------------------------------------------- -EN N POP,NEXTIEN - D ^%ZIS Q:$G(POP) - U IO - S NEXTIEN=0 - F D Q:'+NEXTIEN - .S NEXTIEN=$O(^BPSF(9002313.92,NEXTIEN)) - .Q:'+NEXTIEN - .D R2(NEXTIEN) - D ^%ZISC - Q - ;--------------------------------------------------------------------- -R2(IEN) ; - D R2^BPSECR2(IEN) - Q - ; the rest of this was pretty much duplicated in BPSECR2 - ; we enhanced what was there, too. - ; so what follows is obsolete and can be deleted - N FD,FIEN,GCODE,GN,MD,MIEN,NODE,O,RD,XFLAG - Q:IEN="" - Q:$D(^BPSF(9002313.92,IEN,0))=0 - D R2HEADER(IEN) - F NODE=10,20,30,40 D - .W ! - .I NODE=10 W "Claim Header (Required) Record:",!! - .I NODE=20 W "Claim Header (Optional) Record:",!! - .I NODE=30 W "Claim Information (Required) Record:",!! - .I NODE=40 W "Claim Information (Optional) Record:",!! - .S O=0 - .F D Q:'+O - ..S O=$O(^BPSF(9002313.92,IEN,NODE,"B",O)) - ..Q:'+O - ..S MIEN=$O(^BPSF(9002313.92,IEN,NODE,"B",O,"")) - ..Q:'+MIEN - ..S MD=$G(^BPSF(9002313.92,IEN,NODE,MIEN,0)) - ..S FIEN=$P(MD,U,2) - ..Q:'+FIEN - ..S FD=$G(^BPSF(9002313.91,FIEN,0)) - ..S:$P(MD,U,3)="X" XFLAG(NODE,MIEN)=FIEN - ..W $J(O,3)," ",$J($P(FD,U,1),3)," ",$P(MD,U,3)," ",$P(FD,U,3),! - H 1 - W @IOF - D:$D(XFLAG) - .D R2HEADER(IEN) - .F NODE=10,20,30,40 D - ..Q:'$D(XFLAG(NODE)) - ..W ! - ..S MIEN="" - ..F D Q:'+MIEN - ...S MIEN=$O(XFLAG(NODE,MIEN)) - ...Q:'+MIEN - ...S FIEN=$G(XFLAG(NODE,MIEN)) - ...Q:FIEN="" - ...S RD=$G(^BPSF(9002313.91,FIEN,0)) - ...Q:RD="" - ...W !,$J($P(RD,U,1),3),?10,$P(RD,U,3),! - ...S GN=0 - ...F D Q:'+GN - ....S GN=$O(^BPSF(9002313.92,IEN,NODE,MIEN,1,GN)) - ....Q:'+GN - ....S GCODE=$G(^BPSF(9002313.92,IEN,NODE,MIEN,1,GN,0)) - ....W ?10,"X",GN,": ",GCODE,! - .H 1 - .W @IOF - Q - ;---------------------------------------------------------------------- -R2HEADER(IEN) ; - W "NCPDP Record Definition" - W $$RJBF^BPSECFM($P($G(^BPSF(9002313.92,IEN,0)),U,1),IOM-23),! - W $TR($J("",IOM)," ","-"),! - Q diff -auBN ./r1/BPSECR2.m ./r2/r/BPSECR2.m --- ./r1/BPSECR2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECR2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,127 +0,0 @@ -BPSECR2 ;BHAM ISC/FCS/DRS/VA/DLF - NCPDP Record Print-Out ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;NCPDP Record Print-Out - ; Why this and not BPSECR1? Don't know. - ; Just carrying it along for now. - ;---------------------------------------------------------------------- -EN1 ; - ;Open 10:(MODE="W":FILE="A:NCPDP-R.TXT") - ;Use 10 - ;S NEXTIEN=0 - ;F D Q:'+NEXTIEN - ;.S NEXTIEN=$ORDER(^BPSF(9002313.92,NEXTIEN)) - ;.Q:'+NEXTIEN - ;.D R2(NEXTIEN) - S NEXTIEN=8 - D R2(NEXTIEN) - ;Close 10 - Q - ;---------------------------------------------------------------------- -EN2(NEXTIEN) ; - ;Open 10:(MODE="W":FILE="A:NCPDP-R.TXT") - ;Use 10 - D R2(NEXTIEN) - ;Close 10 - Q - ;--------------------------------------------------------------------- -R2(IEN) ;EP - - N FDATA,FIEN,GCODE,GN,MDATA,MIEN,NODE,ORDER,RDATA,XFLAG - N POSITION,LENGTH,GSECME S POSITION=1 - N IENS S IENS=IEN_"," - I '$G(IOM) N IOM S IOM=80 - D R2HEADER(IEN) - ;F NODE=10,20,30,40 D ;LJE; THEIRS - S NODE=1 F S NODE=$O(^BPSF(9002313.92,IEN,NODE)) Q:NODE="" D ;LJE; MINE - .;S NODE=56 D ;LJE;MINE - .W ! - .I NODE=10 W "Claim Header (Required) Record:",!! - .I NODE=20 W "Claim Header (Optional) Record:",!! - .I NODE=30 D - . . I '$$GET1^DIQ(9002313.92,IENS,1.07,"I") D - . . . D GS W ! - . . . S GSPOS=POSITION - . . W "Claim Information (Required) Record:",!! - .I NODE=40 W "Claim Information (Optional) Record:",!! - .S ORDER=0 - . W !,"SEGMENT: ",NODE,!! - .F D Q:'+ORDER - ..S ORDER=$ORDER(^BPSF(9002313.92,IEN,NODE,"B",ORDER)) - ..Q:'+ORDER - ..S MIEN=$ORDER(^BPSF(9002313.92,IEN,NODE,"B",ORDER,"")) - ..Q:'+MIEN - ..S MDATA=$G(^BPSF(9002313.92,IEN,NODE,MIEN,0)) - ..I $P(MDATA,U,3)="" S $P(MDATA,U,3)="S" ; defaults to Standard mode - ..S FIEN=$P(MDATA,U,2) - ..Q:'+FIEN - ..S FDATA=$G(^BPSF(9002313.91,FIEN,0)) - ..S LENGTH=$P(FDATA,U,5) - ..I NODE=20!(NODE=40) S LENGTH=LENGTH+3 - ..S:$P(MDATA,U,3)="X" XFLAG(NODE,MIEN)=FIEN - ..W FIEN," ",$J(ORDER,3)," " ;LJE; ADDED FIEN - ..W $J($P(FDATA,U,1),3)," " - ..W $J(POSITION,3) - ..I LENGTH>1 D - ...W "-",$J(POSITION+LENGTH-1,3) - ..E D - ...W " "," " - ..W " " - ..S POSITION=POSITION+LENGTH - ..W $P(MDATA,U,3)," " - ..W $P(FDATA,U,3),! - ;W !,"Total length of claim record: ",POSITION-1," bytes",! - ; more claims in the same packet, maybe - I $G(GSPOS) N CLAIMLEN S CLAIMLEN=POSITION-GSECME ; length of one claim - I '$G(CLAIMLEN) S CLAIMLEN=POSITION - F N=2:1:$$GET1^DIQ(9002313.92,IENS,1.03) D CLAIM(N) - ;W # - D:$D(XFLAG) - .;D R2HEADER(IEN) - .F NODE=10,20,30,40 D - ..Q:'$D(XFLAG(NODE)) - ..W ! - ..S MIEN="" - ..F D Q:'+MIEN - ...S MIEN=$ORDER(XFLAG(NODE,MIEN)) - ...Q:'+MIEN - ...S FIEN=$G(XFLAG(NODE,MIEN)) - ...Q:FIEN="" - ...S RDATA=$G(^BPSF(9002313.91,FIEN,0)) - ...Q:RDATA="" - ...W $J($P(RDATA,U,1),3),?10,$P(RDATA,U,3),! - ...S GN=0 - ...F D Q:'+GN - ....S GN=$ORDER(^BPSF(9002313.92,IEN,NODE,MIEN,1,GN)) - ....Q:'+GN - ....S GCODE=$G(^BPSF(9002313.92,IEN,NODE,MIEN,1,GN,0)) - ....W ?10,"X",GN,": ",GCODE,! - .W # - Q -GS ; where a group separator occurs - W " ",$J(POSITION,3)," " - W "Group Separator ($C(29))",! - S POSITION=POSITION+1 - Q -CLAIM(N) ; where 2nd, 3rd, 4th claims go - W ! - D GS ; a group separator comes first - W " ",$J(POSITION,3) - W "-",$J(POSITION+CLAIMLEN-1,3)," " - W "Claim #",N,! - S POSITION=POSITION+CLAIMLEN - Q - ;---------------------------------------------------------------------- -R2HEADER(IEN) ; - W $$GET1^DIQ(9002313.92,IENS,.01) - W " (`",IEN,")",! - W $TR($J("",IOM)," ","-"),! - I '$$GET1^DIQ(9002313.92,IENS,1.07,"I") D ; if not a reversal format - . N FIELD S FIELD=1 - . F S FIELD=$O(^DD(9002313.92,FIELD)) Q:'FIELD D - . . I FIELD'<10,FIELD'>40 Q - . . I FIELD=1.07 Q ; "Is A Reversal Format" - . . W $$GET1^DID(9002313.92,FIELD,,"LABEL"),": " - . . W $$GET1^DIQ(9002313.92,IENS,FIELD) - . . W ! - Q diff -auBN ./r1/BPSECX0.m ./r2/r/BPSECX0.m --- ./r1/BPSECX0.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECX0.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,112 +0,0 @@ -BPSECX0 ;BHAM ISC/FCS/DRS/VA/DLF - Retrieve Claim submission record ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Retrieve Claim submission record - ; - ;Input Variables: CLAIMIEN - Claim Submission IEN (9002313.02) - ; .BPS - Pass by reference, output only - ; - ;Output Variables: BPS(9002313.02,CLAIMIEN,,"I") = Value - ;---------------------------------------------------------------------- - ; IHS/SD/lwj 08/13/02 NCPDP 5.1 changes - ; Many fields that were once a part of the "header" of the claim - ; were shifted to appear on the "rx" or "detail" segments of the - ; claim in 5.1. Additionally, MANY new fields were added beyond 499. - ; For these reasons, we had to change the GETBPS3 - ; subroutine to pull fields 308 through 600 rather than just - ; 402 - 499. The really cool thing is that because we are at the - ; subfile level, the duplicated fields (between header and rx) - ; will only pull at the appropriate level. 3.2 claims should - ; be unaffected by this change, as the adjusted and new fields - ; were not populated for 3.2 - ; - ; New subroutine added GETBPS4 to pull out the repeating fields for - ; the DUR/PPS records - ;---------------------------------------------------------------------- - ; -GETBPS2(CLAIMIEN,BPS) ;EP - from BPSECA1 from BPSOSQH from BPSOSQG from BPSOSQ2 - ;Manage local variables - N DIC,DR,DA,DIQ,D0,DIQ2 - ; - ;Make sure input variables are defined - Q:$G(CLAIMIEN)="" - ; - ;Set input variables for FileMan data retrieval routine - ;IHS/SD/lwj 9/9/02 need to expand the field range to include - ; the "500" range fields now used in the header segments - ; for NCPDP 5.1 - ; - S DIC=9002313.02 - ; IHS/SD/lwj 9/9/02 NCPDP 5.1 changes nxt line remarked - ; out, following line added to replace it - ; S DR="101:401" - S DR="101:600" - S DA=CLAIMIEN - S DIQ="BPS",DIQ(0)="I" - ; - ;Execute data retrieval routine - D EN^DIQ1 - Q - ;---------------------------------------------------------------------- - ;Retrieve Claim Submission, Prescription(s) multiple record - ; - ;Input Variables: CLAIMIEN - Claim Submission IEN (9002313.02) - ; CRXIEN - Prescription Multiple IEN (9002313.0201) - ; - ;Output Variables: BPS(9002313.0201,CRXIEN,,"I") = Value - ;---------------------------------------------------------------------- -GETBPS3(CLAIMIEN,CRXIEN,BPS) ;EP - from BPSECA1 - ;Manage local variables - N DIC,DR,DA,DIQ,D0,DIQ2 - ; - ;Make sure input variables are defined - Q:$G(CLAIMIEN)="" - Q:$G(CRXIEN)="" - ; - ;S input variables for FileMan data retrieval routine - S DIC=9002313.02 - ; - ;IHS/SD/lwj 8/13/02 NCPDP 5.1 nxt line rmkd out - following line added - ;S DR="400",DR(9002313.0201)="402:499" - S DR="400",DR(9002313.0201)="308:600" ;need new RX fields - ;IHS/SD/lwj 8/13/02 end changes - S DA=CLAIMIEN,DA(9002313.0201)=CRXIEN - S DIQ="BPS",DIQ(0)="I" - ; - ;Execute data retrieval routine - D EN^DIQ1 - Q - ;---------------------------------------------------------------------- - ;Retrieve Claim Submission, Prescription(s) multiple, DUR/PPS multiple - ; record - ; - ;Input Variables: CLAIMIEN - Claim Submission IEN (9002313.02) - ; CRXIEN - Prescription Multiple IEN (9002313.0201) - ; CDURIEN - DUR/PPS Multiple IEN (9002313.1001) - ; - ;Output Variables: BPS(9002313.1001,CDURIEN,,"I") = Value - ;---------------------------------------------------------------------- -GETBPS4(CLAIMIEN,CRXIEN,CDURIEN,BPS) ;EP - from BPSECA1 - ; - ;Manage local variables - N DIC,DR,DA,DIQ,D0,DIQ2 - ; - ;Make sure input variables are defined - Q:$G(CLAIMIEN)="" - Q:$G(CRXIEN)="" - Q:$G(CDURIEN)="" - ; - ;S input variables for FileMan data retrieval routine - S DIC=9002313.02 - ; - S DR="400",DR(9002313.0201)=473.01 ;fields - S DR(9002313.1001)=".01;439;440;441;474;475;476" ;fields - S DA=CLAIMIEN,DA(9002313.0201)=CRXIEN,DA(9002313.1001)=CDURIEN - S DIQ="BPS",DIQ(0)="I" - ; - ;Execute data retrieval routine - D EN^DIQ1 - ; - Q diff -auBN ./r1/BPSECX1.m ./r2/r/BPSECX1.m --- ./r1/BPSECX1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECX1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,86 +0,0 @@ -BPSECX1 ;BHAM ISC/FCS/DRS/VA/DLF - Create new Claim ID for Claim Submission file ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;Create new Claim ID for Claim Submission file (9002313.02) - ; - ;Input Variables: NRDEFIEN - NCPDP Record Definitions IEN - ; (9002313.92) - ; - ;Function Returns: String: C-- - ; C can also be P or other ORIGIN code. - ; See remarks a few lines below about ORIGIN - ; Where: is the year - ; is the BIN number of the payor - ; is a 5-digit sequence number - ;---------------------------------------------------------------------- - ; Also called from old Alaska Medicaid batch method, - ; regrettably still in use at one site, but we're going to - ; phase it out someday. - ; - ; ORIGIN argument added 08/23/2000 - ; Can specify the leading character of the claim ID. - ; Defaults to "C". - ; ECME sends in "P" - ; 09/20/2000 - can override by setting BPSECX1("PREFIX")=letter - ; (Do this if you change the batch file to submit via POS) - ; - ; Also changed 08/23/2000: Sequence number is now 6 digits - ; and the first number assigned is 100000. As of yesterday, ANMC - ; is already up to almost 40000. - ; Can't change length in the middle of the year or the $O(,-1) is - ; messed up. So the code will adapt - if it finds 5-digit format - ; already there, it will assign new numbers with 5 digits. - ; -CLAIMID(NRDEFIEN,ORIGIN) ;EP - Called from BPSOSCE from BPSOSCA from BPSOSQG from BPSOSQ2 - N BIN,SEQNUM,ROOT,LAST,NABP,PHARMACY ;LJE - I '$D(ORIGIN) S ORIGIN="C" - I $G(BPSECX1("PREFIX"))?1U S ORIGIN=BPSECX1("PREFIX") - I VARX S ORIGIN="VA" ;LJE - ; - ;Get and format BIN number for the electronic payor - I '$D(CERTIFY) S CERTIFY=(^BPS(9002313.99,1,"CERTIFIER")=DUZ) - S BIN=$S(CERTIFY:$P($G(^BPSF(9002313.92,NRDEFIEN,1)),U,1),VARX:$$GET1^DIQ(9002313.59902,"1,"_IEN59_",","902.03"),1:$P($G(^BPSF(9002313.92,NRDEFIEN,1)),U,1)) - S BIN=$$NFF^BPSECFM(BIN,6) - I ^BPS(9002313.99,1,"CERTIFIER")'=DUZ S PHARMACY=$P(^BPST(IEN59,1),U,7),NABP=$P(^BPS(9002313.56,PHARMACY,0),"^",2) - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ&('$G(PHARMACY)) S PHARMACY=10,NABP=$P(^BPS(9002313.56,PHARMACY,0),"^",2) - ; - ;Establish the root for the claim id number - S ROOT=ORIGIN_$E(DT,2,3)_"-"_BIN_"-" ; 11 characters long - ; LJE;7/24/03; following lines generate the va trasmit id/claim id the quits. - I VARX D Q ROOT - . S BIN=$TR($J("",6-$L(BIN))," ","0")_BIN - . ;I $G(CERTIFY) S NABP=$TR($J("",6-$L(NABP))," ","0")_NABP - . S NABP=$TR($J("",7-$L(NABP))," ","0")_NABP - . S ROOT=ORIGIN_($E(DT,1,3)+1700)_"-"_NABP_"-"_BIN - . L +^BPS(9002313.99,1,3):15 I '$T D IMPOSS^BPSOSUE("DB,P","TI","",,"Can't lock BPS(9002313.99,1,3)",$T(+0)) - . S SEQNUM=^BPS(9002313.99,1,3),^BPS(9002313.99,1,3)=SEQNUM+1 - . I $L(SEQNUM<7) S SEQNUM=$E($TR($J("",7-$L(SEQNUM))," ","0")_SEQNUM,1,7) - . L -^BPS(9002313.99,1,3) - . S ROOT=ROOT_"-"_SEQNUM - ; - ;Get last claim id number with the same root - S LAST=$O(^BPSC("B",ROOT_"Z"),-1) - ; Reversal claim ID? Get rid of the suffix R# - ; BPS*1.0T7*6 could be #>9, in which case the old logic fails! - ; BPS*1.0T7*6 replaced the line that strips off the R# - ;I $L(LAST)>6,LAST?.E1"R"1N S LAST=$E(LAST,1,$L(LAST)-2) ;BPS*1.0T7*6 - I $L(LAST)>6,LAST?.E1"R"1.N S $P(LAST,"-",3)=+$P(LAST,"-",3) ;BPS*1.0T7*6 - ; - ;Set and format sequence number - S SEQNUM=$S($E(LAST,1,11)=ROOT:(+$P(LAST,"-",3))+1,1:0) - N SEQLEN - ; 5 or 6 digit numbers? Depends on what's there already? - ; Six digits is what we really want, but upgrades will be trickier. - ; New installs and ANMC 2001 will have 6 digits. - ; - I SEQNUM=0 S SEQLEN=6,SEQNUM=100000 - E S SEQLEN=$L($P(LAST,"-",3)) - I SEQLEN<5 D IMPOSS^BPSOSUE("DB,P","TI",LAST,,"SEQLEN<5",$T(+0)) ; internal error - I SEQLEN>6 D IMPOSS^BPSOSUE("DB,P","TI",LAST,,"SEQLEN>6",$T(+0)) ; internal error - I $L(SEQNUM)=SEQLEN,SEQNUM?."9" D - . D IMPOSS^BPSOSUE("DB,P","T",LAST,,"OVERFLOWED!",$T(+0)) - I SEQLEN=5 S SEQNUM=$TR($J(SEQNUM,SEQLEN)," ","0") ; pad w/leading 0s - I $L(SEQNUM)'=SEQLEN D ; internal error - . D IMPOSS^BPSOSUE("DB,P","TI",LAST,SEQLEN,"length",$T(+0)) - ; - Q ROOT_SEQNUM diff -auBN ./r1/BPSECX4.m ./r2/r/BPSECX4.m --- ./r1/BPSECX4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECX4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,78 +0,0 @@ -BPSECX4 ;BHAM ISC/FCS/DRS/VA/DLF - Function which gets a claim or response record from the ^BPSECX global ;05/17/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Function which gets a claim or response record from the ^BPSECX - ;transmission scratch global. - ; - ;Input Variables: IEN - Internal Entry Number of Claim Record - ; MODE - "C" for Claim or "R" for Response - ; - ;Function Returns: AREC - ASCII formated record - ;---------------------------------------------------------------------- - ; SVEAREC (Save a Record) - ; Called from BPSOSQH from BPSOSQG from BPSOSQ2 - ; GETAREC is apparently obsolete? - ; - ;GetAREC(IEN,MODE) - ;Manage Local variables - ;N AREC,NNODES,INDEX - ; - ;Make sure input variables are defined - ;Q:$G(IEN)="" "" - ;Q:$G(MODE)="" "" - ; - ;Assemble ascii record from its 245 character sections - ;S AREC="" - ;S NNODES=$G(^BPSECX($J,MODE,IEN,0)) - ;Q:+NNODES=0 - ;F INDEX=1:1:NNODES D - ;.S AREC=AREC_$G(^BPSECX($J,MODE,IEN,INDEX)) - ; - ;Q AREC - ;---------------------------------------------------------------------- - ;Routine which creates and breaks apart an ASCII claim or response - ;record and stores it in the ^BPSECX transmission scratch global. - ; - ;Input Variables: AREC - ASCII formatted record - ; IEN - Internal Entry Number of Claim Record - ; MODE - "C" for Claim or "R" for Response - ; - ;Function Returns: AREC - ASCII formated record - ;---------------------------------------------------------------------- -SVEAREC(AREC,IEN,MODE) ;EP - from BPSOSQH - ;Manage local variables - N NCHARS,NNODES,INDEX,START,END - ; - ;Make sure input variables are defined - Q:$G(AREC)="" - Q:$G(MODE)="" - Q:$G(IEN)="" - ; - ;Determine number of nodes need to store AREC - I $G(VARX) G VASTORE - S NCHARS=$L(AREC) - S NNODES=((NCHARS-1)\245)+1 - ; - K ^BPSECX($J,MODE,IEN) - S ^BPSECX($J,MODE,IEN,0)=NNODES - ; - ;Break AREC into 245 character sections - F INDEX=1:1:NNODES D - .S START=((INDEX-1)*245)+1 - .S END=START+245-1 - .S:END>NCHARS END=NCHARS - .S ^BPSECX($J,MODE,IEN,INDEX)=$E(AREC,START,END) - Q - ; -VASTORE ;LJE; Need to store by segment for VA due to HL7 constraints. Had to changed field, group, and segment separators to control - ; ; characters for Vitria/AAC processing as well as shortening the length of the xmit. - S INDEX=1 F S NNODES=$O(AREC(NNODES)) Q:NNODES="" D - . S ^BPSECX($J,MODE,IEN,INDEX)=AREC(NNODES),INDEX=INDEX+1 - S ^BPSECX($J,MODE,IEN,0)=INDEX-1 - Q - ; - ;S START=AREC - ;F INDEX=1:1 S NCHARS=$P(START,"AM",INDEX) Q:NCHARS="" S ^BPSECX($J,MODE,IEN,INDEX)=$S(INDEX=1:NCHARS,1:"AM"_NCHARS) - ;S ^BPSECX($J,MODE,IEN,0)=INDEX-1 - ;Q diff -auBN ./r1/BPSECZ3.m ./r2/r/BPSECZ3.m --- ./r1/BPSECZ3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECZ3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,76 +0,0 @@ -BPSECZ3 ;BHAM ISC/FCS/DRS/VA/DLF - DISPLAY NDC Electronic Claims (by Response Status ;05/18/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;DISPLAY NDC Electronic Claims (by Response Status) - ;---------------------------------------------------------------------- -EN ;EP - option BPS DISPLAY RESPONSES 1 - N SCRNTXT,ANS,PNAME,PCN,BITEMIEN,LPROMPT,LPROMPT2,IENS - N SDATE,EDATE,RSPCODE - ; - D DT^DICRW - D HOME^%ZIS - ; - S SCRNTXT="DISPLAY NDC Electronic Claims (by Response Status)" - D WHEADER^BPSOSU9(SCRNTXT,IOF,IOM) - W ! - ; - ;Start DATE PROMPT - S (SDATE,EDATE)="" -LP1 S ANS=$$DATE^BPSOSU1("Claims Transmitted On - Start DATE: ",SDATE,1,"","DT","E",DTIME) - G:ANS=-1!(ANS="^")!(ANS="^^")!(ANS="") EXIT - S SDATE=ANS - ; - ;End DATE PROMPT -LP2 S ANS=$$DATE^BPSOSU1("Claims Transmitted On - End DATE: ",EDATE,1,SDATE,"DT","E",DTIME) - I ANS="^" D WHEADER^BPSOSU9(SCRNTXT,IOF,IOM) G LP1 - G:ANS=-1!(ANS="^^")!(ANS="") EXIT - S EDATE=ANS - ; - ;Response Status PROMPT -LP3 S ANS=$$SET^BPSOSU3("Select Response Status","R",1,"V","R:Rejected Medication;P:Payable Medication;C:Captured Medication;D:Duplicate Medication",DTIME) - I ANS="^" D WHEADER^BPSOSU9(SCRNTXT,IOF,IOM) G LP2 - G:ANS=-1!(ANS="^^")!(ANS="") EXIT - S RSPCODE=ANS - ; - ;Construct Billing ITEM List Based on Search PROMPT - D KILL($$LIST) - ;S ^JON=SDATE_U_EDATE_U_RSPCODE - D EN1^BPSES02(SDATE,EDATE,RSPCODE,1000,$$OPENREF($$LIST)) - ; next line may need a $GET - I '@$$LIST@(0) D G LP1 ; 03/12/2001 added ' - .W " (No Entries Found!)",! - .D PRESSANY^BPSOSU5(1,60) - .D WHEADER^BPSOSU9(SCRNTXT,IOF,IOM) - .W ! - ; -LP4 D KILL($$LISTANS) - S LPROMPT(1)="NDC Electronic Claim Response List:" - S ANS=$$LIST^BPSOSU4("S",$$OPENREF($$LIST),$$OPENREF($$LISTANS),SCRNTXT,.LPROMPT,1,10,DTIME) - I ANS="^" D WHEADER^BPSOSU9(SCRNTXT,IOF,IOM) G LP1 - G:ANS=-1!(ANS="^^")!(ANS="") EXIT - S IENS=$G(@$$LIST@(ANS,"I")) - G:IENS="" EXIT - D DISPLAY^BPSECZA(SCRNTXT,IENS) - G LP4 - ; -EXIT ;K ^LIST($J),^LISTANS($J) - Q -ROU() Q $T(+0) -Q() Q """" -C() Q "," -LIST() Q "^TMP("_$$Q_$$ROU_$$Q_$$C_$J_$$C_$$Q_"LIST"_$$Q_")" -LIST2() Q "^TMP("_$$Q_$$ROU_$$Q_$$C_$J_$$C_$$Q_"LIST2"_$$Q_")" -LISTANS() Q "^TMP("_$$Q_$$ROU_$$Q_$$C_$J_$$C_$$Q_"LISTANS"_$$Q_")" -LISTANS2() Q "^TMP("_$$Q_$$ROU_$$Q_$$C_$J_$$C_$$Q_"LISTANS2"_$$Q_")" -OPENREF(X) Q $E(X,1,$L(X)-1)_"," -KILL(REF) ; safety - make sure it's really an ^TMP node - N OK S OK=0 - I REF=$$LIST S OK=1 - I REF=$$LIST2 S OK=1 - I REF=$$LISTANS S OK=1 - I REF=$$LISTANS2 S OK=1 - I 'OK N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","TI","wrong global name",REF,"KILL",$T(+0)) - Q:'OK ; if they said "ignore", continue, but do not kill global - K @REF - Q diff -auBN ./r1/BPSECZA.m ./r2/r/BPSECZA.m --- ./r1/BPSECZA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSECZA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,110 +0,0 @@ -BPSECZA ;BHAM ISC/FCS/DRS/VA/DLF - Display Claim information functions ;05/18/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- -DISPLAY(SCRNTXT,IEN) ;EP - from BPSECZ2 and BPSECZ3 - ;Manage local variables - N DIC,DR,DA,DIQ,DR,F1,F2,F3,F4,CFLDS,RFLDS,RDA,CDA - N RJTCODE,RJTNEXT,RJTDA,RJTCOUNT,ANS - ; - ;Make sure input variables are defined - Q:$G(SCRNTXT)="" - Q:$G(IEN)="" - ; - ;G data from Claim Submission Record - S CDA=$P(IEN,U,1) - S F1=9002313.02,F2=9002313.0201 - S DIC="^BPSC(" ; 03/12/2001 - S DR=".01;.02;.05;1.01;1.02;1.03;301;302;304;400" - S DA=$P(IEN,U,1) - S DIQ="CFLDS" - S DIQ(0)="E" - S DR(F2)=".04;401:405;407;409:412" - S DA(F2)=$P(IEN,U,2) - D EN^DIQ1 - ; - ;G data from Claim Response Record - S RDA=$P(IEN,U,3) - I RDA'="" D - .S F3=9002313.03,F4=9002313.0301 - .S DIC="^BPSR(" ; 03/12/2001 - .S DR=".02;1000" - .S (RDA,DA)=$P(IEN,U,3) - .S DIQ="RFLDS" - .S DIQ(0)="E" - .S DR(F4)="501;503;504;505;506;507;508;509;510;513" - .S DA(F4)=$P(IEN,U,2) - .D EN^DIQ1 - ; - D WHEADER^BPSOSU9(SCRNTXT,IOF,IOM) - W ! - W "Claim ID:",?14,$G(CFLDS(F1,CDA,.01,"E")) - W ?46,"Sent On:",?61,$P($G(CFLDS(F1,CDA,.05,"E")),"@",1),! - W "PCN#:",?14,$G(CFLDS(F1,CDA,1.02,"E")) - W ?46,"VCN#:",?61,$G(CFLDS(F1,CDA,1.03,"E")),! - W $TR($J("",80)," ","-"),! - ; - W "Insurer:",?14,$G(CFLDS(F1,CDA,.02,"E")) - W ?46,"Group #:",?61,$G(CFLDS(F1,CDA,301,"E")),! - W "Patient:",?14,$G(CFLDS(F1,CDA,1.01,"E")) - W ?46,"Card #:",?61,$G(CFLDS(F1,CDA,302,"E")),! - ; - W $TR($J("",80)," ","-"),! - W "Medication:",?14,$G(CFLDS(F2,DA(F2),.04,"E")),! - W "NDC #:",?14,$G(CFLDS(F2,DA(F2),407,"E")) - W ?46,"Prescriber:",?61,$G(CFLDS(F2,DA(F2),411,"E")),! - W "RX #:",?14,$G(CFLDS(F2,DA(F2),402,"E")) - W ?46,"Date Filled:",?61,$G(CFLDS(F2,DA(F2),401,"E")),! - W "N/Refill:",?14,$G(CFLDS(F2,DA(F2),403,"E")) - W ?46,"Ingr Cost:",?61,$G(CFLDS(F2,DA(F2),409,"E")),! - W "Quantity:",?14,$G(CFLDS(F2,DA(F2),404,"E")) - W ?46,"Sales Tax:",?61,$G(CFLDS(F2,DA(F2),410,"E")),! - W "Day Supply:",?14,$G(CFLDS(F2,DA(F2),405,"E")) - W ?46,"Disp Fee:",?61,$G(CFLDS(F2,DA(F2),412,"E")),! - ; - I RDA="" D PRESSANY^BPSOSU5(1,DTIME) Q - ; - W $TR($J("",80)," ","-"),! - ; - I $G(RFLDS(F4,DA(F4),501,"E"))="CLAIM PAYABLE" D - .W "Resp Status:",?14,$G(RFLDS(F4,DA(F4),501,"E")) - .W ?46,"Ingr Cost Pd:",?61,$G(RFLDS(F4,DA(F4),506,"E")),! - .W "Patient Pay:",?14,$G(RFLDS(F4,DA(F4),505,"E")) - .W ?46,"Sales Tax Pd:",?61,$G(RFLDS(F4,DA(F4),508,"E")),! - .W "Rem Ded Amt:",?14,$G(RFLDS(F4,DA(F4),513,"E")) - .W ?46,"Disp Fee Pd:",?61,$G(RFLDS(F4,DA(F4),507,"E")),! - .W "Authoriz #:",?14,$G(RFLDS(F4,DA(F4),503,"E")) - .W ?46,"Total Paid:",?61,$G(RFLDS(F4,DA(F4),509,"E")),! - .W "Message:",?14,$E($G(RFLDS(F4,DA(F4),504,"E")),1,75),! - .D PRESSANY^BPSOSU5(1,DTIME) - ; - I $G(RFLDS(F4,DA(F4),501,"E"))="CLAIM CAPTURED" D - .W "Resp Status:",?14,$G(RFLDS(F4,DA(F4),501,"E")),! - .W "Authoriz #:",?14,$G(RFLDS(F4,DA(F4),503,"E")),! - .W "Message:",?14,$E($G(RFLDS(F4,DA(F4),504,"E")),1,75),! - .D PRESSANY^BPSOSU5(1,DTIME) - ; - I $G(RFLDS(F4,DA(F4),501,"E"))="REJECTED CLAIM" D - .W "Resp Status:",?14,$G(RFLDS(F4,DA(F4),501,"E")) - .W ?46,"Reject COUNT:",?61,$G(RFLDS(F4,DA(F4),510,"E")),! - .W "Message:",?14,$E($G(RFLDS(F4,DA(F4),504,"E")),1,75),! - .S ANS=$$YESNO^BPSOSU3("DISPLAY Reject CODEs","NO",0,DTIME) - .Q:ANS'=1 - .D WHEADER^BPSOSU9(SCRNTXT,IOF,IOM) - .W ! - .W "Claim ID:",?14,$G(CFLDS(F1,CDA,.01,"E")) - .W ?46,"Sent On:",?61,$P($G(CFLDS(F1,CDA,.05,"E")),"@",1),! - .W $TR($J("",80)," ","-"),! - .S (RJTCOUNT,RJTNEXT)=0 - .F D Q:'+RJTNEXT - ..S RJTNEXT=$O(^BPSR(RDA,1000,DA(F4),511,RJTNEXT)) - ..Q:'RJTNEXT - ..S RJTCODE=$P($G(^BPSR(RDA,1000,DA(F4),511,RJTNEXT,0)),U,1) - ..Q:RJTCODE="" - ..Q:'$D(^BPSF(9002313.93,"B",RJTCODE)) - ..S RJTDA=$O(^BPSF(9002313.93,"B",RJTCODE,0)) - ..Q:RJTDA="" - ..S RJTCOUNT=RJTCOUNT+1 - ..W "Reject "_$J(RJTCOUNT,2)_":",?14,$E($P($G(^BPSF(9002313.93,RJTDA,0)),U,2),1,75),! - .D PRESSANY^BPSOSU5(1,DTIME) - Q diff -auBN ./r1/BPSER1A.m ./r2/r/BPSER1A.m --- ./r1/BPSER1A.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSER1A.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,71 +0,0 @@ -BPSER1A ;BHAM ISC/FCS/DRS/VA/DLF - Pharmacy Claim Rejection Report (by Tran Date, Sorted by Insurer) ;05/18/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Pharmacy Claim Rejection Report (by Tran Date, Sorted by Insurer) - ;---------------------------------------------------------------------- -HEADER1 S PAGE=$G(PAGE)+1 - I $Y>0 W @IOF ; D ^XBCLS - W $$LJBF^BPSOSU9(SCRNTXT,IOM-10)_$$LJBF^BPSOSU9("PAGE "_PAGE,10),! - W $TR($J("",IOM)," ","-"),! - Q - ;---------------------------------------------------------------------- -HEADER2 I '$D(PSIEN) S PSIEN=1 - W ! - W "Insurer:",?11,$$LJBF^BPSOSU9(INSNAME,46) - W ?61,"Help #:",?70,$$LJBF^BPSOSU9($G(^TMP($J,RPTNAME,INSNAME)),20) - W ?92,"Transmission Dates:" - W ?113,$$LJBF^BPSOSU9($$FM2MDY^BPSOSU1(SDATE),8)_" - " - W $$LJBF^BPSOSU9($$FM2MDY^BPSOSU1(EDATE),8),! - W ! - D WCOLUMNS^BPSOSU9(0,2,"Trans On:8,Claim ID:17,"_$P($G(^BPS(9002313.99,PSIEN,2)),U,1)_" #:12,Patient Name:20,Cardholder ID:15,NDC #:13,Rejection Reason(s):36",1) - Q - ;---------------------------------------------------------------------- -PRINT ;EP - from BPSER10 - N FLAG,INSNAME,TDATE,ANS,RESPIEN,MEDIEN,DATA,TRANSON,CLAIMID,PCN - N PATNAME,CARDID,NDC,RJCTCNT,RJCTN,RJCTTEXT - ;I IOM<132 D Q DLF - ;.D HEADER1 - ;.W !,"Device selected does not support 132 column reports.",! - ;.D:(IO=$P) PRESSANY^BPSOSU5(1,DTIME) - S FLAG=0,INSNAME="" - F D Q:INSNAME=""!(FLAG) - .S INSNAME=$O(^TMP($J,RPTNAME,INSNAME)) - .Q:INSNAME="" - .D HEADER1,HEADER2 - .S TDATE="" - .F D Q:'+TDATE!(FLAG) - ..S TDATE=$O(^TMP($J,RPTNAME,INSNAME,TDATE)) - ..Q:'+TDATE - ..S RESPIEN="" - ..F D Q:'+RESPIEN!(FLAG) - ...S RESPIEN=$O(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN)) - ...Q:'+RESPIEN - ...S MEDIEN="" - ...F D Q:'+MEDIEN!(FLAG) - ....S MEDIEN=$O(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)) - ....Q:'+MEDIEN - ....S DATA=$G(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)) - ....S TRANSON=$$FM2MDY^BPSOSU1(TDATE) - ....S CLAIMID=$P(DATA,U,1) - ....S PCN=$P(DATA,U,2) - ....S PATNAME=$P(DATA,U,3) - ....S CARDID=$E($P(DATA,U,4),3,99) - ....S NDC=$P(DATA,U,5) - ....S RJCTCNT=$P(DATA,U,6) - ....F RJCTN=1:1:$S(RJCTCNT:RJCTCNT,1:1) D Q:FLAG - .....S RJCTTEXT=$G(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN,RJCTN)) - .....S:RJCTTEXT="" RJCTTEXT="" ;"Undefined Error" - .....I ($Y+2)>IOSL,'(IO=$P) D HEADER1,HEADER2 - .....I ($Y+2)>IOSL,(IO=$P) D - ......S ANS=$$ENDPAGE^BPSOSU5(0,DTIME) - ......S:ANS=-1!(ANS="^") FLAG=1 - ......I 'FLAG D HEADER1,HEADER2 - .....S CARDID=$E(CARDID,3,99) - .....S CLAIMID=$P(CLAIMID,"-",3,4) - .....S NDC=$E(NDC,$L(NDC)-10,$L(NDC)) - .....D:'FLAG&(RJCTN=1) WDATA^BPSOSU9(0,2,"TRANSON:8,CLAIMID:17,PCN:12,PATNAME:20,CARDID:15,NDC:13,RJCTTEXT:36") - .....D:'FLAG&(RJCTN>1) WDATA^BPSOSU9(96,0,"RJCTTEXT:36") - Q:FLAG - D:(IO=$P) PRESSANY^BPSOSU5(1,DTIME) - Q diff -auBN ./r1/BPSER2A.m ./r2/r/BPSER2A.m --- ./r1/BPSER2A.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSER2A.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,83 +0,0 @@ -BPSER2A ;BHAM ISC/FCS/DRS/VA/DLF - Payable claims report ;05/18/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Pharmacy Claim Payable Report (by Tran Date, Sorted by Insurer) - ;---------------------------------------------------------------------- -HEADER1 S PAGE=$G(PAGE)+1 - W @IOF ;D ^AUCLS - W $$LJBF^BPSOSU9(SCRNTXT,IOM-10)_$$LJBF^BPSOSU9("PAGE "_PAGE,10),! - W $TR($J("",IOM)," ","-"),! - Q - ;---------------------------------------------------------------------- -HEADER2 I '$D(PSIEN) S PSIEN=1 - W ! - W "Insurer:",?11,$$LJBF^BPSOSU9(INSNAME,46) - W ?61,"Help #:",?70,$$LJBF^BPSOSU9($G(^TMP($J,RPTNAME,INSNAME)),20) - W ?92,"Transmission Dates:" - W ?113,$$LJBF^BPSOSU9($$FM2MDY^BPSOSU1(SDATE),8)_" - " - W $$LJBF^BPSOSU9($$FM2MDY^BPSOSU1(EDATE),8),! - W ! - D WCOLUMNS^BPSOSU9(0,2,"Trans On:8,Claim ID:17,"_$P($G(^BPS(9002313.99,PSIEN,2)),U,1)_" #:12,Patient Name:20,NDC #:13,Ingr Pd:7,Disp Pd:7,Total Pd:9,Pat Pay Amt:11,Rem Dedct:11",1) - Q - ;---------------------------------------------------------------------- -PRINT ;EP - from BPSER20 - N FLAG,INSNAME,TDATE,ANS,RESPIEN,MEDIEN,DATA,TRANSON,CLAIMID,PCN - N PATNAME,NDC,INGRPD,DISPPD,TOTPD,PATPAY,REMDED - N TINGRPD,TDISPPD,TTOTPD,TPATPAY,TREMDED - ; - ;I IOM<132 D Q - ;.D HEADER1 - ;.W !,"Device selected does not support 132 column reports.",! - ;.D:(IO=$P) PRESSANY^BPSOSU5(1,DTIME) - ; - ; - ; - S FLAG=0,INSNAME="" - F D Q:INSNAME=""!(FLAG) - .S INSNAME=$O(^TMP($J,RPTNAME,INSNAME)) - .Q:INSNAME="" - .S (TINGRPD,TDISPPD,TTOTPD,TPATPAY,TREMDED)=0 - .D HEADER1,HEADER2 - .S TDATE="" - .F D Q:'+TDATE!(FLAG) - ..S TDATE=$O(^TMP($J,RPTNAME,INSNAME,TDATE)) - ..Q:'+TDATE - ..S RESPIEN="" - ..F D Q:'+RESPIEN!(FLAG) - ...S RESPIEN=$O(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN)) - ...Q:'+RESPIEN - ...S MEDIEN="" - ...F D Q:'+MEDIEN!(FLAG) - ....S MEDIEN=$O(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)) - ....Q:'+MEDIEN - ....S DATA=$G(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)) - ....S TRANSON=$$FM2MDY^BPSOSU1(TDATE) - ....S CLAIMID=$P(DATA,U,1) - ....S PCN=$P(DATA,U,2) - ....S PATNAME=$P(DATA,U,3) - ....S NDC=$P(DATA,U,4) - ....S INGRPD=$P(DATA,U,5),TINGRPD=TINGRPD+$$CLIP^BPSOSU9(INGRPD) - ....S DISPPD=$P(DATA,U,6),TDISPPD=TDISPPD+$$CLIP^BPSOSU9(DISPPD) - ....S TOTPD=$P(DATA,U,7),TTOTPD=TTOTPD+$$CLIP^BPSOSU9(TOTPD) - ....S PATPAY=$P(DATA,U,8),TPATPAY=TPATPAY+$$CLIP^BPSOSU9(PATPAY) - ....S REMDED=$P(DATA,U,9),TREMDED=TREMDED+$$CLIP^BPSOSU9(REMDED) - ....I ($Y+2)>IOSL,'(IO=$P) D HEADER1,HEADER2 - ....I ($Y+2)>IOSL,(IO=$P) D - .....S ANS=$$ENDPAGE^BPSOSU5(0,DTIME) - .....S:ANS=-1!(ANS="^") FLAG=1 - .....I 'FLAG D HEADER1,HEADER2 - ....D:'FLAG WDATA^BPSOSU9(0,2,"TRANSON:8,CLAIMID:17,PCN:12,PATNAME:20,NDC:13,INGRPD:7,DISPPD:7,TOTPD:9,PATPAY:9,REMDED:11") - .;PRINT Totals - .I ($Y+3)>IOSL,'(IO=$P) D HEADER1,HEADER2 - .I ($Y+3)>IOSL,(IO=$P) D - ..S ANS=$$ENDPAGE^BPSOSU5(0,DTIME) - ..S:ANS=-1!(ANS="^") FLAG=1 - ..I 'FLAG D HEADER1,HEADER2 - .Q:FLAG - .W ?79,"------- ------- --------- ----------- -----------",! - .W ?78,$J(TINGRPD,8,2)," ",$J(TDISPPD,8,2)," ",$J(TTOTPD,9,2)," ",$J(TPATPAY,11,2)," ",$J(TREMDED,11,2),! - ; - Q:FLAG - D:(IO=$P) PRESSANY^BPSOSU5(1,DTIME) - Q diff -auBN ./r1/BPSER3A.m ./r2/r/BPSER3A.m --- ./r1/BPSER3A.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSER3A.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,64 +0,0 @@ -BPSER3A ;BHAM ISC/FCS/DRS/VA/DLF - Transmission STATUS Report (Claim Summary) ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Transmission STATUS Report (Claim Summary) - ;---------------------------------------------------------------------- -HEADER1 S PAGE=$G(PAGE)+1 - W @IOF ; D ^AUCLS - W $$LJBF^BPSOSU9(SCRNTXT,IOM-10)_$$LJBF^BPSOSU9("PAGE "_PAGE,10),! - W $TR($J("",IOM)," ","-"),! - Q - ;---------------------------------------------------------------------- -HEADER2 I '$D(PSIEN) N PSIEN S PSIEN=1 - W ! - W "Insurer:",?11,$$LJBF^BPSOSU9(INSNAME,46) - W ?92,"Transmission Dates:" - W ?113,$$LJBF^BPSOSU9($$FM2MDY^BPSOSU1(SDATE),8)_" - " - W $$LJBF^BPSOSU9($$FM2MDY^BPSOSU1(EDATE),8),! - W ! - D WCOLUMNS^BPSOSU9(0,2,"Trans On:8,Claim ID:18,"_$P($G(^BPS(9002313.99,PSIEN,2)),U,1)_" #:12,Patient Name:20,Vst Date:8,NDC #:13,RX #:8,STATUS:9",1) - Q - ;---------------------------------------------------------------------- -PRINT ;EP - from BPSER30 - N FLAG,INSNAME,TDATE,ANS,RESPIEN,MEDIEN,DATA,TRANSON,CLAIMID,PCN - N PATNAME,NDC,RX,STATUS,FDATE - I IOM<132 D Q - .D HEADER1 - .W !,"Device selected does not support 132 column reports.",! - .D:(IO=$P) PRESSANY^BPSOSU5(1,DTIME) - S FLAG=0,INSNAME="" - F D Q:INSNAME=""!(FLAG) - .S INSNAME=$O(^TMP($J,RPTNAME,INSNAME)) - .Q:INSNAME="" - .D HEADER1,HEADER2 - .S TDATE="" - .F D Q:'+TDATE!(FLAG) - ..S TDATE=$O(^TMP($J,RPTNAME,INSNAME,TDATE)) - ..Q:'+TDATE - ..S RESPIEN="" - ..F D Q:'+RESPIEN!(FLAG) - ...S RESPIEN=$O(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN)) - ...Q:'+RESPIEN - ...S MEDIEN="" - ...F D Q:'+MEDIEN!(FLAG) - ....S MEDIEN=$O(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)) - ....Q:'+MEDIEN - ....S DATA=$G(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)) - ....S TRANSON=$$FM2MDY^BPSOSU1(TDATE) - ....S CLAIMID=$P(DATA,U,1) - ....S PCN=$P(DATA,U,2) - ....S PATNAME=$P(DATA,U,3) - ....S FDATE=$P(DATA,U,4) - ....S NDC=$P(DATA,U,5) - ....S RX=$P(DATA,U,6) - ....S STATUS=$P(DATA,U,7) - ....I ($Y+2)>IOSL,'(IO=$P) D HEADER1,HEADER2 - ....I ($Y+2)>IOSL,(IO=$P) D - .....S ANS=$$ENDPAGE^BPSOSU5(0,DTIME) - .....S:ANS=-1!(ANS="^") FLAG=1 - .....I 'FLAG D HEADER1,HEADER2 - ....D:'FLAG WDATA^BPSOSU9(0,2,"TRANSON:8,CLAIMID:19,PCN:12,PATNAME:20,FDATE:8,NDC:13,RX:8,STATUS:9") - Q:FLAG - D:(IO=$P) PRESSANY^BPSOSU5(1,DTIME) - Q diff -auBN ./r1/BPSER4A.m ./r2/r/BPSER4A.m --- ./r1/BPSER4A.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSER4A.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,72 +0,0 @@ -BPSER4A ;BHAM ISC/FCS/DRS/VA/DLF - Pharmacy Claim Rejection Report ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Pharmacy Claim Rejection Report - CODE 40 - (by Tran Date, Sorted by Insurer) - ;---------------------------------------------------------------------- -HEADER1 S PAGE=$G(PAGE)+1 - W @IOF ;D ^AUCLS - W $$LJBF^BPSOSU9(SCRNTXT,IOM-10)_$$LJBF^BPSOSU9("PAGE "_PAGE,10),! - W $TR($J("",IOM)," ","-"),! - Q - ;---------------------------------------------------------------------- -HEADER2 I '$D(PSIEN) N PSIEN S PSIEN=1 - W ! - W "Insurer:",?11,$$LJBF^BPSOSU9(INSNAME,46) - W ?61,"Help #:",?70,$$LJBF^BPSOSU9($G(^TMP($J,RPTNAME,INSNAME)),20) - W ?92,"Transmission Dates:" - W ?113,$$LJBF^BPSOSU9($$FM2MDY^BPSOSU1(SDATE),8)_" - " - W $$LJBF^BPSOSU9($$FM2MDY^BPSOSU1(EDATE),8),! - ;D WCOLUMNS^BPSOSU9(0,2,"Trans On:8,Claim ID:16,"_$P($G(^BPS(9002313.99,PSIEN,2)),U,1)_" #:12,Patient Name:20,Cardholder ID:15,NDC #:13,Rejection Reason(s):36",1) - D WCOLUMNS^BPSOSU9(0,2,"Patient Name:20,"_$P($G(^BPS(9002313.99,PSIEN,2)),U,1)_" #:12,MCAID #:15,Date Filled:8,Presc.#:12,NDC #:13,QTY:3,Days Supply:11,Charge:8",1) - Q - ;---------------------------------------------------------------------- -PRINT ;EP - from BPSER40 - N FLAG,INSNAME,TDATE,ANS,RESPIEN,MEDIEN,DATA,TRANSON,CLAIMID,VCN - N PATNAME,CARDID,NDC,RJCTCNT,RJCTN,RJCTTEXT,CHG,MCAID,QTY,SUP - I IOM<132 D Q - .D HEADER1 - .W !,"Device selected does not support 132 column reports.",! - .D:(IO=$P) PRESSANY^BPSOSU5(1,DTIME) - S FLAG=0,INSNAME="" - F D Q:INSNAME=""!(FLAG) - .S INSNAME=$O(^TMP($J,RPTNAME,INSNAME)) - .Q:INSNAME="" - .D HEADER1,HEADER2 - .S TDATE="" - .F D Q:'+TDATE!(FLAG) - ..S TDATE=$O(^TMP($J,RPTNAME,INSNAME,TDATE)) - ..Q:'+TDATE - ..S RESPIEN="" - ..F D Q:'+RESPIEN!(FLAG) - ...S RESPIEN=$O(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN)) - ...Q:'+RESPIEN - ...S MEDIEN="" - ...F D Q:'+MEDIEN!(FLAG) - ....S MEDIEN=$O(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)) - ....Q:'+MEDIEN - ....S DATA=$G(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)) - ....S TRANSON=$$FM2MDY^BPSOSU1(TDATE) - ....S CLAIMID=$P(DATA,U,1) - ....S VCN=$P(DATA,U,2) - ....S PATNAME=$P(DATA,U,3) - ....S CARDID=$P(DATA,U,4) - ....S MCAID=999999 - ....S QTY="TST" - ....S SUP="TST" - ....S CHG=500 - ....S NDC=$P(DATA,U,5) - ....S RJCTCNT=$P(DATA,U,6) - ....F RJCTN=1:1:RJCTCNT D Q:FLAG - .....S RJCTTEXT=$G(^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN,RJCTN)) - .....S:RJCTTEXT="" RJCTTEXT="Undefined Error" - .....I ($Y+2)>IOSL,'(IO=$P) D HEADER1,HEADER2 - .....I ($Y+2)>IOSL,(IO=$P),($E(IOST,1,1)="C") D - ......S ANS=$$ENDPAGE^BPSOSU5(0,DTIME) - ......S:ANS=-1!(ANS="^") FLAG=1 - ......I 'FLAG D HEADER1,HEADER2 - .....D:'FLAG&(RJCTN=1) WDATA^BPSOSU9(0,2,"PATNAME:20,VCN:12,MCAID:15,TDATE:8,MEDIEN:12,NDC:13,QTY:3,SUP:11,CHG:8") - .....D:'FLAG&(RJCTN>1) WDATA^BPSOSU9(96,0,"RJCTTEXT:36") - Q:FLAG - D:(IO=$P) PRESSANY^BPSOSU5(1,DTIME) - Q diff -auBN ./r1/BPSES00.m ./r2/r/BPSES00.m --- ./r1/BPSES00.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSES00.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,76 +0,0 @@ -BPSES00 ;BHAM ISC/FCS/DRS/VA/DLF - Claims Submission File (9002313.02) - Billing Item Search ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Claims Submission File (9002313.02) - Billing Item Search - ; - ;Parameters: ROOT - - ; MAX - - ; GROOT - Global root of resulting list (eg: "^LIST($J") - ; - ;Returns: Fmatted list - ;---------------------------------------------------------------------- - Q -EN1(ROOT,MAX,GROOT) ;EP - from BPSECZ2 - ; - ;Search 'Patient Name' cross-reference - D BITEM1(ROOT,"C",MAX,GROOT) - Q:$G(@(GROOT_"0)"))>0 - ; - ;Search 'Billing Item PCN #' cross-reference - D BITEM1(ROOT,"D",MAX,GROOT) - Q:$G(@(GROOT_"0)"))>0 - ; - ;Search 'Billing Item VCN #' cross-reference - D BITEM1(ROOT,"E",MAX,GROOT) - Q - ;---------------------------------------------------------------------- - ;Build list of Billing Item records -BITEM1(ROOT,XREF,MAX,GROOT) ; - N ROOTL,NEXT,DA,COUNT,PCN,VCN,PAT,BAL,DATA,BITEMIEN,NCLAIMS - ; - Q:$G(ROOT)="" - Q:$G(XREF)="" - Q:$G(MAX)="" - Q:$G(GROOT)="" - S ROOTL=$L(ROOT) - Q:ROOTL<2 - ; - K @($P(GROOT,",",1,$L(GROOT,",")-1)_")") - S COUNT=0 - S NEXT=$S(XREF="E"&'($E(ROOT,$L(ROOT))?1A):ROOT_" ",1:ROOT) - S:$DATA(^BPSC(XREF,NEXT)) NEXT=$O(^BPSC(XREF,NEXT),-1) - F D Q:$E(NEXT,1,ROOTL)'=ROOT!(COUNT=MAX) - .S NEXT=$O(^BPSC(XREF,NEXT)) - .Q:$E(NEXT,1,ROOTL)'=ROOT - .S DA="" - .F D Q:'+DA - ..S DA=$O(^BPSC(XREF,NEXT,DA)) - ..Q:'+DA - ..Q:'$DATA(^BPSC(DA,0)) - ..S BITEMIEN=$P($G(^BPSC(DA,0)),U,3) - ..Q:'+BITEMIEN - ..Q:$DATA(@(GROOT_",""B"",BITEMIEN)")) - ..S @(GROOT_",""B"",BITEMIEN)")="" - ..S COUNT=COUNT+1 - ..S @(GROOT_",COUNT,""I"")")=BITEMIEN - ..S DATA=$G(^BPSC(DA,1)) - ..S PAT=$$LJBF^BPSOSU9($P(DATA,U,1),30) - ..S PCN=$$LJBF^BPSOSU9($P(DATA,U,2),12) - ..S VCN=$$LJBF^BPSOSU9($P(DATA,U,3),10) - ..S NCLAIMS=$$RJBF^BPSOSU9($$NCLAIMS(BITEMIEN),7) - ..S @(GROOT_"COUNT,""E"")")=PAT_" "_PCN_" "_VCN_" "_NCLAIMS - S @(GROOT_"""Column Headers"")")="2|Patient Name:30,PCN #:12,VCN #:10,# Claims:7" - S @(GROOT_"0)")=COUNT - Q - ;--------------------------------------------------------------------- - ;Returns the number of electronic claims for a billing item record -NCLAIMS(BITEMIEN) ; - N COUNT,NEXT - Q:BITEMIEN="" 0 - S (NEXT,COUNT)=0 - F D Q:'+NEXT - .S NEXT=$O(^BPSC("AC",BITEMIEN,NEXT)) - .Q:'+NEXT - .S COUNT=COUNT+1 - Q COUNT diff -auBN ./r1/BPSJACK.m ./r2/r/BPSJACK.m --- ./r1/BPSJACK.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJACK.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,156 +0,0 @@ -BPSJACK(HL) ;DAOU/LJF - HL7 Acknowledgement Messages ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; Reference to ^HLMA( supported by DBIA 3244 - ; Reference to ^HL(772 supported by DBIA 10138 - ; - ; This routine examines an Acknowledgement Message. If the mesage is - ; the E-PHARM Application Acknowledgement Message, and it is "AA", - ; it kicks off the Pharmacy Registration Messages. - ; If the message flags an error, then error notification is processed. - ; - N ACK,AREG,BPSJSEG,ERR,HCT,SEG - N MFI,MFIIX,MSGCTLID,MSGID,MSGIX,MSH - ; - I '$D(HL) Q - ; - S (AREG,HCT,MFIIX,MSGCTLID,MSGID,MSGIX)=0,(ACK,MFI,MSH)="" - S ERR("MSA")="" - ; Loop through the message and find each segment for processing - F S HCT=$O(^TMP($J,"BPSJHLI",HCT)) Q:HCT="" D - . K BPSJSEG D SPAR^BPSJUTL(.HL,.BPSJSEG,HCT) S SEG=$G(BPSJSEG(1)) - . ; - . I SEG="MSH" D Q - . . S MSGCTLID=$G(BPSJSEG(10)) ; get the message control id - . ; - . I SEG="MSA" D Q ; MSA|AA|509133482 - . . S ACK=$G(BPSJSEG(2)),MSGID=$G(BPSJSEG(3)) K ERR("MSA") - . . ; - . . I ACK="AA",MSGID D - . . . ; - . . . ; Find original message - . . . S MSGIX=$$FINDOMSG(MSGID) I 'MSGIX Q - . . . ; - . . . S MFIIX=+$G(^HLMA(MSGIX,0)),MSGIX=0 I 'MFIIX Q - . . . ; Check original message sent out for - . . . ; MFI seg with "Facility Table" - . . . F S MSGIX=$O(^HL(772,MFIIX,"IN",MSGIX)) Q:'MSGIX D I AREG Q - . . . . ; Get first 18 characters and remove Field Separator - . . . . S MFI=$E($G(^HL(772,MFIIX,"IN",MSGIX,0)),1,18),$E(MFI,4)="" - . . . . I MFI[("MFIFacility Table") S AREG=1 - . ; - . I SEG="MFA",ACK="AE" S ERR("MFA",U_$G(BPSJSEG(5)))="" Q - ; - ; Application Registered, do pharmacy reistrations - I AREG S AREG=0 D - . F S AREG=$O(^BPS(9002313.56,AREG)) Q:'AREG D REG^BPSJPREG(AREG) - ; - I $D(ERR) D ERRORM D MSG^BPSJUTL(.ERR,"BPSJACK") - Q - ; -ERRORM ; Error message setup - N ERRT - ; - S ERR(1)="Error(s) indicated for HL7 Application Acknowledge Message ID: "_$G(MSGCTLID) - I $D(ERR("MSA")) S ERR(2)="Error:NO MSA - No MSA segment found." - I $D(ERR("MFA")) S ERRT="" F S ERRT=$O(ERR("MFA",ERRT)) Q:ERRT="" D - . I ERRT["NC100" S ERR(100)="Error:NC100 - Invalid OP Interface version." Q - . I ERRT["NC200" S ERR(200)="Error:NC200 - Not e-IIV registered." Q - . I ERRT["NC201" S ERR(201)="Error:NC201 - Invalid IIV Interface version." Q - . I ERRT["NC202" S ERR(202)="Error:NC202 - Invalid e-IIV registration state." Q - . I ERRT["NC300" S ERR(300)="Error:NC300 - OP pharmacy not registered. Failed to update Pharmacy information." Q - . I ERRT["NC301" S ERR(301)="Error:NC301 - Unable to update Pharmacy information due to outpatient pharmacy registration has invalid OP interface version." Q - . I ERRT["NC302" S ERR(302)="Error:NC302 - Unable to update Pharmacy information due to invalid e-IIV registration state." Q - . S ERR(399)="Error:"_ERRT_" - Unknown error." - K ERR("MFA"),ERR("MSA") - ; - Q -FINDOMSG(MSGNO) ; find original message - N MSGIX,MFND,MSH,MSGFS,MSH1,MSH2 - S (MSGIX,MFND)=0,MSH1="MFN^M01",MSH2="E-PHARM VISTA" - I $G(MSGNO) F S MSGIX=$O(^HLMA("C",MSGNO,MSGIX)) Q:'MSGIX D I MFND Q - . S MSH=$G(^HLMA(MSGIX,"MSH",1,0)),MSGFS=$E(MSH,4) - . I MSGFS]"",$P(MSH,MSGFS,9)=MSH1,$P(MSH,MSGFS,3)=MSH2 S MFND=MSGIX - Q MFND - ; -APPACK(HL,APPACK,PSIEN) ; Application Acknowledgement for Payer Sheets - N MGRP,MSG,MCT,GENRSLT - N TLN,FS,FS2,FS3,CS - ; - K ^TMP("HLA",$J) - ; - ;-Set up HL7 - D INIT^HLFNC2("BPSJ REGISTER",.HL) - ; - D DGAPPACK ; Dollar G the APPACK variable (bullet proofing) - ; - S FS=$G(HL("FS")) I FS="" S FS="|" ; field separator - S CS=$E($G(HL("ECH"))) I CS="" S CS="^" ; component separator - ; - S MCT=0,FS2=FS_FS,FS3=FS_FS_FS - ; - ;-MSA SEG - I APPACK("MFA",4,1)="S" S ^TMP("HLA",$J,1)="MSA"_FS_"AA"_FS_APPACK("MSA",2) - E S ^TMP("HLA",$J,1)="MSA"_FS_"AE"_FS_APPACK("MSA",2) - ; - ;-MFI SEG - S TLN="MFI"_FS_APPACK("MFI",1,1)_CS_APPACK("MFI",1,2)_FS2 - S ^TMP("HLA",$J,2)=TLN_APPACK("MFI",3)_FS3_APPACK("MFI",6) - ; - ;-MFA SEG(S) - I APPACK("MFA",4,1)="S" D S ^TMP("HLA",$J,3)=TLN - . S TLN="MFA"_FS_APPACK("MFA",1)_FS_APPACK("MFA",2)_FS2 - . S TLN=TLN_APPACK("MFA",4,1)_CS_APPACK("MFA",4,2)_FS - . S TLN=TLN_APPACK("MFA",5)_FS_APPACK("MFA",6) - E D MFASEGS - ; - D GENACK^HLMA1($G(HL("EID")),$G(HL("HLMTIENS")),$G(HL("EIDS")),"GM",1,.GENRSLT) - ; - K ^TMP("HLA",$J) - Q - ; -MFASEGS ; Set up the MFA segs for Reject message - N MFAP1,MFAP2,MFACNTR,FIELD,RECORD,ZPRERR - ; - S MFAP1="MFA"_FS_APPACK("MFA",1)_FS_APPACK("MFA",2) - S MFAP1=MFAP1_FS2_APPACK("MFA",4,1)_CS - S MFAP2=FS_APPACK("MFA",5)_FS_APPACK("MFA",6) - S MFACNTR=2 - ; - I $D(^TMP($J,"BPSJ-ERROR","MFI")) S FIELD="" D - . F S FIELD=$O(^TMP($J,"BPSJ-ERROR","MFI",FIELD)) Q:'FIELD D - .. S MFACNTR=MFACNTR+1 - .. S ^TMP("HLA",$J,MFACNTR)=MFAP1_"V60"_FIELD_MFAP2 - ; - I $D(^TMP($J,"BPSJ-ERROR","MFE")) S FIELD="" D - . F S FIELD=$O(^TMP($J,"BPSJ-ERROR","MFE",FIELD)) Q:'FIELD D - .. S MFACNTR=MFACNTR+1 - .. S ^TMP("HLA",$J,MFACNTR)=MFAP1_"V61"_FIELD_MFAP2 - ; - I $D(^TMP($J,"BPSJ-ERROR","ZPS")) S FIELD="" D - . F S FIELD=$O(^TMP($J,"BPSJ-ERROR","ZPS",FIELD)) Q:'FIELD D - .. S MFACNTR=MFACNTR+1 - .. S ^TMP("HLA",$J,MFACNTR)=MFAP1_"V62"_FIELD_MFAP2 - ; - I $D(^TMP($J,"BPSJ-ERROR","ZPR")) S RECORD="" D - . F S RECORD=$O(^TMP($J,"BPSJ-ERROR","ZPR",RECORD)),FIELD="" Q:'RECORD D - .. F S FIELD=$O(^TMP($J,"BPSJ-ERROR","ZPR",RECORD,FIELD)) Q:'FIELD D - ... S ZPRERR=$G(^TMP($J,"BPSJ-ERROR","ZPR",RECORD,FIELD)) - ... S MFACNTR=MFACNTR+1,^TMP("HLA",$J,MFACNTR)=MFAP1_ZPRERR_MFAP2 - ; - Q -DGAPPACK ; $G the APPACK var - S APPACK("MFA",1)=$G(APPACK("MFA",1)) - S APPACK("MFA",2)=$G(APPACK("MFA",2)) - S APPACK("MFA",3)=$G(APPACK("MFA",3)) - S APPACK("MFA",4,1)=$G(APPACK("MFA",4,1)) - S APPACK("MFA",4,2)=$G(APPACK("MFA",4,2)) - S APPACK("MFA",5)=$G(APPACK("MFA",5)) - S APPACK("MFA",6)=$G(APPACK("MFA",6)) - S APPACK("MFI",1,1)=$G(APPACK("MFI",1,1)) - S APPACK("MFI",1,2)=$G(APPACK("MFI",1,2)) - S APPACK("MFI",3)=$G(APPACK("MFI",3)) - S APPACK("MFI",6)=$G(APPACK("MFI",6)) - S APPACK("MSA",1)=$G(APPACK("MSA",1)) - S APPACK("MSA",2)=$G(APPACK("MSA",2)) - Q diff -auBN ./r1/BPSJAREG.m ./r2/r/BPSJAREG.m --- ./r1/BPSJAREG.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJAREG.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,89 +0,0 @@ -BPSJAREG ;DAOU/LJF - HL7 Application Registration MFN Message ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; Reference to ^HLCS(870 supported by DBIA 4241 - ; - ; This program will process the outgoing registration MFN message - ; - ; Variables - ; HL = HL7 parameters - ; HL7DTG = Date time in HL7 format - ; HLECH = HL7 Encoding Characters - ; HLEID = HL7 Link id - ; HLFS = HL7 Field separator - ; HLLNK = HL7 E-Pharm Link - ; HLRESET = HL7 generate results - ; IPP = IP Port - ; IPA = IP Addres - ; MCT = Mesage Count - ; MGRP = E-Mail message group - ; MSG = Message - ; -INI ; -INIT ; Unconditional jump.... - G ^BPSJINIT - Q - ; -BPSJVAL(BPSJVAL) ; Validation entry point - HL7 message processing prevented - ; -TASKMAN ; Entry point for taskman to run this routine - ; - N HL,HL7DTG,HLECH,HLEID,HLFS,HLLNK,HLRESET,HLPRO - N IPA,IPP - N MGRP,MSG,MCT,BPSJARES - ; - S MCT=0,BPSJVAL=+$G(BPSJVAL) - K ^TMP("HLS",$J) - ; - ; Get Link data from HL7 table - S HLPRO="BPSJ REGISTER",HLLNK="EPHARM OUT" - S HLLNK=$O(^HLCS(870,"B",HLLNK,0)),(IPA,IPP)="" - I HLLNK]"" S IPA=$P($G(^HLCS(870,HLLNK,400)),U,1),IPP=$P($G(^(400)),U,2) - ; - ; Error if any missing data - I IPA=""!(IPP="") S MCT=MCT+1,MSG(MCT)="IP Address or Port is not defined. " - ; - I MCT,'BPSJVAL D MSG^BPSJUTL(.MSG,"BPSJAREG") Q - ; - ; Initialize the HL7 - D INIT^HLFNC2(HLPRO,.HL) - S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|" - S HLECH=$E($G(HL("ECH")),1) I HLECH="" S HLECH="^" - S HL("SITE")=$$SITE^VASITE,HL("SAF")=$P(HL("SITE"),U,2,3) - S HL("EPPORT")=IPP,HLEID=$$HLP^BPSJUTL(HLPRO) - ; - ;Get fileman date/time, ensuring seconds are included: 3031029.135636 - S HL7DTG=$E($$HTFM^XLFDT($H)_"000000",1,14) - ;Set HL7 Date/Time format: 20031029135636-0400 - S HL7DTG=$$FMTHL7^XLFDT(HL7DTG) - ; - ; Set the MFI segment - S ^TMP("HLS",$J,1)="MFI"_HLFS_"Facility Table"_HLFS_HLFS_"UPD"_HLFS - S ^TMP("HLS",$J,1)=^TMP("HLS",$J,1)_HL7DTG_HLFS_HL7DTG_HLFS_"NE" - ; - ; Set the MFE segment - S ^TMP("HLS",$J,2)="MFE"_HLFS_"MUP"_HLFS_HLFS_HL7DTG_HLFS - S ^TMP("HLS",$J,2)=^TMP("HLS",$J,2)_+HL("SITE")_HLFS_"ST" - ; - ; Set the ZQR segment - S ^TMP("HLS",$J,3)=$$^BPSJZQR(.HL) - ; - S BPSJARES=$$VAL1^BPSJVAL(BPSJVAL) ; 0 = ok, - I BPSJVAL=3 G FINI ; Just checking to see if data valid. - ; - ;-Check if msg valid. - I 'BPSJARES D G FINI - . K HLRESLT - . D GENERATE^HLMA(HLEID,"GM",1,.HLRESLT,"") - . I $P($G(HLRESLT),U,2)]"" D Q - .. I BPSJVAL D Q ; Interactive: show no success - ... W !!,"HL7 E-Pharm Application Registration Message not created: "_HLRESLT - .. S MCT=MCT+1,MSG(MCT)="HL7 E-Pharm Application Registration Message not created." - .. S MCT=MCT+1,MSG(MCT)=HLRESLT - .. D MSG^BPSJUTL(.MSG,"BPSJAREG") - . I BPSJVAL D ;Interactive: show success - .. W !!,"HL7 E-Pharm Application Registration Message sucessfully created." - ; -FINI ; Clean up - K ^TMP("HLS",$J) - Q diff -auBN ./r1/BPSJHLI.m ./r2/r/BPSJHLI.m --- ./r1/BPSJHLI.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJHLI.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,36 +0,0 @@ -BPSJHLI ;DAOU/LJF - Incoming HL7 E-PHARM messages ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ;**Program Description** - ; This program processes incoming HL7 message. - ; -EN ; Starting point - put message into a TMP global - N SEGCNT,CNT,SEGMT,EVENT,MSG,MCT,FSHLI - ; - K ^TMP($J,"BPSJHLI") S MCT=0 - F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D - . S CNT=0,^TMP($J,"BPSJHLI",SEGCNT,CNT)=HLNODE - . F S CNT=$O(HLNODE(CNT)) Q:'CNT D - .. S ^TMP($J,"BPSJHLI",SEGCNT,CNT)=HLNODE(CNT) - ; - ; Check MSH seg - S SEGMT=$G(^TMP($J,"BPSJHLI",1,0)) - S FSHLI=$G(HL("FS")) I FSHLI="" S (FS,FSHLI)=$E(SEGMT,4) - ; - I $E(SEGMT,1,3)'="MSH" D D MSG^BPSJUTL(.MSG,"BPSJHLI") G EXIT - . S MCT=MCT+1,MSG(MCT)="MSH Segment is not the first segment found" - ; - S EVENT=$P(SEGMT,FSHLI,9) - ; - ; Acknowledgement Processing - I EVENT="MFK^M01" D ^BPSJACK(.HL) G EXIT - ; - ; Table Update Processing for Payer Sheets - I EVENT="MFN^M01" D - . S HL("HLMTIENS")=$G(HLMTIENS) - . D EN^BPSJHLT(.HL) - ; -EXIT ; - K ^TMP($J,"BPSJHLI"),SEGCNT,CNT,HL,HLREC,HLNEXT,HLNODE - Q diff -auBN ./r1/BPSJHLT.m ./r2/r/BPSJHLT.m --- ./r1/BPSJHLT.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJHLT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,240 +0,0 @@ -BPSJHLT ;DAOU/LJF - HL7 Process Incoming MFN Messages ;05-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ;**Program Description** - ; This program will process incoming MFN messages and - ; update the appropriate tables - ; - ; Direct entry not allowed - Q - ; -PKY(PKYNM,PKYROOT,ADD) ;Lookup ien or add using PKYNM - N DA,DO,DIC,DIE,DINUM,DLAYGO,DTOUT,DUOUT,Y,X - I $G(PKYNM)]"",$G(PKYROOT)]"" S ADD=+$G(ADD) - E Q 0 - S X=PKYNM,DIC=PKYROOT - I 'ADD S DIC(0)="X" D ^DIC - I ADD S DIC(0)="L",DLAYGO=PKYROOT D FILE^DICN - Q +Y - ; -EN(HL) ; Entry Point - ; - N BPSJACT,BPSJPKY,BPSJADT,BPSZPRER,BPSJROOT,PSIEN,APPACK - N ZPRS,BPSJSEG,HCT,ERRFLAG,NAFLG,NPFLG,SEG,MSG,MCT,FLN,FILE - N RBSTART,RBEND,RBCNT,ZPSNNAME,ZPRCNT,BPSETID,RCODE,MAXRX - N FS,CS,PSHTVER,NCPDPVER,NCPDPCK,BPSFILE,BPSJCNT,BPSJDEVN - N BPSJPROD,BPSJNAME,DIK,TCH - ; - S FS=$G(HL("FS")) I FS="" S FS="|" ; field separator - S CS=$E($G(HL("ECH"))) I CS="" S CS="^" ; component separator - ; - K ^TMP($J,"BPSJ-RBACK"),^TMP($J,"BPSJ-ERROR") - ; - D INITZPRS^BPSJZPR(.ZPRS) - S BPSFILE=9002313.92,BPSJROOT=$$ROOT^DILFD(BPSFILE) - S RBSTART=100,RBEND=230,NCPDPCK="51" - S (ZPSNNAME,BPSJPROD,NCPDPVER,BPSJACT,BPSJADT,BPSJPKY)="" - ; - ; Initialize some Application Acknowledgement data - D DGAPPACK^BPSJACK - S APPACK("MSA",1)="AE" ; Assume error - S APPACK("MSA",2)=$G(HL("MID")) ; Message ID - S APPACK("MFA",4,1)="U" ; Set flag type of "unsuccessful event" - S APPACK("MFA",6)="ST" - S APPACK("MFI",6)="NE" - ; - ; Init encoding char array - S TCH("\F\")="|",TCH("\R\")="~" - S TCH("\E\")="\",TCH("\T\")="&" - ; - S HCT=1,(MCT,NAFLG,NPFLG,ERRFLAG,ZPRCNT,MAXRX)=0 - F D Q:'HCT I ERRFLAG Q - . K BPSJSEG S HCT=$O(^TMP($J,"BPSJHLI",HCT)) - . D SPAR^BPSJUTL(.HL,.BPSJSEG,HCT) S SEG=$G(BPSJSEG(1)) - . ; - . ; ; payer sheet detail (multiple) - . I SEG="ZPR" D Q ; Record #5+ (MSH is record #1) - .. ; - .. I ERRFLAG Q ; Fatal Error - .. S ZPRCNT=ZPRCNT+1,BPSETID=$G(BPSJSEG(2)) - .. ;-If not numeric equivalent the warp engines are offline, Captain - .. I BPSETID'=ZPRCNT D FAKEREC(ZPRCNT) - .. D EN^BPSJZPR(PSIEN,.BPSJSEG,BPSJROOT,BPSFILE) - . ; - . I SEG="MFI" D Q ; Record #2 - .. ; - .. ;-Required Field checks - .. D ERRMSG(0,"MFI","1,2,3",.BPSJSEG) - .. ; - .. S APPACK("MFI",1,1)=$P($G(BPSJSEG(2)),CS) - .. S APPACK("MFI",1,2)=$P($G(BPSJSEG(2)),CS,2) - .. I APPACK("MFI",1,1)]"",APPACK("MFI",1,2)]"" - .. E D - ... ; hard code these for Version 1.0 of s/w - ... D FILE^DID(BPSFILE,,"NAME","BPSJNAME") - ... I APPACK("MFI",1,1)="" S APPACK("MFI",1,1)=BPSFILE - ... I APPACK("MFI",1,2)="" S APPACK("MFI",1,2)=$G(BPSJNAME("NAME")) - ... K BPSJNAME - ... ; - .. S APPACK("MFI",3)=$G(BPSJSEG(4)) - . ; - . I SEG="MFE" D Q ; Record #3 - .. ; - .. ;-Required Field checks - .. D ERRMSG(0,"MFE","1,2,4,5",.BPSJSEG) - .. ; - .. S BPSJADT=$$NOW^XLFDT() - .. S (BPSJACT,APPACK("MFA",1))=$G(BPSJSEG(2)) ; Action type - .. I $L(BPSJACT)=3,"^MAD^MUP^MDC^"[(U_BPSJACT_U) - .. E D ERRMSG(1,"MFE","1^INVALID EVENT CODE") - .. ; - .. S APPACK("MFA",2)=$G(BPSJSEG(3)) ; MFN Control ID - .. ; - .. ; Old/Current Sheet name - .. S (BPSJPKY,APPACK("MFA",5))=$G(BPSJSEG(5)) - .. S APPACK("MFA",4,2)="Payer Sheet "_BPSJPKY - .. S BPSJPKY=$$DECODE^BPSJZPR(BPSJPKY,.TCH) - .. ; - .. ;-Get ien using sheet name, if one exists - .. S PSIEN=$$PKY(BPSJPKY,BPSJROOT) - .. ; - .. I PSIEN=0 D ERRMSG(91,"Fileman error") Q - .. ; - .. I PSIEN>0 D ; Exists: save current data for rollback - ... S APPACK("MFA",4,1)="P" ;Set flag type to "P"rior version - ... M ^TMP($J,"BPSJ-RBACK",PSIEN)=^BPSF(9002313.92,PSIEN) - ... ;-Kill appropriate existing Payer Sheet fields - ... F RBCNT=RBSTART:10:RBEND K ^BPSF(9002313.92,PSIEN,RBCNT) - .. ; - .. ;-Create development sheet - .. I PSIEN<0 S BPSJCNT=0 F S BPSJCNT=1+BPSJCNT D Q:PSIEN>0 - ... S BPSJDEVN="BPSJ-DEV-"_$J_"-"_BPSJCNT - ... S PSIEN=$$PKY(BPSJDEVN,BPSJROOT) ; see if dev sheet exists - ... I PSIEN>-1 S PSIEN=0 Q - ... S PSIEN=$$PKY(BPSJDEVN,BPSJROOT,1) ; add new one - .. ; - .. I PSIEN=0 D ERRMSG(92,"Fileman error") Q - .. ; - .. ;-Flag the sheet as being in development by this process - .. K DA,DIE,DR S DA=PSIEN,DIE=BPSJROOT - .. S DR="1.06////1."_$J ;FOR DEVELOPMENT - .. D ^DIE - . ; - . ;payer sheet header - . I SEG="ZPS" D Q ; Record #4 - .. ; - .. ;-Required Field checks - .. D ERRMSG(0,"ZPS","1,2,3,4,5,6,7",.BPSJSEG) - .. ; - .. ;-New sheet name, production status and Payer Sheet and NCPDP versions - .. S ZPSNNAME=$$DECODE^BPSJZPR($G(BPSJSEG(4)),.TCH) K TCH - .. I ZPSNNAME="" S ZPSNNAME=$G(BPSJPKY) - .. S BPSJPROD=$G(BPSJSEG(8)) I BPSJPROD'="P" S BPSJPROD="T" - .. S PSHTVER=$G(BPSJSEG(5)) I PSHTVER'=(PSHTVER\1) S ^TMP($J,"BPSJ-ERROR","ZPS",4)="" - .. S NCPDPVER=$G(BPSJSEG(6)) I NCPDPVER'=NCPDPCK S ^TMP($J,"BPSJ-ERROR","ZPS",5)="" - ; - I '$D(^TMP($J,"BPSJ-ERROR")) D - . S APPACK("MFA",4,1)="S" ; flag success - . S DR=".01////"_ZPSNNAME ; set the name - . S DA=PSIEN,DIE=BPSJROOT D ^DIE - . ; - . I BPSJACT="MDC" S BPSJACT=0 ;Disabled - . E D I 'BPSJACT S BPSJACT=0 - .. I BPSJPROD="P" S BPSJACT=3 ;Production - .. I BPSJPROD="T" S BPSJACT=2 ;Testing - . S DR="1.06////"_BPSJACT,DA=PSIEN,DIE=BPSJROOT D ^DIE - . ; NCPDP Version - . S DR="1.02////"_NCPDPVER,DA=PSIEN,DIE=BPSJROOT D ^DIE - . ; Payer Sheet Version - . S DR="1.14////"_PSHTVER,DA=PSIEN,DIE=BPSJROOT D ^DIE - . ; - . I BPSJACT=2 D SETTEST(ZPSNNAME,PSIEN) - . ; - E I $G(PSIEN) D ;-Roll back - . ;-Remove if no prior existance - . I $G(^TMP($J,"BPSJ-RBACK",PSIEN,0))="" D Q - .. S DIK=BPSJROOT,DA=PSIEN D ^DIK - . ; - . ; Restore old data - . S ^BPSF(9002313.92,PSIEN,0)=$G(^TMP($J,"BPSJ-RBACK",PSIEN,0)) - . S ^BPSF(9002313.92,PSIEN,1)=$G(^TMP($J,"BPSJ-RBACK",PSIEN,1)) - . F RBCNT=RBSTART:10:RBEND D - .. K ^BPSF(9002313.92,PSIEN,RBCNT) - .. M ^BPSF(9002313.92,PSIEN,RBCNT)=^TMP($J,"BPSJ-RBACK",PSIEN,RBCNT) - ; - D APPACK^BPSJACK(.HL,.APPACK,PSIEN) - ; - K ^TMP($J,"BPSJ-RBACK"),^TMP($J,"BPSJ-ERROR") - ; - Q - ; -FAKEREC(REF) ; Setup a fake Record ID (Set ID) - N IX - ; - S REF=+$G(REF) - S IX=$G(BPSJSEG(2)),BPSJSEG(2)=REF - I IX="" D Q ; Missing - . S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-1,"_REF - ; - I IX=+IX,IX'=0 - E D Q ; Invalid - . S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-2,"_REF - ; - ; We have a valid numeric to work with, but: - ; - ; Duplicate - I $G(^TMP($J,"BPSJ-ERROR","ZPR",IX))=IX D Q - . S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-4,"_REF - ; - ; Out Of Sequence - S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-3,"_REF - S ^TMP($J,"BPSJ-ERROR","ZPR",REF)=IX - ; - Q - ; -ERRMSG(SPECIAL,SEG,REQFLDS,BPSJSEG) ; - N FCNT,FNO,FIELD,C - S C=",",SPECIAL=+$G(SPECIAL),SEG=$G(SEG),REQFLDS=$G(REQFLDS) - I 'SPECIAL D Q - . ;-Evaluate required fields for non ZPR segs - . S FNO=$J(REQFLDS,C) - . F FCNT=1:1:FNO S FIELD=$P(REQFLDS,C,FCNT) I FIELD D - .. ;-Set flag for empty required field - .. I $G(BPSJSEG(FIELD+1))="" S ^TMP($J,"BPSJ-ERROR",SEG,FIELD)="" - ; - ;-"Special" handler - I SPECIAL=1 D Q - . ;-Set flag that field contains invalid value - . S ^TMP($J,"BPSJ-ERROR",SEG,+REQFLDS)=REQFLDS - ; - I SPECIAL>90 S ERRFLAG=1 - Q - ; -SETTEST(TESTNAME,TESTIX) ; Test payer sheet handler - ; Massage to look like production version - ; - N PRODNM,PCNT,PRODIX,PRODDATA,TESTDATA,REVERSE - ; - I '$G(TESTIX) Q - ; Derive production version name - ; if test version name = ABCDE-001 then Prod version name = ABCDE - S PCNT=$L($G(TESTNAME),"-")-1 I PCNT<1 Q - S PRODNM=$P(TESTNAME,"-",1,PCNT) - ; Find Production version & get data if exists - S PRODIX=$O(^BPSF(9002313.92,"B",PRODNM,"")) I 'PRODIX Q - S PRODDATA=$G(^BPSF(9002313.92,PRODIX,1)) I PRODDATA="" Q - ; Get this test version's data - S TESTDATA=$G(^BPSF(9002313.92,TESTIX,1)) - ; load test fields from production - S $P(TESTDATA,U,3)=$P(PRODDATA,U,3) ;Maximum RX's Per Claim - S $P(TESTDATA,U,7)=$P(PRODDATA,U,7) ;Is A Reversal Format - S $P(TESTDATA,U,13)=$P(PRODDATA,U,13) ;SOFTWARE VENDOR/CERT ID - S ^BPSF(9002313.92,TESTIX,1)=TESTDATA - ; Get Reversal Format pointer - S REVERSE=$G(^BPSF(9002313.92,PRODIX,"REVERSAL")) - ; Set test sheet to itself if production sheet points to itself. - I REVERSE=PRODIX S REVERSE=TESTIX - S ^BPSF(9002313.92,TESTIX,"REVERSAL")=REVERSE - ; - Q diff -auBN ./r1/BPSJINI1.m ./r2/r/BPSJINI1.m --- ./r1/BPSJINI1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJINI1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,117 +0,0 @@ -BPSJINI1 ;DAOU/LJF - HL7 Application Registration ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - Q ; No direct entry allowed - ; - ; Operating Hours - ; -EN(PHRMIX) ; - N HOURS,HROPEN,HRCLOSE,TAB,BPSJWAIT,BPSJANS,BPSJOH,DTOUT - ; - S HROPEN=$G(^BPS(9002313.56,PHRMIX,"TOPEN")) - S HRCLOSE=$G(^BPS(9002313.56,PHRMIX,"TCLOSE")) - ; initialize to standard hours or ensure hours are valid - I HROPEN="" D - . S HROPEN="^0800^0800^0800^0800^0800^0800" - . S HRCLOSE="^1600^1600^1600^1600^1600^1600" - E F BPSJOH=1:1:7 D - . I $P(HROPEN,U,BPSJOH)="" S $P(HRCLOSE,U,BPSJOH)="" Q - . I $P(HROPEN,U,BPSJOH)<$P(HRCLOSE,U,BPSJOH) Q - . S $P(HROPEN,U,BPSJOH)="",$P(HRCLOSE,U,BPSJOH)="" - ; - S BPSJWAIT=300 ; time out for questions - ; - F D Q:BPSJANS="" - . W !!,"DAILY HOURS OF OPERATION",! - . W "DAY",?16,"1-SUN",?24,"2-MON",?32,"3-TUE",?40,"4-WED",?48,"5-THU",?56,"6-FRI",?64,"7-SAT",! - . S BPSJANS=0 - . W !,"OPEN TIME" F BPSJOH=1:1:7 S TAB="?"_(BPSJOH*8+8) W @TAB,$P(HROPEN,U,BPSJOH) - . W !,"CLOSE TIME" F BPSJOH=1:1:7 S TAB="?"_(BPSJOH*8+8) W @TAB,$P(HRCLOSE,U,BPSJOH) - . S BPSJANS=$$EDITDAY(.HROPEN,.HRCLOSE) I BPSJANS="^" S BPSJANS="" - ; - S ^BPS(9002313.56,PHRMIX,"TOPEN")=HROPEN - S ^BPS(9002313.56,PHRMIX,"TCLOSE")=HRCLOSE - W ! - ; - Q - ; -EDITDAY(HROPEN,HRCLOSE) ; - ; - N BPSJDAY,BPSJT,BPSJO,BPSJC,DIR,X - ; - W ! - S DIR("A")="Enter Day to Edit" - S DIR("?")="^D DOC^BPSJINI1(0)" - S DIR(0)="NO^1:7" - D ^DIR S BPSJDAY=X ; ^,1-7,null - I '$G(DTOUT),BPSJDAY - E Q BPSJDAY ; Non-Numeric or Zero or Timed out - ; - ;OPEN TIME - F S BPSJO=$$OPENTIME Q:BPSJO=0 - ; - Q 0 - ; -OPENTIME() ; - N HH,MM,OPEN,DIR,X - ; - S DIR("?")="^D DOC^BPSJINI1(1)" - S DIR("A")="Enter Open Time (4 digit military time, C=Closed,24 for open 24 hours)" - S DIR(0)="FOU^0:4" - D ^DIR S OPEN=X - I '$G(DTOUT),$L(OPEN),$E(OPEN)'="^" - E Q 0 - ; - I $TR($E(OPEN),"c","C")="C" S $P(HROPEN,U,BPSJDAY)="",$P(HRCLOSE,U,BPSJDAY)="" Q 0 - I OPEN=24 S $P(HROPEN,U,BPSJDAY)="0000",$P(HRCLOSE,U,BPSJDAY)="2359" Q 0 - I OPEN?4N - E W !!,"INVALID TIME ENTERED" D DOC(1) Q 1 - S HH=$E(OPEN,1,2),MM=$E(OPEN,3,4) - I OPEN>-1,OPEN<2359 - E W !!,"INVALID TIME: OPEN TIME MUST BE FROM 0000 TO 2358." Q 1 - I MM>59 W !!,"INVALID TIME: MINUTES MUST FROM 00 TO 59." Q 1 - I HH>23 W !!,"INVALID TIME: HOURS MUST BE FROM 00 AND 23." Q 1 - ; - ;Close Time - F S BPSJC=$$ENDTIME Q:$L(BPSJC) - I BPSJC S $P(HROPEN,U,BPSJDAY)=OPEN,$P(HRCLOSE,U,BPSJDAY)=BPSJC - Q 0 - ; -ENDTIME() ; - N CLOSE,DIR,X - S DIR("?")="^D DOC^BPSJINI1(2)" - S DIR("A")="Enter Close Time (4 digit military time)" - S DIR(0)="FOU^4:4" - D ^DIR S CLOSE=X - I '$G(DTOUT),$L(CLOSE),$E(CLOSE)'="^" - E Q 0 - S HH=$E(CLOSE,1,2),MM=$E(CLOSE,3,4) - I MM>59 W !!,"INVALID TIME: MINUTES MUST FROM 00 TO 59." Q "" - I HH>23 W !!,"INVALID TIME: HOURS MUST BE FROM 00 AND 23." Q "" - I CLOSE>0,CLOSE<2400 - E W !!,"INVALID TIME: CLOSE TIME MUST BE FROM 0001 TO 2359." Q "" - I CLOSE<(OPEN+1) W !!,"INVALID TIME: CLOSE TIME MUST BE LATER THAN OPEN TIME." Q "" - Q CLOSE - ; -DOC(DOCIX) ; - I $G(DOCIX)="" Q - I DOCIX=0 D Q - .W !,"ENTER 1 TO INDICATE SUNDAY, 2 FOR MONDAY ... 7 FOR SATURDAY",! - .W !,"ENTER OR '^' TO EXIT." - ; - I DOCIX=1 D Q - .W !,"ENTER C TO INDICATE THE PHARMACY IS CLOSED ON THIS DAY." - .W !," (NO CLOSING TIME WILL BE REQUESTED)",! - .W !,"ENTER 24 TO INDIACTE THE PHARMACY IS OPEN FOR THE ENTIRE 24 HOURS OF THIS DAY." - .W !," (NO CLOSING TIME WILL BE REQUESTED)",! - .W !,"ENTER A MILITARY TIME FROM 0000 TO 2358." - .W !," (THIS WILL ALLOW THE PHARMACY TO BE OPEN FOR AT LEAST 1 MINUTE IF DESIRED)" - .W !," A CLOSING TIME WILL BE REQUESTED AND THE ALLOWED TIME WILL BE FROM 1 MINUTE" - .W !," AFTER OPENING TIME TO 2359.",!!! - ; - I DOCIX=2 D Q - .W !,"ENTER A MILITARY TIME FROM 0001 TO 2359." - .W !," THE CLOSING TIME MUST BE AT LEAST 1 MINUTE AFTER THE OPENING TIME, UP TO 2359.",!!! - ; - Q diff -auBN ./r1/BPSJINIT.m ./r2/r/BPSJINIT.m --- ./r1/BPSJINIT.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJINIT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,191 +0,0 @@ -BPSJINIT ;DAOU/LJF - HL7 Application Registration ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - N DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - N BPVALFN,BPSJAPPR,BPSJVALR,PHIX,DT,DUZ - ; - ; This program will allow user to enter site data. - ; - ; Programmer Note: D BPSJVAL^BPSJAREG(X) will validate with following. - ; where X is: 0 = HL7 trigger, no validation display - ; 1 = HL7 trigger, display validation - ; 2 = no HL7 trigger, display validation - ; 3 = no validation display, no HL7 trigger - ; - D DT^DICRW S DUZ(0)="@",DT=$$NOW^XLFDT - D HOME^%ZIS,CLEAR^VALM1 - W !!!,"ENTER/VERIFY SITE REGISTRATION DATA.",!! - ; - S BPVALFN=9002313.99 - ; Set Version number to 1 if not set or not an integer - S DA=$O(^BPS(BPVALFN,0)),DIE=$$ROOT^DILFD(BPVALFN) - I 'DA D - . S DA=1 - . S DR=".01////BPS SETUP #1" D ^DIE - . S DR="6003////1" D ^DIE - ; - K DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DR=$P($G(^BPS(BPVALFN,DA,"VITRIA")),U,3) - I DR,DR=+DR - E D - . I 'DR S DR=1 - . S DIE=$$ROOT^DILFD(BPVALFN),DR="6003////"_+DR D ^DIE Q - ; - W !!,"PRIMARY SITE CONTACT DATA." - K DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DIE=$$ROOT^DILFD(BPVALFN) - S DR="[BPSJ CONTACT ENTER/EDIT]" D ^DIE - ; - W !!,"ALTERNATE SITE CONTACT DATA." - K DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DIE=$$ROOT^DILFD(BPVALFN) - S DR="[BPSJ ALT CONTACT ENTER/EDIT]" D ^DIE - ; - D HOME^%ZIS,CLEAR^VALM1 - W !!!,"-- APPLICATION REGISTRATION VALIDATION RESULTS. --",!! - S BPSJVALR=-1 - D BPSJVAL^BPSJAREG(2) - S BPSJAPPR=BPSJVALR - ; - I 'BPSJAPPR W !!,"-- APPLICATION REGISTRATION DATA VALID. --",! - E D - . W !!,"** APPLICATION REGISTRATION DATA INVALID!!! **" - . W !,"** APPLICATION REGISTRATION AND PHARMACY **" - . W !,"** REGISTRATIONS WILL NOT BE SENT! **",! - ; - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DIR(0)="EO" D ^DIR I X=U Q - ; - D PHARM - I BPSJAPPR D Q - . W !!,"REGISTRATION ABORTED DUE TO INVALID SITE REGISTRATION DATA.",!! - ; - D HOME^%ZIS,CLEAR^VALM1 - W !!!,"APPLICATION REGISTRATION DATA IS VALID." - W !!,"PHARMACY REGISTRATION DATA IS:" - S PHIX=$O(^BPS(9002313.56,0)) - F Q:'PHIX D S PHIX=$O(^BPS(9002313.56,PHIX)) - . S BPSJVALR=-1 D REG^BPSJPREG(PHIX,3) - . I BPSJVALR>0 S DIR=" *INVALID",DIE=" and will NOT be transmitted." - . E S DIR=" VALID",DIE=" and will be transmitted." - . W !,DIR_" for "_$P($G(^BPS(9002313.56,PHIX,0)),U)_DIE - W ! - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DIR(0)="YEO",DIR("A")="SEND APPLICATION REGISTRATION: Y/N " D ^DIR - I $TR($E(X),"y","Y")'="Y" Q - ; - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - D BPSJVAL^BPSJAREG(0) - W !!,"APPLICATION REGISTRATION SUBMITTED." - Q - ; -PHARM ;CYCLE THROUGH PHARMACIES - ; - N DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - N BPVALFN,BPSJVALR,DT,DUZ,BPSJPHPR - ; - D DT^DICRW S DUZ(0)="@",DT=$$NOW^XLFDT - ; - S BPVALFN=9002313.56,PHIX=0 - ; - F D Q:PHIX="" - . D HOME^%ZIS,CLEAR^VALM1 - . W !!!,"ENTER/VERIFY PHARMACY REGISTRATION DATA." - . W !!,"PHARMACY SPECIFIC DATA." - . K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - . S DIC(0)="QAELM",DIC=BPVALFN,DLAYGO=DIC D ^DIC - . ; - . I X'=U,0<+Y S PHIX=+Y - . E S PHIX="" Q - . D MOD I 'PHIX Q - . D HOME^%ZIS,CLEAR^VALM1 - . W !!!,"-- PHARMACY REGISTRATION VALIDATION RESULTS. --",! - . ; - . S BPSJVALR=-1 - . D REG^BPSJPREG(PHIX,2) - . S BPSJPHPR=BPSJVALR - . ; - . I 'BPSJPHPR W !!,"-- PHARMACY REGISTRATION DATA VALID. --",! - . E D - .. W !!,"** PHARMACY REGISTRATION DATA INVALID!!! **" - .. W !,"** THIS PHARMACY'S REGISTRATION WILL NOT BE SENT! **",! - . ; - . K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - . S DIR(0)="EO",DIR("A")="Enter RETURN to continue" D ^DIR - ; - Q - ; -MOD ; - N DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - ; - ; Set hours to default if not set. - S DA=$$OPHOURS^BPSJZRP(PHIX),DR=$G(^BPS(9002313.56,PHIX,"HOURS")) - I $P(DR,U,2,5)'=DA S ^BPS(9002313.56,PHIX,"HOURS")="24"_U_DA - ; - W !!,"SITE DATA." - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN) - S DR="[BPSJ PHARMACY SITE ENTER/EDIT]" D ^DIE - ; - I '$G(DA) S PHIX=0 Q ; Pharmacy killed by user - ; - ; Pharmacy open hours - I '$D(Y) D EN^BPSJINI1(PHIX) - ; - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DIR(0)="EO" D ^DIR - ; - I X=U Q - ; - W !!,"PRIMARY CONTACT DATA." - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN) - S DR="[BPSJ PHARM CONTACT ENTER/EDIT]" D ^DIE - ; - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DIR(0)="EO" D ^DIR - ; - I X=U Q - ; - W !!,"ALTERNATE CONTACT DATA." - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN) - S DR="[BPSJ PHARM ALT CONT ENTER/EDIT]" D ^DIE - ; - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DIR(0)="EO" D ^DIR - ; - I X=U Q - ; - W !!,"PHARMACIST DATA." ; VA LEAD PHARMACIST - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN) - S DR="[BPSJ PHARMACIST ENTER/EDIT]" D ^DIE - ; - I $D(Y) Q - ; - ; VA LEAD PHARMACIST LICENSE - K DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,X,Y - S DA=PHIX,DIE=$$ROOT^DILFD(BPVALFN) - S DR="1900.04//" D ^DIE - ; - Q - ; -VALIDATE ; this will only validate the Application Registration and - ; the Pharmacy registrations - Q - N AREG - ; - D BPSJVAL^BPSJAREG(2) - ; - S DIR(0)="EO" - D ^DIR - I X=U Q - ; - S AREG="" F S AREG=$O(^BPS(9002313.56,AREG)) Q:'AREG D I X=U Q - . D REG^BPSJPREG(AREG,2) - . S DIR(0)="EO" - . D ^DIR - ; - Q diff -auBN ./r1/BPSJPHNM.m ./r2/r/BPSJPHNM.m --- ./r1/BPSJPHNM.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJPHNM.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,159 +0,0 @@ -BPSJPHNM(IX1,C,R) ;DAOU/LJF - HL7 E-Pharm Phone Number Parser ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ; Called with Person Index from VA(200 - N N13,RETVAL,RETP,IX,IX2,UC,LC,PHT,SP,C3,PHD,PHDH,FLAG,PHI - ; - I '$G(IX1) Q "" - I $G(IX1) S N13=$G(^VA(200,+IX1,.13)) - I $G(N13)="" Q "" - I $G(C)="" S C="^" - I $G(R)="" S R="~" - ; - ; Set up lowercase to UPPERCASE translation - S LC="abcdefghijklmnopqrstuvwxyz" - S UC="ABCDEFGHIJKLMNOPQRSTUVWXYZ" - S SP=" ",C3=C_C_C - ; - S PHT(1)=C_"PRN"_C_"PH"_C3 ; home phone - S PHT(2)=C_"WPN"_C_"PH"_C3 ; work phone - S PHT(3)=C_"WPN"_C_"PH"_C3 ; 3rd phone - S PHT(4)=C_"WPN"_C_"PH"_C3 ; 4th phone - S PHT(5)=C_"WPN"_C_"PH"_C3 ; Commercial phone - S PHT(6)=C_"WPN"_C_"FX"_C3 ; Fax Number - S PHT(7)=C_"BPN"_C_"BP"_C3 ; Voice Pager Number - S PHT(8)=C_"BPN"_C_"BP"_C3 ; Digital Pager Number - S (PHI(9),PHI(9,1),PHI(9,2),PHI(9,3),PHI(9,4),PHI(9,5))="" - ; - K PHD M PHD=PHI S PHD=$G(^VA(200,IX1,.13)) I $TR(PHD,"^ ")="" Q "" - S PHD(10)=PHD - ; Trim leading and trailing spaces from each piece - F IX2=1:1:8 D - . I $TR($P(PHD,U,IX2),SP)="" S $P(PHD,U,IX2)="" Q - . S PHDH=$P(PHD,U,IX2) - . S $P(PHDH,$E($TR(PHDH,SP)))="" ; remove leading spaces - . S PHDH=$RE(PHDH),$P(PHDH,$E($TR(PHDH,SP)))="",PHDH=$RE(PHDH) ; remove trailing spaces - . ; remove duplicate work numbers - . I IX2>1,IX2<6 D Q - . . I $G(PHD(11,PHDH)) S $P(PHD,U,IX2)="" - . . E S PHD(11,PHDH)=IX2 S $P(PHD,U,IX2)=PHDH - . S $P(PHD,U,IX2)=PHDH - S PHD(10)=PHD - ; - ; Massage pagers into pieces 7&8 - F IX2=1:1:6 S PHDH=$P(PHD,U,IX2),FLAG="" I PHDH]"" D - . I PHDH["BEEPER" D - . . S FLAG="1"_$P(PHDH,"BEEPER",2,99),PHDH=$P(PHDH,"BEEPER") - . I PHDH["BEEP" D - . . S FLAG="1"_$P(PHDH,"BEEP",2,99),PHDH=$P(PHDH,"BEEP") - . I PHDH["BP#" D - . . S FLAG="1"_$P(PHDH,"BP#",2,99),PHDH=$P(PHDH,"BP#") - . I PHDH["BP #" D - . . S FLAG="1"_$P(PHDH,"BP #",2,99),PHDH=$P(PHDH,"BP #") - . I PHDH["BP " D - . . S FLAG="1"_$P(PHDH,"BP ",2,99),PHDH=$P(PHDH,"BP ") - . I PHDH["BP" D - . . S FLAG="1"_$P(PHDH,"BP",2,99),PHDH=$P(PHDH,"BP") - . I FLAG D - . . S $P(PHD,U,IX2)=PHDH,$E(FLAG)="" - . . I $P(PHD,U,8)="" S $P(PHD,U,8)=FLAG Q - . . I $P(PHD,U,7)="" S $P(PHD,U,7)=FLAG Q - . . S $P(PHD,U,8)=$P(PHD,U,8)_" BP#"_FLAG - ; - F IX2=1:1:8 S PHD(IX2)=$P(PHD,U,IX2),PHD(IX2,1)="" I PHD(IX2)]"" D - . S PHD(IX2,1)=$$RESOLVEP(PHD(IX2)) - . ;Init flag fields then load flags - . M PHD(IX2,9)=PHD(9) - ; - S RETVAL="",RETP=0 - F IX2=1:1:8 D - . I '$L(PHD(IX2)) Q - . I '$L(PHD(IX2,1)) S $P(PHD(IX2,1),U,4)=PHD(IX2) - . S PHD(IX2,1)=PHT(IX2)_PHD(IX2,1) - . S RETP=RETP+1,$P(RETVAL,R,RETP)=PHD(IX2,1) - . Q - Q RETVAL - ; -RESOLVEP(PH) ; - ; - N WPA,WPN,WPNH,STDN,WPT,IX,STDN,PREFIX - ; - S WPT=$TR(PH,LC,UC),PREFIX=0 - S $P(WPN,SP,$L(WPT))=SP,WPA=WPN - ; - ; Separate numerics from text - F IX=1:1:$L(WPT) D - . I '$E(WPT,IX),$E(WPT,IX)'=0 S $E(WPA,IX)=$E(WPT,IX) - . E S $E(WPN,IX)=$E(PH,IX) - ; Quit if no numerics - I '$L($TR(WPN,SP)) Q "" - ; - S WPNH=WPN ; save a copy of the numeric data - ; - S $P(WPN,$E($TR(WPN,SP)))="" ; remove leading spaces - S WPN=$RE(WPN),$P(WPN,$E($TR(WPN,SP)))="",WPN=$RE(WPN) ; remove trailing spaces - ; Reduce multiple spaces to single spaces - F IX=$L(WPN):-1:1 I ($E(WPN,IX,IX+1)=(SP_SP)) S $E(WPN,IX)="" - ; - ; WPN contains only NUMBERS and SPACES at this point - ; check if it is preceeded by a 1 as in "1 800 345 9933" - I $E(WPN,1,2)="1 " S $E(WPN,1,2)="",PREFIX=2 - I 'PREFIX,$E(WPN)=1 S $E(WPN)="",PREFIX=1 - ; check if it's a standard 10 digit number - S STDN=0 - I $L($TR(WPN,SP))=10 S STDN=1 D - . I $L(WPN)=10 D I STDN=1 Q ; format: 1234567890 - . . S WPN(1)=$E(WPN,1,3),WPN(2)=$E(WPN,4,6),WPN(3)=$E(WPN,7,10) - . . I PH[WPN(1),PH[WPN(2),PH[WPN(3) - . . E S STDN=0 - . S STDN=1 - . I $L(WPN,SP)=3 D I STDN Q ; format: 123 456 7890 - . . S WPN(1)=$P(WPN,SP,1),WPN(2)=$P(WPN,SP,2),WPN(3)=$P(WPN,SP,3) - . . I $L(WPN(1))=3,PH[WPN(1),$L(WPN(2))=3,PH[WPN(2),$L(WPN(3))=4,PH[WPN(3) - . . E S STDN=0 - . S STDN=1 - . I $L(WPN,SP)=2 D I STDN=1 Q ; Still may be salvageable - . . S WPN(1)=$P(WPN,SP,1),WPN(2)=$P(WPN,SP,2) - . . ; is format "123 4567890"? area code & city/phone - . . I $L(WPN(1))=3 S WPN(3)=$E(WPN(2),4,7),$E(WPN(2),4,7)="" Q - . . ; is format "123456 7890"? area/city code & phone - . . I $L(WPN(1))=6 S WPN(3)=WPN(2),WPN(2)=$E(WPN(1),4,6),$E(WPN(1),4,6)="" Q - . . S STDN=0 ;unsalvagable as standard number - . S STDN=0 ;unsalvagable as standard number - ; - ; Quit if standard format - I STDN Q WPN(1)_WPN(2)_C_WPN(3) - ; - ;Not standard, need to do some work - ; - F IX=1:1:$L(WPN,SP) S WPN(IX)=$P(WPN,SP,IX) - S IX=$L(WPN,SP),WPN(0)="" - ; - ; add prefix back in if applicable - I PREFIX=1,$L(WPN(1))'=10 S WPN(1)="1"_WPN(1) - ; - ; 1 string of digits - I IX=1 D Q:$L(WPN(0)) WPN(0) - . I $L(WPN(1))<7 S WPN(0)=C_C_WPN(1) Q ;assume it's an extension - . I $L(WPN(1))=7 S WPN(0)=$E(WPN(1),1,3)_C_$E(WPN(1),4,7) Q ;city code & local number - ; - ; 2 strings of digits - I IX=2 D Q:$L(WPN(0)) WPN(0) - . ; could be city code & local number - . I $L(WPN(1))=3,$L(WPN(2))=4 S WPN(0)=WPN(1)_C_WPN(2) Q - . ; could be full number plus extension - . I $L(WPN(1))=10 S WPN(0)=$E(WPN(1),1,6)_C_$E(WPN(1),7,10)_C_WPN(2) - ; - ; 3 strings could include extension - I IX=3 D Q:$L(WPN(0)) WPN(0) - . ; "301 7933124 123" - . I $L(WPN(1))=3,$L(WPN(2))=7 S WPN(0)=WPN(1)_$E(WPN(2),1,3)_C_$E(WPN(2),4,7)_C_WPN(3) Q - . ; "793 3124 123" - . I $L(WPN(1))=3,$L(WPN(2))=4 S WPN(0)=WPN(1)_C_WPN(2)_C_WPN(3) - ; - ; 4 strings could include extension "301 344 2111 3424 - I IX=4 D Q:$L(WPN(0)) WPN(0) - . I $L(WPN(1))=3,$L(WPN(2))=3,$L(WPN(3))=4 S WPN(0)=WPN(1)_WPN(2)_C_WPN(3)_C_WPN(4) - ; - Q "" diff -auBN ./r1/BPSJPREG.m ./r2/r/BPSJPREG.m --- ./r1/BPSJPREG.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJPREG.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,90 +0,0 @@ -BPSJPREG ;DAOU/LJF - HL7 Registration MFN Message ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; Reference to ^HLCS(870 supported by DBIA 4241 - ; - ;**Program Description** - ; This program will process the outgoing registration MFN message - ; - ; Variable - ; HL = HL7 parameters - ; HL7DTG = Date time in HL7 format - ; HLECH = HL7 Encoding Characters - ; HLEID = HL7 Link id - ; HLFS = HL7 Field separator - ; HLLNK = HL7 E-Pharm Link - ; HLRESET = HL7 generate results - ; IPP = IP Port - ; IPA = IP Addres - ; MCT = Mesage Count - ; MGRP = E-Mail message group - ; MSG = Message - ; - ; Don't allow direct execution - ; - W !!!,"DIRECT ENTRY NOT ALLOWED",!!! - Q - ; -REG(PHARMIX,BPSJVAL) ; Registration message for when a site installs - ; - N HL,HL7DTG,HLECH,HLEID,HLFS,HLLNK,HLPRO,HLRESLT,IPA,IPP - N MGRP,MCT,MSG,TAXID,ZRPSEG,BPSJVAL2,BPSJPRES - ; - S (MCT,TAXID)=0,BPSJVAL=$G(BPSJVAL) - ; - I '$G(PHARMIX) Q - K ^TMP("HLS",$J) - ; - ; Get Link data from HL7 table - S HLPRO="BPSJ REGISTER",HLLNK="EPHARM OUT" - S HLLNK=$O(^HLCS(870,"B",HLLNK,0)),(IPA,IPP)="" - I HLLNK]"" S IPA=$P($G(^HLCS(870,HLLNK,400)),U,1),IPP=$P($G(^(400)),U,2) - ; - ; Error if any missing data - I IPA=""!(IPP="") S MCT=MCT+1,MSG(MCT)="IP Address or Port is not defined. " - ; - ; Initialize the HL7 - D INIT^HLFNC2(HLPRO,.HL) - S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|" - S HLECH=$E($G(HL("ECH"),1)) I HLECH="" S HLECH="^" - S HL("SITE")=$$SITE^VASITE,HL("SAF")=$P(HL("SITE"),U,2,3) - S HL("EPPORT")=IPP,HLEID=$$HLP^BPSJUTL(HLPRO) - ; - ;Get fileman date/time, ensuring seconds are included: 3031029.135636 - S HL7DTG=$E($$HTFM^XLFDT($H)_"000000",1,14) - ;Set HL7 Date/Time format: 20031029135636-0400 - S HL7DTG=$$FMTHL7^XLFDT(HL7DTG) - ; - ; Set the ZRP Segment - D ^BPSJZRP(.HL,PHARMIX,.TAXID,.ZRPSEG) - M ^TMP("HLS",$J,3)=ZRPSEG K ZRPSEG - ; - ; Set the MFE segment - S ^TMP("HLS",$J,2)="MFE"_HLFS_"MUP"_HLFS_HLFS_HL7DTG - S ^TMP("HLS",$J,2)=^TMP("HLS",$J,2)_HLFS_TAXID_HLFS_"ST" - ; - ; Set the MFI segment - S ^TMP("HLS",$J,1)="MFI"_HLFS_"Pharmacy Table"_HLFS_HLFS_"UPD"_HLFS - S ^TMP("HLS",$J,1)=^TMP("HLS",$J,1)_HL7DTG_HLFS_HL7DTG_HLFS_"NE" - ; - S BPSJPRES=$$VAL2^BPSJVAL(BPSJVAL) ; 0 = ok - I BPSJVAL=3 G FINI ; Just checking to see if data valid. - ; - ;-Check if msg valid. - I 'BPSJPRES D G FINI - . K HLRESLT - . D GENERATE^HLMA(HLEID,"GM",1,.HLRESLT,"") - . I $P($G(HLRESLT),U,2)]"" D Q - .. I BPSJVAL D Q ; Interactive: show no success - ... W !!,"HL7 E-Pharm Pharmacy Registration Message not created: "_HLRESLT - ... W !," PHARMIX: "_PHARMIX_"" - .. S MCT=MCT+1,MSG(MCT)="HL7 E-Pharm Pharmacy Registration Message not created. (PHARMIX: "_PHARMIX_")" - .. S MCT=MCT+1,MSG(MCT)=HLRESLT - .. D MSG^BPSJUTL(.MSG,"BPSJAREG") - . I BPSJVAL D ;Interactive: show success - .. W !!,"HL7 E-Pharm Pharmacy Registration Message sucessfully created." - ; - ; -FINI ; Clean up - K ^TMP("HLS",$J) - Q diff -auBN ./r1/BPSJUTL1.m ./r2/r/BPSJUTL1.m --- ./r1/BPSJUTL1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJUTL1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,52 +0,0 @@ -BPSJUTL1 ;DAOU/DB - e-Pharmacy Utils ;18-JAN-2004 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; Special Code for WebMD Test - ; WBTESTB1 - Billing - ; WBTESTB2 - Reversal - ; Tags are 'FLD'__<'B' (billing) or 'R' (reversal)> -FLD402B ; - S BPS("X")=$G(BPS("X")) I $G(BPS(9002313.0201))="" Q - I BPS("RX",BPS(9002313.0201),"RX IEN")=401944 S BPS("X")=7 - I BPS("RX",BPS(9002313.0201),"RX IEN")=401959 S BPS("X")=1 - I BPS("RX",BPS(9002313.0201),"RX IEN")=401974 S BPS("X")=2 - I BPS("RX",BPS(9002313.0201),"RX IEN")=401976 S BPS("X")=3 - I BPS("RX",BPS(9002313.0201),"RX IEN")=401958 S BPS("X")=4 - ;??? - I BPS("X")="" S BPS("X")=BPS("RX",BPS(9002313.0201),"RX IEN") - I BPS("RX",BPS(9002313.0201),"RX IEN")'=401944 S BPS("X")=BPS("RX",BPS(9002313.0201),"RX IEN") - Q - ; -FLD408B ; - S BPS("X")=0 I $G(BPS(9002313.0201))="" Q - I BPS("RX",BPS(9002313.0201),"RX IEN")=401944 S BPS("X")="1" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401959 S BPS("X")="1" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401974 S BPS("X")="1" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401976 S BPS("X")="0" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401958 S BPS("X")="1" - Q - ; -FLD419B ; - S BPS("X")=0 I $G(BPS(9002313.0201))="" Q - I BPS("RX",BPS(9002313.0201),"RX IEN")=401944 S BPS("X")="1" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401959 S BPS("X")="1" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401974 S BPS("X")="2" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401976 S BPS("X")="1" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401958 S BPS("X")="1" - Q - ; -FLD420B ; - S BPS("X")="00" I $G(BPS(9002313.0201))="" Q - I BPS("RX",BPS(9002313.0201),"RX IEN")=401944 S BPS("X")="03" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401959 S BPS("X")="00" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401974 S BPS("X")="04" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401976 S BPS("X")="03" - I BPS("RX",BPS(9002313.0201),"RX IEN")=401958 S BPS("X")="00" - Q - ; -FLD433B ; - S BPS("X")=10.0 I $G(BPS(9002313.0201))="" Q - I BPS("RX",BPS(9002313.0201),"RX IEN")=401974 S BPS("X")=5.0 - I BPS("RX",BPS(9002313.0201),"RX IEN")=401976 S BPS("X")=5.0 - I BPS("RX",BPS(9002313.0201),"RX IEN")=401958 S BPS("X")=5.0 - Q diff -auBN ./r1/BPSJUTL.m ./r2/r/BPSJUTL.m --- ./r1/BPSJUTL.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJUTL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,98 +0,0 @@ -BPSJUTL ;DAOU/LJF - e-Pharmacy Utils ;16-OCT-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - Q - ; -HLP(PROTOCOL) ; Find the Protocol IEN - Q +$O(^ORD(101,"B",PROTOCOL,0)) - ; -VAHL7ECH(HL) ; Hl7 Encoding Characters - S FS=$G(HL("FS")) I FS="" S FS="|" - S ECH=$G(HL("ECH")) I ECH="" S ECH="^~\&" - S CPS=$E(ECH),REP=$E(ECH,2) - ; - Q - ; -MSG(BPSJMM,BPSJRTN) ; Message Handler - ; - N XMDUZ,XMSUB,XMY,XMTEXT,BPMSJMG - ; - I $G(U)="" S U="^" - I $G(BPSJRTN)]"" S BPSJMM(.0001)="Source Program: "_BPSJRTN - S BPMSJMG=$O(^BPS(9002313.99,0)) Q:'BPMSJMG - S BPMSJMG=+$G(^BPS(9002313.99,BPMSJMG,"VITRIA")) Q:'BPMSJMG - S BPMSJMG=$G(^VA(200,BPMSJMG,.15)) Q:BPMSJMG="" - S XMY(BPMSJMG)="",XMTEXT="BPSJMM(",XMSUB="E-PHARM MESSAGE" - D ^XMD - ; - Q - ; -VA200NM(VAIX,VATITLE,HL) ; - ; - N RETDATA,NMDATA - N FS,CPS,REP - ; - I '$G(VAIX) Q "" - S NMDATA=$P($G(^VA(200,VAIX,0)),U,1) I NMDATA="" Q "" - ; - D VAHL7ECH(.HL) - D STDNAME^XLFNAME(.NMDATA,"C") - ; - S RETDATA=$G(NMDATA("FAMILY")) ;1 - S RETDATA=RETDATA_CPS_$G(NMDATA("GIVEN")) ;2 - S RETDATA=RETDATA_CPS_$G(NMDATA("MIDDLE")) ;3 - S RETDATA=RETDATA_CPS_$G(NMDATA("SUFFIX")) ;4 - S RETDATA=RETDATA_CPS_$G(NMDATA("PREFIX")) ;5 - S RETDATA=RETDATA_CPS_$G(NMDATA("DEGREE")) ;6 - ; - S VATITLE=$P($G(^VA(200,VAIX,0)),U,9) - I VATITLE S VATITLE=$G(^DIC(3.1,VATITLE,0)) - ; - Q RETDATA - ; -VA20013(VAIX,HL) ; Build the HL7 Contact Means data field - ; - N FDATA,RETDATA - N FS,CPS,REP - ; - I '$G(VAIX) Q "" - ; VAIX is the index to ^VA(200,n - D VAHL7ECH(.HL) - S RETDATA=$P($G(^VA(200,VAIX,.15)),U,1) ; LJF@DAOU.COM - I RETDATA]"",RETDATA["@" S RETDATA=CPS_"NET"_CPS_"INTERNET"_CPS_RETDATA - S FDATA=$$^BPSJPHNM(VAIX,CPS,REP) - I $L(FDATA) D - . I $L(RETDATA) S RETDATA=RETDATA_REP - . S RETDATA=RETDATA_FDATA - Q RETDATA - ; -ENCODE(INSTR,TCH) ; Encode data - Primarily HL7 - N X,WCHR,OSTR - S OSTR="" - I $G(INSTR)]"" F X=1:1:$L(INSTR) D S OSTR=OSTR_WCHR - . S WCHR=$E(INSTR,X) I $D(TCH(WCHR)) S WCHR=TCH(WCHR) - Q OSTR - ; -SPAR(HL,BPSJSEG,HCTS) ; Segment Parsing - N II,IJ,IK,ISDATA - N FS,CPS,REP,ECH - ; - I '$G(HCTS) Q - ; - D VAHL7ECH(.HL) - M ISDATA=^TMP($J,"BPSJHLI",HCTS) - S IK=0,IJ=1,II="" - F S II=$O(ISDATA(II)) Q:II="" D - . S ISDATA=$G(ISDATA(II)) Q:ISDATA="" - . F D Q:ISDATA="" - . . S IK=IK+1,BPSJSEG(IJ,IK)=$P(ISDATA,FS) - . . S $P(ISDATA,FS)="" - . . I $E(ISDATA)=FS S IJ=IJ+1,$E(ISDATA)="" - ; - ; Promote data in 1st subnode and kill subnode - S II="" - F S II=$O(BPSJSEG(II)) Q:II="" D - . S IJ=$O(BPSJSEG(II,"")) Q:'IJ - . S BPSJSEG(II)=BPSJSEG(II,IJ) K BPSJSEG(II,IJ) - Q diff -auBN ./r1/BPSJVAL1.m ./r2/r/BPSJVAL1.m --- ./r1/BPSJVAL1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJVAL1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,117 +0,0 @@ -BPSJVAL1 ;DAOU/LJF - Pharmacy Application Validation ;2004-03-01 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; Reference to ^HLCS(870 supported by DBIA 4241 - ; Reference to ^DIC(4.2 supported by DBIA 248 - ; - N BPSJVAL1,VERBOSE - D DT^DICRW D HOME^%ZIS,CLEAR^VALM1 - W !!!,"SITE REGISTRATION VALIDATION.",! - D BPSJVAL^BPSJAREG(2) - W !!!! - ; - Q - ; -VALIDATE ; Validate ZQR Data - ; - N SEG,SEGIX,ZQR,RIX,PIX,PIXL,SEGDAT,ZNOTE,ZMAX - N HL7EINM,HL7EONM,HL7EIIP,HL7EOIP,HL7EDOM - N HL7VINM,HL7VONM,HL7VIIP,HL7VOIP,HL7PDOM - N HL7PORT,HL7OPORT - S HL7PORT=5105,ZMAX=8 - ; - S RETCODE=+$G(RETCODE) - S ZQR="",RIX=0 - ; - S HL7EINM="EPHARM IN",HL7VINM="IIV SERVER" ; IIV SERVER -> EPHARM IN - S HL7EONM="EPHARM OUT",HL7VONM="IIV EC" ; IIV EC -> EPHARM OUT - S HL7PDOM="EPHARMACY.VITRIA-EDI.AAC.VA.GOV" - ; - ; Vitria Domain name - S (HL7EOIP,HL7OPORT)=$O(^HLCS(870,"B",HL7EONM,"")) - S HL7EDOM=$P($G(^HLCS(870,HL7EOIP,0)),U,7) - I HL7EDOM S HL7EDOM=$P($G(^DIC(4.2,HL7EDOM,0)),U) - I HL7EDOM=HL7PDOM S ZNOTE=" DOMAIN NAME - Required - VALID: "_HL7PDOM - E D - . I HL7EDOM="" S ZNOTE="** DOMAIN NAME - Required - INVALID" S RETCODE=.3 Q - . S ZNOTE=" * WARNING: EXPECTED DOMAIN NAME: "_HL7PDOM_" CURRENT DOMAIN NAME: "_HL7EDOM - S RETCODE(.3)=ZNOTE - I +$G(VERBOSE) W !,RETCODE(.3) - ; - S HL7EIIP=$O(^HLCS(870,"B",HL7EINM,"")) - S HL7VIIP=$O(^HLCS(870,"B",HL7VINM,"")) - S HL7VOIP=$O(^HLCS(870,"B",HL7VONM,"")) - ; Get IP addresses - I HL7EIIP S HL7EIIP=$P($G(^HLCS(870,HL7EIIP,400)),U) - I HL7EOIP S HL7EOIP=$P($G(^HLCS(870,HL7EOIP,400)),U) - I HL7VIIP S HL7VIIP=$P($G(^HLCS(870,HL7VIIP,400)),U) - I HL7VOIP S HL7VOIP=$P($G(^HLCS(870,HL7VOIP,400)),U) - ; - I HL7EIIP,HL7EIIP=HL7VIIP S ZNOTE=" TCP/IP ADDRESS FOR ""EPHARM IN"" - Required - VALID: "_HL7EIIP - E D - . I 'HL7EIIP S ZNOTE="** TCP/IP ADDRESS FOR ""EPHARM IN"" - Required - INVALID",RETCODE=.5 Q - . I HL7VIIP,HL7EIIP'=HL7VIIP S ZNOTE=" * WARNING: ""EPHARM IN"" TCP/IP ADDRESS IS DIFFERENT THAN ""IIV SERVER"" TCP/IP ADDRESS. EPHARM IN: "_HL7EIIP_" IIV SERVER: "_HL7VIIP - S RETCODE(.5)=ZNOTE - I +$G(VERBOSE) W !,RETCODE(.5) - ; - I HL7EOIP,HL7EOIP=HL7VOIP S ZNOTE=" TCP/IP ADDRESS FOR ""EPHARM OUT"" - Required - VALID: "_HL7EOIP - E D - . I 'HL7EOIP S ZNOTE="** TCP/IP ADDRESS FOR ""EPHARM OUT"" - Required - INVALID",RETCODE=.7 Q - . I HL7VOIP,HL7EOIP'=HL7VOIP S ZNOTE=" * WARNING: ""EPHARM OUT"" TCP/IP ADDRESS DIFFERENT THAN ""IIV EC"" TCP/IP ADDRESS. EPHARM OUT: "_HL7EOIP_" IIV EC: "_HL7VOIP - S RETCODE(.7)=ZNOTE - I +$G(VERBOSE) W !,RETCODE(.7) - ; - ; Get Outgoing Port and IP Address - S HL7OPORT=$P($G(^HLCS(870,HL7OPORT,400)),U,2) - I HL7OPORT,HL7OPORT=HL7PORT S ZNOTE=" ""EPHARM OUT"" PORT NUMBER - Required - VALID: "_HL7OPORT - E D - . S ZNOTE=" * WARNING: EXPECTED ""EPHARM OUT"" PORT NUMBER: "_HL7PORT - . S ZNOTE=ZNOTE_" CURRENT " - . S ZNOTE=ZNOTE_"""EPHARM OUT"" PORT NUMBER: "_HL7OPORT - . I 'HL7OPORT S ZNOTE="** ""EPHARM OUT"" PORT NUMBER - Required - INVALID",RETCODE=.9 Q - S RETCODE(.9)=ZNOTE - I +$G(VERBOSE) W !,RETCODE(.9) - ; - F SEGIX=3:1 S SEG=$G(^TMP("HLS",$J,SEGIX)),PIX=0 Q:SEG="" D - . I $E(SEG,1,3)="ZQR" S ZQR=$E(SEG,4) S $E(SEG,1,4)="" - . I ZQR="" Q - . S PIXL=$L(SEG,ZQR) - . F S RIX=RIX+1,PIX=PIX+1 Q:RIX>ZMAX D - .. S RETCODE(RIX)=$P(SEG,ZQR,PIX) D @RIX - .. I +$G(VERBOSE),$L($G(RETCODE(RIX))) W !,RETCODE(RIX) Q - ; - Q - ; NS=Not Supported, R=Required, RE=Required or empty, C=Conditional - ; CE=Conditional or empty, O=Optional, - ; -1 ; Set ID - NS - Q -2 ; Site Number - R - S ZNOTE=" SITE NUMBER - Required - VALID: "_RETCODE(RIX) - I RETCODE(RIX)="" S ZNOTE="** SITE NUMBER - Required - INVALID",RETCODE=2 - S RETCODE(RIX)=ZNOTE - Q -3 ; Interface Version - R - ; Must equal 1 for this validation version - S ZNOTE=" INTERFACE VERSION - Required - VALID: " - I RETCODE(RIX)'=1 S ZNOTE="** INTERFACE VERSION - Required - INVALID: ",RETCODE=3 - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -4 ; Port Number - R - S ZNOTE=" ""EPHARM IN"" PORT NUMBER - Required - VALID: " - I RETCODE(RIX)="" S ZNOTE="** ""EPHARM IN"" PORT NUMBER - Required - INVALID",RETCODE=4 - E I RETCODE(RIX)'=5105 S ZNOTE=" * WARNING: EXPECTED ""EPHARM IN"" LINK PORT# 5105, LINK SET TO PORT# " - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -5 ; Contact Name - S RETCODE(RIX)=" CONTACT NAME - VALID: "_RETCODE(RIX) - Q -6 ; Contact Means - S RETCODE(RIX)=" CONTACT MEANS - VALID: "_RETCODE(RIX) - Q -7 ; Alternate Contact NAME - S RETCODE(RIX)=" ALTERNATE CONTACT NAME - VALID: "_RETCODE(RIX) - Q -8 ; Alternate Contact Means - S RETCODE(RIX)=" ALTERNATE CONTACT MEANS - VALID: "_RETCODE(RIX) - Q diff -auBN ./r1/BPSJVAL2.m ./r2/r/BPSJVAL2.m --- ./r1/BPSJVAL2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJVAL2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,152 +0,0 @@ -BPSJVAL2 ;DAOU/LJF - Validate Pharmacy data ;2004-03-01 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - N PHARMIX,RET,DIR,X - ; - S PHARMIX=0,X="" - F S PHARMIX=$O(^BPS(9002313.56,PHARMIX)) Q:'PHARMIX D Q:X=U - . D DT^DICRW,HOME^%ZIS,CLEAR^VALM1 - . W !!,"VERIFY PHARMACY REGISTRATIONS DATA.",! - . D REG^BPSJPREG(PHARMIX,2) - . W ! - . S DIR(0)="EO" D ^DIR - ; - Q - ; -VALIDATE ; - N SEG,SEGIX,ZRP,RAY,RIX,PIX,PIXL,SEGDAT,ZNOTE,ZMAX,CPS,FS,REP - N VALDATA - S ZMAX=16 - ; - S RETCODE=$G(RETCODE) - S ZRP="",RIX=0 - ; - ; Set HL7 Delimiters - use standard defaults if none provided - S FS=$G(HL("FS")) I FS="" S FS="|" - S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^" - S REP=$E($G(HL("ECH")),2) I REP="" S REP="~" - ; - F SEGIX=3:1 S SEG=$G(^TMP("HLS",$J,SEGIX)),PIX=0 Q:SEG="" D I ZRP]"" Q - . I $E(SEG,1,3)="ZRP" S ZRP=$E(SEG,4) S $E(SEG,1,4)="" - I ZRP="" Q - F S RIX=$O(^TMP("HLS",$J,SEGIX,RIX)) Q:'RIX I RIX<(ZMAX+1) D - . S RETCODE(RIX)=$P($G(^TMP("HLS",$J,SEGIX,RIX)),ZRP) D @RIX - . I +$G(VERBOSE),$L($G(RETCODE(RIX))) W !,RETCODE(RIX) Q - ; - Q - ; - ; NS=Not Supported, R=Required, RE=Required or empty, C=Conditional - ; CE=Conditional or empty, O=Optional, - ; -1 ; Set ID - NS - Q -2 ; NABP Number - R - S ZNOTE=" NABP NUMBER - Required - VALID" - I RETCODE(RIX)="" S ZNOTE="** NABP NUMBER - Required - INVALID",RETCODE=2 - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -3 ; PHARMACY NAME - R - S ZNOTE=" PHARMACY NAME - Required - VALID" - I RETCODE(RIX)="" S ZNOTE="** PHARMACY NAME - Required - INVALID",RETCODE=3 - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -4 ; DEA Number - R - S ZNOTE=" DEA NUMBER - Required - VALID" - I RETCODE(RIX)="" S ZNOTE="** DEA NUMBER - Required - INVALID",RETCODE=4 - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -5 ; Hour of Operation - S ZNOTE=" HOURS OF OPERATION - VALID" - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -6 ; Mailing Address - R - S ZNOTE=$$TRIMTAIL(RETCODE(RIX)) - S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Street address - S VALDATA=($L($P(ZNOTE,CPS,3))<1)+VALDATA ; City - S VALDATA=($L($P(ZNOTE,CPS,4))<1)+VALDATA ; State - S VALDATA=($L($P(ZNOTE,CPS,5))<1)+VALDATA ; Zip - S ZNOTE=" MAILING ADDRESS - Required - VALID" - I VALDATA S ZNOTE="** MAILING ADDRESS - Required - INVALID",RETCODE=6 - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -7 ; Remittance Address - R - S ZNOTE=$$TRIMTAIL(RETCODE(RIX)) - S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Street Address - S VALDATA=($L($P(ZNOTE,CPS,3))<1)+VALDATA ; City - S VALDATA=($L($P(ZNOTE,CPS,4))<1)+VALDATA ; State - S VALDATA=($L($P(ZNOTE,CPS,5))<1)+VALDATA ; Zip - S ZNOTE=" REMITTANCE ADDRESS - Required - VALID" - I VALDATA S ZNOTE="** REMITTANCE ADDRESS - Required - INVALID",RETCODE=7 - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -8 ; Contact Name - S ZNOTE=$$TRIMTAIL(RETCODE(RIX)) - S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname - S ZNOTE=" CONTACT NAME - Required - VALID" - I VALDATA S ZNOTE="** CONTACT NAME - Required - INVALID",RETCODE=8 - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -9 ; Contact Title - S ZNOTE=" CONTACT TITLE - VALID" - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -10 ; Contact means - S ZNOTE=" CONTACT MEANS - VALID" - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -11 ; Alternate Contact Name - S ZNOTE=$$TRIMTAIL(RETCODE(RIX)) - S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname - S ZNOTE=" ALTERNATE CONTACT NAME - Required - VALID" - I VALDATA S ZNOTE="** ALTERNATE CONTACT NAME - Required - INVALID",RETCODE=11 - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -12 ; Alternate Contact Title - S ZNOTE=" ALTERNATE CONTACT TITLE - VALID" - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -13 ; Alternate Contact means - S ZNOTE=" ALTERNATE CONTACT MEANS - VALID" - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -14 ; Lead Pharmacist Name - R - S ZNOTE=$$TRIMTAIL(RETCODE(RIX)) - S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname - S ZNOTE=" LEAD PHARMACIST NAME - Required - VALID" - I VALDATA S ZNOTE="** LEAD PHARMACIST NAME - Required - INVALID",RETCODE=14 - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -15 ; Lead Pharmacist Title - S ZNOTE=" LEAD PHARMACIST TITLE - VALID" - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q -16 ; Lead Pharmacist License Number - S ZNOTE=" LEAD PHARMACIST LICENSE NUMBER - VALID" - I RETCODE(RIX)]"" S RETCODE(RIX)=": "_RETCODE(RIX) - S RETCODE(RIX)=ZNOTE_RETCODE(RIX) - Q - ; -TRIMTAIL(INSTR) ; - N OUTSTR,CHR - ; - I $G(INSTR)="" Q "" ; quit if nothing there - ; - S INSTR=$RE(INSTR) - S CHR=$E($TR(INSTR,CPS_REP)) - I CHR]"" Q $RE($P(INSTR,CHR,2,200))_CHR - Q "" diff -auBN ./r1/BPSJVAL.m ./r2/r/BPSJVAL.m --- ./r1/BPSJVAL.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJVAL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,71 +0,0 @@ -BPSJVAL ;DAOU/LJF - Pharmacy data entry ;2004-03-01 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - D ^BPSJVAL1 - K DIR,X S DIR(0)="EO" D ^DIR - I X=U Q - D ^BPSJVAL2 - Q - ; -VAL1(VALCK) ; Application - N RETCODE,VERBOSE,IX2 - ; - ; VALCK=0 = validation, HL7 trigger, no display - I '$G(VALCK) N RETCODE D Q RETCODE ; 0 means ok, '0 means invalid - . ;-validate and quit if ok - . S RETCODE=0 D VALIDATE^BPSJVAL1 I $G(BPSJVALR)=-1 S BPSJVALR=RETCODE - . I 'RETCODE Q - . ;-invalid data, send an email - . S MCT=1+$G(MCT),MSG(MCT)="HL7 E-Pharm Application Registration Message not created." - . F IX2=1:1:RETCODE I $G(RETCODE(IX2))]"" D - .. S MCT=1+MCT,MSG(MCT)=$G(RETCODE(IX2)) - . D MSG^BPSJUTL(.MSG,"BPSJAREG") - ; - ; VALCK=1 = validation, HL7 trigger, display - I $G(VALCK)=1 N RETCODE D Q RETCODE ; 0 means ok, '0 means invalid - . S RETCODE=0,VERBOSE=1 D VALIDATE^BPSJVAL1 - . I $G(BPSJVALR)=-1 S BPSJVALR=RETCODE - ; - ; VALCK=2 = validation, no HL7 trigger, display - I $G(VALCK)=2 N RETCODE D Q 1 - . S RETCODE=0,VERBOSE=1 D VALIDATE^BPSJVAL1 - . I $G(BPSJVALR)=-1 S BPSJVALR=RETCODE - ; - ; VALCK=3 = validation, no HL7 trigger, no display - I $G(VALCK)=3 N RETCODE D Q 1 - . S RETCODE=0 D VALIDATE^BPSJVAL1 - . I $G(BPSJVALR)=-1 S BPSJVALR=RETCODE - ; - Q - ; -VAL2(VALCK) ; Pharmacies - N RETCODE,VERBOSE,IX2 - ; - ; VALCK=0 = validation, HL7 trigger, no display - I '$G(VALCK) N RETCODE D Q RETCODE ; 0 means ok, '0 means invalid - . ;-validate and quit if ok - . S RETCODE=0 D VALIDATE^BPSJVAL2 I $G(BPSJVALR)=-1 S BPSJVALR=RETCODE - . I 'RETCODE Q - . ;-invalid data, send an email - . S MCT=1+$G(MCT),MSG(MCT)="HL7 E-Pharm Pharmacy Registration Message not created." - . F IX2=1:1:RETCODE I $G(RETCODE(IX2))]"" D - .. S MCT=1+MCT,MSG(MCT)=$G(RETCODE(IX2)) - . D MSG^BPSJUTL(.MSG,"BPSJAREG") - ; - ; VALCK=1 = validation, HL7 trigger, display - I $G(VALCK)=1 N RETCODE D Q RETCODE ; 0 means ok, '0 means invalid - . S RETCODE=0,VERBOSE=1 D VALIDATE^BPSJVAL2 - . I $G(BPSJVALR)=-1 S BPSJVALR=RETCODE - ; - ; VALCK=2 = validation, no HL7 trigger, display - I $G(VALCK)=2 N RETCODE D Q 1 - . S RETCODE=0,VERBOSE=1 D VALIDATE^BPSJVAL2 - . I $G(BPSJVALR)=-1 S BPSJVALR=RETCODE - ; - ; VALCK=3 = validation, no display, no HL7 trigger - I $G(VALCK)=3 N RETCODE D Q 1 - . S RETCODE=0 D VALIDATE^BPSJVAL2 - . I $G(BPSJVALR)=-1 S BPSJVALR=RETCODE - ; - Q diff -auBN ./r1/BPSJXI1.m ./r2/r/BPSJXI1.m --- ./r1/BPSJXI1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJXI1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,51 +0,0 @@ -BPSJXI1 ;DAOU/DMK - BPS 1.0 Post-Installation Routine # 1 ;10-MAY-2004 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; Reference to ^HLCS(870 supported by DBIA 4241 - ; Reference to ^DIC(4.2 supported by DBIA 248 - ; - ; BPS 1.0 post installation routine - ; BPS 1.0 is an e-Pharmacy (ECME 1.0) component patch - ; -EPHARMIN ; Update HL LOGICAL LINK File for EPHARM IN & EPHARM OUT records - ; - N DATA,IEN870 - ; - ; Get EPHARM IN IEN - S IEN870("EPHARM IN")=$O(^HLCS(870,"B","EPHARM IN","")) - ; - ; Get IIV SERVER IEN - S IEN870("IIV SERVER")=$O(^HLCS(870,"B","IIV SERVER","")) - ; - ; Set IP address and Routing Node - ; 870 HL LOGICAL LINK FILE - I IEN870("IIV SERVER"),IEN870("EPHARM IN") D - . S DATA=$G(^HLCS(870,IEN870("IIV SERVER"),400)) - . S DATA(870)=$G(^HLCS(870,IEN870("EPHARM IN"),400)) - . ; Get IIV SERVER TCP/IP ADDRESS - . S $P(DATA(870),U)=$P(DATA,U) - . ; Get IIV SERVER STARTUP NODE - . S $P(DATA(870),U,6)=$P(DATA,U,6) - . ; Set the data into EPHARM IN - . S ^HLCS(870,IEN870("EPHARM IN"),400)=DATA(870) - ; - ; Get EPHARM OUT IEN - S IEN870("EPHARM OUT")=$O(^HLCS(870,"B","EPHARM OUT","")) - I IEN870("EPHARM OUT")="" Q - ; - ; Set Vitria Domain IEN (pointer to file 4.2 - DOMAIN) - S DATA=$Q(^DIC(4.2,"B","EPHARMACY.VITRIA-EDI.AAC.VA.")) - ; NOTE: B node will contain only the first 30 characters - I DATA["EPHARMACY.VITRIA-EDI.AAC.VA.",$QS(DATA,4) S DATA=$QS(DATA,4) D - . ; Initialize EPHARM OUT DOMAIN to EPHARMACY.VITRIA-EDI.AAC.VA.GOV IEN - . I $P($G(^DIC(4.2,DATA,0)),U)'="EPHARMACY.VITRIA-EDI.AAC.VA.GOV" Q - . S $P(^HLCS(870,IEN870("EPHARM OUT"),0),U,7)=DATA - ; - ; Set EPHARM OUT IP address to reflect IIV EC IP address - S IEN870("IIV EC")=$O(^HLCS(870,"B","IIV EC","")) - I 'IEN870("IIV EC") Q - S DATA=$G(^HLCS(870,IEN870("IIV EC"),400)) - S $P(^HLCS(870,IEN870("EPHARM OUT"),400),U)=$P(DATA,U) - ; - ; - Q diff -auBN ./r1/BPSJZPR.m ./r2/r/BPSJZPR.m --- ./r1/BPSJZPR.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJZPR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,227 +0,0 @@ -BPSJZPR ;DAOU/CMW/LJF - Process Incoming HL7 ZPR Message ;01-DEC-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ; Description: - ; Process incoming HL7 ZPR Messages - ; Update Payer Sheet File (9002313.92) - ; - Q - ; - ; Entry point -EN(BPSJEN,BPSJSEG,BPSJROOT,BPSFILE) ; - ; - N BPRCODE,BPSF,BPSFDIC,BPSEGID,BPORDER,BPMODE,BPNOTES,BPSETID - N FLN,FLNSC,FLNPN,FLNSPEC - N DIE,DIC,DLAYGO,DR,DA,DINUM - N C,X,Y,NCNT,BPND - ; - I $G(BPSJEN),$G(BPSJROOT)]"",$G(BPSFILE)]"",$D(BPSJSEG) - E Q ; invalid info - ; - S BPRCODE=$$ZPR(),DIE=$G(BPSJROOT),C="," - ; - I BPRCODE,BPSEGID,BPORDER - E Q - ; - S BPSF=DIE_BPSJEN_C_BPSEGID_",0)" - I '$D(@BPSF) D - . S FLNSPEC=$$GET1^DID(BPSFILE,BPSEGID,"","SPECIFIER") - . S @BPSF=U_FLNSPEC_U_U - ; - S (X,DINUM)=BPORDER - S DA(1)=BPSJEN,DIC=DIE_BPSJEN_C_BPSEGID_C - S DIC(0)="L",(DIC("P"),DLAYGO)=FLN - D ^DIC - ; - S DA=+Y - S DIE=DIC - S DR=".02////"_BPRCODE_";.03////"_BPMODE - D ^DIE - ; - S BPSFDIC=DIC ; save dictionary ID - ; NOTES - I $D(BPSJSEG(8)) D - . S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",2,",BPSF=DIE_"0)" - . I '$D(@BPSF) S @BPSF=U_FLNPN_U_U - . S BPND="BPSJSEG(7,99)",NCNT=0 - . F S BPND=$Q(@BPND) Q:BPND="" I $G(@BPND)]"" D - .. S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",2,",BPSF=DIE_"0)" - .. K DA S DA(4)=BPSJEN,DA(3)=BPSEGID,DA(2)=BPORDER,DA(1)=2,(NCNT,DA)=NCNT+1 - .. K DR S DR=".01////"_@BPND - .. D ^DIE - K BPSJSEG(8) ; kill 8 so $Q of 7 won't find it - ; - ; Special Code - I $D(BPSJSEG(7)) D - . S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",1,",BPSF=DIE_"0)" - . I '$D(@BPSF) S @BPSF=U_FLNSC_U_U - . S BPND="BPSJSEG(6,99)",NCNT=0 - . F S BPND=$Q(@BPND) Q:BPND="" I $G(@BPND)]"" D - .. S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",1,",BPSF=DIE_"0)" - .. K DA S DA(4)=BPSJEN,DA(3)=BPSEGID,DA(2)=BPORDER,DA(1)=1,(NCNT,DA)=NCNT+1 - .. K DR S DR=".01////"_@BPND - .. D ^DIE - Q - ; -ZPR() ; Validate Fields and Initialize ZPR variables - N RCODE,WDATA - ; - ; Reject reasons: 1=Missing ,2=Invalid - ; - S BPSETID=$G(BPSJSEG(2)) - ; - S BPSEGID=$G(BPSJSEG(3)) - I BPSEGID="" S BPSEGID=0 D - . S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,2)="V632-1,"_BPSETID - E S BPSEGID=$G(ZPRS(BPSEGID)) D - . I 'BPSEGID S BPSEGID=0 D Q - .. S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,2)="V632-2,"_BPSETID - . ; - . S FLN=$P(BPSEGID,U,2) - . S FLNSC=$P(BPSEGID,U,3) - . S FLNPN=$P(BPSEGID,U,4) - . S BPSEGID=+BPSEGID - ; - S RCODE=$$GETPTR($G(BPSJSEG(4))) - I 'RCODE S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,3)="V633-2,"_BPSETID - I $G(BPSJSEG(4))="" S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,3)="V633-1,"_BPSETID - ; - S BPORDER=$G(BPSJSEG(5)) - I BPORDER="" S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,4)="V634,"_BPSETID - ; - S BPMODE=$G(BPSJSEG(6)) - ; - I BPMODE'="X",BPMODE'="S" D - . S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,5)="V635,"_BPSETID - ; - I '$L($G(BPSJSEG(7))),$D(BPSJSEG(7))'>1 K BPSJSEG(7) - E D ;NOTES(.BPSJSEG(7)) - . K WDATA M WDATA(7)=BPSJSEG(7) D NOTES(.WDATA) - . K BPSJSEG(7) M BPSJSEG(7)=WDATA K WDATA - ; - ; flag error if processing mode="X" and no special code - I BPMODE="X",'$D(BPSJSEG(7)) S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,6)="V636,"_BPSETID - ; - I '$L($G(BPSJSEG(8))),$D(BPSJSEG(8))'>1 K BPSJSEG(8) - E D ;NOTES(.BPSJSEG(8)) - . K WDATA M WDATA(8)=BPSJSEG(8) D NOTES(.WDATA) - . K BPSJSEG(8) M BPSJSEG(8)=WDATA K WDATA - ; - Q RCODE - ; -NOTES(ARRAYIN,TRCH) ; fProgrammer Notes - Special Code handler - ; - N II,ODAT,NODENM - N ISDATA,ISDATA1,ISDATA2,ISDATA3 - ; - I '$D(TRCH) D ; apply standard Vista/Vitria "Free Text" de-encoding - . S TRCH("\F\")="|",TRCH("\R\")="~",TRCH("\E\")="\" - . S TRCH("\T\")="&",TRCH("\S\")="^" - . S TRCH("\.b")=1,TRCH("\.br\")=1 - ; - S NODENM="ARRAYIN" - ; - S (ODAT,ISDATA1)="" - F S NODENM=$Q(@NODENM) Q:NODENM="" S ISDATA=@NODENM D - . ; clean up partial string if any - . I $L(ISDATA1) D I '$L(ISDATA) Q - .. S ISDATA1=ISDATA1_$E(ISDATA,1,10) - .. S ISDATA3=$$DECODE(ISDATA1,.TRCH,.ODAT,.ISDATA2) - .. S $E(ISDATA,1,10)=ISDATA2 - . ; - . S ISDATA2=$$DECODE(ISDATA,.TRCH,.ODAT,.ISDATA1) - ; - S ODAT=ODAT_ISDATA1 D NWNODE(.ODAT) K ARRAYIN M ARRAYIN=ODAT - Q - ; -NWNODE(FREERAY) ; build free text array - N CNT - S CNT=1+$O(FREERAY(""),-1),FREERAY(CNT)=FREERAY,FREERAY="" - Q - ; -DECODE(INSTR,TCH,WDAT,INSTR1) ; - ; INSTR - Input string - ; TCH - translation array - ; WDAT - Output in a Vista compliant "Free Text" array - ; INSTR1 - Remainder of text when last or - ; second to last INSTR char = "\" - ;Development Note: - ;\.br\ - removed and new node created - ;\E\.br\E\ = \.br\ - (no further translation) - ;non-printable character translation not supported - ;Output Array nodes will contain no more than 200 characters each - ; - N II,CH - S INSTR1="",WDAT=$G(WDAT) - F II=1:1:$L(INSTR) S CH=$E(INSTR,II) D:CH="\" S WDAT=WDAT_CH I $L(WDAT)>199 D NWNODE(.WDAT) - . ; - . ; Partial TCH string, if \.br\ (CR-LF) translation allowed - . I $L($E(INSTR,II,II+2))<3,$G(TCH("\.br\")) D Q - .. S INSTR1=$E(INSTR,II,II+2),II=$L(INSTR),CH="" - . ; - . I '$D(TCH($E(INSTR,II,II+2))) Q ; not one we're interested in - . I +$G(TCH($E(INSTR,II,II+2))) D Q ; \.br\ to conversion - .. I (II+4)>$L(INSTR) S INSTR1=$E(INSTR,II,$L(INSTR)),II=$L(INSTR),CH="" Q - .. I +$G(TCH($E(INSTR,II,II+4))) S II=II+4,CH="" D NWNODE(.WDAT) - . ; - . S CH=TCH($E(INSTR,II,II+2)),II=II+2 ; std conversion - Q WDAT ; Return top node of WDAT - for strings less than 200 characters - ; -GETPTR(BPDAT) ; Get pointer into BPS NCPDP FIELD DEFS - N BPSFNM,BPSFNO,BPSIX,BPSIXALT,BPSFX,BPNAMIX,BPNUMIX,BPSFNOCK - ; - S BPSFNM=$P($G(BPDAT),"-",2),BPSFNO=+$G(BPDAT) - I BPSFNM]"",BPSFNO S (BPSIX,BPSIXALT)=0,BPSFX=BPSFNO_U_BPSFNM - E Q 0 - S BPNAMIX=$O(^BPSF(9002313.91,"D",BPSFNM,"")) - S BPNUMIX=$O(^BPSF(9002313.91,"B",BPSFNO,"")) - ; - ;-if NAME and NUMBER point to the same IEN (but not 0) - I BPNAMIX,BPNUMIX=BPNAMIX Q BPNAMIX - ; - ;-else might be in another node of the "D" x-ref - I BPNAMIX,BPNUMIX F D Q:BPSIX Q:'BPNAMIX - . S BPNAMIX=$O(^BPSF(9002313.91,"D",BPSFNM,BPNAMIX)) - . I BPNUMIX=BPNAMIX S BPSIX=BPNAMIX - ; - ;-If not found, try "B" x-ref value - I 'BPSIX,BPNUMIX D - . I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX Q - . I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX Q - . ; - . ;-try additional "B" x-ref's for this NUMBER - . F D Q:BPSIX Q:'BPNUMIX - .. S BPNUMIX=$O(^BPSF(9002313.91,"B",BPSFNO,BPNUMIX)) - .. I BPNUMIX D - ... I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX - ... I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX - ; - ;-Last resort - go through all iens' - I 'BPSIX S BPNUMIX=0 F D Q:BPSIX Q:'BPNUMIX - . S BPNUMIX=$O(^BPSF(9002313.91,BPNUMIX)) - . I BPNUMIX,+$G(^BPSF(9002313.91,BPNUMIX,0))[BPSFNO D - .. S BPSFNOCK=+$G(^BPSF(9002313.91,BPNUMIX,0)) - .. ; Note: Special coding included for BPSFNO of 498 (498.nn) - .. I BPSFNOCK'=BPSFNO,$P(BPSFNOCK,".")'=498 Q - .. I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX - .. I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX - ; - Q BPSIX - ; -INITZPRS(ZPRS) ;BPSEGID^FLN^FLNSC^FLNPN - S ZPRS(0)="100^9002313.9205^9002313.92051^9002313.92052" - S ZPRS(1)="110^9002313.9206^9002313.92061^9002313.92062" - S ZPRS(2)="140^9002313.9209^9002313.92091^9002313.92092" - S ZPRS(3)="150^9002313.921^9002313.9211^9002313.9212" - S ZPRS(4)="120^9002313.9207^9002313.92071^9002313.92072" - S ZPRS(5)="160^9002313.9213^9002313.92131^9002313.92132" - S ZPRS(6)="170^9002313.9214^9002313.92141^9002313.92142" - S ZPRS(7)="130^9002313.9208^9002313.92081^9002313.92082" - S ZPRS(8)="180^9002313.9215^9002313.92151^9002313.92152" - S ZPRS(9)="200^9002313.9217^9002313.92171^9002313.92172" - S ZPRS(10)="210^9002313.9218^9002313.92181^9002313.92182" - S ZPRS(11)="190^9002313.9216^9002313.92161^9002313.92162" - S ZPRS(12)="220^9002313.9219^9002313.92191^9002313.92192" - S ZPRS(13)="230^9002313.922^9002313.9221^9002313.9222" - Q diff -auBN ./r1/BPSJZQR.m ./r2/r/BPSJZQR.m --- ./r1/BPSJZQR.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJZQR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,38 +0,0 @@ -BPSJZQR(HL) ;DAOU/LJF - HL7 Registration ZQR Message ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ; ZQR is pharmacy site registration info - ; - N ZQR,FS,CPS,REP,VAIX1,VAIX2,VERNM,CNF - ; - ; Normally: HL("FS")="|" HL("ECH")="^~\&" - S FS=$G(HL("FS")) I FS="" S FS="|" - S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^" - S REP=$E($G(HL("ECH")),2) I REP="" S REP="~" - ; - S ZQR=FS_(+$G(HL("SITE"))) - ; - ; Get Contact Info - S VAIX1=$G(^BPS(9002313.99,1,"VITRIA")),VAIX2=$P(VAIX1,U,2) - ; - S VERNM=$P(VAIX1,U,3),VAIX1=+VAIX1 - I VERNM="" S VERNM=1 - ; - S ZQR=ZQR_FS_VERNM - ; - ; Port - S ZQR=ZQR_FS_$G(HL("EPPORT")) - ; - ; Load the Name and Means Fields - ; Contact - I VAIX1 D - . S CNF=$$VA200NM^BPSJUTL(VAIX1,"",.HL) I CNF]"" S $P(ZQR,FS,5)=CNF - . S CNF=$$VA20013^BPSJUTL(VAIX1,.HL) I CNF]"" S $P(ZQR,FS,6)=CNF - ; - ; Alternate Contact - I VAIX2 D - . S CNF=$$VA200NM^BPSJUTL(VAIX2,"",.HL) I CNF]"" S $P(ZQR,FS,7)=CNF - . S CNF=$$VA20013^BPSJUTL(VAIX2,.HL) I CNF]"" S $P(ZQR,FS,8)=CNF - ; - Q "ZQR|"_ZQR diff -auBN ./r1/BPSJZRP.m ./r2/r/BPSJZRP.m --- ./r1/BPSJZRP.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSJZRP.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,130 +0,0 @@ -BPSJZRP(HL,PHIX,TAXID,ZRP) ;DAOU/LJF - HL7 Registration ZRP Message ;21-NOV-2003 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ; ZRP array contains pharmacy registration info - N ZRPS,FS,CPS,REP,NDZRO,NDHRS,NDREM,NDREP,NDREP1,NDADD,STATE - N VAIX1,VAIX2,VAIXLP,VATLE,CNF,MSGCNT,TCH - ; - ; Quit if no Phamacy index provided - I '$G(PHIX) Q - ; - K ZRP S ZRPS="" - ; - ; Set HL7 Delimiters - use standard defaults if none provided - S FS=$G(HL("FS")) I FS="" S FS="|" - S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^" - S REP=$E($G(HL("ECH")),2) I REP="" S REP="~" - ; - S NDZRO=$G(^BPS(9002313.56,PHIX,0)) - S NDREM=$G(^BPS(9002313.56,PHIX,"REMIT")) - S NDREP=$G(^BPS(9002313.56,PHIX,"REP")) - S NDREP1=$G(^BPS(9002313.56,PHIX,"REP1")) - S NDADD=$G(^BPS(9002313.56,PHIX,"ADDR")) - ; - F ZRP=1:1:16 S ZRP(ZRP)="" ;Initialize - S TAXID=$P(NDZRO,U,5) ;TAX ID - S ZRP(2)=$P(NDZRO,U,2) ;NCPDP # - S ZRP(3)=$P(NDZRO,U) ;NAME - S ZRP(4)=$P(NDZRO,U,3) ;DEFAULT DEA # - ; - S ZRP(5)=$$OPHOURS(PHIX) - ; - I $L($P(NDADD,U,8)) S $P(ZRPS,CPS,1)=$P(NDADD,U,8) ;SITE ADDRESS NAME - I $L($P(NDADD,U,1)) S $P(ZRPS,CPS,1)=$P(ZRPS,CPS,1)_" "_$P(NDADD,U,1) ;SITE ADDRESS 1 - I $L($P(NDADD,U,2)) S $P(ZRPS,CPS,2)=$P(NDADD,U,2) ;SITE ADDRESS 2 - I $L($P(NDADD,U,3)) S $P(ZRPS,CPS,3)=$P(NDADD,U,3) ;CITY - I $L($P(NDADD,U,4)) S STATE=$P(NDADD,U,4) I STATE D ; State - . S STATE=$P($G(^DIC(5,STATE,0)),U,2) - . I STATE]"" S $P(ZRPS,CPS,4)=STATE - I $L($P(NDADD,U,5)) S $P(ZRPS,CPS,5)=$P(NDADD,U,5) ;ZIP - I ZRPS]"" S ZRP(6)=ZRPS,ZRPS="" - ; - I $L($P(NDREM,U,1)) S $P(ZRPS,CPS,1)=$P(NDREM,U,1) ;REMITTANCE ADDRESS NAME - I $L($P(NDREM,U,2)) S $P(ZRPS,CPS,1)=$P(ZRPS,CPS,1)_" "_$P(NDREM,U,2) ;REMIT ADDRESS LINE 1 - I $L($P(NDREM,U,3)) S $P(ZRPS,CPS,2)=$P(NDREM,U,3) ;REMIT ADDRESS LINE 2 - I $L($P(NDREM,U,6)) S $P(ZRPS,CPS,3)=$P(NDREM,U,6) ;CITY - I $L($P(NDREM,U,7)) S STATE=$P(NDREM,U,7) I STATE D ;State - . S STATE=$P($G(^DIC(5,STATE,0)),U,2) - . I STATE]"" S $P(ZRPS,CPS,4)=STATE - I $L($P(NDREM,U,8)) S $P(ZRPS,CPS,5)=$P(NDREM,U,8) ;ZIP - I ZRPS]"" S ZRP(7)=ZRPS,ZRPS="" - ; - ; Load the Name and Means Fields - S VAIX1=$P(NDREP,U,3) - S VAIX2=$P(NDREP,U,4) - S VAIXLP=$P(NDREP,U,5) - ; - ; Contact - I $G(VAIX1) S VATLE="" D - . S CNF=$$VA200NM^BPSJUTL(VAIX1,.VATLE,.HL) I CNF]"" S ZRP(8)=CNF - . I VATLE]"" S ZRP(9)=VATLE - . S CNF=$$VA20013^BPSJUTL(VAIX1,.HL) I CNF]"" S ZRP(10)=CNF - ; - ; Alternate Contact - I $G(VAIX2) S VATLE="" D - . S CNF=$$VA200NM^BPSJUTL(VAIX2,.VATLE,.HL) I CNF]"" S ZRP(11)=CNF - . I VATLE]"" S ZRP(12)=VATLE - . S CNF=$$VA20013^BPSJUTL(VAIX2,.HL) I CNF]"" S ZRP(13)=CNF - ; - ; Lead Pharmist - I $G(VAIXLP) S VATLE="" D - . S CNF=$$VA200NM^BPSJUTL(VAIXLP,.VATLE,.HL) I CNF]"" S ZRP(14)=CNF - . I VATLE]"" S ZRP(15)=VATLE - ; - ; Pharmacist's License - I $L($P(NDREP1,U)) S ZRP(16)=$P(NDREP1,U) - ; - ; Encode special chars. Add Field separators. - S TCH("\")="\E\",TCH("&")="\T\",TCH("|")="\F\" - S (ZRPS(5),ZRPS(10),ZRPS(13))=1 ;Fields with HL7 repetion chars - F ZRP=16:-1:1 D S ZRP(ZRP)=$$ENCODE^BPSJUTL(ZRP(ZRP),.TCH)_FS - . I $G(ZRPS(ZRP)) K TCH("~") ; don't convert repetion chars - . E S TCH("~")="\R\" ; ok to convert repetion chars - S ZRP="ZRP|" - ; - Q - ; -OPHOURS(PHINDEX) ; Operational Hours - N DAY,DIX,OPH,RETURN,WEEK,OPDAY,OPHOUR - N CLH - ; - S PHINDEX=+$G(PHINDEX),RETURN="" - S WEEK="SUN^MON^TUE^WED^THU^FRI^SAT^" - S OPH=$G(^BPS(9002313.56,PHINDEX,"TOPEN")) - S CLH=$G(^BPS(9002313.56,PHINDEX,"TCLOSE")) - I $G(CPS)="" S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^" - I $G(REP)="" S REP=$E($G(HL("ECH")),2) I REP="" S REP="~" - I OPH]"" F DAY=1:1:7 I $P(OPH,U,DAY)]"" D - . I RETURN]"" S RETURN=RETURN_REP - . S RETURN=RETURN_$P(WEEK,U,DAY)_CPS_$P(WEEK,U,DAY)_CPS - . S OPHOUR=$$HOURS($P(OPH,U,DAY)) I OPHOUR<0 S OPHOUR="0000" - . S RETURN=RETURN_OPHOUR_CPS - . S OPHOUR=$$HOURS($P(CLH,U,DAY)) I OPHOUR<0 S OPHOUR="2359" - . S RETURN=RETURN_OPHOUR - I RETURN]"" Q RETURN - ; - S WEEK=U_WEEK - S OPH=$G(^BPS(9002313.56,PHINDEX,"HOURS")) - S OPDAY=$E($P(OPH,U,2),1,3) - ;-if start day unrecognizable force to SUN - I WEEK[(U_OPDAY_U) S RETURN=OPDAY_CPS - E S RETURN="SUN"_CPS - S OPDAY=$E($P(OPH,U,3),1,3) - ;-if end day unrecognizable force to SAT - I WEEK[(U_OPDAY_U) S RETURN=RETURN_OPDAY_CPS - E S RETURN=RETURN_"SAT"_CPS - ;-if start time unrecognizable force to 0000 - S OPHOUR=$$HOURS($E($P(OPH,U,4),1,4)) I OPHOUR<0 S OPHOUR="0000" - ;-if end time unrecognizable force to 2359 - S OPDAY=$$HOURS($E($P(OPH,U,5),1,4)) I OPDAY<0 S OPDAY="2359" - ;-if end time is less than start time force 0000 to 2359 - I OPDAY>OPHOUR S RETURN=RETURN_OPHOUR_CPS_OPDAY - E S RETURN=RETURN_"0000"_CPS_"2359" - Q RETURN - ; -HOURS(MIN) ; Validate time 0000 - 2359 - N HRS - S HRS=$E(MIN,1,2),$E(MIN,1,2)="" - I $L(HRS)=2,HRS>-1,HRS<24,$L(MIN)=2,MIN>-1,MIN<60 Q HRS_MIN - Q -1 diff -auBN ./r1/BPSMHDR.m ./r2/r/BPSMHDR.m --- ./r1/BPSMHDR.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSMHDR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,59 +0,0 @@ -BPSMHDR ;BHAM ISC/FCS/DRS - MENUS HEADERS ;06/01/2004 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - ; - ;****** Send this routine with each new patch with **n** in piece - ;****** 3 so the patch level can be displayed as part of the - ;****** menu header. - ; -INIT ;EP - - I $G(XQY0)'="",$G(BPSTOP)="" S BPSTOP=XQY0 - S BPSY="",BPSY=$O(^DIC(9.4,"C","BPS",BPSY)) - S BPSVER=^DIC(9.4,BPSY,"VERSION"),BPSVER="V"_BPSVER K BPSY - S X=$T(+2),X=$P(X,";;",2),X=$P(X,";",3),X=$P(X,"**",2),X=$P(X,",",$L(X,",")) - S:X]"" BPSVER=BPSVER - S BPSPNM="Electronic Claims Management Engine (ECME)" - I '$D(DUZ(2)) W !!,"Your SITE NAME is not set for the KERNEL.",!,"Please contact your System Support person.",!! S BPSQUIT=1 Q - I '$D(DUZ(0)) W !!,"You do not have the DUZ(0) variable.",!,"Please contact your System Support person.",!! S BPSQUIT=1 Q - I DUZ(0)'["M",DUZ(0)'["P",DUZ(0)'["p",DUZ(0)'["@" W !!,"You do not have the appropriate FileMan access.",!,"Please contact your System Support person.",!! S BPSQUIT=1 Q - S BPSSITE=$P(^DIC(4,DUZ(2),0),"^") - I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS - I $G(IO) S Y=$O(^%ZIS(1,"C",IO,0)) I Y S Y=$P($G(^%ZIS(1,Y,"SUBTYPE")),U) I Y S X=$G(^%ZIS(2,Y,5)),BPSRVON=$P(X,U,4),BPSRVOF=$P(X,U,5) - I $G(BPSRVON)="" S BPSRVON="""""",BPSRVOF="""""" - Q - ; -HDR ;EP - Screen header. - Q:$G(XQY0)="" - I $G(BPSTOP)="" D INIT Q:$G(BPSQUIT) - I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS - S X=$P(XQY0,U,2),BPSMT=$S($P(XQY0,U)="BPSMENU":"Main Menu",1:X) - S BPSPNV=BPSPNM_" "_BPSVER - NEW A,D,F,I,L,N,R,V - S F=0 - W ! - S A=$X W IORVON,IORVOFF S D=$X S:D>A F=D-A ;compute length of revvideo - S L=(80-$L(BPSPNV))\2-1,R=L+$L(BPSPNV)+1 - S D=$L(BPSPNV)+2,N=$L(BPSPNV)-1 - W @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),! - W ?L,"*",$$CTR(BPSPNV,N),?R,"*",! - W ?L,"*",$$CTR($$LOC(),N),?R,"*",! - W ?L,"*",?(L+(((R-L)-$L(BPSMT))\2)),IORVON,BPSMT,IORVOFF,?R+F,"*",! - W $$CTR($$REPEAT^XLFSTR("*",D)),! - K BPSMT,BPSPNV - Q - ; - ;---------- -CTR(X,Y) ;EP - Center X in a field Y wide. - Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X - ;---------- -LJRF(X,Y,Z) ;EP - left justify X in a field Y wide, right filling with Z. - NEW L,M - I $L(X)'(VALMBG+(18-3)) Q 0 - Q 1 -VALUES ;EP - from BPSOS2 - ; note! This must correspond with the LABELS code in BPSOS2C - N R,R1,R2,C,X,X2,X3 - N TIME S TIME=CURR("COMM","$$H")-CURR("COMM",2) I 'TIME S TIME=1 - S R1=1,CDIV=3 - G VA101 -VA001 S R=R1 ;,C=3,X="* * * * * COMMUNICATIONS STATISTICS * * * * *" D L1 - S R=R+1 ;,C=9,X="Packets Per min Bytes Per Min" D L1 - S R=R+1 ;,C=3,X="Sent" D L1 - I $D(CHG("COMM",402)) D - .S C=9,X=CHG("COMM",402),X2=0,X3=7 D COM - I $D(CHG("COMM","$$H"))&$D(CHG("COMM",402)) D - .S C=18,X=CURR("COMM",402)/TIME*60,X2=1,X3=6 D COM - I $D(CHG("COMM",403)) D - .S C=27,X=CHG("COMM",403),X2=0,X3=11 D COM - I $D(CHG("COMM","$$H"))&$D(CHG("COMM",403)) D - .S C=41,X=CURR("COMM",403)/TIME*60,X2=0,X3=7 D COM - ;S R=R+1 ;,C=1,X="Rexmit" D L1 -VA005 S R=R+1 ;,C=3,X="Recd" D L1 - I $D(CHG("COMM",404)) D - .S C=9,X=$G(CHG("COMM",404)),X2=0,X3=7 D COM - I $D(CHG("COMM",404))&$G(CHG("COMM","$$H")) D - .S C=18,X=CURR("COMM",404)/TIME*60,X2=1,X3=6 D COM - I $D(CHG("COMM",405)) D - .S C=27,X=CHG("COMM",405),X2=0,X3=11 D COM - I $D(CHG("COMM",405))&$D(CHG("COMM","$$H")) D - .S C=41,X=CURR("COMM",405)/TIME*60,X2=0,X3=7 D COM - S R=R+1 ;,C=3,X="Total claims" D L1 S C=26,X="Average per min" D L1 - I $D(CHG("COMM",200)) D - .S C=16,X=CHG("COMM",200),X2=0,X3=7 D COM - I $D(CHG("COMM",200))&$D(CHG("COMM","$$H")) D - .S C=41,X=CURR("COMM",200)/TIME*60,X2=1,X3=6 D COM - S R=R+1 ;,C=3,X="Average claims per packet" D L1 - I $D(CHG("COMM",200))&$D(CHG("COMM",402)) D - .S C=34 - .I CURR("COMM",402) S X=CURR("COMM",200)/CURR("COMM",402) - .E S X=0 - .S X2=2,X3=5 D COM - S R=R+1 ;,C=3,X="Average seconds per transaction" D L1 - I $D(CHG("COMM",501))!$D(CHG("COMM",404)) D - .; Just let Receive packets = transaction count - .S C=34 - .I CURR("COMM",404) S X=CURR("COMM",501)/CURR("COMM",404) - .E S X=0 - .S X2=2,X3=5 D COM - S R=R+1 ;,C=32,X="Now Average" D L1 -VA010 S R=R+1 ;,C=3,X="Packets waiting to be sent" D L1 - I $D(CHG("PKTQ","C")) D - .S C=31,X=CHG("PKTQ","C"),X2=0,X3=4 D COM - .; the average would be xxx.x in column C=38,C2=1,X3=5 - S R=R+1 ;,C=3,X="Responses waiting for proc" D L1 - I $D(CHG("PKTQ","R")) D - .S C=31,X=CHG("PKTQ","R"),X2=0,X3=4 D COM - .; the average would be xxx.x in column C=38,C2=1,X3=5 - S R=R+1 ;C=1,X="* * * Transaction Codes * * * Control Chars * * *" D L1 - S R=R+1 ;,C=7,X="01" D L1 S C=30,X="Dialing out" - I $D(CHG("COMM",411)) D - .S C=4,X=CHG("COMM",411),X2=0,X3=7 D COM - I $D(CHG("COMM",414)) D - .S C=19,X=CHG("COMM",414),X2=0,X3=7 D COM - I $O(CHG("COMM",599))<700 D ; dialing errors - .N % S X=0,%=602 ; sum dial errors: fields 603-699 - .F S %=$O(CURR("COMM",%)) Q:%>699!(%="") S X=X+CURR("COMM",%) - .S C=43,X2=0,X3=5 D COM - S R=R+1 ;,C=7,X="02" D L1 S C=30,X="Sending" - I $D(CHG("COMM",412)) D - .S C=4,X=CHG("COMM",412),X2=0,X3=7 D COM - I $D(CHG("COMM",415)) D - .S C=19,X=CHG("COMM",415),X2=0,X3=7 D COM - I $O(CHG("COMM",700))<800 D ; problems around sending time 700-799 - .N % S X=0,%=700 - .F S %=$O(CURR("COMM",%)) Q:%>799!(%="") I %'=702 S X=X+CURR("COMM",%) - .S C=43,X=0,X3=5 D COM -VA015 S R=R+1 ;,C=7,X="03" D L1 S C=30,X="Receiving" - I $D(CHG("COMM",413)) S C=4,X=CHG("COMM",413),X2=0,X3=7 D COM - I $D(CHG("COMM",419)) S C=19,X=CHG("COMM",419),X2=0,X3=7 D COM - I $G(CHG("COMM",799))<900 D - .N % S X=0,%=799 ; sum receive errors: fields 801-899 - .F S %=$O(CURR("COMM",%)) Q:%>899!(%="") S X=X+CURR("COMM",%) - .S C=43,X2=0,X3=5 D COM - S R=R+1 ; we sent nak - I $D(CHG("COMM",408)) D ; details of responses to nak in #901-999 - .S C=43,X=CHG("COMM",408),X2=0,X3=5 D COM - S R=R+1 ;,C=7,X="11",C=11,X="Other" D L1 - S R2=R ;,C=CDIV,X="|" F R=R1:1:R2 D L1 -VA101 S R=R1 ;,C=CDIV+2,X="* * * CLAIM STATUS * * *" D L1 - S R=R+1 ;,C=CDIV+2,X="Waiting to start" D L1 - I $D(CHG("STAT",0)) D - .S C=CDIV+20,X=CHG("STAT",0),X2=0,X3=3 D COM - S R=R+1 ;,X="Gathering info" D L1 - I $D(CHG("STAT",10)) D - .S C=CDIV+20,X=CHG("STAT",10),X2=0,X3=3 D COM -VA105 S R=R+1 ;,X="Wait packet build" D L1 - I $D(CHG("STAT",30)) D - .S C=CDIV+20,X=CHG("STAT",30),X2=0,X3=3 D COM - S R=R+1 ;,X="Building packet" D L1 - I $D(CHG("STAT",40)) D - .S C=CDIV+20,X=CHG("STAT",40),X2=0,X3=3 D COM - S R=R+1 ;,X="Wait for transmit" D L1 - I $D(CHG("STAT",50)) D - .S C=CDIV+20,X=CHG("STAT",50),X2=0,X3=3 D COM - S R=R+1 ;,X="Transmitting" D L1 - I $D(CHG("STAT",60)) D - .S C=CDIV+20,X=CHG("STAT",60),X2=0,X3=3 D COM - S R=R+1 ;,X="Receiv'g response" D L1 - I $D(CHG("STAT",70)) D - .S C=CDIV+20,X=CHG("STAT",70),X2=0,X3=3 D COM -VA110 S R=R+1 ;,X="Wait resp process" D L1 - I $D(CHG("STAT",80)) D - .S C=CDIV+20,X=CHG("STAT",80),X2=0,X3=3 D COM - S R=R+1 ;,X="Proces'g response" D L1 - I $D(CHG("STAT",90)) D - .S C=CDIV+20,X=CHG("STAT",90),X2=0,X3=3 D COM - S R=R+1 ; * CLAIM RESULTS * - S R=2,CDIV=65 ;,X="Paid claims" D L1 - I $D(CHG("COMM",203)) D - .S C=CDIV+1,X=CHG("COMM",203),X2=0,X3=7 D COM - S R=R+1 ;,X="Rejected claims" D L1 - I $D(CHG("COMM",202)) D - .S C=CDIV+1,X=CHG("COMM",202),X2=0,X3=7 D COM - S R=R+1 ;,X="Unbillable claims" - I $D(CHG("COMM",201)) D - .S C=CDIV+1,X=CHG("COMM",201),X2=0,X3=7 D COM -VA115 S R=R+1 ;,X="Duplicate claims" D L1 - I $D(CHG("COMM",204)) D - .S C=CDIV+1,X=CHG("COMM",204),X2=0,X3=7 D COM -VA116 S R=R+1 ;,X="Captured claims" D L1 - I $D(CHG("COMM",205)) D - .S C=CDIV+1,X=CHG("COMM",205),X2=0,X3=7 D COM - ;S VALMCNT=$S(R>R2:R,1:R2) -VA200 ; Then line 18 begins "Next screen" - S (R,R1)=17 - ;S X="***** Communications Problems *****",C=$L(X)/2*-1+80 D L1 - N C1 S C1=1+$L("Other errors during dialing")+2,X2=0,X3=4 -VA210 S R=R+1 ;,X="* Dialing and Connecting *" D L1 - S R=R+1 ;,X="How many times we dialed" D L1 - I $D(CHG("COMM",601)) D - .N X2,X3 S C=C1,X=CHG("COMM",601) D COM60 - S R=R+1 ;,X="Did not receive CONNECT" D L1 - I $D(CHG("COMM",604)) S C=C1,X=CHG("COMM",604) D COM60 - S R=R+1 ;,X="Other errors during dialing" D L1 - I $D(CHG("COMM",603)) S C=C1,X=CHG("COMM",603) D COM60 - S R=R+1 -VA220 S R=R+1 ;,X="* Before & After Sending *" D L1 - S R=R+1 ;,X="No initial ENQ rec'd" D L1 - I $D(CHG("COMM",719)) S C=C1,X=CHG("COMM",719) D COM60 - S R=R+1 ;,X="Didn't get STX back" D L1 - I $D(CHG("COMM",701)) S C=C1,X=CHG("COMM",701) D COM60 - S R=R+1 ;,X="Got ENQ instead" D L1 - I $D(CHG("COMM",702)) S C=C1,X=CHG("COMM",702) D COM60 - S R=R+1 ;,X="Got NAK instead" D L1 - I $D(CHG("COMM",703)) S C=C1,X=CHG("COMM",703) D COM60 - S R=R+1 ;,X="Got +++ instead" D L1 - I $D(CHG("COMM",704)) S C=C1,X=CHG("COMM",704) D COM60 - S R=R+1 ;,X="Got null instead" D L1 - I $D(CHG("COMM",705)) S C=C1,X=CHG("COMM",705) D COM60 - S R=R+1 ;,X="Got something else" D L1 - I $D(CHG("COMM",709)) S C=C1,X=CHG("COMM",709) D COM60 - S R2=R,CDIV=40,C=CDIV ;,X="|" F R=R1+1:1:R2 D L1 - S R=R1,C1=CDIV+4+$L("Received null during")+1 -VA260 S R=R+1 ;,X="* While receiving responses *" D L1 - S R=R+1 ;,X="Did not receive ETX" D L1 - I $D(CHG("COMM",801)) S X=CHG("COMM",801),C=C1 D COM60 - S R=R+1 ;,X="Received EOT during" D L1 - I $D(CHG("COMM",802)) S X=CHG("COMM",802),C=C1 D COM60 - S R=R+1 ;,X="Received null during" D L1 - I $D(CHG("COMM",803)) S X=CHG("COMM",803),C=C1 D COM60 - S R=R+1 ;,X="Received +++ during" D L1 - I $D(CHG("COMM",804)) S X=CHG("COMM",804),C=C1 D COM60 - S R=R+1 ;,X="Miscellaneous" D L1 - I $D(CHG("COMM",809)) S X=CHG("COMM",809),C=C1 D COM60 - S R=R+1 -VA270 S R=R+1 ;,X="* We sent NAK *" D L1 - S R=R+1 ;,X="How many times" D L1 - I $D(CHG("COMM",408)) S X=CHG("COMM",408),C=C1 D COM60 - S R=R+1 ;,X="Got STX back (good)" D L1 - I $D(CHG("COMM",902)) S X=CHG("COMM",902),C=C1 D COM60 - S R=R+1 ;,X="Got null back" D L1 - I $D(CHG("COMM",903)) S X=CHG("COMM",903),C=C1 D COM60 - S R=R+1 ;,X="Got +++ back" D L1 - I $D(CHG("COMM",904)) S X=CHG("COMM",904),C=C1 D COM60 - S R=R+1 ;,X="Got something else" D L1 - I $D(CHG("COMM",909)) S X=CHG("COMM",909),C=C1 D COM60 -VA300 S (R,R1)=33 ; begin page 3 - S C=5 - S R=R+1 ;,X="*** Front-end inputs ***" D L1 - S R=R+1 ;,X="Total claims submitted" D L1 - S X=$G(CHG("COMM",101)) I X]"" D COM70 - S R=R+1 ;,X="Unique, first-time ones" D L1 - S X=$G(CHG("COMM",102)) I X]"" D COM70 - S R=R+1 ;,X,"Repeat submissions" D L1 - S X=$G(CHG("COMM",103)) I X]"" D COM70 - S R=R+1 - S R=R+1 ;,X="*** Finding PCC Visits ***" D L1 - S R=R+1 ;,X="Found via PCC link in prescription file" D L1 - S X=$G(CHG("COMM",1101)) I X]"" D COM70 - S R=R+1 ;,X="Found by patient,date@time ""AA"" index" D L1 - S X=$G(CHG("COMM",1102)) I X]"" D COM70 - S R=R+1 ;,X="Could not find; created new visit" D L1 - S X=$G(CHG("COMM",1103)) I X]"" D COM70 - ;S VALMCNT=R - K CHG - Q diff -auBN ./r1/BPSOS2C.m ./r2/r/BPSOS2C.m --- ./r1/BPSOS2C.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS2C.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,105 +0,0 @@ -BPSOS2C ;BHAM ISC/FCS/DRS/DLF - BPSOS2 continuation ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -LABELS ;EP - from BPSOS2 ; set up the labels display - N R,R1,R2,C,CDIV,X - S R1=1 ; start in row 1 - S CDIV=1 - S R2=0 - G LA101 ; RMOVE NON VA STUFF FROM THE SCREEN DLF - S CDIV=50 ; column divider line goes in column 50 -LA001 S R=R1,C=3,X="* * * * * COMMUNICATIONS STATISTICS * * * * *" D L1 - S R=R+1,C=9,X="Packets Per min Bytes Per Min" D L1 - S R=R+1,C=3,X="Sent" D L1 - ;S R=R+1,C=1,X="Rexmit" D L1 -LA005 S R=R+1,C=3,X="Recd" D L1 - S R=R+1,C=3,X="Total claims" D L1 S C=26,X="Average per min" D L1 - S R=R+1,C=3,X="Average claims per packet" D L1 - S R=R+1,C=3,X="Average seconds per transaction" D L1 - S R=R+1,C=32,X="Now Average" D L1 -LA010 S R=R+1,C=3,X="Packets waiting to be sent" D L1 - S R=R+1,C=3,X="Responses waiting for proc" D L1 - S R=R+1,C=1,X=" * * Transaction Codes * * * Comms Problems * *" D L1 - S R=R+1 - S C=1,X="01:" D L1 S C=16,X="04:" D L1 S C=27,X="| Dialing out" D L1 - S R=R+1 - S C=1,X="02:" D L1 S C=16,X="11:" D L1 S C=27,X="| Sending data" D L1 -LA015 S R=R+1 - S C=1,X="03:" D L1 S C=15,X="Oth:" D L1 S C=27,X="| Rec'v'g data" D L1 - S R=R+1,C=27,X="| We sent NAK" D L1 - S R=R+1 ; nothing on the left side on this line -LA099 ; - S R2=R,C=CDIV-1,X="|" F R=R1:1:R2 D L1 - S R2=R,C=CDIV,X="|" F R=R1:1:R2 D L1 -LA101 S R=R1,C=CDIV+2,X="* CLAIM STATUS *" D L1 - S R=R+1,C=CDIV+2,X="Waiting to start" D L1 - S R=R+1,X="Gathering info" D L1 -LA105 S R=R+1,X="Wait packet build" D L1 - S R=R+1,X="Building packet" D L1 - S R=R+1,X="Wait for transmit" D L1 - S R=R+1,X="Transmitting" D L1 - S R=R+1,X="Receiv'g response" D L1 -LA110 S R=R+1,X="Wait resp process" D L1 - S R=R+1,X="Proces'g response" D L1 - S R=0,R=R+1,CDIV=40,C=CDIV,X=" * CLAIM RESULTS *" D L1 - S C=CDIV+9 - S R=R+1,C=CDIV,X="Paid claims" D L1 - S R=R+1,X="Rejected claims" D L1 - S R=R+1,X="Paper or Unbillable" D L1 -LA115 S R=R+1,X="Duplicate claims" D L1 -LA116 S R=R+1,X="Captured claims" D L1 - S VALMCNT=$S(R>R2:R,1:R2) - Q -LA200 ; Then line 18 begins "Next screen" - S (R,R1)=17 - S X="***** Communications Problems *****",C=$L(X)/2*-1+40 D L1 - S C=1 -LA210 S R=R+1,X="*** Dialing and Connecting ***" D L1 - S R=R+1,X="How many times we dialed" D L1 - S R=R+1,X="Did not receive CONNECT" D L1 - S R=R+1,X="Other errors during dialing" D L1 - S R=R+1 -LA220 S R=R+1,X="*** Before & After Sending ***" D L1 - S R=R+1,X="Didn't get init ENQ" D L1 - S R=R+1,X="Didn't get STX back" D L1 - S R=R+1,X="Got ENQ instead" D L1 - S R=R+1,X="Got NAK instead" D L1 - S R=R+1,X="Got +++ instead" D L1 - S R=R+1,X="Got null instead" D L1 - S R=R+1,X="Got something else" D L1 - S R2=R,CDIV=40,C=CDIV,X="|" F R=R1+1:1:R2 D L1 - S R=R1,C=CDIV+4 -LA260 S R=R+1,X="*** While receiving responses ***" D L1 - S R=R+1,X="Did not receive ETX" D L1 - S R=R+1,X="Received EOT during" D L1 - S R=R+1,X="Received null during" D L1 - S R=R+1,X="Received +++ during" D L1 - S R=R+1,X="Miscellaneous" D L1 - S R=R+1 -LA270 S R=R+1,X="*** We sent NAK (LRC disagrees) ***" D L1 - S R=R+1,X="How many times" D L1 - S R=R+1,X="Got STX back (good)" D L1 - S R=R+1,X="Got null back" D L1 - S R=R+1,X="Got +++ back" D L1 - S R=R+1,X="Got something else" D L1 -LA300 I R<33 F Q:R=33 D - .S R=R+1 S X=" " D L1 - S R1=R ; begin page 3 ; - S C=15 - S R=R+1,X="*** Front-end inputs ***" D L1 - S R=R+1,X="Total claims submitted" D L1 - S R=R+1,X="Unique, first-time ones" D L1 - S R=R+1,X="Repeat submissions" D L1 - S R=R+1 - S R=R+1,X="*** Finding PCC Visits ***" D L1 - S R=R+1,X="Found via PCC link in prescription file" D L1 - S R=R+1,X="Found by patient,date@time ""AA"" index" D L1 - S R=R+1,X="Could not find; created new visit" D L1 - S VALMCNT=R - Q -L1 ; given R=row,C=col,X=string - ; Duplicate of L1^BPSOS2B - D SET^VALM10(R,$$SETSTR^VALM1(X,$G(@VALMAR@(R,0)),C,$L(X))) - I $$VISIBLE(R) D WRITE^VALM10(R) - Q -VISIBLE(R) Q $$VISIBLE^BPSOS2B(R) diff -auBN ./r1/BPSOS2D.m ./r2/r/BPSOS2D.m --- ./r1/BPSOS2D.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS2D.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,30 +0,0 @@ -BPSOS2D ;BHAM ISC/FCS/DRS/FLS - Poke the queues ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -POKE ;EP - from BPSOS2A ; protocol BPSOS P2 POKE - ; If things seem to be stalled, here's a kludgey way to start up - ; more background jobs to give 'em a poke. - W !,"Poking the pharmacy ECME processing queues:",! - I '$$LOCKPOS^BPSOSUD Q - W "." - N A,B,ABSBRXI F A=40,50 D - .S B="" F S B=$O(^BPST("AD",A,B)) Q:'B D - ..W "." - ..S ABSBRXI=B D SETSTAT^BPSOSU(0) ; restart all of these - ..D LOG59^BPSOSL("POKE set this claim back to restart processing",B) - D ; kill all outbound claims, lest we send claims twice - . N DIALOUT S DIALOUT=0 - . F S DIALOUT=$O(^BPSECX("POS",DIALOUT)) Q:'DIALOUT D - . . N LOCKED S LOCKED=$$LLIST^BPSOSAP - . . K ^BPSECX("POS",DIALOUT,"C") ; kill outbound claims, locked or not - . . I LOCKED D ULLIST^BPSOSAP - D ULKECME^BPSOSUD - D TASK^BPSOSIZ W "." H 1 - D TASK^BPSOSQ1 W "." H 1 - N DIALOUT - S DIALOUT=$$ANY2SEND^BPSOSQJ - I DIALOUT D TASK^BPSOSQ2 W "." H 1 - S DIALOUT=$$ANYRESPS^BPSOSQ4 - I DIALOUT D TASK^BPSOSQ3() W "." H 1 - W "OK, they've been POKEd.",! -PZ Q diff -auBN ./r1/BPSOS2E.m ./r2/r/BPSOS2E.m --- ./r1/BPSOS2E.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS2E.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,34 +0,0 @@ -BPSOS2E ;BHAM ISC/FCS/DRS/FLS - print queues ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -QUEUES() ;EP - option BPS SUP QUEUES - ; Note: these don't LOCK anything, so you could get anomalous-looking - ; results because of timing. - W ! N ROOT,STATUS,SET,WHICH,X - I '$D(IOM) N IOM S IOM=80 - S ROOT="^BPST" ; because we hate typing all that -QUE1 F STATUS=0:1:98 D - .I '$D(@ROOT@("AD",STATUS)) Q - .W $$QCOUNT(STATUS)," in Q" - .W STATUS," ",$$STATI^BPSOSU(STATUS) - .N X S X="" - .F S X=$O(@ROOT@("AD",STATUS,X)) Q:X="" Q:$X+$L(X)+1'80 S X=$$SETFLD^VALM1($E(C,81,160),X,"COMMENTS 2") - .I $L(C)>160 S X=$$SETFLD^VALM1($E(C,161,$L(C)),X,"COMMENTS 3") - ; - ; Setting up for a patient line: - ; -SETL3 E D - .S ^TMP("BPSOS",$J,"VALM","IDX",LINE,INFO("PATIEN"))="" - .I INFO("%")=100 S INFO("%")="done" - .E S INFO("%")=" "_$J(INFO("%"),2)_"%" - .S X=$$SETFLD^VALM1(INFO("%"),X,"PERCENT DONE") - .S X=$$SETFLD^VALM1(PAT,X,"PATIENT") - .N C S C=INFO("RES") ;$S(INFO("%")="done":$$COMMENTS,1:INFO("RES")) - .S X=$$SETFLD^VALM1($E(C,1,80),X,"COMMENTS") - .I $L(C)>80 S X=$$SETFLD^VALM1($E(C,81,160),X,"COMMENTS 2") - .I $L(C)>160 S X=$$SETFLD^VALM1($E(C,161,210),X,"COMMENTS 3") -SETL9 D SET^VALM10(LINE,X,LINE) - I $$VISIBLE^BPSOS6I(LINE) D WRITE^VALM10(LINE) - Q -INFOCT(N) ; how many of these things? - I INFO("COUNT")=1 Q "" ; only one, so we display no count - I N=INFO("COUNT") Q "ALL " ; more than one and they're all this way - Q N_" " -COMMENTS() ; construct the comments based on what's in the INFO array - N %,A,M,X,Y S %="",M=255 ; M = max length - ; start with results - I $O(INFO("RES",""))]"" D ;S %="RESULTS: " D - .S A="" F S A=$O(INFO("RES",A)) Q:A="" D - ..;S X=$P(A,U),Y=$P(A,U,2,$L(A,U)) ; X = result code, Y = text - ..S %=%_$$INFOCT(INFO("RES",A)) ; how many of them - ..;I Y]"" S %=%_Y ; with this status - ..;E S %=%_"result code "_X - ..S %=%_A - ..S %=%_"; " - ..I $L(%)>M S %=$E(%,1,$L(M)) - ; tack on statuses - I INFO("%")'="done" D - .S %=%_"STATUS: " - .S A="" F S A=$O(INFO("STAT",A)) Q:A="" D - ..S %=%_$$INFOCT(INFO("STAT",A))_$$STATI^BPSOSU(A)_"; " ; count,text - ..I $L(%)>M S %=$E(%,1,$L(M)) - I %?.E1"; " S %=$E(%,1,253) - Q % -DISPHIST(MSG,HANG) ;EP - DEBUGGING - to record history and pause - Q:'$P($G(^BPS(9002313.99,1,"BPSOS6*")),U) - S @DISPHIST=@DISPHIST+1 - S @DISPHIST@(@DISPHIST)=MSG - Q:'$G(HANG)!$G(NODISPLY) - ;D MSG^VALM10(MSG) - HANG HANG - D MSG^VALM10("") - Q diff -auBN ./r1/BPSOS6I.m ./r2/r/BPSOS6I.m --- ./r1/BPSOS6I.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS6I.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,235 +0,0 @@ -BPSOS6I ;BHAM ISC/FCS/DRS/FLS - Data Entry & Status Disp ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; ALL writes of screen lines as follows: - ; IF $$VISIBLE(line) DO WRITE^VALM10(line) - ; When approp., set NODISPLY=true and $$VISIBLE returns false - Q - ; DISPDBG: are we debugging the display? -DISPDBG() Q $P($G(^BPS(9002313.99,1,"BPSOS6*")),U) -DISPHIST(MSG,HANG) ; DEBUGGING - to record history and pause - Q:'$$DISPDBG - I '$D(HANG) S HANG=1 - D DISPHIST^BPSOS6H(MSG,HANG) - Q -UPDATE(COUNTER) ;EP - from BPSOS6A - ; with COUNTER = a count down, -1 for indefinite repeat - N CHGCOUNT S CHGCOUNT=0 - N STOP F D Q:$G(STOP) - .D UPD1 - .S COUNTER=COUNTER-1 I 'COUNTER S STOP=1 Q - .I '$G(NODISPLY) D - ..D MSG^VALM10("In continuous update mode: press Q to Quit") - ..N X ;R X#1:^TMP("BPSOS",$J,"FREQ") D MSG^VALM10(" ") - ..;Try doing this single-character read with ^XGKB - ..;I $D(^TMP("XGKEY",$J)) ; possible interference - ..S X=$$READ^XGKB(1,^TMP("BPSOS",$J,"FREQ")) - ..;I X]"","Qq^^"[X S STOP=1 - ..I '$G(DTOUT),X]"","Qq^^"[X S STOP=1 - ..N Y F R Y:0 Q:'$T ; clean out typeahead (like mistaken arrow keys) - Q -UPD1 ; one update cycle - N NOW,PAT,RXI,T,CHG,LAST,OLDEST,ONEPAT D - .N %,%H,%I,X D NOW^%DTC S NOW=% - S ONEPAT=^TMP("BPSOS",$J,"PATIENT") - I ONEPAT D - .S T=^TMP("BPSOS",$J,"PATIENT TIME") - .S CHG=$$SORT^BPSOSUA(0,ONEPAT,T,1) - E D - .S T=^TMP("BPSOS",$J,"LAST UPDATE") ; absolute time on 2nd & subseq - .I T="" S T=^TMP("BPSOS",$J,"TIME") ; delta time on 1st call - .S ^TMP("BPSOS",$J,"LAST UPDATE")=NOW ; remember the time you did this - .S CHG=$$SORT^BPSOSUA(^TMP("BPSOS",$J,"USER"),,T) ; get changes - S OLDEST=$$TADD^BPSOSUD(NOW,-^TMP("BPSOS",$J,"TIME")) - ; - ; Deal with dismissals - ; - S PAT="" F S PAT=$O(@DISMISS@(PAT)) Q:PAT="" D - .I PAT'?1"*".E,'ONEPAT Q - .I @DISMISS@(PAT)^TMP("BPSOS",$J,"MAX LINES") Q ; overflow - N PATNEXT S PATNEXT=$O(@DISP@(PAT)) - I PATNEXT="" D ; the new patient and prescriptions go at end - .S LINE=@DISPLINE+1 ; this is the new line number - .S (VALMCNT,@DISPLINE)=@DISPLINE+NLINES ; update count of total lines - .D DISPHIST("Goes at end, on line #"_LINE,0) - E D ; the new patient pushes the next one downward - .D DISPHIST("Pushes existing ones at line "_LINE_" down "_NLINES,1) - .S LINE=$P(@DISP@(PATNEXT),U) - .D SHIFTDN(LINE,NLINES) - ; - ; common handling for new patient, whether at end or not - ; - S @DISP@(PAT)=LINE_U_U_U_NPRESC - S @DISPLINE@(LINE)=PAT_U ; remember who's stored here - ; - ; Init for each prescription that came with this new patient - ; - S RXI="" ; should always get @CHG@(PAT) iterations, right? - F I=1:1:@CHG@(PAT) S RXI=$O(@CHG@(PAT,"RXI",RXI)) Q:RXI="" D - .S @DISP@(PAT,RXI)=(LINE+I)_U_U - .S @DISPLINE@(LINE+I)=PAT_U_RXI - ; - ; and fall through to treat the rest of it same as existing patient - G UPD3 -UPD2 ; - ; Patient was already in our list, but maybe there are - ; new prescriptions for which we must make room - ; - S RXI="" F I=1:1:@CHG@(PAT) S RXI=$O(@CHG@(PAT,"RXI",RXI)) D - .Q:$D(@DISP@(PAT,RXI)) ; prescription already has a spot - .I VALMCNT+1>^TMP("BPSOS",$J,"MAX LINES") Q ; overflow - .N I ; protect index - .D DISPHIST("New prescription "_RXI_" for "_PAT,0) - .; - .; a new prescription for the already-existent patient - .; assign a line for it and shift everything else down - .; - .S PATCHG=1 ; flag: "patient info has changed" - .N ADDATEND - .N RXINEXT S RXINEXT=$O(@DISP@(PAT,RXI)) - .I RXINEXT S LINE=$P(@DISP@(PAT,RXINEXT),U),ADDATEND=0 - .E D ; prescription comes at end of this patient's stuff - ..N PATNEXT S PATNEXT=$O(@DISP@(PAT)) - ..I PATNEXT="" S ADDATEND=1 - ..E S LINE=$P(@DISP@(PATNEXT),U),ADDATEND=0 - .I ADDATEND D ; adding at end, nothing needs to be shifted down - ..S LINE=@DISPLINE+1,(VALMCNT,@DISPLINE)=@DISPLINE+1 - .E D ; adding in the middle or beginning; need to shift down - ..D SHIFTDN(LINE,1) - .; - .; no matter where we added the new prescription, do the following: - .; - .S @DISP@(PAT,RXI)=LINE_U_U - .S @DISPLINE@(LINE)=PAT_U_RXI ; 02/02/2000 - .S $P(@DISP@(PAT),U,4)=$P(@DISP@(PAT),U,4)+1 - ; -UPD3 ; this patient is already in our list (maybe having just been added) - ; The patient and all of his prescriptions have display space - ; Now we can deal with the actual changes (date-time of change,status) - ;I $P($G(^BPS(9002313.99,1,"BPSOS6*")),U,2) S $ZT="ERR^ZU" - S RXI="" F I=1:1:@CHG@(PAT) D - .;K ^ABSTMP("BPSOS SAVE",$J) M ^ABSTMP("BPSOS SAVE",$J)=^TMP("BPSOS",$J) ; TEMPORARY TEMPORARY TEMPORARY - .S RXI=$O(@CHG@(PAT,"RXI",RXI)) ; next changed prescription - .N X S X=@CHG@(PAT,"RXI",RXI) ; status^dateTimeof last change - .;D DISPHIST("UPD3:"_PAT_" "_RXI_":"_X) - .I '$D(@DISP@(PAT,RXI)) D LOGERR^BPSOS6F("UPD3^BPSOS") ; 01/27/2000 - .I X=$P(@DISP@(PAT,RXI),U,2,3) D Q ; we saw this last time around - ..D DISPHIST("UPD3: already processed this one, so quit early") -UPD4 .N S,D S S=$P(X,U),D=$P(X,U,2) - .; NO! I D>^TMP("BPSOS",$J,"LAST UPDATE") S ^("LAST UPDATE")=D - .;D DISPHIST("UPD3: reset LAST UPDATE to "_D) - .N L S L=$P(@DISP@(PAT,RXI),U) ; line # -UPD5 .I S=100,$P(@DISP@(PAT,RXI),U,2)'=100 D ; marking as complete - ..N B S B=$$BUCKET^BPSOS6B(RXI) - ..; NO! S $P(@DISP@(PAT),U,4)=$P(@DISP@(PAT),U,4)+1 - ..S $P(@DISP@(PAT),U,B)=$P(@DISP@(PAT),U,B)+1 - .S @DISP@(PAT,RXI)=L_U_S_U_D ; line^status^dateTime of change - .;D DISPHIST("UPD3: PAT REC BEFORE:"_@DISP@(PAT)) -UPD6 .I D>$P(@DISP@(PAT),U,3) S $P(@DISP@(PAT),U,3)=D,PATCHG=1 - .;D DISPHIST("UPD3: PAT REC AFTER:"_@DISP@(PAT)) - .D SETLINE^BPSOS6H(L,PAT,RXI) ; update list manager data and disp. if visible - ; -UPD7 ; Sum the total of the statuses - used for computing %done - N TOTSTAT S TOTSTAT=0 - S RXI="" F I=1:1:$P(@DISP@(PAT),U,4) D - .S RXI=$O(@DISP@(PAT,RXI)) - .S TOTSTAT=TOTSTAT+$P(@DISP@(PAT,RXI),U,2) - I TOTSTAT'=$P(@DISP@(PAT),U,2) S PATCHG=1 ; total of statuses changed - S $P(@DISP@(PAT),U,2)=TOTSTAT - D DISPHIST("After summing:"_@DISP@(PAT)) - ; - ; If the patient data changed, update the list manager data and - ; if the line is visible, update the display, too - ; - I PATCHG D SETLINE^BPSOS6H($P(@DISP@(PAT),U),PAT) - Q -VISIBLE(LINE) ;EP - from BPSOS6H - is LINE number visible? - ; HARDCODED!!! list region is from line 6 to line 18 - ; ASSUMPTION!! VALMBG is the first line number displayed - ; so lines VALMBG through VALMBG+(18-6) are visitble - I $G(NODISPLY) Q 0 - I '$G(VALMBG) Q 0 - I LINE(VALMBG+(18-6)) Q 0 - Q 1 -SHIFTDN(LINE,NLINES) ; as in when something is inserted - D DISPHIST("SHIFTDN(LINE,NLINES) for "_LINE_","_NLINES) - F I=VALMCNT:-1:LINE D - .D MOVELINE(I,I+NLINES) - S (@DISPLINE,VALMCNT)=VALMCNT+NLINES - Q -MOVELINE(FROM,TO,CLR) ; - D DISPHIST("Move line "_FROM_" to "_TO_";visible="_$$VISIBLE(TO)_","_$$VISIBLE(FROM)) - D DISPHIST("VALMAR="_VALMAR) - M @DISPHIST@(@DISPHIST,"VALMAR")=@VALMAR - ;I $P($G(^BPS(9002313.99,1,"BPSOS6*")),U,2) S $ZT="ERR^ZU" - I '$D(@DISPLINE@(FROM)) D LOGERR^BPSOS6F("MOVELINE^BPSOS") ;01/27/2000 - N PAT,RXI,X S X=@DISPLINE@(FROM),PAT=$P(X,U),RXI=$P(X,U,2) - I $G(RXI) S $P(@DISP@(PAT,RXI),U)=TO - E S $P(@DISP@(PAT),U)=TO - S @DISPLINE@(TO)=@DISPLINE@(FROM) - D SET^VALM10(TO,@VALMAR@(FROM,0),TO) ; set destination = new contents - D FLDTEXT^VALM10(TO,"LINE NUMBER",$J(TO,2)) ; fix line number in dest - I $$VISIBLE(TO) D WRITE^VALM10(TO) ; if any visible, write them - I $G(CLR) D CLRLINE(FROM) - D DISPHIST("Move line "_FROM_" to "_TO_" complete") - Q -CLRLINE(N) ; clear out line N - D DISPHIST("Clearing line "_N_", $$VISIBLE(N)="_$$VISIBLE(N)) - D SET^VALM10(N," ") ; clear contents of source line - I $$VISIBLE(N) D WRITE^VALM10(N) - S @DISPLINE@(N)="DELETED "_@DISPLINE@(N) - K @VALMAR@("IDX",N) - Q -SHIFTUP(FROM,TO) ; move upward from SRC to DST, all the way to end - D DISPHIST("SHIFTUP(FROM,TO) for "_FROM_","_TO) - I FROM'>TO D Q - . D IMPOSS^BPSOSUE("P","TI","bad params FROM="_FROM_",TO="_TO,,"SHIFTUP",$T(+0)) - N NLINES S NLINES=FROM-TO - F Q:FROM>VALMCNT D - .D MOVELINE(FROM,TO,0) - .S FROM=FROM+1,TO=TO+1 - F D CLRLINE(TO) Q:TO=VALMCNT S TO=TO+1 - S (VALMCNT,@DISPLINE)=VALMCNT-NLINES - Q diff -auBN ./r1/BPSOS6K.m ./r2/r/BPSOS6K.m --- ./r1/BPSOS6K.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS6K.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,30 +0,0 @@ -BPSOS6K ;BHAM ISC/FCS/DRS/FLS - Other options ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -MENU ; - D FULL^VALM1 - N X - F D Q:X<1 - . S X=$$SET^BPSOSU3("Select 1: Log diagnostic info // ","1",0,"V","1:Diagnostics") - . Q:X<1 - . I X=1 D - . . D DIAG - . ;E I X=2 D - . S X=-1 ; for now, cause it to bump out - . ; worthwhile to loop and ask again when you get more options here - S VALMBCK="R" - Q -DIAG ; collect diagnostic information - N X - W !,"This logs diagnostic information to a file for later analysis",! - W "by programming staff. ",! - W ! - W "Select 1 to log general information about the system.",! - W "Select 2 to log information about your screen in particular.",! - W "Select 3 to do both 1 + 2.",! - S X=$$SET^BPSOSU3("Select 1: General 2: Your screen 3:Both // ","1",0,"H","1:General;2:Your screen;3:Both") - W ! - I X<1 W !,"Nothing logged.",! Q - D FULL^BPSOSUB:X=1,JOB^BPSOSUB:X=2,BOTH^BPSOSUB:X=3 - D ANY^BPSOS2A ; press any key - Q diff -auBN ./r1/BPSOS6L.m ./r2/r/BPSOS6L.m --- ./r1/BPSOS6L.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS6L.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,31 +0,0 @@ -BPSOS6L ;BHAM ISC/FCS/DRS - Cancel a claim ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -CANCEL(RXI) ; option to cancel claim would come here - ; now done from a protocol on the data entry screen - ; - ; We merely flag the claim for cancellation. - ; Let the transmit program handle the details. - ; And if we got here too late, the results reporting takes care of it. - ; If we really get fancy, we can have the result processing initiate - ; a claim reversal. - ; - I $D(RXI) G CANC5 - W !,"Enter the prescription number whose claim you wish to cancel.",! - N RXI,ABSBRXI S (ABSBRXI,RXI)=$$GETRX^BPSOSIV Q:RXI<1 -CANC5 ;EP - from BPSOS6D ; Given RXI=pointer to 9002313.59 - Q:'$$LOCKPOS^BPSOSUD - N DIE,DA,DR S DIE=9002313.59,DA=RXI - S DR="301////"_DUZ_";302///@;7///NOW" D ^DIE - D ULKECME^BPSOSUD - ; NO SLEEP PROBER INFO EXISITS UNLESS IT IS IHS 7/29/2003 DLF - ; - I ^BPS(9002313.99,1,"SITE TYPE")=1 D - .N INS - .S INS=$P(^BPST(RXI,1),U,6) - .I $G(^BPSEI(INS,101)) D - .. N X S X=^BPSEI(INS,101) - .. I $P(X,U,6)=RXI S $P(^BPSEI(INS,101),U,6)="" ; release Sleep Prober ownership - .. I $D(^BPST("AD",31)) D TASK^BPSOSQ1 ; poke other 31s - .. D TASK^BPSOSQ1 ; another 31, if any, will take over - Q diff -auBN ./r1/BPSOS6N.m ./r2/r/BPSOS6N.m --- ./r1/BPSOS6N.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS6N.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,98 +0,0 @@ -BPSOS6N ;BHAM ISC/FLS - Claim resubmission routine ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; -RESUB ; - I $D(^TMP($J,"MOREDATA",IEN59,"RESUB")) K MOREDATA,EMSG M MOREDATA=^TMP($J,"MOREDATA",IEN59,"RESUB") I $D(MOREDATA("IBDATA")) D - . S SUBF=9002313.59 N IENS S IENS=IEN59_"," - . S VASEQ="",VASEQ=$O(MOREDATA("IBDATA",VASEQ)) - . S FDA(SUBF,IENS,.01)=IEN59 - . S FDA(SUBF,IENS,501)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",7) ;DRUG QUANTITY - . S FDA(SUBF,IENS,502)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",8) ;INGREDIENT COST - . S FDA(SUBF,IENS,10)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",9) ;NDC - . S FDA(SUBF,IENS,10)=$$NDCF^BPSECFM(FDA(SUBF,IENS,10)) ;CONVERT ndc - . I $L(FDA(SUBF,IENS,10))=10 S FDA(SUBF,IENS,9.08)=$E(FDA(SUBF,IENS,10),2,12) ;strip of the extra zero for va - . S FDA(SUBF,IENS,504)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",1) ;DISPENSE FEE - . S FDA(SUBF,IENS,505)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",3) ;USUAL & CUSTOMARY CHARGE - . S FDA(SUBF,IENS,507)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",5) ;ADMINISTRATIVE FEE - . D UPDATE^DIE("E","FDA","VAIEN","EMSG") - . I $D(EMSG) D S VAXXX="",VAXXX=$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"FDA",$T(+0)) Q:VAXX'="" - . . W !,"Unexpected error in FILEARAY^"_$T(+0),! - . . D ZWRITE^BPSOS("ABSBRXI","IEN59","IENS","EMSG") - . S SUBF=9002313.59902,IENS="1,"_IENS - . S FDA(SUBF,IENS,.01)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",1) ;PAYER SHEET - . S FDA(SUBF,IENS,902.03)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",2) ;BIN - . S FDA(SUBF,IENS,902.04)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",3) ;PCN - . S FDA(SUBF,IENS,902.18)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",13) ;SOFTWARE VENDOR CERT ID - . S FDA(SUBF,IENS,902.19)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",11) ;B2 PAYER SHEET REVERSAL - . S FDA(SUBF,IENS,902.21)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",12) ;B3 PAYER SHEET REVERSAL - . S FDA(SUBF,IENS,902.12)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",14) ;CERTIFY MODE - . S FDA(SUBF,IENS,902.02)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",4) ;PLAN IEN - . S FDA(SUBF,IENS,902.05)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",5) ;GROUP ID - . S FDA(SUBF,IENS,902.06)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",6) ;CARDHOLDER ID - . S FDA(SUBF,IENS,902.07)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",7) ;PATIENT RELATIONSHIP CODE - . I FDA(SUBF,IENS,902.07)="" S FDA(SUBF,IENS,902.07)=0 - . I $L(FDA(SUBF,IENS,902.07))>1 S FDA(SUBF,IENS,902.07)=$E(FDA(SUBF,IENS,902.07),$L(FDA(SUBF,IENS,902.07)),$L(FDA(SUBF,IENS,902.07))) - . S FDA(SUBF,IENS,902.08)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",8) ;CARDHOLDER FIRST NAME - . I $L(FDA(SUBF,IENS,902.08))=10 S FDA(SUBF,IENS,902.08)=$E(FDA(SUBF,IENS,902.08),2,12) ;strip of the extra zero for va - . S FDA(SUBF,IENS,902.09)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",9) ;CARDHOLDER LAST NAME - . S FDA(SUBF,IENS,902.11)=$P($G(MOREDATA("IBDATA",VASEQ,1)),"^",10) ;HOME PLAN STATE - . S FDA(SUBF,IENS,902.12)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",1) ;DISPENSE FEE - . S FDA(SUBF,IENS,902.13)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",2) ;BASIS OF COST DETERMINATION - . S FDA(SUBF,IENS,902.14)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",3) ;USUAL & CUSTOMARY CHARGE - . S FDA(SUBF,IENS,902.15)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",4) ;GROSS AMOUNT DUE - . S FDA(SUBF,IENS,902.16)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",5) ;ADMINISTRATIVE FEE - . S FDA(SUBF,IENS,902.18)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",6) ;Software Vendor/Cert ID - . S FDA(SUBF,IENS,902.12)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",1) ;DISPENSE FEE - . S FDA(SUBF,IENS,902.14)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",3) ;USUAL & CUSTOMARY CHARGE - . S FDA(SUBF,IENS,902.16)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",5) ;ADMINISTRATIVE FEE - . S FDA(SUBF,IENS,902.17)=$P($G(MOREDATA("IBDATA",VASEQ,2)),"^",10) - . D UPDATE^DIE("E","FDA","EMSG") - I $D(EMSG) D S VAXXX="",VAXXX=$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"FILEARAY",$T(+0)) I VAXXX K VAXXX Q - . W !,"Unexpected error in FILEARAY^"_$T(+0),! - S ZXX="",ZXX=$$NEW57^BPSOSU(IEN59) - K ^TMP($J,"MOREDATA",IEN59) - N ABSBRXI S ABSBRXI=IEN59 D SETSTAT^BPSOSU(0) - Q - ; -CLOSE ; Protocol BPS P1 CLOSE CLAIM ; Close selected claims - N WHICH,VALMI,OK,DIR,Y,X,CLOSE,BPSTRA,BPSCLA,NODISPLY,SUB,RSP,DIRUT,REASON,DIR S (WHICH,VALMI)=0 - D FULL^VALM1 -SEL W ! D EN^VALM2(XQORNOD(0),"O") S VALMBCK="R" Q:'$O(VALMY(0)) - K CLOSE W !!,"You've chosen to CLOSE the CLAIM(S) for the following prescription(s): ",! - F S WHICH=$O(VALMY(WHICH)) Q:'WHICH D - . S BPSTRA=+$P(@DISPLINE@(WHICH),U,2),BPSCLA=$$GET1^DIQ(9002313.59,BPSTRA,3,"I") - . I 'BPSTRA W !,$J(WHICH,2)," *** INVALID ENTRY - CANNOT BE CLOSED ***" K VALMY(WHICH) Q - . I 'BPSCLA W !,$J(WHICH,2)," *** INVALID CLAIM - CANNOT BE CLOSED ***" K VALMY(WHICH) Q - . D RESPINFO^BPSOSQ4(BPSTRA,.RSP) - . I $G(RSP("RSP"))'="Rejected" W !,$J(WHICH,2)," *** NOT REJECTED - CANNOT BE CLOSED ***" K VALMY(WHICH) Q - . L +^BPSC(BPSCLA):0 E W !,$J(WHICH,2)," *** CLAIM ",$$GET1^DIQ(9002313.02,BPSCLA,.01)," IN USE ***" K VALMY(WHICH) Q - . W !,$E($G(^TMP("BPSOS",$J,"VALM",WHICH,0)),1,80) S CLOSE(BPSCLA)=BPSTRA - . W !?9,"Claim ID: ",$$GET1^DIQ(9002313.02,BPSCLA,.01) - G SEL:'$D(CLOSE) - ; - ; - Asks for REASON for Closing - S DIR(0)="S^1:NOT ELECTRONICALLY BILLABLE;2:NOT INSURED;3:SERVICE NOT COVERED;4:COVERAGE CANCELED;5:DRUG NOT BILLABLE;6:INVALID PRESCRIPTION ENTRY;7:PRESCRIPTION DELETED;8:PRESCRIPTION NOT RELEASED" - S DIR("A")="Select Close Claim REASON" - D ^DIR I $D(DIRUT) G UNLK - S REASON=Y - ; - W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Are you sure" D ^DIR I '$G(Y)!$D(DIRUT) G UNLK - N DIE,DA,DR,ERROR S BPSCLA="" W ! - F S BPSCLA=$O(CLOSE(BPSCLA)) Q:BPSCLA="" D - . W !,"Closing Claim ",$$GET1^DIQ(9002313.02,BPSCLA,.01),"..." - . D CLOSE^BPSIBUTL(BPSCLA,CLOSE(BPSCLA),REASON,.ERROR) I $D(ERROR) W "NOT OK" D DSPERR(ERROR) Q - . S DIE="^BPSC(",DA=BPSCLA,DR="901///1;902///"_$$NOW^XLFDT()_";903///"_DUZ_";904///"_REASON D ^DIE - . H 1 W "OK" - ; - F SUB="CHG","DISP","DISPLINE","VALM" K ^TMP("BPSOS",$J,SUB) - S ^TMP("BPSOS",$J,"LAST UPDATE")="" - S ^TMP("BPSOS",$J,"HIST")=0,^TMP("BPSOS",$J,"DISPLINE")=0 - S NODISPLY=1,VALMCNT=0 D HDR^BPSOS6C D UPD^BPSOS6A - S VALMBCK="R" W ! H 2 ;,VALMPGE=1 - ; -UNLK ; Unlocks the Claim file entries - S BPSCLA="" F S BPSCLA=$O(CLOSE(BPSCLA)) Q:'BPSCLA L -^BPSC(BPSCLA) - Q -DSPERR(MSG) ; Display the ERROR message - W !,"Error: *** ",MSG," ***" - Q diff -auBN ./r1/BPSOS96.m ./r2/r/BPSOS96.m --- ./r1/BPSOS96.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS96.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,29 +0,0 @@ -BPSOS96 ;BHAM ISC/FCS/DRS/FLS - display cross refrences for Tech Manual ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - N START,END S START=9002313,END=START+.9999999999999 - D EP(START,END) - Q -EP(START,END) ; - I '$D(^DIC(START)) S START=$O(^DIC(START)) - N FILE S FILE=START - F Q:FILE>END D FILE S FILE=$O(^DIC(FILE)) - Q -FILE ; one file - W "Cross References for file ",FILE," ",$P(^DIC(FILE,0),U),! - N FIELD S FIELD=0 - F S FIELD=$O(^DD(FILE,FIELD)) Q:'FIELD D FIELD - W ! - Q -FIELD N IEN S IEN=0 - F S IEN=$O(^DD(FILE,FIELD,1,IEN)) Q:IEN="" D XREF - Q -XREF ; for ^DD(FILE,FIELD,1,IEN,*) - I ^DD(FILE,FIELD,1,IEN,0)["^TRIGGER^" Q - W "on field ",FIELD," ",$P(^DD(FILE,FIELD,0),U),! - N A S A=0 - F D S A=$O(^DD(FILE,FIELD,1,IEN,A)) Q:'A - . W ?$S(A=0:3,1:6) - . W ^DD(FILE,FIELD,1,IEN,A),! - W ! - Q diff -auBN ./r1/BPSOS97.m ./r2/r/BPSOS97.m --- ./r1/BPSOS97.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOS97.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,34 +0,0 @@ -BPSOS97 ;BHAM ISC/FCS/DRS/FLS - MSM Win NT 4.40 busted! ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; This routine demonstrates the problem: - W !,"TESTING $$ AND ERRORS",! - ;W "Testing on ",$ZV,! - K X - W "Now we call $$SUBROU",! - S X=$$SUBROU(1) - W "Back from call to $$SUBROU with $D(X)=",$D(X) - I $D(X) W ", X=",X,! - Q -SUBROU(ARG) ; - W !,"Now in SUBROU with ARG=",ARG,! - ; This $$NEWTRAP doesn't seem to help - ;I $$NEWTRAP N $ESTACK S $ECODE="",$ETRAP="Q:$Q 0 Q" - N X S X="TRAP^"_$T(+0) - S @^%ZOSF("TRAP") - ;S $ZT="TRAP^"_$T(+0) - ;W "And $ZT=",$ZT,! - W "^%ZOSF(""TRAP"")=",^%ZOSF("TRAP"),! - W "And now we make an error happen:",! - X $T(+1) - W "SHOULD NOT REACH THIS LINE!!!!",! - Q 1 -TRAP() W "At the error trap",! - Q 2 -NEWTRAP() ; do you need the new error trapping? - ;N X S X=$ZV - N Y S Y="MSM for Windows NT, Version " - I X'[Y Q 0 - S X=$P(X,Y,2) - S X=$P(X,".",1,2) - Q X'<4.4 ; v4.4 and up needs it diff -auBN ./r1/BPSOSAA.m ./r2/r/BPSOSAA.m --- ./r1/BPSOSAA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,79 +0,0 @@ -BPSOSAA ;BHAM ISC/FCS/DRS/FLS - Connection utility ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; $$CONNECT(DIALOUT) - initialize modem and dial - ; Called from BPSOSAQ from BPSOSAM - ; Various errors can be returned - ; Future: put a field in the 9002313.55 record to put these - ; stages as you progress through establishing the connection. - ; Future: tap into that field when constructing display message - ; for the data entry / status display screen. - ; That is, show more than just "Waiting to transmit" - show - ; it going through stages like "Initializing modem", - ; "Dialing", "Waiting for remote connect", etc. - ; And tack on "Failed while " in front, when something goes wrong. - ; -CONNECT(DIALOUT) ;EP - - ; Open the device - N RET - S RET=$$OPEN^BPSOSAB(DIALOUT) - I RET Q 20999_",OPEN^BPSOSAB(),"_RET - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",0" - ; - ;Flush input buffer - S RET=$$FLUSH^BPSOSAB(DIALOUT) - I RET Q 20997_",FLUSH^BPSOSAB(),"_RET_",1" - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",1" - ; - ; if it's a direct T1 line connection, we are done - return success - ; - I $$T1DIRECT^BPSOSA(DIALOUT) Q 0 - ; - ; First, ATZ command to reset the modem - ; And flush the buffer, too. - S RET=$$ATZ^BPSOSAB(DIALOUT) - I RET Q 20008_",ATZ^BPSOSAB(),"_RET - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",2" - S RET=$$FLUSH^BPSOSAB(DIALOUT) - I RET Q 20997_",FLUSH^BPSOSAB(),"_RET_",2" - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",3" - ; - ; Then send the initialization string, and flush - ; - S RET=$$INIMODEM^BPSOSAB(DIALOUT) - I RET Q 20009_",INIMODEM^BPSOSAB(),"_RET - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",4" - S RET=$$FLUSH^BPSOSAB(DIALOUT) - I RET Q 20997_",FLUSH^BPSOSAB(),"_RET_",3" - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",5" - ; - ; Diagnostics: query the modem for its status - ; - S RET=$$MODEMSTS^BPSOSAB(DIALOUT) - I RET Q 20997_",MODEMSTS^BPSOSAB(),"_RET_",31" - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",32" - S RET=$$FLUSH^BPSOSAB(DIALOUT) - I RET Q 20997_",FLUSH^BPSOSAB(),"_RET_",31" - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",33" - ; - ; Now we can dial the phone, and flush - ; - S RET=$$DIAL^BPSOSAB(DIALOUT) - I RET Q 20010_",DIAL^BPSOSAB(),"_RET - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",6" - S RET=$$FLUSH^BPSOSAB(DIALOUT) - I RET Q 20997_",FLUSH^BPSOSAB(),"_RET_",4" - S RET=$$STATUS(DIALOUT) I RET Q "20998,STATUS^"_$T(+0)_","_RET_",7" - Q 0 - ; -STATUS(DIALOUT) ;check status of IO - ; Always returns 0 (OK) for direct-connect Modem. - ; Returns $ZB value for terminal server. - ; Development: $$STATRPT^BPSOSAZ, $$GETSTAT^BPSOSAZ may be useful - ; - ;I '$$TCP^BPSOSA(DIALOUT) Q 0 ; relevant only to term server and T1 - ; if last operation timed out (-3), that's okay - ; maybe we should also skim past "end of input" (-1), too - ;N IO S IO=$$IO^BPSOSA(DIALOUT) - ;U IO N ZB S ZB=$ZB S:ZB=-3 ZB=0 Q ZB - Q 0 ;always quit 0 for VA we dont use modems diff -auBN ./r1/BPSOSAB.m ./r2/r/BPSOSAB.m --- ./r1/BPSOSAB.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAB.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,216 +0,0 @@ -BPSOSAB ;BHAM ISC/FCS/DRS/FLS - various modem commands ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; Low-level IO routines which: - ; * take DIALOUT as an argument - ; * optionally ECHO as a second argument, passed along to LOG^POSU - ; * can be called as either DO ^ or as a $$ function - ; * preserve your current $IO - ; - ; T1 line should reach these for OPEN and FLUSH, only. - ; - ; - ;IHS/SD/lwj 06/10/02 Changes made to make the open and - ; use commands Cache compliant. Open command for Cache must - ; be in the format of: - ; O "|TCP|6802":(199.244.222.6:6802:"M"):3 - ; (the "M" is very important in extending the buffer for the - ; large claims.) - ; Changes tested on the Parker Cache test data base and will - ; be incorporated in Patch 2 of ECME V1.0. Changes made - ; to the BPS Dial Out file (^BPS(9002313.55) to include a - ; Cache Device - this device will be used for the T1 connection - ; (New field is 420.03 on the DEVICE node) - ; - ; -OPEN(DIALOUT) ;EP - return 0 if okay, nonzero if error - ; Error can be: 79 - $ZB=79, reproducible by telnet - ; or perhaps just due to a few seconds while port resets from prev - ; use. - Q:'$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) ;LJE;QUIT IF VA - N IO,SERVER,PORT,BAUD,RETVAL ;,MSYSTEM - ;S MSYSTEM=$$MSYSTEM - ;;;S IO=$$IO^BPSOSA(DIALOUT) ; Mumps IO device number - N X S X=$T(+0)_" - MODEM - OPEN - device "_IO - I $$TCP^BPSOSA(DIALOUT) D ; server type device; get server & port names - . S SERVER=$$SERVER^BPSOSA(DIALOUT),PORT=$$PORT^BPSOSA(DIALOUT) - . S X=X_" - "_SERVER_", port "_PORT - E D - . S BAUD=$$GET55FLD^BPSOSA(DIALOUT,208) - . S:'BAUD BAUD=2400 - D LOG^BPSOSL(X,$G(ECHO)) - I $$TCP^BPSOSA(DIALOUT) D - . ; IHS/SD/lwj 06/10/02 begin changes for Cache - . I ^%ZOSF("OS")["OpenM" D Q ;Cache system - .. S RETVAL=0 - .. ;;;O IO:(SERVER:PORT:"M"):3 ;O "|TCP|6802":("199.244.222.6":6802:"M"):3 - .. I '$T S RETVAL=1,X=$T(+0)_" - |TCP|:("_SERVER_":"_PORT_")" ;failed - .. ;;;I 'RETVAL U IO - .. Q - . ;;;I ^%ZOSF("OS")'["OpenM" D Q - .;;;. O IO:(:3) U IO::"TCP" W /SOCKET(SERVER,PORT) - .;;;. S RETVAL=$ZB - .;;;. I $ZB'=0 D - .;;;. S X=$T(+0)_" - MODEM - W /SOCKET("_SERVER_","_PORT_") - $ZB="_$ZB - .;;;. Q - .;;;. ; IHS/SD/lwj 06/10/02 end changes for Cache - E D ; a plain old traditional modem - . N PARAM S PARAM(1)=0 ; no echo - . S PARAM(5)=8388608 ; don't interpret control characters - . S PARAM(5)=PARAM(5)+2097152 ; CTRL/O is data, not usual CTRL/O - . S PARAM(5)=PARAM(5)+4096 ; TAB not expanded - . S PARAM(5)=PARAM(5)+1 ;no echo - . S PARAM(8)=9*4096 - . S PARAM(8)=PARAM(8)+(0*256) - . S PARAM(8)=PARAM(8)+(5*16) - . S PARAM(8)=PARAM(8)+$S(BAUD=2400:11,BAUD=1200:9) - . ;;;O IO:(PARAM(1)::::PARAM(5):::PARAM(8)):600 - . I '$T D - . . S X=$T(+0)_" - MODEM - OPEN command timed out - could not get device "_IO - . . S RETVAL=-1 - . E S RETVAL=0 - I RETVAL D LOG^BPSOSL(X,$G(ECHO)) - Q RETVAL -CLOSE(DIALOUT) ;EP - return 0 if okay, nonzero if error - D FLUSH(DIALOUT,2) ; give it 2 secs to flush? - ;;;N IO S IO=$$IO^BPSOSA(DIALOUT) - D LOG^BPSOSL($T(+0)_" - MODEM - CLOSE - device "_IO,$G(ECHO)) - ;;;C IO Q 0 -FLUSH(DIALOUT,TO) ;EP - return 0 if okay, nonzero if error - I '$D(TO) S TO=0 - ;;;N IO S IO=$$IO^BPSOSA(DIALOUT) - ;;;N X,I,FLUSHSTR,MAXI S FLUSHSTR="",MAXI=3000 - ;;;S X="FZE^"_$T(+0),@^%ZOSF("TRAP") - ;;;U IO F I=0:1:MAXI+1 R *X:TO Q:'$T D - ;;;.I I'>60 S FLUSHSTR=FLUSHSTR_$C(X) - ;;;.E I I=60 S $E(FLUSHSTR,58,60)="..." - ; I = how many characters were flushed - I I D - . N N F N=I:-1:1 I $E(FLUSHSTR,N)?1C D - . . S FLUSHSTR=$E(FLUSHSTR,1,N-1)_"\"_$TR($J($A(FLUSHSTR,N),3)," ","0")_$E(FLUSHSTR,N+1,$L(FLUSHSTR)) - . D LOG^BPSOSL($T(+0)_" - MODEM - FLUSH - "_I_" byte(s) - "_FLUSHSTR,$G(ECHO)) - I I>MAXI D Q -1 ; runaway - error - . D LOG^BPSOSL($T(+0)_" - MODEM - FLUSH - runaway after "_MAXI_" bytes",$G(ECHO)) - Q 0 - ; Error trap for FLUSH, still need this for -FZE D LOGZE("FLUSH") Q -1 -LOGZE(WHERE) D LOG^BPSOSL($T(+0)_" - MODEM - "_WHERE_" - $ZE="_$$ZE^BPSOS) Q - ; - ; ECHOOFF Issue the echo off command to the modem. - ; It is assumed that every modem type has the command E0. - ; If that changes, you need to build a field into 9002313.54. - ; -ECHOOFF(DIALOUT) ; - N RETVAL - D LOG^BPSOSL($T(+0)_" - MODEM - E0 to turn echo off",$G(ECHO)) - D COMMAND^BPSOSA(DIALOUT,"E0") ; hopefully same for all modem types? - S RETVAL=$$WAITSTR^BPSOSAW(DIALOUT,"OK",10) D FLUSH(DIALOUT,1) - Q RETVAL - ; - ; ATZ Issue the ATZ (Reset) command to the modem. - ; It is assumed that every modem type has the command Z. - ; If that changes, you need to build a field into 9002313.54. - ; -ATZ(DIALOUT) ;EP - return 0 if okay, nonzero if error - ; added FLUSH calls to give a little cushion around the ATZ command - N RETVAL - D ECHOOFF(DIALOUT) - D LOG^BPSOSL($T(+0)_" - MODEM - INIT - ATZ command",$G(ECHO)) - D COMMAND^BPSOSA(DIALOUT,"ATZ") ; hopefully same for all modem types? - S RETVAL=$$WAITSTR^BPSOSAW(DIALOUT,"OK",20) D FLUSH(DIALOUT,1) - D ECHOOFF(DIALOUT) ; in case software reset turned it on again - Q RETVAL - ; - ; INIMODEM Send the modem initialization command. - ; This varies a lot by modem type. - ; -INIMODEM(DIALOUT) ;EP - return 0 if okay, nonzero if error - N RETVAL - N INI S INI=$P(^BPS(9002313.54,$$MODEMTYP^BPSOSA(DIALOUT),"INIT"),U) - ; ANMC: "AT&FE0&Q1V1X1&E0&E3&E10&E12&E14$MB2400$SB2400#A3" - D COMMAND^BPSOSA(DIALOUT,INI) - D LOG^BPSOSL($T(+0)_" - MODEM - INIT - command "_INI,$G(ECHO)) - S RETVAL=$$WAITSTR^BPSOSAW(DIALOUT,"OK",20) D FLUSH(DIALOUT,1) - Q RETVAL - ; - ; MODEMSTS - Issue the modem's query command and log the output. - ; The command comes from 9002313.54, since the query - ; command varies a lot from one modem to another. - ; -MODEMSTS(DIALOUT) ;EP - return 0; or you can just DO it. - ;;;N IO,RETVAL,CMD,TIMEOUT,LOOK4OK,I,X,% S IO=$$IO^BPSOSA(DIALOUT) - N MODEMTYP S MODEMTYP=$$MODEMTYP^BPSOSA(DIALOUT) - S %=$G(^BPS(9002313.54,MODEMTYP,"QUERY FOR STATUS")) - S CMD=$P(%,U),TIMEOUT=$P(%,U,2),LOOK4OK=$P(%,U,3) - I CMD="" Q 0 ; no Inquiry command for this modem type?? - I 'TIMEOUT S TIMEOUT=1 - D LOG^BPSOSL($T(+0)_" - MODEM - QUERY - command "_CMD,$G(ECHO)) - D COMMAND^BPSOSA(DIALOUT,CMD) - ;;;U IO - F I=1:1 R X(I):TIMEOUT Q:'$T Q:LOOK4OK&($TR(X(I),$C(13,10),"")="OK") - D LOG^BPSOSL($T(+0)_" - MODEM - QUERY - reply:",$G(ECHO)) - F I=1:1 Q:'$D(X(I)) D - .D LOG^BPSOSL($TR(X(I),$C(13,10),""),$G(ECHO)) - Q 0 - ; - ; DIAL - Issue the command to dial the phone - ; and wait for the successful CONNECT 2400 response. - ; -DIAL(DIALOUT) ;EP - return 0 if okay, nonzero if error - ;;;N IO,RETVAL,DIAL S IO=$$IO^BPSOSA(DIALOUT) - N DIAL,MODEMTYP,CONNMSG - S DIAL="ATDT"_$$PHONENUM(DIALOUT) - S MODEMTYP=$$MODEMTYP^BPSOSA(DIALOUT) - S CONNMSG=$P($G(^BPS(9002313.54,MODEMTYP,"CONNECT MESSAGE")),U) - D LOG^BPSOSL($T(+0)_" - MODEM - DIAL - command "_DIAL,$G(ECHO)) - D COMMAND^BPSOSA(DIALOUT,DIAL) - N X S X=$T(+0)_" - MODEM - DIAL - " - I CONNMSG="" D S RETVAL=0 - .D LOG^BPSOSL(X_" but no CONNECT MESSAGE in 9002313.54",$G(ECHO)) - E I '$$WAITSTR^BPSOSAW(DIALOUT,CONNMSG,40) D S RETVAL=0 - .D LOG^BPSOSL(X_"successful",$G(ECHO)) - E D S RETVAL=1 - .D LOG^BPSOSL(X_"did not receive expected "_CONNMSG,$G(ECHO)) - Q RETVAL - ; - ; $$PHONENUM Look up the phone number for this dial out. - ; -PHONENUM(N) ; - N X,Y - S X=$P($G(^BPS(9002313.99,1,"OUTSIDE LINE")),U) - ; If you do need to dial a number to get an outside line, - ; tack on a comma if needed - modem will pause to wait for - ; second dial tone. (No parameter needed yet since apparently - ; all modems have this feature.) - I X]"",$E(X,$L(X))'="," S X=X_"," - S Y=$$GET55FLD^BPSOSA(N,450.01) - S X=$P(X,U,$S($E(Y)=1:1,1:2)) ; local or long distance? - Q $S(Y]"":X_Y,1:"") - ; - ; HANGUP - Issue the hang up command. - ; -HANGUP(DIALOUT) ;EP - this does nothing. - ; The "W +" and timeout stuff wasn't effective. - ; Just the CLOSE seems to take care of things okay at ANMC. - ; This is probably the case at other sites, too. - ;;;N IO S IO=$$IO^BPSOSA(DIALOUT) - G HANGUP99 - N TRY,I,ANS - ; - ;Make sure input variables are defined - Q:$G(IO)="" - ; - ;Get modem into command mode, then hangup, try up to 3 times - F TRY=1:1:3 D Q:ANS=1 - .;O IO - .H 1 - .;;;F I=1:1:3 U IO W "+" - .H 2 - .;;;U IO W "ATH0",! - .H 1 - . D IMPOSS^BPSOSUE("P","T","Code not reachable","Obsolete subroutine/not used","HANGUP",$T(+0)) - .;need to ; S ANS=$$WaitFor(IO,"OK",2) - ; - ;Close input/output device -HANGUP99 ;D CLOSE^BPSOSAB(DIALOUT) - Q diff -auBN ./r1/BPSOSAD.m ./r2/r/BPSOSAD.m --- ./r1/BPSOSAD.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAD.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,39 +0,0 @@ -BPSOSAD ;BHAM ISC/FCS/DRS/FLS - Longitudinal Redundancy Checker routines ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;--------------------------------------------------------------------- - Q - ; - ;--------------------------------------------------------------------- - ;Longitudinal Redundancy Checker routines - ; - ; - ;Parameters: STRING - STRING of characters (eg: message to be sent - ; to or received from host) - ; - ;Returns: LRC - CHARacter representing the cumlative XOR of - ; each character in the STRING - ;--------------------------------------------------------------------- -LRC(STRING) ;EP - - N LRC,CHAR,INDEX,LEN - ; - ;Loop through STRING and calculate LRC by doing a cumlative XOR - S LRC=$C(0),LEN=$L(STRING) - F INDEX=1:1:LEN D - .S CHAR=$E(STRING,INDEX) - .;;;S LRC=$ZBOOLEAN(LRC,CHAR,6) ;- for MSM System /GTI ;LJE;Don't use this & it doesn't pass xindex - .;S LRC=$ZCRC($C(LRC)_CHAR,1) - Q LRC ;- for MSM System /GTI - ;Q $C(LRC) - ;--------------------------------------------------------------------- - ;Test if LRC character received from host for a message is correct - ; - ;Parameters: GETMSG - Message received from host - ; LRC - LRC character received from host - ; - ;Returns: 1 - LRC is correct - ; 0 - LRC is not correct - ;--------------------------------------------------------------------- -TESTLRC(GETMSG,LRC) ;EP - from BPSOSAM - N XLRC - S XLRC=$$LRC(GETMSG) - Q $S(LRC=XLRC:1,1:0) diff -auBN ./r1/BPSOSA.m ./r2/r/BPSOSA.m --- ./r1/BPSOSA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,104 +0,0 @@ -BPSOSA ;BHAM ISC/FCS/DRS/FLS - Communication Utilities ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; BPSOSA contains a lot of one-liner utility routines - ; available for general use in the BPSOSA* family. - ; And maybe other routines, too. - Q - ; - ; The Dial Out file, 9002313.55 - ; Don't directly refer to 9002313.55 in here - use $$GET55FLD instead. - ; This resolves defaults. - ; - ;IHS/SD/lwj 06/10/02 new logic added to allow the package to work - ; in a Cache environment. Changes added to the IO subroutine - - ; will now check the system type, and if it is Cache, it will - ; retrieve the value in the 420.03 field of the BPS dial Out file - ; rather than the 420.01 field that is used for standard MSM systems. - ; - ; -THEDEF55() Q $O(^BPS(9002313.55,"B","DEFAULT",0)) -ISDEF55(DIALOUT) Q $P(^BPS(9002313.55,DIALOUT,0),U)="DEFAULT" -DEF5599() ;EP - what's the default dial-out as pointed to by 9002313.99? - Q $P($G(^BPS(9002313.99,1,"DIAL-OUT DEFAULT")),U) -DEF55(DIALOUT) ; return pointer to the dial out used to supply defaults - ; for this given dial-out. For the DEFAULT dial out, lookup the - ; pointer in 9002313.99. For others, they point to the default. - I $$ISDEF55(DIALOUT) Q $$DEF5599 - Q $$THEDEF55 - ; -GET55FLD(DIALOUT,FIELD) ;EP - get dialout field value; resort to default if necessary - N X - S X=$$GET55F1(DIALOUT,FIELD) ; try the dial-out itself first - I X="" S X=$$GET55F1($$DEF55(DIALOUT),FIELD) ; else go to the default - Q X -GET55F1(DIALOUT,FIELD) ; - Q $$GET1^DIQ(9002313.55,DIALOUT_",",FIELD,"I") - ; - ; How to terminate modem commands? - ; CR LF has been troublesome in some cases - ; Plain old CR seems to work fine. - ; -TERMATOR(DIALOUT) ; terminate modem command with what? CR? LF? CR LF? - Q $C(13) ; seems to work at ANMC, too. - ;I $ZV["Windows NT" Q $C(13) - ;Q $C(13,10) - ; - ; COMMAND issues a command to the modem. - ; If it doesn't begin with AT, then this routine supplies it. - ; -COMMAND(DIALOUT,COMMAND) ;EP - from BPSOSAB - I $E(COMMAND,1,2)'="AT" S COMMAND="AT"_COMMAND - U $$IO(DIALOUT) W COMMAND,$$TERMATOR(DIALOUT) Q - ; - ; STATUS returns status of the dial out device. - ; You hope to get the result 0. - ; -STATUS(DIALOUT) ; - ;N IO S IO=$$IO(DIALOUT) - ;N ZA,ZB,ZC,RET U IO S ZA=$ZA,ZB=$ZB,ZC=$ZC - ;I $$TCP(DIALOUT) D - ;. S RET=$S(ZB=0:0,ZB=-3:0,1:ZB) - ;E D - ;. S RET=ZC - ;Q RET - Q 0 - ; - ; MSYSTEM() used to return the value of the type of M system - ; field in 9002313.99. It's obsolete. Not used any more. - ; If you need this functionality, use ^%ZOSF(something) - ; - ; SERVER(), PORT(), IO(), TCPSERV(), MODEMTYP() - ; all return information about the current dial out. - ; It uses $$GET55FLD so as to get the value from the default dial - ; out, or if not, from the dial out named DEFAULT. - ; -SERVER(DIALOUT) ;EP - - Q $$GET55FLD(DIALOUT,2021.01) -PORT(DIALOUT) ;EP - - Q $$GET55FLD(DIALOUT,2021.02) -IO(DIALOUT) ;EP - - ;IHS/SD/ljw 06/10/02 routine altered to incorporate changes - ; needed for Cache. If the system is Cache, we will retrieve - ; the device from the 420.03 field - if it's MSM we will use - ; the 420.01 field - both fields in BPS Dial Out - ; - ; IHS/SD/lwj 06/10/02 begin changes - ; - N BPSOFLD - ; - S BPSOFLD=420.01 ;standard MSM systems device - I ^%ZOSF("OS")["OpenM" S BPSOFLD=420.03 ;Cache device - ; - ;Q $$GET55FLD(DIALOUT,420.01) ;remarked out - nxt line added - Q $$GET55FLD(DIALOUT,BPSOFLD) ;new quit for either device - ; - ;IHS/SD/lwj 06/10/02 end Cache changes - ; -TCP(DIALOUT) ;EP - - N X S X=$$GET55FLD(DIALOUT,420.02) Q X=2!(X=3) -TCPSERV(DIALOUT) Q $$GET55FLD(DIALOUT,420.02)=2 -T1DIRECT(DIALOUT) ;EP - - Q $$GET55FLD(DIALOUT,420.02)=3 -MODEMTYP(DIALOUT) ;EP - - Q $$GET55FLD(DIALOUT,.02) diff -auBN ./r1/BPSOSAM.m ./r2/r/BPSOSAM.m --- ./r1/BPSOSAM.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAM.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,217 +0,0 @@ -BPSOSAM ;BHAM ISC/FCS/DRS/FLS - main program for send/receive communications with the Envoy or NDC switches ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; BPSOSAM is the main program for send/receive communications - ; with the Envoy or NDC switches. Or certain insurance company - ; systems, such as the PCS test system. - ; - ; Sets up these variables: - ; BPSECT2 = count of successful xmit/recv transactions - ; (without regard to rejected claims, merely that the - ; xmit/recv sequence completed with apparent success) - ; - ; Subroutines are in BPSOSAN, BPSOSAO, BPSOSAP, BPSOSAQ - ; - ; - ; - Q -SEND(DIALOUT) ;EP - from BPSOSQ3 - S BPSECT2=0 - ; - I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) S VARX=1 - N CLAIMNXT,I,RESPLRC,RESPMSG - N HMSG,LRCOK,SENDMSG,SENDMSGP,GETMSG,CLAIMIEN,LRC,RET - N TRANSBEG,TRANSEND,TRANSTIM ; transaction begin,end,time - N SEG S SEG=245 ; length of string segments storing long string in gbl - ; - N ACK,ENQ,EOT,ETX,NAK,STX,ETB - S ACK=$C(6),ENQ=$C(5),EOT=$C(4),ETX=$C(3) - S NAK=$C(21),STX=$C(2),ETB=$C(23) - ; -S12 ; - ; - S VARX=0 I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) S VARX=1 G VA1 ;LJE;7/14/03 - ;N IO S IO=$$IO^BPSOSA(DIALOUT) I 'IO G S12:$$IMPOSS^BPSOSUE("DB","TRI","IO field missing in DIALOUT="_DIALOUT,,"S12",$T(+0)) - N IO S IO=$$IO^BPSOSA(DIALOUT) I IO="" G S12:$$IMPOSS^BPSOSUE("DB","TRI","IO field missing in DIALOUT="_DIALOUT,,"S12",$T(+0)) - ; IHS/SD/lwj 06/10/02 - end of Cache changes - ; - N T1LINE S T1LINE=$$T1DIRECT^BPSOSA(DIALOUT) - ; -VA1 I $$SHUTDOWN Q 0 - I '$$GETNEXT^BPSOSAP Q 0 - I VARX G START ;LJE;7/16/03 - ; Dial the phone and connect to Envoy - S RET=$$CONNECT^BPSOSAQ(DIALOUT) - I RET D PUTBACK^BPSOSAP Q RET ; error? put back claim before quitting - ; -START ;Main message loop ; we have SENDMSG and SENDMSGP and CLAIMIEN - ; If anything goes wrong, be sure to DO PUTBACK before quitting! - ; - D CLAIMBEG ; write to our own log file - beginning for this claim - D SETCOMMS^BPSOSU(CLAIMIEN,$$GETPLACE^BPSOSL) ; mark start in .59 - ; -LOOP0 ; Wait for host to send ENQ - ; - I 'VARX I 'T1LINE D I RET Q RET ;LJE;7/16/03 - . S RET=$$INITIATE^BPSOSAO I RET D ; wait for host to send ENQ - . . D PUTBACK^BPSOSAP,CLAIMEND ; and if you didn't get it... - ; - ;Send message to host: STX, message, ETX, LRC - ; - D SETCSTAT^BPSOSU(CLAIMIEN,60) ; set prescrs' status = "Transmitting" -LOOP1A D LOG("2 - Sending message #"_CLAIMIEN) - N RETVAL - ; NDC and test mode, "HN." instead of "HN*" ? Ancient code. - ; I don't know if it makes a shred of difference - I $E(SENDMSG,1,3)="HN." D - . D LOG("2 - Sending message in TEST mode") - S TRANSBEG=$P($H,",",2) ; beginning time (for timing transaction) - I VARX D G AGAIN ;LJE;7/14/03 - . K VAMSG - . M VAMSG("HLS")=SENDMSGP - . N IEN59 S IEN59="",IEN59=$O(^BPST("AE",CLAIMIEN,IEN59)) - . S:IEN59="" IEN59=$O(^BPST("AER",CLAIMIEN,IEN59)) - . D CHOP^BPSECMC2(.VAMSG,CLAIMIEN,IEN59) ;NOT CALLING YET - . S BPSECT2=BPSECT2+1 - . K VAMSG - E S RETVAL=$$SENDREQ^BPSOSAS(DIALOUT,.SENDMSG) - D ; stats - figure out which piece the transaction code increments - .N % S %=$P($G(^BPSC(CLAIMIEN,100)),U,3) - .S %=$S(%>0&(%<5):%,%=11:5,1:19) - .D ADDSTAT^BPSOSUD("C",2,1,"C",3,$L(SENDMSG)+3,"C",%,1) - ; - ; -LOOP1B ; - I T1LINE S HMSG="ACK" G LOOP1C - D LOG("2 - Waiting for ACK or NAK") - S HMSG=$$WAITCHAR(ACK_NAK_STX_ENQ,60) - I HMSG="ACK" D - . ; we got what we expected; do nothing else here - E I HMSG="STX" D - . D LOG("2 - Missing ACK but got STX; must be start of response?") - E I HMSG="NAK" D G LOOP1A - . D LOG("2 - Host sent NAK - we will resend") - E I HMSG="ENQ" D G LOOP1A ; Envoy 4.1, p. 12 - . D LOG("2 - Host sent another ENQ - we will resend") - E D Q RET - . D LOG("2 - But received "_HMSG_" instead.") - . D PUTBACK^BPSOSAP,CLAIMEND ; put message back for later transmission - . I HMSG'="+++" D HANGUP - . S RET=$S(HMSG="+++":31101,HMSG="":31102,1:31103) - ; - ; The response message is preceded by STX - ; If we just got an ACK, then wait for the STX - ; -LOOP1C I HMSG="ACK" D - . I T1LINE S HMSG="STX" Q - . S HMSG=$$WAITCHAR(STX,60) - . D LOG("2 - "_HMSG_" received from host") - E I HMSG="STX" D - . ; do nothing; fall through with STX still here - E D Q 30239 - . D LOG("Internal error at LOOP1C") - ; - I HMSG="STX" D - . ; nothing, got what we expected - E D Q RET - . D LOG("2 - Expected STX but got "_HMSG_" instead") - . D PUTBACK^BPSOSAP,CLAIMEND - . S RET=$S(HMSG="+++":30251,HMSG="":30252,1:30253) - ;I HMSG'="STX" D INCSTAT^BPSOSUD("CR",$S(HMSG="ENQ":2,HMSG="NAK":3,HMSG="+++":4,HMSG="":5,1:9)) - ; - ; The host sends us the response message - ; -LOOP3 S (GETMSG,LRC)="" - D SETCSTAT^BPSOSU(CLAIMIEN,70) ; status = "Receiving response" - D LOG("3 - Gathering response from host") - S HMSG=$$GETMSG^BPSOSAR(DIALOUT,.RESPMSG,.RESPLRC,60) - ; - ; HMSG="ETX" or "EOT" or "" (if timed out) - ; - I HMSG="ETX" D - . D LOG("3 - Received "_$L(RESPMSG)_" bytes; LRC "_$A(RESPLRC)) - . D ADDSTAT^BPSOSUD("C",4,1,"C",5,$L(RESPMSG)+3) - E D Q RET - . D INCSTAT^BPSOSUD("CR2",1,"CR2",$S(HMSG="EOT":2,HMSG="":3,HMSG="+++":4,1:9)) - . D LOG("3 - Error while gathering response: HMSG="_HMSG) - . D PUTBACK^BPSOSAP - . D CLAIMEND - . I HMSG'="+++" D HANGUP - . S RET=$S(HMSG="+++":30261,HMSG="":30262,1:30263) - I T1LINE!(VARX) S LRCOK=1 ; G PASTLRC ; if T1 connection, LRC is n/a ;LJE - E I $L(RESPMSG)<9 S LRCOK=0 ; we have seen 1-byte response msg! - E S LRCOK=$$TESTLRC^BPSOSAD(RESPMSG,RESPLRC) - ; - S CLAIMNXT=0 ; assume no claims to send after this one - I LRCOK D - . N CLAIMIEN ; protect CLAIMIEN - $$GETNEXT will reset it - . I '$$SHUTDOWN S CLAIMNXT=$$GETNEXT^BPSOSAP ; remember next CLAIMIEN - . I CLAIMNXT,$P($G(^BPS(9002313.55,DIALOUT,"PROTOCOL")),U) D - . . Q:T1LINE - . . D LOG("6 - Send ETB to host") - . . D SENDETB^BPSOSAS(DIALOUT) - . E D - . . Q:T1LINE - . . D LOG("6 - Send ACK to host") - . . D SENDACK^BPSOSAS(DIALOUT) - . S BPSECT2=BPSECT2+1 ; count our successes (and blessings) - . I BPSECT2>10,BPSECT2#5=0 D TASK^BPSOSQ3() - E D - . D LOG("6 - Send NAK to host because of LRC disagreement") - . D SENDNAK^BPSOSAS(DIALOUT) - ; -PASTLRC ; - S TRANSEND=$P($H,",",2) ; timing - when transaction completed - S TRANSTIM=TRANSEND-TRANSBEG S:TRANSTIM<0 TRANSTIM=TRANSTIM+86400 - ; Statistics: Comms - Transaction Time Comms - ; Comms - Send ACK Comms - Send NAK - D ADDSTAT^BPSOSUD("CT",1,TRANSTIM,"C",7+'LRCOK,1) - ; - I 'LRCOK D G LOOP1C - . S HMSG="ACK" ; fake it out so it drops into the WAITCHAR(STX) code - ; - D CLAIMEND - ; -LR L +^BPSECX("POS",DIALOUT,"R",CLAIMIEN):300 ; lock the response - I '$T G LR:$$IMPOSS^BPSOSUE("L","RIT","LOCK response",,"LR",$T(+0)) - K ^BPSECX("POS",DIALOUT,"R",CLAIMIEN) ; kill anything that's there - F I=1:SEG:$L(RESPMSG) D - .S ^BPSECX("POS",DIALOUT,"R",CLAIMIEN,I\SEG+1)=$E(RESPMSG,I,I+SEG-1) - .S ^BPSECX("POS",DIALOUT,"R",CLAIMIEN,0)=I\SEG+1 - L -^BPSECX("POS",DIALOUT,"R",CLAIMIEN) ; unlock the response - D SETCSTAT^BPSOSU(CLAIMIEN,80) ; Waiting to process response. - ; - ; Now we're ready to go again. -AGAIN ;LJE;7/14/03 - S:'$G(CLAIMNXT) CLAIMNXT=0 - I CLAIMNXT S CLAIMIEN=CLAIMNXT G START - ; - ; No more to send. - ; We expect EOT from Envoy. NDC might send ENQ here? - I VARX Q 0 ;LJE;7/21/03 - I T1LINE Q 0 - S HMSG=$$WAITCHAR(EOT_ENQ,3) - I HMSG'="+++",HMSG'="ENQ" D - . D LOG("9 - No more to send; expect EOT, got "_HMSG) - I HMSG'="+++" D HANGUP - Q 0 - ; ----- end of main part of routine ----- - ; -LOG(X) D LOG^BPSOSL($T(+0)_" - "_X) Q - ; - ; -WAITCHAR(CHARS,TIMEOUT) ;EP - - I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) Q 1 ;LJE;7/16/03 - N RET S RET=$$WAITCHAR^BPSOSAW(DIALOUT,CHARS,TIMEOUT) - I RET="+++" D LOG("WAITCHAR tells us that modem is disconnected.") - Q RET - ; -SHUTDOWN() N RET S RET=$$SHUTDOWN^BPSOSQ3 - I RET D LOG("The transmit/receive shutdown flag is set.") - Q RET -HANGUP D HANGUP^BPSOSAB(DIALOUT) Q - ; NOTE!!! Print of log for one claim depends on finding - ; the exact texts shown below! -CLAIMBEG D LOG("CLAIM - BEGIN - #"_CLAIMIEN_$$CLAIM01) Q -CLAIMEND D LOG("CLAIM - END - #"_CLAIMIEN_$$CLAIM01) Q -CLAIM01() Q " ("_$P(^BPSC(CLAIMIEN,0),U)_")" diff -auBN ./r1/BPSOSAN.m ./r2/r/BPSOSAN.m --- ./r1/BPSOSAN.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAN.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,49 +0,0 @@ -BPSOSAN ;BHAM ISC/FCS/DRS/FLS - Check for cancellation ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; CANCEL: See any of CLAIMIEN's claims have been marked for - ; cancellation. If so, we don't want to send the claim. - ; Called from GETNEXT^BPSOSAP. - ; -CANCEL() ;EP - Deal with Cancellations in CLAIMIEN - N RXI,CXL,KEEP S RXI="",(CXL,KEEP)=0 - N OLDSLOT S OLDSLOT=$$GETSLOT^BPSOSL - F S RXI=$O(^BPST("AE",CLAIMIEN,RXI)) Q:RXI="" D - .I $G(^BPST(RXI,3)) S CXL=CXL+1 Q - I 'CXL Q 0 ; none being canceled - ; At least one being canceled - ; The canceled one gets stamped as finished - ; The others get sent back to status 30, Waiting for packet build - S RXI="" F S RXI=$O(^BPST("AE",CLAIMIEN,RXI)) Q:RXI="" D - .N ABSBRXI S ABSBRXI=RXI ; as some called subroutines expect it - .D SETSLOT^BPSOSL(ABSBRXI) - .I $G(^BPST(RXI,3)) D - ..D DOCANCEL(RXI) ; cancel this claim - .E D ; send this claim back to status 30 - ..S KEEP=KEEP+1 - ..D SETSTAT^BPSOSU(30) - ..D LOG(CXL_" claim"_$S(CXL>1:"s",1:"")_" in the transmit packet were canceled; this claim was requeued.") - ; Finally, rev up a packeter to make sure that any surviving claims - ; get another chance - I KEEP D PACKETER^BPSOSQ1 ; ensure surviving claims get repacketed - D SETSLOT^BPSOSL(OLDSLOT) - Q CXL - ; - ; -DOCANCEL(IEN59) ; actually do the cancellation - ; This may be called from other places. - N BYDUZ S BYDUZ=$P(^BPST(IEN59,3),U) - N MSG S MSG=RXI_" CANCELED by "_DUZ_" "_$P($G(^VA(200,BYDUZ,0)),U) - N OLDSLOT S OLDSLOT=$$GETSLOT^BPSOSL - D SETSLOT^BPSOSL(IEN59) - D LOG(MSG) - D RELSLOT^BPSOSL - I OLDSLOT D SETSLOT^BPSOSL(OLDSLOT) - ; In field 302, put the status of the claim at the time it was canceled - ; Test: I field 302 ]"", then the claim was successfully canceled. - S $P(^BPST(IEN59,3),U,2)=$P(^BPST(IEN59,0),U,2) - D SETSTAT^BPSOSU(99) - D SETRESU^BPSOSU(-1,MSG) - Q -LOG(X) D LOG^BPSOSL($T(+0)_" - "_X) Q diff -auBN ./r1/BPSOSAO.m ./r2/r/BPSOSAO.m --- ./r1/BPSOSAO.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAO.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,48 +0,0 @@ -BPSOSAO ;BHAM ISC/FCS/DRS/FLS - wait for the host to initiate communications ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; Future: extra parameter to WAITCHAR to tell it "no big deal if - ; the character doesn't come in" - it looks like an error message - ; when you don't get the ACK after the ENQ but then again, it's - ; rare. - ; - ; -INITIATE() ;EP - wait for the host to initiate communications - ; usually, this is an ENQ - ; sometimes, it may be ACK/ENQ or ENQ/ACK (Envoy 4.1 page 6) - ; Returns 0 if success, error code if failure - ; Error code 30101 - disconnected - ; This probably means that the host system only gives us one - ; transaction per phone call, and we were hoping for an ENQ to - ; let us send a second transaction, but the host sent EOT instead. - ; Error code 30102 - nothing received and we hung up - ; - D LOG("1 - Waiting for host to initiate with ENQ") - N CH S CH=$$WAITCHAR^BPSOSAM(ENQ_ACK,30) - N RET,OK ; variable OK can probably be gotten rid of - I CH="ENQ" D - . ; the usual case is ENQ, not ENQ ACK, right? so only give 1 sec. - . S CH=$$WAITCHAR^BPSOSAM(ACK,1) - . I CH="ACK" D S OK=1 - . . D LOG("1 - Host sent ENQ ACK to initiate") - . . S RET=0 - . E I CH="" D S OK=1 - . . D LOG("1 - Host sent ENQ to initiate") - . . S RET=0 - . ;E leave RET undef and CH = retval from WAITCHAR - E I CH="ACK" D - . S CH=$$WAITCHAR^BPSOSAM(ENQ,30) - . I CH="ENQ" D S OK=1 - . . D LOG("1 - Host sent ACK ENQ to initiate") - . . S RET=0 - . E D ; leave RET undef and CH = retval from WAITCHAR - . . D LOG("1 - Received ACK but not expected ENQ") - I '$D(RET) D ; if RET not set, then something went wrong - . D LOG("1 - Last WAITCHAR returned "_CH) - . I CH="+++" S RET=30101 ; modem disconnected - . E S RET=30102 D HANGUP ; nothing received - I RET D LOG("1 - Unsuccessful attempt to initiate - "_RET) - Q RET -LOG(X) D LOG^BPSOSL($T(+0)_" - "_X) Q -HANGUP D HANGUP^BPSOSAB(DIALOUT) Q diff -auBN ./r1/BPSOSAP.m ./r2/r/BPSOSAP.m --- ./r1/BPSOSAP.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAP.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,56 +0,0 @@ -BPSOSAP ;BHAM ISC/FCS/DRS/FLS/DLF - GETNEXT, PUTBACK ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; GETNEXT, PUTBACK - manage the list of packets to be sent - ; for this DIALOUT. -LLIST() ; EP - from BPSOSC4 - L +^BPSECX("POS",DIALOUT,"C"):300 Q:$T 1 - D LOG("Unable to get exclusive access to the list of claims for DIALOUT="_DIALOUT) - D TASK^BPSOSQ2 - Q 0 -ULLIST ; EP - from BPSOSC4 - L -^BPSECX("POS",DIALOUT,"C") Q - ; - ; Routines to get and unget messages - ; Given DIALOUT - ; optional parameter N says "first message after #N" - ; Sets SENDMSG = the big string and kills message out of the global - ; SENDMSGP(n)=the message in segments as copied from global - ; CLAIMIEN=the message number - ; (this is for convenient restoring in case of comms error) - ; Returns message number - ; If no message ready to send, returns FALSE and $D(SENDMSG)=0 - ; and $D(CLAIMIEN)=0 - ; -GETNEXT(N) ;EP - - ; (any NEW commands go here) -GETNEXT1 ; - I '$$LLIST S CLAIMIEN="" Q ; lock the list for this DIALOUT - I '$G(N) S N=0 - K SENDMSG,SENDMSGP,CLAIMIEN - S N=$O(^BPSECX("POS",DIALOUT,"C",0)) - I N D - . M SENDMSGP=^BPSECX("POS",DIALOUT,"C",N) ; SENDMSG(*) = message - . ; Note: BPSOSC4 also does a KILL of the claim packet - . K ^BPSECX("POS",DIALOUT,"C",N) - . S SENDMSG="" - . I 'VARX N I F I=1:1:SENDMSGP(0) S SENDMSG=SENDMSG_SENDMSGP(I) - . S CLAIMIEN=N - E S CLAIMIEN="" - D ULLIST ; unlock the list - ; - ; If we got a claim packet to be sent, check to see if any of the - ; claims therein are marked for cancellation. If so, then handle - ; the cancellation, which involves NOT sending this packet. - ; Then loop back and see if you can get another one, instead. - I N,$$CANCEL^BPSOSAN G GETNEXT1 - Q N -PUTBACK ;EP - puts message back, with given CLAIMIEN - F Q:$$LLIST Q:'$$IMPOSS^BPSOSUE("L,P","RIT","Lock list to put back message","DIALOUT="_DIALOUT,"PUTBACK",$T(+0)) - I $D(^BPSECX("POS",DIALOUT,"C",CLAIMIEN)) D G PB9 ; should never happen - . N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P,DB","TRI","Old slot is now occupied again?!",,"PUTBACK",$T(+0)) - M ^BPSECX("POS",DIALOUT,"C",CLAIMIEN)=SENDMSGP -PB9 D ULLIST ; unlock the list - Q -LOG(X) D LOG^BPSOSL($T(+0)_" - "_X) Q diff -auBN ./r1/BPSOSAQ.m ./r2/r/BPSOSAQ.m --- ./r1/BPSOSAQ.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAQ.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,20 +0,0 @@ -BPSOSAQ ;BHAM ISC/FCS/DRS/FLS - CONNECT ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; CONNECT - subroutine of BPSOSAM - ; -CONNECT(DIALOUT) ;EP - connect to DIALOUT = pointer to 9002313.55 - ; Returns 0 if success, nonzero error code if failure - ; Future: we want this to be able to try multiple devices - ; Today, it's one device per destination - ; Future: (Intermediate term) a utility to switch the device - N ECODE S ECODE=$$CONNECT^BPSOSAA(DIALOUT) I 'ECODE Q 0 - N X S X=$T(+0)_" - Error "_ECODE_" returned from $$CONNECT^BPSOSAA" - D LOG^BPSOSL(X) - I +ECODE'=20999 D ; if OPEN succeeded, hangup phone and close device - . D HANGUP^BPSOSAB(DIALOUT) - . N RETVAL S RETVAL=$$CLOSE^BPSOSAB(DIALOUT) - S ^BPS(9002313.55,DIALOUT,"ERROR")=$$NOW_U_ECODE - Q ECODE -NOW() N %,%H,%I,X D NOW^%DTC Q % diff -auBN ./r1/BPSOSAR.m ./r2/r/BPSOSAR.m --- ./r1/BPSOSAR.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,102 +0,0 @@ -BPSOSAR ;BHAM ISC/FCS/DRS/FLS - low-level Receive response ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;--------------------------------------------------------------------- - ;Gather message from host until ETX, EOT control characters have been - ;received or timeout has occurred - ; - ;Parameters: DIALOUT - ; .RESPMSG - Message text gathered from modem - ; .RESPLRC - Longitudinal redundancy checker character - ; TIMEOUT - Number of seconds before process terminates - ; - ;Returns: "EOT" - an EOT was received from the host - ; "" - process timed out - ; "ETX" - ETX received; we have a message & LRC - ;--------------------------------------------------------------------- - Q -GETMSG(DIALOUT,RESPMSG,RESPLRC,TIMEOUT) ;EP - from BPSOSAM - ; - ; Since we cannot USE:(parameters) to set the READ terminator, - ; we must read one character at a time and check for STX,ETX,EOT - ; - ;FIXED128 = how many times we had to clear unwanted high bit - ;ZB mimics a terminal device's $ZB, the READ terminator - N IO S IO=$$IO^BPSOSA(DIALOUT) U IO - D LOG^BPSOSL($T(+0)_" - RESP - Begin gathering host system's response",$G(ECHO)) -1 N FIXED128,MAXMSG,ZA,ZB,I,X,T1LENGTH,T1LINE - S FIXED128=0,MAXMSG=2048 - S T1LINE=$$T1DIRECT^BPSOSA(DIALOUT) ; true if this is a T1 connection - ; -START S (RESPMSG,RESPLRC,RET)="",(T1LENGTH,ZB)=0 - S X="GETZE^"_$T(+0),@^%ZOSF("TRAP") - F I=1:1:MAXMSG D Q:ZB ; loop to read characters -4 . ;;;R *X:0 ;LJE;don't use;doesn't pass xindex - . I '$T S ZB=-1 D ; timed out; retry for up to TIMEOUT secs more - . . ;;;N J F J=1:1:TIMEOUT U IO R *X:1 I $T S ZB=0 Q ;LJE;don't use;doesn't pass xindex - . I ZB D S RET="+++" Q ; Timed out, retried, still couldn't get more - . . D LOG^BPSOSL($T(+0)_" - RESP - Timed out after "_$L(RESPMSG)_" characters",$G(ECHO)) - . I X<1 Q ; Something's wrong: got a character but it's 0 or negative -5 . I X>127 S X=X-128,FIXED128=FIXED128+1 ; clear unwanted high bit - . ; - . ; Did not time out; process the character - . ; - . S X=$C(X) - . ; - . ; If it's a T1 connection, first four bytes are the length - . ; But if a length contains a nonnumeric byte, you have an error. - . ; - . I T1LINE,I<5 D Q:X?1N - . . I X'?1N D S X=EOT - . . . D LOG^BPSOSL($T(+0)_" - RESP - Character #"_I_" of length prefix was nonnumeric $C("_$A(X)_")") - . . S T1LENGTH=T1LENGTH*10+$A(X)-$A("0") - . ; - . ; Handle special control characters for modem connections: - . ; - . I 'T1LINE,X=STX!(X=ETX)!(X=EOT) D Q ; a terminator was received - . . S ZB=$A(X) ; remember what terminated the READ - . . I X=ETX D ; (and this terminator is our favorite one) -7 . . . S RESPMSG=RESPMSG_X - . . . S RESPLRC=$$GETCH(5) ; got the RESPMSG,now get the LRC - . . . I RESPLRC="" D S ZB=-1 ; reset ZB to indicate timeout in GETLRC() - . . . . D LOG^BPSOSL($T(+0)_" - RESP - Timed out - got "_$L(RESPMSG)_" characters but not LRC character",$G(ECHO)) -8 . S RESPMSG=RESPMSG_X - . ; - . ; If T1 line and you've got the entire message gathered, - . ; then fake out an ETX. This will cause the outer loop to stop. - . ; - . I T1LINE,I=(T1LENGTH+4) S ZB=$A(ETX),RESPLRC=0 - ; - ; The READ loop is done - now act on the results - ; - ;D SAVECOPY^BPSOSAY(RESPMSG,"R",RESPLRC) - I FIXED128 D LOG^BPSOSL($T(+0)_" - RESP - Had to clear high bit "_FIXED128_" times",$G(ECHO)) - I ZB=$A(EOT) D Q "EOT" ; EOT received from host - .D LOG^BPSOSL($T(+0)_" - RESP - received EOT",$G(ECHO)) - I ZB=$A(STX) D G START ; 03/08/2000 - . D LOG^BPSOSL($T(+0)_" - RESP - received STX, read again",$G(ECHO)) - I ZB=-1 D Q "" ; timed out - .D LOG^BPSOSL($T(+0)_" - RESP - timed out",$G(ECHO)) - I ZB=0 D Q "" ; must have gotten to MAXMSG !? - .D LOG^BPSOSL($T(+0)_" - RESP - got to MAXMSG characters",$G(ECHO)) - I ZB'=$A(ETX) D Q "" ;ZT ; must be ETX, then, right? - .D LOG^BPSOSL($T(+0)_" - RESP - unexpected ZB = "_ZB_" (should have gotten ETX)",$G(ECHO)) - . D IMPOSS^BPSOSUE("P","TRI","ZB="_ZB,,"GETMSG",$T(+0)) - D LOG^BPSOSL($T(+0)_" - RESP - Received "_$L(RESPMSG)_" characters",$G(ECHO)) -9999999 Q "ETX" - ; - ; GETCH(timeout) - read one character - ; Returns the character obtained, if any. - ; Returns "" if it timed out. -GETCH(TO) ; read one character, timeout TO ; returns "" if timed out - ; - ; If a character is ready immediately, grab it and get out. - ; - ;;;N X U IO R *X:0 I $T Q $C(X) ;LJE;don't use;doesn't pass xindex - ; - ; Otherwise, loop and keep trying; maybe timeout. - ; - ;;;N J,RET S RET="" F J=1:1:TO R *X:1 I $T S RET=$C(X) Q ;LJE;don't use;doesn't pass xindex - Q RET - ; -GETZE D LOGZE("GETMSG") Q "" -LOGZE(WHERE) D LOG^BPSOSL($T(+0)_" - MODEM - "_WHERE_" - $ZE="_$$ZE^BPSOS) Q diff -auBN ./r1/BPSOSAS.m ./r2/r/BPSOSAS.m --- ./r1/BPSOSAS.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAS.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,46 +0,0 @@ -BPSOSAS ;BHAM ISC/FCS/DRS/FLS - Low-level SEND claim ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; Modem - low-level message send - ; SENDREQ is main - ; - ;IHS/SD/lwj 6/7/02 need to add a line feed when the system is - ; Cache. - ; - ;IHS/SD/lwj 8/19/02 we were getting "invalid version" and - ;"corrupted" response messages after the switch to Cache and - ; only at the Cache sites. From the research, it appeared that - ; the buffer was not being cleared all the way. David Slauenwhite, - ; Hoarce Whitt, and Intersystems, determined that rather than a - ; "!" (cr/lf) we needed to W *-3 after each send. The code - ; has been changed, and it appears has solved the problems. - ; - ; -SENDREQ(DIALOUT,MSG) ;EP - - ; (Don't modify MSG; caller may have called with .MSG) - N IO S IO=$$IO^BPSOSA(DIALOUT) U IO - I $$T1DIRECT^BPSOSA(DIALOUT) D - . D LOG^BPSOSL($T(+0)_" - T1 LINE - SEND - "_$L(MSG)_"+4 characters") - . W $TR($J($L(MSG),4)," ","0"),MSG ; write message length, then msg - . ;I ^%ZOSF("OS")["OpenM" W ! ;IHS/SD/lwj 6/7/02 LF for Cache - . I ^%ZOSF("OS")["OpenM" W *-3 ;IHS/SD/lwj 8/19/02 for Cache - . D LOG^BPSOSL($T(+0)_" - T1 LINE - SEND - "_$L(MSG)_"+4 characters") - E D - . N STX,ETX S STX=$C(2),ETX=$C(3) - . N X S X="SENDZE^"_$T(+0),@^%ZOSF("TRAP") - . W STX,MSG,ETX,$$LRC^BPSOSAD(MSG_ETX) - . D LOG^BPSOSL($T(+0)_" - MODEM - SEND - "_$L(MSG)_"+3 characters") - ; SAVECOPY - uncomment for development debugging - ;D SAVECOPY^BPSOSAY(MSG,"C") - Q 0 -SENDZE D LOGZE("SENDREQ") Q -SENDCHAR(DIALOUT,CHAR) N IO S IO=$$IO^BPSOSA(DIALOUT) U IO W CHAR Q -SENDACK(DIALOUT) ;EP - - D SENDCHAR(DIALOUT,$C(6)) Q -SENDNAK(DIALOUT) ;EP - - D SENDCHAR(DIALOUT,$C(21)) Q -SENDEOT(DIALOUT) D SENDCHAR(DIALOUT,$C(4)) Q -SENDETB(DIALOUT) ;EP - - D SENDCHAR(DIALOUT,$C(23)) Q -LOGZE(WHERE) D LOG^BPSOSL($T(+0)_" - MODEM - "_WHERE_" - $ZE="_$$ZE^BPSOS) Q diff -auBN ./r1/BPSOSAW.m ./r2/r/BPSOSAW.m --- ./r1/BPSOSAW.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAW.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,131 +0,0 @@ -BPSOSAW ;BHAM ISC/FCS/DRS/FLS - Modem - wait for char,str ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; Utilities for waiting for certain characters or strings - ; Beware, WAITOK, WAITSTR have different return values! - ; WAITOK(DIALOUT,TIMEOUT) - ; WAITSTR(DIALOUT,STRING,TIMEOUT) - ; WAITCHAR(DIALOUT,CHAR,TIMEOUT) - ; WAIT1(STRING,TIMEOUT) ; on current device - ; WAIT2(CHARSTRING,TIMEOUT) ; on current device - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ; - ; - ; WAITOK(DIALOUT,TIMEOUT) - ; Wait for the "OK" response to a modem command - ; Returns true if received, false if timed out. - ; -WAITOK(DIALOUT,TIMEOUT) ; returns 1 if you got "OK", 0 if you didn't, - N IO S IO=$$IO^BPSOSA(DIALOUT) - N RETVAL - I $$WAITSTR(DIALOUT,"OK",$S($G(TIMEOUT):TIMEOUT,1:20)) D S RETVAL=1 - .D LOG^BPSOSL($T(+0)_" - MODEM - WAITOK - Success",$G(ECHO)) - E D S RETVAL=0 - .D LOG^BPSOSL($T(+0)_" - MODEM - WAITOK - Failure",$G(ECHO)) - Q RETVAL - ; - ; - ; WAITSTR(DIALOUT,STRING,TIMEOUT) - ; Wait for some expected string. - ; TIMEOUT defaults to 60 seconds. - ; Returns 0 if string was received, success - ; Returns -1 if NOT received, failure. - ; -WAITSTR(DIALOUT,STR,TIMEOUT) ;EP - wait for a given string - ; returns 0 if okay, nonzero if not received - N IO,RETVAL S IO=$$IO^BPSOSA(DIALOUT) U IO - D LOG^BPSOSL($T(+0)_" - MODEM - Waiting for string "_STR,$G(ECHO)) - N RET S RET=$$WAIT1(STR,$S($G(TIMEOUT):TIMEOUT,1:60)) - N X S X=$T(+0)_" - MODEM - WAITSTR - " - I RET D S RETVAL=0 - . S X=X_"Received expected "_STR - . D LOG^BPSOSL(X,$G(ECHO)) - E D S RETVAL=-1 - . S X=X_"Did NOT receive expected "_STR - . N RECD S RECD=$P(RET,U,2,$L(RET,U)) - . I RECD="" S X=X_" - Received nothing" - . D LOG^BPSOSL(X,$G(ECHO)) - . I RECD]"" D - . . N I F I=$L(RECD):-1:1 Q:$L(RECD)>250 D - . . . I $E(RECD,I)?1C D - . . . . S RECD=$E(RECD,1,I-1)_"\"_$A(RECD,I)_"\"_$E(RECD,I+1,$L(RECD)) - . . S X=$T(+0)_" - MODEM - WAITSTR - Received instead: "_RECD - . . D LOG^BPSOSL(X,$G(ECHO)) - Q RETVAL - ; - ; WAIT1(STRING,TIMEOUT,MAXCHAR) - ; Wait for the given string. - ; Returns true for success, false for failure. - ; Returns 0^$ZE if error happened (most likely disconnect). - ; (Note! Different return value types than WAITSTR has!) - ; - ; To protect against terminal server overflowing with $C(0), - ; we impose MAXCHAR, default 3000 characters - ; -WAIT1(WAITTXT,TIMEOUT,MAXCHAR) ; - ;returns 1 for success 0 for failure (diff. from WAITSTR) - ; Appended to the return value: "^" and the message it received - N START,END,FLAG,CHAR,MSG,TIMEOUTA,X,NCHAR - I '$D(MAXCHAR) S MAXCHAR=3000 - S TIMEOUTA=0 ; counts up to TIMEOUT and then you've got a real timeout - ;Read input buffer until WAITTXT has been received or timeout - S (FLAG,MSG)="" - S X="W1ZE^"_$T(+0),@^%ZOSF("TRAP") - F NCHAR=1:1:MAXCHAR D Q:TIMEOUTA'127 CHAR=CHAR-128 ; 7-Bit communications - .S:$L(MSG)=255 MSG=$E(MSG,1,254) - .S MSG=MSG_$C(CHAR) - .S FLAG=$S(MSG[WAITTXT:1,1:"") - Q $S(MSG[WAITTXT:1,1:0)_U_MSG -W1ZE D LOGZE("WAIT1") Q 0_U_$$ZE^BPSOS - ; - ; Waiting for a particular control charcter -WAITCHAR(DIALOUT,CHARS,TIMEOUT) ;EP - - ; returns 0 if okay, nonzero if not received - I '$G(TIMEOUT) S TIMEOUT=60 - N IO,RETVAL S IO=$$IO^BPSOSA(DIALOUT) U IO - N X S X=$T(+0)_" - MODEM - Waiting for" - I $L(CHARS)>1 S X=X_" any of" - S X=X_":" - N I F I=1:1:$L(CHARS) S X=X_" $C("_$A(CHARS,I)_")" - S X=X_" timeout "_$G(TIMEOUT) - D LOG^BPSOSL(X,$G(ECHO)) - S RETVAL=$$WAIT2(CHARS,TIMEOUT) - N X S X=$T(+0)_" - MODEM - WAITCHAR - " - I RETVAL]"" D - . S X=X_"Received "_RETVAL - . D LOG^BPSOSL(X,$G(ECHO)) - . I RETVAL="EOT" D D HANGUP^BPSOSAB(DIALOUT) S RETVAL="+++" - . . D LOG^BPSOSL($T(+0)_" - MODEM - Received EOT from host") - E D - . S X=X_"Did NOT receive what was expected." - . D LOG^BPSOSL(X,$G(ECHO)) - Q RETVAL - ;--------------------------------------------------------------------- - ;Monitors a port and waits for particular control characters within a - ;specified time frame - ; WCHARS - String of control characters - ; TIMEOUT - Time frame (in seconds) - at least 1 - ; Returns "STX" or "ETX" or "EOT" or "ENQ" or "ACK" or "NAK" or "" - ; or it may return "RUNAWAY" - ;-------------------------------------------------------------------- -WAIT2(WCHARS,TIMEOUT) ; - N I,MAXI,START,END,FLAG,ACH,CCH,EOT,TIMEOUTA,X - S EOT=$C(4),TIMEOUTA=0 - I WCHARS'[EOT S WCHARS=WCHARS_EOT ; always be on the lookout for EOT - S FLAG="",MAXI=3000 - S X="W2ZE^"_$T(+0),@^%ZOSF("TRAP") - F I=1:1:MAXI D Q:TIMEOUTA'127 ACH=ACH-128 Q:'ACH - . S CCH=$C(ACH) - . S:WCHARS[CCH FLAG=ACH - I I=MAXI Q "RUNAWAY" ; runaway byte stream?! - ;D LOG^BPSOSL("TEMPORARY: Stopped with END="_END_",$H="_$H_",FLAG="_FLAG) - Q $P(",STX,ETX,EOT,ENQ,ACK,,,,,,,,,,,,,,,NAK",",",FLAG) -W2ZE D LOGZE("WAIT2") Q "" -LOGZE(WHERE) D LOG^BPSOSL($T(+0)_" - MODEM - "_WHERE_" - $ZE="_$$ZE^BPSOS) Q diff -auBN ./r1/BPSOSAY.m ./r2/r/BPSOSAY.m --- ./r1/BPSOSAY.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAY.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,69 +0,0 @@ -BPSOSAY ;BHAM ISC/FCS/DRS/FLS - Packet print utils ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;--------------------------------------------------------------------- - Q - ; - ; D DUMPLAST ; look at most recent response and associated claim. - ; - ; D DUMPN(pointer to 9002313.02) prints claim and response both - ; - ; Development and low-level support utilities - ; Most useful callable entry points are: - ; PRINT02(pointer to 9002313.02) - ; PRINT03(pointer to 9002313.03) - ; DIAGPRT(string) to print diagram in pretty formatted form - ; - ; -DUMPLAST ; Print the most recently-received claim-response pair - N IEN03 S IEN03=$P(^BPSR(0),U,3) - N IEN02 S IEN02=$P(^BPSR(IEN03,0),U) - D PRINT02(IEN02),PRINT03(IEN03) - Q - ; - ; -DUMP(REQ) ; given REQ = ien or ID of request packet, do the whole thing - I REQ'?1N.N D Q:REQ="" - . S REQ=$O(^BPSC("B",REQ,0)) - D PRINT02(REQ) - N IEN03 S IEN03=$O(^BPSR("B",REQ,""),-1) ; most recent response! - I IEN03 D PRINT03(IEN03) - Q - ; - ; Useful entry points now that we retain raw packet in 9002313.02,.03 - ; (earlier versions just saved the one single most recent packet) - ; -PRINT02(N) ;EP - dump of a claim packet - D PRINT0X(9002313.02,N) Q -PRINT03(N) ;EP - dump of a response packet - D PRINT0X(9002313.03,N) Q -PRINT0X(FILE,N) ; dump of a claim or response, given file number and IEN - I FILE=9002313.02 D - . W "Claim `",N," ",$P(^BPSC(N,0),U) - . N X S X=$P(^BPSC(N,0),U,5) - . I X W " transmitted ",X - . S X=$P(^BPSC(N,0),U,6) - . I X W " created ",X - E W "Response `",N," received ",$P(^BPSR(N,0),U,2) - N PKT S PKT=$$GETPKT(FILE,N) - D DIAGPRT(PKT) - Q -GETPKT(FILE,N) ; reassemble - N X,ROOT - S X="",ROOT="^BPS"_$S(FILE=9002313.02:"C",FILE=9002313.03:"R") - F I=1:1:$P(@ROOT@(N,"M",0),U,3) D - . S X=X_@ROOT@(N,"M",I,0) - Q X - ; - ; DIAGPRT(string) to print the given string in a pretty formatted way - ; -DIAGPRT(A) ; - N I,J,K,X - I $E(A)=$C(2) S A=$E(A,2,$L(A)) - I $E(A,1,3)="HN."!($E(A,1,3)="HN*") S A=$E(A,4,$L(A)) - F I=1:15:$L(A) D - .W !,$J(I,4),"/ " - .F J=0:1:14 S K=I+J Q:K>$L(A) S X=$E(A,K) D - ..I X=" " W " ","sp"," " - ..E I X?1ANP W " ","'",X,"'" - ..E W $J($A(X),4) - W ! Q diff -auBN ./r1/BPSOSAZ.m ./r2/r/BPSOSAZ.m --- ./r1/BPSOSAZ.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSAZ.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,28 +0,0 @@ -BPSOSAZ ;BHAM ISC/FCS/DRS/FLS - returns $ZA^$ZB values , ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; $$GETSTAT returns $ZA^$ZB values -GETSTAT(DIALOUT) ; - N IO S IO=$$IO^BPSOSA(DIALOUT) - Q 0 - ;U IO Q $ZA_"^"_$ZB Q - ; $$STATRPT displays info about a TCP terminal server connection (MSM) -STATRPT(DIALOUT) ; report $ZA, $ZB for the socket - ; - N ZA,ZB S ZA=$$GETSTAT(DIALOUT),ZB=$P(ZA,"^",2),ZA=$P(ZA,"^") U $P - W "$ZA = characters left in input buffer = ",ZA,! - W "$ZB = ",ZB," " I ZB=0 W "(okay)",! Q - I ZB>0 W "operating system error code",! - E I ZB=-1 W "end of input" - E I ZB=-2 W "socket not allocated" - E I ZB=-3 W "operation timed out" - E I ZB=-4 W "BREAK key" - E I ZB=-5 W "no server allocated (MSM-Unix)" - E I ZB=-6 W "socket already exists" - E I ZB=-7 W "no resource" - E I ZB=-8 W "license limit exceeded" - E I ZB=-9 W "socket operation failed (see docu)" - E I ZB=-10 W "variable length read timed out" - E W "(unknown reason?)" - W ! - Q diff -auBN ./r1/BPSOSB0.m ./r2/r/BPSOSB0.m --- ./r1/BPSOSB0.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSB0.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,6 +0,0 @@ -BPSOSB0 ;BHAM ISC/FCS/DRS/FLS - Obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -MAIN ; option BPS DO BILLING marked as DELETE AT SITE - XINDEX bug? - N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","TI",,,"MAIN",$T(+0)) - Q diff -auBN ./r1/BPSOSB1.m ./r2/r/BPSOSB1.m --- ./r1/BPSOSB1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSB1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSB1 ;BHAM ISC/FCS/DRS/FLS - obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSB2.m ./r2/r/BPSOSB2.m --- ./r1/BPSOSB2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSB2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSB2 ;BHAM ISC/FCS/DRS/FLS - obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSB4.m ./r2/r/BPSOSB4.m --- ./r1/BPSOSB4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSB4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSB4 ;BHAM ISC/FCS/DRS/FLS - obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSB5.m ./r2/r/BPSOSB5.m --- ./r1/BPSOSB5.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSB5.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSB5 ;BHAM ISC/FCS/DRS/FLS - obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSBA.m ./r2/r/BPSOSBA.m --- ./r1/BPSOSBA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,6 +0,0 @@ -BPSOSBA ;BHAM ISC/FCS/DRS/FLS - obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -EN ; option BPS SUP ILC AR BILLING LISTS marked as DELETE AT SITE - XINDEX bug? - N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","T",,,"EN",$T(+0)) - Q diff -auBN ./r1/BPSOSBC.m ./r2/r/BPSOSBC.m --- ./r1/BPSOSBC.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBC.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,25 +0,0 @@ -BPSOSBC ;BHAM ISC/FCS/DRS/FLS - ECME billing - new ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - Q - ; - ; TRANSACT - transaction complete - called from STATUS99^BPSOSU, - ; to request that this transaction be posted. - ; -TRANSACT(IEN57) ; EP - - D SETFLAG(IEN57,1) ; set the flag - D SCHEDULE^BPSOSBD() ; schedule the background job, if needed - Q - ; - ; SETFLAG - set the billing flag for this transaction - ; VALUE = 1 for needs billing - ; VALUE = 0 for billing done - ; -SETFLAG(IEN57,VALUE) ;EP - - D - . N FDA,MSG ; clear the "needs billing" flag - . S FDA(9002313.57,IEN57_",",.16)=VALUE -SF1 . D FILE^DIE(,"FDA","MSG") - . I $D(MSG) D G SF1:$$IMPOSS^BPSOSUE("FM","TRI",.FDA,.MSG,"SETFLAG",$T(+0)) - . . D ZWRITE^BPSOS("FDA","MSG") - Q diff -auBN ./r1/BPSOSBD.m ./r2/r/BPSOSBD.m --- ./r1/BPSOSBD.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBD.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,77 +0,0 @@ -BPSOSBD ;BHAM ISC/FCS/DRS/FLS - ECME billing - background ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - Q -SCHEDULE(DELTA) ; EP - schedule it to run again, if needed - ; DELTA = how many minutes - L +^TMP($J,"BPSOSBD","SCHEDULE"):0 Q:'$T - I '$D(DELTA) S DELTA=$$DELTA - S DELTA=DELTA*60\1 ; how many seconds - I DELTA<60 S DELTA=60 ; but not immediately - N ATTIME S ATTIME=$$TADDNOWS^BPSOSUD(DELTA) - N NEXTTIME S NEXTTIME=$$NEXTTIME - I 'NEXTTIME!(ATTIME$$NOW^BPSOS Q 0 ; this time is already past - Q NEXTTIME ; future -DELTA() ; delta time until background job runs - in minutes - N DELTA S DELTA=$P($G(^BPS(9002313.99,1,"BILLING - NEW")),U,2) - I 'DELTA S DELTA=15 - I $$DISABLED,DELTA<60 S DELTA=60 ; min 1 hour if it's disabled - Q DELTA -DISABLED() Q $P($G(^BPS(9002313.99,1,"BILLING - NEW")),U,3)=1 -DISABLE ; EP - - S $P(^BPS(9002313.99,1,"BILLING - NEW"),U,3)=1 Q -ENABLE ; EP - - S $P(^BPS(9002313.99,1,"BILLING - NEW"),U,3)=0 - D TASKAT() - Q -TASKAT(ZTDTH) ; - I '$D(ZTDTH) S ZTDTH=$$NOW^BPSOS - I '$$NEXTTIME!(ZTDTH<$$NEXTTIME) D - . S $P(^BPS(9002313.99,1,"BILLING - NEW"),U)=ZTDTH - N ZTRTN,ZTIO - S ZTRTN="BACKGR^"_$T(+0),ZTIO="" - ;ZW ZTDTH,ZTRTN - D ^%ZTLOAD - Q -ANY() Q $O(^BPSTL("AS",1,0)) ; any need billing? - ; - ; LOCK, UNLOCK also used by BPSOSBX -LOCK() ;EP - - L +^TMP($J,"BPSOSBD","BACKGR"):15 Q $T - ; -UNLOCK ;EP - - L -^TMP($J,"BPSOSBD","BACKGR") Q -BACKGR ; - I '$$ANY Q ; none need billing - I '$$LOCK Q - D INIT^BPSOSL(DT+.2,1) - D LOG("Billing job begins") - I $$DISABLED D G BACKGR99 - . D LOG("Disabled; will reschedule.") - ; - ; Loop: Process the 9002313.57 entries which need billing. - ; They are listed in ^BPSTL("AS",1,*) - ; BPS57 is the variable name expected by POSTING^BPSOSBB - ; - N BPS57 S BPS57=0 - F S BPS57=$O(^BPSTL("AS",1,BPS57)) Q:'BPS57 D - . D LOG^BPSOSL("Posting transaction "_BPS57_".") - . D POSTING^BPSOSBB ; post the transaction - . D SETFLAG^BPSOSBC(BPS57,0) ; clear the "needs billing" flag - ; - D DONE^BPSOSL - ; -BACKGR99 ; - D UNLOCK - I $$ANY D SCHEDULE($S($$DISABLED:60,1:1)) ; in case any slipped in while we were leaving - Q -ILCAR ; - Q -LOG(X) D LOG^BPSOSL(X) Q -PRINTLOG D PRINTLOG^BPSOSL(DT+.2) Q diff -auBN ./r1/BPSOSBE.m ./r2/r/BPSOSBE.m --- ./r1/BPSOSBE.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBE.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSBE ;BHAM ISC/FCS/DRS/FLS - obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSBI.m ./r2/r/BPSOSBI.m --- ./r1/BPSOSBI.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBI.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSBI ;BHAM ISC/FCS/DRS/FLS - obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSBL.m ./r2/r/BPSOSBL.m --- ./r1/BPSOSBL.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,6 +0,0 @@ -BPSOSBL ;BHAM ISC/FCS/DRS/FLS - obsolete;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -EN ; option BPS LOG OF BILLING marked as DELETE AT SITE - XINDEX bug? - N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","T",,,"EN",$T(+0)) - Q diff -auBN ./r1/BPSOSB.m ./r2/r/BPSOSB.m --- ./r1/BPSOSB.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSB.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,53 +0,0 @@ -BPSOSB ;BHAM ISC/FCS/DRS/FLS - utilities used by BPSOSB* ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; A/R Interfaces - in routines BPSOSB* - ; - ; BPSOSBC,BPSOSBD - the billing background job - ; BPSOSBB - calls to various interfaces - ; BPSOSBB - Third Party Billing - ; BPSOSBQ - reserved for Other interfaces (stub) - ; BPSOSBT - reserved for ANMC - ; BPSOSBP - reserved for PAC (BBM*) - ; BPSOSBV,BPSOSBW - ILC A/R, main program - ; BPSOSB* all others - mostly ILC A/R, many obsolete - ; - ; ILC old A/R's NCPDP forms printing in BPSOSN* - ; New NCPDP forms printing in BPSOSF* - usable by all, not just ILC - ; - ; The following ILC A/R routines are invoked by ECME: - ; (this list written on November 12, 2000) - ; EN^ABSB1592 - called by BPSOSN1 - main routine to print bills - ; ^ABSBMAKE - called by BPSOSBM - create an A/R account - ; OFFNCPDP^ABSBPBRX - called by BPSOSBM - - ; ^ABSBVCN - called by BPSOSQD - to assign a VCN - Q -AGE57(N) ;EP - BPSOSB5 ; how old is ^BPSTL(N,... ? - ; $$AGE57(N)=number of days, with decimal - N %,%H,%I,X D NOW^%DTC ; % = now - N LAST S LAST=$P(^BPSTL(N,0),U,8) - I 'LAST S LAST=$P(^BPSTL(N,0),U,11) - N RET S RET=$$TIMEDIFI^BPSOSUD(LAST,%) - Q RET/86400 -ARSYSTEM() ;EP - what A/R system do we interface to? - ; 0 (or null?) is the ILC system. - ; Other true-valued ones are IHS 3PBilling, etc. - ; The value "NONE" is non-zero, too - Q $P($G(^BPS(9002313.99,1,"A/R INTERFACE")),U) -DOINGAR() ;EP - from many places - Do we do a Billing Interface in BPSOSB*? - Q $S($$ISABMAR:1,$$ISILCAR:1,1:0) -ISILCAR() ;EP - various places - Q $$ARSYSTEM=0 ; returns TRUE if it's ILC's billing system -ISABMAR() ; EP - various places - Q $$ARSYSTEM=3 ; returns TRUE if it's IHS 3rd Party Billing -MUSTILC() ; EP - from many places - I $$ISILCAR Q 1 - W "Requires the ILC Accounts Receivable system",! - D PRESSANY^BPSOSU5() - Q - ; ZWRITE command -ZW(%) ;EP - BPSOSB* ; should instead ZWRITE^BPSOS - I $D(%)=0 W %," undefined",! Q - I $D(%)#10=1 W %,"=",@%,! - N Q S Q=% F S Q=$Q(@Q) Q:Q="" W Q,"=",@Q,! - Q diff -auBN ./r1/BPSOSBP.m ./r2/r/BPSOSBP.m --- ./r1/BPSOSBP.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBP.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,27 +0,0 @@ -BPSOSBP ;BHAM ISC/FCS/DRS/FLS - Billing - PAC;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; Billing interface for PAC, Patient Accounts Component - ; - ; Called at tag POST from BPSOSBB - ; with the variable BPS57 pointing to 9002313.57, the transaction - ; You must return a value - that value is stuffed into field .15 - ; of the transaction record - ; and indexed by ^BPSTL("AR",value,IEN57) - ; - ; Many useful utilities are available in BPSOS57 - ; DO LOG^BPSOSL(text) puts text into the billing log file - ; DO LOG57^BPSOS57(text) puts text into the claim's log file - ; -POST ; EP - from BPSOSBB - N IEN57 S IEN57=BPS57 ; now you can $$label^BPSOS57 - N PREV57 S PREV57=$$PREVIOUS^BPSOS57 ; if this prescrip prev posted - N RESULT,RETVAL S RETVAL="" - S RESULT=$$GET1^DIQ(9002313.57,BPS57_",","RESULT WITH REVERSAL") - ; - ; RESULT can by E PAYABLE, E REJECTED, E CAPTURED, PAPER - ; or E REVERSAL ACCEPTED or PAPER REVERSAL - ; or E REVERSAL REJECTED - ; - S RETVAL=0 - Q RETVAL diff -auBN ./r1/BPSOSBQ.m ./r2/r/BPSOSBQ.m --- ./r1/BPSOSBQ.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBQ.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,27 +0,0 @@ -BPSOSBQ ;BHAM ISC/FCS/DRS/FLS - Billing - Other A/R;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; Billing interface for other Accounts Receivable, - ; - ; Called at tag POST from BPSOSBB - ; with the variable BPS57 pointing to 9002313.57, the transaction - ; You must return a value - that value is stuffed into field .15 - ; of the transaction record - ; and indexed by ^BPSTL("AR",value,IEN57) - ; - ; Many useful utilities are available in BPSOS57 - ; DO LOG^BPSOSL(text) puts text into the billing log file - ; DO LOG57^BPSOS57(text) puts text into the claim's log file - ; -POST() ; EP - from BPSOSBB - N IEN57 S IEN57=BPS57 ; now you can $$label^BPSOS57 - N PREV57 S PREV57=$$PREVIOUS^BPSOS57 ; if this prescrip prev posted - N RESULT,RETVAL S RETVAL="" - S RESULT=$$GET1^DIQ(9002313.57,BPS57_",","RESULT WITH REVERSAL") - ; - ; RESULT can by E PAYABLE, E REJECTED, E CAPTURED, PAPER - ; or E REVERSAL ACCEPTED or PAPER REVERSAL - ; or E REVERSAL REJECTED - ; - S RETVAL=0 - Q RETVAL diff -auBN ./r1/BPSOSBT.m ./r2/r/BPSOSBT.m --- ./r1/BPSOSBT.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,28 +0,0 @@ -BPSOSBT ;BHAM ISC/FCS/DRS/FLS - Billing - ANMC ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; Billing interface for ANMC - ; - ; Called at tag POST from BPSOSBB - ; with the variable BPS57 pointing to 9002313.57, the transaction - ; You must return a value - that value is stuffed into field .15 - ; of the transaction record - ; and indexed by ^BPSTL("AR",value,IEN57) - ; - ; Many useful utilities are available in BPSOS57 - ; DO LOG^BPSOSL(text) puts text into the billing log file - ; DO LOG57^BPSOS57(text) puts text into the claim's log file - ; - ; -POST() ; EP - from BPSOSBB - N IEN57 S IEN57=BPS57 ; now you can $$label^BPSOS57 - N PREV57 S PREV57=$$PREVIOUS^BPSOS57 ; if this prescrip prev posted - N RESULT,RETVAL S RETVAL="" - S RESULT=$$GET1^DIQ(9002313.57,BPS57_",","RESULT WITH REVERSAL") - ; - ; RESULT can by E PAYABLE, E REJECTED, E CAPTURED, PAPER - ; or E REVERSAL ACCEPTED or PAPER REVERSAL - ; or E REVERSAL REJECTED - ; - S RETVAL=0 - Q RETVAL diff -auBN ./r1/BPSOSBU.m ./r2/r/BPSOSBU.m --- ./r1/BPSOSBU.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBU.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSBU ;BHAM ISC/FCS/DRS/FLS - obsolete ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSBW.m ./r2/r/BPSOSBW.m --- ./r1/BPSOSBW.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSBW.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,138 +0,0 @@ -BPSOSBW ;BHAM ISC/FCS/DRS/FLS - Billing - FSI/ILC A/R v1,2;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; Billing interface for FSI/ILC Accounts Receivable, - ; Versions 1 and 2 - ; - ; Called at tag POST from BPSOSBB - ; with the variable BPS57 pointing to 9002313.57, the transaction - ; You must return a value - that value is stuffed into field .15 - ; of the transaction record - ; and indexed by ^BPSTL("AR",value,IEN57) - ; - ; Many useful utilities are available in BPSOS57 - ; need to write - ; DO LOG57^BPSOS57(text) puts text into the claim's log file - ; - ; Note about this billing interface and interlocks: - ; We have another background job to actually post charges. - ; A job is scheduled for each visit - to run BPSOSBX. - ; That posting job uses the same interlock as the main - ; background billing. So you can freely use the "AR" index - ; and everything else. - ; -POST() ; EP - from BPSOSBB - N IEN57 S IEN57=BPS57 ; now you can $$label^BPSOS57 - N PREV57 D - . S X=$P(^BPSTL(IEN57,0),U) ; 1234567.000rt - . S PREV57=$O(^BPSTL("B",X,IEN57),-1) - N RESULT,RETVAL S RETVAL="" - S RESULT=$$GET1^DIQ(9002313.57,BPS57_",","RESULT WITH REVERSAL") - ; - ; RESULT can by E PAYABLE, E REJECTED, E CAPTURED, PAPER - ; or E REVERSAL ACCEPTED or PAPER REVERSAL - ; or E REVERSAL REJECTED - ; - N VISITIEN S VISITIEN=$$VISITIEN^BPSOS57 - ; - ; We want to group all the claims for a single visit and - ; then post them together on a single bill (well, more bills if - ; some of the claims have different insurers. One per insurer.) - ; - ; So for this phase, we simply schedule a billing job for the visit - ; for some time from now (30 minutes?). At that time, we check to - ; see if all the collected charges for the visit are at least - ; (15 minutes?) old. If so, we post. If not, we reschedule for later. - ; - ; But reversals, we handle those right now: - ; The original charge might not yet be posted! It could still be - ; in ^BPSOS("AR",KEY15, waiting. - ; - I RESULT["REVERSAL" D - . D REVERSAL ; IEN57 is a reversal - E D ; it's a charge to be posted - . S RETVAL=$$KEY15 ; make sure posting job is scheduled - Q RETVAL ; caller stuffs this into 9002313.57 field #.15 for us - ; - ; - ; - ; ^BPSTL("AR",key,ien57) - ; What to use for the key? - ; For claims awaiting posting, - ; visitien/insien/time scheduled to post - ; For claims already posted: - ; "" (so it disappears from the index) - ; or ?1N.N (another pointer to where it was posted - ; - ; So to get the vis/ins/time ones, - ; $O(^BPSTL("AR"," ")) - ; -KEY15() N X,Y S X=$$VISITIEN^BPSOS57_"/"_$$INSIEN^BPSOS57_"/" - S Y=$O(^BPSTL("AR",X)) - I $P(Y,"/",1,2)=$P(X,"/",1,2) D ; posting already scheduled - . S $P(X,"/",3)=$P(Y,"/",3) ; so take the same posting time - E D ; posting not yet scheduled for this visit+insurer - . S $P(X,"/",3)=$$TADDNOWS^BPSOSUD($$DELAY1) - . D SCHED(X) - Q X -SCHED(KEY15) ; schedule posting job for transaction as directed by X - ; X = format of $$KEY15, above - S KEY15=$P(KEY15,"/",1,3) - N ZTDTH,ZTSAVE,ZTIO - S ZTDTH=$P(KEY15,"/",3) - S ZTRTN="EN^BPSOSBX",ZTIO="",ZTSAVE("KEY15")="" - D ^%ZTLOAD - Q -REVERSAL ; IEN57 is a reversal - handle it and set RETVAL - S RETVAL="" ; until we say otherwise - D LOG("Transaction "_IEN57_" is a reversal; previous transaction was "_PREV57_".") - I 'PREV57 D Q - . D LOG(" ??No record of any previous charge. Nothing done.") - ; - ; Find where the previous charge was posted. - ; - N PCNDFN S PCNDFN=$P(^BPSTL(PREV57,0),U,3) - ; - ; Perhaps it wasn't posted yet. This would be typical if the - ; reversal is made immediately after the original charge is posted. - ; The original charge is probably in Taskman now waiting for other - ; charges that might come along for the same visit. At that time, - ; the reversal will be detected and posting of charge will be skipped. - ; - I 'PCNDFN D Q ; it wasn't posted the first time around - . D LOG^BPSOSL("Original charge not posted; no adjustment needed.") - ; - ; The original charge was posted, to PCNDFN. - ; Put an adjustment and make a comment on the account. - ; - N WHEN S WHEN=$$GET1^DIQ(9002313.57,IEN57_",",7,"I")_"0000" - S WHEN=$E(WHEN,4,5)_"/"_$E(WHEN,6,7)_"/"_$E(WHEN,2,3) - S WHEN=WHEN_"@"_$E(WHEN,9,10)_":"_$E(WHEN,11,12) - ; - ; if failed reversal, make a comment - ; - I RESULT'="E REVERSAL ACCEPTED",RESULT'="PAPER REVERSAL" D Q - . N RETVAL S RETVAL=$$COMMENT^BPSOSBF(PCNDFN,"CLAIM REVERSED on "_WHEN) - . D LOG^BPSOSL("Comment made on `"_PCNDFN_" for "_RESULT) - ; - ; if successful reversal, write off the old charge - ; - N AMTOLD S AMTOLD=$P(^BPSTL(PREV57,5),U,5) ; original charge amount - N REASON S REASON=RESULT_" on "_WHEN - D ADJUST^BPSOSBX(PCNDFN,AMTOLD,REASON) - N FDA,MSG ; mark transaction as having been posted to A/R. - S FDA(9002313.57,IEN57_",",2)=PCNDFN - S FDA(9002313.57,IEN57_",",.15)=PCNDFN -R88 D FILE^DIE(,"FDA","MSG") - I $D(MSG) D G R88:$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",.MSG,"REVERSAL",$T(+0)) - . D LOGARRAY^BPSOSL("FDA") - . D LOGARRAY^BPSOSL("MSG") - Q - ; - ; -DELAY1() Q 30*60 ; how many seconds to wait before posting -DELAY2() ;EP - - Q $$DELAY1/2 ; how many seconds quiet time before it's safe to post - ; (that is, if any additional charges in the past xxx time, - ; reschedule the posting for later) -LOG(X) D LOG^BPSOSL(X) Q diff -auBN ./r1/BPSOSC1.m ./r2/r/BPSOSC1.m --- ./r1/BPSOSC1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSC1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,102 +0,0 @@ -BPSOSC1 ;BHAM ISC/FCS/DRS/DLF - certification testing ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; DEVELOPMENT USE ONLY!!! For use when doing certification testing. - ; (Envoy, PCS, etc.) - ; - ; The format has to be in 9002313.92, with NDC BIN number and - ; Envoy plan number filled in. - ; Need to have ^BPSEI(insurer,100) pointing to the format - ; The insurer comes from $P(^BPSC(n,0),U,2) - ; Point the insurer to the RESERVED - FOR TESTING dial out. - ; - ; Have to set up an entry in 9002313.31. Fill in values for - ; each of the NCPDP data dictionary fields for the test claim. - ; In general, DON'T fill in 101 BIN Number. It will pick up the - ; Envoy plan number from the 9002313.92 record for you. - ; - ; Once, before doing any of these, - ; - ; DO SETINSUR^BPSOSC1(low,high pointer to 9002313.31) - ; It prompts for insurer and sets the right insurer into each of - ; those .31 records. - ; - ; BPS INSURER file - BPS SETUP INSURER QUICK to attach it to - ; the format you're testing. - ; - ; DO SETDATE^BPSOSC1(date,low,high pointer to 9002313.31) - ; - ; - ; Then, to test an individual claim: - ; - ; DO TEST^BPSOSC2(pointer to 9002313.31) - ; But if you're doing a Reversal, - ; instead DO REVERSAL^BPSOSC2(pointer to 9002313.31) - ; Temporarily uncomment the line in RXI4REV^BPSOSU - ; - ; DO SEND^BPSOSC2(pointer to 9002313.31) to transmit - ; - ; DO LOG^BPSOSC2 to invoke BPS COMMS LOG - ; RESERVED - FOR TESTING is dial out `5 (saves typing!) - ; - ; DO PRINT^BPSOSC2(pointer to 9002313.31) to dump raw claim - ; and response packets - ; DO PRINTR^BPSOSC2(pointer to 9002313.31) to dump response only - ; - ; Use Fileman to print 9002313.02, .03 fields' contents. - ; DO ^%G on ^BPSC(entry # to look at fields that - ; way, especially the trailing spaces. - ; - ; When there's multiple test claims to send, and the data varies - ; just a little bit, use fileman Transfer Entries, then Enter/Edit - ; to change the few that need to be changed. - ; - Q - ; Utilities to operate on lots of claims at once: -SETDATE(DATE,LOW,HIGH) ; Set DATE FILLED,DATE WRITTEN fields - ; to the given date ; DT is a good choice for parameter 1! - N CLAIM,FIELD - I '$G(DATE) S DATE=DT - F CLAIM=LOW:1:HIGH F FIELD=401,414 D SETFIELD(CLAIM,FIELD,DATE) - Q -SETINSUR(LOW,HIGH) ; - N DIC,X,DTIME,DLAYGO,DINUM,Y,DTOUT,DUOUT - ;S DIC="^AUTNINS(",DIC(0)="AEMN" D ^DIC Q:Y<1 S Y=+Y - F CLAIM=LOW:1:HIGH D SET0(CLAIM,4,Y) - Q -SET0(CLAIM,PIECE,VALUE) ; set given piece of 0 node of 9002313.31 entry - Q:'$D(^BPS(9002313.31,CLAIM)) - S X=^BPS(9002313.31,CLAIM,0) - N REF S REF="^BPS(9002313.31,"_CLAIM_",0)" ;=$ZR - S ^TMP("BPS",$J,"BPSOSC1",DT,REF)=X ; save old values, just in case - S $P(X,U,PIECE)=Y - S ^BPS(9002313.31,CLAIM,0)=X - W "Done for `",CLAIM,": ",X,! - Q -SETFIELD(CLAIM,FIELD,VALUE) ; general - set NCPDP field # value for given - ; entry in 9002313.31 ; both in claim header and prescription detail - N M,N S M=0 - F S M=$O(^BPS(9002313.31,CLAIM,1,M)) Q:'M D ; claim header loop - . N X S X=^BPS(9002313.31,CLAIM,1,M,0) - . S REF="^BPS(9002313.31,"_CLAIM_",1,"_M_",0)" ;,REF=$ZR - . D SETF1 - S N=0 F S N=$O(^BPS(9002313.31,CLAIM,2,N)) Q:'N D ; presc loop - . N M S M=0 - . F S M=$O(^BPS(9002313.31,CLAIM,2,N,1,M)) Q:'M D ; field in presc - . . N X S X=^BPS(9002313.31,CLAIM,2,N,1,M,0) - . . S REF="^BPS(9002313.31,"_CLAIM_",2,"_N_",1,"_M_",0)" ;,REF=$ZR - . . D SETF1 - Q -SETF1 ; given REF, X, FIELD, VALUE - I REF'?1"^BPS(9002313.31,".E D Q ; safety!!! - . D IMPOSS^BPSOSUE("P","T","Bad global REF="_REF,,"SETF1",$T(+0)) - N F S F=$P(X,U) ; pointer to 9002313.91 - N Y S Y=^BPSF(9002313.91,F,0) - I $P(Y,U)'=FIELD Q ; match on NCPDP Field # - S ^TMP("BPS",$J,"BPSOSC1",DT,REF)=X ; save old value of node - S $P(X,U,2)=VALUE ; replace it with the new value - W "Changed ",REF,"=",@REF - S @REF=X - W " to ",@REF,! - Q diff -auBN ./r1/BPSOSC2.m ./r2/r/BPSOSC2.m --- ./r1/BPSOSC2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSC2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,253 +0,0 @@ -BPSOSC2 ;BHAM ISC/FCS/DRS - certification testing ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; see remarks in BPSOSC1 too - Q - ; ^BPS(9002313.31, has data for test claims - ; Now construct packets -ALL ; Construct packets for all entries in 9002313.31 - D IMPOSS^BPSOSUE("P","TI","Development utility - incomplete",,"ALL",$T(+0)) - Q - ; -TEST(ENTRY) ; - K BPS - S ZREVERSE=0 - S BPS51=1 - S VARX=0 I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) S VARX=1 - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S CERTIFY=1 - ;S CERTIFY=1 - W "Testing in ",$T(+0),! - I 'VARX I '$P(^BPS(9002313.31,ENTRY,0),U,4) D Q - . W "Field .04 in 9002313.31 needs to have pointer to insurer.",! - N DIALOUT S DIALOUT=$$DIALOUT - N X S X=$$PACKET(ENTRY,DIALOUT,2) ; ^TMP($J gets copy of BPS() data - W "Input: 9002313.31 entry `",ENTRY,! - W "Output: 9002313.02 entry `",X,! - W !,"To send this claim, DO SEND^BPSOSC2(",ENTRY,")",! - Q -REVERSAL(ENTRY,N) ; construct the reversal packet for this 9002313.31 entry - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S CERTIFY=1 - ;S CERTIFY=1 - K BPS - S ZREVERSE=1 - D LOG^BPSOSL("Reversal claim `"_ENTRY_" "_$P(^BPSC(ENTRY,0),U)) - ; for the N'th prescription therein - N defaults to 1 - ; First construct the original version. - D TEST(ENTRY) - N ORIG K WP S ORIG=$P(^BPS(9002313.31,ENTRY,0),U,3) - I 'ORIG D Q - . D IMPOSS^BPSOSUE("DB,P","TRI","Error constructing original claim",,"REVERSAL - 1",$T(+0)) - N REVERSAL S REVERSAL=$$REVERSE^BPSECA8(ORIG,$S($G(N):N,1:1)) - W "Reversal: 9002313.02 entry `",REVERSAL,! - I 'REVERSAL D Q ; error during construction of reversal - . D IMPOSS^BPSOSUE("DB,P","TRI","Error constructing reversal claim",,"REVERSAL - 2",$T(+0)) - ; Now construct the data packet - N COUNT,DIALOUT,CLAIMIEN S COUNT=0 - S DIALOUT=$$DIALOUT,CLAIMIEN=REVERSAL D PASCII1^BPSOSQH - ; ORIG is obsolete, orphaned - ; Overwrite the pointer to 9002313.02 with the Reversal packet - N DIE S DIE=9002313.31,DA=ENTRY,DR=".03////"_REVERSAL D ^DIE - ; Now SEND^BPSOSC2(ENTRY) will send the reversal - Q -DIALOUT() ; - I VARX Q "1VA" ;LJE - Q $O(^BPS(9002313.55,"B","RESERVED - DO NOT USE",0)) -SEND(ENTRY) ; - N IEN02 S IEN02=$P(^BPS(9002313.31,ENTRY,0),U,3) - D RUNTEST^BPSOSC3($$DIALOUT,IEN02) - W "The log file can be viewed by DO LOG^",$T(+0),! - Q -LOG ;EP - - W !,"At the prompt, just type RES to get the RESERVED - DO NOT USE",! - D COMMSLOG^BPSOSU6 - Q -PRINT(IEN31,FLAG) ; - W "IEN31=",IEN31,! - N CLAIM S CLAIM=$P(^BPS(9002313.31,IEN31,0),U,3) - I 'CLAIM W "No claim for IEN31=",IEN31,! Q - I $G(FLAG)=0 G P12 - D PRINT02^BPSOSAY(CLAIM) -P12 N RESP S RESP=$O(^BPSR("B",CLAIM,""),-1) ; get the most recent resp. - I 'RESP W "No response for CLAIM=",CLAIM,! Q - D PRINT03^BPSOSAY(RESP) - Q -PRINTR(IEN31) ; - D PRINT(IEN31,0) - Q -SAVEBPS K ^TMP($J,$T(+0)) - N % S %="BPS" - F S %=$Q(@%) Q:%="" S ^TMP($J,$T(+0),%)=@% - Q -PACKET(ENTRY,DIALOUT,DUMPBPS) ; EP - from BPSOSC4 - N BPS - D SETBPS(ENTRY) ; construct the BPS(*) array - I $G(DUMPBPS)[1 D ZWRITE^BPSOS("BPS") ;ZW BPS - I $G(DUMPBPS)[2 D SAVEBPS - N N S N=$P(^BPS(9002313.31,ENTRY,2,0),U,3) - D NEWCLAIM^BPSOSCE(1,N,N) ; builds a 9002313.02 record - N CLAIMIEN S CLAIMIEN=$P(^BPSC(0),U,3) - N COUNT S COUNT=0 ; this variable is used by PASCII1^BPSOSQH - D PASCII1^BPSOSQH ; construct the data packet - N DA,DIE,DR S DIE=9002313.31,DA=ENTRY,DR=".03////"_CLAIMIEN D ^DIE - Q CLAIMIEN -SETBPS(ENTRY) ; Construct packet for just one entry in 9002313.31 - W "Create 9002313.02 claim for " - W $P(^BPS(9002313.31,ENTRY,0),U),! - S BPS("Insurer","IEN")=$P(^BPS(9002313.31,ENTRY,0),U,4) - S BPS("Site","Switch Type")=$P(^BPS(9002313.31,ENTRY,0),U,5) - I BPS("Site","Switch Type")="" S BPS("Site","Switch Type")="ENVOY" - I VARX S BPS("Site","Switch Type")="VA" - I 'VARX S BPS("NCPDP","IEN")=$P(^BPSEI(BPS("Insurer","IEN"),100),U) - E S BPS("NCPDP","IEN")=$P(^BPS(9002313.31,ENTRY,4),"^",1) - S BPS("NCPDP","BIN Number")=$P(^BPSF(9002313.92,BPS("NCPDP","IEN"),1),U) - S BPS("NCPDP","Envoy Plan Number")=$P(^BPSF(9002313.92,BPS("NCPDP","IEN"),1),U,4) - S BPS("NCPDP","Version")=$P(^BPSF(9002313.92,BPS("NCPDP","IEN"),1),U,2) - S BPS("Envoy Terminal ID")=$P(^BPS(9002313.56,1,0),U,6) - S BPS("Patient","SSN")="" - ; - I $G(ZREVERSE) D - .S BPS("RX",1,"RX IEN")=1 - .S BPS("RX",1,"IEN59")="999991.00001",BPS("RX","0")=1,BPS("RX",BPS("RX","0"),"Date Filled")=20011206,IEN59="999991.00001" - ; - ;S BPS("RX",1,"RX IEN")="502762.00011" - ;S IEN59="502762.00011" - I '$G(BPS("RX",1,"RX IEN")) S BPS("RX",1,"RX IEN")=1,(IEN59,BPS("RX",1,"IEN59"))="999"_ENTRY_".00001" - ; - ;for advancepcs - second bin number and hardcoded rx number. - S BPS("RX",1,"CERT RX IEN")=BPS("RX",1,"RX IEN") - I ",20,21,22,23,15,16,"[(","_ENTRY_",") S BPS("RX",1,"CERT RX IEN")=$P(^BPS(9002313.31,ENTRY,2,1,1,8,0),"^",2) - ; - ;I ",8,9,10,"[(","_ENTRY_",") S BPS("RX",1,"CERT RX IEN")="502762" - S BPS("Site","Pharmacy #")=10 - S DFN=$P(^BPS(9002313.31,ENTRY,4),"^",2) - N A,N S A=0 ; Loop through claim header fields - F S A=$O(^BPS(9002313.31,ENTRY,1,A)) Q:'A D - . ; Set the Claim Header fields - . N X S X=^BPS(9002313.31,ENTRY,1,A,0) - . N FIELD S FIELD=$P(^BPSF(9002313.91,$P(X,U),0),U) - . W !,FIELD,?30,$P(X,U,2) - . D SETBPS1(FIELD,$P(X,U,2)) - S N=0 ; Loop through prescription fields - F S N=$O(^BPS(9002313.31,ENTRY,2,N)) Q:'N D - . N A S A=0 - . F S A=$O(^BPS(9002313.31,ENTRY,2,N,1,A)) Q:'A D - . . S X=^BPS(9002313.31,ENTRY,2,N,1,A,0) - . . N FIELD S FIELD=$P(^BPSF(9002313.91,$P(X,U),0),U) - . . W !,FIELD,?30,$P(X,U,2),?50,N - . . D SETBPS1(FIELD,$P(X,U,2),N) - . ; Construct a few other fields that weren't already set - . ; Need this IEN59 for logging some stuff. - . ; call it 9999991.00001, 9999992.00001, etc. - . I '$D(^PSRX(BPS("RX",1,"RX IEN"))) S BPS("RX",N,"IEN59")=$$MYIEN59(ENTRY) ;LJE N TO ENTRY - . I '$D(^PSRX(BPS("RX",1,"RX IEN"))) D INIT^BPSOSL(BPS("RX",N,"IEN59")) - ; Construct a few other fields that weren't already set. - S BPS("Patient","Name")=$G(BPS("Patient","Last Name"))_","_$G(BPS("Patient","First Name")) - I '$D(BPS("RX",1,"Quantity")) S BPS("RX",1,"Quantity")=BPS("RX",1,"Metric Decimal Quantity") - ; - ;S ^BPST(BPS("RX",1,"IEN59"),0)=BPS("RX",1,"IEN59")_"^"_10_"^"_BPS("NCPDP","PCN")_"^^^"_DFN_"^^^^"_DUZ - ;S ^BPST(BPS("RX",1,"IEN59"),1)=$P(BPS("RX",1,"IEN59"),"^",1)_"^"_BPS("RX",1,"NDC")_"^^" - ;ZW BPS - S BPS("RX",1,"Date Filled")=BPS("RX","Date Filled") - I ENTRY=9 S BPS("RX",ENTRY,"Date Filled")=20040107,BPS("RX","Date Filled")=20040107 - S BPS("RX","0")=1 - I ENTRY=53 S BPS("RX",ENTRY,"Prescriber ID Qualifier")=12 - Q -PRINTLOG(N) ; print the log file for test claim number N - D PRINTLOG^BPSOSL($$MYIEN59(N)) Q -MYIEN59(N) ; a fake number - Q "999999"_N_".00001" -SETBPS1(FIELD,VALUE,N) ; store values in Claim Header's BPS(*) - N OK S OK=0 - N I F I=1:1 Q:$T(TABLE+I)=" ;*" D Q:OK - . N X S X=$T(TABLE+I) - . I $P(X,";",2)'=FIELD Q - . S @("BPS("_$P(X,";",3)_")=VALUE") - . S OK=1 - I 'OK W !,"Failed to find field ",FIELD," in TABLE^",$T(+0),! - ;W !,FIELD,"^",VALUE - Q -TABLE ; - ;101;"NCPDP","Envoy Plan Number" - ;102;"NCPDP","Version" - ;103;"Transaction Code" - ;104;"NCPDP","PCN" - ;109;"Transaction Count" - ;110;"NCPDP","Software Vendor/Cert ID" - ;111;"NCPDP","Segment Identification" - ;201;"Site","Pharmacy #" - ;202;"Service Provider ID Qual" - ;301;"Insurer","Group #" - ;302;"Insurer","Policy #" - ;303;"Insurer","Person Code" - ;304;"Patient","DOB" - ;305;"Patient","Sex" - ;306;"Insurer","Relationship" - ;308;"Patient","Other Coverage Code" - ;307;"Customer Location" - ;309;"Eligibility Clarification Code" - ;310;"Patient","First Name" - ;311;"Patient","Last Name" - ;312;"Cardholder","First Name" - ;313;"Cardholder","Last Name" - ;322;"Patient","Street Address" - ;323;"Patient","City" - ;324;"Patient","State" - ;325;"Patient","Zip" - ;331;"Patient","Patient ID Qualifier" - ;332;"Patient","SSN" - ;326;"Patient","Phone #" - ;401;"RX","Date Filled" - ;402;"RX",N,"RX Number" - ;403;"RX",N,"Refill #" - ;404;"RX",N,"Quantity" - ;405;"RX",N,"Days Supply" - ;406;"RX",N,"Compound Code" - ;407;"RX",N,"NDC" - ;408;"RX",N,"DAW" - ;409;"RX",N,"Ingredient Cost" - ;410;"RX",N,"Sales Tax" - ;411;"RX",N,"Prescriber ID" - ;412;"RX",N,"Dispensing Fee" - ;414;"RX",N,"Date Written" - ;415;"RX",N,"# Refills" - ;416;"RX",N,"Preauth #" - ;418;"RX",N,"Level of Service" - ;419;"RX",N,"Origin Code" - ;420;"RX",N,"Clarification" - ;421;"RX",N,"Primary Prescriber" - ;422;"RX",N,"Clinic ID" - ;423;"RX",N,"Basis of Cost Determination" - ;424;"RX",N,"Diagnosis Code" - ;426;"RX",N,"Usual & Customary" - ;427;"RX",N,"Prescriber Last Name" - ;429;"RX",N,"Unit Dose Indicator" - ;430;"RX",N,"Gross Amount Due" - ;431;"RX",N,"Other Payor Amount" - ;433;"RX",N,"Patient Paid Amount" - ;436;"RX",N,"Alt. Product Type" - ;438;"RX",N,"Incentive Amount" - ;439;"RX",N,"DUR","DUR Conflict Code",439 - ;440;"RX",N,"DUR","DUR Intervention Code",440 - ;441;"RX",N,"DUR","DUR Outcome Code",441 - ;442;"RX",N,"Metric Decimal Quantity" - ;443;"RX",N,"Primary Payor Denial Date" - ;444;"RX",N,"Provider ID" - ;455;"RX",N,"Rx/Service Ref Num Qual" - ;460;"RX",N,"Quantity" - ;461;"Claim",N,"Prior Auth Type" - ;462;"Claim",N,"Prior Auth Num Sub" - ;465;"RX",N,"Provider ID" - ;466;"RX",N,"Prescriber ID Qualifier" - ;467;"RX",N,"Prescriber Location Code" - ;468;"RX",N,"Primary Care Prov ID Qual" - ;469;"RX",N,"Primary Care Prov ID" - ;470;"RX",N,"Primary Care Prov Last Name" - ;473;"RX",N,"DUR","DUR/PPS CODE COUNTER",473 - ;478;"Insurer","Other Amt Claim Sub Cnt" - ;479;"Insurer","Other Amt Claim Sub Qual" - ;480;"Insurer","Other Amt Claim Submitted" - ;481;"Insurer","Flat Sales Tax Amt Sub" - ;482;"Insurer","Percentage Sales Tax Amt Sub" - ;483;"Insurer","Percent Sales Tax Rate Sub" - ;484;"Insurer","Percent Sales Tax Basis Sub" - ;498;"RX",N,"Prescriber Phone #" - ;* diff -auBN ./r1/BPSOSC3.m ./r2/r/BPSOSC3.m --- ./r1/BPSOSC3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSC3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,53 +0,0 @@ -BPSOSC3 ;BHAM ISC/FCS/DRS/DLF - development - certification testing ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -RUNTEST(DIALOUT,FROM,THRU) ;EP - from BPSOSC2,BPSOSC4 - I '$D(THRU) S THRU=FROM - K ^BPSECX("POS",DIALOUT) - N I F I=FROM:1:THRU D - . N J S J=$P(^BPSC(I,"M",0),U,3) - . S ^BPSECX("POS",DIALOUT,"C",I,0)=J - . N K F K=1:1:J D - . . S ^BPSECX("POS",DIALOUT,"C",I,K)=^BPSC(I,"M",K,0) - D TASK^BPSOSQ2 ; which should start up COMMS^BPSOSQ3 - Q -LASTCOMM ; print the last comms log - look backwards for the last .1 suffix - S X=9999999999 - F S X=$O(^BPSECP("LOG",X),-1) Q:'X Q:X#1=.1 - W "Comms log ",X,! H 1 - D PRINTLOG^BPSOSL(X) - Q -RESTOR02 ; by sending ASCII file A:\BPSEC02.GSA - N I,X,Y - K ^TMP($J) N DONE - W "SEND file A:\BPSEC02.GSA in ASCII mode, you have 20 seconds:",! - F I=1:1 R ^TMP($J,I):20 Q:'$T - D CLR0203("YES") - ;K ^BPSC(*) - W !,"Now setting the data values...",! - F I=3:2 D Q:$G(DONE) - . S X=^TMP($J,I),Y=^TMP($J,I+1) - . I X="*",Y="*" S DONE=1 Q - . S @X=Y - W "We processed up through line number ",I-1,! - Q -CLR0203(X) ; erase all entries in 9002313.02 and .03 claims & responses - I X'="YES" D Q ; must pass this parameter to say you're really sure - . N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","TI","parameter X="_X,,"CLR0203",$T(+0)) - N IEN,DA,DR,DIE,FILE - F FILE=9002313.02,9002313.03 DO CLR0203A(FILE) - Q -CLR0203A(FILE) I X'="YES" D Q - . N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","TI","parameter X="_X,,"CLR0203A",$T(+0)) - N X,IEN,DIE,DA,DR - W "Erasing all entries in file ",FILE,"..." - S IEN=0 F S IEN=$O(^BPS(FILE,IEN)) Q:'IEN D - . S DIE=FILE - . I DIE'=9002313.02,DIE'=9002313.03 D Q ; safety! - . . N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","TI","DIE="_DIE,,"CLR0203A",$T(+0)) - . S DA=IEN,DR=".01///@" - . D ^DIE - . W:$X>70 !?5 W "." - W ! - D ZWRITE^BPSOS("IEN") - Q diff -auBN ./r1/BPSOSCA.m ./r2/r/BPSOSCA.m --- ./r1/BPSOSCA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSCA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,76 +0,0 @@ -BPSOSCA ;BHAM ISC/FCS/DRS - Create 9002313.02 entries ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; Create 9002313.02 entries for RXILIST(*) claims. - ; Called from PACKET^BPSOSQG - ; - ; Input: - ; RXILIST(IEN59) array of pointers to 9002313.59 - ; A list of prescriptions for the same visit/patient/etc. - ; to be bundled into one or more 9002313.02 claims - ; - ; Outputs: - ; CLAIMIEN(CLAIMIEN)="", pointers to the ^BPSC(CLAIMIEN, - ; claim records created. - ; ERROR - ; - ; BPSOSCA calls: - ; BPSOSCB to build BPS(*) array - ; (and BPSOSCB calls BPSOSCC) - ; BPSOSCD to build the ^BPSC( entry - ; -EN(DIALOUT) ;EP - from BPSOSQG - I $D(RXILIST)<10 D - .N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","TI","bad RXILIST",,,$T(+0)) - ;Manage local variables - N BPS,START,END,TOTAL,NCLAIMS,CLAIMN - S ERROR=$$BPS^BPSOSCB(DIALOUT,.BPS) - I ERROR D LOG2LIST^BPSOSQ($T(+0)_" - $$BPS^BPSOSCB("_DIALOUT_",.BPS) returned "_ERROR) - I $G(BPS("RX",0))="" S:'ERROR ERROR=301 Q - I $G(BPS("NCPDP","# Meds/Claim"))="" S ERROR=302 Q - ; - ; Override any BPS() nodes that you need to override. - ; - D ; NDC #s - Translate POSTAGE (may be insurer-dependent someday) - .N N F N=1:1:BPS("RX",0) D - ..N X,Y S X=$TR(BPS("RX",N,"NDC"),"-",""),Y=BPS("RX",N,"IEN59") - ..N Z S Z=$P(^BPST(Y,1),U,2) - ..I Z="POSTAGE" S Z=99999999981 ; 06/21/2000 - ..; This next part should never happen; it should already be correct - ..; BPSOSQ1 already put the correct NDC # into the ^PSRX - ..; and BPSOSCE will pick it out from there. - ..I X'=Z,Z'="POSTAGE",Z'="" D ; $TR inserted above, 03/07/2000 - ...S BPS("RX",N,"NDC")=Z - ...D LOG59^BPSOSQ("CLAIM - NDC # on `"_Y_" sent as "_Z_", not "_X,Y) - ; - ;Calculate number of claim records to be generated for Billing Item - S NCLAIMS=((BPS("RX",0)-1)\BPS("NCPDP","# Meds/Claim"))+1 - I NCLAIMS=0 S ERROR=303 Q - ; - ;Generate claim submission records - F CLAIMN=1:1:NCLAIMS D Q:$G(ERROR) - .S START=((CLAIMN-1)*BPS("NCPDP","# Meds/Claim"))+1 - .S END=START+BPS("NCPDP","# Meds/Claim")-1 - .S:END>BPS("RX",0) END=BPS("RX",0) - .S TOTAL=END-START+1 - .D NEWCLAIM^BPSOSCE(START,END,TOTAL) - .S CLAIMIEN=BPS(9002313.02) - .S CLAIMIEN(CLAIMIEN)="" - .; Mark each of the .59s with the claim number and position within - .F I=START:1:END D - ..;IEN59 handling 06/23/2000. The ELSE should never happen again. - ..; and the $G() can probably be gotten rid of, safely. - ..N IEN59 S IEN59=$G(BPS("RX",I,"IEN59")) - ..I IEN59 D - ...N DIE,DA,DR S DIE=9002313.59 - ...; Field (#3) CLAIM (#14) POSITION - ...S DA=IEN59,DR=3_"////"_CLAIMIEN_";14////"_I N I D ^DIE - ..E D - ...S $P(^BPST(BPS("RX",I,"RX IEN"),0),"^",4)=CLAIMIEN - ...S ^BPST("AE",CLAIMIEN,BPS("RX",I,"RX IEN"))="" - ...S $P(^BPST(BPS("RX",I,"RX IEN"),0),"^",9)=I - ..; POSITION: Not the relative position within the packet, - ..; but the index in BPS("RX",n,.... This is the position in which - ..; it will be stored in ^BPSC(ien,400,POSITION - ..; and likewise for 9002313.03 when the response comes in. - Q diff -auBN ./r1/BPSOSCF.m ./r2/r/BPSOSCF.m --- ./r1/BPSOSCF.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSCF.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,174 +0,0 @@ -BPSOSCF ;BHAM ISC/FCS/DRS/DLF - Low-level format of .02 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; FORMAT is a pointer to 9002313.92 - ; NODE = 100 (5.1 Transaction Header Segment) - ; 110 (5.1 Patient Segment) - ; 120 (5.1 Insurance Segment) - ; 130 (5.1 Claim Segment) - ; 140 (5.1 Pharmacy Provider Segment) - ; 150 (5.1 Prescriber Segment) - ; 160 (5.1 COB/Other Payments Segment) - ; 170 (5.1 Worker's Compensation Segment) - ; 180 (5.1 DUR/PPS Segment) - ; 190 (5.1 Pricing Segment) - ; 200 (5.1 Coupon Segment) - ; 210 (5.1 Compound Segment) - ; 220 (5.1 Prior Authorization Segment) - ; 230 (5.1 Clinical Segment) - ; MEDN set to reflect the prescription for nodes 130 - 230 - ; - ; For 5.1 there is only one significant change to this routine - - ; the values used in the NODE field in the XFLDCODE subroutine - ; will be now based on the version of claim we are processing. - ; For 3.2 claims, we will process the 10, 20, and 30 nodes from - ; from the NCPDP Field defs dictionary. - ; For 5.1, we will process 10, 25 and 30. - ; -XLOOP(FORMAT,NODE,MEDN) ;EP - N ORDER,RECMIEN,MDATA,FLDIEN,PMODE,FLAG - ; - ;IHS/SD/lwj 8/1/02 for 5.1, segments won't always be defined-just quit - Q:(BPS("NCPDP","Version")[5)&('$D(^BPSF(9002313.92,FORMAT,NODE,0))) - ; - ;IHS/SD/lwj 8/20/01 for 5.1 segment 180 is the DUR/PPS segment - ; this is a repeating field segment, and must be handled differently - ; than the regular sections - S HEADER=",1,2,3,4,92,75,5,13,76," ;header seg fields don't get qualifiers - I ",230,220,210,200,170,160,"[NODE Q ;210=Compound,200=coupon,170=workers comp,160=cob/other payments ;ITERATION 3 WON'T DO THESE. ;LJE - I NODE=180 D DURPPS^BPSOSHF(FORMAT,NODE,MEDN) Q - ; - I '$D(^BPSF(9002313.92,FORMAT,NODE,0)) D IMPOSS^BPSOSUE("DB,P","TI","FORMAT="_FORMAT,"NODE="_NODE,1,$T(+0)) - ; - S ORDER=0 - F D Q:'ORDER - .S ORDER=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER)) Q:'ORDER - .S RECMIEN=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER,0)) - .I 'RECMIEN D IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"ORDER="_ORDER,2,$T(+0)) - .S MDATA=^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0) - .S FLDIEN=$P(MDATA,U,2) - .I VARX Q:FLDIEN=241!(FLDIEN=240)!(FLDIEN=93) ;LJE;7/21/03 - .I 'FLDIEN D IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"RECMIEN="_RECMIEN,3,$T(+0)) ; corrupt or erroneous format file - .S PMODE=$P(MDATA,U,3) - .I PMODE="" S PMODE="S" ;default it - .I PMODE="X",$P(^BPSF(9002313.91,FLDIEN,0),U)=104 D - . . ; Processor control number is different for Envoy - . . ; It's always the Envoy Terminal ID, regardless of payor - . . ; The XECUTE special code is only for non-Envoy - . . ; Change it to "standard" mode for Envoy - . . I BPS("Site","Switch Type")="ENVOY" S PMODE="S" - . S FLAG=$S(PMODE="S":"GFS",1:"FS") - . ; Apply any override values, as needed. - . N OVERRIDE ; the override value, if any - . I $D(MEDN) D ; for a prescription detail - . . I $D(BPS("OVERRIDE","RX",MEDN,FLDIEN)) D - . . . S OVERRIDE=BPS("OVERRIDE","RX",MEDN,FLDIEN) - . E D ; for patient/header info - . . I $D(BPS("OVERRIDE",FLDIEN)) D - . . . S OVERRIDE=BPS("OVERRIDE",FLDIEN) - . ; BPS("X") is the field value as it's being computed - . S BPS("X")="" - . I PMODE="X" D ; special Xecute code, in lieu of the field's Get code - . . I $D(OVERRIDE) S BPS("X")=OVERRIDE - . . E D XSPCCODE(FORMAT,NODE,RECMIEN) - . I $D(OVERRIDE) D - . . D XFLDCODE(FLDIEN,FLAG,OVERRIDE) - . E D - . . D XFLDCODE(FLDIEN,FLAG) - Q - ;Execute Get, Format and/or Set MUMPS code for a NCPDP Field - ; - ;Parameters: FLDIEN - NCPDP Field Definitions IEN - ; FLAG - If variable contains: - ; "G" - Execute Get Code - ; "F" - Execute Format Code - ; "S" - Execute S Code - ; OVERRIDE - if defined, it's used instead of Get Code - ;--------------------------------------------------------------------- -XFLDCODE(FLDIEN,FLAG,OVERRIDE) ;EP - ;Manage local variables - ;IHS/SD/lwj 8/1/02 added logic to work with the 5.1 format - ; code instead of the 3.2 format code. If the claim is for - ; 5.1, we will loop with 10, 25, 30 and if it is 3.2 we will - ; loop with 10, 20, 30. - ; - ; This subroutine was flagged as an entry point with the NCPDP - ; 5.1 changes. The only call to this subroutine from outside - ; of this program is done in BPSOSHF. - ; - N NODE,INDEX,MCODE - N FNODE ;IHS/SD/lwj 8/1/02 format node - S FNODE=25 ;IHS/SD/lwj 8/1/02 default to 5.1 node - ; - ;I FLDIEN=50 W $T(+0) ZW FLDIEN ; temporary!! - ; - ;Check if record exist and FLAG variable is set correctly - ; (Changed from Q: to give fatal error 10/18/2000) - I 'FLDIEN D IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"XFLDCODE",$T(+0)) - I '$D(^BPSF(9002313.91,FLDIEN,0)) D IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"XFLDCODE",$T(+0)) - I FLAG="" D IMPOSS^BPSOSUE("DB,P","TI","FLAG null",,"XFLDCODE",$T(+0)) - ; - ; IHS/SD/lwj 8/1/02 added next line of code - I BPS("NCPDP","Version")[3 S FNODE=20 - ; - ;Loop through Get, Format and Set Code fields and execute code - ; - ; IHS/SD/lwj 8/1/02 nxt line remarked out - new line added - ;F NODE=10,20,30 D - F NODE=10,FNODE,30 D - .; - .; IHS/SD/lwj 8/21/02 nxt line remarked out- new line added - .; Q:FLAG'[$S(NODE=10:"G",NODE=20:"F",NODE=30:"S",1:"") - .Q:FLAG'[$S(NODE=10:"G",NODE=20:"F",NODE=25:"F",NODE=30:"S",1:"") - .I VARX Q:FLDIEN=241!(FLDIEN=240)!(FLDIEN=93) ;LJE;7/21/03 - .;I CERTIFY W !,NODE," ",FLDIEN - .I '$D(^BPSF(9002313.91,FLDIEN,NODE,0)) D IMPOSS^BPSOSUE("DB","TI","FLDIEN="_FLDIEN,"NODE="_NODE,"XFLDCODE",$T(+0)) - . ;If value is being overridden, just take the override value & get out - .I NODE=10,$D(OVERRIDE) S BPS("X")=OVERRIDE Q - .S INDEX=0 - .F D Q:'+INDEX - ..S INDEX=$O(^BPSF(9002313.91,FLDIEN,NODE,INDEX)) - .. Q:'+INDEX - .. ;I FLDIEN=37 S ^ZLE("BPS",$H,"CERT BPS FLDIEN 1",37)=BPS("X") H 1 - .. ;I FLDIEN=18&($G(BPS("RX",1,"CERT RX IEN"))) S BPS("X")=BPS("RX",1,"CERT RX IEN") - ..S QUAL="" I $G(VARX)&(NODE=30) S QUAL=$P(^BPSF(9002313.91,FLDIEN,5),"^",1) ;LJE - ..I NODE=30&($G(VARX)) I $E(BPS("X"),1,2)'=QUAL&(HEADER'[(","_FLDIEN_",")) S BPS("X")=QUAL_BPS("X") ;LJE;7/16/03 - ..S MCODE=$G(^BPSF(9002313.91,FLDIEN,NODE,INDEX,0)) - ..Q:MCODE="" - ..Q:$E(MCODE,1)=";" - ..;; ?????? I $D(BPS(9002313.0201)) I $D(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01)) D - .. ;I FLDIEN=37 S ^ZLE("BPS",$H,"CERT BPS FLDIEN 2",37)=BPS("X") - ..X MCODE - ..;I FLDIEN=37 S ^ZLE("BPS",$H,"CERT BPS FLDIEN 3",37)=BPS("X")_"^"_MCODE - ..;S QUAL="" I $G(VARX)&(NODE=25) S QUAL=$P(^BPSF(9002313.91,FLDIEN,5),"^",1) ;LJE - ..;I NODE=30&($G(VARX)) I $E(BPS("X"),1,2)'=QUAL&(HEADER'[(","_FLDIEN_",")) S BPS("X")=QUAL_BPS("X") ;LJE;7/16/03 - ..;I $G(MSG) D IMPOSS^BPSOSUE("DB,P","TI","ERROR",,"XFLDCODE",$T(+0)) - ..;I NODE=30 W $T(+0)," $ZR=",$ZR," ",@$ZR," ",$P(@$ZR,"^",43),! R ">>>",%,! - Q - ;---------------------------------------------------------------------- - ;Execute Special Code (for a NCPDP Field within a NCPDP Record) - ; - ;Parameters: FORMAT - NCPDP Record Format IEN (9002313.92) - ; NODE - Global node value (10,20,30,40) - ; RECMIEN - Field Multiple IEN - ;--------------------------------------------------------------------- -XSPCCODE(FORMAT,NODE,RECMIEN) ;EP - ;Manage local variables - ; - ; This subroutine was flagged as an entry point with the NCPDP - ; 5.1 changes. The only call to this subroutine from outside - ; of this program is done in BPSOSHR. - ; - N INDEX,MCODE - I '$D(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0)) D IMPOSS^BPSOSUE("DB,P","TI","no special code there to XECUTE","FORMAT="_FORMAT,"XSPCCODE",$T(+0)) - ; - S INDEX=0 - F D Q:'+INDEX - .S INDEX=$O(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,1,INDEX)) - . Q:'+INDEX ;I '+INDEX S BPX("X")="" ;LJE ;Q:'+INDEX - .S MCODE=$G(^BPSF(9002313.92,FORMAT,NODE,RECMIEN,1,INDEX,0)) - .Q:MCODE="" - .Q:$E(MCODE,1)=";" - .X MCODE - Q - ; diff -auBN ./r1/BPSOSD1.m ./r2/r/BPSOSD1.m --- ./r1/BPSOSD1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSD1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSD1 ;BHAM ISC/FCS/DRS/DLF - (unused) ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSEC.m ./r2/r/BPSOSEC.m --- ./r1/BPSOSEC.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSEC.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,102 +0,0 @@ -BPSOSEC ;BHAM ISC/SD/lwj/dlf - ECME environment cheker; 06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; This routine is an environment checker used with the installation - ; of patch 1 of the ECME software. - ; It will check for the following RPMS packages, their version - ; and patch numbers before allowing the user to continue - ; with the installation of patch 1 for ECME: - ; - ; Fileman (DI) v21 - ; Kernel (XU) v8.0 - ; IHS Patient Dictionaries (AUPN) V99.1 - ; IHS Dictionary Pointers (AUT) V98.1, patch 8 - ; Outpatient Pharmacy (PSO) V6.0 patch 3 - ; Pharmacy ECME (BPS) V1.0 - ; - ; (XPDQUIT will be set to 2 if the above mention packages are not - ; at the require version and patch level. 2 indicates that - ; the KIDS install will abort the installation, but will leave the - ; ^XTMP global in place.) - ; - ; -CHECK ;EP - called from Kids install routine - ; First let's make sure they have DUZ(0) defined, and greet the user - ; - N BPSERS,X,BPSMSG - I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q - I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q - ; - S BPSERS=$P($G(^VA(200,DUZ,0)),U) - W !!,$$CJ^XLFSTR("Hello, "_$P(BPSERS,",",2)_" "_$P(BPSERS,","),IOM) - W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" Ver: "_$P($T(+2),";",3)_" Patch: "_$P($T(+2),";",5)_".",IOM),! - ; - ;now lets get the the nitty gritty and check the packages - ; and their versions - ; - Q:'$$VCHK("DI","21.0",2) - Q:'$$VCHK("XU","8.0",2) - Q:'$$VCHK("AUPN","99.1",2) - Q:'$$VCHK("AUT","98.1",2) - Q:'$$VCHK("PSO","6.0",2) - Q:'$$VCHK("BPS","1.0",2) - W !! - ; - ; okay - we have the packages, and they are on the right version - ; but lets check for a couple of patchs - ; - ; first outpatient pharmacy patch 3 - not in package or kids file - ; so we will look for a routine that was new in patch 3 - ; - S X="APSQUTL" X ^%ZOSF("TEST") - I '$T S BPSMSG="Outpatient Pharmacy V6.0 Patch 3 MUST be loaded to continue." D SORRY(BPSMSG,2) - ; - ; now let's see if IHS dictionary pointers have at least patch 8 - ; - S BPSPK="AUT*98.1*8" - S BPSPTCH=$$INSTALLD(BPSPK) - I 'BPSPTCH S BPSMSG="IHS Dictionary Pointers (AUT) must be at V98.1 patch 8 to continue with this load" D SORRY(BPSMSG,2) - ; - ; - Q - ; -VCHK(BPSPRE,BPSVER,BPSQUIT) ; Check versions needed - ; - NEW BPSV - S BPSV=$$VERSION^XPDUTL(BPSPRE) - W !,$$CJ^XLFSTR("Need at least "_BPSPRE_" v "_BPSVER_"....."_BPSPRE_" v "_BPSV_" Present ",IOM) - I BPSV120 FLDDATA=$G(BPS(9002313.0201,IEN(9002313.01),FLDNUM,"I")) - ..; - ..I FLDID'=$TR(FLDDATA,"0 {}") S DATAFND=1 ;fld chk-is the field empty? - ..; - ..;check if this is the seg id - call this after fld chk since - ..;we don't want to send the segment if this is all there is - ..I (NODE>100)&(FLDNUM=111) S FLDDATA=$$SEGID(NODE) - ..; - ..I VARX Q:FLDDATA="" ;lje;7/23/03; don't want extra field separators when field is blank for testing for WebMD. - ..; - ..S:NODE=100 SEGREC=SEGREC_FLDDATA ;no FS on the header rec - ..S:NODE>100 SEGREC=SEGREC_$C(28)_FLDDATA ;FS always proceeds fld - ..; - .; - . I 'VARX D ;LJE;8/18/03; VMS CAN'T HANDLE MORE THAT 255 CHARACTERS - . . I (DATAFND)&(NODE=100) S REC=SEGREC ;no SS when it's the header - . . I (DATAFND)&(NODE>100) S REC=REC_$C(30)_SEGREC ;SS before the seg - . E D - . . I (DATAFND)&(NODE=100) S REC(NODE)=SEGREC ;no SS when it's the header - . . I (DATAFND)&(NODE>100) D - . . . I '$D(REC(NODE)) S REC(NODE)=REC I REC[$C(29) S REC="" - . . . S REC(NODE)=REC(NODE)_$C(30)_SEGREC ;SS before the seg - ; - Q - ; -SEGID(ND) ; Field 111 is the Segment Identifier - for each segment, other than - ; the header, a pre-defined, unique value must be sent in this field - ; to identify which segment is being sent. This value is not stored - ; in the claim - as it changes with each of the 13 segments. The - ; field does appear as part of the NCPCP Format, put is simply not - ; stored. - ; 01 = Patient 02 = Pharmacy Provider 03 = Prescriber - ; 04 = Insurance 05 = COB/Other Payment 06 = Workers Comp - ; 07 = Claim 08 = DUR/PPS 09 = Coupon - ; 10 = Compound 11 = Pricing 12 = Prior Auth - ; 13 = Clinical - ; - N FLD - ; - S FLD=$S(ND=110:"01",ND=120:"04",ND=130:"07",ND=140:"02",ND=150:"03",ND=160:"05",ND=170:"06",ND=180:"08",ND=190:11,ND=200:"09",ND=210:10,ND=220:12,ND=230:13,1:"00") - S FLD="AM"_$$NFF^BPSECFM(FLD,2) - ; - Q FLD - ; -PROCDUR ;NCPDP 5.1 - The DUR/PPS segment can repeat itself for any given - ; transaction within a claim. This means we have to have special - ; programming to handle the repeating fields. - ; - N FIELD,DUR,FLD - ; - ; if there isn't any data in this segment, then lets quit - Q:'$D(BPS(9002313.1001)) - ; - ; second thing - create the 111 field entry as it is not repeating - S FLDDATA=$$SEGID(NODE) - S SEGREC=SEGREC_$C(28)_FLDDATA ;FS always proceeds fld - ; - ; next- let's look to the format to see which DUR/PPS fields are - ; needed (remember - ALL fields on the DUR/PPS segment are optional) - D GETFLDS^BPSOSHF(+IEN(9002313.92),NODE,.FIELD) - ; - ;finally -loop through and process the fields for as many times - ; as they appear - S DUR=0 - F S DUR=$O(BPS(9002313.1001,DUR)) Q:DUR="" D - . S ORD=0 - . F S ORD=$O(FIELD(ORD)) Q:ORD="" D - .. S FLDIEN=$P(FIELD(ORD),U) - .. S FLD=$P(FIELD(ORD),U,2) - .. S:FLD=473 FLD=.01 ;473 value stored in the .01 field - .. S FDATA5=$G(^BPSF(9002313.91,FLDIEN,5)) ;5.1 id and length - .. S FLDID=$P(FDATA5,U,1) ;5.1 ID - .. ; - .. ;transaction data - .. S FLDDATA=$G(BPS(9002313.1001,DUR,FLD,"I")) - .. ; - .. I FLDID'=$TR(FLDDATA,"0 {}") S DATAFND=1 ;fld chk-is the fld empty? - .. ; - .. S SEGREC=SEGREC_$C(28)_FLDDATA ;FS always proceeds fld - ; - ; - Q diff -auBN ./r1/BPSOSH4.m ./r2/r/BPSOSH4.m --- ./r1/BPSOSH4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSH4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,207 +0,0 @@ -BPSOSH4 ;BHAM ISC/FCS/DRS/DLF - Parse Claim 5.1Response ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Parse ASCII Response Claim Record and Sup FDATA() Array - ; - ;Parameters: RREC - Ascii Response Record - ; RESPIEN - Claim Response IEN (90023130.3) - ;---------------------------------------------------------------------- - ; Calls BPSOSH5 - ; - ;---------------------------------------------------------------------- - ; IHS/SD/lwj 8/6/02 NCPDP 5.1 changes - ; NCPDP 5.1 response segments are completely different than the - ; 3.2 response. Of significant importance are: - ; In 3.2, there were 4 basic repsonse segments (header required, - ; header option, information required, information optional.) - ; In 5.1, there are 8 possible segments (header, message, insurance, - ; status, claim, pricing, DUR/PPS, and prior authorization) - ; - ; In 5.1, for all segments following the header, a segment separator - ; is used. - ; - ; In 5.1, field separators, and field identifiers are used for all - ; fields not appearing on the header segment. - ; - ; This routine will be solely responsible for parsing the data - ; for 5.1 claims. It is called by BPSECA4. - ;---------------------------------------------------------------------- -PARSE51(RREC,RESPIEN) ;EP - from BPSECA4 - N GS,FS,SS - ; - ;Make sure input varaibles are defined - Q:$G(RREC)="" - Q:$G(RESPIEN)="" - Q:'$D(^BPSR(RESPIEN,0)) - ; - ;group and field separator characters - S GS=$C(29),FS=$C(28),SS=$C(30) - ; - D TRANSMSN ;process the transmission level data - D TRANSACT ;process the transaction level data - D FILE^BPSOSH5(RESPIEN) ;add information to the response file - ; - Q - ; - ; -TRANSMSN ;This subroutine will work through the transmission level information - ; - N RTRANM,RHEADER,SEG,SEGMENT,SEGID - ; - ;Parse response transmission level from ascii record - S RTRANM=$P(RREC,GS,1) - ; - ; get just the header segment - S RHEADER=$P(RTRANM,SS,1) ;header- required/fixed length - D PARSEH - ; - ; There are 2 optional segments on the trasmission level - message - ; and insurance. We'll check for both and parse what we find. - ; - F SEG=2:1:3 D - . S SEGMENT=$P(RTRANM,SS,SEG) - . Q:SEGMENT="" - . S SEGID=$P(SEGMENT,FS,2) - . I $E(SEGID,1,2)="AM" D ;segment identification - . D:($E(SEGID,3,4)=20)!($E(SEGID,3,4)=25) PARSETM - ; - Q - ; -TRANSACT ;This subroutine will work through the transaction level information - ; - N RTRAN,SEG,SEGMENT,MEDN - S MEDN=0 - ; - F GRP=2:1 D Q:RTRAN="" - . S RTRAN=$P(RREC,GS,GRP) ;get the next transaction (could be 4) - . Q:RTRAN="" ;we're done if it's empty - . S MEDN=MEDN+1 ;transaction counter - . ; - . F SEG=2:1 D Q:SEGMENT="" ;break the record down by segments - .. S SEGMENT=$P(RTRAN,SS,SEG) ;get the segment - .. Q:SEGMENT="" - .. D PARSETN ;get the fields - ; - ; - Q - ; - ; -PARSEH ; The header record is required on all responses, and is fixed - ; length. It is the only record that is fixed length. - ; - S FDATA(102)=$E(RHEADER,1,2) ;version/release number - S FDATA(103)=$E(RHEADER,3,4) ;transaction code - S FDATA(109)=$E(RHEADER,5,5) ;transaction count - S FDATA(501)=$E(RHEADER,6,6) ;header response status - S FDATA(202)=$E(RHEADER,7,8) ;service provider id qualifier - S FDATA(201)=$E(RHEADER,9,23) ;service provider id - S FDATA(401)=$E(RHEADER,24,31) ;date of service - ; - Q - ; -PARSETM ; This subroutine will parse the variable portions of the transmission - ; level message. Keep in mind that most fields are optional - ; so we have no idea what is coming back. We will parse based - ; on the field separators, and field identification. - ; (tranmission level variable records are the message (ID=20) - ; and insurance (ID=25) segments) - ; - N FIELD,PC,FLDNUM - ; - F PC=3:1 D Q:FIELD="" ;skip the seg id -already know its value - . S FIELD=$P(SEGMENT,FS,PC) ;piece through the record - . Q:FIELD="" ;stop - we hit the end - . S FLDNUM=$$GETNUM(FIELD) ;get the field number used for storage - . Q:FLDNUM="" ;shouldn't happen - but lets skip - . S FDATA(FLDNUM)=$E(FIELD,3,$L(FIELD)) ;hold the value - ; - Q - ; -PARSETN ; This subroutine will parse the transaction level segments. For - ; most transactions, the only segment required in this area of - ; the response is the status segment. However, since we aren't - ; sure what we will be getting back, we will process whatever - ; is sent our way. - ; - ; Please note that most fields are optional, so we will parse the - ; record based on field separators and the value of the field - ; identification. - ; Also please note that several of the segments have repeating - ; fields - we will determine which fields are repeating, based - ; on the segment identification. - ; - ; Possible values of the SEGFID field: - ; 21 = Response Status Segment - ; 22 = Response Claim Segment - ; 23 = Response Pricing Segment - ; 24 = Response DUR/PPS Segment - ; 26 = Repsonse Prior Authorization Segment - ; - N FIELD,PC,FLDNUM,RPTFLD,RCNT,REPEAT - ; - S RPTFLD="" - S SEGID=$P(SEGMENT,FS,2) ;this should be the segment id - Q:SEGID="" ;don't process without a Seg id - Q:$E(SEGID,1,2)'="AM" ;don't know what we have - skip - ; - S SEGFID=$E(SEGID,3,4) ;this should be the field ID - ; - ; setup the repeating flds based on the segment - I SEGFID=21 D ;status segment - . S RPTFLD=",548,511,546," - . S (RCNT(548),RCNT(511),RCNT(546))=0 - ; - I SEGFID=22 D ;claim segment - . S RPTFLD=",552,553,554,555,556," - . S (RCNT(552),RCNT(553),RCNT(554),RCNT(555),RCNT(556))=0 - ; - I SEGFID=23 D ;pricing segment - . S RPTFLD=",564,565," - . S (RCNT(564),RCNT(565))=0 - ; - I SEGFID=24 D ;DUR/PPS segment - . S RPTFLD=",439,528,529,530,531,532,533,544,567," - . S (RCNT(439),RCNT(528),RCNT(529),RCNT(530),RCNT(531))=0 - . S (RCNT(532),RCNT(533),RCNT(544),RCNT(567))=0 - ; - ; now lets parse out the fields - ; - F PC=3:1 D Q:FIELD="" ;skip the seg id -jump to the other flds - . S FIELD=$P(SEGMENT,FS,PC) ;piece through the record - . Q:FIELD="" ;stop - we hit the end - . S FLDNUM=$$GETNUM(FIELD) ;get the field number used for storage - . ; - . S REPEAT=0 ;for this segment, lets figure - . S CKRPT=","_FLDNUM_"," ;out if the field is a repeating - . S:RPTFLD[CKRPT REPEAT=1 ;field - . ; - . I REPEAT D ;if rptg, store with a counter - .. S RCNT(FLDNUM)=$G(RCNT(FLDNUM))+1 - .. S FDATA("M",MEDN,FLDNUM,RCNT(FLDNUM))=$E(FIELD,3,$L(FIELD)) - . ; - . I 'REPEAT D ;not rptg, store without counter - .. S FDATA("M",MEDN,FLDNUM)=$E(FIELD,3,$L(FIELD)) - ; - ; - Q - ; -GETNUM(FIELD) ; This routine will translate the field ID into a field number. - ; We will use the BPS NCPDP field Defs files, corss ref "D" to - ; perform this translation. (The field number is needed to store - ; the data in the correct field within the response file.) - ; - N FLDID,FLDIEN,FLDNUM - S (FLDID,FLDNUM)="" - S FLDIEN=0 - ; - S FLDID=$E(FIELD,1,2) ;field identifier - Q:FLDID="" - ; - I FLDID'="" D - . S FLDIEN=$O(^BPSF(9002313.91,"D",FLDID,FLDIEN)) ;internal fld # - . S:FLDIEN FLDNUM=$P($G(^BPSF(9002313.91,FLDIEN,0)),U) ;fld number - ; - ; - Q FLDNUM - ; diff -auBN ./r1/BPSOSH5.m ./r2/r/BPSOSH5.m --- ./r1/BPSOSH5.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSH5.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,132 +0,0 @@ -BPSOSH5 ;BHAM ISC/SD/lwj/DLF - Post 5.1 Claim Response ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;File FDATA() Array Data in Claim Response File (9002313.03) - ; - ;Parameters: RESPIEN - Claim Response Record IEN (9002313.03) - ;--------------------------------------------------------------------- - ; Called from BPSOSH4 from BPSECA4 from BPSOSQL from BPSOSQ4 - ; - ;--------------------------------------------------------------------- - ; IHS/SD/lwj 8/7/02 NCPDP 5.1 changes - ; NCPDP 5.1 response segments are completely different from 3.2 - ; response segments, and as such many new fields had to be added - ; to BPSR to store the information coming back. (52 new flds added) - ; (There were several significant differences in the parsing of - ; data from a 3.2 response and a 5.1 response - please refer to - ; BPSOSH4 for details regarding the parsing.) - ; The purpose of this routine is to load the information from a 5.1 - ; response into the ^BPSR global after the parsing is complete. - ;(please see BPSECA5 for the storing of information from a 3.2 - ; claim into ^BPSR) - ; - ; Of interest - in 3.2, if the response was for a duplicate, the - ; information for the response was duplicated in the Response subfile, - ; on node 1000, in addition to be stored in node 500 and 504. - ; With 5.1 being so much different, the node 1000 on the subfile - ; will not be populated since the information is stored at all the - ; other nodes. - ; - ; Special Note - The values are hard set into the BPS response - ; file within this routine and cross references are rebuilt - ; manually. While this is not considered the optimum way of - ; approaching this, it does two things. It works as documentation - ; for what is being set where, and it stays consistent with the - ; original coding of ECME (please see the BPSECA5 routine for - ; loading of values for 3.2 claims). - ; - ; For ALL the repeating fields, we will make a general assumption - ; that the counter field that goes with the repeating field section - ; really does tell us how many occurences of the repeating fields - ; there will be. This counter will be used to loop through the - ; repeating fields. - ; - ; - ;-------------------------------------------------------------------- - ; -FILE(RESPIEN) ;EP - from BPSOSH4 - ; - I 'RESPIEN Q:$$IMPOSS^BPSOSUE("P",,,,,$T(+0)) - ; - N MEDN,COUNT,INDEX,RJTN,RJTCOUNT,RJTCODE,NEXT,CLAIMIEN - ; - D CLNDATA^BPSOSHU ;clean out spaces and zeros - D WRTTMSN ;write the transmission level data - D WRTTRAN ;write the transaction level data - ; - ; - Q -WRTTMSN ; The purpose of this subroutine is to read through the - ; FDATA transmission level fields, and write out the data - ; to the ^BPSR (BPS Responses) file. - ; - ; first lets work on what we got from the header segment - S $P(^BPSR(RESPIEN,100),U,2)=$G(FDATA(102)) ;version/release # - S $P(^BPSR(RESPIEN,100),U,3)=$G(FDATA(103)) ;transaction code - S $P(^BPSR(RESPIEN,100),U,9)=$G(FDATA(109)) ;transaction count - S $P(^BPSR(RESPIEN,500),U,1)=$G(FDATA(501)) ;header response status - S $P(^BPSR(RESPIEN,200),U,1)=$G(FDATA(201)) ;service provider id - S $P(^BPSR(RESPIEN,200),U,2)=$G(FDATA(202)) ;service prov id qual - S $P(^BPSR(RESPIEN,400),U,1)=$G(FDATA(401)) ;date of service - ; - ; now lets look for a message, if there was one - S $P(^BPSR(RESPIEN,504),U,1)=$G(FDATA(504)) ;message - ; - ; if there was any insurance information passed back - let's record it - S $P(^BPSR(RESPIEN,300),U,1)=$G(FDATA(301)) ;group ID - S $P(^BPSR(RESPIEN,500),U,24)=$G(FDATA(524)) ;plan ID - S $P(^BPSR(RESPIEN,540),U,5)=$G(FDATA(545)) ;network reimbrsmnt id - S $P(^BPSR(RESPIEN,560),U,8)=$G(FDATA(568)) ;payer ID qualifier - S $P(^BPSR(RESPIEN,560),U,9)=$G(FDATA(569)) ;payer ID - ; - Q - ; -WRTTRAN ;The purpose of this routine is to write the transaction level - ; information out to the ^BPSR (BPS Responses) file. - ; **Special Note - the cross references and header for the subfiles - ; are hard set within this subroutine - this is done to stay - ; consistent with the original ECME software (please see BPSECA5) - ; - ; the logic for setting of COUNT and INDEX was borrowed from - ; BPSECA5 - INDEX will stay in line with the subfile ien on the - ; claim 400 subfile, COUNT is used to update the subfile header in - ; the response file - ; - N COUNT,INDEX,CLAIMIEN,MEDN - ; - ; claimien was set in BPSOSQL - S CLAIMIEN=$P($G(^BPSR(RESPIEN,0)),U,1) ;claim pointer - S INDEX=$S(CLAIMIEN="":0,1:$O(^BPSC(CLAIMIEN,400,0))-1) - S:INDEX<0 INDEX=0 - S COUNT=0 - ; - ; now find where we need to start with the transaction data - ; and loop through each one to write out to the response file - S MEDN="" - F D Q:MEDN="" - . S MEDN=$O(FDATA("M",MEDN)) - . Q:MEDN="" - . ; - . S COUNT=COUNT+1 ;sub file record count - . S INDEX=INDEX+1 ;sub file index - . ; - . S ^BPSR(RESPIEN,1000,INDEX,0)=INDEX ;.01 fld Medication order - . ; - . ; let's take it a segment at a time - remember most everything - . ; is optional - . ; (all the below subroutines were originally in BPSOSH5, but - . ; because of SAC routine size limitations, they were relocated.) - . D RESPSTS^BPSOSH6 ;status segment - . D RESPCLM^BPSOSH6 ;claim segment - . D RESPPRC^BPSOSH7 ;pricing segment - . D RESPDUR^BPSOSH7 ;DUR segment - . D RESPPA^BPSOSH7 ;prior authorization segment - . ; - . ; now - lets update the "b" cross reference - . S ^BPSR(RESPIEN,1000,"B",INDEX,INDEX)="" - ; - ; last step - let's update the 0 node with the last rec and rec cnt - S ^BPSR(RESPIEN,1000,0)="^9002313.0301A^"_INDEX_"^"_COUNT - ; - Q diff -auBN ./r1/BPSOSH6.m ./r2/r/BPSOSH6.m --- ./r1/BPSOSH6.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSH6.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,167 +0,0 @@ -BPSOSH6 ;BHAM ISC/SD/lwj/DLF - NCPDP 5.1 Post 5.1 response ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;------------------------------------------------------------- - ; Originally, the entire response was processed in the - ; BPSOSH5 routine - but it exceed SAC limitations on - ; routine size - so the processing of some of the transaction - ; level information was moved to this routine. Other portions - ; were moved to the BPSOSH7 routine. - ; - ; This routine is called solely from BPSOSH5. - ; - ; - Q - ; -RESPSTS ;EP - NCPDP 5.1 response processing (moved from BPSOSH5) - ; called from WRTTRAN^BPSOSH5 - ; MEDN is set in BPSOSH5 in the WRTTRAN subroutine - ; process the response status segment - here's the fields we MIGHT - ; encounter: - ; 112 - transaction response status (mandatory) - ; 503 - authorization number - ; 510 - reject count - ; 511 - reject code (repeating field) - ; 546 - reject field occurrence indicator (repeating field) - ; 547 - approved message code count - ; 548 - approved message code (repeating field) - ; 526 - additional message information - ; 549 - help desk phone number qualifier - ; 550 - help desk phone number - ; - ; *special note - in 3.2 the transaction response is stored in field - ; 501 at the prescription level. In 5.1 that was moved to field 112. - ; All the reports are based on the 501 field, so to keep things - ; simple, we will simply update both the 112 and 501 fields with - ; the transaction level response status. - ; - S $P(^BPSR(RESPIEN,1000,INDEX,110),U,2)=$G(FDATA("M",MEDN,112)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U)=$G(FDATA("M",MEDN,112)) ;501 - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,3)=$G(FDATA("M",MEDN,503)) - ; - ; process reject information if there - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,10)=$G(FDATA("M",MEDN,510)) - I $D(FDATA("M",MEDN,510)) D REPREJ ;process the rejection codes - ; - ; process approved information if there - S $P(^BPSR(RESPIEN,1000,INDEX,540),U,7)=$G(FDATA("M",MEDN,547)) - I $D(FDATA("M",MEDN,547)) D REPAPP ;process the repeating fld - ; - ; finish up with the additional message, and help desk information - S $P(^BPSR(RESPIEN,1000,INDEX,526),U)=$G(FDATA("M",MEDN,526)) - S $P(^BPSR(RESPIEN,1000,INDEX,540),U,9)=$G(FDATA("M",MEDN,549)) - S $P(^BPSR(RESPIEN,1000,INDEX,540),U,10)=$G(FDATA("M",MEDN,550)) - ; - ; - Q - ; -REPREJ ; This subroutine will process the reject repeating fields - ; that are a part of the status segment. - ; Two fields here - 511 - Reject Code and - ; 546 - Reject field occurrence indicator - ; - N CNTR,COUNT,RJCD,RJOC,RLCNT - ; - S RLCNT=0 - S COUNT=$G(FDATA("M",MEDN,510)) ;reject count - Q:COUNT'>0 - ; - F CNTR=1:1:COUNT D - . S (RJCD,RJOC)="" - . S RJCD=$G(FDATA("M",MEDN,511,CNTR)) ;rejection code - . S RJOC=$G(FDATA("M",MEDN,546,CNTR)) ;reject fld occurence ind - . I $D(RJCD) D - .. S $P(^BPSR(RESPIEN,1000,INDEX,511,CNTR,0),U)=RJCD - .. S ^BPSR(RESPIEN,1000,INDEX,511,"B",RJCD,CNTR)="" - . S:$D(RJOC) $P(^BPSR(RESPIEN,1000,INDEX,511,CNTR,0),U,2)=RJOC - . S:(($D(RJOC))!($D(RJCD))) RLCNT=RLCNT+1 - ; - I RLCNT>0 D - . S ^BPSR(RESPIEN,1000,INDEX,511,0)="^9002313.03511A^"_RLCNT_"^"_RLCNT - ; - Q - ; - ; -REPAPP ; This subroutine will process the approved repeating field - ; that is a part of the status segment. - ; Field 548 - Approved Message Code - ; - N CNTR,COUNT,RLCNT,APP - ; - S RLCNT=0 - S COUNT=$G(FDATA("M",MEDN,547)) ;approved message code count - Q:COUNT'>0 - ; - F CNTR=1:1:COUNT D - . S (APP)="" - . S APP=$G(FDATA("M",MEDN,548,CNTR)) ;approved message code - . I $D(APP) D - .. S $P(^BPSR(RESPIEN,1000,INDEX,548,CNTR,0),U)=APP - .. S ^BPSR(RESPIEN,1000,INDEX,548,"B",APP,CNTR)="" - .. S RLCNT=RLCNT+1 - ; - I RLCNT>0 D - . S ^BPSR(RESPIEN,1000,INDEX,548,0)="^9002313.301548A^"_RLCNT_"^"_RLCNT - ; - Q - ; -RESPCLM ;EP - NCPDP 5.1 response processing (moved from BPSOSH5) - ; called from WRTTRAN^BPSOSH5 - ; MEDN is set in BPSOSH5 in the WRTTRAN subroutine - ; process the response claim segment - here's the fields we MIGHT - ; encounter: - ; 455 - prescription/service reference number qualifier - ; 402 - prescripton/service reference number - ; 551 - preferred product count - ; 552 - preferred product id qualifier (repeating) - ; 553 - preferred product id (repeating) - ; 554 - preferred product incentive (repeating) - ; 555 - preferred product copay incentive (repeating) - ; 556 - preferred product description (repeating) - ; - ; start with what are suppose to be mandatory fields - S $P(^BPSR(RESPIEN,1000,INDEX,450),U,5)=$G(FDATA("M",MEDN,455)) - S $P(^BPSR(RESPIEN,1000,INDEX,400),U,2)=$G(FDATA("M",MEDN,402)) - ; - ; now lets try to process the preferred product repeating fields - S $P(^BPSR(RESPIEN,1000,INDEX,550),U)=$G(FDATA("M",MEDN,551)) - I $D(FDATA("M",MEDN,551)) D REPPPD ;process the repeating fld - ; - Q - ; -REPPPD ; This subroutine will process the preferred product repeating fields - ; that are a part of the claim segment. - ; five fields here- 552 - Preferred product id qualifier - ; 553 - Preferred product id - ; 554 - Preferred product incentive - ; 555 - preferred product copay incentive - ; 556 - preferred product description - ; - N CNTR,COUNT,PPIDQ,PPID,PPINC,PPCOP,PPDESC,CKREC - ; - S RLCNT=0 - S COUNT=$G(FDATA("M",MEDN,551)) ;preferred product count - Q:COUNT'>0 - ; - F CNTR=1:1:COUNT D - . S (PPIDQ,PPID,PPINC,PPCOP,PPDESC)="" - . S PPIDQ=$G(FDATA("M",MEDN,552,CNTR)) ;preferred product id qual - . S PPID=$G(FDATA("M",MEDN,553,CNTR)) ;preferred product id - . S PPINC=$G(FDATA("M",MEDN,554,CNTR)) ;preferred product incentive - . S PPCOP=$G(FDATA("M",MEDN,555,CNTR)) ;preferred product copay inc - . S PPDESC=$G(FDATA("M",MEDN,556,CNTR)) ;preferred product desc - . S CKREC=PPIDQ_PPID_PPINC_PPCOP_PPDESC ;quick chk for values - . I $D(CKREC) D - .. S $P(^BPSR(RESPIEN,1000,INDEX,551.01,CNTR,0),U)=CNTR - .. S ^BPSR(RESPIEN,1000,INDEX,551.01,"B",CNTR,CNTR)="" - .. S RLCNT=RLCNT+1 - . S:$D(PPIDQ) $P(^BPSR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,1)=PPIDQ - . S:$D(PPID) $P(^BPSR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,2)=PPID - . S:$D(PPINC) $P(^BPSR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,3)=PPINC - . S:$D(PPCOP) $P(^BPSR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,4)=PPCOP - . S:$D(PPDESC) $P(^BPSR(RESPIEN,1000,INDEX,551.01,CNTR,1),U,5)=PPDESC - ; - I RLCNT>0 D - . S ^BPSR(RESPIEN,1000,INDEX,551.01,0)="^9002313.1301A^"_RLCNT_"^"_RLCNT - ; - Q - ; diff -auBN ./r1/BPSOSH7.m ./r2/r/BPSOSH7.m --- ./r1/BPSOSH7.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSH7.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,202 +0,0 @@ -BPSOSH7 ;BHAM ISC/SD/lwj/DLF - NCPDP 5.1 Post 5.1 response ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;------------------------------------------------------------- - ; Originally, the entire response was processed in the - ; BPSOSH5 routine - but it exceed SAC limitations on - ; routine size - so the processing of some of the transaction - ; level information was moved to this routine. Other portions - ; were moved to the BPSOSH6 routine. - ; - ; This routine is called solely from BPSOSH5. - ; - ; - Q -RESPPRC ;EP - NCPDP 5.1 response processing (moved from BPSOSH5) - ; called from WRTTRAN^BPSOSH5 - ; MEDN is set in BPSOSH5 in the WRTTRAN subroutine - ; process the response pricing segment - here's the fields we MIGHT - ; encounter: - ; 505 - patient pay amount - ; 506 - ingredient code paid - ; 507 - dispensing fee paid - ; 557 - tax exempt indicator - ; 558 - flat sales tax amount paid - ; 559 - percentage sales tax amount paid - ; 560 - percentage sales tax rate paid - ; 561 - percentage sales tax basis paid - ; 521 - incentive amount paid - ; 562 - professional service fee paid - ; 563 - other amount paid count - ; 564 - other amount paid qualifier (repeating) - ; 565 - other amount paid (repeating) - ; 566 - other payer amount recognized - ; 509 - total amount paid - ; 522 - basis of reimbursement determination - ; 523 - amount attributed to sales tax - ; 512 - accumulated deductible amount - ; 513 - remaining deductible amount - ; 514 - remaining benefit amount - ; 517 - amount applied to periodic deductible - ; 518 - amount of copay/co-insurance - ; 519 - amount attributed to product selection - ; 520 - amount exceeding periodic benefit maximum - ; 346 - basis of calculation - dispensing fee - ; 347 - basis of calculation - copay - ; 348 - basis of calculation - flat sales tax - ; 349 - basis of calculation - percentage sales tax - ; - ; process everything up to the repeating fields - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,5)=$G(FDATA("M",MEDN,505)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,6)=$G(FDATA("M",MEDN,506)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,7)=$G(FDATA("M",MEDN,507)) - S $P(^BPSR(RESPIEN,1000,INDEX,550),U,7)=$G(FDATA("M",MEDN,557)) - S $P(^BPSR(RESPIEN,1000,INDEX,550),U,8)=$G(FDATA("M",MEDN,558)) - S $P(^BPSR(RESPIEN,1000,INDEX,550),U,9)=$G(FDATA("M",MEDN,559)) - S $P(^BPSR(RESPIEN,1000,INDEX,550),U,10)=$G(FDATA("M",MEDN,560)) - S $P(^BPSR(RESPIEN,1000,INDEX,560),U)=$G(FDATA("M",MEDN,561)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,21)=$G(FDATA("M",MEDN,521)) - S $P(^BPSR(RESPIEN,1000,INDEX,560),U,2)=$G(FDATA("M",MEDN,562)) - ; - ; figure out if we have any of the other paid amount repeating flds - S $P(^BPSR(RESPIEN,1000,INDEX,560),U,3)=$G(FDATA("M",MEDN,563)) - I $D(FDATA("M",MEDN,563)) D REPOPA ;process the repeating flds - ; - ; now back to the reqular fields - S $P(^BPSR(RESPIEN,1000,INDEX,560),U,6)=$G(FDATA("M",MEDN,566)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,9)=$G(FDATA("M",MEDN,509)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,22)=$G(FDATA("M",MEDN,522)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,23)=$G(FDATA("M",MEDN,523)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,12)=$G(FDATA("M",MEDN,512)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,13)=$G(FDATA("M",MEDN,513)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,14)=$G(FDATA("M",MEDN,514)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,17)=$G(FDATA("M",MEDN,517)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,18)=$G(FDATA("M",MEDN,518)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,19)=$G(FDATA("M",MEDN,519)) - S $P(^BPSR(RESPIEN,1000,INDEX,500),U,20)=$G(FDATA("M",MEDN,520)) - S $P(^BPSR(RESPIEN,1000,INDEX,340),U,6)=$G(FDATA("M",MEDN,346)) - S $P(^BPSR(RESPIEN,1000,INDEX,340),U,7)=$G(FDATA("M",MEDN,347)) - S $P(^BPSR(RESPIEN,1000,INDEX,340),U,8)=$G(FDATA("M",MEDN,348)) - S $P(^BPSR(RESPIEN,1000,INDEX,340),U,9)=$G(FDATA("M",MEDN,349)) - ; - ; - Q - ; - ; -REPOPA ; This subroutine will process the other amount paid repeating fields - ; that are a part of the pricing segment. - ; Two fields here - 564 - other amount paid qualifier - ; 565 - other amount paid - ; - N CNTR,COUNT,AMTPDQ,AMTPD,CKREC - ; - S RLCNT=0 - S COUNT=$G(FDATA("M",MEDN,563)) ;other amoutn paid count - Q:COUNT'>0 - ; - F CNTR=1:1:COUNT D - . S (AMTPDQ,AMTPD)="" - . S AMTPDQ=$G(FDATA("M",MEDN,564,CNTR)) ;other amount paid qual - . S AMTPD=$G(FDATA("M",MEDN,565,CNTR)) ;other amount paid - . S CKREC=AMTPDQ_AMTPD ;quick chk for values - . I $D(CKREC) D - .. S $P(^BPSR(RESPIEN,1000,INDEX,563.01,CNTR,0),U)=CNTR - .. S ^BPSR(RESPIEN,1000,INDEX,563.01,"B",CNTR,CNTR)="" - .. S RLCNT=RLCNT+1 - . S:$D(AMTPDQ) $P(^BPSR(RESPIEN,1000,INDEX,563.01,CNTR,1),U,1)=AMTPDQ - . S:$D(AMTPD) $P(^BPSR(RESPIEN,1000,INDEX,563.01,CNTR,1),U,2)=AMTPD - ; - I RLCNT>0 D - . S ^BPSR(RESPIEN,1000,INDEX,563.01,0)="^9002313.1401A^"_RLCNT_"^"_RLCNT - ; - Q - ; -RESPDUR ;EP - NCPDP 5.1 response processing (moved from BPSOSH5) - ; called from WRTTRAN^BPSOSH5 - ; MEDN is set in BPSOSH5 in the WRTTRAN subroutine - ; process the response DUR segment - here's the fields we MIGHT - ; encounter: - ; 567 - DUR/PPS Response Code counter (repeating) - ; 439 - reason for service (repeating) - ; 528 - clinical significance code (repeating) - ; 529 - other pharmacy indicator (repeating) - ; 530 - previous date of fill (repeating) - ; 531 - quanityt of previous fill (repeating) - ; 532 - database indicator (repeating) - ; 533 - other prescriber indicator (repeating) - ; 544 - DUR free text message (repeating) - ; - ; All fields on this segment are not only optional, but also - ; repeating. Please note that field 567 is NOT a count, but - ; a counter, which changes how we process this repeating - ; segment. Since this entire record is repeating, and the - ; logic is different, we will keep it here, rather than have - ; it call a separate repeating subroutine. - ; - ; - N CNTR,RLCNT,RSNCD,CLINCD,OTHPHM,PREVDT,PRVQTY,DBID,OTHPRS,FREETX - ; - Q:'$D(FDATA("M",MEDN,567)) ;just quit if there isn't anything - ; - S (CNTR,RLCNT)=0 - ; - F S CNTR=$O(FDATA("M",MEDN,567,CNTR)) Q:CNTR="" D - . ;first lets retrieve the values for this record - . S RLCNT=RLCNT+1 - . S (RSNCD,CLINCD,OTHPHM,PREVDT,PRVQTY,DBID,OTHPRS,FREETX)="" - . S RSNCD=$G(FDATA("M",MEDN,439,CNTR)) ;reason for service code - . S CLINCD=$G(FDATA("M",MEDN,528,CNTR)) ;clinical significance code - . S OTHPHM=$G(FDATA("M",MEDN,529,CNTR)) ;other pharmacy indicator - . S PREVDT=$G(FDATA("M",MEDN,530,CNTR)) ;previous date of fill - . S PRVQTY=$G(FDATA("M",MEDN,531,CNTR)) ;quantity of previous fill - . S DBID=$G(FDATA("M",MEDN,532,CNTR)) ;database indicator - . S OTHPRS=$G(FDATA("M",MEDN,533,CNTR)) ;other prescriber indicator - . S FREETX=$G(FDATA("M",MEDN,544,CNTR)) ;DUR free text message - . ; - . ; now lets set the response file with the values we just got - . ; don't forget that we have to hard set the "b" xref too - . S $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U)=CNTR - . S ^BPSR(RESPIEN,1000,INDEX,567.01,"B",CNTR,CNTR)="" - . S:$D(RSNCD) $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U,2)=RSNCD - . S:$D(CLINCD) $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U,3)=CLINCD - . S:$D(OTHPHM) $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U,4)=OTHPHM - . S:$D(PREVDT) $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U,5)=PREVDT - . S:$D(PRVQTY) $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U,6)=PRVQTY - . S:$D(DBID) $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U,7)=DBID - . S:$D(OTHPRS) $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U,8)=OTHPRS - . S:$D(FREETX) $P(^BPSR(RESPIEN,1000,INDEX,567.01,CNTR,0),U,9)=FREETX - ; - I RLCNT>0 D - . S ^BPSR(RESPIEN,1000,INDEX,567.01,0)="^9002313.1101A^"_RLCNT_"^"_RLCNT - ; - Q - ; - ; -RESPPA ;EP - NCPDP 5.1 response processing (moved from BPSOSH5) - ; called from WRTTRAN^BPSOSH5 - ; MEDN is set in BPSOSH5 in the WRTTRAN subroutine - ; process the response prior authorization segment - here's the - ; fields we MIGHT encounter: - ; 498.51 - prior authorization processed date - ; 498.52 - prior authorization effective date - ; 498.53 - prior authorization expiration date - ; 498.57 - prior authorization quantity - ; 498.58 - prior authorization dollars authorized - ; 498.54 - prior authorization number of refills authorized - ; 498.55 - prior authorization quantity accumulated - ; 498.14 - prior authorization number - assigned - ; - ; no repeating fields on this segments so we will simply process - ; what we find - ; - S $P(^BPSR(RESPIEN,1000,INDEX,498),U,1)=$G(FDATA("M",MEDN,498.51)) - S $P(^BPSR(RESPIEN,1000,INDEX,498),U,2)=$G(FDATA("M",MEDN,498.52)) - S $P(^BPSR(RESPIEN,1000,INDEX,498),U,3)=$G(FDATA("M",MEDN,498.53)) - S $P(^BPSR(RESPIEN,1000,INDEX,498),U,7)=$G(FDATA("M",MEDN,498.57)) - S $P(^BPSR(RESPIEN,1000,INDEX,498),U,8)=$G(FDATA("M",MEDN,498.58)) - S $P(^BPSR(RESPIEN,1000,INDEX,498),U,4)=$G(FDATA("M",MEDN,498.54)) - S $P(^BPSR(RESPIEN,1000,INDEX,498),U,5)=$G(FDATA("M",MEDN,498.55)) - S $P(^BPSR(RESPIEN,1000,INDEX,498),U,6)=$G(FDATA("M",MEDN,498.14)) - ; - ; - Q - ; diff -auBN ./r1/BPSOSHF.m ./r2/r/BPSOSHF.m --- ./r1/BPSOSHF.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSHF.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,107 +0,0 @@ -BPSOSHF ;BHAM ISC/SD/lwj/DLF- Get/Format/Set value for DUR/PPS segment ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; This routine is an addemdum to BPSOSCF. Its purpose is to handle - ; some of the repeating fields that now exist in NCPDP 5.1. - ; The logic was put in here rather than BPSOSCF to keep the original - ; routine (BPSOSCF) from growing too large and too cumbersome to - ; maintain. - ; - ; At this point, the only repeating fields we handle in this routine - ; are those contained in the DUR/PPS segment. - ; -DURPPS(FORMAT,NODE,MEDN) ;EP called from BPSOSCF - ;--------------------------------------------------------------- - ;NCPDP 5.1 changes - ; Processing of the 5.1 DUR/PPS segment is much different than the - ; conventional segments of 3.2, simply because all of its fields - ; are optional, and repeating. The repeating portion of this - ; causes us to have yet another index we have to account for, and - ; we must be able to tell which of the fields really needs to be - ; populated. The population of this segment is based on those - ; values found for the prescription or refill in the BPS DUR/PPS - ; file. The file's values are temporarily stored in the - ; BPS("RX",MEDN,DUR....) array for easy access and reference. - ; (Special note - Overrides are not allowed on this multiple since - ; they can simply update the DUR/PPS filed directly. For the same - ; reason, "special" code is not accounted for either. - ;--------------------------------------------------------------- - ; - ; first order of business - check the BPS("RX",MEDN,"DUR") array - ; for values - if there aren't any, we don't need to write this - ; segment - ; - N FIELD,BPS51,RECCNT,DUR,FLD,OVERRIDE,FLAG,ORD,FLDIEN,FLDNUM - S FLAG="FS" - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S FLAG="GFS" - ; - Q:'$D(BPS("RX",MEDN,"DUR")) - ; - ;next we need to figure out which fields on this format are really - ; needed, then we will loop through and populate them - ; - D GETFLDS(FORMAT,NODE,.FIELD) - ; - ; now lets get, format and set the field - S BPS51=1 ;needed in the set logic for dual 3.2/5.1 fields - S (ORD,RECCNT,ZDUR)=0 - S RECCNT=RECCNT+1 - F S ZDUR=$O(BPS("RX",MEDN,"DUR",ZDUR)) Q:ZDUR="" D - . S FLDNUM="" F S FLDNUM=$O(BPS("RX",MEDN,"DUR",ZDUR,FLDNUM)) Q:FLDNUM="" D - .. S ORD="",FOUND=0 - .. F S ORD=$O(FIELD(ORD)) Q:ORD="" D Q:FOUND - ... S FLDNUMB="",FLDNUMB=$P(FIELD(ORD),U,2) Q:FLDNUMB'=FLDNUM - ... S FLDIEN="",FLDIEN=$P(FIELD(ORD),U) - ... S BPS("X")=BPS("RX",MEDN,"DUR",ZDUR,FLDNUM) - ... ;I $D(BPS("RX",MEDN,"DUR",ZDUR,FLDNUM)) - ... S FOUND=1 S ^ZLE("BPS",$H,"CERT BPS "_ZDUR)=BPS("X") ;get - ... D XFLDCODE^BPSOSCF(FLDIEN,FLAG) ;format/set - ; - M ^ZLE("BPS",$H,"CERT BPS HF")=BPS - ; this sets the record count and last record on the subfile - S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,0)="^9002313.1001A^"_RECCNT_"^"_RECCNT - ; - Q -GETFLDS(FORMAT,NODE,FIELD) ;EP NCPDP 5.1 - ;--------------------------------------------------------------- - ;This routine will get the list of repeating fields that must be - ; be worked with separately - ; (This was originally coded for the DUR/PPS segment - I'm not - ; 100% sure how and if it will work for the other repeating - ; fields that exist within a segment.) - ;--------------------------------------------------------------- - ; Coming in: - ; FORMAT = BPSF(9002313.92 's format IEN - ; NODE = which segment we are processing (i.e. 180 - DUR/PPS) - ; .FIELD = array to store the values in - ; - ; Exitting: - ; .FIELD array will look like: - ; FIELD(ord)=int^ext - ; Where: ext = external field number from BPSF(9002313.91 - ; int = internal field number from BPSF(9002313.91 - ; ord = the order of the field - used in creating clm - ;--------------------------------------------------------------- - ; - N ORDER,RECMIEN,MDATA,FLDIEN,FLDNUM,DUR - ; - S ORDER=0 - ; - F D Q:'ORDER - . ; - . ; let's order through the format file for this node - . ; - . S ORDER=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER)) Q:'ORDER - . S RECMIEN=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER,0)) - . I 'RECMIEN D IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"ORDER="_ORDER,2,$T(+0)) - . S MDATA=^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0) - . S FLDIEN=$P(MDATA,U,2) - . I 'FLDIEN D IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"RECMIEN="_RECMIEN,3,$T(+0)) ; corrupt or erroneous format file - . I '$D(^BPSF(9002313.91,FLDIEN,0)) D IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"DURPPS",$T(+0)) ;incomplete field definition - . ; - . ;lets create a list of fields we need - . S FLDNUM=$P($G(^BPSF(9002313.91,FLDIEN,0)),U) - . S:FLDNUM'=111 FIELD(ORDER)=FLDIEN_"^"_FLDNUM - ; - ; - Q diff -auBN ./r1/BPSOSHR.m ./r2/r/BPSOSHR.m --- ./r1/BPSOSHR.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSHR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,146 +0,0 @@ -BPSOSHR ;BHAM ISC/SD/lwj/DLF - 3.2 to 5.1 clm reversal format ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ;------------------------------------------------------- - ; IHS/SD/lwj 10/22/02 NCPDP 5.1 changes - ; We ran into a big snag - some processors are doing an all or nothing - ; switch to 5.1 with no grace period for 3.2 and 5.1 claims. What this - ; means is that we have to be able to reverse a previously submitted - ; 3.2 claim in 5.1 reversal format since they won't accept 3.2 any - ; more. The biggest problem with this is that 3.2 and 5.1 fields - ; are formatted differently, and the reversal process was used to - ; simply copy the information from the original claim into the - ; reversal claim. To get around this, this routine was created - ; to try and reformat those fields that require the 5.1 format to - ; reverse properly. - ; - ; This routine should only be called from within the BPSECA8 - it - ; is dependent on variables set there. - ; - ; Basic logic: - ; Read the format for the designated segment - ; Read through the fields on the segment (no xref - very few fields) - ; Determine if there are "special" values for the field - ; Format the field with the proper value - ; Set the TMP field to the formatted value - ; - Q - ; -REFORM(BPSFORM) ;EP main driver of problem and entry point - everything - ; should call through to here - ; - N BPS - ; - D REFRMH(BPSFORM) - D REFRMD(BPSFORM) - ; - Q -REFRMH(BPSFORM) ; - ; This routine will only attempt to reset the "header" fields that need - ; adjusting for 5.1. There are four fields in the header segment that - ; need to be reformatted - we will leave the others since they may have - ; gone through extensive formatting for the original claim and are fine - ; the way they are. These four fields were either new to the reversal - ; in 5.1, or changed value/length in 5.1. The fields are: - ; 109 Transaction Count (not on 3.2 reversal) - ; 110 Software Vendor/Certificationd ID (new field to 5.1) - ; 201 Service Provider ID (changed length in 5.1) - ; 202 Service Provider ID Qualifier (new to 5.1) - ; - ; Remember - the header is stagnate - that's the only reason we look - ; specifically for those two fields. - ; - ; IEN and TMP are set in BPSECA8 - ; - ; The header segment is small, and there isn't a xref by field #, so we - ; will read the entire segment here. - ; - N FLDIEN,PMODE,ORDER,RECMIEN,FIELD - ; - S ORDER=0 - F S ORDER=$O(^BPSF(9002313.92,BPSFORM,100,"B",ORDER)) Q:'ORDER D - . S RECMIEN=$O(^BPSF(9002313.92,BPSFORM,100,"B",ORDER,0)) - . Q:'RECMIEN - . S FLDIEN=$P($G(^BPSF(9002313.92,BPSFORM,100,RECMIEN,0)),U,2) - . S FIELD=$P($G(^BPSF(9002313.91,FLDIEN,0)),U) - . Q:(FIELD'=110)&(FIELD'=202)&(FIELD'=201)&(FIELD'=109) - . ; - . ; check to see if the format has a "special" value for this field - . S PMODE=$P($G(^BPSF(9002313.92,BPSFORM,100,RECMIEN,0)),U,3) - . I PMODE="X" D XSPCCODE^BPSOSCF(BPSFORM,100,RECMIEN) - . I PMODE'="X" S BPS("X")=TMP(9002313.02,IEN,FIELD,"I") - . ; - . D FORMAT - . ; - . S TMP(9002313.02,IEN,FIELD,"I")=BPS("X") - ; - ; - Q - ; -REFRMD(BPSFORM) ; - ; This routine is going to try and reformat the "detail" portion of the - ; claim. For now, the only segment we are going to look at is 130 - ; which is the claim segment. If other reversal formats become - ; available, and they require other segments - this section will have - ; to change. Since the claim segment full of optional fields, we wil - ; read through the format and take it a field at a time. - ; - ; IEN, RX, and TMP were set in BPSECA8 - ; - ; - N FLDIEN,PMODE,ORDER,RECMIEN,NODE,IDIEN,DOFORM,FIELD - S NODE=130 - ; - S ORDER=0 - F S ORDER=$O(^BPSF(9002313.92,BPSFORM,NODE,"B",ORDER)) Q:'ORDER D - . S RECMIEN=$O(^BPSF(9002313.92,BPSFORM,NODE,"B",ORDER,0)) - . Q:'RECMIEN - . S FLDIEN=$P($G(^BPSF(9002313.92,BPSFORM,NODE,RECMIEN,0)),U,2) - . S FIELD=$P($G(^BPSF(9002313.91,FLDIEN,0)),U) - . Q:FIELD=111 ;(SEGMENT IDENTIFIER - SKIP) - . ; - . ; check to see if the format has a "special" value for this field - . S PMODE=$P($G(^BPSF(9002313.92,BPSFORM,NODE,RECMIEN,0)),U,3) - . I $G(VARX) S BPS("X")=TMP(9002313.0201,RX,FIELD,"I") ;LJE;8/2/03 - . I PMODE="X" D XSPCCODE^BPSOSCF(BPSFORM,NODE,RECMIEN) - . ; - . ; if this isn't a special value field in 5.1, we need to make sure - . ; it wasn't an optional field in 3.2. If it was, the field ID is - . ; already a part of the field, and we don't need to reformat it - . ; - . S DOFORM=1 - . I PMODE'="X" D - .. S:$P($G(^BPSF(9002313.91,FLDIEN,0)),U,2)'="" DOFORM=0 - .. S:DOFORM BPS("X")=TMP(9002313.0201,RX,FIELD,"I") - . ; - . ; format it only if it needs it - . ; - . I DOFORM D - .. D FORMAT - .. S TMP(9002313.0201,RX,FIELD,"I")=BPS("X") - ; - ; - Q - ; -FORMAT ; This routine will format the field to 5.1 standards - remember it - ; will set BPS("X") based on what is in the BPS NCPDP Field Defs file - ; - N INDEX,MCODE,NODE,QUAL,QUALFLG ;LJE;8/2/03 - S NODE=25 ;we only want the 5.1 format code - ; - S QUALFLG=0,QUAL="",QUAL=$P(^BPSF(9002313.91,FLDIEN,5),"^",1) ;LJE;8/2/03 - I $E(BPS("X"),1,2)=QUAL S QUALFLG=1,BPS("X")=$P(BPS("X"),QUAL,2) ;LJE;8/2/03 - S INDEX=0 - F D Q:'+INDEX - . S INDEX=$O(^BPSF(9002313.91,FLDIEN,NODE,INDEX)) - . Q:'+INDEX - . S MCODE=$G(^BPSF(9002313.91,FLDIEN,NODE,INDEX,0)) - . Q:MCODE="" - . Q:$E(MCODE,1)=";" - . ;S QUALFLG=0,QUAL="",QUAL=$P(^BPSF(9002313.91,FLDIEN,5),"^",1) ;LJE;8/2/03 - . ;I $E(BPS("X"),1,2)=QUAL S QUALFLG=1,BPS("X")=$P(BPS("X"),QUAL,2) ;LJE;8/2/03 - . X MCODE - I QUALFLG&($E(BPS("X"),1,2)'=QUAL) S BPS("X")=QUAL_BPS("X") - ; - ; - Q diff -auBN ./r1/BPSOSHU.m ./r2/r/BPSOSHU.m --- ./r1/BPSOSHU.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSHU.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,30 +0,0 @@ -BPSOSHU ;BHAM ISC/SD/lwj/DLF - various miscellaneous 5.1 utilities ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ;-------------------------------------------------------------- - ; Because of SAC routine size limitations, many utilities - ; had to be split off into their own individual routines to - ; avoid the limitation. - ; - ; -CLNDATA ;EP NCPDP 5.1 Called from BPSOSH5 - ; Remove the leading and trailing blanks in each of the fields - ; that is to be written to the ^BPSR global. - ; - N NEXT,MEDN - ; - S NEXT=0 - F D Q:'NEXT - .S NEXT=$O(FDATA(NEXT)) Q:'NEXT - .S FDATA(NEXT)=$$CLIP^BPSOSU9($G(FDATA(NEXT))) - S MEDN="" - F D Q:MEDN="" - .S MEDN=$O(FDATA("M",MEDN)) - .Q:MEDN="" - .S NEXT=0 - .F D Q:'+NEXT - ..S NEXT=$O(FDATA("M",MEDN,NEXT)) - ..Q:'+NEXT - ..S FDATA("M",MEDN,NEXT)=$$CLIP^BPSOSU9($G(FDATA("M",MEDN,NEXT))) - ; - Q diff -auBN ./r1/BPSOSI7.m ./r2/r/BPSOSI7.m --- ./r1/BPSOSI7.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSI7.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,79 +0,0 @@ -BPSOSI7 ;BHAM ISC/FCS/DRS/DLF - utilities to go with Page 7 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------- - ;IHS/SD/lwj 8/29/02 NCPDP 5.1 changes - ; new field added to the insurance/prior authorization screen - ; to capture the Prior Authorization Type Code. Changed - ; ENAB subroutine to enable and disable this field. The - ; field will be enabled when the preauthorization code is - ; enabled, and disabled when the preauth is disable. - ; The only time the value of this field will be recorded in - ; the claim is when the format for the claims is 5.1. - ;---------------------------------------------------------- - Q -DOPAGE() ;EP - should we do page 7? Only if one or more of the ques. are enabled - ; this is used by the BRANCH logic of the NDC/CPT/HCPCS field - ; to figure whether to set DDSSTACK="THE ASKS" - ; Actual enabling is done by ENAB - N DOIT - I $$DOFIELD(1.01) S DOIT=1 ; insurance - E I $$DOFIELD(1.02) S DOIT=1 ; preauth - E I $$DOFIELD(1.03) S DOIT=1 ; pricing - E S DOIT=0 - Q DOIT -ISCPT() ; non-prescription, CPT code - detected by absence of RXI - Q $$GET^DDSVAL(DIE,.DA,1.01)="" -DOFIELD(N) ;EP - context: form, page 1, block BPS PAGE 1 BOTTOM - ; DIE = "^BPS(9002313.51,DA(1),2,DA," - ; DA(1), DA point to the line item. - ; But we're looking at the yes/no's at ^BPS(9002313.51,DA(1),*) - N RET S RET=$$GET^DDSVAL(9002313.51,DA(1),N) - ; For insurance, you have to have had lines set up for insurance, too - I N=1.01,RET S RET=RET&$D(^BPS(9002313.51,DA(1),2,DA,"I",1)) - ; for pricing, this can't be POSTAGE (it's done on Page 11, not 7) - I N=1.03 D - . ; Do not ask pricing for POSTAGE; it has its own pricing page - . I $$GET^DDSVAL(DIE,.DA,.03)="POSTAGE" S RET=0 Q - . ; Do ask pricing for CPT codes (detected by absence of RXI) - . I $$ISCPT S RET=1 Q - Q RET -ENAB ; enable/disable blocks,fields based on settings in fields 1.01 ff - ; done on entry to page 7 - D ENAB1(1.01,4,1) ; insurance - ; - ;IHS/SD/lwj 8/30/02 NCPDP 5.1 changes - ; A new field for the prior auth type code was needed- to have - ; the screen flow, the new field, and the existing preauthorization - ; field were reversed - field 1 is now the type, and field 2 is the - ; prior auth number (formally preauthorization) - D ENAB1(1.02,1,2) ;IHS/SD/lwj 8/30/02 now the prior auth type - ; - D ENAB1(1.02,2,2) ;IHS/SD/lwj 8/30/02 this is the prior auth number - ; - N F F F=11,12,14 D ENAB1(1.03,F,3) ; qty, unit price, dispense fee - ; set up some pricing defaults if nothing is set up yet - I $$DOFIELD(1.03),$$GET^DDSVAL(DIE,.DA,5.02)="" D PAGE7^BPSOSQP - ; set up some insurance defaults if nothing is set up yet - I $$DOFIELD(1.01),$$GET^DDSVAL(DIE,.DA,7.01)="" D INIT^BPSOSI8 - Q -ENAB1(ORIG,FIELD,BLOCK,PAGE) ;EP - I '$G(PAGE) S PAGE=7 - D UNED^DDSUTL(FIELD,BLOCK,PAGE,'$$DOFIELD(ORIG)) - Q -RECALC1 ;EP - from BPSOSI2,BPSOSQP - ; when you change quantity or unit price - N X S X=$$GET^DDSVAL(DIE,.DA,5.01) - N Y S Y=$$GET^DDSVAL(DIE,.DA,5.02) - N Z S Z=X*Y - S Z=$$ROUND(Z) - D PUT^DDSVAL(DIE,.DA,5.03,$J(Z,0,2)) - D RECALC2 ; and then that affects the total price - Q -RECALC2 ; when you change dispense fee - N X S X=$$GET^DDSVAL(DIE,.DA,5.03) - N Y S Y=$$GET^DDSVAL(DIE,.DA,5.04) - N Z S Z=X+Y - S Z=$$ROUND(Z) - D PUT^DDSVAL(DIE,.DA,5.05,$J(Z,0,2)) - Q -ROUND(X) Q X*100+.5\1/100 diff -auBN ./r1/BPSOSI8.m ./r2/r/BPSOSI8.m --- ./r1/BPSOSI8.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSI8.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,173 +0,0 @@ -BPSOSI8 ;BHAM ISC/FCS/DRS/DLF - insurance selection - page 8 ;06/14/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -FN() Q 9002313.522 -INIT ;EP - from BPSOSI7 - ;This initializes the page 8 data. - ; It's called as the entry action for page 8. - ; - ; We have DIE, DA(1) and DA, which point us into - ; ^BPS(9002313.51,DA(1),2,DA,*) - ; We want to initialize the insurance data in - ; ^BPS(9002313.51,DA(1),2,DA,"I",*) - ; - ; All the line items are already created, before we entered the form, - ; and there's a fixed number of them. Unpleasant, but true. - ; We tried various kludgey ways to call UPDATE^DIE and create a - ; variable-length list at the time the page was loaded, but it - ; had various problems and we gave up. Hopefully, there are enough - ; line items to hold everything that's needed. If there aren't, - ; let's try to always make SELF PAY the last one, always leaving - ; room for SELF PAY. - ; - ; We always refresh with newest stuff from a call to BPSOS25. - ; But if we had an existing order, we will impose that order on - ; the BPSOS25 results. - ; - ; - ; How many entries are there? We can look at the global because - ; the size is, regrettably, fixed. - N NINS S NINS=$P(^BPS(9002313.51,DA(1),2,DA,"I",0),U,4) - ; - ; What is the current order? (For efficient assignment later). - N ORDER D - . N I F I=1,2,3 D - . . N X S X=$$GET^DDSVAL(DIE,.DA,"6.0"_I) - . . I X]"" S ORDER(X)=I - ; First, call BPSOS25, giving ARRAY -1 N ARRAY D AVAIL() ; what insurance choices are available, per A/R? - ; Fill in defaults for any 6.01,7.01,...,6.03,7.03 that are empty - D ; fill in any missing orders - . N I S I=0 ; source pointer - . N J,K S K=0 F J=1:1:3 I $$GET^DDSVAL(DIE,.DA,J/100+6)="" S K=J Q - . I 'K Q ; all three slots already in use - . ; J = first slot available - . N STOP S STOP=0 - . F D Q:STOP - . . S I=I+1 I I>ARRAY(0) S STOP=1 Q ; exhausted the ARRAY() - . . N PINS S PINS=$P(ARRAY(I),U,2) ; is this entry already in top 3? - . . I $D(ORDER(PINS)) Q ; yes, already in top 3 - . . D PUT^DDSVAL(DIE,.DA,J/100+6,PINS) ; not in top 3 yet, assign it - . . D PUT^DDSVAL(DIE,.DA,J/100+7,$P(ARRAY(I),U),,"I") ; store corr. INSIEN - . . S ORDER(PINS)=J - . . I J=3 S STOP=1 Q - . . S J=J+1 ; advance to next -2 ; Do not delete old entries - we're not allowed to delete existing - ; entries with PUT^DDSVAL, and we surely shouldn't KILL them off. - I 0 D - . N X S X="" N S S S="" F S S=$O(ORDER(S)) Q:S="" D - . . S X=X_"ORDER("_S_")="_ORDER(S)_"; " - . D MSGWAIT^BPSOSI1(X) -3 D STOREARR() ; set up the database - Q -MSGWAIT(X) D MSGWAIT^BPSOSI1(X) Q -AVAIL() ;Use BPSOS25 to get the very latest insurance information. - ; - K ARRAY ; fills ARRAY(*) - D ; set up parameters and make the call to BPSOS25 - . N FRESH S FRESH=1 ; without regard to previous visits - . N ABSBRXI S ABSBRXI=$$GET^DDSVAL(DIE,.DA,1.01) - . N ABSBRXR S ABSBRXR=$$GET^DDSVAL(DIE,.DA,1.02) - . N ABSBPATI S ABSBPATI=$$GET^DDSVAL(DIE,.DA,1.04) - . N ABSBVISI S ABSBVISI=$$GET^DDSVAL(DIE,.DA,1.06) - . N RETVAL S RETVAL=$$INSURER^BPSOS25(.ARRAY,FRESH,NINS) - ; ARRAY(0)=count and then some other stuff - ; ARRAY(n)=insurer IEN ^ PINS - QUIT -STOREARR() ; setup entries in database and on form, based on ARRAY(*) - N ENTRY F ENTRY=1:1:$P(ARRAY(0),U) D SETUP1 - Q -SETUP1 ; for ARRAY(ENTRY) - N RETVAL - N INSIEN,PINS S INSIEN=$P(ARRAY(ENTRY),U),PINS=$P(ARRAY(ENTRY),U,2) - N RECNUM S RECNUM=$$FIND(PINS) ; find the PINS record - I 'RECNUM D - . S RECNUM=$$NEW ; if not found, assign a new one and set it up - E S RETVAL=$$STORE(RECNUM,PINS,INSIEN) - Q -FIND(PINS) ; given DA(1),DA - does it exist? - ; return record number, or false if not found - N RET,STOP,FN S (RET,STOP)=0,FN=$$FN - S DA(2)=DA(1),DA(1)=DA - N RECNUM F RECNUM=1:1:NINS D Q:STOP - . N ERR - . S DA=RECNUM - . I $$GET^DDSVAL(FN,.DA,.04)=PINS S (RET,STOP)=DA ; found - S DA=DA(1),DA(1)=DA(2) K DA(2) ; restore state of DA - Q RET -NEW() ; given DA(1),DA,PINS,INSIEN - init a new record - N RECNUM S RECNUM=$$FIND("") ; first one with a null PINS - N RETVAL - I RECNUM="" Q 0 ; none available - S RETVAL=$$STORE(RECNUM,PINS,INSIEN) - Q RECNUM -STORE(RECNUM,PINS,INSURER) ; - S DA(2)=DA(1),DA(1)=DA,DA=RECNUM ; set up DA for this level - N FN S FN=$$FN - D PUT^DDSVAL(FN,.DA,.02,$G(ORDER(PINS))) ; - D PUT^DDSVAL(FN,.DA,.03,INSURER,,"I") - D PUT^DDSVAL(FN,.DA,.04,PINS) - S DA=DA(1),DA(1)=DA(2) K DA(2) ; restore state of DA - Q RECNUM -ERASEALL ;EP - from BPSOSI1 - ;erase all data in the "I" multiple - ; given DA(1)=entry number in 9002313.51 - ; DA = line number in LINE ITEMS multiple - ; Refer to the global only for figuring how many of these there are - ; This is needed because if someone DELETEs a prescription line, - ; we have to erase all the data associated with that line. This is - ; called from BPSOSI1, where the DELETE is handled. - I $O(DA(1)) D IMPOSS^BPSOSUE("P","TI","At wrong data level in form",,"ERASEALL",$T(+0)) Q ; make sure you're really at this level DA(1) not DA(2) - S DA(2)=DA(1),DA(1)=DA,DA=0 - N FN S FN=$$FN - F S DA=$O(^BPS(9002313.51,DA(2),2,DA(1),"I",DA)) Q:'DA D - . Q:'$$GET^DDSVAL(FN,.DA,.03) ; no insurer on this line - . N F F F=.02,.03,.04,1.01 D - . . D PUT^DDSVAL(FN,.DA,F,"",,"I") - S DA=DA(1),DA(1)=DA(2) K DA(2) ; restore the DA array - Q -POST02 ; POST ACTION ON CHANGE for ORDER, field .02 - ; DA=which insurer line DA(1)=which prescription line DA(2)=IEN - ; X=new internal value, DDSOLD = previous internal value - ; This has side effects: - ; Example: assign order #2 to some item - N THISDA S THISDA=DA - F DA=1:1 Q:'$D(^BPS(9002313.51,DA(2),2,DA(1),"I",DA)) D - . Q:DA=THISDA ; but skip the one you're changing right now - . ; For each field, get its current order - . N THISORD S THISORD=$$GET^DDSVAL(DIE,.DA,.02,,"I") - . ; - . ; DDSOLD="" example: pick one unassigned and make it #2 - . ; then #3 disappears and old #2 becomes #3 - . I DDSOLD="" D - . . I THISORD="" ;do nothing, it remains blank - . . E I THISORD=3 D - . . . D PUT^DDSVAL(DIE,.DA,.02,"",,"I") - . . E I THISORD'DDSOLD example: change 2nd to be 3rd ; X=3,DDSOLD=2 - . E I X>DDSOLD D ; so 3rd moves up to 2nd (1st unaffected) - . . I THISORD="" Q ; unassigned ones unaffected - . . I THISORD>DDSOLD,THISORD'>X D - . . . D PUT^DDSVAL(DIE,.DA,.02,THISORD-1,,"I") - . . . D SET70X(THISORD-1) ; BPS*1.0T7*8 - . ; - . ; X0 - D UNED^DDSUTL(6,3,1,'DOFILLDT) ; field 6, block 3, page 1 - I DOFILLDT S DDSBR=6 ; and branch to that field - Q diff -auBN ./r1/BPSOSI.m ./r2/r/BPSOSI.m --- ./r1/BPSOSI.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSI.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,157 +0,0 @@ -BPSOSI ;BHAM ISC/FCS/DRS/DLF - Data entry w/ScreenMan ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; This calls ScreenMan for an entry in file 9002313.51 -ALL ; This entry point does data entry and submits the claims, both. - ; This is what we'll call from the ListManager menu. - W !,"The NEW option will be available in a future patch." H 2 Q ;LJE - DO FULL^VALM1 ; List manager had set scroll regions - I $$OLDSTYLE G ^BPSOSIV -ALL1 ;EP - BPSOSIV branches back here if user decides he wants Screenman - N INPUTIEN S INPUTIEN=$$NEW - ;D TERM^VALM0 ; sets terminal characteristics ; not in LM docum'n - I INPUTIEN D - . D FULL^VALM1 ; full screen - we might do I/O - . D FILE^BPSOSIZ(INPUTIEN) ; send them to ECME or to paper - . N NODISPLY S NODISPLY=1 D UPD^BPSOS6A ; so your new claims show up - . N % W ! R %:1 - E D - . W "Because of Q,",! - . W "These charges and claims are NOT filed and processed.",! - . W ! R %:3 - W ! - S VALMBCK="R" ; tell List Manager to Refresh - Q - ; - ; Usually, for a new input session, $$NEW^BPSOSI - ; It returns the IEN of the session - ; - ; D ^BPSOSI -> TEST^BPSOSI for testing and development - ; - ; If you need to edit an existing session, $$MYSCREEN^BPSOSI(IEN) - ; That's probably not going to be used, but it's here if you need it. - ; - Q -NEW() ;EP - from BPSOSI - Q $$MYSCREEN(-1) - Q -MYSCREEN(DA) ; returns IEN of input if E (or the equivalent) was used - ; if the user quits out (Q or the equivalent), returns 0^IEN - N DDSFILE,DR,DDSPAGE,DDSPARM - N DDSCHANG,DDSSAVE,DIMSG,DTOUT,RETVAL - S DDSFILE=9002313.51 ; PEC/MIS INPUT file - S DR="[BPS INPUT 1]" - I DA'>0 D - . S DA=$$NEWREC(,,2) - . S RETVAL=$$INIT(DA) - S DDSPARM="CS" - D ^DDS - I $G(DDSSAVE) Q DA - E Q 0_U_DA -TEST ; - W "NEW^BPSOSI returns ",$$NEW^BPSOSI - W "Outputs:",! - D ZWRITE^BPSOS("DDSCHANG","DDSSAVE","DIMSG","DTOUT") - D GL - Q DA -ISEMPTY(DA) ; true if PRESCRIPTIONS multiple count >0, false if not - Q $P($G(^BPS(9002313.51,DA,2,0)),U,4)>0 -FN() Q 9002313.51 -FNPRESC() Q 9002313.512 -FNINS() Q 9002313.522 -NEWREC(NMULT,NINS,ORIGIN) ;EP - from BPSOSIV - a new PEC/MIS INPUT record - ; NMULT = how many multiples to initialize (opt, defaults to 9) - ; NINS = how many insurance lines to init for each one (opt, def to 5) - ; ORIGIN = pointer to 9002313.516 - N FDA,IEN,MSG,FN,NEW S FN=$$FN,NEW="+999999," - N FNPRESC,FNINS S FNPRESC=$$FNPRESC,FNINS=$$FNINS - S FDA(FN,NEW,.01)="NOW" - S FDA(FN,NEW,.03)=$P(^BPS(9002313.516,ORIGIN,0),U) - N I F I=1000:1000:1000*$S($D(NMULT):NMULT,1:9) D - . N X S X="+"_I_","_NEW - . S FDA(FNPRESC,X,.01)=I/1000 - . N J F J=1:1:$S($D(NINS):NINS,1:5) D - . . S FDA(FNINS,"+"_(I+J)_","_X,.01)=J - . . ; ex: +3002,+3000,+999999, for 2nd ins in 3rd presc - N STOP F D Q:STOP - . D UPDATE^DIE("E","FDA","IEN","MSG") - . I '$D(MSG),$G(IEN(999999)) S STOP=1 Q - . D ZWRITE^BPSOS("MSG","IEN") - . S STOP='$$IMPOSS^BPSOSUE("FM","TRI","UPDATE^DIE failed",,"NEWREC",$T(+0)) - Q IEN(999999) -INIT(IEN) ;EP - from BPSOSIV - initialize record IEN - N FDA,MSG,FN S FN=$$FN,IEN=IEN_"," - S FDA(FN,IEN,.02)=DUZ ; USER - D - . N ARR,I,Y - . D GET515(DUZ,.ARR) ; get this user's settings, apply defaults - . S Y=$G(ARR(1)) ; we're interested in the ASK ones in the 1 subscript - . F I=1:1:4 I $P(Y,U,I)="" S $P(Y,U,I)=0 ; defaults for default - . F I=1:1:4 S FDA(FN,IEN,I/100+1)=$P(Y,U,I) ; ASK INS, etc. - . S Y=$G(ARR(100)) ; and in the 100 subscript, - . ; piece 1 - should we default the NDC # - the default default is YES - . ; defaults for the default - . F I=1:1:1 I $P(Y,U,I)="" S $P(Y,U,I)=$S(I=1:1,1:0) - . F I=1:1:1 S FDA(FN,IEN,I/100+100)=$P(Y,U,I) - N STOP F D Q:STOP - . D FILE^DIE("","FDA","MSG") - . I '$D(MSG) S STOP=1 Q - . D ZWRITE^BPSOS("MSG") - . S STOP='$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"INIT",$T(+0)) - Q '$D(MSG) ;='0=1 if success, ='nonzero=0 if failure -DELALL ; delete all records ; good for testing - N FN S FN=$$FN I FN'=9002313.51 D Q ; must be that file - . D IMPOSS^BPSOSUE("P","TI",,,"DELALL",$T(+0)) - W !,"Deleting all records from file ",FN - N IEN F S IEN=$O(^BPS(FN,0)) Q:'IEN Q:'$$DELETE(IEN) W "." - W ! D GL - Q -GL ; quickie global list good for testing - N FN S FN=$$FN - N X M X=^BPS(FN) - D ZWRITE^BPSOS("X") - Q -DELETE(IEN) ; delete record IEN - N FDA,MSG,FN S FN=$$FN,IEN=IEN_"," - S FDA(FN,IEN,.01)="@" - D FILE^DIE("E","FDA","MSG") - I $D(MSG) D ZWRITE^BPSOS("MSG") - I $D(MSG) Q 0 - Q 1 -GENINSTR ; general instructions, in the FORM-level pre-action for Block 2C - N AR - S AR(1)="Use E to SUBMIT the claims" - S AR(1)=AR(1)_", Q to QUIT and cancel" - ;S AR(2)="Use Q to QUIT without submitting claims." - ;S AR(3)="Use ?? to get extra help on a question." - D HLP^DDSUTL(.AR) - Q -OLDSTYLE() ; return true if DUZ wants old style input - ; if this user has a specific setting, go with it - N X D GET515(DUZ,.X) - Q $P($G(X(0)),U,3) -GET515(USER,DEST) ;EP - from BPSOSIV ; call as GET515(USER,.DESTINATION) - ; where .DESTINATION is undefined coming in. - ; set DEST(*) = copy of the .515 in effect, - ; with defaults overlaid as needed - I $D(DEST) D Q - . D IMPOSS^BPSOSUE("P","TI",,,"GET515",$T(+0)) - D GET515A(USER,.DEST) - I $P($G(DEST(0)),U,2) D ; if this user inherits from another, - . N ARR - . D GET515A(USER,.ARR) ; then get that user's settings - . D GET515B(.DEST,.ARR) ; fill in any that need defaults - D - . N ARR - . D GET515A(1,.ARR) ; likewise, inherit from user #1 - . D GET515B(.DEST,.ARR) - Q -GET515A(USER,DEST) ; grab copy of the record for this user - N IEN S IEN=$O(^BPS(9002313.515,"B",USER,0)) Q:'IEN - M DEST=^BPS(9002313.515,IEN) ; DEST(0), DEST(1), etc. are set now - Q -GET515B(A,B) ; fill in defaults in A as needed, from B - N X,Y,I,S S S="" - F S S=$O(B(S)) Q:S="" D - . S X=B(S) F I=1:1:$L(X,U) S Y=$P(X,U,I) I Y]"" D - . . I $P($G(A(S)),U,I)="" S $P(A(S),U,I)=Y ; not def, so fill default - Q diff -auBN ./r1/BPSOSIO.m ./r2/r/BPSOSIO.m --- ./r1/BPSOSIO.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSIO.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,69 +0,0 @@ -BPSOSIO ;BHAM ISC/FCS/DRS/DLF - NCPDP Overrides form ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; Property of Indian Health Service - ; - ; IHS/OKCAO/ECME IHS/ASDST/lwj 1/9/02 added logic for overrides - ; For the "new" claim option, the adding and updating of - ; override codes was not functioning properly - Patrick wrote - ; code to first look up existing overrides for the prescription - ; and/or add new overrides when requested. - ; The original call from BPSOSIB (at tag THEASKS) was altered - ; to call into NEWENTR2 instead of to NEWENTRY. - Q -NEWENTRY ;EP - create new entry if needed - I '$$GET^DDSVAL(DIE,.DA,1.09) D - .;W "Creating a new entry for Overrides",! R ">> ",%,! - .D PUT^DDSVAL(DIE,.DA,1.09,$$NEW^BPSOSO2,,"I") - ;W "Field 1.09 = ",$$GET^DDSVAL(DIE,.DA,1.09,,"I"),! - ;N % R ">>",%,! - Q -NEWENTR1() ;EP ;from a function call IHS/OKCAO/ECME 1/9/02 overrides - ; No routines are calling into this point at this time. - ; - ; -NEWENTR2 ;EP - IHS/OKCAO/ECME IHS/ASDST/lwj 1/9/02 updating of overrides - ; The original logic for the maintaining of the override codes - ; in the "new" claim feature was not correct - this routine - ; will replace that logic. - ; - ; Called from BPSOSIB - ; If there isn't an RX - routine will simply quit - ; If there is a RX, and it already has overrides, the overrides - ; will be retrieved for updating - ; If there is a RX, and it doesn't have overrides, a new override - ; will be created to store with the transaction - ; - N RXI,RXR,OVERRIDE,FFDA,STRING - ; - ; get the prescription information - S RXI=$$GET^DDSVAL(DIE,.DA,1.01) ;RX IEN - S RXR=$$GET^DDSVAL(DIE,.DA,1.02) ;RX Refill IEN - I 'RXI D NEWENTRY Q OVERRIDE - ; - ; figure out if prescription already has override information - S OVERRIDE=$$GETIEN^BPSOSO(RXI,RXR) ;get override number - ; - ; if overrides exist - put on screen for updating - I $G(OVERRIDE) D ;override exists - . S STRING(1)="Will add override from IEN RX "_RXI ;msg on scrn - . S:+RXR STRING(1)=STRING(1)_" IEN Refill "_RXR - . D HLP^DDSUTL(.STRING) ;displays what is happening - ; - ; if override doesn't exist - create new code for use in trans file - I '$G(OVERRIDE) D - . S OVERRIDE=$$NEW^BPSOSO2 ;get new code - . S STRING(1)="Will add new Override "_OVERRIDE - . D HLP^DDSUTL(.STRING) - . ; - . I '+$G(RXR) D ;if not a refill - .. S FFDA(52,RXI_",",9999999.12)=OVERRIDE - .. D FILE^DIE("","FFDA","") - . ; - . I +$G(RXR) D ;refill - .. S FFDA(52.1,RXR_","_RXI_",",9999999.12)=OVERRIDE - .. D FILE^DIE("","FFDA","") - ; - ; now- update the input data file with the override code - D PUT^DDSVAL(DIE,.DA,1.09,OVERRIDE,,"I") - ; - Q OVERRIDE diff -auBN ./r1/BPSOSIP.m ./r2/r/BPSOSIP.m --- ./r1/BPSOSIP.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSIP.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,12 +0,0 @@ -BPSOSIP ;BHAM ISC/FCS/DRS/DLF - BPS INPUT POSTAGE block ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -PRE ; PRE action for the page - ;D MSGWAIT^BPSOSI1("DIE="_DIE_", DA="_$G(DA)_", DA(1)="_$G(DA(1))) - Q -POST ;D MSGWAIT^BPSOSI1("This is the POST action for the postage page.") - ; Set the NDC field to POSTAGE $amount - ; "POSTAGE" is case-sensitive; checked in other places - N AMT S AMT=$$GET^DDSVAL(DIE,.DA,5.02) - D PUT^DDSVAL(DIE,.DA,.03,"POSTAGE $"_$J(AMT,0,2)) - Q diff -auBN ./r1/BPSOSIW.m ./r2/r/BPSOSIW.m --- ./r1/BPSOSIW.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSIW.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,64 +0,0 @@ -BPSOSIW ;BHAM ISC/FCS/DRS/DLF - Old-style input ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; overflow from BPSOSIV -BACKLOG() ;EP - from BPSOSIV - ; a rough guess on how many seconds of backlog there are - N STATS,LOCK,TALLY S LOCK=1,TALLY=0 - D FETSTAT^BPSOS2("STATS(1)") - N A S A="" F S A=$O(STATS(1,A)) Q:'A D - . S TALLY=STATS(1,A)*7 ; 7 seconds of packet preparation & overhead - D FETPKTQ^BPSOS2("STATS(2)") - N CLAIMS S CLAIMS=$G(STATS(2,"C")) ; figure about 12 secs each - N RESPS S RESPS=$G(STATS(2,"R")) ; figure about 3 secs each - S TALLY=CLAIMS*12+(RESPS*3)+TALLY ; - S TALLY=CLAIMS*20+TALLY ; and 20 secs dialing for each one (EOT prob) - ;I CLAIMS S TALLY=TALLY+20 ; normally, just 20 secs once - I 0,+$H=58107,$P($H,",",2)<(7*3600) D Q 300 - . W "Computed value from $$BACKLOG=",TALLY," but change it for testing.",! - Q TALLY -GETNDC() ;EP - from BPSOSIV - ;Prompt - get NDC # - ; Returns the NDC # with the "-" - ; Even if pure numeric input, figure it out and put in the "-" - ; "^" OR "^^" or "" if the user inputs one of those - ; 0 if automatic answer input was a bad number - ; - ; Don't default it - they want the real, true number to always be - ; scanned in from the bottle, every time. - ; - N X,NDCDEF -NDC0 I DEFNDCNO S NDCDEF=$$DEFNDC^BPSOSIV ; relies on ABSBRXI, ABSBRXR - E S NDCDEF="" - S X=$$FREETEXT^BPSOSU2("NDC#: ",NDCDEF,1,1,15,$G(DTIME)) - ; - ; "the Abbot Labs bar codes are really funky" - I X?1"++3"10.11N2E D - . S X=$E(X,4,$L(X)-2) ; strip off the surrounding junk - . ; fine if it's 11N - . ; if it's 10N, what? leave it to the mercy of the $$NDC10^BPSOS9? - I "^^"[X Q X ;I X="^^" Q X ;Q:X=-1 "^" Q:X="" X - ; If it's entirely numeric input, figure out where the "-" go. - I X?9N D - . S X=$E(X,1,3)_"-"_$E(X,4,7)_"-"_$E(X,8,9) ;LJE;VA 9 Digit ndc's - I X?10N D - .N Y S Y=$$NDC10^BPSOS9(X) - .I Y="" W !,"We couldn't figure out ",X,! - .E W " ",Y S X=Y - I X?11N D - .S X=$E(X,1,5)_"-"_$E(X,6,9)_"-"_$E(X,10,11) - I X?12N D ; got to ask Carlene about this - .W !,"12 digit NDC number? We will proceed anyhow, but it's going",! - .W "to be truncated" - .S X=$E(X,1,6)_"-"_$E(X,7,10)_"-"_$E(X,11,12) ; put in 6-4-2 format - .W ! - I X?3N1"-"4N1"-"2N G NDC1 ;LJE;VA - I X?4N1"-"4N1"-"2N G NDC1 - I X?5N1"-"3N1"-"2N G NDC1 - I X?5N1"-"4N1"-"1N G NDC1 - I X?5N1"-"4N1"-"2N G NDC1 - I X?6N1"-"4N1"-"2N G NDC1 - W:'$G(SILENT) !,"Bad NDC #",! G NDC0 -NDC1 ;S $P(^PSRX(ABSBRXI,2),U,7)=X ; store input NDC # in PRESCRIPTION file - ; Don't store it yet - just get input now - let background job store it - W " ",$$NAME^BPSOS9(X) - Q X ; JUST RETURN WHAT WAS INPUT!!! diff -auBN ./r1/BPSOSIY.m ./r2/r/BPSOSIY.m --- ./r1/BPSOSIY.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSIY.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,178 +0,0 @@ -BPSOSIY ;BHAM ISC/FCS/DRS/DLF - Filing with .51,.59 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -IEN59() ;EP - given INPUT(), what should we use for an IEN in file 9002313.59? - N RXI,RET - S RXI=$P(INPUT(1),U) - I RXI D - . S RXR=$P(INPUT(1),U,2) - . I RXR>9000 D - . . D IMPOSS^BPSOSUE("DB","TI","Refill number near overflow point","RXI="_RXI,"IEN59",$T(+0)) - . ; you can raise the limit and be thinking of how to get around it - . S RET=RXI_"."_$TR($J(RXR,4)," ","0") - . S RET=RET_$S($P(INPUT(0),U,3)?1"POSTAGE".E:2,1:1) - E D - . N VIS,CPT S VIS=$P(INPUT(1),U,6),CPT=$P(INPUT(1),U,8) - . I 'VIS D ; visit IEN, must not be zero - . . D IMPOSS^BPSOSUE("P","TI","Visit IEN missing; should have been detected by now",,"IEN59",$T(+0)) - . . S VIS="MISSING" - . I 'CPT D ; CPT IEN, must not be zero - . . D IMPOSS^BPSOSUE("P","TI","CPT IEN missing; should have been detected by now",,"IEN59",$T(+0)) - . . S CPT="MISSING" - . S RET=VIS_"."_$TR($J(CPT,6)," ","0")_3 - Q RET -SETUP59(N,ORIGIN) ;EP - from BPSOSIZ - given the INPUT array - ; You don't have to set null fields, so long as you have called - ; CLEAR, or if this is a NEW entry. - N FLAGS,FDA,MSG,FN,REC,X,I S FN=9002313.59,REC=N_"," - N TYPE S TYPE=$E(N,$L(N)) - S FDA(FN,REC,.13)=TYPE - I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) S VARX=1 - ; TYPE = 1 for prescription, = 2 for mailing prescription, - ; = 3 for non-prescription items - ; FDA(FN,REC,.01) = $P(INPUT(0),U,1) already stored in = field .01 - S FDA(FN,REC,.14)=ORIGIN - S FDA(FN,REC,1)=0 ; STATUS - waiting to start - ; Field 1.06 - copied from field 701, below - S FDA(FN,REC,1.08)=1 ; PINS piece - I TYPE=1!(TYPE=2) S FDA(FN,REC,1.11)=$P(INPUT(1),U) ; RXI - ; - ;IHS/SD/lwj 8/30/02 NCPDP 5.1 changes - ; the prior authorization code is now two fields - type and number - ; begin changes to capture both values - ; - I $D(INPUT(2)),$P(INPUT(2),U,2)]"" D - . S FDA(FN,REC,1.09)=$P(INPUT(2),U) ; prior authorization number - . S FDA(FN,REC,1.15)=$P(INPUT(2),U,2) ; prior auth type code - ; - ;IHS/SD/lwj 8/30/02 end NCPDP 5.1 prior authorization changes - ; - S FDA(FN,REC,5)=$P(INPUT(1),U,4) ; Patient - S FDA(FN,REC,7)=$$NOW ; LAST UPDATE - S FDA(FN,REC,9)=$P(INPUT(1),U,2) ; RXR - refill index - I TYPE=1 S FDA(FN,REC,10)=$P(INPUT(0),U,3) ; NDC - I TYPE=1&(VARX) S FDA(FN,REC,10)=$P($G(INPUT(9)),"^",8) ;LJE - I TYPE=1!(TYPE=2) S FDA(FN,REC,12)=$P(INPUT(1),U,6) ; Visit - S FDA(FN,REC,13)=DUZ ; USER - S FDA(FN,REC,15)=FDA(FN,REC,7) ; START TIME - F I=1:1:6 S X=$P($G(INPUT(5)),U,I) I X]"" S FDA(FN,REC,500+I)=X - I $G(INPUT(6))]""!($G(INPUT(7))]"") D - . F I=1:1:3 D - . . I $P(INPUT(6),U,I)]"" S FDA(FN,REC,600+I)=$P($G(INPUT(6)),U,I) - . . I $P(INPUT(7),U,I)]"" S FDA(FN,REC,700+I)=$P($G(INPUT(7)),U,I) - I $D(FDA(FN,REC,701)) D - . S FDA(FN,REC,1.06)=FDA(FN,REC,701) ; INSURER - ; 500's, 600's, 700's done above - ; - ;LJE;6/26/03; Set initial insurance to work with - I $D(INPUT(8)) D - . ;S FDA(FN,REC,901)=$P($G(INPUT(8)),"^",1) - . S FDA(FN,REC,901)=1 ;first insurance ien - . S FDA(FN,REC,504)=$P($G(INPUT(9)),"^",1) ;DISPENSE FEE - . S FDA(FN,REC,505)=$P($G(INPUT(9)),"^",3) ;GROSS AMOUNT DUE/USUAL & CUSTOMARY - . S FDA(FN,REC,507)=$P($G(INPUT(9)),"^",5) ;ADMINISTRATIVE FEE - . S FDA(FN,REC,501)=$P($G(INPUT(9)),"^",6) ;Drug QUANTITY - . S FDA(FN,REC,502)=$P($G(INPUT(9)),"^",7) ;INGREDIENT COST - . S FDA(FN,REC,10)=$P($G(INPUT(9)),"^",8) ;NDC - last NDC billed for this drug - I FDA(FN,REC,10)'["-" S FDA(FN,REC,10)=$E(FDA(FN,REC,10),1,5)_"-"_$E(FDA(FN,REC,10),6,9)_"-"_$E(FDA(FN,REC,10),10,11) - ; - D FILE^DIE("","FDA","MSG") ; NO "E" FLAG - DATA IS IN INTERNAL FORMAT! - ; - ;LJE;6/24/03;Added VA sets to .59 file; continuing sets throughout process in order to - ; ; not lose any data should an error occur. - ; - S VA59IEN="+1," - S ISTHERE="",ISTHERE=$$GET1^DIQ(9002313.59902,"1,"_REC_",","902.02","MSG") - I ISTHERE'=""&('$D(MSG)) S VA59IEN="1," - S FN=9002313.59902 - I $D(INPUT(8)) D - . S FDA(FN,VA59IEN_REC,.01)=$P($G(INPUT(8)),"^",1) ;PLAN ID - . S FDA(FN,VA59IEN_REC,902.03)=$P($G(INPUT(8)),"^",2) ;BIN - . S FDA(FN,VA59IEN_REC,902.04)=$P($G(INPUT(8)),"^",3) ;PCN - . S FDA(FN,VA59IEN_REC,902.02)=$P($G(INPUT(8)),"^",4) ;PAYER SHEET IEN - . S FDA(FN,VA59IEN_REC,902.05)=$P($G(INPUT(8)),"^",5) ;GROUP ID - . S FDA(FN,VA59IEN_REC,902.06)=$P($G(INPUT(8)),"^",6) ;CARDHOLDER ID - . S FDA(FN,VA59IEN_REC,902.07)=$P($G(INPUT(8)),"^",7) ;PATIENT RELATIONSHIP CODE - . S FDA(FN,VA59IEN_REC,902.08)=$P($G(INPUT(8)),"^",8) ;CARDHOLDER FIRST NAME - . I FDA(FN,VA59IEN_REC,902.08)[" " S FDA(FN,"+1,"_REC,902.08)=$P(FDA(FN,"+1,"_REC,902.08)," ",1) - . S FDA(FN,VA59IEN_REC,902.09)=$P($G(INPUT(8)),"^",9) ;CARDHOLDER LAST NAME - . S FDA(FN,VA59IEN_REC,902.11)=$P($G(INPUT(8)),"^",10) ;HOME PLAN STATE - . S FDA(FN,VA59IEN_REC,902.18)=$P($G(INPUT(8)),"^",13) ;Software/Vendor Cert ID - . S FDA(FN,VA59IEN_REC,902.19)=$P($G(INPUT(8)),"^",11) ;B2 PAYER SHEET REVERSAL - . S FDA(FN,VA59IEN_REC,902.21)=$P($G(INPUT(8)),"^",12) ;B3 PAYER SHEET REBILL - . S FDA(FN,VA59IEN_REC,902.22)=$P($G(INPUT(8)),"^",14) ;CERTIFY MODE - . S FDA(FN,VA59IEN_REC,902.23)=$P($G(INPUT(8)),"^",13) ;CERTIFICATION IEN TO USE FROM 9002313.31 - . S FDA(FN,VA59IEN_REC,902.12)=$P($G(INPUT(9)),"^",1) ;DISPENSE FEE - . S FDA(FN,VA59IEN_REC,902.13)=$P($G(INPUT(9)),"^",2) ;BASIS OF COST DETERMINATION - . S FDA(FN,VA59IEN_REC,902.14)=$P($G(INPUT(9)),"^",3) ;USUAL & CUSTOMARY CHARGE - . S FDA(FN,VA59IEN_REC,902.15)=$P($G(INPUT(9)),"^",4) ;GROSS AMOUNT DUE - . S FDA(FN,VA59IEN_REC,902.16)=$P($G(INPUT(9)),"^",5) ;ADMINISTRATIVE FEE - . S FDA(FN,VA59IEN_REC,902.17)=$P($G(INPUT(9)),"^",9) ;FILL NUMBER - .; S FDA(FN,"+1,"_REC,902.18)=$P($G(INPUT(9)),"^",10) ;SOFTWARE VENDOR/CERT ID - ; - I VA59IEN'["+" D FILE^DIE("E","FDA","MSG") - E D UPDATE^DIE("E","FDA","VAIEN","MSG") - S FN=9002313.59 ; SET IT BACK TO ORIGINAL, JUST IN CASE - K ISTHERE,VA59IEN - Q $S($D(MSG):0,1:1) -ACTIVEWT(IEN59,IEN51,IEN512) ;EP - from BPSOSIZ - ; Return 0 = forget about it, don't wait, just skip this one - ; 1 = yes, wait and check again in several seconds from now - ; - N PROMPT - ; An opportunity to wait for the active prescription to finish - ; processing. Return 1 if you do want to wait; 0 if you do not. - I '$G(ECHO) Q 1 ; not interactive, you can't ask - assume YES, wait - W ?5,"There is currently an active transaction for this item" - ;The new IEN59 should decisively say if it's the same date. - ;N X,Y S X=$P(^BPST(IEN59,1),U) - ;S Y=$P(^BPS(9002313.51,IEN51,2,IEN512,0),U,8) - ;I X'=Y W !?5,"though for a different fill date" - W ".",! - W ?5,"So this item will be skipped.",! H 1 ; 03/22/2001 - Q 0 ; 03/22/2001 -ACWTA S PROMPT="Do you want to wait for the active transaction to finish" - S Y=$$YESNO^BPSOSU3(PROMPT,"YES",1) W ! - I Y=1 Q 1 - S PROMPT="Do you want to forget about this one" - S Y=$$YESNO^BPSOSU3(PROMPT,"NO",1) W ! - I Y=1 Q 0 - G ACWTA -RXPREV(IEN,ENTRY) ; has this item previously been through ECME? - ; return false if not - ; return pointer to 9002313.57 if true - N RXI,RXR,VIS,CPT,INDEX,A,B - S RXI=$$RXI(IEN,ENTRY) - I RXI D - . S RXR=$$RXR(IEN,ENTRY) - . S INDEX=$S($$NDC(IEN,ENTRY)?1"POSTAGE".E:"POSTAGE",1:"RXIRXR") - . S A=RXI,B=RXR - E D - . S VIS=$$VIS(IEN,ENTRY) - . S CPT=$$CPTIEN(IEN,ENTRY) - . S A=VIS,B=CPT,INDEX="OTHERS" - Q $O(^BPSTL("NON-FILEMAN",INDEX,A,B,""),-1) -RXPAID(IEN,ENTRY) ;EP - from BPSOSIZ - ; return true if the prescription and fill has a "paid" - ; status as far as ECME is concerned - ; A paper claim counts as a ECME "paid" for this purpose - ; Return 1 = POS, paid - ; Return 2 = paper - N N57 S N57=$$RXPREV(IEN,ENTRY) - I 'N57 Q "" ; no ECME record of this - ; If it's a reversal, then our result depends on the reversal: - ; Was the reversal accepted? If so, then No, not paid. - ; Was the reversal rejected? Assume Paid, since we try to - ; allow reversals only in the case of a paid original. - I $$ISREVERS^BPSOS57(N57) Q $S($$REVACC^BPSOS57(N57):0,1:1) - ; Not a reversal: - N X S X=$$CATEG^BPSOSUC(N57) - Q $S(X="E PAYABLE":1,X="PAPER":2,X="E DUPLICATE":3,1:0) -RXI(IEN,ENTRY) Q $P(^BPS(9002313.51,IEN,2,ENTRY,1),U) -RXR(IEN,ENTRY) Q $P(^BPS(9002313.51,IEN,2,ENTRY,1),U,2) -VIS(IEN,ENTRY) Q $P(^BPS(9002313.51,IEN,2,ENTRY,1),U,6) -NDC(IEN,ENTRY) Q $P(^BPS(9002313.51,IEN,2,ENTRY,0),U,3) -CPTIEN(IEN,ENTRY) Q $P(^BPS(9002313.51,IEN,2,ENTRY,1),U,8) -WANTREV() ;EP - from BPSOSIZ - Q 0 ; TO BE IMPLEMENTED -NOW() N %,%H,%I,X D NOW^%DTC Q % diff -auBN ./r1/BPSOSIZ.m ./r2/r/BPSOSIZ.m --- ./r1/BPSOSIZ.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSIZ.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,218 +0,0 @@ -BPSOSIZ ;BHAM ISC/FCS/DRS/DLF - Filing with .51,.59 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -LOCK() L +^TMP($J,"BPSOSIZ"):300 Q $T -UNLOCK L -^TMP($J,"BPSOSIZ") Q -LOCK59() L +^BPST:300 Q $T -UNLOCK59 L -^BPST Q -FILE(IEN,ECHO) ;EP - from BPSOSI, BPSOSIV - ; E was hit - so we make these claims official - ; ^BPS(9002313.51,IEN,...) -> 9002313.59 or wherever - I '$D(ECHO) S ECHO=1 - N ENTRY S ENTRY=0 - N BPSOSQ1 S BPSOSQ1=0 ; set to nonzero if you need background job - D DELEMPTY ; delete empty entries from the multiple - I '$P($G(^BPS(9002313.51,IEN,2,0)),U,4) D G FZ - . I ECHO W "Nothing entered..." - I ECHO W "Submitting claims...",! - F S ENTRY=$O(^BPS(9002313.51,IEN,2,ENTRY)) Q:'ENTRY D - . I ECHO D QUICK51(IEN,ENTRY) - . F Q:$$LOCK Q:'$$IMPOSS^BPSOSUE("L","RTI","Single-thread filing through BPSOSIZ",,"FILE",$T(+0)) - . D INSUR(IEN,ENTRY,ECHO) - . D FILE1(IEN,ENTRY,ECHO) - . D UNLOCK - ; start background job if necessary - I BPSOSQ1 D TASK -FZ I ECHO W "...done.",! H 2 - Q -TASK ;EP - from BPSOS2D,BPSOS6D,BPSOSQ1,BPSOSQ4,BPSOSU - N BPSQQQT - S BPSQQQT=0 - D - . N CHECK - . S CHECK=$G(^BPSECP("CHECKTIM")) ;last submittal time - . S:$$FMDIFF^XLFDT($$NOW^XLFDT,CHECK,2)'>2 BPSQQQT=1 - Q:BPSQQQT - S ^BPSECP("CHECKTIM")=$$NOW^XLFDT - ; - ;IHS/SD/lwj 11/03/02 end changes - ; - N X,Y,%DT - S X="N",%DT="ST" D ^%DT - D TASKAT(Y) - Q -TASKAT(ZTDTH) ;EP - from above and from BPSOSQS - N ZTRTN,ZTIO - S ZTRTN="LOOP^BPSOSQ1",ZTIO="" - D ^%ZTLOAD - Q - ; KScratch ;Kill scratch globals - ;K ^BPSECX($J,"R") -DELEMPTY ; the multiple probably has some empty entries - delete them - ; IEN is inherited from caller - N FDA,MSG,FN,ENTRY S FN=9002313.512,ENTRY=0 - F S ENTRY=$O(^BPS(9002313.51,IEN,2,ENTRY)) Q:'ENTRY D - . N X,Y S X=^BPS(9002313.51,IEN,2,ENTRY,0),Y=$G(^(1)) - . I X?1N.N."^",Y?."^" D ; see Note 1, below - . . S FDA(FN,ENTRY_","_IEN_",",.01)="" - Q:'$D(FDA) ; nothing to delete -D5 D FILE^DIE("","FDA","MSG") - Q:'$D(MSG) ; success - D ZWRITE^BPSOS("FDA","MSG") - G D5:$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"DELEMPTY",$T(+0)) - Q - ; Note 1. In DELEMPTY, the test for an empty node: - ; piece 1 is the entry number, uneditable, ?1N.N - ; pieces 2ff may be present but null - apparently, just visiting - ; a field (e.g., pressing down arrow from NDC number) - ; And also need to test for no fields in the ^(1) node ; 09/21/2000 - ; could lead to filling in some empty values) -INSUR(IEN,ENTRY,ECHO) ; ^BPS(9002313.51,IEN,2,ENTRY,"I",*) - ; need to move it into ^BPS(9002313.51,IEN,2,ENTRY,6)=PINS data - ; and ^BPS(9002313.51,IEN,2,ENTRY,7)=insurer IENs - N N S N=0 F S N=$O(^BPS(9002313.51,IEN,2,ENTRY,"I",N)) Q:'N D - . N X S X=^BPS(9002313.51,IEN,2,ENTRY,"I",N,0) - . I $P(X,U,2) D ; ORDER is given - . . N ORDER S ORDER=$P(X,U,2) - . . S $P(^BPS(9002313.51,IEN,2,ENTRY,6),U,ORDER)=$P(X,U,4) ; PINS - . . S $P(^BPS(9002313.51,IEN,2,ENTRY,7),U,ORDER)=$P(X,U,3) ;ins ien - ; Delete the entire INS SEL SCRATCH field - it's no longer needed - K ^BPS(9002313.51,IEN,2,ENTRY,"I") - ; the following fails because the field is a multiple - ;N FDA,MSG,FN - ;S FDA(9002313.512,ENTRY_","_IEN_",",100)="" - ;D FILE^DIE("","FDA","MSG") - ;I $D(MSG) W "at INSUR^",$T(+0),! ZW MSG IMPOSS^BPSOSUE call, too - Q -FILE1(IEN,ENTRY,ECHO) ; ^BPS(9002313.51,IEN,2,ENTRY,...) - N INPUT M INPUT=^BPS(9002313.51,IEN,2,ENTRY) ; convenience - N ORIGIN S ORIGIN=$P(^BPS(9002313.51,IEN,0),U,3) - N X S X=$P(INPUT(0),U,2) - ;I $D(MOREDATA("IBDATA",1,1)) M INPUT(8)=MOREDATA("IBDATA",1,1),INPUT(9)=MOREDATA("IBDATA",1,2) - ; X can be any of the following: - ; `# # points to ^PSRX(#, - ; (still have to work out the visit file details) - D REMAP - D FILERX - Q -REMAP ; do any needed adjusing of INPUT(*) to handle postage, supplies, etc. - Q -ISRX() ; return pointer to ^PSRX if true, else return "" - N X S X=$P(INPUT(1),U) I 'X Q "" - I $P(INPUT(0),U,3)?1"POSTAGE".E Q "" - Q X -ISPOST() ; return pointer to ^PSRX if true, else return "" - N X S X=$P(INPUT(1),U) I 'X Q "" - I $P(INPUT(0),U,3)?1"POSTAGE".E Q X - Q "" -ISVISIT() ; return pointer to visit if true, else return "" - ; (this is for non-prescription items) - N X S X=$P(INPUT(1),U) I X Q "" ; has ^PSRX pointer, so ret false - Q $P(INPUT(1),U,6) -FILERX ; EVERYTHING is filed here: postage, supplies, as well as RX's - ; - ; If it's being actively processed now, do not allow it to be - ; submitted again here. - ; - N DEBUG S DEBUG=0 ;(DUZ=120&(DUZ(2)=1859)) - N IEN59 S IEN59=$$IEN59^BPSOSIY - ;I DEBUG W ?10,"IEN59=",IEN59,! -RXA I $$ACTIVE59(IEN59) Q:'$$ACTIVEWT^BPSOSIY(IEN59,IEN,ENTRY) D G RXA - . D UNLOCK H 30 - . F Q:$$LOCK Q:'$$IMPOSS^BPSOSUE("L","RTI","LOCK transaction record for IEN59="_IEN59,,"RXA",$T(+0)) - N X - ; - ; If it's been deleted... - ; Let it through for now. - ; We're catching deleted ones in BPSOSRB, so anything marked for - ; deletion that reaches here was input manually. - ;S X=$$RXDEL^BPSOS(RXI,RXR) I X D I X=1 Q - ; - ; If it's been submitted in the past, - ; mention that fact and look at what happened to it. - ; case 1: Payable or Duplicate of a paid claim or Paper - ; Invite a reversal - ; - ; NOTE for the indefinite interim: - ; We don't yet have it set up to invite an easy reversal here. - ; We are letting paper claims go through and be resubmitted. - ; - ; case 2: Not paid - ; Allow it to be submitted again here. - ; - S X=$$RXPAID^BPSOSIY(IEN,ENTRY) I X D I X=1!(X=3) Q - . I '$G(ECHO) Q ; not interactive, so just skip it - . W ?5,"This claim has already been submitted.",! - . I X=1!(X=3) D - . . W ?5,"It was an electronic claim and it was " - . . W $S(X=1:"paid",X=3:"captured."),! - . I X=2 D - . . W ?5,"It was flagged to be sent on a paper claim.",! - . . W ?5,"It will be processed again, as if it had been reversed.",! - . I X=1 D - . . W ?5,"You must first reverse the original claim,",! - . . W ?5,"and then resubmit it. RES will do it all for you.",! - . D PRESSANY^BPSOSU5() ; $$WANTREV^BPSOSIY not yet implemented - ; - ; Not active, not submitted in the past - SUBMIT IT NOW - ; Create a .59 entry, fill in the pieces - ; -L59A I '$$LOCK59 G L59A:$$IMPOSS^BPSOSUE("L","RTI","LOCK transaction for IEN59="_IEN59,,"L59A",$T(+0)) - I $$EXIST59(IEN59) D - . D CLEAR59(IEN59) - E D -L59N . I $$NEW59(IEN59)'=IEN59 G L59N:$$IMPOSS^BPSOSUE("FM,DB,P","RTI","init new transaction record for IEN59="_IEN59,,"L59N",$T(+0)) - I $$SETUP59^BPSOSIY(IEN59,ORIGIN) S BPSOSQ1=BPSOSQ1+1 - D UNLOCK59 - Q -EXIST59(N) ; - N X - S X=$$FIND1^DIC(9002313.59,,"QX","`"_N) - Q $S(X>0:X,X=0:0) -NEW59(N) ; send N = desired IEN in file 9002313.59 - N FLAGS,FDA,IEN,MSG,X,FN - S FLAGS="" ; internal values - N X S X="+1," - S FN=9002313.59 - S (IEN(1),FDA(FN,X,.01))=N - D UPDATE^DIE(FLAGS,"FDA","IEN","MSG") - I $D(MSG) Q 0 - Q IEN(1) -CLEAR59(N) ; - ; deletes all values except the value in the .01 field - N FN,X,FLAGS,FDA,MSG,FIELD - S FN=9002313.59,X=N_",",FLAGS="" - S FIELD=.01 ; $O will skip past this field - F S FIELD=$O(^DD(FN,FIELD)) Q:'FIELD D - . ; Erase every field except RESULT TEXT, RESUBMIT AFTER REVERSAL - . I FIELD=202!(FIELD=1.12) D - . . ;S FDA(FN,X,FIELD)=$E("[Previously: "_$$GET1^DIQ(FN,X,FIELD)_"]",1,200) - . E S FDA(FN,X,FIELD)="" ; delete - D FILE^DIE(FLAGS,"FDA","MSG") - D PREVISLY(N) ; for result text field 202 - Q -PREVISLY(IEN59) ;EP ; Bracket result text with [Previously: ], if not null - ; Called by REVERSE^BPSOS6D, too - N X S X=$$GET1^DIQ(9002313.59,IEN59,202) - Q:X="" - S X=$E("[Previously: "_X_"]",1,200) - N FN,FDA,MSG S FDA(9002313.59,IEN59_",",202)=X -PR5 D FILE^DIE("","FDA","MSG") Q:'$D(MSG) - D ZWRITE^BPSOS("FDA","MSG","IEN59","X") - G PR5:$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"PREVISLY",$T(+0)) - Q -ACTIVE59(N) ; is ^BPST(N) active now? - F Q:$$LOCK59 Q:'$$IMPOSS^BPSOSUE("L","RTI","LOCK of transaction for IEN59="_IEN59,,"ACTIVE59",$T(+0)) - N Z S Z=$G(^BPST(N,0)) - D UNLOCK59 - I Z="" Q 0 ; easy - there's no such record - I $P(Z,U,2)=99 Q 0 ; status = complete - I $$TIMEDIFI^BPSOSUD($P(Z,U,8),$$NOW)>604800 Q 0 ; Must have been stranded over a week? Let it through. - Q 1 ; status not complete -NOW() N %,%H,%I,X D NOW^%DTC Q % -QUICK51(IEN,ENTRY) ; ^BPS(9002313.51,IEN,2,ENTRY,...) - N X - S X=^BPS(9002313.51,IEN,2,ENTRY,0) - W $P(X,U,4)," ",$P(X,U,2)," ",$P(X,U,5)," ",$P(X,U,7),! - W ! - Q diff -auBN ./r1/BPSOSJ1.m ./r2/r/BPSOSJ1.m --- ./r1/BPSOSJ1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSJ1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,231 +0,0 @@ -BPSOSJ1 ;BHAM ISC/SD/lwj/DLF - NCPDP 5.1 pre and post init for V1.0 patch 3 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; Pre and Post init routine use in BPS0100.03k - ; - ; Purpose of routine: - ; When the BPS claim file was originally designed, it attempted to - ; keep all the NCPDP 400 range fields on one node - 400. While - ; this was clean, and offered logic to the sequencing, it will no - ; longer work as planned with the NCPDP 5.1 implementation. - ; 42% of all the 3.2 fields that were defined and used in ECME were - ; redefined either in their field name/value, field type (numeric - ; to alpha) or in their length for 5.1. The changes in the field - ; length in the 400 range fields with NCPDP 5.1 suddenly caused - ; the 400 node to exceed the 245 byte limitation of global nodes. - ; To adjust for this limitation, the field 431, and 433-443 needed - ; to be moved from the 400 node to 430 and 440 nodes respectively. - ; - ; Tag SAVE of this program is the first step in that move. The - ; code within this tag will save any values that are currently - ; stored on node 400 for the 431, and 433-443 fields. - ; It will also save field 320, which is stored on node 300. - ; - ; Step 2 is for the Data Dictionary for the BPS Claim file to - ; be restored in the Kids installation, which will redefine - ; the fields at their new location. - ; - ; Finally, the last step will be for this program to be run - ; from tag RESTORE to populate the newly defined fields with - ; their old values. - ; - ; These fields did not have any cross references, and were all - ; free text fields. - ; - ; Fields: - ; 320 Carrier ID - ; 431 Other Payer Amount - ; 433 Patient Paid Amount - ; 434 Date of Injury - ; 435 Claim/Ref ID Number - ; 436 Alt. Product Type - ; 437 Alt. Product Code - ; 438 Incentive Amount Submitted - ; 439 DUR Conflict Code - ; 440 DUR INtervention Code - ; 441 DUR Outcome Code - ; 442 Metric Decimal Quantity - ; 443 Primary Payer Decimal Date - ; - ; ** Special note - field 432 did not have to be move - it had - ; been defined on node 420 some previous time in history. - ; - Q -SAVE ;EP - pre-init for abps0100.p3k - ; This subroutine will save any existing values found in the - ; 431, and 433-443 fields into a save global (^BPSOSXX($J,"BPSOSJ1") - ; This global will be used to hold the values while the data - ; dictionary redefines their storage location, and it will - ; then be used in the RESTORE subroutine of this program during the - ; post-init to restore the values to their new home. - ; - ; ^BPSOSXX($J,"BPSOSJ1",ClmIEN,400,MedIEN,400) - ; ClmIEN - IEN for the individual claims - ; MedIEN - IEN for the medication subfile - ; - ; first thing - see if the conversion has run before - if so, quit - Q:$$CKSETUP() - ; - N CLMIEN,MEDIEN,REC - S (CLMIEN,MEDIEN)=0 - ; - ; First let's loop through and save the values - if values - ; are found, let's then delete them from the 400 node since - ; the DD redefine won't do that. - ; - F S CLMIEN=$O(^BPSC(CLMIEN)) Q:'+CLMIEN D - . D SAV320 - . S MEDIEN=0 - . F S MEDIEN=$O(^BPSC(CLMIEN,400,MEDIEN)) Q:'+MEDIEN D - .. S REC=$G(^BPSC(CLMIEN,400,MEDIEN,400)) - .. Q:REC="" - .. D SAVREC - ; - Q - ; -SAV320 ; Save the 320 field, since node 300 also hit its limits - ; - N OUTREC,FDA,MSG,VALUE - ; - S VALUE=$P($G(^BPSC(CLMIEN,300)),U,20) ;grab 320 - Q:VALUE="" - S OUTREC=VALUE_"^" - ; - S FDA(9002313.02,CLMIEN_",",320)="" - D FILE^DIE("","FDA","MSG") - ; - S ^BPSOSXX("BPSOSJ1",CLMIEN,320)=OUTREC - ; - Q - ; -SAVREC ; Save the record (in a separate routine to keep the looping - ; clean) - ; - N OUTREC,I,FND - S FND=0 ;set to 1 if a value is found - S OUTREC="^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^" ;start at 31 - ; - S OUTREC=OUTREC_$P(REC,U,31)_"^" ;1st just field 431 - I $P(REC,U,31)'="" D DELFLD(431) ;if value - delete it - ; - F I=33:1:43 D ;now get 433- 443 - . S OUTREC=OUTREC_"^"_$P(REC,U,I) ;save it - . I $P(REC,U,I)'="" D DELFLD(400+I) ;delete it - ; - S:FND ^BPSOSXX("BPSOSJ1",CLMIEN,400,MEDIEN,400)=OUTREC - ; - Q - ; - ; -DELFLD(FLDNUM) ; When you delete fields from the DD, it will not delete them - ; from the global. If we're here, it means we found a value in - ; one of the fields - let's delete it now, so that it's not - ; dangling after the DD redefinition. - ; - N FDA,MSG - ; - S FDA(9002313.0201,MEDIEN_","_CLMIEN_",",FLDNUM)="" - D FILE^DIE("","FDA","MSG") - ; - S FND=1 ;we found at least 1 - ; - Q - ; -POST ;EP - This will be the entry point for the post init in patch - ; 3 of Pharmacy ECME Version 1.0. It will do two - ; things. First, it will check to see if patch 2 was run - ; First, it will call the routine created in Patch 2 that - ; creates the Cache entry in the BPS Dial out file. Secondly, - ; it will call the "RESTORE" subroutine in this program to - ; restore the values from the moves done in fields on the - ; BPS claims file in preparation of 5.1. - ; - ; first thing - see if the conversion has run before - if so, quit - Q:$$CKSETUP() - ; - D ^BPSOSSC ;create Cache entry in dial out (from Patch 2) - ; - D RESTORE - ; - D UPSETUP ;log that the conversion is complete - ; - Q -RESTORE ;EP - Post init routine for BPS0100.03k. - ; This subroutine will take the values stored in the save global - ; created in the above "SAVE" subroutine and restore the values - ; in their new locations in the ^BPSC file. - ; - N CLMIEN,MEDIEN,RTN,REC,LAST,I - S (LAST,MEDIEN,CLMIEN)="" - S RTN="BPSOSJ1" - ; - ; if we have to restart - this is where we need to start - S LAST=$G(^BPSOSXX(RTN,"LAST PROCESSED")) - I LAST'="" D - . S CLMIEN=$P(LAST,U) - . S MEDIEN=$P(LAST,U,2) - ; - ; - F S CLMIEN=$O(^BPSOSXX(RTN,CLMIEN)) Q:CLMIEN="" D - . D RST320 - . F S MEDIEN=$O(^BPSOSXX(RTN,CLMIEN,400,MEDIEN)) Q:MEDIEN="" D - .. S REC=$G(^BPSOSXX(RTN,CLMIEN,400,MEDIEN,400)) - .. Q:REC="" - .. F I=31:1:43 D MOVFLD(I+400,$P(REC,U,I)) - .. S ^BPSOSXX(RTN,"LAST PROCESSED")=CLMIEN_"^"_MEDIEN - ; - Q - ; -RST320 ; this will restore the 320 value onto the 320 node, piece 20 - ; - N FDA,MSG,VALUE - ; - S VALUE=$P($G(^BPSOSXX(RTN,CLMIEN,320)),U) - Q:VALUE="" - ; - S FDA(9002313.02,CLMIEN_",",320)=VALUE - D FILE^DIE(,"FDA","MSG") - ; - Q -MOVFLD(FLDNUM,VALUE) ;Adds the field back to it's new location - ; - N FDA,MSG - ; - Q:FLDNUM=432 ;don't need to move 432 - ; - S FDA(9002313.0201,MEDIEN_","_CLMIEN_",",FLDNUM)=VALUE - D FILE^DIE(,"FDA","MSG") - ; - Q - ; -UPSETUP ; This routine is called after the conversion to the claim file is - ; completed. It will update the "NCPDP51" node of the setup file - ; with today's date so that future patches will not need to - ; run the conversion again. - ; - N DATE,FDA,MSG - ; - D NOW^%DTC - S DATE=% - ; - ; we are hard setting the IEN of 1 in the next command - this is - ; because long along, ECME was written to assume that it will - ; always exist and it will be where the setup information - ; is stored. - ; - S FDA(9002313.99,"1,",5151)=DATE - D FILE^DIE(,"FDA","MSG") - ; - ; - Q - ; -CKSETUP() ; This routine will check the setup file for the existance of the - ; NCPDP51 node in the setup file. If it exists, then the conversion - ; has already been run, and we will exit the routine. - ; - N CONV - S CONV=1 ;1 means the conversion has run - ; - S:$P($G(^BPS(9002313.99,1,"NCPDP51")),U)="" CONV=0 - ; - Q CONV diff -auBN ./r1/BPSOSK2.m ./r2/r/BPSOSK2.m --- ./r1/BPSOSK2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSK2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,32 +0,0 @@ -BPSOSK2 ;BHAM ISC/FCS/DRS/DLF - winnow ECME data ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -FIX57IDX ; EP - from 57^BPSOSK - ; Clean up the NON-FILEMAN indexes from 9002313.57 - ; ^BPSTL("NON-FILEMAN","RXIRXR",RXI,RXR,N57) - ; ^BPSTL("NON-FILEMAN","RXIRXR",category,RXI,RXR,N57) - ; ^BPSTL("NON-FILEMAN","PCNDFN",PCNDFN,N57) - N ROOT S ROOT="^BPSTL(""NON-FILEMAN"",""RXIRXR"")" - N RXI,RXR,N57 - S RXI="" F S RXI=$O(@ROOT@(RXI)) Q:'RXI D - . S RXR="" F S RXR=$O(@ROOT@(RXI,RXR)) Q:RXR="" D - . . S N57=0 F S N57=$O(@ROOT@(RXI,RXR,N57)) Q:'N57 D - . . . I '$D(^BPSTL(N57)) D - . . . . K @ROOT@(RXI,RXR,N57) - ; at this point, RXI=the first "category" - N CAT S CAT=RXI - F D S CAT=$O(@ROOT@(CAT)) Q:CAT="" - . S RXI="" F S RXI=$O(@ROOT@(CAT,RXI)) Q:'RXI D - . . S RXR="" F S RXR=$O(@ROOT@(CAT,RXI,RXR)) Q:RXR="" D - . . . S N57="" F S N57=$O(@ROOT@(CAT,RXI,RXR,N57)) Q:'N57 D - . . . . I '$D(^BPSTL(N57)) D - . . . . . K @ROOT@(CAT,RXI,RXR,N57) - ; and now the PCNDFNs - S ROOT="^BPSTL(""NON-FILEMAN"",""PCNDFN"")" - N PCNDFN S PCNDFN=0 - F S PCNDFN=$O(@ROOT@(PCNDFN)) Q:'PCNDFN D - . S CAT="" F S CAT=$O(@ROOT@(CAT,PCNDFN)) Q:CAT="" D - . . S N57=0 F S N57=$O(@ROOT@(CAT,PCNDFN,N57)) Q:'N57 D - . . . I '$D(^BPSTL(N57)) D - . . . . K @ROOT@(CAT,PCNDFN,N57) - Q diff -auBN ./r1/BPSOSK.m ./r2/r/BPSOSK.m --- ./r1/BPSOSK.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSK.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,143 +0,0 @@ -BPSOSK ;BHAM ISC/FCS/DRS/DLF - winnow ECME data ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -SILENT(LOGSONLY) ;EP - do it silently, as in taskmanned task - ; $G(LOGSONLY)=1 if you are winnowing log files only. - ; Invoked sporadically at random from transaction completion in BPSOSU - N SILENT S SILENT=1 -MAIN ;EP - show progress - L +^TMP($J,$T(+0)):0 Q:'$T ; only one winnower at a time - ; (this protects against the case where two or more of these happen - ; to be scheduled at random throughout the day) - D ; log files - . N X S X=$G(^BPS(9002313.99,1,"WINNOW LOGS")) - . D INIT^BPSOSL(DT+.5,1) - . S X=DT+.5_U_$P(X,U,1,9) ; shift old down one spot and put new in - . S ^BPS(9002313.99,1,"WINNOW LOGS")=X - ; NEW the vars commonly used - N IEN,AGE,BILLSYS,TESTING,ISILCAR,NENTRIES,OLDPCT,COUNT - S ISILCAR=$$ISILCAR^BPSOSB ; some algorithms vary if you have ILC A/R - D AGES ; set AGE(field name)=value - D BILLSYS ; set BILLSYS=which billing system interface (internal) - S TESTING=$P($G(^BPS(9002313.99,1,"WINNOW TESTING")),U) - I TESTING D LOG("Just testing; nothing will actually be deleted.") - E D LOG("This is for real; we may really delete some data.") - ; The order of these files is important! Certain things won't be - ; deleted if the things pointed to them are still around. - I $G(LOGSONLY) G LOGS - D LOGHDG(9002313.57),INIFOR(9002313.57) - D 57 ; 9002313.57 Billing - D LOGHDG(9002313.59),INIFOR(9002313.59) - D 59 ; 9002313.59 Working - D LOGHDG(9002313.03),INIFOR(9002313.03) - D 03 ; 9002313.03 Responses - D LOGHDG(9002313.02),INIFOR(9002313.02) - D 02 ; 9002313.02 Claims - D LOGHDG(9002313.51),INIFOR(9002313.51) - D 51 ; 9002313.51 Input - D LOGHDG(9002313.511),INIFOR(9002313.511) - D 511 ; 9002313.511 Override - D LOGHDG("COMBINS"),INIFOR(9002313.1) - D COMBINS ; combined insurance -LOGS D LOGHDG("LOG FILES"),INIFOR("LOG FILES") - D LOGFILES ; Log files in ^BPSECP("LOG", - D RELSLOT^BPSOSL - L -^TMP($J,$T(+0)) - Q -INIFOR(F) ; - S COUNT=0,OLDPCT="" - I +F=F D - . I F=9002313.02 S NENTRIES=$P(^BPSC(0),U,4) - . E I F=9002313.03 S NENTRIES=$P(^BPSR(0),U,4) - . E I F=9002313.1 S NENTRIES=$P(^BPSCOMB(0),U,4) - . E S NENTRIES=$P(^BPS(F,0),U,4) - E D - . ; note: percentages will be off for the log files - . I F="LOG FILES" S NENTRIES=$P(^BPSECP("LOG","LAST SLOT"),U) - Q -LOGHDG(FILE) ; - N X ; - D LOGLINES - I FILE="COMBINS" S FILE=9002313.1 ; renumbered since original rou - I +FILE=FILE D - . S X="Winnowing file "_FILE_": "_$P(^DIC(FILE,0),U) - E D - . I FILE="LOG FILES" S X="Winnowing "_FILE - D LOG(X) - D LOGLINES - Q - ; Instead of going by indexes, just scan the entire file. - ; There may be some without the date field set, for example. - ; We don't want those hanging around forever. - ; -03 ; 9002313.03 Responses - S IEN=0 F S IEN=$O(^BPSR(IEN)) Q:'IEN D 03^BPSOSK1,PCT - D LOGDONE - Q -02 ; 9002313.02 Claims - S IEN=0 F S IEN=$O(^BPSC(IEN)) Q:'IEN D 02^BPSOSK1,PCT - D LOGDONE - Q -51 ; 9002313.51 Input - S IEN=0 F S IEN=$O(^BPS(9002313.51,IEN)) Q:'IEN D 51^BPSOSK1,PCT - D LOGDONE - Q -511 ; 9002313.511 Override - S IEN=0 - F S IEN=$O(^BPS(9002313.511,IEN)) Q:'IEN D 511^BPSOSK1,PCT - D LOGDONE - Q -57 ; 9002313.57 Billing - S IEN=0 F S IEN=$O(^BPSTL(IEN)) Q:'IEN D 57^BPSOSK1,PCT - D LOG("Fixing 9002313.57 indexes...") D FIX57IDX^BPSOSK2 - D LOGDONE - Q -59 ; 9002313.59 Working - S IEN=0 F S IEN=$O(^BPST(IEN)) Q:'IEN D 59^BPSOSK1,PCT - D LOGDONE - Q -LOGFILES ; ^BPSECP("LOG", - S IEN=0 - F S IEN=$O(^BPSECP("LOG",IEN)) Q:'IEN D LOGFILES^BPSOSK1,PCT - D LOGDONE - Q -COMBINS ; ^BPSCOMB( - ; Our ECME combined insurance can be winnowed because - ; we don't keep any pointers to combined insurance. - ; This is different in A/R, I think. - S IEN=0 - F S IEN=$O(^BPSCOMB(IEN)) Q:'IEN D COMBINS^BPSOSK1,PCT - D LOGDONE - Q -PCT Q:'NENTRIES Q:$G(SILENT) S COUNT=COUNT+1 - N X S X=COUNT/NENTRIES*100+.5\1 S:X=101 X=100 - I X'=OLDPCT W @IOBS,@IOBS,@IOBS,@IOBS,@IOBS,$J(X,3),"% " S OLDPCT=X - Q -LOGDONE D LOG("Done with this part.") Q -LOG(X) D LOG^BPSOSL(X) - I '$G(SILENT) U $P W X,! - Q -LOGLINES N X S X=$J("",60),X=$TR(X," ","=") D LOG(X) Q -GET99(FIELD) ; ^BPS(9002313.99,1,"WINNOWING") - ; field numbers #2341.nn -AGES ; set AGE(field name) = value for field numbers 2341.nn - I $G(^BPS(9002313.99,1,"WINNOW"))?."^" D - . ; Set some defaults if nothing has been explicitly set. - . N X S X="400^100^100^100^31^366^31^366^100^100^366^0" - . S ^BPS(9002313.99,1,"WINNOW")=X - N FIELD S FIELD=2341 - F S FIELD=$O(^DD(9002313.99,FIELD)) Q:FIELD'<2342 Q:'FIELD D - . N NAME,DEST D FIELD^DID(9002313.99,FIELD,,"LABEL","DEST") - . S NAME=$G(DEST("LABEL")) - . I NAME="" D - . . D ZWRITE^BPSOS("FIELD","DEST") - . . D IMPOSS^BPSOSUE("FM","TI","FIELD^DID(9002313.99 failed on field "_FIELD,,"AGES",$T(+0)) - . N VALUE S VALUE=$$GET1^DIQ(9002313.99,"1,",FIELD) - . I VALUE="" S VALUE=365+365+366 ; 3 years - . S AGE(NAME)=VALUE - . D LOG("AGE("_NAME_")="_VALUE) - Q -BILLSYS ; set BILLSYS= which billing system you're interfacing to - S BILLSYS=$$GET1^DIQ(9002313.99,"1,",170.01) - D LOG("BILLSYS="_BILLSYS) - Q diff -auBN ./r1/BPSOSL1.m ./r2/r/BPSOSL1.m --- ./r1/BPSOSL1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSL1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,79 +0,0 @@ -BPSOSL1 ;BHAM ISC/FCS/DRS/DLF - log file printing ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; D CLAIMLOG^BPSOS6M - individual claims, as called from user screen - ; D PRINTLOG^BPSOSBD - DT+.2 - background posting to A/R - ; D label^BPSOSBL - billing log file - ILC interface - n+.2 - ; BPSOSC2, BPSOSC3 - testing and certification - ; D LOGFILE^BPSOSR1 - DT+.3 - background scanner of ^PSRX(indexes) - ; D LASTLOG^BPSOSRB - same as in BPSOSRX, below - ; D LASTLOG^BPSOSRX - DT+.4 - background claims submission - ; D LOGFILE^BPSOSR4 - DT+.6 - back billing - ; D COMMSLOG^BPSOSU6 - dial out's log files - offset .1 - ; (no entry point) - DT+.5 - winnowing old data - ; D PRINT^BPSOSUT - the programmer-mode modem tests - ; - ; Two entry points: PRINTLOG to print the log file, given the # - ; And PRINTDAT(type,start,end) prints all log files of the given - ; type in the given date range. It prompts for missing parameters. - ; (if start is given and end is missing, it just does start) - ; -PRINTDAT(TYPE,START,END) ;EP - I '$D(TYPE) S TYPE=$$GETTYPE Q:'TYPE - W ! - I $D(START) D - . I '$D(END) S END=START - E D Q:'START - . S START=$$GETDATES,END=$P(START,U,2),START=$P(START,U) - N POP D ^%ZIS Q:$G(POP) - N FORDATE S FORDATE=START F D Q:FORDATE>END - . N SLOT S SLOT=FORDATE+(TYPE/10) - . I $$EXISTS^BPSOSL(SLOT) D - . . D PRINTLOG(SLOT) - . E D - . . W "There is no log file ",SLOT,! H 1 - . S FORDATE=$$TADD^BPSOSUD(FORDATE,1) ; add one day - D ^%ZISC - Q -GETDATES() ; return start^end - N PROMPT1 S PROMPT1="Starting date: " - N PROMPT2 S PROMPT2=" Ending date: " - N DEF1,DEF2 S (DEF1,DEF2)=DT - Q $$DTR^BPSOSU1(PROMPT1,PROMPT2,DEF1,DEF2,"") -GETTYPE() ; return 2 = billing, 3 = background scanner, etc. - N PROMPT S PROMPT="Which log file? " - N DEF S DEF=2 - N MODE S MODE="V" - N MENU S MENU="2:Billing;3:Background scan;4:Claims submitter;5:Winnowing;6:Back billing" - Q $$SET^BPSOSU3(PROMPT,DEF,1,MODE,MENU) -PRINTLOG(SLOT,START,END) ; EP - I $Y D HDR - I '$$EXISTS^BPSOSL(SLOT) W "Nothing in SLOT=",SLOT,! Q - I '$G(START) N START S START=1 - I '$G(END) N END S END=$$PRINTEND^BPSOSL(SLOT) - N PREVTIME S PREVTIME="" - N MISS S MISS=0 ; count of missing lines - N LEN S LEN=$S($G(IOM):IOM,1:80)-10-1 - N STOP S STOP=0 - N LINE F LINE=START:1:END D Q:STOP - .I '$D(^BPSECP("LOG",SLOT,LINE)) D Q - ..I MISS>3 Q ; don't bother saying any more - ..S MISS=MISS+1 W "Missing line ",LINE - ..I MISS=3 W "; no more missing lines will be reported." - ..W ! - .N X S X=^BPSECP("LOG",SLOT,LINE) ; =$H seconds^text - .N % S %=$P(X,U) - .I %'=PREVTIME S PREVTIME=% D - ..S %=PREVTIME W $J(%\3600,2),":" S %=%#3600 - ..W $TR($J(%\60,2)," ","0"),":" S %=$J(%#60,2) W $TR(%," ",0) - .S X=$P(X,U,2,$L(X,U)) - .N I F I=1:LEN:$L(X) D Q:STOP - ..I I>1 W ?6,"..." - ..W ?10,$E(X,I,I+LEN-1),! - ..D EOP - Q -EOP ; end of page handling - ; set STOP if the user wants to get out - S STOP=$$EOPQ^BPSOSU8(2,,"D HDR^"_$T(+0)) - Q -HDR W @IOF,"Log file #",SLOT,! Q diff -auBN ./r1/BPSOSL.m ./r2/r/BPSOSL.m --- ./r1/BPSOSL.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,221 +0,0 @@ -BPSOSL ;BHAM ISC/FCS/DRS/DLF - logging ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; Lots of entry points called from lots of places. - ; - ; The job that reads the prescription does this: - ; DO INIT^BPSOSL(ABSBRXI,NODELETE) to init a new session - ; It will also DO SETSLOT() for you and timestamp. - ; NODELETE true will keep anything already there, - ; otherwise, any previous data is deleted. - ; DO LOG^BPSOSL(text) to log an event - ; DO RELSLOT^BPSOSL to release the slot - ; - ; The job(s) that build the packet and handle the communications - ; should do the following to stuff info into a prescription's log: - ; DO SETSLOT^BPSOSL(prescription ien) - ; DO LOG^BPSOSL(text) to log an event - ; DO RELSLOT^BPSOSL to release the slot - ; - ; DO LOG2LIST^BPSOSL(text) to log to all IEN59 in RXILIST(IEN59) - ; DO LOG2CLM^BPSOSL(text,IEN02) to log all IEN59 represented - ; in ^BPSC(IEN02, claim - ; DO LOG59(text,IEN59) to log to IEN59 (does SETSLOT/RELSLOT for you) - ; DO LOGARRTO(root,slot) to log an entire array to IEN59 - ; - ; DO FINDPREV(type[,start]) to find most recent slot of given n.type - ; (type is the decimal suffix) start = optional start at this # - ; - ; Communications jobs - to not interfere with prescription numbers, - ; add an extra .1 onto the index. - ; DO INIT^BPSOSL(.1) - ; Processing responses (BPSOSQ4) - tacks on .11 - ; Billing jobs - add an extra .2 onto the index - (DT+.2) - ; Silent submitter (BPSOSR1) - add .3 - (these will be DT+.3) - ; Calls to ABSOPSRX - add .4 - (these will be DT+.4) - ; Winnowing - BPSOSK - add .5 - (these will be DT+.5) - ; Back billing - add .6 (these will be DT+.6) - ; - ; The job(s) that handle the response should - ; DO SETSLOT^BPSOSL(prescription ien) - ; DO LOG^BPSOSL(text) to log an event - ; DO DONE^BPSOSL to close a session - ; It will also do RELSLOT for you. - ; - ; - ; Other functions: - ; $$GETSLOT returns the slot # currently in use (as when you wish to - ; use a different one and stack this one for later reuse) - ; $$GETINDEX returns the position of the logging (a subscript, - ; a copy of ^BPSECP("LOG",slot #,0)) - ; $$GETINDEX(SLOT) gets it for some other given slot, not your own - ; $$GETPLACE returns $$GETSLOT_","_$$GETINDEX - ; $$EXISTS(SLOT) does this slot # exist? - ; - ; - ; PRINTLOG(SLOT) to print the log of entire session from SLOT - ; PRCLLOG("slot,line",claim#) to print the transmissions log - ; excerpt relevant to claim# - ; - ; ^BPSECP("LOG","LAST SLOT")=last # assigned ; obsolete - ; ^BPSECP("LOG","JOB",j)=# ; given $J, what's the log # - ; ^BPSECP("LOG",#)=time assigned^job number^time done - ; ^BPSECP("LOG",#,0)=last n assigned - ; ^BPSECP("LOG",#,n)=$H secs^event text - ; - ; -LOG(TEXT,ECHO,SPECIAL) ;EP - log the event given by TEXT - ; SPECIAL="D" to prefix with printable date, T time, DT both - N H S H=$H - N SLOT S SLOT=$G(^BPSECP("LOG","JOB",$J)) Q:'SLOT - N N S N=$G(^BPSECP("LOG",SLOT,0))+1,^(0)=N - I $G(SPECIAL)]"",SPECIAL["D"!(SPECIAL["T") D - . N %,%H,%I,X,Y D NOW^%DTC S Y=% X ^DD("DD") - . I SPECIAL'["D" S Y=$P(Y,"@",2) - . I I SPECIAL'["T" S Y=$P(Y,"@") - . S TEXT=Y_" "_TEXT - S ^BPSECP("LOG",SLOT,N)=$P(H,",",2)_"^"_$E(TEXT,1,200) - ;S ECHO=0 ; temporary ; temporary ; temporary ; while testing tasking - I $G(ECHO) D - .N IO S IO=$I - .U $P W:$X>0 ! W TEXT,! - .U IO - I $G(SPECIAL)=9999 S $P(^BPSECP("LOG",SLOT),"^",3)=H - Q -INIT(SLOTNUM,NODELETE,TMSTAMP) ;EP - very first caller does this: - ; TMSTAMP undef or 1 -> you'll get a one-line time stamp - ; TMSTAMP = 0 -> you won't get it. - ; TMSTAMP = -1 -> timestamp only if brand new log file - I '$G(^BPSECP("LOG","LAST SLOT")) D - . N X S X=$O(^BPSECP("LOG",999999999999),-1) S:'X X=99 - . S ^BPSECP("LOG","LAST SLOT")=X\1 - F L +^BPSECP("LOG"):300 Q:$T Q:'$$IMPOSS^BPSOSUE("L","RTI","interlock on obtaining new log file slot",,"INIT",$T(+0)) - N SLOT - I $G(SLOTNUM)'<1 D ; if a specific slot number was specified: - . S SLOT=SLOTNUM - E D ; SLOTNUM<1, a differential to add - . I '$D(SLOTNUM) S SLOTNUM=0 - . S SLOT=^BPSECP("LOG","LAST SLOT")+1+SLOTNUM ; add in the differential - . ; check: slot doesn't exist - . N STOP S STOP=0 - . F D Q:STOP S SLOT=SLOT+1 - . . ; want: nothing in this SLOT\1 range - . . I $D(^BPSECP("LOG",SLOT\1)) Q ; no, ^BPSECP("LOG",xxx) defined - . . I $O(^BPSECP("LOG",SLOT\1))\1=(SLOT\1) Q ; no,^BPSECP("LOG",xxx.yy) defined - . . S STOP=1 - . S ^BPSECP("LOG","LAST SLOT")=SLOT\1 - D SETSLOT(SLOT) - I '$G(NODELETE) K ^BPSECP("LOG",SLOT) - I '$G(NODELETE)!('$D(^BPSECP("LOG",SLOT,0))) S ^BPSECP("LOG",SLOT,0)=0 - I $G(TMSTAMP)=-1 D ; we want a time stamp only if it's brand new file - . S TMSTAMP='$D(^BPSECP("LOG",SLOT,1)) - I $G(TMSTAMP)'=0 D ; only skip if TMSTAMP is explicitly 0 - . N %,%H,%I,X D NOW^%DTC S Y=% X ^DD("DD") D LOG(Y_" "_%H_" "_%_" "_SLOT) - L -^BPSECP("LOG") - Q -SETSLOT(SLOT) ;EP - - S ^BPSECP("LOG","JOB",$J)=SLOT - ;L +^BPSECP("LOG",SLOT):0 ZT:'$T - I SLOT S ^BPSECP("LOG",SLOT)=$H_"^"_$J - Q -RELSLOT ; EP - - N SLOT S SLOT=$G(^BPSECP("LOG","JOB",$J)) - I SLOT S $P(^BPSECP("LOG","JOB",$J),U,2)="R" - ;L -^BPSECP("LOG",SLOT) - Q - ; -GETSLOT() ;EP - - N X S X=$G(^BPSECP("LOG","JOB",$J)) ; = "" if you had none - I X?.E1"^R" S X="" ; you (or prev user) had one, but it was released - Q X - ; -GETINDEX(SLOT) Q $G(^BPSECP("LOG",$S($D(SLOT):SLOT,1:$$GETSLOT),0)) - ; -GETPLACE() ;EP - - Q $$GETSLOT_","_$$GETINDEX - ; -DONE ;EP - - D LOG("DONE^BPSOSL",0,9999) - D RELSLOT - K ^BPSECP("LOG","JOB",$J) - Q -PRCLLOG(WHERE,CLAIM) ;EP - print portion of comms log related to given claim - N SLOT,START,END,END1,X,FOUND - S SLOT=$P(WHERE,","),START=$P(WHERE,",",2) - S END=$$PRINTEND(SLOT) I 'END Q - ; Is the START what we expect? - ; this must match text at CLAIMBEG, CLAIMEND^BPSOSAM - S X=$G(^BPSECP("LOG",SLOT,START)) - I $P(X,U,2)'[("CLAIM - BEGIN - #"_CLAIM) D Q - .W "Found ",X,! - .W " instead of expected beginning of claim ",CLAIM,".",! - S FOUND=0 ; whether we found the expected end or not - F END1=START+1:1:END D Q:FOUND ; with END1 pointing to the end - .S X=$G(^BPSECP("LOG",SLOT,END1)) - .I $P(X,U,2)[("CLAIM - END - #"_CLAIM) S FOUND=1 - I 'FOUND D - .W "Did not find the expected end of claim transmission info.",! - .W "We will print out some of what is there.",! - .S END1=START+25 S:END1>END END1=END - D PRINTLOG(SLOT,START,END1) - Q -PRINTEND(SLOT) ;EP -find the end of the logging session - N END S END=$G(^BPSECP("LOG",SLOT,0)) - I 'END D - .W "Missing the 0 node that tells us where the end is?",! - .S END=$O(^BPSECP("LOG",SLOT,""),-1) - .W "Working backwards, we think the end is at ",END,! - Q END -PRINTLOG(SLOT,START,END) ;EP - - D PRINTLOG^BPSOSL1(SLOT,$G(START),$G(END)) Q -HDIF(THEN,NOW) Q $P(NOW,",")-$P(THEN,",")*86400+$P(NOW,",",2)-$P(THEN,",",2) -EXISTS(X) ;EP - - Q $D(^BPSECP("LOG",X)) -FINDPREV(TYPE,START) ; - I '$D(START) D Q:'START - . I TYPE>1 S START=TYPE-1,TYPE=TYPE#1 Q - . S START=+$G(^BPSECP("LOG","LAST SLOT"))+1 - I START#1=0 S START=START+TYPE - I START#1'=TYPE S START=START\1-1+TYPE - F Q:$D(^BPSECP("LOG",START)) S START=START-1 I START<1 S START="" Q - Q START - ; These logging utilities originally came from BPSOSQ2 -LOG2LIST(MSG) ;EP - write MSG to the log files of all in RXILIST(*) - N IEN59 S IEN59=0 - F S IEN59=$O(RXILIST(IEN59)) Q:'IEN59 D - . D LOG59(MSG,IEN59) - Q -LOG2CLM(MSG,IEN02) ;EP - write MSG to log file for all claims in this 9002313.02 - N IEN59 S IEN59=0 - F S IEN59=$O(^BPST("AE",IEN02,IEN59)) Q:'IEN59 D - . D LOG59(MSG,IEN59) - Q -LOG59(MSG,IEN59) ;EP - - D LOG2SLOT(MSG,IEN59) Q - ; obsolete: - D SETSLOT(IEN59) - D LOG(MSG) - D RELSLOT - Q -LOG2SLOT(MSG,SLOT) ;EP - - N OLDSLOT S OLDSLOT=$$GETSLOT - D SETSLOT(SLOT) - D LOG(MSG) - D RELSLOT - D SETSLOT(OLDSLOT) - Q -LOGARRAY(ROOT,SLOT,MAX) ;EP - - N REF S REF=ROOT - N COUNT S COUNT=0 - I '$D(MAX) S MAX=100 - I $D(@REF)#10'=1 S REF=$Q(@REF) - F Q:REF="" D Q:'MAX - . I $D(SLOT) D - . . D LOG2SLOT(REF_"="_@REF,SLOT) - . E D LOG(REF_"="_@REF) - . S COUNT=COUNT+1 - . S REF=$Q(@REF) - . S MAX=MAX-1 - I 'MAX,REF]"" D LOG2SLOT("More of "_ROOT_" to log, but max reached",SLOT) - I 'COUNT D LOG2SLOT("Nothing found in "_ORIGROOT,SLOT) - Q diff -auBN ./r1/BPSOSM1.m ./r2/r/BPSOSM1.m --- ./r1/BPSOSM1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSM1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,169 +0,0 @@ -BPSOSM1 ;BHAM ISC/FCS/DRS/DLF - build Report Master data ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; File 9002313.61 - BPS REPORT MASTER - ; Purpose: make it easy to use Fileman to get data, - ; by storing pointers to various places, indexed by Release Date - ; -AUTO(SILENT) ; EP - entry action to the claims report menu - ; automatically update for a few days prior to the last update - ; up through the end of today - N PRVLOG - ; - No new transactions since the last update ran - S PRVLOG=+$$GET1^DIQ(9002313.99,1,119.05,"I") I '$O(^BPSTL(PRVLOG)) Q - I '$D(SILENT) D S SILENT=1 - . W !,"...updating the Report Master file, please stand by...",! - L +^BPS(9002313.99,1,$T(+0)):+0 Q:'$T ; could be timing probs; just go on - I 'PRVLOG,'SILENT W !,"The REPORT MASTER FILE is being prepared for its first use.",! - I 'SILENT W !,"Updating the Report Master file..." - ; - I '$$UPDATE61(PRVLOG,SILENT) G AUTO9 - ; -AUTO9 L -^BPS(9002313.99,1,$T(+0)) - Q -UPDATE61(FIRSTLOG,SILENT) ; EP - update the .61 file. - ; If called with $$, returns 1 success, 0 failure - N LASTLOG,NLSTLOG - I '$D(SILENT) S SILENT=0 - I '$$LOCK61 D Q 0 - . I 'SILENT W !,"Someone else is already using this program.",! - ; - I '$D(FIRSTLOG) D I FIRSTLOG="^" Q 0 - . N DIR,DTOUT,DUOUT,DIRUT,DATE,X,Y,LGBDT,LGEDT,RPDATE - . S FIRSTLOG=+$$GET1^DIQ(9002313.99,1,119.05,"I") - . I 'FIRSTLOG!'$D(^BPSECX("RPT","AD")) D Q - . . W !!,"The REPORT MASTER FILE will be updated for its first use.",! - . . K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="CONFIRM" D ^DIR I Y=0!$D(DIRUT) S FIRSTLOG="^" Q - . W !!,"Choose the start date to build the REPORT MASTER FILE",! - . S LGBDT=$O(^BPSTL("AH",0))\1,LGEDT=$O(^BPSTL("AH",""),-1)\1,RPDATE=$O(^BPSECX("RPT","AD",""),-1) - . S DIR("?",1)="Enter the START date to rebuild the REPORT MASTER FILE." - . S DIR("?")="It must be between "_$$FMTE^DILIBF(LGBDT,"5U")_" and "_$$FMTE^DILIBF(RPDATE,"5U") - . S DIR(0)="D^"_LGBDT_":"_RPDATE_":EX",DIR("A")="START TRANSACTION DATE" D ^DIR I $D(DIRUT) S FIRSTLOG="^" Q - . S STDATE=Y,DATE=$O(^BPSTL("AH",STDATE),-1),FIRSTLOG=0 S:DATE FIRSTLOG=$O(^BPSTL("AH",DATE,0))-1 - . S DIR("?",1)="Enter the END date to rebuild the REPORT MASTER FILE." - . S DIR("?")="It must be between "_$$FMTE^DILIBF(STDATE,"5U")_" and TODAY" - . S DIR(0)="D^"_STDATE_":"_DT_":EX",DIR("A")=" END TRANSACTION DATE" D ^DIR I $D(DIRUT) S FIRSTLOG="^" Q - . S ENDATE=Y,DATE=$O(^BPSTL("AH",ENDATE),-1) S:'DATE DATE=ENDATE S LASTLOG=$O(^BPSTL("AH",DATE,0),-1) - . W !!,"The REPORT MASTER FILE will be updated for the date range: " - . W !!?20,"From ",$$FMTE^DILIBF(STDATE,"5U")," Thru ",$$FMTE^DILIBF(ENDATE,"5U"),! - . K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="CONFIRM" D ^DIR I Y=0!$D(DIRUT) S FIRSTLOG="^" Q - ; - I 'SILENT W !,"Processing..." - D BUILD61(FIRSTLOG,$G(LASTLOG),.NLSTLOG) - S $P(^BPS(9002313.99,1,$T(+0)),U,4)=$$NOW - I $G(NLSTLOG),NLSTLOG>$P($G(^BPS(9002313.99,1,$T(+0))),U,5) D - . S $P(^BPS(9002313.99,1,$T(+0)),U,5)=NLSTLOG - D UNLOCK61 - I 'SILENT W "Done!",! - Q 1 - ; -BUILD61(FIRSTLOG,LASTLOG,NLSTLOG) ; Build file 9002313.61 from the BPS TRANSACTION LOG file (#9002313.57) - N IEN,LOGIEN,RXI,RXR - S LOGIEN=+FIRSTLOG,LASTLOG=+$G(LASTLOG) - F S LOGIEN=$O(^BPSTL(LOGIEN)) Q:'LOGIEN!(LASTLOG&(LOGIEN>LASTLOG)) D - . I $D(^BPSECX("RPT","AE",LOGIEN)) D - . . S IEN=$O(^BPSECX("RPT","AE",LOGIEN,0)) D DELETE(IEN) - . S RXI=$$GET1^DIQ(9002313.57,LOGIEN,1.11,"I") - . S RXR=$$GET1^DIQ(9002313.57,LOGIEN,9,"I") - . I RXR,'$D(^PSRX(RXI,1,RXR)) Q - . D ONE S NLSTLOG=LOGIEN - Q - ; -LOCK61() L +^BPSECX("RPT"):0 Q $T -UNLOCK61 L -^BPSECX("RPT") Q -DELETE(IEN) ; - N FDA,MSG - S FDA(9002313.61,IEN_",",.01)="" -D5 D FILE^DIE(,"FDA","MSG") - Q:'$D(MSG) ; success - D ZWRITE^BPSOS("FDA","MSG") - G D5:$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"DELETE",$T(+0)) - Q -FIND() ; look for existing RXI,RXR entry in 9002313.61 - N IEN,FOUND S (IEN,FOUND)=0 - F S IEN=$O(^BPSECX("RPT","C",RXI,IEN)) Q:'IEN D Q:FOUND - . N X S X=^BPSECX("RPT",IEN,0) - . I $P(X,U,5)=RXR S FOUND=IEN - Q FOUND -ONE ; RXI, RXR released at time WHEN - N FDA,MSG,FN,IENS,IEN57,XRXARY,RXIEN,RXRIEN,RXINFO - S RXARY="RXINFO" - S IENS=$$FIND - I '$$FIND S IENS="+1" - S IENS=IENS_"," - S FN=9002313.61 - S (IEN57,FDA(FN,IENS,.03))=$$LAST57^BPSOSBB(RXI,RXR) - D GETS^DIQ("52",RXI,"1;22;31;52*","I",RXARY) - S RXIEN=RXI_",",RXRIEN=RXR_","_RXIEN - ; added "I IEN57" to next line - I IEN57 S FDA(FN,IENS,.02)=$P($P($G(^BPSTL(IEN57,0)),U,8),".") ;BPS*1.0T7*1 - ; - S FDA(FN,IENS,.04)=RXI - S FDA(FN,IENS,.05)=RXR - I RXR=0 D - .I RXINFO(52,RXIEN,31,"I")\1=0 D - ..S FDA(FN,IENS,.01)="NOT RELEASED" - .E D - ..S FDA(FN,IENS,.01)=RXINFO(52,RXIEN,31,"I")\1 - .I $G(^PSRX($P(RXIEN,","),"L",1,0)) S FDA(FN,IENS,.095)=$P(^PSRX($P(RXIEN,","),"L",1,0),"^")\1 - .S FDA(FN,IENS,.08)=RXINFO(52,RXIEN,22,"I") - .S FDA(FN,IENS,.09)=RXINFO(52,RXIEN,1,"I") - E D - .I RXINFO(52.1,RXRIEN,17,"I")\1=0 D - ..S FDA(FN,IENS,.01)="NOT RELEASED" - .E D - ..S FDA(FN,IENS,.01)=RXINFO(52.1,RXRIEN,17,"I")\1 - .I $G(^PSRX($P(RXIEN,","),"L",1,0)) S FDA(FN,IENS,.095)=$P(^PSRX($P(RXIEN,","),"L",1,0),"^")\1 - .S FDA(FN,IENS,.08)=RXINFO(52.1,RXRIEN,.01,"I") - .S FDA(FN,IENS,.09)=RXINFO(52.1,RXRIEN,10.1,"I") - N RWR,X - I IEN57 S RWR=$$GET1^DIQ(9002313.57,IEN57_",","RESULT WITH REVERSAL") - E S RWR="" - ; - ; Note! Computed fields rely on these code values. - ; Also, AMOUNT OTHER takes in all the X<0 cases - ; - I RWR?1"E ".E D - . S X=RWR - . I X="E PAYABLE" S X=4 - . E I X="E CAPTURED" S X=3 - . E I X="E DUPLICATE" S X=2 - . E I X="E REJECTED" S X=1 - . E I X="E REVERSAL ACCEPTED" S X=11 - . E I X="E REVERSAL REJECTED" S X=12 - . E S X=0 - E I RWR="PAPER" S X=9 - E I RWR="PAPER REVERSAL" S X=19 - E S X=15 - S FDA(FN,IENS,.06)=X - ; - ; If the claim has any message text, store it - N MSGTEXT - I RWR?1"E ".E D - . S X=$$MESSAGE^BPSOSM(IEN57,1) - . I X]"" S MSGTEXT(1)=X - . S X=$$MESSAGE^BPSOSM(IEN57,2) - . I X]"" S MSGTEXT(2)=X - I $D(MSGTEXT) S FDA(FN,IENS,1300)="MSGTEXT" - E S FDA(FN,IENS,1300)="" - ; - ; If it's a rejected claim, build the rejection text - ; - N REJTEXT - I RWR="E REJECTED"!(RWR="E REVERSAL REJECTED") D - . N RESP,ECME D RESPPOS^BPSOSM(IEN57) ; set RESP,ECME pointers - . D REJTEXT^BPSOS03(RESP,POS,.REJTEXT) - . ; word processing text goes into FDA(FILE,IENS,FIELD,n)=text - . S FDA(FN,IENS,1800)=$S($D(REJTEXT):"REJTEXT",1:"") - E S FDA(FN,IENS,1800)="" -ONE5 I IENS["+" D - . D UPDATE^DIE(,"FDA",,"MSG") - E D - . D FILE^DIE(,"FDA","MSG") - Q:'$D(MSG) ; success - D ZWRITE^BPSOS("IENS","FDA","MSG") - G ONE5:$$IMPOSS^BPSOSUE("FM","TRI",$S(IENS["+":"UPDATE",1:"FILE")_"^DIE failed",,"ONE5",$T(+0)) - Q -NOW() N %,%H,%I,X D NOW^%DTC Q % - Q diff -auBN ./r1/BPSOSMA.m ./r2/r/BPSOSMA.m --- ./r1/BPSOSMA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSMA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,137 +0,0 @@ -BPSOSMA ;BHAM ISC/FCS/DRS/DLF - General Inquiry/Report .57;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; General inquiry and reporting on the Transaction File, 9002313.57. - ; First menu selection determines whether you're doing an inquiry - ; or a report. - ; Second menu selection determines how to select transactions. - ; If you're doing an inquiry, do the search only. Then display - ; a list of the claims. Select one or more and then you get the - ; prompt for what kind of output to generate. - ; Third menu selection determines what kind of output to generate. - ; You get this right away if you're operating in report mode. - ; - ; Primary sort is always by date/time, usually transaction date/time. - ; If sorting by released date (date only, can't do it by time), - ; for efficiency, pre-scan 9002313.61 Report Master file and - ; determine a range of transaction date/time to search by. - ; - ; Transaction date/time means the LAST UPDATE field. - ; - ; Local array BPSOSMA() contains the parameters: - ; BPSOSMA("BY WHICH DATE")="TRANSACTION" or "RELEASED" - ; BPSOSMA("MODE")="INQUIRY" or "REPORT" - ; BPSOSMA("SORT",7,"FR")=transaction date/time, start value - ; BPSOSMA("SORT",7,"TO")=transaction date/time, to value - ; Released date/time - 9999.95 - is applicable - ; only if BPSOSMA("BY WHICH DATE")="RELEASED" - ; BPSOSMA("SORT",9999.95,"FR")=released date/time, start value - ; BPSOSMA("SORT",9999.95,"TO")=released date/time, to value - ; Other sort fields are always field name, not field number. - ; This way, you can $O(BPSOSMA("SORT"," ")) to find out - ; what kind of a sort is being done. - ; BPSOSMA("SORT",field name,"FR")=other field sort, start value - ; BPSOSMA("SORT",field name,"TO")=other field sort, to value - ; - ; BPSOSMA("SCREEN",n)=screens, to be copied to DIS(n) - ; BPSOSMA("OUTPUT TYPE")=see list of codes in BPSOSMZ - ; - ;----------------------------------------------------------- - ;IHS/SD/lwj 8/28/02 Cache cannot handle a reverse $O of an - ; array, so the logic used to retrieve the last entry in - ; BPSOSMA("SCREEN") had to be altered somewhat. (subroutine - ; ADDSCREE - ;----------------------------------------------------------- - ; -INIT ; EP - init BPSOSMA - ; Nice idea for future - retain settings on user-by-user basis - K BPSOSMA - S BPSOSMA("BY WHICH DATE")="TRANSACTION" - S (BPSOSMA("SORT",7,"FR"),BPSOSMA("SORT",7,"TO"))="?" - S BPSOSMA("MODE")="INQUIRY" - S BPSOSMA("OUTPUT TYPE")=$$DEFOUT^BPSOSMZ - S BPSOSMA("SCREEN",0)="I $D(^BPSECX(""RPT"",""AE"",D0))" ; only the most recent transaction for any one given presc. ; 1" ; easier to fill in a dummy here - Q -KILLSORT ; EP - kill all sort fields except the date/time ones - N A S A=0 F S A=$O(BPSOSMA("SORT",A)) Q:A="" D - . Q:A=7 Q:A=9999.95&(BPSOSMA("BY WHICH DATE"))="RELEASED" - . K BPSOSMA("SORT",A) - Q -ADDSCREE(X) ; store the screen, xecutable code stored in X - ;IHS/SD/lwj 8/28/02 Cache cannot do a reverse $O on an array - ; so we had to change the logic used to retrieve the last - ; array entry in BPSOSMA - nxt line remarked out and - ; the two following were added - ;S BPSOSMA("SCREEN",$O(BPSOSMA("SCREEN",""),-1)+1)=X Q - N BPSL,BPSLST - S BPSL="" - F S BPSL=$O(BPSOSMA("SCREEN",BPSL)) Q:BPSL="" S BPSLST=BPSL - S BPSOSMA("SCREEN",BPSLST+1)=X Q - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ; Handling for each of the BPS INQUIRY options - ; Each of these does the following: - ; D INIT ; init BPSOSMA() - ; ; then its own specific setup - ; G JOIN - ; And at JOIN, then all go to JOIN^BPSOSMB - ; Eventually, EN1^DIP will do all the work for us, - ; both sorting and printing. -JOIN G JOIN^BPSOSMB - ; -PHARM ; EP - Option BPS INQUIRY BY PHARMACY - D INIT - N PHARM S PHARM=$$ASKPHARM^BPSOSMZ - Q:'PHARM - S BPSOSMA("SORT","PHARMACY","FR")=$P(^BPS(9002313.56,PHARM,0),U) - S BPSOSMA("SORT","PHARMACY","TO")=$P(^BPS(9002313.56,PHARM,0),U) - Q -PATIENT ; EP - Option BPS INQUIRY BY PATIENT - ; Select a list of patients. - ; Build screens corresponding to the list (i.e., it's not a sort item) - ; I $P(^BPSTL(D0,0),U,6)=patient ien - D INIT - N PAT F S PAT=$$ASKPAT^BPSOSMZ Q:'PAT D - . D ADDSCREE("I $P(^BPSTL(D0,0),U,6)="_PAT) - G JOIN -RESTYPE ; EP - Option BPS INQUIRY BY RESULT TYPE - ; Select from the entries in file 9002313.83 - ; Build screens corresponding to the list (i.e., it's not a sort item) - D INIT - N R F S R=$$ASKRTYPE^BPSOSMZ Q:R="" D - . D ADDSCREE("I $$GET1^DIQ(9002313.57,D0_"","",""RESULT WITH REVERSAL"")="""_R_"""") - G JOIN -CLAIMID ; EP - Option BPS INQUIRY BY CLAIM ID - ; A sort criterion. Prompt for FR and TO. - ; Lookup on file 9002313.02 now? - D INIT - D KILLSORT - S BPSOSMA("SORT","CLAIM:Claim ID","FR")="?" - S BPSOSMA("SORT","CLAIM:Claim ID","TO")="?" - G JOIN -INSURER ; EP - Option BPS INQUIRY BY INSURER - D INIT - S BPSOSMA("SORT","INSURER","FR")="?" - S BPSOSMA("SORT","INSURER","TO")="?" - G JOIN -NDC ; EP - Option BPS INQUIRY BY NDC NUMBER - D INIT - W !,"When prompted for NDC number, use the 11-digit form " - W "with no hyphens.",! H 2 - S BPSOSMA("SORT","ABSBNDC","FR")="?" - S BPSOSMA("SORT","ABSBNDC","TO")="?" - G JOIN -PRICE ; EP - Option BPS INQUIRY BY PRICE - D INIT - S BPSOSMA("SORT","TOTAL PRICE","FR")="?" - S BPSOSMA("SORT","TOTAL PRICE","TO")="?" - G JOIN -FM ; EP - Option BPS INQUIRY BY FILEMAN - ; we will leave the BY undefined - D INIT - K BPSOSMA("SORT") - G JOIN -ONLY ; EP - Option BPS INQUIRY BY DATE ONLY - D INIT - D KILLSORT - G JOIN -TEST D ONLY Q diff -auBN ./r1/BPSOSMB.m ./r2/r/BPSOSMB.m --- ./r1/BPSOSMB.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSMB.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,67 +0,0 @@ -BPSOSMB ;BHAM ISC/FCS/DRS/DLF - General Inquiry/Report .57;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -JOIN ;EP - various options from BPSOSMA join here - N X,DEFDATES -A ;S X=$$MODE^BPSOSMZ - S X="I" ; always Inquiry mode? - I X="I" S BPSOSMA("MODE")="INQUIRY" - E I X="R" S BPSOSMA("MODE")="REPORT" - E Q -B I '$D(BPSOSMA("SORT")) G D ; if doing a Fileman sort, skip date range - D DEFDATES ; set default sort dates - S X=$$SORTDATE^BPSOSMZ I X="" G A - I X="T" D - . S BPSOSMA("BY WHICH DATE")="TRANSACTION" - . K BPSOSMA("SORT",9999.95) - E I X="R" D - . S BPSOSMA("BY WHICH DATE")="RELEASED" - E Q -C S X=$$DATES^BPSOSMZ(DEFDATES) G:'X B - I BPSOSMA("BY WHICH DATE")="TRANSACTION" D - . S BPSOSMA("SORT",7,"FR")=$P(X,U) - . S BPSOSMA("SORT",7,"TO")=$P(X,U,2) - . K BPSOSMA("SORT",9999.95) - . D AUTO^BPSOSM1() ; have to do this because of "AE" screen - E D ; released dates: compute equivalent transaction dates - . S BPSOSMA("SORT",9999.95,"FR")=$P(X,U) - . S BPSOSMA("SORT",9999.95,"TO")=$P(X,U,2) - . S X=$$FILE61(X) - . I 'X D - . . W !,"No transactions in this range of released dates?!",! - . S BPSOSMA("SORT",7,"FR")=$P(X,U) - . S BPSOSMA("SORT",7,"TO")=$P(X,U,2) - I 'BPSOSMA("SORT",7,"FR") G B -D ; If in report mode, then get the type of output right now - I BPSOSMA("MODE")="REPORT" D G:X="" C - . S X=$$OUTPUT^BPSOSMZ Q:X="" - . S BPSOSMA("OUTPUT TYPE")=X - W ! G CONTINUE^BPSOSMC -FILE61(X) ; given X = low^high date range of released dates - ; figure out range of transaction dates needed to include all of them - ; This will make the sort efficient. - ; return low^high range of transaction dates - D AUTO^BPSOSM1() ; update last couple days of 9002313.61 - N TLO,THI S TLO=9999999,THI=-1 - N RLO,RHI S RLO=$P(X,U)\1,RHI=$P(X,U,2)\1 ; stored w/o time in .61 - N RDT S RDT=RLO - N IEN61 S IEN61=0 - F D S RDT=$O(^BPSECX("RPT","B",RDT)) Q:'RDT Q:RDT>RHI D - . ; loop through all released on this date - . S IEN61=0 F S IEN61=$O(^BPSECX("RPT","B",RDT,IEN61)) Q:'IEN61 D - . . N IEN57 S IEN57=$P(^BPSECX("RPT",IEN61,0),U,3) - . . N X S X=$P($G(^BPSTL(IEN57,0)),U,8) ; transaction date - . . S:XTHI THI=X - I TLO>THI Q "" ; none?! - Q TLO_U_THI -DEFDATES ; set DEFDATES=start^end default sort dates - N X S X=$O(BPSOSMA("SORT"," ")) ; what are we sorting on? - ; by Patient or by Claim ID, we go back a year - I X="PATIENT"!(X="CLAIM:Claim ID") S DEFDATES=DT-10000 - E S DEFDATES=DT ; for others, it's today only - I $P(DEFDATES,U,2)="" S $P(DEFDATES,U,2)=DT - ; If start date default is today and there are no transactions, - ; set the default start date to yesterday - I $P(DEFDATES,U)=DT,'$O(^BPSTL("AH",DT)) S $P(DEFDATES,U)=$$YESTER - Q -YESTER() Q $$TADD^BPSOSUD(DT,-1) ; yesterday diff -auBN ./r1/BPSOSMC.m ./r2/r/BPSOSMC.m --- ./r1/BPSOSMC.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSMC.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,177 +0,0 @@ -BPSOSMC ;BHAM ISC/FCS/DRS/DLF - General Inquiry/Report .57;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; Local array BPSOSMA() contains the parameters: - ; BPSOSMA("BY WHICH DATE")="TRANSACTION" or "RELEASED" - ; BPSOSMA("MODE")="INQUIRY" or "REPORT" - ; BPSOSMA("SORT",7,"FR")=transaction date/time, start value - ; BPSOSMA("SORT",7,"TO")=transaction date/time, to value - ; BPSOSMA("SORT",9999.95,"FR")=released date/time, start value - ; BPSOSMA("SORT",9999.95,"TO")=released date/time, to value - ; BPSOSMA("SORT",field #,"FR")=other field sort, start value - ; BPSOSMA("SORT",field #,"TO")=other field sort, to value - ; BPSOSMA("OUTPUT TYPE")=one of the codes (see BPSOSMZ for list) -CONTINUE ;EP - continued (via GOTO) from BPSOSMB - N L,DIC,FLDS,BY,FR,TO,DHD,DIASKHD,DIPCRIT,PG,DHIT,DIOEND,DIOBEG - N DCOPIES,IOP,DQTIME,DIS,DISUPNO,DISTOP,DISPAR - N SELECT,ANSCOUNT,X,ACTION -A ; - D DIPSETUP - I BPSOSMA("MODE")="INQUIRY" D INILIST,INIANS - ; - - - - - - - - - - sort and print - - - - - - - - - - - - - I BPSOSMA("MODE")="INQUIRY" W "Searching...",! - D EN1^DIP - I BPSOSMA("MODE")="REPORT" Q ; If in Report mode, we're finished - ; - - - - - Inquiry mode - - - - - display list and select - - - - - - I '@$$LIST@(0) D Q ; If empty list, quit. - . W "No transactions found with these criteria." - W "Found ",@$$LIST@(0)," transactions.",! H 2 -SELECT S SELECT=$$SELECT1 ; we expect to get back "^" - Q:(SELECT="^^")!(SELECT=-1) - S X=0 F ANSCOUNT=0:1 S X=$O(@$$ANSLIST@(X)) Q:X="" - W !,"Selected ",ANSCOUNT," item",$S(ANSCOUNT=1:"",1:"s"),! H 2 - D IEN57 - I 'ANSCOUNT H 2 Q -ACTION S ACTION=$$OUTPUT^BPSOSMZ - I ACTION="" H 2 G SELECT ;Q - D ACTION^BPSOSMD - G ACTION ; otherwise, branch back for more inquiry -SELECT1() ; - N TYPE,LROOT,AROOT,STITLE,PROMPT,OPT,PGLEN,TIMEOUT - S TYPE="M" ; multiple selection - S LROOT=$$OPEN($$LIST) - S AROOT=$$OPEN($$ANSLIST) - S STITLE="Pharmacy ECME - Inquiry Screen" - ;S PROMPT(1)="Select line number(s)" - S OPT=1 ; optional response - S PGLEN=12 ; - S TIMEOUT=600 - D INIANS ; erase any previous answers - N X - S X=$$LIST^BPSOSU4(TYPE,LROOT,AROOT,STITLE,,OPT,PGLEN,TIMEOUT) - Q X -OPEN(X) ;EP - - Q $E(X,1,$L(X)-1)_"," ; convert to open root -LIST() ;EP - Q "^TMP("""_$T(+0)_""","_$J_",""LIST"")" -ANSLIST() ; EP - Q "^TMP("""_$T(+0)_""","_$J_",""ANS"")" -ANSCOUNT() Q @$$ANSLIST@(0) -IENLIST() ; EP - Q "^TMP("""_$T(+0)_""","_$J_",""IEN57"")" -IEN57 ; build IEN57 list based on ANSLIST - N A,B,C S A=$$ANSLIST,B=$$IENLIST,C=$$LIST K @B - N X,IEN57 S X=0 - F S X=$O(@A@(X)) Q:'X D - . S IEN57=@C@(X,"I") - . S @B@(IEN57)="" - Q -INILIST K @$$LIST - S @$$LIST@(0)=0 - S @$$LIST@("Column HEADERs")="2|Presc/Fill:12,Trans. Date:11,Stat:5,Patient and Drug:35" - Q -INIANS K @$$ANSLIST Q - ; -DIPSETUP ; This routine sets up the call to EN1^DIP - S L=0 - S DIC=9002313.57 - D FLDS - D BY - D FR ; FR and TO - D DHD ; header - K DIASKHD ; do not prompt user for a header - S DIPCRIT=1 ; SORT criteria will print in the header of first page - K PG ; start at page 1 - I BPSOSMA("MODE")="INQUIRY" D ; build the list - . S DHIT="D DHIT^"_$T(+0) - E K DHIT - ; DIOEND ; executed at end of printout - ; DIOBEG ; executed before printing begins - ; DCOPIES - ; IOP - I BPSOSMA("MODE")="INQUIRY" S IOP="HOME;80" - ; DQTIME - D DIS ; screens - ; S DISUPNO=1 - S DISTOP="I 1" ; allow user to stop queued print - ; DISTOP("C") - Q -FLDS ; Which fields to print? If inquiry mode: print no fields - I BPSOSMA("MODE")="INQUIRY" S FLDS="""""" Q - ; Report mode: set to the appropriate template. - ; Temporary - just to put something in there. - S FLDS="[CAPTIONED]" - Q -BY ; Which fields to sort on? - I '$D(BPSOSMA("SORT")) K BY Q ; doing Fileman sort; leave BY undef - ; Always primary sort is on transaction date. - S BY="@-LAST UPDATE" - I BPSOSMA("BY WHICH DATE")="RELEASED" S BY=BY_",@9999.95" - N F S F="" - F S F=$O(BPSOSMA("SORT",F)) Q:F="" D - . Q:F=7 Q:F=9999.95 ; one of the date fields we already have - . S BY=BY_",@"_F ; append - S BY=BY_",@NUMBER" ; tie breaker - Q -FR ; FR and TO range of sort - ; order must correspond with order of BY fields - S (FR,TO)="" - N F F F=7,9999.95 D FR1 - S F="" - F S F=$O(BPSOSMA("SORT",F)) Q:F="" I F'=7,F'=9999.95 D FR1 - S FR=FR_",",TO=TO_"," ; NUMBER sort - Q -FR1 ; - Q:'$D(BPSOSMA("SORT",F)) - S:FR]"" FR=FR_"," S FR=FR_BPSOSMA("SORT",F,"FR") - S:TO]"" TO=TO_"," S TO=TO_BPSOSMA("SORT",F,"TO") - Q -DHD ; Header - I BPSOSMA("MODE")="INQUIRY" S DHD="W !,""Searching...""" - Q -DIS ; screens - K DIS - N I F I=0:1 Q:'$D(BPSOSMA("SCREEN",I)) S DIS(I)=BPSOSMA("SCREEN",I) - Q -DHIT ;EP - called here indirectly when in Inquiry mode and a hit is found - ;W "." W:$X>70 ! - N IEN57,NLINE,DATA,X S IEN57=D0 ; D0 points to the entry - S (NLINE,@$$LIST@(0))=@$$LIST@(0)+1 - ; Line number - comes automatically, we don't need to put it in. - S DATA="" ;$J(NLINE,4)_" " - ; Prescription and fill number - S DATA=DATA_$J("`"_$$RXI^BPSOS57,9) - S X=$$RXR^BPSOS57 - I X D - . S DATA=DATA_"/"_X - . I X<10 S DATA=DATA_" " - E S DATA=DATA_" " - S DATA=DATA_" " - ; Transaction date - S X=$P(^BPSTL(IEN57,0),U,8) - N XD,XT S XD=$P(X,"."),XT=$P(X,".",2) - N SY S SY=$E(X,2,3)=$E(DT,2,3) ; SY = same year? - I DT=XD S XD="T" - E I DT-1=XD S XD="T-1" - E I DT-2=XD S XD="T-2" - E S XD=+$E(XD,4,5)_"/"_+$E(XD,6,7)_$S(SY:"",1:"/"_$E(XD,2,3)) - S XD=XD_"@"_+$E(XT,1,2) - I $L(XD)<9 S XD=XD_":"_$E(XT,3,4) - S DATA=DATA_$E(XD_" ",1,11)_" " - ; Result - S X=$$GET1^DIQ(9002313.57,IEN57_",","RESULT WITH REVERSAL") - I X]"" D - . N Y S Y=$O(^BPSF(9002313.83,"B",X,0)) - . I Y S Y=$P(^BPSF(9002313.83,Y,0),U,2) - . I Y]"" S X=Y - S X=$E(X_" ",1,5) - S DATA=DATA_X_" " - ; Patient and drug - S X=$$PATIENT^BPSOS57 - I X S X=$P($G(^DPT(X,0)),U) ; just last,first - I X[" " S X=$P(X," ")_" "_$E($P(X," ",2)) ; and middle initial - S X=X_" / "_$$DRGNAME^BPSOS57 - S DATA=DATA_$E(X_$J("",35),1,35) - S @$$LIST@(NLINE,"E")=DATA - S @$$LIST@(NLINE,"I")=IEN57 - Q diff -auBN ./r1/BPSOSM.m ./r2/r/BPSOSM.m --- ./r1/BPSOSM.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSM.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,66 +0,0 @@ -BPSOSM ;BHAM ISC/FCS/DRS/DLF - Report Master (.61) ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; BPSOSM1 - takes care of updating of file .61 - ; BPSOSM2 - some report headers called from Print options - ; BPSOSMA-BPSOSM* for lowercase * - general inquiry/report on .57 - ; - Q -MESSAGE(IEN57,N) ;EP - message sent in e-claim response - I 'IEN57 Q "" - N RESP,POS D RESPPOS(IEN57) Q:'RESP!'POS "" - I '$D(N) S N=0 - I N=1 Q $$MESSAGE^BPSOS03(RESP,POS,1) - I N=2 Q $$MESSAGE^BPSOS03(RESP,POS,2) - Q $$MESSAGE^BPSOS03(RESP,POS) -RESPPOS(IEN57) ;EP - caller should N RESP,POS - I $G(^BPSTL(IEN57,4)) D ; reversal - . S RESP=$P(^BPSTL(IEN57,4),U,2) - . S POS=1 - E D - . S RESP=$P(^BPSTL(IEN57,0),U,5) - . S POS=$P(^BPSTL(IEN57,0),U,9) - Q - ; Computed fields: -INSHELP(D0) ;EP - (#10002) INSURER HELP # - N X S X=$P($G(^BPSECX("RPT",D0,0)),U,3) I 'X Q "" ; IEN57 - S X=$P($G(^BPSTL(X,1)),U,6) I 'X Q "" ; INSURER - S X=$G(^BPSEI(X,100)) I X="" Q "" ; insurer pharm e-claims info - N Y S Y=$P(X,U,5) I Y]"" Q Y ; specific phone # for insurer - S X=$P(X,U) I 'X Q "" ; format - Q $P($G(^BPSF(9002313.92,X,1)),U,5) ; phone # as stored with format -RELTIME(D0) ;EP - (#10003) RX RELEASED DATE/TIME - N RXI,RXR D D0RXIRXR - I RXI=""!(RXR="") Q "" ; should never happen - I RXR Q $P($G(^PSRX(RXI,1,RXR,0)),U,17) - E Q $P($G(^PSRX(RXI,2)),U,13) -RETSTOCK(D0) ;EP - (#10004) RX RETURNED TO STOCK - N RXI,RXR D D0RXIRXR - I RXI=""!(RXR="") Q "" ; should never happen - I RXR Q +$P($G(^PSRX(RXI,1,RXR,0)),U,16) - E Q +$P($G(^PSRX(RXI,2)),U,15) -DELETED(D0) ; EP - (#10001) RX DELETED - N RXI,RXR D D0RXIRXR - I RXI=""!(RXR="") Q "" ; should never happen - Q $$RXDEL^BPSOS(RXI,RXR) -QTY(D0) ;EP - - N RXI,RXR D D0RXIRXR Q:RXI=""!(RXR="") - I RXR Q $P($G(^PSRX(RXI,1,RXR,0)),U,4) - E Q $P($G(^PSRX(RXI,0)),U,7) -D0RXIRXR ; set up RXI,RXR,R for computed fields for ien D0 - N X S X=$G(^BPSECX("RPT",D0,0)),RXI=$P(X,U,4),RXR=$P(X,U,5) - Q -RELDATE(D0) ; - N VAL - S VAL=$P($G(^BPSECX("RPT",D0,0)),"^",1) - I VAL?1N.N N Y S Y=VAL D DD^%DT S VAL=Y - Q VAL - ; -GREVDT(D0) ; - N CIEN,VAL,VAR - S VAL="" - S CIEN=$P($G(^BPSC(D0,4)),"^") - I CIEN'="" S VAL=$P($G(^BPSC(CIEN,0)),"^",5) - Q VAL -SORTDT(D0) ; - Q $P($G(^BPSECX("RPT",D0,0)),"^",$P($G(^TMP($J,"REPORT")),"^",3)) diff -auBN ./r1/BPSOSMZ.m ./r2/r/BPSOSMZ.m --- ./r1/BPSOSMZ.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSMZ.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,92 +0,0 @@ -BPSOSMZ ;BHAM ISC/FCS/DRS/DLF - General Inquiry/Report .57;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -ASKPHARM() ; EP - Lookup pharmacy (the ECME pharmacy, that is) - ; Return pointer to 9002313.56 - N DIC,X,Y,DINUM,DTIME,DLAYGO - S DIC=9002313.56,DIC(0)="AEMQ" - D ^DIC - Q $S(Y>0:+Y,1:"") -ASKPAT() ; EP - Lookup patient - patient must have a ECME transaction - ; Return patient IEN, return false if none selected - N DIC,X,Y,DINUM,DTIME,DLAYGO - S DIC=2,DIC(0)="AEMQ" - S DIC("S")="I $D(^BPSTL(""AC"",Y))" - D ^DIC - Q $S(Y>0:+Y,1:"") -ASKRTYPE() ; EP - Lookup result type - ; Return the name of the result type, null if none selected - N DIC,X,Y,DINUM,DTIME,DLAYGO - S DIC=9002313.83,DIC(0)="AEMQ" - D ^DIC - Q $S(Y>0:$P(^BPSF(9002313.83,+Y,0),U),1:"") -OUTPUT() ; EP - ask for output type - ; Returns one of the codes in OUTMENU, below. Or "" if no selection. - N DIR,X,Y - S DIR(0)="SAO^" - S DIR("A")="Select style of output: " - N I,X W !! F I=1:1 S X=$P($T(OUTMENU+I),";",2) Q:X="*" D - . S DIR(0)=DIR(0)_X_";" - . W ?5,$P(X,":"),?10,$P(X,":",2),! - S DIR("B")=$G(BPSOSMA("OUTPUT TYPE")) S:DIR("B")="" DIR("B")="S" - D ^DIR - Q $S("^^"[Y:"",1:Y) -OUTMENU ; - ;D:DUR info only - ;F:Financial Detail - ;C:Claim - Basic info - ;S:Transaction Summary only - ;R:Response info - ;J:Rejection Codes Detail - ;* - ;T:Total Detail - ;REC:Summary Receipt - ;PT:Print Template selection - ;FM:Fileman to customize output -DEFOUT() ; EP - return code of first item in OUTMENU - N X S X=$T(OUTMENU+1) - Q $P($P(X,";",2),":") -SORTDATE() ; EP - ask which date to sort by - ; Returns "T" for transaction date, "R" for released date, or "" - N DIR,X,Y S DIR(0)="SAO^" - S DIR("A")="Select by which date? " - S DIR("B")="T" - N I,X W !! F I=1:1 S X=$P($T(DATEMENU+I),";",2) Q:X="*" D - . S DIR(0)=DIR(0)_X_";" - . W ?5,$P(X,":"),?10,$P(X,":",2),! - D ^DIR - Q $S("^^"[Y:"",1:Y) -DATEMENU ; - ;T:Transaction date - ;R:Released date - ;* -DATES(DEF) ; EP - - N PR1,PR2,DEF1,DEF2 - S PR1="Starting with "_BPSOSMA("BY WHICH DATE")_" date: " - S PR2=" Going thru "_BPSOSMA("BY WHICH DATE")_" date: " - S DEF1=$P(DEF,U),DEF2=$P(DEF,U,2) - ;I BPSOSMA("BY WHICH DATE")="TRANSACTION" D - ;. S DEF1=$G(BPSOSMA("SORT",7,"FR")) - ;. S DEF2=$G(BPSOSMA("SORT",7,"TO")) - ;E D - ;. S DEF1=$G(BPSOSMA("SORT",9999.95,"FR")) - ;. S DEF2=$G(BPSOSMA("SORT",9999.95,"TO")) - I 'DEF2 S DEF2=$E($$NOW^BPSOS,1,7+1+2+2) ; today (down to the minute) - I 'DEF1 S DEF1=$$TADD^BPSOSUD(DEF2\1,-7) ; a week ago - W ! - Q $$DTR^BPSOSU1(PR1,PR2,DEF1,DEF2,"T") -MODE() ; EP - ask which mode to run in - Inquiry or Report - ; Returns "I" for inquiry mode, "R" for report mode, or "" - N DIR,X,Y S DIR(0)="SAO^" - S DIR("A")="Inquiry or Report mode? " - S DIB("B")="I" - N I,X W !! F I=1:1 S X=$P($T(MODEMENU+I),";",2) Q:X="*" D - . S DIR(0)=DIR(0)_X_";" - . W ?5,$P(X,":"),?10,$P(X,":",2),! - S DIR("B")=$E($G(BPSOSMA("MODE"))) S:DIR("B")="" DIR("B")="I" - D ^DIR - Q $S("^^"[Y:"",1:Y) -MODEMENU ; - ;I:Inquiry mode (choose from list) - ;R:Report mode (just print, no choosing) - ;* diff -auBN ./r1/BPSOSN0.m ./r2/r/BPSOSN0.m --- ./r1/BPSOSN0.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSN0.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,15 +0,0 @@ -BPSOSN0 ;BHAM ISC/FCS/DRS/DLF - NCPDP forms ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; Routines BPSOSN1-BPSOSN8 are included in the kit. - ; They are for printing NCPDP forms with the ILC A/R package. - ; The ABSB NCPDP xxxxx options are not included in the kit. - ; They still point to the ABSBNRX* routines. - ; Long term goal: replace the ABSBNRX* routines - ; with these BPSOSN* routines and try to decouple them from - ; the A/R structures as much as possible. - ; - ; BPSOSNC is not an NCPDP form routine, - ; though it happens to be in this same namespace. - ; "NC" stands for "Nightly Checker", the ANMC process which - ; first inspired the need for an external query of ECME status - ; given a V MEDICATION pointer. diff -auBN ./r1/BPSOSN4.m ./r2/r/BPSOSN4.m --- ./r1/BPSOSN4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSN4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,34 +0,0 @@ -BPSOSN4 ;BHAM ISC/FCS/DRS/DLF - NCPDP Fms F ILC A/R ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -PFM ;EP - ; - N XXX - S $P(XXX,"X",80)="" - N I F I=1:1:3 D - .W ! - .W ?7,$E(XXX,1,15),?31,$E(XXX,1,20),!! - .W ?6,$E(XXX,1,33),?46,"X",!!! - .W ?5,$E(XXX,1,23),?29,$E(XXX,1,19),! - .W ?49,$E(XXX,4,5),?52,$E(XXX,6,7) - .W ?55,$E(XXX,2,3) - .W ?58,"X",?60,"X",?63,"X",?66,"X",?69,"X",?72,"X",! - .W ?5,$E(XXX,1,23),! - .W ?56,"XXXX.XX",?64,"XXXX.XX",! - .W ?5,$E(XXX,1,23),! - .W ?56,"XXXX.XX",?64,"XXXX.XX",! - .W ?6,$E(XXX,1,13),?20,$E(XXX,4,5) - .W ?23,$E(XXX,6,7),?26,$E(XXX,2,3),!! - .W ?6,$E(XXX,1,13),?20,$E(XXX,4,5) - .W ?23,$E(XXX,6,7),?26,$E(XXX,2,3),! - .W ?56,"XXXX.XX",?64,"XXXX.XX",!! - .W ?4,$E(XXX,1,7),?12,$E(XXX,1,1) - .W ?15,$E(XXX,1,5),?21,$E(XXX,1,4) - .W ?26,$E(XXX,1,7),?34,$E(XXX,1,6) - .W ?41,$E(XXX,1,2),?44,$E(XXX,1,9),!! - .W ?4,$E(XXX,1,7),?12,$E(XXX,1,1) - .W ?15,$E(XXX,1,5),?21,$E(XXX,1,4) - .W ?26,$E(XXX,1,7),?34,$E(XXX,1,6) - .W ?41,$E(XXX,1,2),?44,$E(XXX,1,9) - .W ?56,"XXXX.XX",?64,"XXXX.XX",!! - Q diff -auBN ./r1/BPSOSN7.m ./r2/r/BPSOSN7.m --- ./r1/BPSOSN7.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSN7.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,41 +0,0 @@ -BPSOSN7 ;BHAM ISC/FCS/DRS/DLF - NCPDP Fms F ILC A/R ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- -WCENTER(TEXT,MARGIN) ; - W ?MARGIN-$L(TEXT)/2,TEXT,! - Q - ;---------------------------------------------------------------------- - ;Display screen header -HEADER(TEXT) ;EP - W @IOF - W ! - D WCENTER(TEXT,80) - D WCENTER($TR($J("",$L(TEXT))," ","-"),80) - Q - ;---------------------------------------------------------------------- - ;Device PROMPT (returns %ZIS variables eg: IOM, IOSL, IOF....) -DEVICE(PROMPT,EXIT) ;EP - N %ZIS,POP - W !! - S %ZIS="" - S %ZIS("A")=PROMPT - S %ZIS("B")="" - D ^%ZIS - I POP S EXIT=1 Q - U IO - Q - ;--------------------------------------------------------------------- -YNPROMPT(PROMPT,DFLT) ;EP - N %,%Y,U - S U="^" - S %=$S(DFLT="Yes":1,DFLT="No":2,1:0) - W PROMPT - D YN^DICN - Q $S(%=1:"Yes",%=2:"No",1:"") - ;-------------------------------------------------------------------- -CONTINUE(EXIT) ;EP - N DIR,X,Y - S DIR(0)="E" D ^DIR - S:Y=0 EXIT=1 - Q - ;-------------------------------------------------------------------- diff -auBN ./r1/BPSOSO1.m ./r2/r/BPSOSO1.m --- ./r1/BPSOSO1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSO1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,54 +0,0 @@ -BPSOSO1 ;BHAM ISC/FCS/DRS - NCPDP Override Main menu ;09/03/2002 11:14 AM - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;--------------------------------------------------------------- - ; IHS/SD/lwj 9/3/02 NCPDP 5.1 changes - ; In 3.2, prior authorization was updated and stored in field 416. - ; In 5.1, 416 is obsolete, and the information could be stored - ; in field 461, and 462 or in the prior authorization segment. - ; For now, the insurer/processors appear to be using 461, and - ; 462 rather than the segment. In any case, we needed to change - ; the way we capture prior authorization information - AND - we - ; have to keep populating 416 since we have to still process 3.2 - ; claims. This routine was changed to call PRIORA in BPSOSo2 - ; rather than EDIT^BPSOSO2 when we are processing a prior auth. - ;(Field prompts also altered to match 5.1 standards.) - ;--------------------------------------------------------------- - Q -TEST D MENU("") Q -MENU(IEN) ;EP - - D SETLIST - N PROMPT S PROMPT(1)="Select which claim data you wish to override." - S PROMPT(2)="Use ^ to exit this menu." - N SEL F D Q:'SEL Q:SEL=-1 - . S SEL=$$LIST^BPSOSU4("S",$$LISTROOT,$$ANSROOT,"Override Claim Defaults",.PROMPT,1,20,$S($G(DTOUT):DTOUT,1:300)) - . I SEL W ! H 1 D @$P($T(LIST+SEL),";",4) ; - Q -LISTROOT() Q "^TMP("""_$T(+0)_""","_$J_"," -ANSROOT() Q "^TMP("""_$T(+0)_""","_($J+.1)_"," -SETLIST K ^TMP("BPSOSO1",$J),^TMP("BPSOSO1",$J+.1) - N I,X F I=1:1 D Q:X="*" - . S X=$T(LIST+I),X=$P(X,";",2,$L(X)) Q:X="*" - . S ^TMP("BPSOSO1",$J,I,"I")=$P(X,";") - . S ^TMP("BPSOSO1",$J,I,"E")=$P(X,";",2) - S ^TMP("BPSOSO1",$J,0)=I-1 - Q - ; - ; IHS/SD/lwj 9/3/02 - the following 3 lines were removed from LIST - - ; new 1 - 3 lines were added to replace them - ;1;Preauthorization #;EDIT^BPSOSO2(IEN,416) - ;2;Person Code;EDIT^BPSOSO2(IEN,303) - ;3;Relationship Code;EDIT^BPSOSO2(IEN,306) - ; - ; IHS/SD/lwj 9/3/02 - since still unimplemented, the following - ; lines were removed from the menu options in LIST - ;I;Order of insurance;NOTIMP - ;P;Pricing;NOTIMP - ; -LIST ; - ;1;Prior Authorization;PRIORA^BPSOSO2(IEN) ;IHS/SD/lwj 9/3/02 - ;2;Patient Gender Code;EDIT^BPSOSO2(IEN,303) - ;3;Patient Relationship Code;EDIT^BPSOSO2(IEN,306) - ;4;Eligibility Clarification Code;EDIT^BPSOSO2(IEN,309) - ;*;Enter/edit/override any NCPDP field;EDIT^BPSOSO2(IEN) - ;* -NOTIMP W !,"That option isn't yet implemented.",! N % R %:3 Q diff -auBN ./r1/BPSOSO2.m ./r2/r/BPSOSO2.m --- ./r1/BPSOSO2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSO2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,182 +0,0 @@ -BPSOSO2 ;BHAM ISC/FCS/DRS/DLF - NCPDP Override-Fman utils ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; EDIT,EDITGEN are called from the menus in BPSOSO1, - ; typically reached from the pharmacy package's call - ; to OVERRIDE^BPSOSO - ; GET511 is called from BPSOSCD during claim construction - ; - ;IHS/SD/lwj 8/01/02 NCPDP 5.1 changes to GET511 subroutine - ; Routine was changed to look at an exceptions list, if the - ; field being processed is in the exceptions list it will - ; create a "claim header" and "claim rx" entry. The reason - ; for this is that several 300 range fields were moved to the - ; claim rx area within the 5.1 segments creating duplicate flds. - ; (i.e. the <402 and >402 rule is no longer valid) - ; - ; New routine (PRIORA) added to handle the input of the prior - ; authorization information at prescription creation time. - ; -EDIT(IEN,FIELDNUM) ; - I '$D(FIELDNUM) D EDITGEN(IEN) Q - ; Editing one field - N DIE,DA,DR,DIDEL,DTOUT,FIELDNAM - S DA=$$HASVALUE(IEN,FIELDNUM) - ; Make sure the entry exists in the subfile. - ; Create an empty one if necessary. - I 'DA S DA=$$SETVALUE(IEN,FIELDNUM,"") - ; edit the value field in the subfile - S DIE="^BPS(9002313.511,"_IEN_",1,",DA(1)=IEN - S DR=.02_$TR($$FIELDNAM(FIELDNUM),""";~","") - D ^DIE - ; If the value is null, then delete the entire FIELDNUM entry - I $$GETVALUE(IEN,FIELDNUM)="" D DELVALUE(IEN,FIELDNUM) - Q -EDITGEN(IEN) ; general edit - ; First pass: quick & dirty Fileman ^DIE call - ; Future: Screenman interface - N DIE,DA,DR,DIDEL,DTOUT - S DA=IEN,DIE=$$FILENUM,DR=1 D ^DIE - ; And we need to delete any entries with null values - N A S A=0 F S A=$O(^BPS(9002313.511,IEN,1,A)) Q:'A D - . N X S X=^BPS(9002313.511,IEN,1,A,0) - . I $P(X,U,2)="" D - . . N FIELDNUM S FIELDNUM=$P(^BPSF(9002313.91,$P(X,U),0),U) - . . D DELVALUE(IEN,FIELDNUM) - Q -GET511(IEN,ARR101,ARR402) ;EP - from BPSOSCD - load arrays with data from IEN - ; IHS/SD/lwj 8/1/02 altered for NCPDP 5.1 - must store some - ; 300 range fields at the "header" and "detail" level due to - ; restructing of 5.1 claim segments - ; - N A,C S A=0,C=0 - N EXPTLST,TFLD ;IHS/SD/lwj 8/1/02 - ; - S EXPTLST=",308,315,316,317,318,319,320,327," ;IHS/SD/lwj 8/1/02 - ; - F S A=$O(^BPS(9002313.511,IEN,1,A)) Q:'A D - . N X S X=^BPS(9002313.511,IEN,1,A,0) - . N F S F=$P(X,U) ; field IEN, points to 9002313.91 - . ; store in either claim header or claim detail, based on field # - . I $$FIELDNUM(F)<402 S @ARR101@(F)=$P(X,U,2) - . E S @ARR402@(F)=$P(X,U,2) - . ; - . ; IHS/SD/lwj 8/1/02 nxt 2 lns added to check for exception flds - . S TFLD=","_$$FIELDNUM(F)_"," - . I EXPTLST[TFLD S @ARR402@(F)=$P(X,U,2) - . ; - . S C=C+1 - Q C - ; - ; Generalized utilities - good for everything, not just auth # -LOCK() L +^BPS(9002313.511,IEN):300 Q $T -UNLOCK L -^BPS(9002313.511,IEN) Q -FILENUM() Q 9002313.511 -SUBFNUM() Q 9002313.5111 -FLOCK() L +^BPS(9002313.511):300 Q $T -FUNLOCK L -^BPS(9002313.511) Q -FIELDIEN(FIELDNUM) ; ien of a 9002313.91 NCPDP Data Dictionary field - Q $$FIND1^DIC(9002313.91,,,FIELDNUM) -FIELDNAM(FIELDNUM) ; name of a 9002313.91 NCPDP Data Dictionary field - Q $$GET1^DIQ(9002313.91,$$FIELDIEN(FIELDNUM),.03) - ; given pointer to NCPDP Data Dictionary fields, return external # -FIELDNUM(IEN91) Q $P($G(^BPSF(9002313.91,IEN91,0)),U) -NEW() ;EP - create new entry in 9002313.511 - F Q:$$FLOCK Q:'$$IMPOSS^BPSOSUE("L","RTI","interlock on new Override record creation",,"NEW",$T(+0)) - N FLAGS,FDA,IEN,MSG,FN,X,NEWREC S FN=$$FILENUM - D NEW1 - D FUNLOCK - Q NEWREC -NEW1 ; - S FDA(FN,"+1,",.01)=$O(^BPS(FN,"B",999999999999),-1)+1 - D UPDATE^DIE(,"FDA","IEN","MSG") - I $D(MSG) D G NEW1:$$IMPOSS^BPSOSUE("FM","TRI","UPDATE^DIE failed",,"NEW1",$T(+0)) - . D ZWRITE^BPSOS("FDA","IEN","MSG") - . K MSG - S NEWREC=IEN(1) -NEW2 ; - S FDA(FN,NEWREC_",",.02)="NOW" - D FILE^DIE("E","FDA","MSG") - Q:'$D(MSG) ; success - G NEW2:$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"NEW2",$T(+0)) - Q -HASVALUE(IEN,FIELDNUM) ; does the FIELDNUM have an override value? - ; returns IEN into the subfile - Q $$FIND1^DIC($$SUBFNUM,","_IEN_",",,FIELDNUM) -GETVALUE(IEN,FIELDNUM) ; return currently-set override value for given FIELDNUM - N X S X=$$HASVALUE(IEN,FIELDNUM) I 'X Q "" - Q $$GET1^DIQ($$SUBFNUM,X_","_IEN_",",.02) -SETVALUE(IEN,FIELDNUM,VALUE) ; - ; can DO or $$; $$ = ien in subfile for this FIELDNUM - ; Special case for the override file: if you're trying to set the - ; field's value to "@", don't just delete the field value, - ; which would leave the field defined with a null value. - ; Instead, delete the entire override for the field. - ; This prevents accidentally overriding a genuine value with null. - I "@"=VALUE D DELVALUE(IEN,FIELDNUM) Q "" - ; But the usual case is just storing a value: - N FDA,MSG,IENS,IENARRAY - ; Note: I tried the "+?1,ien," method but it always created a new - ; entry, even when it meant creating duplicates. So now we test to - ; see if there's already an entry for the fieldnum, and if not, - ; then we put in a "+1," - N ENTRY S ENTRY=$$HASVALUE(IEN,FIELDNUM) ; do we already have FIELDNUM - I 'ENTRY S ENTRY="+1" ; if not, then create a new entry - S IENS=ENTRY_","_IEN_"," - S FDA($$SUBFNUM,IENS,.01)=FIELDNUM - S FDA($$SUBFNUM,IENS,.02)=VALUE - D SETV1 - I ENTRY="+1" S ENTRY=$G(IENARRAY(1)) - Q ENTRY -SETV1 ; - D UPDATE^DIE("E","FDA","IENARRAY","MSG") - Q:'$D(MSG) ; success - K ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE") - S ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE")=$$ERRHDR - M ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE","MSG")=MSG - I $D(IENARRAY) M ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE","IENARRAY")=IENARRAY - D ZWRITE^BPSOS("FDA","IENARRAY","MSG") - G SETV1:$$IMPOSS^BPSOSUE("FM","TRI",,,"SETVALUE",$T(+0)) - Q -DELVALUE(IEN,FIELDNUM) ; - N ENTRY S ENTRY=$$HASVALUE(IEN,FIELDNUM) Q:'ENTRY ; wasn't defined - N FDA,MSG - S FDA($$SUBFNUM,ENTRY_","_IEN_",",.01)="@" -DE5 D FILE^DIE("E","FDA","MSG") - Q:'$D(MSG) ; success - K ^TMP("BPS",$J,"BPSOSO2",$J,"DELVALUE") - S ^TMP("BPS",$J,"BPSOSO2",$J,"DELVALUE")=$$ERRHDR - D ZWRITE^BPSOS("IEN","FDA","MSG") - G DE5:$$IMPOSS^BPSOSUE("FM","TRI",,,"DELVALUE",$T(+0)) - Q -ERRHDR() Q "ERROR AT $H="_$H_" FOR $J="_$J -SEE(IEN) N TMP M TMP=^BPS($$FILENUM,IEN) D ZWRITE^BPSOS("TMP") Q ; debugging - ; -PRIORA(IEN) ;IHS/SD/lwj 9/3/02 NCPDP 5.1 Changes - Prior Authorization - ; We are still processing 5.1 and 3.2 claims, so we have to be able - ; to populate fields 461, 462 and 416. 416 will be created based - ; on the input into fields 461, and 462. - ; - N FIELDNUM - ; - S FIELDNUM=461 ;Prior authorization type code - D EDIT(IEN,FIELDNUM) - ; - S FIELDNUM=462 ;Prior authorization number submitted - D EDIT(IEN,FIELDNUM) - ; - ;now we combine field 461 and 462 to creat field 416 - ; - N VAL461,VAL462,VAL416,DA - S (VAL461,VAL462,VAL416)="" - ; - S VAL461=$$GETVALUE(IEN,461) - S VAL462=$$GETVALUE(IEN,462) - S VAL416=VAL461_VAL462 - Q:VAL416="" - ; - S DA=$$SETVALUE(IEN,416,"") - S:$G(DA)'="" DA=$$SETVALUE(IEN,416,VAL416) - ; - ; - Q diff -auBN ./r1/BPSOSO3.m ./r2/r/BPSOSO3.m --- ./r1/BPSOSO3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSO3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSO3 ; IHS/FCS/DRS - NO DESCRIPTION PROVIDED ; JUN 22 2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSO4.m ./r2/r/BPSOSO4.m --- ./r1/BPSOSO4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSO4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSO4 ; IHS/FCS/DRS - NO DESCRIPTION PROVIDED ; JUN 22 2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSO5.m ./r2/r/BPSOSO5.m --- ./r1/BPSOSO5.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSO5.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,3 +0,0 @@ -BPSOSO5 ; IHS/FCS/DRS - NO DESCRIPTION PROVIDED ; JUN 22 2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q diff -auBN ./r1/BPSOSQ1.m ./r2/r/BPSOSQ1.m --- ./r1/BPSOSQ1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQ1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,88 +0,0 @@ -BPSOSQ1 ;BHAM ISC/FCS/DRS/DLF - ECME background, Part 1 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; This is usually started by Taskman call in TASK^BPSOSIZ - ; - ; For all with status 0, LOOP loops and calls CLAIMINF() - ; to fill in any missing information. Pricing, for example, - ; may or may not have already been determined. - ; Sets status = 10 while it's working on a request. - ; Sets status = 30 when it's done - and then it's ready for BPSOSQ2 - ; If there were problems with the claim, the status will be set = 99. - ; - ; Also deals with status = 19 (special for Oklahoma Medicaid) - ; - ; BPSOSQ - contains many useful $$ calls - ; Here in BPSOSQ1: - ; The big outer loop through ^BPST("AD",0,*) - ; and Task manager calls to start up ^BPSOSQ2 - ; Extensions of BPSOSQ1: - ; BPSOSQA - ONE59 - ; BPSOSQB - CLAIMINF - ; BPSOSQC - some CLAIMINF subroutines - ; BPSOSQD - data for certain a/r interfaces - ; BPSOSQS - special queuing for Oklahoma Medicaid 3 highest prices - ; - ;-------------------------------------------------------------- - ;IHS/SD/lwj 11/04/02 on behalf of IHS/OKCAO/POC - ; Set ZTREQ to delete the task after it completes in task man - ; - ;------------------------------------------------------------- - Q -LOOP ; line item detail: your work list is ^BPST("AD",0) - N ERROR,PREVPAT,THISPAT,COUNT,PACKETER S PACKETER=0 - N IEN59,ABSBRXI,ABSBRXR,ABSBNDC,MODULO - N ABSBPATI,ABSBPDIV,ABSBSDIV,ABSBVISI,BPSHARM,INSURER - N VMEDDFN,APCDVCN - ; - ;IHS/SD/lwj 11/04/02 on behalf of IHS/OKCAO/POC 11/04/02 - I $D(ZTQUEUED) S ZTREQ="@" ;delete task if complete - ; - ;IHS/SD/lwj 11/04/02 end change - ; - S MODULO=4 ; interval at which we start up a packeter program - S COUNT=0 - F S IEN59=$$NEXT59 Q:'IEN59 D - . D INIT^BPSOSL(IEN59,1) ; logging (don't delete old data) - . D ONE59^BPSOSQA ; process this claim - . D LOG^BPSOSL("BPSOSQ1") - . D RELSLOT^BPSOSL ; release logging slot - ; Deal with the status 19s (special for Oklahoma Medicaid bundling) - I $D(^BPST("AD",19)) D - . I $$STAT19^BPSOSQS D ; if any 19s pushed to status 30, then - . . S COUNT=.1 ; force packeter to start - I COUNT#MODULO'=0 D PACKETER - Q -NEXT59() ; Get the next entry with Status = 0 - ; If there is one, change its status to 10 - ; (says "Gathering claim information") - ; (Being very careful to LOCK access while you're getting the entry - ; and changing its status.) - ; Timed lock and resulting complications is a hassle but not a mess. - L +^BPST:300 - I '$T D Q 0 ; lock failed?! - . D TASK^BPSOSIZ ; try again - requeue this job - S IEN59=$O(^BPST("AD",0,0)) - I IEN59 D SETSTAT(10) - L -^BPST - Q IEN59 -SETSTAT(NEWSTAT) ;EP - from BPSOSQA - N ABSBRXI S ABSBRXI=IEN59 ; unfortunate variable name convention - D SETSTAT^BPSOSU(NEWSTAT) - Q -PACKETER ;EP - from BPSOSAN,BPSOSQA - ; tell the packetizer it's time to get working - ; But only if there are claims in status 30 - I $O(^BPST("AD",30,0)) D TASK - Q -TASK ;EP - from BPSOS2D,BPSOS6D,BPSOS6L,BPSOSQ2,BPSOSQ4 - N X,%DT,Y S X="N",%DT="ST" D ^%DT - D TASKAT(Y) - I $D(PACKETER) S PACKETER=PACKETER+1 ; note: "we started the packeter" - Q -TASKAT(ZTDTH) ;EP - from BPSOSQ4 (requeue if insurer is sleeping) - ; called here from BPSOSQS - - ;N (DUZ,PACKETER,ZTDTH) N ZTRTN - N ZTRTN,ZTIO - S ZTRTN="PACKETS^BPSOSQ2",ZTIO="" - D ^%ZTLOAD diff -auBN ./r1/BPSOSQ2.m ./r2/r/BPSOSQ2.m --- ./r1/BPSOSQ2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQ2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,159 +0,0 @@ -BPSOSQ2 ;BHAM ISC/FCS/DRS/DLF - form transmission packets ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 -PACKETS ; construct packets for transmission to NDC - N ERROR,SILENT S SILENT=1 - N RXILIST,STATUS30 - D STATUS31^BPSOSQF ; deal with insurer alseep waiting - F STATUS30=30 I $D(^BPST("AD",STATUS30)) D STATUS30 - ; If there are still any claims with status 30, - ; perhaps due to failed LOCK59, queue up BPSOSQ2 to run again - N NEEDQ1 S NEEDQ1=$O(^BPST("AD",30,0)) - I NEEDQ1 H 60 D TASK^BPSOSQ1 - Q -SETSTAT(NEWSTAT) ;EP - BPSOSQF ; given IEN59 - N ABSBRXI S ABSBRXI=IEN59 ; unfortunate variable naming convention - D SETSTAT^BPSOSU(NEWSTAT) - Q -SETRESU(RESCODE,TEXT) ; given IEN59 - N ABSBRXI S ABSBRXI=IEN59 ; unfortunate variable naming convention - D SETRESU^BPSOSU(RESCODE,TEXT) - Q -LOCK59() ;EP - BPSOSQF - L +^BPST("AD",STATUS30):60 Q $T -UNLOCK59 ;EP - BPSOSQF - L -^BPST("AD",STATUS30) Q -NEXT59(X) ;EP - BPSOSQF - N INS,T -N59A ; - ;LJE;6/25/03; If it's a VA prescriptions go to the VAN59A subroutine - I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) G VAN59A - S X=$O(^BPST("AD",STATUS30,X)) - I X="" Q X ; end of list, return "" - ; but if the insurer is asleep, don't take this one - S INS=$P(^BPST(X,1),U,6) - S T=$P($G(^BPSEI(INS,101)),U) ; insurer asleep retry time - I 'T Q X ; insurer is not asleep - ; - below here - insurer is asleep - - ; If cancellation is requested, let it through, regardless of sleep. - ; This will speed it on its way to cancellation - I $G(^BPST(X,3)) Q X - ; If necessary, update the .59's record of when to retry - I $P($G(^BPST(X,8)),U)'=T D ; - . S $P(^BPST(X,8),U)=T ; stamp with latest retry time - . N IEN59 S IEN59=X D SETSTAT(31) ; force screen update, too - . D LOG59^BPSOSQ("Insurer still asleep - retry at "_T,IEN59) - I T<$$NOW Q X ; time to retry, so yes, we do this one - ;. don't clear this - a successful non-sleep response will clear it - ;. S $P(^BPSEI(INS,101),U)="" ; clear the sleep-until time - ;. but don't clear the piece 5 current interval, as we may increment - ; Else still in waiting - if it's status 30, change it to 31 - I STATUS30=30 D - . N IEN59 S IEN59=X D SETSTAT(31) - . S $P(^BPST(IEN59,8),U)=$P(^BPSEI(INS,101),U) - . S $P(^BPST(IEN59,8),U,3)=INS - G N59A ; still in wait time; don't look at this claim -NOW() N %,%H,%I,X D NOW^%DTC Q % -VAN59A ;lje;6/26/03;VA wait time/insurer asleep - S X=$O(^BPST("AD",STATUS30,X)) - I X="" Q X ; end of list, return "" - ; but if the insurer is asleep, don't take this one - S INS=$P(^BPST(X,9),U,1) S:INS="" INS=1,$P(^BPST(X,9),U,1)=INS ;LJE;8/25/03 ;current insurance - I $D(^BPST(X,10)) S VAINS=^BPST(X,10,INS,0) ;LJE;7/1/03 - S T=$$GET1^DIQ(9002313.59902,INS_","_IEN59_",","PAYER SHEET:INSURER ASLEEP?") - I 'T Q X ; insurer is not asleep because there is no wait time set - S T=$$GET1^DIQ(9002313.59901,INS_","_IEN59_",","PAYER SHEET:RETRY TIME") ;RETRY TIME - I 'T Q X ; insurer is not asleep - ; - below here - insurer is asleep - - ; If cancellation is requested, let it through, regardless of sleep. - ; This will speed it on its way to cancellation - I $G(^BPST(X,3)) Q X - ; If necessary, update the .59's record of when to retry - I $P($G(^BPST(X,8)),U)'=T D ; - . S $P(^BPST(X,8),U)=T ; stamp with latest retry time - . N IEN59 S IEN59=X D SETSTAT(31) ; force screen update, too - . D LOG59^BPSOSQ("Insurer still asleep - retry at "_T,IEN59) - I T<$$NOW Q X ; time to retry, so yes, we do this one - I STATUS30=30 D - . N IEN59 S IEN59=X D SETSTAT(31) - . S $P(^BPST(IEN59,8),U)=$P($G(^BPSF(9002313.92,INS,1)),"^",12) - . S $P(^BPST(IEN59,8),U,3)=INS - G VAN59A ; still in wait time; don't look at this claim - ; -STATUS30 ; given STATUS30=30 - N IEN59 S IEN59="" - Q:'$$LOCK59 - F S IEN59=$$NEXT59(IEN59) Q:IEN59="" D - . K RXILIST ; init list each time through this loop - . S RXILIST(IEN59)="" - . D SETSTAT(40) ; set its status to "packetizing" - .; Reversals go in a packet alone - . I $G(^BPST(IEN59,4)) G POINTX - . G:$$CHKPA2() POINTX - . ;G:'$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) POINTX ;LJE;6/25/03;ONE PATIENT PER XMIT FOR VA FOR NOW. - . I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) I $D(VADIAL) G POINTX:VADIAL="1VA" - . I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) I '$D(VADIAL) G POINTX - . N RA0,RA1 S RA0=^BPST(IEN59,0),RA1=^(1) - . N IEN59 S IEN59="" ; preserve the top-level index! - . F S IEN59=$$NEXT59(IEN59) Q:'IEN59 D - . . N RB0,RB1 S RB0=^BPST(IEN59,0),RB1=^(1) - . . ; Only bundle when you have the same: - . . ; Patient, Visit, Division, Division Source, Insurer, Pharmacy - . . I $P(RA0,U,6,7)'=$P(RB0,U,6,7) Q - . . I $P(RA1,U,4,7)'=$P(RB1,U,4,7) Q - . . I $P(RB0,U,2)'=30 Q ; might have been canceled, or maybe 31'd - . . I $P(RB0,U,2)'=STATUS30 D Q - . . . D IMPOSS^BPSOSUE("P","TI","IEN59 status "_$P(RB0,U,2)_" but must be 30",,"STATUS30",$T(+0)) - . . D SETSTAT(40) - . . S RXILIST(IEN59)="" -POINTX . ; (reversals branch here around multi-claim packeting) - . S ERROR=$$PACKET^BPSOSQG ; - . S IEN59="" F S IEN59=$O(RXILIST(IEN59)) Q:IEN59="" D - . . I ERROR D - . . . D SETSTAT(99) ; - . . . D SETRESU($P(ERROR,U),$P(ERROR,U,2,$L(ERROR,U))) ; - . . E D - . . . D SETSTAT(50) ; "Waiting for transmit" - D UNLOCK59 - Q -TASK ;EP - BPSOS2D,BPSOSAP,BPSOSC3,BPSOSQG - N X,Y,%DT - S X="N",%DT="ST" D ^%DT - D TASKAT(Y) - Q -TASKAT(ZTDTH) ;EP - BPSOSQJ - N ZTRTN,ZTIO,ZTSAVE - S ZTRTN="COMMS^BPSOSQ3",ZTIO="" - S ZTSAVE("DIALOUT")="" ; which entry in 9002313.55 - D ^%ZTLOAD - Q -KSCRATCH ;EP - BPSOSQG ; Kill scratch globals - K ^BPSECX($J,"R") - K ^BPSECX($J,"C") - Q - ; -CHKPA() ;--------------------------------------------------------------- - N OVRREC,OVRFLD,NCPDPF,NCPDPFN,PACLM - S PACLM=0 - ; - S OVRREC=$P($G(^BPST(IEN59,1)),U,13) ;grab the overrides - Q:OVRREC="" 0 ;no overrides - can't be a prior auth claim - ; - ; loop through the overrides and look for the prior auth fields - S OVRFLD=0 - F S OVRFLD=$O(^BPS(9002313.511,OVRREC,1,OVRFLD)) Q:'+OVRFLD D - . S NCPDPF=$P($G(^BPS(9002313.511,OVRREC,1,OVRFLD,0)),U) ;int fld - . S NCPDPFN=$P($G(^BPSF(9002313.91,NCPDPF,0)),U) ;fld number - . Q:(NCPDPFN<498.01)!(NCPDPFN>498.04) - . S PACLM=1 - ; - Q PACLM - ; -CHKPA2() ;--------------------------------------------------------------- - N PATYP,PANUM - S PACLM=0 - ; - S PATYP=$P($G(^BPST(IEN59,1)),U,15) ;prior auth type code - S PANUM=$P($G(^BPST(IEN59,1)),U,9) ;prior auth number - I ($G(PATYP)'="")!($G(PANUM)'="") S PACLM=1 - ; - Q PACLM diff -auBN ./r1/BPSOSQ3.m ./r2/r/BPSOSQ3.m --- ./r1/BPSOSQ3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQ3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,234 +0,0 @@ -BPSOSQ3 ;BHAM ISC/FCS/DRS/DLF - tasked from BPSOSQ2 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; Subroutines split away from BPSOSQ3: - ; EWAIT55^BPSOSQJ(DIALOUT,OPERATION) - manage ERROR WAIT condition - ; ANY2SEND^BPSOSQJ(DIALOUT) - any claims waiting to be sent? - ; -COMMS ; This is the entry point - usually by taskman call from BPSOSQ2. - ; Given DIALOUT = pointer into 9002313.55 - ; Transmit and receive as long as you have claims to be transmitted - ; The task manager sets up DIALOUT in the call from BPSOSQ2. - ; When it's done with one DIALOUT, it looks around for others that - ; are in need of transmit, so you could end up doing lots of - ; transmissions in this one routine. - ; - ; Tell the world that we're up and running. - ; - I '$G(VARX) S VARX=0 S:'$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) VARX=1 - L +^BPSECX("BPSOSQ3","JOB",$J):0 I '$T D Q - . D IMPOSS^BPSOSUE("P","TI","can't obtain job-specific lock for $J="_$J_" ????",,"COMMS",$T(+0)) - ; - ; Remark about ^BPSECX("BPSOSQ3","JOB",$J,... - ; $$JOBCOUNT uses LOCKs to decide if they're running. - ; If a job bombs, the global remains but the LOCK is gone. - ; And that way, $$JOBCOUNT knows when to kill off such entries. - S ^BPSECX("BPSOSQ3","JOB",$J)=$H - S ^BPSECX("BPSOSQ3","JOB",$J,"DIALOUT")=DIALOUT - I $$JOBCOUNT>$$MAXJOBS H 2 I $$JOBCOUNT>$$MAXJOBS G ENDJOB99 - ; - ; put in long delay here for testing stuff like cancel a claim - ; - I 0 H 300 - ; - N BPSECT2,ABSBPOSE - ; - ; You need a slot for logging - D LOG^BPSOSL("Before INIT^BPSOSL in BPSOSQ3 "_$J_" begins; SLOT="_$G(SLOT)) - D INIT^BPSOSL(.1) - D LOG^BPSOSL("Sender/Receiver Job "_$J_" begins; DIALOUT="_DIALOUT) ;LJE;ADDED SLOT REF - D REMEMLOG(DIALOUT,$$GETSLOT^BPSOSL) - ; -AGAIN ; Loop back to here ; DIALOUT may have been changed since first entry - N RETVAL - S ^BPSECX("BPSOSQ3","JOB",$J,"DIALOUT")=DIALOUT - ;I $$JOBCOUNT>$$MAXJOBS D G ENDJOB ; already enough of these running - ;. D LOG^BPSOSL("Exceeded "_$$MAXJOBS_" sender/receiver jobs.") - ; - I $$ANY2SEND^BPSOSQJ(DIALOUT) D - . D TASK(60) ; start up proc. of responses right now, - . ; so something's ready - 60 = seconds for BPSOSQ4 to wait around - . ; for response packets to arrive - . S ABSBPOSE=$$TRANSMIT(DIALOUT) ; transmit / receive - E S (BPSECT2,ABSBPOSE)=0 ; none sent, no errors - ; - I BPSECT2 D ;if there were any complete transactions - . ; and someone hasn't already processed the responses, - . I $O(^BPSECX("POS",DIALOUT,"R",0)) D TASK() ; start up resp. handl'g - ; - ; I there were any errors returned by $$TRANSMIT - ; Check for the simple one-transaction-per-call case and loop back - ; if that's what happened. - ; - I ABSBPOSE=6999.30101,BPSECT2>0 G AGAIN - ; - ; Else: - ; 1 Mark the DIAL OUT as being in an error state. - ; 2 Mark the ECME WORKING claims as being in an error wait state (51) - ; 3 Schedule this program to run again after the wait period expires. - ; - I 'VARX I ABSBPOSE D - . ; one call to EWAIT55^BPSOSQJ does it all - . ; if BPSECT2 (i.e., any successful transactions), then reset - . ; to first increment - else bump up to next increment - . S RETVAL=$$EWAIT55^BPSOSQJ(DIALOUT,$S(BPSECT2:"RESET",1:"INCREMENT")) - . N X S X=$T(+0)_" - Increment ERROR WAIT on Dial Out `"_DIALOUT - . S X=X_" to "_$P(^BPS(9002313.55,DIALOUT,"ERROR WAIT"),U) - . D LOG^BPSOSL(X) - E I 'VARX I $P($G(^BPS(9002313.55,DIALOUT,"ERROR WAIT")),U) D - . ; No error, but should be clear the error on the dial-out? - . ; Case 1: Yes, clear it if we had a successful transmit-receive. - . ; Case 2: We had nothing to send, and there's no other active - . ; transmit-receive jobs on this same dial-out trying to work. - . I ('$$OTHJOBS)!(BPSECT2) D - . . D LOG^BPSOSL($T(+0)_" - Clear ERROR WAIT - Dial Out #"_DIALOUT) - . . S RETVAL=$$EWAIT55^BPSOSQJ(DIALOUT,"CLEAR") - ; - ; We finished with DIALOUT - K ^BPSECX("BPSOSQ3","JOB",$J,"DIALOUT") - ; - any others to do, though? - ; Give it 10 seconds; more efficient than task managering again - H 10 -TOLOOP ; - ; Now that transmit is done for this DIALOUT, maybe there are others - ; we can help out with? - I '$$SHUTDOWN S DIALOUT=$$ANY2SEND^BPSOSQJ I DIALOUT D G AGAIN - . D LOG^BPSOSL($T(+0)_" - $$ANY2SEND^BPSOSQJ(DIALOUT)="_DIALOUT_": loop back") - ; -ENDJOB ; - D LOG^BPSOSL("Sender/Receiver Job "_$J_" ends") - D DONE^BPSOSL -ENDJOB99 ; - I '$D(^BPSECX("BPSOSQ3","JOB",$J)) D ; impossible - . D IMPOSS^BPSOSUE("P","TI","my job-defined locked node disappeared!!! $J="_$J,,"ENDJOB99",$T(+0)) - K ^BPSECX("BPSOSQ3","JOB",$J) - L -^BPSECX("BPSOSQ3","JOB",$J) - ; - Q -OTHJOBS() ; any other transmit-receive jobs using DIALOUT? returns count of - N A,R S (A,R)=0 - F S A=$O(^BPSECX("BPSOSQ3","JOB",A)) Q:'A D - . I DIALOUT=$G(^BPSECX("BPSOSQ3","JOB",A,"DIALOUT")) S R=R+1 - Q R -TASK(Q4WAIT) ;EP - BPSOS2D,BPSOSQ4 ; start processing of responses - N X,Y,%DT - S X="N",%DT="ST" D ^%DT - D TASKAT(Y,$G(Q4WAIT)) - Q -TASKAT(ZTDTH,Q4WAIT) ; EP - - ;ZTDTH = time when you want EN^BPSOSQ4 to run - ; called from TASK, above, normally - ; Q4WAIT true: it will wait that many seconds for responses to come in, - ; polling every few seconds. - ; Q4WAIT false: if there's none ready, it stops - N ZTRTN,ZTIO,ZTSAVE - S ZTRTN="EN^BPSOSQ4",ZTIO="" - S ZTSAVE("DIALOUT")="" ; which entry in 9002313.55 - I $G(Q4WAIT) S ZTSAVE("Q4WAIT")="" - D ^%ZTLOAD - Q - ; -TRANSMIT(DIALOUT) ; returns 0 if success, nonzero error code if failure - ; This does transmit/receive for ONLY the given DIALOUT - N ECODE,ERROR S ERROR=0 - ; ERROR codes: - ; 3xx - in (to be completed - routine names changed) - ; 69xx - in - ; 80xx - in - ; - ; Dialing and $$CONNECT moved into $$SEND - ; S ECODE=$$CONNECT(DIALOUT) ; connect to NDC (or other host) - ; -TMIT1 S ECODE=$$SEND(DIALOUT) ; transmit and receive - ; in case the OPEN failed, wait about one transaction xmit time or so - I +ECODE=20999 H 10 H $R(5) G TMIT1 ; - ; sets BPSECT2=count - I $G(VARX) Q 0 ;LJE;7/17/03 - ; - N RETVAL S RETVAL=$$CLOSE^BPSOSAB(DIALOUT) - D ADDSTAT^BPSOSUD("D",1,1,"D",2,$G(BPSECT2),"D",3,ECODE'=0) - ; - I ECODE=0 D ; success - . S RETVAL=$$EWAIT55^BPSOSQJ(DIALOUT,"CLEAR") ; clear any error indicators - E D - . S RETVAL=$$EWAIT55^BPSOSQJ(DIALOUT,"INCREMENT") ; init or incr err indicator - . N X S X="CLAIM - ERROR - "_ECODE_" - " - . S X=X_$P($G(^BPSF(9002313.89,ECODE,0)),U,2) - . D LOG^BPSOSL(X) - ; - Q $S(ECODE:6999_"."_ECODE,1:0) - ; -NOW() N %,%H,%I,X D NOW^%DTC Q % - ; - ; -SEND(DEST) ; - S BPSECT2=0 - N RET S RET=$$SEND^BPSOSAM(DEST) - I BPSECT2 D - . N X S X=$T(+0)_" - Complete transactions: "_BPSECT2 - . D LOG^BPSOSL(X) - I RET D - . I RET=20999 D ; couldn't open device (not unusual) - . . ; - . E D - . . N X S X=$T(+0)_" - Error code "_RET_" returned from $$SEND^BPSOSAM" - . . D LOG^BPSOSL(X) - Q RET -ROOTREF(DEST) Q "^BPSECX(""POS"","_DEST_",""C"")" -SETSTAT(ABSBRXI,STAT) D SETSTAT^BPSOSU(STAT) Q -TSTAMP(DA) N DIE,DR S DIE=9002313.59,DR="7///NOW" D ^DIE Q -REMEMLOG(N,SLOT) ; ^("LOG FILE") remembers current and past several log files - N X S X=$G(^BPS(9002313.55,N,"LOG FILE")) - S X=SLOT_U_$P(X,U,1,9) - S ^BPS(9002313.55,N,"LOG FILE")=X - Q - ; - ; = = = = = = = = = = UTILITIES = = = = = = = = = = - ; ^BPSECX("BPSOSQ3","JOB",$J) is set for each of these that's running - ; and the node is also LOCKed. - ; ^TMP($J,"BPSOSQ3","SHUTDOWN") tells these to shut down. - ; $$SHUTDOWN() to query, $$SHUTDOWN(N) to set it. - ; >0 means shut down, =0 means enabled - ; ^TMP($J,"BPSOSQ3","MAX JOBS")=maximum # of these you want running - ; May actually be greater than that, but excess ones will drop out. - ; $$MAXJOBS() to query, $$MAXJOBS(n) to set it. - ; - ; JOBCOUNT tells you how many of these are running right now - ; -JOBMON ; temporary, for use by direct mode debugging - F W $$JOBCOUNT(1)," ",$P($H,",",2)," / " W:$X>60 ! H 1 - Q -JOBCOUNT(ECHO) N N,X S N=0 - S X="" F S X=$O(^BPSECX("BPSOSQ3","JOB",X)) Q:X="" D - .L +^BPSECX("BPSOSQ3","JOB",X):0 - .I '$T S N=N+1 ; yes, it's really running - .E D - ..I X=$J S N=N+1 ; it's us, we're that job, that's why LOCK succeeded - ..E D ; we got the lock, and we must unlock - ...I $G(ECHO) W "We're going to kill the entry for job ",X,! - ...K ^BPSECX("BPSOSQ3","JOB",X) ; it's not running, must've bombed - ..L -^BPSECX("BPSOSQ3","JOB",X) - Q N - ; -LOCK(X) L +^TMP($J,"BPSOSQ3",X):300 Q $T -UNLOCK(X) L -^TMP($J,"BPSOSQ3",X) Q - ; -SHUTDOWN(N) ;EP - BPSOS2A,BPSOSAM - N RET,ROU,X - S ROU=$T(+0),X="SHUTDOWN" - F Q:$$LOCK(X) Q:'$$IMPOSS^BPSOSUE("L","RIT","LOCK of SHUTDOWN flag",,"SHUTDOWN",$T(+0)) H 30 - I $D(N) S ^TMP($J,"BPSOSQ3",$J,X)=N - S RET=+$G(^TMP($J,"BPSOSQ3",$J,X)) - D UNLOCK(X) - Q RET - ; -MAXJOBS(N) ;EP - BPSOS2A - N RET,ROU,X S RET=0 - S ROU=$T(+0),X="MAX JOBS" - I '$$LOCK(X) ; - I $D(N) S ^TMP($J,"BPSOSQ3",X)=N - S RET=$G(^TMP($J,"BPSOSQ3",X)) - I 'RET S (RET,^TMP($J,"BPSOSQ3",X))=1 ; an arbitrary default for first timers - D UNLOCK(X) - Q RET diff -auBN ./r1/BPSOSQ4.m ./r2/r/BPSOSQ4.m --- ./r1/BPSOSQ4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQ4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,213 +0,0 @@ -BPSOSQ4 ;BHAM ISC/FCS/DRS/DLF - Process responses ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; Called from BPSOSQ3 at RESPONSE() - ; - ; What's here: the main LOOP and several miscellaneous subroutines, - ; many of which are called from outside. - ; - ; The meat of the response packet processing is in RESPONSE^BPSOSQL - ; and its subroutines, ONE, ONE1, RESP1 - ; - ;--------------------------------------------------------- - ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - ; The responses are exactly the same between 5.1 and 3.2 - we needed - ; to add new logic to RESP1000 and RESPMSG to capture the newer - ; information - ; - ;--------------------------------------------------------- - Q -EN ; the task from BPSOSQ3 starts here - ; for a specific DIALOUT - ; Q4WAIT might be defined, too - I '$G(Q4WAIT),'$O(^BPSECX("POS",DIALOUT,"R",0)) Q ; not waiting; nothing ready - N A,B,BLIMIT,ODIALOUT,GOTLOCK ; "O" as in "Original" - S ODIALOUT=DIALOUT,BLIMIT=$G(Q4WAIT,10) - D INIT^BPSOSL(.11) - D LOG($T(+0)_" - Job "_$J_" processing ECME responses.") -LOOP ; - ; The task may have been started before the responses were ready yet. - ; For example, it may have been started before dialing - figure up - ; to a minute before something might be available. - S B=0 F A=5:5:BLIMIT D Q:B - . S B=$O(^BPSECX("POS",DIALOUT,"R","")) Q:B - . HANG 2+$R(6) ; averages out to 5 seconds between checking - I 'B G LOOP7 ; no responses ready for this DIALOUT -LOOP1 ; - D LOG($T(+0)_" - Processing responses for DIALOUT="_DIALOUT) - L +^TMP($J,"BPSOSQ4",DIALOUT):5 ; only one job per DIALOUT (overcautious) - S GOTLOCK=$T - I GOTLOCK D - . D RESPONSE^BPSOSQL(DIALOUT) ; process all responses for this DIALOUT - . L -^TMP($J,"BPSOSQ4",DIALOUT) - . D LOG($T(+0)_" - Done for DIALOUT="_DIALOUT) - E D G LOOP9 - . D LOG($T(+0)_" - couldn't get LOCK? Another one already running?") - . D TASKAT^BPSOSQ3($$TADDNOW^BPSOSUD(.0002)) ; try again in 2 mins. -LOOP7 S DIALOUT=$$ANYRESPS(0) ; any others for anybody else we can do now? - I DIALOUT G LOOP1 - I B S DIALOUT=ODIALOUT,BLIMIT=10 G LOOP ; worth looping back to check original -LOOP9 D LOG($T(+0)_" - Job "_$J_" completed.") - D RELSLOT^BPSOSL - ; If there are any Status 19's, rev up a processor to rescue them - I $D(^BPST("AD",19)) D TASK^BPSOSIZ ; BPSOSQ1 - Q -LOG(X) D LOG^BPSOSL(X) Q -ANYRESPS(DIALOUT) ;EP - BPSOS2D ; - ; are there any responses waiting to be processed? - ; Also called from POKE^BPSOSUD - I $G(DIALOUT) Q $S($O(^BPSECX("POS",DIALOUT,"R","")):DIALOUT,1:0) - ; DIALOUT not given, so look for any DIALOUTs that need work - ; If any waiting, return DIALOUT where there are - ; Else return "" - N SET,RET S (SET,RET)=0 - F S SET=$O(^BPS(9002313.55,SET)) Q:'SET I $$ANYRESPS(SET) S RET=SET Q - Q RET - ; - ; The following are separate little utilities called from elsewhere. - ; -PAID(IEN59) ;EP - BPSOSQS ;quick query to see if it's paid - N TMP D RESPINFO(IEN59,.TMP) Q:'$D(TMP("RSP")) 0 - N X S X=TMP("RSP") - I X="Payable" Q 1 - ;I X="Captured" Q .5 ; should we? - Q 0 -RESPINFO(RXI,DST) ;EP - BPSOS6B,BPSOSNC,BPSOSUA - ; quick way to get all the response info for a given RXI - ; IMPORTANT!! D not change spelling, case, wording, or spacing!!! - ; Callers such as BPSOSNC are depending on the exact DST("RSP") - ; If a reversal was attempted, it complicates things. - ; fills DST array as follows: - ; DST("HDR")=Response Status (header) - ; DST("RSP")=Response Status (prescription) - ; This could be: "Payable" "Rejected" "Captured" "Duplicate" - ; or "Accepted reversal" or "Rejected reversal" - ; or "null" or "null reversal" (no response or corrupt response - ; or maybe someone without insurance, so no request was sent) - ; DST("REJ",0)=count of reject codes - ; DST("REJ",n)=each reject code - ; DST("MSG")=message with the response - ; All of these are defined, even if originals were '$D. - ; The external forms are returned. - N REVERSAL S REVERSAL=$G(^BPST(RXI,4))>0 - N RESP - I 'REVERSAL S RESP=$P(^BPST(RXI,0),U,5) - E S RESP=$P(^BPST(RXI,4),U,2) - Q:'RESP - N ECME S POS=$P(^BPST(RXI,0),U,9) Q:'POS - N FMT S FMT="E" - S DST("HDR")=$$RESP500(RESP,FMT) - S DST("RSP")=$$RESP1000(RESP,POS,FMT) - S DST("REJ",0)=$$REJCOUNT(RESP,POS,FMT) - I DST("REJ",0) D - .N I F I=1:1:DST("REJ",0) S DST("REJ",I)=$$REJCODE(RESP,POS,I,FMT) - S DST("MSG")=$$RESPMSG(RESP,POS,FMT) - ; Dealing with oddities of PCS (and others'?) response to reversals - I REVERSAL,DST("RSP")["null" D - .I DST("RSP")["null" S DST("RSP")=DST("HDR")_" reversal" - Q - ; In the following quickies: - ; RESP = RESPIEN, pointer to 9002313.03 - ; FMT = "I" for internal, "E" for external, defaults to internal -RESP500(RESP,FMT) ;EP - BPSOS57,BPSOSP2,BPSOSUC - ; returns the response header status - N X S X=$P($G(^BPSR(RESP,500)),U) - I $G(FMT)'="E" Q X - I X="" S X="null" - S X=$S(X="A":"Accepted",X="R":"Rejected",1:"?"_X) - Q X -RESP1000(RESP,POS,FMT) ;EP - BPSOSP2,BPSOSUC - ; returns the prescription response status - ; Note! Could be DP or DC for duplicates - N X S X=$P($G(^BPSR(RESP,1000,POS,500)),U) - I $G(FMT)'="E" Q X - I X="" S X="null" - ; - ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - they will send an "A" back - ; now on the transaction level to indicate that it has been accepted - ; Next code line remarked out - following added - ; - ;S X=$S(X="P":"Payable",X="R":"Rejected",X="C":"Captured",X="D"!(X="DP")!(X="DC"):"Duplicate",1:"?"_X) - S X=$S(X="A":"Accepted",X="P":"Payable",X="R":"Rejected",X="C":"Captured",X="D"!(X="DP")!(X="DC"):"Duplicate",1:"?"_X) - Q X -REJCOUNT(RESP,POS,FMT) ; returns rejection count - Q +$P($G(^BPSR(RESP,1000,POS,511,0)),U,3) -REJCODE(RESP,POS,N,FMT) ; returns Nth rejection code - ; if FMT="E", returns code:text - N CODE S CODE=$P($G(^BPSR(RESP,1000,POS,511,N,0)),U) - I CODE="" S CODE="null" - I FMT'="E" Q CODE - N X S X=$O(^BPSF(9002313.93,"B",CODE,0)) - I X]"" S CODE=CODE_":"_$P($G(^BPSF(9002313.93,X,0)),U,2) - E S CODE="?"_CODE - Q CODE - ; - ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - message may not come - ; back in 504 - may come back in 526 instead - ; -RESPMSG(RESP,POS,FMT) ; response message - additional text from insurer - ; - N MSG - S MSG="" - S MSG=$G(^BPSR(RESP,1000,POS,504)) - S:MSG="" MSG=$G(^BPSR(RESP,1000,POS,526)) - ;Q $G(^BPSR(RESP,1000,POS,504)) - Q MSG - ; - ;IHS/SD/lwj 10/07/02 end of NCPDP 5.1 changes to RESPMSG - ; -NOW() N %,%H,%I,X D NOW^%DTC Q % - ; - ; The xxxSLEEP functions are called from BPSOSQL - ; -CLRSLEEP(INS,WHY) ;EP - BPSOSQL - ; clear insurer sleeping condition - ; also called from CANCEL^BPSOSUD - ; WHY = 1 - we know for sure they're awake now - ; - ; skip the sleeping check for VA, the check will be done by IB DLF 7/31/03 - ; - I ^BPS(9002313.99,1,"SITE TYPE")=1 D - .N X S X=$G(^BPSEI(INS,101)) Q:'X ; not asleep - .S $P(X,U)="",$P(X,U,5)="",$P(X,U,6)="",^BPSEI(INS,101)=X - .I $D(^BPST("AD",31)) D - .. D TASK^BPSOSQ1 ; awaken any other 31s waiting for this insurer - Q -REJSLEEP(RESP,POS) ;EP - BPSOSQL - ; return TRUE if this claim was rejected because the - ; insurer is sleeping - ; Reject codes we look for depend on which switch. - ; Envoy's: - I $G(^BPSR(RESP,1000,POS,504))?1"EV16-".E Q 1 - I $G(^BPSR(RESP,1000,POS,504))?1"EV38-".E Q 1 - I $G(^BPSR(RESP,1000,POS,504))?1"EV32-".E Q 1 - I $G(^BPSR(RESP,1000,POS,504))?1"EV25-".E Q 1 ; BPS*1.0T7*4 - ; NDC's, and theoretically, Envoy too, though they seem to do EV- msgs - I $O(^BPSR(RESP,1000,POS,511,"B",90))="" Q 0 ; cheap check - ; But for a PCS case we see, Code 99 + some code < 90 ; BPS*1.0T7*2 - ; isn't "asleep" - 99 is something PCS threw in ; BPS*1.0T7*2 - ; so require 99 to be accompanied by something <99 too ; BPS*1.0T7*2 - N RET S RET=0 N I F I=92,93,99 D Q:RET - . I $D(^BPSR(RESP,1000,POS,511,"B",I)) S RET=1 - . Q:I'=99 Q:'RET ; BPS*1.0T7*2 - . I I=99,$O(^BPSR(RESP,1000,POS,511,"B",0))<90 S RET=0 ; BPS*1.0T7*2 - Q RET -INCSLEEP(INS) ;EP - BPSOSQL - ; Increment sleep time for this insurer, if necessary. - ; Return the scheduled retry time - N X - I VARX S X="^^^^^" ;LJE - E S X=$G(^BPSEI(INSURER,101)) - I $P(X,U)<$$NOW D ; previous retry expired, let's retry: - . I '$P(X,U,2) S $P(X,U,2)=600 ; base time = 10 minutes - . I '$P(X,U,3) S $P(X,U,3)=3 ; multiplier - . I '$P(X,U,4) S $P(X,U,4)=2.5*60*60 ; max wait time ; 2.5 hrs - . I '$P(X,U,5) S $P(X,U,5)=$P(X,U,2) ; current wait time (either init - . E S $P(X,U,5)=$P(X,U,5)*$P(X,U,3) ; or multiply) - . S $P(X,U,5)=$P(X,U,5)\1 - . S:$P(X,U,5)>$P(X,U,4) $P(X,U,5)=$P(X,U,4) ; apply max if needed - . S $P(X,U)=$$TADDNOWS^BPSOSUD($P(X,U,5)) ; set retry time - . I VARX S ^BPSEI(INSURER,101)=X ;LJE - . E S $P(^BSPF(9002313.92,INSURER,1),U,12)=$P(X,U,5) - . D TASKAT^BPSOSQ1($P(X,U)) ; BPSOSQ2 will run again upon expiry - . D TASK^BPSOSQ1 ; and run it again right away, too, to stamp new times on the others in status 31 - Q $P(X,U) diff -auBN ./r1/BPSOSQF.m ./r2/r/BPSOSQF.m --- ./r1/BPSOSQF.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQF.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,41 +0,0 @@ -BPSOSQF ;BHAM ISC/FCS/DRS/FLS - Insurer asleep - status 31 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; Continuation of BPSOSQ2 - ; -STATUS31 ;EP - BPSOSQ2 - ; Situation: you have 1 or 2 or maybe 200 claims in status 31, - ; because we've determined that the insurer is asleep. - ; change at most one claim per insurer to status 30, to let it - ; go through and try again. But if the insurer is awake for sure, - ; let all of the claims for that insurer go on through. - Q:'$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) ;LJE - N STATUS30,IEN59,INSURER S STATUS30=31,IEN59="" - K ^TMP("BPSOSQF",$J) ; build ^TMP("BPSOSQF",$J,INSURER,IEN59)="" - Q:'$$LOCK59^BPSOSQ2 - F S IEN59=$$NEXT59^BPSOSQ2(IEN59) Q:'IEN59 D - . ; if $$NEXT59() returned us an IEN59, then the waiting time - . ; has expired - or better yet, the insurer has awakened - . S INSURER=$P(^BPST(IEN59,1),U,6) - . ; If still in wait, but wait expired, just allow one claim thru. - . ; But if wait has been canceled - that is, we had a successful - . ; transmit, meaning the insurer has awakened - then let them all - . ; go through to status 30. - . Q:^BPS(9002313.99,1,"SITE TYPE")=0 ;Q IF VA DLF 7/30/2003 - . N X S X=$G(^BPSEI(INSURER,101)) - . N T,PROBER S T=$P(X,U),PROBER=$P(X,U,6) - . ; if somehow the prober became complete, without clearing 101;6 - . ; (maybe this happens if cancellation takes place?) - . I PROBER D - . . N X S X=$P($G(^BPST(PROBER,0)),U,2) - . . I X=99!(X="") S PROBER="" - . I T,PROBER,PROBER'=IEN59 Q ; only prober can go thru during wait - . I T S $P(^BPSEI(INSURER,101),U,6)=IEN59 ; you're the prober - . S ^TMP("BPSOSQF",$J,INSURER,IEN59)="" - D UNLOCK59^BPSOSQ2 - S INSURER="" F S INSURER=$O(^TMP("BPSOSQF",$J,INSURER)) Q:'INSURER D - . S IEN59="" F S IEN59=$O(^TMP("BPSOSQF",$J,INSURER,IEN59)) Q:'IEN59 D - . . D SETSTAT^BPSOSQ2(30) ; reset to status 30 - . . K ^BPST(IEN59,8) ; clear Listmanager wait info - Q diff -auBN ./r1/BPSOSQG.m ./r2/r/BPSOSQG.m --- ./r1/BPSOSQG.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQG.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,95 +0,0 @@ -BPSOSQG ;BHAM ISC/FCS/DRS/FLS - form transmission packets ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; PACKET(), split off from BPSOSQ2 - ; -PACKET() ;EP - BPSOSQ2 - ; packetize one prescription (and possibly more prescriptions - ; for the same patient, if they're ready now.) - ; Called from BPSOSQ2, - ; which gave us RXILIST(IEN59) array of claims to packetize. - ; - N X S X="PACKERR^"_$T(+0),@^%ZOSF("TRAP") - N CLAIMIEN,DIALOUT,ERROR - I $P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) S DIALOUT=$$DIALOUT ;lje;6/27;/03 get dialout if not va - E S DIALOUT="1VA" I $D(VADIAL) S DIALOUT=VADIAL - ; - ; If it's a reversal, we already have an ^BPSC( It was - ; created by the call to BPSECA8, way back at the beginning. - ; So, unlike claims, we need only the NCPDP formatting for it. - N FIRST59 S FIRST59=$O(RXILIST(0)) - I $G(^BPST(FIRST59,4)) D G POINTM - . ; Mimic a few things that are set up in the code we're skipping - . S CLAIMIEN=$P(^BPST(FIRST59,4),U) - . S CLAIMIEN(CLAIMIEN)="" - ; - - - - - But if it's not a reversal, do all this stuff: - - - - - - I $O(RXILIST($O(RXILIST("")))) D - . D LOG2LIST^BPSOSQ("Packetizing - we have more than one claim:") - . N I,X,Y S (X,Y)="" - . F I=1:1 S X=$O(RXILIST(X)) Q:'X D - . . S $P(Y,", ",I-1#4+1)=X - . . I I#4=0 D LOG2LIST^BPSOSQ(Y) S Y="" - . I Y]"" D LOG2LIST^BPSOSQ(Y) - ; - - - - - - ; Retrieve some important variables from the ECME WORKING file - ; The ones we retrieve are the same for all prescriptions in RXILIST(*) - N PATDFN S PATDFN=$P(^BPST(FIRST59,0),U,6) - N ABSBVISI S ABSBVISI=$P(^BPST(FIRST59,0),U,7) - ; - ; BPSOSCA calls BPSOSCB,BPSOSCC,BPSOSCD to set up BPS(*) - ; then BPSOSCE to create claims in 9002313.02 - ; -LOCK L +^BPSC:300 ; may be multiple copies of this running!!! - I '$T D G LOCK:$$IMPOSS^BPSOSUE("L","RIT","LOCK ^BPSC claims file",,,$T(+0)) - . D LOG2LIST^BPSOSQ($T(+0)_" - unable to lock file 9002313.02 - should never happen!") - ; input RXILIST(*) - D EN^BPSOSCA(DIALOUT) ; - ; output ERROR, CLAIMIEN, CLAIMIEN(*) - I ERROR D LOG2LIST^BPSOSQ($T(+0)_" - ERROR="_ERROR_" returned from BPSOSCA") - ; BPSOSCA set up ERROR,CLAIMIEN,CLAIMIEN(*) - L -^BPSC - I $G(CLAIMIEN)<1 Q $S(ERROR:ERROR,1:300) - ; - ; CLAIMIEN=last claim created - ; CLAIMIEN(CLAIMIEN)=the list of all claims created - ; - ; Then, BPSOSQH calls BPSECA1 to build NCPDP claim format records - ; -POINTM ; Reversals are joining again here - D KSCRATCH^BPSOSQ2 ; erase ^BPSECX($J) - D PASCII^BPSOSQH(DIALOUT) ; gives you ^BPSECX($J,"C",CLAIMIEN,... - ; - ; Drop the NCPDP-formatted records into the list used by - ; the sender-receiver. Too coarse to lock the whole list - - ; you'll be blocked by a sender-receiver who has one claim locked. - ; (Even though we fixed that recently so that a sender locks the - ; claim for only the minimal amount of time.) - ; - ; Drop each claim in there individually. - ; And as soon as the very first one hits, rev up a sender-receiver. - ; - N FIRST S FIRST=1 - N X S X="" F S X=$O(^BPSECX($J,"C",X)) Q:X="" D - . F L +^BPSECX("POS",DIALOUT,"C",X):60 Q:$T Q:'$$IMPOSS^BPSOSUE("L","RIT","LOCK claims list for DIALOUT="_DIALOUT,,"POINTM",$T(+0)) - . M ^BPSECX("POS",DIALOUT,"C",X)=^BPSECX($J,"C",X) - . L -^BPSECX("POS",DIALOUT,"C",X) - . N MSG S MSG="Claim ID "_$P(^BPSC(X,0),U) - . I '$G(VARX) S MSG=MSG_" queued for "_$P(^BPS(9002313.55,DIALOUT,0),U) ;lje;7/9/03 - . E S MSG=MSG_" queued for VA" ;lje;7/9/03 - . D LOG2CLM^BPSOSQ(MSG,X) - . I FIRST D TASK^BPSOSQ2 S FIRST=0 - D RELSLOT^BPSOSL - Q 0 -DIALOUT() ; RXILIST(*) should be sent to NDC? or what other processor? - ; Return a pointer to File 9002313.55, the DIAL OUT file. - N IEN59 S IEN59=$O(RXILIST(0)) - N X S X=$P(^BPST(IEN59,1),U,6) ; INSURER - S X=$P(^BPSEI(X,100),U,7) ; which DIAL OUT it points to - ; get the default dial-out, otherwise - I 'X S X=$P($G(^BPS(9002313.99,1,"DIAL-OUT DEFAULT")),U) - I 'X S X=$O(^BPS(9002313.55,"B","DEFAULT",0)) - I 'X S X=$O(^BPS(9002313.55,0)) ; they deleted the DEFAULT one?? - Q X -PACKERR ; error trap comes here - D @^%ZOSF("ERRTN") ; make error log entry, too - Q "8899^INTERNAL ERROR: "_$$ZE^BPSOS ; this will go in transaction and eventually on display screen for user diff -auBN ./r1/BPSOSQH.m ./r2/r/BPSOSQH.m --- ./r1/BPSOSQH.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQH.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,57 +0,0 @@ -BPSOSQH ;BHAM ISC/FCS/DRS/FLS - prepare claims for transmission 10:46 AM 7 Jan 1997 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;prepare claims for transmission (eg assemble into ASCII record format) - ; Called from BPSOSQG, usually from BPSOSQ2 - ; Also used by certification, called from BPSOSC2 - ; - ; You have CLAIMIEN(*), array of pointers to 9002313.02 claims - ; - ;Creates the following scratch global: - ; ^BPSECX($J,"C",0) = - ; ^BPSECX($J,"C",CLAIMIEN,0) = - ; ^BPSECX($J,"C",CLAIMIEN,1) = - ; ^BPSECX($J,"C",CLAIMIEN,2) = - ; N) = <..........................> - ;---------------------------------------------------------------------- -PASCII(DIALOUT) ;EP - from BPSOSQG - ;Manage local variables - N AREC,COUNT - S COUNT=0 - ; - K ^BPSECX($J,"C") - ; - S VARX=0 I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) S VARX=1 ;LJE;7/14/03 - ; Coming into this, ABS????? has - ; set up CLAIMIEN(*) = a list of CLAIMIENs that were generated from - ; all the prescriptions that might have been bundled together. - ; So we must loop through that list. - S CLAIMIEN="" - F S CLAIMIEN=$O(CLAIMIEN(CLAIMIEN)) Q:CLAIMIEN="" D PASCII1 - Q - ; -PASCII1 ;EP - from above and also BPSOSC2 ; - ; Assemble NCPDP Ascii formatted record - S AREC=$$ASCII^BPSECA1(CLAIMIEN) - Q:AREC="" - ; - ;Store NCPDP Ascii formatted record in ^BPSECX($J,"C",CLAIMIEN,..) - ;transmission scratch global - N PREFIX - I 'VARX S PREFIX=$P($G(^BPS(9002313.55,DIALOUT,"NDC")),U,2) - E S PREFIX="VA" ;LJE - ; If test mode for NDC, then change that prefix from HN* to HN. - ; (Actually, I don't understand when or where that test mode really - ; means anything.) - I 'VARX D SVEAREC^BPSECX4(PREFIX_AREC,CLAIMIEN,"C") ;production mode - ; - ; And save a copy of the original transmitted record in - ; ^BPSC(CLAIMIEN,"M") - I 'VARX D ;VA CLAIM INFO STORED IN BPSECA1;LJE - . N WP,I F I=1:100:$L(AREC) S WP(I/100+1,0)=$E(AREC,I,I+99) - . D WP^DIE(9002313.02,CLAIMIEN_",",9999,"","WP") - ; - ;Increment claim counter - S COUNT=COUNT+1 - ; - ;S ^BPSECX($J,"C",0)=COUNT - Q diff -auBN ./r1/BPSOSQJ.m ./r2/r/BPSOSQJ.m --- ./r1/BPSOSQJ.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQJ.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,136 +0,0 @@ -BPSOSQJ ;BHAM ISC/FCS/DRS/FLS - subroutines of BPSOSQ2 ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -SETSTAT(ABSBRXI,STAT) D SETSTAT^BPSOSU(STAT) Q -TSTAMP(DA) N DIE,DR,X S DIE=9002313.59,DR="7///NOW" D ^DIE Q -NOW() N %,%H,%I,X D NOW^%DTC Q % - ; Query whether there are formatted claim packets ready - ; to send, or formatted response packets ready to be processed. - ; Call them without DIALOUT (or with DIALOUT=0) to check all DIALOUTs - ; Call with a specific DIALOUT to check only that DIALOUT - ; -ANY2SEND(DIALOUT) ;EP - from BPSOS2D,BPSOSQ3 - ; are there any claims waiting to be sent? - ; also called from POKE^BPSOSUD - ; I called with an DIALOUT, look for just that DIALOUT - ; Return TRUE (=DIALOUT) if there are, FALSE if there aren't - ; Also: Return false if this DIALOUT is currently in an ERROR WAIT - ; state. - ; - ; If called without a DIALOUT: scan all DIALOUTs and return the - ; first one that has some waiting to send. FALSE if none nowhere. - ; - N RET - I '$G(DIALOUT) G ANY2SA - I '$O(^BPSECX("POS",DIALOUT,"C","")) Q 0 ; none waiting to be sent - ; Yes, there are some to be set for this DIALOUT - I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) Q DIALOUT ;LJE;7/17/03 - I '$$EWAIT55(DIALOUT,"FLAGGED") Q DIALOUT ; no error condition - I $$EWAIT55(DIALOUT,"EXPIRED") D Q DIALOUT ; okay, it's time to retry - . D LOG^BPSOSL($T(+0)_" - ERROR WAIT expired, time to retry on dial out #"_DIALOUT) - ; Yes, some to be sent, but we're in error wait retry. - ; Make sure the individual claims are marked. (this is to catch any - ; newly arrived claims destined for the DIALOUT with prior comms - ; problems) - D MARKWAIT(DIALOUT) - Q 0 - ; -ANY2SA ; DIALOUT not given, so look for any DIALOUTs that need work - N SET,RET S (SET,RET)=0 - F S SET=$O(^BPS(9002313.55,SET)) Q:'SET I $$ANY2SEND(SET) S RET=SET Q - Q RET - ; - ; EWAIT55 manages ERROR WAIT condition on a DIALOUT -EWAIT55(DEST,OPER) ;EP - BPSOSQ3 - L +^BPS(9002313.55,DEST):300 - N RET S RET=$$EWAIT55A - L -^BPS(9002313.55,DEST) - Q RET -EWAIT55A() ; given DEST, OPER - N X S X=$G(^BPS(9002313.55,DEST,"ERROR WAIT")) - ; - ; $$EWAIT55(DEST,"FLAGGED") - ; returns TRUE (=expiration time) if it's in ERROR WAIT state - ; returns FALSE (=0) if it's not - I OPER="FLAGGED" Q $P(X,U) ; is it flagged? - ; - ; $$EWAIT55(DEST,"EXPIRED") returns TRUE if the ERROR WAIT state - ; has expired (or if it's not even flagged) - I OPER="EXPIRED" Q $$NOW'<$P(X,U) ; has it expired? - ; - ; $$EWAIT55(DEST,"INCREMENT") bumps ERROR WAIT to next increment - ; $$EWAIT55(DEST,"RESET") resets it to its first increment - I OPER="INCREMENT"!(OPER="RESET") D Q - . L +^BPS(9002313.55,DEST):300 - . N FIRST S FIRST=('$P(X,U))!(OPER="RESET") ; the first time through? - . I 'FIRST,$$NOW<$P(X,U) Q ;hasn't reached the time yet - do not incr. - . I '$P(X,U,2) S $P(X,U,2)=30 ; base time - . I '$P(X,U,3) S $P(X,U,3)=1.2 ; multiplier - . I '$P(X,U,4) S $P(X,U,4)=30*60 ; max wait time - . I '$P(X,U,5)!FIRST S $P(X,U,5)=$P(X,U,2) ; current wait time (either init - . E S $P(X,U,5)=$P(X,U,5)*$P(X,U,3) ; or multiply) - . S $P(X,U,5)=$P(X,U,5)\1 - . S:$P(X,U,5)>$P(X,U,4) $P(X,U,5)=$P(X,U,4) ; apply max if needed - . S $P(X,U)=$$TADDNOWS^BPSOSUD($P(X,U,5)) ; set retry time - . S ^BPS(9002313.55,DEST,"ERROR WAIT")=X ; store updated data - . L -^BPS(9002313.55,DEST) - . I FIRST,OPER'="INCREMENT" D - . . D MARKWAIT(DEST) ; change claims' status from 50 to 51 - . E D - . . D INCRWAIT(DEST) ; stamp claims with new time of retry - . N DIALOUT S DIALOUT=DEST ; variable needed by TASKAT^BPSOSQ2 - . D TASKAT^BPSOSQ2($P(^BPS(9002313.55,DIALOUT,"ERROR WAIT"),U)) ; program will run again upon expiry - ; - ; $$EWAIT55(DEST,"CLEAR") clears the error wait condition - I OPER="CLEAR" D Q - . S $P(X,U)="",$P(X,U,5)="" ; clear retry time, current wait time - . S ^BPS(9002313.55,DEST,"ERROR WAIT")=X - . ; claims are okay in state 51; don't need to requeue them - ; - D IMPOSS^BPSOSUE("P","TI","Bad arg OPER="_OPER,,"EWAIT55A",$T(+0)) - Q - ; - ; When an err condition is first established: DO MARKWAIT - ; It takes the affected claims from code 50 and resets to 51 - ; This is done in two places: - ; 1. When an err condition is first detected. - ; 2. When a new claim packet comes along and discovers - ; a pre-existing error condition. - ; - ; When an err condition persists and a retry is scheduled: DO INCRWAIT - ; This marks all the affected claims with the retry time. - ; - ; -MARKWAIT(DEST) ; Put status 50 claims into wait state because of this DEST - ; having comms problems. - ; The packets are in @ROOT@(PACKET), PACKET is pointer to 9002313.02 - ; The claims are in ^BPST("AE",PACKET,*) - ; The claims are in ^BPST("AD",50,*), too - ; You want to check ONLY the code 50's! I you do it by going - ; through the "AE" index, and it's a long delay, and you have - ; hundreds of claims backed up, this gets to be too expensive. - N TIME S TIME=$P(^BPS(9002313.55,DEST,"ERROR WAIT"),U) - N IEN59 S IEN59="" - F S IEN59=$O(^BPST("AD",50,IEN59)) Q:'IEN59 D - . N PACKET S PACKET=$P(^BPST(IEN59,0),U,4) - . I $D(^BPSECX("POS",DEST,"C",PACKET)) D - . . D SETSTAT(IEN59,51) ; takes care of LOCK, last update, etc.! - . . ; and mark the claim with useful data for the Listmanager screen - . . S $P(^BPST(IEN59,8),U,1,2)=TIME_U_DEST - Q -INCRWAIT(DEST) ; Stamp all the waiting claims for this DIALOUT (DEST) - ; with the scheduled retry time. - ; This will induce the Listman display to update its display, too, - ; when the Listman job sees that the LAST UPDATE time in .59 - ; has changed. - N TIME S TIME=$P(^BPS(9002313.55,DEST,"ERROR WAIT"),U) - N PACKET S PACKET="" - F S PACKET=$O(^BPSECX("POS",DEST,"C",PACKET)) Q:PACKET="" D - . N IEN59 S IEN59="" - . F S IEN59=$O(^BPST("AE",PACKET,IEN59)) Q:IEN59="" D - . . S $P(^BPST(IEN59,8),U,1,2)=TIME_U_DEST - . . D TSTAMP(IEN59) - . F S IEN59=$O(^BPST("AER",PACKET,IEN59)) Q:IEN59="" D - . . S $P(^BPST(IEN59,8),U,1,2)=TIME_U_DEST - . . D TSTAMP(IEN59) - Q diff -auBN ./r1/BPSOSQL.m ./r2/r/BPSOSQL.m --- ./r1/BPSOSQL.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,225 +0,0 @@ -BPSOSQL ;BHAM ISC/FCS/DRS/FLS - Process responses ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ;----------------------------------------------------- - ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - ; The reversal claim now has a transaction code of "B2" instead of - ; 11. Needed to adjust the ISREVERS routine to account for the - ; difference. Also adjusted the RESP1 routine to check the - ; additional message field (526) since not all processors will use - ; the 504 message field in 5.1. - ; - ;----------------------------------------------------- - Q - ; - ; Subroutines from BPSOSQ4 - the main line of processing is in here. - ; The utility subroutines remain in BPSOSQ4. - ; - ; RESPONSE(DIALOUT) - ; Processes all response packets for this DIALOUT - ; Creates 9002313.03 response record - ; At this point, you are guaranteed to be the only job - ; processing responses for this DIALOUT - you have a LOCK on - ; that privilege, set up in BPSOSQ4. But the old LOCK logic - ; is retained in here, in case that BPSOSQ4 restriction is - ; ever removed. - ; ONE(CLAIMIEN,RESPIEN) - ; Process the 9002313.03 RESPIEN for the 9002313.02 CLAIMIEN - ; Loops through all 9002313.59's represented in the CLAIMIEN - ; ONE1(IEN59) - ; Processing the 9002313.03 RESPIEN for this one IEN59 - ; It's just a tiny wrapper for RESP1 to save,set,restore logging - ; RESP1 - ; The real work of response handling for one IEN59 is in here - ; -RESPONSE(DIALOUT) ;EP - BPSOSQ4 - ; - ; Currently, the caller from BPSOSQ4 will already have the - ; lock on ^TMP($J,"BPSOSQ4",DIALOUT) - ; This routine tries to get L +^BPSECX("POS",DIALOUT,"R") - ; and then L +^BPSECX("POS",DIALOUT,"R",CLAIMIEN) - ; All of this locking could be greatly simplified, it seems. - ; - N CLAIMIEN,RESPIEN,RESPREC,CLAIMID,DIC,X,Y - S CLAIMIEN="" - F D Q:CLAIMIEN="" - . I '$$LLIST S CLAIMIEN="" Q ; Lock the whole list of responses - . ;D LOG^BPSOSL("PRAscii1^"_$T(+0)_" 1. with CLAIMIEN="_CLAIMIEN) - . S CLAIMIEN=$O(^BPSECX("POS",DIALOUT,"R",CLAIMIEN)) - . ;D LOG^BPSOSL("PRAscii1^"_$T(+0)_" 2. with CLAIMIEN="_CLAIMIEN) - . I CLAIMIEN="" D ULLIST Q - . ; lock the individual response and unlock the list (useless oper?) - . F Q:$$LRESP Q:'$$IMPOSS^BPSOSUE("L","RI","Locking response for CLAIMIEN="_CLAIMIEN,,"RESPONSE",$T(+0)) - . D ULLIST ; unlock the list - . ; - . ;Assemble RESPREC from scratch global - . S RESPREC="" - . N I F I=1:1:^BPSECX("POS",DIALOUT,"R",CLAIMIEN,0) D - . . S RESPREC=RESPREC_^BPSECX("POS",DIALOUT,"R",CLAIMIEN,I) - . S RESPREC=$P(RESPREC,$C(3)) - . I RESPREC="" D Q ; null response? should be impossible, - . . ; but we saw it once at Parker. - . . D LOG^BPSOSL($T(+0)_" - ??? Null response to CLAIMIEN "_CLAIMIEN) - . . D KILLRESP - . ; - . S CLAIMID=$P($G(^BPSC(CLAIMIEN,0)),U,1) - . I CLAIMID="" D Q ; impossible? - . . D LOG^BPSOSL($T(+0)_" - ??? CLAIMID is missing from "_CLAIMIEN) - . . D KILLRESP - . ; - . ;Create Claim Response Record (9002313.03) - . F D Q:RESPIEN'<1 Q:$$IMPOSS^BPSOSUE("FM","TI","^DIC failed to create new ^BPSR record for CLAIMID="_CLAIMID,,,$T(+0)) - . . N X,DLAYGO,DIC,Y S X=""""_CLAIMID_"""" - . . S DIC="^BPSR(",DIC(0)="LXZ",DLAYGO=9002313.03 D ^DIC - . . S RESPIEN=+Y - . ; - . D LOG^BPSOSL($T(+0)_" - Claim "_CLAIMIEN_" got Response "_RESPIEN) - . ; - . N STAMP S STAMP=$$NOWFM^BPSOSU1() - . ; - . ;Set Date/Time Response Received field, set cross-reference - . S $P(^BPSR(RESPIEN,0),U,2)=STAMP - . S ^BPSR("AE",STAMP,RESPIEN)="" - . ; - . ;Set Transmitted On field, set cross-reference - . S $P(^BPSC(CLAIMIEN,0),U,5)=STAMP - . S ^BPSC("AE",STAMP,CLAIMIEN)="" - . ; - . ;Turn off transmit flag, reset cross-reference - . S $P(^BPSC(CLAIMIEN,0),U,4)=0 - . K ^BPSC("AD",2,CLAIMIEN) ; 2 (POS) not 1 (old batch) - . S ^BPSC("AD",0,CLAIMIEN)="" - . ; - . ;Parse and File Ascii Response record in Claim Response File - . D PARSE^BPSECA4(RESPREC,RESPIEN) - . ; - . ; and the right place to process ECME responses is here!!!! - . ; - . ; (there was some problem with this slot stacking mechanism?) - . ;N OLDSLOT S OLDSLOT=$$GETSLOT^BPSOSL ; remember current slot - . D ONE(CLAIMIEN,RESPIEN) - . ;D SETSLOT^BPSOSL(OLDSLOT) ; restore the old one - . ; - . D KILLRESP ; kill the scratch response - . ; Save a copy of the received packet, too - . N WP,I F I=1:100:$L(RESPREC) S WP(I/100+1,0)=$E(RESPREC,I,I+99) - . D WP^DIE(9002313.03,RESPIEN_",",9999,"","WP") - . D ULRESP ; unlock the response - . Q - Q - ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - for reversals we need - ; to account for a transaction code of 11 for 3.2 claims and - ; B2 for 5.1 claims. The next line was remarked out and - ; replaced with the 6 lines following it. - ;ISREVERS(X) Q $P(^BPSC(X,100),U,3)=11 ; trans.code REVERSAL -ISREVERS(X) ; trans.code REVERSAL - ; - N REVS - S REVS=0 - S:($P(^BPSC(X,100),U,3)=11)!($P(^BPSC(X,100),U,3)="B2") REVS=1 - Q REVS - ; - ;IHS/SD/lwj 10/07/02 end changes to ISREVERS - ; -ONE(CLAIMIEN,RESPIEN) ; - ; Both the 9002313.02 and 9002313.03 are correct and complete - ; Now update all of the prescription records affected by them. - ; Loop: for each prescription represented in the original claim: - N OLDSLOT S OLDSLOT=$$GETSLOT^BPSOSL - N ISREVERS S ISREVERS=$$ISREVERS(CLAIMIEN) - N X S X="RESPONSE -" - I ISREVERS S X=X_" REVERSAL -" - S X=X_" Response #"_RESPIEN - S X=X_" for Claim #"_CLAIMIEN D LOG^BPSOSL(X) - N INDEX S INDEX=$S(ISREVERS:"AER",1:"AE") - N IEN59 S IEN59=0 - F S IEN59=$O(^BPST(INDEX,CLAIMIEN,IEN59)) Q:IEN59="" D - . D ONE1(IEN59) - Q -ONE1(ABSBRXI) ; ABSBRXI would more properly be called IEN59 - D SETSLOT^BPSOSL(OLDSLOT) - D LOG^BPSOSL("RESPONSE - for ^BPST("_ABSBRXI_")") - D RESP1 - D SETSLOT^BPSOSL(OLDSLOT) ; because RESP1 changed it, probably - Q - ;---------------------------------------------------------------------- - ;Process ASCII Claim Response Records: - ; - ; 1. Loop through ^BPSECX("POS",DIALOUT,$J,"R",CLAIMIEN) - ; transmission scratch global - ; 2. Assemble ASCII Claim Response Records - ; 3. Create new records in Claim Response File (9002313.03) - ; 4. Parse ASCII Claim Response Records then file in - ; Claim Response File (9002313.03) - ;---------------------------------------------------------------------- - ; -LLIST() L +^BPSECX("POS",DIALOUT,"R"):60 Q $T -ULLIST L -^BPSECX("POS",DIALOUT,"R") Q -LRESP() L +^BPSECX("POS",DIALOUT,"R",CLAIMIEN):60 Q $T -ULRESP L -^BPSECX("POS",DIALOUT,"R",CLAIMIEN) Q -KILLRESP K ^BPSECX("POS",DIALOUT,"R",CLAIMIEN) Q - ; -RESP1 ; called from ONE1 - ; ABSBRXI would more properly be called IEN59 - N ERROR - D SETSLOT^BPSOSL(ABSBRXI) ; point to slot for logging - N REVERSAL S REVERSAL=$G(^BPST(ABSBRXI,4))>0 - D ; store pointer to response - . N DIE,DA,DR S DIE=9002313.59,DA=ABSBRXI - . S DR=$S(REVERSAL:402,1:4)_"////"_RESPIEN - . D ^DIE - D SETSTAT^BPSOSU(90) ; "Processing response" - ;D LOG^BPSOSL("RESPONSE - Status (Header) = "_$P($G(^BPSR(RESPIEN,500)),U) - N POSITION S POSITION=$P(^BPST(ABSBRXI,0),U,9) - I REVERSAL S POSITION=1 ; but reversals have only 1 transaction - D LOG^BPSOSL("RESPONSE - #"_RESPIEN_", POSITION="_POSITION) - I '$D(^BPSR(RESPIEN,1000,POSITION,500)) S ERROR=1 G RESPBAD - N RESP S RESP=$P(^BPSR(RESPIEN,1000,POSITION,500),U) - D INCSTAT^BPSOSUD("R",$S(RESP="R":2,RESP="P":3,RESP="D":4,RESP="C":5,1:19)) - D - . N X S X="RESPONSE - Position "_POSITION_" = "_RESP - . I RESP="P" S X=X_" $"_$$INSPAID1^BPSOS03(RESPIEN,POSITION) - . D LOG^BPSOSL(X) - ; - ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - look at field 526 - ; (additional message) if nothing found in 504 - N X S X=$G(^BPSR(RESPIEN,1000,POSITION,504)) - I X="" S X=$G(^BPSR(RESPIEN,1000,POSITION,526)) ;IHS/SD/lwj 10/07/02 - I X]"" D LOG^BPSOSL("RESPONSE - MESSAGE - "_X) - ; - I RESP="R" D ; rejected, give rejection reasons - .N J S J=0 F S J=$O(^BPSR(RESPIEN,1000,POSITION,511,J)) Q:'J D - ..N R S R=$P($G(^BPSR(RESPIEN,1000,POSITION,511,J,0)),U) - ..N X I R]"" D - ...S X=$O(^BPSF(9002313.93,"B",R,0)) - ...I X]"" S X=$P($G(^BPSF(9002313.93,X,0)),U,2) - ..E S X="" - ..D LOG^BPSOSL("REJECT - "_R_" - "_X) - ; - S VARX=0 I '$P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) S VARX=1 - N INSURER - I 'VARX S INSURER=$P(^BPST(ABSBRXI,1),U,6) ;LJE - E S INSURER=^BPST(ABSBRXI,9) D - . S INSURER=$$GET1^DIQ(9002313.59902,"1,"_ABSBRXI_",",".01") ;LJE - I $$REJSLEEP^BPSOSQ4(RESPIEN,POSITION) D ; ins. asleep: want to retry - . D SETSTAT^BPSOSU(31) - . N X S X=$$INCSLEEP^BPSOSQ4(INSURER) - . S $P(^BPST(IEN59,8),U)=X_U_U_INSURER - . D LOG^BPSOSL($T(+0)_" - Insurer asleep; retry scheduled for "_X) - E D ; else: a normal kind of response, so we are done - . D CLRSLEEP^BPSOSQ4(INSURER,1) - . D SETSTAT^BPSOSU(99) ; "Done" - . I $G(^BPST(ABSBRXI,3)) D - . . D SETRESU^BPSOSU(0,"Cancellation tried too late; claim sent.") - . E D - . . D SETRESU^BPSOSU(0,"Payable") ; indicates a complete response was received - ; status reports should refer to the ^BPSR entry - D RELSLOT^BPSOSL - Q -RESPBAD ; corrupted response escape from RESP1 ; reached by a GOTO - N MSG S MSG="Corrupted response `"_RESPIEN - D SETSTAT^BPSOSU(99) ; "Done" - D SETRESU^BPSOSU(6500+$G(ERROR),MSG) - D LOG^BPSOSL(MSG) - D DONE^BPSOSL ; close up the logging slot - Q diff -auBN ./r1/BPSOSQS.m ./r2/r/BPSOSQS.m --- ./r1/BPSOSQS.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSQS.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,194 +0,0 @@ -BPSOSQS ;BHAM ISC/FCS/DRS/FLS - special queuing considerations ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; IHS/DSD/lwj 4/18/02 on behalf of Patrick Cox - ; IHS/OKCAO/POC 10/2/01 In Oklahoma there is a general 3 punch - ; a month limitation. However, there are no limitation for kids - ; under the age of 18, or for patients in a nursing home. This - ; change will simply address the limitation on the kids under 18. - ; The maximum number of prescriptions will simply be set to 999 - ; to reflect no limitation. - ; - ; IHS/SD/lwj 6/17/02 on behalf of Patrick Cox - ; IHS/OKCAO/POC 5/22/02 In the subroutine CAIDPAID, the routine - ; attempts to count how many Medicaid paid repsonses have been - ; received for a given month. The script count could be incorrectly - ; inflatted if a script was flled/reflled in a prev month, but was - ; sbmtd/resbmtd in the current month. Original logic was only - ; looking at the month of the claim - not the DOS. Logic - ; changed to use the scripts fill dt/refill dt instead of clm dt. - ; (effected back billing, or resubmittal of previous month scripts - ; when current month limitation had been reached) - ; - ; IHS/SD/lwj 8/28/02 on behalf of Patrick Cox (OKCAO/POC) - ; Cache systems do not allow the reverse dollar order on arrays. - ; Patrick simply reversed the sign in the PRICEORD array, which - ; allowed the values to appear in descending order - this eliminated - ; the need for the reverse $O on the PRICEORD array. - ; - Q -STAT19() ;EP - is called at the bottom of BPSOSQ1 - ; if there are any claims of status 19 - waiting for special - ; Oklahoma Medicaid rule to run its course - N ROU S ROU=$T(+0) - L +^TMP($J,"BPSOSQS"):0 Q:'$T 0 ; only one of these running - N COUNT30 S COUNT30=0 ; count how many 19s got pushed to status 30 - D RULE19 - L -^TMP($J,"BPSOSQS") - ; If there are still any claims with status = 19, - ; then you need to schedule BPSOSQ1 to run again in a little while. - I $D(^BPST("AD",19)) D - . N WAIT S WAIT=$P(^BPS(9002313.99,1,"SPECIAL"),U,2) - . S:'WAIT WAIT=60 - . S WAIT="."_$TR($J(WAIT\3600,2)_$J(WAIT#3600\60,2)_$J(WAIT#60,2)," ","0") - . D TASKAT^BPSOSIZ($$TADDNOW^BPSOSUD(WAIT)) - Q COUNT30 -RULE19 ; - N INCYCLE,NLIMIT,SINCEDAT,PAT,IEN59,STAT,LASTUPD,I,X,Y - ; - ; Gather all the claims with status 19 into ^TMP($J,"BPSOSQS",$J,PAT,19,IEN59) - ; Medicaid claims only - already taken care of, in that only - ; Medicaid claims can ever be in status 19 - ; For any status, just set ^TMP($J,"BPSOSQS",$J,PAT,status)=latest last-update - ; to make it easy to detect if a given patient has any non-19's. - ; - K ^TMP($J,"BPSOSQS") - S STAT="",IEN59=0 - F S STAT=$O(^BPST("AD",STAT)) Q:STAT="" Q:STAT=99 D - . S IEN59=0 - . F S IEN59=$O(^BPST("AD",STAT,IEN59)) Q:'IEN59 D - . . ; $G() in next line guards against corrupt index - . . S PAT=$P($G(^BPST(IEN59,0)),U,6) Q:'PAT - . . S LASTUPD=$P(^BPST(IEN59,0),U,8) - . . S X=$G(^TMP($J,"BPSOSQS",$J,PAT,STAT)) - . . I LASTUPD>X S ^TMP($J,"BPSOSQS",$J,PAT,STAT)=LASTUPD - . . I STAT=19 S ^TMP($J,"BPSOSQS",$J,PAT,STAT,IEN59)="" - ; - ; Loop for each such patient: - S PAT="" F S PAT=$O(^TMP($J,"BPSOSQS",$J,PAT)) Q:'PAT D - . I '$D(^TMP($J,"BPSOSQS",$J,PAT,19)) Q ; no 19's for this patient; nothing to do - . D PAT19 - Q -PAT19 ; Then look at each patient's situation: - ; - ; If the patient has any claims with status 20-98 (i.e., actively - ; going through ECME right now) then leave their 19s as 19 for now. - ; What we do with these depends on how the others turn out. - ; - ; Also, if the patient has any with status <19, wait for those to - ; catch up - because apparently, data entry is still going on - ; and we want to wait, so we just pick off the three highest-priced. - ; - I $O(^TMP($J,"BPSOSQS",$J,PAT,""))'=19 Q ; there are some w/status < 19 - I $O(^TMP($J,"BPSOSQS",$J,PAT,19))'="" Q ; there are some w/status > 19 - ; - ; IHS/DSD/lwj 04/18/02 on behalf of IHS/OKCAO/POC 10/2/2001 - ; begin changes - ; - ;N LIMIT,MAX S MAX=3 S LIMIT=MAX-$$CAIDPAID ;IHS/OKCAO/POC rmkd out - N BPSINS,BPSERR,LIMIT,MAX,DFN ;IHS/OKCAO/POC new def - ; - ; In the BPS setup file, there is a special node: - ; ^BPS(9002313.99,1,"SPECIAL")=OK MEDICAID INS NAME^OK MEDICAID - ; CYCLE^OK MEDICAID LIMIT - ; This portion of the code is retrieving the INS name, and the limits - ; If the insurer is Oklahoma, we will adjust the limits for kids - ; - S BPSINS=$$GET1^DIQ(9002313.99,"1,",1960.01,"","","BPSERR") - S MAX=+$P($G(^BPS(9002313.99,1,"SPECIAL")),U,3) ;IHS/OKCAO/POC def - S:'MAX MAX=3 ;IHS/OKCAO/POC use def when pos - ; - ;If this is for Oklahoma and patient is under 18 extend limits - ; (insurance name is either Oklahoma Medicaid or Oklahoma) - ; ONLY FOR IHS DLF I ($G(BPSINS)["OKLAHOMA")&($$AGE^AUPNPAT(PAT)<18) S MAX=999 - ; - S LIMIT=MAX-$$CAIDPAID - ; - ; IHS/DSD/lwj 04/18/02 for IHS/OKCAO/POC 10/2/01 end changes - ; - ; - ; LIMIT = how many more paid responses we're allowed for this month - ; - ; If LIMIT=0, we've used up our limit of Medicaid prescriptions - ; for the month. Each of these will have to bump to the next - ; insurer. (For now, just reject them - ; - I LIMIT=0 D Q - . S IEN59=0 F S IEN59=$O(^TMP($J,"BPSOSQS",$J,PAT,19,IEN59)) Q:'IEN59 D - . . D SETSLOT^BPSOSL(IEN59) - . . N MSG S MSG="Medicaid monthly limit of "_MAX_" reached." - . . D LOG^BPSOSL(MSG) - . . I $$BUMPINS^BPSOSQA(IEN59) D ; bump to next insurer - . . . ; Succeeded, there is more insurance ; - . . . ; And $$BUMPINS reset status to 0 - . . . D LOG^BPSOSL(" We will try the next insurer.") - . . E D - . . . ; Failed - no more insurance - $$BUMPINS set status to 99 - . . . N ABSBRXI S ABSBRXI=IEN59 ; unfortunate variable naming - . . . D SETRESU^BPSOSU(19,MSG) - . . D RELSLOT^BPSOSL - ; - ; We can still submit some Medicaid prescriptions, but let's - ; make sure we have all the ones that we're going to get at - ; this visit - make sure that the most recent activity on - ; any of the status 19 claims is at least 2 minutes old. - ; Otherwise, there may be some more coming, and we would rather - ; wait and make sure we get the more expensive ones. - I $$TDIFNOW^BPSOSUD(^TMP($J,"BPSOSQS",$J,PAT,19))<$P(^BPS(9002313.99,1,"SPECIAL"),U,2) Q - ; - ; If LIMIT>0, then take this many of the patient's status 19 claims - ; and change them to status 30. Any other 19s stay as 19s, - ; as we need to wait and see how the others turn out. If they're - ; rejected, we could still submit a few of the other 19s. - ; - N PRICEORD ; set PRICEORD(price,ien59)="" for each of this pat's 19s - N PRICE,N - S IEN59=0 - F S IEN59=$O(^TMP($J,"BPSOSQS",$J,PAT,19,IEN59)) Q:'IEN59 D - . N PRICE S PRICE=$P(^BPST(IEN59,5),U,5) - . ;IHS/SD/lwj 8/28/02 on behalf of IHS/OKCAO/ECME nxt line remarked - . ; out, following line added - . ; S PRICEORD(PRICE,IEN59)="" ;IHS/OKCAO/ECME 8/28/02 - . S PRICEORD(0-PRICE,IEN59)="" ;IHS/OKCAO/POC 8/28/02 reverse order - S PRICE="",N=0 - F D Q:PRICE="" Q:N=LIMIT - . ;IHS/SD/lwj 8/28/02 on behalf of IHS/OKCAO/POC nxt line remarked - . ;out, following line added (reverse $O does not work on arrays - . ;Cache) - . ;S PRICE=$O(PRICEORD(PRICE),-1) Q:PRICE="" ; from highest to lowest - . S PRICE=$O(PRICEORD(PRICE)) Q:PRICE="" ; from highest to lowest - . S IEN59=0 - . F S IEN59=$O(PRICEORD(PRICE,IEN59)) Q:IEN59="" Q:N=LIMIT D - . . N ABSBRXI S ABSBRXI=IEN59 D SETSTAT^BPSOSU(30) - . . S N=N+1 ; how many submitted for this patient - . . S COUNT30=COUNT30+1 ; how many submitted in total by this routine - Q -CAIDPAID() ; count how many Medicaid paid responses for this patient - ; this month, up to 3 maximum - ; given PAT = patient IEN; MAX=3 - ; - ; IHS/OKCAO/ECME 5/22/02 (IHS/SD/lwj 6/17/02) changed to look - ; at month script was filled/refilled for considering script in cnt - ; - N INS S INS=$P(^BPS(9002313.99,1,"SPECIAL"),U) ; insurer we seek - N FOUND S FOUND=0 ; count how many are found - N SINCE S SINCE=DT,$E(SINCE,6,7)="00" ; yyymm00 - N IEN59,STOP S IEN59=0,STOP=0 - F S IEN59=$O(^BPST("AC",PAT,IEN59)) D Q:STOP - . I 'IEN59 S STOP=1 Q - . S X=^BPST(IEN59,0) - . ; IHS/OKCAO/POC 05/22/02 (IHS/SD/lwj 6/17/02) begin changes - . ;I $P(X,U,8)74 ! - . . ; Handle the case where the job was killed: - . . ; Run flag says its running but the lock says it's not - . . ; So force run flag to say "stopped". - . . I $$STATUS="REQUESTED STOP?" D SETFIELD(120.03,2) - Q -DELAYSTP(N) H N D STOPIT() Q ; J TEST^BPSOSR1 for your testing - ; - ; Advice for testing: - ; 0. Init ^BPS(9002313.99,"BPSOSR1")=a starting T1 time - ; Just do this once, ever. - ; - ; Then for each time you do testing: - ; 1. DO NEXT^BPSOSR1(N) ; N = desired number of transactions - ; and it sets T1,T2 so you get N transactions - ; 2. D TEST^BPSOSR1 to actually run the test. - ; When done, it will update ^BPS(9002313.99,"BPSOSR1") - ; to be 1 second past the previous T2 that you used. - ; 3. DO ^BPSOS (which goes to EN^BPSOS6A) to watch the results. - ; 4. D LASTLOG^BPSOSR1 to examine the .3 log and see what's going on -TEST W !,"Running the test - times ",T1,"-",T2,! - I '$$LOCK W "Can't get LOCK",! Q - D INIT^BPSOSL(.3,1) - D DEFAULTS - D KTESTLST - D WORKLIST^BPSOSR3(T1,T2,$$TESTLIST) - D PROCESS^BPSOSR3($$TESTLIST) - D LASTLOG - D UNLOCK - S $P(^BPS(9002313.99,"BPSOSR1"),U)=$$TADD^BPSOSUD(T2,.000001) - Q -KTESTLST K ^BPSECP($T(+0)_" TESTING") Q -TESTLIST() Q "^BPSECP("""_$T(+0)_" TESTING"")" -LASTLOG ; tool for test - find and print most recent log file - N X S X=2990000 - F S X=$O(^BPSECP("LOG",X),-1) Q:'X Q:X#1=.3 - I 'X W "No log file found",! Q - D PRINTLOG^BPSOSL(X) - Q -EN ; EP - via Taskman as initiated by START, above - ; main program for background job to stealthily submit claims - ; changes to EN should be mimicked in TEST(), above - I '$$LOCK Q - N RESTART - D SETFIELD(120.01,$J),SETFIELD(120.03,0) - D INIT^BPSOSL(DT+.3,1) - D LOG("Background claim submitter running as job "_$J) - D DEFAULTS - D MONITOR^BPSOSR3 ; may set RESTART - D LOG("Background claim submitter job "_$J_" completed.") - D RELSLOT^BPSOSL - D UNLOCK - I $G(RESTART) D TASK - Q -DEFAULTS ;EP - - I '$$GETFIELD(120.02) D SETFIELD(120.02,"NOW","E") ; last time proc'd - I '$$GETFIELD(120.04) D SETFIELD(120.04,30) ; default interval 30 sec - ; 30 secs is the minimum! you have to allow time for BPSOSRX - ; to get background jobs started, to create .59 entries, etc. - I '$$GETFIELD(120.05) D SETFIELD(120.05,30) ; reach back more sec - ; but you miss something if they enter it now with a release time - ; of an hour ago, or yesterday - I $$GETFIELD(120.06)="" D SETFIELD(120.06,"AL") ; index for new claims - I $$GETFIELD(120.07)="" D SETFIELD(120.07,"AJ") ; index for canceled - Q -SETFIELD(FIELD,VALUE,FLAGS) ;EP - - N FDA,IENS,MSG,FN S IENS="1,",FN=9002313.99 - S FDA(FN,IENS,FIELD)=VALUE -SF1 D FILE^DIE($G(FLAGS),"FDA","MSG") - Q:'$D(MSG) ; success - D ZWRITE^BPSOS("FLAGS","FDA","MSG","FIELD","VALUE") - G SF1:$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"SETFIELD",$T(+0)) - Q -GETFIELD(FIELD) ;EP - - Q $P($G(^BPS(9002313.99,1,"BPSOSR1")),U,FIELD-120*100) -LOCK() L +^BPS(9002313.99,"BPSOSR1"):0 Q $T -UNLOCK L -^BPS(9002313.99,"BPSOSR1") Q -LOG(X) D LOG^BPSOSL(X) Q diff -auBN ./r1/BPSOSR2.m ./r2/r/BPSOSR2.m --- ./r1/BPSOSR2.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSR2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,22 +0,0 @@ -BPSOSR2 ;BHAM ISC/FCS/DRS/FLS - silent claim submitter ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; SHOWQ subroutine - continuation of BPSOSRX - Q -SHOWQ ;EP - BPSOSRX ; ^BPSECP("BPSOSRX",type,RXI,RXR) - N ROOT S ROOT="^BPSECP(""BPSOSRX"")" - N COUNT S COUNT=0 - I '$O(@ROOT@(""))="" W "None",! Q - N TYPE,RXI,RXR - F TYPE="CLAIM","UNCLAIM" D - . W TYPE - . I '$D(@ROOT@(TYPE)) W " - none",! Q - . W ":",! - . S RXI="" F S RXI=$O(@ROOT@(TYPE,RXI)) Q:RXI="" D - . . S RXR="" F S RXR=$O(@ROOT@(TYPE,RXI,RXR)) Q:RXR="" D - . . . W RXI,",",RXR - . . . ; details like patient, drug could go here - . . . W ! - . . . S COUNT=COUNT+1 - . W "Total ",COUNT," ",TYPE W:COUNT'=1 "s" - . W ! - Q diff -auBN ./r1/BPSOSR4.m ./r2/r/BPSOSR4.m --- ./r1/BPSOSR4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSR4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,81 +0,0 @@ -BPSOSR4 ;BHAM ISC/FCS/DRS/FLS - back billing ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; Back billing - similar to BPSOSR3 - ; and in fact, it uses BPSOSR3 subroutines to do much of its work. - ; It depends very much on the BPSOSR3 flag to DO NOT RESUMBIT. - ; (We want to backbill, not rebill!) - ; - ; Might be programmer mode only, though an option could certainly - ; point here. - Q ; -BACKBILL ;EP - - N RANGE,X - S X=$$DTR^BPSOSU1("Backbill starting at date@time: ","Backbill thru what date@time: ",,,"T") - Q:'X - N BEGINDT,ENDDT S BEGINDT=$P(X,U),ENDDT=$P(X,U,2) - I $P(ENDDT,".",2)="" S $P(ENDDT,".",2)=24 ; assume entire day - D INIT^BPSOSL(DT+.6,1) - D LOG("Back billing with range "_BEGINDT_"-"_ENDDT) - D LOG(" (from "_$$CVTDATE(BEGINDT)_" thru "_$$CVTDATE(ENDDT)_")") - N THELIST S THELIST=$$THELIST D KILLLIST - ; - I 1'=$$YESNO^BPSOSU3("Backbill for "_$$CVTDATE(BEGINDT)_" thru "_$$CVTDATE(ENDDT)_"; are you sure","N",0) D Q - . W !,"Okay, nothing is done.",! - ; - W !!,"Processing...",! H 1 - ; - ; Gather list of prescriptions that need to be back billed. - ; - D LOG("Building the list of prescriptions to back bill for...") - D WORKLIST^BPSOSR3(BEGINDT,ENDDT,THELIST) - N COUNT S COUNT=$$DUMPLIST(THELIST) - W !!,"Count of transactions in the work list: ",COUNT,!! - I 'COUNT G EXIT - H 3 - ; - ; We now have @THELIST@(time,type,rxi,rxr) - ; time = date/time of pharmacy activity - ; type = 1 for claim, 2 for returned to stock - ; rxi,rxr points to prescription, refill - ; - ; And now bill them all - ; - D LOG("Submitting all the claims...") - N RETVAL - I 0 D - . D LOG("Short-circuit - not just yet") D - . S RETVAL=$$DUMPLIST(THELIST) - E D - . D PROCESS^BPSOSR3(THELIST) - ; - W !,"Done! There may still be processing going on in the background.",! - W "The usual ECME programs can be used to examine",! - W "any ongoing progress on these claims.",! - W "The usual ECME reports can be run; you should wait",! - W "until all the background processing of the back billing has finished.",! - W ! - W "Also note that before trying to run reports, you should",! - W "run URM (on the CLA reports menu) for the date range.",! - H 5 -EXIT D LOG("Complete.") - D RELSLOT^BPSOSL - Q - ; -LOGFILE D LOGFILE1^BPSOSR1(.6) Q -DUMPLIST(X) ; $G(X)=0 to count and return total - ; X=1 to dump contents to log file - N TIME,TYPE,RXI,RXR,COUNT S COUNT=0 - D LOG("Contents of THELIST:") - S TIME="" F S TIME=$O(@THELIST@(TIME)) Q:TIME="" D - . S TYPE="" F S TYPE=$O(@THELIST@(TIME,TYPE)) Q:TYPE="" D - . . S RXI="" F S RXI=$O(@THELIST@(TIME,TYPE,RXI)) Q:RXI="" D - . . . S RXR="" F S RXR=$O(@THELIST@(TIME,TYPE,RXI,RXR)) Q:RXR="" D - . . . . D LOG(TIME_" "_TYPE_" "_RXI_" "_RXR) - . . . . S COUNT=COUNT+1 - Q COUNT -LOG(X) D LOG^BPSOSL(X) Q - ; Keep THELIST and KILLLIST in agreement! -THELIST() Q "^BPSECP("""_$T(+0)_""","_$J_","_BEGINDT_")" -KILLLIST K ^BPSECP($T(+0),$J,BEGINDT) Q ; safer than K @ -CVTDATE(Y) X ^DD("DD") Q Y diff -auBN ./r1/BPSOSRB.m ./r2/r/BPSOSRB.m --- ./r1/BPSOSRB.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSRB.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,127 +0,0 @@ -BPSOSRB ;BHAM ISC/FCS/DRS/FLS - background from BPSOSRX ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -BACKGR ; - I '$$LOCKNOW^BPSOSRX("BACKGROUND") Q - N BACKSLOT S BACKSLOT=DT+.4 - D INIT^BPSOSL(BACKSLOT,1,-1) - N LIST,TYPE,RXI,RXR S LIST="BPSOSRX" - I '$$LOCK^BPSOSRX("BACKGROUND") D G FAIL - . D LOG^BPSOSL("Failed to $$LOCK^BPSOSRX(""BACKGROUND"")") - I $D(MOREDATA("DIALOUT")) S VADIAL=MOREDATA("DIALOUT") ;LJE - F TYPE="CLAIM","UNCLAIM" D - . S RXI="" F S RXI=$O(^BPSECP(LIST,TYPE,RXI)) Q:RXI="" D - . . S RXR="" F S RXR=$O(^BPSECP(LIST,TYPE,RXI,RXR)) Q:RXR="" D - . . . N X S X=$$STATUS(RXI,RXR) - . . . I $P(X,U)="IN PROGRESS" D Q - . . . . D LOG^BPSOSL(RXI_","_RXR_" in progress; wait") - . . . N TIME,MOREDATA - . . . S TIME=^BPSECP(LIST,TYPE,RXI,RXR) ; time requested - . . . I '$$LOCK^BPSOSRX("SUBMIT") D Q - . . . . D LOG^BPSOSL("Failed to $$LOCK^BPSOSRX(""SUBMIT"") for RXI="_RXI_",RXR="_RXR) - . . . I $D(^BPSECP(LIST,TYPE,RXI,RXR,"MOREDATA")) M MOREDATA=^("MOREDATA") - . . . E S MOREDATA=0 - . . . K ^BPSECP(LIST,TYPE,RXI,RXR) - . . . D BACKGR1(TYPE,RXI,RXR,TIME,.MOREDATA) - . . . D UNLOCK^BPSOSRX("SUBMIT") - . . . I $P($G(^BPS(9002313.99,1,"SITE TYPE")),"^",1) D HANG ;LJE; don't hang for VA Rx's -FAIL D RELSLOT^BPSOSL - D UNLOCK^BPSOSRX("BACKGROUND") - Q -STARTTIM(RXI,RXR) Q $P($G(^BPST($$IEN59(RXI,RXR),0)),U,11) -BACKGLOG(X) ; - N MSG S MSG=RXI_","_RXR_" "_$S(TYPE="CLAIM":"",1:TYPE)_" "_X - D LOG2SLOT^BPSOSL(MSG,BACKSLOT) - Q -BACKGR1(TYPE,RXI,RXR,TIME,MOREDATA) ; - ; Resolve multiple requests - N SKIP S SKIP=0 ; skip if you already got desired result - N SKIPREAS - N RESULT S RESULT=$$STATUS(RXI,RXR),RESULT=$P(RESULT,U) - ;I RXI=502757 S RESULT="" - N STARTTIM S STARTTIM=$$STARTTIM(RXI,RXR) - I TYPE="CLAIM" D - . I $$RXDEL^BPSOS(RXI,RXR) D Q - . . S SKIP=1,SKIPREAS="is marked as DELETED or CANCELLED" - . ; If it's never been through ECME before, good. - . I RESULT="" Q - . ; There's already a complete transaction for this RXI,RXR - . ; (We screened out "IN PROGRESS" earlier) - . ; The program to poll indexes would have set DO NOT RESUBMIT. - . ; Calls from pharm pkg to ECME have '$D(MOREDATA("DO NOT RESUBMIT")) - . I $D(MOREDATA("DO NOT RESUBMIT")) D - . . S SKIP=1 - . . S SKIPREAS="MOREDATA(""DO NOT RESUBMIT"") is set" - . E I TIME " - . N P S P=$O(^BPS(9002313.56,"C",A,0)) - . I P D - . . I ECHO W $P(^BPS(9002313.56,P,0),U),! - . E D - . . S RET=0 - . . I ECHO W "** no associated ECME pharmacy!! **",! - Q RET -PROBLEM W !,"*** PROBLEM FOUND:",! Q diff -auBN ./r1/BPSOSSG.m ./r2/r/BPSOSSG.m --- ./r1/BPSOSSG.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSSG.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,229 +0,0 @@ -BPSOSSG ;BHAM ISC/SD/lwj/FLS - Special gets for formats ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -COLSTATE() ;EP entry point frm clm frmt for Colorado State Lic - N BPSST,BPSFND,BPSLIC,BPSPRO ;state IEN, fnd ind, state lic - S (BPSST,BPSFND,BPSLIC,BPSPRO)="" - S BPSPRO=$G(BPS("RX",BPS(9002313.0201),"Prescriber IEN")) ;for 200 - I BPSPRO S BPSPRO=$P($G(^VA(200,BPSPRO,0)),U,16) ;get prov - I BPSPRO'="" D - . F S BPSST=$O(^DIC(6,BPSPRO,999999921,BPSST)) Q:BPSST="" D - .. I $P($G(^DIC(5,BPSST,0)),U)["COLORADO" D - ... S BPSLIC=$P($G(^DIC(6,BPSPRO,999999921,BPSST,0)),U,2) - ... S BPSFND=1 - ... S BPSST=99999999 - I 'BPSFND S BPSLIC=BPS("Site","Default CAID #") - Q BPSLIC - ;******************************************************************* -STATE(STATE) ;EP IHS/SD/lwj 10/28/02 retrieve the state license number - N STPOINT,DRPOINT,LIPOINT,LICENSE - S (STPOINT,DRPOINT,LIPOINT,LICENSE)="" - S STPOINT=$O(^DIC(5,"C",STATE,0)) ;state pointer - S DRPOINT=$G(BPS("RX",BPS(9002313.02),"Prescriber IEN")) ;prsc pntr - ; - ; get the license pointer - S:STPOINT&DRPOINT LIPOINT=$O(^VA(200,DRPOINT,"PS1","B",STPOINT,0)) - S:LIPOINT LICENSE=$P($G(^VA(200,DRPOINT,"PS1",LIPOINT,0)),U,2) - ; - S:LICENSE="" LICENSE=$G(BPS("Site","Default CAID #")) - ; - Q LICENSE - ; -NEW416() ; IHS/SD/lwj 8/30/02 NCPDP 5.1 - N PATYPE,PANUM,PA - ; - S PATYPE=$E($G(BPS("X")),1,1) - S PANUM=$E($G(BPS("X")),2,12) - S PA="DG"_$G(PATYPE)_$$NFF^BPSECFM($G(PANUM),11) - ; - Q PA -FMT416() ;---------------------------------------------------------------- - N BPSPA,BPSCD,BPSPC - S BPSCD=$S(BPS("X")=2:2,BPS("X")=4:4,BPS("X")=5:5,1:$S(BPS("X"):"1",1:"0")) - I (BPS("X")=5)!(BPS("X")=2)!(BPS("X")=4) D ;prs lmt/med cert/cpy - . S BPSPA=$$NFF^BPSECFM("",11) - I (BPS("X")'=5)&(BPS("X")'=2)&(BPS("X")'=4) D ;prior authorization - . S BPSPA=$$NFF^BPSECFM($G(BPS("X")),11) - ; - S BPSPC="DG"_BPSCD_BPSPA - ; - Q BPSPC -FLD308 ;Other Coverage Code - S $P(^BPSC(BPS(9002313.02),300),U,8)=BPS("X") - I $D(BPS(9002313.0201)) D - . S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),300),U,8)=BPS("X") - ; - Q - ; -FLD315 ;Employer Name - S $P(^BPSC(BPS(9002313.02),300),U,15)=BPS("X") - I $D(BPS(9002313.0201)) D - . S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),310),U,5)=BPS("X") - ; - Q - ; -FLD316 ;Employer Street Address - ; 3.2/5.1 Set Code - called by set command in BPS NCPDP Field DEfs - ; - ;3.2 Set - S $P(^BPSC(BPS(9002313.02),300),U,16)=BPS("X") - ; - ;5.1 Set - I $D(BPS(9002313.0201)) D - . S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),310),U,6)=BPS("X") - ; - Q - ; -FLD317 ;Employer City Address - ;3.2/5.1 Set Code - called by set command in BPS NCPDP Field Defs - ; - ;3.2 Set - S $P(^BPSC(BPS(9002313.02),300),U,17)=BPS("X") - ; - ;5.1 Set - I $D(BPS(9002313.0201)) D - . S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),310),U,7)=BPS("X") - ; - Q - ; -FLD318 ;Employer State/Prov Address - ;3.2/5.1 Set Code - called by set command in BPS NCPDP Field Defs - ; - ;3.2 Set - S $P(^BPSC(BPS(9002313.02),300),U,18)=BPS("X") - ; - ;5.1 Set - I $D(BPS(9002313.0201)) D - . S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),310),U,8)=BPS("X") - ; - Q - ; -FLD319 ;Employer Zip/Postal Zip - ;3.2/5.1 Set Code - called by set command in BPS NCPDP Field Defs - ; - ;3.2 Set - S $P(^BPSC(BPS(9002313.02),300),U,19)=BPS("X") - ; - ;5.1 Set - I $D(BPS(9002313.0201)) D - . S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),310),U,9)=BPS("X") - ; - Q - ; -FLD320 ;Employer Phone Number - ;3.2/5.1 Set Code - called by set command in BPS NCPDP Field Defs - ; - ;3.2 Set - S $P(^BPSC(BPS(9002313.02),320),U,20)=BPS("X") - ; - ;5.1 Set - I $D(BPS(9002313.0201)) D - . S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),310),U,10)=BPS("X") - ; - Q - ; -FLD327 ;Carrier ID - ;3.2/5.1 Set Code - called by set command in BPS NCPDP Field Defs - ; - ;3.2 Set - S $P(^BPSC(BPS(9002313.02),320),U,27)=BPS("X") - ; - ;5.1 Set - I $D(BPS(9002313.0201)) D - . S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),320),U,7)=BPS("X") - ; - Q -FLD439 ;Reason for service code - ; - ;3.2 Set - I '$G(BPS51) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),430),U,9)=BPS("X") - ; - ;5.1 Set - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1,BPS51=1 - I $G(BPS51) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,2)=BPS("X") - ; - Q - ; -FLD440 ;Professional Service Code - ; - ;3.2 Set - I '$G(BPS51) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),430),U,10)=BPS("X") - ; - ;5.1 Set - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1,BPS51=1 - I $G(BPS51) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,3)=BPS("X") - ; - Q - ; -FLD441 ;Result of Service Code - ; - ;3.2 Set - I '$G(BPS51) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),440),U,1)=BPS("X") - ; - ;5.1 Set - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1,BPS51=1 - I $G(BPS51) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,4)=BPS("X") - ; - Q - ; -FLD473 ;DUR/PPS code counter - called from set logic in BPS NCPDP Field Defs - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1,BPS51=1 - S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,1)=BPS("X") - S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,"B",BPS("X"),DUR)="" - ; - Q - ; -FLD480 ;lje;7/23/03;VA - Other Amount Claimed Submitted field - Q:BPS("X")=""!(BPS("X")=0)!($TR(BPS("X"),"{}0.H7H8H9")="") - S FDA(9002313.0601,"+1,"_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)="H7"_1 - S FDA(9002313.0601,"+1,"_BPS(9002313.0201)_","_BPS(9002313.02)_",",480)=BPS("X") - S FDA(9002313.0601,"+1,"_BPS(9002313.0201)_","_BPS(9002313.02)_",",479)="H8"_$G(BPS("Insurer","Other Amt Claim Sub Qual")) - D UPDATE^DIE("","FDA","BPS(9002313.0601)","MSG") - I $D(MSG) D LOG^BPSOSL("Failed to update NCPDP field 480 and/or 479") - I $D(MSG) D LOGARRAY^BPSOSL("MSG") - Q - ; -EMPL ;lje;7/18/03; get employer info for VA - Q:'$G(BPS("Patient","IEN")) - D GETS^DIQ(2,BPS("Patient","IEN"),".3111;.3112;.3113;.3115;.3116;.3117;.3118;.3119","","EMPL") - S BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3111) - S:EMPL(2,BPS("Patient","IEN")_",",.3111)=""&(EMPL(2,BPS("Patient","IEN")_",",.3112)'="") BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3112) - S BPS("Employer","Address")=EMPL(2,BPS("Patient","IEN")_",",.3113) - S BPS("Employer","City")=EMPL(2,BPS("Patient","IEN")_",",.3116) - S BPS("Employer","State")=EMPL(2,BPS("Patient","IEN")_",",.3117) - I BPS("Employer","State")'="" D - . S STATEIEN="",STATEIEN=$O(^DIC(5,"B",BPS("Employer","State"),STATEIEN)),BPS("Employer","State")=$P($G(^DIC(5,STATEIEN,0)),"^",2) - S BPS("Employer","Zip Code")=EMPL(2,BPS("Patient","IEN")_",",.3118) - S BPS("Employer","Phone")=EMPL(2,BPS("Patient","IEN")_",",.3119) - K EMPL,STATEIEN - Q -FLD474 ;DUR/PPS level of effort - called from set logic in BPS NCPDP Field - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1 - S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,5)=BPS("X") - ; - Q - ; -FLD475 ;DUR Co-agent ID Qualifier - called from set logic in BPS NCPDP Field - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1 - S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,6)=BPS("X") - ; - Q - ; -FLD476 ;DUR Co-agent ID - called from set logic in BPS NCPDP Field - I ^BPS(9002313.99,1,"CERTIFIER")=DUZ S DUR=1 - S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,7)=BPS("X") - ; - Q - ; -FLD402 ; - I '$D(TYPE) Q - I $G(TMP("9002313.0201",RX,"402","I")) I TYPE="CLAIM" D - .I TMP("9002313.0201",RX,"402","I")[401944 S BPS("X")=7 - .I TMP("9002313.0201",RX,"402","I")[401959 S BPS("X")=1 - .I TMP("9002313.0201",RX,"402","I")[401974 S BPS("X")=2 - .I TMP("9002313.0201",RX,"402","I")[401976 S BPS("X")=3 - .I TMP("9002313.0201",RX,"402","I")[401958 S BPS("X")=4 - .I BPS("X")="" S BPS("X")=TMP("9002313.0201",RX,"402","I") - .I BPS("RX",BPS(9002313.0201),"RX IEN")=401944 S BPS("X")=401944 - I TYPE="UNCLAIM" S BPS("X")=$S(RXI=401944:7,1:RXI) - Q diff -auBN ./r1/BPSOSU1.m ./r2/r/BPSOSU1.m --- ./r1/BPSOSU1.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSU1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,182 +0,0 @@ -BPSOSU1 ;BHAM ISC/FCS/DRS/FLS/DLF - copied for ECME ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Standard Date Functions - ;---------------------------------------------------------------------- - ;Standard Date PROMPT: - ; - ;Parameters: - ; PROMPT = Text to be displayed before read - ; DFLT = Default date (internal format) - ; OPT = 1 - Answer optional 0 - Answer required - ; SDATE = Minimum date (internal format or NOW and DT) - ; EDATE = Maximum date (internal format or NOW and DT) - ; %DT = E - Echo answer R - Require time - ; S - Seconds returned T - Time allowed but not req - ; X - Exact date req - ; TIMEOUT = Number of seconds - ; - ;Returns: - ; = No response <^> - Up-arrow entered - ; <-1> = Timeout occurred <^^> - Two up-arrows entered - ; = Internal FM Date - ;---------------------------------------------------------------------- - ; IHS/SD/lwj 8/5/02 NCPDP 5.1 changes - ; Subroutine FM3EXT cloned from FM2EXT - routine used to transfer - ; the dates. Now that NCPDP 5.1 stores the field ID with all the - ; fields, we needed currently just want to skip transforming the - ; date for 5.1 type claims - ; - ; - ;---------------------------------------------------------------------- -DATE(PROMPT,DFLT,OPT,SDATE,EDATE,%DT,TIMEOUT) ;EP - - ; - N XDATA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - ; - Q:$G(PROMPT)="" "" - ; - S $P(DIR(0),"^",1)="DA"_$S(OPT=1:"O",1:"") - S $P(XDATA,":",1)=SDATE - S $P(XDATA,":",2)=EDATE - S $P(XDATA,":",3)=%DT - S $P(DIR(0),"^",2)=XDATA - S DIR("A")=PROMPT - S:$G(DFLT)'="" DIR("B")=$$FM2EXT(DFLT) - S:+$G(TIMEOUT)>0 DIR("T")=TIMEOUT - D ^DIR - Q $S($G(DTOUT)=1:-1,$G(DIROUT)=1:"^^",$G(DUOUT)=1:"^",1:Y) - ;---------------------------------------------------------------------- - ;Convert FileMan Date to External Date Format - ; - ;Parmeters: Y - FileMan formatted date (YYYMMDD.HHMMSS) - ;Returns: Y - External date - ;---------------------------------------------------------------------- -FM2EXT(Y) ;EP - Q:$G(^DD("DD"))="" "" - X ^DD("DD") - Q $S($E(Y,1,3)?3A:Y,1:"") - ;---------------------------------------------------------------------- - ; -FM3EXT(Y) ;EP IHS/SD/lwj 8/5/02 clone of FM2EXT- accomodates 5.1 type clms - Q:$E(Y,1,1)["C" Y - S Y=Y-17000000 - Q:$G(^DD("DD"))="" "" - X ^DD("DD") - Q $S($E(Y,1,3)?3A:Y,1:"") - ;---------------------------------------------------------------------- - ; -FM2MDY(Y) ;EP - Q:Y="" "" - Q $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) - ;---------------------------------------------------------------------- - ;Convert External Date to FileMan Date Format - ; - ;Parameters: X - External date - ;Returns: Y - FileMan formatted date (YYYMMDD.HHMMSS) - ;---------------------------------------------------------------------- -EXT2FM(X) ; - N %DT,Y - Q:$G(X)="" "" - D ^%DT - Q Y - ;---------------------------------------------------------------------- - ;Returns current Date/Time in FileMan date format -NOWFM() ;EP - N %,%H,%I,X - D NOW^%DTC - Q % -NOWEXT() ;EP - External form of $$NOWFM - N Y S Y=$$NOWFM X ^DD("DD") Q Y - ;---------------------------------------------------------------------- - ;Takes a FileMan date and adds or subtracts days - ; - ;Parameters: X1 - FileMan formatted date - ; X2 - Number of days (ECME = add, neg = subtract) - ;Returns: X - Resulting FileMan formatted date - ;---------------------------------------------------------------------- -CDTFM(X1,X2) ;EP - BPSER*,BPSES02 - N X,%H - Q:$G(X1)="" "" - Q:$G(X2)="" "" - D C^%DTC - Q X - ;---------------------------------------------------------------------- - ;Takes a FileMan date and returns 3-digit julian date -JULDATE(DT) ; - N X,X1,X2,%H,%T,%Y - Q:'(DT?7N) "" - S X2=$E(DT,1,3)_"0101",X1=DT - D ^%DTC - S X=X+1 - Q $TR($J(X,3)," ","0") - ;---------------------------------------------------------------------- - ; - ;$$DTR(AA,AB,ADEF,BDEF,T) Input Beginning & Ending prompts, return - ; "Begin date^End date" or 0 if unsuccessful. - ;$$DTR() is okay - all args are optional - ;$$DTP(AA,DEF) Input a prompt, return a single date "Internal^External" - ;$$DTM(AA,DEF) Input a prompt, return month/year "Internal^External" - ;-------------------------------------------------------------------- - ; -DTR(AA,AB,ADEF,BDEF,T) ;EP - GET THE DATE RANGE (beginning and ending dates) - ; IN: - ; AA = PROMPT for BEGINNING DATE - ; AB = PROMPT for ENDING DATE - ; ADEF = DEFAULT date for BEGINNING DATE - ; BDEF = DEFAULT date for ENDING DATE - ; T = whether TIME is allowed as entry, and if REQUIRED - ; (If T="T" then TIME is allowed; is REQ'd if T="R"). - ; OUT: - ; Beginning Date^Ending Date in 7digit FileMan format - ; If user enters "^" then out=0 - ; - NEW %DT,X,Y,U,PROMPT,DEFAULT,BEGDT,ENDDT - S U="^" - ; -DTR1 ; -- Get beginning date - S %DT="AE"_$G(T) - I $D(AA) S PROMPT=AA - E S PROMPT="Enter the Beginning Date"_$S($G(T)]"":" @ Time",1:"")_": " - S:$D(ADEF) DEFAULT=ADEF - S BEGDT=$$DATE^BPSOSU1(PROMPT,$G(DEFAULT),1,1000101,3991231,%DT,$G(DTIME)) - I BEGDT<1 QUIT 0 - ; - WRITE ! - S %DT="AE"_$G(T) - I $D(AB) S PROMPT=AB - E S PROMPT="Enter the Ending Date"_$S($G(T)]"":" @ Time",1:"")_": " - S:$D(BDEF) DEFAULT=BDEF - S ENDDT=$$DATE^BPSOSU1(PROMPT,$G(DEFAULT),1,BEGDT,3991231,%DT,$G(DTIME)) - I ENDDT["^" Q 0 ;user wants out if "^" - ; -- Ensure END date is not earlier than BEG date - I ENDDT = No response <^> - Up-arrow entered - ; <-1> = Timeout occurred <^^> - Two up-arrows entered - ; = Response text - ;--------------------------------------------------------------------- -FREETEXT(PROMPT,DFLT,OPT,MINLEN,MAXLEN,TIMEOUT) ;EP - ; - N XDATA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - ; - Q:$G(PROMPT)="" "" - S:$G(MINLEN)="" MINLEN=0 - S:$G(MAXLEN)="" MAXLEN=245 - ; - S $P(DIR(0),"^",1)="FA"_$S(OPT=1:"O",1:"") - S $P(XDATA,":",1)=MINLEN - S $P(XDATA,":",2)=MAXLEN - S $P(DIR(0),"^",2)=XDATA - S DIR("A")=PROMPT - S:$G(DFLT)'="" DIR("B")=DFLT - S:+$G(TIMEOUT)>0 DIR("T")=TIMEOUT - D ^DIR - Q $S($G(DTOUT)=1:-1,$G(DIROUT)=1:"^^",$G(DUOUT)=1:"^",1:Y) - ;--------------------------------------------------------------------- - ;Standard Numeric PROMPT: - ; - ;Parameters: - ; PROMPT = Text to be displayed before read - ; DFLT = DEFAULT Numeric - ; OPT = 1 - Answer optional 0 - Answer required - ; MINNUM = Minimum numeric value - ; MAXNUM = Maximum numeric value - ; MAXDEC = Maximum number of decimal places allowed - ; TIMEOUT = Number of seconds - ; - ;Returns: - ; = No response <^> - Up-arrow entered - ; <-1> = Timeout occurred <^^> - Two up-arrows entered - ; = Response Numeric - ;--------------------------------------------------------------------- -NUMERIC(PROMPT,DFLT,OPT,MINNUM,MAXNUM,MAXDEC,TIMEOUT) ;EP - ; - N XDATA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - ; - Q:$G(PROMPT)="" "" - ; - S $P(DIR(0),"^",1)="NA"_$S(OPT=1:"O",1:"") - S $P(XDATA,":",1)=$G(MINNUM) - S $P(XDATA,":",2)=$G(MAXNUM) - S $P(XDATA,":",3)=$G(MAXDEC) - S $P(DIR(0),"^",2)=XDATA - S DIR("A")=PROMPT - S:$G(DFLT)'="" DIR("B")=DFLT - S:+$G(TIMEOUT)>0 DIR("T")=TIMEOUT - D ^DIR - Q $S($G(DTOUT)=1:-1,$G(DIROUT)=1:"^^",$G(DUOUT)=1:"^",1:Y) diff -auBN ./r1/BPSOSU3.m ./r2/r/BPSOSU3.m --- ./r1/BPSOSU3.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSU3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,63 +0,0 @@ -BPSOSU3 ;BHAM ISC/FCS/DRS/FLS - copied for ECME ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Standard SET and YESNO Functions - ;---------------------------------------------------------------------- - ;Standard SET PROMPT: - ; - ;Parameters: - ; PROMPT = Text to be displayed before read - ; DFLT = DEFAULT choice (external format) - ; OPT = 1 - Answer optional 0 - Answer required - ; DISPLAY = V - Vertical display H - Horizontal display - ; N - No display - ; CHOICES = :;:..... - ; TIMEOUT = Number of seconds - ; - ;Returns: - ; = No response <^> - Up-arrow entered - ; <-1> = Timeout occurred <^^> - Two up-arrows entered - ; = Response choice (internal format) - ;--------------------------------------------------------------------- -SET(PROMPT,DFLT,OPT,DISPLAY,CHOICES,TIMEOUT) ;EP - ; - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - ; - Q:$G(PROMPT)="" "" - Q:$G(DISPLAY)="" "" - Q:$G(CHOICES)="" "" - ; - S $P(DIR(0),"^",1)="S"_$S(DISPLAY="H":"B",DISPLAY="N":"A",1:"")_$S(OPT=1:"O",1:"") - S $P(DIR(0),"^",2)=CHOICES - S DIR("A")=PROMPT - S:$G(DFLT)'="" DIR("B")=DFLT - S:+$G(TIMEOUT)>0 DIR("T")=TIMEOUT - D ^DIR - Q $S($G(DTOUT)=1:-1,$G(DIROUT)=1:"^^",$G(DUOUT)=1:"^",1:Y) - ;--------------------------------------------------------------------- - ;Standard Yes/No PROMPT: - ; - ;Parameters: - ; PROMPT = Text to be displayed before read - ; DFLT = YES, NO or - ; OPT = 1 - Answer optional 0 - Answer required - ; TIMEOUT = Number of seconds - ; - ;Returns: - ; = No response <^> - Up-arrow entered - ; <-1> = Timeout occurred <^^> - Two up-arrows entered - ; <0> = No <1> - Yes - ;--------------------------------------------------------------------- -YESNO(PROMPT,DFLT,OPT,TIMEOUT) ;EP - ; - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - ; - Q:$G(PROMPT)="" "" - ; - S $P(DIR(0),"^",1)="Y"_$S(OPT=1:"O",1:"") - S DIR("A")=PROMPT - S:$G(DFLT)'="" DIR("B")=DFLT - S:+$G(TIMEOUT)>0 DIR("T")=TIMEOUT - D ^DIR - Q $S($G(DTOUT)=1:-1,$G(DIROUT)=1:"^^",$G(DUOUT)=1:"^",1:Y) diff -auBN ./r1/BPSOSU4.m ./r2/r/BPSOSU4.m --- ./r1/BPSOSU4.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSU4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,161 +0,0 @@ -BPSOSU4 ;BHAM ISC/FCS/DRS/FLS - copied for ECME ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Standard List PROMPT: - ; - ;Parameters: - ; TYPE - S or M (single or multiple selection) - ; LROOT - List global root (eg: "^LIST($J,") - ; AROOT - Answer global root (eg: "^LISTANS($J,") - ; STITLE - Screen Title - ; .PROMPT - List PROMPT Array - ; OPTIONAL - 1 or 0 (optional or required) - ; PGLEN - Page length - ; TIMEOUT - Number of seconds - ; - ;Returns: - ; - Unable to process list - ; - For TYPE="S", item selected - ; <^> - Up-arrow entered - ; <^^> - Two up-arrows entered - ; <-1> - Timeout occurred - ; - ;---------------------------------------------------------------------- -LIST(TYPE,LROOT,AROOT,STITLE,PROMPT,OPTIONAL,PGLEN,TIMEOUT) ;EP - ; - ;Manage local variables - N CPAGE,NPAGES,START,END,ANS,NLINES,CHEAD1,CHEAD2,I,CMD - ; - Q:$G(TYPE)="" "" - Q:$G(LROOT)="" "" - Q:$G(AROOT)="" "" - ; - S STITLE=$G(STITLE) - S OPTIONAL=+$G(OPTIONAL) - S:$G(PGLEN)="" PGLEN=10 - S:$G(TIMEOUT)="" TIMEOUT=$G(DTIME) - ; - D INIT -LP1 D DPAGE - S ANS=$$PROMPT() - I ANS="?" D DHELP G LP1 - Q:(TYPE="M")&('OPTIONAL)&(ANS="^")&($D(@($E(AROOT,1,$L(AROOT)-1)_")"))'=0) ANS - Q:OPTIONAL&(ANS="^") ANS - Q:ANS="^^" ANS - Q:ANS="TIMEOUT" -1 - I ANS="" D NEXTPG G LP1 - I $E(ANS,1)="P" D JUMPPG G LP1 - ; - I TYPE="S"&(+ANS<1!(+ANS>END)) G LP1 - I TYPE="S"&(+ANS>0&(+ANS'>END)) S @(AROOT_(+ANS)_")")="" Q ANS - I TYPE="M" F I=1:1:$L(ANS,",") D - .S CMD=$P(ANS,",",I) - .I CMD?1N.N D MARK(CMD) Q - .I CMD?1"-".N D UNMARK($P(CMD,"-",2)) Q - .I CMD?1N.N1"-"1N.N D RMARK(CMD) Q - .I CMD?1"-"1N.N1"-"1N.N D RUNMARK(CMD) Q - G LP1 - ;---------------------------------------------------------------------- -HEADER N LINE - W @IOF,! - D:STITLE'="" WCENTER^BPSOSU9(STITLE,IOM) - D:STITLE'="" WCENTER^BPSOSU9($TR($J("",$L(STITLE))," ","-"),IOM) - ; - ;DISPLAY PROMPT LINEs - S LINE=0 - F D Q:LINE="" - .S LINE=$O(PROMPT(LINE)) - .Q:LINE="" - .W:LINE=1 !! - .W PROMPT(LINE),! - ; - W:$G(CHEAD1)'="" !,?9,CHEAD1,! - W:$G(CHEAD2)'="" ?9,CHEAD2 - Q - ;---------------------------------------------------------------------- -INIT N CNSPACES,CNAMES,CDEF,INDEX,COLUMNS - S NLINES=+$G(@(LROOT_"0)")) I 'NLINES D Q - . D IMPOSS^BPSOSUE("P","TI","0 lines indicated in "_LROOT,,"INIT",$T(+0)) - S NPAGES=((NLINES-1)\PGLEN)+1 - S CPAGE=1 - S COLUMNS=$G(@(LROOT_"""Column HEADERs"""_")")) - D:COLUMNS'="" - .S (CHEAD1,CHEAD2)="" - .S CNSPACES=$P(COLUMNS,"|",1) - .S CNAMES=$P(COLUMNS,"|",2) - .F INDEX=1:1:$L(CNAMES,",") D - ..S CDEF=$P(CNAMES,",",INDEX) - ..S CHEAD1=CHEAD1_$S(INDEX=1:"",1:$J("",CNSPACES))_$$LJBF^BPSOSU9($P(CDEF,":",1),$P(CDEF,":",2)) - ..S CHEAD2=CHEAD2_$S(INDEX=1:"",1:$J("",CNSPACES))_$TR($J("",$P(CDEF,":",2))," ","-") - Q - ;---------------------------------------------------------------------- -MARK(X) ; - Q:X<1!(X>NLINES) - S @(AROOT_X_")")="" - Q - ;---------------------------------------------------------------------- -RMARK(X) ; - N START,END,INDEX - S START=$P(X,"-",1) - S END=$P(X,"-",2) - F INDEX=START:1:END D MARK(INDEX) - Q - ;---------------------------------------------------------------------- -UNMARK(X) ; - Q:X<1!(X>NLINES) - K @(AROOT_X_")") - Q - ;---------------------------------------------------------------------- -RUNMARK(X) ; - N START,END,INDEX - S START=$P(X,"-",2) - S END=$P(X,"-",3) - F INDEX=START:1:END D UNMARK(INDEX) - Q - ;---------------------------------------------------------------------- -DPAGE N LNUM - D HEADER - W ! - S START=((CPAGE-1)*PGLEN)+1 - S END=START+PGLEN-1 - S:END>NLINES END=NLINES - F LNUM=START:1:END D - .W $S($D(@(AROOT_LNUM_")")):"*",1:" ") - .W $J(LNUM,5)," - " - .W $G(@(LROOT_LNUM_","_"""E"""_")")),! - Q - ;---------------------------------------------------------------------- -PROMPT() ; - W:TYPE="S" !,"[Page "_CPAGE_" of "_NPAGES_"] Commands: #, P#, , ^, ^^ or ?",! - W:TYPE="M" !,"[Page "_CPAGE_" of "_NPAGES_"] Commands: #, -#, #-#, -#-#, P#, , ^, ^^ or ?",! - W "Select Item #: " - R ANS:TIMEOUT - I '$T S ANS="TIMEOUT" - Q ANS - ;---------------------------------------------------------------------- -NEXTPG S CPAGE=CPAGE+1 - S:CPAGE>NPAGES CPAGE=NPAGES - Q - ;---------------------------------------------------------------------- -JUMPPG N NUM - Q:$E(ANS,1)'="P" - S NUM=+$P(ANS,"P",2) - Q:NUM<1!(NUM>NPAGES) - S CPAGE=NUM - Q - ;---------------------------------------------------------------------- -DHELP ; - N X - W !!,"Enter one of the following commands:",!! - W ?10,"#",?20,"- Selects entry number # from the list",! - W:TYPE="M" ?10,"-#",?20,"- Deselects entry number # from the list",! - W:TYPE="M" ?10,"#-#",?20,"- Selects the range of entries # thru #",! - W:TYPE="M" ?10,"-#-#",?20,"- Deselects the range of entries # thru #",! - W:TYPE="M"!(TYPE="S"&(OPTIONAL)) ?10,"^",?20,"- Exit the list",! - W ?10,"P#",?20,"- Jumps to page number #",! - W ?10,"",?20,"- DISPLAYs next page",! - W ?10,"^^",?20,"- Aborts and returns to menu",! - W ?10,"?",?20,"- DISPLAYs this help text",!! - D PRESSANY^BPSOSU5(0,TIMEOUT) - Q diff -auBN ./r1/BPSOSU5.m ./r2/r/BPSOSU5.m --- ./r1/BPSOSU5.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSU5.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,57 +0,0 @@ -BPSOSU5 ;BHAM ISC/FCS/DRS/FLS - utilities ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ;---------------------------------------------------------------------- -TOSCREEN() ;EP; True or False, is output to screen? - I $E(IOST)'="C" Q 0 - I $D(ZTQUEUED) Q 0 - I IOT'="TRM",IOT'="VTRM" Q 0 - I $D(IO("S")) Q 0 - Q 1 -PRESSANY(NLF,TIMEOUT) ;EP - I '$$TOSCREEN Q - N X,I - S NLF=+$G(NLF) - S:+$G(TIMEOUT)=0 TIMEOUT=30 - F I=1:1:NLF W ! - ;W "Press any key to continue: " R *X:TIMEOUT - I $$FREETEXT^BPSOSU2("Press ENTER to continue: ",,1,1,1,300) - Q - ;---------------------------------------------------------------------- - ;'Press the return key to continue of ^ to exit:' PROMPT - ; See also $$EOPQ^BPSOSU8 -ENDPAGE(NLF,TIMEOUT) ;EP - I '$$TOSCREEN Q 1 - N X,Y,I,DIR,DTOUT,DUOUT,DIRUT,DIROUT - S NLF=+$G(NLF) - F I=1:1:NLF W ! - S:+$G(TIMEOUT)>0 DIR("T")=TIMEOUT - S DIR(0)="E" - D ^DIR - Q $S(Y="":-1,Y=0:"^",1:Y) - ;---------------------------------------------------------------------- -ENDRPT() ; EP - N RETVAL - S RETVAL=$$ENDRPT^BPSOSU8() Q - ;===================================================================== -BYE ; EP - ; Most routines should come here when they exit. - ; Example: GOTO BYE^BPSOSU3 - ; IN: FLGSTOP 1=user wanted out - ; - I $G(FLGSTOP) W " < exit >" HANG 1 - D ^%ZISC - Q - ;===================================================================== -BOTTOM(LINES) ;07/26/96 - ; IN: lines (optional) = lines from the bottom (default=1) - ; This line-feeds down to the bottom of the screen - ; - Q:'$G(IOSL) - N X1,X2,J S LINES=$S($D(LINES):LINES,1:1) - S X1=($Y+2) - I X1>(IOSL-LINES) DO - . S X1=($Y+2) - S X2=(IOSL-X1) F J=1:1:X2 W ! - Q - ;================================================================= diff -auBN ./r1/BPSOSU7.m ./r2/r/BPSOSU7.m --- ./r1/BPSOSU7.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSU7.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,49 +0,0 @@ -BPSOSU7 ;BHAM ISC/FCS/DRS/FLS - misc. utilities ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; delete antique, hopeless .59s [ 09/14/2000 8:36 AM ] - ; How can they possibly get stranded? - ; Well, this cleans them up -PURGE(HRS) ;EP - purge all the ones older than HRS hours - W ! - I '$D(HRS) D Q:'$G(HRS) - . W "Unstrand all the claims which haven't been updated",! - . N PROMPT S PROMPT="in how many hours? " - . N DEF S DEF=24 - . N OPT S OPT=1 - . N MIN,MAX S MIN=.05,MAX=99999999 ; .05 hours = 3 minutes - . S HRS=$$NUMERIC^BPSOSU2(PROMPT,DEF,OPT,MIN,MAX,2) ; 2 = dec. places - . I HRSSECS D - . . . W ?10,"setting it to complete..." - . . . D PURGE1(IEN59) - . . . W "done.",! - . . . S COUNT("SET TO COMPLETE")=COUNT("SET TO COMPLETE")+1 - . . E D - . . . W ?10,"nothing done to this claim.",! - D ZWRITE^BPSOS("COUNT") - Q -PURGE1(IEN59) ; - N ABSBRXI S ABSBRXI=IEN59 - D SETSTAT^BPSOSU(99) - D SETRESU^BPSOSU(-1,"mark incomplete claim as stranded after "_AGE) - Q -PURGEALL D PURGE(0) Q ; should only be done by programmer? diff -auBN ./r1/BPSOSU8.m ./r2/r/BPSOSU8.m --- ./r1/BPSOSU8.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSU8.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,160 +0,0 @@ -BPSOSU8 ;BHAM ISC/FCS/DRS/FLS - utilities ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;*** Collection of FSI UTILITIES *** - ; - ;EOPQ(LINES,PARAM,Xcode) - Return 0 to continue, 1 to quit. - ;PAUSE() Return 1 to continue, 0 to stop. - ;ENDRPT() - ;DEVICE(DEV,RTN,TITLE,MULTI) S up a device, 1 if successful, 0 not. - ;HEADER(PROGRAM,TITLE1,TITLE2,RUNTIME,NOFF,UL) Procedure call - ;CENTER - ;UNDERLINE - ;REPLICATE - ;FMPAGE() Handle the screen or printer for an FM print report. - ;PAGE0 - ;STANDBY - ;====================================================================== -EOPQ(LINESBOT,PARAM,EOPXCODE) ;EP - - ; IN: LINESBOT = (optional) # of LINES from bottom (IOSL) before - ; determining what to do next. I this is a CRT, we - ; will ask user whether to continue; for printers, just - ; continue. DEFAULT=6 - ; PARAM = List of parameter codes (each may occur): - ; "M" - Will display "-- More --" at bottom. - ; EOPXCODE = xecutable code that will occur if this is the - ; end of the page (like, D HEADER^ROU). - ; - ; OUT: 0 if not end of page, OR if we're EOP but we're continuing; - ; 1 if user wants to quit. - ; May call this as DO in some cases (like a little trailer on report) - ; - N X,Y,%,DIR - ; - I '$G(IOSL) Q 0 ;if we don't know page length, then not at end - S LINESBOT=$S($G(LINESBOT):LINESBOT,1:6) - I ($Y+LINESBOT)" - N DIR,X,Y - S DIR(0)="E" - S DIR("A")=" -- END OF REPORT -- (Press to return to menu)" - D ^DIR - Q Y - ;=================================================================== -DEVICE(DEV,RTN,TITLE,MULTI) ;EP - ;Select an output device. Return 1 if successful, 0 if not. - ;No parameters are required. DEV can be set alone, or if queing - ;set to variables needed for queing. - ;DEV - DEFAULT device, "HOME" if undefined. - ;RTN - Routine name if queing is selected. - ;TITLE - Description for the task log if queing is selected. - ;MULTI - I set then ask NUMBER OF COPIES. This sets the variable - ; DCOPIES that the calling routine should use. - ;Examples: Q:'$$DEVICE^ABSBUU01("STANDARD") - ; - ; Q:'$$DEVICE^ABSBUU01("PC;132;66","EN^WSHLC","CORRECTION LIST") - ; note: D ^%ZISC to close the device after printing is done. - N I,Y - W !! - S ZTSAVE("PAGE")="" - I $D(RTN) S %ZIS="QM" ; Ask if queing is allowed only if RTN is set. - S %ZIS("A")="Send report to device: " ;PROMPT - S %ZIS("B")=$S($D(DEV):DEV,1:"HOME") ;DEFAULT device - D ^%ZIS ;Input/Output variables. - I POP W " try again later" S Y=0 G DEVQ ;Device success flag - S PAGE=0 - I '$D(IO("Q")) U IO S Y=1 G DEVQ ;Queing not selected - S ZTRTN=RTN ;Routine entry point for queing. - S ZTIO=ION ;Output device for queing. - S ZTDESC=$G(TITLE) ;Report title if queing is selected. - S ZTSAVE("*")="" ;All variables in memory for queing. - D ^%ZTLOAD ;Entry point for queuing. - W !,$S($D(ZTQUEUED):"Request queued!",1:"Request cancelled!") ;flag - S Y='$D(ZTQUEUED) - D HOME^%ZIS ;S IO variables back to device = screen. - U IO ;Use the currently open IO device -DEVQ I +$G(MULTI)>0 D USE IO - . USE $P - . N Y - . S DCOPIES=0 - . K DIR - . S DIR(0)="NO^0:99999",DIR("A")="NUMBER OF COPIES TO OUTPUT" - . S DIR("B")=1 - . D ^DIR K DIR - . I +Y>0 S DCOPIES=Y - . I Y["^" S DCOPIES=-1 - I $G(DCOPIES)<0 S Y=0 - Q Y - ;=================================================================== -HEADER(PROGRAM,TITLE1,TITLE2,RUNTIME,NOFF,UL) ; - ; This PROCEDURE accepts the routine name and titles and prints out a - ; standard header with the run date and time,page and increments - ; the page counter by 1. Page is initialized in function DEVICE. - ; W @IOF if (to SCREEN) OR (to PRINTER after page 1) - ; TITLE variable has special uses. I the calling routine - ; send-in the TITLE-array (by setting TITLE(1)="LINE 1", TITLE(n)= - ; "LINE n of title", and then D HEADER^WSHUTL("ROUTINE",.TITLE),"."), - ; then the entire array of TITLE will be used (and TITLE2 will be - ; ignored). You must send-in TITLE2="." - ; RUNTIME has been added so that all pages of the report can - ; have the same date.time. The calling report must send it in. - ; NOFF (optional) - if it exists, then do NOT issue a FormFeed. - ; This is necessary for reports that are controlled as a FileMan - ; template... since FM issues its own FF, this routine should not. - ; UL (opt) - is flag to print a 1-IOSL dashes after the header. - ; DEFAULT is no-underline. S UL to 1 to print the underline. - ; - N X - S $Y=0,PAGE=$G(PAGE) - I $E(IOST,1)="C"!($E(IOST,1)="P"&(PAGE>0)) I '$D(NOFF) W @IOF - S PAGE=PAGE+1 - I $G(RUNTIME)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S RUNTIME=Y - W !,"RUN DATE: ",RUNTIME - W ?(IOM-10),"PAGE: ",$J(PAGE,3,0) - I $D(PROGRAM),PROGRAM'="" W !,"PGM: ",PROGRAM - I $G(TITLE2)'="." DO - . I $D(TITLE1) D WCENTER^BPSOSU9(TITLE1) - . I $D(TITLE2) D WCENTER^BPSOSU9(TITLE2) - I $G(TITLE2)="." DO - . S N="" - . F S N=$O(TITLE1(N)) Q:N="" D WCENTER^BPSOSU9($G(TITLE1(N))) - I $G(UL)=1 D ;print dashes across the page - . W ! - . FOR I=1:1:$S($G(IOM)>0:IOM,1:80) W "-" - W ! - Q - ;=================================================================== -FMPAGE ;at end of page - I $$TOSCREEN^BPSOSU5 D Q - . D PRESSANY^BPSOSU5() - I IOST["P-" W @IOF Q - ; should we fall through to PAGE0? - Q - ;=================================================================== -PAGE0 ; This checks the IO device and issues a pagefeed if $Y>0 - Q:'$G(IO) - ;OPEN IO USE IO I $Y>0 USE IO W # - U IO I $Y>0 U IO W # - Q - ;=================================================================== -STANDBY ; W a message to screen to "Please Wait" - USE $P D WAIT^DICD USE +$G(IO) - Q - ;=================================================================== diff -auBN ./r1/BPSOSU9.m ./r2/r/BPSOSU9.m --- ./r1/BPSOSU9.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSU9.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,89 +0,0 @@ -BPSOSU9 ;BHAM ISC/FCS/DRS/FLS - copied for ECME ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ;---------------------------------------------------------------------- - ;---------------------------------------------------------------------- - ;Standard W and String Formatting Functions - ;---------------------------------------------------------------------- - ;W a line of centered text - ;WCENTER(Text,Margin) - ;W ?Margin-$L(Text)/2,Text,! - ;Q - ;W a line of centered text. OPTion UL is for UNDERLINING. -WCENTER(TEXT,IOM,UL) ;EP - S:$G(IOM)="" IOM=80 - W ?IOM-$L(TEXT)/2,TEXT,! - I $G(UL) W ?IOM-$L(TEXT)/2,$TR($J("",$L(TEXT))," ","-"),! - Q - ;---------------------------------------------------------------------- - ;W Standard Underlined HEADER -WHEADER(TEXT,IOF,IOM) ;EP - Q:$G(TEXT)="" - S:$G(IOF)="" IOF="#" - S:$G(IOM)="" IOM=80 - W @IOF,! - D WCENTER(TEXT,IOM) - D WCENTER($TR($J("",$L(TEXT))," ","-"),IOM) - Q - ;---------------------------------------------------------------------- - ;W Column HEADERs (with option to underline) -WCOLUMNS(INDENT,COLDEFS,CNAMES,ULINE) ;EP - N CHEAD1,CHEAD2,INDEX,CDEF - Q:$G(CNAMES)="" - S:$G(INDENT)="" INDENT=0 - S:$G(COLDEFS)="" COLDEFS=2 - S:$G(ULINE)="" ULINE=1 - ; - S COLDEFS=$J("",COLDEFS) - S (CHEAD1,CHEAD2)="" - F INDEX=1:1:$L(CNAMES,",") D - .S CDEF=$P(CNAMES,",",INDEX) - .S CHEAD1=CHEAD1_$S(INDEX=1:"",1:COLDEFS)_$$LJBF($P(CDEF,":",1),$P(CDEF,":",2)) - .S:ULINE CHEAD2=CHEAD2_$S(INDEX=1:"",1:COLDEFS)_$TR($J("",$P(CDEF,":",2))," ","-") - W ?INDENT,CHEAD1,! - W:ULINE ?INDENT,CHEAD2,! - Q - ;---------------------------------------------------------------------- -WDATA(INDENT,COLDEFS,VNAMES) ;EP - N INDEX,DEF,DLINE,VAR,LEN - Q:$G(VNAMES)="" - S:$G(INDENT)="" INDENT=0 - S:$G(COLDEFS)="" COLDEFS=2 - ; - S COLDEFS=$J("",COLDEFS) - S DLINE="" - F INDEX=1:1:$L(VNAMES,",") D - .S DEF=$P(VNAMES,",",INDEX) - .S VAR=$P(DEF,":",1) - .S LEN=$P(DEF,":",2) - .S DLINE=DLINE_$S(INDEX=1:"",1:COLDEFS)_$$LJBF($S(VAR="":"",1:$G(@VAR)),LEN) - W ?INDENT,DLINE,! - Q - ; - ;---------------------------------------------------------------------- - ;Left justifies and blank fills -LJBF(X,L) ;EP - Q $E(X_$J("",L-$L(X)),1,L) - ;---------------------------------------------------------------------- - ;Right justifies and blank fills -RJBF(X,L) ;EP - Q $E($J("",L-$L(X))_X,1,L) - ;---------------------------------------------------------------------- - ;CENTER justifies and blank fills -CJBF(X,L) ; - Q $$LJBF($E($J("",(L-$L(X))\2)_X,1,L),L) - ;---------------------------------------------------------------------- - ;Convert lower case characters to upper case characters -UCASE(X) ;EP - Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ;---------------------------------------------------------------------- - ;Convert upper case characters to lower case characters -LCASE(X) ; - Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") - ;---------------------------------------------------------------------- - ;Delete leading and trailing blanks -CLIP(X) ;EP - F D Q:$E(X,1)'=" " - .S:$E(X,1)=" " X=$E(X,2,$L(X)) - F D Q:$E(X,$L(X))'=" " - .S:$E(X,$L(X))=" " X=$E(X,1,$L(X)-1) - Q X diff -auBN ./r1/BPSOSUA.m ./r2/r/BPSOSUA.m --- ./r1/BPSOSUA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSUA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,166 +0,0 @@ -BPSOSUA ;BHAM ISC/FCS/DRS/FLS - sort and print utilities ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -DEFDEST() Q "^TMP("""_$T(+0)_""","_$J_",1)" ; default dest for sort -SAVEAREA() Q "^TMP("""_$T(+0)_""","_$J_",2)" ; if you save old vers. -SAVEOLD K @$$SAVEAREA M @$$SAVEAREA=@$$DEFDEST Q - ; -SORT(USER,PATDFN,TDIF,INIT,DEST,LOCK) ;EP - from BPSOS6I - ; USER = DUZ or 0 for all users - ; USER = DUZ # you want; MINS = within the last N minutes - ; (Because of timing, you might catch a prescription more than once) - ; PATDFN = a particular patient or 0 for all patients - ; TDIF = days.hhmmss = 0.0015, for instance, for last 15 minutes - ; or TSINCE, e.g. 2991105.140305, for changes since absolute time - ; If TDIF is given, TSINCE is computed from NOW^%DTC and TDIF - ; TDIF can be positive and we'll take care of treating it as minus. - ; TDIF can theoretically be days.hhmmss but in practice it's - ; either one or the other. - ; INIT = 1 if you want to init list (erase what's there now) - ; DEST defaults to ^TMP("BPSOSUA",$J) - ; If it's a global,it must begin with ^TMP( or ^UTILITY( - ; LOCK defaults to 1, Lock file 9002313.59 - ; It seems that not locking really does lead to some misleading - ; displays. - ; - - - - - It builds this: - - - - - - ; @DEST=how many patients - ; @DEST@(patname)=how many prescriptions for this patient - ; @DEST@(patname,"RXI",ABSBRXI)=status^datetime last update - ; And this node, which we aren't using anymore: - ; @DEST@(patname,100-status,9'sDate9'sTime,ABSBRXI)="" for each presc - ; - ; Returns the root reference of the DEST. - ; -SORT0 N ROU S ROU=$T(+0) - I '$D(USER) S USER=0 - I '$D(PATDFN) S PATDFN=0 - I '$D(TDIF) S TDIF=0.001500 - I '$D(INIT) S INIT=1 - I '$D(DEST) S DEST=$$DEFDEST - I $E(DEST)="^",$P(DEST,"(")'="^TMP",$P(DEST,"(")'="^UTILITY" D Q - . D IMPOSS^BPSOSUE("P","TI","we cannot use "_DEST_" for scratch storage",,,$T(+0)) - I '$D(LOCK) S LOCK=1 -SORT1 N NOW,%,%H,%I,X D NOW^%DTC S NOW=% - N TIME,STARTTIM ;S (TIME,STARTTIM)=$$TADD(NOW,TDIF) - N ROOT S ROOT="^BPST" - I TDIF>2990000 S (TIME,STARTTIM)=TDIF ; absolute time was given - E S (TIME,STARTTIM)=$$TADD(NOW,TDIF*$S(TDIF>0:-1,1:1)) ; delta - I INIT K @DEST S @DEST=0 - I $G(LOCK) L +@ROOT:3600 - D SORT2 - I $G(LOCK) L -@ROOT - Q DEST - ; -SORT2 ; If doing one particular patient, then use the patient index - I PATDFN D - . S STARTTIM=STARTTIM\1 - . S RXI="" F S RXI=$O(@ROOT@("AC",PATDFN,RXI)) Q:'RXI D - . . Q:$P($G(@ROOT@(RXI,0)),U,8)86400 D G TADDLOOP ; carry 86400 secs = 1 day - . S $P(%H,",")=$P(%H,",")+1,$P(%H,",",2)=$P(%H,",",2)-86400 - ;W "any carry/borrow done, and %H=",%H,! - D YMD^%DTC - Q X_% -CLOSED(TRA) ; Checks if the CLAIM for specific Transaction is CLOSED - N CLAIM S CLAIM=$$GET1^DIQ(9002313.59,TRA,3,"I") I 'CLAIM Q 0 - Q $$GET1^DIQ(9002313.02,CLAIM,901,"I") diff -auBN ./r1/BPSOSUB.m ./r2/r/BPSOSUB.m --- ./r1/BPSOSUB.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSUB.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,79 +0,0 @@ -BPSOSUB ;BHAM ISC/FCS/DRS/FLS - diagnostic data collection ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q ; diagnostics data collection from full screen display - ; You may need to rework this if/when it's ever needed to debug - ; the user screen and the continuous update. -FILE(N) Q "/usr/spool/uucppublic/absbposm"_N_".tmp" -COMMON N %,%H,%I,X,NOW D NOW^%DTC - N NOW S NOW=% - S ^TMP("BPS",$J,"BPSOSUB","DATE CREATED")=NOW - M ^TMP("BPS",$J,"BPSOSUB","BPSOSL")=^BPSECP("LOG") ; too hard to separate by $J - M ^TMP("BPS",$J,"BPSOSUB",9002313.58)=^BPSECX("S") - Q -INIT S ROU=$T(+0) K ^TMP("BPS",$J,"BPSOSUB") S ^TMP("BPS",$J,"BPSOSUB")="" - W "Collecting diagnostic data...",! - Q -BOTH ;EP - BPSOS6K - W "Doing first part...",! D FULL - W "Doing second part...",! D JOB - W "Both parts done.",! - Q -FULL ;EP - BPSOS6K - N ROU D INIT - S ^TMP("BPS",$J,"BPSOSUB")="Created by FULL^"_$T(+0) - D COMMON - M ^TMP("BPS",$J,"BPSOSUB","BPSOS")=^TMP("BPSOS") - M ^TMP("BPS",$J,"BPSOSUB","BPSOSUA")=^TMP("BPSOSUA") - ; take the last hundred ^BPSC( and associated responses - D LAST0203(100) - D LAST59(100) - W "Writing file ",$$FILE(1),"...",! - D GS(1) - W "Done.",! - Q -JOB ;EP - BPSOS6K - D INIT - S ^TMP("BPS",$J,"BPSOSUB")="Created by JOB^"_$T(+0)_" for $JOB="_$J - D COMMON - M ^TMP("BPS",$J,"BPSOSUB","BPSOS",$J)=^TMP("BPSOS",$J) - M ^TMP("BPS",$J,"BPSOSUB","BPSOSUA",$J)=^TMP("BPSOSUA",$J) - D LISTMGR - D LAST0203(10) - D LAST59(10) - W "Writing file ",$$FILE(2),"...",! - D GS(2) - W "Done.",! - Q -LISTMGR ; List Manager data - F X="VALMCNT","VALMBG","VALMAR" D - . I $D(@X) S ^TMP("BPS",$J,"BPSOSUB",X)=@X - M ^TMP("BPS",$J,"BPSOSUB","VALMAR")=@VALMAR - Q -LAST59(N) ; last N 9002313.59 entries - N X S X="A" - N J F J=1:1:100 S X=$O(^BPST(X),-1) Q:'X D - .M ^TMP("BPS",$J,"BPSOSUB","9002313.59",X)=^BPST(X) - Q -LAST0203(N) ; last N 9002313.02 entries and associated 9002313.03's. - N X S X=$P(^BPSC(0),"^",3) - N CLAIM,RESP F CLAIM=X:-1:X-N+1 D - .M ^TMP("BPS",$J,"BPSOSUB","CLAIM",CLAIM)=^BPSC(CLAIM) - .S RESP="" F S RESP=$O(^BPSR("B",CLAIM,RESP)) Q:'RESP D - ..M ^TMP("BPS",$J,"BPSOSUB","RESP",RESP)=^BPSR(RESP) - Q -GS(TYPE) ; write file in ^%GS format - ; TYPE = 1 - from the FULL option - ; TYPE = 2 - from the JOB option - N FILE,R,R0 - S FILE=$$FILE(TYPE) - N RETVAL S RETVAL=$$IMPOSS^BPSOSUE("P","TI","routine still in development",,"GS",$T(+0)) - ; O 51:(FILE:"W") - ;U 51 W $T(+1),!,$G(NOW)_" "_$H,! - S R="^TMP(""BPS"","_$J_",""_ROU_"")" - S R0=$E(R,1,$L(R)-1) - F D Q:$E(R,1,$L(R0))'=R0 - . W R,!,@R,! - . S R=$Q(@R) - W "*",!,"*",!,"**",!,"**",! - ;C 51 - Q diff -auBN ./r1/BPSOSUC.m ./r2/r/BPSOSUC.m --- ./r1/BPSOSUC.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSUC.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,66 +0,0 @@ -BPSOSUC ;BHAM ISC/FCS/DRS/FLS - ECME utilities ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; CATEG is used by ILC billing in BPSOSB2 - ; Also called by several other routines -CATEG(N,WANTREV) ;EP - many - ; given N, return category for the duplicate resolution process - ; Can call with either N = integer IEN into 9002313.57 - ; or N = decimal IEN into 9002313.59 - ; $G(WANTREV) = true if you care about reversals - ; (that's the default if N is an IEN59) - ; $G(WANTREV) = false if you want to ignore reversals - ; (that's the default if IEN57) - ; because billing is handled differently. - ; - ; Many routines rely on these exact return values; do not change them: - ; Return values: PAPER, E PAYABLE, E CAPTURED, E DUPLICATE, - ; E REJECTED, E OTHER - ; and CANCELLED (two L's) (only for 9002313.59) - ; - ; E DUPLICATE - being phased out - 02/06/2001 - ; remap to E PAYABLE or E CAPTURED, as appropriate - ; - ; and if you want to consider reversals, - ; PAPER REVERSAL, E REVERSAL ACCEPTED, E REVERSAL REJECTED - ; or E REVERSAL OTHER - ; (CORRUPT, E OTHER and E REVERSAL OTHER should never happen) - ; - ; - I N<1 Q "" ; N=-1 can happen from print templates, e.g. MISSED PRESC - N FILENUM S FILENUM=$S(N[".":9002313.59,1:9002313.57) - I '$D(WANTREV) S WANTREV=$S(FILENUM=9002313.57:0,FILENUM=9002313.59:1) - N RETVAL,CLAIM,RESP,REV,X,RESULT - I '$$GET1^DIQ(FILENUM,N_",",.01) Q "CORRUPT" - S CLAIM=$$GET1^DIQ(FILENUM,N_",",3,"I") - S RESP=$$GET1^DIQ(FILENUM,N_",",4,"I") - I 'CLAIM S RETVAL="PAPER" D Q RETVAL - . I 'WANTREV Q - . I $$GET1^DIQ(FILENUM,N_",",403,"I") S RETVAL=RETVAL_" REVERSAL" - ; otherwise, there is an electronic claim and you get an "E xxxxxx" - ;S RESULT=$$GET1^DIQ(FILENUM,N_",",202) - ;S RESULT=$G(^BPSEC(FILENUM,N,2)) - I $$GET1^DIQ(FILENUM,N_",",302) Q "CANCELLED" - I WANTREV S X=$$GET1^DIQ(FILENUM,N_",",401,"I") I X D Q RETVAL - . S RETVAL="E REVERSAL " - . S RESP=$$GET1^DIQ(FILENUM,N_",",402,"I") - . I 'RESP S RETVAL="E OTHER" Q - . S X=$$RESP500^BPSOSQ4(RESP,"I") - . S RETVAL=RETVAL_$S(X="A":"ACCEPTED",X="R":"REJECTED",1:"OTHER") - ; Electronic claim, don't want to consider reversal - I 'RESP D Q RETVAL - . S RETVAL="E OTHER" ; electronic claim but no response? - N RESP500 S RESP500=$$RESP500^BPSOSQ4(RESP,"I") - ; Give precedence to the particular response in 1000 - ;I X="R" Q "E REJECTED" ; 10/26/2000 ; Oklahoma Medicaid might give - ; a rejected header as well as a rejected prescription therein - ;I X'="A" Q "E OTHER" ; rejected header? corrupt? rejected reversal? - N ECME S POS=$$GET1^DIQ(FILENUM,N_",",14) - S X=$$RESP1000^BPSOSQ4(RESP,POS,"I") - I X="P"!(X="DP") Q "E PAYABLE" - I X="D" Q "E DUPLICATE" ; SHOULD NEVER HAPPEN as of 02/06/2001 - I X="R" Q "E REJECTED" - I X="C"!(X="DC") Q "E CAPTURED" - ; 1000 indefinite, fall back to 500 - I RESP500="R" Q "E REJECTED" - Q "E OTHER" ; corrupt? diff -auBN ./r1/BPSOSUD.m ./r2/r/BPSOSUD.m --- ./r1/BPSOSUD.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSUD.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,150 +0,0 @@ -BPSOSUD ;BHAM ISC/FCS/DRS/FLS - utils, some options ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - ; - ; Some utilities. - ; Some options- goal is to move them out to other routines - ; - Q - ; -INCSTAT(N1,P1,N2,P2,N3,P3) ;EP - BPSOSAM,BPSOSQA,BPSOSQC,BPSOSQL,others to come - ; increment the given N nodes at the P pieces - D ADD1STAT(N1,P1,1) - Q:'$D(N2) D ADD1STAT(N2,P2,1) - Q:'$D(N3) D ADD1STAT(N3,P3,1) - Q -ADDSTAT(N1,P1,Q1,N2,P2,Q2,N3,P3,Q3) ;EP - BPSOSAM,BPSOSQ3,others to come - ; add Quantities to given Nodes,Pieces - D ADD1STAT(N1,P1,Q1) - Q:'$D(N2) D ADD1STAT(N2,P2,Q2) - Q:'$D(N3) D ADD1STAT(N3,P3,Q3) - Q -ADD1STAT(N,P,Q) ; - L +^BPSECX("S",1,N):5 - I '$D(^BPSECX("S",1,N)) S ^BPSECX("S",1,N)="" - S $P(^BPSECX("S",1,N),U,P)=$P(^BPSECX("S",1,N),U,P)+Q - L -^BPSECX("S",1,N) - Q - ; - ; General LOCK routine to exclusive ownership of 9002313.59 - ; Interactive by default - ; -LOCKPOS(OK2WAIT,SILENT) ;EP - BPSOS2D,BPSOS6L - Lock 9002313.59 - I '$D(OK2WAIT) S OK2WAIT=1 - N RESULT S RESULT="" - F D Q:RESULT]"" Q:'OK2WAIT - . L +^BPST:1 I $T S RESULT=1 Q - . W "Waiting 5 minutes for interLOCK...",! - . L +^BPST:299 I $T S RESULT=1 Q - . D Q - . . W "Failed to obtain interLOCK",! - . . S RESULT=0 Q - . I 'VARX H 5 ;LJE ; want to ask here - and set RESULT=0 if they say no, don't wait - Q RESULT -ULKECME ;EP - L -^BPST Q - ; -DATETIME(Y) ;EP - BPSOS6M - convert fileman date.time to printable - X ^DD("DD") Q Y -TIMEAGO(THEN) ;EP - BPSOSU7 ; external form for TIMEAGOI - N %,%H,%I,X D NOW^%DTC Q $$TIMEDIF(THEN,%) -TIMEAGOI(THEN) ;EP - BPSOSU7 ; - ; how many seconds ago was it? returns positive value - N %,%H,%I,X D NOW^%DTC ; giving % - Q $$TIMEDIFI(THEN,%) -TIMEDIFI(X1,X2) ;EP - BPSOSB,BPSOSIV,BPSOSIZ ; - ; time difference in seconds, negative if X1>X2 - I X1>X2 Q -$$TIMEDIFI(X2,X1) - N %,X,%H,%T,%Y,D1,T1,D2,T2 - S X=X1 D H^%DTC S D1=%H,T1=%T - S X=X2 D H^%DTC S D2=%H,T2=%T - S X=D2-D1*86400+T2-T1 - Q X -TIMEDIF(X1,X2) ;EP - BPSOS6M,BPSOSIV - N X S X=$$TIMEDIFI(X1,X2) - N SGN S SGN=$S(X<0:-1,1:1),X=X*SGN - Q $S(SGN<0:"-",1:"")_$$SECSDHMS(X) -SECSDHMS(X) ;EP - seconds -> # da # hr # min # sec - N % S %="" - I X'<86400 S %=X\86400_" da",X=X#86400 - I X'<3600!(%]"") S:%]"" %=%_" " S %=%_(X\3600)_" hr",X=X#3600 - I X'<60!(%]"") S:%]"" %=%_" " S %=%_(X\60)_" min",X=X#60 - S:%]"" %=%_" " S %=%_X_" sec" - Q % -PRESSANY D PRESSANY^BPSOSU5() Q -CONTINUE(DEF) ;EP - BPSOS2E - ; returns a single character - ; or returns DEF, the default - ;N X,%,%H,%I,X,Y,TT D NOW^%DTC S Y=% S TT=$$TT X TT -CONT1 ;W "----- ",Y," Press C to continue, Q to quit, or ^: " - ;R X#1:15 S:'$T X=DEF W ! - S X=$$FREETEXT^BPSOSU2("Type C to continue or Q to quit: ",,1,1,1,15) - Q X - ; - ; SORT() has moved to BPSOSUA - ; DEFDEST^BPSOSUA() gives default root of where its results are - ; DISP and DISP1 have been superseded by ^BPSOS functionality - ; the code has been deleted and all that's left is the paper copy -TT() Q "S:Y[""."" Y=$P(Y,""."",2) S Y=Y_""000000"" S Y=""@""_$E(Y,1,2)_"":""_$E(Y,3,4)_"":""_$E(Y,5,6)" ; TT is kind of like ^DD("DD") but just for our times -SHOULDNT W "this should never happen" Q -TDIFNOW(T) ;EP - BPSOSQS ; compute time difference between T and NOW - ; returns # of seconds, positive if T precedes now (how long ago) - ; negative if T follows NOW (countdown "T minus...") - N %,%H,%I,X D NOW^%DTC ; giving % - Q $$TDIF(%,T) -TDIF(T1,T2) ; compute time difference T1-T2 = how many seconds - ;T1,T2 both Fileman date.times - S T1=$TR($J(T1,16,8)," ","0"),T2=$TR($J(T2,16,8)," ","0") - N R S R=$P(T1,".")-$P(T2,".")*86400 ; days' difference - S T1=$P(T1,".",2),T2=$P(T2,".",2) ; hhmmsstt - S T1=$E(T1,1,2)*60+$E(T1,3,4)*60+$E(T1,5,6) - S T2=$E(T2,1,2)*60+$E(T2,3,4)*60+$E(T2,5,6) - I $E(T1,7,8) S T1=$E(T1,7,8)/100+T1 - I $E(T2,7,8) S T2=$E(T2,7,8)/100+T2 - S R=R+T1-T2 - Q R -TADDSECS(T1,SECS) ;EP - BPSOSR1 - add SECS seconds to T1 - N T2 S T2=$$SECS2T2(SECS) - Q $$TADD(T1,T2) -BADPARAM(VARNAME,ATLABEL) D IMPOSS^BPSOSUE("P,DB","TI","Bad parameter "_VARNAME_"="_$G(@VARNAME),,ATLABEL,$T(+0)) Q -TADDNOWS(SECS) ;EP - BPSOSQ4,BPSOSQJ - add SECS seconds to NOW - I SECS'?1N.N D BADPARAM("SECS","TADDNOWS") Q "" - N T2 S T2=$$SECS2T2(SECS) - Q $$TADDNOW(T2) -SECS2T2(SECS) ; convert integer seconds into a fileman time format - N T2,NEG S NEG=(SECS<0) I NEG S SECS=-SECS - I SECS>86400 S T2=SECS\86400,SECS=SECS#86400_"." - E S T2="." - N % S %=SECS\3600,SECS=SECS#3600 S:$L(%)=1 %="0"_% S T2=T2_% - S %=SECS\60,SECS=SECS#60 S:$L(%)=1 %="0"_% S T2=T2_% - S:$L(SECS)=1 SECS="0"_SECS S T2=T2_SECS - Q $S(NEG:"-",1:"")_T2 -TADDNOW(T2) ;EP - BPSOSQS ; add T2 time differential to NOW - N %,%H,%I,X D NOW^%DTC ; giving % - Q $$TADD(%,T2) -TADD(T1,T2) ;EP - BPSOS6D,BPSOS6I ; add T2 time differential to T1 - I T1<0 D BADPARAM("T1","TADD") Q ; but T2 can be negative - N SGN S SGN=$S(T2<0:-1,1:1),T2=T2*SGN - I SGN<0,T2>T1 D BADPARAM("T2","TADD") Q ; can't handle this case (yet) - S T1=$TR($J(T1,16,8)," ","0"),T2=$TR($J(T2,16,8)," ","0") - N R ;S R=$P(T1,".",1)+($P(T2,".",1)*SGN) ; add days portion - S R=$$CDTC($P(T1,"."),$P(T2,".")*SGN) - S T2=$P(T2,".",2) ; note: without the sign - S T1=$P(T1,".",2) - S T1=$E(T1,1,2)*60+$E(T1,3,4)*60+$E(T1,5,6) ; seconds - S T2=$E(T2,1,2)*60+$E(T2,3,4)*60+$E(T2,5,6) ; seconds - I $E(T1,7,8) S T1=$E(T1,7,8)/100+T1 ; hundredths - I $E(T2,7,8) S T2=$E(T2,7,8)/100+T2 ; hundredths - S T2=T2*SGN ; restore sign to T2's hundredths - N S S S=T1+T2 - I S>86400 S S=S-86400,R=$$CDTC(R,1) ; R+1 ; carry - E I S<0 S S=S+86400,R=$$CDTC(R,-1) ; R-1 ; borrow - S T2=S\3600,S=S#3600 - S R=R_"."_$TR($J(T2,2)," ","0") ; hours - S T2=S\60,S=S#60 - S R=R_$TR($J(T2,2)," ","0") ; minutes - S T2=S\1,S=S#1 - S R=R_$TR($J(T2,2)," ","0") ; seconds - S T2=S*100\1,R=R_$TR($J(T2,2)," ","0") ; hundredths of seconds - S R=+R ; removes trailing zeroes - Q R -CDTC(X1,X2) N X,%H D C^%DTC Q X diff -auBN ./r1/BPSOSUE.m ./r2/r/BPSOSUE.m --- ./r1/BPSOSUE.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSUE.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,150 +0,0 @@ -BPSOSUE ;BHAM ISC/FCS/DRS/FLS - impossible errors ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; - ; Deal with impossible errors (errors which should never occur, - ; and which weren't already trapped by M). - ; -IMPOSS(UETYPE,UEOPT,UEMSG,UEMSG2,UELOC,UEROU,UENOLOG) ;EP - deal with impossible errors - called from many places - ; $$IMPOSS^BPSOSUE(UETYPE,UEOPT,UEMSG,UELOC,UEROU) - ; UETYPE = kinds of problems which may have occured - ; ["FM" a Fileman call has returned an error - ; ["L" a LOCK with ample time has failed - ; ["DB" a database error (some missing/incorrect field) - ; ["P" a programming error / some unexpected condition - ; ["DEV" some kind of device or file error - ; UEOPT = options available; first one listed is the default - ; Defaults to "TRI" - ; ["R" retry - retry the operation; log err - ; ["I" ignore - continue as though operation had succeeded; log err - ; ["T" abort - log err and terminate - ; UEMSG = optionally, an additional message to output - ; can be .MSG, and we'll walk the array for you. - ; UEMSG2 = even more message, like UEMSG. In a Fileman call failure, - ; you'd probably send .FDA,.MSG - ; UELOC = location, any number or name unique to the calling routine - ; UEROU = the name of the calling routine - ; UENOLOG = true if you do not want error log entry to be made - ; - ; $$ returns 1 to retry, 0 to ignore - ; - ; Caller may do with these values what he desires. - ; - ; To prevent excessive errors, we won't actually log an error if - ; another one has been logged recently. - ; - ; This routine really isn't as important as it looks. In fact, - ; it will almost never be encountered in practice. Its existence - ; owes mostly to an outrageous ruling made in the name of, - ; but contrary to, the very quality and maintainability that forced - ; errors give you. This in turn led to a significant delay - ; in the release of a product which has been proven to be dependable - ; in practice. - ; - ; Formerly, a zero/zero forced error was found at various places - ; in the code. In 13 months at ANMC, 11 months at Sitka, - ; and several months at Pawhuska, Wewoka, Santa Fe, and Taos, the - ; zero div by zero traps were never encountered, but over $3,000,000 - ; in revenues were collected. The ironic thing is, - ; without those extra checking, of things like Fileman return values, - ; sanity checks on input values, etc., the product would have been - ; less reliable, yet it would have sailed through the verifiction - ; phase of the project plan. - ; - ; Forced errors already pervade all of the M language. is - ; a forced error, for example. And forced errors are an integral part - ; of the design of the very hardware that runs these programs. - ; Follow the anti-forced error policy to its logical end and you - ; go to Intersleaze and say "stop issuing and instead, - ; prompt the user for the opportunity to continue" and then you go - ; to Intel and say "remove the addressing exception trap from your - ; microcode; our support organization wouldn't be able to cope with - ; the problem report on something like that." - ; - I $G(UEOPT)="" S UEOPT="TRI" - I $G(ZTQUEUED) S UECHOICE=$E(UEOPT) G QD - D:'$D(IOF) HOME^%ZIS ; make sure screen vars there - U IO - I '$D(IORVON) N IORVON,IORVOFF D - . N X S X="IORVON;IORVOFF" D ENDR^%ZISS - W !!,IORVON - W "An unexpected problem has been detected; notify programmer!" - I $D(UELOC)!$D(UEROU) D - . W !?5,"The problem occurred " - . I $D(UELOC) W "at location ",UELOC," " W:$X>60 ! - . I $D(UEROU) W "in routine ",UEROU - . W ".",! - W !?5,"The likely source" W:UETYPE["," "s" - W " of such a problem " W $S(UETYPE[",":"are",1:"is"),":",!!?5 - I UETYPE["FM" D - . W "Fileman has reported an error to the program.",!?5 - I UETYPE["L" D - . W "An interlock could not be obtained.",!?5 - I UETYPE["DB" D - . W "An inconsistency in the database was detected.",!?5 - I UETYPE["DEV" D - . W "An error condition trying to open a device or a file.",!?5 - I UETYPE["P" D - . W "A condition the program was unprepared to handle",!?5 - . W "or perhaps an error in the program logic.",!?5 - W !,"A programmer should be notified of this unfortunate event.",! - D MSG(.UEMSG),MSG(.UEMSG2) - W IORVOFF,!! - ; - N UECHOICE S UECHOICE=$$CHOICE ; Present the options; get I, R, T -QD ; - D LOGERR ; always log an error (unless too soon after prev. error) - I UECHOICE="T" G HALT - ;LJE;H $R(10)+1 ; could help various things (locks, database conditions) - H 2 - Q:$Q $S(UECHOICE="I":0,UECHOICE="R":1) Q - ; -MSG(X) ; display message, directly or in array - I '$D(X) W "X is undefined",! Q - I $D(X)#10 W X,! - I $D(X)>9 D - . N R S R="X" F S R=$Q(@R) Q:R="" W @R,! - W ! - Q - ; -CHOICE() ; given UEOPT[letters, UETYPE too - I UEOPT="" S UEOPT="T" - N DIR,X,Y - I $L(UEOPT)=1 S X=UEOPT G CH5 - S DIR(0)="SM^",X="" - I UEOPT["I" S X=X_"I:Ignore the problem and try to continue" - I UEOPT["R" S:X]"" X=X_";" S X=X_"R:Retry the operation" - I UEOPT["T" S:X]"" X=X_";" S X=X_"T:Terminate the program" - I UETYPE'="L" S X=X_" (WE RECOMMEND ""T"")" - S DIR(0)=DIR(0)_X - S DIR("B")=$E(UEOPT) D ^DIR -CH5 Q $S(X?1U:X,1:"T") - ; -LOGERR ; log an error - ; ^TMP($J,$T(+0),$J)=DUZ^$H last time we did this - N X S X=$G(^TMP($J,$T(+0),$J)) - I $P(X,U)'=DUZ G LOG2 - S X=$P(X,U,2) I +$H'=+X G LOG2 - S X=$P(X,",",2) I $P($H,",",2)-X>300 G LOG2 - I '$G(ZTQUEUED) D - . W !,"No additional error log entry will be made at this time.",! - Q -LOG2 ; - Q:$G(UENOLOG) ; requested: no error log entry - I '$G(ZTQUEUED) D - . W !,"Now recording some error log information to help the programmer...",! - D @^%ZOSF("ERRTN") ; trap an error - S ^TMP($J,$T(+0),$J)=DUZ_U_$H - I '$D(ZTQUEUED) D - . W ?10,"..." H 2 W "done.",! - Q -HALT ; halt - D H^XUS - ; at this point, the user is logged off - ; programmer shouldn't reach here, either, if HALT^ZU disinstackifies - Q "" ; error gets you back into programmer mode -TEST ; - N MYEXMSG,I F I=1:1:4 S MYEXMSG(I)="my extra msg line "_I - N X S X=$$IMPOSS^BPSOSUE("P","TIR","Additional Message",.MYEXMSG,"point 1","MYROU") - W !,"returned value = ",X,! - Q diff -auBN ./r1/BPSOSXA.m ./r2/r/BPSOSXA.m --- ./r1/BPSOSXA.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSXA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,4 +0,0 @@ -BPSOSXA ;BHAM ISC/FCS/DRS/FLS - Support ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; reserved for expansion diff -auBN ./r1/BPSOSXE.m ./r2/r/BPSOSXE.m --- ./r1/BPSOSXE.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSXE.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,58 +0,0 @@ -BPSOSXE ;BHAM ISC/FCS/DRS/FLS - Support - error log search ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -ERRLOG ;EP - search error log for $ZE in a ECME routine - ; ^%ZTER(1,$Hdate,m,n,"ZE")=$ZERROR value - N DERANGE S DERANGE=$$DTRANGE^BPSOSX Q:'DERANGE - D SEARCH($$HRANGE^BPSOSX(DERANGE)) - Q -RECENT D SEARCH($H-1_U_+$H) - Q -SEARCH(RANGE) ;EP - - W !,"Searching error log for ECME errors...",! - N COUNT S COUNT=0 - N H F H=$P(RANGE,U):1:$P(RANGE,U,2) D SEARCH1 - I 'COUNT W "None found",! - Q -SEARCH1 ; for one given H - N A,B,C - S A="" - F S A=$O(^%ZTER(1,H,A)) Q:A="" D - . S B="" - . F S B=$O(^%ZTER(1,H,A,B)) Q:B="" D - . . I $$CHECK(H,A,B) D REPORT(H,A,B) S COUNT=COUNT+1 - Q -CHECK(H,A,B) ; ^%ZTER(1,H,A,B,... is it for ECME? - N R S R=$$ZEROU(H,A,B) ; routine name in $ZERROR - I R?1"BPS".E Q 1 ; - S R=$$XQY0(H,A,B) ; option name in variable XQY0 - I R?1"BPS".E Q 1 - Q 0 -REPORT(H,A,B) ; - W "Error # ",B," on " - N H1 S H1=$P($G(^%ZTER(1,H,A,B,"H")),U) I 'H1 S H1=H - W $$HPRINT(H1) - I A'=1 W " (subscript A=",A,"?)" - W ! - W "Code: ",$G(^%ZTER(1,H,A,B,"LINE")),! - W "$ZE=",$$ZE(H,A,B),! - W "XQY0=",$$XQY0(H,A,B),! - Q -HPRINT(%H) ; - N Y,X,% D YX^%DTC - Q Y -ZE(H,A,B) ; return $ZERROR variable from error log entry - Q $G(^%ZTER(1,H,A,B,"ZE")) -ZEROU(H,A,B) ; return routine name from $ZERROR value - N X S X=$$ZE(H,A,B) - I X'[U Q "" - S X=$P(X,U,2) - S X=$P(X,":") - Q X -XQY0(H,A,B) Q $$VAR("XQY0",H,A,B) -VAR(VAR,H,A,B) ; return value of variable or "" if not found - N V,STOP,VAL S V="" - F S V=$O(^%ZTER(1,H,A,B,"ZV",V)) Q:V="" D Q:$D(VAL) - . I $P($G(^%ZTER(1,H,A,B,"ZV",V,0)),U)=VAR D - . . S VAL=^%ZTER(1,H,A,B,"ZV",V,"D") - Q $S($D(VAL):VAL,1:"") diff -auBN ./r1/BPSOSX.m ./r2/r/BPSOSX.m --- ./r1/BPSOSX.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSOSX.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,131 +0,0 @@ -BPSOSX ;BHAM ISC/FCS/DRS/FLS - Support ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q - ; Directory: - ;BPSOSXE - search for error log entries - ; -AUTO ; EP - automatic, using setup params for date range - S RANGE=$$GETRANGE(1) Q:RANGE<1 - D THELIST - Q -INTER ; EP - interactive use - S RANGE=$$GETRANGE Q:RANGE<1 -INTERJ ; join - N POP D ^%ZIS Q:$G(POP) - D THELIST - D ^%ZISC - Q -TODAY ;EP - S RANGE=DT_U_DT G INTERJ -YESTER ;EP - S RANGE=$$TADD^BPSOSUD(DT,-1),RANGE=RANGE_U_RANGE G INTERJ -WEEK ;EP - S RANGE=$$TADD^BPSOSUD(DT,-8)_U_$$TADD^BPSOSUD(DT,-1) G INTERJ - ; -THELIST ; calls to all the little things you want to monitor - ; given RANGE=fileman start^end dates - ; Put errors and shouldn't-happen things first: - W "Support Utility to survey ECME activity (",$T(+0),")",! - W "Site: ",$P(^DIC(4,DUZ(2),0),U),! - W "Date: ",$$NOWEXT^BPSOSU1,! - D SEARCH^BPSOSXE($$HRANGE(RANGE)) ; error log - D STRANDED ; stranded claims - report and cleanup - D UE ; impossible errors - ; Then put informational things: - D SHOWQ^BPSOSR2 - W "Winnowing old data:",! - W " the log files are in: ",$G(^BPS(9002313.99,1,"WINNOW LOGS")),! - W "Update of Report Master file: ",$G(^BPS(9002313.99,1,"BPSOSM1")),! - D TRANSACT - D PRESSANY^BPSOSU5() - D VOLUME^BPSOS35($P(RANGE,U),$P(RANGE,U,2)) ; pharmacy volume - Q -TRANSACT ; count 9002313.57 transactions in RANGE - ; It's a date range; be sure you get them all - D TRANS1 - W "Count of complete transactions: ",^TMP($J,"TRANSACT"),! - W "Tally by result type: ",! - N R S R="" F S R=$O(^TMP($J,"TRANSACT","R",R)) Q:R="" D - . W $J(^TMP($J,"TRANSACT","R",R),10)," ",R,! - W "Tally by insurer and by result type: ",! - N INS S INS="" F S INS=$O(^TMP($J,"TRANSACT","INS",INS)) Q:INS="" D - . W ?10,$J(^TMP($J,"TRANSACT","INS",INS),5)," for ",INS - . I ^TMP($J,"TRANSACT","INS",INS)=$G(^TMP($J,"TRANSACT","INS",INS,"R","PAPER")) W " - all PAPER",! Q - . E W ! - . S R="" F S R=$O(^TMP($J,"TRANSACT","INS",INS,"R",R)) Q:R="" D - . . W ?20,$J(^TMP($J,"TRANSACT","INS",INS,"R",R),5)," ",R,! - W "Tally by transaction time:",! - N SECS S SECS="" F S SECS=$O(^TMP($J,"TRANSACT","TIME",SECS)) Q:SECS="" D - . W $J(^TMP($J,"TRANSACT","TIME",SECS),10)," - " - . I SECS?1N.N W $$SECSDHMS^BPSOSUD(SECS) - . E W SECS - . I SECS'?1N.N!(SECS>120) W " - IEN57=",$O(^TMP($J,"TRANSACT","TIME",SECS,"")) - . W ! - Q -TRANS1 ; - ; ^TMP($J,"TRANSACT")=count of 9002313.57 transactions - ; ^TMP($J,"TRANSACT","R",result)=count by result type - ; ^TMP($J,"TRANSACT","INS",company)=count by insurance company - ; ^TMP($J,"TRANSACT","INS",company,"R",result)=count result by company - ; ^TMP($J,"TRANSACT","TIME",secs)=count - ; ^TMP($J,"TRANSACT","TIME",secs,IEN57) for certain too-long ones - ; - K ^TMP($J,"TRANSACT") S ^TMP($J,"TRANSACT")=0 ; caller should have already NEWed this - N T,X,Y S X=$P(RANGE,U),Y=$P(RANGE,U,2) - I Y'["." S $P(Y,".",2)=24 ; thru midnight, if nothing specified - S T=X - F D S T=$O(^BPSTL("AH",T)) Q:'T Q:T>Y - . N IEN57 S IEN57="" - . F S IEN57=$O(^BPSTL("AH",T,IEN57)) Q:'IEN57 D - . . N IEN57C S IEN57C=IEN57_"," - . . N R S R=$$GET1^DIQ(9002313.57,IEN57C,4.0098) S:R="" R="null??" - . . N INS S INS=$$GET1^DIQ(9002313.57,IEN57C,1.06) S:INS="" INS="No Insurance" - . . S ^TMP($J,"TRANSACT")=^TMP($J,"TRANSACT")+1 - . . S ^TMP($J,"TRANSACT","R",R)=$G(^TMP($J,"TRANSACT","R",R))+1 - . . S ^TMP($J,"TRANSACT","INS",INS)=$G(^TMP($J,"TRANSACT","INS",INS))+1 - . . S ^TMP($J,"TRANSACT","INS",INS,"R",R)=$G(^TMP($J,"TRANSACT","INS",INS,"R",R))+1 - . . N SECS S SECS=$$GET1^DIQ(9002313.57,IEN57C,9999.98) - . . I SECS="" S SECS="null?" - . . S ^TMP($J,"TRANSACT","TIME",SECS)=$G(^TMP($J,"TRANSACT","TIME",SECS))+1 - . . I SECS>120 S ^TMP($J,"TRANSACT","TIME",SECS,IEN57)="" - Q -STRANDED ; - N HRS S HRS=$P($G(^BPS(9002313.99,"BPSOSX TDIF")),U,3)*24 - I 'HRS S HRS=24*31 ; make it a month - D PURGE^BPSOSU7(HRS) - Q -UE ; ^TMP($J,"BPSOSUE",$J)=DUZ^$H - N NDAYS S NDAYS=$P($G(^BPS(9002313.99,"BPSOSX TDIF")),U,3) - I 'NDAYS S NDAYS=31 - N J S J="" Q:$O(^TMP($J,"BPSOSUE",J))="" - W "Errors which went through BPSOSUE:",! - F S J=$O(^TMP($J,"BPSOSUE",J)) Q:J="" D - . N X S X=^TMP($J,"BPSOSUE",J) - . N H S H=$P(X,U,2) - . I H-$H>NDAYS D Q ; too old to report; winnow it if it's really old - . . I H-$H>(NDAYS+30) K ^TMP($J,"BPSOSUE",J) - . D ; convert H from $H to Fileman - . . N %H,%,X S %H=H D YMD^%DTC S H=X - . Q:H<$P(RANGE,U) Q:H>$P(RANGE,U,2) - . W "Encountered by ",$P($G(^VA(200,+X,0)),U)," on ",H,! - Q -GETRANGE(HOW) ; HOW = 1 - silently, from setup file - ; otherwise, interactive, ask - I $G(HOW)=1 D - . N X S X=$G(^BPS(9002313.99,"BPSOSX TDIF")) - . I X?."^" S X="7^1",^BPS(9002313.99,"BPSOSX TDIF")=X - . S RANGE=$$TADD^BPSOSUD(DT,-$P(X,U))_U_$$TADD^BPSOSUD(DT,-$P(X,U,2)) - E D - . S RANGE=$$DTR^BPSOSU1 - Q RANGE -DTRANGE() ;EP - - N DEF S DEF=$P($$NOWFM^BPSOSU1,".") - N X S X=$$DTR^BPSOSU1("From date: ","Thru date: ",DEF,DEF,0) - Q X -HRANGE(RANGE) ;EP - convert fileman^fileman to $H^$H - N I,X,%H,%T,%Y - F I=1:1:$L(RANGE,U) D - . S X=$P(RANGE,U,I) - . D H^%DTC - . S $P(RANGE,U,I)=%H_$S(%T:","_%T,1:"") - Q RANGE diff -auBN ./r1/BPSRDT.m ./r2/r/BPSRDT.m --- ./r1/BPSRDT.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSRDT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,169 +0,0 @@ -BPSRDT ;BHAM ISC/FCS/DRS/FLS - choose which field to sort reports on. ;06/01/2004 - ;;1.0;IHS PHARMACY POINT OF SALE;;JUN 2004 - Q -INFO(BPSTYPE) ;EP - from BPSOS6H - N BPSSRT,BPSPRT,RELVAL,BPSFR,BPSTO,BPSPHR,DIR,PAG,X,DIS,Y,I,FILTER,DIC - ; -PHR ; - ECME Pharmacy Selection - I $P(^BPS(9002313.56,0),"^",4)>1 D - . W ! S DIC=9002313.56,DIC(0)="QEAM",DIC("A")="ECME PHARMACY: " - . F D ^DIC I $G(Y)>0!$D(DUOUT)!$D(DTOUT) Q - E S Y=+$O(^BPS(9002313.56,0)) W:Y !!,"ECME PHARMACY: ",$$GET1^DIQ(9002313.56,Y,.01) - G END:Y'>0 S BPSPHR=+Y W "NCPDP (NABP) #"_$$GET1^DIQ(9002313.56,BPSPHR,.02),! - ; -SEL ; - Main Sort Criteria selection - K ^TMP($J,"REPORT"),DIR,DIC - I BPSTYPE="NOTREL" S BPSSRT=.02,Y=5 G PRT - ; - S DIR(0)="SO^1:Released Date;2:Date Label printed;3:Fill Date;4:Date Issued;5:Transaction Date;Q:Quit" - S DIR("L",1)="Select one of the following:" - S DIR("L",2)="" - S DIR("L",3)=" 1 Released Date 4 Date Issued" - S DIR("L",4)=" 2 Date Label Printed 5 Transaction Date" - S DIR("L")=" 3 Fill Date" - D ^DIR K DIR G END:Y="Q"!(Y="^") - S BPSSRT=$S(Y=1:.01,Y=2:.095,Y=3:.08,Y=4:.09,Y=5:.02,1:"BAD") - I $G(BPSSRT)="BAD" W !!,"Enter a number between 1 and 5, Q or ^" G SEL - ; -PRT S BPSSRT="@"_BPSSRT - S $P(^TMP($J,"REPORT"),"^",1)=$S(BPSTYPE="REVERSE":"REVERSAL",BPSTYPE="REJECT":"REJECTED",1:BPSTYPE)_" CLAIMS" - S $P(^TMP($J,"REPORT"),"^",2)=$P("RELEASE^LABEL^FILL^ISSUE^TRANSACTION","^",Y) - S $P(^TMP($J,"REPORT"),"^",3)=$S(Y=1:1,Y=2:10,Y=3:8,Y=4:9,Y=5:2,1:0) - ; - I BPSTYPE="PAYABLE" D - . S BPSSRT=BPSSRT_",@TRANSACTION:PATIENT,@RXI:DRUG,@TRANSACTION:RESULT CATEGORY" - . F I=2,3 S (BPSFR(I),BPSTO(I))="",(BPSFR(4),BPSTO(4))="E PAYABLE" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""PAYABLE"")" - . S BPSPRT="[BPS PAYABLE DETAIL]" - ; - I BPSTYPE="NOTREL" D - . S BPSSRT=BPSSRT_",@RELEASE DATE,@TRANSACTION:PATIENT,@RXI:DRUG,@TRANSACTION:RESULT CATEGORY" - . S (BPSFR(2),BPSTO(2))="NOT RELEASED" F I=3:1:5 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""NOTREL"")" - . S BPSPRT="[BPS PAYABLE DETAIL]" - ; - I BPSTYPE="PAPER" D - . S BPSSRT=BPSSRT_",@TRANSACTION:PATIENT,@RXI:DRUG" - . F I=2,3 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""PAPER"")" - . S BPSPRT="[BPS PAPER DETAIL]" - ; - I BPSTYPE="MISSED" D - . S BPSSRT=BPSSRT_",@TRANSACTION:PATIENT,@RXI:DRUG" - . F I=2,3 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""MISS"")" - . S BPSPRT="[BPS MISSED PRESCRIPTIONS]" - ; - I BPSTYPE="DUPLICATE" D - . S BPSSRT=BPSSRT_",@TRANSACTION:PATIENT,@RXI:DRUG,@RESULT TYPE" - . S (BPSFR(4),BPSTO(4))=2 F I=2,3 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""DUPLICATE"")" - . S BPSPRT="[BPS DUPLICATE DETAIL]" - ; - I BPSTYPE="REVERSE" D - . S BPSSRT=BPSSRT_",@TRANSACTION:PATIENT,@RXI:DRUG,@TRANSACTION:RESULT WITH REVERSAL" - . S BPSFR(4)="E REVERSAL",BPSTO(4)="E REVERSAM" F I=2,3 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""REVERSE"")" - . S BPSPRT="[BPS PAYABLE DETAIL]" - ; - I BPSTYPE="NEEDREV" D - . S BPSSRT=BPSSRT_",@TRANSACTION:PATIENT,@RXI:DRUG,@TRANSACTION:RESULT WITH REVERSAL" - . S BPSFR(4)="E REVERSAL",BPSTO(4)="E REVERSAM" F I=2,3 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""NEEDREV"")" - . S BPSPRT="[BPS RPT NEED REVERSAL DETAIL]" - ; - I BPSTYPE="REJECT" D - . S BPSSRT=BPSSRT_",@TRANSACTION:PATIENT,@RXI:DRUG,@TRANSACTION:RESPONSE:RESPONSE STATUS" - . S (BPSFR(4),BPSTO(4))="R" F I=2,3 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""REJECT"")" - . S BPSPRT="[BPS REJECTION DETAIL]" - ; - I BPSTYPE="CAPTURED" D - . S BPSSRT=BPSSRT_",@RESULT TYPE,@TRANSACTION:PHARMACY,@#+TRANSACTION:INSURER,@TRANSACTION:PATIENT" - . S (BPSFR(2),BPSTO(2))=3 F I=3:1:5 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""CAPTURED"")" - . S BPSPRT="[BPS CAPTURED DETAIL]" - ; - I BPSTYPE="DAY" D - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""DAY"")" - . S BPSPRT="[BPS RPT TOTALS DETAIL]" - ; - I BPSTYPE="CLOSED" D - . S BPSSRT=BPSSRT_",@TRANSACTION:PATIENT,@RXI:DRUG" - . F I=2,3 S (BPSFR(I),BPSTO(I))="" - . S FILTER(0)="I $$FILTER^BPSRDT(D0,""CLOSED"")" - . S BPSPRT="[BPS CLOSED CLAIMS DETAIL]" - ; - D TEMPLATE(9002313.61,BPSSRT,BPSPRT,.BPSFR,.BPSTO,.FILTER) K ^TMP($J,"REPORT") - Q - ; -END W ! Q - ; -TEMPLATE(FILE,BY,FLDS,FR,TO,DIS) ;EP - from BPSOSS* - N L,DIC,DIASKHD,DIPCRIT,PG,DHIT,DIOEND,DATE,DCOPIES,IOP,DQTIME,DISUPNO,DISTOP,DISPAR,BPSRCODE - S L="",DIC=$S($D(FILE):FILE,1:9002313.4) - D DATE($P($P(BY,",",1),"@",2),.DATE) Q:$G(DATE)="^" - I FLDS="[BPS REJECTION DETAIL]" D Q:$G(BPSRCODE)="^" - . D RJCD(.BPSRCODE) Q:$G(BPSRCODE)="^" W ! - S ^TMP($J,"REPORT","RUNDT")=$$FMTE^XLFDT($$NOW^XLFDT()) - D EN1^DIP - W ! - Q -DATE(TYPE,DATE) ; For sorts to work we need a precise format, this sub handles that. - N VAL,TYPEVAL,DIR,X,Y - S TYPEVAL=$S(+TYPE=.01:"RELEASE",TYPE=.095:"LABEL",TYPE=.08:"FILL",TYPE=.09:"ISSUE",TYPE=.02:"TRANSACTION",1:"INCORRECT") - W ! S DIR(0)="DA^:"_DT_":EX",DIR("A")="START WITH "_TYPEVAL_" DATE: ",DIR("B")="T-1" D ^DIR I $D(DIRUT) S DATE="^" Q - S FR(1)=Y - S DIR(0)="DA^"_FR(1)_":"_DT_":EX",DIR("A")=" GO TO "_TYPEVAL_" DATE: ",DIR("B")="T" D ^DIR I $D(DIRUT) S DATE="^" Q - S TO(1)=Y,DATE="" W ! - S ^TMP($J,"REPORT","FR")=FR(1),^TMP($J,"REPORT","TO")=TO(1) - Q -RJCD(SELECT) ; - Selection of REJECTION CODES to print on the Report - N DIR,X,I,QT,DIR,Y K SELECT - W !,"You may select a single or multiple REJECTION CODES," - W !,"or enter ALL to select all REJECTION CODES.",! - S DIR(0)="9002313.93,.01;O",DIR("A")="REJECTION CODE" - S DIR("?")="^D HLP1^BPSRDT",DIR("B")="ALL" - F D ^DIR Q:X="" D Q:$G(QT) - . I $D(DUOUT)!($D(DTOUT)) K SELECT S SELECT="^",QT=1 Q - . I X="ALL" K SELECT S SELECT="ALL",QT=1 Q - . I '$D(^BPSF(9002313.93,"B",X)) W " ??",$C(7) Q - . S Y=$O(^BPSF(9002313.93,"B",X,0)) W " ",$$GET1^DIQ(9002313.93,Y,.02) - . S SELECT(+Y)="" K DIR("B") S DIR("A")=" ANOTHER ONE" - Q -FILTER(D0,TYPE) ; Filter - N RTYPE,VAL,DATA,CLAIM,TRANS - S VAL=0,DATA=$G(^BPSECX("RPT",D0,0)),TRANS=+$P(DATA,"^",3),RTYPE=$P(DATA,"^",6) - I 'TRANS Q VAL - I BPSPHR'=$$GET1^DIQ(9002313.57,TRANS,1.07,"I") Q VAL - ; - S CLAIM=+$P($G(^BPSTL(TRANS,0)),"^",4) - I TYPE="CLOSED" Q:$G(^BPSC(CLAIM,900)) 1 Q 0 - I +$G(^BPSC(CLAIM,900)) Q VAL - ; - I TYPE="PAYABLE" I RTYPE'=2 S VAL=1 - I TYPE="REVERSE" I RTYPE=8!(RTYPE=10) S VAL=1 - I TYPE="PAPER" I RTYPE=9 S VAL=1 - I TYPE="MISS" D - . I RTYPE=11!(RTYPE=19) S VAL=1 - . I $$DELETED^BPSOSM(D0)!$$RETSTOCK^BPSOSM(D0) S VAL=0 - I TYPE="REJECT" S VAL=$$RJFND(D0,.BPSRCODE) - I TYPE="NEEDREV" D - . I RTYPE'=11,RTYPE'=15,TYPE'=19 S VAL=1 - . I '$$DELETED^BPSOSM(D0),'$$RETSTOCK^BPSOSM(D0) S VAL=0 - Q VAL -RJFND(DO,CODES) ; - Checks entries against selected Rejection Codes - N FOUND,RJ,RCIEN - ; - I $G(CODES)="ALL" Q 1 - ; - S (FOUND,RJ)=0 - F S RJ=$O(^BPSECX("RPT",D0,"R",RJ)) Q:RJ="" D Q:FOUND - . S Z=$G(^BPSECX("RPT",D0,"R",RJ,0)) - . S RJIEN=$O(^BPSF(9002313.93,"B",$P(Z,":"),0)) Q:RJIEN="" - . I $D(CODES(RJIEN)) S FOUND=1 - ; - Q FOUND -HLP1 ; - Displays the help for the REJECTION CODE prompt - N DIC,D S DIC="^BPSF(9002313.93,",DIC(0)="",D="B" D DQ^DICQ - Q diff -auBN ./r1/BPSUTIL.m ./r2/r/BPSUTIL.m --- ./r1/BPSUTIL.m 2005-02-21 00:30:58.000000000 -0500 +++ ./r2/r/BPSUTIL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,19 +0,0 @@ -BPSUTIL ;BHAM ISC/FLS - Utility routine to put menu item descriptions in upper case;06/01/2004 - ;;1.0; IHS PHARMACY POINT OF SALE;; JUN 2004 - Q - ; -MAKEUPR(X) ; - N TST,VAL - S VAL=X - S TST=$$UPPER(X) - I $L(TST)>2,"|THE|FOR|NOW|AND|FOR|"'[("|"_TST_"|") S $E(VAL)=$$UPPER($E(VAL)) - Q VAL - ; -UPPER(X) ; - Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; -ECMEON(SITE) ; - Returns 1 if ECME is turned ON or 0 if not - ; SITE - Pointer to #59 (OUTPATIENT SITE) - Q:'$G(SITE) 0 - I $D(^BPS(9002313.56,"C",SITE)) Q 1 - Q 0 diff -auBN ./r1/CJS2.m ./r2/r/CJS2.m --- ./r1/CJS2.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/CJS2.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,31 @@ +CJS2 ; Save patches to HFS files in respective folders ;12/14/98 10:56 + ; Get Mail Basket + ; Order through all messages + ; Parse on subject for patche's namespace\version + ; Save each under .txt for instructions and .kid for build + I '$D(DUZ) D ^XUP + S DIC="^XMB(3.7,DUZ,2,",DIC(0)="AEMQZ",DIC("A")="Select Basket: " D ^DIC G:Y<0 EXIT S BASKET=+Y + S DIR(0)="F^2:60",DIR("A")="Full path, up to but not including patch names" D ^DIR G:Y="^" EXIT S ROOT=Y + S MESSAGE=0 F S MESSAGE=$O(^XMB(3.7,DUZ,2,BASKET,1,MESSAGE)) Q:MESSAGE'>0 D I $D(POP) G:POP ERROR + . S SUBJECT=$P($G(^XMB(3.9,MESSAGE,0)),U) S NAME=$P($P(SUBJECT,"*")," ",$S(SUBJECT["EMERGENCY":3,1:2)) Q:'$L(NAME) Q:'$O(^DIC(9.4,"C",NAME,"")) + . S VER=$P(SUBJECT,"*",2),NUM=$P($P(SUBJECT,"*",3)," "),SEQ=$P(SUBJECT,"SEQ #",2) + . S PATCH=NAME_"-"_$TR(VER,".","p")_"_SEQ-"_SEQ_"_PAT-"_NUM + . D OPEN^%ZISH("OUTFILE",ROOT,PATCH_".txt","W") + . Q:POP + . U IO + . S LINE=.99 F S LINE=$O(^XMB(3.9,MESSAGE,2,LINE)) Q:LINE'>0 S TEXT=^(LINE,0) W TEXT,! Q:TEXT["$END TXT" + . D CLOSE^%ZISH("OUTFILE") + . F S LINE=$O(^XMB(3.9,MESSAGE,2,LINE)) Q:LINE'>0 S TEXT=^(LINE,0) Q:TEXT["$KID" + . Q:TEXT'["$KID" I (NAME_"*"_$S(VER[".":$S(VER<1:"0"_VER,1:VER),1:VER_".0")_"*"_NUM)'=$P(TEXT," ",2) W !,SUBJECT Q + . D OPEN^%ZISH("OUTFILE",ROOT,PATCH_".kid","W") + . Q:POP + . U IO + . W SUBJECT,!,"Extracted from mail message",!,"**KIDS**:"_NAME_"*"_$S(VER[".":$S(VER<1:"0"_VER,1:VER),1:VER_".0")_"*"_NUM_U,!! + . F S LINE=$O(^XMB(3.9,MESSAGE,2,LINE)) Q:LINE'>0 S TEXT=^(LINE,0) Q:TEXT["$END KID" W TEXT,! + . W "**END**",!,"**END**",! + . D CLOSE^%ZISH("OUTFILE") + W !,"Done" +EXIT K BASKET,NAME,DIC,Y,DIR,ROOT,SUBJECT,PATCH,VER,POP,LINE,MESSAGE,TEXT + Q +ERROR W !,"ERROR ON OPEN" + G EXIT diff -auBN ./r1/DDWT1.m ./r2/r/DDWT1.m --- ./r1/DDWT1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DDWT1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,10 @@ DDWT1 ;SFISC/PD KELTZ,MKO-READ AND PROCESS ;11:35 AM 25 Aug 2000 - ;;22.0;VA FileMan;**18**;Mar 30, 1999 + ;;22.0;VA FileMan;**18,GTM**;Mar 30, 1999 + ;;GT.M PORT;2.00;*under development*;4.3-001A;Unix,VMS + ; + ; worked around the GT.M bug with SET $EXTRACT. two lines in + ; STATUS changed 999 to +999 (HOU/DJW,PUG/TOAD). + ; ;Per VHA Directive 10-93-142, this routine should not be modified. D LOAD^DDW1 K DUOUT ;GFT F D GETIN Q:$D(DDWFIN) @@ -95,9 +100,9 @@ STATUS N DDWX,DDWS S DDWS="Scr "_(DDWA+DDWRW-1\DDWMR+1)_" of "_(DDWCNT-1\DDWMR+1) S DDWX="Ln "_(DDWA+DDWRW)_" of "_DDWCNT - S $E(DDWS,IOM\2+1-($L(DDWX)\2),999)=DDWX + S $E(DDWS,IOM\2+1-($L(DDWX)\2),+999)=DDWX S DDWX="Col "_DDWC - S $E(DDWS,IOM-$L(DDWX),999)=DDWX + S $E(DDWS,IOM-$L(DDWX),+999)=DDWX D CUP(DDWMR+2,1) W $P(DDGLCLR,DDGLDEL)_DDWS D POS(DDWRW,DDWC) Q diff -auBN ./r1/DENTVCNV.m ./r2/r/DENTVCNV.m --- ./r1/DENTVCNV.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVCNV.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,146 @@ +DENTVCNV ;DSS/SGM - CONVERT VEJD TO DENT ;10/29/2001 20:50 + ;;1.2;DENTAL;**30,32**;Aug 10, 2001 + ; this routine has the pre and post init routines to convert the DSS + ; DRM from the VEJD namespace and 19600 files to the DENT namespace + ; and 228 files + ; +FILE(RTN,FILE,IENS,VAL) ; call file^die to edit entry in IENS for file#=FILE + ; VAL = new value (or @) for .01 field + ; return RTN=1 if successful file, else = 0 + N X,Y,DIERR,ERR,FDA,ROOT + S ROOT=^DIC(FILE,0,"GL")_IENS_")",IENS=IENS_"," + S FDA(FILE,IENS,.01)=VAL + L +@ROOT D FILE^DIE(,"FDA","ERR") L -@ROOT + S RTN=1 I $D(DIERR) D MSG^DENTVUTL(.RTN,.ERR) S RTN=0 + Q + ; +FIND(FILE,VAL) ; return ien for FILE=lookup file# and record name=VAL + ; FILE = lookup file # VAL = lookup value for FILE + ; return RET=ien if successful; 0 if not found; if error + N X,Y,DIERR,ERR,IEN,RTN + S RTN=$$FIND1^DIC(FILE,,"QX",VAL,"B",,"ERR") + D:$D(DIERR) MSG^DENTVUTL(.RET,.ERR) + Q RTN + ; +ERR N I,X F I=1:1 Q:'$D(TMP(I)) S X=TMP(I) D MSG + Q + ; +MSG N A S A=1+$O(MSG("A"),-1),MSG(A)=X Q + ; +PRE ; pre-init to rename the DSS DRM gui option and security key + N MSG,UL S $P(UL,"-",76)="" + D PREO,PREK I $D(MSG) D MES^XPDUTL(.MSG) + Q + ; +PREO ; preinit to rename option name + N X,Y,Z,IEN,NAME,TMP + S NAME="VEJDWP DSS DENTAL RPCS",NAME(0)="DENTV DSS DRM GUI" + S IEN=$$FIND(19,NAME) Q:'IEN S IEN(0)=$$FIND(19,NAME(0)) + ; check to see if both options exist + I IEN(0)>0 D + .K TMP D FILE(.TMP,19,IEN,"@") + .I 'TMP D Q + ..S X=UL D MSG + ..S X="*** ERROR encountered trying to delete option "_NAME_" ***" + ..D MSG,ERR + ..Q + .; delete old option from any menus + .F X=0:0 S X=$O(^DIC(19,"AD",IEN,X)) Q:'X S Y=0 D + ..F S Y=$O(^DIC(19,"AD",IEN,X,Y)) Q:'Y D + ...K TMP S Z=Y_","_X_"," D FILE(.TMP,19.01,Z,"@") + ...Q + ..Q + .; delete old option from any secondary menus + .F X=0:0 S X=$O(^VA(200,"AD",IEN,X)) Q:'X S Y=0 D + ..F S Y=$O(^VA(200,"AD",IEN,X,Y)) Q:'Y D + ...K TMP S Z=Y_","_X_"," D FILE(.TMP,200.03,Z,"@") + ...Q + ..Q + .S X=UL D MSG S X="Option: "_NAME_" has been deleted" D MSG + .Q + ; old option exists, new option does not + I 'IEN(0) K TMP D + .D FILE(.TMP,19,IEN,NAME(0)) S X=UL D MSG + .I TMP S X="Option "_NAME_" renamed to "_NAME(0) D MSG + .I K ^DIC(19,IEN,"RPC") + .E S X="*** Error encountered renaming option "_IEN_" ***" D MSG,ERR + .Q + Q + ; +PREK ; rename security key VEJDWPD EDIT LOCAL to DENTV EDIT FILE + N X,Y,Z,NAME + S NAME="VEJDWPD EDIT LOCAL",NAME(0)="DENTV EDIT FILE" + S IEN=$$LKUP^XPDKEY(NAME) Q:'IEN + S Z=$$LKUP^XPDKEY(NAME(0)) Q:Z S X=UL D MSG + ;M ^XUSEC(NAME(0))=^XUSEC(NAME) + S Z=$$RENAME^XPDKEY(NAME,NAME(0)) + I Z S X="Security Key "_NAME_" renamed to "_NAME(0) + E S X="*** ERROR trying to rename security key "_NAME_" to "_NAME(0) + D MSG + Q + ; +POST ; post init + N MSG,UL S $P(UL,"-",76)="" + D MOVE,DEL I $D(MSG) D MES^XPDUTL(.MSG) + Q + ; +MOVE ; move file 19600.1 to 228.1 + N I,X,Y,Z,DA,DFN,DIK,ENC,INV,LOC,MSG,VST,X0 + Q:$O(^DENT(228.1,0)) + K ^TMP("DENT",$J) + L +^DENT(228.1) + D BMES^XPDUTL("Moving file 19600.1 to file 228.1 ...... ") + D BMES^XPDUTL("Start time: "_$$FMTE^XLFDT($$NOW^XLFDT)) + M ^DENT(228.1)=^VEJD(19600.1) + S $P(^DENT(228.1,0),U,1,2)=^DIC(228.1,0) + S X="A" F S X=$O(^DENT(228.1,X)) Q:X="" K ^(X) + F I=0:0 S I=$O(^DENT(228.1,I)) Q:'I S X0=^(I,0) D + .S DFN=$P(X0,U,2) + .S ENC=$P(X0,U,8) + .S VST=$P(X0,U,5) + .S LOC=$P(X0,U,11) + .S INV=9999999-(ENC\1) S:ENC["." INV=INV_"."_$P(ENC,".",2) + .F X=8,12,13,14,15,16,17 S $P(X0,U,X)="" + .I $G(^DENT(228.1,I,1,0))]"" S $P(^(0),U,2)=228.11 + .I 'VST,LOC S Z=0 D + ..F S Z=$O(^AUPNVSIT("AHL",LOC,+INV,Z)) Q:'Z Q:$P($G(^AUPNVSIT(Z,0)),U,5)=DFN + ..I Z S $P(X0,U,5)=Z + ..E S ^TMP("DENT",$J,I)="" + ..Q + .S ^DENT(228.1,I,0)=X0 + .Q + D BMES^XPDUTL("Reindexing file 228.1 .....") + S DIK="^DENT(228.1," D IXALL^DIK + L -^DENT(228.1) + D BMES^XPDUTL("Conversion of file 19600.1 to 228.1 completed") + D BMES^XPDUTL("End time: "_$$FMTE^XLFDT($$NOW^XLFDT)) + I $D(^TMP("DENT",$J)) D + .S X=UL D MSG + .S X="Unable to link the following record numbers in file 228.1 to a visit" + .D MSG S X="",I=0 + .F S I=$O(^TMP("DENT",$J,I)) Q:'I S X=X_$J(I,10) I $L(X)>60 D MSG S X="" + .I $L(X) D MSG + .D MES^XPDUTL(.MSG) K ^TMP("DENT",$J) + .Q + Q + ; +DEL ; delete any vejd stuff left over + N I,X,Y,Z,CPT,DA,DIK,DIU,X0 + ; move any local cpt codes from 19600 to 228 + I $O(^VEJD(19600,99999))>0 D + .L +^DENT(228) + .S Z=$O(^DENT(228,"A"),-1) + .F I=99999:0 S I=$O(^VEJD(19600,I)) Q:'I S X0=$P(^(I,0),U,1,2) D + ..Q:$O(^DENT(228,"B",+X0,0)) + ..S $P(X0,U,6)="LOCAL CODES",$P(X0,U,15)="L",Z=Z+1,^DENT(228,Z,0)=X0 + ..Q + .S X="A" F S X=$O(^DENT(228,X)) Q:X="" K ^(X) + .S DIK="^DENT(228," D IXALL^DIK + .L -^DENT(228) + .Q + I $D(CK) Q ; came from dentvip routine + ; delete VEJDWPD EDIT FILE security key + S Z=$$LKUP^XPDKEY("VEJDWPD EDIT FILE") D:Z DEL^XPDKEY(Z) + ; delete file 19600 + I $D(^DIC(19600)) S DIU="^VEJD(19600,",DIU(0)="DET" D EN^DIU2 + Q diff -auBN ./r1/DENTVDD.m ./r2/r/DENTVDD.m --- ./r1/DENTVDD.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVDD.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,67 @@ +DENTVDD ;DSS/SGM - CALLS FROM DENTAL DDs ;2/2/01 19:08 + ;;1.2;DENTAL;**30**;Aug 10, 2001 + ;the various entry points here are called from data dictionary elements + ;They may also be invoked by dentv* routines + ; + ;=========================== file 228 ================================= +EXH(XRF) ;executable help on fields 5 & 6 in file 228 + ; XRF = xref subscript from fields 5 & 6 + N SUB,I,Z S Z="" + F I=1:1 S Z=$O(^DENT(228,XRF,Z)) Q:Z="" S SUB(I)=" "_Z + D EN^DDIOL(.SUB) + Q +FLD4 ; input transform on DD(228,4). Ensures that value entered here is + ; compatible with corresponding field in file 221 + N %,AX,AY,AZ S AX=$P(^DENT(228,DA,0),U,4) + I 'AX K X Q ; no field pointer to file 221 + I '$D(^DD(221,AX,0)) K X Q ; invalid field ptr to file 221 + S AX=^DD(221,AX,0) I $P(AX,U,2)["S" D I "Q"[$P(AX,U,5,99)!'$D(X) Q + .F AY=1:1 S AZ=$P($P(AX,U,3),";",AY) Q:AZ="" Q:X=$P(AZ,":") + .K:AZ="" X Q ; checking for set of codes compatiblity + X $P(AX,U,5,99) Q ; execute input transform from dd(221) + ; +FLD4E ; executable help on DD(228,4). Shows help text and field description + ; from file 221 depending upon ? or ?? + N AX,AY,AZ S AX=$P(^DENT(228,DA,0),U,4) Q:'AX Q:'$D(^DD(221,AX,0)) + I X'="??" D EN^DDIOL($G(^DD(221,AX,3)),"","!?3") Q + F AZ=0:0 S AZ=$O(^DD(221,AX,21,AZ)) Q:'AZ D EN^DDIOL(^(AZ,0),"","!?3") + D EN^DDIOL(" ","","!") Q + ; +NUM ; called from input transform on dd(228,9.1) + N X1,X2,X3,X4,X5,Z S Z=X,X5="" K X Q:Z?.E1A.E + F X1=1:1 S X2=$P(Z,",",X1) Q:X2="" D Q:'$D(X5) + .I $P(X2,"-")'=(X2\1) K X5 Q + .I X2["-",$P(X2,"-",2,99)'=($P(X2,"-",2)\1) K X5 Q + .S X3=+X2,X4=+$P(X2,"-",2) I X3<1!(X3>32) K X5 Q + .I X4,X4<1!(X4>32)!(X48) K X Q + F X1=1:2:$L(X) S X2=$E(X,X1,X1+1),X2(X2)="" + S X2="" F S X2=$O(X2(X2)) Q:X2="" I "^LL^UL^LR^UR^"'[(U_X2_U) K X Q + I $D(X) S (X,X2)="" F S X2=$O(X2(X2)) Q:X2="" S X=X_X2_"," + S:$D(X) X=$E(X,1,$L(X)-1) Q + ; +SURF(F) ; input transform on various dds where F = dd number + ; checks for string as valid tooth surfaces + ; acceptable codes FDIOLM , if F'=228.1 then A acceptable + ; called from dd(228.11,2) + N A,B,C,L S X=$$UP^XLFSTR(X),B="",F=$G(F) S:F="" F=228.1 + I F'=228.1,X["A" K:$L(X)>1 X Q + F A=1:1:$L(X) S L=$E(X,A) K:"FMDIOL"'[L X Q:'$D(X) S C=$F(B,L) S:'C B=B_L + S:$D(X) X=B Q diff -auBN ./r1/DENTVI01.m ./r2/r/DENTVI01.m --- ./r1/DENTVI01.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVI01.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,208 @@ +DENTVI01 ;DSS/SGM - DATA FOR FILE 228 ;02/15/2002 20:37 + ;;1.2;DENTAL;**33,34**;AUG 10, 2001 + N I,X,Z K DATA + F I=1:2 S X=$P($T(DATA+I),";",3) Q:X="" S Z=$P(X,U) D + .S DATA(Z)=X,X=$P($T(DATA+I+1),";",3) S:X]"" DATA(Z,2)=X + .Q + Q +DATA ; + ;;D0120^V72.2^1.5^6^S^DIAG^VISITS^^^^^^^^C + ;; + ;;D0140^V72.2^1.5^6^S^DIAG^VISITS^^^^^^^^C + ;; + ;;D0150^V72.2^3^6^C^DIAG^VISITS^^^^^^^^C + ;; + ;;D0160^V72.2^3^6^C^DIAG^VISITS^^^^^^^^C + ;; + ;;D0170^V72.2^3^6^C^DIAG^VISITS^^^^^^^^C + ;; + ;;D0210^V72.2^3^10^18^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0220^V72.2^1^10^1^DIAG^XRAYS^^^y^^^^^C + ;; + ;;D0230^V72.2^1^10^1^DIAG^XRAYS^^^y^^^^^C + ;; + ;;D0240^V72.2^1^10^1^DIAG^XRAYS^^^y^^^^^C + ;; + ;;D0250^V72.2^1^8^1^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0260^V72.2^1^8^1^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0270^V72.2^1^10^1^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0272^V72.2^1^10^2^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0274^V72.2^1^10^4^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0277^V72.2^1^10^8^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0290^V72.2^2^8^1^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0310^V72.2^9^37^9^DIAG^MISC^^^^^^^^C + ;; + ;;D0320^V72.2^12^37^12^DIAG^MISC^^^^^^^^C + ;; + ;;D0321^V72.2^6^37^6^DIAG^MISC^^^^^^^^C + ;; + ;;D0322^V72.2^6^37^6^DIAG^MISC^^^^^^^^C + ;; + ;;D0330^V72.2^2^8^1^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0340^V72.2^2^8^1^DIAG^XRAYS^^^^^^^^C + ;; + ;;D0350^V72.2^2^37^2^DIAG^MISC^^^^^^^^C + ;; + ;;D0415^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0425^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0460^V72.2^1^37^1^DIAG^MISC^^^^^^^^C + ;; + ;;D0470^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0472^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0473^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0474^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0480^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0501^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0502^V72.2^3^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D0999^V72.2^1^37^3^DIAG^MISC^^^^^^^^C + ;; + ;;D1110^523.1^6^11^1^PREV^PROPH^^^^^^^^C + ;; + ;;D1120^523.1^5^11^1^PREV^PROPH^^^^^^^^C + ;; + ;;D1201^523.1^6^11^1^PREV^PROPH^^^^^^^^C + ;; + ;;D1203^521.00^1^37^2^PREV^MISC^^^^^^^^C + ;; + ;;D1204^521.00^1^37^2^PREV^MISC^^^^^^^^C + ;; + ;;D1205^523.1^7^11^1^PREV^PROPH^^^^^^^^C + ;; + ;;D1310^521.00^3^25^3^PREV^INSTRUCTIONS^^^^^^^^C + ;; + ;;D1320^305.1^3^25^3^PREV^INSTRUCTIONS^^^^^^^^C + ;; + ;;D1330^523.9^3^25^3^PREV^INSTRUCTIONS^^^^^^^^C + ;; + ;;D1351^521.00^2^37^2^PREV^MISC^^^y^^^^^C + ;; + ;;D1510^520.9^6^37^6^PREV^MISC^^^^^^^^C + ;; + ;;D1515^520.9^8^37^8^PREV^MISC^^^^^^^^C + ;; + ;;D1520^520.9^4^37^4^PREV^MISC^^^^^^^^C + ;; + ;;D1525^520.9^5^37^5^PREV^MISC^^^^^^^^C + ;; + ;;D1550^520.9^4^37^4^PREV^MISC^^^^^^^^C + ;; + ;;D2110^521.00^4^21^1^REST^SURFACES RESTORED^^1^y^^^y^^C + ;; + ;;D2120^521.00^5^21^2^REST^SURFACES RESTORED^^2^y^^^y^^C + ;; + ;;D2130^521.00^6^21^3^REST^SURFACES RESTORED^^3^y^^^y^^C + ;; + ;;D2131^521.00^7^21^4^REST^SURFACES RESTORED^^4+^y^^^y^^C + ;; + ;;D2140^521.00^4^21^1^REST^SURFACES RESTORED^^1^y^^^^^C + ;; + ;;D2150^521.00^5^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;; + ;;D2160^521.00^6^21^3^REST^SURFACES RESTORED^^3^y^^^^^C + ;; + ;;D2161^521.00^7^21^4^REST^SURFACES RESTORED^^4+^y^^^^^C + ;; + ;;D2330^521.00^4^21^1^REST^SURFACES RESTORED^^1^y^^^^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D2331^521.00^4.5^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D2332^521.00^6^21^3^REST^SURFACES RESTORED^^3^y^^^^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D2335^521.00^7^21^4^REST^SURFACES RESTORED^^4+^y^^^^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D2336^521.00^7^21^4^REST^SURFACES RESTORED^^4+^y^^^y^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D2337^521.00^7^21^5^REST^SURFACES RESTORED^^5^y^^^^^C + ;; + ;;D2380^521.00^4^21^1^REST^SURFACES RESTORED^^1^y^^^y^^C + ;;4,5,12,13,20,21,28,29 + ;;D2381^521.00^5^21^2^REST^SURFACES RESTORED^^2^y^^^y^^C + ;;4,5,12,13,20,21,28,29 + ;;D2382^521.00^8^21^3^REST^SURFACES RESTORED^^3+^y^^^y^^C + ;;4,5,12,13,20,21,28,29 + ;;D2385^521.00^4^21^1^REST^SURFACES RESTORED^^1^y^^^^^C + ;;1,2,3,4,5,12,13,14,15,16,17,18,19,20,21,28,29,30,31,32 + ;;D2386^521.00^5^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;;1,2,3,4,5,12,13,14,15,16,17,18,19,20,21,28,29,30,31,32 + ;;D2387^521.00^8^21^3^REST^SURFACES RESTORED^^3+^y^^^^^C + ;;1,2,3,4,5,12,13,14,15,16,17,18,19,20,21,28,29,30,31,32 + ;;D2388^521.00^8^21^4^REST^SURFACES RESTORED^^4+^y^^^^^C + ;; + ;;D2410^521.00^8^21^1^REST^SURFACES RESTORED^^1^y^^^^^C + ;; + ;;D2420^521.00^10^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;; + ;;D2430^521.00^12^21^3^REST^SURFACES RESTORED^^3^y^^^^^C + ;; + ;;D2510^521.00^10^21^1^REST^SURFACES RESTORED^^1^y^^^^^C + ;; + ;;D2520^521.00^12^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;; + ;;D2530^521.00^15^21^3^REST^SURFACES RESTORED^^3+^y^^^^^C + ;; + ;;D2542^521.00^12^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;; + ;;D2543^521.00^15^21^3^REST^SURFACES RESTORED^^3^y^^^^^C + ;; + ;;D2544^521.00^16^21^4^REST^SURFACES RESTORED^^4+^y^^^^^C + ;; + ;;D2610^521.00^19^21^1^REST^SURFACES RESTORED^^1^y^^^^^C + ;; + ;;D2620^521.00^19^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;; + ;;D2630^521.00^19^21^3^REST^SURFACES RESTORED^^3+^y^^^^^C + ;; + ;;D2642^521.00^12^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;; + ;;D2643^521.00^13^21^3^REST^SURFACES RESTORED^^3^y^^^^^C + ;; + ;;D2644^521.00^14^21^4^REST^SURFACES RESTORED^^4+^y^^^^^C + ;; + ;;D2650^521.00^19^21^1^REST^SURFACES RESTORED^^1^y^^^^^C + ;; + ;;D2651^521.00^19^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;; + ;;D2652^521.00^19^21^3^REST^SURFACES RESTORED^^3+^y^^^^^C + ;; + ;;D2662^521.00^18^21^2^REST^SURFACES RESTORED^^2^y^^^^^C + ;; + ;;D2663^521.00^18^21^3^REST^SURFACES RESTORED^^3^y^^^^^C + ;; + ;;D2664^521.00^18^21^4^REST^SURFACES RESTORED^^4+^y^^^^^C + ;; + ;;D2710^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2720^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2721^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2722^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2740^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2750^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2751^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2752^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2780^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; diff -auBN ./r1/DENTVI02.m ./r2/r/DENTVI02.m --- ./r1/DENTVI02.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVI02.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,208 @@ +DENTVI02 ;DSS/SGM - DATA FOR FILE 228 ;02/15/2002 20:37 + ;;1.2;DENTAL;**33,34**;AUG 10, 2001 + N I,X,Z K DATA + F I=1:2 S X=$P($T(DATA+I),";",3) Q:X="" S Z=$P(X,U) D + .S DATA(Z)=X,X=$P($T(DATA+I+1),";",3) S:X]"" DATA(Z,2)=X + .Q + Q +DATA ; + ;;D2781^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2782^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2783^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2790^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2791^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2792^521.00^18^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2799^521.00^8^27^1^REST^CROWNS^^^y^^^^^C + ;; + ;;D2910^521.00^3^37^3^REST^MISC^^^y^^^^^C + ;; + ;;D2920^521.00^3^37^3^REST^MISC^^^y^^^^^C + ;; + ;;D2930^521.00^4^37^4^REST^MISC^^^y^^^y^^C + ;; + ;;D2931^521.00^4^37^4^REST^MISC^^^y^^^^^C + ;; + ;;D2932^521.00^4^37^4^REST^MISC^^^y^^^^^C + ;; + ;;D2933^521.00^5^37^5^REST^MISC^^^y^^^^^C + ;; + ;;D2940^521.00^2^37^2^REST^MISC^^^y^^^^^C + ;; + ;;D2950^521.00^7^28^1^REST^POSTS/CORES^^^y^^^^^C + ;; + ;;D2951^521.00^1.5^37^1^REST^MISC^^^y^^^^^C + ;; + ;;D2952^521.00^7^28^1^REST^POSTS/CORES^^^y^^^^^C + ;; + ;;D2953^521.00^7^28^1^REST^POSTS/CORES^^^y^^^^^C + ;; + ;;D2954^521.00^7^28^1^REST^POSTS/CORES^^^y^^^^^C + ;; + ;;D2955^521.00^4^37^4^REST^MISC^^^y^^^^^C + ;; + ;;D2957^521.00^7^28^1^REST^MISC^^^y^^^^^C + ;; + ;;D2960^521.00^10^37^10^REST^MISC^^^y^^^^^C + ;; + ;;D2961^521.00^5^37^5^REST^MISC^^^y^^^^^C + ;; + ;;D2962^521.00^10^37^10^REST^MISC^^^y^^^^^C + ;; + ;;D2970^521.00^4^37^4^REST^MISC^^^y^^^^^C + ;; + ;;D2980^521.00^6^37^6^REST^MISC^^^y^^^^^C + ;; + ;;D2999^521.00^1^37^3^REST^MISC^^^y^^^^^C + ;; + ;;D3110^521.00^1^37^1^ENDO^MISC^^^y^^^^^C + ;; + ;;D3120^521.00^1^37^1^ENDO^MISC^^^y^^^^^C + ;; + ;;D3220^521.00^2^37^2^ENDO^MISC^^^y^^^y^^C + ;; + ;;D3221^521.00^3^37^3^ENDO^MISC^^^y^^^y^^C + ;; + ;;D3230^521.00^12^22^1^ENDO^ROOT CANALS^^^y^^^y^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D3240^521.00^24^22^2^ENDO^ROOT CANALS^^^y^^^y^^C + ;;4,5,12,13,20,21,28,29 + ;;D3310^522.0^12^22^1^ENDO^ROOT CANALS^^^y^3^^^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D3320^522.0^24^22^2^ENDO^ROOT CANALS^^^y^2^^^^C + ;;4,5,12,13,20,21,28,29 + ;;D3330^522.0^36^22^3^ENDO^ROOT CANALS^^^y^3^^^^C + ;;1,2,3,14,15,16,17,18,19,30,31,32 + ;;D3331^522.0^3^37^3^ENDO^MISC^^^y^^^^^C + ;; + ;;D3332^522.0^3^37^3^ENDO^MISC^^^y^^^^^C + ;; + ;;D3333^522.0^3^37^3^ENDO^MISC^^^y^^^^^C + ;; + ;;D3346^522.0^12^22^1^ENDO^ROOT CANALS^^^y^3^^^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D3347^522.0^20^22^2^ENDO^ROOT CANALS^^^y^2^^^^C + ;;4,5,12,13,20,21,28,29 + ;;D3348^522.0^28^22^3^ENDO^ROOT CANALS^^^y^3^^^^C + ;;1,2,3,14,15,16,17,18,19,30,31,32 + ;;D3351^522.9^3^37^3^ENDO^MISC^^^y^^^^^C + ;; + ;;D3352^522.9^2^37^2^ENDO^MISC^^^y^^^^^C + ;; + ;;D3353^522.9^6^37^6^ENDO^MISC^^^y^^^^^C + ;; + ;;D3410^522.9^12^19^12^ENDO^OTHER SURGERY^^^y^^^^^C + ;;6,7,8,9,10,11,22,23,24,25,26,27 + ;;D3421^522.9^15^19^15^ENDO^OTHER SURGERY^^^y^^^^^C + ;;4,5,12,13,20,21,28,29 + ;;D3425^522.9^16^19^16^ENDO^OTHER SURGERY^^^y^^^^^C + ;;1,2,3,14,15,16,17,18,19,30,31,32 + ;;D3426^522.9^2^19^2^ENDO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D3430^522.9^2^19^2^ENDO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D3450^522.9^4^19^4^ENDO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D3460^522.9^10^19^10^ENDO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D3470^522.9^6^19^6^ENDO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D3910^521.00^2^19^2^ENDO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D3920^525.9^6^19^6^ENDO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D3950^521.00^3^37^3^ENDO^MISC^^^y^^^^^C + ;; + ;;D3999^522.9^1^19^3^ENDO^MISC^^^y^^^^^C + ;; + ;;D4210^523.4^9^23^1^PERIO^QUADS^y^^^^^^^C + ;; + ;;D4211^523.4^4^19^4^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4220^523.4^6^23^1^PERIO^QUADS^y^^^^^^^C + ;; + ;;D4240^523.4^12^23^1^PERIO^OTHER SURGERY^y^^^^^^^C + ;; + ;;D4245^523.4^12^23^1^PERIO^OTHER SURGERY^y^^^^^^^C + ;; + ;;D4249^525.9^9^19^9^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4260^523.4^12^23^1^PERIO^OTHER SURGERY^y^^^^^^^C + ;; + ;;D4263^523.4^2^19^2^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4264^523.4^2^19^2^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4266^523.4^2^19^2^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4267^523.4^2^19^2^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4268^523.4^6^19^6^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4270^523.4^9^19^9^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4271^523.4^9^19^9^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4273^523.4^9^19^9^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4274^523.4^9^19^9^PERIO^OTHER SURGERY^^^y^^^^^C + ;; + ;;D4320^523.4^5^37^5^PERIO^MISC^^^y^^^^^C + ;; + ;;D4321^523.4^3^37^3^PERIO^MISC^^^y^^^^^C + ;; + ;;D4341^523.4^6^24^1^PERIO^QUADS^y^^^^^^^C + ;; + ;;D4355^523.4^6^24^1^PERIO^QUADS^^^^^^^^C + ;; + ;;D4381^523.4^2^37^2^PERIO^MISC^^^y^^^^^C + ;; + ;;D4910^523.4^6^37^6^PERIO^MISC^^^^^^^^C + ;; + ;;D4920^523.4^2^37^2^PERIO^MISC^^^^^^^^C + ;; + ;;D4999^523.8^1^37^3^PERIO^MISC^^^^^^^^C + ;; + ;;D5110^525.10^25^32^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5120^525.10^25^32^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5130^525.10^26^32^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5140^525.10^26^32^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5211^525.10^20^31^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5212^525.10^15^31^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5213^525.10^30^31^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5214^525.10^25^31^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5281^525.10^20^31^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5410^525.10^3^37^3^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5411^525.10^3^37^3^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5421^525.10^3^37^3^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5422^525.10^3^37^3^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5510^525.10^4^33^1^REMO^REPAIR^^^^^^^^C + ;; + ;;D5520^525.10^3^33^1^REMO^REPAIR^^^y^^^^^C + ;; + ;;D5610^525.10^3^33^1^REMO^REPAIR^^^^^^^^C + ;; + ;;D5620^525.10^6^33^1^REMO^REPAIR^^^^^^^^C + ;; + ;;D5630^525.10^4^33^1^REMO^REPAIR^^^^^^^^C + ;; + ;;D5640^525.10^3^33^1^REMO^REPAIR^^^y^^^^^C + ;; diff -auBN ./r1/DENTVI03.m ./r2/r/DENTVI03.m --- ./r1/DENTVI03.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVI03.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,208 @@ +DENTVI03 ;DSS/SGM - DATA FOR FILE 228 ;02/15/2002 20:37 + ;;1.2;DENTAL;**33,34**;AUG 10, 2001 + N I,X,Z K DATA + F I=1:2 S X=$P($T(DATA+I),";",3) Q:X="" S Z=$P(X,U) D + .S DATA(Z)=X,X=$P($T(DATA+I+1),";",3) S:X]"" DATA(Z,2)=X + .Q + Q +DATA ; + ;;D5650^525.10^4^33^1^REMO^REPAIR^^^y^^^^^C + ;; + ;;D5660^525.10^4^33^1^REMO^REPAIR^^^^^^^^C + ;; + ;;D5710^525.10^13^37^13^REMO^MISC^^^^^^^^C + ;; + ;;D5711^525.10^13^37^13^REMO^MISC^^^^^^^^C + ;; + ;;D5720^525.10^3^37^3^REMO^MISC^^^^^^^^C + ;; + ;;D5721^525.10^13^37^13^REMO^MISC^^^^^^^^C + ;; + ;;D5730^525.10^8^37^8^REMO^MISC^^^^^^^^C + ;; + ;;D5731^525.10^8^37^8^REMO^MISC^^^^^^^^C + ;; + ;;D5740^525.10^6^37^6^REMO^MISC^^^^^^^^C + ;; + ;;D5741^525.10^6^37^6^REMO^MISC^^^^^^^^C + ;; + ;;D5750^525.10^14^37^14^REMO^MISC^^^^^^^^C + ;; + ;;D5751^525.10^14^37^14^REMO^MISC^^^^^^^^C + ;; + ;;D5760^525.10^12^37^12^REMO^MISC^^^^^^^^C + ;; + ;;D5761^525.10^12^37^12^REMO^MISC^^^^^^^^C + ;; + ;;D5810^525.10^19^32^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5811^525.10^19^32^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5820^525.10^12^31^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5821^525.10^12^31^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5850^525.10^5^37^5^REMO^MISC^^^^^^^^C + ;; + ;;D5851^525.10^5^37^5^REMO^MISC^^^^^^^^C + ;; + ;;D5860^525.10^27^32^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5861^525.10^27^32^1^REMO^PROSTHESIS^^^^^^^^C + ;; + ;;D5862^525.10^15^34^15^REMO^SPLINTS^^^^^^^^C + ;; + ;;D5867^525.10^9^37^9^FIXED^MISC^^^y^^^^^C + ;; + ;;D5875^525.10^4^33^1^REMO^REPAIR^^^^^^^y^C + ;; + ;;D5899^525.10^6^34^6^REMO^SPLINTS^^^^^^^^C + ;; + ;;D5911^524.9^9^34^9^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5912^524.9^18^34^18^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5913^524.9^63^34^63^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5914^524.9^80^34^80^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5915^524.9^80^34^80^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5916^524.9^100^34^99^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5919^524.9^49^34^49^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5922^524.9^55^34^55^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5923^524.9^68^34^68^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5924^524.9^50^34^50^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5925^524.9^63^34^63^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5926^524.9^63^34^63^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5927^524.9^80^34^80^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5928^524.9^80^34^80^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5929^524.9^49^34^49^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5931^528.9^75^34^75^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5932^528.9^49^34^49^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5933^528.9^12^34^12^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5934^525.10^60^34^60^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5935^525.10^60^34^60^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5936^528.9^61^34^61^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5937^528.9^12^34^12^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5951^528.9^11^34^11^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5952^528.9^49^34^49^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5953^528.9^49^34^49^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5954^525.10^49^34^49^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5955^528.9^50^34^50^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5958^528.9^33^34^33^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5959^528.9^10^34^10^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5960^528.9^10^34^10^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5982^528.9^5^34^5^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5983^528.9^12^34^12^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5984^528.9^12^34^12^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5985^528.9^12^34^12^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5986^521.00^4^34^4^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5987^528.9^12^34^12^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5988^528.9^6^34^6^MXFPROS^SPLINTS^^^^^^^^C + ;; + ;;D5999^528.9^1^34^3^MXFPROS^MISC^^^^^^^^C + ;; + ;;D6010^525.10^12^19^12^IMPLANT^OTHER SURGERY^^^y^^^^^C + ;; + ;;D6020^525.10^12^19^12^IMPLANT^OTHER SURGERY^^^y^^^^^C + ;; + ;;D6040^525.10^12^19^12^IMPLANT^OTHER SURGERY^^^y^^^^^C + ;; + ;;D6050^525.10^12^19^12^IMPLANT^OTHER SURGERY^^^y^^^^^C + ;; + ;;D6055^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6056^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6057^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6058^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6059^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6060^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6061^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6062^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6063^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6064^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6065^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6066^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6067^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6068^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6069^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6070^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6071^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6072^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6073^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6074^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6075^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6076^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6077^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6078^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6079^525.10^12^37^12^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6080^525.10^3^19^3^IMPLANT^OTHER SURGERY^^^y^^^^^C + ;; + ;;D6090^525.10^6^37^6^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6095^525.10^6^37^6^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6100^525.10^16^37^16^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6199^525.10^6^37^6^IMPLANT^MISC^^^y^^^^^C + ;; + ;;D6210^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6211^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; diff -auBN ./r1/DENTVI04.m ./r2/r/DENTVI04.m --- ./r1/DENTVI04.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVI04.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,208 @@ +DENTVI04 ;DSS/SGM - DATA FOR FILE 228 ;02/15/2002 20:37 + ;;1.2;DENTAL;**33,34**;AUG 10, 2001 + N I,X,Z K DATA + F I=1:2 S X=$P($T(DATA+I),";",3) Q:X="" S Z=$P(X,U) D + .S DATA(Z)=X,X=$P($T(DATA+I+1),";",3) S:X]"" DATA(Z,2)=X + .Q + Q +DATA ; + ;;D6212^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6240^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6241^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6242^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6245^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6250^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6251^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6252^525.10^2^30^1^FIXED^PONTIC UNITS^^^y^^^^^C + ;; + ;;D6519^525.10^19^29^1^FIXED^ABUTMENTS^^2+^y^^^^^C + ;; + ;;D6520^525.10^19^29^1^FIXED^ABUTMENTS^^2^y^^^^^C + ;; + ;;D6530^525.10^19^29^1^FIXED^ABUTMENTS^^3+^y^^^^^C + ;; + ;;D6543^525.10^20^29^1^FIXED^ABUTMENTS^^3^y^^^^^C + ;; + ;;D6544^525.10^26^29^1^FIXED^ABUTMENTS^^4+^y^^^^^C + ;; + ;;D6545^525.10^6^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6548^525.10^12^37^12^FIXED^MISC^^^y^^^^^C + ;; + ;;D6720^525.10^17^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6721^525.10^17^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6722^525.10^17^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6740^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6750^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6751^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6752^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6780^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6781^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6782^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6783^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6790^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6791^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6792^525.10^18^29^1^FIXED^ABUTMENTS^^^y^^^^^C + ;; + ;;D6920^525.10^6^37^6^FIXED^MISC^^^y^^^^^C + ;; + ;;D6930^525.10^5^37^5^FIXED^MISC^^^y^^^^^C + ;; + ;;D6940^525.10^6^37^6^FIXED^MISC^^^y^^^^^C + ;; + ;;D6950^525.10^5^37^5^FIXED^MISC^^^y^^^^^C + ;; + ;;D6970^521.00^7^28^1^FIXED^POSTS/CORES^^^y^^^^^C + ;; + ;;D6971^521.00^7^28^1^FIXED^POSTS/CORES^^^y^^^^^C + ;; + ;;D6972^521.00^7^28^1^FIXED^POSTS/CORES^^^y^^^^^C + ;; + ;;D6973^521.00^7^28^1^FIXED^POSTS/CORES^^^y^^^^^C + ;; + ;;D6975^521.00^7.5^27^1^FIXED^CROWNS^^^y^^^^^C + ;; + ;;D6976^521.00^4^28^1^FIXED^POSTS/CORES^^^y^^^^^C + ;; + ;;D6977^521.00^4^28^1^FIXED^POSTS/CORES^^^y^^^^^C + ;; + ;;D6980^525.10^9^37^9^FIXED^MISC^^^y^^^^^C + ;; + ;;D6999^521.00^1^37^3^FIXED^MISC^^^y^^^^^C + ;; + ;;D7110^521.00^4^35^1^SURG^EXTRACTIONS^^^y^^^^^C + ;; + ;;D7120^521.00^2^35^1^SURG^EXTRACTIONS^^^y^^^^^C + ;; + ;;D7130^521.00^4^35^1^SURG^EXTRACTIONS^^^y^^^^^C + ;; + ;;D7210^520.9^5^36^1^SURG^SURGICAL EXTRACTIONS^^^y^^^^^C + ;; + ;;D7220^520.9^5^36^1^SURG^SURGICAL EXTRACTIONS^^^y^^^^^C + ;; + ;;D7230^520.9^6^36^1^SURG^SURGICAL EXTRACTIONS^^^y^^^^^C + ;; + ;;D7240^520.9^7^36^1^SURG^SURGICAL EXTRACTIONS^^^y^^^^^C + ;; + ;;D7241^520.9^8^36^1^SURG^SURGICAL EXTRACTIONS^^^y^^^^^C + ;; + ;;D7250^521.00^5^36^1^SURG^SURGICAL EXTRACTIONS^^^y^^^^^C + ;; + ;;D7260^528.9^9^19^9^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7270^525.9^10^19^10^SURG^OTHER SURGERY^^^y^^^^^C + ;; + ;;D7272^525.9^8^19^8^SURG^OTHER SURGERY^^^y^^^^^C + ;; + ;;D7280^525.9^7^19^7^SURG^OTHER SURGERY^^^y^^^^^C + ;; + ;;D7281^525.9^6^19^6^SURG^OTHER SURGERY^^^y^^^^^C + ;; + ;;D7285^525.9^4^16^1^SURG^BIOPSY^^^^^^^^C + ;; + ;;D7286^528.7^3^16^1^SURG^BIOPSY^^^^^^^^C + ;; + ;;D7290^525.9^7^19^7^SURG^OTHER SURGERY^^^y^^^^^C + ;; + ;;D7291^525.9^6^19^6^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7310^521.00^7^19^7^SURG^OTHER SURGERY^y^^^^^^^C + ;; + ;;D7320^525.9^4^19^4^SURG^OTHER SURGERY^y^^^^^^^C + ;; + ;;D7340^525.2^11^19^11^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7350^525.9^21^19^21^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7410^525.9^7^19^7^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7420^525.9^8^19^8^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7430^525.9^3^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7431^525.9^5^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7440^525.9^5^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7441^525.9^6^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7450^525.9^5^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7451^525.9^6^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7460^525.9^6^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7461^525.9^7^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7465^525.9^5^15^1^SURG^NEOPLASMS^^^^^^^^C + ;; + ;;D7471^525.9^7^19^7^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7480^525.9^7^19^7^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7490^525.9^40^19^40^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7510^528.3^5^19^5^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7520^525.9^7^19^7^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7530^525.9^4^19^4^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7540^525.9^6^19^6^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7550^525.9^10^19^10^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7560^525.9^17^19^17^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7610^802.5^21^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7620^802.4^11^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7630^802.30^21^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7640^802.20^11^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7650^802.5^17^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7660^802.4^9^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7670^802.27^10^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7680^802.20^29^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7710^802.5^24^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7720^802.5^14^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7730^802.39^26^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7740^802.29^14^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7750^802.5^20^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7760^802.4^11^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7770^802.37^12^17^1^SURG^FRACTURES^^^^^^^^C + ;; + ;;D7780^802.30^34^17^1^SURG^FRACTURES^^^^^^^^C + ;; diff -auBN ./r1/DENTVI05.m ./r2/r/DENTVI05.m --- ./r1/DENTVI05.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVI05.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,208 @@ +DENTVI05 ;DSS/SGM - DATA FOR FILE 228 ;02/15/2002 20:37 + ;;1.2;DENTAL;**33,34**;AUG 10, 2001 + N I,X,Z K DATA + F I=1:2 S X=$P($T(DATA+I),";",3) Q:X="" S Z=$P(X,U) D + .S DATA(Z)=X,X=$P($T(DATA+I+1),";",3) S:X]"" DATA(Z,2)=X + .Q + Q +DATA ; + ;;D7810^525.9^24^19^24^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7820^524.60^6^19^6^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7830^525.9^6^19^6^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7840^525.9^20^19^20^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7850^525.9^22^19^22^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7852^525.9^22^19^22^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7854^525.9^22^19^22^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7856^525.9^12^19^12^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7858^525.9^40^19^40^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7860^525.9^30^19^30^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7865^525.9^23^19^23^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7870^525.9^12^19^12^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7871^525.9^6^19^6^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7872^525.9^10^19^10^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7873^525.9^13^19^13^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7874^525.9^21^19^21^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7875^525.9^23^19^23^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7876^525.9^23^19^23^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7877^525.9^26^19^26^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7880^525.9^3^34^3^SURG^SPLINTS^^^^^^^^C + ;; + ;;D7899^525.9^6^37^6^SURG^MISC^^^^^^^^C + ;; + ;;D7910^525.9^5^19^5^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7911^525.9^6^19^6^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7912^525.9^6^19^6^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7920^525.9^12^19^12^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7940^525.9^23^19^23^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7941^525.9^44^19^44^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7943^525.9^33^19^33^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7944^525.9^33^19^33^SURG^OTHER SURGERY^y^^^^^^^C + ;; + ;;D7945^525.9^34^19^34^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7946^525.9^58^19^58^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7947^525.9^35^19^35^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7948^525.9^83^19^83^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7949^525.9^110^19^99^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7950^525.9^55^19^55^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7955^525.9^32^19^32^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7960^528.9^7^19^7^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7970^528.9^11^19^11^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7971^528.9^4^19^4^SURG^OTHER SURGERY^^^y^^^^^C + ;; + ;;D7980^527.9^20^19^20^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7981^527.9^32^19^32^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7982^527.9^12^19^12^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7983^527.9^25^19^25^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7990^525.9^17^19^17^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7991^525.9^18^19^18^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7995^524.9^18^19^18^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7996^524.9^18^19^18^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7997^525.9^6^19^6^SURG^OTHER SURGERY^^^^^^^^C + ;; + ;;D7999^520.9^1^19^6^SURG^MISC^^^^^^^^C + ;; + ;;D8010^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8020^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8030^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8040^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8050^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8060^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8070^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8080^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8090^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8210^520.9^12^37^12^ORTHO^MISC^^^^^^^^C + ;; + ;;D8220^520.9^12^37^12^ORTHO^MISC^^^^^^^^C + ;; + ;;D8660^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8670^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8680^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8690^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8691^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8692^520.9^6^37^6^ORTHO^MISC^^^^^^^^C + ;; + ;;D8999^520.9^1^37^15^ORTHO^MISC^^^^^^^^C + ;; + ;;D9110^525.9^3^37^3^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9210^525.9^2^37^2^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9211^525.9^1^37^1^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9212^525.9^1^37^1^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9215^525.9^1^37^1^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9220^525.9^3^37^3^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9221^525.9^1.5^37^1^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9230^525.9^2^37^2^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9241^525.9^3^37^3^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9242^525.9^1.5^37^1^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9248^525.9^1^37^1^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9310^V72.2^2^6.4^1^ADJUNCT^VISITS^^^^^^^^C + ;; + ;;D9410^525.9^12^37^12^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9420^525.9^10^6.2^1^ADJUNCT^VISITS^^^^^^^^C + ;; + ;;D9430^525.9^2^6.2^1^ADJUNCT^VISITS^^^^^^^^C + ;; + ;;D9440^525.9^12^37^12^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9610^525.9^2^37^2^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9630^525.9^2^37^2^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9910^525.9^2^37^2^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9911^525.9^2^37^2^ADJUNCT^MISC^^^y^^^^^C + ;; + ;;D9920^525.9^3^37^3^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9930^525.9^3^37^3^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9940^525.9^3^37^3^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9941^525.9^3^37^3^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9950^525.9^5^37^5^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9951^524.9^5^37^5^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9952^524.9^15^37^15^ADJUNCT^MISC^^^^^^^^C + ;; + ;;D9970^525.9^5^37^5^ADJUNCT^MISC^^^y^^^^^C + ;; + ;;D9971^524.9^2^37^2^ADJUNCT^MISC^^^y^^^^^C + ;; + ;;D9972^521.7^4^37^4^ADJUNCT^MISC^^^^^^^y^C + ;; + ;;D9973^521.7^1^37^1^ADJUNCT^MISC^^^y^^^^^C + ;; + ;;D9974^521.7^3^37^3^ADJUNCT^MISC^^^y^^^^^C + ;; + ;;D9999^V72.9^1^37^1^ADJUNCT^MISC^^^^^^^^C + ;; diff -auBN ./r1/DENTVIP1.m ./r2/r/DENTVIP1.m --- ./r1/DENTVIP1.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVIP1.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,247 @@ +DENTVIP1 ;DSS/SGM - POST INIT (CONTINUED) ;02/15/2002 20:37 + ;;1.2;DENTAL;**33,34**;Aug 10, 2001 + ; pre/post init when file 228 is exported +POST N RESET D S1,S2,S3,S4 + Q + ; +BMES(T) N VEJD D:$G(T)]"" BMES^XPDUTL(T) D:$D(T)>9 MES^XPDUTL(.T) + I $D(ERR) D MSG^DIALOG("AE",.VEJD,,,"ERR"),MES^XPDUTL(.VEJD) + Q + ; +CERR(T) ; process errors + N A,Y S A=1+$O(MESS("A"),-1) + I A=1 S MESS(1)="FILE 228 IEN CPT CODE ICD9 CODE ERROR CODES" + I S MESS(2)="------------ -------- --------- -----------",A=3 + S Y=$J($G(IFN),8),$E(Y,15)=CPTN,$E(Y,25)=ICDN,$E(Y,40)=T + S MESS(A)=Y + Q + ; +CJ(T) Q $$CJ^XLFSTR(T,72,"*") + ; +ICCK(X) ; check for status of icd9 code + ; return value^icd9 code name + ; value="" if no problems + ; value=4 if error retrieving data from file 80 + ; value=5 if icd9 code is inactive + ; value = 4,5 + N DENT,DIERR,ERR,ICD,RET + S ICD=+$G(X)_",",RET="" + D GETS^DIQ(80,ICD,".01;100;102",,"DENT","ERR") + I $D(DIERR) S RET=4 + I $G(DENT(80,ICD,100))]""!($G(DENT(80,ICD,102))]"") + I S:RET RET=RET_"," S RET=RET_5 + S $P(RET,U,2)=$G(DENT(80,ICD,.01)) + Q RET + ; +INDX ; reindex B xref on file 228 + N DA,DIK + S DIK="^DENT(228,",DIK(1)=".01^B" + L +^DENT(228) K ^DENT(228,"B") + D ENALL^DIK L -^DENT(228) + Q + ; +S1 ; RESET any local mods for mapping icd9 to cpt (only active icd9) + N X,Z,CPT,ICD,IEN + D INDX S RESET=1 + F CPT=0:0 S CPT=$O(^XTMP("DENT228",CPT)) Q:'CPT S ICD=^(CPT) D:ICD + .S IEN=$O(^DENT(228,"B",CPT,0)) Q:'IEN + .S X=$P(^DENT(228,IEN,0),U,2) Q:X=ICD + .S Z=$$ICCK(ICD) I $P(Z,U)="" S $P(^DENT(228,IEN,0),U,2)=ICD + .Q + K ^XTMP("DENT228") + Q + ; +S2 ; verify that all ADA CODES got added to file 228 + ;; Checking file 228 for any missing CPT/ICD9 codes + ;; Unable to lock ^DENT(228) - verification of all ADA codes not done + ;;1 - did not find CPT code in file 81 + ;;2 - error encountered trying to add CPT to file 228 + ;;3 - unexpected problem encountered trying to add CPT to file 228 + ;;4 - problem encountered trying to add ICD9 code to entry in file 228 + N X,Y,CPT,CPTN,DA,DATA,DIERR,DIK,ERR,ICD,ICDN,IEN,IFN,MESS,RTN,VCPT,VEJD + D BMES($$CJ($P($T(S2+1),";",3))) + I '$G(RESET) D INDX + L +^DENT(228):10 E D BMES($P($T(S2+2),";",3)) Q + F RTN=1:1:5 K DATA D @("^DENTVI0"_RTN) S VCPT="" D + .F S VCPT=$O(DATA(VCPT)) Q:VCPT="" D + ..K IFN S CPTN=$P(DATA(VCPT),U),ICDN=$P(DATA(VCPT),U,2) + ..S CPT=$$CPTIEN^DENTVUTL(VCPT) + ..I CPT<1 D CERR(1) Q + ..; check for any entries with no valid icd9 pointers + ..; IFN>0 if cpt code found in file 228 + ..S IFN=$O(^DENT(228,"B",CPT,0)) + ..I IFN,$P($G(^DENT(228,IFN,0)),U,2)>0 Q + ..K DA,DIERR,DIK,ERR,IEN,VEJD + ..I 'IFN S VEJD(228,"+1,",.01)=CPT,IEN(1)="" + ..I D UPDATE^DIE(,"VEJD","IEN","ERR") D Q:X + ...S X=0,IFN=$S(IEN(1)>0:IEN(1),1:"") + ...I $D(DIERR) D CERR(2) S X=1 + ...I 'X,IFN<1 D CERR(3) S X=1 + ...Q + ..S ICD=+$$ICD^DENTVUTL(ICDN) I ICD<1 D CERR(4) S ICD="" + ..S $P(^DENT(228,IFN,0),U,2,98)=ICD_U_$P(DATA(VCPT),U,3,99) + ..S:$G(DATA(VCPT,2))]"" ^DENT(228,IFN,2)=DATA(VCPT,2) + ..S DA=IFN,DIK="^DENT(228," D IX1^DIK + ..Q + .Q + L -^DENT(228) + I $D(MESS) S X=$O(MESS("A"),-1) D + .S X=X+1,MESS(X)=" " + .F Y=1,2 S X=X+1,MESS(X)=$TR($T(S3+Y),";"," ") + .F Y=3:1:6 S X=X+1,MESS(X)=$TR($T(S2+Y),";"," ") + .K ERR D BMES(.MESS) + .Q + Q + ; +S3 ; check for any INACTIVE CODES - cpt and icd9 + ;; Error codes + ;;------------------------------------------------------------ + ;;1 - invalid CPT code + ;;2 - CPT code is inactive + ;;3 - error encountered retrieving CPT code + ;;4 - error encountered trying to retrieve data from ICD9 file + ;;5 - ICD9 code is inactive + N X,Y,Z,CPT,CPTN,DENT,DIERR,ERR,ICD,ICDN,IFN,MESS,STR + D BMES($$CJ(" Checking file 228 for any inactive codes ")) + F IFN=0:0 S IFN=$O(^DENT(228,IFN)) Q:'IFN S X=^(IFN,0) D + .S CPT=+X,ICD=+$P(X,U,2) + .K DENT,DIERR,ERR,STR S STR="" + .D CPT^DENTVUTL(.DENT,CPT,,,DT) I +DENT=-1 D + ..I DENT["Invalid" S STR=1 + ..E I DENT["inactive" S STR=2 + ..E S STR=3 + ..Q + .S CPTN="" S:+DENT'=-1 CPTN=$P(DENT,U,2) + .S X=$$ICCK(ICD),ICDN=$P(X,U,2),X=$P(X,U) + .I +X S:STR STR=STR_"," S STR=STR_X + .I STR]"" D CERR(STR) + .Q + I $D(MESS) K ERR S X=1+$O(MESS("A"),-1) D + .S MESS(X)="" F Y=1:1:7 S X=X+1,MESS(X)=$TR($T(S3+Y),";"," ") + .D BMES(.MESS) + .Q + Q + ; +S4 ; verify that DENTV DSS DRM GUI option has all RPCs + N X,Y,DA,DENT,DIERR,DIK,ERR,IENS,LINE,OPT,RPC + S OPT="DENTV DSS DRM GUI" + D BMES($$CJ(" Checking RPC multiple in the "_OPT_" option ")) + S X=$$FIND1^DIC(19,,"QUX",OPT,"B",,"ERR") + I X=0!$D(DIERR) D BMES(" Could not find option "_OPT) Q + S IENS=","_X_",",OPT=X_U_OPT + L +^DIC(19,+OPT):10 E D Q + .K X,ERR S X(1)=" Unable to lock "_$NA(^DIC(19,+OPT)) + .S X(2)=" Did not verify that all RPCs are in option "_$P(OPT,U,2) + .D BMES(.X) + .Q + K DA,DIK S DA(1)=+OPT,DIK="^DIC(19,+OPT,""RPC""," + F DA=0:0 S DA=$O(^DIC(19,DA(1),"RPC","B",0,DA)) Q:'DA D ^DIK + K DA,DIK,^DIC(19,+OPT,"RPC","B") + S DA(1)=+OPT,DIK="^DIC(19,+OPT,""RPC"",",DIK(1)=".01^B" + D ENALL^DIK K DA,DIK + F LINE=1:1 S RPC=$P($T(L+LINE),";",3) Q:RPC="" D + .K X,Y,DENT,DIERR,ERR,RPCN + .S RPCN=$$FIND1^DIC(8994,,"QUX",RPC,"B",,"ERR") + .I $D(DIERR) D BMES(" Error encounted while looking for RPC = "_RPC) Q + .I RPCN=0 D BMES(" Did not find "_RPC_" in file 8994") Q + .S Y=$$FIND1^DIC(19.05,IENS,"QUX",RPCN,"B",,"ERR") + .Q:Y>0 K DIERR,ERR S DENT(19.05,"+1"_IENS,.01)=RPCN + .D UPDATE^DIE(,"DENT","ERR") Q:'$D(DIERR) K X + .S X=" Error trying to add "_RPC_" rpc to option "_$P(OPT,U,2) + .D BMES(X) + .Q + L -^DIC(19,+OPT) + Q + ; +L ; list of RPC names that should be in option + ;;DDR DELETE ENTRY + ;;DDR FILER + ;;DDR FIND1 + ;;DDR FINDER + ;;DDR GET DD HELP + ;;DDR GETS ENTRY DATA + ;;DDR KEY VALIDATOR + ;;DDR LISTER + ;;DDR LOCK/UNLOCK NODE + ;;DDR VALIDATOR + ;;DENTV ADA CODES + ;;DENTV ADA CODES QUICK + ;;DENTV ADD QL ENTRY + ;;DENTV DD FIELD UPDATE + ;;DENTV DD GET 221 + ;;DENTV DD GET 228 + ;;DENTV DD GET DATA + ;;DENTV DD GET/ADD RECORD + ;;DENTV DD SECURITY KEY + ;;DENTV DELETE HISTORY ENTRY + ;;DENTV DELETE QL ENTRY + ;;DENTV DENT HISTORY ENC + ;;DENTV DENTAL CLASSIFICATIONS + ;;DENTV DENTAL PROVIDER + ;;DENTV EXCEL EXTRACT + ;;DENTV FILE ADMIN TIME + ;;DENTV FILE DATA + ;;DENTV GET CATEG/CODES + ;;DENTV GET CATEGORIES + ;;DENTV GET CODE LIST + ;;DENTV GET DIAGNOSES LIST + ;;DENTV PCE PRIMARY + ;;DENTV TOOTH HISTORY + ;;DENTV USER DEFAULT DIV + ;;DG SENSITIVE RECORD ACCESS + ;;DG SENSITIVE RECORD BULLETIN + ;;GMRC LIST CONSULT REQUESTS + ;;ORQOR LIST + ;;ORQQAL DETAIL + ;;ORQQAL LIST + ;;ORQQCN GET CONSULT + ;;ORQQLR DETAIL + ;;ORQQPL DETAIL + ;;ORQQPL LIST + ;;ORQQPP LIST + ;;ORQQPS DETAIL + ;;ORQQPS LIST + ;;ORQQPX IMMUN LIST + ;;ORQQVI VITALS + ;;ORWCS LIST OF CONSULT REPORTS + ;;ORWCS REPORT TEXT + ;;ORWMC PATIENT PROCEDURES + ;;ORWPT LAST5 + ;;ORWPT LIST ALL + ;;ORWPT PTINQ + ;;ORWRA IMAGING EXAMS + ;;ORWRA REPORT TEXT + ;;ORWRP REPORT LISTS + ;;ORWRP REPORT TEXT + ;;ORWU DEVICE + ;;ORWU CLINLOC + ;;ORWU NEWPERS + ;;ORWU USERINFO + ;;ORWU VALIDSIG + ;;TIU AUTHORIZATION + ;;TIU CREATE ADDENDUM RECORD + ;;TIU CREATE RECORD + ;;TIU DELETE RECORD + ;;TIU DOCUMENTS BY CONTEXT + ;;TIU GET PN TITLES + ;;TIU GET RECORD TEXT + ;;TIU IS THIS A CONSULT? + ;;TIU LOAD BOILERPLATE TEXT + ;;TIU LOAD RECORD FOR EDIT + ;;TIU LOCK RECORD + ;;TIU LONG LIST OF TITLES + ;;TIU PERSONAL TITLE LIST + ;;TIU PRINT RECORD + ;;TIU REQUIRES COSIGNATURE + ;;TIU SIGN RECORD + ;;TIU SUMMARIES + ;;TIU UNLOCK RECORD + ;;TIU UPDATE ADDITIONAL SIGNERS + ;;TIU UPDATE RECORD + ;;VEJD DDR FINDER + ;;VEJD TPA GET KIDS STATUS + ;;VEJDWPB ADD PROBLEM + ;;VEJDWPB GET SC CONDITIONS + ;;VEJDWPB GET VISITS/APPOINTMENT + ;;VEJDWPB UPDATE PROBLEM + ;;XWB GET VARIABLE VALUE diff -auBN ./r1/DENTVIP.m ./r2/r/DENTVIP.m --- ./r1/DENTVIP.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVIP.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,43 @@ +DENTVIP ;DSS/SGM - PRE/POST INIT ROUTINE ;02/20/2002 12:34 + ;;1.2;DENTAL;**30,32,34**;Aug 10, 2001 + ; this contains the pre and post init entry points for the DSS DRM + ; KIDS package + ; environment check +ENV ;;To install this KIDS, you must have a valid DUZ and DUZ(0)="@" + Q:$G(XPDENV)'=1 I $G(DUZ)>0,$G(DUZ(0))="@" Q + S XPDQUIT=2 W !!?3,$P($T(ENV),";",3) + Q + ; +V() N X S X=$T(DENTVIP+1) Q $P(X,";",3)_U_$P($P(X,";",5),"*",3) + ; +PRE ; pre-init + N VER S VER=$$V + I $P(VER,U,2)=30 D PRE^DENTVCNV + D SAVE + Q + ; +POST ; post init + N I,X,CK,CPT,DATA,ICD,RTN,VCPT,VER S VER=$$V + I $P(VER,U,2)=30 D POST^DENTVCNV + I $P(VER,U,2)="30,32" D CLEAN + D POST^DENTVIP1 + Q + ; +CLEAN ; clean up file 19600 if left over from patch 30 + N CK,DA,DIU + S CK="" S:$D(^VEJD(19600)) CK="V" S:$D(^DD(19600)) CK=CK_"D" + S:$D(^DIC(19600)) CK=CK_"C" Q:CK="" + I CK["V" D DEL^DENTVCNV + I CK'["DC" K ^VEJD(19600) + I CK["D",CK'["C" K ^DD(19600) + I CK["C",CK'["D" K ^DIC(19600) + Q:CK'["DC" + I CK'["V" S ^VEJD(19600,0)="DENTAL CPT CODE MAPPING^19600PI^" + S DIU="^VEJD(19600,",DIU(0)="DT" D EN^DIU2 + Q + ; +SAVE ; save local changes made to national mapping of icd9 to cpt + K ^XTMP("DENT228") N I,X S I=0 + S ^XTMP("DENT228",0)=$$FMADD^XLFDT(DT,7)_U_$$NOW^XLFDT + F S I=$O(^DENT(228,I)) Q:'I S X=^(I,0) I $P(X,U,15)="C" S ^XTMP("DENT228",$P(X,U))=$P(X,U,2) + Q diff -auBN ./r1/DENTVRP1.m ./r2/r/DENTVRP1.m --- ./r1/DENTVRP1.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP1.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,148 @@ +DENTVRP1 ;DSS/SGM - RPC CALLS FOR DSS DENTAL CPRS ;02/20/2002 14:41 + ;;1.2;DENTAL;**30,34**;Aug 10, 2001 + ; See individual line tags for description of RPC calls + ; All rpcs in this routine make no chnages to the database, they + ; retrieve data only + Q + ; build array for ADA codes in ^tmp("dentvrp1",$j,cptname) + ; return ^tmp("dentvrp1",$j,cptname) = p1^p2^p3^p4^...^p12 where + ; p1 :== subcategory 1 from file 228 + ; p2 :== subcategory 2 from file 228 + ; p3 :== cpt short description from file 81 + ; p4 :== cpt name (.01 field from file 81) + ; p5 :== ctv value from file 228 + ; p6 :== # tooth surfaces from file 228 + ; p7 :== y if cpt related to a tooth (from file 228) + ; if $p(^dent(228,x,2),u)]"" then return teeth# instead + ; p8 :== y if cpt related to a quadrant from file 228 + ; p9 :== # canals if cpt related to tooth canal from file 228 + ; p10 :== associated ICD9 diagnosis (from file 228) in the format + ; pointer to icd9 (file 80)~icd9 short desc~icd9 code name + ; p11 :== field number from file 221 + ; p12 :== primary flag + ;^tmp("dentvrp1",$j,cptname,#)=$^mult descript field from cpt file #81 + ; +A(CPT) ; return ada codes and associated fields in ^tmp("dentvrp1",$j,cptname) + ; cpt=pointer to file 81 (^ICPT) + N I,X,X0,X1,X2,X3,Y,CPTNM,RET,STR + D CPT^DENTVUTL(.RET,+$G(CPT)) Q:RET=-1 + S CPTNM=$P(RET,U,2),X=$O(^DENT(228,"B",CPT,0)) + S X2="6^7^3^9^10^8^11^4^13" ; piece of ^dent(228,#,0) + S X3="1^2^5^6^7^8^9^11^12" ; piece of ada array to return to gui + S STR="^^"_$P(RET,U,1,2) + I X S X0=^DENT(228,X,0),Y=$L(X3,U) D + .F I=1:1:Y S $P(STR,U,$P(X3,U,I))=$P(X0,U,$P(X2,U,I)) + .S X1=$P(X0,U,2) S:X1 X1=$$ICD^DENTVUTL(X1) S $P(STR,U,10)=X1 + .; check to see if tooth related and have specific tooth #s + .I $P(STR,U,7)="y",$P($G(^DENT(228,X,2)),U)]"" S $P(STR,U,7)=$P(^(2),U) + .Q + S ^TMP(ND,$J,CPTNM)=STR + F X=0:0 S X=$O(RET(X)) Q:'X S ^TMP(ND,$J,CPTNM,X)="$^"_RET(X) + Q + ; +A1(TARG,ROOT) ; place ^tmp("dentvrp1",$j) into @targ@(#) + ; root = $na(^dent(228,"B")), $na(^dent(220.5,dent,19600,"B")) + ; or subtype to use the AS1 and AS2 xrefs + N CNT,GLB,ND,NXT + S ND="DENTVRP1",NXT=0 K ^TMP(ND,$J) + I ROOT["^DENT(" F S NXT=$O(@ROOT@(NXT)) Q:'NXT D A(NXT) + I ROOT'["^DENT(" D + .N IEN,QS S IEN=0 I ROOT'="ARR" D + ..F QS="AS1","AS2" F S IEN=$O(^DENT(228,QS,ROOT,IEN)) Q:'IEN D + ...D A(+^DENT(228,IEN,0)) + ...Q + ..Q + .I ROOT="ARR" F S IEN=$O(ARR(IEN)) Q:'IEN D A(ARR(IEN)) + .Q + S CNT=0,GLB=$NA(^TMP(ND,$J,0)) + F S GLB=$Q(@GLB) Q:$QS(GLB,2)'=$J Q:$QS(GLB,1)'=ND D + .S CNT=1+CNT,@TARG@(CNT)=@GLB + .Q + K ^TMP(ND,$J) + Q + ; +ADALST(RET) ; return all the ada codes in file 228 in above format + N X ;S RET=$NA(^TMP("DENT",$J)) K ^TMP("DENT",$J) + D A1("RET",$NA(^DENT(228,"B"))) + Q + ; +CAT(RET,TYP) ; rpc to return ada categories from 228 + ; TYP - optional - <1> for subcategory-1 <2> for sub cat-2 + ; ,<12> - for both subcategories [default] + N I,J,X,Y,Z S TYP=$G(TYP,12) + F I=1,2 S X="AS"_I I TYP[I S Y="" D + .F S Y=$O(^DENT(228,X,Y)) Q:Y="" S Z(Y)="" + .Q + S Y="" + F I=1:1 S Y=$O(Z(Y)) Q:Y="" S RET(I)=$E(Y)_$$LOW^XLFSTR($E(Y,2,$L(Y))) + Q + ; +CATC(RET,TYP) ; rpc to return ada code string for a given subcategory TYP + I $G(TYP)="" S RET(1)="-1^No dental category sent" Q + S TYP=$$UP^XLFSTR(TYP) D A1("RET",TYP) + S:'$D(RET) RET(1)="-1^"_TYP_" category not found in file 228" + Q + ; +DC(RET) ; rpc to return dental classifications (#220.2) + ; ret(#) = ien to file 220.2 ^ name from 220.2 ^ I/O + ; where I = inpatient classification , O = outpatient + N I,J S (I,J)=0 + F S I=$O(^DIC(220.2,I)) Q:'I D + .S J=J+1,RET(J)=I_U_$P(^(I,0),U)_U_$E("IO",(I>8)+1) + .Q + Q + ; +ICD(RET,VAL,SCR) ; rpc call to look up ICD9 diagnoses + ; VAL - required - user input lookup value + ; SCR - optional - default value of 1 + ; SCR=1 - only return active codes as of today + ; SCR=0 (or null) - only return inactive codes as of today + ; SCR - if you wish your own screening logic, then pass the M + ; code that is equivalent to a DIC("S") + ; RET = global array to return matches + ; if nothing found or error return RET(1)=-1^ + ; else return RET(#) = ien ^ icd9 code ^ short description + N I,X,Y,Z,DIERR,ERR,GLB,SCR,TEMP + S RET=$NA(^TMP("DENT",$J)),TEMP=$NA(^TMP("DILIST",$J)),SCR=$G(SCR,1) + K @RET,@TEMP + I $G(VAL)="" S @RET@(1)="-1^No lookup value received" Q + I SCR=1 S SCR="I '$P(^(0),U,9),'$P(^(0),U,11)" + I 0[SCR S SCR="I $P(^(0),U,9)!$P(^(0),U,11)" + D FIND^DIC(80,,"@;.01;3","MP",VAL,,,SCR,,,"ERR") + I $D(DIERR) S @RET@(1)="-1^error encountered doing lookup" Q + S (I,Z)=0 + F S I=$O(@TEMP@(I)) Q:'I S Z=Z+1,@RET@(Z)=$P(^(I,0),U,1,3) + I '$O(@RET@(0)) S @RET@(1)="-1^No matches found for "_VAL + K @TEMP + Q + ; +LIST(RET,VAL) ; rpc to return ada codes - VAL=fileman lookup value + N I,J,X,ARR,DIERR,ERR,LIST + I $G(VAL)="" S RET(1)="-1^No lookup value sent" Q + D FIND^DIC(228,,,"M",VAL,,,,,"LIST","ERR") + S J=+$G(LIST("DILIST",0)) + I 'J S RET(1)="-1^No entries found matching '"_VAL_"'" + E M ARR=LIST("DILIST",1) K LIST D A1("RET","ARR") + Q + ; +PROV(RET,IEN) ; rpc determine if NEW PERSON IEN is an active dental provider + ; return provider's name (1st m last) if active + ; else return -1 + N DEN,DIERR,ERR,NM S DEN=$D(^VA(200,+$G(IEN),0)),RET=-1 + I DEN S DEN=+$O(^DENT(220.5,"B",+$G(IEN),0)) + I DEN,$P(^DENT(220.5,DEN,0),U,3)=1 S DEN=0 ; active flag + I DEN S NM=$$GET1^DIQ(200,IEN_",",20.2,,,"ERR") I NM]"" S RET=NM + I DEN,NM="" D + .S NM=$$GET1^DIQ(200,IEN_",",.01,,,"ERR"),NM=$$NAMEFMT^XLFNAME(NM,,"DM") + .I NM]"" S RET=NM + .Q + Q + ; +QUICK(RET) ; RPC get quick list of cpt codes for user duz from file 220.5 + ; return ret(#) :== see description for subroutine A + ; return ret(1)="-1^No quick list on file" + N DENT,X S X="-1^No quick list on file" + S DENT=+$$DPROV^DENTVUTL($G(DUZ)) I 'DENT S RET(1)=X Q + I '$O(^DENT(220.5,DENT,19600,0)) S RET(1)=X Q + D A1("RET",$NA(^DENT(220.5,DENT,19600,"B"))) + Q diff -auBN ./r1/DENTVRP2.m ./r2/r/DENTVRP2.m --- ./r1/DENTVRP2.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP2.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,28 @@ +DENTVRP2 ;DSS/SGM - RPC CALLS FOR DSS DENTAL CPRS ;06/09/2001 18:02 + ;;1.2;DENTAL;**30**;Aug 10, 2001 + ; See individual line tags for description of RPC calls + ; All rpcs in this routine make changes to file 220.5 + Q +QLA(RET,DAT) ; rpc to add a cpt code to the user's quick list + ; DAT=cpt name to cpt (#81) RET returned 1 = successful, -1 = failed + N X,Y,DENT,ERR,IEN,IENS,DIERR S RET=-1 Q:$G(DAT)="" + S DAT=$$CPTIEN^DENTVUTL(DAT) Q:DAT<1 + S IENS=+$$DPROV^DENTVUTL($G(DUZ))_"," + Q:'IENS ; not a dental provider + I $O(^DENT(220.5,+IENS,19600,"B",DAT,0)) S RET=1 Q ;already on quick + S DENT(220.5196,"+1,"_IENS,.01)=DAT L +^DENT(220.5,+IENS,19600) + D UPDATE^DIE(,"DENT","IEN","ERR") L -^DENT(220.5,+IENS,19600) + S:+$G(IEN(1))>0 RET=1 + Q + ; +QLD(RET,DAT) ; rpc to delete a cpt code from a user's quick list + ; dat=cpt name to cpt (#81) RET returned 1 = successful, -1 = failed + N X,Y,DENT,ERR,IEN,IENS,DIERR S RET=-1 Q:$G(DAT)="" + S DAT=$$CPTIEN^DENTVUTL(DAT) Q:DAT<1 + S IEN=+$$DPROV^DENTVUTL($G(DUZ)) + Q:'IEN ; not a dental provider + S X=$O(^DENT(220.5,IEN,19600,"B",DAT,0)) I 'X S RET=1 Q ;not on quick + S IENS=X_","_IEN_",",DENT(220.5196,IENS,.01)="@" + L +^DENT(220.5,IEN,19600) D FILE^DIE(,"DENT","ERR") + L -^DENT(220.5,IEN,19600) S:'$D(DIERR) RET=1 + Q diff -auBN ./r1/DENTVRP3.m ./r2/r/DENTVRP3.m --- ./r1/DENTVRP3.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP3.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,150 @@ +DENTVRP3 ;DSS/SGM - DSS DENTAL EDIT FILE 228 ;08/03/2001 13:24 + ;;1.2;DENTAL;**30,32**;Aug 10, 2001 + ; This routine contains various rpcs for doing fileman enter/edits + ; into file 228 + Q + ; +ADD(RET,DATA) ; get ien to file 228 (or add new entry) + ; DATA = cpt code name ^ flag where flag=1 if adding new cpt code + ; return ien to file 228 or -1^error message + N I,J,X,Y,Z,ADD,CPT,DCPT,DENT,DIERR,ERR,FDA,FLG,IEN,DIERR + S X=$G(DATA),CPT=$P(X,U),FLG=+$P(X,U,2),ADD="" + ; if don't own key can't edit file + I '$$KEY(,1) S X=7 G ERR + ; check for valid cpt code + D CPT^DENTVUTL(.DCPT,CPT) I +DCPT=-1 S X=DCPT G ERR + S CPT=$P(DCPT,U,2) + I $E(CPT)="D",FLG S X=1 G ERR + ; look for ien in file 228 + S Y=$$FIND1^DIC(228,,"XM",CPT,,,"ERR") + I Y>0 S RET=Y Q + I 'FLG S X=2 G ERR + L +^DENT(228,0):1 E S X=3 G ERR + ; add new local code to file 228 + S IEN(1)="",DENT(228,"+1,",.01)=$P(DCPT,U,3) + D UPDATE^DIE(,"DENT","IEN","ERR") L -^DENT(228,0) + I $G(IEN(1))<1 S X=4 G ERR + S IEN=IEN(1)_",",FDA(228,IEN,14)="L",FDA(228,IEN,5)="LOCAL CODES" + D FILE^DIE(,"FDA","ERR") S RET=+IEN + Q + ; +DD(RET) ; rpc to return data dictionary definitions for file 228 + ; field# ^ field name ^ code ^ restrictions + ; where code is P, N, F, S, X, or L + ; P=pointer; N=numeric ; F=free text ; S=set of codes + ; X=special pointer ; L=list box entries (free text) + ; where restrictions are like input transform + N I,J,X,Y,DIERR,ERR,FIEN,FLD + I '$$KEY(,1) S X=7 G ERR + F FIEN=.01,1 D + .N DIERR,ERR,FLD + .D FIELD^DID(228,FIEN,"","LABEL;SPECIFIER","FLD","ERR") Q:$D(DIERR) + .S X=FIEN_U_FLD("LABEL")_"^P^"_(+$P(FLD("SPECIFIER"),"P",2)) + .D SET(X) + .Q + Q + ; +DD2(RET) ; rpc to return data dictionary definitions for file 221 + ; field# ^ field name ^ code ^ restrictions (see DD above for descript) + N I,J,X,Y,DIERR,ERR,FIEN,FLD + S RET="-1^this function is no longer used" Q + I '$$KEY(,1) S X=7 G ERR + F FIEN=5.9:0 S FIEN=$O(^DD(221,FIEN)) Q:FIEN>40 D + .N DIERR,ERR,FLD + .S Y="LABEL;TYPE;SPECIFIER;POINTER" + .D FIELD^DID(221,FIEN,"",Y,"FLD","ERR") Q:$D(DIERR) + .S X=FIEN_U_FLD("LABEL")_U_$E(FLD("TYPE"))_U_(+$P(FLD("SPECIFIER"),"P",2)) + .D SET(X) I $P(X,U,3)="S" S Y=FLD("POINTER") D + ..F I=1:1 S X=$P(Y,";",I) Q:X="" D SET("~"_$P(X,":",2)_U_$P(X,":")) + ..Q + .Q + Q + ; +ERR ; if bad data is received set ret(#)=-1^message and quit + ; if X=-1 then don't call D SET because ret array already set up + I X=1 S X="-1^Sorry, you cannot add a dental cpt code" + I X=2 S X="-1^"_CPT_" not found in file 228" + I X=3 S X="-1^Unable to lock file 228, try again" + I X=4 S X="-1^Unable to add "_CPT_" to file 228" + I X=5 S X="-1^No CPT code received" + I X=6 S X="-1^Errors encountered getting data for "_CPT + I X=7 S X="-1^Access to this file to not allowed" + I X=8 S X="-1^Invalid field name/number received" + I X=9 S X="-1^You are not allowed to edit this field" + I X=10 S X="-1^Invalid file 228 entry number: "_(+IENS) + I X=11 S X="-1^Do not use this rpc to edit the CPT name" + I X=12 S X="-1^No data sent to be filed" + I X=13 S X="-1^You may only delete locally added ADA codes" + I X'=-1,'$D(ADD) D SET(X) + I $D(ADD) S RET=X + Q + ; +FILE(RET,DATA) ; rpc to edit entries to file 228 + ; DATA = ien_to_file_228 ^ field# in 228 ^ value + N I,J,X,Y,IENS,DIERR,ERR,FLD,FDA,LOCAL + S DATA=$G(DATA) + S IENS=+DATA_",",FLD=+$P(DATA,U,2),DATA=$P(DATA,U,3),J=0 + ; must own key to use this rpc + I '$$KEY(,1) S X=7 G ERR + ; check for valid field name/number + S FLD=$$FLD(228,FLD) I FLD<0 S X=8 G ERR + ; check for allowable fields to be edited + I FLD'=.01,FLD'=1 S X=9 G ERR + ; check for valid record number + I '$D(^DENT(228,+IENS,0)) S X=10 G ERR + I FLD=.01,DATA'="@" S X=11 G ERR + I DATA="" S X=12 G ERR + S LOCAL=$P(^DENT(228,+IENS,0),U,15)="L" + I FLD=.01,'LOCAL S X=13 G ERR + S FDA(228,IENS,FLD)=DATA + L +^DENT(228,+IENS):2 E S X=3 G ERR + D FILE^DIE(,"FDA","ERR") L -^DENT(228,+IENS) + I $D(DIERR) D MSG^DENTVUTL(.RET,.ERR) S X=-1 G ERR + S RET(1)="1^Entry successfully updated" + Q + ; +FLD(FILE,FLD) ; FILE = file#, F = field number or name + ; return field# or -1 + N X,Y,DIERR,ERR,RET + S RET=-1 + I '$G(FILE)!($G(FLD)="") Q RET + I $D(^DD(228,FLD,0)) Q FLD + S X=$$GET1^DID(FILE,FLD,"","LABEL",,"ERR") + I X="" Q RET + S X=$O(^DD(FILE,"B",FLD,0)) I X Q X + Q RET + ; +GTD(RET,CPT) ; rpc to get data from file 228 for cpt and icd9 codes + ;return RET(#) = field# ^ field name ^ internal value ^ external value + ; ^ short description from pointer files + N X,Y,DAT,DATA,DESCCPT,DESCICD,DIERR,ERR,IENS,FLD,TMP + ; must own key to use this rpc + I '$$KEY(,1) S X=7 G ERR + ; check for cpt code sent + S CPT=$G(CPT) I CPT="" S X=5 G ERR + ; find internal entry number in file 228 + S IENS=$$FIND1^DIC(228,,"AM",CPT,,,"ERR")_"," + I 'IENS S X=2 G ERR + D GETS^DIQ(228,IENS,".01;1","EI","DATA","ERR") + I '$D(DATA) S X=6 G ERR + M DAT=DATA(228,IENS) + S (DESCCPT,DESCICD)="",X=$G(DAT(.01,"I")) + I X D CPT^DENTVUTL(.TMP,X) I +X'=-1 S DESCCPT=$P(TMP,U) + S X=$G(DAT(1,"I")) + I X S Y=$$ICD^DENTVUTL(X) I +Y'=-1 S DESCICD=$P(Y,"~",2) + S FLD=$$GET1^DID(228,.01,"","LABEL",,"ERR") + S X=".01^"_FLD_U_$G(DAT(.01,"I"))_U_$G(DAT(.01,"E"))_U_DESCCPT + D SET(X) + S FLD=$$GET1^DID(228,1,"","LABEL",,"ERR") + S X="1^"_FLD_U_$G(DAT(1,"I"))_U_$G(DAT(1,"E"))_U_DESCICD + D SET(X) + Q + ; +KEY(RET,EX) ; check for security key - either called from above or rpc + ; if $G(EX) then extrinsic function, else rpc call + ; returns 1 or 0 + N X S X=($D(^XUSEC("DENTV EDIT FILE",DUZ))#2) + I '$G(EX) S RET=X Q + Q X + ; +SET(T) N N S N=1+$O(RET("A"),-1),RET(N)=T Q diff -auBN ./r1/DENTVRP4.m ./r2/r/DENTVRP4.m --- ./r1/DENTVRP4.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP4.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,176 @@ +DENTVRP4 ;DSS/SGM - RPC CALLS FOR DSS DENTAL ;10/29/2001 20:50 + ;;1.2;DENTAL;**30,32**;Aug 10, 2001 + Q + ; +DEL(RET,IEN) ; RPC to delete all data in history file, das, and pce + ; associated with history record number IEN + ; RET - return RET(1)=1^message if successfully deleted all + ; else return RET(n)=-1^error messages + ; + N I,J,X,X0,Y,Z,CPT,DA,DD,DO,DAS,DATA,DENT,DIERR,DIK,ERR,ICD,MSG,PCE + N PKG,SOURCE,VISIT N:'$D(ERRFLG) ERRFLG + S IEN=+$G(IEN),ERRFLG=$G(ERRFLG,1) + I '$D(^DENT(228.1,IEN,0))!'IEN S X=9 G ERR + M DATA(228.1)=^DENT(228.1,IEN) + I $S($$KEY:0,1:$P(DATA(228.1,0),U,7)'=DUZ) S X=18 G ERR + S DAS=+$P(DATA(228.1,0),U,6),VISIT=+$P(DATA(228.1,0),U,5) + I DAS,$D(^DENT(221,DAS,0)) M DATA(221)=^DENT(221,DAS) + I VISIT D Q:$D(RET) + .S PKG=$$PKG^DENTVRP5 + .I 'PKG S X=15 D ERR S X=RET K RET S RET(1)=X Q + .S SOURCE="DENTV DSS GUI" + .S DENT("ENCOUNTER",1,"ENC D/T")=$P(^AUPNVSIT(VISIT,0),U) + .S DENT("ENCOUNTER",1,"PATIENT")=$P(DATA(228.1,0),U,2) + .S DENT("ENCOUNTER",1,"HOS LOC")=$P(DATA(228.1,0),U,11) + .S DENT("ENCOUNTER",1,"SERVICE CATEGORY")="A" + .S DENT("ENCOUNTER",1,"ENCOUNTER TYPE")="P" + .S DENT("ENCOUNTER",1,"DELETE")=1 + .S DENT("PROVIDER",1,"NAME")=$P(DATA(228.1,0),U,7) + .S DENT("PROVIDER",1,"DELETE")=1 + .F I=0:0 S I=$O(DATA(228.1,1,I)) Q:'I S X0=DATA(228.1,1,I,0) D + ..Q:$P(X0,U,13)'="y" ; did not file to PCE + ..F J=7:1:11 S X=$P(DATA(228.1,0),U,J) I X,'$D(ICD(X)) S ICD(X)="" + ..S X=$P(DATA(228.1,0),U,3) S:X CPT(X)=1+$G(CPT(X)) + ..Q + .S (I,X)=0 F S X=$O(ICD(X)) Q:'X S I=I+1 D + ..S DENT("DX/PL",I,"DIAGNOSIS")=X + ..S DENT("DX/PL",I,"DELETE")=1 + ..Q + .S (I,X)=0 F S X=$O(CPT(X)) Q:'X S I=I+1 D + ..S DENT("PROCEDURE",I,"PROCEDURE")=X + ..S DENT("PROCEDURE",I,"QTY")=CPT(X) + ..S DENT("PROCEDURE",I,"DELETE")=1 + ..Q + .S X=VISIT K VISIT S VISIT(1)=X + .S PCE=$$DATA2PCE^PXAPI("DENT",PKG,SOURCE,.VISIT,DUZ) + .I PCE<1 S Z=0 D + ..F I=0:0 S I=$O(DENT("DIERR",I)) Q:'I S J=0 D + ...F S J=$O(DENT("DIERR",I,"TEXT",J)) Q:'J D + ....S X=DENT("DIERR",I,"TEXT",J) + ....Q:$E(X,1,4)="TO: " Q:X?." " + ....I X?1"Calling Package".E S J="A" Q + ....S Z=Z+1,RET(Z)="-1^"_X + ....Q + ...S Z=Z+1,RET(Z)="-1^" + ...Q + ..Q + .Q + I DAS S DA=DAS,DIK="^DENT(221," D ^DIK + K DA,DIK S DA=IEN,DIK="^DENT(228.1," D ^DIK + S X=1_U + I DAS S X=X_"DAS entry "_$$FMTE^XLFDT(9999999-DATA(221,0))_"; " + S X=X_"Dental History record "_IEN_"; " + I $G(PCE)>0 S X=X_" associated PCE data " + S RET(1)=X_"deleted" + Q + ; +DELV(RET,VISIT) ; RPC to delete all data in history file with VISIT + ; RET - return array + ; RET(n) = 1^message detailing what was deleted + ; else RET(1) = -1^error message + ; + N I,X,ERRFLG,NODE,NODERR,SAVE,TMP,TMPERR,VST + S VISIT=+$G(VISIT),ERRFLG=1 + I 'VISIT S X=16 G ERR + I '$D(RET),'$O(^DENT(228.1,"V",VISIT,0)) S X=17 G ERR + F VST=0:0 S VST=$O(^DENT(228.1,"V",VISIT,VST)) Q:'VST D + .D DEL(.TMP,VST) + .I +TMP(1)=1 S NODE=1+$G(NODE),SAVE(NODE)=TMP(1) + .E D + ..S NODERR=1+$G(NODERR),I=0 + ..S TMPERR(NODERR)="Error while deleting visit ien: "_VST + ..F S I=$O(TMP(I)) Q:'I S NODERR=1+$G(NODERR),TMPERR(NODERR)=TMP(I) + ..Q + .Q + S X=0 F I=0:0 S I=$O(SAVE(I)) Q:'I S X=X+1,RET(X)=SAVE(I) + F I=0:0 S I=$O(TMPERR(I)) Q:'I S X=X+1,RET(X)=SAVE(I) + I '$D(RET) S RET(1)="-1^Nothing was deleted" + Q + ; +DELH(RET,IEN) ; delete ien in file 228.1 + N ARR,DIERR,ERR,X,Y S IEN=+$G(IEN) + I '$D(^DENT(228.1,IEN)) S X=9 G ERR + S ARR(228.1,IEN_",",.01)="@" + L +^DENT(228.1,IEN) D FILE^DIE(,"ARR","ERR") L -^DENT(228.1) + I $D(DIERR) S X=10 G ERR + S RET="1^Record "_IEN_" has been deleted" + Q + ; +NON(RET,DATA) ; rpc to file non-clinical time into file 226 + ; msg = 1 (if file successful), or -1^message text if unsuccessful + ; DATA = P1^P2^P3^P4 + ; p1 = duz (pointer to file 200 - must also be in 220.5) + ; p2 = single character (A)dmin, (F)ee, (E)duc/train, (R)esearch + ; p3 = hour.min + ; p4 = division name from file 225 + N I,J,K,X,X1,Y,ARR,DENT,DENT0,DIERR,ERR,HR,IEN,MIN,TIME + S DATA(.3)=$P(DATA,U,4) + S DATA(.6)=$P(DATA,U,2) + S DATA(.9)=$P(DATA,U,3) + S DENT=$$DPROV^DENTVUTL(+DATA),DENT0=$G(^DENT(220.5,+DENT,0)) + I 'DENT S X=1 G ERR + I $P(DENT0,U,3) S X=2 G ERR + I DATA(.6)'?1U!("ARFE"'[DATA(.6)) S X=3 G ERR + S TIME=DATA(.9),MIN=$P(TIME,".",2) + I TIME<.25!(TIME>49.75)!("^^25^5^75^"'[(U_MIN_U)) S X=4 G ERR + S DATA(.4)=$P(DENT0,U,2),X1=+$E(DATA(.4)) + I 12'[X1,"AF"[DATA(.6) S X=5 G ERR + I $S(DATA(.3)="":1,1:'$O(^DENT(225,"B",DATA(.3),0))) S X=6 G ERR + ; + ; check if site has any required identifiers on 226, if so use during UPDATE + ; + F I=.3,.4,.6,.9 I $D(^DD(226,0,"ID",I)) S ARR(226,"+1,",I)=DATA(I) K DATA(I) + L +^DENT(226,0):2 E S X=7 G ERR + S X=$$NOW^XLFDT F Q:'$D(^DENT(226,"B",X)) S X=$$FMADD^XLFDT(X,,,,1) + S IEN(1)=9999999-X,ARR(226,"+1,",.01)=X + D UPDATE^DIE(,"ARR","IEN","ERR") L -^DENT(226,0) + I $D(DIERR) S X=8 G ERR + K ARR S IEN=IEN(1)_"," + F I=.3,.4,.6,.9 I $D(DATA(I)) S ARR(226,IEN,I)=DATA(I) + I $D(ARR) L +^DENT(226,+IEN):5 I D FILE^DIE(,"ARR","ERR") L -^DENT(226,+IEN) + S RET="1^Record successfully added" + Q + ; +KEY() Q $D(^XUSEC("DENTV DELETE ENTRY",DUZ)) + ; +TIU(RET,IEN,NOTE) ; RPC to file TIU note pointer to file 228.1 + ; IEN - required - pointer to file 228.1 + ; NOTE - required - pointer to file 8925 (tiu document) + ; RET - return value = 1 if successful, else return -1^error message + ; + N X,X0,Y,Z,DENT,DIERR,ERR + S IEN=+$G(IEN),NOTE=+$G(NOTE)_"," + I NOTE D GETS^DIQ(8925,NOTE,".02;.03","I","DENT","ERR") + I $D(DIERR)!'NOTE S X=11 G ERR + S X0=$G(^DENT(228.1,IEN,0)) I X0=""!'IEN S X=9 G ERR + I DENT(8925,NOTE,.02,"I")'=$P(X0,U,2) S X=12 G ERR + I $P(X0,U,3),DENT(8925,NOTE,.03,"I")'=$P(X0,U,3) S X=13 G ERR + K DENT S DENT(228.1,IEN_",",7)=+NOTE + L +^DENT(228.1,IEN) D FILE^DIE(,"DENT","ERR") L -^DENT(228.1,IEN) + I $D(DIERR) S X=14 G ERR + S RET=1 + Q + ; +ERR ; error meesages from this routine - expects X=1,2,3,4,5,6.... + ; ERRFLG - optional - I $G(ERRFLG) then set RET(1), else set RET + I X=1 S X="Provider not found in Dental Provider file (225)" + I X=2 S X="Provider not marked as active in Dental Provider file (225)" + I X=3 S X="Non clinical time category (R,A,E,F) is not correct" + I X=4 S X="Non clinical time (hr.min) is incorrect" + I X=5 S X="Only dentists may enter non clin time spent in admin or fee categories" + I X=6 S X="Invalid station.division name" + I X=7 S X="Unable to lock file 226 - try again later" + I X=8 S X="Unable to create a new record for administative time" + I X=9 S X="Invalid Dental History record number received" + I X=10 S X="Dental History record not deleted - problems encountered" + I X=11 S X="Invalid TIU record number received" + I X=12 S X="The patient for the dental history record does not match the patient associated with the TIU note" + I X=13 S X="The VISIT associated with the dental history record and TIU note do not match" + I X=14 S X="Error encountered while filing note to history file" + I X=15 S X="No Dental PACKAGE file entry found to use in PCE" + I X=16 S X="No VISIT record number received" + I X=17 S X="No Dental History records found with VISIT="_VISIT + I X=18 S X="You are not authorized to delete record# "_IEN + I $G(ERRFLG) S RET(1)="-1^"_X + E S RET="-1^"_X + Q diff -auBN ./r1/DENTVRP5.m ./r2/r/DENTVRP5.m --- ./r1/DENTVRP5.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP5.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,223 @@ +DENTVRP5 ;DSS/SGM - FILE DATA FOR DENTAL DSS ;12/18/2001 10:02 + ;;1.2;DENTAL;**30,34**;Aug 10, 2001 + ;This routine is the main program caled from rpc to file data to VistA + Q +UPD(RET,DATA) ; rpc call to file pce, file 19600.1, and DAS (221) + ; see bottom of routine for documentation + N A,B,C,I,J,K,X,Y,Z,DAS,DENTPCE,DFN,ERR,FILE,LOC,MSG,ND,PCE + N PROV,SDAT,TH,VST,ZMSG + S ND="",FILE=" " D SDAT + I '$D(SDAT) S RET(1)="-1^No data passed to the rpc" Q + S (X,DFN)=SDAT(1,1) + I +X'=X,X'="GROUP" S RET(1)="-1^Invalid patient sent" Q + I +X=X S X=$$DFN^DENTVUTL(DFN) I X<0 S RET(1)=X Q + ; convert das disposition to internal format + S X=SDAT(4,3) I X]"" D S SDAT(4,3)=X + .I X?.E1N.E S X=$S(X'?1N:0,123'[X:0,1:X) Q + .I X?.E1U.E S X=$S(X'?1U:0,1:$F("ICT",X)-1) Q + .S X=0 Q + S LOC=$$LOC^DENTVUTL(SDAT(1,5)) + I LOC="",$E(FILE,3) S RET(1)="-1^Invalid Hospital Location" Q + S PROV=+$G(SDAT(1,6)) S:'PROV PROV=DUZ ; primary pce provider + ; flagged to send data to PCE, if true errors found + I $$PCE M RET=ZMSG Q + ; now actually file data to various systems + F X=0,1,2 S DAS(X)=0 + I +$E(FILE) S DAS(0)=$$EN^DENTVRP6(.ZMSG) + I +$E(FILE,2) D + .I DAS(0)<0 S DAS(1)="-1^"_$P($T(11),";",3) Q + .S DAS(1)=$$EN^DENTVRP7(.ZMSG) Q:DAS(1)>0 + .D DEL(0,221) + .S DAS(0)="-1^"_$P($T(12),";",3) + .Q + I +$E(FILE,3),$D(DENTPCE) D + .I DAS(0)<0!(DAS(1)<0) S DAS(2)="-1^"_$P($T(13),";",3) Q + .S DAS(2)=$$FTOPCE(.ZMSG) Q:DAS(2)'<0 + .I DAS(0)>0 D DEL(0,221) S DAS(0)="-1^"_$P($T(14),";",3) + .I DAS(1)>0 D DEL(1,228.1) S DAS(1)="-1^"_$P($T(15),";",3) + .Q + S Y=0 F X=0,1,2 I +DAS(X) S Y=Y+1,RET(Y)=DAS(X) + I $D(ZMSG) F X=1:1 Q:'$D(ZMSG(X)) S Y=Y+1,RET(Y)=ZMSG(X) + Q + ; + ; =========== subroutine modules to do small parts ============= +DEL(SUB,DIK) ; delete entry + N X,Y,DA S DA=+DAS(SUB),DIK=$G(^DIC(DIK,0,"GL")) D:DIK]"" ^DIK + Q + ; +ZMSG(T) N A S A=$O(ZMSG("A"),-1)+1,ZMSG(A)=T Q + ; +SDAT N L,N,P,T,X,Y K SDAT S N="",T=0 + F S N=$O(DATA(N)) Q:N="" S T=T+1,Y=DATA(N) D + .S L=$S(T=1:7,T=3:6,T=4:4,T>4:12,1:$L(Y,U)) + .F P=1:1:L S SDAT(T,P)=$P(Y,U,P) + .Q:T<5 S X=SDAT(T,1) S:X="" (X,SDAT(T,1))=111 + .F L=1:1:3 S:+$E(X,L) $E(FILE,L)=1 + .Q + Q + ; +PKG() ; check for valid dental package pointer for use with PCE + N DIERR,ERR Q +$$FIND1^DIC(9.4,,"MOQ","DENT","B^C",,"ERR") + ; +APT() ; get encounter date/time + N B S B=$P($G(^AUPNVSIT(+SDAT(1,2),0)),U) + S B=$S(B:B,SDAT(1,3):SDAT(1,3),SDAT(1,4):SDAT(1,4),1:-1) + Q B + ; +FTOPCE(MSG) ; file to PCE + ; if pce errors messages exists, put into MSG + N I,J,X,Y,Z,PKG,SOURCE,VISIT + S PKG=$$PKG + I 'PKG Q "-1^No Dental package file entry found" + S SOURCE="DENTV DSS GUI" + S:SDAT(1,2) VISIT=SDAT(1,2) + S Y=$$DATA2PCE^PXAPI("DENTPCE",PKG,SOURCE,.VISIT,PROV) + I $D(DENTPCE("DIERR")) D + .S Z=$O(ZMSG("A"),-1) + .F I=0:0 S I=$O(DENTPCE("DIERR",I)) Q:'I S J=0 D + ..F S J=$O(DENTPCE("DIERR",I,"TEXT",J)) Q:'J D + ...S X=DENTPCE("DIERR",I,"TEXT",J) + ...Q:$E(X,1,4)="TO: " Q:X?." " + ...I X?1"Calling Package".E S J="A" Q + ...S Z=Z+1,ZMSG(Z)="-1^"_X + ...Q + ..S Z=Z+1,ZMSG(Z)="-1^" + ..Q + .Q + I Y=1 D:+DAS(1) S Y="1^PCE data successfully filed"_U_VISIT + .N X,Y,DIERR,ERR,FDA,IEN + .S IEN=+DAS(1)_",",FDA(228.1,IEN,5)=VISIT + .L +^DENT(228.1,+IEN) D FILE^DIE(,"FDA","ERR") L -^DENT(228.1,+IEN) + .I $D(DIERR) D MSG^DENTVUTL(.ZMSG,.ERR) + .Q + I Y=-1 S Y="1^"_$P($T(8),";",3)_U_VISIT + I Y<-1 S Y="-1^"_$P($T(@(7-Y)),";",3) + Q Y + ; +PCE() ; parse sdat(n,m) for icd9/cpt codes and setup pce array + ; this module will convert all icd9/cpt names to pointers or null + ; returns 0 if all okay, else returns 1 indicates data problems + N I,J,M,N,X,Y,Z,APT,CPT,ERR,FLG,ICD,PCE,PRIM,SUB + S ERR=0,APT=$$APT + I APT<1 S ERR=1 D ZMSG("-1^No encounter/appointment date/time") + I $S(DFN="GROUP":1,1:'$E(FILE,3)) + E S DENTPCE("ENCOUNTER",1,"ENC D/T")=APT + E S DENTPCE("ENCOUNTER",1,"PATIENT")=DFN + E S DENTPCE("ENCOUNTER",1,"HOS LOC")=LOC + E S DENTPCE("ENCOUNTER",1,"CHECKOUT D/T")=$E($$NOW^XLFDT,1,12) + E S DENTPCE("ENCOUNTER",1,"SERVICE CATEGORY")="A" + E S DENTPCE("ENCOUNTER",1,"ENCOUNTER TYPE")="P" + E S DENTPCE("PROVIDER",1,"NAME")=PROV + E S DENTPCE("PROVIDER",1,"PRIMARY")=1 + E F I=1:1:6 D:10[SDAT(3,I) + .S DENTPCE("ENCOUNTER",1,$P("AO^EC^IR^SC^MST^HNC",U,I))=SDAT(3,I) + .Q + E F I=1:1 Q:'$G(SDAT(2,I)) S DENTPCE("PROVIDER",I+1,"NAME")=SDAT(2,I) + S X=$G(SDAT(1,7)),X=$$ICD^DENTVUTL(X) + I +X<1 S ERR=1 D ZMSG("-1^Invalid Primary PCE Diagnosis Code received") + S (PRIM,SDAT(1,7))=+X,PRIM(0)=$P(X,"~",2) S:PRIM<1 PRIM=0 + ; parse the cpt data strings + F N=5:1 Q:'$D(SDAT(N)) S FLG=$P(SDAT(N,1),U),X=$G(SDAT(N,2)) D + .K CPT I X]"" D CPT^DENTVUTL(.CPT,X) + .S CPT(0)=$P(X,U,2),CPT=$P(CPT,U,3),SDAT(N,2)=CPT + .S X="-1^Tooth# "_$G(SDAT(N,3))_" received with no cpt code" + .I +$E(FLG,1,2),CPT="" D ZMSG(X) S ERR=1 + .S X=$G(SDAT(N,6)) I X]"" D QUAD^DENTVDD S:$D(X) SDAT(N,6,0)=$L(X,",") + .S FLG=+$E(FLG,3),SUB="PROCEDURE" I FLG,CPT D + ..I '$D(DENTPCE(SUB,CPT,SUB)) S DENTPCE(SUB,CPT,SUB)=CPT + ..S DENTPCE(SUB,CPT,"QTY")=$G(SDAT(N,6,0),1)+$G(DENTPCE(SUB,CPT,"QTY")) + ..S:'$D(DENTPCE(SUB,CPT,"ENC PROVIDER")) DENTPCE(SUB,CPT,"ENC PROVIDER")=PROV + ..Q + .S SUB="DX/PL" F M=8:1:12 S X=$G(SDAT(N,M)) I X]"" D + ..S X=$$ICD^DENTVUTL(X),ICD=+X,X=$P(X,"~",2),SDAT(N,M)=ICD + ..I ICD<1 D Q + ...S ERR=1 D ZMSG("-1^Invalid ICD9 code received for tooth#"_SDAT(N,3)) + ...Q + ..I 'FLG!$D(DENTPCE(SUB,ICD)) Q + ..S DENTPCE(SUB,ICD,"DIAGNOSIS")=ICD + ..S DENTPCE(SUB,ICD,"ENC PROVIDER")=PROV + ..S DENTPCE(SUB,ICD,"PRIMARY")=ICD=PRIM + ..S:X]"" DENTPCE(SUB,ICD,"NARRATIVE")=X + ..Q + .Q + S SUB="DX/PL" I $D(DENTPCE),PRIM,'$D(DENTPCE(SUB,PRIM)) D + .S DENTPCE(SUB,PRIM,"DIAGNOSIS")=PRIM + .S DENTPCE(SUB,PRIM,"ENC PROVIDER")=PROV + .S DENTPCE(SUB,PRIM,"PRIMARY")=1 + .S:PRIM(0)]"" DENTPCE(SUB,PRIM,"NARRATIVE")=PRIM(0) + .Q + D:+$E(FILE,3) + .I 'PRIM D + ..S ERR=1 D ZMSG("-1^No primary diagnosis received for filing to PCE") + ..Q + .I '$D(DENTPCE("PROCEDURE")) D + ..S ERR=1 D ZMSG("-1^No procedures received for filing to PCE") + ..Q + .I '$D(DENTPCE("DX/PL")) D + ..S ERR=1 D ZMSG("-1^No diagnoses received for filing to PCE") + ..Q + .Q +PCEOUT Q ERR + ; +8 ;;PCE data filed, but was not completed due to exceptions encountered +9 ;;No PCE data processed - unable to identify a valid visit +10 ;;No PCE data processed - data2pce api incorrectly called +11 ;;New dental history was not filed due to errors filing DAS data +12 ;;DAS data was acceptable, but was not filed since a new dental history record was not created +13 ;;No data was filed to PCE since errors occurred when filing dental data +14 ;;DAS data was acceptable, but was not filed since filing to PCE failed +15 ;;The Dental History data was acceptable, but was not filed since filing to PCE failed + ; + ; documentation of variables for UPD entry point + ; data(1) = p1^p2^p3^p4^p5^p6^p7 where + ; p1=dfn p2=visit file ien p3=appt date.time + ; p4=new appt date.time p5=location (file 44 ien) + ; p6=primary provider p7=primary icd9 for pce + ; + ; data(2) = secondary provider^sec prov^sec prov^ .... + ; data(3) = p1^p2^p3^p4^p5^p6 [ "AO^EC^IR^SC^MST^HNC" ] + ; data(4)= DAS category ^ bedsection ^ disposition ^ station.division + ; + ;NOTES: Must have a location in order to create a new visit by passing a + ;new appointment date.time If filing data to PCE, then location and + ;primary ICD9 are mandatory + ; + ; data(n) = p1^p2^p3^p4^...^p12 where n=5,6,7,8,9.... and where + ; p1 = optional - flag for filing data + ; p2 = cptcode (.01 field value from file 81) + ; p3 = tooth# (0-32) + ; p4 = surfaces + ; p5 = canals + ; p6 = quadrants + ; p7 = primary (Y) + ; p8 = icd9 code (primary diag code for this procedure and tooth) + ; p9,p10,p11,p12 - optional secondary icd9 codes + ; + ;NOTES: p1 is optional - format mmm where m is either 0 or 1 + ; null or 111 - file data to old DAS, new dental history, and to PCE + ; 000 - don't file data - should never be + ; 100 - file to old DAS only + ; 010 - file to new dental history only + ; 001 - file to PCE only + ; 110 - file to old DAS and new dental history + ; 101 - file to old DAS and PCE + ; 011 - file to new dental history and PCE + ; + ; p4,p5,p6,p8-p11 - all optional - send data only if relevant + ; p5 - qty may be eliminated pending outcome of current messages + ; + ; definitions of local variables + ; DENTPCE array as defined in data2pce^pxapi documentation + ; sdat(n,m) where n=1,2,3,4... and m=1,2,3,...,$L(DATA(Z),U) + ; This parses the data array from the gui into individual array + ; elements where n=the array number from the gui and + ; m=the "^" for each data(z) + ; + ; return array values + ; ret(x) = y ^ message where + ; x = sequential numbers 1,2,3,... + ; y = negative number for error condition + ; positive number + ; for das, dental history: ien ^ message + ; for PCE: 1 ^ PCE ^ visit ien + ; zmsg(x) = contains cumulative error messages from dentvrp6, dentvrp7 diff -auBN ./r1/DENTVRP6.m ./r2/r/DENTVRP6.m --- ./r1/DENTVRP6.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP6.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,124 @@ +DENTVRP6 ;DSS/SGM - CREATE A NEW RECORD IN FILE 221 ;01/18/2002 15:36 + ;;1.2;DENTAL;**30,34**;Aug 10, 2001 + ; This routine is called by DENTVRP5 to create a new record in file 221 + ; It expects the local variables as defined in dentvrp6 + Q +EN(ZERR) ; create a new DAS entry + ; Return -1^error message, or das record number^message + ; ZERR - passed by reference, return error messages + N I,J,K,L,X,Y,Z,ERR,FDA,IENS,NAME,SSN,SUB,YFDA,ZFDA,ZIEN + F SUB=5:1 Q:'$D(SDAT(SUB)) I +$E(SDAT(SUB,1)) D + .N CPT,ADA,VAL,FLD + .S CPT=+$G(SDAT(SUB,2)),ADA=$$ADA^DENTVUTL(CPT) Q:ADA="" + .S FLD=$P(ADA,U,4),VAL=$P(ADA,U,5) Q:FLD=""!(VAL="") + .D DD(.FLD) Q:$D(FLD)<11 + .; zfda(field# for 221)=value + .I FLD("S") S ZFDA(FLD)=VAL Q + .S Y=$G(SDAT(SUB,6,0),1) + .S ZFDA(FLD)=VAL*Y+$G(ZFDA(FLD)) Q:'$D(FLD("I")) + .; yfda(field# for 221,cpt)=total number + .S YFDA(FLD,CPT)=Y+$G(YFDA(FLD,CPT)) + .S:$G(YFDA(FLD))="" YFDA(FLD)=FLD("L")_U_FLD("I") + .Q + F Z=0:0 S Z=$O(YFDA(Z)) Q:'Z S X=ZFDA(Z) X $P(YFDA(Z),U,2,99) D:'$D(X) + .S X="Too many cpt codes selected for filing data to "_$P(YFDA(Z),U) + .S X=X_" field in the DAS file - cpts selected: " S Y=0 + .F S Y=$O(YFDA(Z,Y)) Q:'Y S X=X_$P($G(^ICPT(Y,0)),U)_";" + .D ERR(X) + .Q + ; station.division + I $G(SDAT(4,4))]"",$O(^DENT(225,"B",SDAT(4,4),0)) S ZFDA(.3)=SDAT(4,4) + E D FLD(.3) + I 'PROV D FLD(.5) + I PROV D + .S X=$O(^DENT(220.5,"B",PROV,0)) I 'X D FLD(.5) Q + .S Y=^DENT(220.5,X,0) + .I $P(Y,U,3) S X=$P($G(^VA(200,PROV,0)),U)_" is inactive" D ERR(X) Q + .S ZFDA(.4)=$P(Y,U,2),ZFDA(.5)=X + .Q + I DFN="GROUP" S ZFDA(1)="000000001",ZFDA(2)=DFN + E S NAME=$P($G(^DPT(DFN,0)),U),SSN=$P($G(^(0)),U,9) D + .I NAME=""!(SSN="") D FLD(1):SSN="",FLD(2):NAME="" Q + .S ZFDA(1)=SSN,ZFDA(2)=NAME,ZFDA(3)=DFN + .S X=$$DENTADD^DENTVUTL(DFN) + .I X<1 D ERR($P(X,U,2)) + .Q + ; dental category + I $G(SDAT(4,1)),$D(^DIC(220.2,SDAT(4,1))) S ZFDA(4.5)=SDAT(4,1) + E D FLD(4.5) + ; dental bedsection + I $G(SDAT(4,2)),$D(^DIC(220.4,SDAT(4,2))) S ZFDA(5)=SDAT(4,2) + ; dental disposition + S X=$G(SDAT(4,3)) I X>1 S ZFDA(7.1)=X + I '$D(ZFDA) D ERR("DAS data not filed, please correct") G OUT + S Z=$G(ZFDA(4.5)) I Z<8,Z'=4,Z'=5,'$G(ZFDA(5)) D ERR(1) + I $G(ZFDA(5)),Z>8!(Z=4)!(Z=5) D ERR(2) + I $G(ZFDA(6.6))!$G(ZFDA(6.7)),Z<9!(Z>17) D ERR(3) + I "^7^8^21^22^"[(U_Z_U) D + .I $G(ZFDA(6))="S" D ERR(4) Q + .F X=6,6.2,6.4,14,15,16,17 I $G(ZFDA(X)) D ERR(4) Q + .Q + I $G(ZFDA(6.4)),$G(ZFDA(6))]"" D ERR(5) + I $G(ZFDA(25))]"",$G(ZFDA(11))]""!($G(ZFDA(12))]"") D ERR(6) + ;I $G(ZFDA(23))]"",$G(ZFDA(24))]"" D ERR(7) ; not a -1 message + I $G(ZFDA(30))="",$G(ZFDA(29))]"" D ERR(8) + I $G(ZFDA(30))]"",$G(ZFDA(29))="" D ERR(9) + I $G(ZFDA(38)),$E($G(ZFDA(.4)))'<3 D ERR(10) + ; okay let's create old das record in file 221 + I '$D(ZERR) S SUB=$$NEW D:SUB FILE + I '$D(ZERR) S X=SUB_"^DAS record#"_SUB_" created" +OUT I $D(ZERR) S X="-1^DAS record not record" + Q X + ; +DD(ASLF) ; ASLF = field# to file 221 - return dd elements + ; ASLF passed by ref + ; returns ASLF("L")=field label ASLF("S")=1 if field a set of codes + ; ASLF("R")=1 if field is required + ; optional ASLF("I")=input transform (if there is one) + Q:'$D(^DD(221,+$G(ASLF),0)) N X,Y,Z,ASL,DIERR,ERR + S Z="LABEL;SPECIFIER;INPUT TRANSFORM" + D FIELD^DID(221,ASLF,,Z,"ASL","ERR") Q:$D(DIERR) + S ASLF("L")=ASL("LABEL") + S ASLF("S")=ASL("SPECIFIER")["S" + S ASLF("R")=ASL("SPECIFIER")["R" + S Y=$P(ASL("INPUT TRANSFORM")," I $D(X)") I Y]"",Y'="Q" S ASLF("I")=Y + Q + ; +ERR(X) ; error processor + I $G(X)=+$G(X) S X=$P($T(MSG+X),";",3) + N A S A=1+$O(ZERR("A"),-1) S:$D(X) ZERR(A)="-1^"_X + I $D(ERR) D MSG^DENTVUTL(.ZERR,.ERR) + Q + ; +FILE ; file data elements to dent(221,flg) + N X,Y,Z,DIERR,DA,DD,DIERR,DIK,DINUM,DO,ERR,FDA,IENS + S IENS=SUB_"," M FDA(221,IENS)=ZFDA + L +^DENT(221,SUB) D FILE^DIE(,"FDA","ERR") L -^DENT(221,SUB) + I $D(DIERR) D ERR(12),ERR() S DA=SUB,DIK="^DENT(221," D ^DIK + Q + ; +FLD(F) S X=$P($G(^DD(221,F,0)),U)_" entry is required for DAS" D ERR(X) + Q + ; +NEW() ; create new DAS stub record, return ien or 0 if failed + N X,Y,Z,DIERR,ERR,FDA,IENS,ZIEN S IENS="+1," + L +^DENT(221,0):2 E D ERR(11) Q 0 + F S X=$$NOW^XLFDT Q:'$D(^DENT(221,"B1",X)) + S ZIEN(1)=9999999-X,FDA(221,IENS,.01)=X + D UPDATE^DIE(,"FDA","ZIEN","ERR") L -^DENT(221,0) + I $D(DIERR) D ERR(12),ERR() S ZIEN(1)=0 + Q ZIEN(1) + ; +MSG ; error messages + ;;Bed section is missing + ;;Bed section must be blank if patient category is OPT, NHC, or DOM + ;;Patient category must be Class I-VI for spot check/pre-auth exam + ;;Patient category and type of service code are incompatible + ;;You cannot mark both the screening/complete and evaluation fields + ;;Patient education must be blank if prophy is marked + ;;WARNING - both perio and quad fields have been marked, please verify + ;;Fixed partials - you selected abutment procedures with no pontics + ;;Fixed partials - you selected pontic procedures with no abutments + ;;Operating room can only be marked if the provider is a staff dentist + ;;Unable to lock file 221, try again + ;;Unable to create a DAS record diff -auBN ./r1/DENTVRP7.m ./r2/r/DENTVRP7.m --- ./r1/DENTVRP7.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP7.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,111 @@ +DENTVRP7 ;DSS/SGM - CREATE A NEW RECORD IN FILE 228.1 ;08/03/2001 15:55 + ;;1.2;DENTAL;**30**;Aug 10, 2001 + ; called from DENTVRP5 + Q +EN(ZERR) ; called from DENTVRP5 - see that rtn for variable description + ; returns -1 errors, else return ien^message + ; ZERR - passed by reference, array for error messages + N I,J,K,X,Y,Z,ARR,CODE,DAT,DEL,DIERR,ERR,FDA,FLD,FLG,IENS,SUB,ZIEN + L +^DENT(228.1,0):2 E D G OUT + .D ERR("Unable to lock file 228.1, try again in a few minutes") + .Q + S X=1+$O(^DENT(228.1,"A"),-1),IENS="+1," + S ZIEN(1)=X,FDA(228.1,IENS,.01)=X + D UPDATE^DIE(,"FDA","ZIEN","ERR") L -^DENT(228.1,0) + I $D(DIERR) D ERR() G OUT + ; new stub record created + S X=ZIEN(1) K IENS,FDA,ZIEN,DIERR,ERR S IENS=X_"," + ; set up fda(228.1,iens,fld#) array + F I=1:1 S Z=$P($T(DATA+I),";",4,6) Q:Z="" D + .S ARR=$P(Z,";"),FLD=$P(Z,";",2),CODE=$P(Z,";",3) + .S DAT=$G(@ARR) I 1 X:CODE]"" CODE I S FDA(228.1,IENS,FLD)=DAT + .Q + ; encounter date.time + ;S Z=$G(SDAT(1,3)) S:Z="" Z=$G(SDAT(1,4)) S:Z FDA(228.1,IENS,5.1)=Z + L +^DENT(228.1,+IENS) D FILE^DIE(,"FDA","ERR") L -^DENT(228.1,+IENS) + I $D(DIERR) D ERR() G OUT + S ZIEN=IENS K FDA,ERR,DIERR,IENS + ; now get teeth data + F SUB=5:1 Q:'$D(SDAT(SUB)) I +$E(SDAT(SUB,1),2) D + .N ADA,DAT,DIERR,ERR,FDA,IENS,TH,ZCPT + .S (X,TH)=$G(SDAT(SUB,3)),IENS="+1,"_ZIEN,ZCPT=+$G(SDAT(SUB,2)) + .I X'?1.2N!(X<0)!(X>32) D Q + ..D ERR("Tooth# "_TH_" received - only numbers from 0-32 allowed") + ..Q + .S ADA=$$ADA^DENTVUTL(ZCPT) + .I TH,ADA]"",$P(ADA,U,10)'="y" D Q + ..S K="Tooth# "_TH_"/cpt "_$P($G(^ICPT(ZCPT,0)),U)_" received, " + ..S K=K_"yet this ADA code is not tooth related" D ERR(K) + ..Q + .S FDA(228.11,IENS,.01)=TH D UPDATE^DIE(,"FDA","DAT","ERR") + .I $D(DIERR) D Q + ..S K="Tooth# "_TH_"/cpt "_$P($G(^ICPT(ZCPT,0)),U)_" received, " + ..S K=K_"but was unable to add it to the New History file" + ..D ERR(K) + ..Q + .K FDA S IENS=DAT(1)_","_ZIEN + .F I=1:1 S Z=$P($T(MULT+I),";",4,6) Q:Z="" D + ..S ARR=$P(Z,";"),FLD=$P(Z,";",2),CODE=$P(Z,";",3) + ..S DAT=$G(@ARR) I 1 X:CODE]"" CODE Q:'$T + ..I I<9,134[I,'$$QA(I) D Q + ...S K="Tooth# "_TH_"/cpt "_$P($G(^ICPT(ZCPT,0)),U)_" received, but the" + ...S K=K_$S(I=1:"surfaces",I=3:"quadrants",1:"canals") + ...S K=K_" qualifier was not accepted" D ERR(K) + ...Q + ..S FDA(228.11,IENS,FLD)=DAT + ..Q + .I $D(FDA) D FILE^DIE(,"FDA","ERR"),ERR():$D(DIERR) + .Q + I $D(ZERR) N DA,DIK,X,Y S DA=+ZIEN,DIK="^DENT(228.1," D ^DIK + L -^DENT(228.1,+ZIEN) + I '$D(ZERR) S X=+ZIEN_"^New dental history record# "_(+ZIEN)_" created" +OUT I $D(ZERR) S X="-1^New Dental History record not created" + Q X + ; +ERR(X) ; report errors + I $D(X) N A S A=1+$O(ZERR("A"),-1),ZERR(A)="-1^"_X + I $D(ERR) D MSG^DENTVUTL(.ZERR,.ERR) + Q + ; +QA(W) ; do QA on data elements for teeth + I W=1 D + .S X=DAT D SURF^DENTVDD(228.1) S W=$D(X) S:W DAT=X + .S:'$P(ADA,U,9) W=0 Q:'W + .; check if # surf codes matches the ada table entry for this cpy code + .I $P(ADA,U,9)'["+",$L(DAT)'=+$P(ADA,U,9) S W=0 + .I $P(ADA,U,9)["+",$L(DAT)<+$P(ADA,U,9)!($L(DAT)>6) S W=0 + .Q + I W=3 D + .S X=DAT D QUAD^DENTVDD S W=$D(X) S:W DAT=X + .I W,ADA]"",$P(ADA,U,8)'="y" S W=0 + .Q + I W=4 S X=$P(ADA,U,11) S:'DAT DAT=X S:DAT>9 W=0 ; max # canals + Q W + ; +DATA ;;descript;variable name;field#;execute M code to set $T - input trans + ;;;SDAT(1,1);2;I +DAT,$D(^DPT(+DAT)) + ;;;DT;3 + ;;;DUZ;4 + ;;;PROV;4.1 + ;;;LOC;11;I +DAT + ;;visit ien;SDAT(1,2);5;I +DAT + ;;das pat cat;SDAT(4,1);21;I DAT,$D(^DIC(220.2,DAT)) + ;;das bed section;SDAT(4,2);22;I DAT,$D(^DIC(220.4,DAT)) + ;;das disposition;SDAT(4,3);24;I DAT>0 + ;;das sta/div;SDAT(4,4);23;I DAT]"" S DAT=+$O(^DENT(225,"B",DAT,0)) I DAT + ;;das ptr(#221);DAS(0);6;S DAT=+DAT I DAT,$D(^DENT(221,DAT)) + ; +MULT ; same format as DATA but this is for tooth multiple + ;;surfaces;SDAT(SUB,4);2;I DAT]"" + ;;cpt;SDAT(SUB,2);3;I +DAT + ;;quadrant;SDAT(SUB,6);4;I DAT]"" + ;;canals;SDAT(SUB,5);5;I +DAT + ;;primary;SDAT(SUB,7);6;I DAT]"","1Yy"[DAT S DAT="y" + ;;icd9-1;SDAT(SUB,8);7;I +DAT + ;;icd9-2;SDAT(SUB,9);8;I +DAT + ;;icd9-3;SDAT(SUB,10);9;I +DAT + ;;icd9-4;SDAT(SUB,11);10;I +DAT + ;;icd9-5;SDAT(SUB,12);11;I +DAT + ;;file to das;SDAT(SUB,1);12;I +$E(DAT) S DAT="y" + ;;file to pce;SDAT(SUB,1);13;I +$E(DAT,3) S DAT="y" + ;;ctv;FDA(228.11,IENS,3);14;I +DAT,$O(^DENT(228,"B",DAT,0)) S X=+$P($G(^DENT(228,+$O(^(0)),0)),U,3) I X S DAT=X diff -auBN ./r1/DENTVRP8.m ./r2/r/DENTVRP8.m --- ./r1/DENTVRP8.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP8.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,201 @@ +DENTVRP8 ;DSS/SGM - VARIOUS RPC CALLS FOR DSS DENTAL ;12/18/2001 10:02 + ;;1.2;DENTAL;**30,32,34**;Aug 10, 2001 + Q +ENC(RET,IEN) ; rpc call to return dental encounter data for record# ien + N X,Y,Z,ARR,DIERR,ERR,IENS,TMP,VST + S X="-1^Invalid dental history record number received" + I '$D(^DENT(228.1,+$G(IEN),0)) S RET=X Q + S IENS=IEN_"," + D GETS^DIQ(228.1,IENS,"3:24","IE","ARR","ERR") + I '$D(ARR) S RET="-1^Error encounted when trying to retrieve data" Q + M TMP=ARR(228.1,IENS) K ARR S RET(2)="" + S RET(1)=$G(TMP(3,"E"))_U_$G(TMP(4,"E"))_U_$G(TMP(4.1,"E")) + S $P(RET(1),U,5)=$G(TMP(11,"E")) + D VST(.VST,$G(TMP(5,"I"))) S VST=VST(1) + S $P(RET(1),U,4)=$P(VST,U,2) ; ext visit date + S $P(RET(1),U,6)=$P(VST,U,3) ; icd9 desc + S $P(RET(1),U,7)=$P(VST,U,4) ; icd9 code + S $P(RET(1),U,8)=$P(VST,U,5) ; duz + S $P(RET(1),U,9)=$P(VST,U,6) ; prim enc name + S $P(RET(1),U,10,15)=$P(VST,U,7,12) ; service conditions + F X=6,21,22,23,24 S RET(2)=RET(2)_$G(TMP(X,"E"))_U + Q + ; +TH(TH,DATA) ; return tooth history - DATA = dfn ^ tooth# ^ fmdate + ; see end of routine for format of TH(n) + N A,B,I,J,K,X,Y,Z,CNT,DFN,DAT,INV,ROOT,TOOTH + S CNT=0,TH=$NA(^TMP("DENT",$J)) K @TH,^TMP("DEN",$J) + F I=1:1:3 S @$P("DFN^TOOTH^DAT",U,I)=$P(DATA,U,I) + S X=$$DFN^DENTVUTL(DFN) I X]"" S @TH@(1)="-1^"_X Q + I '$D(^DENT(228.1,"C",DFN)) S @TH@(1)="-1^Patient has no dental history on file" Q + S:'DAT DAT=1 S DAT=DAT-.000001 + I TOOTH?.E1L.E S TOOTH=$$UP^XLFSTR(TOOTH) + S ROOT=$NA(^DENT(228.1,"AE",DFN,DAT)) + F S ROOT=$Q(@ROOT) Q:$QS(ROOT,2)'="AE" Q:$QS(ROOT,3)'=DFN D + .N A,IEN,INV,STUB S IEN=$QS(ROOT,5),STUB=$$GET1(IEN) + .Q:STUB="" S INV=+STUB,$P(STUB,U)="" + .I TOOTH'="ALL" D GET2(+TOOTH,IEN) + .I TOOTH="ALL" F A=0:1:32 D GET2(A,IEN) + .Q + S X=$NA(^TMP("DEN",$J)),Y=0 + F S X=$Q(@X) Q:$QS(X,1)'="DEN" Q:$QS(X,2)'=$J S Y=Y+1,@TH@(Y)=@X + I '$D(@TH) S @TH@(1)="-1^No dental history found" + K ^TMP("DEN",$J) + Q + ; +GET1(IENS) ; get data from dental encounter record (no tooth data) + N X,Y,ARR,ERR,DIERR,RET,VST S IENS=IENS_"," + D GETS^DIQ(228.1,IENS,"3;4.1;5;","IE","ARR","ERR") + I '$D(ARR) Q "" + S VST=+$G(^AUPNVSIT(+$G(ARR(228.1,IENS,5,"I")),0)) + S RET=-$S(VST:VST,1:$G(ARR(228.1,IENS,3,"I"))) + S $P(RET,U,2)=$G(ARR(228.1,IENS,3,"E")) ; record create date + S $P(RET,U,5)=$G(ARR(228.1,IENS,4.1,"E")) ; provider + S $P(RET,U,13)=$G(ARR(228.1,IENS,5,"E")) ; visit date.time + S $P(RET,U,12)=+IENS + I VST K ARR D PCE(.ARR,VST) I ARR'=-1 D + .S $P(RET,U,10)=$P(ARR,U) + .S $P(RET,U,11)=$P(ARR,U,2) + .S $P(RET,U,13)=$P(ARR,U,3) + .S $P(RET,U,14)=$P(ARR,U,4) + .Q + Q RET + ; +GET2(THN,IEN) ; get individual tooth data and set tmp global data + N I,F,X,Y,ARR,ASL,CPT,DIERR,ERR,FLD,IENS,SHORT,STR,TMP + S IEN=IEN_",",ASL=0 + F S ASL=$O(^DENT(228.1,+IEN,1,"B",THN,ASL)) Q:'ASL D + .K I,F,X,Y,ARR,CPT,DIERR,ERR,FLD,IENS,TMP + .S IENS=ASL_","_IEN N ASL,IEN + .D GETS^DIQ(228.11,IENS,".01:14","IE","ARR","ERR") + .Q:'$D(ARR) M TMP=ARR(228.11,IENS) + .S SHORT="",X=$G(TMP(3,"I")) + .I X D CPT^DENTVUTL(.STR,X,0,1) I +STR'=-1 S SHORT=$P(STR,U) + .F FLD=7:1:11 S X=$G(TMP(FLD,"I")) I X D + ..S TMP(FLD,"S")=$$GET1^DIQ(80,X_",",3,,,"ERR") + ..Q + .S Y=STUB + .S $P(Y,U)=$G(TMP(.01,"E")) + .S $P(Y,U,4)=$G(TMP(3,"E")) + .S $P(Y,U,6)=$G(TMP(2,"E")) + .S $P(Y,U,7)=$G(TMP(4,"E")) + .S $P(Y,U,8)=$G(TMP(5,"E")) + .S $P(Y,U,9)=$G(TMP(6,"E")) + .S $P(Y,U,14)=$G(TMP(14,"E")) + .S $P(Y,U,3)=SHORT + .S CNT=1+CNT,^TMP("DEN",$J,THN,INV,CNT)=Y,Y="$" + .F F=7:1:11 I $G(TMP(F,"I")) S Y=Y_U_TMP(F,"S")_U_TMP(F,"E") + .I Y'="$" S CNT=1+CNT,^TMP("DEN",$J,THN,INV,CNT)=Y + .Q + Q + ; +PCE(RET,IEN) ; rpc call to return pce primary diagnosis and provider + ; IEN - required - pointer to VISIT file + ; return p1^p2^p3^p4 or -1 if error, not found, etc. + ; p1 = pce primary diagnosis short description + ; p2 = pce primary diagnosis code + ; p3 = pce primary provider duz + ; p4 = pce primary provider name + N X,RETZ D VST(.RETZ,+$G(IEN)) + S X=$P(RETZ(1),U,3,6) S:X?."^" X="" S:X="" X=-1 + S RET=X + Q + ; +VST(RETN,IEN) ; get all related data for visit = ien + ; DBIA# 1894 + ; PRIM - optional + ; if +PRIM return RETN(1) = + ; else return + ; if failure return RETN(1) = "" + ; return RETN(1)=p1^p2^p3^...^p12 where + ; p1 = fm visit date.time + ; p2 = external visit date.time + ; p3 = primary PCE diagnosis short description + ; p4 = primary PCE diagnosis code + ; p5 = primary PCE provider duz + ; p6 = primary PCE provider name (1st m last) + ; p7 = service connected (y) + ; p8 = agent orange (y) + ; p9 = ionizing radiation (y) + ; p10 = Persian Gulf exposure (y) + ; p11 = military sexual trauma (y) + ; p12 = head & neck cancer (y) + ; RETN(n)=secondary provider duz^secondary provider name (1st m last) + ; where n=2,3,4,5,... for each secondary provider + N X,Y,Z,RTN,PROV,PROV2,XN K ^TMP("PXKENC",$J) + S RETN(1)="" + S IEN=$G(IEN) I 'IEN Q + D ENCEVENT^PXKENC(IEN,1) + I '$D(^TMP("PXKENC",$J,IEN)) Q + S Y=$P($G(^TMP("PXKENC",$J,IEN,"VST",IEN,0)),U) ; visit date.time + I Y S RTN=Y_U_$$FMTE^XLFDT(Y) + S Y=$TR($P($G(^TMP("PXKENC",$J,IEN,"VST",IEN,800)),U,1,6),1,"y") + S $P(RTN,U,7)=Y ; sc,ao,ir,ec,mst,hnc + F X=0:0 S X=$O(^TMP("PXKENC",$J,IEN,"POV",X)) Q:'X S Z=+^(X,0) D + .Q:$P(^(0),U,12)'="P" S Y=$$ICD^DENTVUTL(Z) + .I Y>0 S $P(RTN,U,3,4)=$TR($P(Y,"~",2,3),"~",U) + .Q + S X=0,Z="" + F S X=$O(^TMP("PXKENC",$J,IEN,"PRV",X)) Q:X="" S PROV=^(X,0) D + .S XN=$P($G(^VA(200,+PROV,0)),U) Q:XN="" + .S XN=+PROV_U_$$NAMEFMT^XLFNAME(XN,,"MD") + .I $P(PROV,U,4)="P" S $P(RTN,U,5,6)=XN ; primary pce provider + .E S PROV2(+XN)=XN + .Q + S:RTN?."^" RTN="" S RETN(1)=RTN I $O(PROV2(0)) S X=1,Y=0 D + .F S Y=$O(PROV2(Y)) Q:'Y S X=X+1,RETN(X)=PROV2(Y) + .Q + Q + ; + ; ============== documentation on rpc calls ======================= + ;TH(TH,DATA) + ; An global array will be passed back to the calling client. The format + ; of the returned array is: + ; ^TMP("DENT",$J,n) =p1^p2^p3^...^p13^p14 + ;continuation node ^TMP("DENT",$J,n+1)=$q1^q2^q3^q4^q5^q6^q7^q8^q9^q10 + ; where n = 1,2,3,4,.... + ; + ; p1 = tooth number (0-32) ; 0 indicates procedure not related to a + ; specific tooth + ; p2 = date of 228.1 record, human readable, in reverse chronological + ; order (newest record first) - use visit date if present, else + ; use date record created + ; p3 = cpt short description + ; p4 = cpt code + ; p5 = provider's name + ; p6 = surfaces + ; p7 = quadrant + ; p8 = # canals + ; p9 = primary (this will be null or equal to 'YES') + ; p10 = pce primary icd9 short description + ; p11 = pce primary icd9 diagnosis + ; p12 = record number (ien) in file 228.1 + ; p13 = visit/appointment date/time (may be null) + ; p14 = ctv value + ; + ; The diagnoses codes (1-5) associated with each tooth/cpt code will be + ; on the second continuation line + ; q1 = icd9-1 short description of the primary dental diagnosis + ; q2 = icd9-1 code of the primary dental diagnosis + ; If there are more than one diagnoses associated with a tooth/cpt + ; combination then q3^q4 / q5^q6 / q7^q8 / q9^q10 will follow q1^q2 + ; + ;ENC(RET,IEN) + ; RET(1) = p1^p2^p3^...^p15 RET(2) = q1^q2^q3^q4^q5 + ; p1 = date record created q1 = DAS record number (date) + ; p2 = creator q2 = DAS patient category + ; p3 = provider q3 = DAS bed section + ; p4 = encounter date/time q4 = DAS division + ; p5 = location q5 = DAS disposition + ; p6 = primary pce diagnosis short description + ; p7 = primary pce diagnosis code + ; p8 = duz of pce primary provider + ; p9 = name (1st m last) of pce primary provider + ; p10 = agent orange related (y) + ; p11 = environmental contamination related (y) + ; p12 = ionizing radiation (y) + ; p13 = service connected (y) + ; p14 = military sexual trauma (y) + ; p15 = head & neck cancer (y) + ; + ;PCE(RET,IEN) - see line tag for description diff -auBN ./r1/DENTVRP9.m ./r2/r/DENTVRP9.m --- ./r1/DENTVRP9.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVRP9.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,217 @@ +DENTVRP9 ;DSS/SGM - RETURN DATA FROM HISTORY FILE ;12/18/2001 10:02 + ;;1.2;DENTAL;**30,32,34**;Aug 10, 2001 +EXCEL(RET,SDT,EDT,PROV,DFN,FLG) ; rpc to return history data in excel format + ; see line tag DOC below for description of this rpc + K ^TMP("DENT",$J) + N I,J,K,X,Y,Z,DAT,HLAST,NODE,NUMPRV,QD,QI,QN,ROOT,SCR,STOP + F X="SDT","EDT","PROV","DFN","FLG" S @X=$G(@X) + S (NODE,NUMPRV)=0 S:FLG="" FLG="E" + S RET=$NA(^TMP("DENT",$J)),X="" + I 'SDT S X="No start date received - " + I 'EDT S X=X_"No end date received" + I X="",EDTEDT!'DATE S STOP=1 Q + .I QI="AE",Q3'=DFN S STOP=1 Q + .I QI="AP",Q3'=PROV S STOP=1 Q + .I $D(SCR) X SCR E Q + .S IEN=IEN_"," D GETS^DIQ(228.1,IEN,"**","IE","DENT","ERR") + .I $D(DENT) D BUILD + .Q + I NUMPRV S X=^TMP("DENT",$J,HLAST) D + .F I=1:1:NUMPRV S X=X_"Secondary Provider^" + .S ^TMP("DENT",$J,HLAST)=X + .Q + Q + ; +ERR S ^TMP("DENT",$J,1)="-1^"_X Q + ; +CK(X) ; build common array for encounter + I $L(VAL)+$L(X)>254 S L=L+1,COM(L)=VAL,VAL="" + E S VAL=VAL_X_U + Q + ; +CK1(X) I $L(VAL)+$L(X)>254 S K=K+1,VAL(K)=VAL,VAL="" + E S VAL=VAL_X_U + Q + ; +BUILD ; build lines to export for individual record + ; COM() contains the common columns for each tooth/cpt record + N I,K,L,X,Y,COM,TMP,VAL,VST + S VAL="",L=0 M TMP=DENT(228.1,IEN) + D VST^DENTVRP8(.VST,$G(TMP(5,"I"))) + D CK(+IEN) ; record number + D CK($G(TMP(2,"E"))) ; Patient name + D CK($P($G(^DPT(+$G(TMP(2,"I")),0)),U,9)) ; Patient SSN + D CK($G(TMP(2.1,"I"))) ; Group flag + D CK($G(TMP(3,"E"))) ; Record date + D CK($G(TMP(4,"E"))) ; Creator + D CK($G(TMP(4.1,"E"))) ; Provider + D CK($G(TMP(5,"I"))) ; Visit ien + D CK($P($G(TMP(5,"E")),"@")) ; Encounter Date + D CK($P($G(TMP(5,"E")),"@",2)) ; Encounter time + D CK($G(TMP(6,"E"))) ; DAS record# + D CK($G(TMP(11,"E"))) ; Location + D CK($P(VST(1),U,7)) ; Service connected + D CK($P(VST(1),U,8)) ; Agent orange + D CK($P(VST(1),U,9)) ; Ion rad + D CK($P(VST(1),U,10)) ; Env contam + D CK($P(VST(1),U,11)) ; MST + D CK($P(VST(1),U,12)) ; Head & neck cancer + D CK($P(VST(1),U,4)) ; primary pce diag + D CK($G(TMP(21,"E"))) ; DAS patient cat + D CK($G(TMP(22,"E"))) ; DAS bed section + D CK($G(TMP(23,"E"))) ; DAS division + D CK($G(TMP(24,"E"))) ; DAS disposition + I $L(VAL) S L=L+1,COM(L)=VAL + ; count number of secondary providers for visit + ; NUMPRV = max number of secondary providers - needed for setting + ; column headings properly + S I=$O(VST("A"),-1)-1 I I>NUMPRV S NUMPRV=I + S IEN="" + F S IEN=$O(DENT(228.11,IEN)) Q:IEN="" D + .K TMP,VAL S VAL="",K=0 M TMP=DENT(228.11,IEN) + .D CK1($G(TMP(.01,"E"))) ; tooth# + .D CK1($G(TMP(2,"E"))) ; surface + .D CK1($G(TMP(3,"E"))) ; cpt + .D CPT^DENTVUTL(.DATA,$G(TMP(3,"I"))) S X=$P(DATA,U) + .D CK1(X) ; CPT Description + .D CK1($G(TMP(4,"E"))) ; quad + .D CK1($G(TMP(5,"E"))) ; #canals + .D CK1($G(TMP(6,"E"))) ; primary flag + .D CK1($G(TMP(7,"E"))) ; primary icd9 + .D CK1($G(TMP(14,"E"))) ; ctv + .D CK1($G(TMP(12,"E"))) ; filed to DAS (y) + .D CK1($G(TMP(13,"E"))) ; filed to PCE (y) + .D CK1($G(TMP(8,"E"))) ; secondary icd9 + .D CK1($G(TMP(9,"E"))) ; secondary icd9 + .D CK1($G(TMP(10,"E"))) ; secondary icd9 + .D CK1($G(TMP(11,"E"))) ; secondary icd9 + .; secondary pce providers + .S Y=0 + .F I=2:1 Q:'$D(VST(I)) D CK1($P(VST(I),U,2)) + .I $L(VAL) S K=K+1,VAL(K)=VAL + .F I=1:1:L D SET(COM(L)) + .I K F I=1:1:K D SET(VAL(K)) + .D SET("$") + .Q + Q + ; +SET(T) S NODE=1+NODE,^TMP("DENT",$J,NODE)=T Q + ; +HDR ; create column headings for spreadsheet + ; DAT(#) = local variable to be used in SET indirection + N I,X,Z S Z="" + F I=1:1 S X=$P($T(COL+I),";",3) Q:X="" D + .I $L(X)+$L(Z)>254 D SET(Z) S Z="" + .S Z=Z_X_U + .Q + D SET(Z):$L(Z),SET("$") S HLAST=NODE-1 + Q + ; +COL ; excel column header - offset column + ;;Record# + ;;Patient + ;;SSN + ;;Group + ;;Record Date + ;;Creator + ;;Provider + ;;Visit ien + ;;Encounter Date + ;;Encounter Time + ;;DAS Record + ;;Location + ;;S.C. + ;;A.O. + ;;I.R. + ;;E.C. + ;;MST + ;;H&NC + ;;Prim PCE + ;;DAS Patient Cat + ;;DAS Bed Section + ;;DAS Division + ;;DAS Dispos + ;;Tooth# + ;;Surface + ;;CPT + ;;CPT Description + ;;Quad + ;;#Canals + ;;PrimaryFlag + ;;PrimaryICD9 + ;;CTV + ;;Filed to DAS + ;;Filed to PCE + ;;ICD9 + ;;ICD9 + ;;ICD9 + ;;ICD9 + ; +DOC ; documentation for excel rpc call + ; RET is returned as the global reference ^TMP("DENT",$J) + ; SDT = start date for extract (required) + ; EDT = end date for extract (required) + ; PROV = provider ien (optional) - if present only return prov's recs + ; DFN = patient ien (optional) - if present only return pat's recs + ; FLG = E or R (optional) - default is "E" if not passed + ; E:use encounter date/time R:use record created date + ; Format of global array returned. Each record found in file 228.1 + ; will consist of the following format: + ; + ; $ indicates end of individual record (or row in a spreadsheet) + ; + ; all lines preceding the ending $ line consists of one record. + ; On the PC side, the lines should be joined together to form one + ; string. This string will be delimiter with the "^" which will + ; consist of 38 or more ^-pieces. + ; p1 = ien to file 228.1 p20 = DAS pat category + ; p2 = name of patient p21 = DAS bed section + ; p3 = SSN of patient p22 = DAS division + ; p4 = group flag (y) p23 = DAS disposition + ; p5 = date record created p24 = tooth # (0-32) + ; p6 = name of person who entered record p25 = surfaces + ; p7 = name of provider p26 = cpt code + ; p8 = ien to visit file p27 = cpt short desc + ; p9 = date of encounter p28 = quadrants + ; p10 = time of encounter p29 = # canals + ; p11 = date/time of DAS entry p30 = primary flag (y) + ; p12 = location p31 = icd9 (primary) + ; p13 = service connected (y) p32 = ctv value + ; p14 = agent orange related (y) p33 = data to DAS (y) + ; p15 = ionizing rad related (y) p34 = data to PCE (y) + ; p16 = env contaminant related (y) p35 = icd9 (secondary) + ; p17 = military sexual trauma related (y) p36 = icd9 (secondary) + ; p18 = head & neck cancer related (y) p37 = icd9 (secondary) + ; p19 = primary pce diagnosis p38 = icd9 (secondary) + ; + ; p39,p40,p41,... - optional - secondary pce providers + ; + ;The program receiving this data needs a loop: + ; 1. Get first line + ; 2. Get second line, if line does not equal $ then append this line + ; to the first line + ; 3. Get next line, if line does not equal $ then append this line + ; also + ; 4. Continue getting lines until the ending $ is read + ; 5. You now have a spreadsheet row + ; 6. Repeat steps 1-4 until no more data to be processed + ; 7. User should now have a .TXT file for importing into Excel to be + ; parsed using the ^ as a delimiter. diff -auBN ./r1/DENTVUTL.m ./r2/r/DENTVUTL.m --- ./r1/DENTVUTL.m 1969-12-31 19:00:00.000000000 -0500 +++ ./r2/r/DENTVUTL.m 2003-03-21 10:31:20.000000000 -0500 @@ -0,0 +1,124 @@ +DENTVUTL ;DSS/SGM - COMMON CALLS FOR GUI ;03/06/2002 09:02 + ;;1.2;DENTAL;**30,33,34**;Aug 10, 2001 + ; this routine contains common subroutines called by more that one + ; DENTV* routine + ; +ADA(C) ; return zeroth node of ^dent(228,ien,0) or for cptien=C + N X S X=+$O(^DENT(228,"B",+$G(C),0)) + Q $G(^DENT(228,X,0)) + ; +CPT(RET,Z,F,NDENT,INACT) ; + ; see cpt^icdptcod for detailed description of what is returned + ; Z = required - ien or name to file 81 + ; NDENT = optional - if '$G(NDENT) then add [Primary] to short desc + ; if file 228 entry indicates this is a primary + ; F = optional - if $G(F) then return 4-7 ^piece + ; category_ien^source^effective_date^status + ; INACT = optional - FM date to pass to ICPTCOD to screen out codes + ; inactive as of this date + ;return RET = cpt short name ^ cpt code ^ pointer to 81 ^ {see F} + ; RET(#) = description from cpt file + ; if problem return RET = -1^error message + ; + N X,Y,DCPT,DESC + S F=$G(F,0),NDENT=$G(NDENT,0),Z=$G(Z,0) + I Z=0 S RET="-1^Invalid CPT code received" Q + I '$G(INACT) S DCPT=$$CPT^ICPTCOD(Z) + I $G(INACT) S DCPT=$$CPT^ICPTCOD(Z,INACT) + I DCPT<0 S RET=DCPT Q + I $G(INACT),'$P(DCPT,U,7) D Q + .S RET="-1^Code inactive as of "_$$FMTE^XLFDT($P(DCPT,U,6)) + .Q + S RET=$$STRIP($P(DCPT,U,3)) + I 'NDENT,$P($$ADA(+DCPT),U,13)="y" S RET=RET_" [Primary]" + S RET=RET_U_$P(DCPT,U,2)_U_(+DCPT) S:F RET=RET_U_$P(DCPT,U,4,7) + S X=$$CPTD^ICPTCOD(+DCPT,"DESC") + F X=0:0 S X=$O(DESC(X)) Q:'X S RET(X)=DESC(X) + Q + ; +CPTIEN(CPT) ; return ien to cpt file only, if not found return + N XCPT D:$G(CPT)]"" CPT(.XCPT,CPT) S XCPT=$P($G(XCPT),U,3) + Q XCPT + ; +DENTADD(DFN) ; add/lookup patient to the dental patient file (#220) + ; DFN - required - pointer to the patient file + ; return -1^error message or file220ien (same as DFN) + N X,DIERR,ERR,FDA,IEN,IENS + S X=$$DFN(+$G(DFN)) I X<0 Q X + S X=$O(^DENT(220,"B",DFN,0)) I X>0 Q X + S IENS="+1,",IEN(1)=DFN,FDA(220,IENS,.01)=DFN + L +^DENT(220,0):2 + E Q "-1^Unable to lock the Dental Patient file, try again" + D UPDATE^DIE(,"FDA","IEN","ERR") L -^DENT(220,0) + I $D(DIERR) S X="-1^Error encountered when adding patient to file 220" + E S X=IEN(1) + Q X + ; +DFN(R) ; check for valid patient file pointer R + N T S T=$D(^DPT(+$G(R),0))#2,T=$S(T:"",1:"-1^Invalid patient DFN") + Q T + ; +DIVDEF(RET,USER) ; this RPC returns the default division for user + ; if user has only one division in the DIVISION multiple in the + ; NEW PERSON file, then that entry will be assumed to be their + ; default division unless it is explicitly marked as NO + ; USER - optional - default to DUZ - pointer to file 200 + ; RET - return -1 if no default division found or errors + ; else RET = p1^p2^p3 where + ; p1 = pointer to file 4 + ; p2 = institution name p3 = institution sta# + ; + N X,Y,DEF,DIERR,ERR,LAST,TMP + S USER=$G(USER,DUZ) S:USER="" USER=DUZ + D GETS^DIQ(200,USER_",","16*","I","TMP","ERR") + S (X,Y)=0 F S Y=$O(TMP(200,Y)) Q:Y="" D Q:$D(DEF) + .S X=X+1,LAST=Y S:+$G(TMP(200,Y,1,"I")) DEF=+Y + .Q + I '$D(DEF),X=1,LAST,$G(TMP(200,LAST,1,"I"))'=0 S DEF=+LAST + I +$G(DEF) S RET=DEF_U_$$NS^XUAF4(DEF) + E S RET=-1 + Q + ; +DPROV(P) ; P = pointer to new person file + ; return file 220.5 ien or 0 + Q +$O(^DENT(220.5,"B",+$G(P),0)) + ; +ICD(VEJD,SCR) ; return icd9 ptr ~ icd9 short desc ~ icd9 code + ; VEJD - required, can be either ien or name from file 80 + ; SCR - optional, M code that will be used as DIC("S") + ; if SCR=1, then default to screen out inactive codes + N VEJDICD,VEJDERR,RET,X,Y + S VEJD=$G(VEJD,0),RET="-1^Invalid ICD code received" + I VEJD=0 G OUT + I $G(SCR)]"" S:SCR=1 SCR="I '$P(^(0),U,9),'$P(^(0),U,11)" + I D FIND^DIC(80,,3,"AXQ",VEJD,,,SCR,,"VEJDICD","VEJDERR") + I $G(SCR)="" D FIND^DIC(80,,3,"AXQ",VEJD,,,,,"VEJDICD","VEJDERR") + S X=+$G(VEJDICD("DILIST",2,1)) I 'X K VEJDICD,VEJDERR + I D FIND^DIC(80,,3,"AXM",VEJD_" ",,,,,"VEJDICD","VEJDERR") + I '$G(VEJDICD("DILIST",2,1)) G OUT + S RET=VEJDICD("DILIST",2,1)_"~"_$$STRIP(VEJDICD("DILIST","ID",1,3)) + S RET=RET_"~"_VEJDICD("DILIST",1,1) +OUT Q RET + ; +LOC(X) ; verify X is a pointer value to file 44 - return X or + ;N ERR S X=$$FIND1^DIC(44,,"AXM",$G(X,0),,,"ERR") Q $S(+X:X,1:"") + Q $S($D(^SC(+$G(X),0)):X,1:"") + ; +MSG(ERRMSG,TXT,FUN,FLG) ; error messages processed + ; ERRMSG - passed by reference, processed error message will be added + ; to this array - return parameter + ; TXT - passed by reference, array containing error message from FM + ; FUN - if $G(FUN), return one error message string + ; FLG - if $G(FLG) do not append -1^ in front of error message + N X,Y,Z,ETMP D MSG^DIALOG("AE",.ETMP,72,,"TXT") + S Y=$O(ERRMSG("A"),-1),Z="-1^" S:$G(FLG) Z="" + F X=0:0 S X=$O(ETMP(X)) Q:'X D + .I '$G(FUN) S Y=1+Y,ERRMSG(Y)=Z_ETMP(X) + .E S Z=Z_ETMP(X)_" " + .Q + I $G(FUN) Q Z + Q + ; +STRIP(T) ; strip trailing punctuation chars from T + N W F S W=$E(T,$L(T)) Q:W'?1P!(W="") S T=$E(T,1,$L(T)-1) + Q T diff -auBN ./r1/DG1010P1.m ./r2/r/DG1010P1.m --- ./r1/DG1010P1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG1010P1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DG1010P1 ;ALB/REW - VA FORM 10-10 (CONT) ; 26 MAY 92 - ;;5.3;Registration;**489**;Aug 13, 1993 + ;;5.3;Registration;;Aug 13, 1993 ; DGP(N) = NTH NODE OF PATIENT FILE - ALREADY DEFINED ST W !?25,"SEE ATTACHMENT FOR PAPERWORK REDUCTION INFORMATION AND PRIVACY ACT INFORMATION",!,DGLDASH I $G(IOST)["C-" S DGLUND="" @@ -47,32 +47,13 @@ W !,DGL2 W !,"9F. HOME TELEPHONE NUMBER: ",$$DISP^DG1010P0(DGP(.13),1),?66,"| ","10F. HOME TELEPHONE NUMBER:",?96 W:DGTMP $$DISP^DG1010P0(DGP(.121),10) - W !,DGLUND -CA ;Display confidential address information - N DGACT,DGCAT,DGCATN,DGCATS,VAPA - D ADD^VADPT - W !,"11. CONFIDENTIAL ADDRESS",?66,"|" - I VAPA(12)=""!(VAPA(12)=0) D G SEX - .W !?11,"Not Applicable",?66,"|" - .W !,DGLUND - W !,DGL2 - W !,"11A. STREET ADDRESS:",?21,VAPA(13) - W ?66,"| ","11B. CITY: ",$E(VAPA(16),0,19),?99,"| 11C. STATE: ",$P(VAPA(17),"^",2) - W !,?21,VAPA(14) - W ?66,"| ","11D. ZIP CODE: ",$P(VAPA(18),"^",2),?99,"| 11E. COUNTY: ",$P(VAPA(19),"^",2) - W !,?21,VAPA(15),?66,"| 11F. START DATE: ",$P(VAPA(20),"^",2),?99,"| STOP DATE: ",$P(VAPA(21),"^",2) - W !,$E(DGL2,1,99),"|",$E(DGL2,1,32) - W !,"11G. Active Confidential Address Categories",?66,"|" - S DGCATS="" F S DGCATS=$O(VAPA(22,DGCATS)) Q:DGCATS="" D - .S DGCAT=VAPA(22,DGCATS),DGACT=$P(DGCAT,"^",3),DGCATN=$P(DGCAT,"^",2) - .I DGACT="Y" W !?11,DGCATN,?66,"|" - W !,DGLUND + W ?131,$C(13),DGLUND SEX K DGD,DGX - W !,"12. PATIENT'S SEX",?33,"| ","13. MOTHER'S MAIDEN NAME",?66,"| ","14. MOTHER'S NAME",?99,"| ","15. FATHER'S NAME" + W !,"11. PATIENT'S SEX",?33,"| ","12. MOTHER'S MAIDEN NAME",?66,"| ","13. MOTHER'S NAME",?99,"| ","14. FATHER'S NAME" S X=$P(DGP(0),U,2) W !?5,$S((X="M"):"MALE",(X="F"):"FEMALE",1:"UNANSWERED") W ?33,"| ",?40,$E(($$DISP^DG1010P0(DGP(.24),3)),1,25),?66,"| ",?73,$E(($$DISP^DG1010P0(DGP(.24),2)),1,23),?99,"| ",?106,$E(($$DISP^DG1010P0(DGP(.24),1)),1,30),?131,$C(13),DGLUND RELIG ; - W !,"16. RELIGIOUS PREFERENCE",?33,"| ","17. DATE OF PREVIOUS CARE",?66,"| ","18. LOCATION OF PREVIOUS CARE",?99,"| ","19. SPINAL CORD INJURY" + W !,"15. RELIGIOUS PREFERENCE",?33,"| ","16. DATE OF PREVIOUS CARE",?66,"| ","17. LOCATION OF PREVIOUS CARE",?99,"| ","18. SPINAL CORD INJURY" W !?5,$$POINT^DG1010P0(DGP(0),8,13),?33,"| ",?40,$$DATENP^DG1010P0(DGP(1010.15),1),?66,"| ",?73,$$POINT^DG1010P0(DGP(1010.15),2,4) S X=$$UNK^DG1010P0($P(DGP(57),U,4)) W ?99,"| ",?106,$S((DGUNK):X,(X=1):"PARAPLEGIA-TRAUMATIC",(X=2):"QUADRIPLEGIA-TRAUMATIC",(X=3):"PARAPLEGIA-NONTRAUMATIC",(X=4):"QUADRIPLEGIA-NONTRAUMATIC",(X="X"):"NOT APPLICABLE",1:"INVALID"),?131,$C(13),DGLUND,! diff -auBN ./r1/DG1010P5.m ./r2/r/DG1010P5.m --- ./r1/DG1010P5.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG1010P5.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DG1010P5 ;ALB/REW - PRINT 1010 CONT'D PART V ; 15 MAR 92 - ;;5.3;Registration;**570**;Aug 13, 1993 + ;;5.3;Registration;;Aug 13, 1993 ;;1 ;NOTE: Due to space reasons, the convention of having the code for ; section 'n' in DG1010Pn is modified. The question #11 code @@ -10,18 +10,16 @@ W !,"2. IS NEED FOR MEDICAL CARE RELATED TO AN",?44,"| ","3. IS THE NEED FOR MEDICAL CARE RELATED",?89,"| ","4. IS PATIENT ELIGIBLE FOR MEDICAID:" W !," ON THE JOB INJURY: ",$$YN2(DGP("DIS2"),1),?44,"| ",?50,"TO AN ACCIDENT: ",$$YN2(DGP("DIS2"),4),?89,"| ",?95,$$YN2(DGP(.38),1),?131,$C(13),DGLUND W !,"5A. DOES PATIENT HAVE HEALTH INSURANCE",?44,"| ","5B. IF YES, COVERAGE PROVIDED BY:" - N DGIB,DGIBA,DGYN,DGIB8,DGIB4,DGINS,DGX ; changes for DG*570 - S DGYN=$$INSUR^IBBAPI(DFN,,"R",.DGINS,"1,10,11,12") - W !?4,"COVERAGE: ",$S(DGYN:"YES",1:"NO"),?44,"| ",?50 - I 'DGYN W "NOT APPLICABLE" G GI + W !?4,"COVERAGE: ",$$YN2(DGP(.31),11),?44,"| ",?50 + I X'="Y" W "NOT APPLICABLE" G GI INSINFO ; - S (DGVT,DGSP,DGOT)="",DGX=0 - F S DGX=$O(DGINS("IBBAPI","INSUR",DGX)) Q:'DGX D - . S DGIB8=$G(DGINS("IBBAPI","INSUR",DGX,10)),DGIB4=$G(DGINS("IBBAPI","INSUR",DGX,11)) - . I $S((DGIB8>(9999999-DFN1)):1,(DGIB4']""):0,((9999999-DFN1)>DGIB4):1,1:0) Q - . I $P(DGINS("IBBAPI","INSUR",DGX,12),U,1)="P" S DGVT="PATIENT'S INSURANCE" - . I $P(DGINS("IBBAPI","INSUR",DGX,12),U,1)="S" S DGSP="SPOUSE'S INSURANCE" - . I $P(DGINS("IBBAPI","INSUR",DGX,12),U,1)="O" S DGOT="OTHER" + S (DGVT,DGSP,DGOT)="" + F DGINS=0:0 S DGINS=$O(^DPT(DFN,.312,DGINS)) Q:DGINS'>0 D + .S DGI=^DPT(DFN,.312,DGINS,0) + .I $S(($P(DGI,U,8)>(9999999-DFN1)):1,($P(DGI,U,4)']""):0,((9999999-DFN1)>$P(DGI,U,4)):1,1:0) Q + .I $P(DGI,U,6)="v" S DGVT="PATIENT'S INSURANCE" + .I $P(DGI,U,6)="s" S DGSP="SPOUSE'S INSURANCE" + .I $P(DGI,U,6)="o" S DGOT="OTHER" I DGVT_DGSP_DGOT="" W "NO ACTIVE (UNEXPIRED) INSURANCE ON FILE FOR THIS APPLICANT" I DGVT_DGSP_DGOT'="" W DGVT_$S((DGVT'="")&((DGSP_DGOT)'=""):" & ",1:"")_DGSP_$S((DGOT'="")&((DGVT_DGSP)'=""):" & ",1:"")_DGOT GI W ?131,$C(13),DGLUND diff -auBN ./r1/DG1010PA.m ./r2/r/DG1010PA.m --- ./r1/DG1010PA.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG1010PA.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DG1010PA ;ALB/REW - 1010 PRINT--INQUIRY PATIENT -ADDITIONL ; 28-MAY-93 - ;;5.3;Registration;**18,28,86,108,113,570**;Aug 13, 1993 + ;;5.3;Registration;**18,28,86,108,113**;Aug 13, 1993 ; NOREG(DFN) ; DOES PROMPTS FOR 10/10 PRINT W/O REGISTRATION ;INPUT: DFN @@ -54,7 +54,7 @@ S DGFAIL=0 I DGX=1010 G QTFAIL I DGX="1010I" D G QTFAIL - . I '($$INSUR^IBBAPI(DFN)) S DGFAIL=1 + .I '($O(^DPT(DFN,.312,0))) S DGFAIL=1 I DGX="THIRD" F D Q:$G(%) G QTFAIL .N DGNOQ,DGDEF .D ADM diff -auBN ./r1/DG1010S1.m ./r2/r/DG1010S1.m --- ./r1/DG1010S1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG1010S1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DG1010S1 ;ALB/MRL/EG - SUPPLEMENTAL DATA SHEET FOR 10-10 ; 02/02/2005 - ;;5.3;Registration;**606,568,585**;Aug 13, 1993 +DG1010S1 ;ALB/MRL - SUPPLEMENTAL DATA SHEET FOR 10-10 ; 19 JUN 86 + ;;5.3;Registration;;Aug 13, 1993 ;;MAS VERSION 5.1; ; ;INPUT: DFN = IEN OF PATIENT FILE @@ -20,27 +20,17 @@ W:'I1 "NO ALIAS' ON FILE" K DGD,I,I1 S DGD=$S($L($P(DGP(0),U,10)):$P(DGP(0),U,10),1:"NO REMARKS CURRENTLY ENTERED FOR THIS APPLICANT") W !?5,DGLSUP1,!?5,"4. Remarks: ",DGD,!?5,DGLSUP1 S DGD=DGP(.24) W !?5,"5. Fathers Name: ",$S($L($P(DGD,U,1)):$P(DGD,U,1),1:"NOT SPECIFIED"),?90,"|" W !?9,"Mothers Name: ",$S($L($P(DGD,U,2)):$P(DGD,U,2),1:"NOT SPECIFIED"),?90,"|",!?9,"Mothers Maiden Name: ",$S($L($P(DGD,U,3)):$P(DGD,U,3),1:"NOT SPECIFIED"),?90,"|",!?5,DGLSUP1 - N DGARRAY,I,SDOUT,CLIEN,APTDT W !?5,"6a. Enrollment Clinic(s): " S I1="" F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:I'>0 I $P(^(I,0),U,2)'="I" S I1=I1+1,DGD=$S($D(^SC(+^(0),0)):$P(^(0),U,1)_", ",1:"") W:(128-$X)<$L(DGD) !?9 W DGD W:'I1 "NOT ACTIVELY ENROLLED IN ANY CLINICS AT THIS TIME" K DGD,I,I1 W !?5,DGLSUP,!?5,"6b. Future Appointments: " S I1="",I2=DT_".9999" - S DGARRAY("FLDS")="1;2",DGARRAY(4)=DFN,I=$$SDAPI^SDAMA301(.DGARRAY) - ;it's not clear if it is an error or clinic or patient - ;if an error,there will be no lower subscripts eg 01/20/2005 - I $D(^TMP($J,"SDAMA301",101))=1 S I1=1,DGD="** Appointment Database Unavailable **" - I $D(^TMP($J,"SDAMA301",101))'=1 D - .S (DGD,CLIEN)="" F S CLIEN=$O(^TMP($J,"SDAMA301",DFN,CLIEN)) Q:'CLIEN D - ..S APTDT=DT F S APTDT=$O(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT)) Q:'APTDT D - ...S SDOUT=^TMP($J,"SDAMA301",DFN,CLIEN,APTDT),I1=1,DGD=DGD_$P($P(SDOUT,U,2),";",2)_" ("_$$FMTE^DILIBF($P(SDOUT,U),"5U")_")," - W:(128-$X)<$L(DGD) !?9 W DGD - K DGARRAY,^TMP($J,"SDAMA301"),SDOUT,CLIEN,APTDT + F J=0:0 S I2=$O(^DPT(DFN,"S",I2)) Q:I2="" I $S($P(^(I2,0),U,2)']"":1,$P(^(0),U,2)="I":1,1:0) S DGD(1)=+$P(^(0),U,1),Y=I2 X ^DD("DD") S DGD=$S($D(^SC(+DGD(1),0)):$P(^(0),U,1),1:"UNKNOWN")_" ("_Y_"), ",I1=1 W:(128-$X)<$L(DGD) !?9 W DGD W:'I1 "NO PENDING APPOINTMENTS ON FILE" W !?5,DGLSUP1,!?5,"7a. Last Admission: " S DGAD=$S('$D(^DPT(DFN,.1)):0,'$L(^DPT(DFN,.1)):0,1:1),DGD=$O(^DGPM("ATID1",DFN,+$S(DGAD:$O(^DGPM("ATID1",DFN,0)),1:0))) I DGD'>0 W "NO PREVIOUS ADMISSIONS TO THIS FACILITY ON FILE" G EL S DGD=$O(^DGPM("ATID1",DFN,DGD,0)) I $S('$D(^DGPM(+DGD,0)):1,'$D(^DGPT(+$P(^(0),"^",16),0)):1,1:0) W "LAST ADMISSION PTF DATA NO LONGER STORED" G EL - S DGD=+$P(^DGPM(+DGD,0),"^",16),Y=+^(0),DGDAT=Y + S DGD=+$P(^DGPM(+DGD,0),"^",16),Y=+^(0) X ^DD("DD") W Y S Y=$P($S($D(^DGPT(DGD,70)):^(70),1:0),U,1) X ^DD("DD") W:Y]"" " (DISCHARGED '"_Y_"')" W !?5,DGLSUP,!?5,"7b. Discharge Diagnosis(es): " S I1=$S($D(^DGPT(DGD,"M",1,0)):^(0),1:0) - S I3="" F I=5:1:15 I I'=10 S I2=$P(I1,U,I) Q:'I2 S I3=1,I2=$$ICDDX^ICDCODE(I2,DGDAT),I2=$S(+I2>0:"("_$P(I2,U,2)_")-"_$P(I2,U,4)_"; ",1:"") W:(128-$X)<$L(I2) !?9 W I2 - W:'I3 "NO DIAGNOSES ON FILE FOR THIS ADMISSION PERIOD YET",!?5,DGLSUP S DGD(1)=$S($D(^DGPT(DGD,70)):^(70),1:0),X="UNSPECIFIED",I2=$$ICDDX^ICDCODE(+$P(DGD(1),U,11),DGDAT),X=$S('DGD(1):X,+I2>0:"("_$P(I2,U,2)_")-"_$P(I2,U,4),1:X) - W !?5,"7c. Admit Diagnosis: ",X,!?5,DGLSUP,!?5,"7d. Diagnosis Responsible for Greatest Length of Stay: " S X="UNSPECIFIED",I2=$$ICDDX^ICDCODE(+$P(DGD(1),U,10),DGDAT),X=$S('DGD(1):X,+I2>0:"("_$P(I2,U,2)_")-"_$P(I2,U,4),1:X) W X + S I3="" F I=5:1:15 I I'=10 S I2=$P(I1,U,I) Q:'I2 S I3=1,I2=$S($D(^ICD9(I2,0)):"("_$P(^(0),U,1)_")-"_$P(^(0),U,3)_"; ",1:"") W:(128-$X)<$L(I2) !?9 W I2 + W:'I3 "NO DIAGNOSES ON FILE FOR THIS ADMISSION PERIOD YET",!?5,DGLSUP S DGD(1)=$S($D(^DGPT(DGD,70)):^(70),1:0),X="UNSPECIFIED",X=$S('DGD(1):X,$D(^ICD9(+$P(DGD(1),U,11),0)):"("_$P(^(0),U,1)_")-"_$P(^(0),U,3),1:X) + W !?5,"7c. Admit Diagnosis: ",X,!?5,DGLSUP,!?5,"7d. Diagnosis Responsible for Greatest Length of Stay: " S X="UNSPECIFIED",X=$S('DGD(1):X,$D(^ICD9(+$P(DGD(1),U,10),0)):"("_$P(^(0),U,1)_")-"_$P(^(0),U,3),1:X) W X EL W !?5,DGLSUP1 S DGD=DGP(.361),DGD(1)=$P(DGD,U,5),DGD(2)=$P(DGD,U,6),Y=$P(DGD,U,2),DGD=$P(DGD,U,1),DGD(1)=$S($L(DGD(1)):DGD(1),'$L(DGD):"NOT APPLICABLE",1:"NOT VERIFIED") S DGD(2)=$S(+DGD(2):$S($D(^VA(200,+DGD(2),0)):$P(^(0),U,1),1:"UNKNOWN"),'$L(DGD):"NOT APPLICABLE",1:"NOT SPECIFIED") X:+Y ^DD("DD") S Y=$S($L(Y):Y,'$L(DGD):"NOT APPLICABLE",1:"NOT SPECIFIED") W !?5,"8. Eligibility Status: ",$S(DGD="P":"PENDING VERIFICATION",DGD="R":"PENDING RE-VERIFICATION",DGD="V":"VERIFIED",1:"UNKNOWN OR NONE"),?90,"| Status Date: ",Y,!?9,"Verification Method: ",DGD(1),?90,"| By: ",DGD(2) @@ -48,4 +38,4 @@ G:DGEL C S DGD(1)=$P(DGD,U,1),DGD(1)=$S(DGD(1)=1:"VAMC",DGD(1)=2:"REGIONAL OFFICE",DGD(2)=3:"RPC",1:"UNKNOWN"),DGD(2)=$S($L($P(DGD,U,3)):$P(DGD,U,3),1:"CITY UNKNOWN"),DGD(3)=$S($D(^DIC(5,+$P(DGD,U,4),0)):$P(^(0),U,1),1:"STATE UNKNOWN") S DGD(4)=$S($P(DGD,U,6)]"":$P(DGD,U,6),1:"VARO DECISION UNKNOWN") C W ?90,"| TWX Source: ",DGD(1),!?9,"TWX City: ",DGD(2),?90,"| TWX State: ",$E(DGD(3),1,26),!?9,"VARO Decision: ",DGD(4),!?5,DGLSUP1 - K DGAD,DGD,DGEL,I,I1,I2,Y,DGDAT G ^DG1010S2 + K DGAD,DGD,DGEL,I,I1,I2,Y G ^DG1010S2 diff -auBN ./r1/DG10.m ./r2/r/DG10.m --- ./r1/DG10.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG10.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,16 +1,13 @@ -DG10 ;ALB/MRL,DAK,AEG-LOAD/EDIT PATIENT DATA ; 1/12/04 4:58pm - ;;5.3;Registration;**32,109,139,149,182,326,513,425,574**;Aug 13, 1993 +DG10 ;ALB/MRL,DAK,AEG-LOAD/EDIT PATIENT DATA ; 15 Jul 2000 9:07 PM + ;;5.3;Registration;**32,109,139,149,182,326**;Aug 13, 1993 START ; D LO^DGUTL - I $G(DGPRFLG)=1,$G(DGPLOC)=1 D G Q:$G(DGRPOUT),A1 - .; D EN^DGRPD,REG^IVMCQ($G(DFN)) - . D EN^DGRPD - . Q:$G(DGRPOUT) - . D REG^IVMCQ($G(DFN)) + I $G(DGPRFLG)=1,$G(DGPLOC)=1 D G A1 + . D EN^DGRPD,REG^IVMCQ($G(DFN)) . D HINQ ; A W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO - N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0) + I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0) ; ;MPI QUERY ;check to see if CIRN PD/MPI is installed @@ -19,11 +16,6 @@ D MPIQ^MPIFAPI(DFN) K MPIFRTN ; - I +$G(DGNEW) D - . ; query CMOR for Patient Record Flag Assignments if NEW patient and - . ; display results - . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN) - ; SKIP ; S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A D HINQ,REG^IVMCQ($G(DFN)) G A1 @@ -108,8 +100,8 @@ D ^DIR OKQ Q $S(Y=1:1,1:0) ; -CP ;If not (autoexempt or MTested) & no CP test this year then - ;prompt for add/edit cp test +CP ; If not (autoexempt or MTested) & no CP test this year then + ; prompt for add/edit cp test N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT) diff -auBN ./r1/DG3PR0.m ./r2/r/DG3PR0.m --- ./r1/DG3PR0.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG3PR0.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,28 +1,6 @@ DG3PR0 ;ALB/JDS - 10-10I ;01 JAN 1987 - ;;5.3;Registration;**26,69,570**;Aug 13, 1993 -START K ^UTILITY($J) - N DGIBB,DGX,DGINS,DGBLD - S (N(1),N(0),DG(1),DG(0))="" - I $$INSUR^IBBAPI(DFN,,,.DGIBB,"*") - S DGX="DGIBB(""IBBAPI"",""INSUR"")" M DGINS=@DGX - ; - F I=0:0 S I=$O(DGINS(I)) Q:'I D - . S L=+DGINS(I,1) - . S M=$P($G(DGINS(I,12)),U) - . S M=$S(M="P":"v",M="S":"s",M="O":"o",1:0) - . S DGBLD=L ; ID Number - . S $P(DGBLD,U,2)=DGINS(I,14) ; Subscriber ID - . S $P(DGBLD,U,3)=DGINS(I,18) ; Group Policy No. - . S $P(DGBLD,U,4)=DGINS(I,11) ; Expiration Date - . S $P(DGBLD,U,6)=M ; Subscriber Relationship (Whose Insurance) - . S $P(DGBLD,U,8)=DGINS(I,10) ; Effective Date - . S $P(DGBLD,U,16)=$S(M="v":"01",M="s":"02",M="o":"09",1:"09") ; (Pt. Relationship to Insured - Derived) - . S $P(DGBLD,U,17)=DGINS(I,13) ; Subscriber Name - . S $P(DGBLD,U,18)=+DGINS(I,8) ; Group Plan (Policy Name) - . S $P(DGBLD,U,20)=+DGINS(I,7) ; Coord. of Benefits - . S $P(DGBLD,U,30)=I ; Save of Insurance API Index - . S ^UTILITY($J,M,L)=DGBLD - ; + ;;5.3;Registration;**26,69**;Aug 13, 1993 +START K ^UTILITY($J) S (N(1),N(0),DG(1),DG(0))="" D ALL^IBCNS1(DFN,"DGIBINS",1) F I=0:0 S I=$O(DGIBINS(I)) Q:'I S L=DGIBINS(I,0),M=$P(L,U,6),M=$S(M']"":0,1:M),^UTILITY($J,M,I)=L F I="v",0,"s","o" I $D(^UTILITY($J,I)) S DG(0)=^($O(^(I,0))),N(0)=I Q F I="v",0,"s","o" I $D(^UTILITY($J,I)) S L=$S(N(0)=I:$O(^($O(^(I,0)))),1:$O(^(I,0))) I L>0 S DG(1)=^UTILITY($J,I,L),N(1)=I Q ;K ^UTILITY($J) @@ -38,20 +16,8 @@ S (L,DGL)=0 F I=0:0 S I=$O(^DIC(47,+DGY,1,I)) Q:'I!(DGL=I) S J=^(I,0),X="" W ! F K=1:1 W $E($P(J,"{}",K),$S(K=1:1,X']"":1,1:$L(X)-1),999) S X=$P(J,"{",K+1) Q:X']"" S L=L+1 D SE W:X']"" " " Q D ENDREP^DGUTL K A,B,D,DG,DGL,DGY,DIC,E,I,J,K,L,M,N,X,X1,X2,Y,DGIBINS,^UTILITY($J) Q - ; -SET ; - N DGX - S DGX=$P($G(DG(I)),U,30) - S A=$S(DGX>0:$P(DGINS(DGX,1),U,2),1:"") ; Insurance Co. Name - S X="" - S:DGX>0 X=DGINS(DGX,3)_", "_$P(DGINS(DGX,4),U,2)_" "_DGINS(DGX,5) - ; - S X(I)=A_U_$S(DGX>0:DGINS(DGX,6),1:"")_U_$S(DGX>0:DGINS(DGX,2),1:"")_U_X_U_$P(DG(I),U,2)_U_$P(DG(I),U,3)_U - S Y=$S(DGX>0:DGINS(DGX,10),1:""),Y=$$FMTE^XLFDT(Y) ; Effective Date of Policy - S X(I)=X(I)_Y_U - S Y="",Y=$$FMTE^XLFDT(Y) ; Renewal Date (Not available in Insurance API) - S X(I)=X(I)_Y - ; +SET S A=DG(I),A=$S($D(^DIC(36,+A,0)):^(0),1:""),B=$G(^DIC(36,+DG(I),.11)),Y=$P(B,U,6) D ZIPOUT^VAFADDR S X=$P(B,U,4,5)_U_Y D AD2 + S X(I)=$P(A,U,1)_U_$P($G(^DIC(36,+DG(I),.13)),U,1)_U_$P(B,U,1)_U_X_U_$P(DG(I),U,2)_U_$P(DG(I),U,3)_U,Y=$P(DG(I),U,8) X ^DD("DD") S X(I)=X(I)_Y_U,Y=$P(DG(I),U,7) X ^DD("DD") S X(I)=X(I)_Y S N=$S(N(I)="s":$P(DG(I),U,17)_U_"SPOUSE",(N(I)=0!(N(I)="v")):$P(D(0),U,1)_U_"SAME",1:$P(DG(I),U,17)_U) S E=$S(N(I)=0!(N(I)="v"):D(.311),N(I)="s":D(.25),1:"^^^^") S X=$P(DG(I),U,12,14) D AD2 S X1(I)=N_U_E,X2(I)=$P(DG(I),U,9,11)_U_X diff -auBN ./r1/DG3PR1.m ./r2/r/DG3PR1.m --- ./r1/DG3PR1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG3PR1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,12 +1,11 @@ DG3PR1 ;ALB/JDS/MIR - 3rd PARTY REIMBURSEMENT SORT/PRINT ; 3 MAY 90@8P - ;;5.3;Registration;**26,570**;Aug 13, 1993 + ;;5.3;Registration;**26**;Aug 13, 1993 SORT S (DGFL,DGTIME)=1 F DGI=DGFR:0 S DGI=$O(^DGPM(DGBY,DGI)) Q:'DGI!(DGI>DGTO)!'DGFL F DGJ=0:0 S DGJ=$O(^DGPM(DGBY,DGI,DGJ)) Q:'DGJ D PRINT Q:'DGFL D Q^DG3PR Q PRINT ;OUTPUT Q:'$D(^DGPM(+DGJ,0)) I DGBY[3 S DGDC=^(0),DGCA=$P(DGDC,"^",14),DGAD=$S($D(^DGPM(+DGCA,0)):^(0),1:"") I DGBY[1 S DGAD=^(0),DGCA=DGJ,DGDC=$S($D(^DGPM(+$P(DGAD,"^",17),0)):^(0),1:"") - S DFN=$P(DGAD,"^",3) - I $S('DFN:1,'$D(^DPT(DFN,0)):1,'$$INSUR^IBBAPI(DFN,"","R"):1,'$D(^DPT(DFN,"VET")):1,$P(^("VET"),"^",1)'="Y":1,1:0) Q + S DFN=$P(DGAD,"^",3) I $S('DFN:1,'$D(^DPT(DFN,0)):1,'$O(^DPT(DFN,.312,0)):1,'$D(^DPT(DFN,"VET")):1,$P(^("VET"),"^",1)'="Y":1,1:0) Q I 'DGTIME,($E(IOST,1)="C") S DIR(0)="E" D ^DIR S DGFL=Y Q:'DGFL S DGTIME=0 W @IOF,!,"THIRD PARTY REIMBURSEMENT",?49,"PRINTED: " D NOW^%DTC S Y=% X ^DD("DD") W Y S DGNOW=Y W !!,$P(^DPT(DFN,0),"^",1),?39,"EMPLOYMENT STATUS: " S DGX=$S($D(^DPT(DFN,.311)):^(.311),1:""),X1=$P(DGX,"^",15) diff -auBN ./r1/DG3PR2.m ./r2/r/DG3PR2.m --- ./r1/DG3PR2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG3PR2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,16 +1,7 @@ DG3PR2 ;ALB/MIR - CONTINUATION OF THE THIRD PARTY REIMBURSEMENT ; NOV 21 90@8 - ;;5.3;Registration;**26,606,617,570**;Aug 13, 1993 + ;;5.3;Registration;**26**;Aug 13, 1993 S DGINS=0 W !!,"INSURANCE TYPE",?24,"INSURANCE #",?45,"GROUP #",?63,"EXPIRES HOLDER",!,"--------- ----",?24,"--------- -",?45,"----- -",?63,"------- ------" - ;570 - ;D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I)) Q:'I S J=DGIBINS(I,0) S X=$G(^DIC(36,+J,0)) W !,$S($P(X,"^",2)="N":"*",1:""),$E($P(X,"^",1),1,22),?24,$P(J,"^",2),?45,$P(J,"^",3) S DGINS=$S($P(X,"^",2)="N":1,1:0) D INS2 - N DGX,DGDATA - I $$INSUR^IBBAPI(DFN,,"R",.DGDATA,"1,8,9,11,12,14,18") - S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGIBINS=@DGX - F I=0:0 S I=$O(DGIBINS(I)) Q:'I D - . W !,$S('+DGIBINS(I,9):"*",1:" "),$E($P(DGIBINS(I,1),"^",2),1,22),?24,DGIBINS(I,14),?45 - . I $D(DGIBINS(I,18)) W $G(DGIBINS(I,18)) ; Group Policy number - . S DGINS=$S($P(DGIBINS(I,9),U,2)="NO":1,1:0) D INS2 - ; + D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I)) Q:'I S J=DGIBINS(I,0) S X=$G(^DIC(36,+J,0)) W !,$S($P(X,"^",2)="N":"*",1:""),$E($P(X,"^",1),1,22),?24,$P(J,"^",2),?45,$P(J,"^",3) S DGINS=$S($P(X,"^",2)="N":1,1:0) D INS2 I DGINS W !?22,"* - Insurer may not reimburse!" K DGINS,DGIBINS S Y=+DGAD X ^DD("DD") W !!,"Admitted: ",Y,?40,"Discharged: " S Y=+DGDC I Y X ^DD("DD") W Y @@ -20,18 +11,14 @@ K ^UTILITY("DG") F I=0:0 S I=$O(^DGPT(DGPTF,"M",I)) Q:'I S J=^(I,0) S:$P(J,"^",2) ^UTILITY("DG",$J,"M",+$P(J,"^",10))=J F I=0:0 S I=$O(^DGPT(DGPTF,"S",I)) Q:'I D HEAD:$Y>(IOSL-5) Q:'DGFL S J=^DGPT(DGPTF,"S",I,0),^UTILITY("DG",$J,"S",+J)=J Q:'DGFL I $O(^UTILITY("DG",$J,"M",0)) W !!,"DATE",?22,"LOS BEDSECTION",?39,"LOS",?45,"DIAGNOSES",!,"----",?22,"---------------",?39,"---- ---------" - N DGDAT,DXD - S DGDAT=$P(^DGPT(DGPTF,0),"^",2) - S DGPR=DGAD F I=0:0 S I=$O(^UTILITY("DG",$J,"M",I)) Q:'I S J=^(I) D HEAD:$Y>(IOSL-5) Q:'DGFL S (DGDAT,Y)=I X ^DD("DD") D LOL W !,Y,?22,$E($S($D(^DIC(42.4,+$P(J,"^",2),0)):$P(^(0),"^",1),1:""),1,16),?39,$J(DGLOL,4) D DIAG S DGPR=I - ;Q:'DGFL S DGPMIFN=DGCA D ^DGPMLOS W !?39,"---- ----------",!?26,"TOTAL LOS:",?39,$J(+$P(X,"^",5),4),?45,$S($D(^ICD9(+$S($D(^DGPT(DGPTF,70)):$P(^(70),"^",10),1:""),0)):"DXLS: "_$P(^(0),"^",1)_" ("_$P(^(0),"^",3)_")",1:"") - Q:'DGFL S DGPMIFN=DGCA - D ^DGPMLOS W !?39,"---- ----------",!?26,"TOTAL LOS:",?39,$J(+$P(X,"^",5),4) S DXD=+$S($D(^DGPT(DGPTF,70)):$P(^(70),"^",10),1:0),DXD=$S(+DXD:$$ICDDX^ICDCODE(DXD,DGDAT),1:"") W ?45,$S(+DXD>0:"DXLS: "_$P(DXD,"^",2)_" ("_$P(DXD,"^",4)_")",1:"") + S DGPR=DGAD F I=0:0 S I=$O(^UTILITY("DG",$J,"M",I)) Q:'I S J=^(I) D HEAD:$Y>(IOSL-5) Q:'DGFL S Y=I X ^DD("DD") D LOL W !,Y,?22,$E($S($D(^DIC(42.4,+$P(J,"^",2),0)):$P(^(0),"^",1),1:""),1,16),?39,$J(DGLOL,4) D DIAG S DGPR=I + Q:'DGFL S DGPMIFN=DGCA D ^DGPMLOS W !?39,"---- ----------",!?26,"TOTAL LOS:",?39,$J(+$P(X,"^",5),4),?45,$S($D(^ICD9(+$S($D(^DGPT(DGPTF,70)):$P(^(70),"^",10),1:""),0)):"DXLS: "_$P(^(0),"^",1)_" ("_$P(^(0),"^",3)_")",1:"") Q:'$O(^UTILITY("DG",$J,"S",0)) D HEAD:$Y>(IOSL-10) Q:'DGFL W !!,"SURGERY DATE",?22,"SPECIALTY",?45,"OP CODES",!,"------------",?22,"----------",?44,"--------" - F I=0:0 S I=$O(^UTILITY("DG",$J,"S",I)) Q:'I S J=^(I),(DGDAT,Y)=I X ^DD("DD") W !,Y,?22,$E($S($D(^DIC(45.3,+$P(J,"^",3),0)):$P(^(0),"^",2),1:""),1,16) D OP + F I=0:0 S I=$O(^UTILITY("DG",$J,"S",I)) Q:'I S J=^(I),Y=I X ^DD("DD") W !,Y,?22,$E($S($D(^DIC(45.3,+$P(J,"^",3),0)):$P(^(0),"^",2),1:""),1,16) D OP Q -DIAG S M=0 F K=5:1:15 I K'=10 S L=$P(J,"^",K) I L S DXD=$$ICDDX^ICDCODE(+L,$G(DGDAT)) W:M ! W ?45,$S(+DXD>0:$P(DXD,"^",2)_" ("_$P(DXD,"^",4)_")",1:"") S M=1 +DIAG S M=0 F K=5:1:15 I K'=10 S L=$P(J,"^",K) I L W:M ! W ?45,$S($D(^ICD9(+L,0)):$P(^(0),"^",1)_" ("_$P(^(0),"^",3)_")",1:"") S M=1 Q -OP S M=0 F K=8:1:12 S L=$P(J,"^",K) I L S DXD=$$ICDOP^ICDCODE(+L,$G(DGDAT)) W:M ! W ?45,$S(+DXD>0:$P(DXD,"^",2)_" ("_$P(DXD,"^",5)_")",1:"") S M=1 +OP S M=0 F K=8:1:12 S L=$P(J,"^",K) I L W:M ! W ?45,$S($D(^ICD0(+L,0)):$P(^(0),"^",1)_" ("_$P(^(0),"^",4)_")",1:"") S M=1 Q LOL S X1=I,X2=DGPR D DTC S DGLOL=X F K=DGPR+.0000005:0 S K=$O(^DGPM("APCA",DFN,DGCA,K)) Q:'K!(K>I) S C=$O(^(+K,0)) I $D(^DGPM(+C,0)),"^2^3^13^43^44^45^"[("^"_$P(^(0),"^",18)_"^") S X1=$O(^DGPM("APCA",DFN,DGCA,K)),X1=$S('X1:I,X1>I:I,1:X1),X2=K D DTC S DGLOL=DGLOL-X @@ -41,12 +28,7 @@ W !,"("_$P(^DPT(DFN,0),"^",1)_")",! Q INS2 ;insurance data continued - ;570 - N X - ;I $P(X,"^",2)="N" S DGINS=1 - ;S X=$P(J,"^",4) W:X]"" ?63,$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3) S X=$P(J,"^",6) W ?73,$S(X="v":"VETERAN",X="s":"SPOUSE",X="o":"OTHER",1:"UNKNOWN") - I $P(DGIBINS(I,9),U,2)="NO" S DGINS=1 - S X=DGIBINS(I,11) W:X]"" ?63,$$FMTE^XLFDT(X,"2D") - S X=$P(DGIBINS(I,12),U) W ?73,$S(X="P":"VETERAN",X="S":"SPOUSE",X="O":"OTHER",1:"UNKNOWN") + I $P(X,"^",2)="N" S DGINS=1 + S X=$P(J,"^",4) W:X]"" ?63,$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3) S X=$P(J,"^",6) W ?73,$S(X="v":"VETERAN",X="s":"SPOUSE",X="o":"OTHER",1:"UNKNOWN") Q DTC N I,J,K,L,M,Y D ^%DTC Q diff -auBN ./r1/DG53358C.m ./r2/r/DG53358C.m --- ./r1/DG53358C.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53358C.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,45 +0,0 @@ -DG53358C ;ALB/AEG,GN DG*5.3*296 DELETE INC TEST CON'T;01 JUNE 2000 ; 10/29/03 2:41pm - ;;5.3;REGISTRATION;**358,558**;JUNE 1 2000 - ; - ;This is a modified version for IVMCMD1. It deletes records - ;from the Annual Means Test(#408.31) file. It does not open - ;a case record in the IVM Patient (#301.5)file, does not send 'delete' - ;bulletin/notification to local mail group, does not call the means - ;test event driver and does not call DGMTR. - ; - ;DG*53*558 - re-deploy with this patch - ; -EN ;This entry point is called from the routine (DG53358D) and - ;contains calls that are responsible for completing the - ;deletion of an income test. - ; - ; Delete record from Annual Means Test (#408.31) file - D DEL31(IVMMTIEN) - S IVMDONE=1 - ; - ; Cleanup variables - D CLEAN - ; -ENQ Q - ; - ; -DEL31(IVMDIEN) ; Delete record from Annual Means Test (#408.31) file. - ; - ; Input(s): - ; IVMDIEN - as IEN of the Annual Means Test (#408.31) file - ; - ; Output(s): None - ; - N DA,DIK - S DA=IVMDIEN,DIK="^DGMT(408.31," - D ^DIK - Q - ; - ; - ; -CLEAN ; Cleanup variables used for deletion. - K DA,DFN,DGINC,DGINR,DGMTA,DGMTACT,DGMTI,DGMTP - K DGMTYPT,DIE,DIK,DR,IVM12,IVM121,IVM13,IVM41,IVM411 - K IVMAR1,IVMDEP,IVMFILE,IVMNOD,IVMOLD - K IVMPAT,IVMTEXT,IVMVAMCA,XMSUB,Y - Q diff -auBN ./r1/DG53358D.m ./r2/r/DG53358D.m --- ./r1/DG53358D.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53358D.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,191 +0,0 @@ -DG53358D ;ALB/AEG,GN DG*5.3*358 DELETE INCOME TESTS ; 12/17/03 3:06pm - ;;5.3;REGISTRATION;**358,558**;5-1-2001 - ; - ;This is a modified version of IVMCMD in that it calls a modified - ;version of IVMCMD1 called DG53358C which only deletes the - ;records from the Annual Means Test(#408.31) file. It does not open - ;a case record in the IVM Patient (#301.5)file, does not send 'delete' - ;bulletin/notification to local mail group, does not call the means - ;test event driver and does not call DGMTR. - ; - ;DG*53*558 - re-deploy with this patch - ; -EN(IVMMTIEN) ; -- - ; This routine will process income test deletion requests received - ; from the IVM Center. - ; - ; Input(s): - ; IVMMTIEN - pointer to test to be deleted in file 408.31 - ; - ; Output(s): - ; Function Value - 1 test deleted - ; 0 test not deleted - ; - ; - ; Initialize variables - N DFN,IVMERR,IVMLINK,IVMNODE0,IVMDOT,IVMTOT,IVMDONE - S IVMDONE=0 - ; -EN1 ; Get zero node of (#408.31) - S IVMNODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - I 'IVMNODE0 Q 1 ; test not found - S IVMDOT=$P(IVMNODE0,"^") ; date of test - S DFN=$P(IVMNODE0,"^",2) - S IVMTOT=$P(IVMNODE0,"^",19) ; type of test - S IVMLINK=$P($G(^DGMT(408.31,IVMMTIEN,2)),"^",6) - ;don't delete copay test linked to valid means test - I IVMTOT=2,IVMLINK,$D(^DGMT(408.31,IVMLINK,0)) Q 0 - I IVMTOT=1,IVMLINK D I $D(IVMERR) Q 0 ;I MT linkd to copay delete both - .D DELETE(IVMLINK,DFN,IVMDOT) ; delete copay - D DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT - Q IVMDONE - ; -DELETE(IVMMTIEN,DFN,IVMDOT) ; delete copay or MT - ; - ; Get Income Relation IEN array (DGINR) and - ; Individual Annual Income IEN array (DGINC) - D ALL^DGMTU21(DFN,"VSC",IVMDOT,"IR",IVMMTIEN) - ; - ; -DEL22 ; Delete veteran, spouse, and dependent entries from the - ; Income Relation (#408.22) file: - ; - Veteran (#408.22) record - S DA=$G(DGINR("V")) D - .Q:'DA - .S DIK="^DGMT(408.22," - .D ^DIK - ; - ; - Spouse (#408.22) record - S DA=$G(DGINR("S")) D - .Q:'DA - .S DIK="^DGMT(408.22," - .D ^DIK - ; - ; - All dependent children (#408.22) records - S IVMDEP=0 - F S IVMDEP=$O(DGINR("C",IVMDEP)) Q:'IVMDEP D - .S DA=$G(DGINR("C",IVMDEP)) - .S DIK="^DGMT(408.22," - .D ^DIK - ; - ; -DEL21 ; Delete veteran, spouse, and dependent entries from - ; Individual Annual Income (#408.21) file: - ; - Veteran (#408.21) record - S DA=$G(DGINC("V")) D - .Q:'DA - .S DIK="^DGMT(408.21," - .D ^DIK - ; - ; - Spouse (#408.21) record - S DA=$G(DGINC("S")) D - .Q:'DA - .S DIK="^DGMT(408.21," - .D ^DIK - ; - ; - All dependent children (#408.21) records - S IVMDEP=0 - F S IVMDEP=$O(DGINC("C",IVMDEP)) Q:'IVMDEP D - .S DA=$G(DGINC("C",IVMDEP)) - .S DIK="^DGMT(408.21," - .D ^DIK - ; - ; - ; Logic for (#408.12/#408.1275) & (#408.13) file entries - D SETUPAR - ; - ; Look for IVM/DCD Patient Realtion (#408.12) file entries. - ; If no entries in "AIVM" x-ref, no dependent changes required. - S IVM12="" F S IVM12=$O(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12)) Q:'IVM12 D Q:$D(IVMERR) - .; -- if can't find entry in (#408.12), set IVMERR - .I $G(^DGPR(408.12,+IVM12,0))']"" D Q - ..S IVMERR="" Q - .; - .; - if only one record exists in (#408.1275) mult., then only one - .;IVM/DCD dependent to delete - .I $P($G(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1 D Q - ..; - ..; -- if can't find entry in (#408.13), set IVMERR - ..S IVM13=$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";") - ..I $G(^DGPR(408.13,+IVM13,0))']"" D Q - ...S IVMERR="" Q - ..; - ..; -- delete (#408.12) & (#408.13) records for IVM/DCD dependent - ..S DA=IVM12,DIK="^DGPR(408.12," D ^DIK K DA,DIK - ..S DA=IVM13,DIK="^DGPR(408.13," D ^DIK K DA,DIK - ..Q - .; - .; - .; Delete (#408.1275) record for IVM/DCD dependent and - .; change demo data in (#408.12) & (#408.13) back to VAMC values. - .; OR, Delete (#408.1275) record for inactivated VAMC dependent. - .S IVM121="",IVM121=$O(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121)) - .; - if can't find entry in (#408.1275), set IVMERR - .I $G(^DGPR(408.12,+IVM12,"E",+IVM121,0))']"" D Q - ..S IVMERR="" Q - .; - .S IVMVAMCA=$P($G(^DGPR(408.12,+IVM12,"E",+IVM121,0)),"^",2) - .;dependent active? - .; - .; - If active, inactivate dependant - .I IVMVAMCA D - ..S DR=".02////0",DA=+IVM121,DA(1)=0 - ..S DIE="^DGPR(408.12,"_+IVM12_",""E""," - ..D ^DIE S IVMVAMCA=0 Q - .; - .S DA(1)=IVM12,DA=IVM121,DIK="^DGPR(408.12,"_DA(1)_",""E""," - .D ^DIK K DA(1),DA,DIK - .; - .Q - ; - ; Complete deletion of income test - D EN^DG53358C - ; -ENQ Q - ; - ; -SETUPAR ; Create array IVMAR1() where - ; 1) Subscript is MT Changes Type (#408.42) file node where type of - ; change = Name, DOB, SSN, Sex, Relationship. - ; 2) 1st piece is (#408.12) or (#408.13) file. - ; 3) 2nd piece is (#408.12) or (#408.13) file field number. - ; - F IVM41=4:1 S IVM411=$P($T(TYPECH+IVM41),";;",2) Q:IVM411="QUIT" D - .S IVMAR1($P(IVM411,";"))=$P(IVM411,";",2,3) - K IVM41,IVM411 - Q - ; -DELTYPE(DFN,MTDATE,TYPE) ; - ;will delete any primary test for patient=DFN for same income year as - ;MTDATE for test of type=TYPE - ; - Q:'$G(DFN) - Q:'$G(MTDATE) - Q:'$G(TYPE) - N MTNODE,YEAR,RET - S YEAR=$E(MTDATE,1,3)_1230.999999 - D - .S MTNODE=$$LST^DGMTU(DFN,YEAR,TYPE) - .Q:'+MTNODE - .I $E($P(MTNODE,"^",2),1,3)'=$E(YEAR,1,3) Q - .;don't want to delete auto-created Rx copay tests -they are deleted by - .; deleting the MT that they are based on - .I TYPE=2,+$P($G(^DGMT(408.31,+MTNODE,2)),"^",6) Q - .I $P(MTNODE,"^",5),$P(MTNODE,"^",5)'=1 I $$EN(+MTNODE) D - ..; - ..S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) - ..I $E($P(RET,"^",2),1,3)'=$E(YEAR,1,3) S RET="" - ..D ADD^IVMCMB(DFN,IVMTYPE,"DELETE PRMYTEST",$P(MTNODE,"^",2),$P(MTNODE,"^",4),$P(RET,"^",4)) - Q - ; -TYPECH ; Type of dependent changes (#408.41/#408.42) file - ; 1st piece - 408.42 table file node - ; 2nd piece - file (408.12/408.13) - ; 3rd piece - 408.12/408.13 field - ;;16;408.13;.01 - ;;17;408.13;.03 - ;;18;408.13;.09 - ;;19;408.13;.02 - ;;20;408.12;.02 - ;;QUIT - Q diff -auBN ./r1/DG53463.m ./r2/r/DG53463.m --- ./r1/DG53463.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53463.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,18 +0,0 @@ -DG53463 ;ALB/RMM - Mail Group Utility ; 2/03/03 - ;;5.3;Registration;**463**;Aug 13, 1993 - ; - ; This post-install routine will add the user who is performing the - ; install of Patch DG*5.3*463 to the MT INCONSISTENCIES Mail Group - ; -EN ; Get the IEN of the mail group distributed in this patch - N DGENDA,DATA,ERR - S DGENDA(1)=$O(^XMB(3.8,"B","MT INCONSISTENCIES","")) - ; - ; Quit if the user has already been added to the mail group - Q:$D(^XMB(3.8,DGENDA(1),1,"B",DUZ)) - ; - ; Add the user to the MT INCONSISTENCIES Mail Group - S DATA(.01)=DUZ - I $$ADD^DGENDBS(3.81,.DGENDA,.DATA,.ERR) - ; - Q diff -auBN ./r1/DG53478I.m ./r2/r/DG53478I.m --- ./r1/DG53478I.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53478I.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,224 +0,0 @@ -DG53478I ; SLC/PKR - Create cross-references for clinical reminder index. ;10/12/2004 - ;;5.3;Registration;**478**;Aug 13, 1993 - ; - Q - ;=============================================================== -CDGPTXR ;Create all the cross-references. - D CDGPT0 - D CDGPT9 - D CHLOC - Q - ; - ;=============================================================== -CDGPT0 ;Create cross-references for PTF ICD0 data. - ;For node 401 surgery node: - ;ICD0 from nodes: 45.01,8; 45.01,9; 45.01,10; 45.01,11; 45.01,12 - ;For node 601, procedure node: - ;ICD0 from nodes: 45.05,4; 45.05,5; 45.05,6; 45.05,7; 45.05,8 - N IND,MSG,NAME,NODE,NODENUM,RESULT,XREF - D BMES^XPDUTL("Creating PTF ICD0 cross-references.") - ;Set the XREF nodes that are the same for all cross-references. - S XREF("FILE")=45 - S XREF("WHOLE KILL")="K ^PXRMINDX(45,""ICD0"")" - S XREF("TYPE")="MU" - S XREF("SHORT DESCR")="Clinical Reminders index for ICD0 lookup." - S XREF("DESCR",1)="This cross-reference builds two indexes, one for finding" - S XREF("DESCR",2)="all patients with a particular ICD0 code and one for finding all" - S XREF("DESCR",3)="the ICD0 codes a patient has." - S XREF("DESCR",4)="The indexes are stored in the Clinical Reminders index global as:" - S XREF("DESCR",5)=" ^PXRMINDX(45,""ICD0"",""INP"",ICD0,NODE,DFN,DATE,DAS) and" - S XREF("DESCR",6)=" ^PXRMINDX(45,""ICD0"",""PNI"",DFN,NODE,ICD0,DATE,DAS)" - S XREF("DESCR",7)="respectively. DATE is the surgery/procedure date." - S XREF("USE")="ACTION" - S XREF("EXECUTION")="R" - S XREF("ACTIVITY")="IR" - ; - ;These XREF nodes change for each cross-reference. - S XREF("ROOT FILE")=45.01 - S XREF("VAL",1)=.01 - S XREF("VAL",1,"SUBSCRIPT")=1 - S XREF("VAL",2,"SUBSCRIPT")=2 - S IND=0 - S NODE="S" - S XREF("DESCR",8)="NODE is S followed by code number. For example," - S XREF("DESCR",10)="For all the details, see the Clinical Reminders Index Technical Guide/Programmer's Manual." - F NODENUM=8,9,10,11,12 D - . S IND=IND+1 - . S XREF("DESCR",9)=NODE_IND_" means it was found on the S node and it was operation code "_IND_"." - . S NAME="ACR0S"_IND - . S XREF("NAME")=NAME - . S XREF("VAL",2)=NODENUM - . S XREF("SET")="D SDGPT0^DGPTDDCR(.X,.DA,"""_NODE_""","_IND_")" - . S XREF("KILL")="D KDGPT0^DGPTDDCR(.X,.DA,"""_NODE_""","_IND_")" - . D CREIXN^DDMOD(.XREF,"k",.RESULT,"","MSG") - . I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - ; - S XREF("ROOT FILE")=45.05 - S XREF("VAL",1)=.01 - S XREF("VAL",1,"SUBSCRIPT")=1 - S XREF("VAL",2,"SUBSCRIPT")=2 - S IND=0 - S NODE="P" - S XREF("DESCR",8)="NODE is S followed by code number. For example," - S XREF("DESCR",10)="For all the details, see the Clinical Reminders Index Technical Guide/Programmer's Manual." - F NODENUM=4,5,6,7,8 D - . S IND=IND+1 - . S XREF("DESCR",9)=NODE_IND_" means it was found on the P node and it was operation code "_IND_"." - . S NAME="ACR0P"_IND - . S XREF("NAME")=NAME - . S XREF("VAL",2)=NODENUM - . S XREF("SET")="D SDGPT0^DGPTDDCR(.X,.DA,"""_NODE_""","_IND_")" - . S XREF("KILL")="D KDGPT0^DGPTDDCR(.X,.DA,"""_NODE_""","_IND_")" - . D CREIXN^DDMOD(.XREF,"k",.RESULT,"","MSG") - . I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - Q - ; - ;=============================================================== -CDGPT9 ;Create cross-references for PTF ICD9 data. - ;ICD9 from nodes: 45,79; 45,80; 45,79.16 45,79.17; 45,79.18; - ;45,79.19; 45,79.201; 45,79.21; 45,79.22; 45,79.22; 45.79.23; - ;45,79.24; 45,79.241; 45,79.242; 45,79.243; 45,79.244 - ;By name these nodes are: DXLS, PRINCIPAL DIAGNOSIS, SECONDARY - ;DIAGNOSIS 1, through SECONDARY DIAGNOSIS 12. - N IND,MSG,NAME,NODE,RESULT,XREF - D BMES^XPDUTL("Creating PTF ICD9 cross-references.") - ;Set the XREF nodes that are the same for all cross-references. - S XREF("FILE")=45 - S XREF("ROOT FILE")=45 - S XREF("WHOLE KILL")="K ^PXRMINDX(45)" - S XREF("TYPE")="MU" - S XREF("SHORT DESCR")="Clinical Reminders index for ICD9 lookup." - S XREF("DESCR",1)="This cross-reference builds two indexes, one for finding" - S XREF("DESCR",2)="all patients with a particular ICD9 code and one for finding all" - S XREF("DESCR",3)="the ICD9 codes a patient has." - S XREF("DESCR",4)="The indexes are stored in the Clinical Reminders index global as:" - S XREF("DESCR",5)=" ^PXRMINDX(45,""ICD9"",""INP"",ICD9,NAME,DFN,DATE,DAS) and" - S XREF("DESCR",6)=" ^PXRMINDX(45,""ICD9"",""PNI"",DFN,NAME,ICD9,DATE,DAS)" - S XREF("DESCR",7)="respectively. DATE is the discharge date. If it does not" - S XREF("DESCR",8)="exist then the admission date is used." - S XREF("EXECUTION")="R" - S XREF("ACTIVITY")="IR" - S XREF("VAL",1)=.01 - S XREF("VAL",1,"SUBSCRIPT")=1 - S XREF("VAL",2)=2 - S XREF("VAL",2,"SUBSCRIPT")=2 - S XREF("VAL",3)=11 - S XREF("VAL",3,"SUBSCRIPT")=3 - S XREF("VAL",5)=70 - ; - ;These XREF nodes change for each cross-reference. - S XREF("DESCR",9)="NAME is the name of the ICD9 code field. An example is DXLS." - S XREF("DESCR",10)="If the TYPE OF RECORD is CENSUS then the entry is not indexed." - S XREF("DESCR",11)="For all the details, see the Clinical Reminders Index Technical Guide/Programmer's Manual." - S XREF("NAME")="ACR9DXLS" - S XREF("VAL",4)=79 - S XREF("VAL",4,"SUBSCRIPT")=4 - S XREF("SET")="D SDGPT9D^DGPTDDCR(.X,.DA,""DXLS"")" - S XREF("KILL")="D KDGPT9D^DGPTDDCR(.X,.DA,""DXLS"")" - D CREIXN^DDMOD(.XREF,"k",.RESULT,"","MSG") - I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - ; - S XREF("DESCR",9)="NAME is the name of the ICD9 code field. An example is PDX." - S XREF("DESCR",10)="If the TYPE OF RECORD is CENSUS then the entry is not indexed." - S XREF("DESCR",11)="For all the details, see the Clinical Reminders Index Technical Guide/Programmer's Manual." - S XREF("NAME")="ACR9PDX" - S XREF("VAL",4)=80 - S XREF("VAL",4,"SUBSCRIPT")=4 - S XREF("SET")="D SDGPT9D^DGPTDDCR(.X,.DA,""PDX"")" - S XREF("KILL")="D KDGPT9D^DGPTDDCR(.X,.DA,""PDX"")" - D CREIXN^DDMOD(.XREF,"k",.RESULT,"","MSG") - I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - ; - ;Remove the cross-references using the original names (this applies to - ;test sites). - S IND=1 - F FIELD=79.16,79.17,79.18,79.19,79.201,79.21,79.22,79.23,79.24 D - . S IND=IND+1 - . S NAME="ACR9DICD"_IND - . D DELIXN^DDMOD(45,NAME,"","","MSG") - . I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - ;Remove ACR9DSD14, it was created in error. - D DELIXN^DDMOD(45,"ACR9DSD14","","","MSG") - I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - ; - S IND=0 - F FIELD=79.16,79.17,79.18,79.19,79.201,79.21,79.22,79.23,79.24,79.241,79.242,79.243,79.244 D - . S IND=IND+1 - . S XREF("DESCR",9)="NAME is the name of the ICD9 code field. An example is D SD"_IND_", where D SD tells us it is a discharge secondary diagnosis." - . S XREF("DESCR",10)="If the TYPE OF RECORD is CENSUS then the entry is not indexed." - . S XREF("DESCR",11)="For all the details, see the Clinical Reminders Index Technical Guide/Programmer's Manual." - . S NAME="SD"_IND - . S NODE="D "_NAME - . S XREF("NAME")="ACR9D"_NAME - . S XREF("VAL",4)=FIELD - . S XREF("VAL",4,"SUBSCRIPT")=4 - . S XREF("SET")="D SDGPT9D^DGPTDDCR(.X,.DA,"""_NODE_""")" - . S XREF("KILL")="D KDGPT9D^DGPTDDCR(.X,.DA,"""_NODE_""")" - . D CREIXN^DDMOD(.XREF,"k",.RESULT,"","MSG") - . I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - ; - ;Add the movement nodes. - K XREF("VAL") - S XREF("ROOT FILE")=45.02 - S XREF("VAL",1)=10 - S XREF("VAL",1,"SUBSCRIPT")=1 - S XREF("DESCR",7)="respectively. DATE is movement date." - K XREF("DESCR",8),XREF("DESCR",9),XREF("DESCR",10),XREF("DESCR",11) - S XREF("DESCR",9)="If the TYPE OF RECORD is CENSUS then the entry is not indexed." - S XREF("DESCR",10)="For all the details, see the Clinical Reminders Index Technical Guide/Programmer's Manual." - S IND=0 - F FIELD=5,6,7,8,9,11,12,13,14,15 D - . S IND=IND+1 - . S XREF("DESCR",8)="NAME is the name of the ICD9 code field. An example is M ICD"_IND_", where M tells us it is a movement diagnosis." - . S NAME="ICD"_IND - . S NODE="M "_NAME - . S XREF("NAME")="ACR9M"_NAME - . S XREF("VAL",2)=FIELD - . S XREF("VAL",2,"SUBSCRIPT")=2 - . S XREF("SET")="D SDGPT9M^DGPTDDCR(.X,.DA,"""_NODE_""")" - . S XREF("KILL")="D KDGPT9M^DGPTDDCR(.X,.DA,"""_NODE_""")" - . D CREIXN^DDMOD(.XREF,"k",.RESULT,"","MSG") - . I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - Q - ; - ;=============================================================== -CHLOC ;Create cross-references for Hospital Location. - N MSG,RESULT,XREF - D BMES^XPDUTL("Creating Hospital Location cross-references.") - S XREF("FILE")=44 - S XREF("ROOT FILE")=44 - S XREF("TYPE")="R" - S XREF("USE")="SORTING ONLY" - S XREF("EXECUTION")="F" - S XREF("ACTIVITY")="IR" - S XREF("SHORT DESCR")="Index credit stop codes" - S XREF("DESCR",1)="This index can be used to find all hospital locations in a" - S XREF("DESCR",2)="credit stop code." - S XREF("WHOLE KILL")="K ^SC(""ACST"")" - S XREF("VAL",1)=2503 - S XREF("VAL",1,"SUBSCRIPT")=1 - S XREF("NAME")="ACST" - S XREF("SET")="S ^SC(""ACST"",X,DA)" - S XREF("KILL")="K ^SC(""ACST"",X,DA)" - D CREIXN^DDMOD(.XREF,"kS",.RESULT,"","MSG") - I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - ; - S XREF("SHORT DESCR")="Index stop codes" - S XREF("DESCR",1)="This index can be used to find all hospital locations in a" - S XREF("DESCR",2)="stop code." - S XREF("WHOLE KILL")="K ^SC(""AST"")" - S XREF("VAL",1)=8 - S XREF("VAL",1,"SUBSCRIPT")=1 - S XREF("NAME")="AST" - S XREF("SET")="S ^SC(""AST"",X,DA)" - S XREF("KILL")="K ^SC(""AST"",X,DA)" - K MSG - D CREIXN^DDMOD(.XREF,"kS",.RESULT,"","MSG") - I RESULT="" D DCERRMSG^PXRMP12I(.MSG,.XREF) - ;Eliminate the original CST and ST indexes. - D DELIXN^DDMOD(44,"CST") - D DELIXN^DDMOD(44,"ST") - K ^SC("CST") - K ^SC("ST") - Q - ; diff -auBN ./r1/DG53514.m ./r2/r/DG53514.m --- ./r1/DG53514.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53514.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,189 +0,0 @@ -DG53514 ;ALB/PHH - DG*5.3*514 DOD Cleanup ; 4/25/03 - ;;5.3;Registration;**514**;Aug 13, 1993 - Q -RESET ; Reset the data for the cleanup process - K ^XTMP($$NAMESPC) - Q -TEST ; Simulate Live Run - N MODE - S MODE=0 -START ; Start Processor - N NAMESPC,QTIME - S NAMESPC=$$NAMESPC - Q:$$RUNCHK(NAMESPC) ; Quit if already running or has run to completion - Q:$$QTIME(.QTIME) - S:$D(^XTMP(NAMESPC,"CONFIG","RUN MODE")) MODE=^XTMP(NAMESPC,"CONFIG","RUN MODE") - S:'$D(^XTMP(NAMESPC,"CONFIG","RUN MODE")) ^XTMP(NAMESPC,"CONFIG","RUN MODE")=$S($G(MODE)=0:0,1:1) - S ^XTMP(NAMESPC,"CONFIG","USER")=$S($G(DUZ)'="":DUZ,1:"UNKNOWN") - S:'$$QUEUE(QTIME) ^XTMP(NAMESPC,"CONFIG","RUNNING")="" - Q -NAMESPC() ; API returns the name space for this patch - Q "DG514" -RUNCHK(NAMESPC) ; Check to see if clean up is already running - Q:NAMESPC="" 1 ; Name Space must be defined - Q:$D(^XTMP(NAMESPC,"CONFIG","RUNNING")) 1 - Q:$D(^XTMP(NAMESPC,"CONFIG","COMPLETE")) 1 - Q 0 -QTIME(WHEN) ; Get the run time for queuing - N %,%H,%I,X - D NOW^%DTC - S WHEN=$P(%,".")_"."_$E($P(%,".",2),1,4) - Q 0 -QUEUE(ZTDTH) ; Queue the process - N NAMESPC,QUEERR,ZTDESC,ZTRTN,ZTSK - S NAMESPC=$$NAMESPC - S QUEERR=0 - S ZTRTN="CLEAN^DG53"_$P(NAMESPC,"DG",2) - S ZTDESC=NAMESPC_" - DOD Cleanup Process" - S ZTIO="" - D ^%ZTLOAD - K ^XTMP(NAMESPC,"CONFIG","ZTSK") - I '$D(ZTSK) S ^XTMP(NAMESPC,"CONFIG","ZTSK")="Unable to queue post-install process.",QUEERR=1 - I $D(ZTSK) S ^XTMP(NAMESPC,"CONFIG","ZTSK")="Post-install queued. Task ID: "_$G(ZTSK) - D HOME^%ZIS - Q QUEERR -CLEAN ; Actual cleanup process - N NAMESPC,MODE,USER,TASKID,%,%H,%I,X,X1,X2,CHKCNT,TMSWT,TOTDPT,DFN - S NAMESPC=$$NAMESPC - K ^XTMP(NAMESPC,"CONFIG","ABORT TIME") - S MODE=$G(^XTMP(NAMESPC,"CONFIG","RUN MODE"),0) - S USER=$G(^XTMP(NAMESPC,"CONFIG","USER"),"UNKNOWN") - S TASKID=$G(^XTMP(NAMESPC,"CONFIG","ZTSK"),"UNKNOWN") - ; - I '$D(^XTMP(NAMESPC,0)) D - .K ^XTMP(NAMESPC) - .S ^XTMP(NAMESPC,"CONFIG","DFN")=0 - .S ^XTMP(NAMESPC,"CONFIG","TOTPR")=0 - .S ^XTMP(NAMESPC,"CONFIG","PERCENT COMPLETE")=0 - .S ^XTMP(NAMESPC,"CONFIG","RUN MODE")=MODE - .S ^XTMP(NAMESPC,"CONFIG","USER")=USER - .S ^XTMP(NAMESPC,"CONFIG","ZTSK")=TASKID - .D NOW^%DTC - .S ^XTMP(NAMESPC,"CONFIG","START TIME")=% - .S X1=$$DT^XLFDT,X2=90 - .D C^%DTC - .S ^XTMP(NAMESPC,0)=X_U_$$DT^XLFDT_U_NAMESPC_" - DOD CLEANUP" - ; - S CHKCNT=250,(ZTSTOP,TMSWT)=0,TOTDPT=+$P($G(^DPT(0)),"^",4) - S DFN=$G(^XTMP(NAMESPC,"CONFIG","DFN")) - F S DFN=$O(^DPT(DFN)) Q:'DFN!(TMSWT) D - .D PROC(DFN) - .S ^XTMP(NAMESPC,"CONFIG","TOTPR")=$G(^XTMP(NAMESPC,"CONFIG","TOTPR"))+1 - .S ^XTMP(NAMESPC,"CONFIG","DFN")=DFN - .I TOTDPT D - ..S ^XTMP(NAMESPC,"CONFIG","PERCENT COMPLETE")=+$G(^XTMP(NAMESPC,"CONFIG","TOTPR"))/TOTDPT - ..S ^XTMP(NAMESPC,"CONFIG","PERCENT COMPLETE")=+$P((^XTMP(NAMESPC,"CONFIG","PERCENT COMPLETE")*100),".") - .I +$G(^XTMP(NAMESPC,"CONFIG","TOTPR"))#CHKCNT=0 D - ..S TMSWT=$$STOPIT() - ..I TMSWT D - ...S ZTSTOP=1 - ...N %,%H,%I,X - ...D NOW^%DTC - ...S ^XTMP(NAMESPC,"CONFIG","ABORT TIME")=% - ...D ABORTMSG - ; - I 'DFN,'TMSWT D - .N %,%H,%I,X - .D NOW^%DTC - .S ^XTMP(NAMESPC,"CONFIG","COMPLETE")=% - .S ^XTMP(NAMESPC,"CONFIG","PERCENT COMPLETE")=100 - .D DONEMSG - ; - K ^XTMP(NAMESPC,"CONFIG","RUNNING") - Q -PROC(DFN) ; Process the DFN - N NAMESPC,DOD,CURENR,ENRSTAT,QLOGIEN,SUCCESS - S NAMESPC=$$NAMESPC - S DOD=$P($G(^DPT(DFN,.35)),"^") - Q:DOD="" - S CURENR=$P($G(^DPT(DFN,"ENR")),"^") ; Get Current Enr Record - Q:CURENR="" - S ENRSTAT=$P($G(^DGEN(27.11,CURENR,0)),"^",4) - Q:ENRSTAT'=1 ; Quit if it's not an 'Unverified' status - ; - S ^XTMP(NAMESPC,"DATA",DFN)="" - S ^XTMP(NAMESPC,"CONFIG","ANOMALY")=$G(^XTMP(NAMESPC,"CONFIG","ANOMALY"))+1 - S ^XTMP(NAMESPC,"CONFIG","DFN")=DFN - ; - S SUCCESS=0 - I MODE S SUCCESS=$$SEND(DFN) ; Resend the Z11 query - S $P(^XTMP(NAMESPC,"DATA",DFN),"^")=SUCCESS - ; - I SUCCESS=0 S ^XTMP(NAMESPC,"CONFIG","FAILED")=$G(^XTMP(NAMESPC,"CONFIG","FAILED"))+1 - I SUCCESS=1 S ^XTMP(NAMESPC,"CONFIG","SUCCESS")=$G(^XTMP(NAMESPC,"CONFIG","SUCCESS"))+1 - Q -STOPIT() ; Checks if user requested task to stop - N X,STOPIT - S STOPIT=0 - S X=$$S^%ZTLOAD - I X D ; - .S STOPIT=1 - .I $G(ZTSK) S ZTSTOP=1 - Q STOPIT -SEND(DFN) ; Send an ENROLLMENT/ELIGIBILITY QUERY to HEC for a veteran - ;Output: returns 1 on success, 0 on failure. - ; - I '$$ON^DGENQRY Q 0 - N LAST,DGQRY,MSGID,SUCCESS,SENT,ERROR - S SUCCESS=1,ERROR="" - I '$$LOCK^DGENQRY($G(DFN)) S SUCCESS=0 - S LAST=$$FINDLAST^DGENQRY(DFN) ; Find latest Enr. Query Log IEN - I LAST,$$GET^DGENQRY(LAST,.DGQRY) ; - D:SUCCESS - .S SENT=$$MSG^DGENQRY1(DFN,.MSGID,.ERROR) - .I 'SENT S SUCCESS=0 Q - .S DGQRY("DFN")=DFN - .S DGQRY("SENT")=SENT - .S DGQRY("STATUS")=0 - .S DGQRY("MSGID")=MSGID - .S DGQRY("NOTIFY")=$G(NOTIFY) - .S DGQRY("FIRST")=$S($G(FIRST):FIRST,1:SENT) - .S DGQRY("RESPONSE")="" - .S DGQRY("RESPONSEID")="" - .I '$$LOG^DGENQRY(.DGQRY) S SUCCESS=0 Q - D UNLOCK^DGENQRY($G(DFN)) - Q SUCCESS -ABORTMSG ; Send the user aborted message: - N NAMESPC,NAMESPCN,TMP,XMY,XMDUZ,XMTEXT,XMSUB - S NAMESPC=$$NAMESPC - S NAMESPCN=$P(NAMESPC,"DG",2) - S XMY(DUZ)="",XMDUZ="DG PACKAGE",XMTEXT="TMP("_NAMESPCN_"," - S XMSUB="DG*5.3*"_NAMESPCN_": DOD CLEANUP - PROCESS STOPPED BY USER" - S TMP(NAMESPCN,1)="CLEANUP PROCESSING" - S TMP(NAMESPCN,2)="------------------" - S TMP(NAMESPCN,3)="" - S TMP(NAMESPCN,4)="The cleanup process was aborted prematurely. Here is the current status:" - S TMP(NAMESPCN,5)="" - S TMP(NAMESPCN,6)=" Start Date/Time: "_$$FMTE^XLFDT(+$G(^XTMP(NAMESPC,"CONFIG","START TIME")),"P") - S TMP(NAMESPCN,7)=" End Date/Time: "_$$FMTE^XLFDT(+$G(^XTMP(NAMESPC,"CONFIG","ABORT TIME")),"P") - S TMP(NAMESPCN,8)="" - S TMP(NAMESPCN,9)="Current Counts: " - S TMP(NAMESPCN,10)=" Total Patient Records Processed: "_+$G(^XTMP(NAMESPC,"CONFIG","TOTPR")) - S TMP(NAMESPCN,11)=" Total Anomalies Corrected: "_+$G(^XTMP(NAMESPC,"CONFIG","SUCCESS")) - S TMP(NAMESPCN,12)=" Percentage Completed: "_+$G(^XTMP(NAMESPC,"CONFIG","PERCENT COMPLETE"))_"%" - S TMP(NAMESPCN,13)="" - S TMP(NAMESPCN,14)="" - D ^XMD - Q -DONEMSG ; Send the user aborted message: - N NAMESPC,NAMESPCN,TMP,XMY,XMDUZ,XMTEXT,XMSUB - S NAMESPC=$$NAMESPC - S NAMESPCN=$P(NAMESPC,"DG",2) - S XMY(DUZ)="",XMDUZ="DG PACKAGE",XMTEXT="TMP("_NAMESPCN_"," - S XMSUB="DG*5.3*"_NAMESPCN_": DOD CLEANUP - SUMMARY REPORT" - S TMP(NAMESPCN,1)="CLEANUP PROCESSING" - S TMP(NAMESPCN,2)="------------------" - S TMP(NAMESPCN,3)="" - S TMP(NAMESPCN,4)="The cleanup has run to completion. Here are the results:" - S TMP(NAMESPCN,5)="" - S TMP(NAMESPCN,6)=" Start Date/Time: "_$$FMTE^XLFDT(+$G(^XTMP(NAMESPC,"CONFIG","START TIME")),"P") - S TMP(NAMESPCN,7)=" End Date/Time: "_$$FMTE^XLFDT(+$G(^XTMP(NAMESPC,"CONFIG","COMPLETE")),"P") - S TMP(NAMESPCN,8)="" - S TMP(NAMESPCN,9)="Current Counts: " - S TMP(NAMESPCN,10)=" Total Patient Records Processed: "_+$G(^XTMP(NAMESPC,"CONFIG","TOTPR")) - S TMP(NAMESPCN,11)=" Total Anomalies Corrected: "_+$G(^XTMP(NAMESPC,"CONFIG","SUCCESS")) - S TMP(NAMESPCN,12)=" Percentage Completed: 100%" - S TMP(NAMESPCN,13)="" - S TMP(NAMESPCN,14)="" - D ^XMD - Q diff -auBN ./r1/DG53522P.m ./r2/r/DG53522P.m --- ./r1/DG53522P.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53522P.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,14 +0,0 @@ -DG53522P ;ALB/DW - DG*5.3*522 POST-INSTALL; 6/2/2003 - ;;5.3;Registration;**522**;Aug 13, 1993 -ENV ;Environment check - S XPDABORT="" - D PRGCHK(.XPDABORT) - I XPDABORT="" K XPDABORT - Q - ; -PRGCHK(XPDABORT) ;Checks programmer variables - I '$G(DUZ)!($G(DUZ(0))'="@") D - . W !,$C(7)," To insure that data dictionary changes contained in this patch" - . W !," are installed correctly, DUZ(0) must be equal the ""@"" symbol!",! - . S XPDABORT=2 - Q diff -auBN ./r1/DG53528P.m ./r2/r/DG53528P.m --- ./r1/DG53528P.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53528P.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,156 +0,0 @@ -DG53528P ;ALB/ERC - COMBAT VET PRE & POSTINSTALLS ;7/22/03 - ;;5.3;Registration;**528**; Aug 13, 1993 - ; -PRE ;add 5 new entries to the INCONSISTENT DATA ELEMENTS file (#38.6) - ;to alert users that critical dates for the determination of CV - ;status are either imprecise or missing - ; - ;first check to see if patch already installed - if so do not - ;add these new entries - I $$PATCH^XPDUTL("DG*5.3*528") Q - N DGK,DGWP - K XPDABORT - F DGK=67:1:71 I $D(^DGIN(38.6,DGK)) Q:$G(XPDABORT)=2 D - . D BMES^XPDUTL(" ** Internal Entry # "_DGK_" already exists in file #38.6, contact NVS **") - . S XPDABORT=2 - I $G(XPDABORT)'=2 D - . D BMES^XPDUTL(" >> Adding new entries into the INCONSISTENT DATA ELEMENTS file (#38.6).") - . D ADD - Q -ADD ;set up FDA arrays for the addition of new entries in 38.6 - N DG,DG67,DG68,DG69,DG70,DG71,DGERR,DGFDA,DGIEN,DGWORD,DGX - D SET - F DGX=DG67,DG68,DG69,DG70,DG71 D - . K DGFDA - . S DGFDA(38.6,"+1,",.01)=$P(DGX,U) - . S DGFDA(38.6,"+1,",2)=$P(DGX,U,2) - . S DGFDA(38.6,"+1,",50)="DGWP" - . S DGWP(1,0)=DGWORD - . I $D(DGFDA) D UPD - Q -UPD ;call UPDATE^DIE - S DGIEN(1)=$P(DGX,U,3) - D UPDATE^DIE("E","DGFDA","DGIEN","DGERR") - I $D(DGERR) D BMES^XPDUTL(" >>> ERROR! "_$P($G(DGX),U)_" not added to file #38.6"),MES^XPDUTL(DGERR("DIERR",1)_": "_DGERR("DIERR",1,"TEXT",1)) Q - D BMES^XPDUTL(" "_$P($G(DGX),U)_" successfully added.") - Q -SET ;set the entry field values into variables - N DGA,DGB - S DGA="NO CV, CHECK " - S DGB="Imprecise or Missing" - S DGWORD="Combat Vet status cannot be determined if critical dates are missing or imprecise." - S DG67=DGA_"SERVICE SEP DATE^SERVICE SEPARATION DATE [LAST] "_DGB_"^"_67 - S DG68=DGA_"COMBAT TO DATE^COMBAT TO DATE "_DGB_"^"_68 - S DG69=DGA_"YUGOSLAV TO DATE^YUGOSLAVIA TO DATE "_DGB_"^"_69 - S DG70=DGA_"SOMALIA TO DATE^SOMALIA TO DATE "_DGB_"^"_70 - S DG71=DGA_"PERS GULF TO DATE^PERSIAN GULF TO DATE "_DGB_"^"_71 - Q - ; -POST ;post install routine for Combat Veteran - will loop through the - ;Patient file and populate field .5295 (Combat Veteran End Date) - ;for any veterans who are eligible (.5296 will be also stuffed with - ;the current date in SERCV^DGCV and DELCV^DGCV) - N DFN,DG,DGDONE,ZTSAVE - D POST1 Q:DGDONE - D POSTQ - Q -POST1 ;check to see if process already finished, already started or currently - ;running - N DGMSG,DGSTAT,DGTASK - S DGDONE=0 - I '$D(^XTMP("DGCV")) Q - I $G(^XTMP("DGCV","DONE"))=1 D Q - . S DGMSG="COMBAT VET INITIAL SEEDING COMPLETED ON PREVIOUS INSTALL. EXITING" - . D BMES^XPDUTL(.DGMSG) - . S DGDONE=1 - I $G(DGREQ)'=1 K ^XTMP("DGCV") - S DGTASK=$G(^XTMP("DGCV","TASK")) - I DGTASK'="" D - . S DGSTAT=$$ACTIVE(DGTASK) - . I DGSTAT>0 S DGMSG="Task: "_DGTASK_" is currently running, cannot start duplicate process." D - . . D BMES^XPDUTL(.DGMSG) - . . S DGDONE=1 - Q -ACTIVE(DGTASK) ;check to see if task already running - ; DGTASK - taskman task number - ; output - (1,0) is the task running? - N DGSTAT,Y,ZTSK - S DGSTAT=0,ZTSK=DGTASK - D STAT^%ZTLOAD - S Y=ZTSK(1) - I Y=0 S DGSTAT=-1 - I ",1,2,"[(","_Y_",") S DGSTAT=1 - I ",3,5,"[(","_Y_",") S DGSTAT=0 - Q DGSTAT -POSTQ ;queue the task - N DGTXT,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK - S ZTRTN="LOOP^DG53528P",ZTIO="",ZTDTH=$$NOW^XLFDT() - S ZTDESC="COMBAT VET INITIAL DATA SEEDING" - S ZTSAVE("POS1")="",ZTSAVE("XPDQUES")="" - S ZTSAVE("*")="" - D NOW^%DTC - S ZTDTH=% - D ^%ZTLOAD - S ^XTMP("DGCV","TASK")=ZTSK - S DGTXT(1)="Task: "_ZTSK_" queued." - D BMES^XPDUTL(.DGTXT) - Q -LOOP ; - N DGC,DGT,X,X1,X2,ZTSTOP - S (DFN,DGC,DGT,ZTSTOP)=0 - S DFN=+$G(^XTMP("DGCV","DFN")) - S X1=DT,X2=30 D C^%DTC - S ^XTMP("DGCV",0)=X_"^"_$$DT^XLFDT_"^Combat Veteran Initial Patient File Seeding - DG*5.3*528" - I '$D(^XTMP("DGCV","START")) S ^XTMP("DGCV","START")=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - I $G(XPDQUES("POS1","B"))]"" S IOP=$G(XPDQUES("POS1","B")) ;result of install question - I $G(IOP)]"" D - . S IOP=$O(^%ZIS(1,"B",IOP,"")) - . S IOP="`"_IOP - I $G(IOP)]"" D - . S ^XTMP("DGCV","DEVICE")=IOP - . I '$D(^XTMP("DGCV",0)) D - . . N X,X1,X2 - . . S X1=DT,X2=60 D C^%DTC - . . S ^XTMP("DGCV",0)=X_"^"_$$DT^XLFDT_"^Combat Veteran Initial Patient File Seeding - DG*5.3*528" - ; - F S DFN=$O(^DPT(DFN)) Q:+DFN=0!(ZTSTOP) D - . S DG=0 - . S DGT=DGT+1 ;count of records checked - . S ^XTMP("DGCV","DFN")=DFN ;current DFN - . I (DGT#1000=0),($$S^%ZTLOAD) S ZTSTOP=1 ;is there a stop request? - . S DG=$$CVELIG^DGCV(DFN) - . I +$G(DG)=1 D - . . S DGSRV=$$GET1^DIQ(2,DFN_",",.327,"I") - . . I $G(DGSRV)']"" Q - . . D SETCV^DGCV(DFN,DGSRV) - . . S DGC=DGC+1 - . S ^XTMP("DGCV","COUNT")=DGT_"^"_DGC - . Q:$G(DGSRV)']"" - . I $G(DG)=0!($G(DG)=1)!($G(DG)']"") Q - . D RPT^DGCV1(DG) - S $P(^XTMP("DGCV","START"),U,2)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - I ZTSTOP D Q - . N DGMSG,XMDUZ,XMSUB,XMTEXT,XMY - . S XMSUB="COMBAT VET INITIAL DATA SEEDING" - . S DGMSG(1)="Patch DG*5.3*528" - . S DGMSG(2)="Combat Veteran Initial database seeding was interrupted by" - . S DGMSG(3)="user request. Please re-start by using the following command at the" - . S DGMSG(4)="programmer prompt." - . S DGMSG(5)="D REQUE^DG53528P" - . D BMES^XPDUTL(.DGMSG) - . D SENDMSG^XMXAPI(DUZ,XMSUB,"DGMSG",DUZ) - D REPORT^DGCV1 - N DGMSG - S DGMSG(1)="" - S DGMSG(2)=" Patient file seeding completed...." - S XMSUB="COMBAT VET INITIAL DATA SEEDING - DG*5.3*528" - D SENDMSG^XMXAPI(DUZ,XMSUB,"DGMSG",DUZ) - D BMES^XPDUTL(.DGMSG) - S ^XTMP("DGCV","DONE")=1 - K DG,DGCOM,DGCVDT,DGGULF,DGSOM,DGSRV,DGYUG - Q -REQUE ;requeue initial seeding if interrupted - N DGREQ - S DGREQ=1 - D POST - Q diff -auBN ./r1/DG53558.m ./r2/r/DG53558.m --- ./r1/DG53558.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53558.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,266 +0,0 @@ -DG53558 ;ALB/GN - DG*5.3*558 CLEANUP FOR DUPE MEANS TEST FILE ; 7/16/04 11:17am - ;;5.3;Registration;**558,579**;Aug 13, 1993 - ; - ; Read through the Mean Test file (#408.31) via the "C" xref. - ; Search for duplicate & Bad tests and delete them. Duplicates are - ; defined as more than one test for the same patient for the same day - ; and the same status. All dupes but the primary test will be - ; deleted and when no primary test on a given day then the last - ; transmission for that day will be kept - ; - ; Bad tests are defined as those that have a NULL status code in - ; the 0 node of file 408.31. - ; - ; DG*5.3*579 - changes were made to fix a problem when future dated - ; tests come in and flip a test from Primary to Non-Primary. This - ; should not be done for IVM converted cases. This patch will - ; find those IVM tests and flip them back to Priamry and flip the - ; future test that caused this back to Non-Primary. - Q -TEST ; Entry point for testing this routine - S TESTING=1 -EN ; Entry point for purging Duplicate Means Tests - ; - N QUIT,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT - S CHKPNT=5 - W !,"Do you want to process a group of "_CHKPNT_" duplicates and stop? " - K DIR - S DIR("?",1)=" Enter Y to process at least "_CHKPNT_" dupes and stop the utility. This will " - S DIR("?",2)=" allow you to verify the cleanup in small steps. Enter N to process the " - S DIR("?")=" remainder of the file to completion." - S DIR(0)="Y" D ^DIR - I $D(DTOUT)!$D(DUOUT) W !,"Cancelled...",! Q - ; - S:'Y CHKPNT=0 ;do not use check points - ; - ; setup TM variables and Load - S ZTRTN=$S($G(TESTING):"QUET^DG53558",1:"QUE^DG53558") - S ZTDESC="Cleanup Duplicates in the Means Test file" - S ZTIO="" - S ZTSAVE("CHKPNT")="" - ; - W !!,ZTDESC,! - ;check if already running or completed. - S QUIT=$$CHKSTAT(0) - Q:QUIT - D ^%ZTLOAD - L -^XTMP($$NAMSPC) - I $D(ZTSK) D - . W !,"This request queued as Task # ",ZTSK,! - Q - ; -POST ; - N ZTDTH,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTQUEUED,ZTSAVE,CHKPNT - D MES^XPDUTL("") - D MES^XPDUTL("=====================================================") - D MES^XPDUTL("Queuing Dupe Income Test Purge Utility.....") - I $$CHKSTAT(1) D Q - . D BMES^XPDUTL("ABORTING Post Install Utility Queuing") - . D MES^XPDUTL("=====================================================") - S ZTRTN="QUE^DG53558" - S ZTDESC="Cleanup Duplicates in the Means Test file" - S ZTIO="",ZTDTH=$H - S CHKPNT=0,ZTSAVE("CHKPNT")="" - D ^%ZTLOAD - L -^XTMP($$NAMSPC) - D MES^XPDUTL("This request queued as Task # "_ZTSK) - D MES^XPDUTL("=====================================================") - D MES^XPDUTL("") - Q - ; -QUET ; Entry point for taskman (testing mode) - S TESTING=1 -QUE ; Entry point for taskman (live mode) - N NAMSPC S NAMSPC=$$NAMSPC^DG53558 - L +^XTMP(NAMSPC):10 I '$T D Q ;quit if can't get a lock - . S $P(^XTMP(NAMSPC,0,0),U,5)="NO LOCK GAINED" - N QQ,ZTSTOP,XREC,MTIEN,DIK,DA,IVMTOT,IVMPUR,BEGTIME,PURGDT,IVMBAD - N DFN,TMP,ICDT,MTST,IVMDUPE,COUNT,PRI,TYPE,TYPNAM,DELETED,IVMIEN,PRIM - N SRCE,TMPIVM,XX,IVMCV,MAX,IVMIEND,IVMPFL,LINK,LTYP,LTNAM - S TESTING=+$G(TESTING) - ; - ;get last run info if exists - S XREC=$G(^XTMP(NAMSPC,0,0)) - S DFN=$P(XREC,U,1) ;last REC processed - S IVMTOT=+$P(XREC,U,2) ;total records processed - S IVMPUR=+$P(XREC,U,3) ;total dupe records purged - S IVMBAD=+$P(XREC,U,7) ;total bad records purged - S IVMPFL=+$P(XREC,U,8) ;total PRIM records fliped - S IVMDUPE=IVMPUR - ; - ;setup XTMP according to stds. & for 60 day expiration - D SETUPX^DG53558M(60) - ; - ;init status field and start date & time if null - S $P(^XTMP(NAMSPC,0,0),U,5,6)="RUNNING^" - S:$P(^XTMP(NAMSPC,0,0),U,4)="" $P(^XTMP(NAMSPC,0,0),U,4)=$$NOW^XLFDT - ; - ;drive through "C" XREF level of MT file - S ZTSTOP=0,DELETED=0 - F QQ=1:1 S DFN=$O(^DGMT(408.31,"C",DFN)) Q:'DFN D Q:ZTSTOP - . I $G(CHKPNT)>1,IVMPUR>IVMDUPE,IVMPUR-CHKPNT>IVMDUPE S ZTSTOP=1 Q - . K TMP,TMPIVM - . S IVMTOT=IVMTOT+1 - . ; - . ;build local TMP and prioritize dupes - . S MTIEN=0 - . F S MTIEN=$O(^DGMT(408.31,"C",DFN,MTIEN)) Q:'MTIEN D - . . I '$D(^DGMT(408.31,MTIEN,0)) K ^DGMT(408.31,"C",DFN,MTIEN) Q - . . S ICDT=$P(^DGMT(408.31,MTIEN,0),"^",1) - . . S MTST=$P(^DGMT(408.31,MTIEN,0),"^",3) - . . S PRI=+$G(^DGMT(408.31,MTIEN,"PRIM")) - . . S SRCE=+$P(^DGMT(408.31,MTIEN,0),"^",23) - . . S MAX=0 - . . S:$D(^DGMT(408.31,MTIEN,"C")) MAX=$O(^DGMT(408.31,MTIEN,"C",""),-1) - . . S IVMCV=0 ;init IVM converted flag to no DG*5.3*579 - . . F XX=1:1:MAX D Q:IVMCV - . . . S:^DGMT(408.31,MTIEN,"C",XX,0)["Z06 MT via Edb" IVMCV=1 - . . I SRCE=2,IVMCV D ;IVM converted test from EDB - . . . S TMPIVM(DFN,ICDT,MTST)=MTIEN,TMPIVM(DFN,ICDT)=MTIEN - . . . S PRI=1 ;set as PRIMARY - . . ; - . . ;test for null MT status & flag as BAD and delete - . . I MTST="" D Q - . . . S TYPE=$P($G(^DGMT(408.31,MTIEN,0)),"^",19),TYPNAM="" - . . . S:TYPE]"" TYPNAM=$G(^DG(408.33,TYPE,0)) - . . . D DELBAD(MTIEN,DFN,.IVMBAD,.DELETED) - . . . Q:'DELETED - . . . S ^XTMP(NAMSPC,DFN,ICDT,999999,MTIEN,"BAD")=TYPE - . . . S ^XTMP(NAMSPC_".DET",DFN,ICDT,MTIEN,"BAD")=TYPNAM - . . . S $P(^XTMP(NAMSPC,0,0),U,7)=IVMBAD - . . ; - . . S COUNT=+$G(TMP(DFN,ICDT,MTST))+1 - . . S TMP(DFN,ICDT,MTST)=COUNT - . . S TMP(DFN,ICDT,MTST,MTIEN)=PRI - . . S:PRI TMP(DFN,ICDT,MTST,"P")=MTIEN - . ; - . ;drive thru TMP and delete all dupes, but last one per day per sts - . S ICDT="" - . F S ICDT=$O(TMP(DFN,ICDT)) Q:ICDT="" D - . . S MTST="" - . . ; - . . ;if this is the IVM test that is set to not prim, then flip it - . . S IVMIEND=$G(TMPIVM(DFN,ICDT)) ;DG*5.3*579 - . . I IVMIEND D - . . . D SETPRIM(IVMIEND,1,.IVMPFL) - . . . S LINK=$P($G(^DGMT(408.31,IVMIEND,2)),"^",6) - . . . D:LINK SETPRIM(LINK,1,.IVMPFL) ;set any linked test to PRIM - . . ; - . . F S MTST=$O(TMP(DFN,ICDT,MTST)) Q:MTST="" D - . . . ;keep at least one test per day per status, even if not PRIM - . . . D:'$D(TMP(DFN,ICDT,MTST,"P")) SETPRI(.TMP) - . . . ; drive thru ien's and del dupes - . . . S MTIEN=0 - . . . F S MTIEN=$O(TMP(DFN,ICDT,MTST,MTIEN)) Q:'MTIEN D - . . . . S PRIM=$G(^DGMT(408.31,MTIEN,"PRIM")) - . . . . S LINK=$P($G(^DGMT(408.31,MTIEN,2)),"^",6) - . . . . ; - . . . . ;if this ien is primary & it is not the IVM test or Linked to - . . . . ;the IVM test, then it should be flipped back to Not Primary - . . . . I IVMIEND,PRIM,MTIEN'=IVMIEND,LINK'=IVMIEND D ;DG*5.3*579 - . . . . . D SETPRIM(MTIEN,0,.IVMPFL) - . . . . . S TMP(DFN,ICDT,MTST,MTIEN)=0 - . . . . ; - . . . . I TMP(DFN,ICDT,MTST,"P")'=MTIEN D - . . . . . S TYPE=$P($G(^DGMT(408.31,MTIEN,0)),"^",19),TYPNAM="" - . . . . . S:TYPE]"" TYPNAM=$G(^DG(408.33,TYPE,0)) - . . . . . D DELMT^DG53558M(MTIEN,DFN,.IVMPUR,.DELETED,.LINK) - . . . . . Q:'DELETED - . . . . . S ^XTMP(NAMSPC_".DET",DFN,ICDT,MTIEN)=TYPNAM - . . . . . I LINK,'$D(^DGMT(408.31,LINK,0)) S LINK=0 - . . . . . Q:'LINK - . . . . . S LTYP=$P($G(^DGMT(408.31,LINK,0)),"^",19),LTNAM="" - . . . . . S:LTYP LTNAM=$G(^DG(408.33,LTYP,0)) - . . . . . S ^XTMP(NAMSPC_".DET",DFN,ICDT,LINK)=LTNAM - . . . . M ^XTMP(NAMSPC,DFN,ICDT,MTST)=TMP(DFN,ICDT,MTST) - . ; - . ;update last processed info - . S $P(^XTMP(NAMSPC,0,0),U,1,3)=DFN_U_IVMTOT_U_IVMPUR - . S $P(^XTMP(NAMSPC,0,0),U,7,8)=IVMBAD_U_IVMPFL - . ; - . ;check for stop request after every 100 processed DFN recs - . I QQ#100=0 D - . . S:$$S^%ZTLOAD ZTSTOP=1 - . . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP") - ; - ;set status and mail stats - I ZTSTOP S $P(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT - E S $P(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT - D MAIL^DG53558M - K TESTING - L -^XTMP($$NAMSPC) - Q - ; - ;DG*5.3*579 -SETPRIM(DA,PR,IVMP) ; set an Income Test (in #408.31) to either Prim or Not - Q:'$D(DA)!'$D(PR) - N DR,DIE,DGDATA,DGPRI - S DGPRI=$G(^DGMT(408.31,DA,"PRIM")) - Q:DGPRI=PR ;quit if already at that sts - S IVMP=$G(IVMP)+1 - S DGDATA="FLIPPED TO "_$S(PR=0:"NOT PRIMARY",1:"PRIMARY") - S:$D(NAMSPC) ^XTMP(NAMSPC_".DET",DFN,ICDT,DA)=DGDATA - S DR="2////"_PR,DIE="^DGMT(408.31," - D:'$G(TESTING) ^DIE - Q - ; -SETPRI(TMP) ;indicate like a primary (in TMP) to avoid it from being deleted - N IEN - S IEN=$O(TMP(DFN,ICDT,MTST,""),-1) - S TMP(DFN,ICDT,MTST,IEN)=1 - S TMP(DFN,ICDT,MTST,"P")=IEN - Q - ; -DELBAD(IEN,DFN,PUR,DELETED) ; Kill Bad test - S DELETED=0 - Q:'$G(IEN) - S TESTING=+$G(TESTING,1),DFN=$G(DFN) - I 'TESTING S DELETED=$$DEL^DG53558M(IEN,.LINK,DFN) - S:TESTING DELETED=1 - Q:'DELETED - S IVMBAD=IVMBAD+1 - I '$D(ZTQUEUED) W !,"Deleting BAD IEN in 408.31 > ",IEN," for DFN > ",DFN - Q - ; -CHKSTAT(POST) ;check if job is running, stopped, or completed - N Y,DUOUT,DTOUT,QUIT,STAT,STIME,NAMSPC - S QUIT=0 - S NAMSPC=$$NAMSPC - L +^XTMP(NAMSPC):1 - I '$T D BMES^XPDUTL("*** ALREADY RUNNING ***") Q 1 - ; - ; get job status - S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,5) - S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,6) - ; - I POST D KILIT Q 0 ;DG*5.3*579 - ; - ;if job Completed and run from menu opt, ask to Re-Run - I STAT="COMPLETED" D - . W " was Completed on "_$$FMTE^XLFDT(STIME) - . W !," Do you want to Re-Run again?" - . K DIR - . S DIR("?",1)=" Entering Y, will delete the XTMP global where the previous cleanup" - . S DIR("?")=" information was stored and begin a new job, or N to cancel request" - . S DIR(0)="Y" D ^DIR - . I 'Y S QUIT=1 Q - . W !," ARE YOU SURE?" - . K DIR - . S DIR("?")="Enter Y to begin a new Job or N to cancel request" - . S DIR(0)="Y" D ^DIR - . I 'Y S QUIT=1 Q - . ;fall thru to re-run mode, kill ^XTMPs - . D KILIT - Q QUIT - ; -KILIT ; kill Xtmp work files for a re-run - S:'$D(NAMSPC) NAMSPC=$$NAMSPC^DG53558 - K ^XTMP(NAMSPC),^XTMP(NAMSPC_".DET") - Q - ; -STOP ; alternate stop method - S ^XTMP($$NAMSPC,0,"STOP")="" - Q - ; -NAMSPC() ; Return a consistent name space variable - Q "DG53558" diff -auBN ./r1/DG53558M.m ./r2/r/DG53558M.m --- ./r1/DG53558M.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53558M.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,240 +0,0 @@ -DG53558M ;ALB/GN - DG*5.3*558 CLEANUP UTILITES ; 7/16/04 11:14am - ;;5.3;Registration;**558,579**;Aug 13, 1993 - ; - ;DG*53.*579 - add line for records modified vs. deleted ones - ; Misc cleanup utilities - ; -DELMT(IEN,DFN,PUR,DELETED,LINK) ; Kill duplicate MT - S DELETED=0 - Q:'$G(IEN) - S TESTING=+$G(TESTING,1),DFN=$G(DFN) - S DELETED=$$DEL^DG53558M(IEN,.LINK,DFN) - Q:'DELETED - S PUR=PUR+1 - I '$D(ZTQUEUED) W !,"Deleting Dupe IEN in 408.31 > ",IEN," for DFN > ",DFN - Q - ; -DEL(IVMMTIEN,IVMLINK,DFN) ; delete 408.31 ien only, no income related files killed here - ; input: ien to be deleted - ; output: 1 = was deleted - ; 0 = was not deleted - N DA,DIK,IVMTYP - S DFN=$G(DFN) - S IVMTYP=$P($G(^DGMT(408.31,IVMMTIEN,0)),"^",19) ;test type - S IVMLINK=$P($G(^DGMT(408.31,IVMMTIEN,2)),"^",6) - ;don't delete copay test linked to valid means test directly - I IVMTYP=2,IVMLINK,$D(^DGMT(408.31,IVMLINK,0)) Q 0 - ; - S DA=IVMMTIEN,DIK="^DGMT(408.31," D:'$G(TESTING) ^DIK ;del MT here - D:DFN D4081275(DFN) - ; - ;delete linked RXCT here after above delete of the MT - I IVMTYP=1,IVMLINK D - . S DA=IVMLINK,DIK="^DGMT(408.31," D:'$G(TESTING) ^DIK - . D:DFN D4081275(DFN) - ; - Q 1 - ; -D4081275(DFN) ; Deletes SPOUSE Effective date multiple entries that may exist - ; and point to the MT just deleted. - ; - Q:'$D(^DPT(DFN,0)) - N R12,EIEN,ENODE,QUIT,DA,DIK - S R12=0 - F S R12=$O(^DGPR(408.12,"B",DFN,R12)) Q:'R12 D - . Q:$P($G(^DGPR(408.12,R12,0)),"^",2)'=2 ;only process spouse - . ; drive through the Effective Date Multiple in ien reverse order - . S EIEN="A",QUIT=0 - . F S EIEN=$O(^DGPR(408.12,R12,"E",EIEN),-1) Q:'EIEN D Q:QUIT - . . S ENODE=$G(^DGPR(408.12,R12,"E",EIEN,0)) - . . Q:+$P(ENODE,"^",2) ;active flag - . . Q:'+$P(ENODE,"^",4) ;no MT ien - . . Q:$D(^DGMT(408.31,$P(ENODE,"^",4),0)) ;points to valid MT - . . ; if inactive and does not point to a valid MT, delete this - . . ; effective date multiple rec from 408.1275 - . . S DA=EIEN,DA(1)=R12,DIK="^DGPR(408.12,"_DA(1)_",""E""," - . . D:'$G(TESTING) ^DIK - . . I '$D(ZTQUEUED) W !,"Deleting BAD 408.1275 > ",R12,",",EIEN - . . S QUIT=1 - Q - ; -MAIL ; mail stats - N BTIME,HTEXT,TEXT,NAMSPC,LIN,TYPNAM,MSGNO,IVMBAD,IVMPUR,IVMTOT,IVMPFL - S MSGNO=0 - S NAMSPC=$$NAMSPC^DG53558 - S IVMTOT=$P($G(^XTMP(NAMSPC,0,0)),U,2) - S IVMPUR=$P($G(^XTMP(NAMSPC,0,0)),U,3) - S BTIME=$P($G(^XTMP(NAMSPC,0,0)),U,4) - S STAT=$P($G(^XTMP(NAMSPC,0,0)),U,5) - S STIME=$P($G(^XTMP(NAMSPC,0,0)),U,6) - S IVMBAD=$P($G(^XTMP(NAMSPC,0,0)),U,7) - S IVMPFL=$P($G(^XTMP(NAMSPC,0,0)),U,8) - ; - D HDNG(.HTEXT,.MSGNO,.LIN) - D SUMRY(.LIN) - D MAILIT(HTEXT) - ; - D SNDDET - Q - ; -HDNG(HTEXT,MSGNO,LIN) ;build heading lines for mail message - K ^TMP(NAMSPC,$J,"MSG") - S LIN=0 - S HTEXT="Cleanup Dupes in the Means Test file "_STAT_" on " - S HTEXT=HTEXT_$$FMTE^XLFDT(STIME) - D BLDLINE(HTEXT,.LIN) - D BLDLINE("",.LIN) - I TESTING S TEXT="** TESTING **" D BLDLINE(TEXT,.LIN) - I MSGNO S TEXT="Message number: "_MSGNO D BLDLINE(TEXT,.LIN) - D BLDLINE("",.LIN) - I MSGNO D - . S TEXT="* = modified due to IVM Converted Test scenario" - . D BLDLINE(TEXT,.LIN) ;DG*5.3*579 - S MSGNO=MSGNO+1 - Q - ; -SUMRY(LIN) ;build summary lines for mail message - S TEXT=" Records Processed: "_$J($FN(IVMTOT,","),11) - D BLDLINE(TEXT,.LIN) - S TEXT="Duplicate Tests Purged: "_$J($FN(IVMPUR,","),11) - D BLDLINE(TEXT,.LIN) - S TEXT=" Null Tests Purged: "_$J($FN(IVMBAD,","),11) - D BLDLINE(TEXT,.LIN) - S TEXT="Primary status changed: "_$J($FN(IVMPFL,","),11) - D BLDLINE(TEXT,.LIN) - D BLDLINE("",.LIN) - D BLDLINE("",.LIN) - D BLDLINE("",.LIN) - ; - I (IVMPUR+IVMBAD+IVMPFL) D - . D BLDLINE("Detail changes to follow in subsequent mail messages.",.LIN) - Q - ; -SNDDET ;build and send detail messages limit under 2000 lines each - N BAD,DATE,GL,MAXLIN,MORE,NAME,SSN - S MAXLIN=1995,MORE=0 - D HDNG(.HTEXT,.MSGNO,.LIN) - ; - S GL=$NA(^XTMP(NAMSPC_".DET",1)),TYPNAM="" - F S GL=$Q(@GL) Q:GL="" Q:$QS(GL,1)'=(NAMSPC_".DET") D - . S MORE=1 ;at least 1 more line to send - . S DFN=$QS(GL,2) - . S ICDT=$QS(GL,3) - . S MTIEN=$QS(GL,4) - . S BAD=$QS(GL,5) - . S SSN=$P($G(^DPT(DFN,0)),"^",9),NAME=$P($G(^DPT(DFN,0)),"^") - . S DATE=$$FMTE^XLFDT(ICDT) - . S TYPNAM=$G(@GL) - . S TEXT=$S(TYPNAM["PRIMARY":"* Prim> ",1:" Dupe> ") - . S:BAD="BAD" TEXT=" Null> " - . S TEXT=TEXT_"ssn: "_SSN_" "_$J(TYPNAM,22)_" date: "_DATE_" ien: "_MTIEN - . D BLDLINE(TEXT,.LIN) - . ;max lines reached, print a msg - . I LIN>MAXLIN D MAILIT(HTEXT),HDNG(.HTEXT,.MSGNO,.LIN) S MORE=0 - ; - ;print final message if any to print - D MAILIT(HTEXT):MORE - Q - ; -BLDLINE(TEXT,LIN) ;build a single line into TMP message global - S LIN=LIN+1 - S ^TMP(NAMSPC,$J,"MSG",LIN)=TEXT - Q -MAILIT(HTEXT) ; send the mail message - N XMY,XMDUZ,XMSUB,XMTEXT - S XMY(DUZ)="",XMDUZ=.5 - S XMSUB=HTEXT_" Results" - S XMTEXT="^TMP(NAMSPC,$J,""MSG""," - D ^XMD - Q - ; -MONITOR ; Monitor job while running - N IOINORM,IOINHI,IOUON,IOUOFF,IOBON,IOBOFF,IORVON,IORVOFF,IOHOME - N IOELEOL,NAMSPC,REC,IVMTOT,IVMPUR,STIME,IVMEND,RUN,IVMTOTAL,IVMLST - N STAT,IVMLINE,IVMBLNK,NOWTIM,%H,DTOUT,I,IVMLEN,IVMQUIT,TITLE,TLEN,X - N NOWTIME,PCT,TMP - S:'$D(U) U="^" - S NAMSPC=$$NAMSPC^DG53558 - S TMP=0 F IVMTOTAL=0:1 S TMP=$O(^DGMT(408.31,"C",TMP)) Q:'TMP - S IVMQUIT=0 - D SCRNSET - ; - F D Q:IVMQUIT - . ;check lock status - . L +^XTMP(NAMSPC):0 - . I '$T S RUN=1 - . E S RUN=0 - . L -^XTMP(NAMSPC) - . S REC=$G(^XTMP(NAMSPC,0,0)) - . S STAT=$P(REC,U,5) S:STAT="" STAT="NOT RUNNING" - . S IVMLST=$P(REC,U,1),IVMTOT=$P(REC,U,2),IVMPUR=$P(REC,U,3) - . S STIME=$P(REC,U,6),IVMBAD=$P(REC,U,7) - . S:IVMTOTAL>0 PCT=IVMTOT/IVMTOTAL - . S PCT=PCT*100 - . S NOWTIME=$$NOW^XLFDT - . I (RUN&(STAT'="RUNNING"))!('RUN&(STAT="RUNNING")) D - . . S STAT="ERRORED" - . D CLRSCR - . S $P(IVMBLNK," ",81)="" - . S IVMLINE=IVMBLNK - . S TITLE="Cleanup Duplicates in the Means Test file" - . S TLEN=(80-$L(TITLE)\2) - . W $$FMTE^XLFDT($$NOW^XLFDT,"2P") - . W ?65,"Completed ",$FN(PCT,"",0),"%",!! - . W ?TLEN,IOINHI,IOUON,TITLE,IOUOFF,IOINORM,! - . S IVMLINE=IVMBLNK - . S IVMLINE=$$FMTLINE(IVMLINE,4,"Status") - . S IVMLINE=$$FMTLINE(IVMLINE,12,"Total recs") - . S IVMLINE=$$FMTLINE(IVMLINE,24,"Dupes Purged") - . S IVMLINE=$$FMTLINE(IVMLINE,38,"Nulls Purged") - . S IVMLINE=$$FMTLINE(IVMLINE,52,"Last DFN") - . S IVMLINE=$$FMTLINE(IVMLINE,66,"Completed Time") - . W !!,IORVON,IVMLINE,IORVOFF - . S IVMLINE=IVMBLNK - . S IVMLINE=$$FMTLINE(IVMLINE,2,STAT) - . S IVMLINE=$$FMTLINE(IVMLINE,15,IVMTOT) - . S IVMLINE=$$FMTLINE(IVMLINE,28,IVMPUR) - . S IVMLINE=$$FMTLINE(IVMLINE,40,IVMBAD) - . S IVMLINE=$$FMTLINE(IVMLINE,52,IVMLST) - . S IVMLINE=$$FMTLINE(IVMLINE,64,$$FMTE^XLFDT(STIME,2)) - . W !,IVMLINE - . S IVMLINE=IVMBLNK - . W !,IVMLINE,!!!!!! - . K DIR - . S DIR("T")=5 - . W ?13,"screen refreshes automatically every "_DIR("T")_" seconds",! - . W !!,"Press "_IORVON_""_IORVOFF_" to Stop Monitor...",! - . S DIR(0)="EA" - . D ^DIR - . I '$D(DTOUT) S IVMQUIT=1 - . I STAT'="RUNNING" S IVMQUIT=1 - W @IOF - Q - ; -FMTLINE(IVMLINE,IVMTB,IVMTX) ; format a line - S IVMLEN=$L(IVMTX) - S IVMEND=IVMTB+IVMLEN-1 - S $E(IVMLINE,IVMTB,IVMEND)=IVMTX - Q IVMLINE - ; -SCRNSET ; setup screen variables - S:'$D(IOST(0)) IOST(0)="C-VT320" - S X="IOINORM;IOINHI;IOUON;IOUOFF;IOBON;IOBOFF;IORVON;IORVOFF;IOHOME" - S X=X_";IOELEOL" D ENDR^%ZISS - Q - ; -CLRSCR ; clear screen and return to normal - W IOHOME,IORVOFF,IOBOFF,IOUOFF,IOINORM,@IOF - S $X=0,$Y=0 - Q - ; -SETUPX(EXPDAY) ;Setup XTMP's according to standards and set expiration days - N BEGTIME,PURGDT,NAMSPC - S NAMSPC=$$NAMSPC^DG53558 - S BEGTIME=$$NOW^XLFDT() - S PURGDT=$$FMADD^XLFDT(BEGTIME,EXPDAY) - S ^XTMP(NAMSPC,0)=PURGDT_U_BEGTIME - S $P(^XTMP(NAMSPC,0),U,3)="Cleanup Duplicate Means Test File" - S ^XTMP(NAMSPC_".DET",0)=PURGDT_U_BEGTIME - S $P(^XTMP(NAMSPC_".DET",0),U,3)="Cleanup Duplicate Means Test File detail" - Q diff -auBN ./r1/DG53568A.m ./r2/r/DG53568A.m --- ./r1/DG53568A.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53568A.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,104 +0,0 @@ -DG53568A ;ALB/RMM - POST-INSTALL ROUTINE FOR SD ENCAP ; 03/24/2004 - ;;5.3;Registration;**568**;AUG 13, 1993 - ; -EN ; Entry point for the DG*5.3*568 Post-Install - ; - ; This routine will update the WORD-PROCESSING #3.5 field, in the - ; OPTION (#19) File for the following options (if present): - ; [ZDGYP SD GLOBAL ESTIMATOR] Global Estimator for Scheduling - ; [DGYP SD GLOBAL ESTIMATOR] Global Estimator for Scheduling - ; - ; Get IENs from OPTION File - N DGYP,ZDGYP,DGMSG,MCNT,DGNEW,DGERR,DGOUT - S DGYP=+$O(^DIC(19,"B","DGYP SD GLOBAL ESTIMATOR","")) - S ZDGYP=+$O(^DIC(19,"B","ZDGYP SD GLOBAL ESTIMATOR","")) - ; - S MCNT=1,DGMSG(MCNT)="Updating the description for option: Global Estimator for Scheduling" - S:DGYP>0 MCNT=MCNT+1,DGMSG(MCNT)="IEN = "_DGYP - S:ZDGYP>0 MCNT=MCNT+1,DGMSG(MCNT)="IEN = "_ZDGYP - D MES^XPDUTL(.DGMSG) - ; - D NEWTXT - D:DGYP>0 TXTUPDT(DGYP) - D:ZDGYP>0 TXTUPDT(ZDGYP) - ; - D BMES^XPDUTL("Post-Install Complete, the option text has been updated.") - Q -NEWTXT ; - ; Set up description array. - S DGNEW("WP",1)="In previous versions of PIMS, a patient's outpatient information has" - S DGNEW("WP",2)="been stored in various files in the VistA database. With the" - S DGNEW("WP",3)="requirement to checkout all outpatient encounters, it was necessary" - S DGNEW("WP",4)="to consolidate much of the common outpatient information into one" - S DGNEW("WP",5)="outpatient encounter file." - S DGNEW("WP",6)=" " - S DGNEW("WP",7)="In PIMS v5.3, the data will reside in the new OUTPATIENT" - S DGNEW("WP",8)="ENCOUNTER(#409.68) file as well as in the old data structures." - S DGNEW("WP",9)="This file will hold encounter data for all checked out encounters." - S DGNEW("WP",10)="This will include information from the following:" - S DGNEW("WP",11)=" " - S DGNEW("WP",12)=" o appointments: SDAPI - Appointment API" - S DGNEW("WP",13)=" o add/edits : ^SDV()" - S DGNEW("WP",14)=" o dispositions: ^DPT(patient,""DIS"",date/time)" - S DGNEW("WP",15)=" " - S DGNEW("WP",16)="The MUMPS global for this file is ^SCE." - S DGNEW("WP",17)=" " - S DGNEW("WP",18)=" " - S DGNEW("WP",19)="Also, as part of the checkout process, questions regarding" - S DGNEW("WP",20)="whether the encounter was related to a service-connected disability," - S DGNEW("WP",21)="Agent Orange, ionization and environmental contaminants from the" - S DGNEW("WP",22)="Persian Gulf war, will be asked when appropriate." - S DGNEW("WP",23)=" " - S DGNEW("WP",24)="This data will be stored in the new OUTPATIENT CLASSIFICATION" - S DGNEW("WP",25)="(#409.42) file in the ^SDD(409.42) global node." - S DGNEW("WP",26)=" " - S DGNEW("WP",27)=" " - S DGNEW("WP",28)="The purpose of this utility is the following:" - S DGNEW("WP",29)=" 1. estimate a one year rate of growth for" - S DGNEW("WP",30)=" ^SCE using as a base the encounter data" - S DGNEW("WP",31)=" for the previous 365 days" - S DGNEW("WP",32)=" " - S DGNEW("WP",33)=" 2. estimate a one year rate of growth for" - S DGNEW("WP",34)=" ^SDD(409.42) using as a base the encounter data" - S DGNEW("WP",35)=" for the previous 365 and the patient demographic" - S DGNEW("WP",36)=" information" - S DGNEW("WP",37)=" " - S DGNEW("WP",38)="Using these estimates, you can make a better determination" - S DGNEW("WP",39)="as to where to place this new ^SCE global and how large the" - S DGNEW("WP",40)="existing ^SDD global will grow." - S DGNEW("WP",41)=" " - S DGNEW("WP",42)="This utility will not affect the current v5.2 functionality in any" - S DGNEW("WP",43)="way. However, it is recommended that it be queued to run at non-peak" - S DGNEW("WP",44)="hours. After the estimations are calculated, the results will be" - S DGNEW("WP",45)="reported to the user via a MailMan message." - S DGNEW("WP",46)=" " - S DGNEW("WP",47)="Finally, in v5.3, the site will have the ability to capture provider" - S DGNEW("WP",48)="and diagnostic data as part of the checkout process. Capturing this" - S DGNEW("WP",49)="data will be site selectable. It is estimated that each provider and" - S DGNEW("WP",50)="each diagnosis captured for an encounter will use .05 1K blocks." - S DGNEW("WP",51)=" " - S DGNEW("WP",52)="NOTE: If the site does choose to capture provider data then nurses," - S DGNEW("WP",53)="social workers and other providers of care will need to have entries" - S DGNEW("WP",54)="in the NEW PERSON file and be assigned the PROVIDER security key." - S DGNEW("WP",55)="Assigning this key will allow selection of these providers during the" - S DGNEW("WP",56)="checkout process." - S DGNEW("WP",57)=" " - S DGNEW("WP",58)=" " - S DGNEW("WP",59)="The option should be executed by the IRM staff and is locked with the" - S DGNEW("WP",60)="DGYP IRM security key." - Q -TXTUPDT(OPTIEN) ; - ; Update the Word Processing Field - D WP^DIE(19,OPTIEN_",",3.5,"K","DGNEW(""WP"")","DGERR") - ; - ; Check for and Report any Errors - I $D(DGERR) D - . D BMES^XPDUTL("NOTE: An error occurred when updating the OPTION text.") - . D MSG^DIALOG("AS",.DGOUT,"","","DGERR") - . D MES^XPDUTL(.DGOUT) - . D BMES^XPDUTL("Please contact the VistA Help Desk.") - ; - ; Cleanup after each OPTION is updated - K DGNEW,DGERR,DGOUT,EASIEN,DGMSG - ; - Q diff -auBN ./r1/DG53588P.m ./r2/r/DG53588P.m --- ./r1/DG53588P.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53588P.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,39 +0,0 @@ -DG53588P ;BAY/JAT; Post-init; ; 4/9/04 11:12am - ;;5.3;Registration;**588**;Aug 13, 1993 -ENV ;Environment check point - S XPDABORT="" - D PROGCHK(.XPDABORT) - I XPDABORT="" K XPDABORT - Q - ; -PROGCHK(XPDABORT) ;checks for necessary programmer variables - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("Your programming variables are not set up properly.") - . D MES^XPDUTL("Installation aborted.") - . D MES^XPDUTL("*****") - . S XPDABORT=2 - Q - ; -POST ; - N DGIEN,DGSUB,DGNODE,DGPTR,DGDOMAIN,DIE,DA,DR,DGFOUND,DGNAME - S (DGIEN,DGFOUND)=0 - F S DGIEN=$O(^VAT(407.7,DGIEN)) Q:'DGIEN D - .S DGSUB=0 - .F S DGSUB=$O(^VAT(407.7,DGIEN,"R",DGSUB)) Q:'DGSUB D - ..S DGNODE=$G(^VAT(407.7,DGIEN,"R",DGSUB,0)) - ..Q:DGNODE="" - ..S DGPTR=$P(DGNODE,U,2) - ..Q:'DGPTR - ..S DGDOMAIN=$$GET1^DIQ(4.2,DGPTR_",",.01) - ..Q:DGDOMAIN'="IPDB-CHICAGO.VA.GOV" - ..S DGFOUND=1 - ..S DA(1)=DGIEN - ..S DA=DGSUB - ..S DR="2///0" - ..S DIE="^VAT(407.7,"_DA(1)_",""R""," - ..D ^DIE - ..S DGNAME=$P($G(^VAT(407.7,DGIEN,0)),U) - ..D MES^XPDUTL(DGNAME_" Record updated.") - I 'DGFOUND D MES^XPDUTL("No record found. Contact Vista Support.") - Q diff -auBN ./r1/DG53602S.m ./r2/r/DG53602S.m --- ./r1/DG53602S.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53602S.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,124 +0,0 @@ -DG53602S ;ALB/TDM,BRM - Combat Veteran End Date Sync ; 6/3/04 12:16pm - ;;5.3;Registration;**602**; Aug 13,1993 - ;This post install routine will loop through the "E" cross reference - ;of the PATIENT (#2) file and trigger a Z07 message to the HEC system - ;for all entries that have a value in the COMBAT VETERAN END DATE - ;(#.5295) field that is greater than 1/16/03. - Q - ; -EP ;Entry point - N OK - D CHK Q:'OK - D MSG - D QUETASK - Q - ; -QUETASK ;Queue the task - N TXT,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH - S ZTRTN="EP1^DG53602S",ZTIO="",ZTDTH=$$NOW^XLFDT() - S ZTDESC="CV END DATE SYNCHRONIZATION" - K ^XTMP("DG53602S") - D ^%ZTLOAD S ^XTMP("DG53602S","TASK")=ZTSK - S TXT(1)="Task: "_ZTSK_" Queued." - D BMES^XPDUTL(.TXT) - Q - ; -EP1 ;Entry point - N X1,X2,X,XCVDT,XIEN,TOT,CVDT,CNT,EVENT,IYR - S X1=DT,X2=60 D C^%DTC - S ^XTMP("DG53602S",0)=X_"^"_$$DT^XLFDT_"^DG*5.3*602 Combat Vet Information Sharing w/HEC" - S $P(^XTMP("DG53602S","DATE"),"^")=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - ; - ;Create index by patient. - I $D(^DPT("E")) D - . S (XCVDT,XIEN)=0 - . F S XCVDT=$O(^DPT("E",XCVDT)) Q:XCVDT="" D - . . F S XIEN=$O(^DPT("E",XCVDT,XIEN)) Q:XIEN="" D - . . . S ^XTMP("DG53602S","INDEX",XIEN)="" - ; - ;Loop through ^XTMP("DG53602S","INDEX") index. - I $D(^XTMP("DG53602S","INDEX")) D - . S (XIEN,TOT,CNT)=0,EVENT("ENROLL")=1 - . F S XIEN=$O(^XTMP("DG53602S","INDEX",XIEN)) Q:+XIEN=0 D - . . S CVDT=$P($G(^DPT(XIEN,.52)),"^",15) Q:'CVDT ;No CV End Date - . . S TOT=TOT+1,$P(^XTMP("DG53602S",1),"^")=TOT ;Tot records - . . Q:(CVDT<3030117) ;No CV END DT or CVDT0 D - . . S OK=0 - . . S TXT(1)="Task: "_TASKNUM_" is currently running the Combat Veteran End Date" - . . S TXT(2)="synchronization process. Duplicate processes cannot be started." - . . D BMES^XPDUTL(.TXT) - Q - ; -MSG ;create bulletin message in install file. - N TXT - S TXT(1)="This Post Install routine will queue a Z07 HL7 message to be sent to the" - S TXT(2)="Health Eligibility Center (HEC) for all entries in the PATIENT (#2) file" - S TXT(3)="that have a value in the COMBAT VETERAN END DATE (#.5295) field that is" - S TXT(4)="on or after 1/17/03." - S TXT(5)=" " - D BMES^XPDUTL(.TXT) - Q - ; -MAIL N SITE,STATN,SITENM,XMDUZ,XMSUB,XMY,XMTEXT,MSG,ADR - S SITE=$$SITE^VASITE,STATN=$P($G(SITE),"^",3),SITENM=$P($G(SITE),"^",2) - S:$$GET1^DIQ(869.3,"1,",.03,"I")'="P" STATN=STATN_" [TEST]" - S XMDUZ="CV END DATE SYNCHRONIZATION",XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*602)" - S (XMY(DUZ),XMY(.5))="" - S XMY("terry.moore3@med.va.gov")="",XMY("pat.wilson@med.va.gov")="" - S XMTEXT="MSG(" - S MSG(1)="Combat Veteran End Date synchronization process has completed successfully." - S MSG(1.5)="Task: "_$G(^XTMP("DG53602S","TASK")) - S MSG(2)="" - S MSG(3)="Site Station number: "_STATN - S MSG(4)="Site Name: "_SITENM - S MSG(5)="" - S MSG(6)="Process started at : "_$P($G(^XTMP("DG53602S","DATE")),"^",1) - S MSG(7)="Process completed at : "_$P($G(^XTMP("DG53602S","DATE")),"^",2) - S MSG(8)="Total Veterans processed : "_+$P($G(^XTMP("DG53602S",1)),"^",1) - S MSG(9)="Total Veterans queued for Z07: "_+$P($G(^XTMP("DG53602S",1)),"^",2) - D ^XMD - Q - ; -INCYR(XIEN) ;Get valid income year - N I,LMT,TMP,INCYR - I $D(^IVM(301.5,"APT",XIEN)) Q $O(^IVM(301.5,"APT",XIEN,""),-1) - F I=1,2,4 S LMT=$$LST^DGMTU(XIEN,,I) S:+$G(LMT) TMP($P(LMT,"^",2))="" - I $D(TMP) S LMT=$O(TMP(""),-1),INCYR=($E(LMT,1,3)-1)_"0000" Q INCYR - S INCYR=($E(DT,1,3)-1)_"0000" - Q INCYR - ; -ACTIVE(TASK) ;Checks if task is running - ; input -- The taskman ID - ; output -- 1=The task is running - ; 0=The task is not running - N STAT,ZTSK,Y - S STAT=0,ZTSK=+TASK - D STAT^%ZTLOAD - S Y=ZTSK(1) - I Y=0 S STAT=-1 - I ",1,2,"[(","_Y_",") S STAT=1 - I ",3,5,"[(","_Y_",") S STAT=0 - Q STAT diff -auBN ./r1/DG53625P.m ./r2/r/DG53625P.m --- ./r1/DG53625P.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53625P.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,24 +0,0 @@ -DG53625P ;TDM - Patch DG*5.3*625 Install Utility Routine ; 10/19/04 10:40am - ;;5.3;Registration;**625**; Aug 13,1993 - ; - Q -ADDMGRP ;Check for IB MEANS TEST mail group and add if not already there. - N MGRP,WPARY,FDA,ERR - S MGRP="IB MEANS TEST" - ; - D BMES^XPDUTL("Add '"_MGRP_"' mail group.") - K FDA,ERR - I $$FIND1^DIC(3.8,"","X",MGRP) D BMES^XPDUTL("'"_MGRP_"' entry already exists!") Q - S WPARY(1,0)="This mail group will receive Means Test error messages from integrated billing." - S WPARY(2,0)="errors and the editing/deletion of records which are associated with" - S WPARY(3,0)="Means Test/Category C billing." - ; - S FDA(3.8,"+1,",.01)=MGRP - S FDA(3.8,"+1,",3)="WPARY" - S FDA(3.8,"+1,",4)="PU" - S FDA(3.8,"+1,",5)=.5 - ; - D UPDATE^DIE("","FDA","","ERR") - I $D(ERR) D BMES^XPDUTL(MGRP_" not added! ERROR:"),MES^XPDUTL(ERR("DIERR",1)_": "_ERR("DIERR",1,"TEXT",1)) Q - D MES^XPDUTL("'"_MGRP_"' successfully added.") - Q diff -auBN ./r1/DG53B563.m ./r2/r/DG53B563.m --- ./r1/DG53B563.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53B563.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,116 +0,0 @@ -DG53B563 ;ALB/PJR - DOD Enhancement Post-Install ; 12/30/04 3:53pm - ;;5.3;Registration;**563**; Aug 13,1993 - ;This post install routine will loop through patient file (#2) - ;and delete the DEATH ENTERED BY field - ;for all entries that have NO value in the DATE OF DEATH field (#.351) - ;but DO have a value in the DEATH ENTERED BY field (#.352) - Q - ; -EP ;Entry point - N OK - D CHK Q:'OK - D MSG - D QUETASK - Q - ; -QUETASK ;Queue the task - N TXT,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH - S ZTRTN="EP1^DG53B563",ZTIO="",ZTDTH=$$NOW^XLFDT() - S ZTDESC="DOD ENHANCEMENT POST-INSTALL" - K ^XTMP("DG53B563") - D ^%ZTLOAD S ^XTMP("DG53B563","TASK")=ZTSK - S TXT(1)="Task: "_ZTSK_" Queued." - D BMES^XPDUTL(.TXT) - Q - ; -EP1 ;Entry point - N ZCNT,ZIEN,ZEND,ZDATE,ZEDATE,DA,DIE,DR,ZCK,ZII,ZXX,X - L +^XTMP("DG53B563"):1 E Q - S (ZIEN,ZCNT)=0 - S ZDATE=$$DT^XLFDT D DG53 - S ^XTMP("DG53B563",0)=ZCNT_U_ZDATE_U_X - S $P(^XTMP("DG53B563","DATE"),"^")=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - D LMINUS - ;Loop through patient file - F S ZIEN=$O(^DPT(ZIEN)) Q:'ZIEN D - .S ZXX=$G(^DPT(ZIEN,.35)),ZCK=0 I ZXX=""!ZXX Q - .F ZII=1,2,3,5 I $P(ZXX,U,ZII)]"" S ZCK=1 D - ..S DA=ZIEN,DIE="^DPT(",DR=".35"_ZII_"////@" D ^DIE - .I ZCK S ZCNT=ZCNT+1 ;Tot records updated - S $P(^XTMP("DG53B563","DATE"),"^",2)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - S ZDATE=$$DT^XLFDT,ZEDATE=$$FMTE^XLFDT(DT) D DG53 - S ^XTMP("DG53B563",0)=ZCNT_U_ZDATE_U_X - S ^XTMP("DG53B563","COMPLETED")=1 D MAIL - D DG53 S X="The "_X_" process is complete." - D BMES^XPDUTL(X) - Q - ; -CHK ;check for completion - N TXT,TASKNUM,STAT - S OK=1 L +^XTMP("DG53B563"):1 E D Q - .S OK=0 D DG53 S TXT(1)=X_" process has a lock table" - .S TXT(2)="problem. Nothing Done!" - .D BMES^XPDUTL(.TXT),LMINUS - ; - I $G(^XTMP("DG53B563","COMPLETED")) D Q - .S OK=0 D DG53 S TXT(1)=X_" process was completed in a" - .S TXT(2)="previous run. Nothing Done!" - .D BMES^XPDUTL(.TXT),LMINUS - ; - S TASKNUM=$G(^XTMP("DG53B563","TASK")) - I +TASKNUM D Q - .S STAT=$$ACTIVE(TASKNUM) - .I STAT>0 D - ..S OK=0 D DG53 - ..S TXT(1)="Task: "_TASKNUM_" is currently running the" - ..S TXT(2)=X_" process." - ..S TXT(3)="Duplicate processes cannot be started." - ..D BMES^XPDUTL(.TXT) - .D LMINUS - ; - D LMINUS Q - ; -MSG ;create bulletin message in install file. - N TXT - S TXT(1)="This Post Install routine will loop through the Patient (#2) file" - S TXT(2)="and delete the DEATH ENTERED BY field for all patients" - S TXT(3)="that have NO value in the DATE OF DEATH (#.531) field" - S TXT(4)="but DO have a value in the DEATH ENTERED BY field." - S TXT(5)=" " - D BMES^XPDUTL(.TXT) - Q - ; -MAIL N SITE,STATN,SITENM,XMDUZ,XMSUB,XMY,XMTEXT,MSG - S SITE=$$SITE^VASITE,STATN=$P($G(SITE),"^",3),SITENM=$P($G(SITE),"^",2) - S:$$GET1^DIQ(869.3,"1,",.03,"I")'="P" STATN=STATN_" [TEST]" - D DG53 S XMDUZ=X,XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*563)" - S (XMY(DUZ),XMY(.5))="" - S XMTEXT="MSG(" D DG53 - S MSG(1)="The "_X_" process" - S MSG(2)="has completed successfully." - S MSG(3)="Task: "_$G(^XTMP("DG53B563","TASK")) - S MSG(4)="" - S MSG(5)="Site Station number: "_STATN - S MSG(6)="Site Name: "_SITENM - S MSG(7)="" - S MSG(8)="Process started at : "_$P($G(^XTMP("DG53B563","DATE")),"^",1) - S MSG(8)="Process completed at : "_$P($G(^XTMP("DG53B563","DATE")),"^",2) - S MSG(10)="Total Veterans updated: "_+$G(^XTMP("DG53B563",0)) - D ^XMD - Q - ; - ; -ACTIVE(TASK) ;Checks if task is running - ; input -- The taskman ID - ; output -- 1=The task is running - ; 0=The task is not running - N STAT,ZTSK,Y - S STAT=0,ZTSK=+TASK - D STAT^%ZTLOAD - S Y=ZTSK(1) - I Y=0 S STAT=-1 - I ",1,2,"[(","_Y_",") S STAT=1 - I ",3,5,"[(","_Y_",") S STAT=0 - Q STAT -DG53 S X="DG*5.3*563 DOD Post-Install cleanup DEATH ENTERED BY" Q -LMINUS L -^XTMP("DG53B563") Q diff -auBN ./r1/DG53E451.m ./r2/r/DG53E451.m --- ./r1/DG53E451.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53E451.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,57 +0,0 @@ -DG53E451 ;BRM - Patch DG*5.3*451 Install Utility Routine #2 ; 4/14/04 8:16am - ;;5.3;Registration;**451**; Aug 13,1993 - ; - Q - ; -EDITINC ; edit a few entries to the INCONSISTENT DATA ELEMENTS file (#38.6) - N DGK,DGWP,ROOT,DGFDA,DGWP,DGIEN,DGERR,DGTITL - D BMES^XPDUTL(" >> Editing entries 37-40 in the INCONSISTENT DATA ELEMENTS file (#38.6)") - F DGK=37:1:40 D - .K DGFDA,ROOT,DGWP - .S ROOT="DGFDA(38.6,"""_DGK_","")" - .D @DGK Q:'$D(DGFDA) - .S DGIEN(1)=DGK - .S DGTITL=@ROOT@(.01) - .D UPDATE^DIE("E","DGFDA","DGIEN","DGERR") - .I $D(DGERR) D BMES^XPDUTL(" >>> ERROR! "_DGTITL_" could not be edited in file #38.6"),MES^XPDUTL(DGERR("DIERR",1)_": "_DGERR("DIERR",1,"TEXT",1)) Q - .D BMES^XPDUTL(" "_DGTITL_" successfully edited.") - Q -37 ; - S @ROOT@(.01)="POW DATA MISSING OR INCOMPLETE" - S @ROOT@(2)="PRISONER OF WAR STATUS INDICATED, RELATED DATA MISSING OR INCOMPLETE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results when the user responds YES to the WERE YOU A" - S DGWP(2,0)="PRISONER OF WAR prompt and any (or all) of the following prompts are" - S DGWP(3,0)="left unanswered: POW WAR, POW FROM DATE, POW TO DATE. This inconsistency " - S DGWP(4,0)="also results when an imprecise date (without at least month and year " - S DGWP(5,0)="precision) is entered." - Q -38 ; - S @ROOT@(.01)="POW DATES INCONSISTENT" - S @ROOT@(2)="'PRISONER OF WAR' STATUS INDICATED, TO DATE PRECEDES FROM DATE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results when the user responds YES to the WERE YOU A" - S DGWP(2,0)="A PRISONER OF WAR prompt and the 'from' date does not precede the 'to'" - S DGWP(3,0)="date." - Q -39 ; - S @ROOT@(.01)="COMBAT DATA MISSING/INCOMPLETE" - S @ROOT@(2)="COMBAT SERVICE INDICATED, RELATED DATA MISSING OR INCOMPLETE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results when the user responds YES to the IN COMBAT (Y/N)" - S DGWP(2,0)="and any (or all) of the following prompts are left unanswered: COMBAT" - S DGWP(3,0)="WHERE, COMBAT FROM DATE, COMBAT TO DATE. This inconsistency also results" - S DGWP(4,0)="when an imprecise date (without at least month and year precision) is" - S DGWP(5,0)="entered." - Q -40 ; - S @ROOT@(.01)="COMBAT DATES INCONSISTENT" - S @ROOT@(2)="COMBAT SERVICE INDICATED, TO DATE PRECEDES FROM DATE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results when the COMBAT (Y/N) prompt is answered YES" - S DGWP(2,0)="but the 'to' date precedes the 'from' date of service." - Q diff -auBN ./r1/DG53E574.m ./r2/r/DG53E574.m --- ./r1/DG53E574.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53E574.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,19 +0,0 @@ -DG53E574 ; BAY/JAT- Patch DG*5.3*574 Install Utility Routine ; 12/9/03 3:11pm - ;;5.3;Registration;**574**;AUG 13, 1993 - ; -ENV ;Main entry point for Environment check point. - ; - S XPDABORT="" - D PROGCHK(.XPDABORT) ;checks programmer variables - I XPDABORT="" K XPDABORT - Q - ; -PROGCHK(XPDABORT) ;checks for necessary programmer variables - ; - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("Your programming variables are not set up properly.") - . D MES^XPDUTL("Installation aborted.") - . D MES^XPDUTL("*****") - . S XPDABORT=2 - Q diff -auBN ./r1/DG53P425.m ./r2/r/DG53P425.m --- ./r1/DG53P425.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P425.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,146 +0,0 @@ -DG53P425 ;ALB/RPM - PATCH DG*5.3*425 INSTALL UTILITIES ; 8/21/03 4:52pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -ENV ;Main entry point for Environment check point. - ; - S XPDABORT="" - D PROGCHK(.XPDABORT) ;checks programmer variables - I XPDABORT="" K XPDABORT - Q - ; - ; -PRE ;Main entry point for Pre-init items. - ; - Q - ; - ; -POST ;Main entry point for Post-init items. - ; - N DGACTDT ;software activation date - ; - S DGACTDT="Sep 25, 2003" ;National PRF Software Activation date - ; - D POST1(DGACTDT) ;create/update PRF PARAMETERS (#26.18) file - D POST2 ;load BEHAVIORAL Category I PRF - Q - ; - ; -PROGCHK(XPDABORT) ;checks for necessary programmer variables - ; - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO - .D BMES^XPDUTL("*****") - .D MES^XPDUTL("Your programming variables are not set up properly.") - .D MES^XPDUTL("Installation aborted.") - .D MES^XPDUTL("*****") - .S XPDABORT=2 - Q - ; -POST1(DGACTDT) ;create PRF PARAMETERS (#26.18) file entry at IEN "1" - ; - ; Input: - ; DGACTDT - (optional) software activation date in external format - ; [default="May 01, 2003" ;used at test sites] - ; - ; Output: - ; none - ; - N DGACT ;type of file activity (add/update) - N DGFDA ;FDA array - N DGFLD ;field # - N DGERR ;error array - N DGIEN ;IEN array - N DGIENS - N DGPARM ;parameter record - ; - I $G(DGACTDT)="" S DGACTDT="May 01, 2003" ;date for test sites - ; - ;existing file entry - I $D(^DGPF(26.18,1,0))#2 D - . N DGERR - . S DGIENS="1," - . S DGACT="update" - E D - . S DGIENS="+1," - . S DGACT="add" - ; - ;retrieve existing record - S DGPARM=$G(^DGPF(26.18,1,0)) - ; - ;provide values for any missing parameters - I $P(DGPARM,U,1)="" S DGFDA(26.18,DGIENS,.01)=1 - I $P(DGPARM,U,2)="" S DGFDA(26.18,DGIENS,1)=DGACTDT ;activation date - I $P(DGPARM,U,3)="" S DGFDA(26.18,DGIENS,2)="ACTIVE" ;ORU HL7 interface - I $P(DGPARM,U,4)="" S DGFDA(26.18,DGIENS,3)="DIRECT" ;QRY HL7 interface - I $P(DGPARM,U,6)="" S DGFDA(26.18,DGIENS,5)=7 ;HL7 Auto Retrans Days - ; - ;short-circuit when there are no missing parameters - I '$D(DGFDA) D Q - . D BMES^XPDUTL("*****") - . D MES^XPDUTL(" PRF PARAMETERS (#26.18) file values previously defined...no action taken.") - . D MES^XPDUTL("*****") - Q:'$D(DGFDA) - D UPDATE^DIE("ES","DGFDA","DGIEN","DGERR") - ; - ;check for errors and inform the installer of update status - I '$D(DGERR) D - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("The '1' entry in the PRF PARAMETERS (#26.18) file was "_DGACT_$S(DGACT="add":"ed",1:"d")_" successfully.") - . ; - . ;display updated field list and values - . I DGACT="update" D - . . S DGFLD=0 - . . F S DGFLD=$O(DGFDA(26.18,DGIENS,DGFLD)) Q:'DGFLD D - . . . D MES^XPDUTL("The "_$$GET1^DID(26.18,DGFLD,"","LABEL")_" (#"_DGFLD_") field was set to '"_DGFDA(26.18,DGIENS,DGFLD)_"'.") - . D MES^XPDUTL("*****") - E D - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("The attempt to "_DGACT_" the '1' entry in the PRF PARAMETERS (#26.18) file failed.") - . D MES^XPDUTL($G(DGERR("DIERR",1,"TEXT",1))) - . D MES^XPDUTL("*****") - ; - Q - ; -POST2 ;create BEHAVIORAL Category I PRF - ; - ;short circuit if flag already exists - I $D(^DGPF(26.15,"B","BEHAVIORAL")) D Q - . D BMES^XPDUTL("*****") - . D MES^XPDUTL(" 'BEHAVIORAL' Category I flag previously defined...no action taken.") - . D MES^XPDUTL("*****") - ; - N DGDESC ;description word-processing array - N DGFDA ;FDA array - N DGIEN ;IEN array - ; - ;flag description - S DGDESC(1,0)="The purpose of this National Patient Record Flag is to alert VHA medical" - S DGDESC(2,0)="staff and employees of patients whose behavior or characteristics may pose" - S DGDESC(3,0)="a threat either to their safety, the safety of other patients, or" - S DGDESC(4,0)="compromise the delivery of quality health care." - S DGDESC(5,0)="Application of National Patient Record Flags is coordinated through the" - S DGDESC(6,0)="Chief of Staff." - S DGDESC(7,0)="This is a nationally distributed flag." - ; - ;build FDA array - S DGFDA(26.15,"+1,",.01)="BEHAVIORAL" - S DGFDA(26.15,"+1,",.02)="ACTIVE" - S DGFDA(26.15,"+1,",.03)="BEHAVIORAL" - S DGFDA(26.15,"+1,",.04)=730 - S DGFDA(26.15,"+1,",.05)=60 - S DGFDA(26.15,"+1,",.06)="DGPF BEHAVIORAL FLAG REVIEW" - S DGFDA(26.15,"+1,",1)="DGDESC" - ; - ;ask for IEN = 1 - S DGIEN(1)=1 - ; - ;store record - D UPDATE^DIE("E","DGFDA","DGIEN","DGERR") - ; - ;check for errors and inform the installer of update status - D BMES^XPDUTL("*****") - I $D(^DGPF(26.15,"B","BEHAVIORAL")),'$D(DGERR) D - . D MES^XPDUTL(" 'BEHAVIORAL' Category I Patient Record Flag created successfully.") - E D - . D MES^XPDUTL(" 'BEHAVIORAL' Category I Patient Record Flag creation failed!") - D MES^XPDUTL("*****") - Q diff -auBN ./r1/DG53P451.m ./r2/r/DG53P451.m --- ./r1/DG53P451.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P451.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,206 +0,0 @@ -DG53P451 ;TDM/BRM - Patch DG*5.3*451 Install Utility Routine ; 4/27/04 2:14pm - ;;5.3;Registration;**451**; Aug 13,1993 - ; - D CHKBOS Q:$G(XPDABORT)=2 - D ADDBOS - D ADDINC Q:$G(XPDABORT)=2 - D EDITINC^DG53E451 - Q -CHKBOS ;Check to ensure that Merchant Seaman and B.E.C. are in the BOS file - ; - K XPDABORT - N BOS - F BOS="MERCHANT SEAMAN","B.E.C." Q:$D(XPDABORT) D - .Q:$D(^DIC(23,"B",BOS)) - .S XPDABORT=2 - .D BMES^XPDUTL(" >>> ERROR: Branch of Service File (#23) needs to be reviewed by NVS! <<<") - .D MES^XPDUTL(" The National Entry for '"_BOS_"' does not exist!") - .D BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>") - Q -ADDBOS ;Add new entries to BRANCH OF SERVICE file (#23) - N ARY,BOS,FDA,ERR,MSG - S ARY(1)="F.COMMONWEALTH" - S ARY(2)="F.GUERILLA" - S ARY(3)="F.SCOUTS NEW" - S ARY(4)="F.SCOUTS OLD" - ; - D BMES^XPDUTL(" >> Adding New Branch Of Service Entries.") - S BOS="" F S BOS=$O(ARY(BOS)) Q:BOS="" D - .K FDA,ERR - .S MSG=" "_ARY(BOS)_" - " - .I $$FIND1^DIC(23,"","X",ARY(BOS)) D BMES^XPDUTL(MSG_"entry already exists!") Q - .S FDA(23,"+1,",.01)=ARY(BOS) - .D UPDATE^DIE("","FDA","","ERR") - .I $D(ERR) D BMES^XPDUTL(MSG_"not added! ERROR:"),MES^XPDUTL(ERR("DIERR",1)_": "_ERR("DIERR",1,"TEXT",1)) Q - .D MES^XPDUTL(MSG_"successfully added.") - Q - ; -ADDINC ; add new entries to the INCONSISTENT DATA ELEMENTS file (#38.6) - N DGK,DGWP,ROOT,DGFDA,DGWP,DGERR,DGIEN,DGTITL - K XPDABORT - D BMES^XPDUTL(" >> Adding entries 72-85 into the INCONSISTENT DATA ELEMENTS file (#38.6)") - F DGK=72:1:85 Q:$G(XPDABORT)=2 D - .I $D(^DGIN(38.6,DGK)) D Q - ..D BMES^XPDUTL(" Internal Entry # "_DGK_" already exists in file #38.6") - ..S ROOT="DGFDA(38.6,"""_DGK_","")" D @DGK - ..I $P($G(^DGIN(38.6,DGK,0)),"^")=$G(@ROOT@(.01)) D MES^XPDUTL(" Entry "_DGK_" matches incoming entry - OK") Q - ..D MES^XPDUTL(" >>> ERROR: Entry # "_DGK_" needs to be reviewed by NVS! <<<") - ..D MES^XPDUTL(" Existing entry: "_$P($G(^DGIN(38.6,DGK,0)),"^")) - ..D MES^XPDUTL(" Incoming entry: "_$G(@ROOT@(.01))) - ..D BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>") - ..S XPDABORT=2 - .K DGFDA,ROOT,DGWP - .S ROOT="DGFDA(38.6,""?+1,"")" - .D @DGK Q:'$D(DGFDA) - .S DGIEN(1)=DGK - .S DGTITL=@ROOT@(.01) - .D UPDATE^DIE("","DGFDA","DGIEN","DGERR") - .I $D(DGERR) D Q - ..D BMES^XPDUTL(" >>> ERROR! "_DGTITL_" not added to file #38.6") - ..D MES^XPDUTL(" "_DGERR("DIERR",1)_": "_DGERR("DIERR",1,"TEXT",1)) - ..D BMES^XPDUTL(" <<<< INSTALLATION ABORTED >>>>") - ..S XPDABORT=2 - .D BMES^XPDUTL(" "_DGTITL_" successfully added.") - Q -72 ; - S @ROOT@(.01)="MSE DATA MISSING/INCOMPLETE" - S @ROOT@(2)="MSE REQUIRED DATA FIELDS ARE MISSING OR INCOMPLETE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results when any of the required MSE data fields are " - S DGWP(2,0)="either left blank or an imprecise date (less than month/year precision) " - S DGWP(3,0)="is entered. The following fields are required for any given Military " - S DGWP(4,0)="Service Episode: BRANCH OF SERVICE, SERVICE ENTRY DATE, SERVICE " - S DGWP(5,0)="SEPARATION DATE, DISCHARGE TYPE." - Q -73 ; - S @ROOT@(.01)="MSE DATES INCONSISTENT" - S @ROOT@(2)="SERVICE SEPARATION DATE PRECEDES SERVICE ENTRY DATE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results when a SERVICE ENTRY DATE is found to be after the" - S DGWP(2,0)="SERVICE SEPARATION DATE." - Q -74 ; - S @ROOT@(.01)="CONFLICT DT MISSING/INCOMPLETE" - S @ROOT@(2)="CONFLICT DATE IS MISSING OR INCOMPLETE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when a conflict date is either missing or " - S DGWP(2,0)="incomplete (imprecise dates must have at least month and year). The " - S DGWP(3,0)="following date fields can trigger this inconsistency: SOMALIA FROM DATE," - S DGWP(4,0)="SOMALIA TO DATE, YUGOSLAVIA FROM DATE, YUGOSLAVIA TO DATE, PANAMA FROM " - S DGWP(5,0)="DATE, PANAMA TO DATE, GRENADA FROM DATE, GRENADA TO DATE, LEBANON FROM " - S DGWP(6,0)="DATE, LEBANON TO DATE, VIETNAM FROM DATE, VIETNAM TO DATE, GULF WAR FROM" - S DGWP(7,0)="DATE, GULF WAR TO DATE." - Q -75 ; - S @ROOT@(.01)="CONFLICT TO DT BEFORE FROM DT" - S @ROOT@(2)="CONFLICT TO DATE PRECEDES THE CONFLICT FROM DATE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when a conflict to date is prior to a conflict " - S DGWP(2,0)="from date. The following date fields can trigger this inconsistency:" - S DGWP(3,0)="SOMALIA FROM DATE, SOMALIA TO DATE, YUGOSLAVIA FROM DATE, YUGOSLAVIA TO" - S DGWP(4,0)="DATE, PANAMA FROM DATE, PANAMA TO DATE, GRENADA FROM DATE, GRENADA TO" - S DGWP(5,0)="DATE, LEBANON FROM DATE, LEBANON TO DATE, VIETNAM FROM DATE, VIETNAM TO" - S DGWP(6,0)="DATE, GULF WAR FROM DATE, GULF WAR TO DATE." - Q -76 ; - S @ROOT@(.01)="INACCURATE CONFLICT DATE" - S @ROOT@(2)="CONFLICT DATE IS NOT WITHIN THE ACCEPTABLE CONFLICT DATE RANGE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when a conflict from and/or to date is not " - S DGWP(2,0)="within the designated date ranges for the specific conflict." - S DGWP(3,0)=" " - S DGWP(4,0)="The following date fields can trigger this inconsistency:" - S DGWP(5,0)="SOMALIA FROM DATE, SOMALIA TO DATE, YUGOSLAVIA FROM DATE, YUGOSLAVIA TO" - S DGWP(6,0)="DATE, PANAMA FROM DATE, PANAMA TO DATE, GRENADA FROM DATE, GRENADA TO" - S DGWP(7,0)="DATE, LEBANON FROM DATE, LEBANON TO DATE, VIETNAM FROM DATE, VIETNAM TO" - S DGWP(8,0)="DATE, GULF WAR FROM DATE, GULF WAR TO DATE." - Q -77 ; - S @ROOT@(.01)="INACCURATE POW DT/LOCATION" - S @ROOT@(2)="POW DATE(S) AND LOCATION DO NOT MATCH" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when the POW from and/or to date is not " - S DGWP(2,0)="within the designated date range for the specified POW LOCATION." - Q -78 ; - S @ROOT@(.01)="INACCURATE COMBAT DT/LOC" - S @ROOT@(2)="COMBAT DATES ARE NOT VALID FOR SPECIFIED LOCATION" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when the COMBAT from and/or to date is " - S DGWP(2,0)="not within the designated date range for the specified COMBAT LOCATION." - Q -79 ; - S @ROOT@(.01)="MSE DATES OVERLAP" - S @ROOT@(2)="MSE DATES OVERLAP" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when more than one Military Service " - S DGWP(2,0)="Episode exists for this patient on a single day." - Q -80 ; - S @ROOT@(.01)="POW DT NOT WITHIN MSE" - S @ROOT@(2)="POW DATES ARE NOT WITHIN THE MSE RANGE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when the entered POW From/To Dates are not " - S DGWP(2,0)="within the patient's military service episodes." - Q -81 ; - S @ROOT@(.01)="COMBAT DT NOT WITHIN MSE" - S @ROOT@(2)="COMBAT DATE IS NOT WITHIN THE MSE RANGE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when the entered COMBAT From/To Dates are not" - S DGWP(2,0)="within the patient's military service episodes." - Q -82 ; - S @ROOT@(.01)="CONFLICT DT NOT WITHIN MSE" - S @ROOT@(2)="CONFLICT DATES ARE NOT WITHIN MSE DATE RANGE" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="This inconsistency results when the entered Conflict From/To Dates are not" - S DGWP(2,0)="within the patient's military service episodes." - S DGWP(3,0)=" " - S DGWP(4,0)="The following fields could cause this inconsistency to occur: SOMALIA" - S DGWP(5,0)="FROM DATE, SOMALIA TO DATE, YUGOSLAVIA FROM DATE, YUGOSLAVIA TO DATE," - S DGWP(6,0)="PANAMA FROM DATE, PANAMA TO DATE, GRENADA FROM DATE, GRENADA TO DATE," - S DGWP(7,0)="LEBANON FROM DATE, LEBANON TO DATE, VIETNAM FROM DATE, VIETNAM TO DATE," - S DGWP(8,0)="GULF WAR FROM DATE, GULF WAR TO DATE." - Q -83 ; - S @ROOT@(.01)="BOS REQUIRES DATE W/IN WWII" - S @ROOT@(2)="MERCH SEA OR FILIPINO VET BOS REQUIRES SERVICE DATES DURING WWII" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results when the Branch of Service is MERCHANT SEAMAN or" - S DGWP(2,0)="one of the Filipino Veteran branches of service (F.COMMONWEALTH," - S DGWP(3,0)="F.GUERILLA, F.SCOUTS NEW, F.SCOUTS OLD) but neither the Military" - S DGWP(4,0)="Service Start Date nor the Service End Date is within World War II" - S DGWP(5,0)="(12/7/1941 - 8/15/1945)." - Q -84 ; - S @ROOT@(.01)="FILIPINO VET, PROOF MISSING" - S @ROOT@(2)="FILIPINO VETERAN BOS WAS ENTERED, FILIPINO VET PROOF IS MISSING" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results if a Filipino Veteran branch of service is entered" - S DGWP(2,0)="(F.COMMONWEATH, F.GUERILLA, or F.SCOUTS NEW) but the FILIPINO VET PROOF" - S DGWP(3,0)="field is left blank." - Q -85 ; - S @ROOT@(.01)="FILIPINO VET SHOULD BE VET='Y'" - S @ROOT@(2)="VERIFIED FILIPINO VETERAN SHOULD HAVE A VETERAN STATUS OF 'YES'" - S @ROOT@(3)=3 - S @ROOT@(50)="DGWP" - S DGWP(1,0)="Inconsistency results if a veteran has a Filipino Veteran branch of" - S DGWP(2,0)="service (F.COMMONWEALTH, F.GUERILLA, F.SCOUTS NEW, or F.SCOUTS OLD)," - S DGWP(3,0)="military service dates during World War II, proof of F.Vet eligibility" - S DGWP(4,0)="(for the first three BOS only), but the Veteran Status is not 'YES'." - Q diff -auBN ./r1/DG53P543.m ./r2/r/DG53P543.m --- ./r1/DG53P543.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P543.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,169 +0,0 @@ -DG53P543 ;BAY/JT - cleanup of file 20 ; 9/16/03 4:56pm - ;;5.3;Registration;**543**;Aug 13, 1993 - ; patient name .01 only - ; -ENV ; do environment check - S XPDABORT="" - D PROGCHK(.XPDABORT) - I XPDABORT="" K XPDABORT - Q -PROGCHK(XPDABORT) ; checks for necessary programmer variables - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D - .D MES^XPDUTL("Your programming variables are not set up properly.") - .D MES^XPDUTL("Installation aborted.") - .S XPDABORT=2 - Q - ; -CLEANUP N DGIEN,DGFULLNM,DGLINK,DGFND,DGDPT,DGNAME,DGZERO,DGONE,DGERR,CNT,DGMID,DGTOT,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGCONC,DGOTHERS,DGGLOBAL,X1,X2 - K ^XTMP("DG53P543") - S X1=DT,X2=90 D C^%DTC - S ^XTMP("DG53P543",0)=X_"^"_DT_"^Problems w/file 2 links w/file 20" - S (DGIEN,DGTOT,DGERR,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGOTHERS)=0 - D BMES^XPDUTL("Beginning clean-up...Reading thru entire Patient File...") - F S DGIEN=$O(^DPT(DGIEN)) Q:'DGIEN D - .S DGTOT=DGTOT+1 - .Q:$P($G(^DPT(DGIEN,0)),U)["MERGING INTO" - .Q:$D(^DPT(DGIEN,-9)) - .S DGFULLNM=$P($G(^DPT(DGIEN,0)),U) - .S DGLINK=+$P($G(^DPT(DGIEN,"NAME")),U) - .I 'DGLINK D NOLINK Q - .S DGZERO=$G(^VA(20,DGLINK,0)) - .I DGZERO="" D NOZERO Q - .I $P(DGZERO,U)'=2!($P(DGZERO,U,2)'=".01")!(+$P(DGZERO,U,3)'=DGIEN) D BADZERO Q - .S DGONE=$G(^VA(20,DGLINK,1)) - .I DGONE="" D NOONE Q - .; - .S DGERR=0 - .; skip if "error" in family name - .I $P(DGFULLNM,",",1)["ERROR" Q - .; compare family name - .I $P(DGFULLNM,",",1)'=$P(DGONE,U) S DGERR=1 S ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=$P(DGFULLNM,",",1)_U_$P(DGONE,U) S DGUPDT=DGUPDT+1 Q - .; skip if no first name - .I $P(DGFULLNM,",",2)="",$P(DGONE,U,2)="" Q - .; if comma in first name, skip if everything equal - .I $P(DGONE,U,2)["," S DGCONC=$P(DGONE,U)_","_$P(DGONE,U,2) I DGCONC=DGFULLNM Q - .; compare first name - .S CNT=$L($P(DGONE,U,2)) - .I $E($P(DGFULLNM,",",2),1,CNT)'=$P(DGONE,U,2) S DGERR=2 S ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=DGFULLNM_"///"_$P(DGONE,U,1,5) S DGOTHERS=DGOTHERS+1 Q - .;compare middle names and suffixes - .S DGMID=$P($P(DGFULLNM,",",2)," ",2) - .I DGMID=$P(DGONE,U,3)!(DGMID=$P(DGONE,U,5)) Q - .S DGMID=$P($P(DGFULLNM,",",2)," ",2,99) - .I $P(DGONE,U,3)'="",DGMID[$P(DGONE,U,3) Q - .I $P(DGONE,U,5)'="",DGMID[$P(DGONE,U,5) Q - .S DGERR=3 - .S ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=DGFULLNM_"///"_$P(DGONE,U,1,5) S DGOTHERS=DGOTHERS+1 - .Q - ; - D MES^XPDUTL("Total # of Patient File records read: "_DGTOT) - D MES^XPDUTL("Total # of Name Component file #20 records needing cleanup: "_DGUPDT) - I DGUPDT D - .D MES^XPDUTL("I will now update these records ...") - .D UPDATE - .D MES^XPDUTL("Done !") - I DGOTHERS!(DGNOLINK)!(DGLINK0)!(DGLINK1) D - .D MES^XPDUTL("I also found other records that need attention:") - .I DGOTHERS D MES^XPDUTL(" # of records needing reformatting: "_DGOTHERS) - .I DGNOLINK D MES^XPDUTL(" # of records with no link: "_DGNOLINK) - .I DGLINK0 D MES^XPDUTL(" # of records with no or bad zero node: "_DGLINK0) - .I DGLINK1 D MES^XPDUTL(" # of records with no '1' node: "_DGLINK1) - .S DGGLOBAL="^XTMP(""DG53P543""" - .D MES^XPDUTL(" For more details, please see the "_DGGLOBAL_" global") - .D MES^XPDUTL(" or print the report PRTRPT^DG53P543") - D BMES^XPDUTL("Clean-up is complete") - Q -NOLINK ; - S DGNOLINK=DGNOLINK+1 - I DGFULLNM="" S ^XTMP("DG53P543",DGIEN,0)="no name on patient file" Q - I '$D(^VA(20,"C",DGFULLNM)) S ^XTMP("DG53P543",DGIEN,0)="no link to file 20" Q - S DGFND=0 - F S DGFND=$O(^VA(20,"C",DGFULLNM,DGFND)) Q:'DGFND D - .S DGDPT=+$P($G(^VA(20,DGFND,0)),U,3) - .I DGDPT S DGNAME=$P($G(^DPT(DGDPT,0)),U) I DGNAME'="",DGNAME=DGFULLNM S ^XTMP("DG53P543",DGIEN,0)=DGFND_" points to Patient file "_DGDPT - Q -NOZERO ; - S DGLINK0=DGLINK0+1 - S ^XTMP("DG53P543",DGIEN,DGLINK)="no zero node on file 20" - Q -BADZERO ; - S DGLINK0=DGLINK0+1 - S ^XTMP("DG53P543",DGIEN,DGLINK)="bad zero node on file 20" - Q -NOONE ; - S DGLINK1=DGLINK1+1 - S ^XTMP("DG53P543",DGIEN,DGLINK)="no '1' node on file 20" - Q -UPDATE ; - Q:'$D(^XTMP("DG53P543")) - N DG20NAME,DA,DR,DIE,X - S DGIEN=0 - F S DGIEN=$O(^XTMP("DG53P543",DGIEN)) Q:'DGIEN D - .S DGLINK=0 - .F S DGLINK=$O(^XTMP("DG53P543",DGIEN,DGLINK)) Q:'DGLINK D - ..S DGERR=0 - ..F S DGERR=$O(^XTMP("DG53P543",DGIEN,DGLINK,DGERR)) Q:'DGERR D - ...I DGERR'=1 Q - ...S DG20NAME=$P($G(^DPT(DGIEN,0)),U) I DG20NAME'="" D - ....S DIE="^DPT(",DA=DGIEN,DR=".01///^S X=DG20NAME" D ^DIE - ....D MES^XPDUTL("Record # "_DGIEN_" for "_$P(^DPT(DGIEN,0),U)_" has been updated") - ....K ^XTMP("DG53P543",DGIEN,DGLINK,DGERR) - ....K DG20NAME - Q - ; -PRTRPT ; - I $$DEVICE() D PRINT - Q -DEVICE() ; choose device and whether to queue. - N OK,IOP,POP,%ZIS,DGX - S OK=1 - S %ZIS="MQ" - D ^%ZIS - S:POP OK=0 - I OK,$D(IO("Q")) D - .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP - .S ZTRTN="PRINT^DG53P543" - .S ZTDESC="Print of XTMP global for DG53P543." - .F DGX=1:1:20 D ^%ZTLOAD Q:$G(ZTSK) - .W !,$S($D(ZTSK):"Request "_ZTSK_" queued!",1:"Request Cancelled!"),! - .D HOME^%ZIS - .S OK=0 - Q OK - ; -PRINT ; - U IO - N DGIEN,DGLINK,DGERR,DGQUIT,DGPG,DGDDT - S (DGQUIT,DGPG)=0 - S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D") - D HEAD - S DGIEN=0,DGIEN=$O(^XTMP("DG53P543",DGIEN)) - I DGIEN="" D Q - .W !!!,?20,"*** No records to report ***" - ; - S DGIEN=0 - F S DGIEN=$O(^XTMP("DG53P543",DGIEN)) Q:'DGIEN D Q:DGQUIT - .I $D(^XTMP("DG53P543",DGIEN,0)) D - ..I $Y>(IOSL-4) D HEAD - ..W "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,0),! - .S DGLINK=0 - .F S DGLINK=$O(^XTMP("DG53P543",DGIEN,DGLINK)) Q:'DGLINK D - ..I $D(^XTMP("DG53P543",DGIEN,DGLINK))=1 D - ...I $Y>(IOSL-4) D HEAD - ...W "# ",DGIEN,?11,$P(^DPT(DGIEN,0),U),?40,^XTMP("DG53P543",DGIEN,DGLINK),?69,"# ",DGLINK,! - ..S DGERR=0 - ..F S DGERR=$O(^XTMP("DG53P543",DGIEN,DGLINK,DGERR)) Q:'DGERR D - ...I $Y>(IOSL-4) D HEAD - ...W "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,DGLINK,DGERR),?69,"# ",DGLINK,! - ; - I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q - I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 - I $D(ZTQUEUED) S ZTREQ="@" - Q -HEAD ; - I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q - I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 - Q:DGQUIT - S DGPG=$G(DGPG)+1 - W @IOF,!,DGDDT,?15,"DG*5.3*543 File #20 Cleanup Utility",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,! - W !,"File 2 IEN",?11,"Patient Name///Component Last^First^Middle^Prefix^Suffix",?69,"File 20 IEN",! - S $P(X,"-",81)="" W X,! - Q diff -auBN ./r1/DG53P555.m ./r2/r/DG53P555.m --- ./r1/DG53P555.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P555.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,33 +0,0 @@ -DG53P555 ; BAY/JAT- Patch DG*5.3*555 Install Utility Routine ; 11/7/03 11:25am - ;;5.3;Registration;**555**;AUG 13, 1993 - ; -ENV ;Main entry point for Environment check point. - ; - S XPDABORT="" - D PROGCHK(.XPDABORT) ;checks programmer variables - I XPDABORT="" K XPDABORT - Q -PRE ;Main entry point for Pre-install items. - Q - ; - ; -POST ;Main entry point for Post-install items. - ; - D POST1 - Q -POST1 ;remove references to field #1 in Race file (it is a - ; partial duplicate of field #2) data dictionary - ; - K ^DD(10,1) - K ^DD(10,"B","ABBREVIATION",1) - K ^DD(10,"GL",0,2,1) - Q -PROGCHK(XPDABORT) ;checks for necessary programmer variables - ; - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("Your programming variables are not set up properly.") - . D MES^XPDUTL("Installation aborted.") - . D MES^XPDUTL("*****") - . S XPDABORT=2 - Q diff -auBN ./r1/DG53P574.m ./r2/r/DG53P574.m --- ./r1/DG53P574.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P574.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,14 +0,0 @@ -DG53P574 ; BAY/JAT- Patch DG*5.3*574 Install Utility Routine ; 12/9/03 3:13pm - ;;5.3;Registration;**574**;AUG 13, 1993 - ; - ; - ; -POST ;Main entry point for Post-install items. - ; - D POST1 - Q -POST1 ; Refine Kill logic on "BS" crossreference on Patient file - ; NOIS CALL PUG-0999-50739 - D MES^XPDUTL("Refining the Kill logic of 'BS' crossreference") - S ^DD(2,.09,1,1,2)="K:$E(X,6,9)'="""" ^DPT(""BS"",$E(X,6,9),DA)" - Q diff -auBN ./r1/DG53P593.m ./r2/r/DG53P593.m --- ./r1/DG53P593.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P593.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,183 +0,0 @@ -DG53P593 ;BAY/JAT - Patient File Cleanup; 2/22/1999 ; 6/24/04 3:43pm - ;;5.3;Registration;**593**;Aug 13,1993 - Q - ; -CLEANUP ;This entry point will do the cleanup. - ; - N DGENSKIP - S DGENSKIP=0 - W !,"This is a one-time cleanup of the Patient File." - W !,"Certain records which were created in error will be deleted." - N X1,X2 - K ^XTMP("DG53P593",$J) - S X1=DT,X2=90 D C^%DTC - S ^XTMP("DG53P593",$J,0)=X_"^"_DT_"^Patient File cleanup" - I $$DEVICE() D ENTER - Q - ; -REPORT ;This entry point was provided for testing, so that before - ;patient records are deleted the site can have a list of - ;the DFN's that would be deleted. - ; - ;Use this entry point to report on what the cleanup would do. - ;No changes will be made to the database. - ; - N DGENSKIP - S DGENSKIP=1 - W !,"This is a preliminary report by DFN of the Patient file" - W !,"records which would be deleted by the cleanup." - N X1,X2 - K ^XTMP("DG53P593",$J) - S X1=DT,X2=90 D C^%DTC - S ^XTMP("DG53P593",$J,0)=X_"^"_DT_"^Patient File cleanup" - I $$DEVICE() D ENTER - Q - ; -ENTER ; - ; - D DELETE(DGENSKIP) - D:(DGENSKIP) ^%ZISC - I $D(ZTQUEUED) S ZTREQ="@" - Q -DEVICE() ; - ;Description: allows the user to select a device. - ; - ;Output: - ; Function Value - Returns 0 if the user decides not to print or to - ; queue the report, 1 otherwise. - ; - N OK,IOP,POP,%ZIS - S OK=1 - S %ZIS="MQ" - D ^%ZIS - S:POP OK=0 - D:OK&$D(IO("Q")) - .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP - .S ZTRTN="ENTER^DG53P593",ZTDESC=$S(DGENSKIP:"Report",1:"Cleanup")_" of Incomplete Patient Records" - .S ZTSAVE("DGENSKIP")="" - .D ^%ZTLOAD - .W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") - .D HOME^%ZIS - .S OK=0 - Q OK - ; -DELETE(DGENSKIP) ; - ;This will delete bogus patient records -- - ; - ;Input: If DGENSKIP=1, the records will not be deleted, - ;just reported. - ; - N DFN,SUB,GOOD,COUNT,DGNAME,DGDEL,DGSORT,DGVAL,DGFDA,DGERR - S (COUNT,DFN)=0 - F S DFN=$O(^DPT(DFN)) Q:'DFN D - .; merged record - .I $D(^DPT(DFN,-9)) Q - .; in process of being merged - .I $P($G(^DPT(DFN,0)),U)["MERGING INTO" Q - .; usual good patient record - .I $D(^DPT(DFN,0)) S DGNAME=$P($G(^DPT(DFN,0)),U) I DGNAME'="",$D(^DPT("B",DGNAME,DFN)) Q - .; evaluate if record related to DG*5.3*578 - .D EVAL578 - .; evaluate if record related to DG*5.3*222 - .S GOOD=0 - .S SUB="" - .F S SUB=$O(^DPT(DFN,SUB)) Q:SUB="" D - ..I (SUB'=.3),(SUB'=.38),(SUB'=.52) S GOOD=1 Q - .I 'GOOD D DIKDEL Q - .I DGDEL D DIKDEL - ; - D PRINT - Q - ; -EVAL578 ; - S DGDEL=0 - N DGCNT,DGNODE,DGSSN,DGNEWIEN,DGMPI - I '$D(^DPT(DFN,0)) Q - S DGNODE="" - S DGCNT=0 - F S DGNODE=$O(^DPT(DFN,DGNODE)) Q:DGNODE="" S DGCNT=DGCNT+1 - ; there must be minimal data, so skip if too many nodes - Q:DGCNT>7 - I DGNAME="" S DGDEL=DGDEL+1 - I DGNAME'="",'$D(^DPT("B",DGNAME,DFN)) S DGDEL=DGDEL+1 - S DGSSN=$P($G(^DPT(DFN,0)),U,9) - I DGSSN="" S DGDEL=DGDEL+1 - I DGSSN'="",'$D(^DPT("SSN",DGSSN,DFN)) S DGDEL=DGDEL+1 D - .S DGNEWIEN=0 - .F S DGNEWIEN=$O(^DPT("SSN",DGSSN,DGNEWIEN)) Q:'DGNEWIEN I DGNEWIEN S DGDEL=DGDEL+1 - S DGMPI=$E($P($G(^DPT(DFN,"MPI")),U),1,3) - I DGMPI="" S DGDEL=DGDEL+1 - ; checking if only local ICN - I DGMPI=+$$SITE^VASITE() S DGDEL=DGDEL+1 - I DGDEL>1 Q - S DGDEL=0 - Q - ; -DIKDEL ; - S COUNT=COUNT+1 - S DGSORT=$S('GOOD:2,1:1) - S ^XTMP("DG53P593",$J,DGSORT,DFN)=$S(DGSORT=1:"Related to DG*5.3*578",1:"Related to DG*5.3*222") - I 'DGENSKIP D - .D DELEXE - .I '$D(^DPT(DFN,0)) D Q - ..S DA=DFN,DIK="^DPT(" D ^DIK K DA,DIK - .I $P($G(^DPT(DFN,0)),U)="" K ^DPT(DFN) Q - .S DGVAL="@" - .S DGFDA(2,DFN_",",.01)=DGVAL - .D FILE^DIE("","DGFDA","DGERR") - Q - ; -DELEXE ; Delete exceptions on file for patient record being removed. - S EXCT="" - F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D - . I $D(^RGHL7(991.1,"ADFN",EXCT,DFN)) D - .. S IEN=0 - .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,DFN,IEN)) Q:'IEN D - ... S IEN2=0 - ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,DFN,IEN,IEN2)) Q:'IEN2 D - .... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) - .... I NUM=1 D - ..... L +^RGHL7(991.1,IEN):10 - ..... S DIK="^RGHL7(991.1,",DA=IEN - ..... D ^DIK K DIK,DA - ..... L -^RGHL7(991.1,IEN) - .... E I NUM>1 D DELE - K EXCT,IEN,IEN2,NUM - Q -DELE ; delete exception - L +^RGHL7(991.1,IEN):10 - S DA(1)=IEN,DA=IEN2 - S DIK="^RGHL7(991.1,"_DA(1)_",1," - D ^DIK K DIK,DA - L -^RGHL7(991.1,IEN) - Q -PRINT ; - U IO - N DGDDT,DGQUIT,DGPG - S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D") - S (DGQUIT,DGPG)=0 - D HEAD - I '$G(COUNT) D Q - .W !!!,?20,"*** No records to report ***" - W !!,"*** COUNT OF BAD PATIENT RECORDS"_$S(DGENSKIP:"",1:" DELETED")_": ",COUNT," ***",!! - S DGSORT=0 - F S DGSORT=$O(^XTMP("DG53P593",$J,DGSORT)) Q:'DGSORT D Q:DGQUIT - .S DFN=0 - .F S DFN=$O(^XTMP("DG53P593",$J,DGSORT,DFN)) Q:'DFN D Q:DGQUIT - ..I $Y>(IOSL-4) D HEAD - ..W ?2,DFN,?15,$G(^XTMP("DG53P593",$J,DGSORT,DFN)),! - ; - I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q - I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 - I $D(ZTQUEUED) S ZTREQ="@" - Q - ; -HEAD ; - I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q - I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 - Q:DGQUIT - S DGPG=$G(DGPG)+1 - W @IOF,!,DGDDT,?15,"DG*5.3*593 Patient File Cleanup Utility",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,! - W !,?2,"DFN",?15,"Reason for Deletion",! - S $P(X,"-",81)="" W X,! - Q diff -auBN ./r1/DG53P597.m ./r2/r/DG53P597.m --- ./r1/DG53P597.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P597.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,91 +0,0 @@ -DG53P597 ; BAY/JAP- Patch DG*5.3*597 Post-Installation ; 04/19/2004 - ;;5.3;Registration;**597**;AUG 13, 1993 - ; - ;be sure that all existing 1010EZ applications in 1010EZ HOLDING file (#712) - ;are linked to file #2 thru the new field MOST RECENT 1010EZ (#1010.156); - ;also update APPOINTMENT REQUEST ON 1010EZ field (#1010.159) using data from field #4.4/file #712 - ;and EMAIL ADDRESS field (#.133) using data from field #4.3/file #712 - ;in the applicant's file #2 record. - ; -POST ; - ;queue the task to background for 5:00 AM following date of install - ;ZTRTN="QUE^DG53P597" - N QUETIME,X1,X2 - S X1=DT,X2=1 D C^%DTC - S QUETIME=X_".05" - S ZTDTH=QUETIME - S ZTIO="",ZTDESC="DG*5.3*597 POST-INSTALLATION TASK" - S ZTRTN="QUE^DG53P597" - D ^%ZTLOAD - I '$G(ZTSK) W !!,"POST-INSTALL BACKGROUND TASK NOT QUEUED",! D NOTASK - Q - ; -QUE ;entry point from TaskManager - ; - ;only update file #2 with data from file #712 record if date filed exists - ;(#3.4) LINK TO FILE #2 [10P:2] - ;(#4.3) APPLICANT E-MAIL [4F] - ;(#4.4) APPOINTMENT REQUESTED [5S] - ;(#7.1) FILING DATE [5D] - S START=$$NOW^XLFDT() - S REC712=0,TOTAL=0,UPDATES=0 - F S REC712=$O(^EAS(712,REC712)) Q:'REC712 D - .S TOTAL=TOTAL+1,NEW=0 - .S DFN=+$P(^EAS(712,REC712,0),U,10),FILED=+$P($G(^EAS(712,REC712,2)),U,5) - .Q:'DFN - .Q:'$D(^DPT(DFN,0)) - .Q:'FILED - .S EMAIL=$P($G(^EAS(712,REC712,1)),U,4),APPTREQ=$P($G(^EAS(712,REC712,1)),U,5) - .I $P($G(^DPT(DFN,1010.15)),U,6)="" S NEW=1 - .S IENS=DFN_"," - .K DATA S DATA(2,IENS,.133)=EMAIL,DATA(2,IENS,1010.156)=REC712,DATA(2,IENS,1010.159)=APPTREQ - .K ERRMSG D FILE^DIE("","DATA","ERRMSG") - .I '$D(ERRMSG),NEW S UPDATES=UPDATES+1 - ;when process of file #712 is complete - D MESS(TOTAL,UPDATES,$G(ZTSK),START) - Q - ; -MESS(TOTAL,UPDATES,ZTSK,START) ; - ;send MailMan message to members of G.VA1010EZ as well installer of patch - ;to inform that job has completed and number of file #2 records updated. - ; - S Y=START D DD^%DT S START=Y - I $G(ZTSK) S MSG(1)="The post-installation background task (#"_ZTSK_") for DG*5.3*597," - I '$G(ZTSK) S MSG(1)="A post-installation update process for DG*5.3*597," - S MSG(2)="which started on "_START_", has completed." - S MSG(3)=" " - S MSG(4)="A total of "_TOTAL_" records in the 1010EZ HOLDING file (#712)" - S MSG(5)="were processed." - S MSG(6)=" " - S MSG(7)=UPDATES_" records in the PATIENT file (#2) were updated as follows:" - S MSG(8)=" Field #.133 from #712/#4.3" - S MSG(9)=" Field #1010.156 from #712 IEN" - S MSG(10)=" Field #1010.159 from #712/#4.4" - S MSG(11)=" " - K XMY - S XMDUZ=.5,XMTEXT="MSG(",XMY(DUZ)="",WHERE=^XMB("NETNAME"),XMY("G.VA1010EZ@"_WHERE)="" - S XMSUB="DG*5.3*597 Post-Installation Task Complete" - D ^XMD - K DFN,MSG,NEW,REC712,TOTAL,UPDATES,WHERE,XMZ,XMY,XMDUZ - Q - ; -NOTASK ; - ;send MailMan message to members of G.VA1010EZ as well installer of patch - ;to inform that post-install job was not successfully tasked. - ; - S MSG(1)="The post-installation background job for DG*5.3*597" - S MSG(2)="was not successfully queued." - S MSG(3)=" " - S MSG(4)="Please have a member of IRM Service at your facility" - S MSG(5)="run the post-installation update directly from" - S MSG(6)="programmer mode by entering the following command:" - S MSG(7)=" " - S MSG(8)="D QUE^DG53P597" - S MSG(9)=" " - S MSG(10)="The process should take less than 30 minutes to complete." - K XMY - S XMDUZ=.5,XMTEXT="MSG(",XMY(DUZ)="",WHERE=^XMB("NETNAME"),XMY("G.VA1010EZ@"_WHERE)="" - S XMSUB="DG*5.3*597 Post-Installation Failure" - D ^XMD - K MSG,WHERE,XMZ,XMY,XMDUZ - Q diff -auBN ./r1/DG53P600.m ./r2/r/DG53P600.m --- ./r1/DG53P600.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P600.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,136 +0,0 @@ -DG53P600 ;BAY/JAT - Patient File Updat; 6/7/04 7:13pm ; 7/16/04 3:22pm - ;;5.3;Registration;**600**;Aug 13,1993 - Q - ; -CLEANUP ;This entry point will do the update. - ; - N DGENSKIP - S DGENSKIP=0 - W !,"This is a one-time update of the Patient File." - W !,"It will correct the TEST PATIENT INDICATOR flag." - N X1,X2 - K ^XTMP("DG53P600",$J) - S X1=DT,X2=90 D C^%DTC - S ^XTMP("DG53P600",$J,0)=X_"^"_DT_"^Patient File update" - I $$DEVICE() D ENTER - Q - ; -REPORT ;This entry point was provided for testing, so that before - ;patient records are updated the site can have a list of - ;the DFN's that would be affected. - ; - ;Use this entry point to report on what the update would do. - ;No changes will be made to the database. - ; - N DGENSKIP - S DGENSKIP=1 - W !,"This is a preliminary report by DFN of the Patient file" - W !,"records which would be affected by the update." - N X1,X2 - K ^XTMP("DG53P600",$J) - S X1=DT,X2=90 D C^%DTC - S ^XTMP("DG53P600",$J,0)=X_"^"_DT_"^Patient File update" - I $$DEVICE() D ENTER - Q - ; -ENTER ; - ; - D UPDATE(DGENSKIP) - D:(DGENSKIP) ^%ZISC - I $D(ZTQUEUED) S ZTREQ="@" - Q -DEVICE() ; - ;Description: allows the user to select a device. - ; - ;Output: - ; Function Value - Returns 0 if the user decides not to print or to - ; queue the report, 1 otherwise. - ; - N OK,IOP,POP,%ZIS - S OK=1 - S %ZIS="MQ" - D ^%ZIS - S:POP OK=0 - D:OK&$D(IO("Q")) - .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP - .S ZTRTN="ENTER^DG53P600",ZTDESC=$S(DGENSKIP:"Report",1:"Update")_" of Patient Records" - .S ZTSAVE("DGENSKIP")="" - .D ^%ZTLOAD - .W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") - .D HOME^%ZIS - .S OK=0 - Q OK - ; -UPDATE(DGENSKIP) ; - ;This will update patient records -- - ; - ;Input: If DGENSKIP=1, the records will not be updated, - ;just reported. - ; - N DFN,COUNT,DGSSN,DGS,DGFLG,DGXREF,DGVAL,DGFDA,DGERR - S (COUNT,DFN)=0 - F S DFN=$O(^DPT(DFN)) Q:'DFN D - .; merged record - .I $D(^DPT(DFN,-9)) Q - .; in process of being merged - .I $P($G(^DPT(DFN,0)),U)["MERGING INTO" Q - .I $D(^DPT(DFN,0)) D - ..S DGSSN=$P($G(^DPT(DFN,0)),U,9) - ..Q:'DGSSN - ..S DGS=$E(DGSSN,1,5) - ..S DGS=$S(DGS="00000":0,1:1) - ..S DGFLG=+$P($G(^DPT(DFN,0)),U,21) - ..S DGXREF=$S('$D(^DPT("ATEST",DFN)):0,1:1) - ..;quit if usual non-test patient - ..I DGS,'DGFLG,'DGXREF Q - ..;update - ..I DGS,DGFLG S DGVAL=0 D UPDR Q - ..I DGS,DGXREF S DGVAL=0 D UPDR Q - ..I 'DGS,'DGFLG S DGVAL=1 D UPDR Q - ..I 'DGS,'DGXREF S DGVAL=1 D UPDR Q - ; - D PRINT - Q - ; -UPDR ; - S COUNT=COUNT+1 - S DGFLG=$S(DGFLG:"YES",1:"NO") - S DGXREF=$S(DGXREF:"YES",1:"NO") - S ^XTMP("DG53P600",$J,DFN)=DGSSN_"^"_DGFLG_"^"_DGXREF - I 'DGENSKIP D - .S DGFDA(2,DFN_",",.6)=DGVAL - .D FILE^DIE("S","DGFDA","DGERR") - .I DGVAL=0 K ^DPT("ATEST",DFN) - Q -PRINT ; - U IO - N DGDDT,DGQUIT,DGPG - S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D") - S (DGQUIT,DGPG)=0 - D HEAD - I '$G(COUNT) D Q - .W !!!,?20,"*** No records to report ***" - W !!,"*** COUNT OF BAD PATIENT RECORDS"_$S(DGENSKIP:"",1:" UPDATED")_": ",COUNT," ***",!! - S DFN=0 - F S DFN=$O(^XTMP("DG53P600",$J,DFN)) Q:'DFN D Q:DGQUIT - .I $Y>(IOSL-4) D HEAD - .S DGSSN=$P($G(^XTMP("DG53P600",$J,DFN)),U) - .S DGFLG=$P($G(^XTMP("DG53P600",$J,DFN)),U,2) - .S DGXREF=$P($G(^XTMP("DG53P600",$J,DFN)),U,3) - .W ?2,DFN,?15,DGSSN,?37,DGFLG,?56,DGXREF,! - ; - I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q - I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 - I $D(ZTQUEUED) S ZTREQ="@" - Q - ; -HEAD ; - I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q - I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 - Q:DGQUIT - S DGPG=$G(DGPG)+1 - W @IOF,!,DGDDT,?15,"DG*5.3*600 Patient File Update Utility",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,! - W ! - W !,?2,"DFN",?15,"SSN",?26,"Test Patient Indicator",?50,"'ATEST' crossref",! - S $P(X,"-",81)="" W X,! - Q diff -auBN ./r1/DG53P604.m ./r2/r/DG53P604.m --- ./r1/DG53P604.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53P604.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,91 +0,0 @@ -DG53P604 ;BAY/JAT - Patient File Updat; 6/7/04 7:13pm ; 8/7/04 7:51pm - ;;5.3;Registration;**604**;Aug 13,1993 - ; -REPORT ; - N X1,X2 - K ^XTMP("DG53P604",$J) - S X1=DT,X2=90 D C^%DTC - S ^XTMP("DG53P604",$J,0)=X_"^"_DT_"^Patient file iens w/decimals" - I $$DEVICE() D ENTER - Q - ; -ENTER ; - D READ - D ^%ZISC - I $D(ZTQUEUED) S ZTREQ="@" - Q -DEVICE() ; - ;Description: allows the user to select a device. - ; - ;Output: - ; Function Value - Returns 0 if the user decides not to print or to - ; queue the report, 1 otherwise. - ; - N OK,IOP,POP,%ZIS - S OK=1 - S %ZIS="MQ" - D ^%ZIS - S:POP OK=0 - D:OK&$D(IO("Q")) - .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP - .S ZTRTN="ENTER^DG53P604",ZTDESC="Patient file iens w/decimals" - .D ^%ZTLOAD - .W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") - .D HOME^%ZIS - .S OK=0 - Q OK - ; -READ ; - ; - N DFN,COUNT,DGSSN,DGWHEN,DGDTCARE - S (COUNT,DFN)=0 - F S DFN=$O(^DPT(DFN)) Q:'DFN D - .; merged record - .I $D(^DPT(DFN,-9)) Q - .; in process of being merged - .I $P($G(^DPT(DFN,0)),U)["MERGING INTO" Q - .I DFN'["." Q - .I $D(^DPT(DFN,0)) D - ..S DGSSN=$P($G(^DPT(DFN,0)),U,9) - ..S DGWHEN=$P($G(^DPT(DFN,0)),U,16) - ..S DGDTCARE=$P($G(^DPT(DFN,1010.15)),U) - ..S COUNT=COUNT+1 - ..S ^XTMP("DG53P604",$J,DFN)=DGSSN_"^"_DGWHEN_"^"_DGDTCARE - ; - D PRINT - Q - ; -PRINT ; - U IO - N DGDDT,DGQUIT,DGPG - S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D") - S (DGQUIT,DGPG)=0 - D HEAD - I '$G(COUNT) D Q - .W !!!,?20,"*** No records to report ***" - W !!,"*** COUNT OF PATIENT RECORDS:",COUNT," ***",!! - S DFN=0 - F S DFN=$O(^XTMP("DG53P604",$J,DFN)) Q:'DFN D Q:DGQUIT - .I $Y>(IOSL-4) D HEAD - .S DGSSN=$P($G(^XTMP("DG53P604",$J,DFN)),U) - .S DGWHEN=$P($G(^XTMP("DG53P604",$J,DFN)),U,2) - .S DGWHEN=$$FMTE^XLFDT(DGWHEN,"D") - .S DGDTCARE=$P($G(^XTMP("DG53P604",$J,DFN)),U,3) - .S DGDTCARE=$$FMTE^XLFDT(DGDTCARE,"D") - .W ?2,DFN,?20,DGSSN,?37,DGWHEN,?56,DGDTCARE,! - ; - I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q - I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 - I $D(ZTQUEUED) S ZTREQ="@" - Q - ; -HEAD ; - I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q - I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1 - Q:DGQUIT - S DGPG=$G(DGPG)+1 - W @IOF,!,DGDDT,?15,"DG*5.3*604 Patient File iens w/decimals",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,! - W ! - W !,?2,"DFN",?23,"SSN",?37,"Date Record Created",?58,"Most Recent Care Date",! - S $P(X,"-",81)="" W X,! - Q diff -auBN ./r1/DG53S451.m ./r2/r/DG53S451.m --- ./r1/DG53S451.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DG53S451.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,124 +0,0 @@ -DG53S451 ;ALB/TDM - Combat Veteran End Date Synchronization ; 6/3/04 3:43pm - ;;5.3;Registration;**451**; Aug 13,1993 - ;This post install routine will loop through the "E" cross reference - ;of the PATIENT (#2) file and trigger a Z07 message to the HEC system - ;for all entries that have a value in the COMBAT VETERAN END DATE - ;(#.5295) field that is less than 1/17/03. - Q - ; -EP ;Entry point - N OK - D CHK Q:'OK - D MSG - D QUETASK - Q - ; -QUETASK ;Queue the task - N TXT,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH - S ZTRTN="EP1^DG53S451",ZTIO="",ZTDTH=$$NOW^XLFDT() - S ZTDESC="COMBAT VETERAN END DATE SYNCHRONIZATION PROCESS" - K ^XTMP("DG53S451") - D ^%ZTLOAD S ^XTMP("DG53S451","TASK")=ZTSK - S TXT(1)="Task: "_ZTSK_" Queued." - D BMES^XPDUTL(.TXT) - Q - ; -EP1 ;Entry point - N X1,X2,X,XCVDT,XIEN,TOT,CNT,EVENT,IYR - S X1=DT,X2=60 D C^%DTC - S ^XTMP("DG53S451",0)=X_"^"_$$DT^XLFDT_"^DG*5.3*451 HVE PHASE II POST INSTALL" - S $P(^XTMP("DG53S451","DATE"),"^")=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - ; - ;Create index by patient. - I $D(^DPT("E")) D - . S (XCVDT,XIEN)=0 - . F S XCVDT=$O(^DPT("E",XCVDT)) Q:XCVDT="" D - . . F S XIEN=$O(^DPT("E",XCVDT,XIEN)) Q:XIEN="" D - . . . S ^XTMP("DG53S451","INDEX",XIEN)="" - ; - ;Loop through ^XTMP("DG53S451","INDEX") index. - I $D(^XTMP("DG53S451","INDEX")) D - . S (XIEN,TOT,CNT)=0,EVENT("ENROLL")=1 - . F S XIEN=$O(^XTMP("DG53S451","INDEX",XIEN)) Q:+XIEN=0 D - . . S CVDT=$P($G(^DPT(XIEN,.52)),"^",15) Q:'CVDT ;No CV End Date - . . S TOT=TOT+1,$P(^XTMP("DG53S451",1),"^")=TOT ;Tot records - . . Q:(CVDT>3030116) ;CVEDT>01/16/03 - . . S IYR=$$INCYR(XIEN) Q:'$$LOG^IVMPLOG(XIEN,IYR,.EVENT) ;Queue Z07 - . . S CNT=CNT+1,$P(^XTMP("DG53S451",1),"^",2)=CNT ;Tot Z07's queued - . . S ^XTMP("DG53S451","INDEX",XIEN)="Z07 Queued" - S $P(^XTMP("DG53S451","DATE"),"^",2)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - S ^XTMP("DG53S451","COMPLETED")=1 - D MAIL ;send mailman message to User - D BMES^XPDUTL("Post install process for Combat Veteran End Date synchronization is complete.") - Q - ; -CHK ;check for completion - N TXT,TASKNUM,STAT - S OK=1 - I $D(^XTMP("DG53S451","COMPLETED")) D - . S OK=0 - . N TXT - . S TXT(1)="The Combat Veteran End Date synchronization process was completed in a" - . S TXT(2)="previous run. Nothing Done!" - . D BMES^XPDUTL(.TXT) - ; - S TASKNUM=$G(^XTMP("DG53S451","TASK")) - I +TASKNUM D Q - . S STAT=$$ACTIVE(TASKNUM) - . I STAT>0 D - . . S OK=0 - . . S TXT(1)="Task: "_TASKNUM_" is currently running the Combat Veteran End Date" - . . S TXT(2)="synchronization process. Duplicate processes cannot be started." - . . D BMES^XPDUTL(.TXT) - Q - ; -MSG ;create bulletin message in install file. - N TXT - S TXT(1)="This Post Install routine will queue a Z07 HL7 message to be sent to the" - S TXT(2)="Health Eligibility Center (HEC) for all entries in the PATIENT (#2) file" - S TXT(3)="that have a value in the COMBAT VETERAN END DATE (#.5295) field that is" - S TXT(4)="prior to 1/17/03. " - S TXT(5)=" " - D BMES^XPDUTL(.TXT) - Q - ; -MAIL N SITE,STATN,SITENM,XMDUZ,XMSUB,XMY,XMTEXT,MSG - S SITE=$$SITE^VASITE,STATN=$P($G(SITE),"^",3),SITENM=$P($G(SITE),"^",2) - S:$$GET1^DIQ(869.3,"1,",.03,"I")'="P" STATN=STATN_" [TEST]" - S XMDUZ="CV END DATE SYNCHRONIZATION",XMSUB=XMDUZ_" - "_STATN_" (DG*5.3*451)" - S (XMY(DUZ),XMY(.5))="" - S XMY("terry.moore3@med.va.gov")="",XMY("pat.wilson@med.va.gov")="" - S XMTEXT="MSG(" - S MSG(1)="Combat Veteran End Date synchronization process has completed successfully." - S MSG(1.5)="Task: "_$G(^XTMP("DG53S451","TASK")) - S MSG(2)="" - S MSG(3)="Site Station number: "_STATN - S MSG(4)="Site Name: "_SITENM - S MSG(5)="" - S MSG(6)="Process started at : "_$P($G(^XTMP("DG53S451","DATE")),"^",1) - S MSG(7)="Process completed at : "_$P($G(^XTMP("DG53S451","DATE")),"^",2) - S MSG(8)="Total Veterans processed : "_+$P($G(^XTMP("DG53S451",1)),"^",1) - S MSG(9)="Total Veterans queued for Z07: "_+$P($G(^XTMP("DG53S451",1)),"^",2) - D ^XMD - Q - ; -INCYR(XIEN) ;Get valid income year - N I,LMT,TMP,INCYR - I $D(^IVM(301.5,"APT",XIEN)) Q $O(^IVM(301.5,"APT",XIEN,""),-1) - F I=1,2,4 S LMT=$$LST^DGMTU(XIEN,,I) S:+$G(LMT) TMP($P(LMT,"^",2))="" - I $D(TMP) S LMT=$O(TMP(""),-1),INCYR=($E(LMT,1,3)-1)_"0000" Q INCYR - S INCYR=($E(DT,1,3)-1)_"0000" - Q INCYR - ; -ACTIVE(TASK) ;Checks if task is running - ; input -- The taskman ID - ; output -- 1=The task is running - ; 0=The task is not running - N STAT,ZTSK,Y - S STAT=0,ZTSK=+TASK - D STAT^%ZTLOAD - S Y=ZTSK(1) - I Y=0 S STAT=-1 - I ",1,2,"[(","_Y_",") S STAT=1 - I ",3,5,"[(","_Y_",") S STAT=0 - Q STAT diff -auBN ./r1/DGAPI.m ./r2/r/DGAPI.m --- ./r1/DGAPI.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGAPI.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,74 +0,0 @@ -DGAPI ;WASH/DWS - PTF's APIs ;7/29/04 7:33am - ;;5.3;Registration;**517,594**;Aug 13, 1993 - Q - ; -DATA2PTF(DFN,PTF,PSDATE,USER,FLAG,SOURCE) ;API to pass data for add/edit/delete to PTF - I $G(PTF) Q:'$D(^DGPT(PTF)) -2 - I '$G(PTF) Q:'$G(PSDATE) -2 D FIND Q:'$G(PTF) -2 - I $P($G(^DGPT(PTF,0)),U,6) S ERR="INPATIENT STAY CLOSED, THE PTF SYSTEM CAN BE USED TO RE-OPEN IT." D Q -1 - .I +$G(FLAG) W !,ERR Q - .S ^TMP("PTF",$J,"DIERR")=ERR - Q:'$D(^TMP("PTF",$J)) -3 S FL=0 D PROV I $G(Y)'>0!FL K FL,Y Q -1 - K ERR,FL Q PTF -CPTINFO(DFN,PTF,PSDATE) ;API to get CPT data from PTF - I '$G(PTF) Q:'$G(PSDATE) D FIND Q:'$G(PTF) - S I=0 F S I=$O(^DGPT(PTF,"C",I)) Q:I'>0 I +^(I,0)=PSDATE S ^TMP("PTF",$J,46,0)=$P(^(0),U,2,5),(K,K1)=0 D Q - .F S K=$O(^DGCPT(46,"C",PTF,K)) Q:K'>0 I PSDATE=+$G(^DGCPT(46,K,1)),'$G(^(9)) S K1=K1+1,^TMP("PTF",$J,46,K1)=K_U_^(0) - K I,K,K1 Q -PTFINFOR(DFN,PTF,PSDATE) ;API to get a list of CPT records from PTF - I '$G(PTF) Q:'$G(PSDATE) D FIND Q:'$G(PTF) - S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"C",I)) Q:I'>0 S ^TMP("PTF",$J,I1)=^(I,0) - K I,I1 Q -DELCPT(DA) ;API to delete cpt code from PTF - S PTF=$P($G(^DGCPT(46,DA,1)),U,3) I $P(^DGPT(PTF,0),U,6) K PTF Q -1 - S REC=DA,DIE="^DGCPT(46,",DR="1////^S X=%" L +^DGCPT(46,REC):2 I D NOW^%DTC,^DIE K DIE,DR L -^DGCPT(46,REC) K REC Q 1 - K REC Q -1 -DELPOV(DA) ;API to delete a diagnosis from PTF - S PTF=+$G(^DGICD9(46.1,DA,1)) I $P(^DGPT(PTF,0),U,6) Q -1 - S REC=DA,DIE="^DGICD9(46.1,",DR="9////^S X=%" L +^DGCPT(46.1,REC):2 I D NOW^%DTC,^DIE K DIE,DR L -^DGCPT(46.1,REC) K REC Q 1 - K REC Q -1 -ICDINFO(DFN,PTF,PSDATE,DGI) ;API to get Diagnosis data from PTF - I '$G(PTF),'$G(DGI) Q:'$G(PSDATE) D FIND Q:'$G(PTF) - I $G(PTF) S I=0 F I1=1:1 S I=$O(^DGICD9(46.1,"C",PTF,I)) Q:I'>0 I '$G(^DGICD9(46.1,I,9)) S ^TMP("PTF",$J,46.1,I1)=I_U_^DGICD9(46.1,I,0) - I '$G(PTF),$G(DGI) S ^TMP("PTF",$J,46.1,1)=DGI_U_$G(^DGICD9(46.1,DGI,0)) - K I,I1 Q -FIND ;Find the IEN for the PTF file - S (I,K)=0 F S I=$O(^DGPT("B",DFN,I)) Q:'I I $P(^DGPT(I,0),U,11)=1 S J=$G(^DGPT(I,70)) I J'PSDATE D - .Q:L0 Q - .S DA(1)=PTF,DIE="^DGPT("_PTF_",""C"",",(DA,REC)=+Y,DR="",I=^TMP("PTF",$J,46,0) - .S REFPROV=+I,PERFPROV=$P(I,U,2) S:REFPROV DR=DR_".02////^S X=REFPROV;" S DR=DR_".03////^S X=PERFPROV;" - .S DIAG=$P(I,U,3),LOC=$P(I,U,4) K I S DR=DR_".04////^S X=DIAG;" S:LOC DR=DR_".05////^S X=LOC;" - .L +^DGPT(REC):2 I '$T D ERR(46,"CPT entry is being edited by another user") K DIE,DR,REC Q - .D ^DIE L -^DGPT(REC) K DIE,DR,REFPROV,PERFPROV,REC S DGI=0 F S DGI=$O(^TMP("PTF",$J,46,DGI)) Q:'DGI D CPT - S DGI=0 F S DGI=$O(^TMP("PTF",$J,46.1,DGI)) Q:'DGI D DIAG - S Y=1 Q -CPT ;FILE CPT INFORMATION IN ^DGCPT - S DGJ=0,STR=^TMP("PTF",$J,46,DGI),DLAYGO=46 - I STR S Y=+STR G CPTFL ;if rec num in DGCPT is passed, overlay without any verification of CPT code passed - F S DGJ=$O(^DGCPT(46,"C",PTF,DGJ)) Q:DGJ'>0 I +^DGCPT(46,DGJ,1)=PSDATE,$P(^(0),U)=$P(STR,U,2),'$D(^(9)) S STR=DGJ_STR,Y=DGJ,^TMP("PTF",$J,46,DGI)=STR Q - I 'STR K DO S DIC="^DGCPT(46,",DIC(0)="F",X=$P(STR,U,2) D FILE^DICN K DIC,X Q:Y'>0 S STR=+Y_STR,^TMP("PTF",$J,46,DGI)=STR -CPTFL S Y=+Y_"," F I=1:1:13 S CPT(46,Y,I/100)=$P(STR,U,I+1) - F I=20:1:24 S CPT(46,Y,I/100)=$P(STR,U,I-5) - S CPT(46,Y,.14)=PSDATE,CPT(46,Y,.16)=PTF - S CPT(46,Y,.17)=$G(SOURCE),CPT(46,Y,.18)=$G(USER) - D FILE^DIE("K","CPT","^TMP(""PTF"",$J,46,DGI)") - I $D(^TMP("PTF",$J,46,DGI,"DIERR")) S FL=1 I +$G(FLAG),$D(^("DIERR",1,"TEXT",1)) W !,^(1) - K STR,CPT,DGJ,I Q -DIAG ;FILE DIAGNOSIS INFORMATION IN ^DGCPT - S DGJ=0,STR=^TMP("PTF",$J,46.1,DGI),DLAYGO=46.1 - I STR S Y=+STR G DIAGFL ;if rec num in DGICD9 is passed, overlay without any verification of DGN code passed - F S DGJ=$O(^DGICD9(46.1,"C",PTF,DGJ)) Q:DGJ'>0 I $P(^DGICD9(46.1,DGJ,0),U)=$P(STR,U,2),'$G(^(9)) S STR=DGJ_STR,Y=DGJ,^TMP("PTF",$J,46.1,DGI)=STR Q - I 'STR K DO S DIC="^DGICD9(46.1,",DIC(0)="F",X=$P(STR,U,2) D FILE^DICN K DIC,X Q:Y'>0 S STR=+Y_STR,^TMP("PTF",$J,46.1,DGI)=STR -DIAGFL S Y=+Y_"," F I=1:1:8 S DIAG(46.1,Y,I/100)=$P(STR,U,I+1) - S DIAG(46.1,Y,1.1)=$G(SOURCE),DIAG(46.1,Y,1.2)=$G(USER) - S DIAG(46.1,Y,1)=PTF D FILE^DIE("K","DIAG","^TMP(""PTF"",$J,46.1,DGI)") - I $D(^TMP("PTF",$J,46.1,DGI,"DIERR")) S FL=1 I +$G(FLAG),$D(^("DIERR",1,"TEXT",1)) W !,^(1) - K STR,CPT,DGJ,DIAG,I Q -ERR(FILE,MESS) ;DISPLAY OR PRINT ERROR MESSAGES BASED ON FLAG PARAMETER FOR DATA2PTF - S FL=1 I +$G(FLAG) W !,MESS Q - S ^TMP("PTF",$J,FILE,DGI,"DIERR")=MESS Q diff -auBN ./r1/DGBLRV.m ./r2/r/DGBLRV.m --- ./r1/DGBLRV.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBLRV.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBLRV ;ALB/BOK - PATIENT ADMISSION FORM/BILL REVIEW ; 18 SEP 86 11:00 - ;;5.3;Registration;**26,570**;Aug 13, 1993 + ;;5.3;Registration;**26**;Aug 13, 1993 ; D LO^DGUTL K ^UTILITY($J) START S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G QUIT:Y'>0 S DFN=+Y I '$D(^DGPM("ATID1",DFN)) W !,"No admissions on file, will check scheduled admissions",! G SCHAD @@ -12,22 +12,13 @@ I DGPMDA S DGI=$S($D(^DGPM(DGPMDA,0)):^(0),1:"") Q:DGI']"" S Y=$P(DGI,"^",1) D D^DIQ S DGADT=Y,DGADX=$P(DGI,"^",10),DGWD=$P(DGI,"^",6) G INS S DGI=$O(^DGS(41.1,"B",DFN,0)),DGI=^DGS(41.1,DGI,0),DGSDT=$P(DGI,U,2) S Y=DGSDT D D^DIQ S DGSDT=Y,DGSDX=$P(DGI,U,4),DGWD=$P(DGI,U,8) ; -INS ; -- new insurance logic, modified for IBBAPI insurance call, DG*570 - N DGIBINS,DGIBDT,DGDATA,DGIB,DGX +INS ; -- new insurance logic + N DGIBINS,DGIBDT S DGIBDT=$S($D(DGPMDA):+$G(^DGPM(DGPMDA,0)),$G(DGSDT):DGSDT,1:DT) - S DGIBDT=$P(DGIBDT,".") - S DGIB=$$INSUR^IBBAPI(DFN,DGIBDT,"R",.DGDATA,"*") - S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGIBINS=@DGX - S P=1,I=0 - I DGIB F S I=$O(DGIBINS(I)) Q:'I D - . I DGIBINS(I,11)>DT!(DGIBINS(I,11)="") D - . . K DGINAD D:DGI ADDR - . . S I(P)=+DGIBINS(I,1)_U_DGIBINS(I,14)_U - . . N DGGRP - . . S DGGRP=DGIBINS(I,18) ; Group Policy Number - . . S I(P)=I(P)_$G(DGGRP)_U - . . S I(P)=I(P)_$P(DGIBINS(I,8),U,2)_U_$S($D(DGINAD):DGINAD,1:"NO ADDRESS ON FILE") - . . S P=P+1 + D ALL^IBCNS1(DFN,"DGIBINS",2,DGIBDT) + S P=1 + I $G(DGIBINS(0)) F I=0:0 S I=$O(DGIBINS(I)) Q:'I D + .S DGINS=$G(DGIBINS(I,0)) I $P(DGINS,U,4)>DT!($P(DGINS,U,4)="") K DGINAD D:DGI ADDR S I(P)=+DGINS_U_$P(DGINS,U,2)_U_$P(DGINS,U,3)_U_$P(DGINS,U,5)_U_$S($D(DGINAD):DGINAD,1:"NO ADDRESS ON FILE"),P=P+1 ; PRT K DIC S DIC(0)="M",X="DGBILLREVIEW",DIC="^DIC(47," D ^DIC G QUIT:Y'>0 S DGY=+Y I '$D(DIS(0)) I $$FIRST^DGUTL G Q S P=0 F DGLN=0:0 S DGLN=$O(^DIC(47,+DGY,1,DGLN)) Q:'DGLN S J=^(DGLN,0),X1="" W ! F K=1:1 W $E($P(J,"{}",K),$S(K=1:1,X1']"":1,1:$L(X)+1),999) S X1=$P(J,"{",K+1),P=$S(DGLN<9:1,DGLN<14:2,1:3) Q:X1']"" D CKLN @@ -37,31 +28,31 @@ Q ; CKLN S L=$S(DGLN>9&(DGLN<14):(DGLN-5),DGLN>14&(DGLN<19):(DGLN-10),1:DGLN)_K D @L Q -ADDR ; - S DGINAD=$S(DGIBINS(I,2)]"":DGIBINS(I,2)_", ",1:"")_$S(DGIBINS(I,2)]"":DGIBINS(I,3)_", ",1:"")_$S(DGIBINS(I,4)]"":$P(DGIBINS(I,4),U,2)_", ",1:"")_$S(DGIBINS(I,5)]"":DGIBINS(I,5)_", ",1:"") - Q +ADDR S DGIMULT=$S($D(^DIC(36,+DGINS,.11)):^(.11),1:"") Q:DGIMULT="" + S DGINAD=$S($P(DGIMULT,U,1)]"":$P(DGIMULT,U,1)_", ",1:"")_$S($P(DGIMULT,U,2)]"":$P(DGIMULT,U,2)_", ",1:"")_$S($P(DGIMULT,U,3)]"":$P(DGIMULT,U,3)_", ",1:"")_$S($P(DGIMULT,U,4)]"":$P(DGIMULT,U,4)_", ",1:"") + S DGINAD=DGINAD_$S('$D(^DIC(5,+$P(DGIMULT,U,5),0)):"",$P(^(0),U,1)]"":$P(^(0),U,1)_", ",1:"")_$S($L($P(DGIMULT,U,6))>5:$E($P(DGIMULT,U,6),1,5)_"-"_$E($P(DGIMULT,U,6),6,9),1:$P(DGIMULT,U,6)) Q 21 S Y=DT D DT^DIQ Q 31 W $P(DGINFO,U,1) Q 32 W VA("PID") Q -51 W $S($D(DGIBINS(P)):$P(DGIBINS(P,1),U,2),1:"") Q +51 W $S('$D(I(P)):"",$D(^DIC(36,+I(P),0)):$P(^(0),U),1:"") Q 61 W $S($D(I(P)):$P(I(P),U,5),1:"") Q -71 W $S($D(DGIBINS(P)):DGIBINS(P,6),1:"") Q +71 W $S('$D(I(P)):"",$D(^DIC(36,$P(I(P),"^",K),.13)):$P(^(.13),"^",1),1:"") Q 72 W $S($D(I(P)):$P(I(P),U,2),1:"") Q 73 W $S($D(I(P)):$P(I(P),U,3),1:"") Q -81 W " " Q ; Pre-certification phone# not currently available in API -82 W " " Q ; Billing phone# not currently available in API +81 W $S('$D(I(P)):"",$D(^DIC(36,$P(I(P),"^",1),.13)):$P(^(.13),"^",3),1:"") Q +82 W $S('$D(I(P)):"",$D(^DIC(36,$P(I(P),"^",1),.13)):$P(^(.13),"^",2),1:"") Q 201 W $S($D(DGADX):DGADX,$D(DGSDX):DGSDX,1:"") Q 202 S X=$S(DGWD:DGWD,1:"-") W $S($D(^DIC(42,X,0)):$P(^(0),U,1),1:"") Q 211 W $S($D(DGSDT):DGSDT,1:"") Q 212 W $S($D(DGADT):DGADT,1:"") Q ; EN1 S DIC="^DGPM(",BY="@.01",L=0,FLDS="[DGPMBLRV]",DHD="@" - S DIS(0)="S DFN=$P(^DGPM(D0,0),U,3) I $P(^(0),""^"",2)=1,$D(^DPT(DFN,""VET"")),($P(^(""VET""),""^"",1)=""Y""),$$INSUR^IBBAPI(DFN,"""",""A"")" + S DIS(0)="S DFN=$P(^DGPM(D0,0),U,3) I $P(^(0),""^"",2)=1,$D(^DPT(DFN,""VET"")),($P(^(""VET""),""^"",1)=""Y""),$O(^DPT(DFN,.312,0))" D EN1^DIP,QUIT K BY,DHD,DIC,DIS,FLDS,I Q ; CK ;check logic to see if 3rd party review is asked ;***if this logic is altered, also change line EN1+1 in DIS(0)*** - I $S('$$INSUR^IBBAPI(DFN,"","A"):1,'$D(^DPT(DFN,"VET")):1,^("VET")'="Y":1,1:0) Q + I $S('$O(^DPT(DFN,.312,0)):1,'$D(^DPT(DFN,"VET")):1,^("VET")'="Y":1,1:0) Q ASK ;print TPR? W !,"PRINT THIRD PARTY REVIEW" S %=$S($D(DGDEF):DGDEF,1:2) D YN^DICN I %=2!(%<0) Q diff -auBN ./r1/DGBT1P2.m ./r2/r/DGBT1P2.m --- ./r1/DGBT1P2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBT1P2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,61 +0,0 @@ -DGBT1P2 ;ALB/MRY - Patch #2 Environment Check ; 4/23/02 10:04 AM - ;;1.0;Beneficiary Travel;**2**;Septembr 25, 2001 -EN ; - S XPDABORT="" - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D G ABRT - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("Your programming variables are not set up properly.") - . D MES^XPDUTL("Installation aborted.") - ; Verify that Bene Travel v1.0 exists, else Quit. - I $$VERSION^XPDUTL("DGBT")'="1.0" D G ABRT - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("VERSION 1.0 OF BENEFICIARY TRAVEL HAS NOT BEEN LOADED.") - . D MES^XPDUTL("Installation aborted.") - W !!,">> Environment check complete and okay." - Q - ; -ABRT ; Abort transport, but leave in ^XTMP. - S ^XPDABORT=2 Q - ; -POST ; Post install - add #392.31 file to list of DGBT files in Package file. - N DGBTI,DGBTIEN,DGBTARRY,DIC,X,DA,DR - D BMES^XPDUTL(" ") - D MES^XPDUTL(" Updating PACKAGE File...") - ; -PKG ; Retrieve 'DGBT' Package name - ; Get Package IEN - D FIND^DIC(9.4,"","@;1","P","DGBT","","C","","","DGBTARRY") - S (DGBTI,DGBTIEN)=0 - F S DGBTI=$O(DGBTARRY("DILIST",DGBTI)) Q:'DGBTI D - . Q:$P($G(DGBTARRY("DILIST",DGBTI,0)),"^",2)'="DGBT" - . S DGBTIEN=$P($G(DGBTARRY("DILIST",DGBTI,0)),"^",1) - I 'DGBTIEN D G EXIT - . D BMES^XPDUTL(" ") - . D MES^XPDUTL(" No PACKAGE entry defined - Cannot update!") - ; -UPD ; - Update fields not updated by the KIDS install. - ; fields: - ; File (#6) ; multiple - ; Fields ; multiple - ; -FILE ; Add #392.31 to list of files under Bene Travel. - F X="392.31" D - . S DIC="^DIC(9.4,",DA(1)=DGBTIEN - . S DIC=DIC_DA(1)_",4,",DIC(0)="L",DIC("P")=$P(^DD(9.4,6,0),"^",2) - . D ^DIC - ; -FLDS ; Add ASSIGN A VERSION NUMBER? entries to File entry #392.31 - S DIC="^DIC(9.4,",DA(1)=DGBTIEN,DIC(0)="X" - S DIC=DIC_DA(1)_",4,",DIC("P")=$P(^DD(9.4,6,0),"^",2) - F X="392.31" D - . D ^DIC - . S DIE=DIC,DA=+Y - . I X[392 S DR="222.2///Y" D ^DIE - D BMES^XPDUTL(" ") - D MES^XPDUTL(" Updating PACKAGE file complete.") - ; -DD ;Hardset IDENTIFIER routine into DD (DBIA #4093) - S ^DD(392.31,0,"ID","Z")="G START^DGBTID" - ; -EXIT K DIC,DGBTARRY,DGBTI,DGBTIEN,X,DA,DR - Q diff -auBN ./r1/DGBT1P3.m ./r2/r/DGBT1P3.m --- ./r1/DGBT1P3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBT1P3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,25 +0,0 @@ -DGBT1P3 ;ALB/MRY - Patch #3 Environment Check ; 7/15/03 10:04 AM - ;;1.0;Beneficiary Travel;**3**;Septembr 25, 2001 -EN ; - S XPDABORT="" - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D G ABRT - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("Your programming variables are not set up properly.") - . D MES^XPDUTL("Installation aborted.") - ; Verify that Bene Travel v1.0 exists, else Quit. - I $$VERSION^XPDUTL("DGBT")'="1.0" D G ABRT - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("VERSION 1.0 OF BENEFICIARY TRAVEL HAS NOT BEEN LOADED.") - . D MES^XPDUTL("Installation aborted.") - W !!,">> Environment check complete and okay." - Q - ; -POST ;Post-init. kill off bad cross reference, re-index. - N DIK - D BMES^XPDUTL("*****") - D MES^XPDUTL("Re-indexing 'BB' cross-reference.") - K ^DGBT(392.31,"BB") S DIK="^DGBT(392.31," D IXALL^DIK - Q - ; -ABRT ; Abort transport, but leave in ^XTMP. - S ^XPDABORT=2 Q diff -auBN ./r1/DGBT2.m ./r2/r/DGBT2.m --- ./r1/DGBT2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBT2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGBT2 ;ALB/LM - BENEFICIARY TRAVEL SCREEN 2 ; 07/09/2004 - ;;1.0;Beneficiary Travel;**7,8**;September 25, 2001 +DGBT2 ;ALB/LM - BENEFICIARY TRAVEL SCREEN 2 ;5/24/91 09:19 + ;;1.0;Beneficiary Travel;;September 25, 2001 Q SCREEN ; W @IOF @@ -36,19 +36,15 @@ K %,DGBTDI,DGBTDN Q STOP I $D(DGBTCS) W ?65,$E($S($D(^SD(409.1,+$P(DGBTCSN,"^",10),0)):$P(^(0),"^"),1:"REGULAR"),1,15),! Q -APPT I $D(DGBTCL(101)) W ?14,DGBTCL(101) Q +APPT I $D(DGBTCL) S DGBTCN=+$P(DGBTCL(I),"^") W ?14,$S($D(^SC(DGBTCN,0)):$P(^(0),"^"),1:"Unknown") S Y=I X ^DD("DD") W " (",Y,") " I $D(DGBTCL) D - .W ?14,$P(DGBTCL(I),U)," ("_$$FMTE^DILIBF(I,"5U")_")" - .S X=$P(DGBTCL(I),U,2) - .W ?50,$S(X["NT":"NO ACTION TAKEN",X["N":"NO-SHOW",X["C":"CANCELLED",1:"") - .W ?66,$P("C&P^10-10^SCHED.^UNSCHED.",U,+$P(DGBTCL(I),U,3)) - .W ?73,$S($D(^SD(409.1,+$P(DGBTCL(I),U,4),0)):$P(^SD(409.1,+$P(DGBTCL(I),U,4),0),U),1:"REGULAR"),! + .S X=$P(DGBTCL(I),"^",2) + .W ?50,$S(X["NT":"NO ACTION TAKEN",X["N":"NO-SHOW",X["C":"CANCELLED",1:""),?66,$P("C&P^10-10^SCHED.^UNSCHED.","^",+$P(DGBTCL(I),"^",7)),?73,$S($D(^SD(409.1,+$P(DGBTCL(I),"^",16),0)):$E($P(^(0),"^"),1,7),1:"REGULAR"),! Q PAST W:'$O(^DGBT(392,"AI",DFN,9999999.99999-DGBTDTI)) !!,"Past Claims: NONE RECORDED" I $O(^DGBT(392,"AI",DFN,9999999.99999-DGBTDTI)) W !!?14,"Date/Time",?35,"Account",?55,"Deductible",?69,"Amt. Paid",!!,"Past Claims: " S J=0 F DGBTP=9999999.99999-DGBTDTI:0 S DGBTP=$O(^DGBT(392,"AI",DFN,DGBTP)) Q:'DGBTP S DGBTPDT=^DGBT(392,"AI",DFN,DGBTP),VADAT("W")=DGBTPDT D ^VADATE W ?14,VADATE("E") D ACCT S J=J+1 Q:J=5 Q ACCT W ?35,$S($P(^DGBT(392,DGBTPDT,0),"^",6):$E($P(^DGBT(392.3,$P(^(0),"^",6),0),"^"),1,15),1:"") D AMT Q -AMT N X3 ;Fresh copy for COMMA^%DTC. Leftovers causing error. - S X=$P(^DGBT(392,DGBTPDT,0),"^",9),X2="2$" D COMMA^%DTC W ?54,X S X=$P(^(0),"^",10) D COMMA^%DTC W ?67,X,! K VADAT,VADATE,X,X2 +AMT S X=$P(^DGBT(392,DGBTPDT,0),"^",9),X2="2$" D COMMA^%DTC W ?54,X S X=$P(^(0),"^",10) D COMMA^%DTC W ?67,X,! K VADAT,VADATE,X,X2 Q diff -auBN ./r1/DGBTCD.m ./r2/r/DGBTCD.m --- ./r1/DGBTCD.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTCD.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTCD ;ALB/SCK - BENEFICIARY TRAVEL CLAIM DISPLAY; 12/15/92 4/14/93 - ;;1.0;Beneficiary Travel;**2,7,9**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 Q SCREEN Q:'$D(^DGBT(392,DGBTDT,0)) S U="^" K DGBTVAR F I=0,"A","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"") S DGBTACCT=$S($D(^DGBT(392.3,+$P(DGBTVAR(0),U,6),0)):$P($G(^(0)),U,5),1:0) @@ -24,22 +24,20 @@ ELIG W !!," Eligibility: " W:$P(DGBTVAR(0),U,3) $P(^DIC(8,$P(DGBTVAR(0),U,3),0),U) W:$P(DGBTVAR(0),U,4)]"" ?45,"SC%: ",$P(DGBTVAR(0),U,4) I $P(DGBTVAR(0),U,5) W ?57,"Cert. Date: " S VADAT("W")=9999999-$P($P(DGBTVAR(0),U,5),".") D ^VADATE W $P(VADATE("E"),"@") K VADAT,VADATE ACCT W !!?5,"Account: ",$S($P(DGBTVAR(0),U,6):$E($P(^DGBT(392.3,$P(DGBTVAR(0),U,6),0),U),1,15),1:"") W:$P(DGBTVAR("A"),U,3) ?31,"REVIEW VISIT" - W ?51,"Most Econ. Cost: " S X=$P(DGBTVAR(0),U,8),X2="2$" N X3 D COMMA^%DTC W X + W ?51,"Most Econ. Cost: " S X=$P(DGBTVAR(0),U,8),X2="2$" D COMMA^%DTC W X ATT I DGBTACCT=4!(DGBTACCT=5) W !,"Attend/Payee: ",$S($D(DGBTVAR("A")):$P(DGBTVAR("A"),U,2),1:"") I DGBTACCT'=4&(DGBTACCT'=5) W !," Mode/Trans.: ",$S($P(DGBTVAR("A"),U,4):$P(^DGBT(392.4,$P(DGBTVAR("A"),U,4),0),U),1:"") - I $D(^DG(43,1,"BT")) I $P(^DG(43,1,"BT"),U,2)=1 W ?51,"Meals & Lodging: " S X=$P(DGBTVAR("M"),U,4) N X3 D COMMA^%DTC W X + I $D(^DG(43,1,"BT")) I $P(^DG(43,1,"BT"),U,2)=1 W ?51,"Meals & Lodging: " S X=$P(DGBTVAR("M"),U,4) D COMMA^%DTC W X I DGBTACCT=4!(DGBTACCT=5) W !,"One Way/" - I DGBTACCT'=4&(DGBTACCT'=5) D - . S DGX=$S($P(DGBTVAR(0),U,7):"Carrier",$P(DGBTVAR(0),U,14):"CoreFLS",1:"Carrier") W:DGX["FLS" !,"CoreFLS Carrier: " W:DGX["Carrier" !?5,"Carrier: " - . W $E($S((DGX["FLS"&$P(DGBTVAR(0),U,14)):$P(^DGBT(392.31,$P(DGBTVAR(0),U,14),0),U),(DGX["Carrier"&$P(DGBTVAR(0),U,7)):$P(^PRC(440,$P(DGBTVAR(0),U,7),0),U),1:""),1,27) K DGX - I $D(^DG(43,1,"BT")) I $P(^DG(43,1,"BT"),U,2)=1 W ?46,"Ferry, Bridges, Etc.: " S X=$P(DGBTVAR("M"),U,5) N X3 D COMMA^%DTC W X + I DGBTACCT'=4&(DGBTACCT'=5) W !?5,"Carrier: ",$S($P(DGBTVAR(0),U,7):$P(^PRC(440,$P(DGBTVAR(0),U,7),0),U),1:"") + I $D(^DG(43,1,"BT")) I $P(^DG(43,1,"BT"),U,2)=1 W ?46,"Ferry, Bridges, Etc.: " S X=$P(DGBTVAR("M"),U,5) D COMMA^%DTC W X I DGBTACCT=4!(DGBTACCT=5) W !?2,"Round Trip: ",$S($P(DGBTVAR("M"),U)=1:"ONE WAY",$P(DGBTVAR("M"),U)=2:"ROUND TRIP",1:"") I DGBTACCT'=4&(DGBTACCT'=5) W !,"Auth. Person: " I $P(DGBTVAR("A"),U) W $S($D(DGBTVAR("A"))&($D(^VA(200,$P(DGBTVAR("A"),U),0))):$P(^VA(200,$P(DGBTVAR("A"),U),0),U),1:"") - I DGBTACCT=4!(DGBTACCT=5) W ?46,"Total Mileage Amount: " S X=$P(DGBTVAR("M"),U,3) N X3 D COMMA^%DTC W X + I DGBTACCT=4!(DGBTACCT=5) W ?46,"Total Mileage Amount: " S X=$P(DGBTVAR("M"),U,3) D COMMA^%DTC W X I DGBTACCT=4!(DGBTACCT=5) W !,"Mileage/" -DED W ?48,"Applied Deductible: " S X=$P(DGBTVAR(0),U,9) N X3 D COMMA^%DTC W X +DED W ?48,"Applied Deductible: " S X=$P(DGBTVAR(0),U,9) D COMMA^%DTC W X W ! W:DGBTACCT=4!(DGBTACCT=5) ?5,"One Way: ",$P(DGBTVAR("M"),U,2)_" MILES" - W ?52,"Amount Payable: " S X=$P(DGBTVAR(0),U,10) N X3 D COMMA^%DTC W X + W ?52,"Amount Payable: " S X=$P(DGBTVAR(0),U,10) D COMMA^%DTC W X REMARK W !!,"Remarks: ",$S($D(^DGBT(392,DGBTDT,"R")):$P(^DGBT(392,DGBTDT,"R"),U),1:"") QUIT K DGBTCNA,DGBTCSZ,DGBTFCTY,DGBTTCTY,DGBTCNA,DGBTDIV,VADAM,X,X2,I Q diff -auBN ./r1/DGBTCE.m ./r2/r/DGBTCE.m --- ./r1/DGBTCE.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTCE.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTCE ;ALB/SCK - BENEFICIARY TRAVEL CLAIM RE-ENTER/EDIT; 12/15/92 06/04/93 - ;;1.0;Beneficiary Travel;**2**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 Q SCREEN ; D QUIT^DGBTCE1 @@ -23,12 +23,7 @@ DIE1 ; S DGBTMLT=$S($D(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):DGBTOWRT*DGBTML*DGBTMR,1:""),$P(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT,$P(DGBTVAR("M"),"^",3)=DGBTMLT ; - S DIE="^DGBT(392,",DA=DGBTDT - I 'DGBTCORE D - . S DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X" - I DGBTCORE S DR="" D - . S DR(1,392,1)="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;" - . S DR(1,392,2)="@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X" + S DIE="^DGBT(392,",DA=DGBTDT,DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X" DIE3 ; D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q ; diff -auBN ./r1/DGBTCR.m ./r2/r/DGBTCR.m --- ./r1/DGBTCR.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTCR.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES; 2/7/88@08:00 ;6/11/93@09:30 - ;;1.0;Beneficiary Travel;**7**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 ;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM START Q:'$D(DGBTDT) S DGBTVAR(0)=$G(^DGBT(392,+DGBTDT,0)),DGBTACCT=$P($G(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)),"^",5) @@ -31,7 +31,6 @@ D PID^VADPT6 S DGBTSSN=VA("PID"),DGBTDOB=$E(VADM(3),4,7)_($E(VADM(3),1,3)+1700) S DGBTSCP=$S($L($P(VAEL(3),"^",2)<3):"0",1:"")_$P(VAEL(3),"^",2) MILES S DGBTM6=$P(DGBTVAR("M"),"^")*$P(DGBTVAR("M"),"^",2) - N X3 S X2="2$",X=DGBTM6*DGBTM7 D COMMA^%DTC S DGBTM8=X S X=$P(DGBTVAR("M"),"^",4) D COMMA^%DTC S DGBTM9=X S X=$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM10=X diff -auBN ./r1/DGBTCSL.m ./r2/r/DGBTCSL.m --- ./r1/DGBTCSL.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTCSL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,133 +0,0 @@ -DGBTCSL ;ALB/MRY- Local Vendor additions (COREFLS) ; 07/15/02@0900 AM - ;;1.0;Beneficiary Travel;**2,3**;September 25, 2001 - Q - ; -CSLASK() ; ask CoreFLS query - ; output: Y ( 1 := "YES", 0 := "NO", <1 := ABORT ) - N DIR,Y - S DIR("A")="DO YOU WANT TO QUERY CoreFLS FOR A VENDOR" - S DIR(0)="Y",DIR("B")="NO" - D ^DIR Q:$D(DIRUT) -1 - Q +Y - ; -CSLIEN() ; make CoreFLS query call returning IEN - ; output: Y ( <1 := invalid IEN, >0 := IEN ) - N OUT,DGBTI,DGBTLINE,DGBTFLD,DIERR -ASK S OUT="" - D VENQ^CSLVQ(.OUT) - I OUT="",$O(OUT(""))="" Q -1 ; assuming ^abort response - I $D(OUT("ERROR")) K OUT G ASK - I $G(OUT("NAME"))=""!($G(OUT("NUMBER"))="")!($G(OUT("SITE_CODE"))="") G BAD - D FLDBLD - ; verify KEY fields sent in OUT array - N FDA,FDAIEN F DGBTI="NUMBER","SITE_CODE" D - . S FDA(392.31,"+1,",DGBTFLD(DGBTI))=$G(OUT(DGBTI)) - S Y=$$KEYVAL^DIE("","FDA","DIERR") - ; only process new entries or edit duplicate entries - I 'Y,(DIERR("DIERR",1)'=740) G BAD - D CLEAN^DILF -NEW ; process new entries - I Y D G:$D(DIERR) BAD Q +FDAIEN(1) - . S DGBTI="" F S DGBTI=$O(DGBTFLD(DGBTI)) Q:DGBTI="" D - . . S FDA(392.31,"+1,",DGBTFLD(DGBTI))=$G(OUT(DGBTI)) - . D UPDATE^DIE("EK","FDA","FDAIEN","DIERR") -EDIT ; edit existing entries - N VAL - ;S VAL(1)=FDA(392.31,"+1,",.01) - S VAL(1)=FDA(392.31,"+1,",.03) - S VAL(2)=FDA(392.31,"+1,",.02) - S Y=$$FIND1^DIC(392.31,"","KQ",.VAL,"","","") - I Y<1 G BAD - K VAL S DGBTI="" F S DGBTI=$O(DGBTFLD(DGBTI)) Q:DGBTI="" D - . S VAL(392.31,+Y_",",DGBTFLD(DGBTI))=$G(OUT(DGBTI)) - D FILE^DIE("","VAL","DIERR") - I $D(DIERR) G BAD - Q +Y - ; -FLDBLD ; build helpful field array DGBTFLD(field name) = field number - F DGBTI=1:1 S DGBTLINE=$T(FLDS+DGBTI) Q:$P(DGBTLINE,";",3)="END" D - . S DGBTFLD($P(DGBTLINE,";",3))=$P(DGBTLINE,";",4) - Q - ; -STAND ; Standalone Query call - N Y,X - S X="CSLVQ" X ^%ZOSF("TEST") I '$T D Q - . W !,"** COMMUNICATIONS SERVICE LIBRARY (CSL) PACKAGE NOT INSTALLED **" - W !!,"** CoreFLS national database query **" -ASKS S Y=$$CSLIEN W ! Q:Y<1 - I +Y>0 W !,"** LOCAL VENDOR (#392.31) File updated. **" - G ASKS - ; -FLDS ; - ;;NAME;.01 - ;;NUMBER;.02 - ;;SITE_CODE;.03 - ;;TAXID;.04 - ;;AREA_CODE;.05 - ;;PHONE;.06 - ;;FAX_AREA_CODE;.07 - ;;FAX;.08 - ;;ADDRESS1;1.01 - ;;ADDRESS2;1.02 - ;;ADDRESS3;1.03 - ;;CITY;2.01 - ;;STATE;2.02 - ;;ZIP;2.03 - ;;SITE_CODE;.03 - ;;LAST_UPDATED;3.01 - ;;INACTIVE;3.02 - ;;END - ; -BAD ; unsuccessful query - W !,"Unsuccessful Query!" - D CLEAN^DILF - Q -1 - ; - ;----------------------------------------------- - ; -PREV(Y) ; called from OUTPUT TRANSFORM - ; input: Y := internal value - ; output: Y ;= converted to external value - ; DGBTV:= internal value - N DGBTV - I '$D(^DGBT(392.31,+Y,0)) Q -1 - S DGBTV=Y,Y=$P(^DGBT(392.31,+Y,0),U) - Q +DGBTV - ; -AFTER(FILE,IEN,DGBTX,DGBTV) ; called from template, or DR string - ; input: IEN := Dzero variable - ; DGBTX := entered response (X) from call - ; DGBTV := previous value of entry - ; output: -1 := no success with entry - ; >0 := vendor updated - I DGBTX'=DGBTV Q 1 ; change was made, don't prompt for CoreFLS query - N DIR,Y,X,FDATA,DIERR - ; if equal, null, or vendor wasn't in local vendor file, prompt for CoreFLS query -ASK2 S Y=$$CSLASK() - I DGBTX,(DGBTX=DGBTV),'Y Q 1 - Q:Y<1 +Y - ; - ; make CoreFLS query call - W !,"** CoreFLS Query **" - S Y=$$CSLIEN() I +Y<1 G ASK2 - Q:+Y<1 +Y - ; - ; Y = IEN of vendor, file vendor in Bene Travel field - ; - I FILE=392 D - . S FDATA(392,IEN_",",14)=+Y - I FILE=680 D - . S FDATA(680,IEN_",",2.6)=+Y - I FILE="680.6" D - . S FDATA(680.6,IEN_",",.09)=+Y - I FILE=681 D - . S FDATA(681,IEN_",",3.01)=+Y - D FILE^DIE("","FDATA","DIERR") - I '$D(DIERR) W !,"** LOCAL VENDOR (#392.31) File updated. **" Q +Y - Q -1 - ; -ADD ; Standalone query - I '$P($G(^DG(43,1,"BT")),"^",4) D Q - . W !,"**COREFLS Vendor interface is not active." - D STAND - Q diff -auBN ./r1/DGBTE1.m ./r2/r/DGBTE1.m --- ./r1/DGBTE1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTE1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,11 +1,11 @@ -DGBTE1 ;ALB/SCK/EG - BENEFICIARY TRAVEL FIND OLD CLAIM DATES ; 1/28/05 11:17am - ;;1.0;Beneficiary Travel;**8,12**;September 25, 2001 +DGBTE1 ;ALB/SCK - BENEFICIARY TRAVEL FIND OLD CLAIM DATES ;11/23/92@0800 03/19/93 + ;;1.0;Beneficiary Travel;;September 25, 2001 DATE ; get date for claim, either new or past date K ^TMP("DGBT",$J),^TMP("DGBTARA",$J),DIR I 'DGBTNEW S DIR("A",2)="Enter a 'P' to display Past CLAIM dates for editing." S DIR("A",3)="Time is required when adding a new CLAIM.",DIR("A",4)="",DIR("A",1)="",DIR("A")="Select TRAVEL CLAIM DATE/TIME",DIR("?")="^D HELP^DGBTE1A" S DIR(0)="F",DIR("B")="NOW" D ^DIR K DIR G ERR1:$D(DIRUT) - S CHZFLG=0,%DT="EXR",DTSUB=$S(Y="N":"NOW",Y="P":"OLD",Y="p":"OLD",1:"OTHR")_"^DGBTE1A" D @DTSUB K DTSUB + S CHZFLG=0,%DT="EXR",DTSUB=$S(Y="N":"NOW",Y="P":"OLD",Y="p":"OLD",1:"OTHR") D @DTSUB^DGBTE1A K DTSUB G ERR1:$D(DTOUT),DATE:Y1<0 S DGBTA=Y1 G SET:CHZFLG DATE1 ; for past claims, set DGBTDT to inverse date of claim date I $D(^DGBT(392,"C",DFN)) D @@ -70,16 +70,7 @@ . X ^DD("DD") ; date conversion, y=cert date (internal) . S DGBTCD=Y,X=DGBTCA,X2="0$",X3=8 K Y D COMMA^%DTC S DGBTCA=X K X,X2,X3 APPTS ; search patient file for appointments through claim date (DTI+1), adddates to array DGBTCL - N DGARRAY,CLIEN,APTDT S DGARRAY("FLDS")="2;3;10;18" - S DGARRAY(4)=DFN,I=$$SDAPI^SDAMA301(.DGARRAY) - ;if dfn = 101, e.g., it's not clear if it is an error or clinic or patient - ;if an error, there will be no lower subscripts eg 01/20/2005 - I $D(^TMP($J,"SDAMA301",101))=1 S I1=1,DGBTCL(101)="** Appointment Database Unavailable **" - I $D(^TMP($J,"SDAMA301",101))'=1 D - .S CLIEN="" F S CLIEN=$O(^TMP($J,"SDAMA301",DFN,CLIEN)) Q:'CLIEN D - ..S APTDT=DGBTDTI\1 F S APTDT=$O(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT)) Q:'APTDT!(APTDT>(DGBTDTI+1)) D - ...S DGBTCL(APTDT)=$P($P(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT),U,2),";",2)_U_$P($P(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT),U,3),";")_U_$P($P(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT),U,18),";")_U_$P($P(^TMP($J,"SDAMA301",DFN,CLIEN,APTDT),U,10),";") - K ^TMP($J,"SDAMA301"),DGARRAY,CLIEN,APTDT + F I=0:0 S I=$O(^DPT(DFN,"S",I)) Q:'I!(I>(DGBTDTI+1)) I $P(I,".")=$P(DGBTDTI,".") S DGBTCL(I)=^(I,0) EXIT ; exit routine Q ERR1 ; error condition diff -auBN ./r1/DGBTEE.m ./r2/r/DGBTEE.m --- ./r1/DGBTEE.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTEE.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTEE ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT; 12/3/92@1600 - ;;1.0;Beneficiary Travel;**2**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 Q SCREEN ; D SCREEN^DGBTEE1 Q:DGBTTOUT=-1!(DGBTTOUT=1) Q:'$D(^DGBT(392,DGBTDT,0)) @@ -29,13 +29,9 @@ D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q DIE2 ; stuff eligibility data, SC%, acct. type S DIE("NO^")="12345" S:'$D(DGBTCD) DGBTCD="" - I 'DGBTCORE D - . S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2" - I DGBTCORE D - . S DR(1,392,1)="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;" - . S DR(1,392,2)="@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2" + S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2" DIE3 ; get most econ. cost - D ^DIE K DR I X=""!(X="^") S DGBTTOUT=-1 Q + D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q ; function $$diclkup passes the city's record #, division name, and flag for MEC (3), the MEC is returned S:$D(DGBTREC) DGBTME=$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,3) S:DGBTME="" DGBTME=0 S DR="8//"_DGBTME_";S DGBTME=X" D ^DIE I X=""!(X="^") S DGBTTOUT=-1 G EXIT diff -auBN ./r1/DGBTEF1.m ./r2/r/DGBTEF1.m --- ./r1/DGBTEF1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTEF1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,7 +1,7 @@ DGBTEF1 ;ALB/SCK - BENEFICIARY TRAVEL UPDATE PARAMETERS INTO FILES ;12/14/92 3/12/93 - ;;1.0;Beneficiary Travel;**2**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 RATES ;enter/edit bene travel parameters;option DGBT BENE TRAVEL RATES - S DA=1,DR="720;723;721",DIE="^DG(43," D ^DIE G QUIT:X="^"!($D(DTOUT))!($D(Y)) K DA,DE,DQ,DR,DIE + S DA=1,DR="720;721",DIE="^DG(43," D ^DIE G QUIT:X="^"!($D(DTOUT))!($D(Y)) K DA,DE,DQ,DR,DIE W !!,"New travel rates are determined each fiscal year. The rates should be",!,"entered each year with the effective date of Oct 1.",! W !,"Changing values for the current or past fiscal years could result in changes",!,"to the claims already entered.",! DATE ; change deductible rates for FY diff -auBN ./r1/DGBTEF.m ./r2/r/DGBTEF.m --- ./r1/DGBTEF.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTEF.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTEF ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT CERTIFICATION FILE ; 12/8/92 03/11/93 - ;;1.0;Beneficiary Travel;**7**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 CERT ; D QUIT S DIC="^DPT(",DIC(0)="AEQMZ" W !! D ^DIC K DIC G QUIT:Y'>0 S DFN=+Y G:'$O(^DGBT(392.2,"C",DFN,0)) ADD S DGBT=$O(^(0)) @@ -20,7 +20,6 @@ S VADAT("W")=9999999.99999-DGBTA D ^VADATE W " ",VADATE("E") K DD,DO S X=DGBTDT,DINUM=DGBTA,DIC="^DGBT(392.2,",DIC(0)="L",DIC("DR")="2////"_DFN D FILE^DICN K DIC("DR") L G:Y'>0 CERT DIE ; - N X3 ;Clean copy used by COMMA^%DTC S X=$$LST^DGMTU(DFN,"",1) I $G(X),$D(^DGMT(408.31,+X,0)) S X=$P(^(0),"^",4),X2="0$" D COMMA^%DTC S DGBTMTI=X K X,X2 W !!,"REPORTED MEANS TEST INCOME: ",DGBTMTI ;I $D(^DG(41.3,DFN,0)),$D(^(1,0)),$D(^(2,0)) S DGBTMTD=$P(^DG(41.3,DFN,1,$P(^(1,0),"^",3),0),"^",3),X=$P(^DG(41.3,DFN,2,$P(^(2,0),"^",3),0),"^",4),X2="0$" D COMMA^%DTC S DGBTMTI=X K X,X2 W !!,"REPORTED MEANS TEST INCOME: ",DGBTMTI D 6^VADPT S DGBTCC=$S($D(^DIC(5,+VAPA(5),1,+VAPA(7),0)):$P(^(0),"^",3),1:""),DGBTEL=$P(VAEL(1),"^",2) diff -auBN ./r1/DGBTE.m ./r2/r/DGBTE.m --- ./r1/DGBTE.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTE.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTE ;ALB/SCK-BENEFICIARY TRAVEL SETUP/MAIN ENTRY CALL UP; 11/20/92@1000; 11/25/92 - ;;1.0;Beneficiary Travel;**2**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 START ; D QUIT^DGBTEND ; kill all variables S PRCABN=1,IOP="HOME" D ^%ZIS K IOP @@ -31,9 +31,6 @@ . ; check for certifying official and that current (or past) FY deductable is set up . W !!,"***WARNING...BENE TRAVEL PARAMETERS HAVE NOT BEEN SET UP",!,"USE THE BENEFICIARY TRAVEL PARAMETER RATES ENTER/EDIT OPTION TO PROPERLY INITIALIZE" ; -COREFLS ; coreFLS vendor interface active/inactive - S DGBTCORE=$P($G(^DG(43,1,"BT")),U,4) - ; SCREEN ; display B/T claim information through screen1 D SCREEN^DGBT1 I '+VAEL(1) W !!,"Eligibility is missing from registration and is required to continue." G EXIT2 diff -auBN ./r1/DGBTID.m ./r2/r/DGBTID.m --- ./r1/DGBTID.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTID.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,93 +0,0 @@ -DGBTID ;ALB/MRY - LOCAL VENDOR IDENTIFIER DATA ;4/23/03 09:11 AM - ;;1.0;Beneficiary Travel;**2**;September 25, 2001 -START ;DISPLAY IDENTIFYING DATA FROM RECORD IN FILE 392.31 - N LN0,LN1,LN2,LN3,PHONE,PH,A,T,T1,NO,ADDR1,CITY,STATE - N ZIP,ADDR2,FAX,IEN - ; - ;GET CURRENT RECORD NODES NEEDED TO DISPLAY IDENTIFIERS - ; - S IEN=+Y - S LN0=$G(^DGBT(392.31,IEN,0)) - S LN1=$G(^DGBT(392.31,IEN,1)) - S LN2=$G(^DGBT(392.31,IEN,2)) - S LN3=$G(^DGBT(392.31,IEN,3)) - ; - ;DISPLAY ADDRESS DATA IN IDENTIFIERS - ; - S ADDR1="ADD:"_$P(LN1,U) - D EN^DDIOL(ADDR1,"","!") - ; - ;DISPLAY DATA (BYPASS PHONE) IF VENDOR IS INACTIVATED. - ; - I $P(LN3,U,2)'="" G IEN - ; - ;DISPLAY DATA IN IDENTIFIERS IF VENDOR IN NOT INACTIVATED - ; - S PHONE="PH:" - S PH=$P(LN0,U,6) I $P(LN0,U,5) S PH=$P(LN0,U,5)_" "_PH - D PHONE - S PHONE=PHONE_PH - D EN^DDIOL(PHONE,"","?54") - ; - ;COME HERE TO DISPLAY THE RECORD'S INTERNAL ENTRY NUMBER - ; -IEN S NO=" "_IEN - S NO="NO:"_$E(NO,$L(NO)-5,99) - D EN^DDIOL(NO,"","?71") - ; - ;NOW DISPLAY SECOND ADDRESS LINE IN IDENTIFIERS - ; - S CITY=$P(LN2,U) - S STATE=$P(LN2,U,2) - I STATE>0 D - . S STATE=$P($G(^DIC(5,STATE,0)),U,2) - S ZIP=$P(LN2,U,3) - I ZIP?9N S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9) - S ADDR2="" - I CITY]"",STATE]"" S ADDR2=ADDR2_CITY_", "_STATE - I CITY="",STATE]"" S ADDR2=ADDR2_STATE - I CITY]"",STATE="" S ADDR2=ADDR2_CITY - S:ADDR2]"" ADDR2=ADDR2_" "_ZIP - S:ADDR2="" ADDR2=ADDR2_ZIP - D EN^DDIOL(ADDR2,"","!?8") - ; - S FAX="FAX:" - K PH - S PH=$P(LN0,U,8) I $P(LN0,U,7) S PH=$P(LN0,U,7)_" "_PH - D PHONE - S FAX=FAX_PH - D EN^DDIOL(FAX,"","?64") - ; - ;END OF ADDRESS LINES - ; - ;LETS INFORM USER IF THIS VENDOR IS INACTIVATED - ; - D EN^DDIOL("","","!") - I $P(LN3,U,2)'="" D - . D EN^DDIOL("****THIS VENDOR IS INACTIVE","","?0") - ; - Q - ; -PHONE ;PHONE/FAX FORMATTING - ; - S PH=$TR(PH,"abcdefghijklmnoprstuvwxy","222333444555666777888999") - S PH=$TR(PH,"ABCDEFGHIJKLMNOPRSTUVWXY","222333444555666777888999") - I PH]"" D - . I PH'?.N D Q - . . S A=1 - . . F S T=$E(PH,1) D:T?1N S:T'?1N PH=$E(PH,2,99) Q:PH="" - . . . S PH(A)="" - . . . F S T1=$E(PH,1) Q:T1'?1N S PH(A)=PH(A)_T1,PH=$E(PH,2,99) Q:PH="" - . . . Q:PH="" - . . . S A=A+1 - . . . Q - . . I $G(PH(1))="011" S PH="INTERN'L" Q - . . I $L($G(PH(1)))=1,$L($G(PH(2)))=3,$L($G(PH(3)))=3,$L($G(PH(4)))=4 S PH=PH(2)_"-"_PH(3)_"-"_PH(4) Q - . . I $L($G(PH(1)))=3,$L($G(PH(2)))=3,$L($G(PH(3)))=4 S PH=PH(1)_" "_PH(2)_"-"_PH(3) Q - . . I $L($G(PH(1)))=3,$L($G(PH(2)))=4 S PH=" "_PH(1)_"-"_PH(2) Q - . . I $L($G(PH(1)))=3,$L($G(PH(2)))=7 S PH=PH(1)_" "_$E(PH(2),1,3)_"-"_$E(PH(2),4,7) - . . Q - . I $L(PH)>9 S PH=$E(PH,1,3)_" "_$E(PH,4,6)_"-"_$E(PH,7,10) Q - . I $L(PH)>6 S PH=" "_$E(PH,1,3)_"-"_$E(PH,4,7) Q - . Q - Q diff -auBN ./r1/DGBTOA1.m ./r2/r/DGBTOA1.m --- ./r1/DGBTOA1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTOA1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTOA1 ;ALB/TT,ALB/MAC - BENEFICIARY TRAVEL OUTPUTS ;4/22/91 12:50 - ;;1.0;Beneficiary Travel;**2**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 D QUIT D DT^DICRW,ASK2^DGBTDIV G QUIT:Y<0 S VAUTNI=1,(DGBTBEG,DGBTEND)=0 BEG W ! S %DT="AEX",%DT("A")="Enter beginning date: " D ^%DT S DGBTBG=Y,DGBTBEG=Y-.0001 G:X="^"!(X="") QUIT END W ! S %DT("A")="Enter ending date: " D ^%DT G:X="^" QUIT I Y<1 D HELP^%DTC G END @@ -25,8 +25,7 @@ Q ACCT S VAUTVB="VAUTN",DIC="^DGBT(392.3,",VAUTSTR="account",VAUTNI=2,DIC("S")="I $P(^(0),U,3)'>DGBTEND&('$P(^(0),U,4)!($P(^(0),U,4)>DGBTBG))" D FIRST^VAUTOMA Q -CAR I '$P($G(^DG(43,1,"BT")),U,4) S VAUTVB="VAUTN",PRCABN=0,DIC="^PRC(440,",VAUTSTR="carrier",VAUTNI=2 D FIRST^VAUTOMA - I $P($G(^DG(43,1,"BT")),U,4) S VAUTVB="VAUTN",PRCABN=0,DIC="^DGBT(392.31,",VAUTSTR="CoreFLS Carrier",VAUTNI=2 D FIRST^VAUTOMA +CAR S VAUTVB="VAUTN",PRCABN=0,DIC="^PRC(440,",VAUTSTR="carrier",VAUTNI=2 D FIRST^VAUTOMA Q TYP S DIR("A")="Would you like ALL Account Types",DIR(0)="Y",DIR("B")="NO",DIR("?")="Enter 'Yes' if you wish to include ALL Account Types or press Return to select individual Account Types." D ^DIR K DIR Q:$D(DTOUT)!($D(DUOUT)) diff -auBN ./r1/DGBTOA2.m ./r2/r/DGBTOA2.m --- ./r1/DGBTOA2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTOA2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,11 +1,9 @@ DGBTOA2 ;ALB/TT,ALB/MAC - BENEFICIARY TRAVEL OUTPUTS (Cont) ;2/21/91 15:57 - ;;1.0;Beneficiary Travel;**2,7**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 ;sort by ACCT, CARrier or PATient=DGBTBY ;associated cross-ref =DGBTIX START D NOW^%DTC S Y=$E(%,1,12) S VADAT("W")=Y D ^VADATE S U="^",DGBTDT=VADATE("E"),$P(DGBTCL,"=",81)="",(DGBTU,DGBTA,DGBTV,DGBT2,DGBTDV,DGBTCH,DGBTS,DGBTSD,X2,DGBTD,DGBTU,DGBTY,DGBT4,DGBTDN,DGBTI,DGBTOTX)=0 D PID^VADPT - S DGBTIX=$S(DGBTSL="ACCT":"AC",DGBTSL="CAR":"AS",DGBTSL="TYP":"ACTP",1:"C") - I $P($G(^DG(43,1,"BT")),U,4) S DGBTIX=$S(DGBTSL="CAR":"AFLS",1:DGBTIX) - D SORT G:DGBTU QUIT1 I $D(^UTILITY($J)) D TOTAL^DGBTOA4 G QUIT1 + S DGBTIX=$S(DGBTSL="ACCT":"AC",DGBTSL="CAR":"AS",DGBTSL="TYP":"ACTP",1:"C") D SORT G:DGBTU QUIT1 I $D(^UTILITY($J)) D TOTAL^DGBTOA4 G QUIT1 W !,"=====>NO PATIENTS FOUND" QUIT1 D CLOSE^DGBTUTQ Q ;Loops thru the "AC","AS","ACTP" or "C" X-ref, depending upon selected sort list @@ -18,9 +16,7 @@ Q:'$D(^DGBT(392,DGBTD,0)) S DGBTK=^DGBT(392,DGBTD,0) Q:'$D(^DPT(+$P(DGBTK,U,2),0)) S DGBTO=^(0),DGBTDN=$S($P(DGBTK,U,11):$P(DGBTK,U,11),1:""),DGBTDV=$S('DGBTDN:"ZNOT SPECIFIED",1:$P(^DG(40.8,DGBTDN,0),U,1)) Q:('VAUTD)&'$D(VAUTD(+DGBTDN)) - I '$P($G(^DG(43,1,"BT")),U,4) S DGBTB=$S($P(DGBTK,U,7):$P(^PRC(440,$P(DGBTK,U,7),0),U,1),1:"") - I $P($G(^DG(43,1,"BT")),U,4) S DGBTB=$S($P(DGBTK,U,14):$P(^DGBT(392.31,$P(DGBTK,U,14),0),U,1),1:"") - S DGBTK9=$P(DGBTK,U,9),DGBTK10=$P(DGBTK,U,10) + S DGBTB=$S($P(DGBTK,U,7):$P(^PRC(440,$P(DGBTK,U,7),0),U,1),1:""),DGBTK9=$P(DGBTK,U,9),DGBTK10=$P(DGBTK,U,10) S DGBTCW=$S('+$P(DGBTK,U,6):"UNKNOWN",1:$P(^DGBT(392.3,+$P(DGBTK,U,6),0),U,1)),DGBTCH=$S(+DGBTCW:+DGBTCW,1:""),DGBTC=$S(+DGBTCW:$E($P(DGBTCW," ",2,$L(DGBTCW," ")),1,15),1:"") S (DGBTG,DGBTXX)=0,DGBTI=$S(DGBTSL="PAT":$P(DGBTO,U,1),DGBTSL="CAR":DGBTB,1:DGBTC) S DGBTP=$P(DGBTO,U,1),DFN=$P(DGBTK,U,2) D PID^VADPT6 S SSN=$S(VA("PID")]"":VA("PID"),1:"UNKNOWN") D PATU:DGBTSL="PAT",ACCTU:DGBTSL'="PAT" @@ -32,8 +28,7 @@ ;Sets up Utility for valid patients PATU S ^UTILITY($J,1,DGBTDN,DGBTP,SSN,DGBTD)=DGBTP_U_DGBTK10_U_DGBTCH_U_DGBTC_U_DGBTB_U_DGBTK9,DGBTK=^(DGBTD) Q ;Sets up Utility for valid accounts, account types and carriers -ACCTU S DGBTCW=$S(DGBTSL="CAR"&('$P($G(^DG(43,1,"BT")),U,4)):$P(^PRC(440,DGBTBY,0),U,1),DGBTSL="CAR"&($P($G(^DG(43,1,"BT")),U,4)):$P(^DGBT(392.31,DGBTBY,0),U,1),1:DGBTCW) - S DGBTOTX(DGBTDN,DGBTCW)=$S('$D(DGBTOTX(DGBTDN,DGBTCW)):0,1:DGBTOTX(DGBTDN,DGBTCW)),DGBTOTX(DGBTDN,DGBTCW)=DGBTOTX(DGBTDN,DGBTCW)+1 +ACCTU S DGBTCW=$S(DGBTSL="CAR":$P(^PRC(440,DGBTBY,0),U,1),1:DGBTCW),DGBTOTX(DGBTDN,DGBTCW)=$S('$D(DGBTOTX(DGBTDN,DGBTCW)):0,1:DGBTOTX(DGBTDN,DGBTCW)),DGBTOTX(DGBTDN,DGBTCW)=DGBTOTX(DGBTDN,DGBTCW)+1 S DGBTPTC(DGBTDV)=$S('$D(DGBTPTC(DGBTDV)):0,1:DGBTPTC(DGBTDV)) S DGBTPTC(DGBTDV)=DGBTPTC(DGBTDV)+1 S ^UTILITY($J,1,DGBTDN,DGBTCW,DGBTP,SSN,DGBTD)=DGBTP_U_DGBTK10_U_DGBTCH_U_DGBTC_U_DGBTB_U_DGBTK9,DGBTK=^(DGBTD) Q -CM N X3 D COMMA^%DTC Q +CM D COMMA^%DTC Q diff -auBN ./r1/DGBTOA3.m ./r2/r/DGBTOA3.m --- ./r1/DGBTOA3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTOA3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTOA3 ;ALB/TT,ALB/MAC - BENEFICIARY TRAVEL OUTPUTS PR ROUTINE ;4/4/91 15:29 - ;;1.0;Beneficiary Travel;**7**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 ;Loops thru ^Utility PR Q:'$D(^UTILITY($J)) S (DGBTDN,DGBTF,DGBTX,DGBTS,DGBTSD,DGBTDD,DGBT3,DGBTCH,DGBTSDT,DGBTAT,DGBTGT,DGBTP,DGBTSSN,DGBTD1,DGBTPG,SSN)=0 F K1=0:0 S DGBTDN=$O(^UTILITY($J,1,DGBTDN)) Q:DGBTDN=""!(DGBTU) D NO S:DGBTZ="T" DGBTPG=0 D:DGBTZ="T" SM^DGBTOA4 D:DGBTF TT,RT Q:DGBTU D:DGBTZ="T"&(DGBT3) RT Q:DGBTU D HE^DGBTOA4 D PRA:DGBTSL'="PAT",PRP:DGBTSL="PAT" @@ -41,5 +41,5 @@ K X S X2="2$",X=$P(DGBTOD,"^",2),DGBTSDT=DGBTSDT+X D CM W X,?52 S X2="2$",X=$P(DGBTOD,"^",1),DGBTAT=DGBTAT+X D CM W X K X2 S DGBTGT(DGBTDV)=DGBTAT_"^"_DGBTSDT Q ;Totals for only totals report TTT D RP Q:DGBTU D DTC^DGBTOA4 S DGBT3=1 Q -CM N X3 D COMMA^%DTC Q +CM D COMMA^%DTC Q NO S DGBTDV=$S('$D(^DG(40.8,DGBTDN,0)):"UNKNOWN",1:$P(^DG(40.8,DGBTDN,0),"^")) S:DGBTDV']"" DGBTDV="UNKNOWN" Q diff -auBN ./r1/DGBTOA4.m ./r2/r/DGBTOA4.m --- ./r1/DGBTOA4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTOA4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGBTOA4 ;ALB/MAC - BENEFICIARY OUTPUTS HEADER ROUTINE ;2/21/91 15:57 - ;;1.0;Beneficiary Travel;**7**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 ;Adds up totals DTC K X,X2 I DGBTSL="PAT" S:DGBTZ="T" DGBTSSN=SSN I DGBTSL="PAT" S DGBTOD=$S(DGBTZ="F":^UTILITY($J,2,DGBTDD,DGBTX1,DGBTSSN,"T"),1:^UTILITY($J,2,DGBTDN,DGBTX,DGBTSSN,"T")) I DGBTSL'="PAT" S DGBTOD=$S(DGBTZ="F":^UTILITY($J,2,DGBTDD,DGBTX1,"T"),1:^UTILITY($J,2,DGBTDN,DGBTX,"T")) @@ -42,4 +42,4 @@ S X2="2$",X=$P(DGBTGT(DGBTDV),"^",1),DGBTAT=DGBTAT+X D CM W ?46,X S X2="2$",X=$P(DGBTGT(DGBTDV),"^",1)+$P(DGBTGT(DGBTDV),"^",2),DGBTGT=DGBTGT+X D CM W ?60,X I DGBTSL'="PAT" W ?74,$J(DGBTPTC(DGBTDV),6) S DGBT3=1 D:$O(DGBTGT(DGBTDV))'="" RP Q -CM N X3 D COMMA^%DTC Q +CM D COMMA^%DTC Q diff -auBN ./r1/DGBTOA5.m ./r2/r/DGBTOA5.m --- ./r1/DGBTOA5.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTOA5.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,8 +1,8 @@ DGBTOA5 ;ALB/SCK - BENEFICIARY TRAVEL OUTPUTS FRONT END/STATISTICS; 2/22/93@10:00 7/2/93 - ;;1.0;Beneficiary Travel;**5**;September 25, 2001 + ;;1.0;Beneficiary Travel;;September 25, 2001 Q START ; - N X3 K DIR + K DIR S (DGBTBG,DGBTEND)=0 W @IOF OPT ; display report options for reports, front-end for claims reports W !?18,"BENEFICIARY TRAVEL REPORT OUTPUTS",! diff -auBN ./r1/DGBTPRE.m ./r2/r/DGBTPRE.m --- ./r1/DGBTPRE.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTPRE.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,16 +0,0 @@ -DGBTPRE ;ALB/RJS - PREINSTALL FOR PATCH DGBT*1.0*4 - ;;1.0;Beneficiary Travel;**4**;August 12, 2003 - ;; THIS IS A PREINSTALL ROUTINE TO DELETE THE OPTIONS - ;; [DGBT LOCAL VENDOR ADD] AND [DGBT LOCAL VENDOR UPDATE] - ;; TO ENSURE THAT THEY INSTALL CLEAN - ;; - N DIC,X,DGBTFDA,DA - S DIC="^DIC(19,",DIC(0)="X",X="DGBT LOCAL VENDOR ADD" - D ^DIC - S DA=+Y,DR=".01////@",DIE=DIC - D ^DIE - S DIC="^DIC(19,",DIC(0)="X",X="DGBT LOCAL VENDOR UPDATE" - D ^DIC - S DA=+Y,DR=".01////@",DIE=DIC - D ^DIE - Q diff -auBN ./r1/DGBTVUP.m ./r2/r/DGBTVUP.m --- ./r1/DGBTVUP.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBTVUP.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,112 +0,0 @@ -DGBTVUP ;ALB/MRY-UPDATE LOCAL VENDOR FILE W/ COREFLS VENDORS ;7/15/2003 - ;;1.0;Beneficiary Travel;**2,3**;September 25, 2001 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ; the subroutines in this program are part of the Update Vendor - ; File event. It builds a global array of the vendor ids for - ; the CoreFLS local vendor file update with CoreFLS Vendor records. - ; The vendor IDs are passed to CoreFLS via DGBT software so - ; retrieval of CoreFLS Vendor records can be done. The retrieved - ; records are sent back to VistA for update to the local vendor - ; file (#392.31). - ; -EN ; entry point for Update Vendor REcords option - ; build temporary global containing CoreFLS vendor ids - N X S X="CSLVQ" X ^%ZOSF("TEST") I '$T W !!," ** COREFLS Package CSL V1.0 not installed. **" Q - I '$D(^DGBT(392.31)) W !!,$C(7),"There are no CoreFLS Vendor IDs stored in the CoreFLS Local Vendor File (392.31)",!,"Vendor File Update cannot occur." Q - W !?5,"Update of the CoreFLS Local Vendor file (#392.31) will begin." - N DGBTDA,DGBTNUM,DGBTSITE,DGBTDATE - S DGBTDA=0 F S DGBTDA=$O(^DGBT(392.31,DGBTDA)) Q:'DGBTDA D - . S DGBTNUM=$$GET1^DIQ(392.31,DGBTDA_",",.02,"I") ; site number - . S DGBTSITE=$$GET1^DIQ(392.31,DGBTDA_",",.03,"I") ; site - . S DGBTDATE=$$GET1^DIQ(392.31,DGBTDA_",",3.01,"I") ; date of last update - . I DGBTNUM="",DGBTSITE="" Q - . S ^TMP("DGBTVUP",$J,DGBTDA)=DGBTNUM_"^"_DGBTSITE_"^"_DGBTDATE - ; DGBT API is called to pass list of vendor ids for processing - ; The vendor update operates asynchronously using a callback model - ; input - 1st argument is Name of an array (local or global) - ; containing ID, Site ID and Date of Last Update for each - ; vendor to be updated - ; 2nd argument is the entry point for the DGBT software to - ; call once CoreFLS returns the vendor records. This - ; entry point belongs to the API that will perform the - ; COREFLS LOCAL VENDOR file (392.31) update. - D UPDATE^CSLVQ($NA(^TMP("DGBTVUP",$J)),"UPD^DGBTVUP") - Q - ; -UPD(DGBTARRY) ; - ; DGBTARRY is an input and is the name of the global or local arry - ; containing the vendor record(s) retrieved from the CoreFLS - ; vendor tables via a request from DGBT software - ; - N DGBTFDA,DGBTVDA,DGBTIDX - S (DGBTIDX,DGBTVDA,DGBTCNT)=0 - F S DGBTIDX=$O(@DGBTARRY@(DGBTIDX)) Q:'DGBTIDX D - . S DGBTVDA=$O(^DGBT(392.31,"BB",@DGBTARRY@(DGBTIDX,"SITE_CODE"),@DGBTARRY@(DGBTIDX,"NUMBER"),"")) - . I 'DGBTVDA S DGBTCNT=DGBTCNT+1,^TMP("DGBTUPDERR",$J,DGBTCNT)="No record entry found for CoreFLS Vendor Number and Vendor Site Name "_@DGBTARRY@(DGBTIDX,"NUMBER")_", "_@DGBTARRY@(DGBTIDX,"SITE_CODE") Q - . D FILE - D GETERRM,SMSG - Q - ; -FILE ; file into existing entry - L +^DGBT(392.31,DGBTVDA):30 - I '$T S DGBTCNT=DGBTCNT+1,^TMP("DGBTUPDERR",$J,DGBTCNT)="Record entry "_DGBTVDA_"could not be locked during COREFLS LOCAL VENDOR file update process. Record entry update with CoreFLS Vendor record not performed." Q - I $D(@DGBTARRY@(DGBTIDX,"NAME")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",.01)=@DGBTARRY@(DGBTIDX,"NAME") - I $D(@DGBTARRY@(DGBTIDX,"NUMBER")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",.02)=@DGBTARRY@(DGBTIDX,"NUMBER") - I $D(@DGBTARRY@(DGBTIDX,"TAXID")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",.04)=@DGBTARRY@(DGBTIDX,"TAXID") - I $D(@DGBTARRY@(DGBTIDX,"AREA_CODE")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",.05)=@DGBTARRY@(DGBTIDX,"AREA_CODE") - I $D(@DGBTARRY@(DGBTIDX,"PHONE")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",.06)=@DGBTARRY@(DGBTIDX,"PHONE") - I $D(@DGBTARRY@(DGBTIDX,"FAX_AREA_CODE")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",.07)=@DGBTARRY@(DGBTIDX,"FAX_AREA_CODE") - I $D(@DGBTARRY@(DGBTIDX,"FAX")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",.08)=@DGBTARRY@(DGBTIDX,"FAX") - I $D(@DGBTARRY@(DGBTIDX,"ADDRESS1")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",1.01)=@DGBTARRY@(DGBTIDX,"ADDRESS1") - I $D(@DGBTARRY@(DGBTIDX,"ADDRESS2")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",1.02)=@DGBTARRY@(DGBTIDX,"ADDRESS2") - I $D(@DGBTARRY@(DGBTIDX,"ADDRESS3")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",1.03)=@DGBTARRY@(DGBTIDX,"ADDRESS3") - I $D(@DGBTARRY@(DGBTIDX,"CITY")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",2.01)=@DGBTARRY@(DGBTIDX,"CITY") - I $D(@DGBTARRY@(DGBTIDX,"STATE")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",2.02)=@DGBTARRY@(DGBTIDX,"STATE") - I $D(@DGBTARRY@(DGBTIDX,"ZIP")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",2.03)=@DGBTARRY@(DGBTIDX,"ZIP") - I $D(@DGBTARRY@(DGBTIDX,"SITE_CODE")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",.03)=@DGBTARRY@(DGBTIDX,"SITE_CODE") - I $D(@DGBTARRY@(DGBTIDX,"LAST_UPDATED")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",3.01)=@DGBTARRY@(DGBTIDX,"LAST_UPDATED") - I $D(@DGBTARRY@(DGBTIDX,"INACTIVE_DATE")) D - . S DGBTFDA(1,392.31,DGBTVDA_",",3.02)=@DGBTARRY@(DGBTIDX,"INACTIVE_DATE") - D FILE^DIE("","DGBTFDA(1)","") - L -^DGBT(392.31,DGBTVDA) - Q - ; -GETERRM ; pull any exceptions from FM output array and assign to ^TMP - Q:'$D(DIERR) ; quit if no output array - N DGBTERRC,DGBTERRT,DGBTERRN,DGBTERRP,DGBTCNT,MSGARRY,DGBTERRM - S (DGBTERRC,DGBTERRN)=0,DGBTCNT=1 - F S DGBTERRC=$O(^TMP("DIERR",$J,"E",DGBTERRC)) Q:'DGBTERRC F S DGBTERRN=$O(^TMP("DIERR",$J,"E",DGBTERRC,DGBTERRN)) Q:'DGBTERRN D - . S DGBTERRP=0 F S DGBTERRP=$O(^TMP("DIERR",$J,DGBTERRN,"PARAM",DGBTERRP)) Q:DGBTERRP="" S MSGARRY("PARAM"_DGBTERRP)=DGBTERRP_" "_^(DGBTERRP) - . S DGBTERRT=0 F S DGBTERRT=$O(^TMP("DIERR",$J,DGBTERRN,"TEXT",DGBTERRT)) Q:'DGBTERRT S MSGARRY("TEXT"_DGBTERRT)=^(DGBTERRT) - . S DGBTERRM="" F S DGBTERRM=$O(MSGARRY(DGBTERRM)) Q:DGBTERRM="" S DGBTCNT=DGBTCNT+1,^TMP("DGBTUPDERR",$J,DGBTCNT)=MSGARRY(DGBTERRM) - ; clean FM error message output array - D CLEAN^DILF - Q - ; -SMSG ; necessary assignment of variables for MAILMAN processing - N XMDUZ,XMSUB,XMTEXT,XMY,DGBTSITE - S DGBTSITE=$P($$SITE^VASITE,"^",2) - S X=$T(+0) X ^%ZOSF("RSUM") S ^TMP("DGBTUPDERR",$J,1)="CoreFLS Local Vendor file update run at "_DGBTSITE_" = "_Y - S XMY("YORTY.M@MNTVBB.FO-ALBANY.MED.VA.GOV")="" - S %DT="T",X="NOW" D ^%DT,DD^LRX S DGBTNOW=Y - S XMSUB="CoreFLS Local Vendor file update at "_DGBTSITE_" at "_DGBTNOW,XMDUZ="UPDATE VENDOR RECORDS post-update message" - S XMTEXT="^TMP(""DGBTUPDERR"",$J," - D ^XMD - K ^TMP("DGBTUPDERR",$J) - Q diff -auBN ./r1/DGBUL.m ./r2/r/DGBUL.m --- ./r1/DGBUL.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGBUL.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,18 +1,11 @@ DGBUL ;ALB/MRL - SEND DG BULLETIN ; 22 MAY 1987 - ;;5.3;Registration;**31,244,545**;Aug 13, 1993 + ;;5.3;Registration;**31**;Aug 13, 1993 ; N DIC,DIX,DIY,DO,DD I '$D(DGB),'$D(XMSUB) G Q K:$D(DGTEXT) XMTEXT I '$D(DGTEXT)&('$D(XMTEXT)) G Q S DGB=+$P($G(^DG(43,1,"NOT")),"^",DGB) I '$D(^XMB(3.8,DGB,0)) G Q - ; - ;Protect Fileman from Mailman call - N DICRREC,DIDATA,DIEFAR,DIEFCNOD,DIEFDAS,DIEFECNT,DIEFF,DIEFFLAG - N DIEFFLD,DIEFFLST,DIEFFREF,DIEFFVAL,DIEFFXR,DIEFI,DIEFIEN,DIEFLEV - N DIEFNODE,DIEFNVAL,DIEFOUT,DIEFOVAL,DIEFRFLD,DIEFRLST,DIEFSORK - N DIEFSPOT,DIEFTMP,DIEFTREF,DIFLD,DIFM,DIQUIET,DISYS,D,D0,DA - ; S XMY("G."_$P($G(^XMB(3.8,DGB,0)),"^",1))="" ; pass mailgroup G Q:'$D(DUZ) S:'$D(DGSM) DGSM=1 S XMTEXT=$S('$D(XMTEXT):"DGTEXT(",1:XMTEXT),XMDUZ=$S(($D(DUZ)#2):DUZ,1:.5) S:$D(DUZ)#2&(DGSM) XMY(DUZ)="" K:'$D(XMY) DGSM D ^XMD:$D(XMY) Q K DGSM,DGB,DGTEXT,XMR,DGII,XMY,XMTEXT,XMDUZ,XMSUB Q diff -auBN ./r1/DGCV1.m ./r2/r/DGCV1.m --- ./r1/DGCV1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGCV1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,208 +0,0 @@ -DGCV1 ;ALB/ERC,BRM - COMBAT VET REPORTS; 07/10/2003 ; 2/5/04 2:52pm - ;;5.3;Registration;**528,565**; Aug 13, 1993 - ; - ;first report is built during the initial seeding, and called by - ;POST^DG53528P -RPT(DG) ;if, during initial seeding, a veteran could not be evaluated - ;for CV eligibility because of an imprecise date the veteran will be - ;added to the appropriate ^XTMP global - ; Input: DG - the code corresponding to the missing or imprecise date - ; - K VADM - I $G(DG)']"" Q - S ^XTMP("DGCV","REPORT",DFN,DG)="" - Q -REPORT ;if there are veterans in the ^XTMP globals, create a report. - I '$D(^XTMP("DGCV","REPORT")) Q - N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR - K IOP,%ZIS - I $G(XPDQUES("POS1","B"))]"" S ZTIO=$G(XPDQUES("POS1","B")) ;result of install question - I $G(ZTIO)']"" S IOP=$G(^XTMP("DGCV","DEVICE")) - S ZTSAVE("*")="" - S ZTRTN="PRINT^DGCV1",ZTDESC="IMPRECISE COMBAT DATE REPORT" - D ^%ZTLOAD -EXIT ; - K XPDQUES - Q -PRINT ;print report - N PAGE,QUIT,DFN - S PAGE=1 - S QUIT="" - D HDR - N DGF,DGFD,DGLN,DGNAM,DGSSN - S (DGF,DFN)="" - F S DFN=$O(^XTMP("DGCV","REPORT",DFN)) Q:DFN']"" D - . Q:'$D(^DPT(DFN)) - . S (DGNAM,DGSSN)="" - . D DEM(DFN) - . I $G(DGNAM)']""!($G(DGSSN)']"") Q - . S DGLN=DGNAM_"^"_DGSSN - . N DGC - . F S DGF=$O(^XTMP("DGCV","REPORT",DFN,DGF)) Q:DGF']""!(QUIT) D - . . N DGFF - . . I $L(DGF)=1 S DGFF=DGF S DGC=1 D SET - . . I $L(DGF)=2 D - . . . S DGFF=$E(DGF,1),DGC=1 D SET - . . . S DGFF=$E(DGF,2),DGC=2 D SET - W !,">>>>END OF REPORT" - Q -SET ; - I DGFF["A"!(DGFF["F") S DGFD="SERVICE SEP" - I DGFF["B"!(DGFF["G") S DGFD="COMBAT TO" - I DGFF["C"!(DGFF["H") S DGFD="YUGOSLAVIA TO" - I DGFF["D"!(DGFF["I") S DGFD="SOMALIA TO" - I DGFF["E"!(DGFF["J") S DGFD="PERS GULF TO" - I $G(DGFD)']"" Q - S DGFD=DGFD_" DATE "_$S("ABCDE"[DGFF:"IMPRECISE",1:"MISSING") - S DGLN=$S(DGC=1:DGLN_"^"_DGFD,DGC=2:"^^"_DGFD,1:"") - D ADD(DGLN) - Q -DEM(DFN) ; - N VADM - D DEM^VADPT - S DGNAM=$G(VADM(1)) - S DGSSN=$P($G(VADM(2)),U,2) - Q -ADD(DGLN) ;add the line to the report - N DGX - I $P(DGLN,U)]"" W ! - W !?2,$P(DGLN,U),?39,$P(DGLN,U,2),?52,$P(DGLN,U,3) - I $E(IOST,1,2)="C-",($Y>(IOSL-4)) D - . D PAUSE - . Q:QUIT - . D TOP - I '$E(IOST,1,2)="C-",($Y>(IOSL-2)) D TOP - Q - ; -TOP ; - W @IOF - D HDR - Q - ; -HDR ;print header for report - N Y - W !!?5,"REPORT OF UPDATES REQUIRED FOR COMBAT VET STATUS" S Y=DT D DD^%DT W ?62,"Date: ",Y - W !,?62,"Page: ",PAGE - W !!?5,"The following patients could not be evaluated for Combat Veteran" - W !?5,"Eligibility status due to having imprecise or missing dates." - W !!!?2,"Patient Name",?39,"SSN",?52,"Date to be updated" - W !?2,"===================================",?39,"===========",?52,"==========================" - S PAGE=PAGE+1 - Q - ; -RPT2 ;second report is option DG CV STATUS, a report of what veterans were - ;assigned CV status during a specified date range - N DIR,DIRUT,X1,X2,X,Y,DGBEG,DGDT,DGEND - S DIR(0)="DAO^,"_DT - S X1=DT,X2=-7 D C^%DTC - S Y=X D DD^%DT - S DIR("A")="BEGINNING DATE: " - S DIR("B")=Y - S DIR("?")="ENTER THE BEGINNING DATE FOR THE REPORT" - S DIR("??")="^W !,""A BEGINNING AND AN END DATE MUST BE ENTERED FOR THIS REPORT""" - D ^DIR - Q:$D(DIRUT) - S DGBEG=Y - S DIR(0)="DAO^"_DGBEG_","_DT - S Y=DT D DD^%DT S DGDT=Y - S DIR("B")=DGDT - S DIR("A")="ENDING DATE: " - S DIR("?")="ENTER THE ENDING DATE FOR THE REPORT" - D ^DIR - Q:$D(DIRUT) - S DGEND=Y - D REPORT2(DGBEG,DGEND) - Q - ; -REPORT2(DGBEG,DGEND) ; - I $G(DGBEG)']""!($G(DGEND)']"") W !!,"DATE RANGE NOT SET. EXITING" Q - N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR - K IOP,%ZIS - S %ZIS="Q" D ^%ZIS G:POP EXIT2 - I $D(IO("Q")) D Q - . S (ZTSAVE("DGBEG"),ZTSAVE("DGEND"))="" - . S ZTRTN="PRINT2^DGCV1",ZTDESC="COMBAT VET DATE EDITED REPORT" - . D ^%ZTLOAD - . D ^%ZISC,HOME^%ZIS - . W !,$S($D(ZTSK):"REQUEST QUEUED!",1:"REQUEST CANCELLED!") - D PRINT2 -EXIT2 D ^%ZISC,HOME^%ZIS - ;Q +G(ZTSK) - Q -PRINT2 ; - N DGLN,PAGE,QUIT - S QUIT="" - U IO - I $E(IOST,1,2)="C-" W @IOF - S DGLN=0 - S PAGE=1 - D HDR2 - D DATA - I DGLN=0 D - . W !!!,?30,"No data to report." - . I $E(IOST,1,2)="C-" D PAUSE - D EXIT2 - Q -HDR2 ; - N DG1,DG2,Y - S Y=DGBEG D DD^%DT S DG1=Y - S Y=DGEND D DD^%DT S DG2=Y - W !!?15,"COMBAT VETERAN STATUS CHANGED REPORT" - S Y=DT D DD^%DT W ?60,"Date: ",Y - W !?20,DG1_" TO "_DG2 - W ?60,"Page: "_PAGE - W !!!?3,"NAME",?41,"SSN",?63,"CV END DATE",!?41,"PRIORITY GROUP" - W !,?3,"===================================",?41,"=================",?63,"============" - S PAGE=PAGE+1 - Q -DATA ; - N DGENR,DFN,DGNAM,DGSSN,DGDT,DGX,QUIT,Y,VADM - S QUIT="" - Q:$G(DGBEG)']""!($G(DGEND)']"") - S DGX=DGBEG-1 - F S DGX=$O(^DPT("E",DGX)) Q:DGX'>0!(DGX>DGEND) D - . S DFN="" - . F S DFN=$O(^DPT("E",DGX,DFN)) Q:DFN']""!(QUIT) D - . . Q:'$D(^DPT(DFN)) - . . K VADM,DGENR - . . D DEM^VADPT - . . Q:'$D(VADM) - . . S DGNAM=VADM(1) - . . S DGSSN=$P(VADM(2),U,2) - . . S DGDT=$$GET1^DIQ(2,DFN_",",.5295,"E") - . . I $G(DGDT)']"" S DGDT="DELETED!!!!" - . . S DGENR=$$PRIOR(DFN) - . . I $G(DGENR)']"" S DGENR="NONE" - . . D ADD2 - Q -PRIOR(DFN) ;gets priority and sub group - ; - N DGEN,DGIEN,DGSUB - I $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGEN) D - . S DGENR=$G(DGEN("PRIORITY")) - . S DGSUB=$G(DGEN("SUBGRP")) - . I $G(DGSUB)]"" S DGENR=DGENR_$$EXTERNAL^DILFD(27.11,.12,"F",DGSUB) - Q $G(DGENR) -PAUSE ; - N DIR,DIRUT,X,Y - F Q:$Y>(IOSL-3) W ! - S DIR(0)="E" - D ^DIR - I ('(+Y))!($D(DIRUT)) S QUIT=1 - Q -ADD2 ; - I $E(IOST,1,2)="C-",($Y>(IOSL-6)) D - . D PAUSE - . Q:QUIT - . D TOP2 - I '$E(IOST,1,2)="C-",($Y>(IOSL-2)) D TOP2 - I '(QUIT) D LINE - Q -TOP2 ; - W @IOF - D HDR2 - Q -LINE ;add a line to the report - W !?3,DGNAM,?41,DGSSN,?63,DGDT,!?41,DGENR,! - S DGLN=1 - Q diff -auBN ./r1/DGCVEXP.m ./r2/r/DGCVEXP.m --- ./r1/DGCVEXP.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGCVEXP.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,20 +0,0 @@ -DGCVEXP ;ALB/ERC - FIND VETS WIITH EXPIRED CV STATUS; 12/11/02 - ;;5.3;Registration;**576**; Aug 13, 1993 - ; - ;this API will list any veterans who have Combat Vet status that has - ;expired. This API will be called by IB to look for any vets who have - ;been billed for treatment on the last day of their CV eligibility. - ; -EN ; - N DGC,DGE,DGEX,DGFILE - K ^TMP("DGCVEX") - S DGC="" - S DGFILE=2 - F S DGC=$O(^DPT("E",DGC)) Q:DGC'>0 D - . S DGE="" - . F S DGE=$O(^DPT("E",DGC,DGE)) Q:DGE'>0 D - . . S DGEX=$$GET1^DIQ(DGFILE,DGE_",",.5295,"I") - . . I $G(DGEX)']"" Q - . . I DT'>DGEX Q - . . S ^TMP("DGCVEX",$J,DGE,DGEX)="" - Q diff -auBN ./r1/DGCV.m ./r2/r/DGCV.m --- ./r1/DGCV.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGCV.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,187 +0,0 @@ -DGCV ;ALB/DW,ERC,BRM - COMBAT VET ELIGIBILTY; 06/05/2003 ; 6/14/04 1:03pm - ;;5.3;Registration;**528,576,564**; Aug 13, 1993 - ; -CVELIG(DFN) ; - ;API will determine whether or not this vetern needs to have CV End - ;Date set. If this determination cannot be done due to imprecise - ;or missing dates, it returns which dates need editing. - ;Input: - ; DFN - Patient file IEN - ;Output - ; RESULT - ; 0 - CV End Date should not be updated - ; 1 - CV End Date should be updated - ; If critical dates are imprecise return the following - ; A - CV End Date should not be updated, imprecise Service Sep date - ; B - CV End Date should not be updated, imprecise Combat To date - ; C - CV End Date should not be updated, imprecise Yugoslavia To date - ; D - CV End Date should not be updated, imprecise Somalia To date - ; E - CV End Date should not be updated, imprecise Pers Gulf To date - ; If the Service Sep Date is missing, return the following so that it - ; will appear on the Imprecise/Missing Date Report - ; F - missing Service Sep Date - ; If critical dates are missing but the corresponding indicator fields - ; are set to 'YES' return the following - ; G - missing Combat To Date, but Combat Indicated? = 'Yes' - ; H - missing PG To Date, but PG Indicated? = 'Yes' - ; I - missing Somalia To Date, but Somalia Indicator = 'Yes' - ; J - missing Yugoslavia To Date, but Yugoslavia Indicator = 'Yes' - ; - N DG1,DG2,I,RESULT - N DGCOM,DGCVDT,DGCVFLG,DGGULF,DGSOM,DGSRV,DGYUG - S (DG1,DG2,RESULT)=0 - I $G(DFN)']"" Q RESULT - I '$D(^DPT(DFN)) Q RESULT - ; - ;get combat related data from VistA - N DGARR,DGERR - D GETS^DIQ(2,DFN_",",".327;.322012;.322018;.322021;.5294;.5295","I","DGARR","DGERR") - D PARSE - ; - S DG1=$$CHKSSD(DFN) ;check SSD for imprecise or missing - ; - S DGDATE=$G(DGCOM)_"^"_$G(DGYUG)_"^"_$G(DGSOM)_"^"_$G(DGGULF) - S DG2=$$CHKREST(DGDATE) ;check other "TO" dates for imprecise or missing - S RESULT=$$RES(DG1,$G(DG2)) - Q RESULT - ; -RES(DG1,DG2) ;determine the final RESULT code from DGRES1 & DGRES2 - ;if SSD evaluates to earlier than 11/11/98, can't set CV End Date - I DG1=0!($G(DG2)=0) Q 0 - ;if SSD is 1 - I DG1=1,($G(DG2)=1!($G(DG2)']"")) Q 1 - I DG1=1,($G(DG2)=0) Q 0 - I DG1=1 Q DG2 - ;if SSD is imprecise or missing - I DG1'=1,($G(DG2)=1) S DG2="" - Q DG1_DG2 - ; -CHKDATE(DGDATE,I) ;check to see if date is imprecise or missing - ;if imprecise check to see if the imprecision prevents CV evaluation - ;if not imprecise check to see if after 11/11/98 - N RES - S RES=0 - I $G(DGDATE)']"" D Q RES - . S RES=$S(I=0:"F",I=1:"G",I=2:"H",I=3:"I",I=4:"J",1:"") - I $E(DGDATE,6,7)="00" D - . I I=0 I DGDATE>2981111 S RES="A" Q - . I DGDATE=2980000!(DGDATE=2981100) D Q - . . S RES=$S(I=0:"A",I=1:"B",I=2:"C",I=3:"D",I=4:"E",1:"") - Q:RES="A" RES - I DGDATE>2981111 S RES=1 - Q RES - ; -SETCV(DFN,DGSRV) ;calculate CV end date - K DGCVEDT - N DGFDA - I $G(DFN)']""!($G(DGSRV)']"") Q - I '$D(^DPT(DFN)) Q - S DGCVEDT=$P($$SCH^XLFDT("24M",DGSRV),".") - I DGCVEDT=$G(DGCVDT) Q - I $$GET1^DIQ(2,DFN_",",.5295,"I") Q - S DGFDA(2,DFN_",",.5295)=DGCVEDT - D FILE^DIE(,"DGFDA") - Q - ; -CVEDT(DFN,DGDT) ;Provide Combat Vet Eligibility End Date, if eligible - ;Supported DBIA #4156 - ;Input: DFN - Patient file IEN - ; DGDT - Treatment date (optional), - ; DT is default - ;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV - ; Eligible on DGDT(1,0)^is patient eligible on input date? - ; (piece 1) 1 - qualifies as a CV - ; 0 - does not qualify as a CV - ; -1 - bad DFN or date - ; (piece 3) 1 - vet was eligible on date specified (or DT) - ; 0 - vet was not eligible on date specified (or DT) - ; - N RESULT - S RESULT="" - I $G(DFN)="" Q -1 - I '$D(^DPT(DFN)) Q -1 - ;if time sent in, drop time - I $G(DGDT)']"" S DGDT=DT - I DGDT?7N1"."1.6N S DGDT=$E(DGDT,1,7) - I DGDT'?7N Q -1 - S RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I") - I $G(RESULT)']"" Q 0 - S RESULT=$S(DGDT'>RESULT:RESULT_"^1",1:RESULT_"^0") ; if treatment date is earlier or equal to end date, veteran is eligible - S RESULT=$S($G(RESULT):1_"^"_RESULT,1:0) - Q RESULT - ; -PARSE ;GETS^DIQ called in CVELIG - in this subroutine stuff results into array - S DGSRV=$G(DGARR(2,DFN_",",.327,"I")) - S DGCOM=$G(DGARR(2,DFN_",",.5294,"I")) ;Combat To Date - S DGGULF=$G(DGARR(2,DFN_",",.322012,"I")) ;Persian Gulf To Date - S DGSOM=$G(DGARR(2,DFN_",",.322018,"I")) ;Somalia To Date - S DGYUG=$G(DGARR(2,DFN_",",.322021,"I")) ;Yugoslavia To Date - S DGCVDT=$G(DGARR(2,DFN_",",.5295,"I")) ;CV End Date - Q - ; -CHKSSD(DFN) ;check the Serv Sep Date [Last] - ; - ; Output - RESULT - ; 1 - Date is present and after 11/11/1998 - ; 0 - Date is present but before 11/11/1998 - ; A - Date is imprecise & either is or potentially is after 11/11/98 - ; F - Date is missing - N DG1 - I $G(DGSRV)']"" Q "F" - S DG1=$$CHKDATE(DGSRV,0) - I $G(DG1)']"" S DG1=0 - Q DG1 - ; -CHKREST(DGDATE) ; - N DG3,DG4,DGDT,DGFLG,DGLEN,DGQ,DGR,DGRES,DGX - S (DG3,DG4,DGR,DGRES)="" - S DGQ=0 ;loop terminator - S DGFLG=0 ;flag to indicate that one of the dates is missing - F DGX=1:1:4 D - . S DGDT=$P(DGDATE,U,DGX) D - . . I $G(DGDT)']"" S DGFLG=1 ;Q - . . S DG4=$$CHKDATE(DGDT,DGX) - . . I $G(DG4)'=0 S DG3=$G(DG3)_$G(DG4) - S DGLEN=$L(DG3) - S DGQ=0 - F DGX=1:1:DGLEN S DGCHAR=$E(DG3,DGX) D Q:DGQ=1 - . I DGCHAR=1 S DG3=DGCHAR,DGQ=1 Q - . I "BCDE"[DGCHAR S DGR=DGR_DGCHAR,DGQ=2 - I DGQ=1 Q 1 - I DGQ=2 Q $E(DGR) - I DGFLG=1 S DGRES=$$MISS(DFN,DGLEN,DG3) - Q DGRES - ; -MISS(DFN,DGLEN,DGRES) ;there is at least one missing date, and in order to - ;return a RESULT of a missing date, need to check to see if the - ;corresponding indicator field is set to 'YES' - N DGARR,DGCHAR,DGERR,DGQ,DGR,DGX - N DGCIND,DGPGIND,DGSIND,DGYIND - S (DGCHAR,DGQ,DGR)=0 - D GETS^DIQ(2,DFN_",",".32201;.322019;.322016;.5291","I","DGARR","DGERR") - S DGCIND=$G(DGARR(2,DFN_",",.5291,"I")) ;Combat Service Indicated - S DGYIND=$G(DGARR(2,DFN_",",.322019,"I")) ;Yugo service indicated - S DGSIND=$G(DGARR(2,DFN_",",.322016,"I")) ;Somalia service indicated - S DGPGIND=$G(DGARR(2,DFN_",",.32201,"I")) ;Pers Gulf service indicated - F DGX=1:1:DGLEN S DGCHAR=$E(DGRES,DGX) D Q:DGQ=1 - . I DGCHAR="G",($G(DGCIND)="Y") S DGR="G",DGQ=1 Q - . I DGCHAR="H",($G(DGYIND)="Y") S DGR="H",DGQ=1 Q - . I DGCHAR="I",($G(DGSIND)="Y") S DGR="I",DGQ=1 Q - . I DGCHAR="J",($G(DGPGIND)="Y") S DGR="J" - Q DGR -DELCV(DFN) ;called by the Kill logic of the ACVCOM cross reference - ;if $$CVELIG^DGCV returns a 0 the CV End Date should be deleted - ;because this would indicate that fields have been changed and - ;CV eligibility is no longer appropriate - ; - N DGCV,DGFDA - K DGCVFLG - S DGCVFLG=0 - I $G(DFN)']"" Q - I '$D(^DPT(DFN)) Q - S DGCV=$$GET1^DIQ(2,DFN_",",.5295,"I") - I $G(DGCV)']"" Q - S DGCVFLG=1 - S DGFDA(2,DFN_",",.5295)="@" - D FILE^DIE(,"DGFDA") - Q diff -auBN ./r1/DGCVRPT.m ./r2/r/DGCVRPT.m --- ./r1/DGCVRPT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGCVRPT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,141 +0,0 @@ -DGCVRPT ;ALB/PJR - Unsupported CV End Dates Report; ; 6/10/04 12:15pm - ;;5.3;Registration;**564**; Aug 13,1993 - ; -EN ; Called from DG UNSUPPORTED CV END DATES RPT option - N DGSRT - S DGSRT=$$SRT I DGSRT="" Q - D RPTQUE Q -SRT() ; Get sort order - ; OUPUT: Y - Sort (N=Name; D=DFN) - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - S DIR(0)="SA^N:Name;D:DFN (Internal ID)" - S DIR("A")="Sort report by Name or DFN (Internal ID): ",DIR("B")="NAME" - S DIR("?",1)="Indicate whether the report should be sorted by the" - S DIR("?")="Veteran's Name or the Internal ID (DFN) of the Veteran" - D ^DIR I $D(DTOUT)!($D(DUOUT)) Q "" - Q Y - ; -RPTQUE ; Get report device. Queue report if requested. - N POP,ZTRTN,ZTDESC,ZTSAVE,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - K IOP,%ZIS - S %ZIS="MQ" - W ! - D ^%ZIS I POP W !!,*7,"Report Cancelled!",! S DIR(0)="E" D ^DIR Q - I $D(IO("Q")) D Q - .S ZTRTN="RPT^DGCVRPT(DGSRT)" - .S ZTDESC="Print Unsupported CV End Dates Report" - .S ZTSAVE("DGSRT")="" - .D ^%ZTLOAD - .W !!,"Report "_$S($D(ZTSK):"Queued!",1:"Cancelled!") - .W ! S DIR(0)="E" D ^DIR - .D HOME^%ZIS - D RPT(DGSRT) - D ^%ZISC - Q - ; -RPT(DGSRT) ; Entry point to produce report - D EN1,EN2(DGSRT) Q -EN1 ; Extract - N RNAME,DFN,RECCOUNT,SELCOUNT,DGXTMP,RES,CEN,CALC,EDITED - ; Initialize ^XTMP global and set start date - K ^XTMP("DGCVRPT") - S RNAME="DG UNSUPPORTED CV END DATE REPORT" - S ^XTMP("DGCVRPT",0)=$$FMADD^XLFDT(DT,60)_U_DT_U_RNAME - S $P(^XTMP("DGCVRPT","DATE"),U,1)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - S:$G(ZTSK) ZTREQ="@" - ; Set variables and initialize array for counts - S (DFN,RECCOUNT,SELCOUNT,EDITED)=0 - S DGXTMP="^XTMP(""DGCVRPT"",""NOSUP"")" - ; Loop through cross-reference "E" - ; If patient meets report criteria, put on list - F S EDITED=$O(^DPT("E",EDITED)) Q:'EDITED S DFN=0 D - .F S DFN=$O(^DPT("E",EDITED,DFN)) Q:'DFN D CHK I CEN,CEN'=CALC D PUT - S $P(^XTMP("DGCVRPT","DATE"),U,2)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - K ^XTMP("DGCVRPT","RUNNING"),DGXTMP - Q - ; -CHK ; Calculate CV End Date - ; INPUT: DFN - Patient file IEN - ; OUTPUT: CEN = CV End Date on file - ; CALC = Calculated CV End Date - N SSD,N322,I99 - S RECCOUNT=RECCOUNT+1 D CNT - S CALC="",CEN=$P($G(^DPT(DFN,.52)),U,15) I 'CEN Q - N SSD,N322,I99 - S SSD=$P($G(^DPT(DFN,.32)),U,7) I 'SSD Q - I $E(SSD,6,7)="00" Q - I SSD'>2981111 Q - I ($P($G(^DPT(DFN,.52)),U,14))>2981111 D SCH Q - S N322=$G(^DPT(DFN,.322)) - F I99=12,18,21 I $P(N322,U,I99)>2981111 D SCH Q - Q - ; -SCH S CALC=$P($$SCH^XLFDT("24M",SSD),".",1) Q - ; -PUT ; Put record on list - N NAM,SSN,NZERO - S SELCOUNT=SELCOUNT+1 D CNT - S NZERO=$G(^DPT(DFN,0)),NAM=$P(NZERO,U,1),SSN=$P(NZERO,U,9) - S @DGXTMP@("DFN",DFN,0)=NAM_U_SSN_U_CEN - I NAM'="" S @DGXTMP@("NAM",NAM,DFN)="" - Q - ; -CNT S @DGXTMP@("CNT","VET")=SELCOUNT_U_RECCOUNT Q - ; -EN2(DGSRT) ; Print - ; INPUT DGSRT - Sort order for report (Name or DFN) - N PG,LINE,RPTDT,CRT,OUT,DSH,CNT,MXLNE,DGXTMP,DGTOT,LOOP - S:$G(ZTSK) ZTREQ="@" - D PRTVAR - U IO D HDR - ;; - S LOOP="LOOP"_DGSRT - D @LOOP Q:OUT - D TOT Q:OUT - W ! S OUT=$$PAUSE - Q -LOOPN ; Sort by name. Loop through ^XTMP("DGCVRPT","NOSUP","NAM", x-ref - N NM,DFN - S (NM,DFN)="" - F S NM=$O(@DGXTMP@("NAM",NM)) Q:NM=""!OUT D - .F S DFN=$O(@DGXTMP@("NAM",NM,DFN)) Q:DFN=""!OUT D PRINT - Q -LOOPD ; Sort by DFN. Loop through ^XTMP("DGCVRPT","NOSUP","DFN", x-ref - N DFN S DFN=0 - F S DFN=$O(@DGXTMP@("DFN",DFN)) Q:'DFN!OUT D PRINT - Q -PRINT ; Print veteran - N VET - Q:'$D(@DGXTMP@("DFN",DFN)) - S VET=$G(@DGXTMP@("DFN",DFN,0)) - I LINE>MXLNE S OUT=$$PAUSE Q:OUT D HDR - W !,DFN,?12,$P(VET,U,2),?24,$E($P(VET,U,1),1,39),?64,$$FMTE^XLFDT($P(VET,U,3)) - S LINE=LINE+1 Q -TOT ; Print total records at the end of the report - I LINE+4>MXLNE S OUT=$$PAUSE Q:OUT D HDR - W !!,"Total Records Printed: ",$$RJ^XLFSTR($P(DGTOT,U,1),7) - W !!,"Total Records with CV End Dates:",$$RJ^XLFSTR($P(DGTOT,U,2),7) - Q -PRTVAR ; Set up variables needed to print report - S CRT=$S($E(IOST,1,2)="C-":1,1:0) - S DGXTMP="^XTMP(""DGCVRPT"",""NOSUP"")" - S DGTOT=$G(@DGXTMP@("CNT","VET")) - S:$G(DGSRT)="" DGSRT="N" - S (PG,CNT,OUT)=0,RPTDT=$$FMTE^XLFDT(DT),MXLNE=$S(CRT:15,1:52) - S DSH="",$P(DSH,"=",80)="" - Q -HDR ; Print report header - S PG=PG+1,LINE=0 - W @IOF - W ?0,"Report Date: ",RPTDT,?68,"Page: ",$$RJ^XLFSTR(PG,4) - W !,"Sorted By: "_$S(DGSRT="N":"Name",1:"DFN") - W !!,$$CJ^XLFSTR("CV END DATES WITH NO SUPPORTING MS DATA REPORT",80) - W !!,"DFN",?12,"SSN",?24,"Veteran's Name",?64,"CV End Date" - W !,DSH - Q -PAUSE() ; If report is sent to screen, prompt for next page or quit - N DIR,DIRUT,DUOUT,DTOUT,X,Y - I 'CRT Q 0 - S DIR(0)="E" - D ^DIR I 'Y Q 1 - Q 0 diff -auBN ./r1/DGDDC.m ./r2/r/DGDDC.m --- ./r1/DGDDC.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGDDC.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,17 +1,10 @@ DGDDC ;ALB/MRL - X-ECUTE KILL X-REFERENCES [PATIENT] ;25 JUL 88@1337 - ;;5.3;Registration;**489,244,527**;Aug 13, 1993 + ;;5.3;Registration;;Aug 13, 1993 ; - Q:$D(DGNOFDEL) ;Flag variable to prevent deletion cascade - ; - Q:'$D(DGXRF) N DGXRFX,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX - S DGXRFX=X,DGXRF1=+$P(DGXRF,".",2),DGXRF2=$P($T(@DGXRF1),";;",2) G Q:DGXRF2="" + Q:'$D(DGXRF) S DGXRFX=X,DGXRF1=+$P(DGXRF,".",2),DGXRF2=$P($T(@DGXRF1),";;",2) G Q:DGXRF2="" I $D(^DD(2,DGXRF,0)) S DGXRFP=$P(^(0),"^",4),DGXRF6=$P(DGXRFP,";",2),DGXRF5=$P(DGXRFP,";",1) I $D(^DPT(DA,DGXRF5)),($P(^(DGXRF5),"^",DGXRF6)=DGXRFX) G Q - N DGFDA,DGERR - ;F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4="" I $D(^DD(2,DGXRF4,0)) S DGXRF5=$P(^(0),"^",4),DGXRF6=$P(DGXRF5,";",2),DGXRF5=$P(DGXRF5,";",1) I $D(^DPT(DA,DGXRF5)),$P(^(DGXRF5),"^",DGXRF6)'="" D KILL - F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4="" I $D(^DD(2,DGXRF4,0)) S DGXRF5=$P(^(0),"^",4),DGXRF6=$P(DGXRF5,";",2),DGXRF5=$P(DGXRF5,";",1) I $D(^DPT(DA,DGXRF5)),$P(^(DGXRF5),"^",DGXRF6)'="" D - .S DGFDA(2,DA_",",DGXRF4)="" - I $D(DGFDA) D FILE^DIE("","DGFDA","DGERR") -Q S X=DGXRFX K DGXRF Q ;,DGXRFX,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX Q + F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4="" I $D(^DD(2,DGXRF4,0)) S DGXRF5=$P(^(0),"^",4),DGXRF6=$P(DGXRF5,";",2),DGXRF5=$P(DGXRF5,";",1) I $D(^DPT(DA,DGXRF5)),$P(^(DGXRF5),"^",DGXRF6)'="" D KILL +Q S X=DGXRFX K DGXRF,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX Q KILL S DGXRF7=$P(^DPT(DA,DGXRF5),"^",DGXRF6),$P(^DPT(DA,DGXRF5),"^",DGXRF6)="" F DGXRF8=0:0 S DGXRF8=$O(^DD(2,DGXRF4,1,DGXRF8)) Q:'DGXRF8 I $D(^DD(2,DGXRF4,1,DGXRF8,2)) S X=DGXRF7 X:^(2)'["DGXRF" ^(2) D SET I $D(^DD(2,DGXRF4,1,DGXRF8,1)) D SET Q @@ -33,9 +26,6 @@ 12105 ;;.1217^.1218 1211 ;;.1212^.1213 1212 ;;.1213 -14105 ;;.1417^.1418 -1411 ;;.1412^.1413 -1412 ;;.1413 213 ;;.214^.215 214 ;;.215 2193 ;;.2194^.2195 diff -auBN ./r1/DGDEATH.m ./r2/r/DGDEATH.m --- ./r1/DGDEATH.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGDEATH.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,34 +1,22 @@ -DGDEATH ;ALB/MRL/PJR-PROCESS DECEASED PATIENTS ; 10/27/04 9:45pm - ;;5.3;Registration;**45,84,101,149,392,545,595,568,563**;Aug 13, 1993 +DGDEATH ;ALB/MRL-PROCESS DECEASED PATIENTS ;19 JUN 87 + ;;5.3;Registration;**45,84,101,149,392**;Aug 13, 1993 ; GET S DGDTHEN="" W !! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S (DA,DFN)=+Y - S DGDOLD=$G(^DPT(DFN,.35)) I $D(^DPT(DFN,.1)) W !?3,"Patient is currently in-house. Discharge him with a discharge type of DEATH." G GET I $S($D(^DPT(DFN,.35)):^(.35),1:"") F DGY=0:0 S DGY=$O(^DGPM("ATID1",DFN,DGY)) Q:'DGY S DGDA=$O(^(DGY,0)) I $D(^DGPM(+DGDA,0)),$P(^(0),"^",17)]"" S DGXX=$P(^(0),"^",17),DGXX=^DGPM(DGXX,0) I "^12^38^"[("^"_$P(DGXX,"^",18)_"^") G DIS - D NOW^%DTC S DGNOW=% - S ^TMP("DEATH",$J)=1 - K A W ! S DIE=DIC,DR=".351" D ^DIE - I '$D(^DPT(DFN,.35)) K ^TMP("DEATH",$J) G GET - S DGDNEW=^DPT(DFN,.35) - I $P(DGDNEW,"^",1)="",$P(DGDNEW,"^",2)'="" S DR=".352////@" D ^DIE - I $P(DGDNEW,"^",1)="" K ^TMP("DEATH",$J) G GET - I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE - I DGDOLD'=DGDNEW D DISCHRGE - I $P(DGDOLD,"^",1)'=$P(DGDNEW,"^",1) D XFR - K ^TMP("DEATH",$J) G GET + K A W ! S DIE=DIC,DR=".351" D ^DIE G GET ; DIS W !,"Patient has a discharge type of Death",!,"Edit the discharge",! -Q K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN,DGDOLD,DGDNEW,DGDONOT Q +Q K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN Q XFR ; called from set x-ref of field .351 of file 2 N DGPCMM,DGFAPT,DGFAPTI,DGFAPT1 Q:'$D(DFN) - K DGTEXT D ^DGPATV S DGDEATH=$$GET1^DIQ(2,DFN,.351,"I"),XMSUB="PATIENT HAS EXPIRED",DGCT=0 + K DGTEXT D ^DGPATV S DGDEATH=X,XMSUB="PATIENT HAS EXPIRED",DGCT=0 D DEMOG - S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGPMSTAT + S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGINPW S Y=$$FMTE^XLFDT(Y),Y=$S(Y]"":Y,1:"UNKNOWN") - S DGDONOT=0 D APTT3 D LINE("") - D LINE(" Date/Time of Death: "_DEATHVAL_$S(DGDONOT:"",'DG1:"",$D(DGDTHEN):"",1:" (While an inpatient)")) + D LINE(" Date/Time of Death: "_Y_$S('DG1:"",$D(DGDTHEN):"",1:" (While an inpatient)")) D LINE("") I '$D(ADM),DG1,$D(^DGPM(+DGA1,0)) S ADM=+^DGPM($P(^(0),"^",14),0) S Y=$$FMTE^XLFDT($S($D(ADM):ADM,1:"")) @@ -40,11 +28,9 @@ I DG1&'$D(DGDTHEN) D . D LINE($S($D(DGXFR0):" Last Transfer: "_$S($D(^DIC(42,+$P(DGXFR0,"^",6),0)):$P(^(0),"^"),1:"UNKNOWN"),1:"")) . D LINE("") -F N DGARRAY,SDCNT S DGFAPT=DGDEATH,DGFAPTI="" - S DGARRAY("FLDS")=3,DGARRAY(4)=DFN,DGARRAY("SORT")="P",DGARRAY(1)=DT - S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) - F S DGFAPT=$O(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:'DGFAPT S DGFAPT1=$G(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:DGFAPT1']"" D Q:DGFAPTI - .I $P($P(DGFAPT1,U,3),";")'["C" D LINE("NOTE: Patient has future appointments scheduled!!") S DGFAPTI=1 +F S DGFAPT=DGDEATH,DGFAPTI="" + F S DGFAPT=$O(^DPT(DFN,"S",DGFAPT)) Q:'DGFAPT S DGFAPT1=$G(^(DGFAPT,0)) Q:'DGFAPT1 D Q:DGFAPTI + .I $P(DGFAPT1,"^",2)'["C" D LINE("NOTE: Patient has future appointments scheduled!!") S DGFAPTI=1 S DGSCHAD=0 D SA I DGSCHAD D LINE("NOTE: Patient had scheduled admissions which have been cancelled!!") I 'DGVETS D LINE("Patient is a NON-VETERAN."_$S($D(^DIC(21,+$P($G(^DPT(DFN,.32)),"^",3),0)):" ["_$P(^(0),"^",1)_"]",1:"")) S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array @@ -55,7 +41,7 @@ Q ; DEL ; delete death bulletin - N DGPCMM,DELBY,DELTM,DTHINFO + N DGPCMM S DFN=+$G(DA) I '$D(^DPT(DFN,0)) Q ; no patient node I +$G(^DPT(DFN,.35)) Q ; not deletion S DGDEATH=X,XMSUB="Patient Death has been Deleted",DGCT=0 @@ -63,7 +49,6 @@ D LINE("The date of death for the following patient has been deleted.") D LINE("") D DEMOG - D LINE("") S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT) S DGB=1 D ^DGBUL S X=DGDEATH @@ -81,62 +66,9 @@ . D LINE(" CLAIM FOLDER LOCATION: "_$S($D(DGLOCATN):DGLOCATN,1:"NOT LISTED")) . D LINE(" CLAIM NUMBER: "_$S($P(DGX,"^",3)]"":$P(DGX,"^",3),1:"NOT LISTED")) D LINE(" COORDINATING MASTER OF RECORD: "_DGCMOR) - D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","DTHINFO") - S DEATHVAL=$G(DTHINFO(2,DFN_",",.351,"E")) - S DEATHVAL=$$FMTE^XLFDT(DEATHVAL),DEATHVAL=$S(DEATHVAL]"":DEATHVAL,1:"UNKNOWN") - S SOURCE=$G(DTHINFO(2,DFN_",",.353,"E")) - S DELTM=$G(DTHINFO(2,DFN_",",.354,"E")) - S DELBY=$G(DTHINFO(2,DFN_",",.355,"E")) - D LINE("") - D LINE(" LAST EDITED BY: "_DELBY) - D LINE(" DATE/TIME LAST MODIFIED: "_DELTM) - D LINE(" SOURCE OF NOTIFICATION: "_$S(SOURCE="":"UNDEFINED",1:SOURCE)) - ;K DEATHVAL,SOURCE,DELTM,DELBY Q ; LINE(X) ; add line contained in X to array S DGCT=DGCT+1 S DGTEXT(DGCT,0)=X Q -DSBULL ; - ; - I $G(IVMDODUP)=1 Q - S DFN=DA - I $D(DGPMDA) D Q - .S DISTYPE=$P($G(^DGPM(DGPMDA,0)),"^",18) - .I $G(^DG(405.2,DISTYPE,0))["DEATH" D - ..S FDA(2,DFN_",",.353)=1 D FILE^DIE(,"FDA","BWFERR") - ..D DISCHRGE,XFR - I $D(^TMP("DEATH",$J)) Q - D DISCHRGE,XFR - Q -DKBULL ; - S DFN=DA - S FDA(2,DFN_",",.353)="@" - I $D(^TMP("DEATH",$J)) S FDA(2,DFN_",",.355)=DUZ - D FILE^DIE(,"FDA",) - D DEL - Q -DISCHRGE ; - ; If the patient is being discharged, determine values needed for - ; Source of Notification and Date/Time last entered. - ; - I '$D(DGNOW) S DGNOW=$$HTFM^XLFDT($H) - I $G(DGDAUTO)'=1 S FDA(2,DFN_",",.354)=DGNOW - S FDA(2,DFN_",",.355)=DUZ - D FILE^DIE(,"FDA",) - Q -APTT3 ;Check to exclude "While an Inpatient" from DOD Bulletin - ; Input: DFN Output: DGDONOT - N DATE,XIEN,TYPE,XDOD,YES - S DGDONOT=0 - S XDOD=$P($G(^DPT(DFN,.35)),"^",1) I 'XDOD Q - S XDOD=$P(XDOD,".",1),YES=0,TYPE="" - I '$D(^DGPM("APTT3",DFN)) Q - S DATE=$O(^DGPM("APTT3",DFN,XDOD)) I 'DATE Q - I $P(DATE,".",1)=XDOD S YES=1 - I ($P(DATE,".",1)-1)=XDOD S YES=1 - S XIEN=$O(^DGPM("APTT3",DFN,DATE,"")) I 'XIEN Q - S TYPE=$P($G(^DGPM(XIEN,0)),"^",4) - I YES,'((TYPE=27)!(TYPE=32)) S DGDONOT=1 - Q diff -auBN ./r1/DGDIS1.m ./r2/r/DGDIS1.m --- ./r1/DGDIS1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGDIS1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGDIS1 ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 02/15/2004 - ;;5.3;Registration;**151,568**;Aug 13, 1993 +DGDIS1 ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 24 AUG 84 15:48 + ;;5.3;Registration;**151**;Aug 13, 1993 1 ;HOSPITAL, NHCU OR DOM ADMISSION A D DISPO^DGPMV K DGPMDER Q @@ -18,7 +18,7 @@ ; Q Q 4 ;FUTURE APPOINTMENT - W !,"APPOINTMENTS CAN NO LONGER BE MADE USING THIS OPTION." + S Y(0)=^DPT(DFN,0),Y=DFN,(SDMM,DIROUT,ORACTION)=0 K SDXXX,%DT,SD D ^SDM K DIROUT,ORACTION W ! Q ; CO(DFN,SDDT,SDISHDL,SDISDEL) ; -- ask check out questions diff -auBN ./r1/DGDIS.m ./r2/r/DGDIS.m --- ./r1/DGDIS.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGDIS.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGDIS ;ALB/JDS - DISPOSITION A REGISTRATION ; 8/6/04 3:17pm - ;;5.3;Registration;**108,121,161,151,459,604**;Aug 13, 1993 +DGDIS ;ALB/JDS - DISPOSITION A REGISTRATION ; 26 AUG 84 14:09 + ;;5.3;Registration;**108,121,161,151**;Aug 13, 1993 ; D LO^DGUTL GETL S L=^DG(43,1,0),DISL=+$P(L,"^",7) S:DISL=0 DISL=24 N SDISHDL @@ -10,6 +10,8 @@ W !,$$FMTE^XLFDT($E($P(L,U),1,12),"5Z"),?20,$P($P(L2,L3,2),";",1) S DGODSND=L ANS ; + S SDISHDL=$$HANDLE^SDAMEVT(3) D BEFORE(DFN,9999999-DFN1,8,SDISHDL) + ; ;** DG*5.3*108; Eligibility Code and Period of Service Checks follow W !! S DR="1;2;2.1;13;5//NOW;D CHT^DGDIS;8"_$S(DUZ'="":";9////"_DUZ,1:""),DIE="^DPT("_DFN_",""DIS"",",DA(1)=DFN,DP=2.101 D ^DIE I $S('$D(^DPT(DFN,"DIS",DA,0)):1,'$P(^(0),"^",6):1,1:0) G DEL N DGPOSX,DGELIGX,DGSTRX @@ -20,6 +22,7 @@ I ('DGELIGX)&(DGPOSX) W !!,"Period of Service is unspecified." K DGPOSX,DGELIGX,DGSTRX G DEL ;S DGXXXD=0 D EL^DGREGE DISP W ! S DIC="^DIC(37,",DIC(0)="AEQMZ",DIC("A")="Select the type of disposition: ",DIC("S")="I '$P(^(0),""^"",10)" D ^DIC K DIC("A"),DIC("B") I Y'>0 G DEL:X?1"^".E W !!,"A disposition must be entered to continue.",!!,*7,*7 G DISP + I "^0^1^"[("^"_$P($G(^DPT(DFN,"DIS",DFN1,0)),"^",2)_"^") D CO^DGDIS1(DFN,9999999-DFN1,SDISHDL,.SDISDEL) G DEL:$G(SDISDEL) D ODS S DR="" I $P(Y(0),"^",1)["INELIG" S DIE("NO^")="",DR="2.1;" S DR=DR_"S:'DGODS Y=6;11500.01////1;11500.02////^S X=$S(DGODSE>0:DGODSE,1:"""");" @@ -29,7 +32,7 @@ S DFN=DGDFN,DFN1=DGDFN1,DGXXXD=0,DIE="^DPT("_DFN_",""DIS""," D EL^DGREGE D MT D EN1^DGEN(DFN) ;enrollment - W !!,"***** Registration dispositioned *****",!!,*7 + D EVT(DFN,9999999-DFN1,8,SDISHDL) W !!,"***** Registration dispositioned *****",!!,*7 D VALIDATE(DFN,DFN1) ; -- call c/o validator D ACT K DGDFN1,DGDOM,DGHEM,DGKAAS,DGL,DGNHCU,DGW,MASD,MASDEV,PARA,POP @@ -43,7 +46,8 @@ S Y=$S(DUZ'="":9,1:0) S:X3'4 D . W:$X ! @@ -51,6 +29,11 @@ ; Output -- VALMBCK R =Refresh screen S VALMBCK="" D FULL^VALM1 + I '$D(^XUSEC("CD DELETE",DUZ)) D Q + .W !!,"Sorry, you do not have the required security key for this option." + .H 3 + .D INIT^DGENLCD + .S VALMBCK="R" I $$RUSURE(DFN) D .I $$DELETE^DGENCDA1(DFN) D INIT^DGENLCD @@ -62,23 +45,7 @@ ;Input: DFN is the patient ien ;Output: Function Value returns 0 or 1 ; - N DIR,SITE,SITEINF,DIROUT,DIRUT,DTOUT,DUOUT,NOERR - S SITE=$$CHKSITE^DGENCDA(DFN) - I '$P(SITE,"^") D Q 0 ;CD was not determined at this site - .S SITEINF=$$NS^XUAF4($P(SITE,"^",2)) - .D BMES^XPDUTL("This Catastrophic Disability evaluation was entered at Site:"_$P(SITEINF,"^",2)) - .D MES^XPDUTL("Please Contact Site "_$P(SITEINF,"^")) - .D MES^XPDUTL("if it is necessary to delete this evaluation.") - ; was this entered in error? - I $$CDTYPE^DGENCDA(DFN) D Q:$G(NOERR) 0 - .D BMES^XPDUTL("This Veteran is currently determined to be Catastrophically Disabled, you") - .D MES^XPDUTL("may not delete this evaluation unless it is due to an error in data entry.") - .S DIR(0)="Y",DIR("B")="NO" - .S DIR("A")="Is this deletion due to an error in data entry" - .D ^DIR - .I $G(DIRUT)!$G(DUOUT)!$G(DIROUT)!$G(DTOUT)!('$G(Y)) S NOERR=1 - .K DIR,Y - ; + N DIR S DIR(0)="Y" S DIR("A")="Are you sure that the Catastrophic Disability should be deleted" S DIR("B")="NO" diff -auBN ./r1/DGENCDA1.m ./r2/r/DGENCDA1.m --- ./r1/DGENCDA1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENCDA1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH,BRM - Catastrophic Disabilty API - File Data;Sep 16, 2002 ; 7/7/04 11:29am - ;;5.3;Registration;**121,147,232,302,356,387,475,451**;Aug 13,1993 +DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH - Catastrophic Disabilty API - File Data;Sep 16, 2002 + ;;5.3;Registration;**121,147,232,302,356,387,475**;Aug 13,1993 ; LOCK(DFN) ; ;Description: Locks the catastrophic disability record for a patient @@ -31,7 +31,6 @@ ; reference N VALID,RESULT,EXTERNAL,ITEM,EIEN,EXIT,OK,ISCD,POP,FLD S ERROR="" - Q:DGCDIS("VCD")="@" 1 ;this is a deletion D ;drops out of block if invalid condition found . S VALID=0 ; Usually invalid if it exits early. . ; CD Flag must have a value if any other CD field is populated diff -auBN ./r1/DGENCDA.m ./r2/r/DGENCDA.m --- ./r1/DGENCDA.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENCDA.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENCDA ;ALB/CJM,Zoltan,JAN,BRM - Catastrophic Disability API - Retrieve Data;May 24, 1999;Nov 14, 2001 ; 7/6/04 5:36pm - ;;5.3;Registration;**121,147,232,387,451**;Aug 13,1993 +DGENCDA ;ALB/CJM,Zoltan,JAN - Catastrophic Disability API - Retrieve Data;May 24, 1999;Nov 14, 2001 + ;;5.3;Registration;**121,147,232,387**;Aug 13,1993 ; GET(DFN,DGCDIS) ; ;Description: Get catastrophic disability information for a patient @@ -71,30 +71,3 @@ ; Q:'$G(DFN) 0 Q $P($G(^DPT(DFN,.39)),"^",6)="Y" - ; -CHKSITE(DFN) ;is this the facility that made the CD determination? - ; - ;Input: - ; DFN - Patient IEN - ;Output: - ; Function Value - returns 1 if CD evaluation was entered at local - ; site, otherwise 0^SITE # - ; - Q:'$G(DFN) 0 - N SITE - S SITE=$$SITE^VASITE - Q:$P($G(^DPT(DFN,.39)),"^",3)=$P(SITE,"^") 1 - Q "0^"_$P($G(^DPT(DFN,.39)),"^",3) - ; -CDTYPE(DFN) ; Was the method of determination "Physical Exam"? - ; - ;Input: - ; DFN - Patient IEN - ;Output: - ; Function Value - returns 1 if CD='Yes' & Method='Physical Exam' - ; otherwise 0 - ; - Q:'$G(DFN) 0 - Q:'$$HASCAT(DFN) 0 - Q $P($G(^DPT(DFN,.39)),"^",5)=3 - ; diff -auBN ./r1/DGENCD.m ./r2/r/DGENCD.m --- ./r1/DGENCD.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENCD.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENCD ;ALB/CJM,Zoltan,ISA/KWP,JAN,BRM - Catastrophic Disability Enter/Edit Option;May 24, 1999,Nov 14, 2001 ; 8/4/03 3:01pm - ;;5.3;Registration;**121,122,232,237,302,387,451**;Aug 13,1993 +DGENCD ;ALB/CJM,Zoltan,ISA/KWP,JAN - Catastrophic Disability Enter/Edit Option;May 24, 1999,Nov 14, 2001 + ;;5.3;Registration;**121,122,232,237,302,387**;Aug 13,1993 ; EN ; ;Description: Entry point used for enter/edit catastrophic disability @@ -20,7 +20,7 @@ S QUIT=0 I $$GET^DGENCDA(DFN,.DGCDIS) D ; If GET CD succeeds ... . ; Set up default values. - . S DGCDIS("FACDET")=$$INST^DGENU() + . I DGCDIS("FACDET")="" S DGCDIS("FACDET")=$$INST^DGENU() . I 'DGCDIS("DATE") S DGCDIS("DATE")=$G(DT) . I 'DGCDIS("REVDTE") S DGCDIS("REVDTE")=DGCDIS("DATE") . I DGCDIS("METDET")="" S DGCDIS("METDET")="" @@ -61,7 +61,7 @@ ; which is passed by reference. N SUB,OK,RESPONSE,FLST,EXIT,SUBEXIT,ITEM,FILENUM,FLDNUM,GETOUT,REQ,VAL S OK=1 - F VAL="BY^1","DATE^1","REVDTE^1","METDET^1" D Q:'OK + F VAL="BY^1","DATE^1","FACDET^1","REVDTE^1","METDET^1" D Q:'OK . S SUB=$P(VAL,"^",1) . S REQ=$P(VAL,"^",2) . S FILENUM=$$FILE^DGENCDU(SUB) diff -auBN ./r1/DGENDD.m ./r2/r/DGENDD.m --- ./r1/DGENDD.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENDD.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENDD ;ALB/CJM,JAN,LBD - Enrollment Data Dictionary Functions; 13 JUN 1997;6-28-01 - ;;5.3;Registration;**121,351,503**;Aug 13,1993 +DGENDD ;ALB/CJM,JAN - Enrollment Data Dictionary Functions; 13 JUN 1997;6-28-01 + ;;5.3;Registration;**121,351**;Aug 13,1993 ; SET1(DFN,DGENRIEN) ; ;Description: sets the "AENRC" X-ref on the patient file @@ -60,34 +60,3 @@ I $$FINDCUR^DGENA(DFN)=DGENRIEN D .K ^DPT("AENRC",STATUS,DFN) Q - ; -SETREM(DGENRIEN,STATUS) ; - ;This set logic is called by the Enrollment Status field (#.04) in - ;the Patient Enrollment file (#27.11). If the Enrollment Status - ;contains the word REJECTED, then "**REJECTED**" will be stuffed - ;into the Remarks field (#.091) of the Patient file (#2). If the - ;Enrollment Status does not contain REJECTED, then the word - ;"**REJECTED**" will be removed. - ;Input: - ; DGENRIEN - IEN of the enrollment record - ; STATUS - enrollment status - ; - Q:'$G(DGENRIEN) - Q:'$G(STATUS) - ; - N DFN,REM - S DFN=$P($G(^DGEN(27.11,DGENRIEN,0)),U,2) - Q:'DFN Q:$G(^DPT(DFN,0))="" - L +^DPT(DFN,0):5 I '$T Q - S REM=$P(^DPT(DFN,0),U,10) - ;The enrollment status contains REJECTED, set REMARKS - I "^11^12^13^14^22^"[(U_STATUS_U) D G SETREMQ - . I REM["**REJECTED**" Q ;Remarks already contain REJECTED - . S REM=REM_"**REJECTED**" - . S $P(^DPT(DFN,0),U,10)=REM - ;The enrollment status does not contain REJECTED, remove REMARKS - I REM'["**REJECTED**" G SETREMQ - S REM=$P(REM,"**REJECTED**",1)_$P(REM,"**REJECTED**",2,99) - S $P(^DPT(DFN,0),U,10)=REM -SETREMQ L -^DPT(DFN,0) - Q diff -auBN ./r1/DGENEGT1.m ./r2/r/DGENEGT1.m --- ./r1/DGENEGT1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENEGT1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENEGT1 ;ALB/KCL,ISA/KWP,LBD,RGL,BRM - Enrollment Group Threshold API's ; 7/28/04 12:54pm - ;;5.3;Registration;**232,417,454,491,513,451,564**;Aug 13, 1993 +DGENEGT1 ;ALB/KCL,ISA/KWP,LBD - Enrollment Group Threshold API's ; 11/21/01 1:30pm + ;;5.3;Registration;**232,417,454**;Aug 13, 1993 ; ; NOTIFY(DGEGT,OLDEGT) ; @@ -68,12 +68,24 @@ ; Q ; -ABOVE(DPTDFN,ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ; - ; Description: This function will determine if the enrollment is above - ; the threshold. +ABOVE(ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ; + ;Description: This function will determine if the enrollment is above the threshold. + ; + ; IMPORTANT NOTE: + ; =============== + ; Due to the timeline of MEGA Regulations Phase I, changes could + ; not be made to ^DPTLK to support modifications to the parameters + ; being passed into this function. + ; + ; DO NOT REMOVE THE EGTPRI AND EGTGRP PARAMETERS UNTIL ENR^DPTLK HAS + ; BEEN MODIFIED !!! + ; + ; As a work-around, the EGT settings will be obtained here in order + ; to support modifications to the EGT type 2 (STOP NEW ENROLLMENTS) + ; logic. At a future date, the EGT parameters should be removed as + ; they are no longer necessary. [ALB/BRM October 11, 2001] ; ;Input: - ; DPTDFN - Patient File IEN ; ENRPRI - Enrollment Priority ; ENRGRP - Enrollment Sub-Group ; EGTPRI - EGT Priority (optional) - not used @@ -92,17 +104,14 @@ I TODAY6&(ENRPRI=EGT("PRIORITY")) D Q ..I ENRGRP'>EGT("SUBGRP") S ABOVE=1 ..Q:$G(EGTFLG) - ..I EGT("TYPE")=4,ENRPRI=EGT("PRIORITY"),ENRGRP'=$$SUBPRI^DGENELA4(DPTDFN,ENRPRI,ENRGRP) S ABOVE=0 Q - ..I ENRGRP=EGT("SUBGRP"),ENRGRP'=$$SUBPRI^DGENELA4(DPTDFN,ENRPRI,ENRGRP) S ABOVE=0 + ..I ENRGRP=EGT("SUBGRP"),ENRGRP'=$$SUBPRI^DGENELA4(DFN,ENRPRI,ENRGRP) S ABOVE=0 .I ENRPRI'>EGT("PRIORITY") S ABOVE=1 Q ; ;EGT types 1 & 3 @@ -112,10 +121,9 @@ I ENRPRI'>(EGT("PRIORITY")) Q 1 Q 0 ; -ABOVE2(DPTDFN,ENRDT,PRIORITY,SUBGRP) ; +ABOVE2(ENRDT,PRIORITY,SUBGRP) ; ; - ; Input: DPTDFN - Patient File IEN - ; ENRDT - enrollment effective date + ; Input: ENRDT - enrollment effective date ; PRIORITY - enrollment priority ; SUBGRP - enrollment sub-priority (internal numeric value) ; @@ -127,51 +135,10 @@ S:'$G(PRIORITY) PRIORITY="" S:'$G(ENRDT) ENRDT="" D NOW^%DTC S TODAY=X - Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(ENRDT),.EGT) 1 + Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) 1 Q:'$G(EGT("EFFDATE")) 1 Q:TODAY0 - ; -RULES(DPTDFN,EGTENR,EGT,ENRCAT) ;check for new cont enrollment rules - N CVDT,RTN,ENRIEN,ENRVER,NODE0,NODEE - S RTN=0 - D Q:RTN>0 RTN - .Q:ENRCAT'="E" - .I (EGTENR("ELIG","POW")="Y")!(EGTENR("ELIG","A&A")="Y")!(EGTENR("ELIG","HB")="Y")!(EGTENR("ELIG","VAPEN")="Y")!EGTENR("ELIG","VACKAMT") Q - .I EGTENR("ELIG","DISRET")!EGTENR("ELIG","MEDICAID")!EGTENR("ELIG","SCPER")!(EGTENR("ELIG","AO")="Y")!(EGTENR("ELIG","IR")="Y")!(EGTENR("ELIG","EC")="Y") Q - .I "^3^5^"'[("^"_EGTENR("ELIG","CODE")_"^") Q - .I EGTENR("ELIG","PH")="Y" Q - .S RTN=1 - S RTN=0 - D Q RTN>0 - .S ENRIEN="",ENRVER=$O(^DGEN(27.15,"B","VERIFIED","")) - .F S ENRIEN=$O(^DGEN(27.11,"C",DPTDFN,ENRIEN)) Q:'ENRIEN!(RTN'=0) D - ..Q:'$D(^DGEN(27.11,ENRIEN)) S NODE0=$G(^DGEN(27.11,ENRIEN,0)) - ..Q:$P(NODE0,"^",4)'=ENRVER S RTN=-1 - ..S NODEE=$G(^DGEN(27.11,ENRIEN,"E")) - ..I $P(NODEE,"^",3)!($P(NODEE,"^",5)="Y")!($P(NODEE,"^",6)="Y")!($P(NODEE,"^",7)="Y")!$P(NODEE,"^",10) S RTN=1 Q ;sc 10-100%,a&a,hb,va pen,medicaid - ..I ($P(NODEE,"^",11)="Y")!($P(NODEE,"^",13)="Y") S RTN=1 Q ;AO or EC - S CVDT=$$GET1^DIQ(2,DPTDFN_",",.5295,"I") - I CVDT,CVDT'0 - ; diff -auBN ./r1/DGENEGT3.m ./r2/r/DGENEGT3.m --- ./r1/DGENEGT3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENEGT3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENEGT3 ;ALB/KCL/RGL - PROCESS INCOMING MFN HL7 MSGS; 04-MAY-1999 ; 7/23/03 4:49pm - ;;5.3;Registration;**232,306,417,451**;Aug 13, 1993 +DGENEGT3 ;ALB/KCL - PROCESS INCOMING MFN HL7 MSGS; 04-MAY-1999 ; 10/24/01 9:12am + ;;5.3;Registration;**232,306,417**;Aug 13, 1993 ; ; MFI ; Description: This procedure parses the MFI segment type. @@ -76,23 +76,17 @@ ; ; Outputs: None ; - ; Store EGT from HEC and quit. + N CURIEN ; - I $$STORE^DGENEGT(.DGEGT,,1) + ; is there a current EGT setting? + S CURIEN=$$FINDCUR^DGENEGT() ; - ; Old code removed per DG*5.3*451 - ;; - ;N CURIEN - ;; - ;; is there a current EGT setting? - ;S CURIEN=$$FINDCUR^DGENEGT() - ;; - ;; if there is no current EGT, store EGT from HEC and quit - ;I 'CURIEN D Q - ;.I $$STORE^DGENEGT(.DGEGT,,1) - ;; - ;; if there is a current EGT, delete current, and store EGT from HEC - ;I $$DELETE^DGENEGT(CURIEN) D - ;.I $$STORE^DGENEGT(.DGEGT,,1) + ; if there is no current EGT, store EGT from HEC and quit + I 'CURIEN D Q + .I $$STORE^DGENEGT(.DGEGT,,1) + ; + ; if there is a current EGT, delete current, and store EGT from HEC + I $$DELETE^DGENEGT(CURIEN) D + .I $$STORE^DGENEGT(.DGEGT,,1) ; Q diff -auBN ./r1/DGENEGT.m ./r2/r/DGENEGT.m --- ./r1/DGENEGT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENEGT.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENEGT ;ALB/KCL/RGL - Enrollment Group Threshold API's ; 11/20/03 3:39pm - ;;5.3;Registration;**232,451**;Aug 13, 1993 +DGENEGT ;ALB/KCL - Enrollment Group Threshold API's ; 03-MAY-1999 + ;;5.3;Registration;**232**;Aug 13, 1993 ; ; LOCK(IEN) ; @@ -29,25 +29,17 @@ Q ; ; -FINDCUR(ENRDT) ; - ; Description: Used to find a record in the ENROLLMENT GROUP THRESHOLD file. +FINDCUR() ; + ; Description: Used to find current record in the ENROLLMENT GROUP THRESHOLD file. Currently, an EGT history is not required/maintained. ; - ; Input: Enrollment Date (optional - if not specified, today is assumed) + ; Input: None ; ; Output: ; Function Value: If successful, returns internal entry number of ; record in the ENROLLMENT GROUP THRESHOLD file, ; otherwise returns 0 on failure ; - N DGEGTDT,STOP,DGEGTIEN,DGEGTF - S DGEGTDT=$G(ENRDT)+.000001,STOP=0,DGEGTIEN="" - S:'$G(ENRDT) DGEGTDT=$$DT^XLFDT+DGEGTDT - F S DGEGTDT=$O(^DGEN(27.16,"B",DGEGTDT),-1) Q:STOP!(DGEGTDT="") D - .F S DGEGTIEN=$O(^(DGEGTDT,DGEGTIEN),-1) Q:DGEGTIEN=""!STOP D - ..S:'$P($G(^DGEN(27.16,+DGEGTIEN,0)),"^",8) STOP=DGEGTIEN - S DGEGTF=1 - I $G(ENRDT),ENRDT'>DT,$$INACT(STOP) ;inactivate old EGT settings - Q +STOP + Q +$O(^DGEN(27.16,0)) ; ; GET(EGTIEN,DGEGT) ; @@ -108,8 +100,7 @@ S ERROR="" I $G(CHKFLG)'=1 Q:'$$VALID(.DGEGT,.ERROR) 0 ; - N ADD,DATA,OLDEGT,INACT - S OLDEGT=$$FINDCUR() + N ADD,DATA S DATA(.01)=DGEGT("EFFDATE") S DATA(.02)=DGEGT("PRIORITY") S DATA(.03)=DGEGT("SUBGRP") @@ -120,9 +111,6 @@ S DATA(25)=DGEGT("REMARKS") S ADD=$$ADD^DGENDBS(27.16,,.DATA,.ERROR) ; - ; inactivate "old" EGT settings - S INACT=$$INACT(ADD,.OLDEGT,.DGEGT) - ; Q +ADD ; ; @@ -268,27 +256,3 @@ .I SUB="REMARKS" S FLD=25 Q ; Q FLD - ; -INACT(EGTIEN,OLDIEN,DGEGT) ;inactivate EGT settings that are currently not in effect - ; - ; input: EGTIEN -Current EGT ien from 27.16 - ; DGEGT (optional array) - Current EGT setting information - ; DGEGTF (optional) - do not inactivate future EGT - ; - Q:'$G(EGTIEN) 0 - N EGTFDA,EGTDT,EGTREC,ERR - S:'$G(OLDIEN) OLDIEN="" - I '$D(DGEGT),'$$GET(EGTIEN,.DGEGT) Q 0 - S:DGEGT("EFFDATE")>$$DT^XLFDT EGTF=1 ;future EGT setting - S EGTDT="" - F S EGTDT=$O(^DGEN(27.16,"B",EGTDT),-1) Q:'EGTDT D - .S EGTREC="" - .F S EGTREC=$O(^DGEN(27.16,"B",EGTDT,EGTREC),-1) Q:'EGTREC D - ..Q:EGTREC=EGTIEN ;new EGT setting - ..Q:$G(EGTF)&(EGTREC=OLDIEN) - ..I $P($G(^DGEN(27.16,EGTREC,0)),"^")>DT D Q - ...Q:$G(DGEGTF) - ...Q:$$DELETE(EGTREC) - ..S EGTFDA(27.16,EGTREC_",",.08)=1 - D:$D(EGTFDA) UPDATE^DIE("","EGTFDA","","ERR") - Q 1 diff -auBN ./r1/DGENELA1.m ./r2/r/DGENELA1.m --- ./r1/DGENELA1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENELA1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD - Patient Eligibility API ; 2/20/04 1:18pm - ;;5.3;Registration;**147,327,314,367,497,451,564**;Aug 13,1993 +DGENELA1 ;ALB/CJM ,RTK- Patient Eligibility API ; 2/5/01 12:01pm + ;;5.3;Registration;**147,327,314,367**;Aug 13,1993 ; CHECK(DGELG,DGPAT,DGCDIS,ERRMSG) ; ;Does validation checks on the eligibility contained in the DGELG array. @@ -41,7 +41,7 @@ .; .I (DGELG("VACKAMT")>0),(DGELG("A&A")_DGELG("HB")_DGELG("VAPEN")_DGELG("VADISAB")'["Y") S ERRMSG="VA CHECK AMOUNT > 0 BUT INCOME INDICATORS ALL SHOW 'NO'" Q .; - .; + .I (DGELG("VACKAMT")'>0),DGELG("VADISAB")_DGELG("VAPEN")_DGELG("A&A")_DGELG("HB")["Y" S ERRMSG="INCOME INDICATORS INCONSISTENT WITH $0 VA CHECK AMOUNT" Q .; .I (DGELG("SC")="N"),(DGELG("VADISAB")="Y") S ERRMSG="NSC VETERANS CAN NOT BE RECEIVING VA DISABILITY BENEFITS" Q .; @@ -57,8 +57,7 @@ ..; ..S DGONV=$O(^DIC(21,"B","OTHER NON-VETERANS","")),INELDATE=$P($G(^DPT(DFN,.15)),"^",2) ..I INELDATE'="",DGPAT("INELDATE")'>0,DGELG("POS"),DGELG("POS")=DGONV,'$D(^DIC(21,DGELG("POS"),"E",DGELG("ELIG","CODE"))) D - ...S DGTEXT="Patient was previously determined to be ineligible for VA health care. Upon review, the individual is now determined to be eligible for " - ...S DGTEXT=DGTEXT_"VA care. Please update period of service and complete a new application for enrollment in VistA." + ...S DGTEXT="Patient was previously determined to be ineligible for VA health care. Upon review, the individual is now determined to be eligible for VA care. Please update period of service and complete a new application for enrollment in VistA." ...D ADDMSG^DGENUPL3(.MSGS,DGTEXT,0) ..; ..I (DGPAT("VETERAN")="Y"),(DGELG("SC")="Y"),(NATCODE=1)!(NATCODE=3) S BAD=0 Q ;primary eligibility OK @@ -82,9 +81,9 @@ ..; ..I DGELG("SC")="Y",((NATCODE=4)!(NATCODE=5)) S ERRMSG="NSC ELIGIBILITY CODE INCONSISTENT WITH SERVICE CONNECTION INDICATOR" Q ..; - ..I (DGPAT("DOB")>2061231),(NATCODE=16) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF MEXICAN BORDER WAR" Q + ..I (DGPAT("DOB")>2200101),(NATCODE=16) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF MEXICAN BORDER WAR" Q ..; - ..I (DGPAT("DOB")>2071231),(NATCODE=17) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF WORLD WAR I" Q + ..I (DGPAT("DOB")>2200101),(NATCODE=17) S ERRMSG="DOB IS INCONSISTENT WITH ELIGIBILITY OF WORLD WAR I" Q ..; ..;primary eligibility is good ..S BAD=0 @@ -129,10 +128,6 @@ .;fire off x-refs unless necessary .I $P($G(^DPT(DFN,.36)),"^")'=DGELG("ELIG","CODE") S DATA(.361)=DGELG("ELIG","CODE") .; - .; Only update User Enrollee fields if the incoming UE status is - .; greater than the USER ENROLLEE VALID THROUGH on file. - .I $G(DATA(.3617))<$P($G(^DPT(DFN,.361)),"^",7) K DATA(.3617),DATA(.3618) - .; .I '$$UPD^DGENDBS(2,DFN,.DATA) S ERROR="FILEMAN FAILED TO UPDATE THE PATIENT RECORD" Q .; .; @@ -189,10 +184,6 @@ Q:SUB="RD" .01 Q:SUB="PER" 2 Q:SUB="RDSC" 3 - Q:SUB="UEYEAR" .3617 - Q:SUB="UESITE" .3618 - Q:SUB="AOEXPLOC" .3213 - Q:SUB="CVELEDT" .5295 ; Q "" ; diff -auBN ./r1/DGENELA4.m ./r2/r/DGENELA4.m --- ./r1/DGENELA4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENELA4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGENELA4 ;ALB/CJM,KCL,RTK,LBD - Patient Eligibility API ; 2/1/02 10:09am - ;;5.3;Registration;**232,275,306,327,314,367,417,437,456,491,451,564**;Aug 13,1993 + ;;5.3;Registration;**232,275,306,327,314,367,417,437,456**;Aug 13,1993 ; ; PRIORITY(DFN,DGELG,DGELGSUB,ENRDATE,APPDATE) ; @@ -11,10 +11,11 @@ ; DFN - ien of patient ; DGELG - ELIGIBILITY object array (optional, pass by reference) ; ENRDATE - The Enrollment Date. This date is used in the priority - ; determination only if the application date is not passed. - ; APPDATE - The Enrollment Application Date. This date is used - ; to determine the priority. If the application date - ; is not passed then the enrollment date (ENRDATE) is used. + ; determination, if this date is not passed the application + ; date (APPDATE) must be passed. + ; APPDATE - The Enrollment Application Date. This date will be used + ; to determine the priority if the enrollment date (ENRDATE) + ; is not passed. ; ;Output: ; Function Value - returns the priority and subgroup computed by the @@ -27,7 +28,7 @@ K DGELGSUB S DGELGSUB="" S (HICODE,HIPRI,SUBGRP,HISUB)="" D - .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q ;can not proceed with eligibility + .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q ;can not procede with eligiblity .; can't proceed without an Enrollment Date or Application Date .I '$G(ENRDATE),'$G(APPDATE) Q .I $$GET^DGENPTA(DFN,.DGPAT) @@ -51,8 +52,6 @@ .S DGELGSUB("MEDICAID")=DGELG("MEDICAID"),DGELGSUB("AO")=DGELG("AO"),DGELGSUB("IR")=DGELG("IR"),DGELGSUB("EC")=DGELG("EC"),DGELGSUB("MTSTA")=DGELG("MTSTA") .;Purple Heart Added to DGELGSUB .S DGELGSUB("VCD")=DGELG("VCD"),DGELGSUB("PH")=DGELG("PH") - .;Added for HVE Phase III (DG*5.3*564) - .S DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY"),DGELGSUB("CVELEDT")=DGELG("CVELEDT") .; .I $G(DGPAT("INELDATE"))'="" S (HIPRI,HISUB)="" ; @@ -61,15 +60,16 @@ ; PRI(CODE,DGELG,ENRDATE,APPDATE) ; ; Description: Returns the priority group and subgroup based on a - ; single eligibility code. + ; single eligibilty code. ;Input - - ; CODE - pointer to file #8.1, MAS Eligibility Code - ; DGELG - local array obtained by calling $$GET, pass by reference + ; CODE - pointer to file #8.1, MAS Eligbility Code + ; DGELG - local array otained by calling $$GET, pass by reference ; ENRDATE - The Enrollment Date. This date is used in the priority - ; determination only if the application date is not passed. - ; APPDATE - The Enrollment Application Date. This date is used - ; to determine the priority. If the application date - ; is not passed then the enrollment date (ENRDATE) is used. + ; determination, if this date is not passed the application + ; date (APPDATE) must be passed. + ; APPDATE - The Enrollment Application Date. This date will be used + ; to determine the priority if the enrollment date (ENRDATE) + ; is not passed. ; ;Output - ; Function Value - returns the priority and subgroup computed by the @@ -78,9 +78,9 @@ N CODENAME,PRIORITY,MTSTA,SUBGRP,DGEGT,PRISUB,DGMTI,MTTHR,GMTTHR S SUBGRP="" ; - ; use the Application Date when determining the priority, otherwise use - ; the Enrollment Date (ESP DG*5,3*491) - S ENRDATE=$S($G(APPDATE):APPDATE,1:$G(ENRDATE)) + ; use the Enrollment Date when determining the priority, otherwise use + ; the Application Date (Re-Enrollment SRS 6.7.1) + S ENRDATE=$S($G(ENRDATE):ENRDATE,1:$G(APPDATE)) ; ;get the name of the national eligibility code S CODENAME=$$CODENAME^DGENELA(CODE) @@ -101,12 +101,11 @@ D ;drops out when priority determined .S PRIORITY="" .I ((DGELG("SC")="Y")&(DGELG("SCPER")>49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q - .I (DGELG("SC")="Y")&(DGELG("SCPER")>0)&(DGELG("UNEMPLOY")="Y")&(DGELG("VACKAMT")>0)&(DGELG("VAPEN")'="Y")&(DGELG("A&A")'="Y")&(DGELG("HB")'="Y") S PRIORITY=1 Q .I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q .I ((DGELG("SC")="Y")&(DGELG("SCPER")>9)&(CODENAME="SC LESS THAN 50%"))!(DGELG("POW")="Y")!(CODENAME="PRISONER OF WAR")!(DGELG("DISRET")=2)!(DGELG("DISRET")=1)!(CODENAME="PURPLE HEART RECIPIENT")!(DGELG("PH")="Y") S PRIORITY=3 Q .I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q .I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q - .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("AO")="Y")!(DGELG("EC")="Y")!(DGELG("IR")="Y")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'0) S PRIORITY=6 Q .I (MTSTA="G")!((MTSTA="P")&(GMTTHR>MTTHR)) S PRIORITY=7 D Q ..I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q ..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3) @@ -125,12 +124,9 @@ D NOW^%DTC S TODAY=X Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP ;EGT isn't set Q:TODAYEGT("PRIORITY")) $$SUBCNV(SUBGRP) - ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP + Q:EGT("TYPE")'=2 SUBGRP + I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP S DGENRIEN=$$FINDCUR^DGENA(DFN) - I 'DGENRIEN,$G(ENRDATE),ENRDATE Patient Eligibilities @@ -38,7 +38,6 @@ ;ELIGSTA ELIGIBILITY STATUS ;ELIGSTADATE ELIGIBILITY STATUS DATE ;ELIGVERIF ELIGIBILITY VERIF. METHOD - ;ELIGVSITE ELIGIBILITY VERIFICATION SITE ;ELIGENTBY ELIGIBILITY STATUS ENTERED BY ;RATEDIS ; ,"RD" RATED DISABILITY @@ -46,8 +45,6 @@ ; ,"RDSC" SERVICE CONNECTED ;"VCD" Veteran Catastrophically Disabled? (#.39) ;"PH" PURPLE HEART INDICATED - ;"AOEXPLOC" AGENT ORANGE EXPOSURE LOCATION - ;"CVELEDT" COMBAT VETERAN END DATE ; K DGELG S DGELG="" @@ -99,14 +96,12 @@ S NODE=$G(^DPT(DFN,.321)) S DGELG("AO")=$P(NODE,"^",2) S DGELG("IR")=$P(NODE,"^",3) - S DGELG("AOEXPLOC")=$P(NODE,"^",13) ; S NODE=$G(^DPT(DFN,.322)) S DGELG("EC")=$P(NODE,"^",13) ; S NODE=$G(^DPT(DFN,.52)) S DGELG("POW")=$P(NODE,"^",5) - S DGELG("CVELEDT")=$P(NODE,"^",15) ; ; Purple Heart Indicator S NODE=$G(^DPT(DFN,.53)) @@ -122,7 +117,7 @@ F S SUBREC=$O(^DPT(DFN,"E",SUBREC)) Q:'SUBREC D .S CODE=+$G(^DPT(DFN,"E",SUBREC,0)) .; - .;need to check the "B" x-ref, because when a code is deleted from the multiple, the kill logic is executed BEFORE the data is actually removed - but the "B" x-ref has been deleted at this point + .;need to check the "B" x-ref, because when a code is deleted from the multiple, the kill logic is executed BEFORE the data is actuall removed - but the "B" x-ref has been deleted at this point .I CODE,$D(^DPT(DFN,"E","B",CODE)) S DGELG("ELIG","CODE",CODE)=SUBREC ; ;rated disability multiple diff -auBN ./r1/DGENL1.m ./r2/r/DGENL1.m --- ./r1/DGENL1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENL1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENL1 ;ALB/RMO,ISA/KWP,Zoltan,ALB/BRM,LBD - Patient Enrollment - Build List Area; 10/23/00 9:49am ; 2/27/01 1:25pm - ;;5.3;Registration;**121,147,232,266,343,564**;Aug 13,1993 +DGENL1 ;ALB/RMO,ISA/KWP,Zoltan,ALB/BRM - Patient Enrollment - Build List Area; 10/23/00 9:49am ; 2/27/01 1:25pm + ;;5.3;Registration;**121,147,232,266,343**;Aug 13,1993 ; EN(DGARY,DFN,DGENRIEN,DGCNT) ;Entry point to build list area ; for patient enrollment and patient enrollment history @@ -125,12 +125,10 @@ S DGLINE=DGLINE+1 D SET(DGARY,DGLINE,"Mil Disab: "_$S($G(DGENR("ELIG","DISRET"))'="":$$EXT^DGENU("DISRET",DGENR("ELIG","DISRET")),1:""),13,,,,,,.DGCNT) ; - ;Combat Vet End Date (added for DG*5.3*564 - HVE Phase III) - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Combat Vet End Date: "_$S($G(DGENR("ELIG","CVELEDT"))'="":$$EXT^DGENU("CVELEDT",DGENR("ELIG","CVELEDT")),1:""),3,,,,,,.DGCNT) - ; ;Eligible for medicaid S DGLINE=DGLINE+1 + D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT) + S DGLINE=DGLINE+1 D SET(DGARY,DGLINE,"Eligible for MEDICAID: "_$S($G(DGENR("ELIG","MEDICAID"))'="":$$EXT^DGENU("MEDICAID",DGENR("ELIG","MEDICAID")),1:""),1,,,,,,.DGCNT) ; ;Service connected and percentage @@ -146,10 +144,8 @@ D SET(DGARY,DGLINE,"Housebound: "_$S($G(DGENR("ELIG","HB"))'="":$$EXT^DGENU("HB",DGENR("ELIG","HB")),1:""),52,,,,,,.DGCNT) ; ;VA Pension - ;Unemployable (added for DG*5.3*564 - HVE Phase III) S DGLINE=DGLINE+1 D SET(DGARY,DGLINE,"VA Pension: "_$S($G(DGENR("ELIG","VAPEN"))'="":$$EXT^DGENU("VAPEN",DGENR("ELIG","VAPEN")),1:""),12,,,,,,.DGCNT) - D SET(DGARY,DGLINE,"Unemployable: "_$S($G(DGENR("ELIG","UNEMPLOY"))'="":$$EXT^DGENU("UNEMPLOY",DGENR("ELIG","UNEMPLOY")),1:""),50,,,,,,.DGCNT) ; ;Total check amount S DGLINE=DGLINE+1 diff -auBN ./r1/DGENRPD1.m ./r2/r/DGENRPD1.m --- ./r1/DGENRPD1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENRPD1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENRPD1 ;ALB/CJM - Veterans with no Application and with a Future Appointment Report; 04/28/2004 - ;;5.3;Registration;**147,568**;Aug 13,1993 +DGENRPD1 ;ALB/CJM - Veterans with no Application and with a Future Appointment Report; June 10,1998 + ;;5.3;Registration;**147**;08/13/93 ; REPORT ; N DGENRP @@ -95,7 +95,7 @@ S DIR("?")="Enter the first day to list appointments." REPEAT D ^DIR Q:$D(DIRUT) 0 - I Y'>DT W !,"Date must be later than today!" G REPEAT + I Y
,,,) I DGENRP("ALL") D - .S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D - ..Q:$P($G(^SC(CLINIC,0)),"^",3)'="C" - ..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D - ...S DIVISION=$P($G(^SC(CLINIC,0)),U,15) - ...S:'DIVISION DIVISION=$O(^DG(40.8,0)) - ...D VALREC(CLINIC,DFN) - ; - ; Get records for specified Divisions only + .S CLINIC=0 + .F S CLINIC=$O(^SC(CLINIC)) Q:'CLINIC D + ..I $P($G(^SC(CLINIC,0)),"^",3)="C" D APPT(CLINIC,DGENRP("BEGIN"),DGENRP("END")) I $O(DGENRP("DIVISION",0)) D - .S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D - ..Q:$P($G(^SC(CLINIC,0)),"^",3)'="C" - ..S DIVISION=$P($G(^SC(CLINIC,0)),U,15) - ..S:'DIVISION DIVISION=$O(^DG(40.8,0)) - ..Q:'DIVISION!('$D(DGENRP("DIVISION",DIVISION))) - ..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D VALREC(CLINIC,DFN) - ; - ; Get records for specified Clinics only + .S CLINIC=0 + .F S CLINIC=$O(^SC(CLINIC)) Q:'CLINIC D + ..S NODE=$G(^SC(CLINIC,0)) + ..S DIVISION=$P(NODE,"^",15) + ..Q:'DIVISION + ..I $P(NODE,"^",3)="C",$D(DGENRP("DIVISION",DIVISION)) D APPT(CLINIC,DGENRP("BEGIN"),DGENRP("END")) I $O(DGENRP("CLINIC",0)) D - .S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D - ..Q:'CLINIC!('$D(DGENRP("CLINIC",CLINIC))) - ..Q:($P($G(^SC(CLINIC,0)),U,3)'="C") - ..S DIVISION=$P($G(^SC(CLINIC,0)),U,15) - ..S:'DIVISION DIVISION=$O(^DG(40.8,0)) - ..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D VALREC(CLINIC,DFN) + .S CLINIC=0 + .F S CLINIC=$O(DGENRP("CLINIC",CLINIC)) Q:'CLINIC D + ..D APPT(CLINIC,DGENRP("BEGIN"),DGENRP("END")) ; - K DGARRAY,^TMP($J,"SDAMA301"),SDCNT - Q ; -ERR101 S NAM="**Appointment Database is Unavailable**" - ;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN) - S ^TMP($J,"NOENREC"," ",NAM," ",DT," ")="" - K DGARRAY,^TMP($J,"SDAMA301"),SDCNT,NAM - Q + ;STEP 2 - make list in following formats + ;^TMP($J,"STEP2",DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN) ; -VALREC(CLINIC,DFN) ; + ;for patients without enrollment records + ;^TMP($J,"NOENREC",DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN) ; - N APPT,STATUS,JUSTONCE S JUSTONCE=0 - S APPT=0 F S APPT=$O(^TMP($J,"SDAMA301",CLINIC,DFN,APPT)) Q:'APPT!(JUSTONCE) D - .S JUSTONCE=+$G(DGENRP("JUSTONCE")) - .; Exclude certain appointment statuses - .S STATUS=$P($P(^TMP($J,"SDAMA301",CLINIC,DFN,APPT),U,3),";") - .Q:"^N^NA^C^CA^PC^PCA^"[(U_STATUS_U) - .; - .; Don't include enrolled veterans or ones that have pending apps + S DFN=0 + F S DFN=$O(^TMP($J,"STEP1",DFN)) Q:'DFN D + .S STATUS=$$STATUS^DGENA(DFN) .S CATEGORY=$$CATEGORY^DGENA4(DFN) + .; + .;don't include enrolled veterans or ones that have pending apps! .I (CATEGORY="E")!(CATEGORY="P") Q .; - .; Exclude if not an eligible veteran (can not enroll) + .;exclude if not an eligible veteran (can not enroll) .Q:'$$VET^DGENPTA(DFN) .; - .D SETTMP(CLINIC,DFN,APPT) - Q - ; -SETTMP(CLINIC,DFN,APPT) ; - ; NOENREC is for patients without enrollment records - ; SITE2 is for other excluded enrollment records - ;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN) - ; - N DIVNAME,CLNAME - S DIVNAME=$S(DIVISION:$P($$SITE^VASITE(APPT\1,DIVISION),U,2),1:" ") - S CLNAME=$P($G(^SC(CLINIC,0)),"^") - S:CLNAME="" CLNAME=" " - ; - I $$FINDCUR^DGENA(DFN)="" S ^TMP($J,"NOENREC",DIVNAME,CLNAME,CATEGORY,APPT,DFN)="" Q - S ^TMP($J,"STEP2",DIVNAME,CLNAME,CATEGORY,APPT,DFN)=$$STATUS^DGENA(DFN)_U_$P($P(^TMP($J,"SDAMA301",CLINIC,DFN,APPT),U,10),";",2) + .S TIME=0 + .F S TIME=$O(^TMP($J,"STEP1",DFN,TIME)) Q:'TIME D Q:DGENRP("JUSTONCE") + ..S DIVISION="" + ..F S DIVISION=$O(^TMP($J,"STEP1",DFN,TIME,DIVISION)) Q:(DIVISION="") D + ...S CLINIC=0 + ...F S CLINIC=$O(^TMP($J,"STEP1",DFN,TIME,DIVISION,CLINIC)) Q:'CLINIC D + ....N DIVNAME,CLNAME + ....S DIVNAME=$S(DIVISION:$P($$SITE^VASITE(TIME\1,DIVISION),"^",2),1:" ") + ....S CLNAME=$P($G(^SC(CLINIC,0)),"^") + ....S:CLNAME="" CLNAME=" " + ....I $$FINDCUR^DGENA(DFN)="" D Q + ..... S ^TMP($J,"NOENREC",DIVNAME,CLNAME,CATEGORY,TIME,DFN)="" + ....S ^TMP($J,"STEP2",DIVNAME,CLNAME,CATEGORY,TIME,DFN)=STATUS_"^"_$P($G(^TMP($J,"STEP1",DFN,TIME,DIVISION,CLINIC)),"^",16) + Q + ; +APPT(CLINIC,BEGIN,END) ; + ;Description: Lists all the appointments for given clinic with date range + ; + N TIME,APPT,DFN,LOCNODE,PATNODE,DIVISION + S END=END+.1 + S TIME=BEGIN-.1 + S DIVISION=$P($G(^SC(CLINIC,0)),"^",15) + F S TIME=$O(^SC(CLINIC,"S",TIME)) Q:(('TIME)!(TIME>END)) D + .S APPT=0 + .F S APPT=$O(^SC(CLINIC,"S",TIME,1,APPT)) Q:'APPT D + ..S LOCNODE=$G(^SC(CLINIC,"S",TIME,1,APPT,0)) + ..S DFN=$P(LOCNODE,"^") + ..Q:'DFN + ..S PATNODE=$G(^DPT(DFN,"S",TIME,0)) + ..; + ..;clinic from the Patient file appointment multiple should match + ..Q:((+PATNODE)'=CLINIC) + ..; + ..;exclude certain appointment statuses + ..Q:"^N^NA^C^CA^PC^PCA^"[("^"_$P(PATNODE,"^",2)_"^") + ..; + ..S:'DIVISION DIVISION=$O(^DG(40.8,0)) + ..S ^TMP($J,"STEP1",+DFN,+TIME,+DIVISION,+CLINIC)=PATNODE Q ; HEADER ; diff -auBN ./r1/DGENRPT1.m ./r2/r/DGENRPT1.m --- ./r1/DGENRPT1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENRPT1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENRPT1 ;ALB/DW,LBD - EGT Preliminary Summary Impact Report ; 04/24/03 2:32pm ; 07/22/02 9:40am - ;;5.3;Registration;**232,306,417,456,491,513**;Aug 13,1993 +DGENRPT1 ;ALB/DW - EGT Preliminary Summary Impact Report ; 11/1/01 2:32pm ; 07/22/02 9:40am + ;;5.3;Registration;**232,306,417,456**;Aug 13,1993 ; ; ENPT ;Preliminary Summary Report selected. @@ -21,7 +21,7 @@ S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT) ;Get EGT Type. S EGTTP=GETEGTS("TYPE") - S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED" + S EGTTP=$S(EGTTP="":"",EGTTP=1:"Annual Fiscal Year",EGTTP=2:"Stop New Enrollments During Cycle",EGTTP=3:"Mid-Cycle Change",1:"Unspecified") Q ; PRESRT1 ;Sort for patient's current record and get the potentially affected. @@ -53,7 +53,7 @@ S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12) S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10) S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U) - S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) + S ABV=$$ABOVE^DGENEGT1(PRT,PRTSUB) I PRT=7!(PRT=8) D . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB) . S:PRTSUB="" PRTSUB="ER" diff -auBN ./r1/DGENRPT2.m ./r2/r/DGENRPT2.m --- ./r1/DGENRPT2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENRPT2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENRPT2 ;ALB/DW,LBD - EGT Preliminary Detailed Impact Report ; 02/17/2004 - ;;5.3;Registration;**232,306,417,456,491,513,568**;Aug 13,1993 +DGENRPT2 ;ALB/DW - EGT Preliminary Detailed Impact Report ; 11/2/01 10:21am ; 07/22/02 9:40am + ;;5.3;Registration;**232,306,417,456**;Aug 13,1993 ; ; ENPT ;Preliminary Detailed Report selected. @@ -47,7 +47,7 @@ S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT) ;Get EGT Type. S EGTTP=GETEGTS("TYPE") - S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED" + S EGTTP=$S(EGTTP="":"",EGTTP=1:"Annual Fiscal Year",EGTTP=2:"Stop New Enrollments During Cycle",EGTTP=3:"Mid-Cycle Change",1:"Unspecified") ;Sort for patient's current record and get the potentially affected. N IND,PRT,DFN,NM,PSSN,PRTSUB,ABV S (IND,PRT,DFN,NM,PSSN,PRTSUB,ABV)="" @@ -59,7 +59,6 @@ .. S PSSN=$P($G(VADM(2)),U),^TMP($J,"CNT2",PRT,PSSN)="" I EGTSUB>4 S EGTSUB="ER" Q S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB) - D GETAPPT^DGENRPT5("BY2") Q ; EGTP ;Get patients EGT Priority. @@ -68,7 +67,7 @@ S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12) S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10) S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U) - S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) + S ABV=$$ABOVE^DGENEGT1(PRT,PRTSUB) I PRT=7!(PRT=8) D . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB) . S:PRTSUB="" PRTSUB="ER" @@ -119,8 +118,8 @@ FAP1 ;Get the patient FUTURE APPOINTMENTS. N J,POP,ADT S (X,ADT)="",POP=0,J=0 K ^UTILITY("VASD",$J) - I $D(^TMP($J,"SDAMA",101)) S X="Appt. DB Unavail." Q - D BLDUTL^DGENRPT5(DFN) + D CALSDA + I VAERR=1 S X="N/A" Q F S J=$O(^UTILITY("VASD",$J,J)) Q:J=""!POP D . S X=$P($G(^UTILITY("VASD",$J,J,"E")),U,2),X=$E(X,1,20) . S ADT=$P($G(^UTILITY("VASD",$J,J,"I")),U),ADT=$P(ADT,".",1) @@ -135,15 +134,20 @@ FAP0 ;See if the patient has future appointment. S X="NO" K ^UTILITY("VASD",$J) - I $D(^TMP($J,"SDAMA",101)) S X="Appt. DB Unavail." Q - D BLDUTL^DGENRPT5(DFN) + D CALSDA + I VAERR=1 S X="N/A" Q I $G(^UTILITY("VASD",$J,1,"I"))'="" S X="YES" Q ; +CALSDA ;Use API to get appointments. + N X + S VASD("F")=DT,VASD("W")=12 D SDA^VADPT + Q + ; PCPVD ;Get the patient PC PROVIDER. ;;Site must use PCMM module. S X="" - S X=$$PCPRACT^DGSDUTL(DFN) + S X=$$OUTPTPR^SDUTL3(DFN) I X="" S X="N/A" Q S X=$P(X,U,2),X=$E(X,1,10) Q diff -auBN ./r1/DGENRPT3.m ./r2/r/DGENRPT3.m --- ./r1/DGENRPT3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENRPT3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENRPT3 ;ALB/DW,LBD - EGT Actual Summary Impact Report ; 04/24/03 2:40pm ; 07/22/02 9:40am - ;;5.3;Registration;**232,306,417,456,491,513**;Aug 13,1993 +DGENRPT3 ;ALB/DW - EGT Actual Summary Impact Report ; 11/1/01 2:40pm ; 07/22/02 9:40am + ;;5.3;Registration;**232,306,417,456**;Aug 13,1993 ; ; ENPT ;Actual Summary Report selected. @@ -41,7 +41,7 @@ S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT) ;Get EGT Type. S EGTTP=GETEGTS("TYPE") - S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED" + S EGTTP=$S(EGTTP="":"",EGTTP=1:"Annual Fiscal Year",EGTTP=2:"Stop New Enrollments During Cycle",EGTTP=3:"Mid-Cycle Change",1:"Unspecified") Q ; PRESRT1 ;Sort for patient's current record and get the potentially affected. @@ -76,7 +76,7 @@ S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12) S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10) S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U) - S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) + S ABV=$$ABOVE^DGENEGT1(PRT,PRTSUB) I PRT=7!(PRT=8) D . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB) . S:PRTSUB="" PRTSUB="ER" diff -auBN ./r1/DGENRPT4.m ./r2/r/DGENRPT4.m --- ./r1/DGENRPT4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENRPT4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENRPT4 ;ALB/DW,LBD/EG - EGT Actual Detailed Impact Report ; 1/20/05 1:04pm - ;;5.3;Registration;**232,306,417,456,491,513,568,585**;Aug 13,1993 +DGENRPT4 ;ALB/DW - EGT Actual Detailed Impact Report ; 11/2/01 10:23am ;07/22/02 9:40am + ;;5.3;Registration;**232,306,417,456**;Aug 13,1993 ; ; ENPT ;Actual Detailed Report selected. @@ -67,7 +67,7 @@ S EGTLDT=GETEGTS("ENTDATE") I EGTLDT S EGTLDT=$$FMTE^XLFDT(EGTLDT) ;Get EGT Type. S EGTTP=GETEGTS("TYPE") - S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP="" EGTTP="UNSPECIFIED" + S EGTTP=$S(EGTTP="":"",EGTTP=1:"Annual Fiscal Year",EGTTP=2:"Stop New Enrollments During Cycle",EGTTP=3:"Mid-Cycle Change",1:"Unspecified") ; PRESRT1 ;Sort for patient's current record and get the potentially affected. N IND,PRT,DFN,NM,PSSN,PEDT,PCTRY,PRTSUB,ABV @@ -84,7 +84,6 @@ ... S PSSN=$P($G(VADM(2)),U),^TMP($J,"CNT4",PRT,PSSN)="" I EGTSUB>4 S EGTSUB="ER" Q S EGTSUB=$$EXTERNAL^DILFD(27.16,.03,"F",EGTSUB) - D GETAPPT^DGENRPT5("BY4") Q ; EGTP ;Get patients EGT Priority. @@ -93,7 +92,7 @@ S:((PRT=7)!(PRT=8)) PRTSUB=$P($G(^DGEN(27.11,IND,0)),U,12) S ENRDT=$P($G(^DGEN(27.11,IND,0)),U,10) S:'ENRDT ENRDT=$P($G(^DGEN(27.11,IND,0)),U) - S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) + S ABV=$$ABOVE^DGENEGT1(PRT,PRTSUB) I PRT=7!(PRT=8) D . S PRTSUB=$$EXTERNAL^DILFD(27.11,.12,"F",PRTSUB) . S:PRTSUB="" PRTSUB="ER" @@ -144,9 +143,8 @@ FAP1 ;Get the patient FUTURE APPOINTMENTS. N J,POP,ADT S (X,J,ADT)="",POP=0 K ^UTILITY("VASD",$J) - ;if there is lower level data, then it is an error eg 01/20/2005 - I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." Q - D BLDUTL^DGENRPT5(DFN) + D CALSDA + I VAERR=1 S X="N/A" Q F S J=$O(^UTILITY("VASD",$J,J)) Q:J=""!POP D . S X=$P($G(^UTILITY("VASD",$J,J,"E")),U,2),X=$E(X,1,20) . S ADT=$P($G(^UTILITY("VASD",$J,J,"I")),U),ADT=$P(ADT,".",1) @@ -161,18 +159,20 @@ FAP0 ;See if the patient has future appointment. S X="NO" K ^UTILITY("VASD",$J) - ;in order to be a valid appointment, there must be - ;lower level subscripts. if not, then it is - ;an error eg 01/20/2005 - I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." Q - D BLDUTL^DGENRPT5(DFN) + D CALSDA + I VAERR=1 S X="N/A" Q I $G(^UTILITY("VASD",$J,1,"I"))'="" S X="YES" Q ; +CALSDA ;Call API to get patient appoinments. + N X + S VASD("F")=DT,VASD("W")=12 D SDA^VADPT + Q + ; PCPVD ;Get the patient PC PROVIDER. ;;Site must use PCMM module. S X="" - S X=$$PCPRACT^DGSDUTL(DFN) + S X=$$OUTPTPR^SDUTL3(DFN) I X="" S X="N/A" Q S X=$P(X,U,2),X=$E(X,1,10) Q diff -auBN ./r1/DGENRPT5.m ./r2/r/DGENRPT5.m --- ./r1/DGENRPT5.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENRPT5.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,33 +0,0 @@ -DGENRPT5 ;ALB/DW,LBD - EGT Impact Report Utility; 02/17/2004 - ;;5.3;Registration;**568**;Aug 13,1993 - ; - ; - Q -GETAPPT(TYPE) ; Set up array of Patient IENs for SD API to process - N VETARRAY,PIEN,PNAME,RCNT,ACNT,DGARRAY,SDCNT,I - S ACNT=1,RCNT=0 - S PNAME="" F S PNAME=$O(^TMP($J,TYPE,PNAME)) Q:PNAME="" D - .S PIEN=0 F S PIEN=$O(^TMP($J,TYPE,PNAME,PIEN)) Q:'PIEN D - ..S RCNT=RCNT+1,VETARRAY(ACNT)=$G(VETARRAY(ACNT))_PIEN_";" - ..; Group DFNs by no more than twenty records - ..I RCNT>19 S ACNT=ACNT+1,RCNT=0 - ; - ; Call SD API by array of Patient DFNs - F I=1:1 Q:'$D(VETARRAY(I)) D - .S DGARRAY("FLDS")="1;2;3;10",DGARRAY(4)=VETARRAY(I) - .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) - .M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301") - .K DGARRAY - Q - ; -BLDUTL(DFN) ; Build Utility Global Entries for records processed - Q:'$D(^TMP($J,"SDAMA301",DFN)) - N CLIEN,APPTDT,NODE,APPTNUM S APPTNUM=1 - S CLIEN=0 F S CLIEN=$O(^TMP($J,"SDAMA301",DFN,CLIEN)) Q:'CLIEN D - .S APPTDT=0 F S APPTDT=$O(^TMP($J,"SDAMA301",DFN,CLIEN,APPTDT)) Q:'APPTDT D - ..Q:APPTDT'>DT - ..S NODE=^TMP($J,"SDAMA301",DFN,CLIEN,APPTDT) - ..S ^UTILITY("VASD",$J,APPTNUM,"E")=$$FMTE^DILIBF($P(NODE,U),"5U")_U_$P($P(NODE,U,2),";",2)_U_U_$P($P(NODE,U,10),";",2) - ..S ^UTILITY("VASD",$J,APPTNUM,"I")=NODE,APPTNUM=APPTNUM+1 - K ^TMP($J,"SDAMA301") - Q diff -auBN ./r1/DGENU.m ./r2/r/DGENU.m --- ./r1/DGENU.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENU.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD - Enrollment Utilities; 12/11/00 4:33pm ; 12/11/00 9:21pm - ;;5.3;Registration;**121,122,147,232,314,564**;Aug 13,1993 +DGENU ;ALB/CJM,ISA/KWP,Zoltan - Enrollment Utilities; 12/11/00 4:33pm ; 12/11/00 9:21pm + ;;5.3;Registration;**121,122,147,232,314**;Aug 13,1993 ; DISPLAY(DFN) ; ;Description: Display status message, current enrollment and @@ -123,8 +123,6 @@ .I SUB="MTSTA" S FLD=50.14 Q .I SUB="VCD" S FLD=50.15 Q .I SUB="PH" S FLD=50.16 Q - .I SUB="UNEMPLOY" S FLD=50.17 Q - .I SUB="CVELEDT" S FLD=50.18 Q .I SUB="DATETIME" S FLD=75.01 Q .I SUB="USER" S FLD=75.02 Q Q FLD diff -auBN ./r1/DGENUPL3.m ./r2/r/DGENUPL3.m --- ./r1/DGENUPL3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPL3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENUPL3 ;ALB/CJM,ISA/KWP,AEG,BRM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 8/5/03 3:30pm - ;;5.3;REGISTRATION;**147,230,232,377,404,451**;Aug 13,1993 +DGENUPL3 ;ALB/CJM,ISA/KWP,AEG - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 04/23/2001 + ;;5.3;REGISTRATION;**147,230,232,377,404**;Aug 13,1993 ; ; ADDMSG(MSGS,MESSAGE,TOHEC) ; @@ -35,7 +35,7 @@ ;Output: none ; N TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT - N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG,CD + N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG ; ;if there are no alerts, then quit Q:'$G(MSGS(0)) @@ -44,19 +44,17 @@ ;reason to display. 'NON-SERVICE' alerts have a higher priority than ;other alerts and are therefore displayed before other alerts in the ;subject line, followed by 'POW' alerts in priority. - S (ELIG,NSC,POW,CD)=0 + S (ELIG,NSC,POW)=0 S COUNT=0 F S COUNT=$O(MSGS(COUNT)) Q:'COUNT!NSC D .I MSGS(COUNT)["PREVIOUSLY ELIGIBLE" S ELIG=1 Q .I MSGS(COUNT)["NON-SERVICE" S NSC=1 Q - .I MSGS(COUNT)["POW" S POW=1 Q - .I MSGS(COUNT)["CD EVALUATION" S CD=1 Q + .I MSGS(COUNT)["POW" S POW=1 .S HEADER=MSGS(COUNT) .Q D .I ELIG S HEADER="Ineligibility Alert: " Q .I NSC S HEADER="NSC Alert: " Q .I POW&'NSC S HEADER="POW Alert: " Q - .I CD S HEADER="CD Alert: " Q .Q ; S XMDF="" diff -auBN ./r1/DGENUPL4.m ./r2/r/DGENUPL4.m --- ./r1/DGENUPL4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPL4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENUPL4 ;ALB/CJM,RTK,ISA/KWP,ISD/GSN,PHH,RGL,PJR,BRM,TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 10/8/04 3:18pm - ;;5.3;REGISTRATION;**147,177,232,253,327,367,377,514,451,625**;Aug 13,1993 +DGENUPL4 ;ALB/CJM,RTK,ISA/KWP,ISD/GSN - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;4/23/2001 + ;;5.3;REGISTRATION;**147,177,232,253,327,367,377**;Aug 13,1993 ; UOBJECTS(DFN,DGPAT,DGELG,DGCDIS,MSGID,ERRCOUNT,MSGS,OLDPAT,OLDELG,OLDCDIS) ; ;Description: Used to update the PATIENT, ELIGIBILITY, and CATASTROPHIC @@ -76,13 +76,6 @@ .; .; Change from Eligible to Ineligible .I 'OLDPAT("INELDATE"),DGPAT("INELDATE") D ADDMSG^DGENUPL3(.MSGS,"VETERAN PREVIOUSLY ELIGIBLE FOR VA HEALTH CARE, NOW INELIGIBLE.",1) - .; - .; Check for erroneous CD deletion - .I OLDCDIS("VCD")="","@"[DGCDIS("VCD") Q ;no notification is needed - .; - .; CD Determination Changed - .I OLDCDIS("VCD")'=DGCDIS("VCD") D ADDMSG^DGENUPL3(.MSGS,"VETERANS CD EVALUATION HAS CHANGED.") - D EP^DGENUPLB Q SUCCESS ; ADD ; @@ -141,21 +134,8 @@ ;catastrophic disability array S SUB="" F S SUB=$O(DGCDIS(SUB)) Q:(SUB="") D - .I $D(DGCDIS(SUB))=1 I ($G(DGCDIS(SUB))'="") S DGCDIS3(SUB)=DGCDIS(SUB) - .I $D(DGCDIS(SUB))=10 D - ..S SUB2="" - ..F S SUB2=$O(DGCDIS(SUB,SUB2)) Q:SUB2="" D - ...I ($G(DGCDIS(SUB,SUB2))'="") S DGCDIS3(SUB,SUB2)=DGCDIS(SUB,SUB2) - ...I SUB="PROC" D - ....N CDPROC,CDEXT,LIEN - ....S CDPROC=$G(DGCDIS3("PROC",SUB2)) - ....Q:CDPROC="" - ....S CDEXT=DGCDIS3("EXT",SUB2) - ....Q:CDEXT="" - ....S LIEN=$O(^DGEN(27.17,CDPROC,1,"B",CDEXT,0)) - ....Q:LIEN="" - ....K DGCDIS3("EXT",SUB2) - ....S DGCDIS3("EXT",SUB2,LIEN)=CDEXT + .I $D(DGCDIS(SUB))=1 I ($G(DGCDIS(SUB))'="") S DGCDIS3(SUB)=$S((DGCDIS(SUB)="@"):"",1:DGCDIS(SUB)) + .I $D(DGCDIS(SUB))=10 S SUB2="" F S SUB2=$O(DGCDIS(SUB,SUB2)) Q:SUB2="" I ($G(DGCDIS(SUB,SUB2))'="") S DGCDIS3(SUB,SUB2)=$S((DGCDIS(SUB,SUB2)="@"):"",1:DGCDIS(SUB,SUB2)) ; ;eligibility array F S SUB=$O(DGELG(SUB)) Q:(SUB="") I ($G(DGELG(SUB))'="") S DGELG3(SUB)=$S((DGELG(SUB)="@"):"",1:DGELG(SUB)) @@ -182,8 +162,6 @@ S SUB=0 F S SUB=$O(DGELG("ELIG","CODE",SUB)) Q:'SUB D .I '$D(LOC($$NATCODE^DGENELA(SUB))) S DGELG3("ELIG","CODE",SUB)=SUB - ;Agent Orange Exp. Location, use local database when upload is NULL - D AO^DGENUPL9 Q ; CHECK() ; diff -auBN ./r1/DGENUPL5.m ./r2/r/DGENUPL5.m --- ./r1/DGENUPL5.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPL5.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,9 +1,7 @@ -DGENUPL5 ;ALB/KCL/GSN - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 5/6/03 2:45pm - ;;5.3;Registration;**222,504**;08/13/93 +DGENUPL5 ;ALB/KCL - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 22 FEB 1999 + ;;5.3;Registration;**222**;08/13/93 + ; ; - ;DG*5.3*504 - Now, only updates the DG SECURITY LOG file #38.1 Zero - ; node, when SECURITY LEVEL [#2] goes from a Non-sensitive - ; value to a Sensitive value, i.e. (null or 0) to 1. GETLOCKS(DFN) ; ; Description - Locks first the patient enrollment history, then the patient record. Used to sychronize the upload with registration and load/edit. ; @@ -58,12 +56,6 @@ .I $$STORE^DGENSEC(.DGSEC) E D .; otherwise update the existing security log entry with HEC security - .; if new level = Yes and old level Not = Yes (DG*5.3*504) - .I $G(DGSEC("LEVEL"))=1,$G(OLDSEC("LEVEL"))'=1 D - ..I $$UPDATE^DGENSEC(DFN,.DGSEC) - .E D - ..; since no update occurring, then set arrays the same to prevent an - ..; Audit record from being created later. - ..M DGSEC=OLDSEC + .I $$UPDATE^DGENSEC(DFN,.DGSEC) ; Q diff -auBN ./r1/DGENUPL7.m ./r2/r/DGENUPL7.m --- ./r1/DGENUPL7.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPL7.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENUPL7 ;ISA/KWP/CKN - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 12/6/04 11:10am - ;;5.3;REGISTRATION;**232,367,397,417,379,431,513,628**;Aug 13,1993 +DGENUPL7 ;ISA/KWP/CKN - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 03/20/02 + ;;5.3;REGISTRATION;**232,367,397,417,379,431**;Aug 13,1993 ;Phase II split from DGENUPL Z11(MSGIEN,MSGID,CURLINE,DFN,ERRCOUNT) ; ;Description: This is used to process a single ORU~Z11 or ORF~Z11 msg. @@ -71,15 +71,12 @@ ..I '$$CHECK^DGENA3(.DGENR,.DGPAT,.ERRMSG) D Q ...S ERROR=1 ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) - ..; - ..; removed EGT consistency check with DG*5.3*628 ..;Phase II EGT consistency checks (SRS 6.5.1.3) ..;Only do the EGT consistency checks for Rejected-Fiscal Year (11),Rejected-Mid Cycle (12),Rejected-Stop enrolling new apps (13),Rejected-Initil App by VAMC (14),Rejected below EGT threshold (22) - ..;I "^11^12^13^14^22^"[("^"_DGENR("STATUS")_"^"),$$ABOVE^DGENEGT1(DGENR("DFN"),DGENR("PRIORITY"),DGENR("SUBGRP"),"","",1) D Q - ..;.S ERROR=1 - ..;.S ERRMSG="THE ENROLLMENT RECORD DID NOT PASS THE EGT CONSISTENCY CHECKS." - ..;.D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) - ..; + ..I "^11^12^13^14^22^"[("^"_DGENR("STATUS")_"^"),$$ABOVE^DGENEGT1(DGENR("PRIORITY"),DGENR("SUBGRP"),"","",1) D Q + ...S ERROR=1 + ...S ERRMSG="THE ENROLLMENT RECORD DID NOT PASS THE EGT CONSISTENCY CHECKS." + ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRCOUNT) ..;Allow null overwrites for Ineligible vets (Ineligible Project): ..I $G(DGPAT("INELDATE"))'="" S (DGENR("PRIORITY"),DGENR("SUBGRP"))="" ..I DGENR("DATE")="@" S DGENR("DATE")="" diff -auBN ./r1/DGENUPL8.m ./r2/r/DGENUPL8.m --- ./r1/DGENUPL8.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPL8.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENUPL8 ;ISA/KWP,RTK,PHH - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 4/25/03 9:21am - ;;5.3;REGISTRATION;**232,266,327,314,365,417,514**;Aug 13,1993 +DGENUPL8 ;ISA/KWP,RTK - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 10/19/01 9:21am + ;;5.3;REGISTRATION;**232,266,327,314,365,417**;Aug 13,1993 ;Moved ENRUPLD from DGENUPL3 ; ENRUPLD(DGENR,DGPAT) ; @@ -51,6 +51,11 @@ .D NOTIFY^DGENUPL3(.DGPAT,.MSGS) .S ERROR=1 ; + ;Phase II if local enrollment is UNVERIFIED(1) or REJECTED-INITIAL APPLICATION BY VAMC(14) and effective date is later than death date and HEC status is DECEASED reject upload (SRS 6.5.1.2 g) + I CURENR("STATUS")=1!(CURENR("STATUS")=14),(CURENR("EFFDATE")>DGPAT("DEATH")),DGENR("STATUS")=6 D G EXIT + .D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE REQUESTED TO VERIFY PATIENT DEATH",.ERRCOUNT),ADDMSG^DGENUPL3(.MSGS,"ELIBILITY UPLOAD CONTAINED DATE OF DEATH AND WAS REJECTED, PLEASE VERIFY PATIENT DEATH",1),NOTIFY^DGENUPL3(.DGPAT,.MSGS) + .S ERROR=1 + ; ;Phase II if local enrollment has status UNVERIFIED(1),REJECTED-INITIAL APPLICATION BY VAMC(14),PENDING(9) ;and HEC sends status of REJECTED-FISCAL YEAR(11),REJECTED-MID-CYCLE(12),REJECTED-STOP ENROLLING APPLICATIONS(13),PENDING-NO ELIGIBILITY CODE in VIVA(15),REJECTED BELOW EGT THRESHOLD ;PENDING-ELIGIBILITY UNVERIFIED(17),PENDING-MEANS TEST REQUIRED(16),PENDING-OTHER(18) diff -auBN ./r1/DGENUPL9.m ./r2/r/DGENUPL9.m --- ./r1/DGENUPL9.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPL9.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENUPL9 ;ISA/KWP,JAN,BRM,PJR,LBD - CD CONSISTENCY CHECKS ; 10/13/04 2:39pm - ;;5.3;REGISTRATION;**232,378,451,564,628**;Aug 13,1993 +DGENUPL9 ;ISA/KWP,JAN - CD CONSISTENCY CHECKS ;5/7/99;4/19/01 + ;;5.3;REGISTRATION;**232,378**;Aug 13,1993 ; CDCHECK() ; ;Description: Does the consistency checks on the CATASTROPHIC DISABILITY objects. @@ -13,46 +13,22 @@ ;Output: ; 1 if consistency checks passed, 0 otherwise ; - ; VistA Changes (DG*5.3*451) added CCs listed below in place of the - ; previous Consistency Checks based on new business rules. - ; - N CDERR - ; Reject CD update if required fields are missing - I DGCDIS("VCD")="Y",'$$CHECK^DGENCDA1(.DGCDIS,.CDERR) D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"CD Error: "_CDERR,.ERRCOUNT) Q 0 - ; - ; If CD is Yes on VISTA and update is Yes and the current Date of - ; Decision is more recent than the incoming one, reject update. - I OLDCDIS("VCD")="Y",DGCDIS("VCD")="Y",DGCDIS("DATE")> this function has been removed based on a customer request - ; >> the code is being left for reactivation if desired w/ ESR - Q - N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ - S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT","")) - Q:'DGMGRP - D XMY^DGMTUTL(DGMGRP,0,1) - S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9) - S XMTEXT="DGBULL(" - S XMSUB="AGENT ORANGE EXPOSURE LOCATION CHANGE" - S DGLINE=0 - D LINE^DGEN("Patient: "_DGNAME,.DGLINE) - D LINE^DGEN("SSN: "_DGSSN,.DGLINE) - D LINE^DGEN("",.DGLINE) - D LINE^DGEN("This veteran's Agent Orange Exposure Location has been changed.",.DGLINE) - D LINE^DGEN("Contact the HEC by phone if you have questions or believe",.DGLINE) - D LINE^DGEN("this information to be incorrect.",.DGLINE) - D ^XMD - Q diff -auBN ./r1/DGENUPLA.m ./r2/r/DGENUPLA.m --- ./r1/DGENUPLA.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPLA.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENUPLA ;ALB/CKN,TDM,PJR,RGL - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 6/10/04 5:05pm - ;;5.3;REGISTRATION;**397,379,497,451,564**;Aug 13,1993 +DGENUPLA ;ALB/CKN - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 9/27/01 5:22pm + ;;5.3;REGISTRATION;**397,379**;Aug 13,1993 ; ;*************************************************************** ; This routine was created because DGENUPL2 had reached it's @@ -53,7 +53,6 @@ .I ERROR D Q ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 17",.ERRCOUNT) .S DGELG("AO")=$$CONVERT^DGENUPL1(SEG(18),"Y/N",.ERROR) - .N AOERR S AOERR=ERROR ; See SEG(29) below. .I ERROR D Q ..D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 18",.ERRCOUNT) .S DGELG("IR")=$$CONVERT^DGENUPL1(SEG(19),"Y/N",.ERROR) @@ -73,19 +72,6 @@ . S DGMST("MSTST")=$$CONVERT^DGENUPL1(SEG(25),"INSTITUTION",.ERROR) . I ERROR D Q . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 25",.ERROR) - .; - . S DGELG("AOEXPLOC")=SEG(29) - .; Logic enhanced during SQA of patch 451. AOERR from SEG(18) above. - . I 'AOERR,DGELG("AO")'="Y",DGELG("AOEXPLOC")="" S DGELG("AOEXPLOC")="@" - . S DGELG("UEYEAR")=$$CONVERT^DGENUPL1(SEG(34),"DATE",.ERROR) - . I ERROR D Q - . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 34",.ERRCOUNT) - . S DGELG("UESITE")=$$CONVERT^DGENUPL1(SEG(35),"INSTITUTION",.ERROR) - . I ERROR D Q - . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 35",.ERRCOUNT) - . S DGELG("CVELEDT")=$$CONVERT^DGENUPL1(SEG(38),"DATE",.ERROR) - . I ERROR D Q - . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEL SEGMENT, SEQ 38",.ERRCOUNT) ; I COUNT>1 D .S DGELG("ELIG","CODE",CODE)="" diff -auBN ./r1/DGENUPLB.m ./r2/r/DGENUPLB.m --- ./r1/DGENUPLB.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPLB.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,82 +0,0 @@ -DGENUPLB ;TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 10/26/04 2:01pm - ;;5.3;REGISTRATION;**625**;Aug 13,1993 - ; -EP N MSGARY - D CHECK,SNDMSG - Q - ; -CHECK ;Perform C&P and SC status checks and generate mailman messages - ;for MCCR eligibility & billing staff. - Q:'$D(OLDELG) - N RDOCC,TMPARY,RD,RDOCC1,RDOCC2,RDFLG - ; - ;Change in SC Indicator - I OLDELG("SC")'=DGELG("SC") D - .Q:(OLDELG("SC")="")&(DGELG("SC")="N") - .Q:(OLDELG("SC")="N")&(DGELG("SC")="") - .D ADDMSG^DGENUPL3(.MSGARY,"VETERAN SC INDICATOR CHANGED",1) - ; - ;SC% change to 50% or greater - I (OLDELG("SCPER")<50),(DGELG("SCPER")>49) D ADDMSG^DGENUPL3(.MSGARY,"VETERAN SC% CHANGED TO 50% OR GREATER",1) - ; - ;Change in VA Pension - I OLDELG("VAPEN")'=DGELG("VAPEN") D - .Q:(OLDELG("VAPEN")="")&(DGELG("VAPEN")="N") - .Q:(OLDELG("VAPEN")="N")&(DGELG("VAPEN")="") - .D ADDMSG^DGENUPL3(.MSGARY,"VETERAN VA PENSION CHANGED",1) - ; - ;Change in Rated Disabilities - I $D(OLDELG("RATEDIS")) D - .S RDOCC=0 F S RDOCC=$O(OLDELG("RATEDIS",RDOCC)) Q:RDOCC="" D - ..S RD=$P(OLDELG("RATEDIS",RDOCC,"RD"),"^") Q:RD="" - ..S TMPARY(RD)=RDOCC - ; - I $D(DGELG("RATEDIS")) D - .S RDOCC=0 F S RDOCC=$O(DGELG("RATEDIS",RDOCC)) Q:RDOCC="" D - ..S RD=$P(DGELG("RATEDIS",RDOCC,"RD"),"^") Q:RD="" - ..S $P(TMPARY(RD),"^",2)=RDOCC - ; - I $D(TMPARY) D - .S RD="",RDFLG=0 - .F S RD=$O(TMPARY(RD)) Q:RD="" D - ..S RDOCC1=+$P(TMPARY(RD),"^"),RDOCC2=+$P(TMPARY(RD),"^",2) - ..I $G(OLDELG("RATEDIS",RDOCC1,"RD"))'=$G(DGELG("RATEDIS",RDOCC2,"RD")) S RDFLG=1 - .I RDFLG D ADDMSG^DGENUPL3(.MSGARY,"VETERAN RATED DISABILITIES CHANGED",1) - Q - ; -SNDMSG ;Description: Send messages generated above to the G.IB MEANS TEST - ;mail group. - ; - N TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT - N HEADER,NSC,POW,TMPSTR,XMGROUP,ELIG,CD - ; - ;if there are no alerts, then quit - Q:'$D(MSGARY) - S HEADER="C&P Alert: ",XMDF="",(XMDUN,XMDUZ)="Registration Enrollment Module" - ;DGPAT("SSN") is built by the parser. DGPAT("NAME"),DGPAT("SEX"),DGPAT("DOB")(are merged into DGPAT from OLDPAT. - ;The checks below are to setup the DGPAT elements from OLDPAT if NOTIFY is called before the merge. - I '$D(DGPAT("NAME")) S DGPAT("NAME")=$G(OLDPAT("NAME")) - I '$D(DGPAT("SEX")) S DGPAT("SEX")=$G(OLDPAT("SEX")) - I '$D(DGPAT("DOB")) S DGPAT("DOB")=$G(OLDPAT("DOB")) - S TMPSTR=" ("_$E(DGPAT("NAME"),1,1) - S TMPSTR=TMPSTR_$E(DGPAT("SSN"),$L(DGPAT("SSN"))-3,1000)_")" - S XMSUB=HEADER_$E(DGPAT("NAME"),1,25)_TMPSTR - ; - ; send msg to mail group in IB SITE PARAMETERS (#350.9) file - S XMY("G.IB MEANS TEST")="" ; Means Test billing Group - ; - S XMTEXT="TEXT(" - S TEXT(1)="The enrollment/eligibility upload produced the following alerts:" - S TEXT(2)=" " - S TEXT(3)="Patient Name : "_DGPAT("NAME") - S TEXT(4)="SSN : "_DGPAT("SSN") - S TEXT(5)="DOB : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB")) - S TEXT(6)="SEX : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX")) - S TEXT(7)=" " - ; - S TEXT(8)=" ** Alerts **" - S TEXT(9)=" " - S COUNT=0 F S COUNT=$O(MSGARY(COUNT)) Q:'COUNT S TEXT(10+COUNT)=COUNT_") "_MSGARY(COUNT) - ; - D ^XMD - Q diff -auBN ./r1/DGENUPL.m ./r2/r/DGENUPL.m --- ./r1/DGENUPL.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGENUPL.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGENUPL ;ALB/CJM,ISA/KWP,TDM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 6/10/04 4:44pm - ;;5.3;REGISTRATION;**147,222,232,363,472,497,564**;Aug 13,1993 +DGENUPL ;ALB/CJM,ISA/KWP - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 8/17/01 4:21pm + ;;5.3;REGISTRATION;**147,222,232,363,472**;Aug 13,1993 ;Phase II Moved Z11 to DGENUPL7 ORUZ11(MSGIEN,ERRCOUNT) ; ;Description: This procedure is used to process a batch of ORU~Z11 @@ -173,7 +173,7 @@ .S SEG(1)=$E(SEGMENT,4) .F I=2:1:30 S SEG(I)=$P(SEGMENT,HLFS,I) E D - .F I=2:1:39 S SEG(I-1)=$P(SEGMENT,HLFS,I) + .F I=2:1:31 S SEG(I-1)=$P(SEGMENT,HLFS,I) Q ; ADVANCE(MSGIEN,CURLINE) ; diff -auBN ./r1/DGFCPROT.m ./r2/r/DGFCPROT.m --- ./r1/DGFCPROT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGFCPROT.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGFCPROT ;FLB/ALB-DG Field Monitor cross-reference initialing routine. ; 01 AUG 2000 ; 6/18/03 9:08am - ;;5.3;Registration;**273,526**;AUG 13, 1993 +DGFCPROT ;FLB/ALB-DG Field Monitor cross-reference initialling routine.; 01 AUG 2000 ; 07 May 2001 6:27 PM + ;;5.3;Registration;**273**;AUG 13, 1993 ; FC(DGDA,DGFILE,DGFIELD,DGTYPE,DGDTH,DGUSER,DGX,DGX1,DGX2,DGOPT) ; Field change listener ;Input: DGDA = DA array as exists during Fileman editing @@ -33,9 +33,9 @@ S DGOPT=$P(DGOPT,U,1,2) S:DGOPT="" DGOPT="-1^Unknown" ;Current option ; ;Task off (Taskman) driver routine. - N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTSK,DGVAR,BXREF,SUBSCR,ZTREQ + N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTSK,DGVAR,BXREF,SUBSCR S ZTRTN="INIT^DGFCPROT",ZTDESC="DG Field monitor task" - S ZTIO="DG FIELD MONITOR",ZTDTH=$$NOW^XLFDT + S ZTIO="",ZTDTH=$$NOW^XLFDT F DGVAR="DGDA","DGDA(","DGFILE","DGFIELD","DGTYPE","DGDTH","DGUSER","DGX","DGX(","DGX1","DGX1(","DGX2","DGX2(","DGOPT" S ZTSAVE(DGVAR)="" ;If there are no subscribers, do not call Taskman S BXREF=0,BXREF=$O(^ORD(101,"B","DG FIELD MONITOR",BXREF)) @@ -46,6 +46,5 @@ ; INIT N X S X=$O(^ORD(101,"B","DG FIELD MONITOR",0))_";ORD(101," D EN1^XQOR - I $D(ZTQUEUED) S ZTREQ="@" K DGDA,DGFILE,DGFIELD,DGTYPE,DGDTH,DGUSER,DGX,DGX1,DGX2,DGOPT Q diff -auBN ./r1/DGFFP01.m ./r2/r/DGFFP01.m --- ./r1/DGFFP01.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGFFP01.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,129 +0,0 @@ -DGFFP01 ; ALB/SCK - FUGITIVE FELON PROGRAM ROUTINE ; 11/08/2002 - ;;5.3;Registration;**485**;Aug 13, 1993 - ; - Q - ; -GETPAT(ACTION) ; Retrieve patient name - N DIR,Y,X,DIRUT,RSLT - ; - S ACTION=$G(ACTION) - S RSLT=-1 - S DIR(0)="PAO^2:EMZ" - S DIR("A")="Select Patient: " - S DIR("?")="Enter the name of a patient to update the Fugitive Felon Flag for." - I ACTION S DIR("S")="I $P($G(^DPT(Y,""FFP"")),U,1)=1" - D ^DIR K DIR - ; - I $D(DIRUT) - E S:+Y RSLT=Y - Q RSLT - ; -CONT() ; Query to continue processing - N DIR,Y,X - ; - S DIR(0)="YA" - S DIR("A",1)="" - S DIR("A")="Process another felon entry? " - S DIR("B")="YES" - S DIR("?")="Enter 'YES' to continue processing, 'NO' to exit." - D ^DIR K DIR - Q +$G(Y) - ; -CONFIRM(DGACT,DGPAT) ; Query to confirm set/clear the fugitive felon flag - N DIR,DIRUT,X,Y,DGABRT - ; - I "S"[DGACT D I $G(DGABRT) Q 0 - . I $D(^DPT("AXFFP",1,+DGPAT)) D Q - . . W !?2,"The Fugitive Felon Flag is already set..." - . . S DGABRT=1 - . S DIR("A",1)="" - . S DIR("A",2)=" >> This will set the Fugitive Felon Flag for "_$P(DGPAT,U,2)_"." - . S DIR("A")=" >> Continue with setting the flag? " - . S DIR("?")="Enter 'YES' to set the flag, 'NO' to skip." - ; - I "C"[DGACT D - . S DIR("A",1)="" - . S DIR("A",2)=" >> This will clear the Fugitive Felon Flag for "_$P(DGPAT,U,2)_"." - . S DIR("A")=" >> Continue with clearing the flag? " - . S DIR("?")="Enter 'YES' to set the flag, 'NO' to skip." - ; - S DIR(0)="YA",DIR("B")="NO" - D ^DIR K DIR - Q $G(Y) - ; -SETFLAG ; Set the Fugitive Felon Flag - N DGPAT,DGFDA,DGERR - ; -SET1 S DGPAT=$$GETPAT - I +DGPAT<0 G QSET - I $$CONFIRM("S",DGPAT) D - . S DGFDA(1,2,+DGPAT_",",1100.01)=1 - . D FILE^DIE("","DGFDA(1)","DGERR") - . I $D(DGERR) D MSG^DIALOG("EAW","",70,5,"DGERR") - ; - I '$$CONT G QSET - G SET1 -QSET Q - ; -CLRFLAG ; Clear the Fugitive Felon Flag - N DGPAT,DGFDA,DGERR - ; -CLR1 S DGPAT=$$GETPAT(1) - I +DGPAT<0 G QCLR - I $$CONFIRM("C",DGPAT) D - . S DGFDA(1,2,+DGPAT_",",1100.01)="@" - . D FILE^DIE("","DGFDA(1)","DGERR") - . I $D(DGERR) D MSG^DIALOG("EAW","",70,5,"DGERR") - ; - I '$$CONT G QCLR - G CLR1 -QCLR Q - ; -DD(DFN) ; CALLED BY AUFFP X-REF ON THE FUGITIVE FELON FLAG FIELD - ; #1100.01 IN THE PATIENT FILE #2. - ; - ; This procedure will set the following fields: - ; FFF ENTERED BY, Field #1100.02 - ; FFF DATE ENTERED, Field #1100.03 - ; FFF REMOVED BY, Field 1100.04 - ; FFF DATE REMOVED,, Field 1100.05 - ; FFF REMOVAL REMARKS, Field 1100.09 - ; - ; Check Input - I +$G(DFN),$D(^DPT(DFN,0)) - E Q - ; - N DGFDA,DGIEN,DGOLD - ; - S DGIEN=DFN_"," - S DGOLD=$G(^DPT(DFN,"FFP")) - I +DGOLD D - . I $P(DGOLD,"^",2)>0 - . E D - . . S DGFDA(1,2,DGIEN,1100.02)=DUZ - . . S DGFDA(1,2,DGIEN,1100.03)=$$NOW^XLFDT - . I $P(DGOLD,"^",4)>0 D - . . S DGFDA(1,2,DGIEN,1100.04)="@" - . . S DGFDA(1,2,DGIEN,1100.05)="@" - . . S DGFDA(1,2,DGIEN,1100.09)="@" - E D - . ;S DGFDA(1,2,DGIEN,1100.02)="@" - . ;S DGFDA(1,2,DGIEN,1100.03)="@" - . S DGFDA(1,2,DGIEN,1100.04)=DUZ - . S DGFDA(1,2,DGIEN,1100.05)=$$NOW^XLFDT - . S DGFDA(1,2,DGIEN,1100.09)=$$RMRK - ; - D:$D(DGFDA) FILE^DIE("","DGFDA(1)") - Q - ; -RMRK() ; - N DIR - ; -AGN S DIR(0)="FA",DIR("A",1)=" >> Enter a brief remark on why this flag is being cleared." - S DIR("A",2)=" >> This is a required field." - S DIR("A")=" --> " - S DIR("?",1)=" Remark must be between 2-80 characters. Please be brief" - S DIR("?")=" This field is required when clearing the Fugitive Felon Flag" - D ^DIR K DIR - I $L(Y)>80!($L(Y)<2) K Y G AGN - Q $G(Y) diff -auBN ./r1/DGFFP02.m ./r2/r/DGFFP02.m --- ./r1/DGFFP02.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGFFP02.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,137 +0,0 @@ -DGFFP02 ; ALB/SCK - FUGITIVE FELON PROGRAM REPORTS ; 11/14/2002 - ;;5.3;Registration;**485**;Aug 13, 1993 - ; -QUE ; - N ZTSAVE,DGTMP,DIR,Y,DGEND,DGBEG,DIRUT,ZTRTN,ZTDESC,ZTDTH,ZTIO,%ZIS - ; - S DIR(0)="YAO",DIR("B")="YES",DIR("A")="Print report by date range? " - S DIR("?",1)="Enter 'YES' to print the report for showing those patients for who the" - S DIR("?",2)="flag was set within a specific date range." - S DIR("?")="Enter 'NO' to print for all dates." - D ^DIR K DIR - Q:$D(DIRUT) - I '+Y S (DGBEG,DGEND)=0 - E D GETDT(.DGBEG,.DGEND) Q:'DGBEG - ; - S %ZIS="Q" D ^%ZIS G EXIT:POP - I $D(IO("Q")) D START Q - D ADMIN,^%ZISC Q - ; -START ; - S ZTDTH=$$NOW^XLFDT - S ZTSAVE("DGBEG")="",ZTSAVE("DGEND")="" - S ZTDESC="DGFFP FF FLAG ALPHA REPORT" - S ZTRTN="ADMIN^DGFFP02" - D ^%ZTLOAD - I $D(ZTSK)[0 W !!?5,"Report canceled" - E W !!?5,"Report Queued" -EXIT D HOME^%ZIS - Q - ; -GETDT(DGBEG,DGEND) ; Retrieve Begin and End date values entered by the user - N DIR,DIRUT,Y - ; - S (DGBEG,DGEND)=0 - S DIR(0)="DAO^::EX" - S DIR("?")="^D HELP^%DTC" - S DIR("A")="Enter beginning date for report: " - D ^DIR - Q:$D(DIRUT) - S DGBEG=+Y - ; - S DIR("A")="Enter end date for report: " - D ^DIR - I $D(DIRUT) S DGBEG=0 Q - S DGEND=+Y - Q - ; -ADMIN ; - N PAGE - ; - U IO - S PAGE=1 - K ^TMP("DGFFP",$J) - ; - I 'DGBEG D BLDALL - E D BLD(DGBEG,DGEND) - ; - D PRINT(DGBEG,DGEND) - K ^TMP("DGFFP",$J) - D ^%ZISC - Q - ; -BLD(DGBEG,DGEND) ; Build report for specified date range - N DGIEN,DGFFP - ; - S DGEND=$$FMADD^XLFDT(DGEND,1) - S DGIEN=0 - F S DGIEN=$O(^DPT("AXFFP",1,DGIEN)) Q:'DGIEN D - . S DGFFP=$G(^DPT(DGIEN,"FFP")) - . I $P($G(^DPT(DGIEN,"FFP")),U,3)>DGBEG&($P($G(^("FFP")),U,3)0 W ?50,$$GET1^DIQ(200,$P(DGUSER,U,2),.01) - . . I (($Y+5)>IOSL) D - . . . I $$PAUSE S DGABRT=1 Q - . . . D HDR(DGBEG,DGEND) - I $$PAUSE - ; - Q - ; -PAUSE() ; Screen pause for Terminal displays - N DIR,RSLT - ; - I $E(IOST,1,2)="C-" D - . S DIR(0)="E" - . D ^DIR K DIR - . I 'Y S RSLT=1 - Q $G(RSLT) - ; -HDR(DGBEG,DGEND) ; - N LINE,TXT,SPACE - ; - I $E(IOST,1,2)="C-" W @IOF - S TXT="Fugitive Felon Alpha List" - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - I DGBEG>0 D - . S TXT="Report Date Range: "_$$FMTE^XLFDT(DGBEG)_" to "_$$FMTE^XLFDT(DGEND) - . S SPACE=(IOM-$L(TXT))/2 - . W !?SPACE,TXT - ; - S TXT="Print Date: "_$$FMTE^XLFDT($$NOW^XLFDT) - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - S TXT="Page: "_PAGE - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - S PAGE=PAGE+1 - ; - W !!,"Patient Name",?40,"Entered",?50,"Who Entered" - S $P(LINE,"=",IOM)="" W !,LINE - Q diff -auBN ./r1/DGFFP03.m ./r2/r/DGFFP03.m --- ./r1/DGFFP03.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGFFP03.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,275 +0,0 @@ -DGFFP03 ; ALB/SCK - FUGITIVE FELON PROGRAM VISIT REPORT ; 11/14/2002 - ;;5.3;Registration;**485**;Aug 13, 1993 - ; -QUE ; - N ZTSAVE,DGTMP,DIR,Y,DGEND,DGBEG,DIRUT,ZTRTN,ZTDESC,ZTDTH,ZTIO,%ZIS - ; - S DIR(0)="YAO",DIR("B")="YES",DIR("A")="Print report by date range? " - S DIR("?",1)="Enter 'YES' to print the report showing those patients for whom the" - S DIR("?",2)="flag was set within a specific date range." - S DIR("?")="Enter 'NO' to print for all dates." - D ^DIR K DIR - Q:$D(DIRUT) - I '+Y S (DGBEG,DGEND)=0 - E D GETDT^DGFFP02(.DGBEG,.DGEND) - ; - W !,$CHAR(7) - W !?5,">> This report requires a 132-column printer" - S %ZIS="Q" D ^%ZIS G EXIT:POP - I $D(IO("Q")) D START Q - D RPT,^%ZISC - Q - ; -START ; - S ZTDTH=$$NOW^XLFDT - S ZTSAVE("DGBEG")="",ZTSAVE("DGEND")="" - S ZTDESC="DGFFP CURRENT STATUS REPORT" - S ZTRTN="RPT^DGFFP03" - D ^%ZTLOAD - I $D(ZTSK)[0 W !!?5,"Report canceled" - E W !!?5,"Report Queued" -EXIT D HOME^%ZIS - Q - ; -RPT ; - N PAGE - ; - U IO - S PAGE=1 - K ^TMP("DGFFP",$J) - ; - I +DGBEG>0 D GETLST(DGBEG,DGEND) - E D GETALL - ; - D PRINT(DGBEG,DGEND) - K ^TMP("DGFFP",$J) - D ^%ZISC - Q - ; -GETALL ; Retrieve entire list of patient to print - N DGDFN,DFN,VAROOT,DGINP - ; - S DGDFN=0 - F S DGDFN=$O(^DPT("AXFFP",1,DGDFN)) Q:'DGDFN D - . S DFN=DGDFN,VAROOT="DGINP" - . D INP^VADPT - . S ^TMP("DGFFP",$J,$S(+DGINP(1):"I",1:"O"),$$GET1^DIQ(2,DGDFN,.01),DGDFN)="" - . K DGINP - Q - ; -GETLST(DGBEG,DGEND) ; Retrieve list of patients with the Fugitive Felon Flag set within specified date range - N DGDFN,DFN,VAROOT,DGINP,DGFFP - ; - S DGEND=$$FMADD^XLFDT(DGEND,1) - S DGDFN=0 - F S DGDFN=$O(^DPT("AXFFP",1,DGDFN)) Q:'DGDFN D - . S DGFFP=$P($G(^DPT(DGDFN,"FFP")),U,3) - . I DGFFP>DGBEG&(DGFFPIOSL) D - . . . I $$PAUSE^DGFFP02 S DGABRT=1 Q - .. . D HDR(DGBEG,DGEND),INPHDR - Q - ; -OUTP(DGBEG,DGEND) ; - N DGNAME,DFN,DGABRT,VA,DGAPT,TXT,DGSTAT - ; - D HDR(DGBEG,DGEND) - D OUTHDR - ; - I '$D(^TMP("DGFFP",$J,"O")) W !!,"No Patients Found" Q - S DGNAME="" - F S DGNAME=$O(^TMP("DGFFP",$J,"O",DGNAME)) Q:DGNAME']"" D Q:$G(DGABRT) - . S DFN=0 - . F S DFN=$O(^TMP("DGFFP",$J,"O",DGNAME,DFN)) Q:'DFN D Q:$G(DGABRT) - . . D PID^VADPT6 - . . S TXT=$E(DGNAME,1,$L(DGNAME))_" ("_VA("BID")_")" W !,TXT - . . D PRNSCRP(DFN) - . . D PRNRCNT(DFN) - . . D PRNAPT(DFN) - . . W ! - . . I (($Y+5)>IOSL) D - . . . I $$PAUSE^DGFFP02 S DGABRT=1 Q - . . . D HDR(DGBEG,DGEND),INPHDR - Q - ; -SCHED(DGBEG,DGEND) ; - N DGNAME,DFN,DGABRT,VA,DGAPT,TXT,DGSTAT,TMPARY - ; - D HDR(DGBEG,DGEND) - D FUHDR - ; - S DFN=0 - F S DFN=$O(^DPT("AXFFP",1,DFN)) Q:'DFN D - . S ^TMP("DGFFP",$J,"F",$$GET1^DIQ(2,DFN,.01),DFN)="" - ; - S DGNAME="" - F S DGNAME=$O(^TMP("DGFFP",$J,"F",DGNAME)) Q:DGNAME']"" D Q:$G(DGABRT) - . S DFN=0 - . F S DFN=$O(^TMP("DGFFP",$J,"F",DGNAME,DFN)) Q:'DFN D Q:$G(DGABRT) - . . S TMPARY="^TMP(""DGFFPF"",$J)" K @TMPARY - . . D GETFUADM(DFN,TMPARY) - . . Q:'$D(@TMPARY) - . . D PID^VADPT6 - . . S TXT=$E(DGNAME,1,$L(DGNAME))_" ("_VA("BID")_")" W !,TXT - . . D PRNSCRP(DFN) - . . D PRNRCNT(DFN) - . . D PRNFUT(TMPARY) - . . K @TMPARY - Q - ; -PRNFUT(TMPARY) ; - N DGDT,DGWARD - ; - S DGDT=0 - F S DGDT=$O(@TMPARY@(DGDT)) Q:'DGDT D - . W !?40,$$FMTE^XLFDT(DGDT,"1P") - . S DGWARD=$P(@TMPARY@(DGDT),U,8) - . W ?80,$$GET1^DIQ(42,DGWARD,.01) - Q - ; -PRNSCRP(DFN) ; Print Active Script Information - N DGSCRPT - ; - S DGSCRPT=$$GET1^DIQ(55,DFN,50) - W ?110,$S(DGSCRPT>0:DGSCRPT,1:"None") - Q - ; -PRNINP(DFN) ; Print Inpatient Information - N VAROOT,DGIN - ; - S VAROOT="DGIN" - D IN5^VADPT - W ?40,$P(DGIN(2),U,2) - W ?55,$$FMTE^XLFDT($P(DGIN(3),U,1),"D") - W ?70,$P(DGIN(6),U,2) - W ?80,$P(DGIN(5),U,2) - Q - ; -PRNRCNT(DFN) ; Print most recent activity - N DGLAST - ; - S DGLAST=$$LASTACT^DGFFPLM(DFN) - I DGLAST]"" D - . W !?3,">> "_DGLAST - Q - ; -PRNAPT(DFN) ; Print Future Appointment information - N LINE,DGRTN,DGCLN,DGDT,TEMP - ; - S TEMP="^TMP(""VASD"",$J)" - K @TEMP - D GETAPT(DFN,TEMP) - S DGCLN="" - F S DGCLN=$O(@TEMP@(DGCLN)) Q:DGCLN']"" D Q:$G(RSLT) - . W !?40,DGCLN - . S DGDT=0 - . F S DGDT=$O(@TEMP@(DGCLN,DGDT)) Q:'DGDT D Q:$G(RSLT) - . . W ?70,$$FMTE^XLFDT(DGDT,"1P"),! - K @TEMP - Q - ; -GETAPT(DFN,TEMP) ; Sort Clinic appointments by clinic - N LINE,VAROOT,VASD,DGAPT - ; - D SDA^VADPT - S DGAPT="^UTILITY(""VASD"",$J)" - S LINE=0 - F S LINE=$O(@DGAPT@(LINE)) Q:'LINE D - . S @TEMP@($P(@DGAPT@(LINE,"E"),U,2),$P(@DGAPT@(LINE,"I"),U,1))=$P(@DGAPT@(LINE,"E"),U,3) - K @DGAPT - Q - ; -GETFUADM(DFN,TMPARY) ; Get future scheduled admissions - N DGIEN,DGNODE - ; - S DGIEN=0 - F S DGIEN=$O(^DGS(41.1,"B",DFN,DGIEN)) Q:'DGIEN D - . S DGNODE=$G(^DGS(41.1,DGIEN,0)) - . S @TMPARY@($P(DGNODE,U,2))=DGNODE - Q - ; -HDR(DGBEG,DGEND) ; - N LINE,TXT,SPACE - ; - I $E(IOST,1,2)="C-"!($G(PAGE)>1) W @IOF - S TXT="Fugitive Felon Status Report" - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - I DGBEG>0 D - . S TXT="Report Date Range: "_$$FMTE^XLFDT(DGBEG)_" to "_$$FMTE^XLFDT(DGEND) - . S SPACE=(IOM-$L(TXT))/2 - . W !?SPACE,TXT - ; - S TXT="Print Date: "_$$FMTE^XLFDT($$NOW^XLFDT) - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - S TXT="Page: "_PAGE - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - S PAGE=PAGE+1 - Q - ; -INPHDR ; - N TXT,LINE,SPACE - ; - S TXT="Inpatient Listing" - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - W !!,"Patient Name",?40,"Movement",?55,"Date",?70,"Room/Bed",?80,"Ward",?110,"Active Scripts?" - S $P(LINE,"=",IOM)="" W !,LINE - Q - ; -OUTHDR ; - N TXT,LINE,SPACE - ; - S TXT="Outpatient Listing" - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - W !!,"Patient Name",?40,"Clinic",?70,"Appt. D/T",?110,"Active Scripts?" - S $P(LINE,"=",IOM)="" W !,LINE - Q - ; -FUHDR ; - N TXT,LINE,SPACE - ; - S TXT="Future Scheduled Admissions" - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - W !!,"Patient Name",?40,"Scheduled Admission",?80,"Ward",?110,"Active Scripts?" - S $P(LINE,"=",IOM)="" W !,LINE - Q diff -auBN ./r1/DGFFP04.m ./r2/r/DGFFP04.m --- ./r1/DGFFP04.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGFFP04.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,115 +0,0 @@ -DGFFP04 ;ALB/SCK - FUGITIVE FELON PROGRAM CLEARED REPORT 12/5/02 - ;;5.3;Registration;**485**;Aug 13, 1993 - ; -QUE ; - N ZTSAVE,DGTMP,DIR,Y,DGEND,DGBEG,DIRUT,ZTRTN,ZTDESC,ZTDTH,ZTIO,POP,IO,ZTSK,%ZIS - ; - S DIR(0)="YAO",DIR("B")="YES",DIR("A")="Print report by date range? " - S DIR("?",1)="Enter 'YES' to print the report showing those patients for whom the" - S DIR("?",2)="flag was cleared within a specific date range." - S DIR("?")="Enter 'NO' to print for all dates." - D ^DIR K DIR - Q:$D(DIRUT) - I '+Y S (DGBEG,DGEND)=0 - E D GETDT^DGFFP02(.DGBEG,.DGEND) - ; - W !,$CHAR(7) - W !?5,">> This report requires a 132-column printer" - S %ZIS="Q" D ^%ZIS G EXIT:POP - I $D(IO("Q")) D START Q - D RPT,^%ZISC - Q - ; -START ; - S ZTDTH=$$NOW^XLFDT - S ZTSAVE("DGBEG")="",ZTSAVE("DGEND")="" - S ZTDESC="DGFFP CLEARED FF FLAG REPORT" - S ZTRTN="RPT^DGFFP04" - D ^%ZTLOAD - I $D(ZTSK)[0 W !!?5,"Report canceled" - E W !!?5,"Report Queued" -EXIT D HOME^%ZIS - Q - ; -RPT ; - N PAGE - ; - U IO - K ^TMP("DGFFP",$J) - ; - I +DGBEG>0 D GETLST(DGBEG,DGEND) - E D GETALL - ; - D PRINT(DGBEG,DGEND) - K ^TMP("DGFFP",$J) - D ^%ZISC - Q - ; -GETALL ; - N DGIEN,DGDFN - ; - S DGDFN=0 - F S DGDFN=$O(^DPT(DGDFN)) Q:'DGDFN D - . Q:'$D(^DPT(DGDFN,"FFP")) - . Q:$D(^DPT("AXFFP",1,DGDFN)) - . S ^TMP("DGFFP",$J,$P($G(^DPT(DGDFN,0)),U,1),DGDFN)=$G(^("FFP")) - Q - ; -GETLST(DGBEG,DGEND) ; Retreive cleared FF Flags by date range (date cleared) - N DGDFN,DGFFP - ; - S DGDFN=0 - S DGEND=$$FMADD^XLFDT(DGEND,1) - F S DGDFN=$O(^DPT(DGDFN)) Q:'DGDFN D - . Q:'$D(^DPT(DGDFN,"FFP")) - . Q:$D(^DPT("AXFFP",1,DGDFN)) - . S DGFFP=$G(^DPT(DGDFN,"FFP")) - . I $P(DGFFP,U,5)>DGBEG&($P(DGFFP,U,5)0 D - . S TXT="Report Date Range: "_$$FMTE^XLFDT(DGBEG)_" to "_$$FMTE^XLFDT(DGEND) - . S SPACE=(IOM-$L(TXT))/2 - . W !?SPACE,TXT - ; - S TXT="Print Date: "_$$FMTE^XLFDT($$NOW^XLFDT) - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - S PAGE=PAGE+1 - S TXT="Page: "_PAGE - S SPACE=(IOM-$L(TXT))/2 - W !?SPACE,TXT - ; - W !!,"Patient Name",?40,"Entered",?50,"Who Entered",?80,"Cleared",?90,"Who Cleared" - S $P(LINE,"=",IOM)="" W !,LINE - Q diff -auBN ./r1/DGFFPLM1.m ./r2/r/DGFFPLM1.m --- ./r1/DGFFPLM1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGFFPLM1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,163 +0,0 @@ -DGFFPLM1 ;ALB/SCK - FUGITIVE FELON PROGRAM LIST MANAGER - 2 ; 12/6/02 - ;;5.3;Registration;**485**;Aug 13, 1993 - ; -SEL(DFN) ; - N DIC - ; - W ! S DIC="^DPT(",DIC(0)="AEQMZ" - D ^DIC - S DFN=+Y - Q - ; -EN(DFN,DGARY,DGSTART,DGCNT) ; - N VAROOT,DGADD,VAPA,DGTMP,DGLINE,TXT,X,Y,DGDT,DGCLN,TEMP,DGFFP,TMPARY,DGWARD - ; - S VAPA("P")="" - S VAROOT="DGADD" D ADD^VADPT - K VAPA - S VAROOT="DGTMP" D ADD^VADPT - I '+DGTMP(9)>0 K DGTMP - ; - S DGLINE=DGSTART,DGCNT=0 - ; - ; FF Program Information - S DGFFP=$G(^DPT(DFN,"FFP")) - S X=$$SETSTR^VALM1("Date Set:","",5,15) - S X=$$SETSTR^VALM1($$FMTE^XLFDT($P(DGFFP,U,3),"D"),X,20,20) - S X=$$SETSTR^VALM1("Set By:",X,40,12) - S X=$$SETSTR^VALM1($$GET1^DIQ(200,$P(DGFFP,U,2),.01),X,53,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S X=$$SETSTR^VALM1("Date Cleared:","",5,15) - S X=$$SETSTR^VALM1($$FMTE^XLFDT($P(DGFFP,U,5),"D"),X,20,20) - S X=$$SETSTR^VALM1("Cleared By:",X,40,12) - S X=$$SETSTR^VALM1($$GET1^DIQ(200,$P(DGFFP,U,4),.01),X,53,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S X=$$SETSTR^VALM1("Closing Remark:","",5,18) - S X=$$SETSTR^VALM1($P(DGFFP,U,9),X,23,110) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - D SET(DGARY,DGLINE,"",.DGCNT) S DGLINE=DGLINE+1 - ; - ; Address Information - S X=$$SETSTR^VALM1("Permanent Address:","",5,30) - S X=$$SETSTR^VALM1("Temporary Address:",X,35,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S X=$$SETSTR^VALM1("==================","",5,30) - S X=$$SETSTR^VALM1("==================",X,35,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S X=$$SETSTR^VALM1(DGADD(1),"",5,30) - S X=$$SETSTR^VALM1($G(DGTMP(1)),X,35,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S X=$$SETSTR^VALM1(DGADD(2),"",5,30) - S X=$$SETSTR^VALM1($G(DGTMP(2)),X,35,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S X=$$SETSTR^VALM1(DGADD(4),"",5,30) - S X=$$SETSTR^VALM1($G(DGTMP(4)),X,35,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S X=$$SETSTR^VALM1($P(DGADD(5),U,2),"",5,30) - S X=$$SETSTR^VALM1($P($G(DGTMP(5)),U,2),X,35,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S X=$$SETSTR^VALM1($P(DGADD(11),U,2),"",5,30) - S X=$$SETSTR^VALM1($P($G(DGTMP(11)),U,2),X,35,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - I +$G(DGTMP(9))>0 D - . S X=$$SETSTR^VALM1("Effective Date: ","",35,20) - . S X=$$SETSTR^VALM1($P($G(DGTMP(9)),U,2),X,55,20) - . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - . S X=$$SETSTR^VALM1("End Date: ",X,35,20) - . S X=$$SETSTR^VALM1($P($G(DGTMP(10)),U,2),X,55,20) - . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - N XCNT - F XCNT=DGLINE:1:VALM("LINES") D - . D SET(DGARY,DGLINE,"",.DGCNT) S DGLINE=DGLINE+1 - ; - ; Inpatient Information - N DGIN - ; - S VAROOT="DGIN" - D IN5^VADPT - I DGIN(1)>0 D - . S X=$$SETSTR^VALM1("Last Inpatient Movement:","",5,30) - . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - . S X=$$SETSTR^VALM1("========================",X,5,30) - . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - . ; - . S X=$$SETSTR^VALM1($P(DGIN(2),U,2),X,5,20) - . S X=$$SETSTR^VALM1($$FMTE^XLFDT($P(DGIN(3),U,1),"D"),X,21,14) - . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - . ; - . S X="",X=$$SETSTR^VALM1("Room/Bed:",X,8,12) - . S X=$$SETSTR^VALM1($P(DGIN(6),U,2),X,20,20) - . S X=$$SETSTR^VALM1("Ward:",X,40,5) - . S X=$$SETSTR^VALM1($P(DGIN(5),U,2),X,48,20) - . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - . D SET(DGARY,DGLINE,"",.DGCNT) S DGLINE=DGLINE+1 - ; - ; Future Scheduled Admission - S X=$$SETSTR^VALM1("Future Scheduled Admissions:","",5,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - S X=$$SETSTR^VALM1("============================",X,5,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S TMPARY="^TMP(""DGFFPFU"",$J)" - K @TMPARY - D GETFUADM^DGFFP03(DFN,TMPARY) - ; - S DGDT=0 - F S DGDT=$O(@TMPARY@(DGDT)) Q:'DGDT D - . S X=$$SETSTR^VALM1("Scheduled:","",5,10) - . S X=$$SETSTR^VALM1($$FMTE^XLFDT(DGDT,"1P"),X,17,30) - . S DGWARD=$P(@TMPARY@(DGDT),U,8) - . S X=$$SETSTR^VALM1("Ward:",X,47,5) - . S X=$$SETSTR^VALM1($$GET1^DIQ(42,DGWARD,.01),X,53,80) - . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - D SET(DGARY,DGLINE,"",.DGCNT) S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"",.DGCNT) S DGLINE=DGLINE+1 - K @TMPARY - ; - ; Outpatient Information - N TEMP - ; - S TEMP="^TMP(""DGFFPOP"",$J)" - K @TEMP - D GETAPT^DGFFP03(DFN,TEMP) - ; - S X="" - S X=$$SETSTR^VALM1("Future Appointments:",X,5,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - S X=$$SETSTR^VALM1("====================",X,5,30) - D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - ; - S DGCLN="" - F S DGCLN=$O(@TEMP@(DGCLN)) Q:DGCLN']"" D - . S X=$$SETSTR^VALM1(DGCLN,"",5,30) - . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - . S DGDT=0 - . F S DGDT=$O(@TEMP@(DGCLN,DGDT)) Q:'DGDT D - . . S X=$$SETSTR^VALM1($$FMTE^XLFDT(DGDT,"1P"),"",10,40) - . . D SET(DGARY,DGLINE,X,.DGCNT) S DGLINE=DGLINE+1 - K @TEMP - D SET(DGARY,DGLINE,"",.DGCNT) S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"",.DGCNT) S DGLINE=DGLINE+1 - Q - ; -SET(DGARY,DGLINE,DGTEXT,DGCNT) ; - N X - ; - S:DGLINE>DGCNT DGCNT=DGLINE - S X=$S($D(^TMP(DGARY,$J,DGLINE,0)):^(0),1:"") - S ^TMP(DGARY,$J,DGLINE,0)=DGTEXT - S ^TMP(DGARY_"IDX",$J,DGLINE,DGLINE)=DGLINE - S DGLINE=DGLINE+1 - Q diff -auBN ./r1/DGFFPLM.m ./r2/r/DGFFPLM.m --- ./r1/DGFFPLM.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGFFPLM.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,73 +0,0 @@ -DGFFPLM ; ALB/SCK - FUGITIVE FELON PROGRAM LM INQUIRY ; 06-DEC-2002 - ;;5.3;Registration;**485**;Aug 13, 1993 -EN ; -- main entry point for DGFFP PATIENT STATUS INQUIRY - N DFN,VALMCNT - ; - D SEL^DGFFPLM1(.DFN) - Q:DFN'>0 - D EN^VALM("DGFFP PATIENT STATUS INQUIRY") - Q - ; -HDR ; -- header code - N VA,X - ; - D PID^VADPT - S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)_" ("_VA("PID")_")" - S VALMHDR(2)=$S($D(^DPT("AXFFP",1,DFN)):"Fugitive Flag Set",1:"") - S VALMHDR(3)=$$LASTACT(DFN) - Q - ; -INIT ; -- init variables and list array - N VALMBCK - D BLD - Q - ; -BLD ; Build patient fugitive felon program screen - D CLEAN^VALM10 - K ^TMP("DGFFPLM",$J) - ; - D HDR - D EN^DGFFPLM1(DFN,"DGFFPLM",1,.VALMCNT) - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - D CLEAN^VALM10 - D CLEAR^VALM1 - K ^TMP("DGFFPLM",$J) - Q - ; -EXPND ; -- expand code - Q - ; -LASTACT(DFN) ; - N DGDT,RSLT,DGCLN,DGCLNME - ; - S DGDT=$$NOW^XLFDT - S DGDT=$O(^DPT(DFN,"S",DGDT),-1) - I DGDT>0 D - . S DGCLN=$P($G(^DPT(DFN,"S",DGDT,0)),U,1) - . S DGCLNME=$$GET1^DIQ(44,DGCLN,.01) - . S RSLT="Last Appointment: "_$$FMTE^XLFDT(DGDT,"1P")_" Clinic: "_DGCLNME - Q $G(RSLT) - ; -PAT ; Entry point for DGFFP CHANGE PATIENT PROTOCOL - ; Input - None - ; Output - DFN Patient IEN - ; VALMBCK R = Refresh screen - ; - N DGDFN - S VALMBCK="" - D FULL^VALM1 - ; - ; Get new patient - D SEL^DGFFPLM1(.DGDFN) - ; - I DGDFN>0 D - . S DFN=DGDFN - . D BLD^DGFFPLM - S VALMBCK="R" - Q diff -auBN ./r1/DGIBDSP.m ./r2/r/DGIBDSP.m --- ./r1/DGIBDSP.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGIBDSP.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,59 +0,0 @@ -DGIBDSP ;ALB/SCK - FORMATTED INSURANCE DISPLAY ; 16-JUNE-04 - ;;5.3;Registration;**570**;Aug 13, 1993 - ; This routine replaces the supported API DISP^IBCNS which provided a formatted - ; display of patient insurance information. This functionality was removed - ; when DBIA10146 was retired. - ; - Q - ; -DISP ;-Display all insurance company information - ; -input DFN - ; -input DGSTAT [optional] Defaults to "RAB" if not defined. - ; - N DGDTIN - Q:'$D(DFN) D:'$D(IOF) HOME^%ZIS - ; - N X,DGINS,DGX,DGRTN,DGERR,DGY - ; - I '$D(DGSTAT) S DGSTAT="RAB" - S DGX=$$INSUR^IBBAPI(DFN,"",DGSTAT,.DGRTN,"*") - S:DGX<0 DGERR=$O(DGRTN("IBBAPI","INSUR","ERROR",0)) - ; - D HDR - I $G(DGERR) W !?6,DGRTN("IBBAPI","INSUR","ERROR",DGERR) G DISPQ - I 'DGX W !," No Insurance Information" G DISPQ - ; - M DGINS=DGRTN("IBBAPI","INSUR") - S DGY=0 - F S DGY=$O(DGINS(DGY)) Q:'DGY D D1(DGY) - ; -DISPQ K DGSTAT - Q - ; -HDR ; -- print standard header - D HDR1("=",IOM-$S($G(DGDTIN):1,1:4)) - Q - ; -HDR1(CHAR,LENG) ; -- print header, specify character - N OFF - S OFF=$S($G(DGDTIN):0,1:2) - W !?(1+OFF),"Insurance",?(13+OFF),"COB",?(17+OFF),"Subscriber ID",?(35+OFF),"Group",?(47+OFF),"Holder",?(55+OFF),"Effect"_$S('OFF:"",1:"i")_"ve",?(65+OFF+$S('OFF:0,1:1)),"Expires" W:'OFF ?75,"Only" - I $G(CHAR)'="",LENG S X="",$P(X,CHAR,LENG)="" W !?(1+OFF),X - Q - ; -D1(DGVAL) ; - N DGX,DGY,DGZ,CAT,OFF - ; - Q:'$D(DGINS) - S OFF=$S($G(DGDTIN):0,1:2) - W !?(1+OFF),$S($D(DGINS(DGVAL,1)):$E($P(DGINS(DGVAL,1),U,2),1,10),1:"UNKNOWN") - S X=+DGINS(DGVAL,7) I X'="" S X=$S(X=1:"p",X=2:"s",X=3:"t",1:"") - W ?(14+OFF),X - W ?(17+OFF),$E(DGINS(DGVAL,14),1,16) - W ?(35+OFF),$E(DGINS(DGVAL,18),1,10) - S DGX=$P(DGINS(DGVAL,12),U,1) - W ?(47+OFF),$S(DGX="P":"SELF",DGX="S":"SPOUSE",1:"OTHER") - W ?(55+OFF),$$FMTE^XLFDT(DGINS(DGVAL,10),"2DF"),?(65+OFF+$S(OFF:1,1:0)),$$FMTE^XLFDT(DGINS(DGVAL,11),"2DF") - I 'OFF D - .I $P(DGINS(DGVAL,9),U,2)="NO" W ?75,"*WNR*" Q - Q diff -auBN ./r1/DGJ1P1.m ./r2/r/DGJ1P1.m --- ./r1/DGJ1P1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGJ1P1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,19 +0,0 @@ -DGJ1P1 ;ALB/MRY - Patch #1 Environment Check ; 12/9/02 10:04 AM - ;;1.0;Incomplete Records Tracking;**1**;Jun 25, 2001 -EN ; - S XPDABORT="" - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D G ABRT - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("Your programming variables are not set up properly.") - . D MES^XPDUTL("Installation aborted.") - ; Verify that Incomplete Records Tracking v1.0 exists, else Quit. - I $$VERSION^XPDUTL("DGJ")'="1.0" D G ABRT - . D BMES^XPDUTL("*****") - . D MES^XPDUTL("VERSION 1.0 OF INCOMPLETE RECORDS TRACKING HAS NOT BEEN LOADED.") - . D MES^XPDUTL("Installation aborted.") - W !!,">> Environment check complete and okay." - Q - ; -ABRT ; Abort transport, but leave in ^XTMP. - S ^XPDABORT=2 Q - ; diff -auBN ./r1/DGJCSL.m ./r2/r/DGJCSL.m --- ./r1/DGJCSL.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGJCSL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,8 +0,0 @@ -DGJCSL ;ALB/MRY - VENDOR ADD (COREFLS) ;11/18/02 - ;;1.0;Incomplete Records Tracking;**1**;Jun 25, 2001 - ; -ADD ; Standalone query - I '$D(^DD(392.31)) D Q - . W !,"**coreFLS Vendor interface is not active." - D STAND^DGBTCSL - Q diff -auBN ./r1/DGLOCK2.m ./r2/r/DGLOCK2.m --- ./r1/DGLOCK2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGLOCK2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,67 +1,52 @@ -DGLOCK2 ;ALB/MRL - PATIENT FILE DATA EDIT CHECKS ; 28 Jan 2002 2:37 PM - ;;5.3;Registration;**18,244**;Aug 13, 1993 +DGLOCK2 ;ALB/MRL - PATIENT FILE DATA EDIT CHECKS ; 28 JUL 86 + ;;5.3;Registration;**18**;Aug 13, 1993 K1 ;NOK Add - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),U,1)']"":1,1:0) W !?4,*7,"'NEXT OF KIN' name must be specified to enter/edit this field" K X Q K1D ;NOK Delete - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $D(^DPT(DFN,.21)),$P(^(.21),U,1)]"" W !?4,*7,"Can't be deleted as long as 'NEXT OF KIN' is specified" K X Q K2 ;NOK2 Add - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN D K1 I $D(X),$S('$D(^DPT(DFN,.211)):1,$P(^(.211),U,1)']"":1,1:0) W !?4,*7,"'NEXT OF KIN-2' name must be specified to enter/edit this field" K X Q K2D ;NOK2 Delete - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $D(^DPT(DFN,.211)),$P(^(.211),U,1)]"" W !?4,*7,"Can't be deleted as long as 'NEXT OF KIN-2' is specified" K X Q E1 ;Emer Add - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $S('$D(^DPT(DFN,.33)):1,$P(^(.33),U,1)']"":1,1:0) W !?4,*7,"'EMERGENCY CONTACT' name must be specified to enter/edit this field" K X Q E1D ;Emer Delete - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $D(^DPT(DFN,.33)),$P(^(.33),U,1)]"" W !?4,*7,"Can't be deleted as long as 'EMERGENCY CONTACT' is specified" K X Q E2 ;Emer2 Add - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN D E1 I $D(X),$S('$D(^DPT(DFN,.331)):1,$P(^(.331),U,1)']"":1,1:0) W !?4,*7,"'EMERGENCY CONTACT-2' name must be specified to enter/edit this field" K X Q E2D ;Emer2 Delete - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $D(^DPT(DFN,.331)),$P(^(.331),U,1)]"" W !?4,*7,"Can't be deleted as long as 'EMERGENCY CONTACT-2' is specified" K X Q D ;Desig Add - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $S('$D(^DPT(DFN,.34)):1,$P(^(.34),U,1)']"":1,1:0) W !?4,*7,"'DESIGNEE' name must be specified to enter/edit this field" K X Q DD ;Desig Delete - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $D(^DPT(DFN,.34)),$P(^(.34),U,1)]"" W !?4,*7,"Can't be deleted as long as 'DESIGNEE' is specified" K X Q EM ;Emp Add I $S('$D(^DPT(DA,.311)):1,"^3^9^"[$P(^(.311),U,15):1,1:0) G EMW Q EMW W !?4,*7,"'EMPLOYMENT STATUS' must be specified to enter/edit this field" K X Q -EM1 I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN - I $S('$D(^DPT(DFN,.311)):1,"^3^9^"[$P(^(.311),U,15):1,1:0) G EMW +EM1 I $S('$D(^DPT(DFN,.311)):1,"^3^9^"[$P(^(.311),U,15):1,1:0) G EMW I $P(^DPT(DFN,.311),U)']"" W !?4,*7,"'EMPLOYER NAME' must be specified to enter/edit this field" K X Q EMD ;Emp Delete - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $D(^DPT(DFN,.311)),$P(^(.311),U,1)]"" W !?4,*7,"Can't be deleted as long as 'EMPLOYER NAME' is specified" K X Q SE ;Sp Emp Add - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN D MAR I $D(X),$S('$D(^DPT(DFN,.25)):1,$P(^(.25),U,1)']"":1,1:0) W !?4,*7,"'SPOUSES EMPLOYER' name must be specified to enter/edit this field" K X Q SED ;Sp Emp Delete - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $D(^DPT(DFN,.25)),$P(^(.25),U,1)]"" W !?4,*7,"Can't be deleted as long as 'SPOUSES EMPLOYER' is specified" K X Q MAR ;Married or Separated - I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN I $S('$D(^DIC(11,+$P(^DPT(DFN,0),U,5),0)):1,$P(^(0),U,1)="MARRIED":0,$P(^(0),U,1)="SEPARATED":0,1:1) W !?4,*7,"NOT POSSIBLE...Applicant is not Married." K X Q Q AAC1 ;Agency/Country Screen diff -auBN ./r1/DGLOCK3.m ./r2/r/DGLOCK3.m --- ./r1/DGLOCK3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGLOCK3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGLOCK3 ;ALB/BOK - PATIENT FILE MUMPS TRIGGER/DATA EDIT CHECKS ; 28 NOV 86 - ;;5.3;Registration;**489,527**;Aug 13, 1993 +DGLOCK3 ;ALB/BOK - PATIENT FILE MUMPS TRIGGER ; 28 NOV 86 + ;;5.3;Registration;;Aug 13, 1993 KILL S DGX=X I $D(^DPT(DFN,.32)) F DGKZ=0:0 S DGKZ=$O(DGBZ(DGKZ)) Q:'DGKZ S X=$P(^DPT(DFN,.32),"^",DGKZ),$P(^(.32),"^",DGKZ)="" I X]"" S DGIZ=$S(DGKZ=20:.32945,1:(DGKZ/10000+.3281)) I $D(^DD(2,DGIZ,1)) D KILL1 S X=DGX Q @@ -11,41 +11,3 @@ S2 K DGBZ F DGKZ=14:1:18 S DGBZ(DGKZ)="" D KILL K DGBZ,DGIZ,DGJZ,DGKZ Q -CAD ;Confidential Address Edit - I $S('$D(^DPT(DFN,.141)):1,$P(^(.141),U,9)'="Y":1,1:0) D - .D EN^DDIOL("Requirement for Confidential Address data not indicated...NO EDITING!","","$C(7),!?4") K X - Q -CADD ;Confidential Address Delete - ;Called from input transform on Confidential Address fields - Q:'$D(^DPT(DFN,.141)) I $P(^(.141),"^",9)="N"!($P(^(.141),"^",1,6)="^^^^^") D Q - .N DGFDA,DGERR - .D CADM - .I $D(DGFDA) D - ..N DGX - ..S DGX=X - ..D FILE^DIE("","DGFDA","DGERR") - ..S X=DGX - ; -ASK W !,"Do you want to delete all confidential address data" S %=2 D YN^DICN I %Y["?" W !,"Answer 'Y'es to remove confidential address information, 'N'o to leave data in file" G ASK -ASK1 ; - Q:%'=1 - ;S DGTEMPH=$P(^DPT(DFN,.141),"^",7,8),^(.141)="^^^^^^"_DGTEMPH_"^N^^" K DGTEMPH - N DGFDA,DGERR,DGX,DGFLD - F DGFLD=.1411,.1412,.1413,.1414,.1415,.1416,.14111 S DGFDA(2,DFN_",",DGFLD)="" - D CADM - S DGX=X - D FILE^DIE("","DGFDA","DGERR") - S X=DGX - Q -CADM ;Delete data from Confidential Address Categories - I $D(^DPT(DFN,.14)) D - .N DGIEN - .S DGIEN=0 - .F S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN D - ..S DGFDA(2.141,DGIEN_","_DFN_",",.01)="" - Q -CADD1 ;Confidential Address Delete - ;Called from Confidential Address "DEL" nodes - I $D(^DPT(DFN,.141)),$P(^(.141),U,9)="Y" D - .D EN^DDIOL("Answer NO to the 'CONFIDENTIAL ADDRESS ACTIVE' prompt to delete.","","$C(7),!?4") K X - Q diff -auBN ./r1/DGLOCK.m ./r2/r/DGLOCK.m --- ./r1/DGLOCK.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGLOCK.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,8 +1,5 @@ DGLOCK ;ALB/MRL - PATIENT FILE DATA EDIT CHECKS ; 28 JUL 86 - ;;5.3;Registration;**108,161,247,485**;Aug 13, 1993 -FFP ; DGFFP Access key required - I '$D(^XUSEC("DGFFP ACCESS",DUZ)) D EN^DDIOL("Fugitive Felon Key required to edit this field.","","!!?4") K X - Q + ;;5.3;Registration;**108,161,247**;Aug 13, 1993 EK ;EKey Rqrd I '$D(^XUSEC("DG ELIGIBILITY",DUZ)) W !?4,$C(7),"Eligibility Key required to edit this field." K X Q diff -auBN ./r1/DGMSCK.m ./r2/r/DGMSCK.m --- ./r1/DGMSCK.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMSCK.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,53 +0,0 @@ -DGMSCK ;ALB/PJR - CONSISTENCY API'S FROM DGRPC3 ; 4/19/04 10:24am - ;;5.3;Registration;**451**;Mar 12, 2004 -0 Q ;; Must be called at a tag (API) - ;; -MSCK(MSECHK) ;; Check MSE API - N I1,I2,MSE - S (MSERR,MSDATERR)=0,ANYMSE="" F I1=1:1:3 S ANYMSE(I1)=0 - F MSE="4;5;6;7","9;10;11;12","14;15;16;17" D ANY - ;; ANYMSE Saved for use with checks 79 through 82 - S ANYMSE="" F I1=1:1:3 I ANYMSE(I1) S ANYMSE=ANYMSE_I1 - Q 1 -ANY S ANYMSE=0 F I2=1:1:4 I $P(DGP(.32),"^",$P(MSE,";",I2))]"" S ANYMSE=1 Q - I 'ANYMSE Q - S ANYMSE(MSE+1\5)=1 ;; Set ANY Data found for Last, NTL, and NNTL - F I2=1:1:4 I $P(DGP(.32),"^",$P(MSE,";",I2))']"" S MSERR=1 S:I2>2 MSDATERR=1 - I MSDATERR Q - F I2=3,4 I $E($P(DGP(.32),"^",$P(MSE,";",I2)),4,7)="0000" S (MSERR,MSDATERR)=1 Q - Q -CNCK(CONCHK) ;; Check Conflicts API - N I1,I2,DATA,DATE,FROMPC,LOC,NODE,TOPC,YESNO - S CONERR=0 F I1=1:1:7 S I2=$T(CNFLT+I1) D LOC - Q 1 -LOC ;; - S LOC=$P(I2,";;",2),DATA=$P(I2,";;",3),CONSPEC(LOC)=DATA - S NODE=$P(DATA,",",1),YESNO=$P(DATA,",",2) - S FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4) - S CONARR(LOC)=0 I $P(DGP(NODE),"^",YESNO)'="Y" Q - S CONARR(LOC)=1 - F I2=FROMPC,TOPC S DATE=$P(DGP(NODE),"^",I2) I 'DATE!($E(DATE,4,7)="0000") S CONERR=1,CONARR(LOC)=2 Q - Q -RANGE(RANSET) ;; Set Conflict Date Ranges - N I1,I2,I3 - S I1="WWI,WWIIE,WWIIP,KOR,VIET,LEB,GREN,PAN,GULF,SOM,YUG,OTHER" - F I2=1:1:12 S I3=$P(I1,",",I2),RANGE(I3)=$$GETCNFDT^DGRPDT(I3) - Q 1 -MSFROMTO(MSESET) ;; Set first and last overall MSE from/to dates - N MSEFROM,MSETO,I1,I2 - S MSEFROM=9999999,MSETO=0 ;; Initialize from/to dates - ;; - ;; Find first MSE FROM Date and last MSE TO date - I $G(ANYMSE) D - .F I1=6,11,16 S I2=$P(DGP(.32),"^",I1) I I2,I2MSETO S MSETO=I2 - Q MSEFROM_"^"_MSETO - ;; -CNFLT ;; - ;;SOM;;.322,16,17,18 - ;;YUG;;.322,19,20,21 - ;;PAN;;.322,7,8,9 - ;;GREN;;.322,4,5,6 - ;;LEB;;.322,1,2,3 - ;;VIET;;.321,1,4,5 - ;;GULF;;.322,10,11,12 diff -auBN ./r1/DGMSRPT1.m ./r2/r/DGMSRPT1.m --- ./r1/DGMSRPT1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMSRPT1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,226 +0,0 @@ -DGMSRPT1 ;ALB/LBD,BRM - Military Service Inconsistency Report; 01/05/04 ; 5/18/04 9:53am - ;;5.3;Registration;**562,603**; Aug 13,1993 - ; - ; This routine scans the Patient file #2 and checks military service - ; data for inconsistencies. The inconsistencies are stored in - ; ^XTMP("DSMSRPT"). - Q -EN ; Entry point called from ^DGMSRPT - ; Initialize ^XTMP global and set start date - S ^XTMP("DGMSRPT",0)=$$FMADD^XLFDT(DT,60)_U_DT_U_"DG MILITARY SERVICE INCONSISTENCY REPORT" - S $P(^XTMP("DGMSRPT","DATE"),U,1)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - S:$G(ZTSK) ZTREQ="@" - D INIT^DGMSRPT - ; Loop through Patient file #2. If patient meets report criteria, check - ; military service data for inconsistencies. - N DFN - S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN I $$CHK(DFN) D MSINC(DFN) - ; Send message containing inconsistency counts, update stop date/time - S $P(^XTMP("DGMSRPT","DATE"),U,2)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P") - D MSG^DGMSRPT(DGXTMP) - K ^XTMP("DGMSRPT","RUNNING"),DGXTMP - Q -CHK(DFN) ; Check if patient meets criteria to include in report - ; OUTPUT: 1=Meets report criteria; 0=Doesn't meet report criteria - N CHK,ENR,ENRDT,UE,UESITE,SITE - S CHK=0 I '$G(DFN) Q CHK - ; Patient is a veteran - I $P($G(^DPT(DFN,"VET")),U)'="Y" Q CHK - ; Patient not deceased - I +$G(^DPT(DFN,.35)) Q CHK - ; Primary eligibility not 'Humanitarian Emergency', 'Sharing Agreement', - ; or 'Employee' - I "^8^9^14^"[(U_+$G(^DPT(DFN,.36))_U) Q CHK - ; User Enrollee of this facility - S UE=$P($G(^DPT(DFN,.361)),U,7) I UE="" Q CHK - S UESITE=$P($G(^DPT(DFN,.361)),U,8) I +UESITE=0 Q CHK - S SITE=$P($$SITE^VASITE,U,3),SITE=$$PSITE^EASUER(SITE) - I $P($G(^DIC(4,UESITE,99)),U)'=$P($G(^DIC(4,SITE,99)),U) Q CHK - ; Has a current enrollment record - I '$G(^DPT(DFN,"ENR")) Q CHK - ; Meets report criteria - S CHK=1 - Q CHK -MSINC(DFN) ; Check military service data for inconsistencies. - N DGMS,NAM,SSN - Q:'$G(DFN) - ; Get veteran's military service data - D GETMS(DFN,.DGMS) - ; Check Military Service Episodes - D MSECHK(DFN,.DGMS) - ; Check Combat and POW data - D CMPWCHK(DFN,.DGMS) - ; Check Conflict data - D CONFCHK(DFN,.DGMS) - ; If inconsistencies were found, add 0 node and x-refs - I $D(@DGXTMP@(DFN)) D - .S NAM=$P($G(^DPT(DFN,0)),U,1),SSN=$P($G(^DPT(DFN,0)),U,9) - .S @DGXTMP@(DFN,0)=NAM_U_SSN - .I NAM'="" S @DGXTMP@("NAM",NAM,DFN)="" - .I SSN'="" S @DGXTMP@("SSN",+$E(SSN,8,9),+$E(SSN,6,9),+SSN,DFN)="" - .D SETCNT("VET") - Q -GETMS(DFN,DGMS) ; Build DGMS array of military service data - ; OUTPUT: DGMS(CATEGORY,FIELD) - array of Military Service data - N MS,I,CAT,FLD - Q:'$G(DFN) - F I=.32,.321,.322,.52 S MS(I)=$G(^DPT(DFN,I)) - S CAT="MSE1^MSE2^MSE3",FLD="DIS^BOS^FDT^TDT^NUM" - D ARRY(CAT,FLD,.32,4,18,.MS,.DGMS) - I $P(MS(.32),U,19)'="Y" K DGMS("MSE2") ;Delete data for inactive MSE - I $P(MS(.32),U,20)'="Y" K DGMS("MSE3") ;Delete data for inactive MSE - S CAT="LEB^GREN^PAN^GULF",FLD="IND^FDT^TDT" - D ARRY(CAT,FLD,.322,1,12,.MS,.DGMS) - S CAT="SOM^YUG" - D ARRY(CAT,FLD,.322,16,21,.MS,.DGMS) - S CAT="VIET",FLD="IND" - D ARRY(CAT,FLD,.321,1,1,.MS,.DGMS) - S FLD="FDT^TDT" - D ARRY(CAT,FLD,.321,4,5,.MS,.DGMS) - S CAT="POW",FLD="IND^LOC^FDT^TDT" - D ARRY(CAT,FLD,.52,5,8,.MS,.DGMS) - S CAT="COM" - D ARRY(CAT,FLD,.52,11,14,.MS,.DGMS) - Q -ARRY(CAT,FLD,SB,P1,P2,MS,DGMS) ; Set array - ; INPUT: CAT - MS categories (e.g. MSE1 = 1st Military Service Episode) - ; FLD - MS fields (e.g. FDT = From Date, TDT = To Date) - ; SB - MS array subscript - ; P1 - Starting piece in MS string - ; P2 - Ending piece in MS string - ; MS( - Array with MS data from the Patient file - ; OUTPUT: DGMS( - Array returned with MS data grouped by category - N I,J,K - S J=1,K=0 - F I=P1:1:P2 D - .I K=$L(FLD,U) S J=J+1,K=0 - .S K=K+1 - .I $P(MS(SB),U,I)'="" S DGMS($P(CAT,U,J),$P(FLD,U,K))=$P(MS(SB),U,I) - Q -MSECHK(DFN,DGMS) ; Check military service episodes for inconsistencies - N DGTXT,CAT,DG,OVR,BOS,WWIIDT,WWIIS,WWIIE - ; Is there MSE data for this veteran? - I '$D(DGMS("MSE1")),'$D(DGMS("MSE2")),'$D(DGMS("MSE3")) Q - F CAT="MSE1","MSE2","MSE3" K DGTXT S DG=1 I $D(DGMS(CAT)) D - .; Check Branch of Service (B.E.C. and Merchant Seaman) - .S BOS=+$G(DGMS(CAT,"BOS")),BOS=$P($G(^DIC(23,BOS,0)),U,1) - .I BOS="B.E.C." S DGTXT="BEC" D SETTXT(.DG,.DGTXT),SETCNT(2) - .I BOS="MERCHANT SEAMAN" D - ..S WWIIDT=$$GETCNFDT^DGRPDT("WWIIP"),WWIIS=$P(WWIIDT,U),WWIIE=$P(WWIIDT,U,2) - ..Q:$$WITHIN^DGRPDT(WWIIS,WWIIE,$G(DGMS(CAT,"FDT"))) - ..Q:$$WITHIN^DGRPDT(WWIIS,WWIIE,$G(DGMS(CAT,"TDT"))) - ..Q:$$RWITHIN^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),WWIIS,WWIIE) - ..S DGTXT="MERC SEA NO WWII SVC" D SETTXT(.DG,.DGTXT),SETCNT(3) - .; Check for missing data - .I $$MISS(CAT,"BOS^DIS^FDT^TDT") S DGTXT="DATA MISS" D SETTXT(.DG,.DGTXT),SETCNT(4) - .; Check for imprecise dates (year only) - .I $$IMPR(CAT,"FDT^TDT") S DGTXT="DT IMPR" D SETTXT(.DG,.DGTXT),SETCNT(5) - .; Check if To Date is before From Date - .I $G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),$$B4^DGRPDT(DGMS(CAT,"TDT"),DGMS(CAT,"FDT")) D - ..S DGTXT="END DT BEFORE START DT" D SETTXT(.DG,.DGTXT),SETCNT(6) - .; Check if dates overlap with another MSE - .S OVR=$$OVRLP(CAT) I OVR S DGTXT="DT OVRLP W/ "_$P(OVR,U,2) D SETTXT(.DG,.DGTXT),SETCNT(7) - .;If inconsistencies found, update ^XTMP("DGMSRPT","MSINC",DFN, - .I $D(DGTXT) D SETVET(DFN,CAT,.DGTXT) - Q -CMPWCHK(DFN,DGMS) ; Check Combat and POW data for inconsistencies - ; INPUT: DFN - Patient file IEN - ; DGMS( - MS data array - N DGTXT,CAT,DG,LOC - F CAT="COM","POW" K DGTXT S DG=1 I $G(DGMS(CAT,"IND"))="Y" D - .; Check for missing data - .I $$MISS(CAT,"FDT^TDT^LOC") S DGTXT="DATA MISS" D SETTXT(.DG,.DGTXT),SETCNT($S(CAT="COM":8,1:16)) - .; Check for imprecise dates (year only) - .I $$IMPR(CAT,"FDT^TDT") S DGTXT="DT IMPR" D SETTXT(.DG,.DGTXT),SETCNT($S(CAT="COM":9,1:17)) - .; Check if dates are valid for the location - .I $G(DGMS(CAT,"LOC")) S LOC=$$LOC(DGMS(CAT,"LOC")) I LOC'="" D - ..Q:$$CNFLCTDT^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),LOC) - ..S DGTXT="DT INVALID FOR LOC" D SETTXT(.DG,.DGTXT),SETCNT($S(CAT="COM":10,1:18)) - .; Check if dates are within a Military Service Episode - .I $G(DGMS(CAT,"FDT"))!($G(DGMS(CAT,"TDT"))) D - ..Q:$$OVRLPCHK^DGRPDT(DFN,$G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),-1) - ..S DGTXT="DT NOT W/IN MSE" D SETTXT(.DG,.DGTXT),SETCNT($S(CAT="COM":11,1:19)) - .;If inconsistencies found, update ^XTMP("DGMSRPT","MSINC",DFN, - .I $D(DGTXT) D SETVET(DFN,CAT,.DGTXT) - Q -CONFCHK(DFN,DGMS) ; Check Conflict data for inconsistencies - N DGTXT,CAT,DG - F CAT="VIET","LEB","GREN","PAN","GULF","SOM","YUG" K DGTXT S DG=1 I $G(DGMS(CAT,"IND"))="Y" D - .; Check for missing data - .I $$MISS(CAT,"FDT^TDT") S DGTXT="DATA MISS" D SETTXT(.DG,.DGTXT),SETCNT(12) - .; Check for imprecise dates (year only) - .I $$IMPR(CAT,"FDT^TDT") S DGTXT="DT IMPR" D SETTXT(.DG,.DGTXT),SETCNT(13) - .; Check if dates are valid for the location - .I $G(DGMS(CAT,"FDT"))!($G(DGMS(CAT,"TDT"))) D - ..Q:$$CNFLCTDT^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),CAT) - ..S DGTXT="DT INVALID FOR LOC" D SETTXT(.DG,.DGTXT),SETCNT(14) - .; Check if dates are within a Military Service Episode - .I $G(DGMS(CAT,"FDT"))!($G(DGMS(CAT,"TDT"))) D - ..Q:$$OVRLPCHK^DGRPDT(DFN,$G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),-1) - ..S DGTXT="DT NOT W/IN MSE" D SETTXT(.DG,.DGTXT),SETCNT(15) - .;If inconsistencies found, update ^XTMP("DGMSRPT","MSINC",DFN, - .I $D(DGTXT) D SETVET(DFN,CAT,.DGTXT) - Q -SETTXT(DG,DGTXT) ; Set array of MS inconsistency text DGTXT( - ; INPUT: DG - Subscript for DGTXT array - Q:'$G(DG) - I $G(DGTXT(DG))="" S DGTXT(DG)=DGTXT Q - I $L(DGTXT(DG)_"; "_DGTXT)>36 S DG=DG+1,DGTXT(DG)=DGTXT Q - S DGTXT(DG)=DGTXT(DG)_"; "_DGTXT - Q -SETVET(DFN,CAT,DGTXT) ; Update ^XTMP("DGMSRPT","MSINC",DFN, with MS inconsistencies for veteran - ; - Q:'$G(DFN) Q:'$D(CAT) Q:'$D(DGTXT) - N DG S DG=0 - F S DG=$O(DGTXT(DG)) Q:'DG S @DGXTMP@(DFN,CAT,DG)=DGTXT(DG) - Q -SETCNT(SUB) ; Update ^XTMP("DGMSRPT","MSINC","CNT", - ; INPUT: SUB - Subscript in ^("CNT") array to increment - Q:$G(SUB)="" - S $P(@DGXTMP@("CNT",SUB),U,1)=+(@DGXTMP@("CNT",SUB))+1 - Q -MISS(CAT,FLD) ; Check for missing data elements - ; INPUT: CAT - MS category, 1st subscript in DGMS array - ; FLD - List of fields to check for missing data - ; OUTPUT: 1=Missing data; 0=No missing data - N MISS,I,X - S MISS=0 - I $G(CAT)=""!($G(FLD)="") Q MISS - F I=1:1 S X=$P(FLD,U,I) Q:X="" I '$D(DGMS(CAT,X)) S MISS=1 Q - Q MISS -IMPR(CAT,FLD) ; Check for imprecise dates (year only) - ; INPUT: CAT - MS category, 1st subscript in DGMS array - ; FLD - List of fields to check for imprecise dates - ; OUTPUT: 1=Imprecise date; 0=No imprecise date - N IMPR,I,X - S IMPR=0 - I $G(CAT)=""!($G(FLD)="") Q IMPR - F I=1:1 S X=$P(FLD,U,I) Q:X="" I $D(DGMS(CAT,X)),'$$MNTHYR^DGRPDT(DGMS(CAT,X)) S IMPR=1 Q - Q IMPR -OVRLP(CAT) ; Check if MSE dates overlap with another MSE - ; INPUT: CAT - MS category, 1st subscript in DGMS array - ; OUTPUT: 0=No overlap; 1^X=Overlap^MSE that overlaps - N OVR,MSE,DGI,DGX - S OVR=0 - I $G(CAT)="" Q OVR - S DGX=$E(CAT,4) - ; If MSE1, no check; if MSE2, check overlap with MSE1; if MSE3, check - ; overlap with MSE2 or MSE1 - F DGI=(DGX-1):-1:1 S MSE="MSE"_DGI I $D(DGMS(MSE)) D Q:OVR - .S OVR=$$WITHIN^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),$G(DGMS(MSE,"FDT"))) I OVR S OVR=+OVR_U_MSE Q - .S OVR=$$WITHIN^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),$G(DGMS(MSE,"TDT"))) I OVR S OVR=+OVR_U_MSE Q - Q OVR -LOC(LN) ; Return conflict location abbreviation to pass to $$CNFLCTDT^DGRPDT - ; INPUT: LN - POW Location file #22 IEN - ; OUTPUT: Conflict location abbreviation - Q:'$G(LN) "" - S LN=$P($G(^DIC(22,LN,0)),U,1) I LN="" Q "" - Q:LN="WORLD WAR I" "WWI" - Q:LN["EUROPE" "WWIIE" - Q:LN["PACIFIC" "WWIIP" - Q:LN["KOREA" "KOR" - Q:LN["VIETNAM" "VIET" - Q:LN="OTHER" "" - Q:LN["GULF" "GULF" - Q:LN["YUGOSLAVIA" "YUG" - Q "" diff -auBN ./r1/DGMSRPT2.m ./r2/r/DGMSRPT2.m --- ./r1/DGMSRPT2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMSRPT2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,81 +0,0 @@ -DGMSRPT2 ;ALB/LBD - Military Service Inconsistency Report; 01/05/04 - ;;5.3;Registration;**562**; Aug 13,1993 - ; - ; This routine prints the Military Service Data Inconsistencies - ; report from the extracted data stored in ^XTMP("DSMSRPT"). - ; - ; -EN(DGBEG,DGEND,DGSRT) ; Entry point called from ^DGMSRPT - ; INPUT: DGBEG - Starting record number to print - ; DGEND - Ending record number to print - ; DGSRT - Sort order for report (Name or SSN) - N PG,LINE,RPTDT,CRT,OUT,DSH,CNT,MXLNE,DGXTMP,DGTOT,LOOP - S:$G(ZTSK) ZTREQ="@" - D PRTVAR - U IO D HDR - I 'DGTOT W !!,?10,"*** There are no records to print ***" S OUT=$$PAUSE Q - S LOOP="LOOP"_DGSRT - D @LOOP Q:OUT - D TOT Q:OUT - W ! S OUT=$$PAUSE - Q -LOOPN ; Sort by name. Loop through ^XTMP("DGMSRPT","MSINC","NAM", x-ref - N NM,DFN - S NM="" - F S NM=$O(@DGXTMP@("NAM",NM)) Q:NM=""!(CNT>DGEND)!OUT S DFN="" F S DFN=$O(@DGXTMP@("NAM",NM,DFN)) Q:DFN=""!(CNT>DGEND)!OUT S CNT=CNT+1 I CNT'DGEND D PRINT - Q -LOOPS ; Sort by SSN. Loop through ^XTMP("DGMSRPT","MSINC","SSN", x-ref - N S2,S4,S9,DFN - S S2="" - F S S2=$O(@DGXTMP@("SSN",S2)) Q:S2=""!(CNT>DGEND)!OUT S S4="" F S S4=$O(@DGXTMP@("SSN",S2,S4)) Q:S4=""!(CNT>DGEND)!OUT D - . S S9="" - . F S S9=$O(@DGXTMP@("SSN",S2,S4,S9)) Q:S9=""!(CNT>DGEND)!OUT S DFN="" F S DFN=$O(@DGXTMP@("SSN",S2,S4,S9,DFN)) Q:DFN=""!(CNT>DGEND)!OUT S CNT=CNT+1 I CNT'DGEND D PRINT - Q -PRINT ; Print detail - N VET,CT,CAT,IN - Q:'$D(@DGXTMP@(DFN)) - S VET=$G(@DGXTMP@(DFN,0)) - I LINE>MXLNE S OUT=$$PAUSE Q:OUT D HDR - W !,$P(VET,U,2),?12,$E($P(VET,U,1),1,25) - S LINE=LINE+1,CAT=0 - F CT=1:1 S CAT=$O(@DGXTMP@(DFN,CAT)) Q:CAT=""!OUT D - . I CT>1 D - . . I LINE>MXLNE S OUT=$$PAUSE Q:OUT D HDR - . . W ! S LINE=LINE+1 - . W ?37,CAT - . S IN="" F S IN=$O(@DGXTMP@(DFN,CAT,IN)) Q:IN=""!OUT D - . . I IN>1 D Q:OUT - . . . I LINE>MXLNE S OUT=$$PAUSE Q:OUT D HDR - . . . W ! S LINE=LINE+1 - . . W ?43,@DGXTMP@(DFN,CAT,IN) - Q -TOT ; Print total records at the end of the report - I LINE+5>MXLNE S OUT=$$PAUSE Q:OUT D HDR - W !!," Starting Record #:",$$RJ^XLFSTR(DGBEG,7) - W !," Ending Record #:",$$RJ^XLFSTR(DGEND,7) - W !!,"Total Records Printed:",$$RJ^XLFSTR((DGEND-DGBEG)+1,7)," out of ",DGTOT - Q -PRTVAR ; Set up variables needed to print report - S CRT=$S($E(IOST,1,2)="C-":1,1:0) - S DGXTMP="^XTMP(""DGMSRPT"",""MSINC"")" - S DGTOT=+$G(@DGXTMP@("CNT","VET")) - S:'$G(DGBEG) DGBEG=1 S:'$G(DGEND) DGEND=DGTOT - S:$G(DGSRT)="" DGSRT="N" - S (PG,CNT,OUT)=0,RPTDT=$$FMTE^XLFDT(DT),MXLNE=$S(CRT:15,1:52) - S DSH="",$P(DSH,"=",80)="" - Q -HDR ; Print report header - S PG=PG+1,LINE=0 - W @IOF - W ?0,"Report Date: ",RPTDT,?68,"Page: ",$$RJ^XLFSTR(PG,4) - W !,"Sorted By: "_$S(DGSRT="N":"Name",1:"SSN (Terminal Digits)") - W !!,$$CJ^XLFSTR("MILITARY SERVICE DATA INCONSISTENCIES DETAIL REPORT",80) - W !!,"SSN",?12,"Veteran's Name",?37,"Cat. Inconsistencies" - W !,DSH - Q -PAUSE() ; If report is sent to screen, prompt for next page or quit - N DIR,DIRUT,DUOUT,DTOUT,X,Y - I 'CRT Q 0 - S DIR(0)="E" - D ^DIR I 'Y Q 1 - Q 0 diff -auBN ./r1/DGMSRPT.m ./r2/r/DGMSRPT.m --- ./r1/DGMSRPT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMSRPT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,179 +0,0 @@ -DGMSRPT ;ALB/LBD - Military Service Inconsistency Report; 01/05/04 - ;;5.3;Registration;**562,603**; Aug 13,1993 - ; -EN ; Called from DG MS INCONSISTENCIES RPT option - ; Prompt user to select to run extract or print report - N DGSEL - S DGSEL=$$SEL Q:'DGSEL - S DGSEL="SEL"_DGSEL - G @DGSEL - Q - ; -SEL() ; Select action: Extract or Print - ; INPUT: None - ; OUTPUT: 1=Extract; 2=Print; 0=Quit - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - W !!,"Military Service Data Inconsistencies Report" - W !,"============================================" - S DIR(0)="S^1:Extract and Count Inconsistencies;2:Print Inconsistencies Detail Report" - S DIR("A")="Enter 1 or 2" - S DIR("?",1)="(1) Extract and Count Inconsistencies - selecting this option will queue a" - S DIR("?",2)=" process to read through the Patient file and find records with" - S DIR("?",3)=" inconsistent military service data. The inconsistencies will be" - S DIR("?",4)=" totaled by category in the Military Service Data Inconsistencies Volume" - S DIR("?",5)=" Report that will be sent as a mail message to the DGEN ELIGIBILITY ALERT" - S DIR("?",6)=" mail group. This process must be run before the detail report can" - S DIR("?",7)=" be printed, and can be rerun as necessary." - S DIR("?",8)="" - S DIR("?",9)="(2) Print Inconsistencies Detail Report - selecting this option will" - S DIR("?",10)=" produce a detail report of the inconsistencies found for" - S DIR("?",11)=" individual veterans. The report can be sorted by veteran name" - S DIR("?",12)=" or SSN (terminal digits)." - S DIR("?")=" " - D ^DIR I 'Y!($D(DTOUT))!($D(DUOUT)) Q 0 - Q Y - ; -SEL1 ; Extract and count military service data inconsistencies from Patient - ; file #2 - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - I '$$CHK W ! S DIR(0)="E" D ^DIR Q - W !! - S DIR(0)="Y",DIR("A")="Queue Extract",DIR("B")="NO" - D ^DIR K DIR Q:'Y!($D(DTOUT))!($D(DUOUT)) - K ^XTMP("DGMSRPT") - D EXTQUE - W ! S DIR(0)="E" D ^DIR - Q -SEL2 ; Print detail report of military service data inconsistencies - ; extracted and stored in ^XTMP("DGMSRPT", - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DGTOT,DGBEG,DGEND,DGSRT - I $P($G(^XTMP("DGMSRPT","DATE")),U,2)="" D Q - .W !!,*7,"*** The Extract of Military Service Data Inconsistencies must be run" - .W !," before the report can be printed." - .W ! S DIR(0)="E" D ^DIR - I '$$CHK W ! S DIR(0)="E" D ^DIR Q - I +$G(^XTMP("DGMSRPT","MSINC","CNT","VET"))=0 W !!,*7,"There are no records to print.",! S DIR(0)="E" D ^DIR Q - W !! - S DIR(0)="Y",DIR("A")="Print Report",DIR("B")="YES" - D ^DIR K DIR Q:'Y!($D(DTOUT))!($D(DUOUT)) - S DGTOT=+$G(^XTMP("DGMSRPT","MSINC","CNT","VET")) - W !!,"Total veteran records to print: ",DGTOT - S DGBEG=$$BEG(DGTOT) Q:'DGBEG - S DGEND=$$END(DGBEG,DGTOT) Q:'DGEND - S DGSRT=$$SRT Q:DGSRT="" - D RPTQUE - Q -CHK() ; Check if extract can be tasked to run - ; INPUT: None - ; OUTPUT: 1=Run Extract; 0=Don't run Extract - N CHK S CHK=1 - I $G(^XTMP("DGMSRPT","RUNNING")) D Q CHK - .N ZTSK - .S ZTSK=^XTMP("DGMSRPT","RUNNING") D STAT^%ZTLOAD - .I ZTSK(1)=1!(ZTSK(1)=2) W !!,*7,"*** Extract is currently running or queued as task ",^XTMP("DGMSRPT","RUNNING") S CHK=0 - I $P($G(^XTMP("DGMSRPT","DATE")),U,2)'="" W !!,"Extract was last run ",$P(^XTMP("DGMSRPT","DATE"),U,2) - Q CHK - ; -BEG(TOT) ; Get starting record number to print - ; INPUT: TOT - Total number of veteran records to print - ; OUTPUT: Y - Starting record number - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - I '$G(TOT) Q 0 - S DIR(0)="NA^1:"_TOT,DIR("A")="Print from record: ",DIR("B")=1 - D ^DIR I 'Y!($D(DTOUT))!($D(DUOUT)) Q 0 - Q Y -END(BEG,TOT) ; Get ending record number to print - ; INPUT: BEG - Starting record number to print - ; TOT - Total number of veteran records to print - ; OUTPUT: Y - Ending record number - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - I '$G(BEG),'$G(TOT) Q 0 - S DIR(0)="NA^"_BEG_":"_TOT,DIR("A")=" to record: ",DIR("B")=DGTOT - D ^DIR I 'Y!($D(DTOUT))!($D(DUOUT)) Q 0 - Q Y -SRT() ; Get sort order - ; OUPUT: Y - Sort (N=Name; S=SSN) - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - S DIR(0)="SA^N:Name;S:SSN (Terminal digits)",DIR("A")="Sort report by Name or SSN (Terminal digits): ",DIR("B")="NAME" - S DIR("?",1)="Indicate whether the report should be sorted by the" - S DIR("?")="Veteran's Name or the terminal digits of the Veteran's SSN" - D ^DIR I $D(DTOUT)!($D(DUOUT)) Q "" - Q Y - ; -EXTQUE ; Queue extract task - N ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,DIR - S ZTRTN="EN^DGMSRPT1",ZTIO="",ZTDTH="" - S ZTDESC="Extract Military Service Inconsistencies" - D ^%ZTLOAD - I $G(ZTSK) D Q - .S ^XTMP("DGMSRPT","RUNNING")=ZTSK - .W !,"Extract queued as task ",ZTSK - .W !!,"When the process is completed a message containing the Military Service Data" - .W !,"Inconsistencies Volume Report will be sent to mail group DGEN ELIGIBILITY ALERT.",! - W !,*7,"Extract could not be queued!" - Q - ; -RPTQUE ; Get report device. Queue report if requested. - N POP,ZTRTN,ZTDESC,ZTSAVE,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - K IOP,%ZIS - S %ZIS="MQ" - W ! - D ^%ZIS I POP W !!,*7,"Report Cancelled!",! S DIR(0)="E" D ^DIR Q - I $D(IO("Q")) D Q - .S ZTRTN="EN^DGMSRPT2(DGBEG,DGEND,DGSRT)" - .S ZTDESC="Print Military Service Inconsistencies Report" - .S (ZTSAVE("DGBEG"),ZTSAVE("DGEND"),ZTSAVE("DGSRT"))="" - .D ^%ZTLOAD - .W !!,"Report "_$S($D(ZTSK):"Queued!",1:"Cancelled!") - .W ! S DIR(0)="E" D ^DIR - .D HOME^%ZIS - D EN^DGMSRPT2(DGBEG,DGEND,DGSRT) - D ^%ZISC - Q - ; -MSG(DGXTMP) ; Send message with counts of inconsistencies when extract completes. - ;INPUT: DGXTMP - ^XTMP global reference - N DGMSG,XMDUZ,XMSUB,XMTEXT,XMY,LN,SUB,SITE - S:$G(DGXTMP)="" DGXTMP="^XTMP(""DGMSRPT"",""MSINC"")" - S SITE=$P($$SITE^VASITE,U,3) S:SITE="" SITE="UNKNOWN" - S XMDUZ="STATION #"_SITE - I $$GET1^DIQ(869.3,"1,",.03,"I")'="P" S XMDUZ=XMDUZ_" [TEST]" - S XMSUB="MILITARY SERVICE DATA INCONSISTENCIES VOLUME REPORT" - S (XMY(DUZ),XMY("G.DGEN ELIGIBILITY ALERT"),XMY("HECDQSUPPORT@MED.VA.GOV"))="",XMTEXT="DGMSG(" - S DGMSG(1)="The extract of Military Service data inconsistencies has completed" - S DGMSG(2)="successfully." - S DGMSG(3)="" - S DGMSG(4)="Extract process started: "_$P($G(^XTMP("DGMSRPT","DATE")),U,1) - S DGMSG(5)="Extract process ended: "_$P($G(^XTMP("DGMSRPT","DATE")),U,2) - S DGMSG(6)="" - S DGMSG(7)="Total Veterans with MS Data Inconsistencies: "_+@DGXTMP@("CNT","VET") - S DGMSG(8)="" - S DGMSG(9)=$$LJ^XLFSTR(" INCONSISTENCY CATEGORY",55)_$$RJ^XLFSTR("TOTAL",20) - S DGMSG(10)=$$LJ^XLFSTR("",79,"=") - S LN=10,SUB="" - F S SUB=$O(@DGXTMP@("CNT",SUB)) Q:'SUB S LN=LN+1,DGMSG(LN)=$$LJ^XLFSTR($P(^(SUB),U,2),55)_$$RJ^XLFSTR($P(^(SUB),U,1),20) - D ^XMD - Q - ; -INIT ; Set variables and initialize array for counts - S DGXTMP="^XTMP(""DGMSRPT"",""MSINC"")" - S @DGXTMP@("CNT",2)="0^Branch of Service=B.E.C." - S @DGXTMP@("CNT",3)="0^Branch of Service=Merchant Seaman, No WWII Service" - S @DGXTMP@("CNT",4)="0^Military Service Episode Data Missing" - S @DGXTMP@("CNT",5)="0^Military Service Episode Date Imprecise" - S @DGXTMP@("CNT",6)="0^Military Service Episode End Date Before Start Date" - S @DGXTMP@("CNT",7)="0^Military Service Episodes Overlap" - S @DGXTMP@("CNT",8)="0^Combat Data Missing" - S @DGXTMP@("CNT",9)="0^Combat Date Imprecise" - S @DGXTMP@("CNT",10)="0^Combat Date Not Valid for Location" - S @DGXTMP@("CNT",11)="0^Combat Date Not Within MSE" - S @DGXTMP@("CNT",12)="0^Conflict Data Missing" - S @DGXTMP@("CNT",13)="0^Conflict Date Imprecise" - S @DGXTMP@("CNT",14)="0^Conflict Date Not Valid for Location" - S @DGXTMP@("CNT",15)="0^Conflict Date Not Within MSE" - S @DGXTMP@("CNT",16)="0^Prisoner of War Data Missing" - S @DGXTMP@("CNT",17)="0^Prisoner of War Date Imprecise" - S @DGXTMP@("CNT",18)="0^Prisoner of War Date Not Valid for Location" - S @DGXTMP@("CNT",19)="0^Prisoner of War Date Not Within MSE" - S @DGXTMP@("CNT","VET")="0^Number of Veterans with Inconsistent MS Data" - Q diff -auBN ./r1/DGMSTR2.m ./r2/r/DGMSTR2.m --- ./r1/DGMSTR2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMSTR2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMSTR2 ;ALB/SCK - MST DETAILED DEMOGRAPHIC REPORT ; 11/19/03 10:56am - ;;5.3;Registration;**195,555**;Aug 13, 1993 +DGMSTR2 ;ALB/SCK - MST DETAILED DEMOGRAPHIC REPORT ; 1/14/99 + ;;5.3;Registration;**195**;Aug 13, 1993 ; EN ; Main entry point for report ; Variable List @@ -124,7 +124,7 @@ S MSTST="" F S MSTST=$O(DGMST(MSTST)) Q:'(MSTST]"") D Q:$G(DGQUIT) . I $O(@RPTARRY@(MSTST,""))="" D Q - .. S X=$$HEADER(MSTST,DGDSP,DGBEG,DGEND) ;DG*5.3*264 + .. S X=$$HEADER("",DGDSP,DGBEG,DGEND) .. W !!?5,"No data for MST status "_MSTST_" found." . S DGQUIT=$$HEADER(MSTST,DGDSP,DGBEG,DGEND) Q:$G(DGQUIT) . S (DGNDX,MSTNAME)="" @@ -141,13 +141,13 @@ N MSTST,DFN,MSTPOS,MSTNAME,MSTIEN,DGQUIT,DGX,DGNDX ; I '$O(@RPTARRY@(""))="" D Q - . S X=$$HEADER(MSTST,DGDSP,DGBEG,DGEND) + . S X=$$HEADER("",DGDSP,DGBEG,DGEND) . W !!?5,"No data for these parameters found." ; S MSTST="" F S MSTST=$O(DGMST(MSTST)) Q:'(MSTST]"") D Q:$G(DGQUIT) . I $O(@RPTARRY@(MSTST,""))="" D Q - .. S X=$$HEADER(MSTST,DGDSP,DGBEG,DGEND) + .. S X=$$HEADER("",DGDSP,DGBEG,DGEND) .. W !!?5,"No data for MST status "_MSTST_" found." . S DGQUIT=$$HEADER(MSTST,DGDSP,DGBEG,DGEND) Q:$G(DGQUIT) . S MSTPOS="" diff -auBN ./r1/DGMTA.m ./r2/r/DGMTA.m --- ./r1/DGMTA.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTA.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTA ;ALB/RMO/CAW/LD/SCG/AEG/PHH - Add a New Means Test ; 07/06/2004 - ;;5.3;Registration;**33,45,137,166,177,182,290,344,332,433,458,535,612,564**;Aug 13, 1993 +DGMTA ;ALB/RMO/CAW/LD/SCG/AEG - Add a New Means Test ;3/12/02 2:00 pm + ;;5.3;Registration;**33,45,137,166,177,182,290,344,332,433,458**;Aug 13, 1993 ; EN ;Entry point to add a new means test N DGMDOD S DGMDOD="" @@ -54,7 +54,7 @@ .Q K % ; -PRINT I "^P^A^C^G^"[(U_$P(DGLDT,U,4)_U) S %=1 W !,"Do you wish to print the prior means test" D YN^DICN G:%=-1 Q I %Y["?" W !!,"This will print the prior means test information.",! G PRINT +PRINT I "^P^A^C^"[(U_$P(DGLDT,U,4)_U) S %=1 W !,"Do you wish to print the prior means test" D YN^DICN G:%=-1 Q I %Y["?" W !!,"This will print the prior means test information.",! G PRINT I $G(%)=1 S DGX=DGMTDT,DGMTDT=DGLD,DGMTI=+DGLDT,DGOPT="" D DEV^DGMTP,CLOSE^DGUTQ S DGMTDT=DGX K DGX D ADD G EN:DGMTI<0 S DGMTACT="ADD",DGMTROU="EN^DGMTA" G EN^DGMTSC @@ -75,10 +75,6 @@ ; obtain lock used to synchronize local MT/CT options with income test upload I $$LOCK^DGMTUTL(DFN) E Q ; - ; Check for Linked test and don't loose the link. - S LINK="",CURIEN=+$$LST^DGMTU(DFN,DGMTDT,DGMTYPT) - I CURIEN S LINK=$P($G(^DGMT(408.31,CURIEN,2)),U,6) - ; S DGSITE=$$GETSITE^DGMTU4(.DUZ) S X=DGMTDT,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31 ; @@ -87,10 +83,10 @@ ; modified without an in-depth review of DD of file #408.31. ; I DGMTYPT=2 D - .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_";2.06////"_LINK + .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE .S DIC("DR")=DIC("DR")_";.02////"_DFN_";.019////"_DGMTYPT_";.23////1" E D - .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_";2.06////"_LINK + .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE .S DIC("DR")=DIC("DR")_";.019////"_DGMTYPT_";.02////"_DFN_";.23////1" K DD,DO D FILE^DICN S DGMTI=+Y @@ -123,12 +119,10 @@ WHY ;Why Copay Test cannot be added ;;Patient is not a veteran. ;;Patient does not have a Primary Eligibility Code. - ;;Patient is Service Connected 50-100%. + ;;Patient has a Primary or Other Eligibility Code of SC>50%, AA, HB or NSC,Pension ;;Means Test options must be used instead of Copay options. ;;Patient is receiving Aid and Attendance, automatically exempted. ;;Patient is receiving Housebound Benefits, automatically exempted. ;;Patient is receiving a VA Pension, automatically exempted. ;;Patient is in a DOM ward, automatically exempted. ;;Patient is an inpatient, automatically exempted. - ;;Patient was a POW, automatically exempted. - ;;Patient is Unemployable, automatically exempted. diff -auBN ./r1/DGMTARR.m ./r2/r/DGMTARR.m --- ./r1/DGMTARR.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTARR.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTARR ;ALB/GRR/PHH - PRINT ROUTINES FOR MEANS TEST VERIFICATION; JAN 21, 1999 - ;;5.3;Registration;**217,535**;AUG 13, 1993 +DGMTARR ;ALB/GRR - PRINT ROUTINES FOR MEANS TEST VERIFICATION; JAN 21, 1999 + ;;5.3;Registration;**217**;AUG 13, 1993 ;DGLOW - LOW DOLLAR AMOUNT RANGE ;DGHIGH - HIGH DOLLAR AMOUNT RANGE ;DGSDAT - START DATE RANGE @@ -30,7 +30,6 @@ S DGDAT=DGSDAT-1 F S DGDAT=$O(^DGMT(408.31,"AG",DGDAT)) Q:DGDAT'>0!(DGDAT\1>DGTDAT) S DGIEN=0 F S DGIEN=$O(^DGMT(408.31,"AG",DGDAT,DGIEN)) Q:DGIEN'>0 D .S DGMT0=$G(^DGMT(408.31,DGIEN,0)) .S DGINC=$P(DGMT0,"^",4) Q:DGINC="" - .Q:$P(DGMT0,"^",19)'=1 .I DGINC'DGTDOL) D ..S DFN=$P(DGMT0,"^",2) D DEM^VADPT Q:$G(VADM(6))]"" S DGNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2) ..S ^TMP($J,"MTSPI",DGINC,DGNAME,DFN)=SSN_"^"_DGDAT @@ -96,7 +95,6 @@ S DGDAT=DGSDAT-1 F S DGDAT=$O(^DGMT(408.31,"AG",DGDAT)) Q:DGDAT'>0!(DGDAT\1>DGTDAT) S DGIEN=0 F S DGIEN=$O(^DGMT(408.31,"AG",DGDAT,DGIEN)) Q:DGIEN'>0 D .S DGMT0=$G(^DGMT(408.31,DGIEN,0)) .S DGINC=$P(DGMT0,"^",4),DGTHR=+$P(DGMT0,"^",12) Q:DGINC="" - .Q:$P(DGMT0,"^",19)'=1 .Q:DGINC>DGTHR .S DGDIFF=DGTHR-DGINC .I DGDIFF'DGTDOL) D diff -auBN ./r1/DGMTCOR.m ./r2/r/DGMTCOR.m --- ./r1/DGMTCOR.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTCOR.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTCOR ;ALB/CAW,SCG,LBD - Check Copay Test Requirements ; 03/03/03 8:15am - ;;5.3;Registration;**21,45,182,290,305,330,344,495,564**;Aug 13, 1993 +DGMTCOR ;ALB/CAW,SCG - Check Copay Test Requirements ; 01/22/01 8:15am + ;;5.3;Registration;**21,45,182,290,305,330,344**;Aug 13, 1993 ; ;A patient may apply for a copay test under the following conditions: ; - Applicant is a veteran @@ -18,10 +18,6 @@ ; past year ; - Applicants who are not currently a DOM patient or inpatient ; (they are temporarily exempt from copay testing) DG*5.3*290 - ; - Applicants who do not have POW eligibility (DG*5.3*564 - HVE III) - ; - Applicants who do not meet criteria for Unemployable: - ; Unemployable="Y", SC%>0, not receiving A&A, HB or Pension, and - ; Total VA Check Amount>0 (DG*5.3*564 - HVE III) ; ; Input -- DFN Patient IEN ; DGADDF Means Test Add Flag (optional) @@ -37,23 +33,23 @@ D CHK ; Q:($G(DGWRT)=8)!($G(DGWRT)=9) ;brm;quit if inpatient or dom;DG*5.3*290 - S IVMZ10F=+$G(IVMZ10F) - I 'DGMTCOR,'$G(DGADDF),'$G(DGMDOD),'IVMZ10F D NLA + I 'DGMTCOR,'$G(DGADDF),'$G(DGMDOD) D NLA I DGMTCOR,'$G(DGADDF),'$G(DGMDOD) D INC I DGRGAUTO&'$G(DGADDF) D QREGAUTO ;if cp event driver not fired off & NOT a new means test ; ENQ Q ; -CHK N STATUS,DGELIG,DGE,DGI,DGNODE,DGMDOD,DGMTDT,DGMTI,DGMTL +CHK N STATUS,ELIG,ELIGIEN,DGNODE,DGMDOD,DGMTDT S DGMTCOR=1,DGMT="",DGMTYPT=2 I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S DGMTCOR=0,DGWRT=1 G CHKQ ;NON-VET ;Added with DG*5.3*344 - S DGMTL=$$LST^DGMTU(DFN),DGMTI=+DGMTL,DGMTDT=$P(DGMTL,U,2) + S DGMTI="",DGMTI=+$$LST^DGMTU(DFN) + S:DGMTI DGMTDT=$P($G(^DGMT(408.31,DGMTI,0)),U) S DGMDOD=$P($G(^DPT(DFN,.35)),U) I 'DGMTI,$G(DGMDOD) S DGMTCOR=0 Q I DGMDOD,(DGMTCOR),(DGMTDT>(DGMDOD-1)) S DGMTCOR=0 G CHKQ ; - I '$P($G(^DPT(DFN,.36)),U) S DGMTCOR=0,DGWRT=2 G CHKQ ;NO PRIM ELIG + S DGMTI=0 I '$P($G(^DPT(DFN,.36)),U) S DGMTCOR=0,DGWRT=2 G CHKQ I +$G(DGMDOD) S DGNOCOPF=1 ; ;This doesn't work! The "AEL" x-ref not there when changing the primary @@ -62,20 +58,18 @@ ;F S DGMTI=$O(^DPT("AEL",DFN,DGMTI)) Q:'DGMTI S DGMTE=$P($G(^DIC(8,DGMTI,0)),U,9) I "^1^2^4^15^"[("^"_DGMTE_"^") S DGMTCOR=0,DGWRT=3 G CHKQ ; ; - S DGI=$P($G(^DPT(DFN,.36)),"^"),DGELIG=U_$P($G(^DIC(8,+DGI,0)),U,9)_U - S DGI=0 F S DGI=$O(^DPT(DFN,"E",DGI)) Q:'DGI S DGE=$P($G(^DPT(DFN,"E",DGI,0)),U),DGELIG=DGELIG_$P($G(^DIC(8,+DGE,0)),U,9)_U - I (DGELIG["^1^") S DGMTCOR=0,DGWRT=3 G CHKQ ;SC 50-100% - F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) - I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR=0,DGWRT=5 G CHKQ ;A&A - I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR=0,DGWRT=6 G CHKQ ;HB - I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR=0,DGWRT=7 G CHKQ ;PENSION - I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0,DGWRT=10 G CHKQ ;POW (DG*5.3*564) - I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S DGMTCOR=0,DGWRT=11 G CHKQ ;UNEMPLOYABLE (DG*5.3*564) + S ELIG=$P($G(^DPT(DFN,.36)),"^") I ELIG S DGMTE=$P($G(^DIC(8,ELIG,0)),U,9) I "^1^2^4^15^"[("^"_DGMTE_"^") S DGMTCOR=0,DGWRT=3 G CHKQ + S ELIGIEN=0 F S ELIGIEN=$O(^DPT(DFN,"E",ELIGIEN)) Q:'ELIGIEN S ELIG=$P($G(^DPT(DFN,"E",ELIGIEN,0)),"^") I ELIG S DGMTE=$P($G(^DIC(8,ELIG,0)),U,9) I "^1^2^4^15^"[("^"_DGMTE_"^") S DGMTCOR=0,DGWRT=3 G CHKQ + S DGNODE=$$LST^DGMTU(DFN),DGMTI=+DGNODE ;brm added next 3 lines for DG*5.3*290 N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR,NOW D DOM^DGMTR I $G(DGDOM) S DGMTCOR=0,DGRGAUTO=0,DGWRT=8 Q ;DOM D IN5^VADPT I $G(VAIP(1))'="" S DGMTCOR=0,DGRGAUTO=0,DGWRT=9 Q ;INP - I DGMTI,'$$OLD^DGMTU4(DGMTDT) S STATUS=$P($G(^DGMT(408.31,+DGMTI,0)),U,3) I STATUS'="3" S DGMTCOR=0,DGWRT=4 G CHKQ + I DGMTI,'$$OLD^DGMTU4($P(DGNODE,"^",2)) S STATUS=$P($G(^DGMT(408.31,+DGMTI,0)),U,3) I STATUS'="3" S DGMTCOR=0,DGWRT=4 G CHKQ + S DGNODE=$G(^DPT(DFN,.362)) + I DGMTCOR,$P(DGNODE,U,12)["Y" S DGMTCOR=0,DGWRT=5 G CHKQ ;A&A + I DGMTCOR,$P(DGNODE,U,13)["Y" S DGMTCOR=0,DGWRT=6 G CHKQ ;HB + I DGMTCOR,$P(DGNODE,U,14)["Y" S DGMTCOR=0,DGWRT=7 G CHKQ ;PENSION CHKQ Q ; NLA ; Change Status to NO LONGER APPLICABLE - if appropriate diff -auBN ./r1/DGMTCOU1.m ./r2/r/DGMTCOU1.m --- ./r1/DGMTCOU1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTCOU1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES ; 8/13/04 8:31am - ;;5.3;Registration;**33,45,54,335,358,401,436,445,564**;Aug 13, 1993 +DGMTCOU1 ;ALB/REW,LD,JAN,AEG - COPAY UTILITIES ; 03/22/02 + ;;5.3;Registration;**33,45,54,335,358,401,436,445**;Aug 13, 1993 AUTO(DFN,AUTOEX) ; ; Returns 1 if Exempt from CP w/o needing MT/CP information ; INPUT: DFN [Required] @@ -15,22 +15,20 @@ ; looked at to determine Copay Exemption Status ; ; INPUT: DFN - IEN of Patient File (Required) - ; OUTPUT: (SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PT^NON.VET^INPT^POW^UNEMP) - ; Piece: ( 1 ^ 2 ^ 3 ^ 4 ^ 5 ^ 6 ^ 7 ^ 8 ^ 9 ) + ; OUTPUT: (SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PATIENT^NON.VET^INPATIENT) + ; Piece: ( 1 ^ 2 ^ 3 ^ 4 ^ 5 ^ 6 ^ 7 ) ; PIECES =1 IF TRUE ; - N DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT,DGI + N DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT S DGX="" I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S $P(DGX,U,6)=1 G QTAUTO ;NON-VET S DGEL=0,DGALLEL=U F S DGEL=$O(^DPT("AEL",DFN,DGEL)) Q:'DGEL S DGALLEL=DGALLEL_$P($G(^DIC(8,DGEL,0)),U,9)_U - F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) + S DGNODE=$G(^DPT(DFN,.362)) I (DGALLEL["^1^") S $P(DGX,U,1)=1 G QTAUTO ;SC>50 - I $P(DGNODE(.362),U,12)["Y"!(DGALLEL["^2^") S $P(DGX,U,2)=1 G QTAUTO ;A&A - I $P(DGNODE(.362),U,13)["Y"!(DGALLEL["^15^") S $P(DGX,U,3)=1 G QTAUTO ;HB - I $P(DGNODE(.362),U,14)["Y"!(DGALLEL["^4^") S $P(DGX,U,4)=1 G QTAUTO ;PENSION - I $P(DGNODE(.52),U,5)["Y"!(DGALLEL["^18^") S $P(DGX,U,8)=1 G QTAUTO ;POW - I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S $P(DGX,U,9)=1 G QTAUTO ;UNEMPLOYABLE + I $P(DGNODE,U,12)["Y"!(DGALLEL["^2^") S $P(DGX,U,2)=1 G QTAUTO ;A&A + I $P(DGNODE,U,13)["Y"!(DGALLEL["^15^") S $P(DGX,U,3)=1 G QTAUTO ;HB + I $P(DGNODE,U,14)["Y"!(DGALLEL["^4^") S $P(DGX,U,4)=1 G QTAUTO ;PENSION N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR D DOM^DGMTR I $G(DGDOM) S $P(DGX,U,5)=1 G QTAUTO ;DOM D IN5^VADPT I $G(VAIP(1))'="" S $P(DGX,U,7)=1 G QTAUTO ;INPAT diff -auBN ./r1/DGMTDD2.m ./r2/r/DGMTDD2.m --- ./r1/DGMTDD2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTDD2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTDD2 ;ALB/RMO,LBD - Income Relation file (#408.22) Data Dictionary Calls ;13 MAR 1992 3:00 pm - ;;5.3;Registration;**33,45,518**;Aug 13, 1993 +DGMTDD2 ;ALB/RMO - Income Relation file (#408.22) Data Dictionary Calls ;13 MAR 1992 3:00 pm + ;;5.3;Registration;**33,45**;Aug 13, 1993 ; ID ;Identifier for Income Relation file N DGIN0,DGPRI,Y @@ -11,13 +11,9 @@ FUN ;"Trigger" Cross-reference on the Married field (#.05) and ;Dependent Children field (#.08) to delete funeral and burial ;expenses - ; If the test is a LTC Copay test do not delete the funeral and - ; burial expenses. Added for LTC Phase III (DG*5.3*518) - N DGFLD,DGIN0,DGINI,DGVAL,DGMT + N DGFLD,DGIN0,DGINI,DGVAL S DGINI=+$P($G(^DGMT(408.22,DA,0)),U,2),DGIN1=$G(^DGMT(408.21,DGINI,1)) - S DGMT=+$G(^DGMT(408.21,DGINI,"MT")) - I DGMT,$P($G(^DGMT(408.31,DGMT,0)),U,19)=3 Q - S DGFLD=1.02,DGVAL=$P(DGIN1,U,2) + S DGFLD=1.01,DGVAL=$P(DGIN1,U,2) I DGVAL]"" D KILL S $P(^DGMT(408.21,DGINI,1),U,2)="" Q ; diff -auBN ./r1/DGMTDEL1.m ./r2/r/DGMTDEL1.m --- ./r1/DGMTDEL1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTDEL1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTDEL1 ;ALB/CAW,LBD,PHH - Delete MT for a Patient (con't) ;12/6/94 - ;;5.3;Registration;**45,166,182,433,518,531**;Aug 13, 1993 +DGMTDEL1 ;ALB/CAW - Delete MT for a Patient (con't) ;12/6/94 + ;;5.3;Registration;**45,166,182,433**;Aug 13, 1993 ; ID ;write identifiers S DGI=Y,DGN=$G(^DGMT(408.31,DGI,0)) @@ -23,16 +23,6 @@ .S DA=DGMTX .I DA S DR="31///@",DIE="^DGMT(408.22," D ^DIE .K DE,DQ,DR,DIK - .; - .; Delete the $0.00 values out of the net worth fields if total income - .; is not greater than zero dollars. - .N DA,NODE0,AMTFLG,CNT,DIE,DR - .S DA=$P($G(^DGMT(408.22,DGMTX,0)),"^",2) - .I DA D - ..Q:'$D(^DGMT(408.21,DA,2)) - ..S NODE0=$G(^DGMT(408.21,DA,0)) Q:NODE0="" - ..S AMTFLG=0 F CNT=0:1:9 S:$P(NODE0,"^",CNT+8)'="" AMTFLG=1 - ..I 'AMTFLG S DIE="^DGMT(408.21,",DR="31///@;2.01///@;2.02///@;2.03///@;2.04///@" D ^DIE D AFTER^DGMTEVT S DGMTINF=0 I DGMTYPT=1!(DGMTYPT=2) D EN^DGMTEVT I DGMTYPT=4 D @@ -63,10 +53,9 @@ . S IEN4=$O(^DGMT(408.31,"AT",DGMTI,"")) Q:IEN4="" ;Test type 4 . S LTCDT=$P($G(^DGMT(408.31,IEN4,0)),"^",1) ;Date of Test .;Check to see if test type 3 is linked with type 4 + . S GIEN=$O(^DGMT(408.31,"AT",IEN4,"")) ;Test type 3 .;if linked, remove pointer value from test type 3 - .; Added FOR loop for LTC Phase III to support multiple type 3 tests - . S GIEN="" F S GIEN=$O(^DGMT(408.31,"AT",IEN4,GIEN)) Q:GIEN="" D - . . S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DIE + . I GIEN S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DIE .;remove linked test type 4 record. . D DELETE^IVMPLOG(DFN,LTCDT,,,,4) . N DGMTI,DGMTP,DGMTA,DGMTINF,DGMTACT,DGMTYPT @@ -75,9 +64,7 @@ . S DGMTACT="DEL" D AFTER^DGMTEVT S DGMTINF=0 . S DGMTYPT=4 D EN^DGMTAUD I DGMTYPT=4 D - .;Check to see if test type 3 is linked with type 4 + . S GIEN=$O(^DGMT(408.31,"AT",DGMTI,"")) Q:GIEN="" ;Linked test type 3 .;if linked, remove pointer value from test type 3 - .; Added FOR loop for LTC Phase III to support multiple type 3 tests - . S GIEN="" F S GIEN=$O(^DGMT(408.31,"AT",DGMTI,GIEN)) Q:GIEN="" D - . . S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DIE + . S DA=GIEN,DIE="^DGMT(408.31,",DR="2.08///@" D ^DIE Q diff -auBN ./r1/DGMTO1.m ./r2/r/DGMTO1.m --- ./r1/DGMTO1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTO1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,72 +1,41 @@ -DGMTO1 ;ALB/CAW,AEG/EG - AGREED TO PAY DEDUCTIBLE PRINT (CON'T) ; 1/21/05 8:08am - ;;5.3;Registration;**33,182,358,568,585**;Aug 13, 1993 +DGMTO1 ;ALB/CAW,AEG - AGREED TO PAY DEDUCTIBLE PRINT (CON'T) ; 8/12/92 + ;;5.3;Registration;**33,182,358**;Aug 13, 1993 ; START ; ; loop through cat Cs for active ones S (DGPAGE,DGSTOP)=0 F DGCAT=2,6 F DFN=0:0 S DFN=$O(^DPT("ACS",DGCAT,DFN)) Q:DFN'>0 D CATCLST - D ACTIVE D CATCOUT K ^TMP("DGMTO",$J,"CNULL"),DFN - D CLOSE^DGMTUTL - Q - ; -CATCLST N DGDT,IEN,NODE0 + D CLOSE^DGMTUTL Q +CATCLST N DGWHEN,DGDT,IEN,NODE0 S NODE0=$G(^DPT(DFN,0)) Q:(+$G(^(.35)))!($P(NODE0,U,14)'=DGCAT) F DGDT=0:0 S DGDT=$O(^DGMT(408.31,"AD",1,DFN,DGDT)) Q:'DGDT S IEN=$$MTIEN^DGMTU3(1,DFN,-DGDT) I IEN,(DGDT'DGTODAY) D .Q:DGCAT'[$P($G(^DGMT(408.31,+IEN,0)),U,3) .Q:$P($G(^DGMT(408.31,+IEN,0)),U,11)=1 - .S ^TMP("DGMTO",$J,"CNULL",$P(NODE0,U,1),DFN)=";;"_$P(NODE0,U,1)_";;"_DGCAT_";;"_$$SR^DGMTAUD1($G(^DGMT(408.31,+IEN,0))) + .S DGWHEN="" + .I $$ACTIVE(DGYRAGO,DGTODAY) S $P(DGWHEN,U,1)="X" ;PAST YR + .I +$G(^DPT(DFN,.105)) S $P(DGWHEN,U,2)="X" ;INHOUSE + .I $$ACTIVE(DGTODAY,9999999) S $P(DGWHEN,U,3)="X" ;FUTURE + .S:DGWHEN]"" ^TMP("DGMTO",$J,"CNULL",$P(NODE0,U,1),DFN)=DGWHEN_";;"_$P(NODE0,U,1)_";;"_DGCAT_";;"_$$SR^DGMTAUD1($G(^DGMT(408.31,+IEN,0))) QTC Q - ; -ACTIVE ; - N APWHEN,I,VETARRAY,PIEN,PNAME,RCNT,ACNT,DGARRAY,SDCNT,APT,CK1,CK3,PATNAM - S ACNT=1,RCNT=0 - S PNAME="" F S PNAME=$O(^TMP("DGMTO",$J,"CNULL",PNAME)) Q:PNAME="" D - .S PIEN=0 F S PIEN=$O(^TMP("DGMTO",$J,"CNULL",PNAME,PIEN)) Q:'PIEN D - ..S RCNT=RCNT+1,VETARRAY(ACNT)=$G(VETARRAY(ACNT))_PIEN_";" - ..; Group DFNs by no more than twenty records - ..I RCNT>19 S ACNT=ACNT+1,RCNT=0 - ; - ; Call SD API by array of Patient DFNs - F I=1:1 Q:'$D(VETARRAY(I)) D - .S DGARRAY("FLDS")="1",DGARRAY(4)=VETARRAY(I) - .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) - .M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301") - .K DGARRAY,^TMP($J,"SDAMA301") - ; - ;if there is data hanging from the 101 subscript, - ;then it is a valid appointment, otherwise - ;it is an error eg 01/20/2005 - ; Appointment Database was unavailable - I $D(^TMP($J,"SDAMA",101))=1 K ^TMP("DGMTO",$J,"CNULL") S ^TMP("DGMTO",$J,"CNULL",101)="" Q - ; - ; Complete ^TMP entries for report - N PATIEN,CLIEN,APPTDT,PATAPPT,APWHEN - S PATNAM="" F S PATNAM=$O(^TMP("DGMTO",$J,"CNULL",PATNAM)) Q:PATNAM="" D - .S PATIEN=0 F S PATIEN=$O(^TMP("DGMTO",$J,"CNULL",PATNAM,PATIEN)) Q:'PATIEN D - ..; - ..S CLIEN=0 F S CLIEN=$O(^TMP($J,"SDAMA",PATIEN,CLIEN)) Q:'CLIEN D - ...S APPTDT=0 F S APPTDT=$O(^TMP($J,"SDAMA",PATIEN,CLIEN,APPTDT)) Q:'APPTDT D - ....; Get list of appointments for vet - ....S PATAPPT(APPTDT)=PATNAM - ..; Update or Delete ^TMP for Report - ..S APT=$O(^DPT(PATIEN,"DIS",(9999999-DGTODAY))),APWHEN="" - ..I APT,(APT<(9999999-DGYRAGO)) S $P(APWHEN,U,1)="X" - ..I +$G(^DPT(PATIEN,.105)) S $P(APWHEN,U,2)="X" - ..I $O(PATAPPT(""),-1)>DT S $P(APWHEN,U,3)="X" - ..K PATAPPT - ..I APWHEN']"" D - ...S CK1=$O(^DGPM("APRD",PATIEN,DGYRAGO)) I (+CK1)&(+CK10 S X=$P($G(^DGS(41.1,+A,0)),U,2) S:(X'TO) Y=3 + I 'Y S X=$O(^DGPM("APRD",DFN,FROM)) S:(+X)&(+X120 S I=I+1 - Q - ; -SDAM ; Build TMP Global with Appointment API Data for Report - S DGARRAY(1)=DGBEG_";"_DGEND - S DGARRAY("FLDS")="1;3;10" - F I=1:1 Q:'$D(CLNARRAY(I)) D - .S DGARRAY(2)=CLNARRAY(I) - .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) - .M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301") - .K ^TMP($J,"SDAMA301") - Q - ; CLN1 ; Loop through appointments ; - N DGTMP S DGDATE=DGBEG-.1,DGLST=DGEND+.9 - S DGCLN=0 F S DGCLN=$O(^TMP($J,"SDAMA",DGCLN)) Q:'DGCLN D - .S DGDFN=0 F S DGDFN=$O(^TMP($J,"SDAMA",DGCLN,DGDFN)) Q:'DGDFN D - ..S DGDATE=0 F S DGDATE=$O(^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE)) Q:'DGDATE D - ...S DGTMP=^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE) - ...Q:$$DOM(DGDFN,DGDATE) - ...Q:"^N^NA^C^CA^PC^PCA^"[(U_$P($P(DGTMP,U,3),";")_U) - ...D MT + S DGDATE=DGBEG-.1,DGLST=DGEND+.9 + F S DGDATE=$O(^SC(DGCLN,"S",DGDATE)) Q:'DGDATE!(DGDATE>DGLST) S DGAPT=0 F S DGAPT=$O(^SC(DGCLN,"S",DGDATE,1,DGAPT)) Q:'DGAPT S DGDFN=$P(^SC(DGCLN,"S",DGDATE,1,DGAPT,0),U),DGPAT=$G(^DPT(DGDFN,"S",DGDATE,0)) D + .Q:DGCLN'=+DGPAT + .Q:$$DOM(DGDFN,DGDATE) + .Q:"^N^NA^C^CA^PC^PCA^"[(U_$P(DGPAT,U,2)_U) + .D MT Q MT ; Is patient going to need to complete a MT/Copay by appt? S DGMT=$$LST^DGMTU(DGDFN,$P(DGDATE,"."),DGMTYPT),DGMT1=$P($G(^DGMT(408.31,+DGMT,0)),U,3) I DGMT1,"^3^10^"'[("^"_DGMT1_"^") D @@ -73,7 +54,7 @@ .N DGNXTMT .S DGNXTMT=$O(^IVM(301.5,"AE",DGDFN,DT)) .I 'DGNXTMT S DGNXTMT="" - .S ^TMP("DGMTO",$J,$S(+$P(^SC(DGCLN,0),U,15):$P(^(0),U,15),1:$O(^DG(40.8,0))),$P(^SC(DGCLN,0),U),$P(^DPT(DGDFN,0),U),DGDATE)=DGDFN_U_$P(DGMT,U,1,4)_U_$P($P(DGTMP,U,10),";")_U_DGNXTMT,^TMP("DGMTL",$J,$P(^DPT(DGDFN,0),U),DGDFN)="" + .S ^TMP("DGMTO",$J,$S(+$P(^SC(DGCLN,0),U,15):$P(^(0),U,15),1:$O(^DG(40.8,0))),$P(^SC(DGCLN,0),U),$P(^DPT(DGDFN,0),U),DGDATE)=DGDFN_U_$P(DGMT,U,1,4)_U_$P(DGPAT,U,16)_U_DGNXTMT,^TMP("DGMTL",$J,$P(^DPT(DGDFN,0),U),DGDFN)="" Q ; LETTER() ; diff -auBN ./r1/DGMTR1.m ./r2/r/DGMTR1.m --- ./r1/DGMTR1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTR1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGMTR1 ;ALB/CJM,SCG,LBD - Check Means Test Requirements Cont'd;3/25/92 09:51 - ;;5.3;Registration;**182,344,433,456,564**;Aug 13, 1993 + ;;5.3;Registration;**182,344,433,456**;Aug 13, 1993 ; COPYRX(DFN,MTIEN) ; ;Creates a Pharmacy Copay test based on the means test if the vet is @@ -94,20 +94,24 @@ ; CHK(DFN) ; ;can the veteran take a RX copay test? - N DGMTI,DGMTCOR,DGNODE,DGELIG,DGI,DGE - S DGMTCOR=1 + N DGMTI,DGMTE,DGMTCOR,DGNODE,DGMTYPT,STATUS,ELIG,ELIGIEN + S DGMTCOR=1,DGMT="",DGMTYPT=2 + ; ; I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S DGMTCOR=0 G CHKQ ;NON-VET - S DGI=$P($G(^DPT(DFN,.36)),U) I 'DGI S DGMTCOR=0 G CHKQ ;NO PRIM ELIG - S DGELIG=U_$P($G(^DIC(8,+DGI,0)),U,9)_U - S DGI=0 F S DGI=$O(^DPT(DFN,"E",DGI)) Q:'DGI S DGE=$P($G(^DPT(DFN,"E",DGI,0)),U),DGELIG=DGELIG_$P($G(^DIC(8,+DGE,0)),U,9)_U - I (DGELIG["^1^") S DGMTCOR=0 G CHKQ ;SC 50-100% - F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) - I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR=0 G CHKQ ;A&A - I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR=0 G CHKQ ;HB - I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR=0 G CHKQ ;PENSION - I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0 G CHKQ ;POW - I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S DGMTCOR=0 G CHKQ ;UNEMPLOYABLE + S DGMTI=0 I '$P($G(^DPT(DFN,.36)),U) S DGMTCOR=0 G CHKQ + ; + S ELIG=$P($G(^DPT(DFN,.36)),"^") + I 'ELIG S DGMTCOR=0 G CHKQ + S DGMTE=$P($G(^DIC(8,ELIG,0)),U,9) + I "^1^2^4^15^"[("^"_DGMTE_"^") S DGMTCOR=0 G CHKQ + S ELIGIEN=0 + F S ELIGIEN=$O(^DPT(DFN,"E",ELIGIEN)) Q:'ELIGIEN S ELIG=$P($G(^DPT(DFN,"E",ELIGIEN,0)),"^") I ELIG S DGMTE=$P($G(^DIC(8,ELIG,0)),U,9) I "^1^2^4^15^"[("^"_DGMTE_"^") S DGMTCOR=0 G CHKQ + ; + S DGNODE=$G(^DPT(DFN,.362)) + I DGMTCOR,$P(DGNODE,U,12)["Y" S DGMTCOR=0 G CHKQ ;A&A + I DGMTCOR,$P(DGNODE,U,13)["Y" S DGMTCOR=0 G CHKQ ;HB + I DGMTCOR,$P(DGNODE,U,14)["Y" S DGMTCOR=0 G CHKQ ;PENSION CHKQ ; Q DGMTCOR MAIL ; Send a mailman msg to user/ INCONSISTENCY EDIT GROUP with results diff -auBN ./r1/DGMTREM.m ./r2/r/DGMTREM.m --- ./r1/DGMTREM.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTREM.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTREM ;ALB/CAW - Comments for Means Test ; 04/28/2003 2:00 pm - ;;5.3;Registration;**45,182,513**;Aug 13, 1993 +DGMTREM ;ALB/CAW - Comments for Means Test ;31 DEC 1991 2:00 pm + ;;5.3;Registration;**45,182**;Aug 13, 1993 ; EN ;Entry point to place comments concerning a means test I DGMTYPT=1 S DIC("S")="I $P(^(0),U,14)" @@ -8,7 +8,7 @@ ; DT S DIC("A")="Select DATE OF TEST: " I $D(^DGMT(408.31,+$$LST^DGMTU(DFN,"",DGMTYPT),0)) S DIC("B")=$P(^(0),"^") - S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT S MTDT=X,MTIEN=Y I $$PRIM^DGMTREM(MTDT,MTIEN)" + S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT,$G(^(""PRIM""))" S DIC="^DGMT(408.31,",DIC(0)="EQZ" W ! D EN^DGMTLK K DIC G Q:Y<0 S DGMTI=+Y,DGMTDT=$P(Y,"^",2),DGMT0=Y(0) ; @@ -25,11 +25,3 @@ ; PAUSE S DIR(0)="E" D ^DIR Q - ; -PRIM(DGMTDT,DGMTIEN) ; - ; Find Primary Test for Income Year, and allow for a Future Dated Test - ; - I ^DGMT(408.31,DGMTIEN,"PRIM")=1 Q 1 - I DGMTDT>DT,$O(^DGMT(408.31,"AD",1,DFN,DGMTDT,""),-1)=DGMTIEN Q 1 - ; - Q 0 diff -auBN ./r1/DGMTREQB.m ./r2/r/DGMTREQB.m --- ./r1/DGMTREQB.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTREQB.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTREQB ;ALB/CAW Send mail bulletin if means test required ; 06/16/2004 - ;;5.3;Registration;**3,608**;Aug 13, 1993 +DGMTREQB ;ALB/CAW Send mail bulletin if means test required ;4/26/93 + ;;5.3;Registration;**3**;Aug 13, 1993 ; ; EN ; @@ -16,15 +16,15 @@ .S SDATA1=$G(^SC($P(SDATA,U,4),"S",$P(SDATA,U,3),1,+SDATA,0)),DFN=$P(SDATA,U,2) D PID^VADPT6 .I 'SDATA1,SDAMEVT=2 S SDATA2=$G(^TMP("SDAMEVT",$J,"AFTER","DPT")),SDATA1="^^^^^"_$P(SDATA2,U,12)_U_$P(SDATA2,U,14) .D XMY^DGMTUTL(+$P(^DG(43,1,"NOT"),U,13),0,1) - .S XMSUB="Means Test Required ("_$E($P($G(^DPT($P(SDATA,U,2),0)),U),1)_VA("BID")_")",XMTEXT="DGBUL(" D + .S XMSUB="Patient: "_$P($G(^DPT($P(SDATA,U,2),0)),U)_" Means Test Required",XMTEXT="DGBUL(" D ..D SET("Action was taken on the following appointment out and the patient 'REQUIRES' a means test.") ..D SET("") - ..D SET("Date of Birth: "_$$FTIME^DGMTUTL($P(^DPT(DFN,0),U,3))) - ..D SET(" Appointment: "_$$FTIME^DGMTUTL($P(SDATA,U,3))) - ..D SET(" Action: "_$P(SDATA("AFTER","STATUS"),U,2)) - ..D SET(" Clinic: "_$P($G(^SC($P(SDATA,U,4),0)),U)) - ..D SET(" Entered By: "_$P($G(^VA(200,+$P(SDATA1,U,6),0)),U)) - ..D SET(" Entered On: "_$$FTIME^DGMTUTL($P(SDATA1,U,7))) + ..D SET(" Patient ID: "_VA("PID")) + ..D SET("Appointment: "_$$FTIME^DGMTUTL($P(SDATA,U,3))) + ..D SET(" Action: "_$P(SDATA("AFTER","STATUS"),U,2)) + ..D SET(" Clinic: "_$P($G(^SC($P(SDATA,U,4),0)),U)) + ..D SET(" Entered By: "_$P($G(^VA(200,+$P(SDATA1,U,6),0)),U)) + ..D SET(" Entered On: "_$$FTIME^DGMTUTL($P(SDATA1,U,7))) .D ^XMD .S ^DGMT(408.31,+DGMT,"BUL")=DT MAILQ Q diff -auBN ./r1/DGMTR.m ./r2/r/DGMTR.m --- ./r1/DGMTR.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTR.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test Requirements ; 03/03/03 - ;;5.3;Registration;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495**;Aug 13, 1993 +DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test Requirements ; 2/19/02 + ;;5.3;Registration;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456**;Aug 13, 1993 ;A patient requires a means test under the following conditions: ; - Primary Eligibility is NSC OR patient is SC 0% non-compensable ; - who is NOT receiving disability retirement from the military @@ -57,7 +57,7 @@ .; next line added 2/19/02 - DG*5.3*426 .I DGREQF,'$G(DGADDF),$G(DGCS)=6,+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGREQF=0,DGNOCOPF=1 Q .I DGREQF,'$G(DGADDF),(('DGCS)!(OLD)),'$G(DGMDOD) D ADD Q - .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD),'+$G(IVMZ10F) D NOL Q + .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD) D NOL Q ;be sure to check whether or not patient is subject to RX copay! D EN^DGMTCOR Q diff -auBN ./r1/DGMTSC4.m ./r2/r/DGMTSC4.m --- ./r1/DGMTSC4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTSC4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTSC4 ;ALB/RMO/CAW,LBD - Means Test Screen Net Worth ; 11/7/03 1:44pm - ;;5.3;Registration;**45,130,456,540,567**;Aug 13, 1993 +DGMTSC4 ;ALB/RMO/CAW,LBD - Means Test Screen Net Worth ;18 MAY 1992 2:05 pm + ;;5.3;Registration;**45,130,456**;Aug 13, 1993 ; ; Input -- DFN Patient IEN ; DGMTDT Date of Test @@ -11,11 +11,6 @@ ; DGMTNWC Net Worth Calculation flag ; Output -- None ; - ;DG*5.3*540 - Skip displaying of calculated Means Test Status at the - ; bottom of screen 4 when in VIEW mode. - ;DG*5.3*567 - Allow bottom to show for all except SOURCE OF TEST[IVM - ; for IVM display Source is IVM instead. - ; EN ;Entry point for previous calendar year net worth screen S DGMTSCI=4 D HD^DGMTSCU D DIS @@ -42,11 +37,6 @@ D HIGH^DGMTSCU1(5,DGMTACT),FLD(.DGIN2,5,"Debts") W !?51,"Total -->",?66,$J($$AMT^DGMTSCU1(DGNWT),12) I DGMTYPT=1,DGMTACT="VEW",$P($G(DGMT0),"^",14) W !!!!!!!!,"Declines to give income information makes a MT COPAY REQUIRED status." G DISQ - ; - ;DG*5.3*540 - ;DG*5.3*567 - I DGMTACT="VEW",DGMTI,$$GET1^DIQ(408.31,DGMTI,.23)["IVM" D G DISQ - . W !!!!!!!!,"Source of Test is IVM" W !!!!!!!! I DGMTYPT=1 W "Income of ",$J($$AMT^DGMTSCU1(DGINT-DGDET),12) W " ",$$GETNAME^DGMTH(DGMTS) I DGMTYPT=1,DGTYC="M",(DGNWT-DGDET)+$S($G(DGMTNWC):0,1:DGINT)'<$P(DGMTPAR,"^",8) W !,?3,"with property of ",$J($$AMT^DGMTSCU1(DGNWT),12)," makes a ",$S(DGTHG>DGTHA:"G",1:""),"MT COPAY REQUIRED status." I DGTYC="M",'DGNWTF W " requires property information." diff -auBN ./r1/DGMTSC.m ./r2/r/DGMTSC.m --- ./r1/DGMTSC.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTSC.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTSC ;ALB/RMO,CAW,RTK,PDJ,LBD - Means Test Screen Driver ; 7/30/03 2:51pm - ;;5.3;Registration;**182,327,372,433,463,540,566**;Aug 13, 1993 +DGMTSC ;ALB/RMO,CAW,RTK,PDJ - Means Test Screen Driver ;21 JAN 1992 8:00 pm + ;;5.3;Registration;**182,327,372,433**;Aug 13, 1993 ; ;A series of screens used to collect the means test data ; Input -- DFN Patient IEN @@ -10,15 +10,10 @@ ; DGMTROU Option Routine Return ; Output -- None ; - ;DG*5.3*540 - set 408.21 (Idiv. Ann. Income) ien to 0 to prevent from - ; linking to old test incomes for IVM converted cases. - ; EN ;Entry point for means test screen driver D PRIOR^DGMTEVT:DGMTACT'="VEW",HOME^%ZIS,SETUP^DGMTSCU I DGERR D MG G Q1 EN1 ;Entry point to edit means test if incomplete - S DGMTSCI=+$O(DGMTSC(0)) - I DGMTI,$$GET1^DIQ(408.31,DGMTI,.23)["IVM" S DGVINI=0 ;DG*5.3*540 - G @($$ROU^DGMTSCU(DGMTSCI)) + S DGMTSCI=+$O(DGMTSC(0)) G @($$ROU^DGMTSCU(DGMTSCI)) ; Q I DGMTACT'="VEW" D EN^DGMTSCC I DGERR G EN1:$$EDT ; Added for LTC Co-pay Phase II - DG*5.3*433 @@ -52,18 +47,11 @@ ; K K %,DGBL,DGDC,DGDEP,DGDR,DGFCOL,DGFL,DGMT0,DGMTA,DGMTINF,DGMTOUT,DGMTP,DGMTPAR,DGMTSC,DGMTSCI,DGREL,DGRNG,DGRPPR,DGSCOL,DGSEL,DGSELTY,DGVI,DGVINI,DGVIRI,DGVO,DGVPRI,DGX,DGY,DTOUT,DUOUT,Y,Z ; - ; Validate record with consistency checks, when adding, editing, or - ; completing either a means or copay test. - ; For DG*5.3*566 - added a check for Status field to be defined before - ; calling the consistency check API (INCON^DGMTUTL1). - K IVMERR,IVMAR,IVMAR2 - I DGMTACT'="VEW",$P($G(^DGMT(408.31,DGMTI,0)),U,3) D INCON^DGMTUTL1(DFN,DGMTDT,DGMTI,DGMTYPT,.IVMERR),PROB^IVMCMFB(DGMTDT,.IVMERR,1) - ; ;Update the TEST-DETERMINED STATUS field (#2.03) in the ANNUAL MEANS ;TEST file (408.31) when adding a means or copay test, completing a ;means test, or editing a means or copay test. I "ADDCOMEDT"[DGMTACT D SAVESTAT^DGMTU4(DGMTI,DGERR) - K DGERR,IVMERR,ARRAY,ZIC,ZIR,ZMT,ZDP,IVMAR,IVMAR2 + K DGERR ; G @(DGMTROU) ; diff -auBN ./r1/DGMTU3.m ./r2/r/DGMTU3.m --- ./r1/DGMTU3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTU3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTU3 ;ALB/MLI/GN/LBD - Internal Entry Number Utility Calls ; 2/20/03 8:45am - ;;5.3;Registration;**33,45,137,182,300,433,499,518**;Aug 13, 1993 +DGMTU3 ;ALB/MLI - Internal Entry Number Utility Calls ; June 1, 1994 + ;;5.3;Registration;**33,45,137,182,300,433**;Aug 13, 1993 ; ; This routine will return the IENs for the primary income ; test from various files. @@ -24,21 +24,9 @@ ; will be assumed) ; Output -- Record IEN ; - N DFN,I,IEN,INR,MTIEN,LAST,DGDT,LTCIEN + N DFN,I,IEN,INR,MTIEN,LAST S DFN=+$G(^DGPR(408.12,+REL,0)) I 'DFN G IAIQ - ; - ;DG*5.3*499, change to if structure and check for presence of DGMTI - ; it is not defined when coming from Bene travel menus - ;LTC Phase III (DG*5.3*518) - add setting of LTCIEN - ; - ; if user selects view option & DGMTI exists, set IEN=DGMTI - I $G(DGMTACT)="VEW",$G(DGMTI) D - . S (MTIEN,LTCIEN)=DGMTI - E D - . S DGDT=$E(YEAR,1,3)+1_"1231.99" - . S MTIEN=$$LST^DGMTU(DFN,DGDT,$S($G(DGMTYPT):DGMTYPT,1:1)) - . S LTCIEN=$S($G(DGMTI):DGMTI,1:$$LST^EASECU(DFN,(YEAR+1231.99),3)) - ; + S MTIEN=$S($G(DGMTACT)'="VEW":$$LST^DGMTU(DFN,$E(YEAR,1,3)+1_"1231.99",$S($G(DGMTYPT):DGMTYPT,1:1)),1:DGMTI) ; If user selects view option, set IEN=DGMTI I MTIEN S LAST=0 D . F I=0:0 S I=$O(^DGMT(408.21,"AI",+REL,-YEAR,I)) Q:'I S LAST=I,INR=$O(^DGMT(408.22,"AIND",I,"")) I +$G(^DGMT(408.22,+INR,"MT"))=+MTIEN Q . S IEN=LAST @@ -47,10 +35,6 @@ . ; don't return it if DGMTYPT is not type 3. . Q:'$G(^DGMT(408.21,IEN,"MT")) . I $P($G(^DGMT(408.31,+^DGMT(408.21,IEN,"MT"),0)),U,19)=3,$G(DGMTYPT)'=3 S IEN="" - . ; If DGMTYPT=3 make sure the IAI record is associated with the - . ; correct LTC Copay test. Added for LTC Phase III (DG*5.3*518) - . I $G(DGMTYPT)=3,+^DGMT(408.21,IEN,"MT")'=+LTCIEN S IEN="" - ; ; if veteran doesn't have a mt I 'MTIEN D . ; The following was added for LTC Copay Phase II (DG*5.3*433) @@ -58,9 +42,6 @@ . ; don't return it if DGMTYPT is not type 3. . S IEN="" F I=0:0 S I=$O(^DGMT(408.21,"AI",+REL,-YEAR,I)) Q:'I S IEN=I Q:'$G(^DGMT(408.21,IEN,"MT")) D Q:IEN .. I $P($G(^DGMT(408.31,+^DGMT(408.21,IEN,"MT"),0)),U,19)=3,$G(DGMTYPT)'=3 S IEN="" - .. ; If DGMTYPT=3 make sure the IAI record is associated with the - .. ; correct LTC Copay test. Added for LTC Phase III (DG*5.3*518) - .. I $G(DGMTYPT)=3,+^DGMT(408.21,IEN,"MT")'=+LTCIEN S IEN="" IAIQ Q $G(IEN) ; ; diff -auBN ./r1/DGMTU4.m ./r2/r/DGMTU4.m --- ./r1/DGMTU4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTU4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGMTU4 ;ALB/CJM,SCG,LBD MEANS TEST UTILITES ; June 1, 1994 - ;;5.3;Registration;**182,267,285,347,454,456,476**;Aug 13, 1993 + ;;5.3;Registration;**182,267,285,347,454,456**;Aug 13, 1993 ; GETSITE(DUZ) ; ;Descripition: Gets the users station number. If not found, it will @@ -239,20 +239,3 @@ .I +RXNODE S ACTVIEN=+RXNODE Q I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN) Q - ; -CHKPT(DFN) ; - ; Cross check the CURRENT MEANS TEST STATUS in the PATIENT File (#2) with the - ; primary means test in the ANNUAL MEANS TEST File (#408.31). Update the - ; CURRENT MEANS TEST STATUS if the fields are out of synch. - ; - N PATMT,DGMTI,DATA - ; - Q:$G(DFN)'>0 - Q:'$D(^DPT(DFN)) - S PATMT=$$GET1^DIQ(2,DFN,.14,"I") - S DGMTI=+$$LST^DGMTU(DFN) - S DATA(.14)=$P($G(^DGMT(408.31,DGMTI,0)),U,3) - Q:DATA(.14)=PATMT - ; - I $$UPD^DGENDBS(2,DFN,.DATA) - Q diff -auBN ./r1/DGMTU.m ./r2/r/DGMTU.m --- ./r1/DGMTU.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTU.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGMTU ;ALB/RMO,LBD,BRM - Means Test Utilities ; 12/9/03 9:26am - ;;5.3;Registration;**4,33,182,277,290,374,358,420,426,411,332,433,456,476,519,451**;Aug 13, 1993 +DGMTU ;ALB/RMO,LBD - Means Test Utilities ; 4/03/02 + ;;5.3;Registration;**4,33,182,277,290,374,358,420,426,411,332,433,456**;Aug 13, 1993 ; LST(DFN,DGDT,DGMTYPT) ;Last means test for a patient ; Input -- DFN Patient IEN @@ -97,7 +97,6 @@ ; ^Status Code^Source of Test ; N X,Y,DGMTDATA,DGQSENT,DGDOD,NODE0,DGRET,DGMFLG,DGTAG,DGMTYPT - D CHKPT^DGMTU4(DFN) S DGMTYPT=1,DGMTDATA=$$LST(DFN,"",DGMTYPT) ;Next line checks to see if patient has expired, if so, Query not initiated S DGDOD=$P($G(^DPT(DFN,.35)),U) @@ -120,22 +119,20 @@ ;benefit. ;Input - DGMTDATA as defined by $$LST function. ;Output - DGRETV - ; 1 = Current Test is REQUIRED - ; 2 = Test is > 365 days old and is in a status of - ; other than REQUIRED or NO LONGER REQUIRED - ; 2 = Pend Adj for GMT, test date is 10/6/99 or - ; greater and agreed to the deductible - ; 0 = CAT C/Pend Adj for MT, test date is 10/6/99 - ; or greater and agreed to the deductible. - ; OR 0 = Cat C, declined income info and agreed - ; to pay deductible. - ; OR 0 = Has a future dated Means Test + ; 1 = Current Test is REQUIRED + ; 2 = Test is > 365 days old and is in a status of + ; other than REQUIRED or NO LONGER REQUIRED + ; 0 = CAT C/Pend Adj for MT, test date is 10/6/99 + ; or greater and agreed to the deductible. + ; OR 0 = Cat C, declined income info and agreed + ; to pay deductible. + ; OR 0 = Has a future dated Means Test N DGRETV,FTST,DGMT0 S DGRETV=0 I '$G(DGMTDATA) Q DGRETV S DGMT0=$G(^DGMT(408.31,+DGMTDATA,0)) I $P(DGMTDATA,U,4)="R" S DGRETV=1 I $$OLD^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S DGRETV=2 - I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S DGRETV=0 + I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S DGRETV=0 I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0 D DOM^DGMTR I $G(DGDOM) S DGRETV=0 S FTST=$$FUT(DFN) @@ -169,7 +166,7 @@ I $$OLD^DGMTU4($P(DGMTDATA,U,2)),($P(DGMTDATA,U,4)'="N")&($P(DGMTDATA,U,4)'="R") S IVMQFLG=1 ;If Cat C/Pend Adj for MT, older than 365 days, agreed to pay, test ;date > 10/5/99 reset flag to 0 - no query is necessary. - I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)'<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S IVMQFLG=0 + I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DGMT0,U,12)<$P(DGMT0,U,27))),$P(DGMTDATA,U,2)>2991005,$P(DGMT0,U,11)=1 S IVMQFLG=0 ;If patient is Cat C, declined to provide income but has agreed to ;pay deductible, no query necessary - reset flag to 0 I ($P(DGMTDATA,U,4)="C"),+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGRETV=0 @@ -181,17 +178,18 @@ ; Input: ; DFN Patient IEN ; DGDT Date (Optional- default to today) - ; DGMTYPT Type of Test (Optional - default to MT) + ; DGMTYPT Type of Test (Optional - default to Means Test) ; Output: ; If a DCD test was performed it will be returned, else the - ; current future dated test for the Income Year. - ; MT IEN^Date of Test^Status Name^Status Code^Source + ; earliest performed future test for the Income Year. + ; Future MT IEN^Date of Test (Future)^Status Name^Status Code^ + ; Source of Test ; - N DGIDT,Y,MTIEN,SRCE,DONE,MTNOD,ARR,LAST,TYPTST + N DGIDT,Y,MTIEN,SRCE,DONE,MTNOD,ARR,FIRST,TYPTST S:'$D(DGMTYPT) DGMTYPT=1 S TYPTST=$S(DGMTYPT=2:"AF",1:"AE") S DGIDT=$S($G(DGDT)>0:DGDT,1:DT),DONE=0 - S (ARR,LAST,Y)="" + S (ARR,FIRST,Y)="" S:$P(DGIDT,".",2) DGIDT=$P(DGIDT,".") F S DGIDT=$O(^IVM(301.5,TYPTST,DFN,DGIDT)) Q:'DGIDT!(DONE) D .S MTIEN=0 @@ -199,6 +197,6 @@ ..Q:'$D(^DGMT(408.31,MTIEN,0)) ..S MTNOD=^DGMT(408.31,MTIEN,0),SRCE=$P(MTNOD,U,23) ..I SRCE'=1 S DONE=1,Y=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23) Q - ..I 'DONE,'$D(ARR($P(MTNOD,U),MTIEN)) S ARR($P(MTNOD,U),MTIEN)=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23) - I 'DONE S LAST=$O(ARR(""),-1) I LAST S Y=ARR(LAST,$O(ARR(LAST,""),-1)) + ..I 'DONE,'$D(ARR($P(MTNOD,U))) S ARR($P(MTNOD,U))=MTIEN_U_$P(MTNOD,U)_U_$$MTS^DGMTU(DFN,+$P(MTNOD,U,3))_U_$P(MTNOD,U,23) + I 'DONE S FIRST=$O(ARR("")) I FIRST S Y=ARR(FIRST) Q $G(Y) diff -auBN ./r1/DGMTUTL1.m ./r2/r/DGMTUTL1.m --- ./r1/DGMTUTL1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTUTL1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,79 +0,0 @@ -DGMTUTL1 ;ALB/RMM - Means Test Consistency Checker ; 07/24/03 - ;;5.3;Registration;**463,542**;Aug 13, 1993 - ; - ; - ; Apply Consistency Checks to the Income Test Processes: ADD, - ; EDIT, and COMPLETE. - ; - ; - Q - ; -INCON(DFN,DGMTDT,DGMTI,IVMTYPE,IVMERR) ; - ; - ; Check Income Test before applying consistency checks - ; - If AGREED TO PAY DEDUCTIBLE is NO - ; - or DECLINES TO GIVE INCOME INFO and AGREED TO PAY DEDUCTIBLE are YES - ; Quit, the consistency checks are unnecessary. - N NODE0,APD,DTGII - S NODE0=$G(^DGMT(408.31,DGMTI,0)),APD=$P(NODE0,U,11),DTGII=$P(NODE0,U,14) - I APD=0!(APD=1&(DTGII=1)) Q - ; - ; Build the data strings for the veteran, and apply consistency checks - ; Get information and initialize variables - N CNT,I,HLFS,IEN,ARRAY,SPOUSE,DEP,DEPIEN,DGDEP,DGINC,DGINR,DGREL - N ZIC,ZIR,ZMT,ZDP,ARRAY,DIEN - S CNT=1,HLFS=U,SPOUSE=0 - D ALL^DGMTU21(DFN,"VSC",DGMTDT) - ; - ; Build ZMT array for CC's - S $P(ARRAY("ZMT"),U,2)=$P($G(^DGMT(408.31,DGMTI,0)),U,1) - S $P(ARRAY("ZMT"),U,2)=$E($P(ARRAY("ZMT"),U,2),1,3)+1700_$E($P(ARRAY("ZMT"),U,2),4,7) - S $P(ARRAY("ZMT"),U,3)=$P($G(^DGMT(408.31,DGMTI,0)),U,3) - S $P(ARRAY("ZMT"),U,3)=$P(^DG(408.32,$P(ARRAY("ZMT"),U,3),0),U,2) - ; - ; Build Spouse ZIC, ZIR, and ZDP Arrays - I $D(DGREL("S")) D - .S SPOUSE=1 - .; Use the Individual Annual Income File #408.21 - .S ARRAY(SPOUSE,"ZIC")=$$ZIC^DGMTUTL2(DGINC("S"),SPOUSE) - .; Use the Income Relation File #408.22 - .S ARRAY(SPOUSE,"ZIR")=$$ZIR^DGMTUTL2(DGINR("S"),SPOUSE) - .; Use Patient Relation File #408.12 and Income Person File #408.13 - .S ARRAY(SPOUSE,"ZDP")=$$ZDP^DGMTUTL2(DGREL("S"),SPOUSE) - ; - ; Build Dependent ZIC, ZIR, and ZDP Arrays - F IEN=1:1:DGDEP D - .S DIEN=IEN+SPOUSE - .; Use the Individual Annual Income File #408.21 - .S ARRAY(DIEN,"ZIC")=$$ZIC^DGMTUTL2(DGINC("C",IEN),DIEN) - .; Use the Income Relation File #408.22 - .S ARRAY(DIEN,"ZIR")=$$ZIR^DGMTUTL2(DGINR("C",IEN),DIEN) - .; Use Patient Relation File #408.12 and Income Person File #408.13 - .S ARRAY(DIEN,"ZDP")=$$ZDP^DGMTUTL2(DGREL("C",IEN),DIEN) - S DEP=DGDEP+SPOUSE - ; - ; Check the Individual Annual Income File #408.21 - S ZIC=$$ZIC^DGMTUTL2(DGINC("V")) - D ZIC^IVMCMF1(ZIC) - ; - ; Check the Income Relation File #408.22 - S ZIR=$$ZIR^DGMTUTL2(DGINR("V"),DGMTDT) - D ZIR^IVMCMF1(ZIR,"",1) - ; - ; Check the Annual Means Test File #408.31 - I "^1^2^4^"[("^"_IVMTYPE_"^") D - .S ZMT=$$ZMT^DGMTUTL2(DGMTI) - .; Create array for Income Calculator - .M ARRAY("ZIC")=ZIC - .D ZMT^IVMCMF2(ZMT) - ; - ; Apply the Consistency Checks to the dependent information - F IEN=1:1:DEP D - .; Check Patient Relation File #408.12 and Income Person File #408.13 - .D ZDP^IVMCMF2(ARRAY(IEN,"ZDP"),IEN) - .; Check the Individual Annual Income File #408.21 - .D ZIC^IVMCMF1(ARRAY(IEN,"ZIC"),IEN) - .; Check the Income Relation File #408.22 - .D ZIR^IVMCMF1(ARRAY(IEN,"ZIR"),IEN) - ; - Q diff -auBN ./r1/DGMTUTL2.m ./r2/r/DGMTUTL2.m --- ./r1/DGMTUTL2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTUTL2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,117 +0,0 @@ -DGMTUTL2 ;ALB/RMM - Means Test Consistency Checker ; 1/31/03 - ;;5.3;Registration;**463**;Aug 13, 1993 - ; - ; - ; - ; - ; -ZIC(VAFIEN,DEPIEN) ; Build ZIC the data string for the veteran - ; - N NODE0,NODE1,NODE2,ZIC - S NODE0=$G(^DGMT(408.21,VAFIEN,0)) - S NODE1=$G(^DGMT(408.21,VAFIEN,1)) - S NODE2=$G(^DGMT(408.21,VAFIEN,2)) - S ZIC="ZIC" - S $P(ZIC,U,2)=$P(NODE0,U,1) ;Income Year - S $P(ZIC,U,3)=$P(NODE0,U,8) ;Social Security - S $P(ZIC,U,4)=$P(NODE0,U,9) ;U.S. Civil Service - S $P(ZIC,U,5)=$P(NODE0,U,10) ;U.S. Railroad Retirement - S $P(ZIC,U,6)=$P(NODE0,U,11) ;Military Retirement - S $P(ZIC,U,7)=$P(NODE0,U,12) ;Unemployment Compensation - S $P(ZIC,U,9)=$P(NODE0,U,14) ;Total Income from Employment - S $P(ZIC,U,10)=$P(NODE0,U,15) ;Interest,Dividend,Annuity - S $P(ZIC,U,11)=$P(NODE0,U,16) ;Workers Comp. or Black Lung - S $P(ZIC,U,12)=$P(NODE0,U,17) ;All Other Income - S $P(ZIC,U,13)=$P(NODE1,U,1) ;Medical Expenses - S $P(ZIC,U,14)=$P(NODE1,U,2) ;Funeral And Burial Expenses - S $P(ZIC,U,15)=$P(NODE1,U,3) ;Educational Expenses - S $P(ZIC,U,16)=$P(NODE2,U,1) ;Cash, Amount In Bank Accounts - S $P(ZIC,U,17)=$P(NODE2,U,2) ;Stocks And Bonds - S $P(ZIC,U,18)=$P(NODE2,U,3) ;Real Property - S $P(ZIC,U,19)=$P(NODE2,U,4) ;Other Property or Assets - S $P(ZIC,U,20)=$P(NODE2,U,5) ;Debts - ; - ; Adjust date field to correct format - S $P(ZIC,U,2)=$E($P(ZIC,U,2),1,3)+1700_$E($P(ZIC,U,2),4,7) - ; - Q ZIC - ; -ZIR(VAFIEN,DEPIEN) ; Build ZIR the data string for the veteran - ; - N NODE0,ZIR - S NODE0=$G(^DGMT(408.22,VAFIEN,0)),ZIR="ZIR" - S $P(ZIR,U,2)=$P(NODE0,U,5) ;Married Last Calendar Year - S $P(ZIR,U,3)=$P(NODE0,U,6) ;Lived With Patient - S $P(ZIR,U,4)=$P(NODE0,U,7) ;Amount Contributed to Spouse - S $P(ZIR,U,5)=$P(NODE0,U,8) ;Dependent Children - S $P(ZIR,U,6)=$P(NODE0,U,9) ;Incapable of Self Suppoort - S $P(ZIR,U,7)=$P(NODE0,U,10) ;Contributed to Support - S $P(ZIR,U,8)=$P(NODE0,U,11) ;Child Had Income - S $P(ZIR,U,9)=$P(NODE0,U,12) ;Income Available to You - S $P(ZIR,U,10)=$P(NODE0,U,13) ;Number of Dependent Children - Q ZIR - ; -ZMT(DGMTI) ; Build ZMT the data string for the veteran - ; - N NODE0,NODE2,ZMT - S NODE0=$G(^DGMT(408.31,DGMTI,0)) - S NODE2=$G(^DGMT(408.31,DGMTI,2)),ZMT="ZMT" - S $P(ZMT,U,2)=$P(NODE0,U,1) ;Means Test Date - S $P(ZMT,U,3)=$P(NODE0,U,3) ;Means Test Status - S $P(ZMT,U,4)=$P(NODE0,U,4) ;Income - S $P(ZMT,U,5)=$P(NODE0,U,5) ;Net Worth - S $P(ZMT,U,6)=$P(NODE0,U,10) ;Date/Time of Adjudication - S $P(ZMT,U,7)=$P(NODE0,U,11) ;Agreed to Pay Deductible - S $P(ZMT,U,8)=$P(NODE0,U,12) ;Threshold A - S $P(ZMT,U,9)=$P(NODE0,U,15) ;Deductible Expenses - S $P(ZMT,U,10)=$P(NODE0,U,7) ;Date/Time MT Completed - S $P(ZMT,U,11)=$P(NODE0,U,16) ;Previous Yr MT Threshold Flag - S $P(ZMT,U,12)=$P(NODE0,U,18) ;Total Dependents - S $P(ZMT,U,13)=$P(NODE0,U,20) ;Hardship - S $P(ZMT,U,14)=$P(NODE0,U,21) ;Hardship Review Date - S $P(ZMT,U,15)=$P(NODE0,U,24) ;Date Veteran Signed Test - S $P(ZMT,U,16)=$P(NODE0,U,14) ;Declines to Give Income Info - S $P(ZMT,U,17)=$P(NODE0,U,19) ;Type of Test - S $P(ZMT,U,18)=$P(NODE0,U,23) ;Source of Income Test - S $P(ZMT,U,19)=$P($G(^DGMT(408.31,DGMTI,"PRIM")),U,1) ;Primary Test? - S $P(ZMT,U,20)=$P(NODE0,U,25) ;Date IVM Verif. MT Completed - S $P(ZMT,U,21)=$P(NODE0,U,26) ;Refused To Sign - S $P(ZMT,U,22)=$P(NODE2,U,5) ;Site Conducting Test - S $P(ZMT,U,23)=$P(NODE2,U,4) ;Hardship Review Site - S $P(ZMT,U,24)=$P(NODE2,U,1) ;Hardship Effective Date - S $P(ZMT,U,25)=$P(NODE2,U,2) ;Date/Time Test Last Edited - S $P(ZMT,U,26)=$P(NODE2,U,3) ;Test Determined Status - S $P(ZMT,U,28)=$P(NODE0,U,27) ;GMT Threshold - ; - ; Adjust date fields to correct format - S $P(ZMT,U,2)=$E($P(ZMT,U,2),1,3)+1700_$E($P(ZMT,U,2),4,7) - S $P(ZMT,U,10)=$E($P(ZMT,U,10),1,3)+1700_$E($P(ZMT,U,10),4,7) - S $P(ZMT,U,25)=$E($P(ZMT,U,25),1,3)+1700_$E($P(ZMT,U,25),4,7)_$P($P(ZMT,U,25),".",2)_"-400" - ; - ; Change Status IENs to Codes - S:$P(ZMT,U,26)="" $P(ZMT,U,26)=$P(ZMT,U,3) - S $P(ZMT,U,3)=$P(^DG(408.32,$P(ZMT,U,3),0),U,2) - S $P(ZMT,U,26)=$P(^DG(408.32,$P(ZMT,U,26),0),U,2) - ; - Q ZMT - ; -ZDP(VAFIEN,DEPIEN) ; Build ZDP the data string for the veteran - ; - N NODE0,NODER,DGPR,ZDP,LIEN - S NODE0=$G(^DGPR(408.12,+VAFIEN,0)),ZDP="ZDP" - S DGPR=+$P(NODE0,U,3),NODER=^DGPR(408.13,DGPR,0) - S $P(ZDP,U,2)=$P(NODER,U,1) ;Name - S $P(ZDP,U,3)=$P(NODER,U,2) ;Sex - S $P(ZDP,U,4)=$P(NODER,U,3) ;Date of Birth - S $P(ZDP,U,5)=$P(NODER,U,9) ;Social Security Number - S $P(ZDP,U,6)=$P(NODE0,U,2) ;Relationship To Patient - S $P(ZDP,U,7)=+VAFIEN ;Internal Entry Number - S LIEN=$O(^DGPR(408.12,+VAFIEN,"E","AID"),-1) - S $P(ZDP,U,9)=+^DGPR(408.12,+VAFIEN,"E",LIEN,0) - ; - ; Change format to match CC format - S $P(ZDP,U,2)=$TR($P(ZDP,U,2),",","~") - S $P(ZDP,U,4)=$E($P(ZDP,U,4),1,3)+1700_$E($P(ZDP,U,4),4,7) - S $P(ZDP,U,9)=$E($P(ZDP,U,9),1,3)+1700_$E($P(ZDP,U,9),4,7) - ; - Q ZDP diff -auBN ./r1/DGMTXX11.m ./r2/r/DGMTXX11.m --- ./r1/DGMTXX11.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX11.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX11 ; COMPILED XREF FOR FILE #408.21 ; 10/15/04 +DGMTXX11 ; COMPILED XREF FOR FILE #408.21 ; 06/26/02 ; S DIKZK=2 S DIKZ(0)=$G(^DGMT(408.21,DA,0)) diff -auBN ./r1/DGMTXX12.m ./r2/r/DGMTXX12.m --- ./r1/DGMTXX12.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX12.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX12 ; COMPILED XREF FOR FILE #408.21 ; 10/15/04 +DGMTXX12 ; COMPILED XREF FOR FILE #408.21 ; 06/26/02 ; S DIKZK=1 S DIKZ(0)=$G(^DGMT(408.21,DA,0)) diff -auBN ./r1/DGMTXX1.m ./r2/r/DGMTXX1.m --- ./r1/DGMTXX1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX1 ; DRIVER FOR COMPILED XREFS FOR FILE #408.21 ; 10/15/04 +DGMTXX1 ; DRIVER FOR COMPILED XREFS FOR FILE #408.21 ; 06/26/02 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff -auBN ./r1/DGMTXX21.m ./r2/r/DGMTXX21.m --- ./r1/DGMTXX21.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX21.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX21 ; COMPILED XREF FOR FILE #408.22 ; 10/15/04 +DGMTXX21 ; COMPILED XREF FOR FILE #408.22 ; 12/10/01 ; S DIKZK=2 S DIKZ(0)=$G(^DGMT(408.22,DA,0)) @@ -12,7 +12,6 @@ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.22,.05,1,1,79.2) S X=X="" I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(408.22,.05,1,1,2.4) S X=$P(DIKZ(0),U,5) I X'="" I $D(^DGMT(408.22,DA,0)),$P(^(0),U,5)="" D FUN^DGMTDD2:'$P(^(0),U,8),SP^DGMTDD2 - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,6) I X'="" D .N DIK,DIV,DIU,DIN @@ -21,7 +20,6 @@ I X'="" D .N DIK,DIV,DIU,DIN .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.22,.06,1,2,79.2) S X=X="" I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(408.22,.06,1,2,2.4) - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,7) I X'="" I $D(^DGMT(408.22,DA,0)),'$P(^(0),U,6),$P(^(0),U,7)="" D SP^DGMTDD2 S X=$P(DIKZ(0),U,8) @@ -32,7 +30,6 @@ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.22,.11,1,1,79.2) S X=X="" I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(408.22,.11,1,1,2.4) S X=$P(DIKZ(0),U,11) I X'="" I $D(^DGMT(408.22,DA,0)),$P(^(0),U,11)="" D INC^DGMTDD2 - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,12) I X'="" I $D(^DGMT(408.22,DA,0)),$P(^(0),U,12)="",$P(^(0),U,11) D INC^DGMTDD2 S X=$P(DIKZ(0),U,14) @@ -43,24 +40,13 @@ I X'="" D .N DIK,DIV,DIU,DIN .X ^DD(408.22,.14,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=408.22,DIG=.16 D ^DICR - S X=$P(DIKZ(0),U,14) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(408.22,.14,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,17)=DIV,DIH=408.22,DIG=.17 D ^DICR - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,16) I X'="" D .N DIK,DIV,DIU,DIN .X ^DD(408.22,.16,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=408.22,DIG=.15 D ^DICR - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) - S X=$P(DIKZ(0),U,17) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(408.22,.17,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=408.22,DIG=.16 D ^DICR S DIKZ("MT")=$G(^DGMT(408.22,DA,"MT")) S X=$P(DIKZ("MT"),U,1) I X'="" K ^DGMT(408.22,"AMT",X,+$P(^DGMT(408.22,DA,0),U),+$P($G(^DGMT(408.22,DA,0)),U,2),DA) - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,1) I X'="" K ^DGMT(408.22,"B",$E(X,1,30),DA) S X=$P(DIKZ(0),U,1) diff -auBN ./r1/DGMTXX22.m ./r2/r/DGMTXX22.m --- ./r1/DGMTXX22.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX22.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX22 ; COMPILED XREF FOR FILE #408.22 ; 10/15/04 +DGMTXX22 ; COMPILED XREF FOR FILE #408.22 ; 12/10/01 ; S DIKZK=1 S DIKZ(0)=$G(^DGMT(408.22,DA,0)) @@ -16,7 +16,6 @@ .X ^DD(408.22,.05,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(408.22,.05,1,1,1.4) S X=$P(DIKZ(0),U,5) I X'="" I $D(^DGMT(408.22,DA,0)),'$P(^(0),U,5) D FUN^DGMTDD2:'$P(^(0),U,8),SP^DGMTDD2 - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,6) I X'="" D .N DIK,DIV,DIU,DIN @@ -25,7 +24,6 @@ I X'="" D .N DIK,DIV,DIU,DIN .X ^DD(408.22,.06,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(408.22,.06,1,2,1.4) - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,7) I X'="" I $D(^DGMT(408.22,DA,0)),'$P(^(0),U,6),$P(^(0),U,7)<600 D SP^DGMTDD2 S X=$P(DIKZ(0),U,8) @@ -36,7 +34,6 @@ .X ^DD(408.22,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(408.22,.11,1,1,1.4) S X=$P(DIKZ(0),U,11) I X'="" I $D(^DGMT(408.22,DA,0)),$P(^(0),U,11)=0 D INC^DGMTDD2 - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,12) I X'="" I $D(^DGMT(408.22,DA,0)),$P(^(0),U,12)=0,$P(^(0),U,11) D INC^DGMTDD2 S X=$P(DIKZ(0),U,14) @@ -47,20 +44,10 @@ I X'="" D .N DIK,DIV,DIU,DIN .X ^DD(408.22,.14,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=408.22,DIG=.16 D ^DICR - S X=$P(DIKZ(0),U,14) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(408.22,.14,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,17)=DIV,DIH=408.22,DIG=.17 D ^DICR - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) S X=$P(DIKZ(0),U,16) I X'="" D .N DIK,DIV,DIU,DIN .X ^DD(408.22,.16,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X="NO" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=408.22,DIG=.15 D ^DICR - S DIKZ(0)=$G(^DGMT(408.22,DA,0)) - S X=$P(DIKZ(0),U,17) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(408.22,.17,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" S DIH=$G(^DGMT(408.22,DIV(0),0)),DIV=X S $P(^(0),U,16)=DIV,DIH=408.22,DIG=.16 D ^DICR S DIKZ("MT")=$G(^DGMT(408.22,DA,"MT")) S X=$P(DIKZ("MT"),U,1) I X'="" S:$P(^DGMT(408.22,DA,0),U,2) ^DGMT(408.22,"AMT",X,+$P(^DGMT(408.22,DA,0),U),+$P(^DGMT(408.22,DA,0),U,2),DA)="" diff -auBN ./r1/DGMTXX2.m ./r2/r/DGMTXX2.m --- ./r1/DGMTXX2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX2 ; DRIVER FOR COMPILED XREFS FOR FILE #408.22 ; 10/15/04 +DGMTXX2 ; DRIVER FOR COMPILED XREFS FOR FILE #408.22 ; 12/10/01 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff -auBN ./r1/DGMTXX31.m ./r2/r/DGMTXX31.m --- ./r1/DGMTXX31.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX31.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX31 ; COMPILED XREF FOR FILE #408.31 ; 10/15/04 +DGMTXX31 ; COMPILED XREF FOR FILE #408.31 ; 12/09/02 ; S DIKZK=2 S DIKZ(0)=$G(^DGMT(408.31,DA,0)) diff -auBN ./r1/DGMTXX32.m ./r2/r/DGMTXX32.m --- ./r1/DGMTXX32.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX32.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 10/15/04 +DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 12/09/02 ; S DIKZK=1 S DIKZ(0)=$G(^DGMT(408.31,DA,0)) @@ -22,7 +22,6 @@ I X'="" D .N DIK,DIV,DIU,DIN .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGMT(408.31,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="9" X ^DD(408.31,.019,1,4,1.4) - S DIKZ(0)=$G(^DGMT(408.31,DA,0)) S X=$P(DIKZ(0),U,2) I X'="" S:$P(^DGMT(408.31,DA,0),U,3)&($P(^(0),U,19)) ^DGMT(408.31,"AS",$P(^(0),U,19),$P(^(0),U,3),-$P(^(0),U),X,DA)="" S X=$P(DIKZ(0),U,2) @@ -37,7 +36,6 @@ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.31,.02,1,5,69.2) S Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGMT(408.31,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="1" X ^DD(408.31,.02,1,5,1.4) S X=$P(DIKZ(0),U,2) I X'="" S ^DGMT(408.31,"ADFN"_X,+^DGMT(408.31,DA,0),DA)="" - S DIKZ(0)=$G(^DGMT(408.31,DA,0)) S X=$P(DIKZ(0),U,3) I X'="" S:$P(^DGMT(408.31,DA,0),U,2)&($P(^(0),U,19)) ^DGMT(408.31,"AS",$P(^(0),U,19),X,-$P(^(0),U),+$P(^(0),U,2),DA)="" S X=$P(DIKZ(0),U,3) diff -auBN ./r1/DGMTXX3.m ./r2/r/DGMTXX3.m --- ./r1/DGMTXX3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGMTXX3.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGMTXX3 ; DRIVER FOR COMPILED XREFS FOR FILE #408.31 ; 10/15/04 +DGMTXX3 ; DRIVER FOR COMPILED XREFS FOR FILE #408.31 ; 12/09/02 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff -auBN ./r1/DGNFUNC.m ./r2/r/DGNFUNC.m --- ./r1/DGNFUNC.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGNFUNC.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGNFUNC ;BPCIOFO/CMC-NAME FORMAT FUNCTIONS ; 22 Jan 2002 10:39 AM - ;;5.3;Registration;**149,244**;Aug 13, 1993 +DGNFUNC ;BPCIOFO/CMC-NAME FORMAT FUNCTIONS ;8 MAR 1999 + ;;5.3;Registration;**149**;Aug 13, 1993 ; ;This routine will contains functions for returning the name field ;in a variety of formats. It will NOT update the Patient file, @@ -14,6 +14,20 @@ ; I '$D(DFN) Q "-1^MISSING DFN" I $G(DFN)<0 Q "-1^Missing DFN" - N DPTNAME - S DPTNAME("IENS")=DFN_",",DPTNAME("FILE")=2,DPTNAME("FIELD")=.01 - Q $$NAMEFMT^XLFNAME(.DPTNAME,"G","") + D DEM^VADPT + N NAME,FIRST,MIDDLE,LAST,SUFFIX,TFLG,TNAME,PL + S TFLG="N" + S NAME=VADM(1) + K VADM + I $E(NAME,($L(NAME)-4),$L(NAME))=" TEST" S NAME=$E(NAME,1,($L(NAME)-4)),TFLG="Y" + S TNAME=NAME + D NAME^VAFCPID2(DFN,.TNAME,0) + ; put name in format LAST,FIRST MIDDLE SUFFIX + S LAST=$P(TNAME,","),TNAME=$P(TNAME,",",2) + S FIRST=$P(TNAME," "),MIDDLE=$P(TNAME," ",2) + S SUFFIX=$P(TNAME," ",3) + I MIDDLE["""" S MIDDLE="" + S TNAME=FIRST_" "_MIDDLE_" "_LAST_" "_SUFFIX + I TFLG="Y" S TNAME=TNAME_" TEST" +SP I $F(TNAME," ") S PL=$F(TNAME," "),TNAME=$E(TNAME,1,PL-2)_$E(TNAME,PL,$L(TNAME)) G SP + Q TNAME diff -auBN ./r1/DGOIL1.m ./r2/r/DGOIL1.m --- ./r1/DGOIL1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGOIL1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,12 +1,12 @@ DGOIL1 ;ALB/AAS - INPATIENT LIST (CONT.) ; 28-SEPT-90 - ;;5.3;Registration;**162,498**;Aug 13, 1993 + ;;5.3;Registration;**162**;Aug 13, 1993 ; PRINT ; -- print line for one entry I IOSL<($Y+6) D HDR^DGOIL Q:$D(DUOUT) N I,J,K D INP^VADPT,PID^VADPT I $D(^DGPM(DGPM,0)),$P(^(0),"^",3)'=DFN W !!,"BAD 'CN' CROSS REFERENCE FOR WARD ",W,", PATIENT NUMBER",DFN,!! Q S DGPMIFN=DGPM D ^DGOIL2 S X=X3,DGL=+X3 - W !,$P(X,"^",10),$P(X,"^",9),$E(N,1,17),?19,VA("BID") + W !,$P(X,"^",9),$E(N,1,17),?19,VA("BID") D PRINT2:DGBRK,PRINT1:'DGBRK D END Q diff -auBN ./r1/DGOIL2.m ./r2/r/DGOIL2.m --- ./r1/DGOIL2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGOIL2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGOIL2 ;ALB/AAS - CALCULATE LOS BY TRANSFER ; 28-SEPT-90 - ;;5.3;Registration;**93,498**;Aug 13, 1993 + ;;5.3;Registration;**93**;Aug 13, 1993 ; ;INPUT - Admission ifn in DGPMIFN - call EN^ ; @@ -18,7 +18,6 @@ ADM F DGT=DGT:1 S A1=A,DGPMIFN1=$O(^DGPM("APCA",DFN,DGPMIFN,A,0)) Q:'DGPMIFN1!('A)!('I) D TRANS Q:$D(DGPMIFN(1)) S $P(X3,"^",9)=DGASIH - S $P(X3,"^",10)=$S($P($G(^DGPM(DGPMIFN,"DIR")),"^",1)'=0:"!",1:"") G END ; EN1 ; - entry to find los for one transfer diff -auBN ./r1/DGOIL.m ./r2/r/DGOIL.m --- ./r1/DGOIL.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGOIL.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGOIL ;ALB/AAS - INPATIENT LIST ; 28-SEPT-90 - ;;5.3;Registration;**162,279,498**;Aug 13, 1993 + ;;5.3;Registration;**162,279**;Aug 13, 1993 ; % ; -- start here D HOME^%ZIS W @IOF @@ -76,7 +76,7 @@ ; LEGEND ; -legend for flag column F L=1:1 Q:IOSL<($Y+6) W ! - W !,"'+' Before the Patient name indicates patient is currently ASIH, '!' Indicates patient chose not to be in Facility Directory" + W !,"'+' Before the Patient name indicates patient is currently ASIH." W:DGDRG&($E(IOST,1,2)'="C-") !,"LEGEND: '####' - Stay exceeds high trim, '**' - Stay exceeds 69% of high trim, '@' Stay exceeds 49% of high trim" I $E(IOST,1,2)="C-" R !,"Press '^' to QUIT or Return to Continue",Z:DTIME I '$T!(Z["^") S DUOUT=1 Q Q diff -auBN ./r1/DGOINPT1.m ./r2/r/DGOINPT1.m --- ./r1/DGOINPT1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGOINPT1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGOINPT1 ;ALB/REW - BUILDS,PRINTS INPATIENT ROSTER ; 8/8/03 11:45am - ;;5.3;Registration;**162,498,544**;Aug 13, 1993 +DGOINPT1 ;ALB/REW - BUILDS,PRINTS INPATIENT ROSTER ; 7 JAN 1992 + ;;5.3;Registration;**162**;Aug 13, 1993 ; ; ; DGS1 IS USED FOR SORTING PRINT @@ -29,12 +29,10 @@ F DGI=0:0 S:DGS]""&TOT ^TMP($J,"DGLIST",DGS1)=TOT S TOT=0,DGS=$S((VAUTW):$O(^DPT(DGXREF,DGS)),1:$O(VAUTW(DGS))) Q:DGS="" D CHECK I DGFL S DFN="" F DGJ=0:0 S DFN=$O(^DPT(DGXREF,DGS2,DFN)) Q:DFN="" D ADMDT Q ADMDT ; - N DGVAIN7,VAL + N DGVAIN7 D QKVADPT Q:'VAIN(7) S DGBID=VA("BID") S TOT=TOT+1,X=+VAIN(7),DGVAIN7="" I X S X=$$FMTE^XLFDT(X,"5DF"),X=$TR(X," ","0"),X=$TR(X,"/","-"),DGVAIN7=X S DGPMIFN=VAIN(1) D ^DGPMLOS S DGDAYS=$P(X,"^",5) - S VAL=VADM(1)_U_DGBID_U_VADM(4)_U_DGVAIN7_U_DGDAYS_U_VAIN(4)_U_VAIN(5)_U_$P(VAIN(2),U,2) - S VAL=VAL_U_$P(VAIN(11),U,2)_U_$P(VAIN(3),U,2)_U_$P(VAEL(9),U,1)_U_$P(VAIP(19,1),U,1) - S ^TMP($J,DGS1,$S(DGSUBS="R":+$$RM(VAIN(5)),1:VADM(1)),+DGBID)=VAL + S ^TMP($J,DGS1,$S(DGSUBS="R":+$$RM(VAIN(5)),1:VADM(1)),+DGBID)=VADM(1)_U_DGBID_U_VADM(4)_U_DGVAIN7_U_DGDAYS_U_VAIN(4)_U_VAIN(5)_U_$P(VAIN(2),U,2)_U_$P(VAIN(11),U,2)_U_$P(VAIN(3),U,2)_U_$P(VAEL(9),U,1) Q CHECK ; S DGFL=1 @@ -52,17 +50,15 @@ QTDOL Q HEAD S X=$S(DGHOW="W":"WARD",DGPVAR="E":"PROVIDER",DGPVAR="P":"PRIMARY PHYSICIAN",1:"ATTENDING PHYSICIAN")_": "_DGS_" "_^TMP($J,"DGLIST",DGS)_" PATIENTS" W:IOF]"" @IOF W !!?4,"INPATIENT ROSTER",?(61-($L(X)/2)),X,?99 W DGADMT - W !!?33,"ADMISSION",?78,"PRIMARY",?95,"ATTENDING",?112,"TREATING",?126,"MEANS" - W !,"PATIENT NAME",?21,"ID",?28,"AGE",?33,"DATE",?46,"DAYS",?52,"WARD",?67,"ROOM-BED",?78,"PHYSICIAN",?95,"PHYSICIAN",?112,"SPECIALTY",?126,"TEST" K X S $P(X,"-",133)="" W !,X,! Q + W !!?33,"ADMISSION",?77,"PRIMARY",?94,"ATTENDING",?111,"TREATING",?126,"MEANS" + W !,"PATIENT NAME",?21,"ID",?28,"AGE",?33,"DATE",?46,"DAYS",?52,"WARD",?67,"ROOM-BED",?77,"PHYSICIAN",?94,"PHYSICIAN",?111,"SPECIALTY",?126,"TEST" K X S $P(X,"-",133)="" W !,X,! Q OUT ; S DGUTV="^TMP("_$J_","""_DGS_""")" - F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,"""")'[($J_","_DGS_",")) S DGADM=@DGUTV D PRINT I $Y>(IOSL-6),($TR($Q(@DGUTV),"""")[($J_","_DGS_",")) D LEGEND,WAIT G QTOUT:DGX D HEAD - I $Y<(IOSL-5) D LEGEND + F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,"""")'[($J_","_DGS_",")) S DGADM=@DGUTV D PRINT I $Y>(IOSL-4),($TR($Q(@DGUTV),"""")[($J_","_DGS_",")) D WAIT G QTOUT:DGX D HEAD QTOUT Q PRINT ; - W !,$S($P(DGADM,U,12):"!",1:""),$E($P(DGADM,U,1),1,19),?21,$P(DGADM,U,2),?28,$J($P(DGADM,U,3),3) - W ?33,$P(DGADM,U,4),?46,$J($P(DGADM,U,5),4),?52,$E($P(DGADM,U,6),1,14),?67,$E($P(DGADM,U,7),1,9),?78,$E($P(DGADM,U,8),1,15) - W ?95,$E($P(DGADM,U,9),1,15),?112,$E($P(DGADM,U,10),1,13),?128,$P(DGADM,U,11) W:DGDS ! + W !,$E($P(DGADM,U,1),1,19),?21,$P(DGADM,U,2),?28,$J($P(DGADM,U,3),3),?33,$P(DGADM,U,4),?46,$J($P(DGADM,U,5),4),?52,$E($P(DGADM,U,6),1,14),?67,$E($P(DGADM,U,7),1,8),?77,$E($P(DGADM,U,8),1,15) + W ?94,$E($P(DGADM,U,9),1,15),?111,$E($P(DGADM,U,10),1,13),?127,$P(DGADM,U,11) W:DGDS ! Q RM(ROOMB) ; ;IGNORES CHARACTERS BEFORE THE FIRST NON-ZERO NUMBER @@ -86,13 +82,8 @@ F I=2,11 S:$D(^VA(200,+VAIN(I),0)) VAIN(I)=VAIN(I)_U_$P(^(0),U,1) S:$D(^DIC(45.7,+VAIN(3),0)) VAIN(3)=VAIN(3)_U_$P(^(0),U,1) DEM S VADM(1)=$P($G(^DPT(DFN,0)),U,1) - S VAIP(19,1)=$P($G(^DGPM(+VAIN(1),"DIR")),"^",1) - S:VAIP(19,1)="" VAIP(19,1)=1 S DGX=$P($G(^DPT(DFN,0)),U,3) S VADM(4)=$E(DT,1,3)-$E(DGX,1,3)-($E(DT,4,7)<$E(DGX,4,7)) D PID^VADPT6 MT S VAEL(9)=$P($$MTS^DGMTU(DFN),U,2) Q -LEGEND F Q:($Y>(IOSL-5)) W ! - W !,"'!' Before the Patient name indicates the patient chose not to be listed in the Facility Directory" - Q diff -auBN ./r1/DGOINPT.m ./r2/r/DGOINPT.m --- ./r1/DGOINPT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGOINPT.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGOINPT ;RWA/SLC,XAK/ALBANY;ALB/MLI;ALB/REW - WARD ROSTER ; 6/11/03 12:26pm - ;;5.3;Registration;**524**;Aug 13, 1993 +DGOINPT ;RWA/SLC,XAK/ALBANY;ALB/MLI;ALB/REW - WARD ROSTER ; 16 SEP 84 1:41 pm + ;;5.3;Registration;;Aug 13, 1993 ;;MAS VERSION 5.1; ; ; DGHOW = PRIMARY SORT METHOD (W=WARD P=PROVIDER) @@ -28,7 +28,7 @@ S Z="^PRIMARY CARE^ATTENDING^EITHER" D IN^DGHELP I %=-1 W !!?3,"Enter P to sort this report of inpatients by PRIMARY CARE PHYSICIAN",!?9,"A to sort the report by ATTENDING PHYSICIAN, or",!?9,"E to print the report where the provider was EITHER",!?12,"Attending or Primary Care" G PROV S DGPVAR=X,VAUTNI=3 - S DIC="^VA(200,",VAUTSTR="provider",VAUTVB="VAUTW" D FIRST^VAUTOMA + S DIC="^VA(200,",VAUTSTR="provider",VAUTVB="VAUTW",DIC("S")="S DGTM=$G(^(""I"")) I DGTM'>0!(DGTM>DT)" D FIRST^VAUTOMA Q:Y<0 NMRM ; R !!,"Sub-sort by (N)ame of Patient or (R)oom NAME// ",X:DTIME I '$T!(X["^") Q diff -auBN ./r1/DGOVBC1.m ./r2/r/DGOVBC1.m --- ./r1/DGOVBC1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGOVBC1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,6 +1,5 @@ DGOVBC1 ;ALB/MRL - VBC OUTPUT ; 12 FEB 87 - ;;5.3;Registration;**162,489**;Aug 13, 1993 - N VAPA + ;;5.3;Registration;**162**;Aug 13, 1993 K DGLN S $P(DGLN," ",80)="",DGU="UNKNOWN",DGPP="" F DGPP1=0:0 S DGPP=$O(^UTILITY($J,"DGOVBC",DGPP)) Q:(DGPP="")!($G(ZTSTOP)=1) S DFN=^UTILITY($J,"DGOVBC",DGPP) D DIS,ENDREP^DGUTL Q K DGCA,I,DGX,X,Y,%DT,DGFR,DGHD,DGHD1,DGHOW,DGIOM,DGLIN,DGLN,DGPP,DGPP1,DGTO,DGU,DGVAR,DIC,DFN,DGCT,DGDFN,DGP,DGPGM,ZTSTOP,^UTILITY($J,"DGOVBC") D CLOSE^DGUTQ Q @@ -10,10 +9,7 @@ D DEM^VADPT D L W !,"1. Patient Name: ",$S(VADM(1)]"":VADM(1),1:"UNSPECIFIED PATIENT #"_DFN),?55,"| 2. DOB: ",$P(VADM(3),"^",2) D PID^VADPT6 W ?80,"| 3. PT ID: ",$S(VA("PID"):VA("PID"),1:DGU),?106,"| 4. Claim #: " S DGMS=$S(VADM(10):$P(VADM(10),"^",2),1:DGU) K VA,VADM D ELIG^VADPT W $S(VAEL(7):VAEL(7),1:DGU),! S DGSC=+VAEL(3),DGMT=$P(VAEL(9),"^",2) K VAEL W "_______________________________________________________|________________________|_________________________|_______________________" - D ADD^VADPT,A W !,"5. Address Information [Street, City, State, Zip Code]:" F I=0:0 S I=$O(DGA(I)) Q:'I W:I>1 ! W ?57,DGA(I),! - I VAPA(12)=1 D - .D L - .D AC W !,"5A. Confidential Address Information [Street, City, State, Zip Code]:" F I=0:0 S I=$O(DGA(I)) Q:'I W:I>1 ! W ?57,DGA(I) + D ADD^VADPT,A W !,"5. Address Information [Street, City, State, Zip Code]:" F I=0:0 S I=$O(DGA(I)) Q:'I W:I>1 ! W ?57,DGA(I) K DGA W ! D SVC^VADPT,L W !,"6. Service Record",?35,"Service #",?55,"Entry Date",?75,"Separation Date",?108,"Discharge Type" W $C(13)," ","______________",$E(DGLN,1,18),"_________",$E(DGLN,1,11),"__________",$E(DGLN,1,10),"_______________",$E(DGLN,1,18),"______________" S DGPOW=VASV(4) F I=6:1:8 I VASV(I) W !?3,$S(VASV(I,1):$P(VASV(I,1),"^",2),1:DGU),?35,$S($L(VASV(I,2)):VASV(I,2),1:DGU),?55,$S('VASV(I,4):DGU,1:$P(VASV(I,4),"^",2)),?75,$S('VASV(I,5):DGU,1:$P(VASV(I,5),"^",2)),?108,$S(VASV(I,3):$P(VASV(I,3),"^",2),1:DGU) @@ -32,25 +28,7 @@ A S DGA=1 F I=1:1:3 Q:'$L(VAPA(I)) S:I=3 DGA(2)=DGA(2)_", "_VAPA(I) S:DGA<3 DGA(I)=VAPA(I),DGA=DGA+1 I VAPA(1)']"" S DGA(1)="STREET ADDRESS UNKNOWN",DGA=2 S DGA(DGA)=$S($L(VAPA(4))&(VAPA(5)):VAPA(4)_", "_$P(VAPA(5),"^",2),$L(VAPA(4)):VAPA(4),VAPA(5):$P(VAPA(5),"^",2),1:"CITY STATE UNKNOWN") - S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_VAPA(6) - I VAPA(12)=0 K I,J - Q -AC ;Formatting Confidential Address Information - K DGA - I VAPA(12)=1 D - .N DGASEQ,SEQ - .S DGA=13 F I=13:1:15 Q:'$L(VAPA(I)) S:I=15 DGA(14)=DGA(14)_", "_VAPA(I) S:DGA<15 DGA(I)=VAPA(I),DGA=DGA+1 - .S DGA(19)="______________________________________________" - .S DGA(20)="Confidential Start Date: "_$P(VAPA(20),"^",2) - .S DGA(21)="Confidential End Date: "_$P(VAPA(21),"^",2) - .S DGA(22)="Confidential Address Categories:" - .S SEQ="",DGASEQ=23 F S SEQ=$O(VAPA(22,SEQ)) Q:SEQ="" D - ..I $P(VAPA(22,SEQ),"^",3)="Y" S DGA(DGASEQ)=$P(VAPA(22,SEQ),"^",2),DGASEQ=DGASEQ+1 - .I VAPA(13)']"" S DGA(1)="STREET ADDRESS UNKNOWN",DGA=2 - .S DGA(DGA)=$S($L(VAPA(16))&(VAPA(17)):VAPA(16)_", "_$P(VAPA(17),"^",2),$L(VAPA(16)):VAPA(16),VAPA(17):$P(VAPA(17),"^",2),1:"CITY STATE UNKNOWN") - .S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_$P(VAPA(18),"^",2) - K I,VAPA Q - Q + S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_VAPA(6) K I,J,VAPA Q AS S Y=$P(DGD,"^",1),Y=$P(Y,".",1) X ^DD("DD") S:$P(DGD,"^",11) DGSCOND=1 S DGD(1)=$S($P(DGD,"^",11):"*",1:" ")_Y,DGD(2)=$S($D(^DG(405.2,+$P(DGD,"^",18),0)):$P(^(0),"^",1),1:DGU) S DGD(3)=$S($D(^DIC(42,+$P(DGD,"^",6),0)):$P(^(0),"^",1),1:DGU) S DGD(4)=$S($P(DGD,"^",10)]"":$E($P(DGD,"^",10),1,30),1:"ADMITTING DIAGNOSIS UNSPECIFIED"),DGD(5)=$S($D(^DIC(43.4,+$P(DGADM(I,4),"^",1),0)):$P(^(0),"^",1),1:DGU) Q diff -auBN ./r1/DGPFAA1.m ./r2/r/DGPFAA1.m --- ./r1/DGPFAA1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFAA1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,11 +0,0 @@ -DGPFAA1 ;ALB/RPM - PRF ASSIGNMENT VALIDATION DATA ; 02/06/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -XREF ;;array node name;field#;required param;word processing?;description - ;;DFN;.01;1;0;patient IEN - ;;FLAG;.02;1;0;pointer to 26.11 or 26.15 - ;;STATUS;.03;1;0;active/inactive - ;;OWNER;.04;1;0;site that controls the assignment - ;;ORIGSITE;.05;1;0;site that created the assignment - ;;REVIEWDT;.06;0;0;review date - ;;NARR;1;1;1;assignment narrative diff -auBN ./r1/DGPFAA2.m ./r2/r/DGPFAA2.m --- ./r1/DGPFAA2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFAA2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,259 +0,0 @@ -DGPFAA2 ;ALB/KCL - PRF ASSIGNMENT API'S CONTINUED ; 4/24/03 3:55pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;- no direct entry - QUIT - ; -ADDOK(DGDFN,DGFLG,DGREASON) ;This function will be used to determine if a flag may be added/assigned to a patient. - ; - ; Input: - ; DGDFN - (required) IEN of patient in PATIENT (#2) file - ; DGFLG - (required) IEN of patient record flag in PRF NATIONAL - ; FLAG (#26.15) file or PRF LOCAL FLAG (#26.11) file. - ; [ex: "1;DGPF(26.15,"] - ; - ; Output: - ; Function Value - returns 1 on success (YES), 0 on failure (NO) - ; DGREASON - undefined on success, reason why flag can not - ; be assigned to patient on failure - ; - N RESULT ;function result - N DGFARRY ;contains flag array - K DGFARRY - ; - S RESULT=0 - ; - D ;-drops out of block on failure - . ; - . ;-- quit if DFN invalid - . I '(+$G(DGDFN)>0),'$D(^DPT(DGDFN)) S DGREASON="Patient is not valid" Q - . ; - . ;-- quit if flag ien invalid - . I '$$TESTVAL^DGPFUT(26.13,.02,DGFLG) S DGREASON="Record flag is not valid" Q - . ; - . ;-- quit if flag already assigned to patient - . I $$FNDASGN^DGPFAA(DGDFN,DGFLG) S DGREASON="Record flag is already assigned to patient" Q - . ; - . ;-- quit if flag STATUS is INACTIVE - . I $$GETFLAG^DGPFUT1(DGFLG,.DGFARRY) - . I '+$G(DGFARRY("STAT")) S DGREASON="Status of record flag assignment is 'Inactive'" Q - . ; - . ;-- success - . S RESULT=1 - ; - Q RESULT - ; - ; -EDTOK(DGPFA,DGORIG,DGREASON) ;This function will be used to determine if an flag assignment may be edited. - ; - ; Input: - ; DGPFA - (required) array containing the flag assignment values - ; DGORIG - (optional) originating site [default = +$$SITE^VASITE()] - ; - ; Output: - ; Function Value - returns 1 on success (YES), 0 on failure (NO) - ; DGREASON - undefined on success, reason why assignment - ; can not be edited on failure - ; - N RESULT ;function result - N DGFARRY ;contains flag array - K DGFARRY - ; - S RESULT=0 - ; - D ;-drops out of block on failure - . ; - . ;-- quit if current site is not the owner site - . I +$G(DGORIG)'>0 S DGORIG=+$$SITE^VASITE() - . I +$G(DGPFA("OWNER"))'=DGORIG S DGREASON="Not the owner site" Q - . ; - . ;-- quit if flag STATUS is INACTIVE - . I $$GETFLAG^DGPFUT1($P($G(DGPFA("FLAG")),U),.DGFARRY) - . I '+$G(DGFARRY("STAT")) S DGREASON="Record flag status is 'Inactive'" Q - . ; - . ;-- success - . S RESULT=1 - ; - Q RESULT - ; -ACTIONOK(DGPFA,DGACT) ;verify ACTION is appropriate for current STATUS - ; - ; Input: - ; DGPFA - (required) assignment array data from current record - ; DGACT - Assignment edit action in internal format - ; [1:NEW ASSIGNMENT,2:CONTINUE,3:INACTIVATE,4:REACTIVATE] - ; - ; Output: - ; Function value - 1 on success, 0 on failure - ; - N DGRSLT - N DGSTAT - ; - S DGACT=+$G(DGACT) - S DGSTAT=$P($G(DGPFA("STATUS")),U,1) - S DGRSLT=0 - ; - I $$TESTVAL^DGPFUT(26.14,.03,DGACT),DGSTAT?1N D - . ; - . ;Must not CONTINUE inactive assignments - . I DGACT=2,DGSTAT=0 Q - . ; - . ;Must not INACTIVATE inactive assignments - . I DGACT=3,DGSTAT=0 Q - . ; - . ;Must not REACTIVATE active assignments - . I DGACT=4,DGSTAT=1 Q - . ; - . ;success - . S DGRSLT=1 - ; - Q DGRSLT - ; -CHGOWN(DGPFA,DGORIG,DGREASON) ;Is site allowed to change ownership of a record flag assignment? - ; - ; Input: - ; DGPFA - (required) array containing the flag assignment values - ; DGORIG - (optional) originating site [default = +$$SITE^VASITE()] - ; - ; Output: - ; Function Value - returns 1 on success (YES), 0 on failure (NO) - ; DGREASON - undefined on success, reason why assignment - ; ownership can not be edited on failure - ; - N DGRSLT ;function result - ; - S:(+$G(DGORIG)'>0) DGORIG=(+$$SITE^VASITE()) - S DGRSLT=0 - ; - D ;drops out of block on failure - . ; - . ;ORIGINATING SITE must be OWNER and flag must be ACTIVE - . Q:('$$EDTOK(.DGPFA,DGORIG,.DGREASON)) - . ; - . ;can't CHANGE OWNERSHIP for an assignment to a LOCAL flag - . I $P(DGPFA("FLAG"),U)["26.11" D Q - . .S DGREASON="Can't change ownership of assignments to Category II (Local) flags" - . . Q - . ; - . ;can't CHANGE OWNERSHIP for an INACTIVE assignment - . I '+$G(DGPFA("STATUS")) D Q - . . S DGREASON="Record flag assignment status is 'Inactive'" - . . Q - . ; - . ;success - . S DGRSLT=1 - ; - Q DGRSLT - ; -HL7EDTOK(DGDFN,DGFLG,DGORIG,DGACT) ;Is site allowed to edit assignment? - ; This function acts as wrapper for $$EDTOK and $$ACTIONOK for edits - ; that originate from PRF HL7 message processing. - ; - ; Input: - ; DGDFN - IEN of patient in PATIENT (#2) file - ; DGFLG - IEN of patient record flag in PRF NATIONAL FLAG (#26.15) - ; file or PRF LOCAL FLAG (#26.11) file. [ex: "1;DGPF(26.15,"] - ; DGORIG - IEN of originating site in INSTITUTION (#4) file - ; DGACT - Assignment edit action in internal format - ; [1:NEW ASSIGNMENT,2:CONTINUE,3:INACTIVATE,4:REACTIVATE] - ; - ; Output: - ; Function value - 1 if authorized, 0 if not authorized - ; - N DGIEN ;pointer to PRF ASSIGNMENT (#26.13) file - N DGPFA ;assignment data array - N DGRSLT ;function value - ; - S DGACT=+$G(DGACT) - S DGDFN=+$G(DGDFN) - S DGFLG=$G(DGFLG) - S DGORIG=+$G(DGORIG) - S DGRSLT=0 - ; - I DGACT>0,DGDFN>0,DGFLG]"",DGORIG>0 D - . ; - . ;retrieve existing assignment data - . S DGIEN=$$FNDASGN^DGPFAA(DGDFN,DGFLG) - . Q:('DGIEN) - . Q:('$$GETASGN^DGPFAA(DGIEN,.DGPFA)) - . ; - . ;ORIGINATING SITE must be OWNER and flag must be ACTIVE - . Q:('$$EDTOK(.DGPFA,DGORIG)) - . ; - . ;ACTION must be valid for current assignment STATUS - . Q:('$$ACTIONOK(.DGPFA,DGACT)) - . ; - . ;success - . S DGRSLT=1 - ; - Q DGRSLT - ; -STOHL7(DGPFA,DGPFAH,DGERR) ;store a valid assignment from HL7 message - ; This function files an assignment if the originating site is - ; authorized to update an existing record and if the action is valid for - ; the status of an existing record. - ; - ; Input: - ; DGPFA - (required) array of assignment values to be filed (see - ; $$GETASGN^DGPFAA for valid array structure) - ; DGPFAH - (required) array of assignment history values to be filed - ; (see $$STOHIST^DGPFAAH for valid array structure) - ; - ; Output: - ; Function Value - Returns 1 on sucess, 0 on failure - ; DGERR - Undefined on success, error code on failure - ; - N DGDFN - N DGFLG - N DGORIG - N DGACT - N DGSTOERR - N DGRSLT - ; - S DGDFN=+$G(DGPFA("DFN")) - S DGFLG=$G(DGPFA("FLAG")) - S DGORIG=+$G(DGPFA("ORIGSITE")) - S DGACT=+$G(DGPFAH("ACTION")) - ; - S DGRSLT=0 - I DGDFN,DGFLG,DGORIG]"",DGACT D - . ; - . ;new assignment action - . I DGACT=1,'$$ADDOK(DGDFN,DGFLG) D Q - . . S DGERR="UU" ;unauthorized update - . ; - . ;all other actions - . I DGACT'=1,'$$HL7EDTOK(DGDFN,DGFLG,DGORIG,DGACT) D Q - . . S DGERR="UU" ;unauthorized update - . ; - . ;file the assignment and history - . I '$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGSTOERR)!($D(DGSTOERR)) D Q - . . S DGERR="FE" ;filer error - . S DGRSLT=1 - Q DGRSLT - ; -ROLLBACK(DGAIEN,DGPFOA) ;Roll back an assignment record - ; - ; Input: - ; DGAIEN - IEN of assignment to roll back in the PRF ASSIGNMENT - ; (#26.13) file - ; DGPFOA - Assignment data array prior to record modification - ; - ; Output: - ; Function value - 1 on successful rollback, 0 on failure - ; - N DGIENS - N DGFDA - N DGERR - N DGRSLT ;function result - ; - S DGRSLT=0 - I +$G(DGAIEN),$D(^DGPF(26.13,DGAIEN)),$D(DGPFOA) D - . S DGIENS=DGAIEN_"," - . I $G(DGPFOA("DFN"))="@" D - . . S DGFDA(26.13,DGIENS,.01)=DGPFOA("DFN") - . . D FILE^DIE("","DGFDA","DGERR") - . . I '$D(DGERR) S DGRSLT=1 - . E D - . . I $$STOASGN^DGPFAA(.DGPFOA,.DGERR),'$D(DGERR) S DGRSLT=1 - Q DGRSLT diff -auBN ./r1/DGPFAA3.m ./r2/r/DGPFAA3.m --- ./r1/DGPFAA3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFAA3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,90 +0,0 @@ -DGPFAA3 ;ALB/RPM - PRF ASSIGNMENT API'S CONTINUED ; 3/28/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q ;no direct entry - ; -NOTIFYDT(DGFLG,DGRDT) ;calculate the notificaton date - ; - ; Input: - ; DGFLG - (required) pointer to PRF LOCAL FLAG (#26.11) file or - ; PRF NATIONAL FLAG (#26.15) file - ; DGRDT - (required) review date in FM format - ; - ; Output: - ; Function Value - notification date in FM format on success, 0 on - ; failure. - ; - N DGFLGA ;flag file data array - N DGNDT ;function value - ; - S DGNDT=0 - I $G(DGFLG)]"",+$G(DGRDT)>0 D - . ; - . ;Retrieve the flag data array - . Q:'$$GETFLAG^DGPFUT1(DGFLG,.DGFLGA) - . ; - . ;must have a review frequency - . Q:(+$G(DGFLGA("REVFREQ"))=0) - . ; - . ;determine notification date - . S DGFLGA("NOTIDAYS")=$G(DGFLGA("NOTIDAYS"),0) - . S DGRDT=+$$FMTH^XLFDT(DGRDT) - . S DGNDT=+$$HTFM^XLFDT(DGRDT-DGFLGA("NOTIDAYS")) - ; - Q DGNDT - ; -GETRDT(DGFLG,DGADT) ;calculate the review date - ; - ; Input: - ; DGFLG - (required) pointer to PRF LOCAL FLAG (#26.11) file or - ; PRF NATIONAL FLAG (#26.15) file - ; DGADT - (required) assignment date in FM format - ; - ; Output: - ; Function Value - review date in FM format on success, 0 on failure - ; - N DGFLGA ;flag file data array - N DGRDT ;function value - ; - S DGRDT=0 - I $G(DGFLG)]"",+$G(DGADT)>0 D - . ; - . ;Retrieve the flag data array - . Q:'$$GETFLAG^DGPFUT1(DGFLG,.DGFLGA) - . ; - . ;must have a review frequency - . Q:(+$G(DGFLGA("REVFREQ"))=0) - . ; - . ;determine review date - . S DGADT=+$$FMTH^XLFDT(DGADT) - . S DGRDT=+$$HTFM^XLFDT(DGADT+DGFLGA("REVFREQ")) - ; - Q DGRDT - ; -LOCK(DGAIEN) ;Lock assignment record. - ; - ; This function is used to prevent another process from editing a - ; patient's record flag assignment. - ; - ; Input: - ; DGAIEN - IEN of record in the PRF ASSIGNMENT (#26.13) file - ; - ; Output: - ; Function Value - Returns 1 if the lock was successful, 0 otherwise - ; - I $G(DGAIEN) L +^DGPF(26.13,DGAIEN):10 - ; - Q $T - ; -UNLOCK(DGAIEN) ;Unlock assignment record. - ; - ; This procedure is used to release the lock created by $$LOCK. - ; - ; Input: - ; DGAIEN - IEN of record in the PRF ASSIGNMENT (#26.13) file - ; - ; Output: None - ; - I $G(DGAIEN) L -^DGPF(26.13,DGAIEN) - ; - Q diff -auBN ./r1/DGPFAAH1.m ./r2/r/DGPFAAH1.m --- ./r1/DGPFAAH1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFAAH1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,10 +0,0 @@ -DGPFAAH1 ;ALB/RPM - PRF ASSIGNMENT HISTORY VALIDATION DATA ; 02/06/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -XREF ;;array node name;field#;required field;word processing?;description - ;;ASSIGN;.01;1;0;pointer to 26.13 - ;;ASSIGNDT;.02;1;0;date/time of edit activity - ;;ACTION;.03;1;0;type of edit performed - ;;ENTERBY;.04;1;0;pointer to NEW PERSON file for entering individual - ;;APPRVBY;.05;1;0;pointer to NEW PERSON file for approval individual - ;;COMMENT;1;0;1;review history comments diff -auBN ./r1/DGPFAAH.m ./r2/r/DGPFAAH.m --- ./r1/DGPFAAH.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFAAH.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,212 +0,0 @@ -DGPFAAH ;ALB/RPM - PRF ASSIGNMENT HISTORY API'S ; 4/23/03 1:27pm - ;;5.3;Registration;**425**;Aug 13, 1993 - Q ;no direct entry - ; -GETALL(DGPFIEN,DGPFIENS) ;retrieve list of history IENs for an assignment - ; - ; Input: - ; DGPFIEN - (required) Pointer to PRF ASSIGNMENT (#26.13) file - ; DGPFIENS - (required) Result array passed by reference - ; - ; Output: - ; Function Value - Count of returned IENs - ; DGPFIENS - Output array subscripted by assignment history IENs - ; - N DGCNT ;number of returned values - N DGHIEN ;single history IEN - ; - S DGCNT=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.14,"B",DGPFIEN)) D - . S DGHIEN=0 - . F S DGHIEN=$O(^DGPF(26.14,"B",DGPFIEN,DGHIEN)) Q:'DGHIEN D - . . S DGPFIENS(DGHIEN)="" - . . S DGCNT=DGCNT+1 - Q DGCNT - ; -GETALLDT(DGPFIEN,DGPFIENS) ;retrieve list of history IENs for an assignment - ; - ; Input: - ; DGPFIEN - (required) Pointer to PRF ASSIGNMENT (#26.13) file - ; DGPFIENS - (required) Result array passed by reference - ; - ; Output: - ; Function Value - Count of returned IENs - ; DGPFIENS - Output array subscripted by assignment history date - ; - N DGADT ;assignment date - N DGCNT ;number of returned values - N DGHIEN ;single history IEN - ; - S DGCNT=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.14,"C",DGPFIEN)) D - . S DGADT=0 - . F S DGADT=$O(^DGPF(26.14,"C",DGPFIEN,DGADT)) Q:'DGADT D - . . S DGHIEN=0 - . . F S DGHIEN=$O(^DGPF(26.14,"C",DGPFIEN,DGADT,DGHIEN)) Q:'DGHIEN D - . . . S DGPFIENS(DGADT)=DGHIEN - . . . S DGCNT=DGCNT+1 - Q DGCNT - ; -GETHIST(DGPFIEN,DGPFAH) ;retrieve a single assignment history record - ; - ; Input: - ; DGPFIEN - (required) IEN for record in PRF ASSIGNMENT HISTORY - ; (#26.14) file - ; DGPFAH - (required) Result array passed by reference - ; - ; Output: - ; Function Value - Return 1 on success, 0 on failure - ; DGPFAH - Output array containing the field values - ; Subscript Field# - ; ----------------- ------ - ; "ASSIGN" .01 - ; "ASSIGNDT" .02 - ; "ACTION" .03 - ; "ENTERBY" .04 - ; "APPRVBY" .05 - ; "COMMENT",line#,0 1 - ; - N DGIENS ;IEN string for DIQ - N DGFLDS ;results array for DIQ - N DGERR ;error array for DIQ - N DGRSLT - S DGRSLT=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.14,DGPFIEN)) D - . S DGIENS=DGPFIEN_"," - . D GETS^DIQ(26.14,DGIENS,"*","IEZ","DGFLDS","DGERR") - . Q:$D(DGERR) - . S DGRSLT=1 - . S DGPFAH("ASSIGN")=$G(DGFLDS(26.14,DGIENS,.01,"I"))_U_$G(DGFLDS(26.14,DGIENS,.01,"E")) - . S DGPFAH("ASSIGNDT")=$G(DGFLDS(26.14,DGIENS,.02,"I"))_U_$G(DGFLDS(26.14,DGIENS,.02,"E")) - . S DGPFAH("ACTION")=$G(DGFLDS(26.14,DGIENS,.03,"I"))_U_$G(DGFLDS(26.14,DGIENS,.03,"E")) - . S DGPFAH("ENTERBY")=$G(DGFLDS(26.14,DGIENS,.04,"I"))_U_$G(DGFLDS(26.14,DGIENS,.04,"E")) - . S DGPFAH("APPRVBY")=$G(DGFLDS(26.14,DGIENS,.05,"I"))_U_$G(DGFLDS(26.14,DGIENS,.05,"E")) - . ;build review comments word processing array - . M DGPFAH("COMMENT")=DGFLDS(26.14,DGIENS,1) - . K DGPFAH("COMMENT","E"),DGPFAH("COMMENT","I") - . ; - Q DGRSLT - ; -GETFIRST(DGPFIEN) ;get IEN of the initial assignment - ;This function returns the IEN of the initial history record for a - ;given patient record flag assignment. - ; - ; Input: - ; DGPFIEN - (required) IEN of record in PRF ASSIGNMENT (#26.13) file - ; - ; Output: - ; Function Value - IEN of initial history record on success - ; 0 on failure - ; - N DGHIEN ;history IEN - N DGEDT ;edit date - N DGPFAH ;history record data array - ; - S DGHIEN=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.13,DGPFIEN)) D - . S DGEDT=$O(^DGPF(26.14,"C",DGPFIEN,0)) - . I DGEDT>0 D - . . S DGHIEN=$O(^DGPF(26.14,"C",DGPFIEN,DGEDT,0)) - Q $S($G(DGHIEN)>0:DGHIEN,1:0) - ; -GETLAST(DGPFIEN) ;determine IEN of last assignment history record - ;This function returns the IEN of the most recent history record for a - ;given patient record flag assignment. - ; - ; Input: - ; DGPFIEN - (required) IEN for record in PRF ASSIGNMENT (#26.13) file - ; - ; Output: - ; Function Value - IEN of last history record on success, 0 on failure - ; - N DGDAT - N DGHIEN - S DGHIEN=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.13,DGPFIEN)) D - . S DGDAT=$O(^DGPF(26.14,"C",DGPFIEN,""),-1) - . I DGDAT>0 D - . . S DGHIEN=$O(^DGPF(26.14,"C",DGPFIEN,DGDAT,0)) - Q $S($G(DGHIEN)>0:DGHIEN,1:0) - ; -GETADT(DGPFIEN) ;get the initial assignment date - ;This function returns the initial assignment date for a given patient - ;record flag assignment. - ; - ; Input: - ; DGPFIEN - (required) IEN for record in PRF ASSIGNMENT (#26.13) file - ; - ; Output: - ; Function Value - assignment date in internal^external format on - ; success, 0 on failure - ; - N DGHIEN ;history IEN - N DGEDT ;edit date - N DGADT ;assignment date - N DGPFAH ;history record data array - ; - S DGADT=0 - S DGHIEN=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.13,DGPFIEN)) D - . S DGEDT=$O(^DGPF(26.14,"C",DGPFIEN,0)) - . I DGEDT>0 D - . . S DGHIEN=$O(^DGPF(26.14,"C",DGPFIEN,DGEDT,0)) - . . I DGHIEN>0,$$GETHIST^DGPFAAH(DGHIEN,.DGPFAH) D - . . . I $P($G(DGPFAH("ACTION")),U,2)="NEW ASSIGNMENT" D - . . . . S DGADT=$G(DGPFAH("ASSIGNDT")) - Q DGADT - ; -FNDHIST(DGAIEN,DGADT) ;Find Assignment - ; This function finds a patient record flag assignment record. - ; - ; Input: - ; DGAIEN - Pointer to assignment in the PRF ASSIGNMENT (#26.13) file - ; DGADT - Assignment date - ; - ; Output: - ; Function Value - Returns IEN of existing record on success, 0 on - ; failure - ; - N DGIEN - ; - I $G(DGAIEN)>0,($G(DGADT)>0) D - . S DGIEN=$O(^DGPF(26.14,"C",DGAIEN,DGADT,0)) - Q $S($G(DGIEN)>0:DGIEN,1:0) - ; -STOHIST(DGPFAH,DGPFERR) ;file a PRF ASSIGNMENT HISTORY (#26.14) file record - ; - ; Input: - ; DGPFAH - (required) Array of values to be filed (see GETHIST tag - ; above for valid array structure) - ; DGPFERR - (optional) Passed by reference to contain error messages - ; - ; Output: - ; Function Value - Returns IEN of record on success, 0 on failure - ; DGPFERR - Undefined on success, error message on failure - ; - N DGSUB - N DGFLD - N DGIEN - N DGIENS - N DGFDA - N DGFDAIEN - N DGERR - F DGSUB="ASSIGN","ASSIGNDT","ACTION","ENTERBY","APPRVBY" D - . S DGFLD(DGSUB)=$P($G(DGPFAH(DGSUB)),U) - I $D(DGPFAH("COMMENT")) M DGFLD("COMMENT")=DGPFAH("COMMENT") - I $$VALID^DGPFUT("DGPFAAH1",26.14,.DGFLD,.DGPFERR) D - . S DGIEN=$$FNDHIST^DGPFAAH(DGFLD("ASSIGN"),DGFLD("ASSIGNDT")) - . I DGIEN S DGIENS=DGIEN_"," - . E S DGIENS="+1," - . S DGFDA(26.14,DGIENS,.01)=DGFLD("ASSIGN") - . S DGFDA(26.14,DGIENS,.02)=DGFLD("ASSIGNDT") - . S DGFDA(26.14,DGIENS,.03)=DGFLD("ACTION") - . S DGFDA(26.14,DGIENS,.04)=DGFLD("ENTERBY") - . S DGFDA(26.14,DGIENS,.05)=DGFLD("APPRVBY") - . S DGFDA(26.14,DGIENS,1)="DGFLD(""COMMENT"")" - . I DGIEN D - . . D FILE^DIE("","DGFDA","DGERR") - . . I $D(DGERR) S DGIEN=0 - . E D - . . D UPDATE^DIE("","DGFDA","DGFDAIEN","DGERR") - . . I '$D(DGERR) S DGIEN=$G(DGFDAIEN(1)) - Q $S($G(DGIEN)>0:DGIEN,1:0) diff -auBN ./r1/DGPFAA.m ./r2/r/DGPFAA.m --- ./r1/DGPFAA.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFAA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,196 +0,0 @@ -DGPFAA ;ALB/RPM - PRF ASSIGNMENT API'S ; 3/27/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q ;no direct entry - ; -GETALL(DGDFN,DGIENS,DGSTAT,DGCAT) ;retrieve list of assignment IENs - ;This function returns an array of patient record flag assignment IENs - ;for a given patient. The returned IEN array may optionally be - ;filtered by Active or Inactive status and by flag category. - ; - ; Input: - ; DGDFN - (required) Pointer to patient in PATIENT (#2) file - ; DGIENS - (required) Result array passed by reference - ; DGSTAT - (optional) Status filter (0:Inactive,1:Active,"":Both). - ; Defaults to Both. - ; DGCAT - (optional) Category filter - ; (1:Category I,2:Category II,"":Both). Defaults to Both. - ; - ; Output: - ; Function Value - Count of returned IENs - ; DGIENS - Output array subscripted by the assignment IENs - ; - N DGCNT ;number of returned values - N DGIEN ;single IEN - N DGCKS ;check status flag (1:check, 0:ignore) - N DGFLAG ;pointer to #26.11 or #26.15 - ; - S DGCNT=0 - I $G(DGDFN)>0,$D(^DGPF(26.13,"B",DGDFN)) D - . S DGFLAG="" - . S DGCKS=0 - . S DGSTAT=$G(DGSTAT) - . I DGSTAT=0!(DGSTAT=1) S DGCKS=1 - . S DGCAT=+$G(DGCAT) - . S DGCAT=$S(DGCAT=1:"26.15",DGCAT=2:"26.11",1:0) - . F S DGFLAG=$O(^DGPF(26.13,"C",DGDFN,DGFLAG)) Q:(DGFLAG="") D - . . I DGCAT,DGFLAG'[DGCAT Q - . . S DGIEN=$O(^DGPF(26.13,"C",DGDFN,DGFLAG,0)) - . . I DGCKS,'$D(^DGPF(26.13,"D",DGDFN,DGSTAT,DGIEN)) Q - . . S DGCNT=DGCNT+1 - . . S DGIENS(DGIEN)="" - Q DGCNT - ; -GETASGN(DGPFIEN,DGPFA) ;retrieve a single assignment record - ;This function returns a single patient record flag assignment in an - ;array format. - ; - ; Input: - ; DGPFIEN - (required) Pointer to patient record flag assignment in - ; PRF ASSIGNMENT (#26.13) file - ; DGPFA - (required) Result array passed by reference - ; - ; Output: - ; Function Value - Returns 1 on success, 0 on failure - ; DGPFA - Output array containing assignment record field - ; values. - ; Subscript Field# Data - ; -------------- ------- --------------------- - ; "DFN" .01 internal^external - ; "FLAG" .02 internal^external - ; "STATUS" .03 internal^external - ; "OWNER" .04 internal^external - ; "ORIGSITE" .05 internal^external - ; "REVIEWDT" .06 internal^external - ; "NARR",line#,0 1 character string - ; - N DGIENS ;IEN string for DIQ - N DGFLDS ;results array for DIQ - N DGERR ;error arrary for DIQ - N DGRSLT - ; - S DGRSLT=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.13,DGPFIEN)) D - . S DGIENS=DGPFIEN_"," - . D GETS^DIQ(26.13,DGIENS,"*","IEZ","DGFLDS","DGERR") - . Q:$D(DGERR) - . S DGRSLT=1 - . S DGPFA("DFN")=$G(DGFLDS(26.13,DGIENS,.01,"I"))_U_$G(DGFLDS(26.13,DGIENS,.01,"E")) - . S DGPFA("FLAG")=$G(DGFLDS(26.13,DGIENS,.02,"I"))_U_$G(DGFLDS(26.13,DGIENS,.02,"E")) - . S DGPFA("STATUS")=$G(DGFLDS(26.13,DGIENS,.03,"I"))_U_$G(DGFLDS(26.13,DGIENS,.03,"E")) - . S DGPFA("OWNER")=$G(DGFLDS(26.13,DGIENS,.04,"I"))_U_$G(DGFLDS(26.13,DGIENS,.04,"E")) - . S DGPFA("ORIGSITE")=$G(DGFLDS(26.13,DGIENS,.05,"I"))_U_$G(DGFLDS(26.13,DGIENS,.05,"E")) - . S DGPFA("REVIEWDT")=$G(DGFLDS(26.13,DGIENS,.06,"I"))_U_$G(DGFLDS(26.13,DGIENS,.06,"E")) - . ;build assignment narrative word processing array - . M DGPFA("NARR")=DGFLDS(26.13,DGIENS,1) - . K DGPFA("NARR","E"),DGPFA("NARR","I") - Q DGRSLT - ; -FNDASGN(DGPFDFN,DGPFFLG) ;Find Assignment - ; This function finds a patient record flag assignment record. - ; - ; Input: - ; DGDFN - Pointer to patient in the PATIENT (#2) file - ; DGFLAG - Pointer to flag in either the PRF LOCAL FLAG (#26.11) - ; file or the PRF NATIONAL FLAG (#26.15) file - ; - ; Output: - ; Function Value - Returns IEN of existing record on success, 0 on - ; failure - ; - N DGIEN - ; - I $G(DGPFDFN)>0,($G(DGPFFLG)>0) D - . S DGIEN=$O(^DGPF(26.13,"C",DGPFDFN,DGPFFLG,0)) - Q $S($G(DGIEN)>0:DGIEN,1:0) - ; -STOASGN(DGPFA,DGPFERR) ;store a single PRF ASSIGNMENT (#26.13) file record - ; - ; Input: - ; DGPFA - (required) array of values to be filed (see GETASGN tag - ; above for valid array structure) - ; DGPFERR - (optional) passed by reference to contain error messages - ; - ; Output: - ; Function Value - Returns IEN of record on success, 0 on failure - ; DGPFERR - Undefined on success, error message on failure - ; - N DGSUB - N DGFLD - N DGIEN - N DGIENS - N DGFDA - N DGFDAIEN - N DGERR - F DGSUB="DFN","FLAG","STATUS","OWNER","ORIGSITE" D - . S DGFLD(DGSUB)=$P($G(DGPFA(DGSUB)),U,1) - ; - ;only build DGFLD("REVIEWDT") if "REVIEWDT" is passed - I $D(DGPFA("REVIEWDT"))=1 S DGFLD("REVIEWDT")=$P(DGPFA("REVIEWDT"),U,1) - ; - I $D(DGPFA("NARR")) M DGFLD("NARR")=DGPFA("NARR") - I $$VALID^DGPFUT("DGPFAA1",26.13,.DGFLD,.DGPFERR) D - . S DGIEN=$$FNDASGN^DGPFAA(DGFLD("DFN"),DGFLD("FLAG")) - . I DGIEN S DGIENS=DGIEN_"," - . E S DGIENS="+1," - . S DGFDA(26.13,DGIENS,.01)=DGFLD("DFN") - . S DGFDA(26.13,DGIENS,.02)=DGFLD("FLAG") - . S DGFDA(26.13,DGIENS,.03)=DGFLD("STATUS") - . S DGFDA(26.13,DGIENS,.04)=DGFLD("OWNER") - . S DGFDA(26.13,DGIENS,.05)=DGFLD("ORIGSITE") - . ; - . ;only touch REVIEW DATE (#.06) field if "REVIEWDT" is passed - . I $D(DGFLD("REVIEWDT")) S DGFDA(26.13,DGIENS,.06)=DGFLD("REVIEWDT") - . ; - . S DGFDA(26.13,DGIENS,1)="DGFLD(""NARR"")" - . I DGIEN D - . . D FILE^DIE("","DGFDA","DGERR") - . . I $D(DGERR) S DGIEN=0 - . E D - . . D UPDATE^DIE("","DGFDA","DGFDAIEN","DGERR") - . . I '$D(DGERR) S DGIEN=$G(DGFDAIEN(1)) - Q $S($G(DGIEN)>0:DGIEN,1:0) - ; -STOALL(DGPFA,DGPFAH,DGPFERR) ;store both the assignment and history record - ;This function acts as a wrapper around the $$STOASGN and $$STOHIST - ;filer calls. - ; - ; Input: - ; DGPFA - (required) array of assignment values to be filed (see - ; $$GETASGN^DGPFAA for valid array structure) - ; DGPFAH - (required) array of assignment history values to be filed - ; (see $$STOHIST^DGPFAAH for valid array structure) - ; DGPFERR - (optional) passed by reference to contain error messages - ; - ; Output: - ; Function Value - Returns circumflex("^") delimited results of - ; $$STOASGN^DGPFAA and $$STOHIST^DGPFAAH calls - ; DGPFERR - Undefined on success, error message on failure - ; - N DGOIEN ;existing assignment file IEN used for "roll-back" - N DGPFOA ;existing assignment data array used for "roll-back" - N DGAIEN ;assignment file IEN - N DGAHIEN ;assignment history file IEN - N DGDFN ;"DFN" value - N DGFLG ;"FLAG" value - ; - S (DGAIEN,DGAHIEN)=0 - S DGDFN=$P($G(DGPFA("DFN")),U,1) - S DGFLG=$P($G(DGPFA("FLAG")),U,1) - S DGOIEN=$$FNDASGN^DGPFAA(DGDFN,DGFLG) - D ;drops out of block if can't rollback or assignment filer fails - . I DGOIEN,'$$GETASGN^DGPFAA(DGOIEN,.DGPFOA) Q ;can't rollback, so quit - . ; - . ;store the assignment - . S DGAIEN=$$STOASGN^DGPFAA(.DGPFA,.DGPFERR) - . I $D(DGPFERR) S DGAIEN=0 - . Q:'DGAIEN ;assignment filer failed, so quit - . ; - . ;store the assignment history - . S DGPFAH("ASSIGN")=DGAIEN - . S DGAHIEN=$$STOHIST^DGPFAAH(.DGPFAH,.DGPFERR) - . I $D(DGPFERR) S DGAHIEN=0 - . I DGAHIEN=0 D ;history filer failed, so rollback the assignment - . . I 'DGOIEN,'$D(DGPFOA) S DGPFOA("DFN")="@" - . . I $$ROLLBACK^DGPFAA2(DGAIEN,.DGPFOA) S DGAIEN=0 - Q $S(+$G(DGAHIEN)=0:0,1:DGAIEN_"^"_DGAHIEN) diff -auBN ./r1/DGPFALF1.m ./r2/r/DGPFALF1.m --- ./r1/DGPFALF1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFALF1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,103 +0,0 @@ -DGPFALF1 ;ALB/KCL,RBS - PRF LOCAL FLAG API'S CONTINUED ; 4/21/03 12:53pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;- no direct entry - QUIT - ; -STOALL(DGPFLF,DGPFLH,DGPFERR) ;File both LOCAL FLAG(#26.11) & HISTORY(#26.12) - ;This function acts as a wrapper around the $$STOFLAG^DGPFALF - ;and the $$STOHIST^DGPFALH filer calls. - ; - ; Input: - ; DGPFLF - (required) array of Local Flag values to be filed - ; (see $$GETLF^DGPFALF for valid array structure) - ; DGPFLH - (required) array of Flag History values to be filed - ; (see $$GETHIST^DGPFALH for valid array structure) - ; DGPFERR - (optional) passed by reference to contain error messages - ; - ; Output: - ; Function Value - Returns circumflex("^") delimited results of - ; $$STOFLAG^DGPFALF and $$STOHIST^DGPFALH calls. - ; Example: "3^12" - ; On Success - "IEN of (#26.11)^IEN of (#26.12)" - ; On Failure - 0 - ; DGPFERR - Undefined on success, error message on failure - ; - N DGOIEN ;existing Local Flag file IEN used for "roll-back" - N DGPFOLF ;existing Local Flag data array used for "roll-back" - N DGLIEN ;Local Flag file IEN - N DGLHIEN ;Local Flag history file IEN - N DGFLG ;"FLAG" value - ; - S (DGLIEN,DGLHIEN)=0 - S DGFLG=$P($G(DGPFLF("FLAG")),U) - S DGOIEN=$$FNDFLAG^DGPFALF(DGFLG) - I 'DGOIEN!(DGOIEN&($$GETLF^DGPFALF(DGOIEN,.DGPFOLF))) D - . S DGLIEN=$$STOFLAG^DGPFALF(.DGPFLF,.DGPFERR) - . I $D(DGPFERR) S DGLIEN=0 - . I DGLIEN D - . . S DGPFLH("FLAG")=DGLIEN - . . S DGLHIEN=$$STOHIST^DGPFALH(.DGPFLH,.DGPFERR) - . . I $D(DGPFERR) S DGLHIEN=0 - . . I DGLHIEN=0 D ;roll back the Local Flag file setup - . . . I 'DGOIEN,'$D(DGPFOLF) S DGPFOLF("FLAG")="@" - . . . I $$ROLLBACK^DGPFALF1(26.11,DGLIEN,.DGPFOLF,"FLAG") S DGLIEN=0 - Q $S(DGLHIEN=0:0,1:DGLIEN_"^"_DGLHIEN) - ; -ROLLBACK(DGFILE,DGFIEN,DGPFOA,DGKEY) ;Rollback a FILE record - ; Input: - ; DGFILE - File reference that will be used for rollback - ; DGFIEN - IEN of record to rollback in DGFILE - ; DGPFOA - Original array of data prior to record modification - ; DGKEY - .01 Field Name reference to DELETE whole record - ; Output: - ; Function value - 1 on successful Rollback - ; 0 on failure - ; - N DGIENS,DGFDA,DGERR,DGRSLT - S DGRSLT=0 - I $D(DGFILE),+$G(DGFIEN),$D(DGPFOA),$D(DGKEY) D - . Q:'$D(^DGPF(DGFILE)) - . Q:'$D(^DGPF(DGFILE,DGFIEN)) - . S DGIENS=DGFIEN_"," - . I $G(DGPFOA(DGKEY))="@" D - . . S DGFDA(DGFILE,DGIENS,.01)="@" - . . D FILE^DIE("","DGFDA","DGERR") - . . I '$D(DGERR) S DGRSLT=1 - . E D - . . I $$STOFLAG^DGPFALF(.DGPFOA,.DGERR),'$D(DGERR) S DGRSLT=1 - Q DGRSLT - ; -LOCKLF(DGPFLIEN) ; Lock Flag ien - ; Input: - ; DGPFLIEN - IEN of record - ; Output: - ; Function Value - Returns 1 on success - ; 0 on failure - L +^DGPF(26.11,DGPFLIEN):10 I '$T Q 0 - Q 1 - ; -UNLOCK(DGPFLIEN) ; Un-Lock Flag ien - ; Input: - ; DGPFLIEN - IEN of record - ; Output: - ; Function Value - Returns 1 on success - ; 0 on failure - L -^DGPF(26.11,DGPFLIEN):2 I '$T Q 0 - Q 1 - ; - ; - ; PRF LOCAL FLAG FILE (#26.11) Field VALIDATION data - ; don't do the Principal Investigator(s) multiple fields... - ; they're pointers anyway and won't be Validated. - ; PRININV;2;0;0;principal investigator(s) (if Research Flag)(pointer) - ; - ; *** Only Validate the following fields... -XREF ;;array node name;field#;required param;word processing?;description - ;;FLAG;.01;1;0;flag name - ;;STAT;.02;1;0;active/inactive - ;;TYPE;.03;1;0;pointer to PRF TYPE FILE (#26.16) - ;;REVFREQ;.04;1;0;review frequency - ;;NOTIDAYS;.05;1;0;notification days - ;;REVGRP;.06;0;pointer to MAIL GROUP FILE (#3.8) - ;;DESC;1;1;1;description of flag diff -auBN ./r1/DGPFALF.m ./r2/r/DGPFALF.m --- ./r1/DGPFALF.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFALF.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,144 +0,0 @@ -DGPFALF ;ALB/KCL,RBS - PRF LOCAL FLAG API'S ; 4/9/03 12:25pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;- no direct entry - QUIT - ; -GETLF(DGPFIEN,DGPFLF) ;retrieve a single PRF LOCAL FLAG (#26.11) record - ;This function returns a single flag record from the PRF LOCAL FLAG - ;file and returns it in an array format. - ; - ; Input: - ; DGPFIEN - (required) pointer to local flag record in the - ; PRF LOCAL FLAG (#26.11) file - ; DGPFLF - (required) result array passed by reference - ; - ; Output: - ; Function Value - returns 1 on success, 0 on failure - ; DGPFLF - output array containing local flag record field - ; values. - ; Subscript Field# Data - ; -------------- ------- ------------------- - ; "FLAG" .01 internal^external - ; "STAT" .02 internal^external - ; "TYPE" .03 internal^external - ; "REVFREQ" .04 internal^external - ; "NOTIDAYS" .05 internal^external - ; "REVGRP" .06 internal^external - ; "DESC",line#,0 1 character string - ; "PRININV",line#,0 2 character string - ; - N DGIENS ;IEN string for DIQ - N DGFLDS ;results array for DIQ - N DGERR ;error arrary for DIQ - N DGSUB ;pincipal investigator multiple subscript - N RESULT ;return function value - ; - S RESULT=0 - ; - I $G(DGPFIEN)>0,$D(^DGPF(26.11,DGPFIEN)) D - . S DGIENS=DGPFIEN_"," - . D GETS^DIQ(26.11,DGIENS,"**","IEZ","DGFLDS","DGERR") - . Q:$D(DGERR) - . ; - . ;-- build local flag array - . S DGPFLF("FLAG")=$G(DGFLDS(26.11,DGIENS,.01,"I"))_U_$G(DGFLDS(26.11,DGIENS,.01,"E")) - . S DGPFLF("STAT")=$G(DGFLDS(26.11,DGIENS,.02,"I"))_U_$G(DGFLDS(26.11,DGIENS,.02,"E")) - . S DGPFLF("TYPE")=$G(DGFLDS(26.11,DGIENS,.03,"I"))_U_$G(DGFLDS(26.11,DGIENS,.03,"E")) - . S DGPFLF("REVFREQ")=$G(DGFLDS(26.11,DGIENS,.04,"I"))_U_$G(DGFLDS(26.11,DGIENS,.04,"E")) - . S DGPFLF("NOTIDAYS")=$G(DGFLDS(26.11,DGIENS,.05,"I"))_U_$G(DGFLDS(26.11,DGIENS,.05,"E")) - . S DGPFLF("REVGRP")=$G(DGFLDS(26.11,DGIENS,.06,"I"))_U_$G(DGFLDS(26.11,DGIENS,.06,"E")) - . ;-- flag description word processing array - . M DGPFLF("DESC")=DGFLDS(26.11,DGIENS,1) - . K DGPFLF("DESC","E"),DGPFLF("DESC","I") - . ;-- principal investigator(s) multiple - . S DGSUB="" F S DGSUB=$O(DGFLDS(26.112,DGSUB)) Q:DGSUB="" D - . . S DGPFLF("PRININV",+DGSUB,0)=$G(DGFLDS(26.112,DGSUB,.01,"I"))_U_$G(DGFLDS(26.112,DGSUB,.01,"E")) - . ; - . S RESULT=1 - ; - Q RESULT - ; -FNDFLAG(DGPFFLG) ;Find Flag Name IEN - ; This function finds a flag record IEN using the name field. - ; Input: - ; DGPFFLG - Flag Name field (.01) value - ; - ; Output: - ; Function Value - Returns IEN of existing record on success, 0 on - ; failure - N DGIEN - I $G(DGPFFLG)["" D - . S DGIEN=$O(^DGPF(26.11,"B",DGPFFLG,0)) - ; - Q $S($G(DGIEN)>0:DGIEN,1:0) - ; -STOFLAG(DGPFLF,DGPFERR) ;store a single PRF LOCAL FLAG (#26.11) file record - ; - ; Input: - ; DGPFLF - (required) array of values to be filed (see GETLF tag - ; above for valid array structure) - ; DGPFERR - (optional) passed by reference to contain error messages - ; - ; Output: - ; Function Value - Returns IEN of record on success, 0 on failure - ; DGPFERR - Undefined on success, error message on failure - ; - N DGSUB,DGFLD,DGIEN,DGIENS,DGFDA,DGFDAIEN,DGERR - ; - F DGSUB="FLAG","STAT","TYPE","REVFREQ","NOTIDAYS","REVGRP" D - . S DGFLD(DGSUB)=$P($G(DGPFLF(DGSUB)),U) - I $D(DGPFLF("DESC")) M DGFLD("DESC")=DGPFLF("DESC") - I $D(DGPFLF("PRININV")) M DGFLD("PRININV")=DGPFLF("PRININV") - I $$VALID^DGPFUT("DGPFALF1",26.11,.DGFLD,.DGPFERR) D - . ; - . ;if name change lookup on original name, otherwise lookup on new name - . S DGIEN=$$FNDFLAG^DGPFALF($S($G(DGPFLF("OLDFLAG"))]"":DGPFLF("OLDFLAG"),1:DGFLD("FLAG"))) - . ;the "?+" on an existing record will do LAYGO to lookup and add new - . ; entries. This was needed for adding another entry to the - . ; Principal Investigator(s) multiple (#26.112) - . I DGIEN S DGIENS=DGIEN_"," ;EDIT existing record - . E S DGIENS="+1," ;ADD new record - . S DGFDA(26.11,DGIENS,.01)=DGFLD("FLAG") - . S DGFDA(26.11,DGIENS,.02)=DGFLD("STAT") - . S DGFDA(26.11,DGIENS,.03)=DGFLD("TYPE") - . S DGFDA(26.11,DGIENS,.04)=DGFLD("REVFREQ") - . S DGFDA(26.11,DGIENS,.05)=DGFLD("NOTIDAYS") - . S DGFDA(26.11,DGIENS,.06)=DGFLD("REVGRP") - . S DGFDA(26.11,DGIENS,1)="DGFLD(""DESC"")" - . ;-- principal investigator(s) multiple - . I $D(DGFLD("PRININV")) D PRININV(+DGIEN,.DGFDA) - . ; - . D UPDATE^DIE("","DGFDA","DGFDAIEN","DGERR") - . I '$D(DGERR),'DGIEN S DGIEN=$G(DGFDAIEN(1)) - ; - Q $S($G(DGIEN)>0:DGIEN,1:0) - ; -PRININV(DGPFIEN,DGFDA) ; setup principal investigator(s) multiple (#26.112) - ; Input: - ; DGPFIEN - value will indicate to EDIT or ADD a New Record - ; IEN# = IEN of existing entry - Edit to existing Record - ; 0 = Add New Record - ; DGFDA - array used by FileMan (passed by reference) - ; - ; Output: - ; DGFDA array subscript entries for "PRININV" - ; - ; The DGFDA FDA_ROOT array needs the "?+" on an existing IEN so - ; that FileMan will do LAYGO to lookup and add new entires. - ; This was needed for adding another entry to an existing - ; Principal Investigator(s) multiple (#26.112) field. - ; - S DGPFIEN=+$G(DGPFIEN) - N DGSUB,DGIENS - ; - S DGSUB=0 F S DGSUB=$O(DGFLD("PRININV",DGSUB)) Q:DGSUB="" D - . I DGPFIEN D ;existing record - . . S DGIENS=DGSUB_","_DGPFIEN_"," ;delete - . . Q:DGFLD("PRININV",DGSUB,0)="@" - . . S DGIENS="?+"_DGIENS ;non-delete uses LAYGO - . E S DGIENS="+"_(DGSUB+1)_",+1," ;new record - . ; - . S DGFDA(26.112,DGIENS,.01)=$P(DGFLD("PRININV",DGSUB,0),U) - ; - Q diff -auBN ./r1/DGPFALH.m ./r2/r/DGPFALH.m --- ./r1/DGPFALH.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFALH.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,176 +0,0 @@ -DGPFALH ;ALB/RBS - PRF LOCAL FLAG HISTORY API'S ; 3/10/03 3:14pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q ;no direct entry - ; -GETALL(DGPFIEN,DGPFIENS) ;retrieve list of history IENs for a Local Flag - ; - ; Input: - ; DGPFIEN - (required) Pointer to PRF LOCAL FLAG (#26.11) file - ; DGPFIENS - (required) Result array passed by reference - ; - ; Output: - ; Function Value - Count of returned IENs - ; DGPFIENS - Output array subscripted by Local Flag history IENs - ; - N DGCNT ;number of returned values - N DGHIEN ;single history IEN - ; - S DGCNT=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.12,"B",DGPFIEN)) D - . S DGHIEN=0 - . F S DGHIEN=$O(^DGPF(26.12,"B",DGPFIEN,DGHIEN)) Q:'DGHIEN D - . . S DGPFIENS(DGHIEN)="" - . . S DGCNT=DGCNT+1 - Q DGCNT - ; - ; -GETALLDT(DGPFIEN,DGPFIENS) ;retrieve list of history IENs for a Local Flag - ; Retrieve list of history IENs for a Local Flag and place in a local - ; array subscripted by Flag Edit Date/Time. - ; - ; Input: - ; DGPFIEN - (required) Pointer to PRF LOCAL FLAG (#26.11) file - ; DGPFIENS - (required) Result array passed by reference - ; - ; Output: - ; Function Value - Count of returned IENs - ; DGPFIENS - Output array containing Local Flag history IENs, - ; subscripted by Flag Edit Date/Time - ; Ex. DGPFIENS(3030310.1025)=2 - ; - ; - N DGCNT ;number of returned values - N DGDT ;flag edit date/time - N DGHIEN ;single history IEN - ; - S DGCNT=0 - ; - I $G(DGPFIEN)>0,$D(^DGPF(26.12,"C",DGPFIEN)) D - . S DGDT=0 - . F S DGDT=$O(^DGPF(26.12,"C",DGPFIEN,DGDT)) Q:'DGDT D - . . S DGHIEN=0 - . . F S DGHIEN=$O(^DGPF(26.12,"C",DGPFIEN,DGDT,DGHIEN)) Q:'DGHIEN D - . . . S DGPFIENS(DGDT)=DGHIEN - . . . S DGCNT=DGCNT+1 - ; - Q DGCNT - ; - ; -GETHIST(DGPFIEN,DGPFLH) ;retrieve a single Local Flag history record - ; - ; Input: - ; DGPFIEN - (required) IEN for record in PRF LOCAL FLAG HISTORY - ; (#26.12) file - ; DGPFLH - (required) Result array passed by reference - ; - ; Output: - ; Function Value - Return 1 on success, 0 on failure - ; DGPFLH - Output array containing the field values - ; Subscript Field# - ; ----------------- ------ - ; "FLAG" .01 - ; "ENTERDT" .02 - ; "ENTERBY" .03 - ; "REASON",line#,0 .04 - ; - N DGIENS ;IEN string for DIQ - N DGFLDS ;results array for DIQ - N DGERR ;error array for DIQ - N DGRSLT - S DGRSLT=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.12,DGPFIEN)) D - . S DGIENS=DGPFIEN_"," - . D GETS^DIQ(26.12,DGIENS,"*","IEZ","DGFLDS","DGERR") - . Q:$D(DGERR) - . S DGRSLT=1 - . S DGPFLH("FLAG")=$G(DGFLDS(26.12,DGIENS,.01,"I"))_U_$G(DGFLDS(26.12,DGIENS,.01,"E")) - . S DGPFLH("ENTERDT")=$G(DGFLDS(26.12,DGIENS,.02,"I"))_U_$G(DGFLDS(26.12,DGIENS,.02,"E")) - . S DGPFLH("ENTERBY")=$G(DGFLDS(26.12,DGIENS,.03,"I"))_U_$G(DGFLDS(26.12,DGIENS,.03,"E")) - . ;build reason of enter/edit word processing array - . M DGPFLH("REASON")=DGFLDS(26.12,DGIENS,.04) - . K DGPFLH("REASON","E"),DGPFLH("REASON","I") - . ; - Q DGRSLT - ; - ; -GETLAST(DGPFIEN) ;determine IEN of last Local Flag history record - ;This function returns the IEN of the most recent history record for - ;a given Local Flag record. - ; - ; Input: - ; DGPFIEN - (required) IEN of record in PRF LOCAL FLAG(#26.11) file - ; - ; Output: - ; Function Value - IEN of last history record on success - ; - 0 on failure - N DGDAT,DGHIEN - S DGHIEN=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.11,DGPFIEN)) D - . S DGDAT=$O(^DGPF(26.12,"C",DGPFIEN,""),-1) - . I DGDAT>0 D - . . S DGHIEN=$O(^DGPF(26.12,"C",DGPFIEN,DGDAT,0)) - Q $S($G(DGHIEN)>0:DGHIEN,1:0) - ; - ; -GETADT(DGPFIEN) ;get the initial entry date/time - ;This function returns the initia entry date/time for a given Local - ;record flag. - ; - ; Input: - ; DGPFIEN - (required) IEN of record in PRF LOCAL FLAG(#26.11) file - ; - ; Output: - ; Function Value - Entry date/time on success (internal^external) - ; 0 on failure - ; - N DGHIEN ;history IEN - N DGEDT ;edit date - N DGADT ;entry date - N DGPFLH ;history record data array - ; - S DGADT=0 - S DGHIEN=0 - I $G(DGPFIEN)>0,$D(^DGPF(26.11,DGPFIEN)) D - . S DGEDT=$O(^DGPF(26.12,"C",DGPFIEN,0)) - . I DGEDT>0 D - . . S DGHIEN=$O(^DGPF(26.12,"C",DGPFIEN,DGEDT,0)) - . . I DGHIEN>0,$$GETHIST^DGPFALH(DGHIEN,.DGPFLH) D - . . . S DGADT=$G(DGPFLH("ENTERDT")) - Q DGADT - ; - ; -STOHIST(DGPFLH,DGPFERR) ;file a PRF LOCAL FLAG HISTORY (#26.12) file record - ; - ; Input: - ; DGPFLH - (required) Array of values to be filed (see GETHIST tag - ; above for valid array structure) - ; DGPFERR - (optional) Passed by reference to contain error msg's - ; - ; Output: - ; Function Value - Returns IEN of record on success - ; - 0 on failure - ; DGPFERR - Undefined on success, error message on failure - ; - N DGSUB,DGFLD,DGIEN,DGIENS,DGFDA,DGFDAIEN,DGERR - ; - F DGSUB="FLAG","ENTERDT","ENTERBY" D - . S DGFLD(DGSUB)=$P($G(DGPFLH(DGSUB)),U) - I $D(DGPFLH("REASON")) M DGFLD("REASON")=DGPFLH("REASON") - I $$VALID^DGPFUT("DGPFALH",26.12,.DGFLD,.DGPFERR) D - . S DGIENS="+1," - . S DGFDA(26.12,DGIENS,.01)=DGFLD("FLAG") - . S DGFDA(26.12,DGIENS,.02)=DGFLD("ENTERDT") - . S DGFDA(26.12,DGIENS,.03)=DGFLD("ENTERBY") - . S DGFDA(26.12,DGIENS,.04)="DGFLD(""REASON"")" - . D UPDATE^DIE("","DGFDA","DGFDAIEN","DGERR") - . I '$D(DGERR) S DGIEN=$G(DGFDAIEN(1)) - Q $S($G(DGIEN)>0:DGIEN,1:0) - ; - ; - ; PRF LOCAL FLAG field VALIDATION DATA -XREF ;;array node name;field#;required param;word processing?;description - ;;FLAG;.01;1;0;flag name - ;;ENTERDT;.02;1;0;pointer to NEW PERSON (#200) file - ;;ENTERBY;.03;1;0;pointer to NEW PERSON (#200) file - ;;REASON;.04;1;1;Reason of Flag enter/edit diff -auBN ./r1/DGPFANF.m ./r2/r/DGPFANF.m --- ./r1/DGPFANF.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFANF.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,60 +0,0 @@ -DGPFANF ;ALB/KCL - PRF NATIONAL FLAG API'S ; 4/24/03 4:25pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;- no direct entry - QUIT - ; -GETNF(DGPFIEN,DGPFNF) ;retrieve a single NATIONAL FLAG record - ;This function returns a single flag record from the PRF NATIONAL FLAG - ;file and returns it in an array format. - ; - ; Input: - ; DGPFIEN - (required) pointer to national flag record in the - ; PRF NATIONAL FLAG (#26.15) file - ; DGPFNF - (required) result array passed by reference - ; - ; Output: - ; Function Value - returns 1 on success, 0 on failure - ; DGPFNF - output array containing national flag record field - ; values. - ; Subscript Field# Data - ; -------------- ------- --------------------- - ; "FLAG" .01 internal^external - ; "STAT" .02 internal^external - ; "TYPE" .03 internal^external - ; "REVFREQ" .04 internal^external - ; "NOTIDAYS" .05 internal^external - ; "REVGRP" .06 internal^external - ; "DESC",line#,0 1 character string - ; "PRININV",line#,0 2 character string - ; - N DGIENS ;IEN string for DIQ - N DGFLDS ;results array for DIQ - N DGERR ;error arrary for DIQ - N DGSUB ;pincipal investigator multiple subscript - N RESULT ;return function value - ; - S RESULT=0 - ; - I $G(DGPFIEN)>0,$D(^DGPF(26.15,DGPFIEN)) D - . S DGIENS=DGPFIEN_"," - . D GETS^DIQ(26.15,DGIENS,"**","IEZ","DGFLDS","DGERR") - . Q:$D(DGERR) - . ; - . ;-- build national flag array - . S DGPFNF("FLAG")=$G(DGFLDS(26.15,DGIENS,.01,"I"))_U_$G(DGFLDS(26.15,DGIENS,.01,"E")) - . S DGPFNF("STAT")=$G(DGFLDS(26.15,DGIENS,.02,"I"))_U_$G(DGFLDS(26.15,DGIENS,.02,"E")) - . S DGPFNF("TYPE")=$G(DGFLDS(26.15,DGIENS,.03,"I"))_U_$G(DGFLDS(26.15,DGIENS,.03,"E")) - . S DGPFNF("REVFREQ")=$G(DGFLDS(26.15,DGIENS,.04,"I"))_U_$G(DGFLDS(26.15,DGIENS,.04,"E")) - . S DGPFNF("NOTIDAYS")=$G(DGFLDS(26.15,DGIENS,.05,"I"))_U_$G(DGFLDS(26.15,DGIENS,.05,"E")) - . S DGPFNF("REVGRP")=$G(DGFLDS(26.15,DGIENS,.06,"I"))_U_$G(DGFLDS(26.15,DGIENS,.06,"E")) - . ;-- flag description word processing array - . M DGPFNF("DESC")=DGFLDS(26.15,DGIENS,1) - . K DGPFNF("DESC","E"),DGPFNF("DESC","I") - . ;-- principal investigator(s) multiple - . S DGSUB="" F S DGSUB=$O(DGFLDS(26.152,DGSUB)) Q:DGSUB="" D - . . S DGPFNF("PRININV",+DGSUB,0)=$G(DGFLDS(26.152,DGSUB,.01,"I"))_U_$G(DGFLDS(26.152,DGSUB,.01,"E")) - . ; - . S RESULT=1 - ; - Q RESULT diff -auBN ./r1/DGPFAPI.m ./r2/r/DGPFAPI.m --- ./r1/DGPFAPI.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFAPI.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,238 +0,0 @@ -DGPFAPI ;ALB/RBS - PRF EXTERNAL USER INTERFACE API'S ; 9/2/03 10:30am - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ; This routine contains API entry points that are used by packages - ; and modules that are external to the Patient Record Flags module. - ; - Q ;no direct entry - ; -GETACT(DGDFN,DGPRF) ;Retrieve all ACTIVE Patient record flag assignments - ; The purpose of this API is to facilitate the retrieval of specific - ; data that can be used for the displaying of or the reporting of - ; only ACTIVE Patient Record Flag (PRF) Assignment information for - ; a patient. - ; - ; Usage of this API, DBIA #3860, is by Controlled Subscription. - ; - ; Input: - ; DGDFN - IEN of patient in the PATIENT (#2) file - ; DGPRF - Closed Root array of return values - ; [Optional-default DGPFAPI] - ; - ; Output: - ; Function result - "0" = No Active record flags for the patient - ; - "nn" = Total number of flags returned in array - ; DGPRF() - Array, passed by closed root reference - ; - Multiple subscripted array of Active flag information - ; If the function call is successful, this array will - ; contain each of the Active flag records. - ; - Subscript field value = internal value^external value - ; 2 piece string caret(^) delimited - ; DGPFAPI() - Default array name if no name passed - ; - ; Subscript Field Name Field #/File # - ; --------- ---------- -------------- - ; "APPRVBY" Approved By (.05)/(#26.14) - ; The field value contains the pointer to the NEW PERSON - ; FILE (#200) of the person approving the assignment of a - ; patient record flag to a patient. - ; The field values will be one of the following two explanations: - ; 1. If calling site IS the Originating Site... - ; PIECE 1 = IEN pointer to NEW PERSON FILE (#200) - ; PIECE 2 = Name of Person - ; 2. If calling site is NOT the Originating Site... - ; PIECE 1 = .5 - ; PIECE 2 = "CHIEF OF STAFF" - ; (Note: The .5 (POSTMASTER) internal field value triggers an - ; output transform that converts the external value - ; of "POSTMASTER" to "CHIEF OF STAFF". - ; "ASSIGNDT" Assign Date/Time (.02)/(#26.14) - ; The field value contains a FileMan internal^external Date and - ; Time of the initial assignment of the Patient Record Flag. - ; - ; "REVIEWDT" Review Date (.06)/(#26.13) - ; The field value contains a FileMan internal^external date that - ; the flag assignment is due for review to determine continuing - ; appropriateness. - ; - ; "FLAG" Flag Name (.02)/(#26.13) - ; The field value contains the Patient Record Flag name that is - ; assigned to the patient as a variable pointer. - ; PIECE 1 = IEN variable pointer to (#26.11) or (#26.15) file - ; PIECE 2 = Name of Flag - ; - ; "FLAGTYPE" Type of Flag (.03)/(#26.11 or #26.15) - ; The field value contains the Record Flag Type usage - ; classification. (i.e. BEHAVIORAL,RESEARCH,CLINICAL,OTHER) - ; PIECE 1 = IEN of the flag Type (pointer to (#26.16) file) - ; PIECE 2 = Name of flag Type - ; - ; "CATEGORY" National or Local Flag (#26.15) or (#26.11) - ; The field value contains the type of category the flag - ; represents. - ; I (NATIONAL) = (#26.15) PRF NATIONAL - ; II (LOCAL) = (#26.11) PRF LOCAL - ; PIECE 1 = I (NATIONAL) or II (LOCAL) - ; PIECE 2 = (same value as PIECE 1) - ; - ; "OWNER" Owner Site (.04)/(#26.13) - ; The field value contains the Site that owns the patient's - ; Record Flag Assignment. Only the Owner Site may edit a patients - ; flag assignment. - ; PIECE 1 = IEN of the site (pointer to INSTITUTION FILE (#4)) - ; PIECE 2 = Name of Institution - ; - ; "ORIGSITE" Originating Site (.05)/(#26.13) - ; The field value contains the Site that first entered the Patient - ; Record Flag on this patient. - ; PIECE 1 = IEN of the site (pointer to INSTITUTION FILE (#4)) - ; PIECE 2 = Name of Institution - ; - ; "NARR" Assignment Narrative (1)/(#26.13) - ; (word-processing, multiple nodes) - ; The field value contains the reason narrative for this patients - ; assignment of a Patient Record Flag. - ; The format is in a word-processing value that may contain - ; multiple nodes of text. Each node of text will be less - ; than 80 characters in length. - ; The format is as follows: - ; TARGET_ROOT(nn,"NARR",line#,0)=text - ; where: - ; nn = a unique number for each Flag - ; line# = a unique number starting at 1 for each wp line - ; of narrative text - ; 0 = standard subscript format for the nodes of a - ; FileMan Word Processing field - ; - N DGPFTCNT ;return results, "0"=no flags, "nn"=number of flags - N DGPFIENS ;array of all active flag assignment IEN's - N DGPFIEN ;ien of record flag assignment in (#26.13) file - N DGPFA ;flag assignment array - N DGPFAH ;flag assignment history array - N DGPFLAG ;flag record array - N DGCAT ;flag category - ; - Q:'$G(DGDFN) 0 ;Quit, null parameter - Q:'$$GETALL^DGPFAA(DGDFN,.DGPFIENS,1) 0 ;Quit, no Active assign's - ; - S DGPRF=$G(DGPRF) - I DGPRF']"" S DGPRF="DGPFAPI" ;setup default array name - S (DGPFIEN,DGCAT)="",DGPFTCNT=0 - ; - ; loop all returned Active Record Flag Assignment ien's - F S DGPFIEN=$O(DGPFIENS(DGPFIEN)) Q:DGPFIEN="" D - . K DGPFA,DGPFAH,DGPFLAG - . ; - . ; retrieve single assignment record fields - . Q:'$$GETASGN^DGPFAA(DGPFIEN,.DGPFA) - . ; - . ; no patient DFN match - . I DGDFN'=$P(DGPFA("DFN"),U) Q - . ; - . ; get initial assignment history - . Q:'$$GETHIST^DGPFAAH($$GETFIRST^DGPFAAH(DGPFIEN),.DGPFAH) - . ; - . ; get record flag record - . Q:'$$GETFLAG^DGPFUT1($P($G(DGPFA("FLAG")),U),.DGPFLAG) - . ; - . S DGPFTCNT=DGPFTCNT+1 - . ; - . ; approved by user - . S @DGPRF@(DGPFTCNT,"APPRVBY")=$G(DGPFAH("APPRVBY")) - . ; - . ; initial assignment date/time - . S @DGPRF@(DGPFTCNT,"ASSIGNDT")=$G(DGPFAH("ASSIGNDT")) - . ; - . ; next review due date - . S @DGPRF@(DGPFTCNT,"REVIEWDT")=$G(DGPFA("REVIEWDT")) - . ; - . ; record flag name - . S @DGPRF@(DGPFTCNT,"FLAG")=$G(DGPFA("FLAG")) - . ; - . ; record flag type - . S @DGPRF@(DGPFTCNT,"FLAGTYPE")=$G(DGPFLAG("TYPE")) - . ; - . ; category of flag - I (NATIONAL) or II (LOCAL) - . S DGCAT=$S($G(DGPFA("FLAG"))["26.15":"I (NATIONAL)",1:"II (LOCAL)") - . S @DGPRF@(DGPFTCNT,"CATEGORY")=DGCAT_U_DGCAT - . ; - . ; owner site - . S @DGPRF@(DGPFTCNT,"OWNER")=$G(DGPFA("OWNER")) - . ; - . ; originating site - . S @DGPRF@(DGPFTCNT,"ORIGSITE")=$G(DGPFA("ORIGSITE")) - . ; - . ; narrative - . I '$D(DGPFA("NARR",1,0)) D Q ;should never happen - but - - . . S @DGPRF@(DGPFTCNT,"NARR",1,0)="No Narrative Text" - . ; - . M @DGPRF@(DGPFTCNT,"NARR")=DGPFA("NARR") - ; - ; Re-Sort Active flags by category & alpha flag name - I +$G(DGPFTCNT)>1 D SORT^DGPFUT2(.@DGPRF) - ; - Q DGPFTCNT - ; -PRFQRY(DGDFN) ;query the CMOR for all patient record flag assignments - ; This function queries a given patient's Coordinated Master of Record - ; (CMOR) site to retrieve all patient record flag assignments for the - ; patient. The function will only succeed when the QRY HL7 interface - ; is enabled, the patient has a national Integrated Control Number - ; (ICN), the patient's CMOR is not the local site and the HL7 query - ; receives an ACK from the CMOR site. - ; - ; Input: - ; DGDFN - pointer to patient in PATIENT (#2) file - ; - ; Output: - ; Function value - 1 on success, 0 on failure - ; - N DGRSLT - N DGQRY - ; - S DGRSLT=0 - ; - S DGQRY=+$$QRYON^DGPFPARM() - I DGQRY D - . S DGRSLT=$$SNDQRY^DGPFHLS(DGDFN,DGQRY) - ; - Q DGRSLT - ; -DISPPRF(DGDFN) ;display active patient record flag assignments - ; This procedure performs a lookup for active patient record flag - ; assignments for a given patient and formats the assignment data for - ; roll-and-scroll display. - ; - ; Input: - ; DGDFN - pointer to patient in PATIENT (#2) file - ; - ; Output: - ; none - ; - Q:'$D(XQY0) - Q:$P(XQY0,U)="DGPF RECORD FLAG ASSIGNMENT" - ; - ;protect Kernel IO variables - N IOBM,IOBOFF,IOBON,IOEDEOP,IOINHI,IOINORM,IORC,IORVOFF,IORVON - N IOSC,IOSGRO,IOSTBM,IOTM,IOUOFF,IOUON - ; - ;protect ListMan variables - N VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCC,VALMCNT,VALMCOFF,VALMCON - N VALMDDF,VALMDN,VALMEVL,VALMHDR,VALMIOXY,VALMKEY,VALMLFT,VALMLST - N VALMMENU,VALMPGE,VALMSGR,VALMUP,VALMWD - ; - ;protect Unwinder variables - N ORU,ORUDA,ORUER,ORUFD,ORUFG,ORUSB,ORUSQ,ORUSV,ORUT,ORUW,ORUX - N XQORM - ; - ; protect original Listman VALM DATA global - K ^TMP($J,"DGPFVALM DATA") - M ^TMP($J,"DGPFVALM DATA")=^TMP("VALM DATA",$J) - ; - D DISPPRF^DGPFUT1(DGDFN) - ; - ; restore original Listman VALM DATA global - M ^TMP("VALM DATA",$J)=^TMP($J,"DGPFVALM DATA") - ; - K ^TMP($J,"DGPFVALM DATA") - Q diff -auBN ./r1/DGPFBGR.m ./r2/r/DGPFBGR.m --- ./r1/DGPFBGR.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFBGR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,207 +0,0 @@ -DGPFBGR ;ALB/RPM - PRF BACKGROUND PROCESSING DRIVER ; 4/28/03 3:24pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q ;no direct entry - ; -EN ;entry point for PRF background processing - ; - Q:'$$ON^DGPFPARM() ;software must be active - ; - D NOTIFY($$NOW^XLFDT()) ;send review notification - D REXMIT^DGPFHLRT ;retransmit rejected HL7 update messages - Q - ; -NOTIFY(DGDATE) ;Send notification message for pending Patient Record Flag - ;Assignment reviews. - ; - ; Input: - ; DGDATE - (optional) notification date requested in FM format, - ; defaults to now ($$NOW^XLFDT()) - ; - ; Output: - ; none - ; - N DGAIEN ;pointer to PRF ASSIGNMENT (#26.13) file - N DGDFN ;pointer to patient in PATIENT (#2) file - N DGDEM ;patient demographics array - N DGDOB ;patient date of birth - N DGFLG ;flag data array - N DGLIST ;closed root array list of patient IENs in a mail group - N DGMSGTXT ;closed root of mail message text - N DGNAME ;patient name - N DGNDT ;notification date - N DGPFA ;assignment data array - N DGMGROUP ;review mail group - N DGSSN ;patient social security number - ; - S DGLIST=$NA(^TMP("DGPFREV",$J)) - K @DGLIST - ; - S DGMSGTXT=$NA(^TMP("DGPFMSG",$J)) - K @DGMSGTXT - ; - I '+$G(DGDATE) S DGDATE=$$NOW^XLFDT() - ; - S DGNDT=0 - F S DGNDT=$O(^DGPF(26.13,"ANDAT",DGNDT)) Q:('DGNDT!(DGNDT>DGDATE)) D - . S DGAIEN=0 - . F S DGAIEN=$O(^DGPF(26.13,"ANDAT",DGNDT,DGAIEN)) Q:'DGAIEN D - . . N DGPFA,DGDEM,DGFLG - . . ; - . . ;get assignment record - . . Q:'$$GETASGN^DGPFAA(DGAIEN,.DGPFA) - . . ; - . . ;retrieve pointer to patient record in PATIENT (#2) file - . . S DGDFN=$P($G(DGPFA("DFN")),U,1) - . . Q:'DGDFN - . . ; - . . ;retrieve patient demographics - . . Q:'$$GETPAT^DGPFUT2(DGDFN,.DGDEM) - . . S DGNAME=$G(DGDEM("NAME")) - . . S DGSSN=$G(DGDEM("SSN")) - . . S DGDOB=$G(DGDEM("DOB")) - . . ; - . . ;retrieve review date - . . S DGREVDT=$P($G(DGPFA("REVIEWDT")),U,1) - . . Q:'DGREVDT - . . ; - . . ;get flag review criteria, notice days and review mail group - . . Q:'$$GETFLAG^DGPFUT1($P($G(DGPFA("FLAG")),U,1),.DGFLG) - . . ; - . . ;retrieve review mail group - . . S DGMGROUP=$P($G(DGFLG("REVGRP")),U,2) - . . Q:(DGMGROUP']"") - . . ; - . . ;build list - . . S @DGLIST@(DGMGROUP,DGAIEN)=DGNAME_U_DGSSN_U_DGDOB_U_$P(DGPFA("FLAG"),U,2)_U_DGREVDT - . . ; - . . ;remove notification index entry - . . K ^DGPF(26.13,"ANDAT",DGNDT,DGAIEN) - ; - ;build and send the message for each mail group - S DGMGROUP="" - F S DGMGROUP=$O(@DGLIST@(DGMGROUP)) Q:(DGMGROUP="") D - . I $$BLDMSG(DGMGROUP,DGLIST,DGMSGTXT) D SEND(DGMGROUP,DGMSGTXT) - . K @DGMSGTXT - ; - ;cleanup - K @DGLIST - ; - Q - ; -BLDMSG(DGMGROUP,DGLIST,DGXMTXT) ;buld MailMan message array - ; - ; Input: - ; DGMGROUP - mail group name - ; DGLIST - closed root array of assignment IENs by mail group - ; - ; Output: - ; DGXMTXT - array of MailMan text lines - ; - N DGDOB ;formatted date of birth - N DGFLAG ;formatted flag name - N DGLIN ;line counter - N DGNAME ;formatted patient name - N DGMAX ;maximum line length - N DGREC ;contents of a single node of the DGLIST array - N DGREVDT ;review date - N DGSITE ;results of VASITE call - N DGSSN ;formatted social security number - ; - S DGLIN=0 - S DGMAX=78 - S DGSITE=$$SITE^VASITE() - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE($$CJ^XLFSTR("* * * * PRF ASSIGNMENT REVIEW NOTIFICATION * * * *",78," "),0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("The following Patient Record Flag Assignments are due for review for continuing appropriateness:",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE($$LJ^XLFSTR("Patient Name",22," ")_$$LJ^XLFSTR("SSN",11," ")_$$LJ^XLFSTR("DOB",10," ")_$$LJ^XLFSTR("Flag Name",22," ")_"Review Date",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE($$REPEAT^XLFSTR("-",DGMAX),0,DGMAX,.DGLIN,DGXMTXT) - ; - S DGAIEN=0,DGCNT=0 - F S DGAIEN=$O(@DGLIST@(DGMGROUP,DGAIEN)) Q:'DGAIEN D - . ;record description: patient_name^SSN^DOB^flag_name^review_date - . S DGREC=@DGLIST@(DGMGROUP,DGAIEN) - . ; - . ;format the fields - . S DGNAME=$$LJ^XLFSTR($E($P(DGREC,U,1),1,20),22," ") - . S DGSSN=$$LJ^XLFSTR($P(DGREC,U,2),11," ") - . S DGDOB=$$LJ^XLFSTR($$FMTE^XLFDT($P(DGREC,U,3),"5D"),10," ") - . S DGFLAG=$$LJ^XLFSTR($E($P(DGREC,U,4),1,20),22," ") - . S DGREVDT=$$FMTE^XLFDT($P(DGREC,U,5),"5D") - . ; - . ;add the line - . D ADDLINE(DGNAME_DGSSN_DGDOB_DGFLAG_DGREVDT,0,DGMAX,.DGLIN,DGXMTXT) - . D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - . ; - . ;success - . S DGCNT=DGCNT+1 - ; - Q DGCNT - ; -ADDLINE(DGTEXT,DGINDENT,DGMAXLEN,DGCNT,DGXMTXT) ;add text line to message array - ; - ; Input: - ; DGTEXT - text string - ; DGINDENT - number of spaces to insert at start of line - ; DGMAXLEN - maximum desired line length (default: 60) - ; DGCNT - line number passed by reference - ; - ; Output: - ; DGXMTXT - array of text strings - ; - N DGAVAIL ;available space for text - N DGLINE ;truncated text - N DGLOC ;location of space character - N DGPAD ;space indent - ; - S DGTEXT=$G(DGTEXT) - S DGINDENT=+$G(DGINDENT) - S DGMAXLEN=+$G(DGMAXLEN) - S:'DGMAXLEN DGMAXLEN=60 - I DGINDENT>(DGMAXLEN-1) S DGINDENT=0 - S DGCNT=$G(DGCNT,0) ;default to 0 - ; - S DGPAD=$$REPEAT^XLFSTR(" ",DGINDENT) - ; - ;determine availaible space for text - S DGAVAIL=(DGMAXLEN-DGINDENT) - F D Q:('$L(DGTEXT)) - . ; - . ;find potential line break - . S DGLOC=$L($E(DGTEXT,1,DGAVAIL)," ") - . ; - . ;break a line that is too long when it has potential line breaks - . I $L(DGTEXT)>DGAVAIL,DGLOC D - . . S DGLINE=$P(DGTEXT," ",1,$S(DGLOC>1:DGLOC-1,1:1)) - . . S DGTEXT=$P(DGTEXT," ",$S(DGLOC>1:DGLOC,1:DGLOC+1),$L(DGTEXT," ")) - . E D - . . S DGLINE=DGTEXT,DGTEXT="" - . ; - . S DGCNT=DGCNT+1 - . S @DGXMTXT@(DGCNT)=DGPAD_DGLINE - Q - ; -SEND(DGGROUP,DGXMTXT) ;send the MailMan message - ; - ; Input: - ; DGGROUP - mail group name - ; DGXMTXT - name of message text array in closed format - ; - ; Output: - ; none - ; - N DIFROM ;protect FM package - N XMDUZ ;sender - N XMSUB ;message subject - N XMTEXT ;name of message text array in open format - N XMY ;recipient array - N XMZ ;returned message number - ; - S XMDUZ="Patient Record Flag Module" - S XMSUB="PRF ASSIGNMENT REVIEW NOTIFICATION" - S XMTEXT=$$OREF^DILF(DGXMTXT) - S XMY("G."_DGGROUP)="" - D ^XMD - Q diff -auBN ./r1/DGPFDD.m ./r2/r/DGPFDD.m --- ./r1/DGPFDD.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFDD.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,99 +0,0 @@ -DGPFDD ;ALB/RPM - PRF DATA DICTIONARY UTILITIES ; 02/04/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q ;No direct entry - ; -INACT(DGIEN,DGSTAT,DGFILE,DGUSER) ;Inactivate flag trigger - ; This procedure is used as a trigger that is fired when the - ; STATUS (#.02) field of a record in either the PRF LOCAL FLAG (#26.11) - ; file or PRF NATIONAL FLAG (#26.15) file is changed from Active to - ; Inactive. The trigger will inactivate all Patient Record - ; Flag assignments associated with the inactivated Flag. - ; - ; Input: - ; DGIEN - IEN of entry in PRF LOCAL FLAG file or PRF NATIONAL - ; FLAG file - ; DGSTAT - Flag Status - ; DGFILE - PRF LOCAL FLAG file number (26.11) or PRF NATIONAL - ; FLAG file number (26.15) - ; DGUSER - IEN of user in NEW PERSON file - ; - ; Output: none - ; - N DGAIEN ;assignment record IEN - N DGSUB ;variable ptr index subscript - ; - Q:('$G(DGIEN)) - Q:($G(DGSTAT)'=0) - Q:(($G(DGFILE)'=26.11)&($G(DGFILE)'=26.15)) - Q:('$G(DGUSER)) - ; - S DGSUB=DGIEN_";DGPF("_DGFILE_"," - S DGAIEN=0 - F S DGAIEN=$O(^DGPF(26.13,"ASTAT",1,DGSUB,DGAIEN)) Q:'DGAIEN D - . N DGPFA ;assignment data array - . N DGPFAH ;assignment history data array - . I $$GETASGN^DGPFAA(DGAIEN,.DGPFA) D - . . Q:($P($G(DGPFA("STATUS")),U,1)=0) - . . S DGPFA("STATUS")=0 - . . S DGPFA("REVIEWDT")="" - . . S DGPFAH("ACTION")=3 - . . S DGPFAH("ASSIGNDT")=$$NOW^XLFDT() - . . S DGPFAH("ENTERBY")=DGUSER - . . S DGPFAH("APPRVBY")=DGUSER - . . S DGPFAH("COMMENT",1,0)="Assignment Inactivated automatically due to Flag Inactivation." - . . I $$STOALL^DGPFAA(.DGPFA,.DGPFAH) - Q - ; -PIHELP ;Executable help for PRINCIPAL INVESTIGATOR(S) (#.01) sub-field of - ;PRINCIPLE INVESTIGATOR(S) (#2) multiple field of PRF LOCAL FLAG - ;(#26.11) file. - ; - ;This sub-routine displays individuals selected as a principal - ;investigator for a research type patient record flag. - ; - ; Input: - ; DGLKUP - (required) array of principal investigators subscripted - ; by the pointer to the NEW PERSON (#200) file and the - ; pointer to the PRF LOCAL FLAG (#26.11) file. - ; Example: DGLKUP(11744,6)="" - ; - ; Output: - ; none - ; - Q:'$D(DGLKUP) - ; - N DGCNT - N DGIEN - N DGNAMES - ; - S DGIEN=0,DGCNT=0 - F S DGIEN=$O(DGLKUP(DGIEN)) Q:'DGIEN D - . S DGCNT=DGCNT+1 - . S DGNAMES(DGCNT)=$$EXTERNAL^DILFD(26.112,.01,"F",DGIEN) - S DGNAMES(DGCNT+1)="" ;add a blank line - D EN^DDIOL(.DGNAMES) - Q - ; -COS(DGAPRV) ;transform POSTMASTER to CHIEF OF STAFF - ;This output transform converts the internal field value of .5 - ;(POSTMASTER) to CHIEF OF STAFF. - ; - ; Supported DBIA #10060 - This supported DBIA permits FileMan reads - ; on all fields of the NEW PERSON (#200) file. - ; - ; Input: - ; DGAPRV - internal value of PRF ASSIGNMENT HISTORY (#26.14) file - ; APPROVED BY (#.05) field - ; - ; Output: - ; Function Value - Returns "CHIEF OF STAFF" when input value is .5 or - ; external value from NAME (.01) field of the NEW - ; PERSON (#200) file on success. - ; Returns null ("") on failure. - ; - N DGERR - ; - Q:(+$G(DGAPRV)'>0) "" - ; - Q $S(DGAPRV=.5:"CHIEF OF STAFF",1:$$GET1^DIQ(200,DGAPRV_",",.01,"","","DGERR")) diff -auBN ./r1/DGPFHLL.m ./r2/r/DGPFHLL.m --- ./r1/DGPFHLL.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,101 +0,0 @@ -DGPFHLL ;ALB/RPM - PRF HL7 TRANSMISSION LOG API'S ; 3/6/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q - ; -GETLOG(DGLIEN,DGPFL) ;retrieve a transmission log record - ; - ; Input: - ; DGLIEN - IEN for PRF HL7 TRANSMISSION LOG (#26.17) file - ; - ; Output: - ; Function value - 1 on success, 0 on failure - ; DGPFL - array of transmission data fields - ; Subscript Field# - ; ----------------- ------ - ; "MSGID" .01 - ; "ASGNHIST" .02 - ; "TRANSDT" .03 - ; "MSGSTAT" .04 - ; "SITE" .05 - ; "ACKDT" .06 - ; - N DGIENS ;IEN string for DIQ - N DGFLDS ;results array for DIQ - N DGERR ;error arrary for DIQ - N DGRSLT - ; - S DGRSLT=0 - I $G(DGLIEN)>0,$D(^DGPF(26.17,DGLIEN)) D - . S DGIENS=DGLIEN_"," - . D GETS^DIQ(26.17,DGIENS,"*","IEZ","DGFLDS","DGERR") - . Q:$D(DGERR) - . S DGRSLT=1 - . S DGPFL("MSGID")=$G(DGFLDS(26.17,DGIENS,.01,"I"))_U_$G(DGFLDS(26.17,DGIENS,.01,"E")) - . S DGPFL("ASGNHIST")=$G(DGFLDS(26.17,DGIENS,.02,"I"))_U_$G(DGFLDS(26.17,DGIENS,.02,"E")) - . S DGPFL("TRANSDT")=$G(DGFLDS(26.17,DGIENS,.03,"I"))_U_$G(DGFLDS(26.17,DGIENS,.03,"E")) - . S DGPFL("MSGSTAT")=$G(DGFLDS(26.17,DGIENS,.04,"I"))_U_$G(DGFLDS(26.17,DGIENS,.04,"E")) - . S DGPFL("SITE")=$G(DGFLDS(26.17,DGIENS,.05,"I"))_U_$G(DGFLDS(26.17,DGIENS,.05,"E")) - . S DGPFL("ACKDT")=$G(DGFLDS(26.17,DGIENS,.06,"I"))_U_$G(DGFLDS(26.17,DGIENS,.06,"E")) - ; - Q DGRSLT - ; -FNDLOG(DGMSGID) ;find and return the record number for a given HL7 Message ID - ; - ; Input: - ; DGMSGID - HL7 Message ID - ; - ; Output: - ; Function value - IEN of PRF HL7 TRANSMISSION LOG (#26.17) file on - ; success, 0 on failure - ; - N DGIEN - ; - I +$G(DGMSGID) D - . S DGIEN=$O(^DGPF(26.17,"B",DGMSGID,0)) - Q $S($G(DGIEN)>0:DGIEN,1:0) - ; -STOXMIT(DGHIEN,DGMSGID,DGINST,DGERR) ;store the transmission log data - ; - ; Input: - ; DGHIEN - pointer to PRF ASSIGNMENT HISTORY (#26.14) file - ; DGMSGID - message ID from VistA HL7 - ; DGINST - pointer to the INSTITUTION (#4) file - ; - ; Output: - ; DGERR - undefined on success, error message on failure - ; - N DGFDA ;fda array - N DGFDAIEN ;ien array from DIE - ; - I +$G(DGHIEN),$D(^DGPF(26.14,DGHIEN)),$D(DGMSGID),+$G(DGINST),$D(^DIC(4,DGINST)) D - . N DGFDAIEN - . Q:$$FNDLOG^DGPFHLL(DGMSGID) - . S DGFDA(26.17,"+1,",.01)=DGMSGID - . S DGFDA(26.17,"+1,",.02)=DGHIEN - . S DGFDA(26.17,"+1,",.03)=$$NOW^XLFDT() - . S DGFDA(26.17,"+1,",.04)="T" - . S DGFDA(26.17,"+1,",.05)=DGINST - . D UPDATE^DIE("","DGFDA","DGFDAIEN","DGERR") - Q - ; -STOSTAT(DGLIEN,DGSTAT) ;update the HL7 transmission status - ; - ; Input: - ; DGLIEN - IEN of PRF HL7 TRANSMISSION LOG (#26.17) file - ; DGSTAT - internal Status value ("T","A","RJ","M","RT") - ; - ; Output: - ; none - ; - N DGERR ;filer errors - N DGFDA ;fda array - N DGLIENS ;iens string - ; - I +$G(DGLIEN),$D(^DGPF(26.17,DGLIEN)),$G(DGSTAT)]"" D - . Q:'$$TESTVAL^DGPFUT(26.17,.04,DGSTAT) - . S DGLIENS=DGLIEN_"," - . S DGFDA(26.17,DGLIENS,.04)=DGSTAT - . S DGFDA(26.17,DGLIENS,.06)=$$NOW^XLFDT() - . D FILE^DIE("","DGFDA","DGERR") - Q diff -auBN ./r1/DGPFHLQ1.m ./r2/r/DGPFHLQ1.m --- ./r1/DGPFHLQ1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLQ1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,105 +0,0 @@ -DGPFHLQ1 ;ALB/RPM - PRF HL7 BUILD QRD SEGMENT ; 02/02/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ; -QRD(DGQID,DGWHO,DGFLD,DGHL) ;QRD HL7 segment API - ;This function wraps the data retrieval and segment creation APIs and - ;returns a formatted QRD segment. - ; - ; Input: - ; DGQID - (required) Query ID (DFN) - ; DGWHO - (required) Who Subject Filter (Integrated Control Number) - ; DGFLD - (optional) List of comma-separated fields (sequence #'s) - ; to include. Defaults to all required fields (1-4,7-10). - ; DGHL - VistA HL7 environment array - ; - ; Output: - ; Function Value - QRD segment on success, "" on failure - ; - N DGQRD - N DGVAL - ; - S DGQRD="" - I $G(DGQID)>0,$G(DGWHO)]"" D - . S DGFLD=$$CKSTR^DGPFHLUT("1,2,3,4,7,8,9,10",DGFLD) ;validate fields - . S DGFLD=","_DGFLD_"," - . I $$QRDVAL(DGFLD,DGQID,DGWHO,.DGVAL) D - . . S DGQRD=$$BLDSEG^DGPFHLUT("QRD",.DGVAL,.DGHL) - Q DGQRD - ; -QRDVAL(DGFLD,DGQID,DGWHO,DGVAL) ;build QRD value array - ; - ; Input: - ; DGFLD - Fields string - ; DGQID - Query ID (DFN) - ; DGWHO - Who Subject filter (ICN) - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; DGVAL - QRD field array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component - ; - N DGRSLT - ; - S DGRSLT=0 - I $G(DGQID)>0,$G(DGWHO)]"",$G(DGFLD)]"" D - . ; - . ; seq 1 (required) Query Date/Time - . I DGFLD[",1," D Q:(+DGVAL(1)'>0) - . . S DGVAL(1)=$$FMTHL7^XLFDT($$NOW^XLFDT()) - . ; - . ; seq 2 (required) Query Format Code - . I DGFLD[",2," D - . . S DGVAL(2)="R" ;always "R"ecord - . ; - . ; seq 3 (required) Query Priority - . I DGFLD[",3," D - . . S DGVAL(3)="I" ;always "I"mmediate - . ; - . ; seq 4 (required) Query ID - . I DGFLD[",4," D - . . S DGVAL(4)=DGQID - . ; - . ; seq 5 (optional) Deferred Response Type - . I DGFLD[",5," D - . . S DGVAL(5)="" - . ; - . ; seq 6 (optional) Deferred Response Date/Time - . I DGFLD[",6," D - . . S DGVAL(6)="" - . ; - . ; seq 7 (required) Quantity Limited Request - . I DGFLD[",7," D - . . S DGVAL(7,1,1)=10 - . . S DGVAL(7,1,2)="RD" ;records - . ; - . ; seq 8 (required) Who Subject Filter - . I DGFLD[",8," D - . . S DGVAL(8,1,1)=DGWHO - . . S DGVAL(8,1,9,1)="USVHA" - . . S DGVAL(8,1,9,2)="" - . . S DGVAL(8,1,9,3)="L" - . ; - . ; seq 9 (required) What Subject Filter - . I DGFLD[",9," D - . . S DGVAL(9,1,1)="OTH" - . . S DGVAL(9,1,2)="Other" - . . S DGVAL(9,1,3)="HL0048" - . ; - . ; seq 10 (required) What Dept. Data Code - . I DGFLD[",10," D - . . S DGVAL(10,1,1)="PRFA" - . . S DGVAL(10,1,2)="Patient Record Flag Assignments" - . . S DGVAL(10,1,3)="L" - . ; - . ; seq 11 (optional) What Data Code Value Qual. - . I DGFLD[",11," D - . . S DGVAL(11)="" - . ; - . ; seq 12 (optional) Query Results Level - . I DGFLD[",12," D - . . S DGVAL(12)="" - . ; - . S DGRSLT=1 - I 'DGRSLT K DGVAL - Q DGRSLT diff -auBN ./r1/DGPFHLQ2.m ./r2/r/DGPFHLQ2.m --- ./r1/DGPFHLQ2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLQ2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,85 +0,0 @@ -DGPFHLQ2 ;ALB/RPM - PRF HL7 BUILD QRF SEGMENT ; 02/02/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ; -QRF(DGSSN,DGDOB,DGFLD,DGHL) ;QRF HL7 segment API - ;This function wraps the data retrieval and segment crateion APIs and - ;returns a formatted QRF segment. - ; - ; Input: - ; DGSSN - (required) Patient's Social Security Number - ; DGDOB - (required) Patient's Date of Birth in FileMan format - ; DGFLD - (optional) List of comma-separated fields (sequence #'s) - ; to include. Defaults to all required fields (1). - ; DGHL - VistA HL7 environment array - ; - ; Output : - ; Function Value - QRF segment on success, "" on failure - ; - N DGQRF - N DGVAL - ; - S DGQRF="" - I $G(DGSSN),$G(DGDOB) D - . S DGFLD=$$CKSTR^DGPFHLUT("1",DGFLD) ;validate field string - . S DGFLD=","_DGFLD_"," - . I $$QRFVAL(DGFLD,DGSSN,DGDOB,.DGVAL) D - . . S DGQRF=$$BLDSEG^DGPFHLUT("QRF",.DGVAL,.DGHL) - Q DGQRF - ; -QRFVAL(DGFLD,DGSSN,DGDOB,DGVAL) ;build QRF field value array - ; - ; Input: - ; DGFLD - (required) Fields string - ; DGSSN - (required) Patient's Social Security Number - ; DGDOB - (required) Patient's Date of Birth - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; DGVAL - QRF field array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component] - ; - N DGRSLT - ; - S DGRSLT=0 - I $G(DGFLD)]"",$G(DGSSN),$G(DGDOB) D - . ; - . ; seq 1 (required) Where Subj Filter - . I DGFLD[",1," D - . . S DGVAL(1)="PRF" - . ; - . ; seq 2 (optional) When Data Start Date/Time - . I DGFLD[",2," D - . . S DGVAL(2)="" - . ; - . ; seq 3 (optional) When Data End Date/Time - . I DGFLD[",3," D - . . S DGVAL(3)="" - . ; - . ; seq 4 (optional) What User Qualifier - . I DGFLD[",4," D - . . S DGVAL(4)=DGSSN - . ; - . ; seq 5 (optional) Other Query Subj Filter - . I DGFLD[",5," D - . . S DGVAL(5)=$$FMTHL7^XLFDT(DGDOB) - . ; - . ;- seq 6 (optional) Which Date/Time Qualifier - . I DGFLD[",6," D - . . S DGVAL(6)="" - . ; - . ; seq 7 (optional) Which Date/Time Status Qualifier - . I DGFLD[",7," D - . . S DGVAL(7)="" - . ; - . ; seq 8 (optional) Date/Time Selection Qualifier - . I DGFLD[",8," D - . . S DGVAL(8)="" - . ; - . ; seq 9 (optional) When Quantity/Timing Qualifier - . I DGFLD[",9," D - . . S DGVAL(9)="" - . ; - . S DGRSLT=1 - I 'DGRSLT K DGVAL - Q DGRSLT diff -auBN ./r1/DGPFHLQ3.m ./r2/r/DGPFHLQ3.m --- ./r1/DGPFHLQ3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLQ3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,243 +0,0 @@ -DGPFHLQ3 ;ALB/RPM - PRF HL7 QRY/ORF PROCESSING ; 3/13/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -PARSQRY(DGWRK,DGHL,DGQRY,DGPFERR) ;Parse QRY~R02 Message/Segments - ; - ; Input: - ; DGWRK - Closed root global reference - ; DGHL - VistA HL7 environment array - ; - ; Output: - ; DGQRY - Patient lookup components array - ; DGPFERR - Undefined on success, ERR segment data array on failure - ; Format: DGPFERR(seg_id,sequence,fld_pos)=error_code - ; - N DGRSLT ;result from CHK^DIE - N DGFS ;field separator - N DGCS ;component separator - N DGRS ;repetition separator - N DGSS ;sub-component separator - N DGCURLIN ;current segment line - N DGSEG ;segment field data array - N DGERR ;error processing array - ; - S DGFS=DGHL("FS") - S DGCS=$E(DGHL("ECH"),1) - S DGRS=$E(DGHL("ECH"),2) - S DGSS=$E(DGHL("ECH"),4) - S DGCURLIN=0 - ; - ;loop through the message segments and retrieve the field data - F D Q:'DGCURLIN - . N DGSEG - . S DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG) - . Q:'DGCURLIN - . D @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGSS,.DGQRY,.DGPFERR)") - Q - ; -PARSORF(DGWRK,DGHL,DGORF,DGMSG) ;Parse ORF~R04 Message/Segments - ; - ; Input: - ; DGWRK - Closed root work global reference - ; DGHL - HL7 environment array - ; - ; Output: - ; DGORF - array of ORF results - ; OBRsetID,assigndt,"ACTION" - ; OBRsetID,assigndt,"COMMENT",line# - ; OBRsetID,"FLAG" - ; OBRsetID,"NARR",line# - ; OBRsetID,"OWNER" - ; "ACKCODE" - acknowledgment code ("AA","AE","AR") - ; "ICN" - patient's Integrated Control Number - ; "MSGDTM" - message creation date/time in FileMan format - ; "MSGID" - - ; "QID" - query ID (DFN) - ; "RCVFAC" - receiving facility - ; "SNDFAC" - sending facility - ; - ; DGMSG - undefined on success, array of MailMan text on failure - ; - N DGFS - N DGCS - N DGRS - N DGSS - N DGCURLIN - ; - S DGFS=DGHL("FS") - S DGCS=$E(DGHL("ECH"),1) - S DGRS=$E(DGHL("ECH"),2) - S DGSS=$E(DGHL("ECH"),4) - S DGCURLIN=0 - ; - ;loop through the message segments and retrieve the field data - F D Q:'DGCURLIN - . N DGSEG - . S DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG) - . Q:'DGCURLIN - . D @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGSS,.DGORF,.DGMSG)") - Q - ; -MSH(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ; - ; - ; Input: - ; DGSEG - MSH segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGORF - array of ORF results - ; "SNDFAC" - sending facility - ; "RCVFAC" - receiving facility - ; "MSGDTM" - message creation date/time in FileMan format - ; DGERR - undefined on success, error array on failure - ; - D MSH^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGORF,.DGERR) - Q - ; -MSA(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ; - ; - ; Input: - ; DGSEG - MSH segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGORF - array of ORF results - ; "ACKCODE" - Acknowledgment code - ; "MSGID" - Message Control ID of the message being ACK'ed - ; DGERR - undefined on success, error array on failure - ; - D MSA^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGORF,.DGERR) - Q - ; -ERR(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ; - ; - ; Input: - ; DGSEG - MSH segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGORF - array of ORF results - ; DGERR - undefined on success, error array on failure - ; - D ERR^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGORF,.DGERR) - Q - ; -QRD(DGSEG,DGCS,DGRS,DGSS,DGQRY,DGERR) ; - ; - ; Input: - ; DGSEG - MSH segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGQRY("ICN") - Patient's Integrated Control Number - ; DGQRY("QID") - Query ID - ; DGERR - undefined on success, error array on failure - ; format: DGERR(seg_id,sequence,fld_pos)=error code - ; - S DGQRY("QID")=$G(DGSEG(4)) - S DGQRY("ICN")=+$P($G(DGSEG(8)),DGCS,1) - I DGQRY("ICN")="" D - . S DGERR("QRD",1,8)="NM" - Q - ; -QRF(DGSEG,DGCS,DGRS,DGSS,DGQRY,DGERR) ; - ; - ; Input: - ; DGSEG - PID segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGQRY("SSN") - Patient's Social Security Number - ; DGQRY("DOB") - Patient's Date of Birth - ; DGERR - undefined on success, error array on failure - ; format: DGERR(seg_id,sequence,fld_pos)=error code - ; - S DGQRY("SSN")=$G(DGSEG(4)) - I DGQRY("SSN")="" S DGERR("QRF",1,4)="NM" ;no match - ; - S DGQRY("DOB")=+$$HL7TFM^XLFDT($G(DGSEG(5))) - I DGQRY("DOB")'>0 S DGERR("QRF",1,5)="NM" ;no match - Q - ; -OBR(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ; - ; - ; Input: - ; DGSEG - OBR segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGORF(setid,"FLAG") - FLAG NAME (.02) field, file #26.13 - ; DGORF(setid,"OWNER") - OWNER SITE (.04) field, file #26.13 - ; DGORF(setid,"ORIGSITE") - ORIGINATING SITE (.05) field, file #26.13 - ; DGORF("SETID") - OBR segment Set ID - ; DGERR - undefined on success, error array on failure - ; format: DGERR(seg_id,sequence,fld_pos)=error code - N DGSETID ;OBR segment Set ID - ; - S (DGORF("SETID"),DGSETID)=+$G(DGSEG(1)) - I DGSETID>0 D - . S DGORF(DGSETID,"FLAG")=$P($G(DGSEG(4)),DGCS,1)_";DGPF(26.15," - . S DGORF(DGSETID,"OWNER")=$$IEN^XUAF4($G(DGSEG(20))) - . S DGORF(DGSETID,"ORIGSITE")=$$IEN^XUAF4($G(DGSEG(21))) - Q - ; -OBX(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ; - ; - ; Input: - ; DGSEG - OBX segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGORF(setid,"NARR",line) - ASSIGNMENT NARRATIVE (1) field, - ; file #26.13 - ; DGORF(setid,assigndt,"ACTION") - ACTION (.03) field, - ; file #26.14 - ; DGORF(setid,assigndt,"COMMENT",line) - HISTORY COMMENTS (1) field, - ; file #26.14 - ; DGERR - undefined on success, error array on failure - ; format: DGERR(seg_id,sequence,fld_pos)=error code - ; - N DGADT ;assignment date - N DGI - N DGLINE ;text line counter - N DGRSLT - N DGSETID ;OBR segment Set ID - ; - S DGSETID=+$G(DGORF("SETID")) - Q:(DGSETID'>0) - ; - ; Narrative Observation Identifier - I $P(DGSEG(3),DGCS,1)="N" D - . S DGLINE=$O(DGORF(DGSETID,"NARR",""),-1) - . F DGI=1:1:$L(DGSEG(5),DGRS) D - . . S DGORF(DGSETID,"NARR",DGLINE+DGI,0)=$P(DGSEG(5),DGRS,DGI) - ; - ; Status Observation Identifier - I $P(DGSEG(3),DGCS,1)="S" D - . S DGADT=$$HL7TFM^XLFDT(DGSEG(14)) - . Q:(+DGADT'>0) - . D CHK^DIE(26.14,.03,,DGSEG(5),.DGRSLT) - . S DGORF(DGSETID,DGADT,"ACTION")=+DGRSLT - ; - ; Comment Observation Identifier - I $P(DGSEG(3),DGCS,1)="C" D - . S DGADT=$$HL7TFM^XLFDT(DGSEG(14)) - . Q:(+DGADT'>0) - . S DGLINE=$O(DGORF(DGSETID,DGADT,"COMMENT",""),-1) - . F DGI=1:1:$L(DGSEG(5),DGRS) D - . . S DGORF(DGSETID,DGADT,"COMMENT",DGLINE+DGI,0)=$P(DGSEG(5),DGRS,DGI) - Q diff -auBN ./r1/DGPFHLQ.m ./r2/r/DGPFHLQ.m --- ./r1/DGPFHLQ.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLQ.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,194 +0,0 @@ -DGPFHLQ ;ALB/RPM - PRF HL7 QRY/ORF PROCESSING ; 1/23/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -BLDQRY(DGDFN,DGICN,DGROOT,DGHL) ;Build QRY~R02 Message/Segments - ; - ; Input: - ; DGDFN - (required) Pointer to patient in PATIENT (#2) file - ; DGICN - (required) Patient's Integrated Control Number - ; DGROOT - (required) Closed root array or global name for segment - ; storage. - ; DGHL - (required) VistA HL7 environment array - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; DGROOT - array of HL7 segments on success - ; - N DGCNT ;segment counter - N DGDEM ;pt. demographics array - N DGQRD ;formatted QRD segment - N DGQRF ;formatted QRF segment - N DGRSLT ;function value - N DGSTR ;field string - ; - S DGRSLT=0 - S DGCNT=0 - ; - I +$G(DGDFN),+$G(DGICN),$G(DGROOT)]"" D - . ; - . ;get patient demographics - . Q:'$$GETPAT^DGPFUT2(DGDFN,.DGDEM) - . ; - . ;build QRD - . S DGSTR="1,2,3,4,7,8,9,10" - . S DGQRD=$$QRD^DGPFHLQ1(DGDFN,DGICN,DGSTR,.DGHL) - . Q:(DGQRD="") - . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGQRD - . ; - . ;build QRF - . S DGSTR="1,4,5" - . S DGQRF=$$QRF^DGPFHLQ2($G(DGDEM("SSN")),$G(DGDEM("DOB")),DGSTR,.DGHL) - . Q:(DGQRF="") - . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGQRF - . ; - . S DGRSLT=1 - Q DGRSLT - ; -BLDORF(DGROOT,DGHL,DGDFN,DGQRY,DGSEGERR,DGQRYERR) ;Build ORF~R04 Message/Segments - ; - ; Input: - ; DGROOT - (required) Segment array - ; DGHL - (required) HL7 environment array - ; DGDFN - (required) Pointer to patient in PATIENT (#2) file - ; DGQRY - (required) Array of parsed QRY data - ; DGSEGERR - (optional) Array of errors encountered during QRY parsing - ; DGQRYERR - (optional) Error encountered during ICN to DFN conversion - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; - N DGACK ;acknowledgment code (i.e. AA, AE) - N DGAIENS ;array of assignment IENS - N DGCNT ;segment counter - N DGI ;generic index - N DGOBROOT ;temporary storage of OBR/OBX segments - N DGRSLT ;function value - N DGSEGSTR ;formatted segment string - N DGSTR ;comma-delimited list of fields to include - ; - S DGRSLT=0 - S DGOBROOT=$NA(^TMP("DGPF OB",$J)) - K @DGOBROOT - ; - I $G(DGROOT)]"",+$G(DGDFN)>0,$D(DGQRY) D - . S DGCNT=0 - . S DGACK=$S($D(DGSEGERR):"AE",$D(DGQRYERR):"AE",1:"AA") - . ; - . ;build OBR/OBX segments for any Category I record flag assignments - . I DGACK="AA",$$GETALL^DGPFAA(DGDFN,.DGAIENS,"",1) D - . . ; - . . ;build and temporarily store OBR/OBX segments - . . Q:$$BLDALLOB(DGOBROOT,.DGAIENS,.DGHL) - . . ; - . . ;if we get here then the data retrieval failed - . . S DGQRYERR="FE" - . . S DGACK="AE" - . . K @DGOBROOT - . ; - . ;build MSA segment - . S DGSTR=$S($D(DGQRYERR):"1,2,6",1:"1,2") - . S DGSEGSTR=$$MSA^DGPFHLU3(DGACK,DGHL("MID"),.DGQRYERR,DGSTR,.DGHL) - . Q:(DGSEGSTR="") - . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR - . ; - . ;build ERR segments for any segment parsing errors - . I $D(DGSEGERR),'$$BLDERR^DGPFHLU4(DGROOT,.DGSEGERR,.DGHL,.DGCNT) Q - . ; - . ;build QRD segment - . S DGSTR="1,2,3,4,7,8,9,10" - . S DGSEGSTR=$$QRD^DGPFHLQ1($G(DGQRY("QID")),$G(DGQRY("ICN")),DGSTR,.DGHL) - . Q:(DGSEGSTR="") - . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR - . ; - . ;move any OBR/OBX segments into the message - . S DGI=0 - . F S DGI=$O(@DGOBROOT@(DGI)) Q:'DGI D - . . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=@DGOBROOT@(DGI) - . ; - . ;success - . S DGRSLT=1 - ; - ;cleanup - K @DGOBROOT - ; - Q DGRSLT - ; -BLDALLOB(DGROOT,DGAIENS,DGHL) ;build all OBRs and OBXs for a patient - ; - ; Input: - ; DGROOT - (required) Closed root array or global name for segment - ; storage. - ; DGAIENS - (required) Array of pointers to PRF ASSIGNMENT (#26.13) file - ; DGHL - (required) VistA HL7 environment array - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; DGROOT - array of HL7 segments on success - ; - N DGAIEN ;single assignment IEN - N DGCNT ;segment counter - N DGHIEN ;single assignment history IEN - N DGHIENS ;array of assignment history IENs - N DGOBRSET ;OBR segment Set ID - N DGOBXOK ;OBX segment creation flag - N DGOBXSET ;OBX segment Set ID - N DGPFA ;assignment data array - N DGPFAH ;assignment history data array - N DGRSLT ;function value - N DGSEGSTR ;formatted segment string - N DGSTR ;comma-delimited list of fields to include - N DGTROOT ;closed root name of text array value - ; - S DGCNT=0 - S DGRSLT=0 - I $G(DGROOT)]"",$D(DGAIENS) D - . S DGAIEN=0 - . S DGOBRSET=0 - . F S DGAIEN=$O(DGAIENS(DGAIEN)) Q:'DGAIEN D - . . N DGHIENS ;array of assignment history IENS - . . N DGPFA ;assignment data array - . . ; - . . ;get assignment details - . . Q:'$$GETASGN^DGPFAA(DGAIEN,.DGPFA) - . . ; - . . ;get last assignment history for narrative observation date - . . Q:'$$GETHIST^DGPFAAH($$GETLAST^DGPFAAH(DGAIEN),.DGPFAH) - . . ; - . . ;build OBR segment for this assignment - . . S DGSTR="1,4,7,20,21" - . . S DGOBRSET=DGOBRSET+1 - . . S DGSEGSTR=$$OBR^DGPFHLU1(DGOBRSET,.DGPFA,.DGPFAH,DGSTR,.DGHL) - . . Q:(DGSEGSTR="") - . . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR - . . ; - . . ;build narrative OBX segment for this assignment - . . S DGOBXSET=0 - . . S DGTROOT="DGPFA(""NARR"")" - . . Q:'$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"N",.DGPFAH,.DGHL,.DGCNT,.DGOBXSET) - . . ; - . . ;get a list of all assignment histories - . . Q:'$$GETALL^DGPFAAH(DGAIEN,.DGHIENS) - . . ; - . . ;loop through each assignment history entry - . . S DGHIEN=0 - . . F S DGHIEN=$O(DGHIENS(DGHIEN)) Q:'DGHIEN D Q:'DGOBXOK - . . . N DGPFAH - . . . S DGOBXOK=0 - . . . ; - . . . ;get single assignment history record - . . . Q:'$$GETHIST^DGPFAAH(DGHIEN,.DGPFAH) - . . . ; - . . . ;build status OBX segment for this history record - . . . S DGSTR="1,2,3,5,11,14" - . . . S DGOBXSET=DGOBXSET+1 - . . . S DGSEGSTR=$$OBX^DGPFHLU2(DGOBXSET,"S","",$P($G(DGPFAH("ACTION")),U,2),.DGPFAH,DGSTR,.DGHL) - . . . Q:(DGSEGSTR="") - . . . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR - . . . ; - . . . ;build review comment OBX segments for this history record - . . . S DGTROOT="DGPFAH(""COMMENT"")" - . . . Q:'$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"C",.DGPFAH,.DGHL,.DGCNT,.DGOBXSET) - . . . S DGOBXOK=1 - . . Q:'DGOBXOK - . . S DGRSLT=1 - Q DGRSLT diff -auBN ./r1/DGPFHLR.m ./r2/r/DGPFHLR.m --- ./r1/DGPFHLR.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,188 +0,0 @@ -DGPFHLR ;ALB/RPM - PRF HL7 RECEIVE DRIVERS ; 6/17/03 1:38pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -RCV ;Receive all message types and route to message specific receiver - ; - ;This procedure is the main driver entry point for receiving all - ;message types (ORU, ACK, QRY and ORF) for patient record flag - ;assignment sharing. - ; - ;All procedures and functions assume that all VistA HL7 environment - ;variables are properly initialized and will produce a fatal error if - ;they are missing. - ; - ;The received message is copied to a temporary work global for - ;processing. The message type is determined from the MSH segment and - ;a receive processing procedure specific to the message type is called. - ;(Ex. ORU~R01 message calls procedure: RCVORU). The specific receive - ;processing procedure calls a message specific parse procedure to - ;validate the message data and return data arrays for storage. If no - ;parse errors are reported during validation, then the data arrays are - ;stored by the receive processing procedure. Control, along with any - ;parse validation errors, is then passed to the message specific send - ;processing procedures to build and transmit the acknowledgment and - ;query results messages. - ; - ; The message specific procedures are as follows: - ; - ; Message Receive Procedure Parse Procedure Send Procedure - ; ------- ----------------- ---------------- -------------- - ; ORU~R01 RCVORU^DGPFHLR PARSORU^DGPFHLU SNDACK^DGPFHLS - ; ACK~R01 RCVACK^DGPFHLR PARSACK^DGPFHLU4 N/A - ; QRY~R02 RCVQRY^DGPFHLR PARSQRY^DGPFHLQ3 SNDORF^DGPFHLS - ; ORF~R04 RCVORF^DGPFHLR PARSORF^DGPFHLQ3 N/A - ; - N DGCNT - N DGMSGTYP - N DGSEG - N DGSEGCNT - N DGWRK - ; - S DGWRK=$NA(^TMP("DGPFHL7",$J)) - K @DGWRK - ; - ;load work global with segments - F DGSEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D - . S DGCNT=0 - . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE - . F S DGCNT=$O(HLNODE(DGCNT)) Q:'DGCNT D - . . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE(DGCNT) - ; - ;get message type from "MSH" - I $$NXTSEG^DGPFHLUT(DGWRK,0,HL("FS"),.DGSEG),$G(DGSEG("TYPE"))="MSH" D - . S DGMSGTYP=$P(DGSEG(9),$E(HL("ECH"),1),1) - . ;HLMTIENS is only required by RCVORU and RCVQRY, thus $GET - . I DGMSGTYP=HL("MTN") D @("RCV"_DGMSGTYP_"(DGWRK,$G(HLMTIENS),.HL)") - ; - ;cleanup - K @DGWRK - Q - ; -RCVORU(DGWRK,DGMIEN,DGHL) ;Receive ORU Message Types (ORU~R01) - ; - ; Input: - ; DGWRK - name of work global containing segments - ; DGMIEN - IEN of message entry in file #773 - ; DGHL - HL environment array - ; - ; Output: - ; none - ; - N DGPFA - N DGPFAH - N DGSEGERR - N DGSTOERR - N DGACKTYP - ; - D PARSORU^DGPFHLU(DGWRK,.DGHL,.DGPFA,.DGPFAH,.DGSEGERR) - ; - D ;drop out of block on failure - . S DGACKTYP="AE" - . Q:$D(DGSEGERR) - . Q:'$$STOHL7^DGPFAA2(.DGPFA,.DGPFAH,.DGSTOERR) - . S DGACKTYP="AA" - ; - D SNDACK^DGPFHLS(DGACKTYP,DGMIEN,.DGHL,.DGSEGERR,.DGSTOERR) - Q - ; -RCVACK(DGWRK,DGMIEN,DGHL) ;Receive ACK Message Types (ACK~R01) - ; - ; Input: - ; DGWRK - name of work global containing segments - ; DGMIEN - IEN of message entry in file #773 - ; DGHL - HL environment array - ; - ; Output: - ; none - ; - N DGACK ;ACK data array - N DGERR ;error array - N DGLIEN ;HL7 transmission log IEN - N DGPFL ;HL7 transmssion log data array - ; - D PARSACK^DGPFHLU4(DGWRK,.DGHL,.DGACK,.DGERR) - I +$G(DGACK("MSGID")) D - . S DGLIEN=$$FNDLOG^DGPFHLL(DGACK("MSGID")) - . Q:'DGLIEN - . I $G(DGACK("ACKCODE"))="AA" D - . . D STOSTAT^DGPFHLL(DGLIEN,"A") - . E D - . . D PROCERR^DGPFHLU5(DGLIEN,.DGACK,.DGERR) - . . D STOSTAT^DGPFHLL(DGLIEN,"RJ") - Q - ; -RCVQRY(DGWRK,DGMIEN,DGHL) ;Receive QRY Message Types (QRY~R02) - ; - ; Input: - ; DGWRK - name of work global containing segments - ; DGMIEN - IEN of message entry in file #773 - ; DGHL - HL environment array - ; - ; Output: - ; none - ; - N DGDFN - N DGQRY - N DGQRYERR - N DGSEGERR - ; - D PARSQRY^DGPFHLQ3(DGWRK,.DGHL,.DGQRY,.DGSEGERR) - S DGDFN=$$GETDFN^DGPFUT2(DGQRY("ICN"),DGQRY("DOB"),DGQRY("SSN")) - I DGDFN'>0 S DGQRYERR="NM" - D SNDORF^DGPFHLS(.DGQRY,DGMIEN,.DGHL,DGDFN,.DGSEGERR,.DGQRYERR) - Q - ; -RCVORF(DGWRK,DGMIEN,DGHL) ;Receive ORF Message Types (ORF~R04) - ; - ; Input: - ; DGWRK - name of work global containing segments - ; DGMIEN - IEN of message entry in file #773 - ; DGHL - HL environment array - ; - ; Output: - ; none - ; - N DGACTDT ;activity date ("ASSIGNDT") - N DGERR ;parse error array - N DGORF ;ORF data array - N DGPFA ;assignment data array - N DGPFAH ;assignment history data array - N DGSET ;OBR set ID - N DGSTOERR ;STOHL7 filer errors - ; - D PARSORF^DGPFHLQ3(DGWRK,.DGHL,.DGORF,.DGERR) - ; - Q:'$D(DGORF) - Q:(+$G(DGORF("QID"))'>0) - Q:'$D(^DPT(DGORF("QID"),0)) - ; - S DGSET=0 - F S DGSET=$O(DGORF(DGSET)) Q:'DGSET D - . N DGAERR ;assignment filer errors - . N DGPFA ;assignment data array - . ; - . Q:($G(DGORF(DGSET,"FLAG"))']"") - . S DGPFA("DFN")=DGORF("QID") - . S DGPFA("FLAG")=DGORF(DGSET,"FLAG") - . ; - . ;set STATUS to null as a placeholder, actual value is determined by - . ;$$STATUS^DGPFUT call below - . S DGPFA("STATUS")="" - . S DGPFA("OWNER")=$G(DGORF(DGSET,"OWNER")) - . S DGPFA("ORIGSITE")=$G(DGORF(DGSET,"ORIGSITE")) - . M DGPFA("NARR")=DGORF(DGSET,"NARR") - . S DGACTDT=0 - . F S DGACTDT=$O(DGORF(DGSET,DGACTDT)) Q:'DGACTDT D - . . N DGAHERR ;assignment history filer errors - . . N DGPFAH ;assignment history data array - . . ; - . . S DGPFAH("ASSIGNDT")=DGACTDT - . . S DGPFAH("ACTION")=$G(DGORF(DGSET,DGACTDT,"ACTION")) - . . S DGPFAH("ENTERBY")=.5 ;always be POSTMASTER (DUZ=.5) - . . S DGPFAH("APPRVBY")=.5 ;always be POSTMASTER (DUZ=.5) - . . M DGPFAH("COMMENT")=DGORF(DGSET,DGACTDT,"COMMENT") - . . ; - . . ;calculate the assignment STATUS from the ACTION - . . S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION")) - . . I $$STOHL7^DGPFAA2(.DGPFA,.DGPFAH,.DGSTOERR) - Q diff -auBN ./r1/DGPFHLRT.m ./r2/r/DGPFHLRT.m --- ./r1/DGPFHLRT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLRT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,75 +0,0 @@ -DGPFHLRT ;ALB/RPM - PRF HL7 MESSAGE RETRANSMIT ; 6/19/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ;This routine provides procedures for retransmitting rejected PRF - ;ORU~R01 HL7 messages. - ; - Q ;no direct entry - ; -REXMIT ;Retransmit all rejected PRF ORU~R01 messages - ;This procedure scans all entries in the ASTAT index of the PRF HL7 - ;TRANSMISSION LOG (#26.17) file, looking for transmissions with a - ;status of REJECT and that were rejected prior to the start of the - ;scan - ; - Q:'$$ORUON^DGPFPARM() ;ORU interface must be active - ; - N DGCODAT ;cutoff date for scan - N DGDAT ;original transmission date - N DGERR ;error array - N DGFAC ;destination station number - N DGFDA ;FDA array - N DGLIEN ;pointer to PRF HL7 TRANSMISSION LOG (#26.17) file - N DGPARAM ;target root for PRF PARAMETERS (#26.18) file date fields - N DGPERIOD ;auto retransmit delay period - N DGPFAH ;assignment history data array - N DGPFL ;HL7 transmission log data array - N DGSTAT ;transmission status - N DGTOT ;total rexmit'd messages - ; - ;retrieve date/time of last scanned entry and retransmit period - D GETS^DIQ(26.18,"1,","4;5","I","DGPARAM","DGERR") - Q:$D(DGERR) - S DGDAT=$G(DGPARAM(26.18,"1,",4,"I")) - S DGPERIOD=$S(DGDAT>0:+$G(DGPARAM(26.18,"1,",5,"I")),1:0) - S DGTOT=0 - ; - ;calculate cutoff date - S DGCODAT=$$FMADD^XLFDT($$NOW^XLFDT(),-DGPERIOD) - ; - ;loop through date/times - F S DGDAT=$O(^DGPF(26.17,"ASTAT",DGDAT)) Q:'DGDAT!(DGDAT>DGCODAT) D - . ; - . ;loop through status - . S DGSTAT="" - . F S DGSTAT=$O(^DGPF(26.17,"ASTAT",DGDAT,DGSTAT)) Q:DGSTAT="" I DGSTAT="RJ" D - . . ; - . . ;loop through log file IEN - . . S DGLIEN=0 - . . F S DGLIEN=$O(^DGPF(26.17,"ASTAT",DGDAT,DGSTAT,DGLIEN)) Q:'DGLIEN D - . . . ; - . . . ;retrieve assignment history file IEN - . . . Q:'$$GETLOG^DGPFHLL(DGLIEN,.DGPFL) - . . . Q:'+DGPFL("ASGNHIST") - . . . ; - . . . ;retrieve institution and convert to station# - . . . S DGFAC(1)=$$STA^XUAF4(+DGPFL("SITE")) - . . . Q:'DGFAC(1) - . . . ; - . . . ;retrieve assignment file IEN - . . . Q:'$$GETHIST^DGPFAAH(+DGPFL("ASGNHIST"),.DGPFAH) - . . . Q:'+DGPFAH("ASSIGN") - . . . ; - . . . ;build and transmit the new message - . . . Q:'$$SNDORU^DGPFHLS(+DGPFAH("ASSIGN"),+DGPFL("ASGNHIST"),.DGFAC) - . . . ; - . . . ;update HL7 transmission log - . . . D STOSTAT^DGPFHLL(DGLIEN,"RT") - . . . ; - . . . ;update total count - . . . S DGTOT=DGTOT+1 - ; - ;update PRF HL7 REXMIT TASK DATE/TIME (#4) field - S DGFDA(26.18,"1,",4)=$O(^DGPF(26.17,"ASTAT",DGDAT),-1) - D FILE^DIE("","DGFDA","DGERR") - ; - Q diff -auBN ./r1/DGPFHLS.m ./r2/r/DGPFHLS.m --- ./r1/DGPFHLS.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLS.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,207 +0,0 @@ -DGPFHLS ;ALB/RPM - PRF HL7 SEND DRIVERS ; 5/13/03 3:20pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -SNDORU(DGPFIEN,DGPFHIEN,DGFAC) ;Send ORU Message Types (ORU~R01) - ;This function builds and transmits a single ORU message to all sites - ;in the associated patient's TREATING FACILITY LIST (#391.91) file. - ;The optional input parameter DGFAC overrides selection of sites - ;from the TREATING FACILITY LIST file. - ; - ; Supported DBIA #2990: This supported DBIA is used to access the - ; Registration API to generate a list of - ; treating facilities for a given patient. - ; Input: - ; DGPFIEN - (required) IEN of assignment in PRF ASSIGNMENT (#26.13) - ; file to transmit - ; DGPFHIEN - (optional) IEN of assignment history in PRF ASSIGNMENT - ; HISTORY (#26.14) file to include in ORU. - ; [default = $$GETLAST^DGPFAAH(DGPFIEN)] - ; DGFAC - (optional) array of message destination facilities - ; passed by reference - ; format: DGFAC(#)=station# - ; - ; Output: - ; Function value - 1 on success, 0 on failure - ; - N HLEID ;event protocol ID - N DGHL ;VistA HL7 environment array - N DGHLROOT ;message array location - N DGPFA ;assignment data array - N DGPFAH ;assignment history data array - N DGRSLT ;function value - ; - S DGRSLT=0 - S DGHLROOT=$NA(^TMP("PRFORU",$J)) - K @DGHLROOT - ; - I $$ORUON^DGPFPARM(),+$G(DGPFIEN)>0,$D(^DGPF(26.13,DGPFIEN)) D - . ; - . ;retrieve assignment record - . Q:'$$GETASGN^DGPFAA(DGPFIEN,.DGPFA) - . ; - . ;retrieve assignment history record - . S DGPFHIEN=$S($G(DGPFHIEN)>0:DGPFHIEN,1:$$GETLAST^DGPFAAH(DGPFIEN)) - . Q:'$$GETHIST^DGPFAAH(DGPFHIEN,.DGPFAH) - . ; - . ;initialize VistA HL7 environment - . S HLEID=$$INIT^DGPFHLUT("DGPF PRF ORU/R01 EVENT",.DGHL) - . Q:'HLEID - . ; - . ;build ORU segments array - . Q:'$$BLDORU^DGPFHLU(.DGPFA,.DGPFAH,.DGHL,DGHLROOT) - . ; - . ;retrieve treating facilities when no destination is provided - . I '$D(DGFAC) D TFL^VAFCTFU1(.DGFAC,+$G(DGPFA("DFN"))) - . Q:'$D(DGFAC) - . ; - . ;transmit and log messages - . Q:'$$XMIT^DGPFHLU6(DGPFHIEN,HLEID,.DGFAC,DGHLROOT,.DGHL) - . ; - . ;success - . S DGRSLT=1 - ; - ;cleanup - K @DGHLROOT - Q DGRSLT - ; -SNDACK(DGACKTYP,DGMIEN,DGHL,DGSEGERR,DGSTOERR) ;Send ACK Message Type (ACK~R01) - ;This procedure assumes the the VistA HL7 environment is providing the - ;environment variables and will produce a fatal error if they are - ;missing. - ; - ; Input: - ; DGACKTYP - (required) ACK message type ("AA","AE") - ; DGMIEN - (required) IEN of message entry in file #773 - ; DGHL - (required) HL7 environment array - ; DGSEGERR - (optional) Errors found during parsing - ; DGSTOERR - (optional) Errors during data storage - ; - ; Output: - ; none - ; - N DGHLROOT - N DGHLERR - ; - Q:($G(DGACKTYP)']"") - Q:('+$G(DGMIEN)) - ; - S DGHLROOT=$NA(^TMP("HLA",$J)) - K @DGHLROOT - ; - ;build ACK segments array - I $$BLDACK^DGPFHLU4(DGACKTYP,DGHLROOT,.DGHL,.DGSEGERR,.DGSTOERR) D - . ; - . ;generate the message - . D GENACK^HLMA1(DGHL("EID"),DGMIEN,DGHL("EIDS"),"GM",1,.DGHLERR) - ; - ;cleanup - K @DGHLROOT - Q - ; -SNDQRY(DGDFN,DGMODE) ;Send QRY Message Types (QRY~R02) - ; - ; Input: - ; DGDFN - (required) pointer to patient in PATIENT (#2) file - ; DGMODE - (optional) type of HL7 connection to use ("1" - direct - ; connection, "2" - deferred connection [default]) - ; - ; Output: - ; Function value - 1 on success, 0 on failure - ; - N DGCMOR - N DGHLROOT - N DGHLLNK - N DGHL - N DGICN - N DGMSG - N DGRSLT - N HLL - N HLEID - N HLRSLT - ; - ;the following HL* variables are created by DIRECT^HLMA - N HL,HLCS,HLDOM,HLECH,HLFS,HLINST,HLINSTN - N HLMTIEN,HLNEXT,HLNODE,HLPARAM,HLPROD,HLQ - N HLQUIT - ; - S DGMODE=+$G(DGMODE) - S DGRSLT=0 - S DGHLROOT=$NA(^TMP("HLS",$J)) - K @DGHLROOT - ; - I $$QRYON^DGPFPARM(),+$G(DGDFN)>0,$D(^DPT(DGDFN,0)) D - . ; - . ;ICN must be national and CMOR must not be local site - . Q:'$$MPIOK^DGPFUT(DGDFN,.DGICN,.DGCMOR) - . ; - . ;retrieve CMOR's HL Logical Link and build HLL array - . S DGHLLNK=$$GETLINK^DGPFHLUT(DGCMOR) - . Q:(DGHLLNK=0) - . S HLL("LINKS",1)="DGPF PRF ORF/R04 SUBSC"_U_DGHLLNK - . ; - . ;initialize VistA HL7 environment - . S HLEID=$$INIT^DGPFHLUT("DGPF PRF QRY/R02 EVENT",.DGHL) - . Q:'HLEID - . ; - . ;build QRY segments array - . Q:'$$BLDQRY^DGPFHLQ(DGDFN,DGICN,DGHLROOT,.DGHL) - . ; - . ;display busy message to interactive users when direct-connect - . I DGMODE=1,$E($G(IOST),1,2)="C-" D - . . S DGMSG(1)="Attempting to connect to CMOR site to search for Patient" - . . S DGMSG(2)="Record Flag Assignments. This request may take some" - . . S DGMSG(3)="time, please be patient ..." - . . D EN^DDIOL(.DGMSG) - . ; - . ;generate HL7 message - . I DGMODE=1 D ;generate direct-connect HL7 message - . . D DIRECT^HLMA(HLEID,"GM",1,.HLRSLT,"","") - . . Q:$P(HLRSLT,U,2)]"" - . . I HLMTIEN D RCV^DGPFHLR - . . ;success - . . S DGRSLT=1 - . ; - . E D ;generate deferred HL7 message - . . D GENERATE^HLMA(HLEID,"GM",1,.HLRSLT,"","") - . . Q:$P(HLRSLT,U,2)]"" - . . ;success - . . S DGRSLT=1 - ; - ;cleanup - K @DGHLROOT - Q DGRSLT - ; -SNDORF(DGQRY,DGMIEN,DGHL,DGDFN,DGSEGERR,DGQRYERR) ;Send ORF Message Type (ORF~R04) - ;This procedure assumes the the VistA HL7 environment is providing the - ;environment variables and will produce a fatal error if they are - ;missing. - ; - ; Input: - ; DGQRY - (required) Array of QRY parsing results - ; DGMIEN - (required) IEN of message entry in file #773 - ; DGHL - (required) HL7 environment array - ; DGDFN - (required) Pointer to patient in PATIENT (#2) file - ; DGSEGERR - (optional) Errors found during parsing - ; DGQRYERR - (optional) Errors found during query - ; - ; Output: - ; none - ; - N DGHLROOT - N DGHLERR - ; - Q:('$D(DGQRY)) - Q:('+$G(DGMIEN)) - ; - S DGHLROOT=$NA(^TMP("HLA",$J)) - K @DGHLROOT - ; - ;build ORF segments array - I $$BLDORF^DGPFHLQ(DGHLROOT,.DGHL,DGDFN,.DGQRY,.DGSEGERR,.DGQRYERR) D - . ; - . ;generate the message - . D GENACK^HLMA1(DGHL("EID"),DGMIEN,DGHL("EIDS"),"GM",1,.DGHLERR) - ; - ;cleanup - K @DGHLROOT - Q diff -auBN ./r1/DGPFHLU1.m ./r2/r/DGPFHLU1.m --- ./r1/DGPFHLU1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLU1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,194 +0,0 @@ -DGPFHLU1 ;ALB/RPM - PRF HL7 BUILD OBR SEGMENT ; 2/18/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q - ; -OBR(DGSET,DGPFA,DGPFAH,DGFLD,DGHL) ;OBR Segment API - ;This function wraps the data retrieval and segment creation APIs and - ;returns a formatted OBR segment. - ; - ; Input: - ; DGSET - (required) OBR segment Set ID - ; DGPFA - (required) Assignment data array - ; DGPFAH - (required) Assignment history data array - ; DGFLD - (optional) List of comma-separated fields (sequence #'s) - ; to include. Defaults to all required fields (4). - ; DGHL - HL7 environment array - ; - ; Output: - ; Function Value - OBR segment on success, "" on failure - ; - N DGOBR - N DGVAL - ; - S DGOBR="" - I $G(DGSET)>0,$D(DGPFA),$D(DGPFAH) D - . S DGFLD=$$CKSTR^DGPFHLUT("4",DGFLD) ;validate the field string - . S DGFLD=","_DGFLD_"," - . I $$OBRVAL(DGFLD,DGSET,.DGPFA,.DGPFAH,.DGVAL) D - . . S DGOBR=$$BLDSEG^DGPFHLUT("OBR",.DGVAL,.DGHL) - Q DGOBR - ; -OBRVAL(DGFLD,DGSET,DGPFA,DGPFAH,DGVAL) ;build OBR value array - ; - ; Input: - ; DGFLD - (required) Fields string - ; DGSET - (required) OBR segment Set ID - ; DGPFA - (required) Assignment data array - ; DGPFAH - (required) Assignment history data array - ; - ; Output: - ; Function Value - 1 on sucess, 0 on failure - ; DGVAL - OBR field array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component] - ; - N DGRSLT ;function value - N DGADT ;assignment date - N DGORIG ;originating site - N DGOWN ;assignment owner - ; - S DGRSLT=0 - I $G(DGFLD)]"",+$G(DGSET)>0,+$G(DGPFA("FLAG"))>0,+$G(DGPFAH("ASSIGN"))>0 D - . ; - . ; seq 1 Set ID - . I DGFLD[",1," D - . . S DGVAL(1)=DGSET - . ; - . ; seq 2 Placer Order Number - . I DGFLD[",2," D - . ; - . ; seq 3 Filler Order Number - . I DGFLD[",3," D - . ; - . ; seq 4 Universal Service ID - . I DGFLD[",4," D ;required field - . . S DGVAL(4,1,1)=+DGPFA("FLAG") ;flag record# only, not IEN - . . S DGVAL(4,1,2)=$P(DGPFA("FLAG"),U,2) ;flag name - . . S DGVAL(4,1,3)="VA085" ;table name - . ; - . ; seq 5 Priority - . I DGFLD[",5," D - . ; - . ; seq 6 Requested Date/time - . I DGFLD[",6," D - . ; - . ; seq 7 Observation Date/Time - . I DGFLD[",7," D - . . S DGADT=$$FMTHL7^XLFDT(+$$GETADT^DGPFAAH(+DGPFAH("ASSIGN"))) - . . S DGVAL(7)=$S(DGADT>0:DGADT,1:"") - . ; - . ; seq 8 Observation End Date/Time - . I DGFLD[",8," D - . ; - . ; seq 9 Collection volume - . I DGFLD[",9," D - . ; - . ; seq 10 Collector Identifier - . I DGFLD[",10," D - . ; - . ; seq 11 Specimen Action Code - . I DGFLD[",11," D - . ; - . ; seq 12 Danger Code - . I DGFLD[",12," D - . ; - . ; seq 13 Relevant Clinical Info - . I DGFLD[",13," D - . ; - . ; seq 14 Specimen Received Date/Time - . I DGFLD[",14," D - . ; - . ; seq 15 Specimen Source - . I DGFLD[",15," D - . ; - . ; seq 16 Ordering Provider - . I DGFLD[",16," D - . ; - . ; seq 17 Order Callback Phone Number - . I DGFLD[",17," D - . ; - . ; seq 18 Placer field 1 - . I DGFLD[",18," D - . ; - . ; seq 19 Placer field 2 - . I DGFLD[",19," D - . ; - . ; seq 20 Filler field 1 - . I DGFLD[",20," D - . . S DGOWN=+$G(DGPFA("OWNER")) - . . S DGVAL(20)=$S(DGOWN>0:$$STA^XUAF4(DGOWN),1:"") - . ; - . ; seq 21 Filler Field 2 - . I DGFLD[",21," D - . . S DGORIG=+$G(DGPFA("ORIGSITE")) - . . S DGVAL(21)=$S(DGORIG>0:$$STA^XUAF4(DGORIG),1:"") - . ; - . ; seq 22 Results Rpt/Status Chng - Date/Time - . I DGFLD[",22," D - . ; - . ; seq 23 Charge to Practice - . I DGFLD[",23," D - . ; - . ; seq 24 Diagnostic Serv Sect ID - . I DGFLD[",24," D - . ; - . ; seq 25 Result Status - . I DGFLD[",25," D - . ; - . ; seq 26 Parent Result - . I DGFLD[",26," D - . ; - . ; seq 27 Quantity/Timing - . I DGFLD[",27," D - . ; - . ; seq 28 Result Copies To - . I DGFLD[",28," D - . ; - . ; seq 29 Parent - . I DGFLD[",29," D - . ; - . ; seq 30 Transportation Mode - . I DGFLD[",30," D - . ; - . ; seq 31 Reason for Study - . I DGFLD[",31," D - . ; - . ; seq 32 Principal Result Interpreter - . I DGFLD[",32," D - . ; - . ; seq 33 Assistant Result Interpreter - . I DGFLD[",33," D - . ; - . ; seq 34 Technician - . I DGFLD[",34," D - . ; - . ; seq 35 Transcription - . I DGFLD[",35," D - . ; - . ; seq 36 Scheduled Date/Time - . I DGFLD[",36," D - . ; - . ; seq 37 Number of Sample Containers - . I DGFLD[",37," D - . ; - . ; seq 38 Transport Logistics of Collected Sample - . I DGFLD[",38," D - . ; - . ; seq 39 Collector's Comment - . I DGFLD[",39," D - . ; - . ; seq 40 Transport Arrangement Responsibility - . I DGFLD[",40," D - . ; - . ; seq 41 Transport Arranged - . I DGFLD[",41," D - . ; - . ; seq 42 Escort Required - . I DGFLD[",42," D - . ; - . ; seq 43 Planned Patient Transport Comment - . I DGFLD[",43," D - . ; - . S DGRSLT=1 - I 'DGRSLT K DGVAL - Q DGRSLT diff -auBN ./r1/DGPFHLU2.m ./r2/r/DGPFHLU2.m --- ./r1/DGPFHLU2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLU2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,174 +0,0 @@ -DGPFHLU2 ;ALB/RPM - PRF HL7 BUILD OBX SEGMENT ; 2/20/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q - ; -OBX(DGSET,DGID,DGSUBID,DGVALUE,DGPFAH,DGFLD,DGHL) ;OBX Segment API - ;This function wraps the data retrieval and segment creation APIs and - ;returns a formatted OBX segment. - ; - ; Input: - ; DGSET - (required) OBX segment Set ID - ; DGID - (required) Observation identifier code - ; DGSUBID - (optional) Observation Sub-ID - ; DGVALUE - (required) Observation value - ; DGPFAH - (required) Assignment history data array - ; DGFLD - (optional) List of comma-separated fields (sequence #'s) - ; to include. Defaults to all required fields (3,11). - ; DGHL - HL7 environment array - ; - ; Output: - ; Function Value - OBX segment on success, "" on failure - ; - N DGOBX - N DGVAL - ; - S DGOBX="" - I $G(DGSET)>0,$G(DGID)?1A,$G(DGVALUE)]"" D - . S DGFLD=$$CKSTR^DGPFHLUT("3,11",DGFLD) ;required fields - . S DGFLD=","_DGFLD_"," - . I $$OBXVAL(DGFLD,DGSET,DGID,DGSUBID,DGVALUE,.DGPFAH,.DGVAL) D - . . S DGOBX=$$BLDSEG^DGPFHLUT("OBX",.DGVAL,.DGHL) - Q DGOBX - ; -OBXVAL(DGFLD,DGSET,DGID,DGSUBID,DGVALUE,DGPFAH,DGVAL) ;build OBX value array - ; - ; Input: - ; DGFLD - (required) Fields string - ; DGSET - (required) OBX segment Set ID - ; DGID - (required) Observation identifier code - ; DGSUBID - (optional) Observation Sub-ID - ; DGVALUE - (required) Observation value - ; DGPFAH - (required) Assignment history data array - ; - ; Output: - ; Function Value - 1 on sucess, 0 on failure - ; DGVAL - OBX field array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component] - ; - N DGRSLT ;function value - N DGTYPE ;observation value type - N DGIDSTR ;observation identifier string - N DGDAT ;observation date - ; - S DGRSLT=0 - I $G(DGFLD)]"",+$G(DGSET)>0,$G(DGID)?1A,$G(DGVALUE)]"" D - . ; - . ; seq 1 Set ID - . I DGFLD[",1," D - . . S DGVAL(1)=DGSET - . ; - . ; seq 2 Value Type - . I DGFLD[",2," D - . . S DGTYPE=$S(DGID="S":"ST",DGID="N":"TX",DGID="C":"TX",1:"") - . . Q:(DGTYPE']"") - . . S DGVAL(2)=DGTYPE - . ; - . ; seq 3 Observation Identifier - . I DGFLD[",3," D Q:'$D(DGVAL(3)) ;required field - . . S DGIDSTR=$S(DGID="S":"Status",DGID="N":"Narrative",DGID="C":"Comment",1:"") - . . Q:(DGIDSTR']"") - . . S DGVAL(3,1,1)=DGID - . . S DGVAL(3,1,2)=DGIDSTR - . . S DGVAL(3,1,3)="L" - . ; - . ; seq 4 Observation Sub-ID (optional) - . I DGFLD[",4," D - . . S DGVAL(4)=$S(+$G(DGSUBID)>0:DGSUBID,1:"") - . ; - . ; seq 5 Observation Value - . I DGFLD[",5," D - . . S DGVAL(5)=DGVALUE - . ; - . ; seq 6 Units - . I DGFLD[",6," D - . . S DGVAL(6)="" - . ; - . ; seq 7 Reference Range - . I DGFLD[",7," D - . . S DGVAL(7)="" - . ; - . ; seq 8 Abnormal Flags - . I DGFLD[",8," D - . . S DGVAL(8)="" - . ; - . ; seq 9 Probability - . I DGFLD[",9," D - . . S DGVAL(9)="" - . ; - . ; seq 10 Nature of Abnormal Test - . I DGFLD[",10," D - . . S DGVAL(10)="" - . ; - . ; seq 11 Observ Result Status - . I DGFLD[",11," D - . . S DGVAL(11)="F" - . ; - . ; seq 12 Date last Obs Normal Values - . I DGFLD[",12," D - . . S DGVAL(12)="" - . ; - . ; seq 13 User Defined Access Checks - . I DGFLD[",13," D - . . S DGVAL(13)="" - . ; - . ; seq 14 Date/Time of the Observation - . I DGFLD[",14," D - . . S DGDAT=$$FMTHL7^XLFDT(+$G(DGPFAH("ASSIGNDT"))) - . . S DGVAL(14)=$S(DGDAT>0:DGDAT,1:"") - . ; - . ; seq 15 Producer's ID - . I DGFLD[",15," D - . . S DGVAL(15)="" - . ; - . ; seq 16 Responsible Observer - . I DGFLD[",16," D - . . S DGVAL(16)="" - . ; - . ; seq 17 Observation Method - . I DGFLD[",17," D - . . S DGVAL(17)="" - . ; - . S DGRSLT=1 - I 'DGRSLT K DGVAL - Q DGRSLT - ; -BLDOBXTX(DGROOT,DGTXTA,DGID,DGPFAH,DGHL,DGSEG,DGSET) ;build OBX text segments - ; - ; Input: - ; DGROOT - (required) Closed root array or global name for segment - ; storage - ; DGTXTA - (required) Closed root array containing text - ; DGID - (required) OBX segment Observation ID - ; DGPFAH - (required) Assignment history data array - ; DGHL - (required) VistA HL7 environment array - ; DGSEG - (optional) Previous segment # in DGROOT - ; DGSET - (optional) Previous OBX Set ID - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; - N DGI ;generic counter - N DGOBX ;formatted OBX segment - N DGOBXTX ;array of pre-processed text lines - N DGRSLT ;function value - N DGSTR ;list of OBX segment fields to include - ; - S DGRSLT=0 - S DGSTR="1,2,3,5,11,14" - I $G(DGROOT)]"",$G(DGTXTA)]"",$G(DGID)?1A,$D(DGPFAH) D - . Q:'$$BLDTEXT^DGPFHLUT(DGTXTA,.DGHL,.DGOBXTX) - . S DGSEG=$G(DGSEG,0) - . S DGSET=$G(DGSET,0) - . S DGI=0 - . F S DGI=$O(DGOBXTX(DGI)) Q:'DGI D Q:(DGOBX="") - . . S DGSET=DGSET+1 - . . S DGOBX=$$OBX^DGPFHLU2(DGSET,DGID,"",DGOBXTX(DGI),.DGPFAH,DGSTR,.DGHL) - . . Q:(DGOBX="") - . . S DGSEG=DGSEG+1,@DGROOT@(DGSEG)=DGOBX - . Q:(DGOBX)="" - . ; - . ;success - . S DGRSLT=1 - ; - Q DGRSLT diff -auBN ./r1/DGPFHLU3.m ./r2/r/DGPFHLU3.m --- ./r1/DGPFHLU3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLU3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,178 +0,0 @@ -DGPFHLU3 ;ALB/RPM - PRF HL7 BUILD MSA/ERR SEGMENTS ; 3/03/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q - ; -MSA(DGACK,DGID,DGERR,DGFLD,DGHL) ;MSA Segment API - ;This function wraps the data retrieval and segment creation APIs and - ;returns a formatted MSA segment. - ; - ; Input: - ; DGACK - (required) MSA segment Acknowledgment code - ; DGID - (required) Message Control ID - ; DGERR - (optional) Error condition - ; DGFLD - (optional) List of comma-separated fields (sequence #'s) - ; to include. Defaults to all required fields (1,2). - ; DGHL - (required) HL7 environment array - ; - ; Output: - ; Function Value - MSA segment on success, "" on failure - ; - N DGMSA - N DGVAL - ; - S DGMSA="" - I $G(DGACK)]"",+$G(DGID) D - . S DGERR=$G(DGERR) - . S DGFLD=$$CKSTR^DGPFHLUT("1,2",DGFLD) ;validate field string - . I DGERR]"" S DGFLD=DGFLD_",6" - . S DGFLD=","_DGFLD_"," - . I $$MSAVAL(DGFLD,DGACK,DGID,"","","",DGERR,.DGVAL) D - . . S DGMSA=$$BLDSEG^DGPFHLUT("MSA",.DGVAL,.DGHL) - Q DGMSA - ; -MSAVAL(DGFLD,DGACK,DGID,DGTEXT,DGESN,DGDAT,DGERR,DGVAL) ;build MSA value array - ; - ; Input: - ; DGFLD - (required) fields string - ; DGACK - (required) MSA segment Acknowledgment code - ; DGID - (required) Message Control ID - ; DGTEXT - (optional) Text message - ; DGESN - (optional) Expected sequence number - ; DGDAT - (optional) Delayed acknowledgment type - ; DGERR - (optional) Error condition - ; - ; Output: - ; Function Value - 1 on sucess, 0 on failure - ; DGVAL - MSA field array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component] - ; - N DGRSLT ;function value - N DGACKS ;array of valid ACK codes - N DGCOD ;ACK code string - N DGERRSTR ;Error condition string - N DGTBL ;VA086 Error code array - ; - S DGRSLT=0 - I $G(DGFLD)]"",$G(DGACK)]"",+$G(DGID) D - . F DGCOD="AA","AE","AR","CA","CE","CR" S DGACKS(DGCOD)="" - . ; - . ; seq 1 Acknowledgment Code - . I DGFLD[",1," D - . . S DGVAL(1)=$S($D(DGACKS(DGACK)):DGACK,1:"") - . Q:(DGVAL(1)="") ;required field - . ; - . ; seq 2 Message Control ID - . I DGFLD[",2," D - . . S DGVAL(2)=DGID - . Q:(DGVAL(2)="") ;required field - . ; - . ; seq 3 Text Message - . I DGFLD[",3," D - . . S DGVAL(3)=$G(DGTEXT) - . ; - . ; seq 4 Expected Sequence Number - . I DGFLD[",4," D - . . S DGVAL(4)=$G(DGESN) - . ; - . ; seq 5 Delayed Acknowledgment Type - . I DGFLD[",5," D - . . S DGDAT=$G(DGDAT) - . . S DGVAL(5)=$S(DGDAT="D":DGDAT,DGDAT="F":DGDAT,1:"") - . ; - . ; seq 6 Error Condition - . I DGFLD[",6," D - . . D BLDVA086^DGPFHLU3(.DGTBL) - . . I $G(DGERR)]"",$D(DGTBL(DGERR))#2 D - . . . S DGVAL(6,1,1)=DGERR - . . . S DGVAL(6,1,2)=DGTBL(DGERR) - . . . S DGVAL(6,1,3)="VA086" - . S DGRSLT=1 - I 'DGRSLT K DGVAL - Q DGRSLT - ; -ERR(DGSEG,DGSEQ,DGPOS,DGCOD,DGFLD,DGHL) ;ERR segment API - ; - ; Input: - ; DGSEG - (required) Segment ID - ; DGSEQ - (required) Sequence - ; DGPOS - (required) Field position - ; DGCOD - (required) Error code from table VA086 - ; DGFLD - (optional) List of comma-separated fields (sequence #'s) - ; to include. Defaults to all required fields (1). - ; DGHL - (required) HL7 Environment array - ; - ; Output: - ; Function value - ERR segment on success, "" on failure - ; - N DGERR - N DGVAL - ; - S DGERR="" - I $G(DGSEG)]"",+$G(DGSEQ),+$G(DGPOS),$G(DGCOD)]"",$G(DGHL("ECH"))]"" D - . S DGFLD=$$CKSTR^DGPFHLUT("1",DGFLD) ;validate field string - . S DGFLD=","_DGFLD_"," - . I $$ERRVAL(DGFLD,DGSEG,DGSEQ,DGPOS,DGCOD,.DGVAL) D - . . S DGERR=$$BLDSEG^DGPFHLUT("ERR",.DGVAL,.DGHL) - Q DGERR - ; -ERRVAL(DGFLD,DGSEG,DGSEQ,DGPOS,DGCOD,DGVAL) ;build ERR value array - ; - ; Input: - ; DGFLD - (required) Field string - ; DGSEG - (required) Segment ID - ; DGSEQ - (required) Sequence - ; DGPOS - (required) Field position - ; DGCOD - (required) Error code from table VA086 - ; - ; Output: - ; Function value - 1 on success, 0 on failure - ; DGVAL - ERR field array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component] - N DGRSLT - N DGTBL - ; - S DGRSLT=0 - I $G(DGFLD)]"",$G(DGSEG)]"",+$G(DGSEQ),+$G(DGPOS),$G(DGCOD)]"" D - . I DGFLD[",1," D - . . D BLDVA086^DGPFHLU3(.DGTBL) - . . I $D(DGTBL(DGCOD))#2 D - . . . S DGVAL(1,1,1)=DGSEG - . . . S DGVAL(1,1,2)=DGSEQ - . . . S DGVAL(1,1,3)=DGPOS - . . . S DGVAL(1,1,4,1)=DGCOD - . . . S DGVAL(1,1,4,2)=DGTBL(DGCOD) - . . . S DGVAL(1,1,4,3)="VA086" - . S DGRSLT=1 - Q DGRSLT - ; -BLDVA086(DGTBL) ;build error code/text array for table VA086 - ; - ; Input: - ; none - ; - ; Output: - ; DGTBL - error code array subscripted by code containing error text - ; - N DGI - N DGLINE - N DGCOD - N DGTXT - N DGDESC - ; - F DGI=1:1 S DGLINE=$T(ERRTBL+DGI) Q:DGLINE="" D - . S DGCOD=$P(DGLINE,";",3) - . S DGTXT=$P(DGLINE,";",4) - . S DGDESC=$P(DGLINE,";",5) - . S DGTBL(DGCOD)=DGTXT - . S DGTBL(DGCOD,"DESC")=DGDESC - Q - ; -ERRTBL ;VA086 Error Code Table;error code;error text - ;;FE;Filer Error;An error occurred at the remote site when attempting to add, update or retrieve assignment data. - ;;IF;Invalid Patient Record Flag;The transmitted Patient Record Flag is not defined at the remote site. - ;;IID;Invalid Observation ID;The transmitted observation ID is not "N"arrative, "S"tatus or "C"omment. - ;;IOR;Invalid Originating Site;The originating site of the transmission is not defined at the remote site. - ;;IOW;Invalid Owner Site;The transmitted owning site is not defined at the remote site. - ;;NM;No Match;No patient was found that correlates to the transmitted ICN, DOB and SSN. - ;;UU;Unauthorized Update;The originating site of the transmission is not defined as the owning site of the assignment or an invalid action was transmitted (i.e. Reactivate an already active assignment). diff -auBN ./r1/DGPFHLU4.m ./r2/r/DGPFHLU4.m --- ./r1/DGPFHLU4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLU4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,169 +0,0 @@ -DGPFHLU4 ;ALB/RPM - PRF HL7 ACK PROCESSING ; 3/04/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -BLDACK(DGACK,DGROOT,DGHL,DGSEGERR,DGSTOERR) ;Build ACK Message/Segments - ; - ; Input: - ; DGACK - (required) Acknowledment code - ; DGROOT - (required) Segment array name - ; DGHL - (required) HL7 environment array - ; DGSEGERR - (optional) defined only if errors during parsing - ; DGSTOERR - (optional) defined only if errors during filing - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; ^TMP("HLA",$J) - Array of ACK segments - ; - N DGCNT ;segment counter - N DGMSA ;formatted MSA segment - N DGRSLT ;function value - ; - S DGRSLT=0 - I $G(DGACK)]"",$G(DGROOT)]"" D - . S DGCNT=0 - . ; - . ;build MSA segment - . S DGMSA=$$MSA^DGPFHLU3(DGACK,DGHL("MID"),.DGSTOERR,"1,2",.DGHL) - . Q:(DGMSA="") - . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGMSA - . ; - . ;build ERR segments - . Q:($D(DGSEGERR)&('$$BLDERR(DGROOT,.DGSEGERR,.DGHL,.DGCNT))) - . ; - . ;success - . S DGRSLT=1 - Q DGRSLT - ; -PARSACK(DGWRK,DGHL,DGACK,DGMSG) ;Parse ACK Message/Segments - ; - ; Input: - ; DGWRK - Closed root work global reference - ; DGHL - HL7 environment array - ; - ; Output: - ; DGACK - array of ACK results - ; DGMSG - undefined on success, array of MailMan text on failure - ; - N DGFS - N DGCS - N DGRS - N DGSS - N DGCURLIN - ; - S DGFS=DGHL("FS") - S DGCS=$E(DGHL("ECH"),1) - S DGRS=$E(DGHL("ECH"),2) - S DGSS=$E(DGHL("ECH"),4) - S DGCURLIN=0 - ; - ;loop through the message segments and retrieve the field data - F D Q:'DGCURLIN - . N DGSEG - . S DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG) - . Q:'DGCURLIN - . D @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGSS,.DGACK,.DGMSG)") - Q - ; -MSH(DGSEG,DGCS,DGRS,DGSS,DGACK,DGERR) ; - ; - ; Input: - ; DGSEG - MSH segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGACK - array of ACK results - ; "SNDFAC" - sending facility - ; "RCVFAC" - receiving facility - ; "MSGDTM" - message creation date/time in FileMan format - ; DGERR - undefined on success, error array on failure - ; - S DGACK("SNDFAC")=$P($G(DGSEG(4)),DGCS,1) - S DGACK("RCVFAC")=$P($G(DGSEG(6)),DGCS,1) - S DGACK("MSGDTM")=$$HL7TFM^XLFDT($G(DGSEG(7))) - Q - ; -MSA(DGSEG,DGCS,DGRS,DGSS,DGACK,DGERR) ; - ; - ; Input: - ; DGSEG - MSH segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGACK - array of ACK results - ; "ACKCODE" - Acknowledgment code - ; "MSGID" - Message Control ID of the message being ACK'ed - ; DGERR - undefined on success, error array on failure - ; - N DGCNT - ; - S DGACK("ACKCODE")=$G(DGSEG(1)) - S DGACK("MSGID")=$G(DGSEG(2)) - I DGACK("ACKCODE")'="AA",$G(DGSEG(6))]"" D - . S DGCNT=$O(DGERR(""),-1),DGCNT=DGCNT+1 - . S DGERR(DGCNT)=$P(DGSEG(6),DGCS,1) - Q - ; -ERR(DGSEG,DGCS,DGRS,DGSS,DGACK,DGERR) ; - ; - ; Input: - ; DGSEG - MSH segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; DGSS - HL7 sub-component separator - ; - ; Output: - ; DGACK - array of ACK results - ; DGERR - undefined on success, error array on failure - ; - N DGCNT - N DGCOD - ; - I $G(DGSEG(1))]"" D - . S DGCOD=$P($P(DGSEG(1),DGCS,4),DGSS,1) - . I DGCOD]"" D - . . S DGCNT=$O(DGERR(""),-1),DGCNT=DGCNT+1 - . . S DGERR(DGCNT)=DGCOD - Q - ; -BLDERR(DGROOT,DGSEGERR,DGHL,DGCNT) ;build all ERR segments - ;This function builds a formatted ERR segment for each entry in the - ;segment error array (DGSEGERR). - ; - ; Input: - ; DGROOT - (required) Closed root array or global name for segment - ; storage - ; DGSEGERR - (required) Array of segment errors - ; Format: DGSEGERR(segment name,sequence,field)=error code - ; DGHL - (required) VistA HL7 environment array - ; DGCNT - (optional) Previous segment # in DGROOT - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; - N DGCOD ;error code - N DGERR ;formatted ERR segment - N DGPOS ;field positions containing error - N DGSEG ;segment name containing error - N DGSEQ ;sequence of segment containing error - N DGRSLT ;function value - ; - S DGRSLT=0 - I $G(DGROOT)]"",$D(DGSEGERR) D - . S DGCNT=$G(DGCNT,0) - . S DGSEG="" - . F S DGSEG=$O(DGSEGERR(DGSEG)) Q:(DGSEG="") D Q:(DGERR="") - . . S DGSEQ=0 - . . F S DGSEQ=$O(DGSEGERR(DGSEG,DGSEQ)) Q:'DGSEQ D Q:(DGERR="") - . . . S DGPOS=0 - . . . F S DGPOS=$O(DGSEGERR(DGSEG,DGSEQ,DGPOS)) Q:'DGPOS D Q:(DGERR="") - . . . . S DGCOD=DGSEGERR(DGSEG,DGSEQ,DGPOS) - . . . . S DGERR=$$ERR^DGPFHLU3(DGSEG,DGSEQ,DGPOS,DGCOD,"1",.DGHL) - . . . . Q:(DGERR="") - . . . . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGERR - . Q:(DGERR="") - . S DGRSLT=1 - Q DGRSLT diff -auBN ./r1/DGPFHLU5.m ./r2/r/DGPFHLU5.m --- ./r1/DGPFHLU5.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLU5.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,178 +0,0 @@ -DGPFHLU5 ;ALB/RPM - PRF HL7 ACK PROCESSING ; 6/20/03 11:30am - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q - ; -PROCERR(DGLIEN,DGACK,DGERR) ;process errors returned from ACK - ; - ; Input: - ; DGLIEN - IEN of PRF HL7 TRANSMISSION LOG (#26.17) file - ; DGACK - array of ACK parse data - ; DGERR - array of parsed errors (ex: DGERR(1)="UU") - ; - ; Output: none - ; - N DGPFA ;assignment array - N DGPFAH ;assignment history array - N DGPFL ;HL7 transmission log array - N DGTBL ;error code array - N DGXMTXT ;mailman msg text array - ; - I +$G(DGLIEN),$D(DGACK),$D(DGERR) D - . ; - . ;retrieve the HL7 transmission log values - . Q:'$$GETLOG^DGPFHLL(DGLIEN,.DGPFL) - . ; - . ;retrieve assignment history values - . Q:'$$GETHIST^DGPFAAH(+$G(DGPFL("ASGNHIST")),.DGPFAH) - . ; - . ;retrieve assignment values - . Q:'$$GETASGN^DGPFAA(+$G(DGPFAH("ASSIGN")),.DGPFA) - . ; - . S DGXMTXT=$NA(^TMP("DGPFERR",$J)) - . K @DGXMTXT - . ; - . ;load error code table - . D BLDVA086^DGPFHLU3(.DGTBL) - . ; - . ;create message text array - . D BLDMSG(.DGPFA,.DGACK,.DGERR,.DGTBL,DGXMTXT) - . ; - . ;send the notification message - . D SEND(DGXMTXT) - . ; - . ;cleanup - . K @DGXMTXT - Q - ; -BLDMSG(DGPFA,DGACK,DGERR,DGTBL,DGXMTXT) ;buld MailMan message array - ; - ; Supported DBIA #2171: The supported DBIA is uses to access Kernel - ; APIs for retrieving Station numbers and names - ; from the INSTITUTION (#4) file. - ; Supported DBIA #2701: The supported DBIA is used to access MPI APIs - ; for retrieving an ICN for a given DFN. - ; - ; Input: - ; DGPFA - assignment data array - ; DGACK - array of ACK data - ; DGERR - array of parsed errors (ex: DGERR(1)="UU") - ; DGTBL - VA086 error code table array - ; - ; Output: - ; DGXMTXT - array of MailMan text lines - ; - N DGCNT ;error count - N DGCOD ;error code - N DGDEM ;patient demographics array - N DGDFN ;pointer to PATIENT (#2) file - N DGFAC ;facility data array from XUAF4 call - N DGICN ;integrated control number - N DGLIN ;line counter - N DGMAX ;maximum line length - N DGSITE ;results of VASITE call - N DGSNDSTA ;sending station number - N DGSNDNAM ;sending station name - ; - S DGDFN=+$G(DGPFA("DFN")) - Q:(DGDFN'>0) - ; - ;retrieve patient demographics - Q:'$$GETPAT^DGPFUT2(DGDFN,.DGDEM) - S DGICN=$$GETICN^MPIF001(DGDFN) - S DGICN=$S(+DGICN>0:DGICN,1:$P(DGICN,U,2)) - ; - S DGLIN=0 - S DGMAX=65 - S DGSITE=$$SITE^VASITE() - S DGSNDSTA=$G(DGACK("SNDFAC")) - D F4^XUAF4(DGSNDSTA,.DGFAC,"","") - S DGSNDNAM=$S(DGFAC>0:$G(DGFAC("NAME")),1:"") - ; - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("* * * * P R F H L 7 E R R O R E N C O U N T E R E D * * * *",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("A facility could not process the following Patient Record Flag assignment on "_$$FMTE^XLFDT($G(DGACK("MSGDTM")))_".",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("Receiving Facility name: "_DGSNDNAM_" ("_DGSNDSTA_")",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("Flag Name: "_$P($G(DGPFA("FLAG")),U,2),14,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("Patient Name: "_DGDEM("NAME"),11,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("Social Security #: "_DGDEM("SSN"),6,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("Date of Birth: "_$$FMTE^XLFDT(DGDEM("DOB"),"2D"),10,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("Integrated Control #: "_DGICN,3,DGMAX,.DGLIN,DGXMTXT) - D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - S DGCNT=0 - F S DGCNT=$O(DGERR(DGCNT)) Q:'DGCNT D - . S DGCOD=DGERR(DGCNT) - . I DGCOD]"",$D(DGTBL(DGCOD,"DESC")) D - . . D ADDLINE("Reason#: "_DGCNT,0,DGMAX,.DGLIN,DGXMTXT) - . . D ADDLINE(DGTBL(DGCOD,"DESC"),12,DGMAX,.DGLIN,DGXMTXT) - . . D ADDLINE("",0,DGMAX,.DGLIN,DGXMTXT) - Q - ; -ADDLINE(DGTEXT,DGINDENT,DGMAXLEN,DGCNT,DGXMTXT) ;add text line to message array - ; - ; Input: - ; DGTEXT - text string - ; DGINDENT - number of spaces to insert at start of line - ; DGMAXLEN - maximum desired line length (default: 60) - ; DGCNT - line number passed by reference - ; - ; Output: - ; DGXMTXT - array of text strings - ; - N DGAVAIL ;available space for text - N DGLINE ;truncated text - N DGLOC ;location of space character - N DGPAD ;space indent - ; - S DGTEXT=$G(DGTEXT) - S DGINDENT=+$G(DGINDENT) - S DGMAXLEN=+$G(DGMAXLEN) - S:'DGMAXLEN DGMAXLEN=60 - I DGINDENT>(DGMAXLEN-1) S DGINDENT=0 - S DGCNT=$G(DGCNT,0) ;default to 0 - ; - S DGPAD=$$REPEAT^XLFSTR(" ",DGINDENT) - ; - ;determine availaible space for text - S DGAVAIL=(DGMAXLEN-DGINDENT) - F D Q:('$L(DGTEXT)) - . ; - . ;find potential line break - . S DGLOC=$L($E(DGTEXT,1,DGAVAIL)," ") - . ; - . ;break a line that is too long when it has potential line breaks - . I $L(DGTEXT)>DGAVAIL,DGLOC D - . . S DGLINE=$P(DGTEXT," ",1,$S(DGLOC>1:DGLOC-1,1:1)) - . . S DGTEXT=$P(DGTEXT," ",$S(DGLOC>1:DGLOC,1:DGLOC+1),$L(DGTEXT," ")) - . E D - . . S DGLINE=DGTEXT,DGTEXT="" - . ; - . S DGCNT=DGCNT+1 - . S @DGXMTXT@(DGCNT)=DGPAD_DGLINE - Q - ; -SEND(DGXMTXT) ;send the MailMan message - ; - ; Input: - ; DGXMTXT - name of message text array in closed format - ; - ; Output: - ; none - ; - N DIFROM ;protect FM package - N XMDUZ ;sender - N XMSUB ;message subject - N XMTEXT ;name of message text array in open format - N XMY ;recipient array - N XMZ ;returned message number - ; - S XMDUZ="Patient Record Flag Module" - S XMSUB="PRF MESSAGE TRANSMISSION ERROR" - S XMTEXT=$$OREF^DILF(DGXMTXT) - S XMY("G.DGPF HL7 TRANSMISSION ERRORS")="" - D ^XMD - Q diff -auBN ./r1/DGPFHLU6.m ./r2/r/DGPFHLU6.m --- ./r1/DGPFHLU6.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLU6.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,71 +0,0 @@ -DGPFHLU6 ;ALB/RPM - PRF HL7 ORU~R01 UTILITIES ; 5/21/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q ;no direct entry - ; -XMIT(DGPFHIEN,HLEID,DGFAC,DGHLROOT,DGHL) ;transmit ORU messages - ;This function loops through an array of treating facilities. For - ;each treating facility: the HL7 logical link is determined, the ORU - ;message contained in the DGHLROOT input parameter is transmitted and - ;an entry is created in the PRF HL7 TRANSMISSION LOG (#26.17) file. - ; - ; Supported DBIA #2171: This supported DBIA is used to access the - ; Kernel API to convert a station number - ; to an INSTITUTION (#4) file IEN. - ; - ; Input: - ; DGPFHIEN - pointer to PRF ASSIGNMENT HISTORY (#26.14) file - ; HLEID - event protocol ID - ; DGFAC - treating facilities array - ; DGHLROOT - name of array containing formatted ORU message - ; DGHL - VistA HL7 environment array - ; - ; Output: - ; Function value - returns 1 on sucess, 0 on failure - ; - N DGHLLNK ;single logical link - N DGHLS ;name of HL7 "HLS" array - N DGI ;generic counter - N DGINST ;pointer to INSTITUTION (#4) file - N DGLOGERR ;error array from transmit log filer - N DGLINST ;pointer to INSTITUTION (#4) file for local site - N DGRSLT ;function value - N HLL ;logical links array - N HLRSLT ;message IEN on successful transmit - ; - S DGHLS=$NA(^TMP("HLS",$J)) - S DGLINST=$P($$SITE^VASITE(),U,1) - S DGRSLT=0 - ; - S DGI=0 - F S DGI=$O(DGFAC(DGI)) Q:'DGI D - . N HLRSLT - . N DGLOGERR - . ; - . ;convert the station number to INSTITUTION (#4) file IEN - . S DGINST=+$$IEN^XUAF4($P(DGFAC(DGI),U,1)) - . Q:'DGINST!(DGINST=DGLINST) - . ; - . ;get the HL7 LOGICAL LINK associated with the institution - . S DGHLLNK=$$GETLINK^DGPFHLUT(DGINST) - . Q:DGHLLNK=0 - . ; - . ;copy formatted message to HL7 "HLS" array - . K @DGHLS - . M @DGHLS=@DGHLROOT - . ; - . ;build HLL logical link - . S HLL("LINKS",1)="DGPF PRF ORU/R01 SUBSC"_U_DGHLLNK - . ; - . ;generate the message - . D GENERATE^HLMA(HLEID,"GM",1,.HLRSLT,"","") - . Q:$P(HLRSLT,U,2)]"" - . ; - . ;store the message ID and destination site in the HL7 transmission log - . D STOXMIT^DGPFHLL(DGPFHIEN,$P(HLRSLT,U),DGINST,.DGLOGERR) - . Q:$D(DGLOGERR) - . ; - . ;success - . S DGRSLT=1 - ; - Q DGRSLT diff -auBN ./r1/DGPFHLU.m ./r2/r/DGPFHLU.m --- ./r1/DGPFHLU.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLU.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,206 +0,0 @@ -DGPFHLU ;ALB/RPM - PRF HL7 ORU/ACK PROCESSING ; 6/17/03 1:27pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -BLDORU(DGPFA,DGPFAH,DGHL,DGROOT) ;Build ORU~R01 Message/Segments - ; - ; Input: - ; DGPFA - (required) Assignment data array - ; DGPFAH - (required) Assignment history data array - ; DGHL - (required) HL7 Kernel array passed by reference - ; DGROOT - (required) Closed root array or global name for segment - ; storage - ; - ; Output: - ; Function Value - 1 on success, 0 on failure - ; DGROOT - array of HL7 segments - ; - N DGRSLT ;function value - N DGSEG ;segment counter - N DGSEGSTR ;formatted segment string - N DGSET ;set id - N DGSTR ;field string - N DGTROOT ;text root - ; - S DGRSLT=0 - S DGSEG=0 - ; - I $D(DGPFA),$D(DGPFAH),$G(DGROOT)]"" D - . ; - . ;build PID - . S DGSTR="1,2,3,5,7,8,19" - . S DGSEGSTR=$$EN^VAFHLPID(+DGPFA("DFN"),DGSTR,1,1) - . Q:(DGSEGSTR="") - . S DGSEG=DGSEG+1,@DGROOT@(DGSEG)=DGSEGSTR - . ; - . ;build OBR - . S DGSET=1 - . S DGSTR="1,4,7,20" - . S DGSEGSTR=$$OBR^DGPFHLU1(DGSET,.DGPFA,.DGPFAH,DGSTR,.DGHL) - . Q:(DGSEGSTR="") - . S DGSEG=DGSEG+1,@DGROOT@(DGSEG)=DGSEGSTR - . ; - . ;start OBX segments - . S DGSET=0 - . ; - . ;build narrative OBX segments - . S DGTROOT="DGPFA(""NARR"")" - . Q:'$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"N",.DGPFAH,.DGHL,.DGSEG,.DGSET) - . ; - . ;build status OBX segment - . S DGSTR="1,2,3,5,11,14" - . S DGSET=DGSET+1 - . S DGSEGSTR=$$OBX^DGPFHLU2(DGSET,"S","",$P($G(DGPFAH("ACTION")),U,2),.DGPFAH,DGSTR,.DGHL) - . Q:(DGSEGSTR="") - . S DGSEG=DGSEG+1,@DGROOT@(DGSEG)=DGSEGSTR - . ; - . ;build review comment OBX segments - . S DGTROOT="DGPFAH(""COMMENT"")" - . Q:'$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"C",.DGPFAH,.DGHL,.DGSEG,.DGSET) - . ; - . ;success - . S DGRSLT=1 - ; - Q DGRSLT - ; -PARSORU(DGWRK,DGHL,DGPFA,DGPFAH,DGPFERR) ;Parse ORU~R01 Message/Segments - ; - ; Input: - ; DGWRK - Closed root work global reference - ; DGHL - HL7 environment array - ; - ; Output: - ; DGPFA - Assignment data array - ; DGPFAH - Assignment history data array - ; DGPFERR - Undefined on success, ERR segment data array on failure - ; Format: DGPFERR(seg_id,sequence,fld_pos)=error_code - ; - N DGFS ;field separator - N DGCS ;component separator - N DGRS ;repetition separator - N DGCURLIN ;current segment line - N DGSEG ;segment field data array - N DGERR ;error processing array - ; - S DGFS=DGHL("FS") - S DGCS=$E(DGHL("ECH"),1) - S DGRS=$E(DGHL("ECH"),2) - S DGCURLIN=0 - ; - ;loop through the message segments and retrieve the field data - F D Q:'DGCURLIN - . N DGSEG - . S DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG) - . Q:'DGCURLIN - . D @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,.DGPFA,.DGPFAH,.DGPFERR)") - ; - ;the ENTERBY and APPRVBY will always be POSTMASTER (DUZ=.5) - S DGPFAH("ENTERBY")=.5 ;ENTERED BY (.04) field, file 26.14 - S DGPFAH("APPRVBY")=.5 ;APPROVED BY (.05) field, file 26.14 - Q - ; -MSH(DGSEG,DGCS,DGRS,DGPFA,DGPFAH,DGERR) ; - ; - ; Input: - ; DGSEG - MSH segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; - ; Output: - ; DGPFA("ORIGSITE") - ORIGINATING SITE (.05) field, file #26.13 - ; DGERR - undefined on success, error array on failure - ; format: DGERR(seg_id,sequence,fld_pos)=error code - ; - S DGPFA("ORIGSITE")=$$IEN^XUAF4($P(DGSEG(4),DGCS,1)) - I (DGPFA("ORIGSITE")="")!('$$TESTVAL^DGPFUT(26.13,.05,DGPFA("ORIGSITE"))) D - . S DGERR("MSH",1,4)="IOR" - Q - ; -PID(DGSEG,DGCS,DGRS,DGPFA,DGPFAH,DGERR) ; - ; - ; Input: - ; DGSEG - PID segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; - ; Output: - ; DGPFA("DFN") - PATIENT NAME (.01) field, file #26.13 - ; DGERR - undefined on success, error array on failure - ; format: DGERR(seg_id,sequence,fld_pos)=error code - ; - N DGICN - N DGDOB - N DGSSN - ; - S DGICN=+$P(DGSEG(3),DGCS,1) - S DGDOB=+$$HL7TFM^XLFDT(DGSEG(7)) - S DGSSN=DGSEG(19) - S DGPFA("DFN")=$$GETDFN^DGPFUT2(DGICN,DGDOB,DGSSN) - I 'DGPFA("DFN") D - . S DGERR("PID",DGSEG(1),3)="NM" ;no match - Q - ; -OBR(DGSEG,DGCS,DGRS,DGPFA,DGPFAH,DGERR) ; - ; - ; Input: - ; DGSEG - OBR segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; - ; Output: - ; DGPFA("FLAG") - FLAG NAME (.02) field, file #26.13 - ; DGPFA("OWNER") - OWNER SITE (.04) field, file #26.13 - ; DGERR - undefined on success, error array on failure - ; format: DGERR(seg_id,sequence,fld_pos)=error code - ; - S DGPFA("FLAG")=$P($G(DGSEG(4)),DGCS,1)_";DGPF(26.15," - I '$$TESTVAL^DGPFUT(26.13,.02,DGPFA("FLAG")) D - . S DGERR("OBR",DGSEG(1),4)="IF" ;invalid flag - S DGPFA("OWNER")=$$IEN^XUAF4(DGSEG(20)) - I (DGPFA("OWNER")="")!('$$TESTVAL^DGPFUT(26.13,.04,DGPFA("OWNER"))) D - . S DGERR("OBR",DGSEG(1),20)="IOW" ;invalid owner site - Q - ; -OBX(DGSEG,DGCS,DGRS,DGPFA,DGPFAH,DGERR) ; - ; - ; Input: - ; DGSEG - OBX segment field array - ; DGCS - HL7 component separator - ; DGRS - HL7 repetition separator - ; - ; Output: - ; DGPFA("STATUS") - STATUS (.03) field, file #26.13 - ; DGPFA("NARR") - ASSIGNMENT NARRATIVE (1) field, file #26.13 - ; DGPFAH("ASSIGNDT") - DATE/TIME (.02) field, file #26.14 - ; DGPFAH("ACTION") - ACTION (.03) field, file #26.14 - ; DGPFAH("COMMENT") - HISTORY COMMENTS (1) field, file #26.14 - ; DGERR - undefined on success, error array on failure - ; format: DGERR(seg_id,sequence,fld_pos)=error code - ; - N DGI - N DGLINE - N DGRSLT - ; - ;validate Observation ID value - quit if invalid - I '$F("NSC",$P(DGSEG(3),DGCS,1)) D Q - . S DGERR("OBX",DGSEG(1),3)="IID" - ; - ; Narrative Observation Identifier - I $P(DGSEG(3),DGCS,1)="N" D - . S DGLINE=$O(DGPFA("NARR",""),-1) - . F DGI=1:1:$L(DGSEG(5),DGRS) D - . . S DGPFA("NARR",DGLINE+DGI,0)=$P(DGSEG(5),DGRS,DGI) - ; - ; Status Observation Identifier - I $P(DGSEG(3),DGCS,1)="S" D - . D CHK^DIE(26.14,.03,,DGSEG(5),.DGRSLT) - . S DGPFAH("ACTION")=+DGRSLT - . S DGPFAH("ASSIGNDT")=$$HL7TFM^XLFDT(DGSEG(14)) - . S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION")) - ; - ; Comment Observation Identifier - I $P(DGSEG(3),DGCS,1)="C" D - . S DGLINE=$O(DGPFAH("COMMENT",""),-1) - . F DGI=1:1:$L(DGSEG(5),DGRS) D - . . S DGPFAH("COMMENT",DGLINE+DGI,0)=$P(DGSEG(5),DGRS,DGI) - Q - ; diff -auBN ./r1/DGPFHLUT.m ./r2/r/DGPFHLUT.m --- ./r1/DGPFHLUT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFHLUT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,239 +0,0 @@ -DGPFHLUT ;ALB/RPM - PRF HL7 UTILITIES ; 1/13/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ;This routine contains generic utilities used when building - ;or processing received patient record flag HL7 messages. - ; - Q ;no supported direct entry - ; -INIT(DGPROT,DGHL) ;Kernel HL7 INIT wrapper - ; - ; Supported DBIA #2161: The supported DBIA is used to access the - ; VistA HL7 API to initialize the HL7 environ- - ; ment variables. - ; - ; Input: - ; DGPROT - Event protocol name - ; - ; Output: - ; Function value - HLEID on success;0 on failure - ; DGHL - HL array from INIT^HLFNC2 Kernel call - ; - N DGHLEID - S DGHLEID=0 - S DGHLEID=$$HLEID(DGPROT) - I DGHLEID D - . D INIT^HLFNC2(DGHLEID,.DGHL) - . I $O(DGHL(""))="" S DGHLEID=0 - Q DGHLEID - ; -HLEID(DGPROT) ;return IEN of HL7 protocol - ; - ; Input: - ; DGPROT - Protocol name - ; - ; Output: - ; Function value - IEN of protocol on success, 0 on failure - ; - I $G(DGPROT)="" Q 0 - Q +$O(^ORD(101,"B",DGPROT,0)) - ; -GETLINK(DGINST) ;retrieve a single link for a given institution - ; - ; Supported DBIA #2271: The supported DBIA is used to access the - ; VistA HL7 API to retrieve logical links - ; given a pointer to the INSTITUTION (#4) file. - ; - ; Input: - ; DGINST - IEN of site in INSTITUTION (#4) file - ; - ; Output: - ; Function Value - HL Logical link on success, 0 on failure - ; - N DGLINKS - N DGLNK - N DGRSLT - ; - S DGRSLT=0 - I $G(DGINST)>0 D - . D LINK^HLUTIL3(DGINST,.DGLINKS) - . S DGLNK=$O(DGLINKS(0)) - . S DGRSLT=$S(DGLNK>0:DGLINKS(DGLNK),1:0) - Q DGRSLT - ; -BLDTEXT(DGWP,DGHL,DGARR) ;Build HL7 word proc text array - ; - ; Supported DBIA #10104: The supported DBIA is used to access KERNEL - ; string functions. - ; - ; Input: - ; DGWP - Word processing closed root - ; DGHL - HL7 environment array - ; - ; Output: - ; Function Value - count of segment array elements on success, - ; 0 on failure - ; DGARR - array of segment text data - ; - N DGLIN ;word processing line iterator - N DGCNT ;text segment counter - N DGTXT ;word processing text - N DGBLK ;blank line counter - N DGREP ;HL7 repetition character - ; - S DGLIN=0 - S DGCNT=0 - S DGBLK=0 - S DGREP=$E(DGHL("ECH"),2) - ; - F S DGLIN=$O(@DGWP@(DGLIN)) Q:'DGLIN D - . S DGTXT=$G(@DGWP@(DGLIN,0)) - . S DGTXT=$$STRIPTS^DGPFHLUT(DGTXT) ;strip trailing spaces - . I DGTXT?1.PC!(DGTXT="") S DGBLK=DGBLK+1 Q - . S DGCNT=DGCNT+1 - . I DGBLK D - . . S DGARR(DGCNT)=$$REPEAT^XLFSTR(DGREP,DGBLK)_DGTXT - . . S DGBLK=0 - . E S DGARR(DGCNT)=DGTXT - Q DGCNT - ; -NXTSEG(DGROOT,DGCURR,DGFS,DGFLD) ;retrieves next sequential segment - ; This function retrieves the next segment in the work global, returns - ; an array of field values and the segment's work global index. If - ; the next segment does not exist, then the function returns a zero. - ; - ; Input: - ; DGROOT - close root name of work global - ; DGCURR - index of current segment - ; DGFS - HL7 field separator character - ; - ; Output: - ; Function Value - index of the next segment on success, 0 on failure - ; DGFLD - array of segment field values - ; - N NXTSEG - ; - S DGCURR=DGCURR+1 - S NXTSEG=$G(@DGROOT@(DGCURR,0)) - I NXTSEG]"" D - . D GETFLDS(NXTSEG,DGFS,.DGFLD) - E D - . S DGCURR=0 - Q DGCURR - ; -GETFLDS(DGSEG,DGFS,DGFLD) ;retrieve HL7 segment fields into an array - ;This procedure parses a single HL7 segment and builds an array - ;subscripted by the field number that contains the data for that field. - ;An additional subscript node, "TYPE" is created containing the segment - ;type. - ; - ; Input: - ; DGSEG - HL7 segment to parse - ; DGFS - HL7 field separator - ; - ; Output: - ; DGFLD - array of segment field values subscripted by field # - ; Example: DGFLD(2)="DOE,JOHN" - ; - N DGI - ; - S DGFLD("TYPE")=$P(DGSEG,DGFS) - F DGI=2:1:$L(DGSEG,DGFS) D - . S DGFLD($S(DGFLD("TYPE")="MSH":DGI,1:DGI-1))=$P(DGSEG,DGFS,DGI) - Q - ; -STRIPTS(DGSTR) ;Strip trailing spaces from a line of text - ; - ; Input: - ; DGSTR - Text string - ; - ; Output: - ; Function Value - Input text string with trailing spaces removed - ; - N SPACE - S SPACE=$C(32) - F Q:$E(DGSTR,$L(DGSTR))'=SPACE S DGSTR=$E(DGSTR,1,$L(DGSTR)-1) - Q DGSTR - ; -BLDSEG(DGTYP,DGVAL,DGHL) ;generic segment builder - ; - ; Input: - ; DGTYP - segment type - ; DGVAL - field data array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component] - ; DGHL - HL7 environment array - ; - ; Output: - ; Function Value - Formatted HL7 segment on success, "" on failure - ; - N DGCMP ;component subscript - N DGCMPVAL ;component value - N DGFLD ;field subscript - N DGFLDVAL ;field value - N DGREP ;repetition subscript - N DGREPVAL ;repetition value - N DGSUB ;sub-component subscript - N DGSUBVAL ;suc-component value - N DGFS ;field separator - N DGCS ;component separator - N DGRS ;repetition separator - N DGSS ;sub-component separator - N DGSEG - N DGSEP - ; - Q:($G(DGTYP)']"") "" - ; - S DGSEG=DGTYP - S DGFS=DGHL("FS") - S DGCS=$E(DGHL("ECH")) - S DGRS=$E(DGHL("ECH"),2) - S DGSS=$E(DGHL("ECH"),4) - ; - F DGFLD=1:1:$O(DGVAL(""),-1) D - . S DGFLDVAL=$G(DGVAL(DGFLD)),DGSEP=DGFS - . D ADD(DGFLDVAL,DGSEP,.DGSEG) - . F DGREP=1:1:$O(DGVAL(DGFLD,""),-1) D - . . S DGREPVAL=$G(DGVAL(DGFLD,DGREP)) - . . S DGSEP=$S(DGREP=1:"",1:DGRS) - . . D ADD(DGREPVAL,DGSEP,.DGSEG) - . . F DGCMP=1:1:$O(DGVAL(DGFLD,DGREP,""),-1) D - . . . S DGCMPVAL=$G(DGVAL(DGFLD,DGREP,DGCMP)) - . . . S DGSEP=$S(DGCMP=1:"",1:DGCS) - . . . D ADD(DGCMPVAL,DGSEP,.DGSEG) - . . . F DGSUB=1:1:$O(DGVAL(DGFLD,DGREP,DGCMP,""),-1) D - . . . . S DGSUBVAL=$G(DGVAL(DGFLD,DGREP,DGCMP,DGSUB)) - . . . . S DGSEP=$S(DGSUB=1:"",1:DGSS) - . . . . D ADD(DGSUBVAL,DGSEP,.DGSEG) - Q DGSEG - ; -ADD(DGVAL,DGSEP,DGSEG) ;append a value onto segment - ; - ; Input: - ; DGVAL - value to append - ; DGSEP - HL7 separator - ; - ; Output: - ; DGSEG - segment passed by reference - ; - S DGSEP=$G(DGSEP) - S DGVAL=$G(DGVAL) - S DGSEG=DGSEG_DGSEP_DGVAL - Q - ; -CKSTR(DGFLDS,DGSTR) ;validate comma-delimited HL7 field string - ; - ; Input: - ; DGFLDS - (required) comma delimited string of required fields - ; DGSTR - (optional) comma delimited string of fields to include - ; in an HL7 segment. - ; - ; Output: - ; Function Value - validated string of fields - ; - N DGI ;generic index - N DGREQ ;required field - ; - Q:($G(DGFLDS)']"") "" - S DGSTR=$G(DGSTR) - F DGI=1:1 S DGREQ=$P(DGFLDS,",",DGI) Q:DGREQ="" D - . I ","_DGSTR_","'[(","_DGREQ_",") S DGSTR=DGSTR_$S($L(DGSTR)>0:",",1:"")_DGREQ - Q DGSTR diff -auBN ./r1/DGPFLF1.m ./r2/r/DGPFLF1.m --- ./r1/DGPFLF1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLF1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,175 +0,0 @@ -DGPFLF1 ;ALB/KCL - PRF FLAG MANAGEMENT BUILD LIST AREA ; 3/11/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EN(DGARY,DGCAT,DGSRTBY,DGCNT) ;Entry point to build list area for PRF Flags. - ; - ; The following variables are 'system wide variables' in the - ; DGPF RECORD FLAG MANAGEMENT List Manager application: - ; Input: - ; DGARY - global array subscript - ; DGCAT - flag category (1=National, 2=Local) - ; DGSRTBY - list sort by criteria (N=Flag Name, T=Flage Type) - ; - ; Output: - ; DGCNT - number of lines in the list - ; - ;display wait msg - D WAIT^DICD - ; - ;retrieve all flags for the category specified - D GET(DGARY,DGCAT,DGSRTBY) - ; - ;build list area for flag screen - D BLD(DGSRTBY,.DGCNT) - ; - ;if no entries in list, display message in list area - I 'DGCNT D - . D SET^DGPFLMU1(DGARY,1,"",1,,,.DGCNT) - . D SET^DGPFLMU1(DGARY,2,"There are currently no flags on file to display.",4,$G(IOINHI),$G(IOINORM),.DGCNT) - ; - Q - ; - ; -GET(DGARY,DGCAT,DGSRTBY) ;Get flag entries for display. - ; - ; Input: - ; DGARY - global array subscript - ; DGCAT - flag category (1=National, 2=Local) - ; DGSRTBY - list sort by criteria (N=Flag Name, T=Flage Type) - ; - ; Output: None - ; - N DGFILE ;file root of LOCAL or NATIONAL flag file - N DGFLAG ;local array used to hold flag record - N DGIEN ;ien of record in LOCAL or NATIONAL flag file - N DGVPTR ;IEN of record in PRF NATIONAL FLAG or PRF LOCAL FLAG file - N DGRSULT - ; - ;determine LOCAL or NATIONAL flag file - S DGFILE=$S(DGCAT=1:"^DGPF(26.15)",DGCAT=2:"^DGPF(26.11)",1:0) - ; - ;loop through each ien of flag file determined by value of DGFILE - S DGIEN=0 F S DGIEN=$O(@DGFILE@(DGIEN)) Q:'DGIEN D - . K DGFLAG - . ;- if national, get flag into DGFLAG array - . I DGCAT=1 D Q:'$G(DGRSULT) - . . S DGRSULT=$$GETNF^DGPFANF(DGIEN,.DGFLAG) - . . S:DGRSULT DGVPTR=DGIEN_";DGPF(26.15," - . ; - . ;- if local, get flag into DGFLAG array - . I DGCAT=2 D Q:'$G(DGRSULT) - . . S DGRSULT=$$GETLF^DGPFALF(DGIEN,.DGFLAG) - . . S:DGRSULT DGVPTR=DGIEN_";DGPF(26.11," - . ; - . ;- set flag entry into sorted output array - . D SORT(DGVPTR,DGSRTBY,DGIEN,.DGFLAG) - ; - Q - ; - ; -SORT(DGVPTR,DGSRTBY,DGIEN,DGFLAG) ;Set flag data into sorted output array based on the sort criteria passed. - ; - ; Input: - ; DGVPTR - IEN of record in PRF NATIONAL FLAG or PRF LOCAL FLAG file - ; [ex: "1;DGPF(26.15,"] - ; DGSRTBY - list sort by criteria (N=Flag Name, T=Flage Type) - ; DGIEN - ien of record in LOCAL or NATIONAL flag file - ; DGFLAG - local array containing flag record - ; - ; Output: - ; Temporary global with following structure - - ; Flag list sorted by flag name: - ; ^TMP("DGPFSORT",$J,,,)=^^^ - ; OR - ; Flag list sorted by flag type: - ; ^TMP("DGPFSORT",$J,,,)=^^^ - ; - I DGSRTBY="N" D ;flag name - . S ^TMP("DGPFSORT",$J,$P($G(DGFLAG("STAT")),U),$P($G(DGFLAG("FLAG")),U,2),DGIEN)=DGVPTR_U_$P($G(DGFLAG("FLAG")),U,2)_U_$P($G(DGFLAG("TYPE")),U,2)_U_$P($G(DGFLAG("STAT")),U,2) - E D ;else flag type - . S ^TMP("DGPFSORT",$J,$P($G(DGFLAG("STAT")),U),$P($G(DGFLAG("TYPE")),U,2),DGIEN)=DGVPTR_U_$P($G(DGFLAG("FLAG")),U,2)_U_$P($G(DGFLAG("TYPE")),U,2)_U_$P($G(DGFLAG("STAT")),U,2) - ; - Q - ; - ; -BLD(DGSRTBY,DGCNT) ;Build list area for flag screen. - ; - ; Input: - ; DGSRTBY - list sort by criteria (N=Flag Name, T=Flage Type) - ; - ; Output: - ; DGCNT - number of lines in the list - ; - N DGFIEN ;^tmp global subscript (flag ien) - N DGLINE ;line counter - N DGNAME ;flag name - N DGNUM ;list selction number - N DGSI ;flag status internal value - N DGSTAT ;flag status - N DGSUB ;^tmp global subscript (flag name or type) - N DGTYPE ;flag type - N DGVPTR ;IEN of record in PRF NATIONAL FLAG or PRF LOCAL FLAG file - ; [ex: "1;DGPF(26.15,"] - N DGTEMP ;sort array root - ; - ;init line counter and selection number - S (DGLINE,DGNUM)=0 - ;- loop through ^TMP global by status, active (1) then inactive (0) - F DGSI=1,0 D - . ;- loop through sort selection by flag name or flag type - . S DGSUB=$S(DGSRTBY="N":"",1:0) - . F S DGSUB=$O(^TMP("DGPFSORT",$J,DGSI,DGSUB)) Q:DGSUB="" D - . . ;- loop through flag file ien's - . . S DGFIEN=0 - . . F S DGFIEN=$O(^TMP("DGPFSORT",$J,DGSI,DGSUB,DGFIEN)) Q:'DGFIEN D - . . . ;-- get flag data fields from entry in ^TMP global - . . . S DGTEMP=$NA(^TMP("DGPFSORT",$J)) - . . . S DGVPTR=$P($G(@DGTEMP@(DGSI,DGSUB,DGFIEN)),U) ;flag IEN - . . . S DGNAME=$P($G(@DGTEMP@(DGSI,DGSUB,DGFIEN)),U,2) ;flag name - . . . S DGTYPE=$P($G(@DGTEMP@(DGSI,DGSUB,DGFIEN)),U,3) ;flag type - . . . S DGSTAT=$P($G(@DGTEMP@(DGSI,DGSUB,DGFIEN)),U,4) ;flag status - . . . ; - . . . ;-- increment selection number - . . . S DGNUM=DGNUM+1 - . . . ; - . . . ;-- increment line counter - . . . S DGLINE=DGLINE+1 - . . . ; - . . . ;-- set line into list area - . . . D SET(DGARY,DGLINE,DGNUM,1,,,DGVPTR,DGNUM,.DGCNT) - . . . D SET(DGARY,DGLINE,DGNAME,6,,,DGVPTR,DGNUM,.DGCNT) - . . . D SET(DGARY,DGLINE,DGTYPE,38,,,DGVPTR,DGNUM,.DGCNT) - . . . D SET(DGARY,DGLINE,DGSTAT,65,,,DGVPTR,DGNUM,.DGCNT) - ; - Q - ; - ; -SET(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGVPTR,DGNUM,DGCNT) ;This procedure will set the lines of flag details in the LM display area. - ; - ; Input: - ; DGARY - global array subscript - ; DGLINE - line number - ; DGTEXT - text - ; DGVPTR - (optional) IEN of record in PRF NATIONAL FLAG or PRF LOCAL - ; FLAG file [ex: "1;DGPF(26.15,"] - ; DGNUM - (optional) selection number - ; DGCOL - starting column - ; DGON - highlighting on - ; DGOFF - highlighting off - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - N DGX - S:DGLINE>DGCNT DGCNT=DGLINE - S DGX=$S($D(^TMP(DGARY,$J,DGLINE,0)):^(0),1:"") - S ^TMP(DGARY,$J,DGLINE,0)=$$SETSTR^VALM1(DGTEXT,DGX,DGCOL,$L(DGTEXT)) - D:$G(DGON)]""!($G(DGOFF)]"") CNTRL^VALM10(DGLINE,DGCOL,$L(DGTEXT),$G(DGON),$G(DGOFF)) - ; - ;associate flag ien with list item for flag selection - S:($G(DGVPTR)]"")&($G(DGNUM)) ^TMP(DGARY,$J,"IDX",DGLINE,DGNUM)="" - S:($G(DGVPTR)]"")&($G(DGNUM)) ^TMP(DGARY,$J,"IDX",DGNUM)=DGVPTR - Q diff -auBN ./r1/DGPFLF2.m ./r2/r/DGPFLF2.m --- ./r1/DGPFLF2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLF2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,101 +0,0 @@ -DGPFLF2 ;ALB/KCL - PRF FLAG MANAGEMENT LM PROTOCOL ACTIONS ; 3/18/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; - ; -SL ;Entry point for DGPF SORT FLAG LIST action protocol. - ; - ; Input: - ; DGSRTBY - flag list sort by criteria (N=Flag Name, T=Flage Type) - ; - ; Output: - ; DGSRTBY - flag list sort by criteria (N=Flag Name, T=Flage Type) - ; VALMBCK - 'R' = refresh screen - ; - N DGCODE,DGFG - ; - ;set screen to full scrolling region - D FULL^VALM1 - ; - D - . ;- prompt for sort criteria - . W ! - . S DGFG=DGSRTBY ;save original sort to default to - . S DGCODE="Y" ;DIC(0)="Y" for Yes/No answering - . S DGSRTBY=$$ANSWER^DGPFUT("Would you like to sort the list by '"_$S($G(DGFG)="N":"Flag Type",1:"Flag Name")_"'","Yes",DGCODE) - . I $G(DGSRTBY)'=1 S DGSRTBY=DGFG Q ;no sort change - . S DGSRTBY=$S($G(DGFG)="N":"T",1:"N") ;change sort (flip / flop) - . ; - . ;- re-build list for selected sort criteria - . D BLD^DGPFLF - ; - ;return to LM (refresh screen) - S VALMBCK="R" - Q - ; - ; -CC ;Entry point for DGPF CHANGE CATEGORY action protocol. - ; - ; Input: - ; DGCAT - flag category (1=National, 2=Local) - ; - ; Output: - ; DGCAT - flag category (1=National, 2=Local) - ; VALMBCK - 'R' = refresh screen - ; - N DGCODE - N DGFG - ; - ;set screen to full scrolling region - D FULL^VALM1 - ; - ;change category - S DGCAT=$S($G(DGCAT)=1:2,1:1) - ; - ;re-build list for category change - D BLD^DGPFLF - ; - ;return to LM (refresh screen) - S VALMBCK="R" - Q - ; - ; -DF ;Entry point for DGPF DISPLAY FLAG DETAIL action protocol. - ; - ; Input: - ; - ; Output: - ; VALMBCK - 'R' = refresh screen - ; - N SEL ;user selection - N VALMY ;output of EN^VALM2 call, array of user selected entries - N DGPFIEN ;IEN of record in PRF NATIONAL FLAG or PRF LOCAL FLAG file - ; [ex: "1;DGPF(26.15,"] - ; - ;set screen to full scroll region - D FULL^VALM1 - ; - ;is action selection allowed? - I '$D(@VALMAR@("IDX")) D Q - . W !!?2,">>> '"_$P($G(XQORNOD(0)),U,3)_"' action not allowed at this point.",*7 - . W !?6,"There are no record flags to display." - . D PAUSE^VALM1 - . S VALMBCK="R" - ; - ;ask user to select a single flag for displaying details - S (SEL,DGPFIEN,VALMBCK)="" - D EN^VALM2($G(XQORNOD(0)),"S") - ; - ;process user selection - S SEL=$O(VALMY("")) - I SEL,$D(@VALMAR@("IDX",SEL)) D - . S DGPFIEN=$P($G(@VALMAR@("IDX",SEL)),U) - . ;- display flag details - . N VALMHDR - . D EN^DGPFLFD - ; - ;return to LM (refresh screen) - S VALMBCK="R" - Q diff -auBN ./r1/DGPFLF3.m ./r2/r/DGPFLF3.m --- ./r1/DGPFLF3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLF3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,173 +0,0 @@ -DGPFLF3 ;ALB/RBS - PRF FLAG MANAGEMENT LM PROTOCOL ACTIONS CONT. ; 7/31/03 3:03pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; - ; -AF ;Entry point for DGPF ADD FLAG action protocol. - ; - ; Input: DGCAT - flag category (1=National, 2=Local) - ; - ; Output: New File entry in PRF LOCAL FLAG FILE (#26.11) - ; New File entry in PRF LOCAL FLAG HISTORY FILE (#26.12) - ; Set variable VALMBCK to 'R' = refresh screen - ; - N DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK ;input vars for EN^DIWE call - N DGASK ;return value from call to ^DIR - $$ANSWER^DGPFUT call - N DGCKWP ;check if word-processing is OK - N DGPFLF ;array containing flag record field values - N DGPFLH ;array containing flag history record field values - N DGABORT ;abort flag - N DGRESULT ;result of $$STOALL^DGPFALF1 api call - N DGRDAY ;review frequency var - N DGNDAY ;notification days var - N DGERR ;if error returned from $$STOALL^DGPFALF1 api call - N DGOK ;ok flag to enter record flag entry & flag description - N DGMSG ;user message - N DGCNT,DGLINE,DGQ ;counters and quit flag - ; - S DGOK=1,(DGCNT,DGLINE,DGQ,DGABORT)=0 - S DGMSG="W !?2,"">>> '""_$P($G(XQORNOD(0)),U,3)_""' action not allowed for Category II (Local) Flags."",*7" - ; - ;set screen to full scrolling region - D FULL^VALM1 - W ! - ;check of Category var - Only Local Flags can be created - I DGCAT=1 D - . W !?2,">>> '",$P($G(XQORNOD(0)),U,3),"' action not allowed for Category I (National) Flags.",*7 - . W !?7,"Only Category II (Local) Flags may be created at the local site.",*7 - . S DGOK=0 - . D PAUSE^VALM1 - ; - ;check of security key - I DGOK,'$D(^XUSEC("DGPF LOCAL FLAG EDIT",DUZ)) D - . X DGMSG - . W !?7,"You do not have the appropriate Security Key.",*7 - . S DGOK=0 - . D PAUSE^VALM1 - ; - ;user prompts - D:DGOK - . ;-- init flag record and history arrays - . ; The DGPFLF array will contain 2 "^" pieces (internal^external) - . ; for a final full screen display before filing. - . K DGPFLF,DGPFLH - . ; - . ;-- prompt for flag name, quit if one not entered - . S DGASK=$$ANSWER^DGPFUT("Enter the Record Flag Name","","26.11,.01^^I $D(^DGPF(26.11,""B"",X)) K X W "" *** Flag name already on file""") - . I DGASK=-1!(DGASK=0) S DGABORT=1 Q - . S DGPFLF("FLAG")=DGASK_U_DGASK - . ; - . ;-- prompt for status of the flag, quit if one not entered - . S DGASK=$$ANSWER^DGPFUT("Enter the Status of the Flag","ACTIVE","26.11,.02") - . I DGASK<0 S DGABORT=1 Q - . S DGPFLF("STAT")=DGASK_U_$$EXTERNAL^DILFD(26.11,.02,"F",DGASK) - . ; - . ;-- prompt for flag type, quit if one not entered - . S DGASK=$$ANSWER^DGPFUT("Enter the Type of the Flag","","26.11,.03") - . I DGASK'>0 S DGABORT=1 Q - . S DGPFLF("TYPE")=DGASK_U_$$EXTERNAL^DILFD(26.11,.03,"F",DGASK) - . ; - . ;-- prompt for principal investigator(s) name for RESEARCH flag type - . I +DGPFLF("TYPE")=2,'$$PRININV^DGPFLF6(0,.DGPFLF) D Q:DGABORT - . . I $$ANSWER^DGPFUT("Enter RETURN to continue or '^' to exit","","E")=-1 S DGABORT=1 - . ; - . ;-- prompt for review frequency, quit if user aborts - . S DGASK=$$ANSWER^DGPFUT("Enter the Review Frequency Days","","26.11,.04^^K:$L(X)>4!(X[""."") X") - . I DGASK<0 S DGABORT=1 Q - . S DGPFLF("REVFREQ")=DGASK_U_DGASK - . S DGRDAY=DGASK - . I DGASK=0 D - . . ;-- if review frequency=0, don't ask notification/review group - . . ; reset both fields - . . S DGPFLF("NOTIDAYS")=0_U_0 - . . S DGPFLF("REVGRP")=""_U_"" - . . ; - . E D Q:DGABORT ;continue to prompt user and check abort logic - . . ; - . . ;-- prompt for notification days - . . S DGASK=$$ANSWER^DGPFUT("Enter the Notification Days","","26.11,.05^^K:$L(X)>4!(X[""."")!(X>DGRDAY) X") - . . I DGASK<0 S DGABORT=1 Q - . . S DGPFLF("NOTIDAYS")=DGASK_U_DGASK - . . ; - . . S DGQ=0 - . . F D Q:(DGQ!DGABORT) - . . . ;-- prompt for review mail group name, optional entry - . . . S DGASK=$$ANSWER^DGPFUT("Enter the Review Mail Group","","26.11,.06") - . . . I DGASK<0 S DGABORT=1 Q - . . . I DGASK'>0 D Q - . . . . W !," >>> You've entered the Review Frequency and Notification Days," - . . . . W !," now enter a Review Mail Group or abort this process.",*7 - . . . . I '$$CONTINUE^DGPFUT() S DGABORT=1 - . . . ; - . . . S DGPFLF("REVGRP")=DGASK_U_$$EXTERNAL^DILFD(26.11,.06,"F",DGASK) - . . . S DGQ=1 ;set entry, quit - . ; - . ;-- have user enter flag description text (required) - . S DGCKWP=0 - . S DGWPROOT=$NA(^TMP($J,"DGPFDESC")) - . K @DGWPROOT - . F D Q:(DGCKWP!DGABORT) - . . W !,"Enter the description for this new record flag:" ;needed for line editor - . . S DIC=$$OREF^DILF(DGWPROOT) - . . S DIWETXT="Patient Record Flag - Flag Description Text" - . . S DIWESUB="Flag Description Text" - . . S DWLW=75 ;max # of chars allowed to be stored on WP global node - . . S DWPK=1 ;if line editor, don't join line - . . D EN^DIWE - . . I $$CKWP^DGPFUT(DGWPROOT) S DGCKWP=1 Q - . . W !,"Flag Description Text is required!",!,*7 - . . I '$$CONTINUE^DGPFUT() S DGABORT=1 - . ; - . ;-- quit if required flag description not entered - . Q:DGABORT - . ; - . ;-- place flag description text into assignment array - . M DGPFLF("DESC")=@DGWPROOT K @DGWPROOT - . ; - . ;-- re-display user's answers on full screen - . S (DGLINE,DGCNT)=0 - . S DGPFLF("PTR")="26.11" - . K ^TMP("DGPFDISP",$J) - . ; - . D FLAGDET^DGPFLFD1("DGPFDISP",.DGPFLF,.DGLINE,.DGCNT) - . ; - . W:$E(IOST,1,2)="C-" @IOF - . S (DGCNT,DGQ)=0 - . F S DGCNT=$O(^TMP("DGPFDISP",$J,DGCNT)) Q:DGCNT="" D Q:DGQ - . . I $Y+3>IOSL W *7,!,"<...There is more Description to display but we need to file this now...>" S DGQ=1 Q - . . W:^TMP("DGPFDISP",$J,DGCNT,0)]"" !,^TMP("DGPFDISP",$J,DGCNT,0) - . ; - . K DGPFLF("PTR") ;clean up - . K ^TMP("DGPFDISP",$J) ;clean up - . ; - . W !,*7 - . I $$ANSWER^DGPFUT("Would you like to file this new local record flag","YES","Y")'>0 S DGABORT=1 Q - . ; - . W !,"Filing the new local record flag..." - . ; - . ;-- setup remaining flag history array nodes for filing - . ; note, the DGPFLH("FLAG") will be setup in $$STOALL^DGPFALF1 - . S DGPFLH("ENTERDT")=$$NOW^XLFDT() ;current date/time - . S DGPFLH("ENTERBY")=DUZ ;current user - . S DGPFLH("REASON",1,0)="New Local Patient Record Flag entered." - . ; - . ;-- file both the (#26.11) & (#26.12) entries - . S DGRESULT=$$STOALL^DGPFALF1(.DGPFLF,.DGPFLH,.DGERR) - . ; - . W !!," >>> Local record flag was "_$S(+DGRESULT:"filed successfully.",1:"not filed successfully."),*7 - . ; - . D PAUSE^VALM1 - ; - I DGABORT D - . W !," >>> The '"_$P($G(XQORNOD(0)),U,3)_"' action is aborting, nothing has been filed.",*7 - . I $$ANSWER^DGPFUT("Enter RETURN to continue","","E") ;pause - ; - ;re-build list of local record flags - D BLD^DGPFLF - ; - ;return to LM (refresh screen) - S VALMBCK="R" - Q - ; diff -auBN ./r1/DGPFLF4.m ./r2/r/DGPFLF4.m --- ./r1/DGPFLF4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLF4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,168 +0,0 @@ -DGPFLF4 ;ALB/RBS - PRF FLAG MANAGEMENT LM PROTOCOL ACTIONS CONT. ; 5/15/03 11:48am - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EF ;Entry point for DGPF EDIT FLAG action protocol. - ; - ; Input: DGCAT - flag category (1=National, 2=Local) - ; - ; Output: Edit File entry in PRF LOCAL FLAG FILE (#26.11) - ; New File entry in PRF LOCAL FLAG HISTORY FILE (#26.12) - ; Set variable VALMBCK to 'R' = refresh screen - ; - N X,Y,DIRUT,DTOUT,DUOUT,DIROUT ;input/output vars for ^DIR - N DGIDXIEN ;ien of flag record from the "IDX" - N DGPFLF ;array containing flag record field values - N DGPFLH ;array containing flag history record field values - N DGPFORIG ;save original array containing flag record field values - N DGABORT ;abort flag - N DGRESULT ;result of $$STOALL^DGPFALF1 api call - N DGERR ;if error returned from $$STOALL^DGPFALF1 api call - N DGOK ;ok flag to enter record flag entry & flag description - N DGLOCK ;lock var for flag file edit - N DGSEL ;user selection (list item) - N VALMY ;output of EN^VALM2 call, array of user selected entries - N DGMSG ;user message - N DGCNT,DGLINE,DGQ,DGSUB ;counters and quit flag - ; - S (DGCNT,DGLINE,DGQ,DGSUB)=0 - ; - S DGOK=1,(DGSEL,DGIDXIEN)="" - S (DGABORT,DGLOCK,DGRESULT)=0 - S DGMSG="W !?2,"">>> '""_$P($G(XQORNOD(0)),U,3)_""' action not allowed for Category II (Local) Flags."",*7" - ; - ;- set screen to full scrolling region - D FULL^VALM1 - W ! - ;- check of Category var - Only Local Flags can be created - I DGCAT=1 D - . W !?2,">>> '",$P($G(XQORNOD(0)),U,3),"' action not allowed for Category I (National) Flags.",*7 - . W !?7,"Only Category II (Local) Flags may be edited.",*7 - . S DGOK=0 - . D PAUSE^VALM1 - ; - ;- check of security key - I DGOK,'$D(^XUSEC("DGPF LOCAL FLAG EDIT",DUZ)) D - . X DGMSG - . W !?7,"You do not have the appropriate Security Key.",*7 - . S DGOK=0 - . D PAUSE^VALM1 - ; - ;-- init flag record and history arrays - ; The DGPFLF array will contain 2 "^" pieces (internal^external) - ; for a final full screen display before filing. - K DGPFLF,DGPFLH,DGPFORIG - ; - ;- allow user to select a single flag for editing - D:DGOK - . S DGOK=0,VALMBCK="" - . D EN^VALM2($G(XQORNOD(0)),"S") - . Q:'$D(VALMY) - . S DGSEL=$O(VALMY("")) - . Q:DGSEL']"" - . Q:'$D(@VALMAR@("IDX",DGSEL)) - . S DGIDXIEN=$G(@VALMAR@("IDX",DGSEL)) - . ; lock flag record - . S DGLOCK=$$LOCKLF^DGPFALF1(DGIDXIEN) - . I 'DGLOCK D Q - . . X DGMSG - . . W !?7,"Unable to Lock Flag, another User is Editing this Flag.",*7 - . . D PAUSE^VALM1 - . ; - . ; call api to get record back in array DGPFLF - . I '$$GETLF^DGPFALF($P(DGIDXIEN,";"),.DGPFLF) D Q - . . X DGMSG - . . W !?7,"No Local Flag record data found. Please check your selection.",*7 - . . D PAUSE^VALM1 - . ; - . M DGPFORIG=DGPFLF ;save original array to compare for edits later - . S DGOK=1 - ; - ;-- Call DGPFLF5 for user prompts to edit fields - ; - split from this one due to size - I DGOK D - . D EFCONT^DGPFLF5(.DGPFLF,.DGPFLH,.DGPFORIG,.DGABORT,DGIDXIEN) - . Q:DGABORT - . ; - . ;-- re-display user's answers on full screen - . S (DGLINE,DGCNT)=0 - . S DGPFLF("PTR")="26.11" - . K ^TMP("DGPFDISP",$J) - . ; - . D FLAGDET^DGPFLFD1("DGPFDISP",.DGPFLF,.DGLINE,.DGCNT) - . ; - . W:$E(IOST,1,2)="C-" @IOF - . S (DGCNT,DGQ)=0 - . F S DGCNT=$O(^TMP("DGPFDISP",$J,DGCNT)) Q:DGCNT="" D Q:DGQ - . . I $Y+3>IOSL S DIR("A")="Enter RETURN to continue",DIR(0)="E" D ^DIR K DIR W:$E(IOST,1,2)="C-" @IOF - . . W !,^TMP("DGPFDISP",$J,DGCNT,0) - . ; - . K DGPFLF("PTR") ;clean up - . K ^TMP("DGPFDISP",$J) ;clean up - . ; - . W !!,"Enter/Edit Reason:",!,"------------------" - . S DGSUB=0 - . F S DGSUB=$O(DGPFLH("REASON",DGSUB)) Q:'DGSUB D - . . I $Y+3>IOSL S DIR("A")="Enter RETURN to continue",DIR(0)="E" D ^DIR K DIR W:$E(IOST,1,2)="C-" @IOF - . . W !,$G(DGPFLH("REASON",DGSUB,0)) - . ; - . ;-- check to see if user changed anything - . S DGSUB="",DGQ=0 - . I $G(DGPFLF("OLDFLAG"))]"" S DGQ=1 ;flag name has changed - . I 'DGQ D - . . F DGSUB="STAT","TYPE","REVFREQ","NOTIDAYS","REVGRP" D Q:DGQ - . . . I DGPFLF(DGSUB)'=DGPFORIG(DGSUB) S DGQ=1 - . . Q:DGQ - . . ; - . . ;was description modified? - . . I $O(DGPFLF("DESC",""),-1)'=$O(DGPFORIG("DESC",""),-1) S DGQ=1 - . . Q:DGQ - . . ; - . . S DGSUB=0 - . . F S DGSUB=$O(DGPFLF("DESC",DGSUB)) Q:DGSUB="" D Q:DGQ - . . . I DGPFLF("DESC",DGSUB,0)'=$G(DGPFORIG("DESC",DGSUB,0)) S DGQ=1 - . . Q:DGQ - . . ; - . . S DGSUB=0 - . . F S DGSUB=$O(DGPFLF("PRININV",DGSUB)) Q:DGSUB="" D Q:DGQ - . . . I DGPFLF("PRININV",DGSUB,0)'=$G(DGPFORIG("PRININV",DGSUB,0)) S DGQ=1 - . ; - . I 'DGQ D Q - . . W !!," >>> No edits to "_$P(DGPFLF("FLAG"),U,2)_" were found." - . . S DGABORT=1 - . ; - . K DGPFORIG ;kill array - no longer needed - . ; - . ; -- file the edits - . W !,*7 - . I $$ANSWER^DGPFUT("Would you like to file the local record flag changes","YES","Y")'>0 S DGABORT=1 Q - . ; - . W !,"Updating the local record flag..." - . ; - . ;-- setup remaining flag history array nodes for filing - . ; note, the DGPFLH("FLAG") will be setup in $$STOALL^DGPFALF1 - . S DGPFLH("ENTERDT")=$$NOW^XLFDT() ;current date/time - . S DGPFLH("ENTERBY")=DUZ ;current user - . ; - . ;-- file both the (#26.11) & (#26.12) entries - . S DGRESULT=$$STOALL^DGPFALF1(.DGPFLF,.DGPFLH,.DGERR) - . ; - . W !!," >>> Local record flag was "_$S(+DGRESULT:"filed successfully.",1:"not filed successfully."),*7 - . ; - . D PAUSE^VALM1 - ; - I DGLOCK,$$UNLOCK^DGPFALF1(DGIDXIEN) - ; - I DGABORT D - . W !!," >>> The '"_$P($G(XQORNOD(0)),U,3)_"' action is aborting, nothing has been filed.",*7 - . I $$ANSWER^DGPFUT("Enter RETURN to continue","","E") ;pause - ; - ;-- re-build list of local record flags - D BLD^DGPFLF - ; - ;- return to LM (refresh screen) - S VALMBCK="R" - Q - ; diff -auBN ./r1/DGPFLF5.m ./r2/r/DGPFLF5.m --- ./r1/DGPFLF5.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLF5.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,165 +0,0 @@ -DGPFLF5 ;ALB/RBS - PRF FLAG MANAGEMENT LM PROTOCOL ACTIONS CONT. ; 7/31/03 3:07pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EFCONT(DGPFLF,DGPFLH,DGPFORIG,DGABORT,DGIDXIEN) ; EF Edit Flag action - ;-- Continue entry point for DGPF EDIT FLAG action protocol. - ; - ; Input: - ; DGPFLF - array of flag record fields (passed by reference) - ; DGPFLH - array for REASON field (passed by reference) - ; DGPFORIG - DGPFLF copy of original values (passed by reference) - ; DGABORT - abort flag - value passed in = 0 - ; DGIDXIEN - ien of flag record from the "IDX" - ; - ; Output: - ; DGPFLF - Edited array of flag record fields - ; DGABORT - 1 if user wishes to abort, 0 otherwise - ; - N DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK ;input vars for EN^DIWE call - N DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT ;input/output vars for ^DIR - N DGDA ;default answer - N DGCKWP ;check if word-processing is OK - N DGASK ;return value from $$ANSWER^DGPFUT call - N DGRDAY ;review frequency - N DGQ,DGSUB ;counters and quit flag - ; - S (DGQ,DGSUB)=0 - ; - ;-- user prompts - D - . ;-- prompt for flag name, quit if one not entered - . S DGDA=$P($G(DGPFLF("FLAG")),U,2) - . S DGASK=$$ANSWER^DGPFUT("Enter the Record Flag Name",DGDA,"26.11,.01^^I X'=DGDA,$D(^DGPF(26.11,""B"",X)) K X W "" *** Flag name already on file""") - . I DGASK=-1!(DGASK=0) S DGABORT=1 Q - . I DGASK'=DGDA D - . . N DGACNT ;count of existing assignments - . . S DGACNT=$$ASGNCNT^DGPFLF6(DGIDXIEN) - . . I DGACNT D Q - . . . W !," >>> Name change not allowed ... "_DGACNT_" patients are assigned to this flag." - . . . S DGABORT=1 - . . S DGPFLF("OLDFLAG")=DGDA ;save for name change lookup - . . S DGPFLF("FLAG")=DGASK_U_DGASK - . Q:DGABORT - . ; - . ;-- prompt for status of the flag, quit if one not entered - . S DGDA=$P($G(DGPFLF("STAT")),U,2) - . S DGASK=$$ANSWER^DGPFUT("Enter the Status of the Flag",DGDA,"26.11,.02") - . I DGASK<0 S DGABORT=1 Q - . S:DGASK'=$P($G(DGPFLF("STAT")),U) DGPFLF("STAT")=DGASK_U_$$EXTERNAL^DILFD(26.11,.02,"F",DGASK) - . ; check for any Active Patient Assignments and give warning - . ; that all patients will be inactivated when this edit is filed - . I DGASK=0,$D(^DGPF(26.13,"ASTAT",1,DGIDXIEN)) D - . . W *7 S DIR("A",1)=" >>> WARNING - All Patient's assigned to this flag will be" - . . S DIR("A",2)=" Inactivated automatically after filing this edit." - . . S DIR("A")="Enter RETURN to continue",DIR(0)="E" D ^DIR K DIR - . ; - . ;-- prompt for flag type, quit if one not entered - . S DGDA=$P($G(DGPFLF("TYPE")),U,2) - . S DGASK=$$ANSWER^DGPFUT("Enter the Type of the Flag",DGDA,"26.11,.03") - . I DGASK'>0 S DGABORT=1 Q - . I DGASK'=$P($G(DGPFLF("TYPE")),U) D - . . N DGACNT ;count of existing assignments - . . S DGACNT=$$ASGNCNT^DGPFLF6(DGIDXIEN) - . . I DGACNT D Q - . . . W !," >>> Flag Type change not allowed ... "_DGACNT_" patients are assigned to this flag." - . . . S DGABORT=1 - . . S DGPFLF("TYPE")=DGASK_U_$$EXTERNAL^DILFD(26.11,.03,"F",DGASK) - . Q:DGABORT - . ; - . ;-- delete all principal investigator(s) if flag type not RESEARCH - . I +DGPFLF("TYPE")'=2,$D(DGPFLF("PRININV")) D - . . S DGSUB=0 - . . F S DGSUB=$O(DGPFLF("PRININV",DGSUB)) Q:DGSUB="" D - . . . S DGPFLF("PRININV",DGSUB,0)="@" - . ; - . ;-- prompt for principal investigator(s) name for RESEARCH type flag - . I +DGPFLF("TYPE")=2,'$$PRININV^DGPFLF6(+DGIDXIEN,.DGPFLF) D Q:DGABORT - . . I $$ANSWER^DGPFUT("Enter RETURN to continue or '^' to exit","","E")=-1 S DGABORT=1 S DGABORT=1 - . ; - . ;-- prompt for review frequency, quit if one not entered - . S DGDA=$P($G(DGPFLF("REVFREQ")),U,2) - . S DGASK=$$ANSWER^DGPFUT("Enter the Review Frequency Days",DGDA,"26.11,.04^^K:$L(X)>4!(X[""."") X") - . I DGASK<0 S DGABORT=1 Q - . S:DGASK'=$P($G(DGPFLF("REVFREQ")),U) DGPFLF("REVFREQ")=DGASK_U_DGASK - . S DGRDAY=DGASK - . I DGASK=0 D ;don't ask notification/review group when review freq = 0 - . . S DGPFLF("NOTIDAYS")=0_U_0 - . . S DGPFLF("REVGRP")=""_U_"" - . . ; - . E D Q:DGABORT - . . ; - . . ;-- prompt for notification days - . . S DGDA=$P($G(DGPFLF("NOTIDAYS")),U,2) - . . S DGASK=$$ANSWER^DGPFUT("Enter the Notification Days",DGDA,"26.11,.05^^K:$L(X)>4!(X[""."")!(X>DGRDAY) X") - . . I DGASK<0 S DGABORT=1 Q - . . S DGPFLF("NOTIDAYS")=DGASK_U_DGASK - . . ; - . . S DGQ=0 - . . F D Q:(DGQ!DGABORT) - . . . ;-- prompt for review mail group name, optional entry - . . . S DGDA=$P($G(DGPFLF("REVGRP")),U,2) - . . . S DGASK=$$ANSWER^DGPFUT("Enter the Review Mail Group",DGDA,"26.11,.06r") - . . . I DGASK<0 S DGABORT=1 Q - . . . I DGASK'>0 D Q - . . . . W !," >>> You've entered the Review Frequency and Notification Days," - . . . . W !," now enter a Review Mail Group or abort this process.",*7 - . . . . I '$$CONTINUE^DGPFUT() S DGABORT=1 - . . . ; - . . . S DGPFLF("REVGRP")=DGASK_U_$$EXTERNAL^DILFD(26.11,.06,"F",DGASK) - . . . S DGQ=1 ;set entry, quit - . ; - . ;-- ask user if they want to edit the flag description text - . I $$ANSWER^DGPFUT("Would you like to edit the description of this record flag","NO","Y")>0 D Q:DGABORT - . . S DGCKWP=0 K DGERR - . . S DGWPROOT=$NA(^TMP($J,"DGPFDESC")) - . . K @DGWPROOT - . . S DGDA=$$GET1^DIQ(26.11,$P(DGIDXIEN,";"),"1","Z",DGWPROOT,"DGERR") - . . I $D(DGERR)!(DGDA="") S DGABORT=1 D Q - . . . W !,"An error has occurred while trying to retrieve the Flag Description Text.",*7 - . . F D Q:(DGCKWP!DGABORT) - . . . S DIC=$$OREF^DILF(DGWPROOT) - . . . S DIWETXT="Patient Record Flag - Flag Description Text" - . . . S DIWESUB="Flag Description Text" - . . . S DWLW=75 ;max # chars allowed to be stored on WP global node - . . . S DWPK=1 ;if line editor, don't join line - . . . D EN^DIWE - . . . I $$CKWP^DGPFUT(DGWPROOT) S DGCKWP=1 Q - . . . W !,"Flag Description Text is required!",!,*7 - . . . I '$$CONTINUE^DGPFUT() S DGABORT=1 K @DGWPROOT - . . ; - . . ;-- quit if required flag description not entered - . . Q:DGABORT - . . ; - . . ;-- place flag description text into assignment array - . . I DGCKWP D - . . . K DGPFLF("DESC") - . . . M DGPFLF("DESC")=@DGWPROOT - . . . K @DGWPROOT - . ; - . Q:DGABORT - . ; - . ;-- have user enter edit reason (required) - . S DGCKWP=0 - . S DGWPROOT=$NA(^TMP($J,"DGPFREASON")) - . K @DGWPROOT - . F D Q:(DGCKWP!DGABORT) - . . W !!,"Enter the reason for editing this record flag:" ;needed for line editor - . . S DIC=$$OREF^DILF(DGWPROOT) - . . S DIWETXT="Patient Record Flag - Edit Reason Text" - . . S DIWESUB="Edit Reason Text" - . . S DWLW=75 ;max # chars allowed to be stored on WP global node - . . S DWPK=1 ;if line editor, don't join line - . . D EN^DIWE - . . I $$CKWP^DGPFUT(DGWPROOT) S DGCKWP=1 Q - . . W !,"Edit Reason Text is required!",!,*7 - . . I '$$CONTINUE^DGPFUT() S DGABORT=1 K @DGWPROOT - . ; - . Q:DGABORT - . I DGCKWP M DGPFLH("REASON")=@DGWPROOT K @DGWPROOT - . ; - . S:'DGCKWP DGABORT=1 - ; - Q diff -auBN ./r1/DGPFLF6.m ./r2/r/DGPFLF6.m --- ./r1/DGPFLF6.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLF6.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,114 +0,0 @@ -DGPFLF6 ;ALB/RPM - PRF FLAG MANAGEMENT LM SUB-ROUTINE ; 4/10/03 - ;;5.3;Registration;**425**;Aug 23, 1993 - ; - Q - ; -PRININV(DGFIEN,DGPFLF) ;Prompt for principle investigators - ; - ; Input: - ; DGFIEN - (optional) Pointer to PRF LOCAL FLAG (#26.11) file. - ; [default=0] - ; DGPFLF - Flag data array - ; - ; Output: - ; Function Value - 1 on success, 0 when user enters "^" - ; DGPFLF("PRININV") - Array of principal investigators - ; - N DGASK ;answer from prompt as a pointer to NEW PERSON (#200) file - N DGCNT ;place holder for new entries - N DGDA ;default answer for prompt - N DGLAST ;last entry in field entry array - N DGLKUP ;principle investigator dynamic "B" index - N DGNEWPI ;principal investigator in FM external form - N DGORIG ;principle investigator unmodified "B" index - N DGPREV ;next to last entry in field entry array - N DGQUIT ;loop termination flag - N DGRSLT ;function value - ; - S DGFIEN=+$G(DGFIEN) ;will be zero for 'Add Flag' - ; - ;build lookup and "on-file" array - M DGORIG=^DGPF(26.11,DGFIEN,2,"B") - M DGLKUP=DGORIG - ; - S DGRSLT=1 - S DGQUIT=0 - S (DGLAST,DGCNT)=+$O(DGPFLF("PRININV",""),-1) - ; - ;set default answer - S DGDA=$P($G(DGPFLF("PRININV",DGLAST,0)),U,2) - ; - F D Q:DGQUIT - . S DGASK=$$ANSWER^DGPFUT("Enter the Principal Investigator(s)",DGDA,"26.112,.01") - . ; - . ;stop prompting if user enters "^" or times out - . I DGASK=-1 S DGQUIT=1,DGRSLT=0 Q - . ; - . ;stop prompting if user accepts default entry - . I DGASK=$P($G(DGPFLF("PRININV",DGLAST,0)),U,1)!(DGASK="") S DGQUIT=1 Q - . ; - . ;perform lookup - re-prompt with new selection when entry exists - . I $D(DGLKUP(DGASK)) D Q - . . S DGLAST=+$O(DGLKUP(DGASK,0)) - . . S DGDA=$P(DGPFLF("PRININV",DGLAST,0),U,2) - . ; - . ;process delete - remove entry from lookup array and move last pointer - . ; to previous entry in list. Set the field entry - . ; array value to "@" when the entry is "on-file", - . ; otherwise, remove the field entry array node. - . I DGASK="@" D Q - . . Q:'$D(DGPFLF("PRININV",DGLAST,0)) - . . Q:'$$ANSWER^DGPFUT("Sure you want to delete '"_$P(DGPFLF("PRININV",DGLAST,0),U,2)_"' as a PRINCIPAL INVESTIGATOR","Yes","Y") - . . K DGLKUP($P(DGPFLF("PRININV",DGLAST,0),U,1)) - . . S DGPREV=+$O(DGPFLF("PRININV",DGLAST),-1) - . . I $D(DGORIG($P(DGPFLF("PRININV",DGLAST,0),U,1))) D - . . . S DGPFLF("PRININV",DGLAST,0)="@" - . . E D - . . . K DGPFLF("PRININV",DGLAST,0) - . . S DGLAST=DGPREV - . . S DGDA=$P($G(DGPFLF("PRININV",DGLAST,0)),U,2) - . ; - . ;process new entry - if we make it here, then the entry is not the - . ; default, does not already exist in the field - . ; entry array and is not a delete. Add entry - . ; to the lookup array and the field entry array. - . I DGDA=""!(DGASK'=$P($G(DGPFLF("PRININV",DGLAST,0)),U)) D - . . S DGNEWPI=$$EXTERNAL^DILFD(26.112,.01,"F",DGASK) - . . Q:'$$ANSWER^DGPFUT("Are you adding '"_DGNEWPI_"' as a new PRINCIPAL INVESTIGATOR","No","Y") - . . S DGCNT=DGCNT+1 - . . S DGLKUP(DGASK,DGCNT)="" - . . S DGPFLF("PRININV",DGCNT,0)=DGASK_U_DGNEWPI - . . S DGDA="" - ; - Q DGRSLT - ; -ASGNCNT(DGFIEN,DGDFNLST) ;counts existing assignments for a given flag - ;This function searches for assignments for a given flag IEN and - ;returns the count of assignments. An optional array parameter will - ;be loaded with the DFNs assigned to the flag. - ; - ; Input: - ; DGFIEN - (required) Pointer to PRF LOCAL FLAG (#26.11) file or - ; PRF NATIONAL FLAG (#26.15) file. - ; DGDFNLST - (optional) Array name to contain list of DFNs - ; - ; Output: - ; Function Value - count of existing assignments - ; DGDFNLST - Defined only when existing assignments are found. - ; Array of DFNs from existing assignments. - ; Example: DGDFNLST(7172421)=assignment IEN - ; - N DGCNT ;function value - N DGDFN ;pointer to PATIENT (#2) file - ; - S DGCNT=0 - ; - I $G(DGFIEN)]"",$D(^DGPF(26.13,"AFLAG",DGFIEN)) D - . ; - . ;count the assignments - . S DGDFN=0 - . F S DGDFN=$O(^DGPF(26.13,"AFLAG",DGFIEN,DGDFN)) Q:'DGDFN D - . . S DGCNT=DGCNT+1 - . . S DGDFNLST(DGDFN)=+$O(^DGPF(26.13,"AFLAG",DGFIEN,DGDFN,0)) - ; - Q DGCNT diff -auBN ./r1/DGPFLFD1.m ./r2/r/DGPFLFD1.m --- ./r1/DGPFLFD1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLFD1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,222 +0,0 @@ -DGPFLFD1 ;ALB/KCL - PRF DISPLAY FLAG DETAIL BUILD LIST AREA ; 7/31/03 3:01pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EN(DGARY,DGPFIEN,DGCNT) ;Entry point to build flag detail list area. - ; - ; Input: - ; DGARY - global array subscript - ; DGPFIEN - IEN of record in PRF NATIONAL FLAG or PRF LOCAL - ; FLAG file [ex: "1;DGPF(26.15,"] - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - N DGPFF ;flag array - N DGPFFH ;flag history array - N DGFHIENS ;contains flag history ien's - N DGFHIEN ;flag history ien - N DGHISCNT ;history record counter - N DGLINE ;line counter - N DGSUB ;subscript of flag history ien's - ; - ;quit if required input paramater not passed - Q:'$G(DGPFIEN) - ; - ;init variables - S (DGCNT,DGLINE,DGHISCNT)=0 - K DGPFF - ; - ;get flag into DGPFF array - Q:'$$GETFLAG^DGPFUT1(DGPFIEN,.DGPFF) - S DGPFF("PTR")=DGPFIEN - ; - ;build 'Flag Details' list area - D FLAGDET(DGARY,.DGPFF,.DGLINE,.DGCNT) - ; - ;quit if NATIONAL flag, they don't have a history - Q:DGPFF("PTR")'["26.11" - ; - ;set history heading into list area - D HISTHDR(DGARY,.DGLINE,.DGCNT) - ; - ;get all history ien's associated with the flag - K DGFHIENS - Q:'$$GETALLDT^DGPFALH(+DGPFF("PTR"),.DGFHIENS) - ; - ;reverse loop through each flag history ien - S DGSUB=9999999.999999 - F S DGSUB=$O(DGFHIENS(DGSUB),-1) Q:DGSUB="" D - . S DGFHIEN=$G(DGFHIENS(DGSUB)) - . K DGPFFH - . ;- for each ien, get flag history into DGPFFH array - . I $$GETHIST^DGPFALH(DGFHIEN,.DGPFFH) D - . . ; - . . ;-- count of history records - . . S DGHISCNT=DGHISCNT+1 - . . ; - . . ;-- build flag history details list area - . . D HISTDET(DGARY,.DGPFFH,.DGLINE,DGHISCNT,.DGCNT) - ; - Q - ; - ; -FLAGDET(DGARY,DGPFF,DGLINE,DGCNT) ;This procedure will build the lines of FLAG details in the list area. - ; - ; Input: - ; DGARY - global array subscript - ; DGPFF - flag array, pass by reference - ; DGLINE - line counter - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - ;temp vars used - N DGSUB ;array subscript - N DGTEMP ;temp text holder - N DGCOUNT ;principal investigator count - ; - ;set flag name - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Flag Name: "_$P($G(DGPFF("FLAG")),U,2),18,,,,,.DGCNT) - ; - ;set flag category - S DGLINE=DGLINE+1 - S DGTEMP=$S(DGPFF("PTR")["26.11":"II (LOCAL)",DGPFF("PTR")["26.15":"I (NATIONAL)",1:"UNKNOWN") - D SET^DGPFLF1(DGARY,DGLINE,"Flag Category: "_DGTEMP,14,,,,,.DGCNT) - ; - ;set flag type - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Flag Type: "_$P($G(DGPFF("TYPE")),U,2),18,,,,,.DGCNT) - ; - ;set flag status - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Flag Status: "_$P($G(DGPFF("STAT")),U,2),16,,,,,.DGCNT) - ; - ;set flag review frequency - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Review Frequency Days: "_$P($G(DGPFF("REVFREQ")),U,2),6,,,,,.DGCNT) - ; - ;set notification days - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Notification Days: "_$P($G(DGPFF("NOTIDAYS")),U,2),10,,,,,.DGCNT) - ; - ;set flag review mail group - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Review Mail Group: "_$P($G(DGPFF("REVGRP")),U,2),10,,,,,.DGCNT) - ; - ;set if principal investigator(s) - I $D(DGPFF("PRININV")) D - . S (DGSUB,DGTEMP)="" - . S DGCOUNT=1 - . F S DGSUB=$O(DGPFF("PRININV",DGSUB)) Q:'DGSUB D - . . Q:$G(DGPFF("PRININV",DGSUB,0))="@" - . . I DGCOUNT=1 D - . . . S DGLINE=DGLINE+1 - . . . S DGTEMP="Principal Investigator(s): "_$P($G(DGPFF("PRININV",DGSUB,0)),U,2) - . . . D SET^DGPFLF1(DGARY,DGLINE,DGTEMP,2,,,,,.DGCNT) - . . I DGCOUNT>1 D - . . . S DGTEMP=$P($G(DGPFF("PRININV",DGSUB,0)),U,2) - . . . S DGLINE=DGLINE+1 - . . . D SET^DGPFLF1(DGARY,DGLINE,DGTEMP,29,,,,,.DGCNT) - . . S DGCOUNT=DGCOUNT+1 - ; - ;set flag description - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"",1,,,,,.DGCNT) - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Flag Description:",1,IORVON,IORVOFF,,,.DGCNT) - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"-----------------",1,,,,,.DGCNT) - I '$D(DGPFF("DESC",1,0)) D Q - . S DGLINE=DGLINE+1 - . D SET^DGPFLF1(DGARY,DGLINE,"Unknown",1,,,,,.DGCNT) - S DGSUB=0,DGTEMP="" - F S DGSUB=$O(DGPFF("DESC",DGSUB)) Q:'DGSUB D - . S DGTEMP=$G(DGPFF("DESC",DGSUB,0)) - . S DGLINE=DGLINE+1 - . D SET^DGPFLF1(DGARY,DGLINE,DGTEMP,1,,,,,.DGCNT) - ; - Q - ; - ; -HISTDET(DGARY,DGPFFH,DGLINE,DGHISCNT,DGCNT) ;This procedure will build the lines of FLAG HISTORY details in the list area. - ; - ; Input: - ; DGARY - global array subscript - ; DGPFFH - flag history array, pass by reference - ; DGLINE - line counter - ; DGHISCNT - history record counter - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - ;temporary variables used - N DGTEMP - N DGSUB - S DGTEMP="" - ; - ;set blank line - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"",1,,,,,.DGCNT) - ; - ;add an additional blank line except on the first history - I DGHISCNT>1 D - . S DGLINE=DGLINE+1 - . D SET^DGPFLF1(DGARY,DGLINE,"",1,,,,,.DGCNT) - ; - ;set history counter - S DGLINE=DGLINE+1 - S DGTEMP=DGHISCNT_"." - D SET^DGPFLF1(DGARY,DGLINE,DGTEMP,1,IORVON,IORVOFF,,,.DGCNT) - ; - ;set edit date/time - D SET^DGPFLF1(DGARY,DGLINE,"Enter/Edit On: "_$$FDTTM^VALM1($P($G(DGPFFH("ENTERDT")),U)),14,IORVON,IORVOFF,,,.DGCNT) - ; - ;set entered by - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Enter/Edit By: "_$P($G(DGPFFH("ENTERBY")),U,2),14,,,,,.DGCNT) - ; - ;set blank line - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"",1,,,,,.DGCNT) - ; - ;set edit reason text - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"Reason For Flag Enter/Edit:",1,,,,,.DGCNT) - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"---------------------------",1,,,,,.DGCNT) - I $D(DGPFFH("REASON",1,0)) D - . S DGSUB=0,DGTEMP="" - . F S DGSUB=$O(DGPFFH("REASON",DGSUB)) Q:'DGSUB D - .. S DGTEMP=$G(DGPFFH("REASON",DGSUB,0)) - .. S DGLINE=DGLINE+1 - .. D SET^DGPFLF1(DGARY,DGLINE,DGTEMP,1,,,,,.DGCNT) - E D - . S DGLINE=DGLINE+1 - . D SET^DGPFLF1(DGARY,DGLINE,"Unknown",1,,,,,.DGCNT) - ; - Q - ; - ; -HISTHDR(DGARY,DGLINE,DGCNT) ;Set history heading into list area. - ; - ; Input: - ; DGARY - global array subscript - ; DGLINE - line counter - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - ;set blank line - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,"",1,,,,,.DGCNT) - ; - ;set hist heading - S DGLINE=DGLINE+1 - D SET^DGPFLF1(DGARY,DGLINE,$TR($J("",80)," ","="),1,,,,,.DGCNT) - D SET^DGPFLF1(DGARY,DGLINE,"",28,IORVON,IORVOFF,,,.DGCNT) - ; - Q diff -auBN ./r1/DGPFLFD.m ./r2/r/DGPFLFD.m --- ./r1/DGPFLFD.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLFD.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,83 +0,0 @@ -DGPFLFD ;ALB/KCL - PRF DISPLAY FLAG DETAIL LM SCREEN ; 3/13/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EN ;Main entry point for DGPF FLAG DETAIL list template. - ; - ; Input: - ; DGPFIEN - IEN of record in PRF NATIONAL FLAG or PRF LOCAL - ; FLAG file [ex: "1;DGPF(26.15,"] - ; - ; Output: None - ; - ;quit if required input not defined - Q:$G(DGPFIEN)']"" - ; - ;display wait msg to user - D WAIT^DICD - ; - ;invoke DGPF FLAG DETAIL list template - D EN^VALM("DGPF FLAG DETAIL") - Q - ; - ; -HDR ;Header Code - ; - N DGHDR - N DGRESULT - N DGPFLG - K DGPFLG - ; - ;retrieve flag, place into DGHDR array - S DGRESULT=$$GETFLAG^DGPFUT1(DGPFIEN,.DGPFLG) - ; - ;construct header array - S VALMHDR(1)="Flag Name: "_$S(DGRESULT:$P($G(DGPFLG("FLAG")),U,2),1:"UNKNOWN") - S DGHDR="Flag Status: "_$S(DGRESULT:$P($G(DGPFLG("STAT")),U,2),1:"UNKNOWN") - S VALMHDR(1)=$$SETSTR^VALM1(DGHDR,VALMHDR(1),55,$L(DGHDR)) - ; - Q - ; - ; -INIT ;Init variables and list array - ; - D BLD - ; - Q - ; - ; -BLD ;Build flag detail screen (list area) - ; - D CLEAN^VALM10 - K VALMHDR - K ^TMP("DGPFDET",$J) - ; - ;init number of lines in list - S VALMCNT=0 - ; - ;build header - D HDR - ; - ;build list area for flag detail - D EN^DGPFLFD1("DGPFDET",DGPFIEN,.VALMCNT) - ; - Q - ; - ; -HELP ;Help Code - S X="?" D DISP^XQORM1 W !! - Q - ; - ; -EXIT ;Exit Code - ; - D CLEAN^VALM10 - D CLEAR^VALM1 - K ^TMP("DGPFDET",$J) - Q - ; - ; -EXPND ;Expand Code - Q diff -auBN ./r1/DGPFLF.m ./r2/r/DGPFLF.m --- ./r1/DGPFLF.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLF.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,82 +0,0 @@ -DGPFLF ;ALB/KCL - PRF FLAG MANAGEMENT LM SCREEN ; 3/10/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;- no direct entry - QUIT - ; -EN ;Main entry point for DGPF RECORD FLAG MANAGEMENT option. - ; - ; Input: None - ; Output: None - ; - ;- invoke DGPF RECORD FLAG MANAGEMENT list template - D EN^VALM("DGPF RECORD FLAG MANAGEMENT") - Q - ; - ; -HDR ;Header Code - ; - N DGHDR - S VALMHDR(1)="Flag Category: "_$S(DGCAT=1:"I (National)",DGCAT=2:"II (Local)",1:"Unknown") - S DGHDR="Sorted By: "_$S(DGSRTBY="N":"Flag Name",DGSRTBY="T":"Flag Type",1:"Unknown") - S VALMHDR(1)=$$SETSTR^VALM1(DGHDR,VALMHDR(1),57,$L(DGHDR)) - Q - ; - ; -INIT ;Init variables and list array - ; - ;- init flag categorey to list (default=National) - S DGCAT=1 - ; - ;init list sort by criteria (default=Flag Name) - S DGSRTBY="N" - ; - ;build record flag list area - D BLD - ; - Q - ; - ; -BLD ;Build record flag screen (list area) - ; - D CLEAN^VALM10 - K DGARY,VALMHDR - K ^TMP("DGPFSORT",$J) - ; - ;- init array that will contain list of items to display - S DGARY="DGPFLAG" - K ^TMP(DGARY,$J) - ; - ;init # of lines in list - S VALMCNT=0 - ; - ;build header area - D HDR - ; - ;build list area for flag screen - D EN^DGPFLF1(DGARY,DGCAT,DGSRTBY,.VALMCNT) - ; - Q - ; - ; -HELP ;Help Code - ; - S X="?" D DISP^XQORM1 W !! - Q - ; - ; -EXIT ;Exit Code - ; - D CLEAN^VALM10 - D CLEAR^VALM1 - K DGCAT - K DGSRTBY - K ^TMP("DGPFSORT",$J) - K ^TMP(DGARY,$J) - K ^TMP(DGARY,"IDX",$J) - K DGARY - Q - ; - ; -EXPND ;Expand Code - Q diff -auBN ./r1/DGPFLMA1.m ./r2/r/DGPFLMA1.m --- ./r1/DGPFLMA1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMA1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,76 +0,0 @@ -DGPFLMA1 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS ; 6/10/03 3:57pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -SP ;Entry point for DGPF SELECT PATIENT action protocol. - ; - ; Input: None - ; - ; Output: - ; DGDFN - pointer to patient in PATIENT #2 file - ; VALMBCK - 'R' = refresh screen - ; - N DGPAT ;patient lookup array - ; - ;set screen to full scrolling region - D FULL^VALM1 - ; - ;patient selection (lookup) - D SELPAT^DGPFUT1(.DGPAT) - I (+$G(DGPAT)>0) D - . S DGDFN=+DGPAT - . ; - . Q:'$$CONTINUE^DGPFUT() - . ; - . ;- build header for selected patient - . D BLDHDR^DGPFLMU(DGDFN,.VALMHDR) - . ; - . ;- build list of flag assignments for selected patient - . D BLDLIST^DGPFLMU(DGDFN) - ; - ;return to LM (refresh screen) - S VALMBCK="R" - Q - ; - ; -DF ;Entry point for DGPF DISPLAY ASSIGNMENT DETAIL action protocol. - ; - ; Input: None - ; - ; Output: - ; VALMBCK - 'R' = refresh screen - ; - N DGDFN ;patient dfn - N DGIEN ;assignment ien - N SEL ;user selection - N VALMY ;output of EN^VALM2 call, array of user selected entries - ; - ;set screen to full scroll region - D FULL^VALM1 - ; - ;is action selection allowed? - I '$D(@VALMAR@("IDX")) D Q - . W !!?2,">>> '"_$P($G(XQORNOD(0)),U,3)_"' action not allowed at this point.",*7 - . I '$G(DGDFN) W !?6,"A patient has not been selected." - . E W !?6,"There are no record flag assignments for this patient." - . D PAUSE^VALM1 - . S VALMBCK="R" - ; - ;ask user to select a single assignment for detail display - S (SEL,DGIEN,VALMBCK)="" - D EN^VALM2($G(XQORNOD(0)),"S") - ; - ;process user selection - S SEL=$O(VALMY("")) - I SEL,$D(@VALMAR@("IDX",SEL,SEL)) D - . S DGIEN=$P($G(@VALMAR@("IDX",SEL,SEL)),U) - . S DGDFN=$P($G(@VALMAR@("IDX",SEL,SEL)),U,2) - . ;-display flag assignment details - . N VALMHDR - . D EN^DGPFLMAD - ; - ;return to LM (refresh screen) - S VALMBCK="R" - Q diff -auBN ./r1/DGPFLMA2.m ./r2/r/DGPFLMA2.m --- ./r1/DGPFLMA2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMA2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,127 +0,0 @@ -DGPFLMA2 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 9/29/04 10:33am - ;;5.3;Registration;**425,623**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -AF ;Entry point for DGPF ASSIGN FLAG action protocol. - ; - ; Input: - ; DGDFN - pointer to patient in PATIENT (#2) file - ; - ; Output: - ; VALMBCK - 'R' = refresh screen - ; - N DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK ;input vars for EN^DIWE call - N DGABORT ;abort flag for entering assignment narrative - N DGOK ;ok flag for entering assignment narrative - N DGPFA ;assignment array - N DGPFAH ;assignment history array - N DGRDAT ;results of review date calculation - N DGRESULT ;result of STOALL api call - N DGREASON ;reason if unable to add new assignment - N DGPFERR ;if error returned from STOALL api call - ; - ;set screen to full scrolling region - D FULL^VALM1 - ; - D ;drop out of do block on failure - . ; - . ;-security key check - . I '$D(^XUSEC("DGPF RECORD FLAG ASSIGNMENT",DUZ)) D Q - . . W !!?2,">>> '"_$P($G(XQORNOD(0)),U,3)_"' action not allowed at this point.",*7 - . . W !?6,"You do not have the appropriate Security Key." - . . D PAUSE^VALM1 - . ; - . ;-is action selection allowed? - . I '$G(DGDFN) D Q - . . W !!?2,">>> '"_$P($G(XQORNOD(0)),U,3)_"' action not allowed at this point.",*7 - . . W !?6,"A patient has not been selected." - . . D PAUSE^VALM1 - . ; - . ;-init assignment and history arrays - . K DGPFA,DGPFAH - . ; - . ;-get patient DFN into assignment array - . S DGPFA("DFN")=$G(DGDFN) - . Q:'DGPFA("DFN") - . ; - . ;-select flag for assignment, quit if not selected - . S DGPFA("FLAG")=$$ANSWER^DGPFUT("Select a flag for this assignment","","26.13,.02") - . Q:(DGPFA("FLAG")'>0) - . ; - . ;-check if ok to add new assignment - . K DGREASON - . I '$$ADDOK^DGPFAA2(DGPFA("DFN"),$P(DGPFA("FLAG"),U),.DGREASON) D Q - . . W !!,"Unable to add new assignment..."_$$LOW^XLFSTR($G(DGREASON)) - . . D PAUSE^VALM1 - . ; - . ;-if local flag assignment, owner site = current site - . ;-else if nat'l flag assignment, prompt for owner site - . I DGPFA("FLAG")["26.11" S DGPFA("OWNER")=$P($$SITE^VASITE,U) - . E S DGPFA("OWNER")=$$ANSWER^DGPFUT("Enter Owner Site",$P($$SITE^VASITE,U,2),"P^4:EMZ") - . Q:(DGPFA("OWNER")'>0) - . ; - . ;-prompt user for approved by person, quit if not selected - . S DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ") - . Q:(DGPFAH("APPRVBY")'>0) - . ; - . ;-have user enter assignment narrative text (required) - . S (DGABORT,DGOK)=0 - . S DGWPROOT=$NA(^TMP($J,"DGPFNARR")) - . K @DGWPROOT - . F D Q:(DGOK!DGABORT) - . . W !!,"Enter Narrative Text for this record flag assignment:" ;needed for line editor - . . S DIC=$$OREF^DILF(DGWPROOT) - . . S DIWETXT="Patient Record Flag - Assignment Narrative Text" - . . S DIWESUB="Assignment Narrative Text" - . . S DWLW=75 ;max # of chars allowed to be stored on WP global node - . . S DWPK=1 ;if line editor, don't join lines - . . D EN^DIWE - . . I $$CKWP^DGPFUT(DGWPROOT) S DGOK=1 Q - . . W !,"Assignment Narrative Text is required!",*7 - . . I '$$CONTINUE^DGPFUT() S DGABORT=1 - . . ; - . ;-quit if required assignment narrative not entered - . Q:$G(DGABORT) - . ; - . ;-place assignment narrative text into assignment array - . M DGPFA("NARR")=@DGWPROOT K @DGWPROOT - . ; - . ;-setup remaining assignment and history array nodes for filing - . S DGPFA("STATUS")=1 ;active - . S DGPFA("ORIGSITE")=$P($$SITE^VASITE(),U) ;current site - . S DGPFAH("ASSIGNDT")=$$NOW^XLFDT() ;current date/time - . S DGPFAH("ACTION")=1 ;new assignment - . S DGPFAH("ENTERBY")=DUZ ;current user - . S DGPFAH("COMMENT",1,0)="New record flag assignment." - . ; - . ;-calculate the default review date - . S DGRDAT=$$GETRDT^DGPFAA3($P(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT")) - . ; - . ;-prompt for review date on valid default review date, otherwise null - . I DGRDAT>0 D - . . S DGPFA("REVIEWDT")=$$ANSWER^DGPFUT("Enter Review Date",$$FMTE^XLFDT(DGRDAT,"5D"),"D^"_DT_":"_DGRDAT_":EX") - . E S DGPFA("REVIEWDT")="" - . Q:DGPFA("REVIEWDT")<0 - . ; - . Q:$$ANSWER^DGPFUT("Would you like to file this new record flag assignment","YES","Y")'>0 - . ; - . ;-file the assignment and history using STOALL api - . W !,"Filing the patient's new record flag assignment..." - . S DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR) - . W !," >>> Assignment was "_$S(+$G(DGRESULT):"filed successfully.",1:"not filed successfully.") - . ; - . ;-- send HL7 message if adding an assignment to a NATIONAL flag - . I $G(DGRESULT),DGPFA("FLAG")["26.15",$$SNDORU^DGPFHLS(+DGRESULT) D - . . W !," >>> HL7 message sent...updating patient's sites of record." - . ; - . D PAUSE^VALM1 - . ; - . ;-re-build list of flag assignments for patient - . D BLDLIST^DGPFLMU(DGDFN) - ; - ;return to LM (refresh screen) - S VALMBCK="R" - ; - Q diff -auBN ./r1/DGPFLMA3.m ./r2/r/DGPFLMA3.m --- ./r1/DGPFLMA3.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMA3.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,177 +0,0 @@ -DGPFLMA3 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 9/29/04 1:13pm - ;;5.3;Registration;**425,623**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EF ;Entry point for DGPF EDIT FLAG ASSIGNMENT action protocol. - ; - ; Input: None - ; - ; Output: - ; VALMBCK - 'R' = refresh screen - ; - N DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK ;input vars for EN^DIWE call - N DGAROOT ;assignment narrative word processing root - N DGCROOT ;assignment history comment word processing root - N DGABORT ;abort flag for entering assignment narrative - N DGOK ;ok flag for entering assignment narrative - N DGCODE ;action code - N DGDFN ;pointer to patient in PATIENT (#2) file - N DGIEN ;assignment ien - N DGPFA ;assignment array - N DGPFAH ;assignment history array - N DGRDAT ;review date - N DGRESULT ;result of STOALL api call - N DGREASON ;reason if unable to edit assignment - N DGPFERR ;if error returned from STOALL api call - N SEL ;user selection (list item) - N VALMY ;output of EN^VALM2 call, array of user selected entries - ; - ;set screen to full scroll region - D FULL^VALM1 - ; - ;security key check - I '$D(^XUSEC("DGPF RECORD FLAG ASSIGNMENT",DUZ)) D Q - . W !!?2,">>> '"_$P($G(XQORNOD(0)),U,3)_"' action not allowed at this point.",*7 - . W !?6,"You do not have the appropriate Security Key." - . D PAUSE^VALM1 - . S VALMBCK="R" - ; - ;is action selection allowed? - I '$D(@VALMAR@("IDX")) D Q - . W !!?2,">>> '"_$P($G(XQORNOD(0)),U,3)_"' action not allowed at this point.",*7 - . I '$G(DGDFN) W !?6,"A patient has not been selected." - . E W !?6,"There are no record flag assignments for this patient." - . D PAUSE^VALM1 - . S VALMBCK="R" - ; - ;allow user to select a SINGLE flag assignment for editing - S (DGIEN,DGSELECT,VALMBCK)="" - D EN^VALM2($G(XQORNOD(0)),"S") - ; - ;process user selection - S SEL=$O(VALMY("")) - I SEL,$D(@VALMAR@("IDX",SEL,SEL)) D - . S DGIEN=$P($G(@VALMAR@("IDX",SEL,SEL)),U) - . S DGDFN=$P($G(@VALMAR@("IDX",SEL,SEL)),U,2) - . ; - . ;-attempt to obtain lock on assignment record - . I '$$LOCK^DGPFAA3(DGIEN) D Q - . . W !!,"Record flag assignment currently in use, can not be edited!" - . . D PAUSE^VALM1 - . ; - . ;-init word processing arrays - . S DGAROOT=$NA(^TMP($J,"DGPFNARR")) - . S DGCROOT=$NA(^TMP($J,"DGPFCMNT")) - . K @DGAROOT,@DGCROOT - . ; - . ;-get PRF assignment into DGPFA array - . I '$$GETASGN^DGPFAA(DGIEN,.DGPFA) D Q - . . W !!,"Unable to retrieve the record flag assignment selected." - . . D PAUSE^VALM1 - . ; - . ;-is editing of assignment allowed?, quit if not allowed - . K DGREASON - . I '$$EDTOK^DGPFAA2(.DGPFA,"",.DGREASON) D Q - . . W !!,"Assignment can not be edited..."_$$LOW^XLFSTR($G(DGREASON)) - . . D PAUSE^VALM1 - . ; - . ;-if assigment is active, set available action codes to 'Continue' - . ; and 'Inactivate', else set action code to 'Reactivate' - . I +DGPFA("STATUS")=1 S DGCODE="S^C:Continue Assignment;I:Inactivate Assignment" - . E S DGCODE="S^R:Reactivate Assignment" - . ; - . ;-prompt user for assignment action, quit if no action selected - . S DGPFAH("ACTION")=$$ANSWER^DGPFUT("Select an assignment action","",DGCODE) - . Q:(DGPFAH("ACTION")=-1) - . S DGPFAH("ACTION")=$S(DGPFAH("ACTION")="C":2,DGPFAH("ACTION")="I":3,DGPFAH("ACTION")="R":4) - . ; - . ;-if assignment action is 'Inactivate', set status to 'Inactive' - . S DGPFA("STATUS")=$S(DGPFAH("ACTION")=3:0,1:1) - . ; - . ;-if action is not 'Inactivate', then prompt user to edit the narr - . I (DGPFAH("ACTION")'=3),(($$ANSWER^DGPFUT("Would you like to edit the assignment narrative","YES","Y")>0)) D - . . ;--allow user to edit the assignment narrative (required) - . . S (DGABORT,DGOK)=0 - . . F D Q:(DGOK!DGABORT) - . . . S DGROOT=$$GET1^DIQ(26.13,DGIEN,"1","Z",DGAROOT) - . . . S DIC=$$OREF^DILF(DGAROOT) - . . . S DIWETXT="Patient Record Flag - Assignment Narrative Text" - . . . S DIWESUB="Assignment Narrative Text" - . . . S DWLW=75 ;max # of chars allowed to be stored on WP global node - . . . S DWPK=1 ;if line editor, don't join lines - . . . D EN^DIWE - . . . I $$CKWP^DGPFUT(DGAROOT) S DGOK=1 Q - . . . W !,"Assignment Narrative Text is required!",*7 - . . . I '$$CONTINUE^DGPFUT() S DGABORT=1 - . . ; - . ;-quit if required assignment narrative not entered - . Q:$G(DGABORT) - . ; - . ;-if narrative edited, place new narrative into DGPFA array - . I $G(DGOK) D - . . K DGPFA("NARR") ;remove old narrative text - . . M DGPFA("NARR")=@DGAROOT K @DGAROOT - . ; - . ;-prompt user for 'Approved By' person, quit if not selected - . S DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ") - . Q:(DGPFAH("APPRVBY")'>0) - . ; - . ;-have user enter the edit reason/history comments (required) - . S (DGABORT,DGOK)=0 - . F D Q:(DGOK!DGABORT) - . . W !!,"Enter the reason for editing this assignment:" ;needed for line editor - . . S DIC=$$OREF^DILF(DGCROOT) - . . S DIWETXT="Patient Record Flag - Edit Reason Text" - . . S DIWESUB="Edit Reason Text" - . . S DWLW=75 ;max # of chars allowed to be stored on WP global node - . . S DWPK=1 ;if line editor, don't join lines - . . D EN^DIWE - . . I $$CKWP^DGPFUT(DGCROOT) S DGOK=1 Q - . . W !,"Edit Reason is required!",*7 - . . I '$$CONTINUE^DGPFUT() S DGABORT=1 - . ; - . ;-quit if required edit reason/history comments not entered - . Q:$G(DGABORT) - . ; - . ;-place comments into history array - . M DGPFAH("COMMENT")=@DGCROOT K @DGCROOT - . ; - . ;-setup remaining assignment history nodes for filing - . S DGPFAH("ASSIGNDT")=$$NOW^XLFDT() ;current date/time - . S DGPFAH("ENTERBY")=DUZ ;current user - . ; - . ;-calculate the default review date - . S DGRDAT=$$GETRDT^DGPFAA3($P(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT")) - . ; - . ;-prompt for review date when valid default review date and ACTIVE - . ; status, otherwise null - . I DGRDAT>0,DGPFA("STATUS")=1 D - . . S DGPFA("REVIEWDT")=$$ANSWER^DGPFUT("Enter Review Date",$$FMTE^XLFDT(DGRDAT,"5D"),"D^"_DT_":"_DGRDAT_":EX") - . E S DGPFA("REVIEWDT")="" - . Q:DGPFA("REVIEWDT")<0 - . ; - . Q:$$ANSWER^DGPFUT("Would you like to file the assignment changes","YES","Y")'>0 - . ; - . ;-file the assignment and history using STOALL api - . W !,"Updating the patient's record flag assignment..." - . S DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR) - . W !," >>> Assignment was "_$S(+$G(DGRESULT):"filed successfully.",1:"not filed successfully.") - . ; - . ;-- send HL7 message if editing assignment to a NATIONAL flag - . I $G(DGRESULT),DGPFA("FLAG")["26.15",$$SNDORU^DGPFHLS(+DGRESULT) D - . . W !," >>> HL7 message sent...updating patient's sites of record." - . ; - . D PAUSE^VALM1 - . ; - . ;-re-build list of flag assignments for patient - . D BLDLIST^DGPFLMU(DGDFN) - . ; - . ;-release lock after edit - . D UNLOCK^DGPFAA3(DGIEN) - ; - ;return to LM (refresh screen) - S VALMBCK="R" - ; - Q diff -auBN ./r1/DGPFLMA4.m ./r2/r/DGPFLMA4.m --- ./r1/DGPFLMA4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMA4.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,140 +0,0 @@ -DGPFLMA4 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 4/24/03 4:43pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; - ; -CO ;Entry point for DGPF CHANGE ASSIGNMENT OWNERSHIP action protocol. - ; - ; Input: None - ; - ; Output: - ; VALMBCK - 'R' = refresh screen - ; - N DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DDWC,DWPK ;input vars for EN^DIWE - N DGCROOT ;assignment history comment word processing root - N DGABORT ;abort flag for entering assignment narrative - N DGOK ;ok flag for entering assignment narrative - N DGIEN ;assignment ien - N DGPFA ;assignment array - N DGPFAH ;assignment history array - N DGRESULT ;result of STOALL api call - N DGREASON ;reason if unable to edit assignment - N DGPFERR ;if error returned from STOALL api call - N SEL ;user selection (list item) - N VALMY ;output of EN^VALM2 call, array of user selected entries - ; - ;set screen to full scroll region - D FULL^VALM1 - ; - ;security key check - I '$D(^XUSEC("DGPF RECORD FLAG ASSIGNMENT",DUZ)) D Q - . W !!?2,">>> '"_$P($G(XQORNOD(0)),U,3)_"' action not allowed at this point.",*7 - . W !?6,"You do not have the appropriate Security Key." - . D PAUSE^VALM1 - . S VALMBCK="R" - ; - ;is action selection allowed? - I '$D(@VALMAR@("IDX")) D Q - . W !!?2,">>> '"_$P($G(XQORNOD(0)),U,3)_"' action not allowed at this point.",*7 - . I '$G(DGDFN) W !?6,"A patient has not been selected." - . E W !?6,"There are no record flag assignments for this patient." - . D PAUSE^VALM1 - . S VALMBCK="R" - ; - ;allow user to select a SINGLE flag assignment for ownership change - S (DGIEN,DGSELECT,VALMBCK)="" - D EN^VALM2($G(XQORNOD(0)),"S") - ; - ;process user selection - S SEL=$O(VALMY("")) - I SEL,$D(@VALMAR@("IDX",SEL,SEL)) D - . S DGIEN=$P($G(@VALMAR@("IDX",SEL,SEL)),U) - . S DGDFN=$P($G(@VALMAR@("IDX",SEL,SEL)),U,2) - . ; - . ;-attempt to obtain lock on assignment record - . I '$$LOCK^DGPFAA3(DGIEN) D Q - . . W !!,"Record flag assignment currently in use, can not be edited!",*7 - . . D PAUSE^VALM1 - . ; - . ;-get assignment into DGPFA array - . I '$$GETASGN^DGPFAA(DGIEN,.DGPFA) D Q - . . W !!,"Unable to retrieve the record flag assignment selected.",*7 - . . D PAUSE^VALM1 - . ; - . ;-can site change ownership of the assignment? - . I '$$CHGOWN^DGPFAA2(.DGPFA,,.DGREASON) D Q - . . W !!,"Changing the ownership of this record flag assignment not allowed.",*7 - . . W !," >>> "_$G(DGREASON)_"." - . . D PAUSE^VALM1 - . ; - . ;-prompt for new OWNER SITE of the assignment - . S DGPFA("OWNER")=$$ANSWER^DGPFUT("Select new owner site for this record flag assignment","","P^4:EMZ") - . I DGPFA("OWNER")=+$$SITE^VASITE D - . . W !!,"Ownership of this record flag assignment has not been changed!",*7 - . . S DGPFA("OWNER")=0 - . . D PAUSE^VALM1 - . Q:(DGPFA("OWNER")'>0) - . ; - . ;-prompt for APPROVED BY person - . S DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ") - . Q:(DGPFAH("APPRVBY")'>0) - . ; - . ;-allow user to enter HISTORY COMMENTS (edit reason) - . S DGCROOT=$NA(^TMP($J,"DGPFCMNT")) ;init WP array for hist comments - . K @DGCROOT - . S (DGABORT,DGOK)=0 - . F D Q:(DGOK!DGABORT) - . . W !!,"Enter the reason for editing this assignment:" ;needed for line editor - . . S @DGCROOT@(1,0)="Change of flag assignment ownership. " - . . S DIC=$$OREF^DILF(DGCROOT) - . . S DIWETXT="Enter the reason for record flag assignment ownership change:" - . . ;S DIWETXT="Enter Record Flag Assignment - Edit Reason Text" - . . S DIWESUB="Change of Ownership Reason" - . . S DWLW=75 ;max # of chars allowed to be stored on WP global node - . . S DWPK=1 ;if line editor, don't join lines - . . S DDWC="E" ;initially place cursor at end of line 1 - . . D EN^DIWE - . . I $$CKWP^DGPFUT(DGCROOT) S DGOK=1 Q - . . W !,"The reason for editing this record flag assignment is required!",*7 - . . I '$$CONTINUE^DGPFUT() S DGABORT=1 - . ; - . ;-quit if required HISTORY COMMENTS not entered - . Q:$G(DGABORT) - . ; - . ;-place HISTORY COMMENTS into history array - . M DGPFAH("COMMENT")=@DGCROOT K @DGCROOT - . ; - . ;-setup remaining assignment history array nodes for filing - . S DGPFAH("ACTION")=2 ;continue - . S DGPFAH("ASSIGNDT")=$$NOW^XLFDT() ;current date/time - . S DGPFAH("ENTERBY")=DUZ ;current user - . ; - . ;-relinquishing ownership should remove existing review date - . S DGPFA("REVIEWDT")="" - . ; - . ;-ask user if ok to file ownership change - . Q:$$ANSWER^DGPFUT("Would you like to file the assignment ownership change","YES","Y")'>0 - . ; - . ;-file the assignment and history using STOALL api - . W !!,"Updating the ownership of this patient's record flag assignment..." - . S DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR) - . W !," >>> Update was "_$S(+$G(DGRESULT):"successful",1:"not successful")_"." - . ; - . ;-- send HL7 ORU msg if editing assignment to a Cat I (NATIONAL) flag - . I +$G(DGRESULT),$$SNDORU^DGPFHLS(+DGRESULT) D - . . W !," >>> HL7 message sent...updating patient's sites of record." - . ; - . D PAUSE^VALM1 - . ; - . ;-rebuild list of flag assignments for patient - . D BLDLIST^DGPFLMU(DGDFN) - . ; - . ;-release lock after CO edit - . D UNLOCK^DGPFAA3(DGIEN) - ; - ;return to LM (refresh screen) - S VALMBCK="R" - ; - Q diff -auBN ./r1/DGPFLMAD.m ./r2/r/DGPFLMAD.m --- ./r1/DGPFLMAD.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMAD.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,68 +0,0 @@ -DGPFLMAD ;ALB/KCL - PRF DISPLAY ASSIGNMENT DETAIL LM SCREEN ; 4/25/03 3:22pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EN ;Main entry point for DGPF RECORD FLAG DETAIL list template. - ; - ; Input: - ; DGDFN - ien of PATIENT (#2) file - ; DGIEN - ien of PRF ASSIGNMENT (#26.13) file - ; - ; Output: None - ; - ;quit if required input parameters not defined - Q:'$G(DGDFN) - Q:'$G(DGIEN) - ; - ;display wait msg to user - D WAIT^DICD - ; - ;invoke list manager and load list template - D EN^VALM("DGPF ASSIGNMENT DETAIL") - Q - ; - ; -HDR ;Header Code - D BLDHDR^DGPFLMU(DGDFN,.VALMHDR) - Q - ; - ; -INIT ;Init variables and list array - D BLD - Q - ; - ; -BLD ;Build record flag detail LM screen - D CLEAN^VALM10 - K VALMHDR - K ^TMP("DGPFDET",$J) - ; - ;init number of lines in list - S VALMCNT=0 - ; - ;build header - D HDR - ; - ;build list area for record flag detail - D EN^DGPFLMU1("DGPFDET",DGIEN,DGDFN,.VALMCNT) - ; - Q - ; - ; -HELP ;Help Code - N X - S X="?" D DISP^XQORM1 W !! - Q - ; - ; -EXIT ;Exit Code - D CLEAN^VALM10 - D CLEAR^VALM1 - K ^TMP("DGPFDET",$J) - Q - ; - ; -EXPND ;Expand Code - Q diff -auBN ./r1/DGPFLMA.m ./r2/r/DGPFLMA.m --- ./r1/DGPFLMA.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,50 +0,0 @@ -DGPFLMA ;ALB/KCL - PRF ASSIGNMENT LISTMAN SCREEN ; 4/24/03 4:34pm - ;;5.3;Registration;**425**;Aug 13,1993 - ; - ; -EN ;Main entry point for DGPF RECORD FLAG ASSIGNMENT option. - ; - ; Input: None - ; Output: None - ; - ;display wait msg to user - D WAIT^DICD - ; - ;invoke list manager and load list template - D EN^VALM("DGPF RECORD FLAG ASSIGNMENT") - Q - ; - ; -HDR ;Header Code - S VALMHDR(1)="Patient: No Patient Selected" - S VALMHDR(2)="" - Q - ; - ; -INIT ;Init variables and list array - N DGTEXT - S DGTEXT=" A patient has not been selected. Please select a patient." - D SET^VALM10(1,"") - D SET^VALM10(2,DGTEXT) - D CNTRL^VALM10(2,4,$L(DGTEXT),$G(IOINHI),$G(IOINORM)) - S VALMCNT=2 - Q - ; - ; -HELP ;Help Code - N X - S X="?" D DISP^XQORM1 W !! - Q - ; - ; -EXIT ;Exit Code - K DGDFN - K DGPFA - K DGPFAH - D CLEAN^VALM10 - D CLEAR^VALM1 - Q - ; - ; -EXPND ;Expand Code - Q diff -auBN ./r1/DGPFLMD1.m ./r2/r/DGPFLMD1.m --- ./r1/DGPFLMD1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMD1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,87 +0,0 @@ -DGPFLMD1 ;ALB/RPM - PRF DISPLAY ACTIVE FLAG ASSIGNMENTS LM ; 5/20/03 2:50pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; -EN(DGARRY,DGPFAPI,DGCNT) ; - ; - N DGFLG - N DGI - N DGLINE - N DGNARR - N DGNUM - N DGTEXT - ; - S (DGNUM,DGFLG,DGLINE)=0 - F S DGFLG=$O(DGPFAPI(DGFLG)) Q:'DGFLG D - . S DGNUM=DGNUM+1 - . ; - . ;blank line(s) - . F DGI=1:1:$S(DGNUM>1:2,1:1) D - . . S DGLINE=DGLINE+1 - . . D SET^DGPFLMU1(DGARRY,DGLINE," ",1,,,.DGCNT) - . ; - . ;Flag Name - . S DGLINE=DGLINE+1 - . S DGTEXT=DGNUM_"." - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,1,IORVON,IORVOFF,.DGCNT) - . S DGTEXT="Flag Name: " - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,5,,,.DGCNT) - . S DGTEXT="<"_$P(DGPFAPI(DGFLG,"FLAG"),U,2)_">" - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,16,IORVON,IORVOFF,.DGCNT) - . ; - . ;Category - . S DGLINE=DGLINE+1 - . S DGTEXT="Category: "_$P(DGPFAPI(DGFLG,"CATEGORY"),U,2) - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,6,,,.DGCNT) - . ; - . ;Flag Type - . S DGLINE=DGLINE+1 - . S DGTEXT="Type: "_$P(DGPFAPI(DGFLG,"FLAGTYPE"),U,2) - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,10,,,.DGCNT) - . ; - . ;Assignment Narrative - . S DGLINE=DGLINE+1 - . D SET^DGPFLMU1(DGARRY,DGLINE," ",1,,,.DGCNT) - . S DGLINE=DGLINE+1 - . S DGTEXT="Assignment Narrative:" - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,1,IORVON,IORVOFF,.DGCNT) - . S DGNARR=0 - . F S DGNARR=$O(DGPFAPI(DGFLG,"NARR",DGNARR)) Q:'DGNARR D - . . S DGLINE=DGLINE+1 - . . S DGTEXT=$G(DGPFAPI(DGFLG,"NARR",DGNARR,0)) - . . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,1,,,.DGCNT) - . ; - . ;blank line - . S DGLINE=DGLINE+1 - . D SET^DGPFLMU1(DGARRY,DGLINE," ",1,,,.DGCNT) - . ; - . ;assignment details header - . S DGLINE=DGLINE+1 - . S DGTEXT="Assignment Details:" - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,1,IORVON,IORVOFF,.DGCNT) - . ; - . ;Assignment Date - . S DGLINE=DGLINE+1 - . S DGTEXT="Initial Assignment: "_$$FMTE^XLFDT($P(DGPFAPI(DGFLG,"ASSIGNDT"),U),"D") - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,3,,,.DGCNT) - . ; - . ;Approved By - . S DGLINE=DGLINE+1 - . S DGTEXT="Approved By: "_$P(DGPFAPI(DGFLG,"APPRVBY"),U,2) - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,10,,,.DGCNT) - . ; - . ;Review Date - . S DGLINE=DGLINE+1 - . S DGTEXT="Next Review Date: "_$S($P(DGPFAPI(DGFLG,"REVIEWDT"),U)>0:$$FMTE^XLFDT($P(DGPFAPI(DGFLG,"REVIEWDT"),U),"D"),1:"N/A") - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,5,,,.DGCNT) - . ; - . ;Owner Site - . S DGLINE=DGLINE+1 - . S DGTEXT="Owner Site: "_$P(DGPFAPI(DGFLG,"OWNER"),U,2) - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,11,,,.DGCNT) - . ; - . ;Originating Site - . S DGLINE=DGLINE+1 - . S DGTEXT="Originating Site: "_$P(DGPFAPI(DGFLG,"ORIGSITE"),U,2) - . D SET^DGPFLMU1(DGARRY,DGLINE,DGTEXT,5,,,.DGCNT) - ; - Q diff -auBN ./r1/DGPFLMD.m ./r2/r/DGPFLMD.m --- ./r1/DGPFLMD.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMD.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,75 +0,0 @@ -DGPFLMD ;ALB/RPM - PRF DISPLAY ACTIVE FLAG ASSIGNMENTS LM ; 5/20/03 2:49pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EN(DGDFN,DGPFAPI) ;DGPF ACTIVE ASSIGNMENTS list template main entry point - ; - ; Input: - ; DGDFN - IEN of record in PATIENT (#2) file - ; DGPFAPI - data array of active patient record flag assignments - ; - ; Output: None - ; - ; - ;quit if required input not defined - Q:+$G(DGDFN)'>0 - Q:'$D(DGPFAPI) - ; - ;display wait msg to user - D WAIT^DICD - ; - ;invoke DISPLAY list template - D EN^VALM("DGPF ACTIVE ASSIGNMENTS") - Q - ; - ; -HDR ;Header Code - ; - D BLDHDR^DGPFLMU(DGDFN,.VALMHDR) - S VALMHDR(3)=" " - S VALMHDR(4)=$$CJ^XLFSTR("<<< Active Patient Record Flag Assignments >>>",80) - Q - ; - ; -INIT ;Init variables and list array - ; - D BLD - ; - Q - ; - ; -BLD ;Build flag detail screen (list area) - ; - D CLEAN^VALM10 - K VALMHDR - K ^TMP("DGPFACT",$J) - ; - ;init number of lines in list - S VALMCNT=0 - ; - ;build header - D HDR - ; - ;build list area for flag detail - D EN^DGPFLMD1("DGPFACT",.DGPFAPI,.VALMCNT) - ; - Q - ; - ; -HELP ;Help Code - S X="?" D DISP^XQORM1 W !! - Q - ; - ; -EXIT ;Exit Code - ; - D CLEAN^VALM10 - D CLEAR^VALM1 - K ^TMP("DGPFACT",$J) - Q - ; - ; -EXPND ;Expand Code - Q diff -auBN ./r1/DGPFLMU1.m ./r2/r/DGPFLMU1.m --- ./r1/DGPFLMU1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMU1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,229 +0,0 @@ -DGPFLMU1 ;ALB/KCL - PRF DISPLAY FLAG DETAIL LM UTILITIES CONT ; 02/04/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -EN(DGARY,DGIEN,DGDFN,DGCNT) ;Entry point to build flag assignment detail list area. - ; - ; Input: - ; DGARY - global array subscript - ; DGIEN - ien of PATIENT ASSIGNMENT (#26.13) file - ; DGDFN - ien of PATIENT (#2) file - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - N DGHIEN ;assignment history ien - N DGHIENS ;contains assignment history ien's - N DGHISCNT ;count of history records - N DGLINE ;line counter - N DGPFA ;assignment array - N DGPFAH ;assignment history array - N DGPFF ;flag array - N DGSUB ;subscript of history ien's array - ; - ;init variables - S DGCNT=0 - S (DGLINE,VALMBEG)=1 - K DGPFA - K DGPFAH - K DGPFF - K DGHIENS - ; - Q:'$G(DGIEN) - ; - ;get assignment into DGPFA array - Q:'$$GETASGN^DGPFAA(DGIEN,.DGPFA) - S DGPFA("INITASSIGN")=$$GETADT^DGPFAAH(DGIEN) ;initial assign date - ; - ;get most recent assignment history and place in DGPFAH array - Q:'$$GETHIST^DGPFAAH($$GETLAST^DGPFAAH(DGIEN),.DGPFAH) - ; - ;get record flag into DGPFF array - Q:'$$GETFLAG^DGPFUT1($P($G(DGPFA("FLAG")),U),.DGPFF) - ; - ;build Assignment Details area - D ASGN(DGARY,.DGPFA,.DGPFAH,.DGPFF,.DGLINE,.DGCNT) - ; - ;build Assignment History heading - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,$TR($J("",80)," ","="),1,,,.DGCNT) - D SET(DGARY,DGLINE,"",30,IORVON,IORVOFF,.DGCNT) - ; - ;get all history ien's associated with the assignment - Q:'$$GETALLDT^DGPFAAH(DGIEN,.DGHIENS) - ; - ;reverse loop through each assignment history ien - ;and get record into DGPFAH array - S DGHISCNT=0,DGSUB=9999999.999999 - F S DGSUB=$O(DGHIENS(DGSUB),-1) Q:DGSUB="" D - . S DGHIEN=+$G(DGHIENS(DGSUB)) - . K DGPFAH - . I $$GETHIST^DGPFAAH(DGHIEN,.DGPFAH) D - . . ; - . . ;-history record counter - . . S DGHISCNT=DGHISCNT+1 - . . ; - . . ;-build assignment history area - . . D HIST(DGARY,.DGPFAH,.DGLINE,DGHISCNT,.DGCNT) - Q - ; - ; -ASGN(DGARY,DGPFA,DGPFAH,DGPFF,DGLINE,DGCNT) ;This procedure will build the lines of FLAG ASSIGNMENT details. - ; - ; Input: - ; DGARY - global array subscript - ; DGPFF - flag array, pass by reference - ; DGPFA - assignment array, pass by reference - ; DGPFAH - assignment history array, pass by reference - ; DGLINE - line counter - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - ;temporary variables used - N DGSUB - N DGTMP - ; - ;set flag name - D SET(DGARY,DGLINE,"Flag Name: "_$P($G(DGPFA("FLAG")),U,2),12,,,.DGCNT) - ; - ;set flag type - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Flag Type: "_$P($G(DGPFF("TYPE")),U,2),12,,,.DGCNT) - ; - ;set flag category - S DGLINE=DGLINE+1 - S DGTMP=$S($P($G(DGPFA("FLAG")),U)["26.11":"II (LOCAL)",1:"I (NATIONAL)") - D SET(DGARY,DGLINE,"Flag Category: "_DGTMP,8,,,.DGCNT) - ; - ;set flag assignment status - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Assignment Status: "_$P($G(DGPFA("STATUS")),U,2),4,,,.DGCNT) - ; - ;set initial assignment date - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Initial Assignment: "_$$FDTTM^VALM1($P(+$G(DGPFA("INITASSIGN")),U)),3,,,.DGCNT) - ; - ;set last review date (do not set if only initial assignment) - S DGLINE=DGLINE+1 - I (+$G(DGPFAH("ASSIGNDT")))=(+$G(DGPFA("INITASSIGN"))) D - . S DGTMP="N/A" - E S DGTMP=$$FDATE^VALM1(+$G(DGPFAH("ASSIGNDT"))) - D SET(DGARY,DGLINE,"Last Review Date: "_DGTMP,5,,,.DGCNT) - ; - ;set next review date - S DGLINE=DGLINE+1 - S DGTMP=+$G(DGPFA("REVIEWDT")) - S DGTMP=$S(DGTMP:$$FDATE^VALM1(DGTMP),1:"N/A") - D SET(DGARY,DGLINE,"Next Review Date: "_DGTMP,5,,,.DGCNT) - ; - ;set owner site - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Owner Site: "_$P($G(DGPFA("OWNER")),U,2),11,,,.DGCNT) - ; - ;set originating site - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Originating Site: "_$P($G(DGPFA("ORIGSITE")),U,2),5,,,.DGCNT) - ; - ;set assignment narrative - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"",1,,,.DGCNT) - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Record Flag Assignment Narrative:",1,IORVON,IORVOFF,.DGCNT) - I '$D(DGPFA("NARR",1,0)) D Q - . S DGLINE=DGLINE+1 - . D SET(DGARY,DGLINE,"No Narrative Text",1,,,.DGCNT) - S (DGSUB,DGTMP)="" - F S DGSUB=$O(DGPFA("NARR",DGSUB)) Q:'DGSUB D - . S DGTMP=$G(DGPFA("NARR",DGSUB,0)) - . S DGLINE=DGLINE+1 - . D SET(DGARY,DGLINE,DGTMP,1,,,.DGCNT) - ; - ;set blank lines - S DGLINE=DGLINE+2 - D SET(DGARY,DGLINE,"",1,,,.DGCNT) - ; - Q - ; - ; -HIST(DGARY,DGPFAH,DGLINE,DGHISCNT,DGCNT) ;This procedure will build the lines of FLAG ASSIGNMENT HISTORY details. - ; - ; Input: - ; DGARY - global array subscript - ; DGPFAH - assignment history array, pass by reference - ; DGLINE - line counter - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - ;temporary variables used - N DGTMP - N DGSUB - ; - ;set blank line - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"",1,,,.DGCNT) - ; - ;add an additional blank line except on the first history - I DGHISCNT>1 D - . S DGLINE=DGLINE+1 - . D SET(DGARY,DGLINE,"",1,,,.DGCNT) - ; - ;set action - S DGLINE=DGLINE+1 - S DGTMP=DGHISCNT_"." - D SET(DGARY,DGLINE,DGTMP,1,IORVON,IORVOFF,.DGCNT) - D SET(DGARY,DGLINE,"Action: "_$P($G(DGPFAH("ACTION")),U,2),10,IORVON,IORVOFF,.DGCNT) - ; - ;set assignment date - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Action Date: "_$$FDTTM^VALM1($P($G(DGPFAH("ASSIGNDT")),U)),5,,,.DGCNT) - ; - ;set entered by - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Entered By: "_$P($G(DGPFAH("ENTERBY")),U,2),6,,,.DGCNT) - ; - ;set approved by - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Approved By: "_$P($G(DGPFAH("APPRVBY")),U,2),5,,,.DGCNT) - ; - ;set history comments - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"Action Comments:",1,,,.DGCNT) - S DGLINE=DGLINE+1 - D SET(DGARY,DGLINE,"----------------",1,,,.DGCNT) - I $D(DGPFAH("COMMENT",1,0)) D - . S (DGSUB,DGTMP)="" - . F S DGSUB=$O(DGPFAH("COMMENT",DGSUB)) Q:'DGSUB D - .. S DGTMP=$G(DGPFAH("COMMENT",DGSUB,0)) - .. S DGLINE=DGLINE+1 - .. D SET(DGARY,DGLINE,DGTMP,1,,,.DGCNT) - E D - . S DGLINE=DGLINE+1 - . D SET(DGARY,DGLINE,"No Comments on file.",1,,,.DGCNT) - ; - Q - ; - ; -SET(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGCNT) ;This procedure will set the lines of flag assignment details into the LM display area. - ; - ; Input: - ; DGARY - global array subscript - ; DGLINE - line number - ; DGTEXT - text - ; DGCOL - starting column - ; DGON - highlighting on - ; DGOFF - highlighting off - ; - ; Output: - ; DGCNT - number of lines in the list, pass by reference - ; - N DGX ;temp variable for line of display text - ; - S DGCNT=DGLINE - S DGX=$S($D(^TMP(DGARY,$J,DGLINE,0)):^(0),1:"") - S ^TMP(DGARY,$J,DGLINE,0)=$$SETSTR^VALM1(DGTEXT,DGX,DGCOL,$L(DGTEXT)) - D:$G(DGON)]""!($G(DGOFF)]"") CNTRL^VALM10(DGLINE,DGCOL,$L(DGTEXT),$G(DGON),$G(DGOFF)) - Q diff -auBN ./r1/DGPFLMU.m ./r2/r/DGPFLMU.m --- ./r1/DGPFLMU.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFLMU.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,134 +0,0 @@ -DGPFLMU ;ALB/KCL - PRF ASSIGNMENT LISTMAN UTILITIES ; 4/25/03 3:39pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;no direct entry - QUIT - ; -BLDHDR(DGDFN,DGPFHDR) ;This procedure builds the VALMHDR array to display the ListMan header. - ; - ; Supported DBIA #2701: The supported DBIA is used to access the - ; MPI functions to retrieve the ICN and CMOR. - ; - ; Input: - ; DGDFN - internal entry number of PATIENT (#2) file - ; DGPFHDR - header array passed by reference - ; - ; Output: - ; DGPFHDR - header array - ; - N DGCMOR ;CIRN Master of Record - N DGICN ;Integrated Control Number - N DGPFPAT ;Patient identifying info - ; - ;retrieve patient identifying info - I $$GETPAT^DGPFUT2(DGDFN,.DGPFPAT) - ; - ;set 1st line of header - S DGPFHDR(1)="Patient: "_$G(DGPFPAT("NAME"))_" " - S DGPFHDR(1)=$$SETSTR^VALM1("("_$G(DGPFPAT("SSN"))_")",DGPFHDR(1),$L(DGPFHDR(1))+1,80) - S DGPFHDR(1)=$$SETSTR^VALM1("DOB: "_$$FDATE^VALM1($G(DGPFPAT("DOB"))),DGPFHDR(1),54,80) - ; - ;set 2nd line of header - S DGICN=$$GETICN^MPIF001(DGDFN) - S DGICN=$S(DGICN<0:"No ICN for patient",1:DGICN) - S DGPFHDR(2)=" ICN: "_DGICN - S DGCMOR=$$CMOR2^MPIF001(DGDFN) - S DGCMOR=$S(DGCMOR<0:$P(DGCMOR,U,2),1:DGCMOR) - S DGCMOR="CMOR: "_DGCMOR - S DGPFHDR(2)=$$SETSTR^VALM1(DGCMOR,DGPFHDR(2),53,27) - Q - ; - ; -BLDLIST(DGDFN) ;This procedure will build list of flag assignments for a patient for display in ListMan. - ; - ; Input: - ; DGDFN - internal entry number of PATIENT (#2) file - ; - ; Output: None - ; - N DGIEN ;ien of assignment - N DGIENS ;array of assignment ien's - N DGPTR ;pointer to last assignment history record - N DGTXT ;msg text if no assignments for patient - ; - ;kill data and video cntrl arrays associated with active list - D CLEAN^VALM10 - ; - ;if no assignments, display msg, quit - K DGIENS - I '$$GETALL^DGPFAA(DGDFN,.DGIENS) D Q - . S DGTXT=" Selected patient has no record flag assignments on file." - . D SET^VALM10(1,"") - . D SET^VALM10(2,DGTXT) - . D CNTRL^VALM10(2,4,$L(DGTXT),$G(IOINHI),$G(IOINORM)) - . S VALMCNT=2 - ; - ;if assignments, get data and build list - S DGIEN=0,VALMCNT=0 - F S DGIEN=$O(DGIENS(DGIEN)) Q:'DGIEN D - . ;-get assignment - . K DGPFA - . Q:'$$GETASGN^DGPFAA(DGIEN,.DGPFA) - . ;-get initial assignment history - . K DGPFAH - . Q:'$$GETHIST^DGPFAAH($$GETFIRST^DGPFAAH(DGIEN),.DGPFAH) - . ;-get 'initial assignment' date - . S DGPFAH("INITASSIGN")=$G(DGPFAH("ASSIGNDT")) - . Q:'DGPFAH("INITASSIGN") - . ;-increment line number count - . S VALMCNT=VALMCNT+1 - . ;-build list - . D BLDLIN(VALMCNT,.DGPFA,.DGPFAH,DGIEN) - ; - Q - ; - ; -BLDLIN(DGLNUM,DGPFA,DGPFAH,DGIEN) ;This procedure will build and setup ListMan lines and array. - ; - ; Input: - ; DGLNUM - line number - ; DGPFA - array containing assignment, passed by reference - ; DGPFAH - array containing assignment history, passed by reference - ; DGIEN - internal entry number of assignment - ; - ; Output: None - ; - N DGTXT ;used as temporary text field - N DGLINE ;string to insert field data - S DGLINE="" ;init - S DGLINE=$$SETSTR^VALM1(DGLNUM,DGLINE,1,3) - ; - ;flag name - S DGTXT=$P($G(DGPFA("FLAG")),U,2) - S DGLINE=$$SETFLD^VALM1(DGTXT,DGLINE,"FLAG") - ; - ;initial assignment date - S DGTXT=$$FDATE^VALM1(+$G(DGPFAH("INITASSIGN"))) - S DGLINE=$$SETFLD^VALM1(DGTXT,DGLINE,"ASSIGN DATE") - ; - ;approved by - S DGTXT=$P($G(DGPFAH("APPRVBY")),U,2) - S DGLINE=$$SETFLD^VALM1(DGTXT,DGLINE,"APPROV BY") - ; - ;review date - S DGTXT=+$G(DGPFA("REVIEWDT")) - S DGTXT=$S(DGTXT:$$FDATE^VALM1(DGTXT),1:"N/A") - S DGLINE=$$SETFLD^VALM1(DGTXT,DGLINE,"REVIEW DATE") - ; - ;status/active (yes/no) - S DGTXT=$P($G(DGPFA("STATUS")),U) - S DGTXT=$S(DGTXT=1:"YES",1:"NO") - S DGLINE=$$SETFLD^VALM1(DGTXT,DGLINE,"STATUS") - ; - ;local (yes/no) - S DGTXT="NO" - I $P($G(DGPFA("FLAG")),U)["26.11" S DGTXT="YES" - S DGLINE=$$SETFLD^VALM1(DGTXT,DGLINE,"LOCAL") - ; - ;construct initial list array - D SET^VALM10(DGLNUM,DGLINE,DGLNUM) - ; - ;set assignment ien and pt DFN into index - S @VALMAR@("IDX",DGLNUM,DGLNUM)=$G(DGIEN)_U_+$G(DGPFA("DFN")) - ; - Q diff -auBN ./r1/DGPFPARM.m ./r2/r/DGPFPARM.m --- ./r1/DGPFPARM.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFPARM.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,73 +0,0 @@ -DGPFPARM ;ALB/RPM - PRF PARAMETER FILE EDIT ; 4/30/03 - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q ;no direct entry - ; -EN ; - N DA,DD,DO,DIC,DIE,DINUM,DR,X,Y - ; - W !!,"Patient Record Flag Parameter Enter/Edit" - I '$D(^DGPF(26.18,1,0)) D - .W !,"You do not have an entry in your parameter file!!" - .W !,"Creating a new entry in the PRF PARAMETER (#26.18) file... ",! - .S DIC="^DGPF(26.18,",DIC(0)="",X=1,DINUM=1 - .K DD,DO D FILE^DICN W " done." - .K %,DA,DIC,DIE,X,Y - ; - S DIE="^DGPF(26.18,",DA=1,DR="2;3" D ^DIE - K DIE,DR,DA - Q - ; -ON() ;Used to determine if the PRF software is 'active'. - ; - ; Input: None - ; - ;Output: - ; Function Value - 1 = 'Active', 0 = 'Not Active' - ; - ; - init variables - N DGACT,RESULT - S RESULT=0 - ; - ;- get software activation date from PRF PARAMETERS (#26.18) file - S DGACT=+$P($G(^DGPF(26.18,1,0)),U,2) - ; - ; - check if activation is past current date - D - .Q:('DGACT)!(DTDGF S DGQ=1 Q ;done with loop on user selection - . K DGDFNLST - . S DGCNT=$$ASGNCNT^DGPFLF6(DGSUB,.DGDFNLST) ;get list of dfn's - . Q:'DGCNT - . F S DGDFN=$O(DGDFNLST(DGDFN)) Q:DGDFN="" D - . . S DGIEN=$G(DGDFNLST(DGDFN)) Q:DGIEN="" - . . D BLDTMP(.DGSORT,DGDFN,DGIEN,DGLIST) - K DGDFNLST - Q - ; -BLDTMP(DGSORT,DGDFN,DGIEN,DGLIST) ; list global builder - ; Input: - ; DGSORT - array of user selected report parameters - ; DGDFN - ien of patient in PATIENT (#2) file - ; DGIEN - ien pointer to PRF ASSIGNMENT (#26.13) file record - ; DGLIST - temp global name used for report list - ; - ; Output: - ; ^TMP("DGPFRFA1",$J) - temp global containing report output - ; - N DGPFA,DGPFAH,DGPFPAT,DGPTR,DGINIT,DGCATG,DGLINE,DGNAME,DGREV,DGFG - S (DGPTR,DGINIT,DGCATG,DGLINE,DGNAME,DGREV)="" - K DGPFA,DGPFAH,DGPFPAT - ;retrieve a single assign record - Q:'$$GETASGN^DGPFAA(DGIEN,.DGPFA) - ;retrieve initial history assign record - Q:'$$GETHIST^DGPFAAH($$GETFIRST^DGPFAAH(DGIEN),.DGPFAH) - ;-- get 'initial assignment' date - S DGPFAH("INITASSIGN")=$G(DGPFAH("ASSIGNDT")) - Q:'DGPFAH("INITASSIGN") - S DGINIT=+DGPFAH("INITASSIGN") - I DGINIT>DGBEG&($P(DGINIT,".")'>DGEND) D - . Q:'$$GETPAT^DGPFUT2(DGDFN,.DGPFPAT) - . S DGCATG=$S(DGSUB[26.15:1,1:2) - . S DGFG=$P(DGPFA("FLAG"),U,2) - . S DGNAME=DGPFPAT("NAME") - . S DGINIT=$$FDATE^VALM1(+DGPFAH("INITASSIGN")) - . I +DGPFA("REVIEWDT") D - .. S DGREV=$$FDATE^VALM1(+DGPFA("REVIEWDT")) - . E S DGREV="N/A" - . S DGLINE=DGPFPAT("SSN")_U_DGINIT_U_DGREV_U_$P(DGPFA("STATUS"),U,2) - . S DGLINE=DGLINE_U_$P(DGPFA("OWNER"),U,2) - . S @DGLIST@(DGCATG,DGFG,DGNAME,DGDFN)=DGLINE - K DGPFA,DGPFAH,DGPFPAT - Q - ; -PRINT(DGSORT,DGLIST) ;output report - ; Input: - ; DGSORT - array of user selected report parameters - ; DGLIST - temp global name used for report list - ; - ; Output: Formated report to user selected device - ; - N DGCAT,DGFG,DGNAM,DGDFN,DGSTR,DGQ,X,Y,DGPAGE,DGDT,DGCNT,DGOFG,DGGRAND,DGLINE - S (DGCNT,DGQ,DGPAGE,DGGRAND)=0,$P(DGLINE,"-",80)="" - S DGDT=$P($$FMTE^XLFDT($$NOW^XLFDT,"T"),":",1,2) - I $O(@DGLIST@(""))="" D Q - . S DGCAT=+DGSORT("DGCAT") - . S DGFG=$S(DGSORT("DGFLAG")="A":"(A)ll Flags",1:$P(DGSORT("DGFLAG"),U,2)) - . D HEAD - . W !!," >>> No Record Flag Assignments were found using the report criteria." - ; loop and print report - S (DGCAT,DGFG,DGNAM,DGDFN,DGSTR,DGOFG)="" - F S DGCAT=$O(@DGLIST@(DGCAT)) Q:DGCAT="" D Q:DGQ - . F S DGFG=$O(@DGLIST@(DGCAT,DGFG)) Q:DGFG="" D Q:DGQ - .. I DGFG'=DGOFG D - ... D:DGCNT SUB(.DGCNT,1) - ... D HEAD - ... S DGOFG=DGFG,DGCNT=0 - .. F S DGNAM=$O(@DGLIST@(DGCAT,DGFG,DGNAM)) Q:DGNAM="" D Q:DGQ - ... F S DGDFN=$O(@DGLIST@(DGCAT,DGFG,DGNAM,DGDFN)) Q:DGDFN="" D Q:DGQ - .... S DGCNT=DGCNT+1,DGCNT(DGCAT)=$G(DGCNT(DGCAT))+1 - .... D:$Y>(IOSL-4) HEAD - .... Q:DGQ - .... S DGSTR=$G(@DGLIST@(DGCAT,DGFG,DGNAM,DGDFN)) - .... W !,$E(DGNAM,1,20),?22,$P(DGSTR,U),?33,$P(DGSTR,U,2),?43,$P(DGSTR,U,3),?53,$P(DGSTR,U,4),?63,$E($P(DGSTR,U,5),1,17) - . Q:DGQ - . I DGCNT D - .. D SUB(.DGCNT,1) - .. D:DGSORT("DGFLAG")="A" SUB(.DGCNT,2) ;only if (A)ll flags - .. S DGOFG="",DGCNT=0 - ; - ;Shutdown if stop task requested - I DGQ W:$D(ZTQUEUED) !!,"REPORT STOPPED AT USER REQUEST" Q - ; - I +DGSORT("DGCAT")=3 D ; Grand totals (B)oth Categories - . S DGCAT=3,DGFG="All Flags",DGGRAND=1 - . D HEAD - . W !!,"REPORT SUMMARY:",!,"---------------" - . F DGCAT=1,2,3 D - .. S:DGCAT'=3 DGCNT(3)=$G(DGCNT(3))+$G(DGCNT(DGCAT)) - .. W:DGCAT=3 !?39,"-------" - .. W !,"Total Assignments for Category " - .. W $S(DGCAT=1:"I",DGCAT=2:"II",1:"I & II"),":" - .. W ?40,$J(+$G(DGCNT(DGCAT)),6) - ; - W !!,"" - Q - ; -PAUSE(DGQ) ; pause screen display - ; Input: - ; DGQ - var used to quit report processing to user CRT - ; Output: - ; DGQ - passed by reference - 0 = Continue, 1 = Quit - ; - I $G(DGPAGE)>0,$E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQ=1 - Q - ; -SUB(CNT,TYP) ; print sub-totals - ; Input: - ; CNT - count of records printed - ; TYP - indicator of which total count is being printed - ; Output: Write lines of Sub-Totals and Totals per Flag and Category - ; - N DGTYPE,DGCOUNT - S DGTYPE=$S(TYP=1:"Flag",2:"Category "_$S(DGCAT=1:"I",1:"II")) - S DGCOUNT=$S(TYP=1:CNT,1:DGCNT(DGCAT)) - W:TYP=1 ! - W !,"Total Assignments for "_DGTYPE_": ",DGCOUNT - Q - ; -HEAD ;Print/Display page header - I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q - D PAUSE(.DGQ) - Q:DGQ - W:'($E(IOST,1,2)'="C-"&'DGPAGE) @IOF - S DGPAGE=$G(DGPAGE)+1 - W !?25,"PATIENT RECORD FLAGS" - W !?24,"FLAG ASSIGNMENT REPORT",?70,"Page: ",$G(DGPAGE) - W !?24,"----------------------",?48,"Printed: ",DGDT - W !?2,"CATEGORY: "_$S($G(DGCAT)=1:"Category I (National)",$G(DGCAT)=2:"Category II (Local)",1:"Both (Category I & II)") - W !,"DATE RANGE: ",$$FDATE^VALM1($G(DGSORT("DGBEG")))_" TO "_$$FDATE^VALM1($G(DGSORT("DGEND"))) - W !?1,"FLAG NAME: ",$G(DGFG),! - I DGGRAND W DGLINE Q - W !,"PATIENT NAME",?22,"SSN",?33,"ASSIGNED",?43,"REVIEW DT",?53,"STATUS",?63,"OWNING SITE" - W !,"--------------------",?22,"---------",?33,"--------",?43,"--------",?53,"--------",?63,"-----------------" - Q - ; -EXIT ; - I $D(ZTQUEUED) S ZTREQ="@" - K @DGLIST - I '$D(ZTQUEUED) D - . K %ZIS,POP - . D ^%ZISC,HOME^%ZIS - Q diff -auBN ./r1/DGPFRFA.m ./r2/r/DGPFRFA.m --- ./r1/DGPFRFA.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFRFA.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,106 +0,0 @@ -DGPFRFA ;ALB/RBS - PRF FLAG ASSIGNMENT REPORT ; 10/28/03 12:03pm - ;;5.3;Registration;**425,555**;Aug 13, 1993 - ; - ;This routine will be used for selecting sort parameters to produce - ; the FLAG ASSIGNMENT REPORT for Patient Record Flags. - ; - ;Selection options will provide the user with the ability to report - ; by: - ; CATEGORY: - ; 1 Category I (National) - ; 2 Category II (Local) - ; 3 BOTH - ; FLAG: - ; S Single Flag - ; A All Flags - ; BEGINING DATE: FileMan date - ; ENDING DATE: FileMan date - ; - ;-- no direct entry - QUIT - ; -EN ;Entry point - ;-- user prompts for report selection sorts - ; Input: none - ; Output: Report generated using user selected parameters - ; - N DGASK,DGRSLT,DGDIRA,DGDIRB,DGDIRO,DGDIRH - N DGSORT,DGCAT,DGFIL,DGSEL,DGFIRST,DGBEG,DGEND - N ZTSAVE,DGQ - ; - ;-- prompt for selection of a flag category - S DGDIRA="Select Flag Category" - S DGDIRB="" - S DGDIRH="Enter one of the category selections to report on" - S DGDIRO="S^1:Category I (National);2:Category II (Local);3:Both" - S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO,DGDIRH) - Q:(DGASK<1) - S DGCAT=DGASK,DGSORT("DGCAT")=DGASK_U_$S(DGCAT=1:"Category I (National)",DGCAT=2:"Category II (Local)",DGCAT=3:"Both",1:"") - ; - ;-- prompt for selection of a single flag or all flags - S DGSEL="" - ;list (A)ll flags if user selects Both Category's - I DGCAT=3 D - . S DGSORT("DGFLAG")="A" - ; - D:DGCAT'=3 ;only prompt if user selects a Category I or II - . S DGDIRA="Select to report on a (S)ingle flag or (A)ll flags" - . S DGDIRB="Single Flag" - . S DGDIRO="S^S:Single Flag;A:All Flags" - . S DGDIRH="Enter one of the flag selections to report on" - . S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO,DGDIRH) - . Q:(DGASK=-1) - . S DGSEL=DGASK - . S DGSORT("DGFLAG")=DGASK - Q:(DGASK=-1) - ; - ;-- prompt for selection of a record flag name - only if (S)ingle - D:DGSEL="S" - . S DGQ=0 - . S DGDIRA="Select Record Flag Name",DGDIRB="" - . S DGDIRO=$S(DGCAT=1:"P^26.15,.01:EMZ",1:"P^26.11,.01:EMZ") - . F D Q:DGQ - . . S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO) - . . I DGASK=-1 S DGQ=1 Q - . . ;set data string = pointer value (5;DGPF(26.11,) ^ external name - . . S DGFIL=DGASK_$S(DGCAT=1:";DGPF(26.15,",1:";DGPF(26.11,") - . . ;if (S)ingle flag selected, check for any flag assignments - . . I '$$ASGNCNT^DGPFLF6(DGFIL) D Q - . . . W !?2,">>> No Patient Record Flag Assignments have been found. Select another flag.",*7 - . . ;a good one to report on - . . S DGSORT("DGFLAG")=DGFIL_U_$$EXTERNAL^DILFD(26.13,.02,"F",DGFIL) - . . S DGQ=1 - ; - Q:(DGASK=-1) - ; - ;-- prompt for beginning date - S DGFIRST=$P(+$O(^DGPF(26.14,"D","")),".") ;first assignment date - I 'DGFIRST D Q - . W !?2,">>> No Patient Record Flag Assignments have been found.",*7 - . I $$ANSWER^DGPFUT("Enter RETURN to continue","","E") ;pause - ; - S DGDIRA="Select Beginning Date" - S DGDIRB="" - S DGDIRH="Enter the earliest Assignment Date to include in the report" - S DGDIRO="D^::EX" - S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO,DGDIRH) - Q:(DGASK=-1) - S (DGSORT("DGBEG"),DGBEG)=DGASK - ; - ;-- prompt for ending date - S DGDIRA="Select Ending Date" - S DGDIRB="" - S DGDIRH="Enter the lastest Assignment Date to include in the report" - S DGDIRO="D^::EX" - S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO,DGDIRH) - Q:(DGASK=-1) - S DGSORT("DGEND")=DGASK - ; - K DGCAT,DGFIL,DGSEL,DGDIRA,DGDIRB,DGDIRO,DGDIRH - K DGASK,DGRSLT,DGFIRST,DGBEG - ; - ;-- prompt for device - S ZTSAVE("DGSORT(")="" - D EN^XUTMDEVQ("START^DGPFRFA1","Patient Record Flag Assignment Report",.ZTSAVE) - D HOME^%ZIS - Q diff -auBN ./r1/DGPFRFR1.m ./r2/r/DGPFRFR1.m --- ./r1/DGPFRFR1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFRFR1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,193 +0,0 @@ -DGPFRFR1 ;ALB/RBS - PRF ASSIGNMENTS DUE REVIEW REPORT CONT. ; 5/21/03 4:40pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ;This routine will create the ASSIGNMENTS DUE FOR REVIEW REPORT. - ;This routine will be used to display or print all of the patient - ; assignments due for Review for Category I and Category II PRF's. - ; - ;All sort input was created in routine DGPFRFR. - ; Input: The following array contains the sort var's: - ; DGSORT("DGCAT") = category reporting on (I, II, or (B)oth) - ; DGSORT("DGFLAG") = "A" = (A)ll Flags will be reported on - ; = IEN of a (S)ingle Flag (#26.11)/(#26.15) - ; example: "1;DGPF(26.15," - ; DGSORT("DGBEG") = Beginning date to report on - ; DGSORT("DGEND") = Ending date to report on - ; - ; Output: Formatted report of Record Flag Assignments due for review. - ; - ;- no direct entry - QUIT - ; -START ; compile and print report - I $E(IOST)="C" D WAIT^DICD - N DGLIST - S DGLIST=$NA(^TMP("DGPFRFR1",$J)) - K @DGLIST - D LOOP(.DGSORT) - D PRINT(.DGSORT,DGLIST) - D EXIT - Q - ; -LOOP(DGSORT) ;use sort var's for record searching to build list - ; Input: - ; DGSORT - array of user selected report parameters - ; - ; Output: - ; ^TMP("DGPFRFA1",$J) - temp global containing report output - ; - N DGCAT,DGFLAG,DGBEG,DGEND,DGIEN,DGDFN,DGC,DGX,DGQ,DGFG,DGSUB,DGNOW - S (DGQ,DGFG)=0 - S DGX="" F S DGX=$O(DGSORT(DGX)) Q:DGX="" S @DGX=DGSORT(DGX) - S DGC=$S(+DGCAT=3:0,1:+DGCAT) ; 0 = both cat. I,II (National,Local) - S:DGC DGC=$S(DGC=1:26.15,1:26.11) - S DGFG=$P(DGFLAG,U) ;"A"=all flags or "5;DGPF(26.11," is selection - S DGSUB=DGBEG-1 ; seed var to start at user selected beginning date - F S DGSUB=$O(^DGPF(26.13,"AFREV",DGSUB)) Q:DGSUB="" D Q:DGQ - . I DGSUB>DGEND S DGQ=1 Q - . S DGDFN="" - . F S DGDFN=$O(^DGPF(26.13,"AFREV",DGSUB,DGDFN)) Q:DGDFN="" D - .. S DGIEN="" - .. F S DGIEN=$O(^DGPF(26.13,"AFREV",DGSUB,DGDFN,DGIEN)) Q:DGIEN="" D - ... Q:'$D(^DGPF(26.13,"D",DGDFN,1,DGIEN)) ;status not active - ... I +DGFG,'$D(^DGPF(26.13,"C",DGDFN,DGFG,DGIEN)) Q ;flag not found - ... D BLDTMP(.DGSORT,DGDFN,DGIEN,DGLIST) - Q - ; -BLDTMP(DGSORT,DGDFN,DGIEN,DGLIST) ; list global builder - ; Input: - ; DGSORT - array of user selected report parameters - ; DGDFN - ien of patient in PATIENT (#2) file - ; DGIEN - ien pointer to PRF ASSIGNMENT (#26.13) file record - ; - ; Output: - ; ^TMP("DGPFRFA1",$J) - temp global containing report output - ; - N DGPFA,DGPFAH,DGPFPAT,DGPTR,DGINIT,DGCATG - N DGLINE,DGNAME,DGREV,DGFG,DGNOT,DGYN - S (DGPTR,DGINIT,DGCATG,DGLINE,DGNAME,DGREV,DGNOT,DGYN)="" - K DGPFA,DGPFAH,DGPFPAT - ;retrieve a single assign record - Q:'$$GETASGN^DGPFAA(DGIEN,.DGPFA) - I +DGC,$P(DGPFA("FLAG"),U)'[+DGC Q ;not category selected - ;retrieve initial history assign record - Q:'$$GETHIST^DGPFAAH($$GETFIRST^DGPFAAH(DGIEN),.DGPFAH) - ;-- get 'initial assignment' date - S DGPFAH("INITASSIGN")=$G(DGPFAH("ASSIGNDT")) - Q:'DGPFAH("INITASSIGN") - Q:'$$GETPAT^DGPFUT2(DGDFN,.DGPFPAT) - S DGCATG=$S($P(DGPFA("FLAG"),U)[26.15:1,1:2) - S DGFG=$P(DGPFA("FLAG"),U,2) - S DGNAME=DGPFPAT("NAME") - S DGINIT=$$FDATE^VALM1(+DGPFAH("INITASSIGN")) - I +DGPFA("REVIEWDT") D - . S DGREV=$$FDATE^VALM1(+DGPFA("REVIEWDT")) - . I +DGPFA("REVIEWDT")>> No Record Flag Assignments were found using the report criteria." - ; loop and print report - S (DGCAT,DGFG,DGNAM,DGDFN,DGSTR,DGOFG)="" - F S DGCAT=$O(@DGLIST@(DGCAT)) Q:DGCAT="" D Q:DGQ - . F S DGFG=$O(@DGLIST@(DGCAT,DGFG)) Q:DGFG="" D Q:DGQ - .. I DGFG'=DGOFG D - ... D:DGCNT SUB(.DGCNT,1) - ... D HEAD - ... S DGOFG=DGFG,DGCNT=0 - .. F S DGNAM=$O(@DGLIST@(DGCAT,DGFG,DGNAM)) Q:DGNAM="" D Q:DGQ - ... F S DGDFN=$O(@DGLIST@(DGCAT,DGFG,DGNAM,DGDFN)) Q:DGDFN="" D Q:DGQ - .... S DGCNT=DGCNT+1,DGCNT(DGCAT)=$G(DGCNT(DGCAT))+1 - .... D:$Y>(IOSL-4) HEAD - .... Q:DGQ - .... S DGSTR=$G(@DGLIST@(DGCAT,DGFG,DGNAM,DGDFN)) - .... W !,$E(DGNAM,1,20),?22,$P(DGSTR,U),?33,$P(DGSTR,U,2),?43,$P(DGSTR,U,3),?60,$P(DGSTR,U,4) - . Q:DGQ - . I DGCNT D - .. D SUB(.DGCNT,1) - .. D:DGSORT("DGFLAG")="A" SUB(.DGCNT,2) ;only if (A)ll flags - .. S DGOFG="",DGCNT=0 - ; - ;Shutdown if stop task requested - I DGQ W:$D(ZTQUEUED) !!,"REPORT STOPPED AT USER REQUEST" Q - ; - I +DGSORT("DGCAT")=3 D ; Grand totals (B)oth Categories - . S DGCAT=3,DGFG="All Flags",DGGRAND=1 - . D HEAD - . W !!,"REPORT SUMMARY:",!,"---------------" - . F DGCAT=1,2,3 D - .. S:DGCAT'=3 DGCNT(3)=$G(DGCNT(3))+$G(DGCNT(DGCAT)) - .. W:DGCAT=3 !?46,"-------" - .. W !,"Total Review Assignments for Category " - .. W $S(DGCAT=1:"I",DGCAT=2:"II",1:"I & II"),":" - .. W ?47,$J(+$G(DGCNT(DGCAT)),6) - ; - W !!,"" - Q - ; -PAUSE(DGQ) ; pause screen display - ; Input: - ; DGQ - var used to quit report processing to user CRT - ; Output: - ; DGQ - passed by reference - 0 = Continue, 1 = Quit - ; - I $G(DGPAGE)>0,$E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQ=1 - Q - ; -SUB(CNT,TYP) ; print sub-totals - ; Input: - ; CNT - count of records printed - ; TYP - indicator of which total count is being printed - ; Output: Write lines of Sub-Totals and Totals per Flag and Category - ; - N DGTYPE,DGCOUNT - S DGTYPE=$S(TYP=1:"Flag",2:"Category "_$S(DGCAT=1:"I",1:"II")) - S DGCOUNT=$S(TYP=1:CNT,1:DGCNT(DGCAT)) - W:TYP=1 ! - W !,"Total Review Assignments for "_DGTYPE_": ",DGCOUNT - W:TYP=1 !,"Note: "" * "" indicates that review date is past due",! - Q - ; -HEAD ;Print/Display page header - I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q - D PAUSE(.DGQ) - Q:DGQ - W:'($E(IOST,1,2)'="C-"&'DGPAGE) @IOF - S DGPAGE=$G(DGPAGE)+1 - W !?22,"PATIENT RECORD FLAGS" - W !?16,"ASSIGNMENTS DUE FOR REVIEW REPORT",?70,"Page: ",$G(DGPAGE) - W !?16,"---------------------------------",?51,"Printed: ",DGDT - W !?2,"CATEGORY: "_$S($G(DGCAT)=1:"Category I (National)",$G(DGCAT)=2:"Category II (Local)",1:"Both (Category I & II)") - W !,"DATE RANGE: ",$$FDATE^VALM1($G(DGSORT("DGBEG")))_" TO "_$$FDATE^VALM1($G(DGSORT("DGEND"))) - W !?1,"FLAG NAME: ",$G(DGFG),! - I DGGRAND W DGLINE Q - W !,"PATIENT NAME",?22,"SSN",?33,"ASSIGNED",?43,"REVIEW DT",?54,"NOTIFICATION SENT" - W !,"--------------------",?22,"---------",?33,"--------",?43,"---------",?54,"-----------------" - Q - ; -EXIT ; - I $D(ZTQUEUED) S ZTREQ="@" - K @DGLIST - I '$D(ZTQUEUED) D - . K %ZIS,POP - . D ^%ZISC,HOME^%ZIS - Q diff -auBN ./r1/DGPFRFR.m ./r2/r/DGPFRFR.m --- ./r1/DGPFRFR.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFRFR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,108 +0,0 @@ -DGPFRFR ;ALB/RBS - PRF ASSIGNMENTS DUE REVIEW REPORT ; 10/28/03 12:04pm - ;;5.3;Registration;**425,555**;Aug 13, 1993 - ; - ;This routine will be used for selecting sort parameters to produce - ; the FLAGS DUE FOR REVIEW REPORT for Patient Record Flags. - ; - ;Selection options will provide the user with the ability to report - ; by: - ; CATEGORY: - ; 1 Category I (National) - ; 2 Category II (Local) - ; 3 BOTH - ; FLAG: - ; S Single Flag - ; A All Flags - ; BEGINING DATE: FileMan date - ; ENDING DATE: FileMan date - ; - ;-- no direct entry - QUIT - ; -EN ;Entry point - ;-- user prompts for report selection sorts - ; Input: none - ; Output: Report generated using user selected parameters - ; - N DGASK,DGRSLT,DGDIRA,DGDIRB,DGDIRO,DGDIRH - N DGSORT,DGCAT,DGFIL,DGSEL,DGNOW,DGFIRST,DGBEG,DGEND - N ZTSAVE,DGQ - ; - ;-- prompt for selection of a flag category - S DGDIRA="Select Flag Category",DGDIRB="" - S DGDIRH="Enter one of the category selections to report on" - S DGDIRO="S^1:Category I (National);2:Category II (Local);3:Both" - S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO,DGDIRH) - Q:(DGASK<1) - S DGCAT=DGASK,DGSORT("DGCAT")=DGASK_U_$S(DGASK=1:"Category I (National)",DGASK=2:"Category II (Local)",DGASK=3:"Both",1:"") - ; - ;-- prompt for selection of a single flag or all flags - S DGSEL="" - ;default to (A)ll flags if user selects Both Category's - I DGCAT=3 D - . S DGSORT("DGFLAG")="A" - ; - D:DGCAT'=3 ;only prompt if user selects a Category I or II - . S DGDIRA="Select to report on a (S)ingle flag or (A)ll flags" - . S DGDIRB="Single Flag" - . S DGDIRO="S^S:Single Flag;A:All Flags" - . S DGDIRH="Enter one of the flag selections to report on" - . S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO,DGDIRH) - . Q:(DGASK=-1) - . S DGSEL=DGASK - . S DGSORT("DGFLAG")=DGASK - Q:(DGASK=-1) - ; - ;-- prompt for selection of a record flag name - only if (S)ingle - D:DGSEL="S" - . S DGQ=0 - . S DGDIRA="Select Record Flag Name" - . S DGDIRB="" - . S DGDIRO=$S(DGCAT=1:"P^26.15,.01:EMZ",1:"P^26.11,.01:EMZ") - . F D Q:DGQ - . . S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO) - . . I DGASK=-1 S DGQ=1 Q - . . ;set data string = pointer value (5;DGPF(26.11,) ^ external name - . . S DGFIL=DGASK_$S(DGCAT=1:";DGPF(26.15,",1:";DGPF(26.11,") - . . ;if (S)ingle flag selected, check for any flag assignments - . . I '$$ASGNCNT^DGPFLF6(DGFIL) D Q - . . . W !?2,">>> No Patient Record Flag Assignments have been found. Select another flag.",*7 - . . ;a good one to report on - . . S DGSORT("DGFLAG")=DGFIL_U_$$EXTERNAL^DILFD(26.13,.02,"F",DGFIL) - . . S DGQ=1 - ; - Q:(DGASK=-1) - ; - ;-- prompt for beginning date - S DGNOW=$$DT^XLFDT() - S DGFIRST=$P(+$O(^DGPF(26.13,"AFREV","")),".") ;first review date - I 'DGFIRST D Q - . W !?2,">>> No Patient Record Flag Assignments have been found.",*7 - . I $$ANSWER^DGPFUT("Enter RETURN to continue","","E") - ; - S DGDIRA="Select Beginning Date" - S DGDIRB="" - S DGDIRH="Enter the earliest Review Date to include in the report" - S DGDIRO="D^::EX" - S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO,DGDIRH) - Q:(DGASK=-1) - S (DGSORT("DGBEG"),DGBEG)=DGASK - ; - ;-- prompt for ending date - S DGDIRA="Select Ending Date" - S DGDIRB="" - S DGDIRH="Enter the latest Review Date to include in the report" - S DGDIRO="D^::EX" - S DGASK=$$ANSWER^DGPFUT(DGDIRA,DGDIRB,DGDIRO,DGDIRH) - Q:(DGASK=-1) - S DGSORT("DGEND")=DGASK - S DGSORT("DGNOW")=DGNOW - ; - K DGCAT,DGFIL,DGSEL,DGDIRA,DGDIRB,DGDIRO - K DGASK,DGRSLT,DGNOW,DGFIRST,DGBEG - ; - ;-- prompt for device - S ZTSAVE("DGSORT(")="" - D EN^XUTMDEVQ("START^DGPFRFR1","Flags Due For Review Report",.ZTSAVE) - D HOME^%ZIS - Q diff -auBN ./r1/DGPFUT1.m ./r2/r/DGPFUT1.m --- ./r1/DGPFUT1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFUT1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,223 +0,0 @@ -DGPFUT1 ;ALB/RBS - PRF UTILITIES CONTINUED ; 6/10/04 12:29pm - ;;5.3;Registration;**425,607**;Aug 13, 1993 - ; - Q ;no direct entry - ; -DISPACT(DGPFAPI) ;Display all ACTIVE Patient Record Flag's for a patient - ; Input: DGPFAPI() = Array of patients active flags - ; (passed by reference) - ; See $$GETACT^DGPFAPI for array format. - ; Output: None - ; - I '$G(DGPFAPI) Q ;no flags - ; - N DGPF,DGPFIEN,DGPFFLAG,DGPFCAT,IORVON,IORVOFF - N DGCNT ;flag display count - N DGRET ;return - ; - I $D(DDS) D CLRMSG^DDS - W:'$D(DDS) !! W ">>> Active Patient Record Flag(s):" - ; - ; setup for reverse video display - ; - S (IORVON,IORVOFF)="" - D:$D(IOST(0)) - . N X S X="IORVON;IORVOFF" D ENDR^%ZISS - ; - ; loop all returned Active Record Flag Assignment ien's - S DGCNT=0 - S DGPFIEN="" F S DGPFIEN=$O(DGPFAPI(DGPFIEN)) Q:DGPFIEN="" D - . I $D(DDS),DGCNT=4 D - . . W !,"Press RETURN to continue..." - . . R DGRET:$S('$D(DTIME):300,1:DTIME) - . . D CLRMSG^DDS - . . W ">>> Active Patient Record Flag(s):" - . . S DGCNT=0 - . S DGPFFLAG=$P($G(DGPFAPI(DGPFIEN,"FLAG")),U,2) - . Q:(DGPFFLAG'["") - . S DGPFCAT=$P($P($G(DGPFAPI(DGPFIEN,"CATEGORY")),U,2)," ") - . W !?5,IORVON,"<"_DGPFFLAG_">",IORVOFF,?45,"CATEGORY ",DGPFCAT - . S DGCNT=DGCNT+1 - W:'$D(DDS) ! - Q - ; -ASKDET() ;does user want to display flag details? - ; - ; Input: - ; None - ; - ; Output: - ; Function value - return 1 on YES; otherwise 0 - ; - N YN,%,%Y - F D Q:"^YN"[YN - . W !,"Do you wish to view active patient record flag details" - . S %=1 ;default to YES - . D YN^DICN - . S YN=$S(%=-1:"^",%=1:"Y",%=2:"N",1:"?") - . I YN="?" D:$D(DDS) CLRMSG^DDS W !,"Enter either 'Y' or 'N'." - ;I $D(DDS) D REFRESH^DDSUTL - Q (YN="Y") - ; -DISPDET(DGPFAPI) ; Display the details of patients Active record flags - ; - ; Input: DGPFAPI() = Array of patients active flags - ; (passed by reference) - ; See $$GETACT^DGPFAPI for array format. - ; Output: None - ; - I '$G(DGPFAPI) Q ;no flags - ; - N DGPFI,DGPFQ,DGPFIEN,DGPFFLAG,IORVON,IORVOFF,DIRUT,DUOUT,DTOUT,X - ; - S (IORVON,IORVOFF)="" - D:$D(IOST(0)) - . N X S X="IORVON;IORVOFF" D ENDR^%ZISS - ; - ; loop all returned Active Record Flag Assignment ien's - S (DGPFIEN,DGPFQ)="" - F S DGPFIEN=$O(DGPFAPI(DGPFIEN)) Q:DGPFIEN="" D Q:DGPFQ - . S DGPFFLAG=$P($G(DGPFAPI(DGPFIEN,"FLAG")),U,2) - . Q:(DGPFFLAG'["") - . I $G(DGPFQ)=0 W ! S DGPFQ='$$CONTINUE^DGPFUT() Q:DGPFQ - . S DGPFQ=0 - . W:$E(IOST,1,2)="C-" @IOF - . W !?11,"Flag Name: ",IORVON,"<"_DGPFFLAG_">",IORVOFF - . W !?11,"Flag Type: ",$P($G(DGPFAPI(DGPFIEN,"FLAGTYPE")),U,2) - . W !?7,"Flag Category: ",$P($G(DGPFAPI(DGPFIEN,"CATEGORY")),U,2) - . W !?3,"Assignment Status: ACTIVE" - . W !?2,"Initial Assignment: ",$P($G(DGPFAPI(DGPFIEN,"ASSIGNDT")),U,2) - . W !?9,"Approved By: ",$P($G(DGPFAPI(DGPFIEN,"APPRVBY")),U,2) - . W !?4,"Next Review Date: ",$P($G(DGPFAPI(DGPFIEN,"REVIEWDT")),U,2) - . W !?10,"Owner Site: ",$P($G(DGPFAPI(DGPFIEN,"OWNER")),U,2) - . W !?4,"Originating Site: ",$P($G(DGPFAPI(DGPFIEN,"ORIGSITE")),U,2) - . W !,"Assignment Narrative:",!,"---------------------" - . I $D(DGPFAPI(DGPFIEN,"NARR",1,0)) D - . . S DGPFI="" - . . F S DGPFI=$O(DGPFAPI(DGPFIEN,"NARR",DGPFI)) Q:DGPFI="" D Q:DGPFQ - . . . I $Y>(IOSL-3) S DGPFQ='$$CONTINUE^DGPFUT() Q:DGPFQ S $Y=2 - . . . W !,$G(DGPFAPI(DGPFIEN,"NARR",DGPFI,0)) - ; - W !!,IORVON,"",IORVOFF,! - N DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT - S DIR("A")="Enter RETURN to continue",DIR(0)="E" - D ^DIR K DIR - W ! - Q - ; -DISPPRF(DGDFN) ; Patient Record Flags screen Display - ; - ; Supported References: - ; DBIA #10096 Z OPERATING SYSTEM FILE (%ZOSF) - ; DBIA #10150 ScreenMan API: Form Utilities - ; - ; Input: - ; DGDFN - pointer to patient in PATIENT (#2) file - ; - ; Output: - ; none - ; - ; patient ien not setup - S DGDFN=+$G(DGDFN) - Q:'DGDFN - ; - N DGPFAPI - ; - ; call API to get the display array for ALL Active Assignments - S DGPFAPI=$$GETACT^DGPFAPI(DGDFN,"DGPFAPI") ;DBIA #3860 - ; - ; quit if no Active Record Flags to display - Q:'+DGPFAPI - ; - ; call api to display Active Record Flags - D DISPACT(.DGPFAPI) - ; - ; display the details of patients Active record flags - ;D DISPDET(.DGPFAPI) ;roll-and-scroll - ; - ; prompt and display assignment details - I $$ASKDET() D EN^DGPFLMD(DGDFN,.DGPFAPI) ;ListMan - ; - ; cleanup display for ScreenMan - I $D(DDS) D D CLRMSG^DDS D REFRESH^DDSUTL - . ;set right margin to zero - needed for Cache - . N X - . S X=0 X ^%ZOSF("RM") - Q - ; -SELPAT(DGPAT) ;This procedure is used to perform a patient lookup for an existing patient in the PATIENT (#2) file. - ; - ; Input: None - ; - ; Output: - ; DGPAT - result array containing the patient selection on success, - ; pass by reference. Array will have same structure as the Y - ; variable returned by the ^DIC call. - ; Array Format: - ; ------------- - ; DGPAT = IEN of patient in PATIENT (#2) file on - ; success, -1 on failure - ; DGPAT(0) = zero node of entry selected - ; DGPAT(0,0) = external form of the .01 field of the entry - ; - ;- int input vars for ^DIC call - N DIC,DTOUT,DUPOT,X,Y - S DIC="^DPT(",DIC(0)="AEMQZV" - ; - ;- lookup patient - D ^DIC K DIC - ; - ;- result of lookup - S DGPAT=Y - ; - ;- if success, setup return array using output vars from ^DIC call - I (+DGPAT>0) D - . S DGPAT=+Y ;patient ien - . S DGPAT(0)=$G(Y(0)) ;zero node of patient in (#2) file - . S DGPAT(0,0)=$G(Y(0,0)) ;external form of the .01 field - ; - Q - ; - ; -GETFLAG(DGPFPTR,DGPFLAG) ;retrieve a single FLAG record - ; This function acts as a wrapper around the $$GETLF and $$GETNF - ; API's. Function will be used to obtain a single flag record from - ; either the PRF LOCAL FLAG (#26.11) file or the PRF NATIONAL FLAG - ; (#26.15) file depending on the value of the DGPFPTR input parameter. - ; - ; Input: - ; DGPFPTR - (required) IEN of patient record flag in PRF NATIONAL - ; FLAG (#26.15) file or PRF LOCAL FLAG (#26.11) file. - ; [ex: "1;DGPF(26.15,"] - ; - ; Output: - ; Function Value - returns 1 on success, 0 on failure - ; DGPFLAG - (required) result array passed by reference. See the - ; $$GETLF and $$GETNF for the result array structure. - ; - N RESULT ;returned function value - N DGPFIEN ;ien of PRF local or national flag file - N DGPFILE ;file # of PRF local or national flag file - ; - S RESULT=0 - ; - D - . ;-- quit if pointer is not valid - . Q:$G(DGPFPTR)']"" - . Q:'$$TESTVAL^DGPFUT(26.13,.02,DGPFPTR) - . ; - . ;-- get ien and file from pointer value - . S DGPFIEN=+$G(DGPFPTR) - . S DGPFILE=$P($G(DGPFPTR),";",2) - . ; - . ;-- if local flag file, get local flag into DGPFLAG array - . I DGPFILE["26.11" D - . . Q:'$$GETLF^DGPFALF(+DGPFIEN,.DGPFLAG) - . . S RESULT=1 ;success - . ; - . ;-- if national flag file, get national flag into DGPFLAG array - . I DGPFILE["26.15" D - . . Q:'$$GETNF^DGPFANF(+DGPFIEN,.DGPFLAG) - . . S RESULT=1 ;success - ; - Q RESULT diff -auBN ./r1/DGPFUT2.m ./r2/r/DGPFUT2.m --- ./r1/DGPFUT2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFUT2.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,189 +0,0 @@ -DGPFUT2 ;ALB/KCL - PRF UTILITIES CONTINUED ; 8/15/03 1:43pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - ; This routine contains generic calls for use throughout DGPF*. - ; - ;- no direct entry - QUIT - ; - ; -GETPAT(DGDFN,DGPAT) ;retrieve patient identifying information - ; Used to obtain identifying information for a patient - ; in the PATIENT (#2) file and place it in an array format. - ; - ; NOTE: Direct global reference of patient's zero node in the - ; PATIENT (#2) file is supported by DBIA #10035 - ; - ; Input: - ; DGDFN - (required) ien of patient in PATIENT (#2) file - ; - ; Output: - ; Function Value - returns 1 on success, 0 on failure - ; DGPAT - output array containing the patient identifying information, - ; on success, pass by reference. - ; Array subscripts are: - ; "DFN" - ien PATIENT (#2) file - ; "NAME" - patient name - ; "SSN" - patient Social Security Number - ; "DOB" - patient date of birth (FM format) - ; "SEX" - patient sex - ; - N DGNODE - N RESULT - ; - S RESULT=0 - ; - I $G(DGDFN)>0,$D(^DPT(DGDFN,0)) D - . - . ;-- obtain zero node of patient record (supported by DBIA #10035) - . S DGNODE=$G(^DPT(DGDFN,0)) - . ; - . S DGPAT("DFN")=DGDFN - . S DGPAT("NAME")=$P(DGNODE,"^") - . S DGPAT("SEX")=$P(DGNODE,"^",2) - . S DGPAT("DOB")=$P(DGNODE,"^",3) - . S DGPAT("SSN")=$P(DGNODE,"^",9) - . S RESULT=1 ;success - ; - Q RESULT - ; -GETDFN(DGICN,DGDOB,DGSSN) ;Convert ICN to DFN after verifying DOB and SSN - ; - ; Supported DBIA #2701: The supported DBIA is used to retrieve the - ; pointer (DFN) to the PATIENT (#2) file for a - ; given ICN. - ; - ; Input: - ; DGICN - Integrated Control Number with or without checksum - ; DGDOB - Date of Birth in FileMan format - ; DGSSN - Social Security Number with no delimiters - ; - ; Output: - ; Function Value - DFN on success, 0 on failure - ; - N DGDFN ;pointer to patient - N DGDPT ;patient data array - N DGRSLT ;function value - ; - S DGRSLT=0 - S DGICN=+$G(DGICN) - S DGDOB=+$G(DGDOB) - S DGSSN=+$G(DGSSN) - I DGICN,DGDOB,DGSSN D ;drops out of block on first failure - . S DGDFN=+$$GETDFN^MPIF001(DGICN) - . Q:(DGDFN'>0) - . Q:('$$GETPAT^DGPFUT2(DGDFN,.DGDPT)) - . Q:(DGDOB'=+DGDPT("DOB")) - . Q:(DGSSN'=+DGDPT("SSN")) - . S DGRSLT=DGDFN - Q DGRSLT - ; -SORT(DGPFAPI) ;sort active record flags by category then name - ; This procedure takes the initial active flag assignment list for a - ; patient and sorts it by category then by name. - ; - ; Input: - ; DGPFAPI - active flag data array list - ; - ; Output: - ; DGPFAPI - sorted active flag data array list - ; - N DGCAT ;category - N DGINDX ;index array - N DGNAME ;flag name - N DGSORT ;sorted data array - N DGX ;generic counter - ; - ;build index - S DGX=0 - F S DGX=$O(DGPFAPI(DGX)) Q:'DGX D - . S DGCAT=$S($P(DGPFAPI(DGX,"FLAG"),U)[26.11:2,1:1) - . S DGINDX(DGCAT,$P(DGPFAPI(DGX,"FLAG"),U,2))=DGX - ; - ;build sorted data array - S DGCAT=0,DGX=0 - F S DGCAT=$O(DGINDX(DGCAT)) Q:'DGCAT D - . S DGNAME="" - . F S DGNAME=$O(DGINDX(DGCAT,DGNAME)) Q:DGNAME="" D - . . S DGX=DGX+1 - . . M DGSORT(DGX)=DGPFAPI(DGINDX(DGCAT,DGNAME)) - ; - ;remove input array and replace with sorted array - K DGPFAPI - M DGPFAPI=DGSORT - Q - ; -ACTDT ; update PRF Software Activation Date field in (#26.18) - ; This utility should only be run at the Alpha and Beta test sites - ; of the Patient Record Flags Project, Patch DG*5.3*425. - ; If necessary, this entry point will change the date that the - ; Patient Record Flags (PRF) System became active. - ; The (#1) PRF SOFTWARE ACTIVATION DATE field of the (#26.18) PRF - ; PARAMETERS file, will be changed to: SEP 25, 2003 - ; - ; Input: none - ; - ; Output: User message on successful or failure of file update - ; - N DGACTDT ; Nationally Released Software Activation Date value - N DGIENS ; IEN - internal entry # OF (#26.18) FILE - N DGFLD ; PRF Software Activation Date field # - N DGFDA ; FDA data array for filer - N DGERR ; error message array returned from filer - N DGERRMSG ; error message for display - N DGPARM ; current internal/external values of field - ; - S DGACTDT="SEP 25, 2003" - S DGIENS="1," - S DGFLD=1 - ; - ; display user message - W !!,"Updating the PRF SOFTWARE ACTIVATION DATE (#1) field in the PRF PARAMETERS FILE (#26.18) to the value of SEP 25, 2003..." - ; - ; checks for necessary programmer variables - I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D - . S DGERRMSG="Your programming variables are not set up properly." - ; - ; check if activation is not less than the current date - I '$D(DGERRMSG),DT<3030925 D - . S DGERRMSG="This file/field update can't be run before the date of SEP 25, 2003 is reached." - ; - ; get current activation date from PRF PARAMETERS (#26.18) file - I '$D(DGERRMSG) D - . D GETS^DIQ(26.18,"1,",1,"IE","DGPARM","DGERR") - . ; - . ; check for errors and inform the user - . I $D(DGERR) D Q - . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1)) - . ; - . ; check to make sure field is not set already - . I $G(DGPARM(26.18,"1,",1,"I"))=3030925 D - . . S DGERRMSG="The date value is already set to SEP 25, 2003." - ; - ; now start the (#26.18) filing process - I '$D(DGERRMSG) D - . ; - . ; DELETE activation date before filing since field is uneditable - . S DGFDA(26.18,DGIENS,1)="@" - . D FILE^DIE("","DGFDA","DGERR") - . ; - . ; check for errors and inform the user - . I $D(DGERR) D Q - . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1)) - . ; - . ; setup and file the new activation date value (external) - . S DGFDA(26.18,DGIENS,1)=DGACTDT - . D FILE^DIE("SE","DGFDA","DGERR") - . ; - . ; check for success or errors and inform the user of update status - . I $D(DGERR) D Q - . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1)) - ; - ; display successful/failure file update - updated field and value - W !!,$C(7) - I $D(DGERRMSG) D - . W "Field could not be updated...",DGERRMSG - E D - . W "Field was successfully changed from ",$G(DGPARM(26.18,"1,",1,"E"))," to ",$G(DGFDA(26.18,DGIENS,DGFLD)),"." - ; - Q diff -auBN ./r1/DGPFUT.m ./r2/r/DGPFUT.m --- ./r1/DGPFUT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPFUT.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,214 +0,0 @@ -DGPFUT ;ALB/RPM - PRF UTILITIES ; 4/24/03 3:34pm - ;;5.3;Registration;**425**;Aug 13, 1993 - ; - Q ;no direct entry - ; -ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH) ;wrap FileMan Classic Reader call - ; - ; Input - ; DGDIR0 - DIR(0) string - ; DGDIRA - DIR("A") string - ; DGDIRB - DIR("B") string - ; DGDIRH - DIR("?") string - ; - ; Output - ; Function Value - Internal value returned from ^DIR or -1 if user - ; up-arrows, double up-arrows or the read times out. - ; - ; DIR(0) type Results - ; ------------ ------------------------------- - ; DD IEN of selected entry - ; Pointer IEN of selected entry - ; Set of Codes Internal value of code - ; Yes/No 0 for No, 1 for Yes - ; - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables - ; - S DIR(0)=DGDIR0 - S DIR("A")=$G(DGDIRA) - I $G(DGDIRB)]"" S DIR("B")=DGDIRB - I $D(DGDIRH) S DIR("?")=DGDIRH - D ^DIR - Q $S($D(DUOUT):-1,$D(DTOUT):-1,$D(DIROUT):-1,X="@":"@",1:$P(Y,U)) - ; -CONTINUE() ;pause display - ; - ; Input: none - ; - ; Output: 1 - continue - ; 0 - quit - ; - N DIR,Y - S DIR(0)="E" D ^DIR - Q $S(Y'=1:0,1:1) - ; -VALID(DGRTN,DGFILE,DGIP,DGERR) ;validate input values before filing - ; - ; Input: - ; DGRTN - (required) Routine name that contains $TEXT table - ; DGFILE - (required) File number for input values - ; DGIP - (required) Input value array - ; DGERR - (optional) Returns error message passed by reference - ; - ; Output: - ; Function Value - Returns 1 on all values valid, 0 on failure - ; - I $G(DGRTN)=""!('$G(DGFILE)) Q 0 - N DGVLD ;function return value - N DGFXR ;node name to field xref array - N DGREQ ;array of required fields - N DGWP ;word processing flag - N DGN ;array node name - ; - S DGVLD=1 - S DGN="" - D BLDXR(DGRTN,.DGFXR) - ; - F S DGN=$O(DGFXR(DGN)) Q:DGN="" D Q:'DGVLD - . S DGREQ=$P(DGFXR(DGN),U,2) - . S DGWP=$P(DGFXR(DGN),U,3) - . I DGREQ D ;required field check - . . I DGWP,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q - . . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0 Q - . I 'DGVLD D Q - . . S DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED" - . Q:DGWP ;don't check word processing fields for invalid values - . ;check for invalid values - . I '$$TESTVAL(DGFILE,+DGFXR(DGN),$P($G(DGIP(DGN)),U)) D Q - . . S DGVLD=0,DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" NOT VALID" - Q DGVLD - ; -BLDXR(DGRTN,DGFLDA) ;build name/field xref array - ;This procedure reads in the text from the XREF line tag of the DGRTN - ;input parameter and loads name/field xref array with parsed line data. - ; - ; Input: - ; DGRTN - (required) Routine name that contains the XREF line tag - ; DGFLDA - (required) Array name for name/field xref passed by - ; reference - ; - ; Output: - ; Function Value - Returns 1 on success, 0 on failure - ; DGFLDA - Name/field xref array - ; format: DGFLDA(subscript)=field#^required?^word proc? - ; - S DGRTN=$G(DGRTN) - Q:DGRTN="" - I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN - Q:($T(@DGRTN)="") - N DGTAG - N DGOFF - N DGLINE - ; - F DGOFF=1:1 S DGTAG="XREF+"_DGOFF_DGRTN,DGLINE=$T(@DGTAG) Q:DGLINE="" D - . S DGFLDA($P(DGLINE,";",3))=$P(DGLINE,";",4)_U_+$P(DGLINE,";",5)_U_+$P(DGLINE,";",6) - Q - ; -CKWP(DGROOT) ;ck word processing required fields - ;This function verifies that at least one line in the word processing - ;array contains text more than one space long. - ; - ; Input: - ; DGROOT - (required) Word processing root - ; - ; Output: - ; Function Value - Returns 1 on success, 0 on failure - ; - N DGLIN - N DGRSLT - S DGRSLT=0 - I $D(@DGROOT) D - . S DGLIN="" - . F S DGLIN=$O(@DGROOT@(DGLIN)) Q:DGLIN="" D Q:DGRSLT - . . I $G(@DGROOT@(DGLIN,0))]"",@DGROOT@(DGLIN,0)'=" " S DGRSLT=1 - Q DGRSLT - ; -TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def - ; - ; Input: - ; DGFIL - (required) File number - ; DGFLD - (required) Field number - ; DGVAL - (required) Field value to be validated - ; - ; Output: - ; Function Value - Returns 1 if value is valid, 0 if value is invalid - ; - N DGVALEX ;external value after conversion - N DGTYP ;field type - N DGRSLT ;results of CHK^DIE - N VALID ;function results - ; - S VALID=1 - I $G(DGFIL)>0,($G(DGFLD)>0),($G(DGVAL)'="") D - . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL) - . I DGVALEX="" S VALID=0 Q - . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER" D - . . D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0 Q - Q VALID - ; -STATUS(DGACT) ;calculate the an assignment STATUS given an ACTION code - ; - ; Input: - ; DGACT - (required) Action (.03) field value for PRF ASSIGNMENT - ; HISTORY (#26.14) file in internal or external format - ; - ; Output: - ; Function Value - Status value on success, -1 on failure - ; - N DGERR ;FM message root - N DGRSLT ;CHK^DIE result array - N DGSTAT ;calculated status value - ; - S DGSTAT=-1 - I $G(DGACT)]"" D - . I DGACT?1.N S DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR") - . Q:$D(DGERR) - . D CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR") - . Q:$D(DGERR) - . I DGRSLT(0)="INACTIVATE" S DGSTAT=0 - . E S DGSTAT=1 - Q DGSTAT - ; -MPIOK(DGDFN,DGICN,DGCMOR) ;return non-local CMOR and ICN - ;This function retrieves an ICN given a pointer to the PATIENT (#2) file - ;for a patient. When the ICN is not local and the local site is not the - ;Coordinating Master of Record (CMOR), the CMOR is retrieved as a - ;pointer to the INSTITUTION (#4) file. - ; - ; Supported DBIA #2701: The supported DBIA is used to access MPI - ; APIs to retrieve ICN, determine if ICN - ; is local and if site is CMOR. - ; Supported DBIA #2702: The supported DBIA is used to retrieve the - ; MPI node from the PATIENT (#2) file. - ; - ; Input: - ; DGDFN - IEN of patient in PATIENT (#2) file - ; DGICN - passed by reference to contain national ICN - ; DGCMOR - passed by reference to contain CMOR - ; - ; Output: - ; Function Value - 1 on national ICN and non-local CMOR, 0 on failure - ; DGICN - Patient's Integrated Control Number - ; DGCMOR - Pointer to INSTITUTION (#4) file for CMOR if CMOR - ; is not local, undefined otherwise. - ; - N DGRSLT - S DGRSLT=0 - I $G(DGDFN)>0,$D(^DPT(DGDFN,"MPI")) D - . S DGICN=$$GETICN^MPIF001(DGDFN) - . ; - . ;ICN must be valid - . Q:(DGICN'>0) - . ; - . ;ICN must not be local - . Q:$$IFLOCAL^MPIF001(DGDFN) - . ; - . ;local site must not be CMOR site - . Q:($$IFVCCI^MPIF001(DGDFN)=1) - . ; - . ;get CMOR institution number - . S DGCMOR=$P($$MPINODE^MPIFAPI(DGDFN),U,3) - . Q:(DGCMOR'>0) - . ; - . S DGRSLT=1 - Q DGRSLT diff -auBN ./r1/DGPLBL1.m ./r2/r/DGPLBL1.m --- ./r1/DGPLBL1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPLBL1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,50 +0,0 @@ -DGPLBL1 ;ALB/RPM - PATIENT INFORMATION LABEL UTILITIES ; 04/08/04 - ;;5.3;Registration;**571**;Aug 13, 1993 - ; - ; This routine contains procedures that will define either a - ; vertical or horizontal format form for printing patient labels - ; on an Intermec label printer. The formatting is done using - ; Intermec Programming Language (IPL). Use the appropriate entry - ; point in the OPEN EXECUTE (#6) field of the TERMINAL TYPE (#3.2) - ; file. - ; - ; Vertical format: VINTERM^DGPLBL1 - ; Horizontal format: HINTERM^DGPLBL1 - ; - Q ;no direct entry - ; -VINTERM ;vertical label format loader for Intermec Label Printers - ; This procedure programs the Patient Information label in vertical - ; format for an Intermec label printer and stores it as format 2. - ; This procedure must defined in the OPEN EXECUTE field of the - ; TERMINAL TYPE (#3.2) file for the Intermec printer. - ; - ; Example: OPEN EXECUTE: D VINTERM^DGPLBL1 - ; - U IO - W "C",! ;operate in "advanced" mode - W "P",! ;enter programming mode - W "E2;F2;",! ;erase format 2;create format 2 - W "H0;o10,70;d0,40;f0;c25;k10;",! ;name field - W "H1;o10,110;d0,40;f0;c25;k10;",! ;SSN field - W "H2;o10,150;d0,40;f0;c25;k10;",! ;DOB field - W "H3;o10,190;d0,40;f0;c25;k10;",! ;inpatient location - Q - ; -HINTERM ;horizontal label format loader for Intermec Label Printers - ; This procedure programs the Patient Information label in horizontal - ; format for an Intermec label printer and stores it as format 2. - ; This procedure must defined in the OPEN EXECUTE field of the - ; TERMINAL TYPE (#3.2) file for the Intermec printer. - ; - ; Example: OPEN EXECUTE: D HINTERM^DGPLBL1 - ; - U IO - W "C",! ;operate in "advanced" mode - W "P",! ;enter programming mode - W "E2;F2;",! ;erase format 2;create format 2 - W "H0;o210,51;d0,40;f3;c25;k10;",! ;name field - W "H1;o170,51;d0,40;f3;c25;k10;",! ;SSN field - W "H2;o130,51;d0,40;f3;c25;k10;",! ;DOB field - W "H3;o90,51;d0,40;f3;c25;k10;",! ;inpatient location - Q diff -auBN ./r1/DGPLBL.m ./r2/r/DGPLBL.m --- ./r1/DGPLBL.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPLBL.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,201 +0,0 @@ -DGPLBL ;ALB/RPM - PATIENT INFORMATION LABELS ; 05/07/04 - ;;5.3;Registration;**571**;Aug 13, 1993 - ; - ;This routine provides a generic patient demographics label - ;print that includes Patient Name, SSN, DOB and an optional - ;inpatient location (ward and bed). Support for various printer - ;types (i.e. bar code, laser, etc.) is provided using the CONTROL - ;CODES (#3.2055) subfile of the TERMINAL TYPE (#3.2) file. The - ;control code mnemonics are documented in DBIA# 3435. - ; - Q ;no direct entry - ; -EN ;main entry point used by DG PRINT PATIENT LABEL option - ; - N DGDFNS ;selected patients array - N DGIOCC ;control codes array - N DGLBCNT ;label count - N DGLPL ;lines per label - N DGLOC ;include location flag (0 or 1) - N DGQVAR ;queuing variables - ; - ;select list of patients to print - Q:'$$SELPATS("DGDFNS") - ; - S DGLOC=$$ASK("Include Inpatient Location on Label","Y","YES","Answer YES to include the inpatient ward and bed location on the label") - Q:(DGLOC<0) - ; - S DGLBCNT=$$ASK("Number of Labels per patient",1,"NO^1:250:0","Enter the number of labels to print per patient, from 1 to 250") - Q:(DGLBCNT<0) - ; - S DGLPL=$$ASK("Number of Lines per Label",6,"NO^6:25:0","Enter the total number of lines that the label stock can contain (6-25)") - Q:(DGLPL<0) - ; - ; - ;init queued variables and select output device - S DGQVAR("DGDFNS(")="" - S DGQVAR("DGLBCNT")="" - S DGQVAR("DGLPL")="" - S DGQVAR("DGLOC")="" - D EN^XUTMDEVQ("START^DGPLBL","DG PRINT PATIENT LABEL",.DGQVAR) - Q - ; -START ;retrieve label field data and print labels - ; - ; Input: - ; DGDFNS - array subscripted by pointer to PATIENT (#2) file - ; DGLBCNT - number of labels to print per patient - ; DGLPL - number of lines per label - ; DGLOC - print ward location flag - ; - ; Output: - ; none - ; - N DGDFN ;pointer to PATIENT file - N DGI,DGJ ;generic counters - N DGIOCC ;printer Control Codes - N DGLN ;line array index - N DGLNCNT ;line count - N DGLINE ;line text - ; - ;initialize printer - S DGIOCC=$$LOADCC(.DGIOCC) - I DGIOCC,$G(DGIOCC("FI"))]"" X DGIOCC("FI") ;format initialize - ; - ;for each patient - S DGDFN=0 - F S DGDFN=$O(DGDFNS(DGDFN)) Q:'DGDFN D - . ; - . ;build text line array - . S DGLNCNT=$$BLDLNAR(DGDFN,DGLOC,.DGLINE) - . Q:'DGLNCNT - . ; - . ;print patient's labels - . F DGI=1:1:DGLBCNT D - . . I DGIOCC,$G(DGIOCC("SL"))]"" X DGIOCC("SL") ;start of label - . . ;for each line - . . F DGLN=1:1:DGLNCNT D - . . . I DGIOCC,$G(DGIOCC("ST"))]"" X DGIOCC("ST") ;start text - . . . I DGIOCC,$G(DGIOCC("STF"))]"" X DGIOCC("STF") ;start text field - . . . W $G(DGLINE(DGLN)) - . . . I DGIOCC,$G(DGIOCC("ETF"))]"" X DGIOCC("ETF") ;end text field - . . . I DGIOCC,$G(DGIOCC("ET"))]"" X DGIOCC("ET") ;end text - . . . I 'DGIOCC W ! - . . I DGIOCC,$G(DGIOCC("EL"))]"" X DGIOCC("EL") ;end of label - . . I 'DGIOCC,DGLNCNT0 S TL=0 ; ^UTILITY("DGWTOR",$J,ORDER,TOTAL LEVEL)=TOTAL NAME ^ PRINT IN CUM TOTALS (ORDER TOTAL) @@ -37,13 +37,9 @@ S CUM="",(W,TL(TL,T2))=NTOTAL D TWR Q ; -TWR N DGDNTD - S DGDNTD=$S($P(DGWTOR,"^")["DON'T DISPLAY":1,1:0) - I DGDNTD,TL=1 W:UL["-" ! F L=1:1:131 W UL - I 'DGDNTD D - .W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL - .W ! - .D PTOT ; print line on BSR +TWR W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL + W ! + I $P(DGWTOR,"^")'["DON'T DISPLAY" D PTOT ; print line on BSR ; code below updates cums S (CB,BD,CW,NTOTAL)="" I $S('$P(DGWTOR,"^",2):1,TL'=1:1,1:0) S CUM="" Q @@ -56,20 +52,18 @@ S $P(W,"^",11)=$S(+$P(W,"^",13)>+$P(W,"^",6):($P(W,"^",13)-$P(W,"^",6)),1:0) ; Vacant Beds = Operating Beds - Patients Remaining S $P(W,"^",14)=$S(+$P(W,"^",6)>+$P(W,"^",13):($P(W,"^",6)-$P(W,"^",13)),1:0) ; Overcapacity = Patients Remaining - Operating Beds W $P(DGWTOR,"^") ; Total (level name) - ;F I=3:1:16 W ?+$P(TAB,"^",I),$J($P(W,"^",I),$P(JUS,"^",I)) - F I=3:1:15 W ?+$P(TAB,"^",I),$J($P(W,"^",I),$P(JUS,"^",I)) ;DG*5.3*592 - S X(16)=$J($P(W,"^",16),0,1) ;DG*5.3*592 - S X(17)=$S($P(TB(TL,T2),"^",3)'>0:0,1:$P(W,"^",18)*100/($P(TB(TL,T2),"^",3))) ; Cum Patient Days*100/Cum Beds + F I=3:1:15 W ?+$P(TAB,"^",I),$J($P(W,"^",I),$P(JUS,"^",I)) + S X(16)=($P(W,"^",18)/FY("D")) ; Cum Pat Days/Days into fiscal year + S X(17)=$S($P(TB(TL,T2),"^",3)'>0:0,1:((X(16)*100)/($P(TB(TL,T2),"^",3)/FY("D")))) ; ADC/(Cum Bed Total/Days into fiscal year) + S X(16)=$J(X(16),0,1) ; Cum ADC S X(17)=$J(X(17),0,1)_"%" ; Cum Occ Rate S X(18)=$P(W,"^",18) ; Cum Pat Days - ;F I=17:1:18 W ?+$P(TAB,"^",I),$J(X(I),$P(JUS,"^",I)) - F I=16:1:18 W ?+$P(TAB,"^",I),$J(X(I),$P(JUS,"^",I)) ;DG*5.3*592 + F I=16:1:18 W ?+$P(TAB,"^",I),$J(X(I),$P(JUS,"^",I)) W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL I $Y>$S($D(IOSL):(IOSL-5),1:61) D HEAD^DGPMBSP,HEAD2^DGPMBSP Q ; -MTL ;F N1=3:1:15,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+$P(TN,"^",N1) - F N1=3:1:16,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+$P(TN,"^",N1) ;DG*5.3*592 +MTL F N1=3:1:15,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+$P(TN,"^",N1) S T3=$O(TB(TL,T)) I T'>T3 S T2=T3 F N1=1:1:3 S $P(TB(TL,T2),"^",N1)=$P(TB(TL,T2),"^",N1)+$P(TX,"^",N1) diff -auBN ./r1/DGPMBSP4.m ./r2/r/DGPMBSP4.m --- ./r1/DGPMBSP4.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMBSP4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMBSP4 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ; 3/29/04 9:02pm - ;;5.3;Registration;**592**;Aug 13, 1993 +DGPMBSP4 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 + ;;5.3;Registration;;Aug 13, 1993 ; A Q:'PL ; @@ -23,12 +23,9 @@ S $P(X,"^",11)=$S(+$P(X,"^",13)>+$P(X,"^",6):($P(X,"^",13)-$P(X,"^",6)),1:0) ; Vacant Beds = Operating Beds - Patients Remaining S $P(X,"^",14)=$S(+$P(X,"^",6)>+$P(X,"^",13):($P(X,"^",6)-$P(X,"^",13)),1:0) ; Overcapacity = Patients Remaining - Operating Beds F N=3:1:15 W ?+$P(TAB,"^",N),$J($P(X,"^",N),+$P(JUS,"^",N)) - ;S X(16)=($P(X,"^",18)/FY("D")) - S X(16)=$P(X,"^",16) ;DG*5.3*592 - ;S X2=$P(X1,"^",3)/FY("D") - S X2=$P(X1,"^",3) ;DG*5.3*592 - ;S X(17)=$S(X2'>0:0,1:((X(16)*100)/X2)) - S X(17)=$S(X2'>0:0,1:(($P(X,"^",18)*100)/X2)) ; DG*5.3*592 + S X(16)=($P(X,"^",18)/FY("D")) + S X2=$P(X1,"^",3)/FY("D") + S X(17)=$S(X2'>0:0,1:((X(16)*100)/X2)) S X(16)=$J(X(16),0,1) S X(17)=$J(X(17),0,1)_"%" S X(18)=+$P(X,"^",18) diff -auBN ./r1/DGPMDD1.m ./r2/r/DGPMDD1.m --- ./r1/DGPMDD1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMDD1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMDD1 ;ALB/MRL - FILE 405 'SET' X-REFERENCES; 08 NOV 88 ; 11/5/03 1:24pm - ;;5.3;Registration;**156,555**;Aug 13, 1993 +DGPMDD1 ;ALB/MRL - FILE 405 'SET' X-REFERENCES; 08 NOV 88<<= NOT VERIFIED > + ;;5.3;Registration;**156**;Aug 13, 1993 D FLDS^DGPMDD2 G Q:DGPMDDER I DGPMDD(2)']"" G 14:DGPMDDF=14,Q I "^1^2^3^22^"[("^"_+DGPMDDF_"^"),DGPMDD(3) S ^DGPM("ATT"_+DGPMDD(2),+DGPMDD(1),DA)="",^DGPM("APTT"_+DGPMDD(2),+DGPMDD(3),+DGPMDD(1),DA)="",^DGPM("AMV"_+DGPMDD(2),+DGPMDD(1),+DGPMDD(3),DA)="",^DGPM("ATID"_+DGPMDD(2),+DGPMDD(3),DGPMDDID,DA)="" I DGPMDD(2)=4!(DGPMDD(2)=5) G Q diff -auBN ./r1/DGPMDD2.m ./r2/r/DGPMDD2.m --- ./r1/DGPMDD2.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMDD2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMDD2 ;ALB/MRL - FILE 405 'KILL' X-REFERENCES; 08 NOV 88 ; 11/5/03 1:25pm - ;;5.3;Registration;**156,555**;Aug 13, 1993 +DGPMDD2 ;ALB/MRL - FILE 405 'KILL' X-REFERENCES; 08 NOV 88<<= NOT VERIFIED > + ;;5.3;Registration;**156**;Aug 13, 1993 D FLDS I DGPMDDER G Q I "^1^2^3^22^"[("^"_+DGPMDDF_"^"),DGPMDD(3) K ^DGPM("ATT"_+DGPMDD(2),+DGPMDD(1),DA),^DGPM("APTT"_+DGPMDD(2),+DGPMDD(3),+DGPMDD(1),DA),^DGPM("AMV"_+DGPMDD(2),+DGPMDD(1),+DGPMDD(3),DA),^DGPM("ATID"_+DGPMDD(2),+DGPMDD(3),DGPMDDID,DA) I DGPMDD(2)=4!(DGPMDD(2)=5) G Q diff -auBN ./r1/DGPMDDCN.m ./r2/r/DGPMDDCN.m --- ./r1/DGPMDDCN.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMDDCN.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGPMDDCN ;ALB/MRL - DETERMINE INPATIENT X-REF'S; 9 FEB 89 - ;;5.3;Registration;**54,498**;Aug 13, 1993 + ;;5.3;Registration;**54**;Aug 13, 1993 ; 1 ; I $S($D(DGPMT):1,('$D(DA)#2):1,'$D(DGPMDDF):1,'$D(DGPMDDT):1,1:0) G KX @@ -77,15 +77,6 @@ I X,$D(^DPT(DFN,.1041)),^(.1041)=X S DGPMX=X,DGFLD=.1041 D KILL Q ; -S41 ; -- fac dir x-ref (AFD) - S DGFLD=.109 S DGPMX=$P($G(^DPT(DFN,.109)),"^",1) D KILL:(DGPMX'="") - S DGPMX=$P(VAFD,"^",1) D SET:(DGPMX'="") - Q - ; -K41 ; - I X'="",$P($G(^DPT(DFN,.109)),"^",1)=X S DGPMX=X,DGFLD=.109 D KILL - Q - ; SET ; -- generic set x-ref logic Q:DGPMX']"" N X,DA S DA=DFN,(^DPT(DA,DGFLD),X)=DGPMX @@ -110,7 +101,7 @@ ; -- kill data and x-refs I $D(^DPT(DFN,.105)),$D(^(.1)),^(.1)]"" K ^DGPM("CN",^(.1),+^(.105)) I $D(^DPT(DFN,.108)) S DGPMX=^(.108),DGFLD=.108 D KILL F DGPMX1=0:0 S DGPMX1=+$O(^DGPM("ARM",DGPMX,DGPMX1)) D CHK I $T K ^DGPM("ARM",DGPMX,DGPMX1) Q - F DGFLD=.1,.101,.102,.103,.104,.1041,.105,.109 I $D(^DPT(DFN,DGFLD)) S DGPMX=^(DGFLD) D KILL + F DGFLD=.1,.101,.102,.103,.104,.1041,.105 I $D(^DPT(DFN,DGFLD)) S DGPMX=^(DGFLD) D KILL ; -- reset data and x-refs D INPTCK I $S('VAWD:1,1:$P(VAWD,"^",2)="") D G RESETQ @@ -120,14 +111,14 @@ D SETALL RESETQ D KVAR^VADPT30 K DGPMX,DGPMX1,DGFLD,I Q ; -SETALL D S6,S7,S8,S9,S19,S41 Q +SETALL D S6,S7,S8,S9,S19 Q ; XREF I $D(^DGPM(DA,0)),$P(^(0),"^",2)=4!($P(^(0),"^",2)=5) G XREF^DGPMDDLD Q:$D(DGPMT) I $D(^DGPM(DA,0)) N DFN S DFN=+$P(^(0),U,3) D RESET Q ; -INPTCK ; check to see if patient is current inpatient +INPTCK ; check so see if patient is current inpatient D NOW^%DTC S VAPRT=0,VATD=9999999.999999-%,(VACN,VAPRC)=1 S VA200="" D VAR^VADPT30 K VA200 Q diff -auBN ./r1/DGPMEVT.m ./r2/r/DGPMEVT.m --- ./r1/DGPMEVT.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMEVT.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMEVT ;ALB/RMO - MAS MOVEMENT EVENT DRIVER; 26 DEC 89 ; 2/2/04 3:18pm - ;;5.3;Registration;**61,574**;Aug 13, 1993 +DGPMEVT ;ALB/RMO - MAS MOVEMENT EVENT DRIVER; 26 DEC 89 + ;;5.3;Registration;**61**;Aug 13, 1993 ; ;Required Variables: ; DFN = Patient's IFN @@ -14,15 +14,7 @@ ;-- establish visit & set pt movement ptr I $P($G(^DIC(150.9,1,0)),U,2)["1" D VISIT ; ************************************************************** - N OROLD D INP^VADPT S X=$O(^ORD(101,"B","DGPM MOVEMENT EVENTS",0))_";ORD(101," - I $P(X,";",1)="" D ERR K VAIN Q - D EN1^XQOR K VAIN,X - Q - ; -ERR ; - W !,"Serious error ! DGPM MOVEMENT EVENTS protocol not found" - W !,"in Protocol file #101. No events fired !" - W ! + N OROLD D INP^VADPT S X=$O(^ORD(101,"B","DGPM MOVEMENT EVENTS",0))_";ORD(101," D EN1^XQOR:X K VAIN,X Q ; VISIT ;-- create visit file entry for new admissions diff -auBN ./r1/DGPMGL5.m ./r2/r/DGPMGL5.m --- ./r1/DGPMGL5.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMGL5.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMGL5 ;ALB/MRL - G&L PARAMETER ENTRY/EDIT; 29 APR 2003 - ;;5.3;Registration;**515**;Aug 13, 1993 +DGPMGL5 ;ALB/MRL - G&L PARAMETER ENTRY/EDIT; 28 JUN 89 + ;;5.3;Registration;;Aug 13, 1993 EN ; D DIS,ASK I Y D EDIT G EN @@ -12,7 +12,7 @@ W !,"G&L Initialization Date",?43,": " S Y=$P(DGPM,"^",1) X:Y ^DD("DD") W $S(Y]"":Y,1:"NOT SPECIFIED") W !,"TSR Initialization Date",?43,": " S Y=$P(DGPM,"^",11) X:Y ^DD("DD") W $S(Y]"":Y,1:"NOT SPECIFIED") W !,"SSN Format",?43,": DISPLAY ",$S($P(DGPM,"^",2)=6:"LAST FOUR ONLY",$P(DGPM,"^",2)=1:"ENTIRE SSN",1:"FORMAT UNSPECIFIED") - W !,"Means Test Copay Applicability Display",?43,": ",$S($P(DGPM,"^",3):"YES",1:"NO") + W !,"Means Test Display",?43,": ",$S($P(DGPM,"^",3):"YES",1:"NO") W !,"Patient's Treating Specialty (Display)",?43,": ",$S($P(DGPM,"^",4):"YES",1:"NO") ;W !,"Display Names in Two or Three Columns",?43,": ",$S($P(DGPM,"^",5)=3:"THREE",1:"TWO") W !,"Show Non-Movements on G&L",?43,": ",$S($P(DGPM,"^",6):"YES",1:"NO") diff -auBN ./r1/DGPMGLG5.m ./r2/r/DGPMGLG5.m --- ./r1/DGPMGLG5.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMGLG5.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMGLG5 ;ALB/LM - G&L GENERATION, CONT.; 27 APR 2003 - ;;5.3;Registration;**34,137,515,570**;Aug 13, 1993 +DGPMGLG5 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90 + ;;5.3;Registration;**34,137**;Aug 13, 1993 ; A ; S NLS=0 ; non-loss indicator @@ -19,20 +19,9 @@ ; Q:MV("TT")'=1!(MV("TT")'=3) ; 1=adm, 3=disch ; Means Test ;I MT,$D(^DG(41.3,DFN,0)) S X=9999999.999998-TO S X=+$O(^DG(41.3,DFN,2,X)) I $D(^(X,0)) S X=$P(^(0),"^",2) I "^A^B^C^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=ID_X,LEG(X)="" K X - I MT,$D(^DGMT(408.31,"C",DFN)) N DGX,X D - . S DGX=$$MTIENLT^DGMTU3(1,DFN,-TO) - . I $D(^DGMT(408.31,+DGX,0)) D - . . S X=$P(^(0),"^",3),X=$P(^DG(408.32,+X,0),"^",2) - . . I $G(X)="P" D ;evaluate pending adjudication to MT (C) or GMT (G) - . . . I '$D(DGX) S X="U" Q - . . . S X=$$PA^DGMTUTL(DGX),X=$S('$D(X):"U",X="MT":"C",X="GMT":"G",1:"U") - . . I "^A^B^C^G^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=ID_X,LEG(X)="" K X,DGX + I MT,$D(^DGMT(408.31,"C",DFN)) S X=$$MTIENLT^DGMTU3(1,DFN,-TO) I $D(^DGMT(408.31,+X,0)) S X=$P(^(0),"^",3) S X=$P(^DG(408.32,+X,0),"^",2) I "^A^B^C^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=ID_X,LEG(X)="" K X INS ; Reimburse Insurance (+) - S INS=0 - N DGINS,DGX - ; API returns ONLY Active and Re-imbursable Insurance entries - I $$INSUR^IBBAPI(DFN,"","",.DGINS,9) D - . S DGX=0 F S DGX=$O(DGINS("IBBAPI","INSUR",DGX)) Q:'DGX S INS=INS+1 + S INS=0 I $O(^DPT(DFN,.312,0)) S INS1=0 F JJ=0:0 S INS1=$O(^DPT(DFN,.312,INS1)) Q:INS1'>0 S I=^DPT(DFN,.312,INS1,0) I +$P(I,"^",8)'>TO I $D(^DIC(36,+I,0)),$P(^DIC(36,+I,0),"^",2)'="N" S INS=INS+1 I $P(I,"^",4)]""&($P(I,"^",4)'>TO) S INS=INS-1 S:INS>0 ID=ID_"+",LEG("+")="" K INS,INS1,JJ Q:MV("TT")'=3 diff -auBN ./r1/DGPMGL.m ./r2/r/DGPMGL.m --- ./r1/DGPMGL.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMGL.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMGL ;ALB/MRL/LM/MJK - G&L ENTRY POINT; 29 APR 2003 - ;;5.3;Registration;**85,515**;Aug 13, 1993 +DGPMGL ;ALB/MRL/LM/MJK - G&L ENTRY POINT; 1 FEB 89 + ;;5.3;Registration;**85**;Aug 13, 1993 ; W !!,"<<>>",! A D DT^DICRW S U="^" D NOW^%DTC S NOW=% D LO^DGUTL @@ -21,7 +21,7 @@ S Y=$S($P(DGPM("G"),"^",7)']"":+DGPM("G"),$P(DGPM("G"),"^",7)<+DGPM("G"):+DGPM("G"),1:$P(DGPM("G"),"^",7)) X ^DD("DD") W !,$E("Earliest Date to Recalculate"_L,1,58),Y W !,$E("SSN Format"_L,1,58),$S(SS=1:"ENTIRE",1:"LAST FOUR OF")," SSN" - W !,$E("Means Test Copay Applicability"_L,1,58),$S(MT:"",1:"NOT "),"DISPLAYED" + W !,$E("Means Test Indicator's"_L,1,58),$S(MT:"",1:"NOT "),"DISPLAYED" W !,$E("Patient's Actual Treating Specialty"_L,1,58),$S(TS:"",1:"NOT "),"DISPLAYED" W !,$E("Show Non-Movements on G&L"_L,1,58),$S(SNM:"",1:"DON'T "),"SHOW" ;W !,$E("G&L Column Placement"_L,1,58),$S(CP=2:"TWO",1:"THREE")," COLUMN" diff -auBN ./r1/DGPMGLP.m ./r2/r/DGPMGLP.m --- ./r1/DGPMGLP.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMGLP.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMGLP ;ALB/LM/MJK - G&L PRINT ROUTINE; 27 APR 2003 - ;;5.3;Registration;**20,134,515**;Aug 13, 1993 +DGPMGLP ;ALB/LM/MJK - G&L PRINT ROUTINE; 11 JUNE 90 + ;;5.3;Registration;**20,134**;Aug 13, 1993 ; A S DIE="^DG(43,",DA=1,DR="50///NOW" D ^DIE K DA,DR,DIE S (RA,LA)="",$P(RA,"-",66)="",$P(LA,"-",66)="" ; RA=Right Arrows "-" LA=Left Arrows "-" @@ -49,7 +49,7 @@ FOOT W ! W:UL["-" ! F L=1:1:131 W UL S C=0,X="" - F I="+","*","#","!","a","b","c","g","r" S C=C+1 I $D(LEG(I)) S X="'"_I_"' - "_$P($T(LEG+C),";;",2)_"; " W:$X>(131-$L(X)) ! W X + F I="+","*","#","!","a","b","c","r" S C=C+1 I $D(LEG(I)) S X="'"_I_"' - "_$P($T(LEG+C),";;",2)_"; " W:$X>(131-$L(X)) ! W X W ! Q ; @@ -58,10 +58,9 @@ ;;While in Absent Sick in Hospital Status (ASIH) ;;Discharge within 48 hours of admission ;;While in Absence Status (authorized/unauthorized absence) - ;;MT Copay Exempt + ;;Category 'A' Veteran ;;Category 'B' Veteran - ;;MT Copay Required - ;;GMT Copay Required + ;;Category 'C' Veteran ;;Current Means Test Required but not completed Q ; diff -auBN ./r1/DGPMRBA1.m ./r2/r/DGPMRBA1.m --- ./r1/DGPMRBA1.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMRBA1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,20 +1,18 @@ -DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 10/21/03 8:48am - ;;5.3;Registration;**544**;Aug 13, 1993 +DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 9 JAN 89 + ;;5.3;Registration;;Aug 13, 1993 PR D NOW^%DTC S DGDT=%,(DGPG,DGFL,DGI)=0,Y=DGDT X ^DD("DD") S DGNOW=Y G:DGOPT="S" SV I 'VAUTW F I1=0:0 S DGI=$O(VAUTW(DGI)) Q:DGI="" S W=VAUTW(DGI) D PRINT Q:DGFL I VAUTW F I1=0:0 S DGI=$O(^DIC(42,"B",DGI)) Q:DGI="" S J=$O(^(DGI,0)) S W=J D PRINT Q:DGFL - I DGOPT="B" D BEDSPR Q SV I 'DGSV F I1=0:0 S DGI=$O(DGSV(DGI)) Q:DGI=""!DGFL D HEAD F DGJ=0:0 S DGJ=$O(^DIC(42,"D",DGI,DGJ)) Q:'DGJ S W=DGJ D PRINT Q:DGFL I DGSV F I1=0:0 S DGI=$O(^DIC(42,"D",DGI)) Q:DGI=""!DGFL D HEAD F DGJ=0:0 S DGJ=$O(^DIC(42,"D",DGI,DGJ)) Q:'DGJ S W=DGJ D PRINT Q:DGFL Q PRINT I $S('$D(^DIC(42,+W,0)):1,VAUTD:0,'$P(^(0),"^",11)&$D(VAUTD(+$O(^DG(40.8,0)))):0,$D(VAUTD(+$P(^DIC(42,+W,0),"^",11))):0,1:1) Q S D0=W D WIN^DGPMDDCF I X Q - S (DGA,DGL)=0,DGNM=$P(^DIC(42,+W,0),"^",1) I 'DGPG!($Y>(IOSL-8)) D:DGOPT'="B" HEAD Q:DGFL + S (DGA,DGL)=0,DGNM=$P(^DIC(42,+W,0),"^",1) I 'DGPG!($Y>(IOSL-8)) D HEAD Q:DGFL ABB ;call in here for abbreviated (single ward) bed availability ABBREV ;abbreviated bed availability - W:DGOPT'="B" !!,DGNM,": " -EN F I=0:0 S I=$O(^DG(405.4,"W",W,I)) Q:I'>0!(DGFL) I $D(^DG(405.4,+I,0)) S J=^(0),J=$P($P(J,"^",1,3)_"^^^","^",1,3),DGR=$P(J,"^",1) D ACT I 'DGU D:DGOPT'="B" DIS I DGOPT="B" D BEDS - I DGOPT="B" Q + W !!,DGNM,": " +EN F I=0:0 S I=$O(^DG(405.4,"W",W,I)) Q:I'>0!(DGFL) I $D(^DG(405.4,+I,0)) S J=^(0),J=$P($P(J,"^",1,3)_"^^^","^",1,3),DGR=$P(J,"^",1) D ACT I 'DGU D DIS I 'DGA W ?21,"There are no available beds on this ward." G LD:'$O(^DGS(41.1,"ARSV",W,0))!'DGSA S DGONE=0 F I=0:0 S I=$O(^DGS(41.1,"ARSV",W,I)) Q:'I I $D(^DGS(41.1,I,0)) S J=^(0) I '$P(J,"^",13),($P(J,"^",2)'(IOSL-8) D HEAD Q:DGFL - . W $E(DGBDNM,1,18) W:DGDESC " ("_$E(DGBDESC,1,15)_")" - . W:DGDESC ?40 W:'DGDESC ?20 W "WARDS: " - . S DGWRD="",DGWCNT=0 F S DGWRD=$O(^TMP("DGPMBD",$J,DGBDNM,DGWRD)) Q:DGWRD="" W:DGWCNT>0 ", " W:($X+$L(DGWRD))>80 !?5 W DGWRD S DGWCNT=DGWCNT+1 - Q:DGFL - W !!?3,$S(DGBCNT:"There are a total of "_DGBCNT_" beds available.",1:"There are no available beds."),! - I $D(^UTILITY("DGPMLD",$J)) D HEAD Q:DGFL D LD - K ^TMP("DGPMBD",$J) - Q diff -auBN ./r1/DGPMRBA.m ./r2/r/DGPMRBA.m --- ./r1/DGPMRBA.m 2005-02-21 00:30:59.000000000 -0500 +++ ./r2/r/DGPMRBA.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,17 +1,14 @@ -DGPMRBA ;ALB/MIR - ROOM-BED AVAILABILITY; 9 JAN 89 ; 10/21/03 8:50am - ;;5.3;Registration;**544**;Aug 13, 1993 +DGPMRBA ;ALB/MIR - ROOM-BED AVAILABILITY; 9 JAN 89 + ;;5.3;Registration;;Aug 13, 1993 OPT ;called from BED AVAILABILITY OPTION ; W !!,"(A)bbreviated or (E)xpanded Bed Availability Listing? A//" R X:DTIME G:'$T!(X["^") Q I X="" S X="A" W X - S Z="^ABBREVIATED^EXPANDED" D IN^DGHELP I %<0 W !!,"ENTER:",!?5,"'A' to see bed availability for a single ward, or",!?5,"'E' for bed availability for multiple wards, by service or",!?9,"a list of all available beds" G OPT - I X="A" S DGOPT=X D ABB,Q Q + S Z="^ABBREVIATED^EXPANDED" D IN^DGHELP I %<0 W !!,"ENTER:",!?5,"'A' to see bed availability for a single ward, or",!?5,"'E' for bed availability for multiple wards or by service" G OPT + I X="A" D ABB,Q Q D ASK2^SDDIV G Q:Y<0 ;get OMA division(s) -WS W !,"Sort by (W)ARD, (S)ERVICE, or (B)EDS: W//" R X:DTIME G Q:'$T!(X["^") I X="" S X="W" W X - S Z="^WARD^SERVICE^BEDS" D IN^DGHELP I %<0 D G WS - .W !,"ENTER:",!?5,"'W' to see available beds for one, many, or all wards, or",!?5,"'S' to see available beds for one, many, or all services, or",!?5,"'B' to see all available beds and wards which can assign them." - S DGOPT=X - I DGOPT="W"!(DGOPT="B") S VAUTNI=1 D WARD^VAUTOMA G Q:Y<0 - G:DGOPT="W" SAD G:DGOPT="B" LDG +WS W !,"Sort by (W)ARD or (S)ERVICE: W//" R X:DTIME G Q:'$T!(X["^") I X="" S X="W" W X + S Z="^WARD^SERVICE^" D IN^DGHELP I %<0 W !,"ENTER:",!?5,"'W' to see available beds for one, many, or all wards, or",!?5,"'S' to see available beds for one, many, or all services" G WS + S DGOPT=X I X="W" S VAUTNI=1 D WARD^VAUTOMA G Q:Y<0,SAD S DIR("A")="Select SERVICE: ",(DIR(0),DGSTR)="SA^A:ALL;M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILLARY;B:BLIND REHAB;NC:NON-COUNT",DIR("B")="ALL" S DIR("?")="Enter desired service for which you would like to see bed availability." S DIR("?",1)="CHOOSE FROM:" @@ -30,7 +27,7 @@ S DGLD='(%-1) D DESC I %<0 G Q CONT S DGVARS="DGOPT^VAUTD#^VAUTW#^DGDESC^DGLD^DGSV#^DGSTR",DGPGM="PR^DGPMRBA1" D ZIS^DGUTQ I 'POP D PR^DGPMRBA1 -Q K ^UTILITY("DGPMLD",$J),^TMP("DGPMBD",$J),%,DFN,DGA,DGDESC,DGDT,DGFL,DGHOW,DGI,DGJ,DGL,DGLD,DGND,DGNM,DGNOW,DGONE,DGPG,DGPGM,DGOPT,DGR,DGSA,DGSTR,DGSV,DGU,DGVARS,DIC,DIR,I,I1,J,J1,M,POP,W,X,Y,VA,VAUTD,VAUTW,Y,Z W ! D CLOSE^DGUTQ Q +Q K ^UTILITY("DGPMLD",$J),%,DFN,DGA,DGDESC,DGDT,DGFL,DGHOW,DGI,DGJ,DGL,DGLD,DGND,DGNM,DGNOW,DGONE,DGPG,DGPGM,DGOPT,DGR,DGSA,DGSTR,DGSV,DGU,DGVARS,DIC,DIR,I,I1,J,J1,M,POP,W,X,Y,VA,VAUTD,VAUTW,Y,Z W ! D CLOSE^DGUTQ Q ; ; ABB ;abbreviated bed availability (single ward only) diff -auBN ./r1/DGPMV10.m ./r2/r/DGPMV10.m --- ./r1/DGPMV10.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMV10.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMV10 ;ALB/MRL/MIR - PATIENT MOVEMENT, CONT.; 11 APR 89 ; 4/15/03 5:48pm - ;;5.3;Registration;**84,498,509**;Aug 13, 1993 +DGPMV10 ;ALB/MRL/MIR - PATIENT MOVEMENT, CONT.; 11 APR 89 + ;;5.3;Registration;**84**;Aug 13, 1993 CS ;Current Status ;first print primary care team/practitioner/attending D PCMM^SCRPU4(DFN,DT) @@ -13,8 +13,7 @@ W "on WARD" CS1 I +DGPMVI(2)=3,$D(^DGPM(+DGPMVI(17),0)) W ?39,"Discharge Type : ",$S($D(^DG(405.1,+$P(^(0),"^",4),0)):$P(^(0),"^",1),1:"UNKNOWN") I "^3^4^5^"'[("^"_+DGPMVI(2)_"^"),$D(^DPT(DFN,"DAC")),($P(^("DAC"),"^",1)="S") W " (Seriously ill)" - W ! I +DGPMVI(19,1) W "Patient chose not to be included in the Facility Directory for this admission" - W !,$S("^4^5^"'[("^"_+DGPMVI(2)_"^"):"Admitted ",1:"Checked-in "),": "_$P(DGPMVI(13,1),"^",2) + W !!,$S("^4^5^"'[("^"_+DGPMVI(2)_"^"):"Admitted ",1:"Checked-in "),": "_$P(DGPMVI(13,1),"^",2) W ?39,$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"Checked-out",+DGPMVI(2)=3:"Discharged ",1:"Transferred")," : ",$S("^1^4^"'[("^"_+DGPMVI(2)_"^"):$P(DGPMVI(3),"^",2),$P(DGPMVI(3),"^",2)'=$P(DGPMVI(13,1),"^",2):$P(DGPMVI(3),"^",2),1:"") W !,"Ward : ",$E($P(DGPMVI(5),"^",2),1,24),?39,"Room-Bed : ",$E($P(DGPMVI(6),"^",2),1,21) I "^4^5^"'[("^"_+DGPMVI(2)_"^") W !,"Provider : ",$E($P(DGPMVI(7),"^",2),1,26),?39,"Specialty : ",$E($P(DGPMVI(8),"^",2),1,21) W !,"Attending : ",$E($P(DGPMVI(18),"^",2),1,26) @@ -52,7 +51,7 @@ ; D NOW^%DTC S (VAX("DAT"),NOW)=%,NOWI=9999999.999999-% I '$D(VAIP("E")) D LAST^VADPT3 F I=1:1:8,13,17 S DGPMVI(I)="" - F I=13,19 S DGPMVI(I,1)="" + S DGPMVI(13,1)="" S DGPMVI(1)=$S($D(VAIP("E")):VAIP("E"),1:E) ;use ifn of last mvt from VADPT call or one passed from DGPMV S DGX=$G(^DGPM(+DGPMVI(1),0)),DGPMVI(2)=$P(DGX,"^",2),DGPMVI(4)=$P(DGX,"^",18) S Y=+DGX X ^DD("DD") S DGPMVI(3)=$P(DGX,"^",1)_"^"_Y S DGPMVI(5)=$P(DGX,"^",6)_"^"_$S($D(^DIC(42,+$P(DGX,"^",6),0)):$P(^(0),"^",1),1:""),DGPMVI(6)=$P(DGX,"^",7)_"^"_$S($D(^DG(405.4,+$P(DGX,"^",7),0)):$P(^(0),"^",1),1:""),DGPMVI(13)=$P(DGX,"^",14) @@ -62,11 +61,6 @@ S (DGTS,DGPP,DGAP)="" ;t.s., primary care physician, attending F I=NOWI:0 S I=$O(^DGPM("ATS",DFN,+DGPMVI(13),I)) Q:'I F J=0:0 S J=$O(^DGPM("ATS",DFN,+DGPMVI(13),I,J)) Q:'J F IFN=0:0 S IFN=$O(^DGPM("ATS",DFN,+DGPMVI(13),I,J,IFN)) Q:'IFN D TS1 G TSQ:DGTS&DGPP&DGAP TSQ S DGPMVI(7)=DGPP,DGPMVI(8)=DGTS,DGPMVI(18)=DGAP - S DGX=$G(^DGPM(+DGPMVI(13),0)) I $P(DGX,"^",2)=1 D - .S DGX=$G(^DGPM(+DGPMVI(13),"DIR")) - .S DGX=$P(DGX,"^",1) - .I DGX="" S DGX=$S('DGPMDCD:1,(DGPMDCD<3030414.999999):"",1:1) Q:DGX="" - .S DGPMVI(19,1)=DGX_"^"_$$EXTERNAL^DILFD(405,41,,DGX) D Q^VADPT3 K DGAP,DGPP,DGTS,DGX,IFN Q ; diff -auBN ./r1/DGPMV33.m ./r2/r/DGPMV33.m --- ./r1/DGPMV33.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMV33.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMV33 ;ALB/MIR - DISCHARGE A PATIENT, CONTINUED ; 8/4/03 1:13pm - ;;5.3;Registration;**204,544**;Aug 13, 1993 +DGPMV33 ;ALB/MIR - DISCHARGE A PATIENT, CONTINUED ; SEP 15 1989@12 + ;;5.3;Registration;**204**;Aug 13, 1993 ; I '$P(DGPMA,"^",4)!$S($P(DGPMA,"^",18)'=10:0,'$P(DGPMA,"^",5):1,1:0) W !,"Incomplete Discharge" S DIK="^DGPM(",DA=DGPMDA D ^DIK W " deleted" S DGPMA="" D G Q .S ^UTILITY("DGPM",$J,3,DA,"A")=$G(^("P")) @@ -35,10 +35,7 @@ SI Q:"^25^26^"[("^"_$P(DGPMA,"^",18)_"^") I $S('$D(^DPT(DFN,.1)):1,^(.1)="":1,1:0)&($D(^("DAC"))) S DR="401.3///@",DIE="^DPT(",DA=DFN K DQ,DG D ^DIE:$P(^("DAC"),"^",1)="S" K DR,DIC Q Q:'$D(^DPT(DFN,.1)) S W=^(.1) Q:W']"" S W=$O(^DIC(42,"B",W,0)),W=$S($D(^DIC(42,+W,0)):^(0),1:""),T="SERIOUSLY ILL" Q:W="" - I $P(W,"^",14),($P(DGPMA,"^",18)>3) D Q - .S DR="401.3//"_$S("^22^23^24^"[("^"_$P(DGPMA,"^",18)_"^"):$S('$D(^DPT(DFN,"DAC")):"",$L($P(^("DAC"),"^",1)):T,1:""),DGPMN:T,1:"") - .I $P(DR,"//",2)=T S DR=$S("^1^2^"[("^"_DGPMT_"^")&+DGPMA:DR_";S:X'=""S"" Y=0;401.4////"_$P(DGPMA,"."),1:DR) - .S DIE="^DPT(",DA=DFN K DQ,DG D ^DIE K DIE,T,W + I $P(W,"^",14),($P(DGPMA,"^",18)>3) S DR="401.3//"_$S("^22^23^24^"[("^"_$P(DGPMA,"^",18)_"^"):$S('$D(^DPT(DFN,"DAC")):"",$L($P(^("DAC"),"^",1)):T,1:""),DGPMN:T,1:""),DIE="^DPT(",DA=DFN K DQ,DG D ^DIE K DIE,T,W Q I $D(^DPT(DFN,"DAC")) I $L($P(^("DAC"),"^",1)) S DA=DFN,DR=401.3,DIE="^DPT(" K DQ,DG D ^DIE K DIE,T,W Q ADM ;update admission or check-in mvt with discharge/check-out mvt pointer diff -auBN ./r1/DGPMVBUR.m ./r2/r/DGPMVBUR.m --- ./r1/DGPMVBUR.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMVBUR.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMVBUR ;ALB/MIR - UR ADMISSION BULLETIN FOR MCCR ; 9/16/03 2:24pm - ;;5.3;Registration;**26,31,483,549,570**;AUG 13, 1993 +DGPMVBUR ;ALB/MIR - UR ADMISSION BULLETIN FOR MCCR ; 13 JUL 91 + ;;5.3;Registration;**26,31**;Aug 13, 1993 ; UR ;UR bulletin K DGPMUR @@ -15,8 +15,7 @@ S DGPMBL="Room-Bed : "_$S($D(^DG(405.4,+$P(DGPMA,"^",7),0)):$P(^(0),"^",1),1:"UNKNOWN") D SETLN S DGPMBL="Admitting DX : "_$P(DGPMA,"^",10) D SETLN S DGPMBL=" " D SETLN - S DGPMBLN=DGPMLAST D V72HR ; visits in last 72 hours - D DIS ;SC disabilities + S DGPMBLN=DGPMLAST D DIS ;SC disabilities D ^XMD URQ K DGPMBL,DGPMBLN,DGPMLAST,DGPMUR,DGTMP,XMY,XMSUB,XMTEXT K %,%Y,DGPMOB,DGPMOW,DGPMX,I,X,X1,X2,Y,DGIBINS @@ -25,28 +24,21 @@ INS ;get insurance effective at time of admission, start at DGPMBLN=10 S DGPMBLN=9 K DGIBINS - N DGX,DGDATA,DGIB - ; - S DGIB=$$INSUR^IBBAPI(DFN,"","",.DGDATA,"*") ; Returns Active, Reimbursable Ins. only - S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGIBINS=@DGX - F I=0:0 S I=$O(DGIBINS(I)) Q:'I D ACT - ; + D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I)) Q:'I S X=DGIBINS(I,0) D ACT I $D(DGPMUR(10)) S DGPMLAST=DGPMBLN Q ; ACT ;is insurance active? If so, set in DGPMBLN array - I DGIBINS(I,11)<+DGPMA,DGIBINS(I,11)]"" Q ;insurance expired before admission - I DGIBINS(I,10)>+DGPMA Q ;insurance effective after admission - Q:'+DGIBINS(I,1) - ; get insurance company information - S DGPMBL="Insurance Co. : "_$P(DGIBINS(I,1),"^",2) D SETLN - S DGTMP=$P(DGIBINS(I,8),U,2) - I DGTMP']"" S DGTMP=$S($G(DGIBNS(I,18))]"":DGIBINS(I,18),1:"") - I DGTMP']"" S DGTMP="" + I $P(X,"^",4)<+DGPMA,$P(X,"^",4) Q ;insurance expired before admission + I $P(X,"^",8)>+DGPMA Q ;insurance effective after admission + Q:'$D(^DIC(36,+X,0)) S X1=^(0),X2=$S($D(^(.13)):^(.13),1:"") ;get insurance company information + I $P(X1,"^",5)!($P(X1,"^",2)="N") Q ;insurance company is inactive or doesn't reimburse + S DGPMBL="Insurance Co. : "_$P(X1,"^",1) D SETLN + S DGTMP=$S(($P(X,"^",15)]""):$P(X,"^",15),1:$P(X,"^",3)) I DGTMP]"" S DGPMBL="Group : "_DGTMP D SETLN - S DGPMBL="Policy Holder : "_DGIBINS(I,13) D SETLN - S DGPMBL="Subscriber ID : "_DGIBINS(I,14) D SETLN - S DGPMBL="Ins. Co Phone# : "_$S(DGIBINS(I,6)]"":DGIBINS(I,6),1:"UNKNOWN") D SETLN + S DGPMBL="Policy Holder : "_$P(X,"^",17) D SETLN + S DGPMBL="Subscriber ID : "_$P(X,"^",2) D SETLN + S DGPMBL="Ins. Co Phone# : "_$S($P(X2,"^",2)]"":$P(X2,"^",2),$P(X2,"^",1)]"":$P(X2,"^",1),1:"UNKNOWN") D SETLN S DGPMBL=" " D SETLN Q DIS ;rated disabilities @@ -55,31 +47,7 @@ ;X=0 node, X1=already one SC disability? S X1=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I I $D(^(I,0)) S X=^(0) I $P(X,"^",3)&$D(^DIC(31,+X,0)) S DGPMBL=$S('X1:"SC Disabilities: ",1:" ")_$P(^(0),"^",1)_" ("_+$P(X,"^",2)_"%)" S X1=1 D SETLN Q -V72HR ; GET INFORMATION FROM VISITS FOR THE LAST 72 HOURS - NEW X,X1,X2,IDEN,ID,LOCN,HSPN - S X1=+DGPMA,X2=-3 - D C^%DTC - S X=X-.0001 -GVTIME ; LOOP THROUGH "B" INDEX OF ^AUPNVSIT FILE - S X=$O(^AUPNVSIT("B",X)) - I X="" Q - I X'<+DGPMA Q - S IDEN="" -GVID ; CHECK FOR CORRECT PATIENT - S IDEN=$O(^AUPNVSIT("B",X,IDEN)) - I IDEN="" G GVTIME - I +$P($G(^AUPNVSIT(IDEN,0)),"^",5)'=+DFN G GVID - S LOCN=$P(^AUPNVSIT(IDEN,0),"^",22) - ; DG/549 - I $G(LOCN)>0 S HSPN=$P($G(^SC(LOCN,0)),"^",1) - E S HSPN="Unknown location" I $P($G(^AUPNVSIT(IDEN,0)),"^",7)="E" S HSPN=HSPN_"-Event(Historical)" - ; - S Y=+X X ^DD("DD") - S DGPMBL="Previous Visit : "_HSPN_" "_Y - D SETLN - G GVID - Q -SETLN ;--set line in xmtext array +SETLN ; -- set line in xmtext array S DGPMBLN=DGPMBLN+1 S DGPMUR(DGPMBLN)=DGPMBL Q diff -auBN ./r1/DGPMVDD.m ./r2/r/DGPMVDD.m --- ./r1/DGPMVDD.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMVDD.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,6 +1,6 @@ -DGPMVDD ;ALB/MIR - MISCELLANEOUS DD CALLS FROM FILE 405 AND 405.1 ; 4/14/04 6:26pm - ;;5.3;Registration;**418,593**;Aug 13, 1993 -W ;called from input transform for ward location +DGPMVDD ;ALB/MIR - MISCELLANEOUS DD CALLS FROM FILE 405 AND 405.1 ;5/9/91 17:47 + ;;5.3;Registration;**418**;Aug 13, 1993 +W ;called form input transform for ward location I '$D(DGPMT) K X,DIC Q S DGPMTYP=$P(^DGPM(DA,0),"^",18),DGPMWD=$P(DGPMP,"^",6) D W1:DGPMT=1,W2:DGPMT=2!($P(^DGPM(DA,0),"^",2)=2) Q W1 ;consistency edits for ward location from admit option @@ -9,8 +9,7 @@ ;S DGX="" I DGPMTYP=18 S DIC("S")=DIC("S")_",""^NH^D^""[(""^""_$P(^(0),""^"",3)_""^"")" Q S DGX="" I DGPMTYP=18 S DIC("S")=DIC("S")_",""^NH^D^""[(""^""_$P(^(0),""^"",3)_""^"")!($P(^(0),""^"",17)=1)" ;p-418 ;I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S DGX=$S($D(^DIC(42,+DGPMWD,0)):$P(^(0),"^",3),1:""),DGX=$S("^NH^D^"'[("^"_DGX_"^"):"H",1:DGX) - ;S DGPMWD="",DGPMTYP=40 ; simulate NOIS REN-0304-60611 - I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S DGX=$S($D(^DIC(42,+DGPMWD,0)):$P($G(^DIC(42,+DGPMWD,0)),U,3),1:""),DGX=$S("^NH^D^"'[("^"_DGX_"^")&($P($G(^DIC(42,+DGPMWD,0)),U,17)'=1):"H",1:DGX) ;p-418/593 + I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S DGX=$S($D(^DIC(42,+DGPMWD,0)):$P(^(0),"^",3),1:""),DGX=$S("^NH^D^"'[("^"_DGX_"^")&($P(^(0),"^",17)'=1):"H",1:DGX) ;p-418 ;I DGX]"" S DIC("S")=DIC("S")_",("_$S(DGX="NH":"""^NH^:""[",DGX="D":"""^D^""[",1:"""^NH^D^""'[")_"(""^""_$P(^(0),""^"",3)_""^""))" ZZ I DGX]"" S DIC("S")=DIC("S")_",("_$S(DGX="NH":"""^NH^:""[",DGX="D":"""^D^""[",1:"""^NH^D^""'[")_"(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)'=1))" ;p-418 I $P(DGPM2,"^",2)=2&$P(DGPM2,"^",6),'DGPMABL S DIC("S")=DIC("S")_",+Y'=$P(DGPM2,""^"",6)" diff -auBN ./r1/DGPMVDL.m ./r2/r/DGPMVDL.m --- ./r1/DGPMVDL.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMVDL.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 2/13/04 1:01pm - ;;5.3;Registration;**161,517**;Aug 13, 1993 +DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 28 SEP 89@12 + ;;5.3;Registration;**161**;Aug 13, 1993 ; ;D_DGPMT - these lines are used as DEL nodes. If DGPMER=1, movement can ; not be deleted. @@ -11,11 +11,8 @@ I $P(DGPMAN,"^",21),$P(DGPMAN,"^",17) S DGPMER=1 W !,"Must delete discharge first" I $O(^DGPT("ACENSUS",+$P(DGPMAN,U,16),0)) S DGPMER=1 W !,"Cannot delete while PTF Census record #",$O(^(0))," is closed." Q -1 S DA=$P(DGPMAN,U,16),DIK="^DGPT(",FLAG=1,I=0 F S I=$O(^DGCPT(46,"C",DA,I)) Q:'I I '$G(^DGCPT(I,9)) S FLAG=0 Q - I FLAG S I=0 F S I=$O(^DGICD9(46.1,"C",DA,I)) Q:'I I '$G(^DGICD9(I,9)) S FLAG=0 Q - I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT ENTRIES." K FLAG H 2 Q - S DGMSG="Patient admission has been deleted for admit date: "_$$FMTE^XLFDT(+DGPMAN,"5DZ"),DGMSG1="Deleted Admission" - D MSG^DGPTMSG1 S DA=$P(DGPMAN,U,16),DIK="^DGPT(" D ^DIK:DA>0 K FLAG,I,DA,DIK ; delete PTF record +1 S DGMSG="Patient admission has been deleted for admit date: "_$$FMTE^XLFDT(+DGPMAN,"5DZ"),DGMSG1="Deleted Admission" D MSG^DGPTMSG1 + S DIK="^DGPT(",DA=$P(DGPMAN,"^",16) D ^DIK:DA>0 ; delete PTF record S DA=$O(^DGS(41.1,"AMVT",DGPMDA,0)) I DA S DIE="^DGS(41.1,",DR="17///@" D ^DIE ;remove scheduled admission reference in 41.1 F DGI=DGPMDA:0 S DGI=$O(^DGPM("CA",DGPMDA,DGI)) Q:'DGI I $D(^DGPM(DGI,0)) S DGPMTYP=$P(^(0),"^",2),DA=DGI,DIK="^DGPM(",^UTILITY("DGPM",$J,DGPMTYP,DA,"P")=^(0),^("A")="" D ^DIK S DGX=$P(DGPMAN,"^",21) G Q1:'DGX S DIK="^DGPM(",DA=DGX I $D(^DGPM(+DA,0)) S DGX1=^(0),^UTILITY("DGPM",$J,2,DA,"P")=^(0),^("A")="" D ^DIK W !,"ASIH transfer deleted",! diff -auBN ./r1/DGPMX11.m ./r2/r/DGPMX11.m --- ./r1/DGPMX11.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMX11.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,3 +1,113 @@ -DGPMX11 ; ;04/03/03 - S X=DG(DQ),DIC=DIE +DGPMX11 ; ;08/08/97 + D DE G BEGIN +DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(7)=% S %=$P(%Z,U,6) S:%]"" DE(12)=% S %=$P(%Z,U,10) S:%]"" DE(8)=% S %=$P(%Z,U,11) S:%]"" DE(1)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="DGPMX11",DQ=1 +1 S DW="0;11",DV="S",DU="",DLB="ADMITTED FOR SC CONDITION?",DIFLD=.11 + S DU="1:YES;0:NO;" + G RE +X1 Q +2 S DQ=3 ;@11 +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X3 S ^DISV(DUZ,"^DG(405.1,")=$S($D(^DISV(DUZ,"DGPM1")):^("DGPM1"),1:"") + Q +4 S DW="0;4",DV="R*P405.1'X",DU="",DLB="TYPE OF ADMISSION",DIFLD=.04 + S DE(DW)="C4^DGPMX11" + S DU="DG(405.1," + G RE +C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0)):^(0),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X="" S DIH=$S($D(^DGPM(DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,18)=DIV,DIH=405,DIG=.18 D ^DICR:$N(^DD(DIH,DIG,1,0))>0 +C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0)):^(0),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y X ^DD(405,.04,1,1,1.1) X ^DD(405,.04,1,1,1.4) + Q +X4 S DIC("S")="I $D(DGPMT),($P(^(0),""^"",2)=DGPMT),$P(^(0),""^"",4) S DGER=0,DGPMTYP=$P(^(0),""^"",3) D:DGPMT<4!(DGPMT=6)!(DGPMT=5) @(""DICS^DGPMV3""_DGPMT) I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 S ^DISV(DUZ,"DGPM1")=$S($D(^DISV(DUZ,"^DG(405.1,")):^("^DG(405.1,"),1:"") + Q +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 I $P(^DGPM(DA,0),"^",18)'=9 S Y=.1 + Q +7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="0;5",DV="RP4'X",DU="",DLB="TRANSFER FACILITY",DIFLD=.05 + S DE(DW)="C7^DGPMX11" + S DU="DIC(4," + G RE +C7 G C7S:$D(DE(7))[0 K DB S X=DE(7),DIC=DIE + I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR +C7S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR + Q +X7 I '$D(DGPMT) W !?3,*7,"USE BED CONTROL MOVEMENT OPTIONS!" K X + Q + ; +8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;10",DV="RFX",DU="",DLB="DIAGNOSIS [SHORT]",DIFLD=.1 + G RE +X8 K:$L(X)>30!($L(X)<3)!(X[";") X + I $D(X),X'?.ANP K X + Q + ; +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 G A +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 G A +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 G A +12 S DW="0;6",DV="R*P42'X",DU="",DLB="WARD LOCATION",DIFLD=.06 + S DE(DW)="C12^DGPMX11" + S DU="DIC(42," + G RE +C12 G C12S:$D(DE(12))[0 K DB S X=DE(12),DIC=DIE + S DGPMDDF=6,DGPMDDT=0 D ^DGPMDDCN + S X=DE(12),DIC=DIE + ; + S X=DE(12),DIC=DIE + S Y=^DGPM(DA,0) I +Y,Y0 + S X=DG(DQ),DIC=DIE + S Y=^DGPM(DA,0) I +Y,Y
9 F^DIE17 G ^DGPMX12 diff -auBN ./r1/DGPMX12.m ./r2/r/DGPMX12.m --- ./r1/DGPMX12.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMX12.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,9 +1,9 @@ -DGPMX12 ; ;04/03/03 +DGPMX12 ; ;08/08/97 D DE G BEGIN DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(1)=% S %=$P(%Z,U,6) S:%]"" DE(6)=% S %=$P(%Z,U,7) S:%]"" DE(7)=% S %=$P(%Z,U,10) S:%]"" DE(2)=% - I $D(^("ODS")) S %Z=^("ODS") S %=$P(%Z,U,1) S:%]"" DE(11)=% - I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE(14)=% S %=$P(%Z,U,4) S:%]"" DE(16)=% + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,7) S:%]"" DE(1)=% + I $D(^("ODS")) S %Z=^("ODS") S %=$P(%Z,U,1) S:%]"" DE(5)=% + I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE(8)=% S %=$P(%Z,U,4) S:%]"" DE(10)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -16,17 +16,17 @@ A K DQ(DQ) S DQ=DQ+1 B G @DQ RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +N I X="" G A:DV'["R",X:'DV,X:D'>0,A RD G QS:X?."?" I X["^" D D G ^DIE17 I X="@" D D G Z^DIE2 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 S X="?BAD" QS S DZ=X D D,QQ^DIEQ G B @@ -44,101 +44,48 @@ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 D ^DIR I 'DDER S %=Y(0),X=Y Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="DGPMX12",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;5",DV="RP4'X",DU="",DLB="TRANSFER FACILITY",DIFLD=.05 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;7",DV="*P405.4'X",DU="",DLB="ROOM-BED",DIFLD=.07 S DE(DW)="C1^DGPMX12" - S DU="DIC(4," - G RE -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR -C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR -C1F1 Q -X1 I '$D(DGPMT) W !?3,*7,"USE BED CONTROL MOVEMENT OPTIONS!" K X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;10",DV="RFX",DU="",DLB="DIAGNOSIS [SHORT]",DIFLD=.1 - G RE -X2 K:$L(X)>30!($L(X)<3)!(X[";") X - I $D(X),X'?.ANP K X - Q - ; -3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 G A -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 G A -5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 G A -6 S DW="0;6",DV="R*P42'X",DU="",DLB="WARD LOCATION",DIFLD=.06 - S DE(DW)="C6^DGPMX12" - S DU="DIC(42," - G RE -C6 G C6S:$D(DE(6))[0 K DB - S X=DE(6),DIC=DIE - S DGPMDDF=6,DGPMDDT=0 D ^DGPMDDCN - S X=DE(6),DIC=DIE - ; - S X=DE(6),DIC=DIE - S Y=^DGPM(DA,0) I +Y,Y0 - S X=DG(DQ),DIC=DIE - S Y=^DGPM(DA,0) I +Y,Y
9 F^DIE17,DE S DQ=7,DW="0;7",DV="*P405.4'X",DU="",DLB="ROOM-BED",DIFLD=.07 - S DE(DW)="C7^DGPMX12" S DU="DG(405.4," G RE -C7 G C7S:$D(DE(7))[0 K DB - S X=DE(7),DIC=DIE +C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE S DGPMDDF=7,DGPMDDT=0 D ^DGPMDDCN -C7S S X="" G:DG(DQ)=X C7F1 K DB - S X=DG(DQ),DIC=DIE +C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S DGPMDDF=7,DGPMDDT=1 D ^DGPMDDCN -C7F1 Q -X7 K:'$D(DGPMT) X I $D(X) S DIC("S")="I $D(^DG(405.4,""W"",+$P(^DGPM(DA,0),""^"",6),+Y)) D OCC^DGPMRB I 'DGPMOC" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) D ROOM^DGPMVDD K:$D(DGOOS) X K DGOOS + Q +X1 K:'$D(DGPMT) X I $D(X) S DIC("S")="I $D(^DG(405.4,""W"",+$P(^DGPM(DA,0),""^"",6),+Y)) D OCC^DGPMRB I 'DGPMOC" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) D ROOM^DGPMVDD K:$D(DGOOS) X K DGOOS Q ; -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 G A -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 G A -10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X10 D DFN^DGYZODS S:'DGODS Y="@12" +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 G A +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 D DFN^DGYZODS S:'DGODS Y="@12" Q -11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="ODS;1",DV="S",DU="",DLB="ODS AT ADMISSION",DIFLD=11500.01 +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="ODS;1",DV="S",DU="",DLB="ODS AT ADMISSION",DIFLD=11500.01 S DU="1:YES;0:NO;" S Y="1" - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD:X="@",Z -X11 Q -12 S DQ=13 ;@12 -13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X13 I DGPMP=^DGPM(DA,0) S Y="" +X5 Q +6 S DQ=7 ;@12 +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 I DGPMP=^DGPM(DA,0) S Y="" Q -14 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",DIFLD=102 +8 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",DIFLD=102 S DU="VA(200," S X=DUZ S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD:X="@",Z -X14 Q -15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 G A -16 S DW="USR;4",DV="RD",DU="",DLB="LAST EDITED ON",DIFLD=103 +X8 Q +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 G A +10 S DW="USR;4",DV="RD",DU="",DLB="LAST EDITED ON",DIFLD=103 S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) S Y=X S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -X16 S %DT="STX" D ^%DT S X=Y K:Y<1 X +X10 S %DT="STX" D ^%DT S X=Y K:Y<1 X Q ; -17 G 0^DIE17 +11 G 0^DIE17 diff -auBN ./r1/DGPMX1.m ./r2/r/DGPMX1.m --- ./r1/DGPMX1.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMX1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,9 +1,8 @@ -DGPMX1 ; GENERATED FROM 'DGPM ADMIT' INPUT TEMPLATE(#446), FILE 405;04/03/03 +DGPMX1 ; GENERATED FROM 'DGPM ADMIT' INPUT TEMPLATE(#446), FILE 405;08/08/97 D DE G BEGIN DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(13)=% S %=$P(%Z,U,11) S:%]"" DE(10)=% S %=$P(%Z,U,12) S:%]"" DE(5)=% - I $D(^("DIR")) S %Z=^("DIR") S %=$P(%Z,U,1) S:%]"" DE(4)=% - I $D(^("PTF")) S %Z=^("PTF") S %=$P(%Z,U,4) S:%]"" DE(7)=% + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S %=$P(%Z,U,12) S:%]"" DE(4)=% + I $D(^("PTF")) S %Z=^("PTF") S %=$P(%Z,U,4) S:%]"" DE(6)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -16,17 +15,17 @@ A K DQ(DQ) S DQ=DQ+1 B G @DQ RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +N I X="" G A:DV'["R",X:'DV,X:D'>0,A RD G QS:X?."?" I X["^" D D G ^DIE17 I X="@" D D G Z^DIE2 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 S X="?BAD" QS S DZ=X D D,QQ^DIEQ G B @@ -44,18 +43,10 @@ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 D ^DIR I 'DDER S %=Y(0),X=Y Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="DGPMX1",DQ=1 - N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1("DIEZ") - M DIEZAR=^DIE(446,"AR") S DICRREC="TRIG^DIE17" - S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=446,U="^" -1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X1 S:$S(DGPMN:1,DGPMY=+^DGPM(DA,0):1,1:0) Y=41 + S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=446,U="^" +1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X1 S:$S(DGPMN:1,DGPMY=+^DGPM(DA,0):1,1:0) Y=.12 Q 2 S DW="0;1",DV="RDX",DU="",DLB="DATE/TIME",DIFLD=.01 S DE(DW)="C2^DGPMX1" @@ -63,8 +54,7 @@ S Y=X S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE +C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE K ^DGPM("B",$E(X,1,30),DA) S X=DE(2),DIC=DIE S DGPMDDF=1 D ^DGPMDD2 @@ -80,8 +70,7 @@ S Y=$P(^DGPM(DA,0),U,2) I Y,Y'=4,Y'=5,X,X
9 F^DIE17,DE S Y=U,DQ=3 G A -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="DIR;1",DV="SXR",DU="",DLB="DOES THE PATIENT WISH TO BE EXCLUDED FROM THE FACILITY DIRECTORY?",DIFLD=41 - S DE(DW)="C4^DGPMX1" - S DU="0:NO;1:YES;" - G RE -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" S DIH=$G(^DGPM(DIV(0),"DIR")),DIV=X S $P(^("DIR"),U,2)=DIV,DIH=405,DIG=42 D ^DICR - S X=DE(4),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGPM(DIV(0),"DIR")),DIV=X S $P(^("DIR"),U,3)=DIV,DIH=405,DIG=43 D ^DICR - S X=DE(4),DIC=DIE - S DGPMDDF=41,DGPMDDT=0 D ^DGPMDDCN -C4S S X="" G:DG(DQ)=X C4F1 K DB - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) X ^DD(405,41,1,1,1.4) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$G(DUZ) S DIH=$G(^DGPM(DIV(0),"DIR")),DIV=X S $P(^("DIR"),U,3)=DIV,DIH=405,DIG=43 D ^DICR - S X=DG(DQ),DIC=DIE - S DGPMDDF=41,DGPMDDT=1 D ^DGPMDDCN -C4F1 Q -X4 I $D(X),'$D(DGPMT) D EN^DDIOL("USE BED CONTROL MOVEMENT OPTIONS!",,"!") K X - Q - ; -5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;12",DV="R*P43.4'",DU="",DLB="ADMITTING REGULATION",DIFLD=.12 +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;12",DV="R*P43.4'",DU="",DLB="ADMITTING REGULATION",DIFLD=.12 S DU="DIC(43.4," G RE -X5 S DIC("S")="I '$P(^(0),""^"",4)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X +X4 S DIC("S")="I '$P(^(0),""^"",4)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A -7 S DW="PTF;4",DV="P35.2'",DU="",DLB="ADMITTING CATEGORY",DIFLD=54 +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 G A +6 S DW="PTF;4",DV="P35.2'",DU="",DLB="ADMITTING CATEGORY",DIFLD=54 S DU="DG(35.2," S X=$$ADCAT^DGSAUTL($P(^DGPM(DA,0),U,12)) S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD:X="@",Z -X7 Q -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:0) S Y="@11" - Q -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 G A -10 S DW="0;11",DV="S",DU="",DLB="ADMITTED FOR SC CONDITION?",DIFLD=.11 - S DU="1:YES;0:NO;" - G RE -X10 Q -11 S DQ=12 ;@11 -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X12 S ^DISV(DUZ,"^DG(405.1,")=$S($D(^DISV(DUZ,"DGPM1")):^("DGPM1"),1:"") - Q -13 S DW="0;4",DV="R*P405.1'X",DU="",DLB="TYPE OF ADMISSION",DIFLD=.04 - S DE(DW)="C13^DGPMX1" - S DU="DG(405.1," - G RE -C13 G C13S:$D(DE(13))[0 K DB - S X=DE(13),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0)):^(0),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X="" S DIH=$S($D(^DGPM(DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,18)=DIV,DIH=405,DIG=.18 D ^DICR:$N(^DD(DIH,DIG,1,0))>0 -C13S S X="" G:DG(DQ)=X C13F1 K DB - D ^DGPMX11 -C13F1 Q -X13 S DIC("S")="I $D(DGPMT),($P(^(0),""^"",2)=DGPMT),$P(^(0),""^"",4) S DGER=0,DGPMTYP=$P(^(0),""^"",3) D:DGPMT<4!(DGPMT=6)!(DGPMT=5) @(""DICS^DGPMV3""_DGPMT) I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X - Q - ; -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X14 S ^DISV(DUZ,"DGPM1")=$S($D(^DISV(DUZ,"^DG(405.1,")):^("^DG(405.1,"),1:"") - Q -15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X15 I $P(^DGPM(DA,0),"^",18)'=9 S Y=.1 +X6 Q +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:0) S Y="@11" Q -16 D:$D(DG)>9 F^DIE17 G ^DGPMX12 +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 G A +9 D:$D(DG)>9 F^DIE17 G ^DGPMX11 diff -auBN ./r1/DGPMX41.m ./r2/r/DGPMX41.m --- ./r1/DGPMX41.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMX41.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,3 +1,114 @@ -DGPMX41 ; ;08/02/04 - S X=DE(12),DIC=DIE +DGPMX41 ; ;03/03/97 + D DE G BEGIN +DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(4)=%,DE(7)=% S %=$P(%Z,U,6) S:%]"" DE(1)=% S %=$P(%Z,U,7) S:%]"" DE(2)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="DGPMX41",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;6",DV="R*P42'X",DU="",DLB="WARD LOCATION",DIFLD=.06 + S DE(DW)="C1^DGPMX41" + S DU="DIC(42," + G RE +C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE + S DGPMDDF=6,DGPMDDT=0 D ^DGPMDDCN + S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + S Y=^DGPM(DA,0) I +Y,Y0 + S X=DG(DQ),DIC=DIE + S Y=^DGPM(DA,0) I +Y,Y
9 F^DIE17,DE S DQ=2,DW="0;7",DV="*P405.4'X",DU="",DLB="ROOM-BED",DIFLD=.07 + S DE(DW)="C2^DGPMX41" + S DU="DG(405.4," + G RE +C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE + S DGPMDDF=7,DGPMDDT=0 D ^DGPMDDCN +C2S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + S DGPMDDF=7,DGPMDDT=1 D ^DGPMDDCN + Q +X2 K:'$D(DGPMT) X I $D(X) S DIC("S")="I $D(^DG(405.4,""W"",+$P(^DGPM(DA,0),""^"",6),+Y)) D OCC^DGPMRB I 'DGPMOC" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) D ROOM^DGPMVDD K:$D(DGOOS) X K DGOOS + Q + ; +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X3 S:($P(DGPMP,"^",18)=$P(^DGPM(DA,0),"^",18)) Y="@42" + Q +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;5",DV="RP4'X",DU="",DLB="TRANSFER FACILITY",DIFLD=.05 + S DE(DW)="C4^DGPMX41" + S DU="DIC(4," + S Y="@" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR +C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR + Q +X4 I '$D(DGPMT) W !?3,*7,"USE BED CONTROL MOVEMENT OPTIONS!" K X + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 S Y="@42" + Q +6 S DQ=7 ;@41 +7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="0;5",DV="RP4'X",DU="",DLB="TRANSFER FACILITY",DIFLD=.05 + S DE(DW)="C7^DGPMX41" + S DU="DIC(4," + G RE +C7 G C7S:$D(DE(7))[0 K DB S X=DE(7),DIC=DIE + I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR +C7S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR + Q +X7 I '$D(DGPMT) W !?3,*7,"USE BED CONTROL MOVEMENT OPTIONS!" K X + Q + ; +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X8 S:($P(DGPMP,"^",18)=$P(^DGPM(DA,0),"^",18)) Y="@42" + Q +9 D:$D(DG)>9 F^DIE17 G ^DGPMX42 diff -auBN ./r1/DGPMX42.m ./r2/r/DGPMX42.m --- ./r1/DGPMX42.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMX42.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,3 +1,114 @@ -DGPMX42 ; ;08/02/04 +DGPMX42 ; ;03/03/97 + D DE G BEGIN +DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,6) S:%]"" DE(1)=% S %=$P(%Z,U,7) S:%]"" DE(2)=% + I $D(^("LD")) S %Z=^("LD") S %=$P(%Z,U,1) S:%]"" DE(4)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% + I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE(7)=% S %=$P(%Z,U,4) S:%]"" DE(9)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +BEGIN S DNM="DGPMX42",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;6",DV="R*P42'X",DU="",DLB="WARD LOCATION",DIFLD=.06 + S DE(DW)="C1^DGPMX42" + S DU="DIC(42," + S Y="@" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE + S DGPMDDF=6,DGPMDDT=0 D ^DGPMDDCN + S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + S Y=^DGPM(DA,0) I +Y,Y0 + S X=DG(DQ),DIC=DIE + S Y=^DGPM(DA,0) I +Y,Y
9 F^DIE17,DE S DQ=2,DW="0;7",DV="*P405.4'X",DU="",DLB="ROOM-BED",DIFLD=.07 + S DE(DW)="C2^DGPMX42" + S DU="DG(405.4," + S Y="@" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE + S DGPMDDF=7,DGPMDDT=0 D ^DGPMDDCN +C2S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE + S DGPMDDF=7,DGPMDDT=1 D ^DGPMDDCN + Q +X2 K:'$D(DGPMT) X I $D(X) S DIC("S")="I $D(^DG(405.4,""W"",+$P(^DGPM(DA,0),""^"",6),+Y)) D OCC^DGPMRB I 'DGPMOC" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) D ROOM^DGPMVDD K:$D(DGOOS) X K DGOOS + Q + ; +3 S DQ=4 ;@42 +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="LD;1",DV="RP406.41'",DU="",DLB="REASON FOR LODGING",DIFLD=30.01 + S DU="DG(406.41," + G RE +X4 Q +5 S DW="LD;2",DV="F",DU="",DLB="LODGING COMMENTS",DIFLD=30.02 + G RE +X5 K:$L(X)>30!($L(X)<3) X + I $D(X),X'?.ANP K X + Q + ; +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 I DGPMP=^DGPM(DA,0) S Y="" + Q +7 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",DIFLD=102 + S DU="VA(200," + S X=DUZ + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +X7 Q +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 G A +9 S DW="USR;4",DV="RD",DU="",DLB="LAST EDITED ON",DIFLD=103 + S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X9 S %DT="STX" D ^%DT S X=Y K:Y<1 X + Q + ; +10 G 0^DIE17 diff -auBN ./r1/DGPMX43.m ./r2/r/DGPMX43.m --- ./r1/DGPMX43.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMX43.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,126 +0,0 @@ -DGPMX43 ; ;08/02/04 - D DE G BEGIN -DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(1)=% S %=$P(%Z,U,7) S:%]"" DE(6)=% - I $D(^("LD")) S %Z=^("LD") S %=$P(%Z,U,1) S:%]"" DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(9)=% - I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE(11)=% S %=$P(%Z,U,4) S:%]"" DE(13)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DGPMX43",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;5",DV="RP4'X",DU="",DLB="TRANSFER FACILITY",DIFLD=.05 - S DE(DW)="C1^DGPMX43" - S DU="DIC(4," - G RE -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR -C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR -C1F1 Q -X1 I '$D(DGPMT) W !?3,*7,"USE BED CONTROL MOVEMENT OPTIONS!" K X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 S:($P(DGPMP,"^",18)=$P(^DGPM(DA,0),"^",18)) Y="@42" - Q -3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X3 N DGWARD - Q -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 S DGWARD(405,DA_",",.06)="" - Q -5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X5 D FILE^DIE("","DGWARD","") - Q -6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;7",DV="*P405.4'X",DU="",DLB="ROOM-BED",DIFLD=.07 - S DE(DW)="C6^DGPMX43" - S DU="DG(405.4," - S Y="@" - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C6 G C6S:$D(DE(6))[0 K DB - S X=DE(6),DIC=DIE - S DGPMDDF=7,DGPMDDT=0 D ^DGPMDDCN -C6S S X="" G:DG(DQ)=X C6F1 K DB - S X=DG(DQ),DIC=DIE - S DGPMDDF=7,DGPMDDT=1 D ^DGPMDDCN -C6F1 Q -X6 K:'$D(DGPMT) X I $D(X) S DIC("S")="I $D(^DG(405.4,""W"",+$P(^DGPM(DA,0),""^"",6),+Y)) D OCC^DGPMRB I 'DGPMOC" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) D ROOM^DGPMVDD K:$D(DGOOS) X K DGOOS - Q - ; -7 S DQ=8 ;@42 -8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="LD;1",DV="RP406.41'",DU="",DLB="REASON FOR LODGING",DIFLD=30.01 - S DU="DG(406.41," - G RE -X8 Q -9 S DW="LD;2",DV="F",DU="",DLB="LODGING COMMENTS",DIFLD=30.02 - G RE -X9 K:$L(X)>30!($L(X)<3) X - I $D(X),X'?.ANP K X - Q - ; -10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X10 I DGPMP=^DGPM(DA,0) S Y="" - Q -11 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",DIFLD=102 - S DU="VA(200," - S X=DUZ - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -X11 Q -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 G A -13 S DW="USR;4",DV="RD",DU="",DLB="LAST EDITED ON",DIFLD=103 - S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X13 S %DT="STX" D ^%DT S X=Y K:Y<1 X - Q - ; -14 G 0^DIE17 diff -auBN ./r1/DGPMX4.m ./r2/r/DGPMX4.m --- ./r1/DGPMX4.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMX4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,7 +1,7 @@ -DGPMX4 ; GENERATED FROM 'DGPM CHECK-IN LODGER' INPUT TEMPLATE(#450), FILE 405;08/02/04 +DGPMX4 ; GENERATED FROM 'DGPM CHECK-IN LODGER' INPUT TEMPLATE(#450), FILE 405;03/03/97 D DE G BEGIN DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(6)=% S %=$P(%Z,U,5) S:%]"" DE(12)=% S %=$P(%Z,U,6) S:%]"" DE(9)=% S %=$P(%Z,U,7) S:%]"" DE(10)=% + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(6)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -14,17 +14,17 @@ A K DQ(DQ) S DQ=DQ+1 B G @DQ RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +N I X="" G A:DV'["R",X:'DV,X:D'>0,A RD G QS:X?."?" I X["^" D D G ^DIE17 I X="@" D D G Z^DIE2 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 S X="?BAD" QS S DZ=X D D,QQ^DIEQ G B @@ -42,17 +42,9 @@ I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 D ^DIR I 'DDER S %=Y(0),X=Y Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="DGPMX4",DQ=1 - N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1("DIEZ") - M DIEZAR=^DIE(450,"AR") S DICRREC="TRIG^DIE17" - S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=450,U="^" -1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 + S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=450,U="^" +1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X1 S:$S(DGPMN:1,DGPMY=+^DGPM(DA,0):1,1:0) Y="@43" Q 2 S DW="0;1",DV="RDX",DU="",DLB="DATE/TIME",DIFLD=.01 @@ -61,8 +53,7 @@ S Y=X S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE +C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE K ^DGPM("B",$E(X,1,30),DA) S X=DE(2),DIC=DIE S DGPMDDF=1 D ^DGPMDD2 @@ -78,8 +69,7 @@ S Y=$P(^DGPM(DA,0),U,2) I Y,Y'=4,Y'=5,X,X
9 F^DIE17,DE S Y=U,DQ=3 G A 4 S DQ=5 ;@43 -5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X5 S ^DISV(DUZ,"DG(405.1,")=$S($D(^DISV(DUZ,"DGPM4")):^("DGPM4"),1:"") Q 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;4",DV="R*P405.1'X",DU="",DLB="CHECK-IN TYPE",DIFLD=.04 S DE(DW)="C6^DGPMX4" S DU="DG(405.1," G RE -C6 G C6S:$D(DE(6))[0 K DB - S X=DE(6),DIC=DIE +C6 G C6S:$D(DE(6))[0 K DB S X=DE(6),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0)):^(0),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X="" S DIH=$S($D(^DGPM(DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,18)=DIV,DIH=405,DIG=.18 D ^DICR:$N(^DD(DIH,DIG,1,0))>0 -C6S S X="" G:DG(DQ)=X C6F1 K DB - S X=DG(DQ),DIC=DIE +C6S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0)):^(0),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y X ^DD(405,.04,1,1,1.1) X ^DD(405,.04,1,1,1.4) -C6F1 Q + Q X6 S DIC("S")="I $D(DGPMT),($P(^(0),""^"",2)=DGPMT),$P(^(0),""^"",4) S DGER=0,DGPMTYP=$P(^(0),""^"",3) D:DGPMT<4!(DGPMT=6)!(DGPMT=5) @(""DICS^DGPMV3""_DGPMT) I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X7 S ^DISV(DUZ,"DGPM4")=$S($D(^DISV(DUZ,"^DG(405.1,")):^("^DG(405.1,"),1:"") Q -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X8 S:$P(^DGPM(DA,0),"^",18)=6 Y="@41" Q -9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;6",DV="R*P42'X",DU="",DLB="WARD LOCATION",DIFLD=.06 - S DE(DW)="C9^DGPMX4" - S DU="DIC(42," - G RE -C9 G C9S:$D(DE(9))[0 K DB - S X=DE(9),DIC=DIE - S DGPMDDF=6,DGPMDDT=0 D ^DGPMDDCN - S X=DE(9),DIC=DIE - ; - S X=DE(9),DIC=DIE - S Y=^DGPM(DA,0) I +Y,Y0 - S X=DG(DQ),DIC=DIE - S Y=^DGPM(DA,0) I +Y,Y
9 F^DIE17,DE S DQ=10,DW="0;7",DV="*P405.4'X",DU="",DLB="ROOM-BED",DIFLD=.07 - S DE(DW)="C10^DGPMX4" - S DU="DG(405.4," - G RE -C10 G C10S:$D(DE(10))[0 K DB - S X=DE(10),DIC=DIE - S DGPMDDF=7,DGPMDDT=0 D ^DGPMDDCN -C10S S X="" G:DG(DQ)=X C10F1 K DB - S X=DG(DQ),DIC=DIE - S DGPMDDF=7,DGPMDDT=1 D ^DGPMDDCN -C10F1 Q -X10 K:'$D(DGPMT) X I $D(X) S DIC("S")="I $D(^DG(405.4,""W"",+$P(^DGPM(DA,0),""^"",6),+Y)) D OCC^DGPMRB I 'DGPMOC" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) D ROOM^DGPMVDD K:$D(DGOOS) X K DGOOS - Q - ; -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 S:($P(DGPMP,"^",18)=$P(^DGPM(DA,0),"^",18)) Y="@42" - Q -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;5",DV="RP4'X",DU="",DLB="TRANSFER FACILITY",DIFLD=.05 - S DE(DW)="C12^DGPMX4" - S DU="DIC(4," - S Y="@" - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C12 G C12S:$D(DE(12))[0 K DB - D ^DGPMX41 -C12S S X="" G:DG(DQ)=X C12F1 K DB - D ^DGPMX42 -C12F1 Q -X12 I '$D(DGPMT) W !?3,*7,"USE BED CONTROL MOVEMENT OPTIONS!" K X - Q - ; -13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X13 S Y="@42" - Q -14 S DQ=15 ;@41 -15 D:$D(DG)>9 F^DIE17 G ^DGPMX43 +9 D:$D(DG)>9 F^DIE17 G ^DGPMX41 diff -auBN ./r1/DGPMXA1.m ./r2/r/DGPMXA1.m --- ./r1/DGPMXA1.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMXA1.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,75 +0,0 @@ -DGPMXA1 ; ;04/03/03 - D DE G BEGIN -DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" - I $D(^("ODS")) S %Z=^("ODS") S %=$P(%Z,U,1) S:%]"" DE(1)=% - I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DGPMXA1",DQ=1 -1 S DW="ODS;1",DV="S",DU="",DLB="ODS AT ADMISSION",DIFLD=11500.01 - S DU="1:YES;0:NO;" - S Y="1" - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -X1 Q -2 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",DIFLD=102 - S DU="VA(200," - S X=DUZ - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -X2 Q -3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 G A -4 S DW="USR;4",DV="RD",DU="",DLB="LAST EDITED ON",DIFLD=103 - S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X4 S %DT="STX" D ^%DT S X=Y K:Y<1 X - Q - ; -5 G 0^DIE17 diff -auBN ./r1/DGPMXA.m ./r2/r/DGPMXA.m --- ./r1/DGPMXA.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMXA.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,8 +1,9 @@ -DGPMXA ; GENERATED FROM 'DGPM ASIH ADMIT' INPUT TEMPLATE(#452), FILE 405;04/03/03 +DGPMXA ; GENERATED FROM 'DGPM ASIH ADMIT' INPUT TEMPLATE(#452), FILE 405;12/10/01 D DE G BEGIN DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S %=$P(%Z,U,6) S:%]"" DE(4)=% S %=$P(%Z,U,7) S:%]"" DE(5)=% S %=$P(%Z,U,10) S:%]"" DE(10)=% S %=$P(%Z,U,11) S:%]"" DE(8)=% S %=$P(%Z,U,12) S:%]"" DE(6)=% - I $D(^("DIR")) S %Z=^("DIR") S %=$P(%Z,U,1) S:%]"" DE(3)=% + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S %=$P(%Z,U,6) S:%]"" DE(3)=% S %=$P(%Z,U,7) S:%]"" DE(4)=% S %=$P(%Z,U,10) S:%]"" DE(9)=% S %=$P(%Z,U,11) S:%]"" DE(7)=% S %=$P(%Z,U,12) S:%]"" DE(5)=% + I $D(^("ODS")) S %Z=^("ODS") S %=$P(%Z,U,1) S:%]"" DE(12)=% + I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE(13)=% S %=$P(%Z,U,4) S:%]"" DE(15)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -54,7 +55,7 @@ M DIEZAR=^DIE(452,"AR") S DICRREC="TRIG^DIE17" S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=452,U="^" 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X1 S:DGPMNA Y=41 +X1 S:DGPMNA Y=.06 Q 2 S DW="0;1",DV="RDX",DU="",DLB="DATE/TIME",DIFLD=.01 S DE(DW)="C2^DGPMXA" @@ -79,7 +80,7 @@ S Y=$P(^DGPM(DA,0),U,2) I Y,Y'=4,Y'=5,X,X
9 F^DIE17,DE S DQ=3,DW="DIR;1",DV="SXR",DU="",DLB="DOES THE PATIENT WISH TO BE EXCLUDED FROM THE FACILITY DIRECTORY?",DIFLD=41 +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;6",DV="R*P42'X",DU="",DLB="WARD LOCATION",DIFLD=.06 S DE(DW)="C3^DGPMXA" - S DU="0:NO;1:YES;" - G RE -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" S DIH=$G(^DGPM(DIV(0),"DIR")),DIV=X S $P(^("DIR"),U,2)=DIV,DIH=405,DIG=42 D ^DICR - S X=DE(3),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGPM(DIV(0),"DIR")),DIV=X S $P(^("DIR"),U,3)=DIV,DIH=405,DIG=43 D ^DICR - S X=DE(3),DIC=DIE - S DGPMDDF=41,DGPMDDT=0 D ^DGPMDDCN -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) X ^DD(405,41,1,1,1.4) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,"DIR")):^("DIR"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$G(DUZ) S DIH=$G(^DGPM(DIV(0),"DIR")),DIV=X S $P(^("DIR"),U,3)=DIV,DIH=405,DIG=43 D ^DICR - S X=DG(DQ),DIC=DIE - S DGPMDDF=41,DGPMDDT=1 D ^DGPMDDCN -C3F1 Q -X3 I $D(X),'$D(DGPMT) D EN^DDIOL("USE BED CONTROL MOVEMENT OPTIONS!",,"!") K X - Q - ; -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;6",DV="R*P42'X",DU="",DLB="WARD LOCATION",DIFLD=.06 - S DE(DW)="C4^DGPMXA" S DU="DIC(42," S X=$P(DGPMA,"^",6) S Y=X S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD:X="@",Z -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE S DGPMDDF=6,DGPMDDT=0 D ^DGPMDDCN - S X=DE(4),DIC=DIE + S X=DE(3),DIC=DIE ; - S X=DE(4),DIC=DIE + S X=DE(3),DIC=DIE S Y=^DGPM(DA,0) I +Y,Y0 S X=DG(DQ),DIC=DIE S Y=^DGPM(DA,0) I +Y,Y
9 F^DIE17,DE S DQ=5,DW="0;7",DV="*P405.4'X",DU="",DLB="ROOM-BED",DIFLD=.07 - S DE(DW)="C5^DGPMXA" + Q +X3 Q +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;7",DV="*P405.4'X",DU="",DLB="ROOM-BED",DIFLD=.07 + S DE(DW)="C4^DGPMXA" S DU="DG(405.4," S X=$P(DGPMA,"^",7) S Y=X S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) G RD:X="@",Z -C5 G C5S:$D(DE(5))[0 K DB - S X=DE(5),DIC=DIE +C4 G C4S:$D(DE(4))[0 K DB + S X=DE(4),DIC=DIE S DGPMDDF=7,DGPMDDT=0 D ^DGPMDDCN -C5S S X="" G:DG(DQ)=X C5F1 K DB +C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S DGPMDDF=7,DGPMDDT=1 D ^DGPMDDCN -C5F1 Q -X5 Q -6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;12",DV="R*P43.4'",DU="",DLB="ADMITTING REGULATION",DIFLD=.12 + Q +X4 Q +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;12",DV="R*P43.4'",DU="",DLB="ADMITTING REGULATION",DIFLD=.12 S DU="DIC(43.4," G RE -X6 S DIC("S")="I '$P(^(0),""^"",4)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X +X5 S DIC("S")="I '$P(^(0),""^"",4)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:0) S Y="@1" +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:0) S Y="@1" Q -8 S DW="0;11",DV="S",DU="",DLB="ADMITTED FOR SC CONDITION?",DIFLD=.11 +7 S DW="0;11",DV="S",DU="",DLB="ADMITTED FOR SC CONDITION?",DIFLD=.11 S DU="1:YES;0:NO;" G RE -X8 Q -9 S DQ=10 ;@1 -10 S DW="0;10",DV="RFX",DU="",DLB="DIAGNOSIS [SHORT]",DIFLD=.1 +X7 Q +8 S DQ=9 ;@1 +9 S DW="0;10",DV="RFX",DU="",DLB="DIAGNOSIS [SHORT]",DIFLD=.1 G RE -X10 K:$L(X)>30!($L(X)<3)!(X[";") X +X9 K:$L(X)>30!($L(X)<3)!(X[";") X I $D(X),X'?.ANP K X Q ; -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 G A -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X12 D DFN^DGYZODS S:'DGODS Y=102 +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 G A +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 D DFN^DGYZODS S:'DGODS Y=102 Q -13 D:$D(DG)>9 F^DIE17 G ^DGPMXA1 +12 S DW="ODS;1",DV="S",DU="",DLB="ODS AT ADMISSION",DIFLD=11500.01 + S DU="1:YES;0:NO;" + S Y="1" + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +X12 Q +13 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",DIFLD=102 + S DU="VA(200," + S X=DUZ + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +X13 Q +14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 G A +15 S DW="USR;4",DV="RD",DU="",DLB="LAST EDITED ON",DIFLD=103 + S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X15 S %DT="STX" D ^%DT S X=Y K:Y<1 X + Q + ; +16 G 0^DIE17 diff -auBN ./r1/DGPMXX1.m ./r2/r/DGPMXX1.m --- ./r1/DGPMXX1.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPMXX1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,4 +1,4 @@ -DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 10/15/04 +DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 11/27/00 ; S DIKZK=2 S DIKZ(0)=$G(^DGPM(DA,0)) @@ -14,7 +14,6 @@ I X'="" D .N DIK,DIV,DIU,DIN .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0)):^(0),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X="" S DIH=$S($D(^DGPM(DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,18)=DIV,DIH=405,DIG=.18 D ^DICR:$N(^DD(DIH,DIG,1,0))>0 - S DIKZ(0)=$G(^DGPM(DA,0)) S X=$P(DIKZ(0),U,5) I X'="" I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR S X=$P(DIKZ(0),U,6) @@ -41,7 +40,6 @@ I X'="" D .N DIK,DIV,DIU,DIN .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I "^3^5^"[("^"_$P(^DGPM(DA,0),"^",2)_"^") I X S X=DIV X ^DD(405,.14,1,3,89.2) S X=$S('$D(^DGPM(+$P(Y(101),U,17),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S DIU=X K Y S X="" X ^DD(405,.14,1,3,2.4) - S DIKZ(0)=$G(^DGPM(DA,0)) S X=$P(DIKZ(0),U,16) I X'="" K ^DGPM("APTF",$E(X,1,30),DA) S X=$P(DIKZ(0),U,17) @@ -54,7 +52,6 @@ I X'="" S Y=^DGPM(DA,0) I +Y,Y
0 S X=$P(DIKZ(0),U,6) I X'="" S Y=^DGPM(DA,0) I +Y,Y
$$FMADD^XLFDT(DGPDT1,1))) - ..S DGPTOT=DGPTOT+1 - ..I $P($G(^DPT(DGPPT,.35)),U)]"" S DGPTDTH=DGPTDTH+1 Q - ..; *** Check for clinic exclusions in MAS PARAMETER File - ..S (DGPN5,DGPEXCL)=0 - ..F S DGPN5=$O(^DG(43,1,"DGPREC",DGPN5)) Q:'DGPN5!(DGPEXCL) D - ...S:$P(^DG(43,1,"DGPREC",DGPN5,0),U)=DGPN1 DGPEXCL=1 - ..I DGPEXCL S DGPTCE=DGPTCE+1 Q - ..; *** Check for eligibility exclusions inthe MAS PARAMETER File - ..N DGPAELG S (DGPN5,DGPEXCL)=0 - ..F S DGPN5=$O(^DG(43,1,"DGPREE",DGPN5)) Q:'DGPN5!(DGPEXCL) D - ...S DGPAELG=$P($G(^DPT(DGPPT,.36)),U) - ...S:$P(^DG(43,1,"DGPREE",DGPN5,0),U)=DGPAELG DGPEXCL=1 - ..I DGPEXCL S DGPTPE=DGPTPE+1 Q - ..; *** Check for inpatient status - ..K DFN S DFN=DGPPT D INP^VADPT - ..I $G(VAIN(1))]"" S DGPINP=DGPINP+1 Q - ..; *** Check for last update in Pre-Registration Audit file - ..S DGPPRDT=DGPTOD+.9999,DGPPRDT=$O(^DGS(41.41,"ADC",DGPPT,DGPPRDT),-1) - ..S DGPNDTW=$P($G(^DG(43,1,"DGPRE")),U,2) - ..I DGPPRDT]""&(DGPNDTW]"") I $$FMDIFF^XLFDT(DGPDT,DGPPRDT,1)DGPDT) D + .. S DGPN3=0 F S DGPN3=$O(^SC(DGPN1,"S",DGPN2,1,DGPN3)) Q:'DGPN3 D + ... S DGPTOT=DGPTOT+1 + ... S DGPPT=$P(^SC(DGPN1,"S",DGPN2,1,DGPN3,0),U) + ... I $P($G(^DPT(DGPPT,.35)),U)]"" S DGPTDTH=DGPTDTH+1 Q + ... S DGPEXCL=0 + ... ; *** Check for clinic exclusions in MAS PARAMETER File + ... S DGPN5=0 F S DGPN5=$O(^DG(43,1,"DGPREC",DGPN5)) Q:'DGPN5!(DGPEXCL) D + .... S:$P(^DG(43,1,"DGPREC",DGPN5,0),U)=DGPN1 DGPEXCL=1 + ... I DGPEXCL S DGPTCE=DGPTCE+1 Q + ... S DGPEXCL=0 + ... ; *** Check for eligibility exclusions inthe MAS PARAMETER File + ... N DGPAELG + ... S DGPN5=0 F S DGPN5=$O(^DG(43,1,"DGPREE",DGPN5)) Q:'DGPN5!(DGPEXCL) D + .... S DGPAELG=$S($P($G(^SC(DGPN1,"S",DGPN2,1,DGPN3,0)),U,10)]"":$P($G(^SC(DGPN1,"S",DGPN2,1,DGPN3,0)),U,10),1:$P($G(^DPT(DGPPT,.36)),U)) + .... S:$P(^DG(43,1,"DGPREE",DGPN5,0),U)=DGPAELG DGPEXCL=1 + ... I DGPEXCL S DGPTPE=DGPTPE+1 Q + ... ; *** Check for inpatient status + ... ; I $P($G(^DPT(DGPPT,.1)),U)]""!($P($G(^DPT(DGPPT,.101)),U)]"") S DGPINP=DGPINP+1 Q + ... K DFN S DFN=DGPPT + ... D INP^VADPT + ... I $G(VAIN(1))]"" S DGPINP=DGPINP+1 Q + ... ; *** Check for last update in Pre-Registration Audit file + ... S DGPPRDT=DGPTOD+.9999,DGPPRDT=$O(^DGS(41.41,"ADC",DGPPT,DGPPRDT),-1) + ... S DGPNDTW=$P($G(^DG(43,1,"DGPRE")),U,2) + ... I DGPPRDT]""&(DGPNDTW]"") I $$FMDIFF^XLFDT(DGPDT,DGPPRDT,1)DGPE) D . S DGPN2="" F S DGPN2=$O(^DIA(2,"C",DGPN1,DGPN2)) Q:'DGPN2 D .. S DGPDATA=$G(^DIA(2,DGPN2,0)) - .. Q:$P(DGPDATA,U,3)="" .. Q:'$D(DGPFLD(+$P($G(DGPDATA),U,3))) .. S DGPDUZ=+$P($G(DGPDATA),U,4) Q:DGPDUZ'>0 .. Q:'($D(^XUSEC("DGPRE EDIT",DGPDUZ))!($D(^XUSEC("DGPRE SUPV",DGPDUZ)))) @@ -89,7 +88,6 @@ F S DGPN1=$O(^DIA(2,"C",DGPN1)) Q:'DGPN1!(DGPN1>DGPE) D . S DGPN2="" F S DGPN2=$O(^DIA(2,"C",DGPN1,DGPN2)) Q:'DGPN2 D .. S DGPDATA=$G(^DIA(2,DGPN2,0)) - .. Q:$P(DGPDATA,U,3)="" .. Q:'$D(DGPFLD($P($G(DGPDATA),U,3))) .. S DGPDUZ=+$P($G(DGPDATA),U,4) Q:DGPDUZ'>0 .. Q:'($D(^XUSEC("DGPRE EDIT",DGPDUZ))!($D(^XUSEC("DGPRE SUPV",DGPDUZ)))) diff -auBN ./r1/DGPT501.m ./r2/r/DGPT501.m --- ./r1/DGPT501.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPT501.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPT501 ;ALB/MTC - Set up process 501 transmission ; 8/27/03 10:05am - ;;5.3;Registration;**64,164,529**;Aug 13, 1993 +DGPT501 ;ALB/MTC - Set up process 501 transmission ; 16 NOV 92 + ;;5.3;Registration;**64,164**;Aug 13, 1993 ; EN ; N ERROR @@ -11,7 +11,7 @@ S DGPTMDT=$E(DGPTSTR,31,40),(X,DGPTMDTS)=$$FMDT^DGPT101($E(DGPTMDT,1,6))_"."_$E(DGPTMDT,7,10) S %DT="XT" D ^%DT K %DT I Y<0 S DGPTERC=505 D ERR G:DGPTEDFL EXIT G ELAPS D DD^%DT S DGPTMDT=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)_" "_$S($P(Y,"@",2)]"":$E($P(Y,"@",2),1,5),1:"00:00") I DGPTMDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N S DGPTERC=505 D ERR G:DGPTEDFL EXIT G TSPEC - I DGPTMDTSDGPTDTS S DGPTERC=537 D ERR G:DGPTEDFL EXIT I DGPTMDTS>DGPTDDS S DGPTERC=540 D ERR G:DGPTEDFL EXIT ELAPS ; S DGPTERC=0 S X1=DGPTMDTS D 501^DGPTAE03 I DGPTERC D ERR G:DGPTEDFL EXIT diff -auBN ./r1/DGPT50DI.m ./r2/r/DGPT50DI.m --- ./r1/DGPT50DI.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPT50DI.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,6 +1,5 @@ -DGPT50DI ;ALB/MTC/ADL - Edit diagnoses.Check ICD DIAGNOSES, current, gender correct ; 16 NOV 92 - ;;5.3;Registration;**510**;Aug 13, 1993 - ;;ADL;Updated for CSV project;;Mar 24, 2003 +DGPT50DI ;ALB/MTC - Edit diagnoses.Check ICD DIAGNOSES, current, gender correct ; 16 NOV 92 + ;;5.3;Registration;;Aug 13, 1993 ; EN ; F I=1:1:5 S DGPTDIB=$P(@("DGPTMD"_I)," ",1) S DGPTERC=0 D DIAG(I) I DGPTERC D ERR G:DGPTEDFL EXIT @@ -25,10 +24,9 @@ S DGPTDIB1=$E(DGPTDIB,1,4)_"."_$E(DGPTDIB,5,$L(DGPTDIB))_" " I '$D(^ICD9("AB",DGPTDIB1)) S DGPTERC=509+I Q S X=$O(^ICD9("AB",DGPTDIB1,0)) I X="" S DGPTERC=509+I Q - S DGPTTMP=$$ICDDX^ICDCODE(X,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT)) ;use date of movement if defined, else today - I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q - I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=509+I Q - I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=791+I Q + I '$D(^ICD9(X,0)) S DGPTERC=509+I Q + I ($P(^ICD9(X,0),U,9)=1)&($E(DGPTMDTS,1,7)>$P(^(0),U,11)) S DGPTERC=509+I Q + I ($P(^ICD9(X,0),U,10)]"")&(DGPTGEN'=$P(^(0),U,10)) S DGPTERC=791+I Q S @("DGPTMD"_I)=$P(DGPTDIB1," ",1) Q DIAGV ; DIAG CODES = "V##.0-2# " @@ -36,16 +34,15 @@ S DGPTDIB1=$E(DGPTDIB,1,3)_"."_$E(DGPTDIB,4,$L(DGPTDIB))_" " I '$D(^ICD9("AB",DGPTDIB1)) S DGPTERC=509+I Q S X=$O(^ICD9("AB",DGPTDIB1,0)) I X="" S DGPTERC=509+I Q - S DGPTTMP=$$ICDDX^ICDCODE(X,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT)) ;use date of movement if defined, else today - I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q - I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=509+I Q - I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=509+I Q + I '$D(^ICD9(X,0)) S DGPTERC=509+I Q + I ($P(^ICD9(X,0),U,9)=1)&($E(DGPTMDTS,1,7)>$P(^(0),U,11)) S DGPTERC=509+I Q + I ($P(^ICD9(X,0),U,10)]"")&(DGPTGEN'=$P(^(0),U,10)) S DGPTERC=509+I Q S @("DGPTMD"_I)=$P(DGPTDIB1," ",1) Q GEN(I) ; S DGPTDIB2=$O(^ICD9("AB",DGPTDIB1,0)) I DGPTDIB2="" S DGPTERC=509+I Q - S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIB2,$S($G(DGPTMDTS)'="":DGPTMDTS,1:DT)) ;use date of movement if defined, else today - I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q - I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=551 Q + I '$D(^ICD9(DGPTDIB2)) S DGPTERC=509+I Q + I '$D(^ICD9(DGPTDIB2,0)) S DGPTERC=509+I Q + I $P(^ICD9(DGPTDIB2,0),U,10)]""&(DGPTGEN'=$P(^(0),U,10)) S DGPTERC=551 Q S @("DGPTMD"_I)=$P(DGPTDIB1," ",1) Q diff -auBN ./r1/DGPT60PR.m ./r2/r/DGPT60PR.m --- ./r1/DGPT60PR.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPT60PR.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,6 +1,5 @@ -DGPT60PR ;ALB/MTC/ADL - Edit procedure codes. In ICD0 Procedures, current, gender ok ; 17 NOV 92 - ;;5.3;Registration;**510**;Aug 13, 1993 - ;;ADL;Update for CSV project;;Mar. 24, 2003 +DGPT60PR ;ALB/MTC - Edit procedure codes. In ICD0 Procedures, current, gender ok ; 17 NOV 92 + ;;5.3;Registration;;Aug 13, 1993 ; EN ; LOOP ; @@ -16,12 +15,11 @@ Q GEN ; S DGPTPP=$O(^ICD0("AB",DGPTOP1,0)) I DGPTPP="" S DGPTERC=604+DGPTL3 Q - S DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$S($G(DGPTPDTS)'="":DGPTPDTS,1:DT)) ;use date of procedure if defined, else today - I DGPTTMP<1!('$P(DGPTTMP,U,10)) S DGPTERC=604+DGPTL3 Q - I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=651 Q + I '$D(^ICD0(DGPTPP)) S DGPTERC=604+DGPTL3 Q + I '$D(^ICD0(DGPTPP,0)) S DGPTERC=604+DGPTL3 Q + I $P(^ICD0(DGPTPP,0),U,10)]""&(DGPTGEN'=$P(^(0),U,10)) S DGPTERC=651 Q CURR ; - S DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$S($G(DGPTPDTS)'="":DGPTPDTS,1:DT)) ;use date of procedure if defined, else today - I ($P(DGPTTMP,U,10)=0)&($E(DGPTPDTS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=604+DGPTL3 Q + I ($P(^ICD0(DGPTPP,0),U,9)=1)&($E(DGPTPDTS,1,7)>$P(^(0),U,11)) S DGPTERC=604+DGPTL3 Q SAVE ; S @("DGPTPC"_DGPTL3)=DGPTOP1 ARRAY ; diff -auBN ./r1/DGPT70DI.m ./r2/r/DGPT70DI.m --- ./r1/DGPT70DI.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPT70DI.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,6 +1,5 @@ -DGPT70DI ;ALB/MTC/ADL - Diagnosis edits for 700's - E codes, V codes, gender and ICD9 Diag. ; 16 NOV 92 - ;;5.3;Registration;**510**;Aug 13, 1993 - ;;ADL;Update for CSV Project;;Mar. 24, 2003 +DGPT70DI ;ALB/MTC - Diagnosis edits for 700's - E codes, V codes, gender and ICD9 Diag. ; 16 NOV 92 + ;;5.3;Registration;;Aug 13, 1993 ; EN ; F DGPTL3=1:1:9 S DGPTDIA=$P((@("DGPTGD"_DGPTL3))," ",1) S DGPTERC=0 D DIAG I DGPTERC D ERR G:DGPTEDFL EXIT @@ -24,10 +23,9 @@ S DGPTDIA1=$E(DGPTDIA,1,4)_"."_$E(DGPTDIA,5,$L(DGPTDIA))_" " I '$D(^ICD9("AB",DGPTDIA1)) S DGPTERC=719+DGPTL3 Q S DGPTDIA2=$O(^ICD9("AB",DGPTDIA1,0)) I DGPTDIA2="" S DGPTERC=719+DGPTL3 Q - S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today - I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 Q - I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=719+DGPTL3 Q - I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=719+DGPTL3 Q + I '$D(^ICD9(DGPTDIA2,0)) S DGPTERC=719+DGPTL3 Q + I ($P(^ICD9(DGPTDIA2,0),U,9)=1)&($E(DGPTDDS,1,7)>$P(^(0),U,11)) S DGPTERC=719+DGPTL3 Q + I ($P(^ICD9(DGPTDIA2,0),U,10)]"")&(DGPTGEN'=$P(^(0),U,10)) S DGPTERC=719+DGPTL3 Q S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1) S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2) Q @@ -36,18 +34,17 @@ S DGPTDIA1=$E(DGPTDIA,1,3)_"."_$E(DGPTDIA,4,$L(DGPTDIA))_" " I '$D(^ICD9("AB",DGPTDIA1)) S DGPTERC=719+DGPTL3 Q S DGPTDIA2=$O(^ICD9("AB",DGPTDIA1,0)) I DGPTDIA2="" S DGPTERC=719+DGPTL3 Q - S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today - I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 Q - I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=719+DGPTL3 Q - I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=719+DGPTL3 Q + I '$D(^ICD9(DGPTDIA2,0)) S DGPTERC=719+DGPTL3 Q + I ($P(^ICD9(DGPTDIA2,0),U,9)=1)&($E(DGPTDDS,1,7)>$P(^(0),U,11)) S DGPTERC=719+DGPTL3 Q + I ($P(^ICD9(DGPTDIA2,0),U,10)]"")&(DGPTGEN'=$P(^(0),U,10)) S DGPTERC=719+DGPTL3 Q S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1) S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2) Q GEN ; S DGPTDIA2=$O(^ICD9("AB",DGPTDIA1,0)) I DGPTDIA2="" S DGPTERC=719+DGPTL3 Q - S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today - I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 Q - I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=751 Q + I '$D(^ICD9(DGPTDIA2)) S DGPTERC=719+DGPTL3 Q + I '$D(^ICD9(DGPTDIA2,0)) S DGPTERC=719+DGPTL3 Q + I $P(^ICD9(DGPTDIA2,0),U,10)]""&(DGPTGEN'=$P(^(0),U,10)) S DGPTERC=751 Q S @("DGPTGD"_DGPTL3)=$P(DGPTDIA1," ",1) ARRAY ; S DGPTDIAR(DGPTDDS)=$S($D(DGPTDIAR(DGPTDDS)):DGPTDIAR(DGPTDDS)_U_DGPTDIA2,1:DGPTDIA2) diff -auBN ./r1/DGPT70DX.m ./r2/r/DGPT70DX.m --- ./r1/DGPT70DX.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPT70DX.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,6 +1,5 @@ -DGPT70DX ;ALB/MTC/ADL - DXLS Edit Checks for 701 ; 13 NOV 92 - ;;5.3;Registration;**510**;Aug 13, 1993 - ;;ADL;Update for CSV Project;;Mar 24, 2003 +DGPT70DX ;ALB/MTC - DXLS Edit Checks for 701 ; 13 NOV 92 + ;;5.3;Registration;;Aug 13, 1993 ; ; EN ;-- check dxls @@ -15,14 +14,12 @@ S DGPTERC=715 G EXIT SET ; S J=$O(^ICD9("AB",DGPTDIA1,0)) I J="" S DGPTERC=715 Q - S DGPTTMP=$$ICDDX^ICDCODE(J,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today - I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=715 Q - I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=715 Q + I '$D(^ICD9(J,0)) S DGPTERC=715 Q + I ($P(^ICD9(J,0),U,9)=1)&($E(DGPTDDS,1,7)>$P(^(0),U,11)) S DGPTERC=715 Q Q GENDR ; - S DGPTTMP=$$ICDDX^ICDCODE(J,$S($G(DGPTDDS)'="":DGPTDDS,1:DT)) ;use date of disp. if defined, else today - G:$P(DGPTTMP,U,11)']"" DDXE - I $P(DGPTTMP,U,11)'=DGPTGEN S DGPTERC=751 G EXIT + G:$P(^ICD9(J,0),U,10)']"" DDXE + I $P(^ICD9(J,0),U,10)'=DGPTGEN S DGPTERC=751 G EXIT DDXE ; S ICDDX(1)=J S DGPTDDXE=$P(DGPTDIA1," ",1) diff -auBN ./r1/DGPTAE04.m ./r2/r/DGPTAE04.m --- ./r1/DGPTAE04.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPTAE04.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,6 +1,5 @@ -DGPTAE04 ;ALB/MTC/ADL - 401 Edit Checks Cont ; 13 NOV 92 - ;;5.3;Registration;**510**;Aug 13, 1993 - ;;ADL;Updated for CSV Project;;Mar 24, 2003 +DGPTAE04 ;ALB/MTC - 401 Edit Checks Cont ; 13 NOV 92 + ;;5.3;Registration;;Aug 13, 1993 ; TRAN ;-- verify transplant status I " 12"'[DGPT40PT S DGPTERC=417 @@ -43,12 +42,10 @@ Q GEN ; S DGPTOPP=$O(^ICD0("AB",DGPTOC,0)) I DGPTOPP="" S DGPTERC=451 Q - S DGPTTMP=$$ICDOP^ICDCODE(DGPTOPP,$S($G(DGPTSDD)'="":DGPTSDD,1:DT)) ;use date of surgery from rec if it exists, else today - I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=451 Q - I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=451 Q + I '$D(^ICD0(DGPTOPP,0)) S DGPTERC=451 Q + I $P(^ICD0(DGPTOPP,0),U,10)]""&(DGPTGEN'=$P(^(0),U,10)) S DGPTERC=451 Q CURR ; - S DGPTTMP=$$ICDOP^ICDCODE(DGPTOPP,$S($G(DGPTSDD)'="":DGPTSDD,1:DT)) ;use date of surgery from rec if it exists, else today - I ($P(DGPTTMP,U,10)=0)&($P(DGPTSDD,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=474+DGPTL3 Q + I ($P(^ICD0(DGPTOPP,0),U,9)=1)&($P(DGPTSDD,1,7)>$P(^(0),U,11)) S DGPTERC=474+DGPTL3 Q SAVE ; S @("DGPTSO"_DGPTL3)=DGPTOC ARRAY ; diff -auBN ./r1/DGPTAEE1.m ./r2/r/DGPTAEE1.m --- ./r1/DGPTAEE1.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPTAEE1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGPTAEE1 ;ALB/MTC - Austin Edits EAL Listing Continued ; 14 DEC 92 - ;;5.3;Registration;**338,565**;Aug 13, 1993 + ;;5.3;Registration;**338**;Aug 13, 1993 ; H101(REC) ;-- 101 header ; INPUT : REC - Node that contains the error @@ -10,9 +10,9 @@ S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X S X="",$P(X," ",80)=" " F X1=1:1 S I=$P(DGER,",",X1) Q:I="" I $P(I,":")<12 S X2=+$P(I,":",2),X=$E(X,1,X2-1)_"#"_$E(X,X2+1,80) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X - S X="BIRTHDATE POS AGO ION ST-CNTY ZIP MT INCOME MST CV CV-END" + S X="BIRTHDATE POS AGO ION ST-CNTY ZIP MT INCOME MST" S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X - S X=$E(REC,57,58)_SP_$E(REC,59,60)_SP_$E(REC,61,64)_" "_$E(REC,65,66)_" "_$E(REC,67)_" "_$E(REC,68)_" "_$E(REC,69,73)_" "_$E(REC,74,78)_" "_$E(REC,79,80)_SP_$E(REC,81,86)_" "_$E(REC,87)_" "_$E(REC,88)_" "_$E(REC,89,94) + S X=$E(REC,57,58)_SP_$E(REC,59,60)_SP_$E(REC,61,64)_" "_$E(REC,65,66)_" "_$E(REC,67)_" "_$E(REC,68)_" "_$E(REC,69,73)_" "_$E(REC,74,78)_" "_$E(REC,79,80)_SP_$E(REC,81,86)_" "_$E(REC,87) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X S X="",$P(X," ",80)=" " F X1=1:1 S I=$P(DGER,",",X1) Q:I="" I $P(I,":")>11 S X2=+$P(I,":",2),X=$E(X,1,X2-1)_"#"_$E(X,X2+1,80) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X diff -auBN ./r1/DGPTAEE2.m ./r2/r/DGPTAEE2.m --- ./r1/DGPTAEE2.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPTAEE2.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ DGPTAEE2 ;ALB/MTC - Austin Edits EAL Report Continued ; 14 DEC 92 - ;;5.3;Registration;**8,338,415,565**;Aug 13, 1993 + ;;5.3;Registration;**8,338,415**;Aug 13, 1993 ; H601(REC) ;-- 601 error processing ; INPUT : REC - Record that contains the errors @@ -32,9 +32,9 @@ S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X S X="",$P(X," ",80)=" " F X1=1:1 S I=$P(DGER,",",X1) Q:I="" I $P(I,":")>10 S X2=+$P(I,":",2),X=$E(X,1,X2-1)_"#"_$E(X,X2+1,80) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X - S X="SC AO IR EC MST HNC ETH RACE CV" + S X="SC AO IR EC MST HNC ETH RACE " S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X - S X=$E(REC,88)_" "_$E(REC,89)_" "_$E(REC,90)_" "_$E(REC,91)_" "_$E(REC,92)_" "_$E(REC,93)_" "_$E(REC,94,95)_" "_$E(REC,96,107)_" "_$E(REC,108) + S X=$E(REC,88)_" "_$E(REC,89)_" "_$E(REC,90)_" "_$E(REC,91)_" "_$E(REC,92)_" "_$E(REC,93)_" "_$E(REC,94,95)_" "_$E(REC,96,107) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X D WRER^DGPTAEE Q diff -auBN ./r1/DGPTDDCR.m ./r2/r/DGPTDDCR.m --- ./r1/DGPTDDCR.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPTDDCR.m 1969-12-31 19:00:00.000000000 -0500 @@ -1,271 +0,0 @@ -DGPTDDCR ;SLC/PKR - Routines for setting and killing Clinical Reminder index. ;08/12/2004 - ;;5.3;Registration;**478**;Aug 13, 1993 - ;=========================================================== -INDEX ;Build the indexes for PTF. - N D1,DA,DAS,DATE,DFN,DIFF,END,ENTRIES,ETEXT,GLOBAL,HASCODES - N ICD0,ICD9,IND,JND,KND,NE0,NE9,NERROR,NODE,START - N TEMP0,TEMP70,TEMP71,TEMPP,TEMPS,TENP,TEXT,VISIT - ;DBIA 4114 - ;Don't leave any old stuff around. - K ^PXRMINDX(45) - S GLOBAL=$$GET1^DID(45,"","","GLOBAL NAME") - S ENTRIES=$P(^DGPT(0),U,4) - S TENP=ENTRIES/10 - S TENP=+$P(TENP,".",1) - I TENP<1 S TENP=1 - D BMES^XPDUTL("Building indexes for DGPT") - S TEXT="There are "_ENTRIES_" entries to process." - D MES^XPDUTL(TEXT) - S START=$H - S (DA,IND,NE0,NE9,NERROR)=0 - F S DA=+$O(^DGPT(DA)) Q:DA=0 D - . S IND=IND+1 - . I IND#TENP=0 D - .. S TEXT="Processing entry "_IND - .. D MES^XPDUTL(TEXT) - . I IND#10000=0 W "." - . S TEMP0=$G(^DGPT(DA,0)) - .;Cenus records are not indexed. - . I $P(TEMP0,U,11)=2 Q - . S DFN=$P(TEMP0,U,1) - . I DFN="" D Q - .. S ETEXT=DA_" no patient" - .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - . S D1=0 - . F S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0 D - .. S TEMPS=$G(^DGPT(DA,"S",D1,0)) - .. S DATE=$P(TEMPS,U,1) - .. I DATE="" D Q - ... S ETEXT=DA_" S node missing date" - ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q - .. S DAS=DA_";S;"_D1_";0" - .. S KND=0 - .. F JND=8,9,10,11,12 D - ... S KND=KND+1 - ... S NODE="S"_KND - ... S ICD0=$P(TEMPS,U,JND) - ... I (ICD0'="") D - .... I $D(^ICD0(ICD0)) D - ..... S NE0=NE0+1 - ..... S ^PXRMINDX(45,"ICD0","INP",ICD0,NODE,DFN,DATE,DAS)="" - ..... S ^PXRMINDX(45,"ICD0","PNI",DFN,NODE,ICD0,DATE,DAS)="" - .... E D - ..... S ETEXT=DAS_" node "_NODE_" invalid ICD0" - ..... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - .; - . S D1=0 - . F S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0 D - .. S TEMPP=$G(^DGPT(DA,"P",D1,0)) - .. S DATE=$P(TEMPP,U,1) - .. I DATE="" D Q - ... S ETEXT=DA_" P node missing date" - ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q - .. S DAS=DA_";P;"_D1_";0" - .. S KND=0 - .. F JND=5,6,7,8,9 D - ... S KND=KND+1 - ... S NODE="P"_KND - ... S ICD0=$P(TEMPP,U,JND) - ... I (ICD0'="") D - .... I $D(^ICD0(ICD0)) D - ..... S NE0=NE0+1 - ..... S ^PXRMINDX(45,"ICD0","INP",ICD0,NODE,DFN,DATE,DAS)="" - ..... S ^PXRMINDX(45,"ICD0","PNI",DFN,NODE,ICD0,DATE,DAS)="" - .... E D - ..... S ETEXT=DAS_" "_NODE_" invalid ICD0" - ..... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - .; - .;Discharge ICD9 codes - . I $D(^DGPT(DA,70)) D - .. S TEMP70=$G(^DGPT(DA,70)) - .. S TEMP71=$G(^DGPT(DA,71)) - .. S DATE=$P(TEMP70,U,1) - .. I DATE="" S DATE=$P(TEMP0,U,2) - .. S DAS=DA_";70" - .. S ICD9=$P(TEMP70,U,10) - .. I (ICD9'="") D - ... I $D(^ICD9(ICD9)) D - .... S NE9=NE9+1 - .... S ^PXRMINDX(45,"ICD9","INP",ICD9,"DXLS",DFN,DATE,DAS)="" - .... S ^PXRMINDX(45,"ICD9","PNI",DFN,"DXLS",ICD9,DATE,DAS)="" - ... E D - .... S ETEXT=DAS_" DXLS invalid ICD9" - .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - ..; - .. S ICD9=$P(TEMP70,U,11) - .. I (ICD9'="") D - ... I $D(^ICD9(ICD9)) D - .... S NE9=NE9+1 - .... S ^PXRMINDX(45,"ICD9","INP",ICD9,"PDX",DFN,DATE,DAS)="" - .... S ^PXRMINDX(45,"ICD9","PNI",DFN,"PDX",ICD9,DATE,DAS)="" - ... E D - .... S ETEXT=DAS_" PDX invalid ICD9" - .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - ..; - .. S KND=0 - .. F JND=16,17,18,19,20,21,22,23,24 D - ... S KND=KND+1 - ... S NODE="D SD"_KND - ... S ICD9=$P(TEMP70,U,JND) - ... I (ICD9'="") D - .... I $D(^ICD9(ICD9)) D - ..... S NE9=NE9+1 - ..... S ^PXRMINDX(45,"ICD9","INP",ICD9,NODE,DFN,DATE,DAS)="" - ..... S ^PXRMINDX(45,"ICD9","PNI",DFN,NODE,ICD9,DATE,DAS)="" - .... E D - ..... S ETEXT=DAS_" node "_NODE_" invalid ICD9" - ..... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - ..; - .. S KND=9 - .. F JND=1,2,3,4 D - ... S KND=KND+1 - ... S NODE="D SD"_KND - ... S ICD9=$P(TEMP71,U,JND) - ... I (ICD9'="") D - .... I $D(^ICD9(ICD9)) D - ..... S NE9=NE9+1 - ..... S ^PXRMINDX(45,"ICD9","INP",ICD9,NODE,DFN,DATE,DAS)="" - ..... S ^PXRMINDX(45,"ICD9","PNI",DFN,NODE,ICD9,DATE,DAS)="" - .... E D - ..... S ETEXT=DAS_" node "_NODE_" invalid ICD9" - ..... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - ..; - .;Movement ICD9 codes - . I '$D(^DGPT(DA,"M")) Q - . S D1=0 - . F S D1=$O(^DGPT(DA,"M",D1)) Q:+D1=0 D - .. S TEMPS=$G(^DGPT(DA,"M",D1,0)) - .. S DATE=$P(TEMPS,U,10) - .. I DATE="" D Q - ... S HASCODES=0 - ... F JND=5,6,7,8,9,11,12,13,14,15 D - .... S ICD9=$P(TEMPS,U,JND) - .... I ICD9'="" S HASCODES=1 - ... I HASCODES D - .... S ETEXT=DA_";M;"_D1_";0"_" M node missing date" - .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - .. S DAS=DA_";M;"_D1 - .. S KND=0 - .. F JND=5,6,7,8,9,11,12,13,14,15 D - ... S KND=KND+1 - ... S NODE="M ICD"_KND - ... S ICD9=$P(TEMPS,U,JND) - ... I (ICD9'="") D - .... I $D(^ICD9(ICD9)) D - ..... S NE9=NE9+1 - ..... S ^PXRMINDX(45,"ICD9","INP",ICD9,NODE,DFN,DATE,DAS)="" - ..... S ^PXRMINDX(45,"ICD9","PNI",DFN,NODE,ICD9,DATE,DAS)="" - .... E D - ..... S ETEXT=DAS_" M node invalid ICD9" - ..... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) - .; - S END=$H - S TEXT=NE0_" PTF ICD0 results indexed." - D MES^XPDUTL(TEXT) - S TEXT=NE9_" PTF ICD9 results indexed." - D MES^XPDUTL(TEXT) - D DETIME^PXRMSXRM(START,END) - ;If there were errors send a message. - I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) - ;Send a MailMan message with the results. - D COMMSG^PXRMSXRM(GLOBAL,START,END,(NE0+NE9),NERROR) - S ^PXRMINDX(45,"GLOBAL NAME")=GLOBAL - S ^PXRMINDX(45,"BUILT BY")=DUZ - S ^PXRMINDX(45,"DATE BUILT")=$$NOW^XLFDT - Q - ; - ;=============================================================== -KDGPT0(X,DA,NODE,NUM) ;Delete index for PTF ICD0 data. - ;Census records are not indexed. - I $P(^DGPT(DA(1),0),U,11)=2 Q - N DAS,DFN,NNAME - S DFN=$P(^DGPT(DA(1),0),U,1) - S NNAME=NODE_NUM - S DAS=DA(1)_";"_NODE_";"_DA_";0" - ;DBIA 4114 - K ^PXRMINDX(45,"ICD0","INP",X(2),NNAME,DFN,X(1),DAS) - K ^PXRMINDX(45,"ICD0","PNI",DFN,NNAME,X(2),X(1),DAS) - Q - ; - ;=============================================================== -KDGPT9D(X,DA,NODE) ;Delete index for PTF discharge ICD9 data. - N DAS,DATE - ;Census records are not indexed. - I X(3)=2 Q - ;If there is no discharge date use the admission date. - S DATE=$S(X(5)'="":X(5),1:X(2)) - S DAS=DA_";70" - ;DBIA 4114 - K ^PXRMINDX(45,"ICD9","INP",X(4),NODE,X(1),DATE,DAS) - K ^PXRMINDX(45,"ICD9","PNI",X(1),NODE,X(4),DATE,DAS) - Q - ; - ;=============================================================== -KDGPT9M(X,DA,NODE) ;Delete index for PTF movement ICD9 data. - ;Census records are not indexed. - I $P(^DGPT(DA(1),0),U,11)=2 Q - N DAS,DFN,TEMP - S TEMP=^DGPT(DA(1),0) - S DFN=$P(TEMP,U,1) - S DAS=DA(1)_";M;"_DA - ;DBIA 4114 - K ^PXRMINDX(45,"ICD9","INP",X(2),NODE,DFN,X(1),DAS) - K ^PXRMINDX(45,"ICD9","PNI",DFN,NODE,X(2),X(1),DAS) - Q - ; - ;=============================================================== -SDGPT0(X,DA,NODE,NUM) ;Set index for PTF ICD0 data. - ;For node 401 surgery node: - ;X(1)=SURGERY/PROCEDURE DATE, X(2)=ICD0 - ;X(2) nodes: 45.01,8; 45.01,9; 45.01,10; 45.01,11; 45.01,12 - ;For node 601, procedure node: - ;X(1)=PROCEDURE DATE, X(2)=ICD0 - ;X(2) source nodes: 45.05,4; 45.05,5; 45.05,6; 45.05,7; 45.05,8 - ;Census records are not indexed. - I $P(^DGPT(DA(1),0),U,11)=2 Q - N DAS,DFN,NNAME - S DFN=$P(^DGPT(DA(1),0),U,1) - S NNAME=NODE_NUM - S DAS=DA(1)_";"_NODE_";"_DA_";0" - ;DBIA 4114 - S ^PXRMINDX(45,"ICD0","INP",X(2),NNAME,DFN,X(1),DAS)="" - S ^PXRMINDX(45,"ICD0","PNI",DFN,NNAME,X(2),X(1),DAS)="" - Q - ; - ;=============================================================== -SDGPT9D(X,DA,NODE) ;Set index for PTF discharge ICD9 data. - ;X(1)=DFN, X(2)=ADMISSION DATE, X(3)=TYPE OF RECORD, X(4)=ICD9, - ;X(5)=DISCHARGE DATE - ;ICD9 from nodes: 45,79; 45,80; 45,79.16 45,79.17; 45,79.18; - ;45,79.19; 45,79.20; 45,79.21; 45,79.22; 45,79.22; 45.79.23; - ;45.79.24. - ;By name these nodes are: DXLS, PRINCIPAL DIAGNOSIS, SECONDARY - ;DIAGNOSIS 1 through SECONDARY DIAGNOSIS 13. - ;Census records are not indexed. - I X(3)=2 Q - N DAS,DATE - ;If there is no discharge date use the admission date. - S DATE=$S(X(5)'="":X(5),1:X(2)) - S DAS=DA_";70" - ;DBIA 4114 - S ^PXRMINDX(45,"ICD9","INP",X(4),NODE,X(1),DATE,DAS)="" - S ^PXRMINDX(45,"ICD9","PNI",X(1),NODE,X(4),DATE,DAS)="" - Q - ; - ;=============================================================== -SDGPT9M(X,DA,NODE) ;Set index for PTF movement ICD9 data. - ;X(1)=MOVEMENT DATE, X(3)=TYPE OF RECORD, X(3)=ICD9 - ;ICD9 from nodes: 45.02,5 45.02,6, 45.02,7 45.02,8 45.02,9 - ;45.02,11 45.02,12 45.02,13 45.02,14 45.02,15 - ;By name these nodes are: ICD 1, through ICD 10. - ;Census records are not indexed. - I $P(^DGPT(DA(1),0),U,11)=2 Q - N DAS,DFN,TEMP - S TEMP=^DGPT(DA(1),0) - S DFN=$P(TEMP,U,1) - S DAS=DA(1)_";M;"_DA - ;DBIA 4114 - S ^PXRMINDX(45,"ICD9","INP",X(2),NODE,DFN,X(1),DAS)="" - S ^PXRMINDX(45,"ICD9","PNI",DFN,NODE,X(2),X(1),DAS)="" - Q - ; diff -auBN ./r1/DGPTDRG.m ./r2/r/DGPTDRG.m --- ./r1/DGPTDRG.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPTDRG.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,9 +1,7 @@ DGPTDRG ;ALB/ABS - DRG Information Report User Prompts ; 3/12/02 4:44pm - ;;5.3;Registration;**60,441,510,559,599,606**;Aug 13, 1993 - ;;ADL;Update for CSV Project;;Mar 28, 2003 + ;;5.3;Registration;**60,441**;Aug 13, 1993 S U="^" D Q,DT^DICRW -PAT D EFFDATE G Q:$D(DUOUT),Q:$D(DTOUT) - W !!,"Choose Patient from PATIENT file" S %=1 D YN^DICN G Q:%=-1 +PAT W !!,"Choose Patient from PATIENT file" S %=1 D YN^DICN G Q:%=-1 I %Y["?"!('%) W !?3,"Enter for YES if you want DRGs for a patient from your PATIENT File",!?3,"Answer 'N' for NO if you want DRGs for a hypothetical patient" G PAT S DGPTHOW=% I %=2 S NAME="" G AGE N DOB S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC G Q:Y'>0 S DFN=+Y,NAME=$P(Y(0),"^"),(DOB,AGE)=$P(Y(0),U,3),SEX=$P(Y(0),U,2),X1=DT,X2=AGE D ^%DTC S AGE=X\365.25 W " AGE:",AGE @@ -20,25 +18,16 @@ S DGTRS=$S(%=1:1,1:0) DMS W !!,"Discharged against medical advice" S %=2 D YN^DICN G Q:%=-1 I %Y["?"!('%) W !?3,"Enter for NO if patient did not leave against medical advice",!?3,"Enter 'Y' for YES if patient did leave against medical advice",!,*7 G DMS S DGDMS=$S(%=1:1,1:0) -DX N DXINF,ICDVDT S ICDVDT=DGDAT - S (DGDX,DGSURG)="",DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A")="Enter DXLS: ",DIC("S")="I '$P($$ICDDX^ICDCODE(+Y,DGDAT),U,5),($$ISVALID^ICDGTDRG(+Y,DGDAT,9))" - W ! D ^DIC G Q:X["^"!(Y'>0) S DGPTTMP=$$ICDDX^ICDCODE(+Y,DGDAT) S:$P(DGPTTMP,U,10) DGDX=+Y,DXINF=$$ICDDX^ICDCODE(+Y,DGDAT),DGDX(1)=$P(DXINF,"^",2)_"^"_$P(DXINF,"^",4) I '$$ISVALID^ICDGTDRG(+Y,DGDAT,9) D INAC G DX - S DIC("A")="Enter SECONDARY diagnosis: " S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,9)" W ! - F DGI=2:1:5 D ^DIC Q:X["^"!(X="") I +Y>0 S DGPTTMP=$$ICDDX^ICDCODE(+Y,DGDAT) S:DGPTTMP>0&($P(DGPTTMP,U,10)) DGDX=DGDX_"^"_+Y,DXINF=$$ICDDX^ICDCODE(+Y,DGDAT),DGDX(DGI)=$P(DXINF,"^",2)_"^"_$P(DXINF,"^",4) I '$P(DGPTTMP,U,10) D INAC S DGI=DGI-1 - G Q:X["^" S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,0)",DIC="^ICD0(",DIC("A")="Enter Operation/Procedure: " W ! - F DGI=1:1:4 D ^DIC Q:X["^"!(X="") I +Y>0 S DGSURG=+Y_"^"_DGSURG,DXINF=$$ICDOP^ICDCODE(+Y,DGDAT),DGSURG(DGI)=$P(DXINF,U,2)_U_$P(DXINF,U,5) +DX S (DGDX,DGSURG)="",DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A")="Enter DXLS: ",DIC("S")="I '$P(^ICD9(+Y,0),U,4)" W ! D ^DIC G Q:X["^"!(Y'>0) S:'$P(Y(0),U,9) DGDX=+Y,DGDX(1)=$P(Y(0),"^")_"^"_$P(Y(0),"^",3) I $P(Y(0),U,9) D INAC G DX + S DIC("A")="Enter SECONDARY diagnosis: " K DIC("S") W ! + F DGI=2:1:5 D ^DIC Q:X["^"!(X="") I +Y>0 S:'$P(Y(0),U,9) DGDX=DGDX_"^"_+Y,DGDX(DGI)=$P(Y(0),"^")_"^"_$P(Y(0),"^",3) I $P(Y(0),U,9) D INAC S DGI=DGI-1 + G Q:X["^" S DIC("S")="I '$P(^ICD0(+Y,0),U,9)",DIC="^ICD0(",DIC("A")="Enter Operation/Procedure: " W ! F DGI=1:1:4 D ^DIC Q:X["^"!(X="") I +Y>0 S DGSURG=+Y_"^"_DGSURG,DGSURG(DGI)=$P(Y(0),"^")_"^"_$P(Y(0),"^",4) ; added next line for DG*5.3*441 S DGSURG=U_DGSURG - G Q:X["^" I $D(DGPTODR) S DGVAR="AGE^NAME^SEX^DGDMS^DGEXP^DGTRS^DGDX#^DGSURG#^DGDAT",DGPGM="^DGPTODR" W ! D ZIS^DGUTQ G:POP Q U IO D ^DGPTODR,CLOSE^DGUTQ,Q S DGPTODR=1 G PAT - S DGDRGPRT=1 D ^DGPTICD,Q G PAT ;return DRG code even if inactive + G Q:X["^" I $D(DGPTODR) S DGVAR="AGE^NAME^SEX^DGDMS^DGEXP^DGTRS^DGDX#^DGSURG#",DGPGM="^DGPTODR" W ! D ZIS^DGUTQ G:POP Q U IO D ^DGPTODR,CLOSE^DGUTQ,Q S DGPTODR=1 G PAT + S DGDRGPRT=1 D ^DGPTICD,Q G PAT Q K DFN,DGI,DGPGM,AGE,NAME,DGDMS,DGDX,DGEXP,DGPTHOW,DGSURG,DGTRS,DGVAR,DGDRGPRT,DRG,DIC,SEX,POP,X,Y,Z,X1,X2,%,%Y Q ; -EFFDATE ;prompts for effective date for DRG grouper? - K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="Effective Date" - S DIR("?")="The effective to be used when calculating the DRG code for the patient." - D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q - S DGDAT=Y - Q INAC ; W !,*7,">>> You have selected an INACTIVE diagnosis code." W !," This code is not used by the grouper and may cause" diff -auBN ./r1/DGPTF1.m ./r2/r/DGPTF1.m --- ./r1/DGPTF1.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPTF1.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPTF1 ;ALB/JDS - PTF ENTRY/EDIT ; 11/24/03 3:29pm - ;;5.3;Registration;**69,114,195,397,342,415,565**;Aug 13, 1993 +DGPTF1 ;ALB/JDS - PTF ENTRY/EDIT ; 10/4/01 10:12am + ;;5.3;Registration;**69,114,195,397,342,415**;Aug 13, 1993 ; I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP S:'$D(IOST) IOST="C" S DGVI="""""",DGVO=DGVI I $D(IOST(0)) S:$D(^%ZIS(2,IOST(0),5)) I=^(5) S:$L($P(I,U,4)) DGVI=$P(I,U,4) S:$L($P(I,U,5)) DGVO=$P(I,U,5) I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM") @@ -50,10 +50,7 @@ AO W !," Agent Or exp: " S L=$P(A(.321),U,2) W $S(L="Y":"YES",L="N":"NO",1:"UNKNOWN") AOLOC S L=$P(A(.321),U,13) W:L'="" ?36,"Exposure Location: ",$S(L="V":"Vietnam",L="K":"Korean DMZ",1:"") MST W !," Claims MST: " S L=$P(A("MST"),U) W $S(L="Y":"YES",L="N":"NO",L="D":"DECLINED TO ANSWER",1:"UNKNOWN") ; added 6/17/98 for MST enhancement -NTR W ?39," N/T Radium: " S L=A("NTR") W $S(L'="":L,1:"UNKNOWN") -CV S L=$S($P(A("CV"),U,1)>0:1,1:0) - W !,"Combat Veteran: ",$S(L:"YES",1:"NO") - I L S Y=$P(A("CV"),U,2) D D^DGPTUTL W ?45,"End Date: ",Y +NTR W !," N/T Radium: " S L=A("NTR") W $S(L'="":L,1:"UNKNOWN") ; D EN^DGPTF4 K A,B Q:DGPR ; @@ -80,7 +77,6 @@ K DGNTARR F I=0,101,70 S B(I)="" S:$D(^DGPT(PTF,I)) B(I)=^(I) S DGDD=+B(70),DGFC=+$P(B(0),U,3) - S A("CV")=$$CVEDT^DGCV(DFN,$P($G(B(0)),U,2)) K PT G DGPTF1 PR W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (screen # appears in upper right of screen '')",!," to continue on to the next screen or 1-7 to edit:" W !?10,"1-Facility, Source of admis, Payment, Transf facil, and Cat. of Benef",!?10,"2-Marital Stat, Race, Ethnicity, Sex, SCI, DOB" diff -auBN ./r1/DGPTF4.m ./r2/r/DGPTF4.m --- ./r1/DGPTF4.m 2005-02-21 00:31:00.000000000 -0500 +++ ./r2/r/DGPTF4.m 2003-03-21 10:31:20.000000000 -0500 @@ -1,5 +1,5 @@ -DGPTF4 ;ALB/JDS - PTF ENTRY/EDIT-4 ; 2/19/04 9:33am - ;;5.3;Registration;**114,115,397,510,517,478**;Aug 13, 1993 +DGPTF4 ;ALB/JDS - PTF ENTRY/EDIT-4 ; 8/2/01 5:42pm + ;;5.3;Registration;**114,115,397**;Aug 13, 1993 ; WR ; W @IOF,HEAD,?72 S Z="<701>" D Z^DGPTFM K X S $P(X,"-",81)="" W !,X @@ -26,33 +26,22 @@ W $S($D(^DIC(21,$S('$D(^DGPM(+$O(^DGPM("APTF",PTF,0)),"ODS")):+