Only in ./VADemo/r1/: A1CKC10.m Only in ./VADemo/r1/: A1CKC11.m Only in ./VADemo/r1/: A1CKC12.m Only in ./VADemo/r1/: A1CKC13.m Only in ./VADemo/r1/: A1CKC14.m Only in ./VADemo/r1/: A1CKC15.m diff -y --suppress-common-lines ./VADemo/r1/A1CKC1.m ./VADemo/r2/r/A1CKC1.m 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, > 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( > I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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= > 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 > 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^VA > 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(D > 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^VA > Q:$D(DE(1))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ) > Q > X1 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILI > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".3;1",DV="RSXa",DU=" > 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 > 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^VA > 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(D 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(D K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) | D AUTOUPD^DGENA2(DA) > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VA > Q:$D(DE(2))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ) > 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= > 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 > 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 > 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^ > 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 > S X=DG(DQ),DIC=DIE > S DFN=DA D EN^DGMTCOR K DGMTCOR S ^DPT("AEL",DA,+X)="" | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | 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= > 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 > 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 > 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^ > 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 > 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^ > 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= > 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 > 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 > 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^ > 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 > 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^ > 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 -y --suppress-common-lines ./VADemo/r1/A1CKC2.m ./VADemo/r2/r/A1CKC2.m 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, > 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( > I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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",D > 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 > 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 > S X=DE(1),DIC=DIE > X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"": > 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" > K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.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) > 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" > 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 > 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^VAF > 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 $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | Q:$D(DE(2))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ) > 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 > 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 > 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 > 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 > 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 > 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. > S DU="DIC(31," > G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY( > S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'=" > M10 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(10)=$P( > S X="`"_ISC > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > 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 > 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 > 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 DISABILI > 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 > 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( > S X=DE(15),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ > 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( > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ > 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 > 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 > 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 > 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 > 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^ > 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 > 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^ > 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 > 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 -y --suppress-common-lines ./VADemo/r1/A1CKC3.m ./VADemo/r2/r/A1CKC3.m A1CKC3 ; ;07/02/04 | A1CKC3 ; ;06/28/99 S X=DE(10),DIC=DIE | D DE G BEGIN S DFN=DA D EN^DGMTCOR K DGMTCOR | DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU= S X=DE(10),DIC=DIE | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S > K %Z Q S X=DE(10),DIC=DIE | W W !?DL+DL-2,DLB_": " D AUTOUPD^DGENA2(DA) | Q S X=DE(10),DIC=DIE | O D W W Y W:$X>45 !?9 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VA | I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 S X=DE(10),DIC=DIE | W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (N D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) | TR R X:DTIME E S (DTOUT,X)=U W $C(7) S X=DE(10),DIIX=2_U_DIFLD D AUDIT^DIET | 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > G RD > X1 I $D(X) D EK^DGLOCK Q > Q > ; > 2 S DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFL > 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 > G RD > X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^D > Q > ; > 3 S DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFL > 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 > G RD > X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK > Q > ; > 4 G 1^DIE17 diff -y --suppress-common-lines ./VADemo/r1/A1CKC4.m ./VADemo/r2/r/A1CKC4.m 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, > I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE( > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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= > 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 > 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 > 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^ > 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 X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ > 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 > 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= > 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 > 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 > 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^ > 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 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VA | 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^ D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) | D AUTOUPD^DGENA2(DA) I $D(DE(10))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D | 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 > X5 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) > Q > 6 S DQ=7 ;@999 > 7 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/A1CKC5.m ./VADemo/r2/r/A1CKC5.m A1CKC5 ; ;07/02/04 | A1CKC5 ; ;01/20/98 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, | DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU= I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(1)=% | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S 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( < I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" < N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ | BEGIN S DNM="A1CKC5",DQ=1+D G B I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/ | 1 S DW="0;1",DV="MP31'X",DU="",DLB="RATED DISABILITIES E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") | S DU="DIC(31," Q | S X="`"_ISC NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G < 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=" < 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 < 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^VA < 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(D < 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(D < 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^VA < 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 < 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= < S DE(DW)="C2^A1CKC5" < S DU="Y:YES;N:NO;U:UNKNOWN;" < S X=$S(PE="Y":"Y",1:"N") < C2 G C2S:$D(DE(2))[0 K DB | X1 I $D(X) D EK^DGLOCK Q 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 < 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^ < 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 < 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^ < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA) < C2F1 Q < X2 S DFN=DA D MV^DGLOCK < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;12",DV="SX",DU= | 2 S DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFL S DE(DW)="C3^A1CKC5" | S X=+SCI(ISC) S DU="Y:YES;N:NO;U:UNKNOWN;" < S X=$S(AA="Y":"Y",1:"N") < C3 G C3S:$D(DE(3))[0 K DB | X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^D 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 < 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^ < 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 < 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^ < 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 < 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;13",DV="SX",DU= | 3 S DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFL S DE(DW)="C4^A1CKC5" | S DU="0:NO;1:YES;" S DU="Y:YES;N:NO;U:UNKNOWN;" | S Y="1" S X=$S(HB="Y":"Y",1:"N") < S Y=X < C4 G C4S:$D(DE(4))[0 K DB | X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK 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 < 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^ < 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 < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".36;1",DV="*P8'Xa",D | 4 G 1^DIE17 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 < 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" < 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 < 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 < 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 < 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) < 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) < 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) < X13 I 'ISC S Y="@39" < Q < 14 D:$D(DG)>9 F^DIE17 G ^A1CKC11 < diff -y --suppress-common-lines ./VADemo/r1/A1CKC6.m ./VADemo/r2/r/A1CKC6.m 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, > I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE( > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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= > 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 > 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 > 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^ > 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 > S X=DG(DQ),DIC=DIE > S DFN=DA D EN^DGMTCOR K DGMTCOR X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ > 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 > 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= > 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 > 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 > 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^ > 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 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ > 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 > 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 -y --suppress-common-lines ./VADemo/r1/A1CKC7.m ./VADemo/r2/r/A1CKC7.m A1CKC7 ; ;07/02/04 | A1CKC7 ; ;01/20/98 S X=DE(5),DIC=DIE | D DE G BEGIN > DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, > I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,13) S:%]"" DE( > K %Z Q S X=DE(5),DIC=DIE | W W !?DL+DL-2,DLB_": " K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I | Q S X=DE(5),DIC=DIE | O D W W Y W:$X>45 !?9 X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"": | I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 S X=DE(5),DIC=DIE | W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (N K ^DPT("AEL",DA,+X) | TR R X:DTIME E S (DTOUT,X)=U W $C(7) S X=DE(5),DIC=DIE | 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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= > 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 > 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 > 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^ > S X=DE(1),DIC=DIE 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 > 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^ > 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 > X2 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) > Q > 3 S DQ=4 ;@999 > 4 G 0^DIE17 Only in ./VADemo/r1/: A1CKC8.m Only in ./VADemo/r1/: A1CKC9.m diff -y --suppress-common-lines ./VADemo/r1/A1CKC.m ./VADemo/r2/r/A1CKC.m A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#150 | A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#150 I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE | I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=1505,U="^" M DIEZAR=^DIE(1505,"AR") S DICRREC="TRIG^DIE17" | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=15 < 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 < C3 G C3S:$D(DE(3))[0 K DB | C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE S X=DE(3),DIC=DIE < S X=DE(3),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C3S S X="" G:DG(DQ)=X C3F1 K DB | C3S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S X=DG(DQ),DIC=DIE < S X=DG(DQ),DIC=DIE | Q:$D(DE(3))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ) D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) | Q I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C3F1 Q < C4 G C4S:$D(DE(4))[0 K DB | C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE S X=DE(4),DIC=DIE < S X=DE(4),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < 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 S X=DG(DQ),DIC=DIE < S X=DG(DQ),DIC=DIE | Q:$D(DE(4))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ) D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) | Q I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C4F1 Q < C5 G C5S:$D(DE(5))[0 K DB | C5 G C5S:$D(DE(5))[0 K DB S X=DE(5),DIC=DIE S X=DE(5),DIC=DIE < ; | X "S DFN=DA D EN^DGMTR K DGREQF" S X=DE(5),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < 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 S X=DG(DQ),DIC=DIE < S X=DG(DQ),DIC=DIE | Q:$D(DE(5))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ) D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) | Q I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C5F1 Q < C6 G C6S:$D(DE(6))[0 K DB | C6 G C6S:$D(DE(6))[0 K DB S X=DE(6),DIC=DIE S X=DE(6),DIC=DIE < 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 D ^A1CKC1 | X "S DFN=DA D EN^DGMTR K DGREQF" C6F1 Q | 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 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) > Q C7 G C7S:$D(DE(7))[0 K DB | C7 G C7S:$D(DE(7))[0 K DB S X=DE(7),DIC=DIE S X=DE(7),DIC=DIE < C7S S X="" G:DG(DQ)=X C7F1 K DB | C7S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE D ^A1CKC2 | I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAF C7F1 Q | Q:$D(DE(7))[0&(^DD(DP,DIFLD,"AUDIT")="e") S X=DG(DQ) > Q 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 | 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW="VET;1",DV="RSXa",DU | 10 D:$D(DG)>9 F^DIE17 G ^A1CKC1 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 < 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 ELIGIBILI < Q < ; < 11 D:$D(DG)>9 F^DIE17 G ^A1CKC5 < Only in ./VADemo/r1/: ABSVM1.m Only in ./VADemo/r1/: ABSVMHV1.m Only in ./VADemo/r1/: ABSVMLC1.m Only in ./VADemo/r1/: ABSVMLC2.m Only in ./VADemo/r1/: ABSVMLC3.m Only in ./VADemo/r1/: ABSVM.m Only in ./VADemo/r1/: ABSVMRV1.m Only in ./VADemo/r1/: ABSVMS1.m Only in ./VADemo/r1/: ABSVMUT1.m Only in ./VADemo/r1/: ABSVMVV1.m Only in ./VADemo/r1/: ABSVMVV2.m Only in ./VADemo/r1/: ABSVMVV3.m Only in ./VADemo/r1/: ACKQAG01.m Only in ./VADemo/r1/: ACKQAG02.m Only in ./VADemo/r1/: ACKQAG03.m Only in ./VADemo/r1/: ACKQAG04.m Only in ./VADemo/r1/: ACKQAG05.m Only in ./VADemo/r1/: ACKQAG06.m diff -y --suppress-common-lines ./VADemo/r1/ACKQAS3.m ./VADemo/r2/r/ACKQAS3.m ;;3.0;QUASAR;**8**;Feb 11, 2000 | ;;3.0;QUASAR;;Feb 11, 2000 W !!,$P(^ICPT(ACK,0),U)," ",$$PROCTXT^ACKQUTL8(ACK," | W !!,$P(^ICPT(ACK,0),U)," ",$P(^(0),U,2) diff -y --suppress-common-lines ./VADemo/r1/ACKQASU.m ./VADemo/r2/r/ACKQASU.m ;;3.0;QUASAR;**8**;Feb 11, 2000 | ;;3.0;QUASAR;;Feb 11, 2000 K ACKQSER,ACKQORG,ACKQIR,ACKQECON,ACKAPMNT,ICPTVDT,IC | K ACKQSER,ACKQORG,ACKQIR,ACKQECON,ACKAPMNT . W !!,X," ",$$PROCTXT^ACKQUTL8(ACKDC,ACKVD) | . W !!,X," ",$$GET1^DIQ(80,ACKDC,3) diff -y --suppress-common-lines ./VADemo/r1/ACKQNQ.m ./VADemo/r2/r/ACKQNQ.m ;;3.0;QUASAR;**8**;Feb 11, 2000 | ;;3.0;QUASAR;;Feb 11, 2000 . D GETS^DIQ(80,+ACKDC_",",".01","E","ACKTGT","ACKMSG | . D GETS^DIQ(80,+ACKDC_",",".01;2;3","E","ACKTGT","AC . S ACKICD(ACKDN)=ACKDN_U_""_U_$$DIAGTXT^ACKQUTL8(+AC | . S ACKICD(ACKDN)=ACKDN_U_ACKTGT(80,+ACKDC_",",2,"E") diff -y --suppress-common-lines ./VADemo/r1/ACKQPCE1.m ./VADemo/r2/r/ACKQPCE1.m ACKQPCE1 ;HCIOFO/AG - Quasar/PCE Interface; August 199 | ACKQPCE1 ;HCIOFO/AG - Quasar/PCE Interface; August 199 ;;3.0;QUASAR;**1,2,5,7,8**;Feb 11, 2000 | ;;3.0;QUASAR;**1,2**;Feb 11, 2000 ; initialize | ; initialise ; initialize temp file | ; initialise temp file ; ^TMP("ACKQPCE1",$J,"FDA",509850.6,visit_",",fldnum | ; ^TMP("ACKQPCE1",$j,"FDA",509850.6,visit_",",fldnum > ; ----------------student--------------------- > S ACKSTUD=@ACKFDA2@(7,"I") > I ACKSTUD'="" D > . S ACKSTUD=$$CONVERT1^ACKQUTL4(ACKSTUD) > . S ACKCT=ACKCT+1,@ACKAPI@("PROVIDER",ACKCT,"NAME")=A . S ACKNARR=$$LDIAGTXT^ACKQUTL8(ACKICD9,ACKVD) | . S ACKNARR=$$GET1^DIQ(80,ACKICD9,10,"I") . ; check for updating PCE problem list flag < . . ; don't send if diagnosis provider blank < . . S ACKPLQT=$$PLIST^ACKQUTL6(ACKPAT,ACKICD9) | . . I ACKPBLMP'="" S ACKPBLMP=$$CONVERT1^ACKQUTL4(ACK . . ; send new problem if not on list | . . S @ACKAPI@("DX/PL",ACKCT,"ENC PROVIDER")=ACKPBLMP . . I 'ACKPLQT S @ACKAPI@("DX/PL",ACKCT,"PL ADD")=1 | . . S ACKIFN=0,ACKPLQT=0 . . ; make existing problem active if currently inact | . . I $D(^AUPNPROB("AC",ACKPAT)) D . . I +ACKPLQT=1 D | . . . F S ACKIFN=$O(^AUPNPROB("AC",ACKPAT,ACKIFN)) Q . . . S @ACKAPI@("DX/PL",ACKCT,"PL IEN")=$P(ACKPLQT,U | . . . . I $D(^AUPNPROB("B",ACKICD9,ACKIFN)) S ACKPLQT . . . S @ACKAPI@("DX/PL",ACKCT,"PL ACTIVE")="A" | . . S:ACKPLQT @ACKAPI@("DX/PL",ACKCT,"PL IEN")=ACKPLQ . . ; send event date and encounter provider if updat | . . S:'ACKPLQT @ACKAPI@("DX/PL",ACKCT,"PL ADD")="1" . . I +ACKPLQT'=2 D | . . S @ACKAPI@("DX/PL",ACKCT,"EVENT D/T")=ACKVD . . . S @ACKAPI@("DX/PL",ACKCT,"EVENT D/T")=ACKVD < . . . S ACKPBLMP=$$CONVERT1^ACKQUTL4(ACKPBLMP) < . . . S @ACKAPI@("DX/PL",ACKCT,"ENC PROVIDER")=ACKPBL < . ; Check for primary diagnosis < ; First Diagnosis sent as Primary if No Primary defin | ; First Diagnosis sent as Primary is No Primary defi . I ACKPROCP'="" S ACKPROCP=$$CONVERT1^ACKQUTL4(ACKPR | . I ACKPROCP'="" S ACKPROCP=$$CONVERT1^ACKQUTL4(ACKPR diff -y --suppress-common-lines ./VADemo/r1/ACKQR2.m ./VADemo/r2/r/ACKQR2.m ;;3.0;QUASAR;**1,8**;Feb 11, 2000 | ;;3.0;QUASAR;**1**;Feb 11, 2000 D GETS^DIQ(81,ACKCPTN_",",".01","",ACKTMP,"ACKMSG") | D GETS^DIQ(81,ACKCPTN_",",".01;2","",ACKTMP,"ACKMSG") S ^TMP("ACKQR2",$J,"CPT",1,81,ACKCPTN_",",2)=$$PROCTX < diff -y --suppress-common-lines ./VADemo/r1/ACKQR3.m ./VADemo/r2/r/ACKQR3.m ;;3.0;QUASAR;**8**;Feb 11, 2000 | ;;3.0;QUASAR;;Feb 11, 2000 N ACKTMP,ACKMSG,ACKICD9,ACKQDTXT | N ACKTMP,ACKMSG,ACKICD9 D GETS^DIQ(80,ACKICDN_",",".01","",ACKTMP,"ACKMSG") | D GETS^DIQ(80,ACKICDN_",",".01;3","",ACKTMP,"ACKMSG") S ACKQDTXT=$$DIAGTXT^ACKQUTL8(ACKICDN,"") < S ^TMP("ACKQR3",$J,"ICD9",1,80,ACKICDN_",",3)=ACKQDTX < diff -y --suppress-common-lines ./VADemo/r1/ACKQR4.m ./VADemo/r2/r/ACKQR4.m ;;3.0;QUASAR;**8**;Feb 11, 2000 | ;;3.0;QUASAR;;Feb 11, 2000 N ACKTME | K ^TMP("ACKQR4",$J) S ACKPG=0 D NOW^%DTC S ACKXDT=$$N K ^TMP("ACKQR4",$J) S ACKPG=0 < D NOW^%DTC < S ACKXDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%) < ..S ACKPN=$P($G(^ICPT(ACKPP,0)),U) Q:ACKPN="" S ACKP | ..S ACKPN=$P($G(^ICPT(ACKPP,0)),U) Q:ACKPN="" S ACKP ..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, > ...I 'ACKMP S ACKPDSC="" Q > ...S ACKPDSC=$P(^ACK(509850.4,ACKPP,1,ACKMP,0),U,2),A diff -y --suppress-common-lines ./VADemo/r1/ACKQTE10.m ./VADemo/r2/r/ACKQTE10.m ACKQTE10 ; ;07/15/03 | ACKQTE10 ; ;04/12/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q C6S S X="" G:DG(DQ)=X C6F1 K DB | C6S S X="" Q:DG(DQ)=X K DB C6F1 Q | Q C8S S X="" G:DG(DQ)=X C8F1 K DB | C8S S X="" Q:DG(DQ)=X K DB C8F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE11.m ./VADemo/r2/r/ACKQTE11.m ACKQTE11 ; ;07/15/03 | ACKQTE11 ; ;04/12/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q C2S S X="" G:DG(DQ)=X C2F1 K DB | C2S S X="" Q:DG(DQ)=X K DB C2F1 Q | Q C4S S X="" G:DG(DQ)=X C4F1 K DB | C4S S X="" Q:DG(DQ)=X K DB C4F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE12.m ./VADemo/r2/r/ACKQTE12.m ACKQTE12 ; ;07/15/03 | ACKQTE12 ; ;04/12/01 C2S S X="" G:DG(DQ)=X C2F1 K DB | C2S S X="" Q:DG(DQ)=X K DB C2F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE1.m ./VADemo/r2/r/ACKQTE1.m ACKQTE1 ; ;07/15/03 | ACKQTE1 ; ;04/12/01 diff -y --suppress-common-lines ./VADemo/r1/ACKQTE2.m ./VADemo/r2/r/ACKQTE2.m ACKQTE2 ; ;07/15/03 | ACKQTE2 ; ;04/12/01 diff -y --suppress-common-lines ./VADemo/r1/ACKQTE3.m ./VADemo/r2/r/ACKQTE3.m ACKQTE3 ; ;07/15/03 | ACKQTE3 ; ;04/12/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q C14S S X="" G:DG(DQ)=X C14F1 K DB | C14S S X="" Q:DG(DQ)=X K DB C14F1 Q | Q C19S S X="" G:DG(DQ)=X C19F1 K DB | C19S S X="" Q:DG(DQ)=X K DB C19F1 Q | Q C23S S X="" G:DG(DQ)=X C23F1 K DB | C23S S X="" Q:DG(DQ)=X K DB C23F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE4.m ./VADemo/r2/r/ACKQTE4.m ACKQTE4 ; ;07/15/03 | ACKQTE4 ; ;04/12/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q C5S S X="" G:DG(DQ)=X C5F1 K DB | C5S S X="" Q:DG(DQ)=X K DB C5F1 Q | Q X7 I '$$PROB^ACKQUTL4(ACKPCE,ACKDIV)!(+$$PLIST^ACKQUTL6( | X7 I '$$PROB^ACKQUTL4(ACKPCE,ACKDIV) S Y="@49" X10 I '$$PROB^ACKQUTL4(ACKPCE,ACKDIV)!(+$$PLIST^ACKQUTL6( | X10 I '$$PROB^ACKQUTL4(ACKPCE,ACKDIV) S Y="@49" C11S S X="" G:DG(DQ)=X C11F1 K DB | C11S S X="" Q:DG(DQ)=X K DB C11F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE5.m ./VADemo/r2/r/ACKQTE5.m ACKQTE5 ; ;07/15/03 | ACKQTE5 ; ;04/12/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q C6S S X="" G:DG(DQ)=X C6F1 K DB | C6S S X="" Q:DG(DQ)=X K DB C6F1 Q | Q C11S S X="" G:DG(DQ)=X C11F1 K DB | C11S S X="" Q:DG(DQ)=X K DB C11F1 Q | Q C15S S X="" G:DG(DQ)=X C15F1 K DB | C15S S X="" Q:DG(DQ)=X K DB C15F1 Q | Q C18S S X="" G:DG(DQ)=X C18F1 K DB | C18S S X="" Q:DG(DQ)=X K DB C18F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE6.m ./VADemo/r2/r/ACKQTE6.m ACKQTE6 ; ;07/15/03 | ACKQTE6 ; ;04/12/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE7.m ./VADemo/r2/r/ACKQTE7.m ACKQTE7 ; ;07/15/03 | ACKQTE7 ; ;04/12/01 C32S S X="" G:DG(DQ)=X C32F1 K DB | C32S S X="" Q:DG(DQ)=X K DB C32F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE8.m ./VADemo/r2/r/ACKQTE8.m ACKQTE8 ; ;07/15/03 | ACKQTE8 ; ;04/12/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE9.m ./VADemo/r2/r/ACKQTE9.m ACKQTE9 ; ;07/15/03 | ACKQTE9 ; ;04/12/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q C22S S X="" G:DG(DQ)=X C22F1 K DB | C22S S X="" Q:DG(DQ)=X K DB C22F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/ACKQTE.m ./VADemo/r2/r/ACKQTE.m ACKQTE ; GENERATED FROM 'ACKQAS VISIT ENTRY' INPUT TEMPLATE( | ACKQTE ; GENERATED FROM 'ACKQAS VISIT ENTRY' INPUT TEMPLATE( C10S S X="" G:DG(DQ)=X C10F1 K DB | C10S S X="" Q:DG(DQ)=X K DB C10F1 Q | Q C13S S X="" G:DG(DQ)=X C13F1 K DB | C13S S X="" Q:DG(DQ)=X K DB C13F1 Q | Q C18S S X="" G:DG(DQ)=X C18F1 K DB | C18S S X="" Q:DG(DQ)=X K DB C18F1 Q | Q Only in ./VADemo/r1/: ACKQUT1.m diff -y --suppress-common-lines ./VADemo/r1/ACKQUTL3.m ./VADemo/r2/r/ACKQUTL3.m ACKQUTL3 ;HCIOFO/AG - QUASAR Utility Routine ; 12/13/0 | ACKQUTL3 ;HCIOFO/AG -QUASAR Utility Routine ; [ 04/25/ ;;3.0;QUASAR;**5**;Feb 11, 2000 | ;;3.0;QUASAR;;Feb 11, 2000 ; ACKTM - time of visit (reqd) (qsr time . | ; ACKTM - time of vsit (reqd) (qsr time .n ; get the visit data from PCE (places it in ^TMP("PXK | ; get the visit data from PCE (places it in ^TMP("PXK N ACKTMP,ACKVIEN,ACKDT,ACKDT1,ACKIVDT,ACKDIEN,ACKICD, | N ACKTMP,ACKVIEN,ACKDT,ACKIVDT,ACKDIEN,ACKICD,ACKARR . . S ACKDT1=$G(@ACKTMP@(2,ACKICD)) | . . S @ACKTMP@(2,ACKICD,ACKDT)="" ; ICD list includi . . I ('ACKDT1)!(ACKDT1>ACKDT) S @ACKTMP@(2,ACKICD)=A < ; sort new diagnosis list by date | ; update diagnosis history S ACKICD="" F S ACKICD=$O(@ACKTMP@(2,ACKICD)) Q:ACKI < . S ACKDT=@ACKTMP@(2,ACKICD) S @ACKTMP@(3,ACKDT,ACKIC < ; < ; update diagnosis history < S (ACKDT,ACKICD)="" F S ACKDT=$O(@ACKTMP@(3,ACKDT)) | S ACKICD="" F S ACKICD=$O(@ACKTMP@(2,ACKICD)) Q:ACKI . K ACKARR | . S ACKDT="" F S ACKDT=$O(@ACKTMP@(2,ACKICD,ACKDT)) . S ACKARR(509850.22,"?+1,"_ACKPAT_",",.01)=ACKICD | . . K ACKARR . S ACKARR(509850.22,"?+1,"_ACKPAT_",",1)=ACKDT | . . S ACKARR(509850.22,"+1,"_ACKPAT_",",.01)=ACKICD . D UPDATE^DIE("","ACKARR","","") | . . S ACKARR(509850.22,"+1,"_ACKPAT_",",1)=ACKDT > . . D UPDATE^DIE("","ACKARR","","") diff -y --suppress-common-lines ./VADemo/r1/ACKQUTL4.m ./VADemo/r2/r/ACKQUTL4.m ;;3.0;QUASAR;**1,8**;Feb 11, 2000 | ;;3.0;QUASAR;**1**;Feb 11, 2000 S (ICPTVDT,ICDVDT)=ACKVD < ; < S ACKEVENT=1 < . . . W ?19,$$MODTXT^ACKQUTL8(ACKTMOD("DILIST",1,ACKK | . . . W ?19,$$GET1^DIQ(81.3,ACKTMOD("DILIST",1,ACKKEY . S ACKD($S(ACKI?.NP:+ACKI,1:ACKI))=ACKI_$E(" ",1,7 | . S ACKD($S(ACKI?.NP:+ACKI,1:ACKI))=ACKI_$E(" ",1,7 . W !," "_$$GET1^DIQ(81.3,ACK1,.01),?5,$$MODTXT^ACKQ | . W !," "_$$GET1^DIQ(81.3,ACK1,.01),?5,$$GET1^DIQ(81 diff -y --suppress-common-lines ./VADemo/r1/ACKQUTL5.m ./VADemo/r2/r/ACKQUTL5.m ;;3.0;QUASAR;**1,4,6,8**;Feb 11, 2000 | ;;3.0;QUASAR;**1,4**;Feb 11, 2000 N ACKQDDD | S DIC("W")="W "" "",$$GET1^DIQ(81.3,Y,.02),?48,$$GET S ACKQDDD=$G(ACKVD) < S DIC("W")="W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_") < ; < ; < N ACKQDDD < S ACKQDDD=$G(ACKVD) < S DIC("W")="W "" "",$$MODTXT^ACKQUTL8(Y,"_ACKQDDD_") | S DIC("W")="W "" "",$$GET1^DIQ(81.3,Y,.02)" ; < ; < N ACKQCD,ACKQQD,ACKQQCPT,ACKPARAM | N ACKQCD,ACKQQD,ACKQQCPT S ACKPARAM=$P($$CPT^ICPTCOD(ACKQCD,ACKVD),"^",7) I 'A < diff -y --suppress-common-lines ./VADemo/r1/ACKQUTL6.m ./VADemo/r2/r/ACKQUTL6.m ACKQUTL6 ;HCIOFO/BH-A&SP Utilities routine ; 5/6/03 11 | ACKQUTL6 ;HCIOFO/BH-A&SP Utilities routine ; 04/01/99 ;;3.0;QUASAR;**1,7**;Feb 11, 2000 | ;;3.0;QUASAR;**1**;Feb 11, 2000 ; the Appointment time field (#55) of the v | ; the Appopintment time field (#55) of the ; defined. This will only be defined if DUPECHK ret | ; defined. This will onl be defined if DUPECHK retu IDATE(D0,Y) ; Checks that the entered Inactive date fall | IDATE(D0,Y) ; Checks the the entered Inactive date falls ADATE(D0,Y) ; Checks that the entered Active date falls | ADATE(D0,Y) ; Checks the the entered Active date falls b PLIST(ACKPAT,ACKDC) ; Determines if an entry exists in th < ; returns Status as first piece, Problem List IEN as < ; (Status^IEN) < ; Status values - 1=Inactive, 2=Active < N ACKIFN,ACKPLQT < S (ACKIFN,ACKPLQT)=0 < I $D(^AUPNPROB("AC",ACKPAT)) D < . F S ACKIFN=$O(^AUPNPROB("AC",ACKPAT,ACKIFN)) Q:(AC < . .I $D(^AUPNPROB("B",ACKDC,ACKIFN)) S ACKPLQT=ACKIFN < I ACKPLQT Q $S($P($G(^AUPNPROB(ACKPLQT,0)),U,12)="A": < Q 0 < diff -y --suppress-common-lines ./VADemo/r1/ACKQUTL7.m ./VADemo/r2/r/ACKQUTL7.m ;;3.0;QUASAR;**8**;Feb 11, 2000 | ;;3.0;QUASAR;;Feb 11, 2000 . D GETS^DIQ(80,+ACKDC_",",".01;2","E","ACKTGT","ACKM | . D GETS^DIQ(80,+ACKDC_",",".01;2;3","E","ACKTGT","AC . S ACKICD(ACKDN)=ACKDN_U_ACKTGT(80,+ACKDC_",",2,"E") | . S ACKICD(ACKDN)=ACKDN_U_ACKTGT(80,+ACKDC_",",2,"E") ERROR ; Display error message if registration returns error < ; that the Appointment Management database is not ava < ; < N ACKERR < W !!!!," ** The Appointment Management Data Base is < W !!," ** Please report this problem to IRM as soon < W " Press any key to continue." < R ACKERR:DTIME < ; < Q < ; < diff -y --suppress-common-lines ./VADemo/r1/ACKQUTL8.m ./VADemo/r2/r/ACKQUTL8.m ;;3.0;QUASAR;**1,2,8**;Feb 11, 2000 | ;;3.0;QUASAR;**1,2**;Feb 11, 2000 ; < ; < DIAGTXT(ACKQDCDS,ACKCVD) ; Get Short ICD9 Description < N DIAGTXT < I $G(ACKCVD)="" S ACKCVD=$$DATE < ; S DIAGTXT=$$GET1^DIQ(80,ACKQDCDS,3) < S DIAGTXT=$$ICDDX^ICDCODE(ACKQDCDS,ACKCVD) < S DIAGTXT=$P(DIAGTXT,"^",4) < Q DIAGTXT < ; < LDIAGTXT(ACKQDCDS,ACKCVD) ; Get Long ICD9 Description < N LDIAGTXT,LST,RET < S ACKQDCDS=$$CONV(ACKQDCDS) < S LST="LST" < I $G(ACKCVD)="" S ACKCVD=$$DATE < ; S LDIAGTXT=$$GET1^DIQ(80,ACKQDCDS,10) < S RET=$$ICDD^ICDCODE(ACKQDCDS,LST,ACKCVD) < I $P(RET,"^",1)="-1" S LDIAGTXT=$P(RET,"^",2) < I $P(RET,"^",1)'="-1" S LDIAGTXT=LST(1) < Q LDIAGTXT < ; < PROCTXT(ACKQDCDS,ACKCVD) ; Get Short CPT Description < N PROCTXT < I $G(ACKCVD)="" S ACKCVD=$$DATE < ; S PROCTXT=$$GET1^DIQ(81,ACKQDCDS,2) < S PROCTXT=$$CPT^ICPTCOD(ACKQDCDS,ACKCVD) < S PROCTXT=$P(PROCTXT,"^",3) < Q PROCTXT < ; < MODTXT(ACKQMCDS,ACKCVD) ; Get Short CPT Modifier Description < N MODTXT < I $G(ACKCVD)="" S ACKCVD=$$DATE < ; S MODTXT=$$GET1^DIQ(81.3,ACKQMCDS,.02) < S MODTXT=$$MOD^ICPTMOD(ACKQMCDS,"I",ACKCVD) < S MODTXT=$P(MODTXT,"^",3) < Q MODTXT < ; < CONV(ACKQDCDS) ; < N CODE < S CODE=$P($G(^ICD9(ACKQDCDS,0)),"^",1) < Q CODE < ; < DATE() ; < D NOW^%DTC < Q $P(%,".",1) < ; < ; < Only in ./VADemo/r2/r/: AFJXADD1.m diff -y --suppress-common-lines ./VADemo/r1/AFJXMABX.m ./VADemo/r2/r/AFJXMABX.m AFJXMABX ;FO-OAKLAND/GMB-PRINT BY SECTION NETWORK HEAL | AFJXMABX ;FJ/CWS;PRINT BY SECTION NETWORK HEALTH EX's; ;;5.1;Network Health Exchange;**1,2,10,11,15,34,35**; | ;;5.1;Network Health Exchange;**1,2,10,11,15**;Jan 23 ; Totally rewritten 3/2003. (Previously FJ/CWS.) | FIRST U IO(0) W @IOF R !!,"Which requests would you like ; Called from ^AFJXWCPM | S:ANS="" ANS="Y" ENTER ; | D:ANS["Y" YOUR^AFJXMABX D:ANS["A" HERE^AFJXMABX D:ANS N AXNHEDUZ,AXABORT | G FIRST S AXABORT=0 | Q S AXNHEDUZ=$$FIND1^DIC(200,"","X","NETWORK,HEALTH EXC | HERE S CT=0 D START,HEAD,PART2,TEXT,EXIT F D Q:AXABORT | Q . N DIR,X,Y,AXLIST,AXCNT | START ; BEGINNING . W @IOF | ; 612/fyb - remove hard sets, use HOME^%ZIS . S DIR(0)="SO^Y:Your Own;A:All" | D HOME^%ZIS S:'$D(DTIME) DTIME=300 S U="^",(BEND,EMS) . S DIR("A")="Select the requests to list" | S NPX="" F S NPX=$O(^VA(200,"B","NETWORK,HEALTH EXCH . S DIR("B")="Your Own" | Q . D ^DIR I $D(DIRUT) S AXABORT=1 Q | HEAD1 Q:BEND>0 I IOST["C-" R !!,"Press return to continue . D LIST(AXNHEDUZ,Y,.AXLIST,.AXCNT) Q:'AXCNT | ; . D CHOOSE(.AXLIST,AXCNT) | HEAD W @IOF,?10,"THIS REPORT CAN BE SENT TO A PRINTER OR R Q | W !,"Message #",?20,"Subject",?60,"Date Sent",! S J=0 LIST(AXNHEDUZ,AXWHICH,AXLIST,AXCNT) ; | Q N AXMZ,AXREC,AXSUBJ,AXABORT,AXLEN,AXDATE | PART2 S MES="" F I=MES:0 S MES=$O(^XMB(3.7,NHXU,2,1,1,MES)) S (AXCNT,AXMZ,AXABORT)=0 | Q S AXLEN("#")=$L($$BMSGCT^XMXUTIL(AXNHEDUZ,1)) | DAT S MESSA=$P($G(^XMB(3.9,MES,0)),U,1),SNDR=$P($G(^XMB(3 S AXLEN("S")=79-14-AXLEN("#")-2-2+10 | Q D LHDR(AXWHICH,.AXLEN) | WRITE I $E(DAT,4,4)?1A S X=$P(DAT," ",1,3) D ^%DT S DAT=Y,D F S AXMZ=$O(^XMB(3.7,AXNHEDUZ,2,1,1,AXMZ)) Q:'AXMZ | S:DAT'["@" DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT . S AXREC=$G(^XMB(3.9,AXMZ,0)) | WDT Q:(MESSA'["<")!($G(BEND)'="") S CT=CT+1,CT(CT)=MES W . S AXSUBJ=$P(AXREC,U,1) Q:$E(AXSUBJ,19,19)'?1A!(AXSU | Q . I AXWHICH="Y",$P($G(^XMB(3.9,AXMZ,2,1,0)),U,2)'=DUZ | TEXT R !!,"Type the number of the report you would like to . I $Y+5>IOSL D Q:AXABORT | I EMS'?.N W !,"PLEASE TYPE THE NUMBER DISPLAYED" G TE . . I $E(IOST,1,2)="C-" D PAGE^XMXUTIL(.AXABORT) Q:AX | S MESSA=$P($G(^XMB(3.9,CT(EMS),0)),U,1) ;CFB 12/15/95 . . D LHDR(AXWHICH,.AXLEN) | I MESSA'["<" W !,"This does not appear to be a Networ . S AXDATE=$$DATE^XMXUTIL2(AXREC) | TY S END=$P($G(^XMB(3.9,CT(EMS),2,0)),U,3) K TYPE,WD . S AXCNT=AXCNT+1,AXLIST(AXCNT)=AXMZ | ONE W !! S DIC("A")="Choose type: ",DIC="^AFJ(537015,",DI . W !,$J(AXCNT,AXLEN("#"))," ",AXDATE," ",$E(AXSUBJ | Q Q | BEGIN N %A,%E,%X D DT^DICRW S %ZIS="MFQ" D ^%ZIS Q:POP LHDR(AXWHICH,AXLEN) ; | ; 612/fyb - thru BEGIN+8 - Queueing/Browser support W @IOF,$S(AXWHICH="Y":"Your",1:"All")," NHE Results" | I $D(IO("Q")) K IO("Q"),ZTI,ZTSK D Q W !," #",?AXLEN("#")+2,"Date Sent Subject" | . S ZTIO=ION_";"_IOST,ZTSAVE("*")="",ZTRTN="PRINT^AFJ W !,$$REPEAT^XLFSTR("=",79) | . D ^%ZTLOAD I $D(ZTSK) W !,"Queued as Task #",ZTSK Q | . K ZTDESC,ZTIO,ZTSAVE,ZTSK CHOOSE(AXLIST,AXCNT) ; | U IO D PRINT,^%ZISC ; G ONE Q; 612/fyb N DIR,X,Y,AXMZ,DIC,D,AXCOMP,AXABORT | Q S AXABORT=0 | SECO S MES="" F I=MES:0 S MES=$O(^XMB(3.7,NHXU,2,1,1,MES)) W ! | Q S DIR(0)="NO^1:"_AXCNT | FDAT S MESSA=$P($G(^XMB(3.9,MES,0)),U,1),SNDR=$P($G(^XMB(3 S DIR("A")="Select the report you'd like to print" | Q D ^DIR I $D(DIRUT) S AXABORT=1 Q | FRIT Q:YOU'=DUZ S AXMZ=AXLIST(Y) | I $E(DAT,4,4)?1A S X=$P(DAT," ",1,3) D ^%DT S DAT=Y,D F D Q:AXABORT | S:DAT'["@" DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT . K DIC,X,Y,D | FWDT Q:(MESSA'["<")!($G(BEND)'="") S CT=CT+1,CT(CT)=MES W . W ! | Q . S DIC("A")="Select Component: " | PRINT S (FLAGYES,PAGE)=0 F I=4:1:END S REC=$G(^XMB(3.9,CT(E . S DIC(0)="AEQZ",D="C" ; Lookup using only the C xre | I FLAGYES=0 W !!," Sorry! That component not cont . S DIC="^AFJ(537015," | Q . D IX^DIC I Y<0 S AXABORT=1 Q | PRT2 Q:(REC'[PTY)!(I=END) . S AXCOMP=Y(0,0) | D HD3 . N AXSAVE,I,ZTSK | F I=I:1:END S REC=$G(^XMB(3.9,CT(EMS),2,I,0)) Q:$E(RE . W ! | S FLAGYES=1 . F I="AXCOMP","AXMZ" S AXSAVE(I)="" | Q . D EN^XUTMDEVQ("PRINT^AFJXMABX","AFJX Print Complete | HEAD2 I IOST["C-" R !!!,"Press return to continue or ""^"" . I $D(ZTSK) W !,"Print queued. Task number: ",ZTSK | HD3 S PAGE=PAGE+1 W @IOF,?70,"PAGE ",PAGE,! I $G(CT(EMS)) Q | Q PRINT ; We assume that there may be more than 1 of the same | EXIT K YOU,BEND,CT,DAT,EMS,END,FLAGYES,MES,MESSA,NUM,PAGE, ; and that they are not necessarily consecutive. | YOUR S CT=0 D START,HEAD,SECO,TEXT,EXIT N AXI,AXTXT,AXPAGE,AXABORT,AXFOUND,AXDASH | Q S (AXI,AXPAGE,AXABORT)=0,AXI=3,AXFOUND=0,AXDASH=$$REP | TRIM(X,Y) ;CFB/TUSC/SF ENSURE NO LINE LONGER THAN Y D PHDR(AXMZ,.AXPAGE) W ! | Q $E(X,$L(X)-Y+1,$L(X)) F S AXI=$O(^XMB(3.9,AXMZ,2,AXI)) Q:'AXI S AXTXT=$G( | ; . Q:AXTXT'[AXCOMP Q:$E(AXTXT,71,78)'["------" < . S AXFOUND=1 < . F D Q:'AXI!AXABORT I $E(AXTXT,71,78)["------",AX < . . I $Y+3+($E(IOST,1,2)="C-")>IOSL D Q:AXABORT < . . . I $E(IOST,1,2)="C-" W ! D PAGE^XMXUTIL(.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 < Q < ; We assume that there may be more than 1 of the same < ; 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 < ;I 'AXI W !,"Component '",AXCOMP,"' is not in this re < ;W !,AXTXT < ;F S AXI=$O(^XMB(3.9,AXMZ,2,AXI)) Q:'AXI S AXTXT=$G < ;. I $Y+3+($E(IOST,1,2)="C-")>IOSL D Q:AXABORT < ;. . I $E(IOST,1,2)="C-" W ! D PAGE^XMXUTIL(.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 print < . W $C(13) < . S AXPAGE(0)="" < W "NHE Results for ",$$NAME^XMXUTIL(DUZ),?70,$J("PAGE < F AXI=2,3 I $G(^XMB(3.9,AXMZ,2,AXI,0))'="" W !,^(0) < W !,$$REPEAT^XLFSTR("=",79) < Q < diff -y --suppress-common-lines ./VADemo/r1/AFJXMBOX.m ./VADemo/r2/r/AFJXMBOX.m AFJXMBOX ;FO-OAKLAND/GMB-SEARCH for PREVIOUSLY COMPLET | AFJXMBOX ;FJ/CWS;SEARCH for PREVIOUSLY COMPLETED NETWO ;;5.1;Network Health Exchange;**2,11,34**;Jan 23, 199 | ;;5.1;Network Health Exchange;**2,11**;Jan 23, 1996 ; Totally rewritten 3/2003. (Previously FJ/CWS.) | ; 612/fyb ; Called from ^AFJXWCP1 & ^AFJXWCPM | FIRST W @IOF R !!,"Which requests would you like Y) Your ENTER ; | S:ANS="" ANS="Y" N AXNHEDUZ,AXABORT | D:ANS["Y" ^AFJXPNHF D:ANS["A" HERE^AFJXMBOX D:ANS["N" S AXABORT=0 | G FIRST S AXNHEDUZ=$$FIND1^DIC(200,"","X","NETWORK,HEALTH EXC < 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 < 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 < . . 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( < . I $Y+3+($E(IOST,1,2)="C-")>IOSL D Q:AXABORT < . . I $E(IOST,1,2)="C-" W ! D PAGE^XMXUTIL(.AXABORT) < . . D PHDR^AFJXMABX(AXMZ,.AXPAGE) < . W !,AXTXT < I 'AXABORT,$E(IOST,1,2)="C-" D PAGE^XMXUTIL(.AXABORT) < > 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) > S NPX="" F S NPX=$O(^VA(200,"B","NETWORK,HEALTH EXCH > Q > HEAD1 Q:BEND>0 I IOST["C-" R !!,"Press return to continue > HEAD W @IOF,?10,"THIS REPORT CAN BE SENT TO A PRINTER OR R > W !,"Message #",?20,"Subject",?60,"Date Sent",! S J=0 > Q > PART2 S MSG="" F I=MSG:0 S MSG=$O(^XMB(3.7,NHXU,2,1,1,MSG)) > Q > DAT ; > S MESSA=$P($G(^XMB(3.9,MSG,0)),U,1),SNDR=$P($G(^XMB(3 > Q > WRITE I $E(DAT,4,4)?1A S X=$P(DAT," ",1,3) D ^%DT S DAT=Y,D > S:DAT'["@" DAT=$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT > WDT Q:(MESSA'["<")!($G(BEND)'="") S CT=CT+1,CT(CT)=MSG W > Q > TEXT W ! S DIR("A")="Type one number eg. 1 or up to ten nu > ;S ONE=$P(EMS,",",1),TWO=$P(EMS,",",2),THR=$P(EMS,"," > S Y=0 F X="ONE","TWO","THR","FUR","FIV","SIX","SEV"," > S:ONE'="" ^TMP("NHMP",$J,ONE)="" S:TWO'="" ^TMP("NHMP > S:SEV'="" ^TMP("NHMP",$J,SEV)="" S:EIG'="" ^TMP("NHMP > ; > BEGIN N %A,%E,%X D DT^DICRW S %ZIS="MFQ" D ^%ZIS Q:POP > ; 612/fyb - through BEGIN+8. Queueing/Browser Suppor > I $D(IO("Q")) K IO("Q"),ZTI,ZTSK D Q > . S ZTIO=ION_";"_IOST,ZTSAVE("*")="",ZTRTN="PRINT^AFJ > . 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 > 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 Networ > Q:'$D(^XMB(3.9,MES,2,1,0)) S PAGE=1 W @IOF,?70,"PAGE > Q > HEAD2 I IOST["C-" R !!!,"Press return to continue or ""^"" > S PAGE=PAGE+1 W @IOF,?70,"PAGE ",PAGE I $G(MES),$G(^X > Q > EXIT K ^TMP("NHMP",$J),CT,DAT,DIR,EIG,EMS,FIV,FUR,MES,MESS Only in ./VADemo/r2/r/: AFJXPNHF.m Only in ./VADemo/r2/r/: AFJXPNHI.m Only in ./VADemo/r2/r/: AFJXREW.m diff -y --suppress-common-lines ./VADemo/r1/AFJXSFAL.m ./VADemo/r2/r/AFJXSFAL.m ;;5.1;Network Health Exchange;**31,32,33,34**;Jan 23, | ;;5.1;Network Health Exchange;**31,32,33**;Jan 23, 19 D EN^XUTMDEVQ("PRINT^AFJXSFAL","AFJX Print NHE Inquir | D EN^XUTMDEVQ("PRINT^AFJXSFAL","AFJX Print Network He S AXI=3,(AXABORT,AXPAGE)=0 | S (AXI,AXABORT)=0,AXPAGE=1 I $E(IOST,1,2)="C-" W @IOF | I $G(IOST)["C-" W @IOF . I $Y+3+($E(IOST,1,2)="C-")>IOSL D Q:AXABORT | . I $Y+3+($G(IOST)["C-")>IOSL D Q:AXABORT . . I $E(IOST,1,2)="C-" W ! D PAGE^XMXUTIL(.AXABORT) | . . I $G(IOST)["C-" W ! D PAGE^XMXUTIL(.AXABORT) Q:AX S AXPAGE=AXPAGE+1 | N I W "NHE Results for ",$$NAME^XMXUTIL(DUZ),?70,$J("Page | W "NHE Results for ",$$NAME^XMXUTIL(DUZ),?70,"Page ", N I S I=0 F S I=$O(AXHDR(I)) Q:'I W !,AXHDR(I) | S I=0 F S I=$O(AXHDR(I)) Q:'I W !,AXHDR(I) W !,$$REPEAT^XLFSTR("=",79) | W !,$$REPEAT^XLFSTR("-",79) Only in ./VADemo/r2/r/: AFJXWCBP.m diff -y --suppress-common-lines ./VADemo/r1/AFJXWCP1.m ./VADemo/r2/r/AFJXWCP1.m ;;5.1;Network Health Exchange;**1,31,34**;Jan 23, 199 | ;;5.1;Network Health Exchange;**1,31**;Jan 23, 1996 D:Y ENTER^AFJXMBOX | D:Y FIRST^AFJXMBOX Only in ./VADemo/r2/r/: AFJXWCPB.m Only in ./VADemo/r2/r/: AFJXWCPD.m diff -y --suppress-common-lines ./VADemo/r1/AFJXWCPM.m ./VADemo/r2/r/AFJXWCPM.m ;;5.1;Network Health Exchange;**6,22,31,33,34**;Jan 2 | ;;5.1;Network Health Exchange;**6,22,31,33**;Jan 23, D ENTER^AFJXMBOX | D ^AFJXMBOX > K ANS,BEND,I,J,K,MSG,NHXU,NPX,X,Y,Z,ZTRTN D ENTER^AFJXMABX | D ^AFJXMABX > K J,K,NHXU,NPX,ANS,I,ITR,ZTRTN Only in ./VADemo/r2/r/: AFJXWCPY.m Only in ./VADemo/r1/: ALPBBK.m diff -y --suppress-common-lines ./VADemo/r1/ALPBCBU.m ./VADemo/r2/r/ALPBCBU.m ALPBCBU ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 ;5/2/20 | ALPBCBU ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 ;5/2/ N ALPRSLT < ;I $P(ALPRSLT,U,2)'="" D ERRLG | I $P(ALPRSLT,U,2)'="" D ERRLG N ALPRSLT < NURV(ALDFN,ALPORD) ;Use this entry to send verifying nur < 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 ONLI < 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 < N ALPRSLT < S XQAMSG="BCBU Contingency Error" | S XQAMSG="BCBU Contingecy Error" W @IOF,!,"PSB BCBU Contingency Error",! | W @IOF,!,"PSB BCBU Contingecy Error",! diff -y --suppress-common-lines ./VADemo/r1/ALPBELOG.m ./VADemo/r2/r/ALPBELOG.m ALPBELOG ;OIFO-DALLAS MW,SED,KC - BCBU LOG PROCESSOR ; | ALPBELOG ;emc,ets/mw,sd,kc-error log processor ;01/01/ I $O(^ALPB(53.71,"C",""))="" D Q | I +$O(^ALPB(53.71,"C",0))'>0 D Q S ALPBLINE=0 | S (ALPBIEN,ALPBLINE)=0 S ALPBIEN="" | F S ALPBIEN=$O(^ALPB(53.71,"C",ALPBIEN)) Q:'ALPBIEN F S ALPBIEN=$O(^ALPB(53.71,"C",ALPBIEN)) Q:ALPBIEN=" | .D CLEAN^ALPBUTL1(ALPBIEN) .I ALPBIEN>0 D CLEAN^ALPBUTL1(ALPBIEN) | .I '$D(^ALPB(53.7,ALPBIEN,0)) Q .I ALPBIEN>0&('$D(^ALPB(53.7,ALPBIEN,0))) Q < .I ALPBPDAT="" S ALPBPDAT="SYSTEM/FILER ERROR^" | .I ALPBPDAT="" K ALPBPDAT Q .S ALPBDATA(ALPBLINE,0)=" "_$P(ALPBPDAT,U) | .S ALPBDATA(ALPBLINE,0)=" "_$P(ALPBPDAT,U)_" (SSN: "_ .I $P(ALPBPDAT,U,2)'="" S ALPBDATA(ALPBLINE,0)=ALPBDA < diff -y --suppress-common-lines ./VADemo/r1/ALPBFRM1.m ./VADemo/r2/r/ALPBFRM1.m ALPBFRM1 ;OIFO-DALLAS MW,SED,KC -STANDARD PRINT FORMAT | ALPBFRM1 ;emc,ets/mw,sd,kc-standard print formatting u ; RESULTS = an array passed by reference into which t | ; RESULTS = an array passed by reference into which t ; entry is set up returns a formatted array | ; entry is set up returns a formated array N ALPBADM,ALPBDAYS,ALPBDRUG,ALPBIBOX,ALPBNBOX,ALPBPBO | N ALPBADM,ALPBDAYS,ALPBIBOX,ALPBNBOX,ALPBPBOX,ALPBSTO ; to use BOLD, comment out the next line and remove c < ; 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 < I DAYS=3 S RESULTS(2)=RESULTS(2)_" Notes" | ;I ALPBADM<16&(DAYS=3) S RESULTS(2)=RESULTS(2)_" No > ; line 5... > ; order number and type... > S RESULTS(5)=" Order #: "_$P(DATA(0),"^") > S RESULTS(5)=$$PAD^ALPBUTL(RESULTS(5),25)_"Type: "_$$ > S RESULTS(6)=" Status: "_$P(DATA(0),"^",3) S LINE=4 | S LINE=6 ..S ALPBDRUG=$G(BOLDON)_$P(DATA(7,ALPBX,0),"^",2)_$G( | ..S RESULTS(LINE)=$G(RESULTS(LINE))_$P(DATA(7,ALPBX,0 ..;S RESULTS(LINE)=$G(RESULTS(LINE))_$P(DATA(7,ALPBX, < ..S RESULTS(LINE)=$G(RESULTS(LINE))_ALPBDRUG < ..K ALPBDRUG < ..S ALPBDRUG=$P(DATA(8,ALPBX,0),"^",2) | ..S RESULTS(LINE)=RESULTS(LINE)_$P(DATA(8,ALPBX,0),"^ ..I $P(DATA(8,ALPBX,0),"^",3)'=""&(ALPBDRUG'[$P(DATA( | ..I $P(DATA(8,ALPBX,0),"^",3)'=""&($P(DATA(8,ALPBX,0) ..S ALPBDRUG=$G(BOLDON)_ALPBDRUG_$G(BOLDOFF) < ..S RESULTS(LINE)=RESULTS(LINE)_ALPBDRUG < ..K ALPBDRUG < ..S ALPBDRUG=$P(DATA(9,ALPBX,0),"^",2) | ..S RESULTS(LINE)=RESULTS(LINE)_$P(DATA(9,ALPBX,0),"^ ..I $P(DATA(9,ALPBX,0),"^",3)'=""&(ALPBDRUG'[$P(DATA( | ..I $P(DATA(9,ALPBX,0),"^",3)'=""&($P(DATA(9,ALPBX,0) ..S ALPBDRUG=$G(BOLDON)_ALPBDRUG_$G(BOLDOFF) < ..S RESULTS(LINE)=RESULTS(LINE)_ALPBDRUG < ..K ALPBDRUG < ;Set PRN Flag < S ALPBPRNG=0 < S:$P($G(DATA(4)),"^",3)["PRN" ALPBPRNG=1 < ; order number and type... < S LINE=LINE+1 < S RESULTS(LINE)=" Order #: "_$P(DATA(0),"^") < S RESULTS(LINE)=$$PAD^ALPBUTL(RESULTS(LINE),25)_"Type < ; order status... < S LINE=LINE+1 < S RESULTS(LINE)=" Status: "_$P($P(DATA(0),"^",3) < ;S ALPBPRN=ALPBADM+4 < .S ALPBPRN=I+3 < ; if PRN med, add line for documenting effectiveness. < I +ALPBPRNG D < .S ALPBFLG=0,ALPBPRN=ALPBPRN+1 < .S:'$D(RESULTS(ALPBPRN)) RESULTS(ALPBPRN)=" ",ALPBFLG < .S RESULTS(ALPBPRN)=$$PAD^ALPBUTL(RESULTS(ALPBPRN),63 < .S:ALPBFLG LINE=LINE+1 < diff -y --suppress-common-lines ./VADemo/r1/ALPBFRM2.m ./VADemo/r2/r/ALPBFRM2.m ALPBFRM2 ;OIFO-DALLAS MW,SED,KC-STANDARD SCREEN DISPLA | ALPBFRM2 ;emc,ets/mw,sd,kc-standard screen display for S RESULTS(3)=" Status: "_$P($P(DATA(0),"^",3)," | S RESULTS(3)=" Status: "_$P(DATA(0),"^",3) S RESULTS(3)="This record last updated: "_$S($P(DATA( | S RESULTS(3)="BCBU Record Last Updated: "_$S($P(DATA( diff -y --suppress-common-lines ./VADemo/r1/ALPBFRMU.m ./VADemo/r2/r/ALPBFRMU.m ALPBFRMU ;OIFO-DALLAS MW,SED,KC-STANDARD PRINT FORMATT | ALPBFRMU ;emc,ets/mw,sd,kc-standard print formatting u ; DATA = an array passed by reference containing t | ; DATA = an array passed by reference containing the ; a patient's record in ^ALPB(53.7,...) | ; be formated ; PG = page number to use | ; PG = page number to use N ALPBALG,ALPBALGL,ALPBALGX,ALPBX,LINE | N ALPBCNT,ALPBX,LINE S RESULTS(4)=$$PAD^ALPBUTL(RESULTS(4),12)_"This recor | S RESULTS(4)=$$PAD^ALPBUTL(RESULTS(4),12)_"BCBU Recor .S RESULTS(LINE)="" | .S RESULTS(LINE)="Allergies: " .S ALPBALGX="Allergies: " < .S ALPBALGL=$L(ALPBALGX)-1 < ..S ALPBALG=$P($G(DATA(1,ALPBX,0)),"^",2) | ..S ALPBCNT=ALPBCNT+1 ..I ALPBALG="" K ALPBALG Q | ..I ALPBCNT>5 D ..I $L(ALPBALGX_ALPBALG_"; ")>90 D < ...S RESULTS(LINE)="" | ...S RESULTS(LINE)=" " ...S ALPBALGX="" | ...S RESULTS(LINE)=$$PAD^ALPBUTL(RESULTS(LINE),12) ...S ALPBALGX=$$PAD^ALPBUTL(ALPBALGX,ALPBALGL) | ..S RESULTS(LINE)=RESULTS(LINE)_$P($G(DATA(1,ALPBX,0) ..S ALPBALGX=ALPBALGX_ALPBALG_$S(+$O(DATA(1,ALPBX)):" | ..I +$O(DATA(1,ALPBX)) S RESULTS(LINE)=RESULTS(LINE)_ ..S RESULTS(LINE)=ALPBALGX < diff -y --suppress-common-lines ./VADemo/r1/ALPBGEN1.m ./VADemo/r2/r/ALPBGEN1.m ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages | ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages > ;I "B01B02"'[$G(ALPBMT) G PERR > . ;Verify SSN H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN | H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU","APPLICATION",DA diff -y --suppress-common-lines ./VADemo/r1/ALPBGEN2.m ./VADemo/r2/r/ALPBGEN2.m ALPBGEN2 ;SFVAMC/JC - Init New Person Data on Workstat | ALPBGEN2 ;SFVAMC/JC - Init New Person Data on Workstat S (ALPBK)=0,ALPBJ="" F S ALPBJ=$O(^VA(200,ALPBJ)) Q: | S (ALPBK,ALPBJ)=0 F S ALPBJ=$O(^VA(200,ALPBJ)) Q:ALP . Q:+ALPBJ<1 | . Q:ALPBJ<1 diff -y --suppress-common-lines ./VADemo/r1/ALPBGEN.m ./VADemo/r2/r/ALPBGEN.m ALPBGEN ;SFVAMC/JC - Build HL7 PMU messages ;10/08/2003 14:1 | ALPBGEN ;SFVAMC/JC - Build HL7 PMU messages ;04/18/2003 12:4 ;;3.0;BAR CODE MED ADMIN;**7**;May 2002 | ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; < ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL < Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLI < ; < ;SFVAMC/JC - 10/8/03 ADD CHECK FOR BCMA USER STATUS < Q:+$$ISBCMA^ALPBGEN2(XUIEN)<1 < ; < S EC=$G(HL("ECH")) Q:EC="" ;Encoding Characters | S EC=$G(HL("ECH")) Q:EC="" ;Encoding Charaters S RS=$E(EC,2) ;Repetition separator | S RS=$E(EC,2) ;Repitition separator S EFS=ESC_"F"_ESC ;escaped field separator | S EFS=ESC_"F"_ESC ;escaped field sep S ECS=ESC_"S"_ESC ;escaped component separator | S ECS=ESC_"S"_ESC ;escaped component sep S ERS=ESC_"R"_ESC ; escaped Repetition separator | S ERS=ESC_"R"_ESC ; escaped repitition sep N ALPBSSN,STF S STF="STF" | N SSN,STF S STF="STF" S ALPBSSN=$TR($G(XUSR("ALPBSSN")),"-","") S:+ALPBSSN | S SSN=$TR($G(XUSR("SSN")),"-","") S:+SSN SSN=$$M10^HL S $P(STF,FS,3)=ALPBSSN_CS_"USSSA"_CS_"SS"_RS_$$ESC($G | S $P(STF,FS,3)=SSN_CS_"USSSA"_CS_"SS"_RS_$$ESC($G(XUS . K DIC,D,X,Y | . Q:'$D(^DG(40.8,"AD",ALPBDIV)) ;does institution li . S DIC="^DG(40.8,",D="AD",X=ALPBDIV,DIC(0)="XN" | . S ALPBDIV1=$O(^DG(40.8,"AD",ALPBDIV,0)) ;MC Div ien . D IX^DIC | . K HLL D GET^ALPBPARM(.HLL,ALPBDIV1) . Q:+Y'>0 < . S ALPBDIV1=+Y < . K DIC,D,X,Y < . D GET^ALPBPARM(.HLL,ALPBDIV1) < diff -y --suppress-common-lines ./VADemo/r1/ALPBHL1.m ./VADemo/r2/r/ALPBHL1.m ALPBHL1 ;OIFO-DALLAS MW,SED,KC - BCBU main HL7 message proces | ALPBHL1 ;emc,ets/mw,sd,kc-main HL7 message processor ;01/01/0 ;;3.0;BAR CODE MED ADMIN;**7**;May 2002 | ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; using patient's DFN, get BCBU record number... | ; using patient's SSN, get patient's record number... S ALPBIEN=0 | S DIC="^ALPB(53.7," I $D(^ALPB(53.7,ALPBPDFN)) S ALPBIEN=ALPBPDFN | S DIC(0)="MZ" > S X=ALPBPSSN > D ^DIC K DIC > S ALPBIEN=+Y > .S DIC("DR")="1///^S X=ALPBPSSN;2///^S X=ALPBPDOB;3// ; 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(ALPBIE < K ALPBFERR,ALPBFILE < ; < ; file, delete its drug(s), additive(s) and/or soluti | ; file, delete it so that it can be rebuilt... ; they will be rebuilt by the other segments in this | I '+$G(ALPBMLOG)&(ALPBOIEN>0) D I +$G(ALPBMLOG)=0&(ALPBOIEN>0) D CLORD^ALPBUTL2(ALPBI | .D DELORD^ALPBUTL(ALPBIEN,ALPBOIEN) > .S ALPBOIEN=0 ..;chech for any continuation lines < ..S J=0 F S J=$O(ALPBMTXT(I,J)) Q:'J S ALPBDATA=ALP < diff -y --suppress-common-lines ./VADemo/r1/ALPBHL1U.m ./VADemo/r2/r/ALPBHL1U.m ALPBHL1U ;OIFO-DALLAS MW,SED,KC -HL7 MESSAGE SEGMENT P | ALPBHL1U ;emc,ets/mw,sd,kc-HL7 message segment parser ;;3.0;BAR CODE MED ADMIN;**7**;May 2002 | ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ..S ALPBTEXT(1)="CAUTION! THIS IS A PENDING ORDER :: | ..S ALPBTEXT(1)="CAUTION! THIS IS A PENDING ORDER :: S ALPBSCHD=$P(ALPBX,CS,2) | S ALPBSCHD=$P($P(ALPBX,CS,2),SCS) S ALPBFILE(53.702,ALPBFIEN,7.3)=$P($P(DATA,FS,22),CS, | S ALPBFILE(53.702,ALPBFIEN,7.3)=$P($P(ALPBX,CS,2),SCS diff -y --suppress-common-lines ./VADemo/r1/ALPBIND.m ./VADemo/r2/r/ALPBIND.m ALPBIND ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 INIT ;5 | ALPBIND ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 INIT > Q K PID,PV1,^TMP("PSJ",$J),^TMP("PSJBU",$J) | K PID,PV1,^TMP("PSJ",$J),^TMP("PSJBU") S X=$S(X>0:"T-"_X,1:"T-30") | S X=$S(X>0:"T-"_X,1:"T-90") S MSCTR=$E(ALPB(MSH),4,8),ALPORD=ALPORDR | S MSCTR=$E(ALPB(MSH),4,8) S X=$S(X>0:"T-"_X,1:"T-15") | S X=$S(X>0:"T-"_X,1:"T-30") diff -y --suppress-common-lines ./VADemo/r1/ALPBIN.m ./VADemo/r2/r/ALPBIN.m ALPBIN ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 INIT ;5 | ALPBIN ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 INIT ;I $D(DIRUT)!$D(ALPHLL) W !!,"No Selected Workstatio | ;I $D(DIRUT)!$D(ALPHLL) W !!,"No Selected Workstaion I '$D(ALPBANS)!$D(ALPHLL) W !!,"No Selected Workstati | I '$D(ALPBANS)!$D(ALPHLL) W !!,"No Selected Workstaio diff -y --suppress-common-lines ./VADemo/r1/ALPBINP.m ./VADemo/r2/r/ALPBINP.m ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/ | ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA-BACKUP INPT TO HL7 ;5/2/ ;Also the patient must have an inpatient status | ;Also the patient must have a inpatient status I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatien | I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not a Inpatient SEED ;Entry point for ^ALPBIND | SEED ;Entry point for ^ALPBINT . 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 < I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Ba | S HLA("HLS",PID)=$$EN^VAFHLPID($P(HLA("HLS",PID),HLFS I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PI < S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") < ;Fix RXE segement for Administration Type < D RXE < . S ALPADR="" < . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR < . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL | . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_$E($P(GMRAL(ALPI), 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 < S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6) | S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,4) ; < 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 Admissio < S ZTIO="",ZTSAVE("ALDFN")="" < D ^%ZTLOAD < K ZTIO,ZTDESC,ZTRTN,ZTSK < Q < I $G(ALPTT)="ADMISSION" D ADMQ < diff -y --suppress-common-lines ./VADemo/r1/ALPBPALL.m ./VADemo/r2/r/ALPBPALL.m ALPBPALL ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA B | ALPBPALL ;emc/MW,SD,KC-print 3-day MAR BCMA backup rep diff -y --suppress-common-lines ./VADemo/r1/ALPBPARM.m ./VADemo/r2/r/ALPBPARM.m ALPBPARM ;SFVAMC/JC - Parameter Definitions ;05/02/200 | ALPBPARM ;SFVAMC/JC - Parameter Definitions ;03/07/200 . Q:$P(LST(X),U,2)']"" < . N LNK870 S LNK870=$P(LST(X),U,2) Q:$E(LNK870,1,2)=" < diff -y --suppress-common-lines ./VADemo/r1/ALPBPPAT.m ./VADemo/r2/r/ALPBPPAT.m ALPBPPAT ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCBU B | ALPBPPAT ;emc/mw,sd,kc-print 3-day MAR BCMA backup rep diff -y --suppress-common-lines ./VADemo/r1/ALPBPWRD.m ./VADemo/r2/r/ALPBPWRD.m ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA B | ALPBPWRD ;emc/MW,SD,KC-print 3-day MAR BCMA backup rep ..S ZTRTN="DQ^ALPBPWRD" | ..S ZTRTN="DQ^ALPBHL2" Only in ./VADemo/r2/r/: ALPBSID.m diff -y --suppress-common-lines ./VADemo/r1/ALPBSP1.m ./VADemo/r2/r/ALPBSP1.m ALPBSP1 ;OIFO-DALLAS MW,SED,KC-LIST AND SELECT PATIENT'S ORDE | ALPBSP1 ;emc,ets/mw,sd,kc-list and select patient's orders ;0 .I $G(ALPBORDS(ALPBX,2))="" S ALPBORDS(ALPBX,2)="XX" | .S ALPBORDS("B",$G(ALPBORDS(ALPBX,2),"XX"),ALPBORDS(A .S ALPBORDS("B",ALPBORDS(ALPBX,2),ALPBORDS(ALPBX),ALP < ...I $G(ALPBORDS(ALPBX,4))'="" D < ....S ALPBY=$P(ALPBORDS(ALPBX,4),"^",1,3) < ....S ALPBY=$TR(ALPBY,"^"," ") < ....S ALPBDATA=ALPBDATA_" ("_ALPBY_")" < ....K ALPBY < diff -y --suppress-common-lines ./VADemo/r1/ALPBSP2.m ./VADemo/r2/r/ALPBSP2.m ALPBSP2 ;OIFO-DALLAS MW,SED,KC-SHOW SELECTED PATIENT ORDERS(S | ALPBSP2 ;emc,ets/mw,sd,kc-show selected patient order(s) ;01/ diff -y --suppress-common-lines ./VADemo/r1/ALPBSPAT.m ./VADemo/r2/r/ALPBSPAT.m ALPBSPAT ;OIFO-DALLAS MW,SED,KC-SELECT AND SHOW PATIEN | ALPBSPAT ;emc,ets/mw,sd,kc-select and show patient ord diff -y --suppress-common-lines ./VADemo/r1/ALPBSWRD.m ./VADemo/r2/r/ALPBSWRD.m ALPBSWRD ;OIFO-DALLAS MW,SED,KC - display BCBU records | ALPBSWRD ;emc/MW,SD,KC-display BCMA records for patien Only in ./VADemo/r2/r/: ALPBT1.m Only in ./VADemo/r2/r/: ALPBTST.m diff -y --suppress-common-lines ./VADemo/r1/ALPBUTL1.m ./VADemo/r2/r/ALPBUTL1.m ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUN | ALPBUTL1 ;emc,ets/maw,sd,kc-BCMA backup report functio I $G(ST)="" Q "" | I ST="" Q "" diff -y --suppress-common-lines ./VADemo/r1/ALPBUTL2.m ./VADemo/r2/r/ALPBUTL2.m ALPBUTL2 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUN | ALPBUTL2 ;emc,ets/maw,sd,kc-BCBU functions and utiliti ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 | ;;2.0;BAR CODE MED ADMIN;**17**;May 2002 ; < CLORD(IEN,OIEN) ; delete drug(s), additive(s) and/or solution < ; 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:'XIE < ..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 < Only in ./VADemo/r1/: ALPBUTL3.m diff -y --suppress-common-lines ./VADemo/r1/ALPBUTL.m ./VADemo/r2/r/ALPBUTL.m ALPBUTL ;OIFO-DALLAS MW,SED,KC-BCMA BCBU REPORT FUNCTIONS AND | ALPBUTL ;emc,ets/maw,sd,kc-BCMA backup report functions and u S RESULT=STRING F I=$L(RESULT):1:SPACES S RESULT=RESU | S RESULT=STRING > F I=$L(RESULT):1:SPACES S RESULT=RESULT_" " S (RESULT,TODAY)=+$E(START,6,7) | S TODAY=+$E(START,6,7) > S RESULT=TODAY S DIM=$$DIM(START),TODAY=+$E(START,6,7),MON1=+$E(STAR | S DIM=$$DIM(START) S (RESULT,MON)=$$MONN(MON1) | S TODAY=+$E(START,6,7) > S MON1=+$E(START,4,5) > S MON=$$MONN(MON1) > S RESULT=MON .S MON=$$MONN(MON1),RESULT=RESULT_MON | .S MON=$$MONN(MON1) .S DIM=$$DIM($E(START,1,3)_$S(MON1<10:"0"_MON1,1:MON1 | .S RESULT=RESULT_MON > .S DIM=$$DIM($E(START,1,3)_$S(MON1<10:"0"_MON1,1:MON1 > .S TODAY=0 S RESULT=$E(RESULT,1,I),RESULT=$TR(RESULT,XSPACE,XSTR | S RESULT=$E(RESULT,1,I) > S RESULT=$TR(RESULT,XSPACE,XSTRIP) S RESULTS(0)=" "_$E(START,4,5)_"/"_$E(START,6,7)_" ", | S RESULTS(0)=" "_$E(START,4,5)_"/"_$E(START,6,7)_" " > S RESULTS(1)=START .S X1=START,X2=I | .S X1=START > .S X2=I .S RESULTS(I+1)=X,RESULTS(0)=RESULTS(0)_" "_$E(X,4,5) | .S RESULTS(I+1)=X > .S RESULTS(0)=RESULTS(0)_" "_$E(X,4,5)_"/"_$E(X,6,7)_ ..S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBW | ..S RESULTS(0)=RESULTS(0)+1 > ..S RESULTS(RESULTS(0))=ALPBWARD ..S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPBW | ..S RESULTS(0)=RESULTS(0)+1 > ..S RESULTS(RESULTS(0))=ALPBWARD ...S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPB | ...S RESULTS(0)=RESULTS(0)+1 > ...S RESULTS(RESULTS(0))=ALPBWARD ...S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=ALPB | ...S RESULTS(0)=RESULTS(0)+1 > ...S RESULTS(RESULTS(0))=ALPBWARD .S ORDERDAT(4)=$G(^ALPB(53.7,IEN,2,ORDERIEN,4)) < .;S RESULTS(ORDERIEN,4)=$P($G(ORDERDAT(4)),"^",3) < .S RESULTS(ORDERIEN,4)=$G(ORDERDAT(4)) < S DA=IEN,DIK="^ALPB(53.7," | S DA=IEN > S DIK="^ALPB(53.7," 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," Only in ./VADemo/r1/: ANRVOA.m Only in ./VADemo/r1/: ANRVOB.m diff -y --suppress-common-lines ./VADemo/r1/AUPNSICD.m ./VADemo/r2/r/AUPNSICD.m AUPNSICD ;OHPRD/LAB - Screen Purpose of Visit/ICD9 cod | AUPNSICD ;OHPRD/LAB - Screen Purpose of Visit/ICD9 cod ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149**;Aug 12, | ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996 N ICDSTR,ICDVDT < ;S ICDSTR=$$ICDDX^ICDCODE(Y,$P(^AUPNVSIT(PXCEVIEN,0), < S ICDSTR=$$ICDDX^ICDCODE(Y,+^AUPNVSIT(PXCEVIEN,0)),IC < ;I $P(^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,9)'=1 | I $P(^ICD9(Y,0),U,9)'=1 I $P(ICDSTR,U,10)=1 < Only in ./VADemo/r1/: AWCMCPR1.m Only in ./VADemo/r1/: AWCMCPR2.m Only in ./VADemo/r1/: AWCMCPR3.m Only in ./VADemo/r1/: AWCMCPR4.m Only in ./VADemo/r1/: AWCMCPS2.m Only in ./VADemo/r1/: AWCMCPST.m Only in ./VADemo/r1/: AWCMCPUR.m Only in ./VADemo/r1/: AWCMFTP1.m Only in ./VADemo/r1/: AWCMFTP.m Only in ./VADemo/r1/: BPSECA1.m Only in ./VADemo/r1/: BPSECA2.m Only in ./VADemo/r1/: BPSECA4.m Only in ./VADemo/r1/: BPSECA5.m Only in ./VADemo/r1/: BPSECA7.m Only in ./VADemo/r1/: BPSECA8.m Only in ./VADemo/r1/: BPSECA9.m Only in ./VADemo/r1/: BPSECFM.m Only in ./VADemo/r1/: BPSECP0.m Only in ./VADemo/r1/: BPSECP1.m Only in ./VADemo/r1/: BPSECP2.m Only in ./VADemo/r1/: BPSECP3.m Only in ./VADemo/r1/: BPSECR0.m Only in ./VADemo/r1/: BPSECR1.m Only in ./VADemo/r1/: BPSECR2.m Only in ./VADemo/r1/: BPSECX0.m Only in ./VADemo/r1/: BPSECX1.m Only in ./VADemo/r1/: BPSECX4.m Only in ./VADemo/r1/: BPSECZ3.m Only in ./VADemo/r1/: BPSECZA.m Only in ./VADemo/r1/: BPSER1A.m Only in ./VADemo/r1/: BPSER2A.m Only in ./VADemo/r1/: BPSER3A.m Only in ./VADemo/r1/: BPSER4A.m Only in ./VADemo/r1/: BPSES00.m Only in ./VADemo/r1/: BPSJACK.m Only in ./VADemo/r1/: BPSJAREG.m Only in ./VADemo/r1/: BPSJHLI.m Only in ./VADemo/r1/: BPSJHLT.m Only in ./VADemo/r1/: BPSJINI1.m Only in ./VADemo/r1/: BPSJINIT.m Only in ./VADemo/r1/: BPSJPHNM.m Only in ./VADemo/r1/: BPSJPREG.m Only in ./VADemo/r1/: BPSJUTL1.m Only in ./VADemo/r1/: BPSJUTL.m Only in ./VADemo/r1/: BPSJVAL1.m Only in ./VADemo/r1/: BPSJVAL2.m Only in ./VADemo/r1/: BPSJVAL.m Only in ./VADemo/r1/: BPSJXI1.m Only in ./VADemo/r1/: BPSJZPR.m Only in ./VADemo/r1/: BPSJZQR.m Only in ./VADemo/r1/: BPSJZRP.m Only in ./VADemo/r1/: BPSMHDR.m Only in ./VADemo/r1/: BPSOS02.m Only in ./VADemo/r1/: BPSOS03.m Only in ./VADemo/r1/: BPSOS2A.m Only in ./VADemo/r1/: BPSOS2B.m Only in ./VADemo/r1/: BPSOS2C.m Only in ./VADemo/r1/: BPSOS2D.m Only in ./VADemo/r1/: BPSOS2E.m Only in ./VADemo/r1/: BPSOS2F.m Only in ./VADemo/r1/: BPSOS2.m Only in ./VADemo/r1/: BPSOS6A.m Only in ./VADemo/r1/: BPSOS6E.m Only in ./VADemo/r1/: BPSOS6F.m Only in ./VADemo/r1/: BPSOS6G.m Only in ./VADemo/r1/: BPSOS6H.m Only in ./VADemo/r1/: BPSOS6I.m Only in ./VADemo/r1/: BPSOS6K.m Only in ./VADemo/r1/: BPSOS6L.m Only in ./VADemo/r1/: BPSOS6N.m Only in ./VADemo/r1/: BPSOS96.m Only in ./VADemo/r1/: BPSOS97.m Only in ./VADemo/r1/: BPSOSAA.m Only in ./VADemo/r1/: BPSOSAB.m Only in ./VADemo/r1/: BPSOSAD.m Only in ./VADemo/r1/: BPSOSA.m Only in ./VADemo/r1/: BPSOSAM.m Only in ./VADemo/r1/: BPSOSAN.m Only in ./VADemo/r1/: BPSOSAO.m Only in ./VADemo/r1/: BPSOSAP.m Only in ./VADemo/r1/: BPSOSAQ.m Only in ./VADemo/r1/: BPSOSAR.m Only in ./VADemo/r1/: BPSOSAS.m Only in ./VADemo/r1/: BPSOSAW.m Only in ./VADemo/r1/: BPSOSAY.m Only in ./VADemo/r1/: BPSOSAZ.m Only in ./VADemo/r1/: BPSOSB0.m Only in ./VADemo/r1/: BPSOSB1.m Only in ./VADemo/r1/: BPSOSB2.m Only in ./VADemo/r1/: BPSOSB4.m Only in ./VADemo/r1/: BPSOSB5.m Only in ./VADemo/r1/: BPSOSBA.m Only in ./VADemo/r1/: BPSOSBC.m Only in ./VADemo/r1/: BPSOSBD.m Only in ./VADemo/r1/: BPSOSBE.m Only in ./VADemo/r1/: BPSOSBI.m Only in ./VADemo/r1/: BPSOSBL.m Only in ./VADemo/r1/: BPSOSB.m Only in ./VADemo/r1/: BPSOSBP.m Only in ./VADemo/r1/: BPSOSBQ.m Only in ./VADemo/r1/: BPSOSBT.m Only in ./VADemo/r1/: BPSOSBU.m Only in ./VADemo/r1/: BPSOSBW.m Only in ./VADemo/r1/: BPSOSC1.m Only in ./VADemo/r1/: BPSOSC2.m Only in ./VADemo/r1/: BPSOSC3.m Only in ./VADemo/r1/: BPSOSCA.m Only in ./VADemo/r1/: BPSOSCF.m Only in ./VADemo/r1/: BPSOSD1.m Only in ./VADemo/r1/: BPSOSEC.m Only in ./VADemo/r1/: BPSOSFD.m Only in ./VADemo/r1/: BPSOSH2.m Only in ./VADemo/r1/: BPSOSH4.m Only in ./VADemo/r1/: BPSOSH5.m Only in ./VADemo/r1/: BPSOSH6.m Only in ./VADemo/r1/: BPSOSH7.m Only in ./VADemo/r1/: BPSOSHF.m Only in ./VADemo/r1/: BPSOSHR.m Only in ./VADemo/r1/: BPSOSHU.m Only in ./VADemo/r1/: BPSOSI7.m Only in ./VADemo/r1/: BPSOSI8.m Only in ./VADemo/r1/: BPSOSIB.m Only in ./VADemo/r1/: BPSOSI.m Only in ./VADemo/r1/: BPSOSIO.m Only in ./VADemo/r1/: BPSOSIP.m Only in ./VADemo/r1/: BPSOSIW.m Only in ./VADemo/r1/: BPSOSIY.m Only in ./VADemo/r1/: BPSOSIZ.m Only in ./VADemo/r1/: BPSOSJ1.m Only in ./VADemo/r1/: BPSOSK2.m Only in ./VADemo/r1/: BPSOSK.m Only in ./VADemo/r1/: BPSOSL1.m Only in ./VADemo/r1/: BPSOSL.m Only in ./VADemo/r1/: BPSOSM1.m Only in ./VADemo/r1/: BPSOSMA.m Only in ./VADemo/r1/: BPSOSMB.m Only in ./VADemo/r1/: BPSOSMC.m Only in ./VADemo/r1/: BPSOSM.m Only in ./VADemo/r1/: BPSOSMZ.m Only in ./VADemo/r1/: BPSOSN0.m Only in ./VADemo/r1/: BPSOSN4.m Only in ./VADemo/r1/: BPSOSN7.m Only in ./VADemo/r1/: BPSOSO1.m Only in ./VADemo/r1/: BPSOSO2.m Only in ./VADemo/r1/: BPSOSO3.m Only in ./VADemo/r1/: BPSOSO4.m Only in ./VADemo/r1/: BPSOSO5.m Only in ./VADemo/r1/: BPSOSQ1.m Only in ./VADemo/r1/: BPSOSQ2.m Only in ./VADemo/r1/: BPSOSQ3.m Only in ./VADemo/r1/: BPSOSQ4.m Only in ./VADemo/r1/: BPSOSQF.m Only in ./VADemo/r1/: BPSOSQG.m Only in ./VADemo/r1/: BPSOSQH.m Only in ./VADemo/r1/: BPSOSQJ.m Only in ./VADemo/r1/: BPSOSQL.m Only in ./VADemo/r1/: BPSOSQS.m Only in ./VADemo/r1/: BPSOSR1.m Only in ./VADemo/r1/: BPSOSR2.m Only in ./VADemo/r1/: BPSOSR4.m Only in ./VADemo/r1/: BPSOSRB.m Only in ./VADemo/r1/: BPSOSS2.m Only in ./VADemo/r1/: BPSOSS3.m Only in ./VADemo/r1/: BPSOSS6.m Only in ./VADemo/r1/: BPSOSS7.m Only in ./VADemo/r1/: BPSOSS8.m Only in ./VADemo/r1/: BPSOSS9.m Only in ./VADemo/r1/: BPSOSSG.m Only in ./VADemo/r1/: BPSOSU1.m Only in ./VADemo/r1/: BPSOSU2.m Only in ./VADemo/r1/: BPSOSU3.m Only in ./VADemo/r1/: BPSOSU4.m Only in ./VADemo/r1/: BPSOSU5.m Only in ./VADemo/r1/: BPSOSU7.m Only in ./VADemo/r1/: BPSOSU8.m Only in ./VADemo/r1/: BPSOSU9.m Only in ./VADemo/r1/: BPSOSUA.m Only in ./VADemo/r1/: BPSOSUB.m Only in ./VADemo/r1/: BPSOSUC.m Only in ./VADemo/r1/: BPSOSUD.m Only in ./VADemo/r1/: BPSOSUE.m Only in ./VADemo/r1/: BPSOSXA.m Only in ./VADemo/r1/: BPSOSXE.m Only in ./VADemo/r1/: BPSOSX.m Only in ./VADemo/r1/: BPSRDT.m Only in ./VADemo/r1/: BPSUTIL.m Only in ./VADemo/r2/r/: CJS2.m diff -y --suppress-common-lines ./VADemo/r1/DDWT1.m ./VADemo/r2/r/DDWT1.m ;;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,VM > ; > ; worked around the GT.M bug with SET $EXTRACT. two l > ; STATUS changed 999 to +999 (HOU/DJW,PUG/TOAD). > ; S $E(DDWS,IOM\2+1-($L(DDWX)\2),999)=DDWX | S $E(DDWS,IOM\2+1-($L(DDWX)\2),+999)=DDWX S $E(DDWS,IOM-$L(DDWX),999)=DDWX | S $E(DDWS,IOM-$L(DDWX),+999)=DDWX Only in ./VADemo/r2/r/: DENTVCNV.m Only in ./VADemo/r2/r/: DENTVDD.m Only in ./VADemo/r2/r/: DENTVI01.m Only in ./VADemo/r2/r/: DENTVI02.m Only in ./VADemo/r2/r/: DENTVI03.m Only in ./VADemo/r2/r/: DENTVI04.m Only in ./VADemo/r2/r/: DENTVI05.m Only in ./VADemo/r2/r/: DENTVIP1.m Only in ./VADemo/r2/r/: DENTVIP.m Only in ./VADemo/r2/r/: DENTVRP1.m Only in ./VADemo/r2/r/: DENTVRP2.m Only in ./VADemo/r2/r/: DENTVRP3.m Only in ./VADemo/r2/r/: DENTVRP4.m Only in ./VADemo/r2/r/: DENTVRP5.m Only in ./VADemo/r2/r/: DENTVRP6.m Only in ./VADemo/r2/r/: DENTVRP7.m Only in ./VADemo/r2/r/: DENTVRP8.m Only in ./VADemo/r2/r/: DENTVRP9.m Only in ./VADemo/r2/r/: DENTVUTL.m diff -y --suppress-common-lines ./VADemo/r1/DG1010P1.m ./VADemo/r2/r/DG1010P1.m ;;5.3;Registration;**489**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 W !,DGLUND | W ?131,$C(13),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,"| 1 < W !,?21,VAPA(14) < W ?66,"| ","11D. ZIP CODE: ",$P(VAPA(18),"^",2),?99 < W !,?21,VAPA(15),?66,"| 11F. START DATE: ",$P(VAPA(20 < 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= < .S DGCAT=VAPA(22,DGCATS),DGACT=$P(DGCAT,"^",3),DGCATN < .I DGACT="Y" W !?11,DGCATN,?66,"|" < W !,DGLUND < W !,"12. PATIENT'S SEX",?33,"| ","13. MOTHER'S MAID | W !,"11. PATIENT'S SEX",?33,"| ","12. MOTHER'S MAID W !,"16. RELIGIOUS PREFERENCE",?33,"| ","17. DATE O | W !,"15. RELIGIOUS PREFERENCE",?33,"| ","16. DATE O diff -y --suppress-common-lines ./VADemo/r1/DG1010P5.m ./VADemo/r2/r/DG1010P5.m ;;5.3;Registration;**570**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 N DGIB,DGIBA,DGYN,DGIB8,DGIB4,DGINS,DGX ; changes for | W !?4,"COVERAGE: ",$$YN2(DGP(.31),11),?44,"| ",?50 S DGYN=$$INSUR^IBBAPI(DFN,,"R",.DGINS,"1,10,11,12") | I X'="Y" W "NOT APPLICABLE" G GI W !?4,"COVERAGE: ",$S(DGYN:"YES",1:"NO"),?44,"| ",?50 < I 'DGYN W "NOT APPLICABLE" G GI < S (DGVT,DGSP,DGOT)="",DGX=0 | S (DGVT,DGSP,DGOT)="" F S DGX=$O(DGINS("IBBAPI","INSUR",DGX)) Q:'DGX D | F DGINS=0:0 S DGINS=$O(^DPT(DFN,.312,DGINS)) Q:DGINS' . S DGIB8=$G(DGINS("IBBAPI","INSUR",DGX,10)),DGIB4=$G | .S DGI=^DPT(DFN,.312,DGINS,0) . I $S((DGIB8>(9999999-DFN1)):1,(DGIB4']""):0,((99999 | .I $S(($P(DGI,U,8)>(9999999-DFN1)):1,($P(DGI,U,4)']"" . I $P(DGINS("IBBAPI","INSUR",DGX,12),U,1)="P" S DGVT | .I $P(DGI,U,6)="v" S DGVT="PATIENT'S INSURANCE" . I $P(DGINS("IBBAPI","INSUR",DGX,12),U,1)="S" S DGSP | .I $P(DGI,U,6)="s" S DGSP="SPOUSE'S INSURANCE" . I $P(DGINS("IBBAPI","INSUR",DGX,12),U,1)="O" S DGOT | .I $P(DGI,U,6)="o" S DGOT="OTHER" diff -y --suppress-common-lines ./VADemo/r1/DG1010PA.m ./VADemo/r2/r/DG1010PA.m ;;5.3;Registration;**18,28,86,108,113,570**;Aug 13, 1 | ;;5.3;Registration;**18,28,86,108,113**;Aug 13, 1993 . I '($$INSUR^IBBAPI(DFN)) S DGFAIL=1 | .I '($O(^DPT(DFN,.312,0))) S DGFAIL=1 diff -y --suppress-common-lines ./VADemo/r1/DG1010S1.m ./VADemo/r2/r/DG1010S1.m DG1010S1 ;ALB/MRL/EG - SUPPLEMENTAL DATA SHEET FOR 10- | DG1010S1 ;ALB/MRL - SUPPLEMENTAL DATA SHEET FOR 10-10 ;;5.3;Registration;**606,568,585**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 N DGARRAY,I,SDOUT,CLIEN,APTDT < S DGARRAY("FLDS")="1;2",DGARRAY(4)=DFN,I=$$SDAPI^SDAM | F J=0:0 S I2=$O(^DPT(DFN,"S",I2)) Q:I2="" I $S($P(^( ;it's not clear if it is an error or clinic or patien < ;if an error,there will be no lower subscripts eg 01/ < I $D(^TMP($J,"SDAMA301",101))=1 S I1=1,DGD="** Appoin < I $D(^TMP($J,"SDAMA301",101))'=1 D < .S (DGD,CLIEN)="" F S CLIEN=$O(^TMP($J,"SDAMA301",DF < ..S APTDT=DT F S APTDT=$O(^TMP($J,"SDAMA301",DFN,CLI < ...S SDOUT=^TMP($J,"SDAMA301",DFN,CLIEN,APTDT),I1=1,D < W:(128-$X)<$L(DGD) !?9 W DGD < K DGARRAY,^TMP($J,"SDAMA301"),SDOUT,CLIEN,APTDT < S DGD=+$P(^DGPM(+DGD,0),"^",16),Y=+^(0),DGDAT=Y | S DGD=+$P(^DGPM(+DGD,0),"^",16),Y=+^(0) S I3="" F I=5:1:15 I I'=10 S I2=$P(I1,U,I) Q:'I2 S I | S I3="" F I=5:1:15 I I'=10 S I2=$P(I1,U,I) Q:'I2 S I W:'I3 "NO DIAGNOSES ON FILE FOR THIS ADMISSION PERIOD | W:'I3 "NO DIAGNOSES ON FILE FOR THIS ADMISSION PERIOD W !?5,"7c. Admit Diagnosis: ",X,!?5,DGLSUP,!?5,"7d. | W !?5,"7c. Admit Diagnosis: ",X,!?5,DGLSUP,!?5,"7d. K DGAD,DGD,DGEL,I,I1,I2,Y,DGDAT G ^DG1010S2 | K DGAD,DGD,DGEL,I,I1,I2,Y G ^DG1010S2 diff -y --suppress-common-lines ./VADemo/r1/DG10.m ./VADemo/r2/r/DG10.m DG10 ;ALB/MRL,DAK,AEG-LOAD/EDIT PATIENT DATA ; 1/12/04 4:5 | DG10 ;ALB/MRL,DAK,AEG-LOAD/EDIT PATIENT DATA ; 15 Jul 2000 ;;5.3;Registration;**32,109,139,149,182,326,513,425,5 | ;;5.3;Registration;**32,109,139,149,182,326**;Aug 13, I $G(DGPRFLG)=1,$G(DGPLOC)=1 D G Q:$G(DGRPOUT),A1 | I $G(DGPRFLG)=1,$G(DGPLOC)=1 D G A1 .; D EN^DGRPD,REG^IVMCQ($G(DFN)) | . D EN^DGRPD,REG^IVMCQ($G(DFN)) . D EN^DGRPD < . Q:$G(DGRPOUT) < . D REG^IVMCQ($G(DFN)) < N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DP | I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET") I +$G(DGNEW) D < . ; query CMOR for Patient Record Flag Assignments if < . ; display results < . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN) < ; < CP ;If not (autoexempt or MTested) & no CP test this yea | CP ; If not (autoexempt or MTested) & no CP test this ye ;prompt for add/edit cp test | ; prompt for add/edit cp test diff -y --suppress-common-lines ./VADemo/r1/DG3PR0.m ./VADemo/r2/r/DG3PR0.m ;;5.3;Registration;**26,69,570**;Aug 13, 1993 | ;;5.3;Registration;**26,69**;Aug 13, 1993 START K ^UTILITY($J) | START K ^UTILITY($J) S (N(1),N(0),DG(1),DG(0))="" D ALL^IBC 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 < . 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 < . S $P(DGBLD,U,17)=DGINS(I,13) ; Subscriber Name < . S $P(DGBLD,U,18)=+DGINS(I,8) ; Group Plan (Policy N < . 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 < ; < ; | SET S A=DG(I),A=$S($D(^DIC(36,+A,0)):^(0),1:""),B=$G(^DIC SET ; | S X(I)=$P(A,U,1)_U_$P($G(^DIC(36,+DG(I),.13)),U,1)_U_ N DGX < S DGX=$P($G(DG(I)),U,30) < S A=$S(DGX>0:$P(DGINS(DGX,1),U,2),1:"") ; Insurance C < S X="" < S:DGX>0 X=DGINS(DGX,3)_", "_$P(DGINS(DGX,4),U,2)_" "_ < ; < S X(I)=A_U_$S(DGX>0:DGINS(DGX,6),1:"")_U_$S(DGX>0:DGI < S Y=$S(DGX>0:DGINS(DGX,10),1:""),Y=$$FMTE^XLFDT(Y) ; < S X(I)=X(I)_Y_U < S Y="",Y=$$FMTE^XLFDT(Y) ; Renewal Date (Not availab < S X(I)=X(I)_Y < ; < diff -y --suppress-common-lines ./VADemo/r1/DG3PR1.m ./VADemo/r2/r/DG3PR1.m ;;5.3;Registration;**26,570**;Aug 13, 1993 | ;;5.3;Registration;**26**;Aug 13, 1993 S DFN=$P(DGAD,"^",3) | S DFN=$P(DGAD,"^",3) I $S('DFN:1,'$D(^DPT(DFN,0)):1,' I $S('DFN:1,'$D(^DPT(DFN,0)):1,'$$INSUR^IBBAPI(DFN,"" < diff -y --suppress-common-lines ./VADemo/r1/DG3PR2.m ./VADemo/r2/r/DG3PR2.m ;;5.3;Registration;**26,606,617,570**;Aug 13, 1993 | ;;5.3;Registration;**26**;Aug 13, 1993 ;570 | D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I) ;D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I < 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) < . I $D(DGIBINS(I,18)) W $G(DGIBINS(I,18)) ; Group Pol < . S DGINS=$S($P(DGIBINS(I,9),U,2)="NO":1,1:0) D INS2 < ; < N DGDAT,DXD | S DGPR=DGAD F I=0:0 S I=$O(^UTILITY("DG",$J,"M",I)) Q S DGDAT=$P(^DGPT(DGPTF,0),"^",2) | Q:'DGFL S DGPMIFN=DGCA D ^DGPMLOS W !?39,"---- ---- S DGPR=DGAD F I=0:0 S I=$O(^UTILITY("DG",$J,"M",I)) Q < ;Q:'DGFL S DGPMIFN=DGCA D ^DGPMLOS W !?39,"---- --- < Q:'DGFL S DGPMIFN=DGCA < D ^DGPMLOS W !?39,"---- ----------",!?26,"TOTAL LOS: < F I=0:0 S I=$O(^UTILITY("DG",$J,"S",I)) Q:'I S J=^(I | F I=0:0 S I=$O(^UTILITY("DG",$J,"S",I)) Q:'I S J=^(I DIAG S M=0 F K=5:1:15 I K'=10 S L=$P(J,"^",K) I L S DXD=$$ | DIAG S M=0 F K=5:1:15 I K'=10 S L=$P(J,"^",K) I L W:M ! W OP S M=0 F K=8:1:12 S L=$P(J,"^",K) I L S DXD=$$ICDOP^IC | OP S M=0 F K=8:1:12 S L=$P(J,"^",K) I L W:M ! W ?45,$S($ ;570 | I $P(X,"^",2)="N" S DGINS=1 N X | S X=$P(J,"^",4) W:X]"" ?63,$E(X,4,5),"/",$E(X,6,7),"/ ;I $P(X,"^",2)="N" S DGINS=1 < ;S X=$P(J,"^",4) W:X]"" ?63,$E(X,4,5),"/",$E(X,6,7)," < 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 < Only in ./VADemo/r1/: DG53358C.m Only in ./VADemo/r1/: DG53358D.m Only in ./VADemo/r1/: DG53463.m Only in ./VADemo/r1/: DG53478I.m Only in ./VADemo/r1/: DG53514.m Only in ./VADemo/r1/: DG53522P.m Only in ./VADemo/r1/: DG53528P.m Only in ./VADemo/r1/: DG53558.m Only in ./VADemo/r1/: DG53558M.m Only in ./VADemo/r1/: DG53568A.m Only in ./VADemo/r1/: DG53588P.m Only in ./VADemo/r1/: DG53602S.m Only in ./VADemo/r1/: DG53625P.m Only in ./VADemo/r1/: DG53B563.m Only in ./VADemo/r1/: DG53E451.m Only in ./VADemo/r1/: DG53E574.m Only in ./VADemo/r1/: DG53P425.m Only in ./VADemo/r1/: DG53P451.m Only in ./VADemo/r1/: DG53P543.m Only in ./VADemo/r1/: DG53P555.m Only in ./VADemo/r1/: DG53P574.m Only in ./VADemo/r1/: DG53P593.m Only in ./VADemo/r1/: DG53P597.m Only in ./VADemo/r1/: DG53P600.m Only in ./VADemo/r1/: DG53P604.m Only in ./VADemo/r1/: DG53S451.m Only in ./VADemo/r1/: DGAPI.m diff -y --suppress-common-lines ./VADemo/r1/DGBLRV.m ./VADemo/r2/r/DGBLRV.m ;;5.3;Registration;**26,570**;Aug 13, 1993 | ;;5.3;Registration;**26**;Aug 13, 1993 INS ; -- new insurance logic, modified for IBBAPI insuran | INS ; -- new insurance logic N DGIBINS,DGIBDT,DGDATA,DGIB,DGX | N DGIBINS,DGIBDT S DGIBDT=$P(DGIBDT,".") | D ALL^IBCNS1(DFN,"DGIBINS",2,DGIBDT) S DGIB=$$INSUR^IBBAPI(DFN,DGIBDT,"R",.DGDATA,"*") | S P=1 S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGIBINS=@DGX | I $G(DGIBINS(0)) F I=0:0 S I=$O(DGIBINS(I)) Q:'I D S P=1,I=0 | .S DGINS=$G(DGIBINS(I,0)) I $P(DGINS,U,4)>DT!($P(DGIN 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): < . . S P=P+1 < ADDR ; | ADDR S DGIMULT=$S($D(^DIC(36,+DGINS,.11)):^(.11),1:"") Q:D S DGINAD=$S(DGIBINS(I,2)]"":DGIBINS(I,2)_", ",1:"")_$ | S DGINAD=$S($P(DGIMULT,U,1)]"":$P(DGIMULT,U,1)_", ",1 Q | S DGINAD=DGINAD_$S('$D(^DIC(5,+$P(DGIMULT,U,5),0)):"" 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:" 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( 81 W " " Q ; Pre-certification phone# not currently ava | 81 W $S('$D(I(P)):"",$D(^DIC(36,$P(I(P),"^",1),.13)):$P( 82 W " " Q ; Billing phone# not currently available in | 82 W $S('$D(I(P)):"",$D(^DIC(36,$P(I(P),"^",1),.13)):$P( S DIS(0)="S DFN=$P(^DGPM(D0,0),U,3) I $P(^(0),""^"",2 | S DIS(0)="S DFN=$P(^DGPM(D0,0),U,3) I $P(^(0),""^"",2 I $S('$$INSUR^IBBAPI(DFN,"","A"):1,'$D(^DPT(DFN,"VET" | I $S('$O(^DPT(DFN,.312,0)):1,'$D(^DPT(DFN,"VET")):1,^ Only in ./VADemo/r1/: DGBT1P2.m Only in ./VADemo/r1/: DGBT1P3.m diff -y --suppress-common-lines ./VADemo/r1/DGBT2.m ./VADemo/r2/r/DGBT2.m DGBT2 ;ALB/LM - BENEFICIARY TRAVEL SCREEN 2 ; 07/09/2004 | DGBT2 ;ALB/LM - BENEFICIARY TRAVEL SCREEN 2 ;5/24/91 09:19 ;;1.0;Beneficiary Travel;**7,8**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 APPT I $D(DGBTCL(101)) W ?14,DGBTCL(101) Q | APPT I $D(DGBTCL) S DGBTCN=+$P(DGBTCL(I),"^") W ?14,$S($D( .W ?14,$P(DGBTCL(I),U)," ("_$$FMTE^DILIBF(I,"5U")_")" | .S X=$P(DGBTCL(I),"^",2) .S X=$P(DGBTCL(I),U,2) | .W ?50,$S(X["NT":"NO ACTION TAKEN",X["N":"NO-SHOW",X[ .W ?50,$S(X["NT":"NO ACTION TAKEN",X["N":"NO-SHOW",X[ < .W ?66,$P("C&P^10-10^SCHED.^UNSCHED.",U,+$P(DGBTCL(I) < .W ?73,$S($D(^SD(409.1,+$P(DGBTCL(I),U,4),0)):$P(^SD( < AMT N X3 ;Fresh copy for COMMA^%DTC. Leftovers causing er | AMT S X=$P(^DGBT(392,DGBTPDT,0),"^",9),X2="2$" D COMMA^%D S X=$P(^DGBT(392,DGBTPDT,0),"^",9),X2="2$" D COMMA^%D < diff -y --suppress-common-lines ./VADemo/r1/DGBTCD.m ./VADemo/r2/r/DGBTCD.m ;;1.0;Beneficiary Travel;**2,7,9**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 W ?51,"Most Econ. Cost: " S X=$P(DGBTVAR(0),U,8),X2=" | W ?51,"Most Econ. Cost: " S X=$P(DGBTVAR(0),U,8),X2=" I $D(^DG(43,1,"BT")) I $P(^DG(43,1,"BT"),U,2)=1 W ?51 | I $D(^DG(43,1,"BT")) I $P(^DG(43,1,"BT"),U,2)=1 W ?51 I DGBTACCT'=4&(DGBTACCT'=5) D | I DGBTACCT'=4&(DGBTACCT'=5) W !?5,"Carrier: ",$S($P(D . S DGX=$S($P(DGBTVAR(0),U,7):"Carrier",$P(DGBTVAR(0) | I $D(^DG(43,1,"BT")) I $P(^DG(43,1,"BT"),U,2)=1 W ?46 . W $E($S((DGX["FLS"&$P(DGBTVAR(0),U,14)):$P(^DGBT(39 < I $D(^DG(43,1,"BT")) I $P(^DG(43,1,"BT"),U,2)=1 W ?46 < I DGBTACCT=4!(DGBTACCT=5) W ?46,"Total Mileage Amount | I DGBTACCT=4!(DGBTACCT=5) W ?46,"Total Mileage Amount DED W ?48,"Applied Deductible: " S X=$P(DGBTVAR(0),U,9) N | DED W ?48,"Applied Deductible: " S X=$P(DGBTVAR(0),U,9) D W ?52,"Amount Payable: " S X=$P(DGBTVAR(0),U,10) N X3 | W ?52,"Amount Payable: " S X=$P(DGBTVAR(0),U,10) D CO diff -y --suppress-common-lines ./VADemo/r1/DGBTCE.m ./VADemo/r2/r/DGBTCE.m ;;1.0;Beneficiary Travel;**2**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 S DIE="^DGBT(392,",DA=DGBTDT | S DIE="^DGBT(392,",DA=DGBTDT,DR="I DGBTACCT=4!(DGBTAC I 'DGBTCORE D < . S DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1; < I DGBTCORE S DR="" D < . S DR(1,392,1)="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"" < . S DR(1,392,2)="@1;I DGBTMLFB=0 S Y=""@2"";34//;S DG < diff -y --suppress-common-lines ./VADemo/r1/DGBTCR.m ./VADemo/r2/r/DGBTCR.m ;;1.0;Beneficiary Travel;**7**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 N X3 < Only in ./VADemo/r1/: DGBTCSL.m diff -y --suppress-common-lines ./VADemo/r1/DGBTE1.m ./VADemo/r2/r/DGBTE1.m DGBTE1 ;ALB/SCK/EG - BENEFICIARY TRAVEL FIND OLD CLAIM DATES | DGBTE1 ;ALB/SCK - BENEFICIARY TRAVEL FIND OLD CLAIM DATES ; ;;1.0;Beneficiary Travel;**8,12**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 S CHZFLG=0,%DT="EXR",DTSUB=$S(Y="N":"NOW",Y="P":"OLD" | S CHZFLG=0,%DT="EXR",DTSUB=$S(Y="N":"NOW",Y="P":"OLD" N DGARRAY,CLIEN,APTDT S DGARRAY("FLDS")="2;3;10;18" | F I=0:0 S I=$O(^DPT(DFN,"S",I)) Q:'I!(I>(DGBTDTI+1)) S DGARRAY(4)=DFN,I=$$SDAPI^SDAMA301(.DGARRAY) < ;if dfn = 101, e.g., it's not clear if it is an error < ;if an error, there will be no lower subscripts eg 01 < I $D(^TMP($J,"SDAMA301",101))=1 S I1=1,DGBTCL(101)="* < I $D(^TMP($J,"SDAMA301",101))'=1 D < .S CLIEN="" F S CLIEN=$O(^TMP($J,"SDAMA301",DFN,CLIE < ..S APTDT=DGBTDTI\1 F S APTDT=$O(^TMP($J,"SDAMA301", < ...S DGBTCL(APTDT)=$P($P(^TMP($J,"SDAMA301",DFN,CLIEN < K ^TMP($J,"SDAMA301"),DGARRAY,CLIEN,APTDT < diff -y --suppress-common-lines ./VADemo/r1/DGBTEE.m ./VADemo/r2/r/DGBTEE.m ;;1.0;Beneficiary Travel;**2**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 I 'DGBTCORE D | S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD . S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBT < I DGBTCORE D < . S DR(1,392,1)="3////"_DGBTELIG_";4////"_DGBTSCP_";5 < . S DR(1,392,2)="@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392, < D ^DIE K DR I X=""!(X="^") S DGBTTOUT=-1 Q | D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q diff -y --suppress-common-lines ./VADemo/r1/DGBTEF1.m ./VADemo/r2/r/DGBTEF1.m ;;1.0;Beneficiary Travel;**2**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 S DA=1,DR="720;723;721",DIE="^DG(43," D ^DIE G QUIT:X | S DA=1,DR="720;721",DIE="^DG(43," D ^DIE G QUIT:X="^" diff -y --suppress-common-lines ./VADemo/r1/DGBTEF.m ./VADemo/r2/r/DGBTEF.m ;;1.0;Beneficiary Travel;**7**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 N X3 ;Clean copy used by COMMA^%DTC < diff -y --suppress-common-lines ./VADemo/r1/DGBTE.m ./VADemo/r2/r/DGBTE.m ;;1.0;Beneficiary Travel;**2**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 COREFLS ; coreFLS vendor interface active/inactive < S DGBTCORE=$P($G(^DG(43,1,"BT")),U,4) < ; < Only in ./VADemo/r1/: DGBTID.m diff -y --suppress-common-lines ./VADemo/r1/DGBTOA1.m ./VADemo/r2/r/DGBTOA1.m ;;1.0;Beneficiary Travel;**2**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 CAR I '$P($G(^DG(43,1,"BT")),U,4) S VAUTVB="VAUTN",PRCABN | CAR S VAUTVB="VAUTN",PRCABN=0,DIC="^PRC(440,",VAUTSTR="ca I $P($G(^DG(43,1,"BT")),U,4) S VAUTVB="VAUTN",PRCABN= < diff -y --suppress-common-lines ./VADemo/r1/DGBTOA2.m ./VADemo/r2/r/DGBTOA2.m ;;1.0;Beneficiary Travel;**2,7**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 S DGBTIX=$S(DGBTSL="ACCT":"AC",DGBTSL="CAR":"AS",DGBT | S DGBTIX=$S(DGBTSL="ACCT":"AC",DGBTSL="CAR":"AS",DGBT I $P($G(^DG(43,1,"BT")),U,4) S DGBTIX=$S(DGBTSL="CAR" < D SORT G:DGBTU QUIT1 I $D(^UTILITY($J)) D TOTAL^DGBTO < I '$P($G(^DG(43,1,"BT")),U,4) S DGBTB=$S($P(DGBTK,U,7 | S DGBTB=$S($P(DGBTK,U,7):$P(^PRC(440,$P(DGBTK,U,7),0) I $P($G(^DG(43,1,"BT")),U,4) S DGBTB=$S($P(DGBTK,U,14 < S DGBTK9=$P(DGBTK,U,9),DGBTK10=$P(DGBTK,U,10) < ACCTU S DGBTCW=$S(DGBTSL="CAR"&('$P($G(^DG(43,1,"BT")),U,4) | ACCTU S DGBTCW=$S(DGBTSL="CAR":$P(^PRC(440,DGBTBY,0),U,1),1 S DGBTOTX(DGBTDN,DGBTCW)=$S('$D(DGBTOTX(DGBTDN,DGBTCW < CM N X3 D COMMA^%DTC Q | CM D COMMA^%DTC Q diff -y --suppress-common-lines ./VADemo/r1/DGBTOA3.m ./VADemo/r2/r/DGBTOA3.m ;;1.0;Beneficiary Travel;**7**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 CM N X3 D COMMA^%DTC Q | CM D COMMA^%DTC Q diff -y --suppress-common-lines ./VADemo/r1/DGBTOA4.m ./VADemo/r2/r/DGBTOA4.m ;;1.0;Beneficiary Travel;**7**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 CM N X3 D COMMA^%DTC Q | CM D COMMA^%DTC Q diff -y --suppress-common-lines ./VADemo/r1/DGBTOA5.m ./VADemo/r2/r/DGBTOA5.m ;;1.0;Beneficiary Travel;**5**;September 25, 2001 | ;;1.0;Beneficiary Travel;;September 25, 2001 N X3 K DIR | K DIR Only in ./VADemo/r1/: DGBTPRE.m Only in ./VADemo/r1/: DGBTVUP.m diff -y --suppress-common-lines ./VADemo/r1/DGBUL.m ./VADemo/r2/r/DGBUL.m ;;5.3;Registration;**31,244,545**;Aug 13, 1993 | ;;5.3;Registration;**31**;Aug 13, 1993 ; < ;Protect Fileman from Mailman call < N DICRREC,DIDATA,DIEFAR,DIEFCNOD,DIEFDAS,DIEFECNT,DIE < N DIEFFLD,DIEFFLST,DIEFFREF,DIEFFVAL,DIEFFXR,DIEFI,DI < N DIEFNODE,DIEFNVAL,DIEFOUT,DIEFOVAL,DIEFRFLD,DIEFRLS < N DIEFSPOT,DIEFTMP,DIEFTREF,DIFLD,DIFM,DIQUIET,DISYS, < ; < Only in ./VADemo/r1/: DGCV1.m Only in ./VADemo/r1/: DGCVEXP.m Only in ./VADemo/r1/: DGCV.m Only in ./VADemo/r1/: DGCVRPT.m diff -y --suppress-common-lines ./VADemo/r1/DGDDC.m ./VADemo/r2/r/DGDDC.m ;;5.3;Registration;**489,244,527**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 Q:$D(DGNOFDEL) ;Flag variable to prevent deletion ca | Q:'$D(DGXRF) S DGXRFX=X,DGXRF1=+$P(DGXRF,".",2),DGXR ; < Q:'$D(DGXRF) N DGXRFX,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DG < S DGXRFX=X,DGXRF1=+$P(DGXRF,".",2),DGXRF2=$P($T(@DGXR < N DGFDA,DGERR | F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4= ;F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4 | Q S X=DGXRFX K DGXRF,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4 F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4= < .S DGFDA(2,DA_",",DGXRF4)="" < I $D(DGFDA) D FILE^DIE("","DGFDA","DGERR") < Q S X=DGXRFX K DGXRF Q ;,DGXRFX,DGXRF1,DGXRF2,DGXRF3,D < 14105 ;;.1417^.1418 < 1411 ;;.1412^.1413 < 1412 ;;.1413 < diff -y --suppress-common-lines ./VADemo/r1/DGDEATH.m ./VADemo/r2/r/DGDEATH.m DGDEATH ;ALB/MRL/PJR-PROCESS DECEASED PATIENTS ; 10/27/04 9:4 | DGDEATH ;ALB/MRL-PROCESS DECEASED PATIENTS ;19 JUN 87 ;;5.3;Registration;**45,84,101,149,392,545,595,568,56 | ;;5.3;Registration;**45,84,101,149,392**;Aug 13, 1993 S DGDOLD=$G(^DPT(DFN,.35)) < D NOW^%DTC S DGNOW=% | K A W ! S DIE=DIC,DR=".351" D ^DIE G GET 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 < 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 < Q K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN,DGDOLD,DG | Q K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN Q K DGTEXT D ^DGPATV S DGDEATH=$$GET1^DIQ(2,DFN,.351,"I | K DGTEXT D ^DGPATV S DGDEATH=X,XMSUB="PATIENT HAS EXP S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGPMSTAT | S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGINPW S DGDONOT=0 D APTT3 < D LINE(" Date/Time of Death: "_DEATHVAL_$S(DGDON | D LINE(" Date/Time of Death: "_Y_$S('DG1:"",$D(D F N DGARRAY,SDCNT S DGFAPT=DGDEATH,DGFAPTI="" | F S DGFAPT=DGDEATH,DGFAPTI="" S DGARRAY("FLDS")=3,DGARRAY(4)=DFN,DGARRAY("SORT")="P | F S DGFAPT=$O(^DPT(DFN,"S",DGFAPT)) Q:'DGFAPT S DGF S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) | .I $P(DGFAPT1,"^",2)'["C" D LINE("NOTE: Patient has f F S DGFAPT=$O(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:'DGF < .I $P($P(DGFAPT1,U,3),";")'["C" D LINE("NOTE: Patient < N DGPCMM,DELBY,DELTM,DTHINFO | N DGPCMM D LINE("") < D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","DTHIN < S DEATHVAL=$G(DTHINFO(2,DFN_",",.351,"E")) < S DEATHVAL=$$FMTE^XLFDT(DEATHVAL),DEATHVAL=$S(DEATHVA < 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="":" < ;K DEATHVAL,SOURCE,DELTM,DELBY < 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 value < ; 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 Bulle < ; 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 -y --suppress-common-lines ./VADemo/r1/DGDIS1.m ./VADemo/r2/r/DGDIS1.m DGDIS1 ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 02/15/2004 | DGDIS1 ;ALB/XAK-MRL - DISPOSITION PROCESSING ; 24 AUG 84 15 ;;5.3;Registration;**151,568**;Aug 13, 1993 | ;;5.3;Registration;**151**;Aug 13, 1993 W !,"APPOINTMENTS CAN NO LONGER BE MADE USING THIS OP | S Y(0)=^DPT(DFN,0),Y=DFN,(SDMM,DIROUT,ORACTION)=0 K S diff -y --suppress-common-lines ./VADemo/r1/DGDIS.m ./VADemo/r2/r/DGDIS.m DGDIS ;ALB/JDS - DISPOSITION A REGISTRATION ; 8/6/04 3:17pm | DGDIS ;ALB/JDS - DISPOSITION A REGISTRATION ; 26 AUG 84 14 ;;5.3;Registration;**108,121,161,151,459,604**;Aug 13 | ;;5.3;Registration;**108,121,161,151**;Aug 13, 1993 > S SDISHDL=$$HANDLE^SDAMEVT(3) D BEFORE(DFN,9999999-DF > ; > I "^0^1^"[("^"_$P($G(^DPT(DFN,"DIS",DFN1,0)),"^",2)_" W !!,"***** Registration dispositioned *****",!!,*7 | D EVT(DFN,9999999-DFN1,8,SDISHDL) W !!,"***** Registr I $P($G(^DPT(DFN,"DIS",DFN1,0)),"^",18) D EN^SDCODEL( | I $P($G(^DPT(DFN,"DIS",DFN1,0)),"^",18) D EN^SDCODEL( > D CLEAN^SDAMEVT(SDISHDL) ; clean up oe evt handle . ; | . diff -y --suppress-common-lines ./VADemo/r1/DGENA1A.m ./VADemo/r2/r/DGENA1A.m DGENA1A ;ALB/CJM,ISA/KWP,Zoltan,LBD - Enrollment API - File D | DGENA1A ;ALB/CJM,ISA/KWP,Zoltan - Enrollment API - File Data ;;5.3;Registration;**121,147,232,314,564**;Aug 13,199 | ;;5.3;Registration;**121,147,232,314**;Aug 13,1993 S NODE=NODE_U_DGENR("ELIG","UNEMPLOY") < S NODE=NODE_U_DGENR("ELIG","CVELEDT") < diff -y --suppress-common-lines ./VADemo/r1/DGENA2.m ./VADemo/r2/r/DGENA2.m DGENA2 ;ALB/CJM,RTK,TDM - Enrollment API - Automatic Update; | DGENA2 ;ALB/CJM,RTK - Enrollment API - Automatic Update; 9/1 ;;5.3;Registration;**121,122,147,232,327,469,491**;Au | ;;5.3;Registration;**121,122,147,232,327,469**;Aug 13 .I STATUS'="VERIFIED",STATUS'="UNVERIFIED",STATUS'="D | .I STATUS'="VERIFIED",STATUS'="UNVERIFIED",STATUS'="D diff -y --suppress-common-lines ./VADemo/r1/DGENA3.m ./VADemo/r2/r/DGENA3.m DGENA3 ;ALB/CJM,ISA/KWP,RTK,TDM,LBD,PHH,PJR - Enrollment API | DGENA3 ;ALB/CJM,ISA/KWP,RTK,TDM,LBD - Enrollment API - Consi ;;5.3;Registration;**232,306,327,367,417,454,456,491, | ;;5.3;Registration;**232,306,327,367,417,454,456**;Au .; ** temporarily commented out for HVE Phase II and | .I DGENR("PRIORITY") D Q:(ERRMSG'="") .;I DGENR("PRIORITY") D Q:(ERRMSG'="") | ..S PRIGRP=$$PRI^DGENELA4(DGENR("ELIG","CODE"),.DGELG .;.S PRIGRP=$$PRI^DGENELA4(DGENR("ELIG","CODE"),.DGEL | ..;check priority .;.;check priority | ..I DGENR("PRIORITY")'=$P(PRIGRP,"^") D Q .;.I DGENR("STATUS")=6 Q ; do not check priority | ...S ERRMSG="ENROLLMENT PRIORITY IS INCONSISTENT WITH .;.I DGENR("PRIORITY")'=$P(PRIGRP,"^") D Q | ..;check subgroup if priority = 7 or 8 .;..I $G(DGCDIS("VCD"))'="" Q | ..Q:DGENR("PRIORITY")<7 .;..S ERRMSG="ENROLLMENT PRIORITY IS INCONSISTENT WIT | ..; sub-priority "b" can be overridden with "a" at HE .;.;check subgroup if priority = 7 or 8 | ..I "^1^1^2^2^1^"[("^"_DGENR("SUBGRP")_"^"_$P(PRIGRP, .;.Q:DGENR("PRIORITY")<7 | ..; sub-priority "d" can be overridden with "c" at HE .;.; sub-priority "e" can be overridden with "a" at H | ..I "^3^3^4^4^3^"[("^"_DGENR("SUBGRP")_"^"_$P(PRIGRP, .;.I "^1^1^5^5^1^"[("^"_DGENR("SUBGRP")_"^"_$P(PRIGRP | ..S ERRMSG="ENROLLMENT PRIORITY IS INCONSISTENT WITH .;.; sub-priority "g" can be overridden with "c" at H < .;.I "^3^3^7^7^3^"[("^"_DGENR("SUBGRP")_"^"_$P(PRIGRP < .;.S ERRMSG="ENROLLMENT PRIORITY IS INCONSISTENT WITH < .; end of temporary comments < ..S ERRMSG="ENROLLMENT PRIORITY IS REQUIRED WITH ENRO | ..S ERRMSG="ENROLLMENT PRIORITY IS REQUIRED WITH ENRO .;if status is DECEASED and Date of Death is missing, | .;if status is DECEASED then Date of Death is require ..I $D(DGPAT),'DGPAT("DEATH") D BULLETIN | ..I $D(DGPAT),'DGPAT("DEATH") S ERRMSG="ENROLLMENT ST ..I '$D(DGPAT),'$$DEATH^DGENPTA(DGENR("DFN")) D BULLE | ..I '$D(DGPAT),'$$DEATH^DGENPTA(DGENR("DFN")) S ERRMS BULLETIN ; Status vs. Date of Death Data Discrepancy B < N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT, < 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 < S XMTEXT="DGBULL(" < S XMSUB="STATUS VS. DATE OF DEATH DATA DISCREPANCY" < 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 Enrollment Status is Dece < D LINE^DGEN("however, there is no Date of Death on fi < D LINE^DGEN("Actions you should take:",.DGLINE) < D LINE^DGEN("",.DGLINE) < D LINE^DGEN("- Add Date of Death Information in VistA < D LINE^DGEN("",.DGLINE) < D LINE^DGEN("- Contact the HEC to remove an erroneous < D ^XMD < Q < diff -y --suppress-common-lines ./VADemo/r1/DGENA6.m ./VADemo/r2/r/DGENA6.m DGENA6 ;ALB/CJM,ISA,KWP,RTK,LBD - Enrollment API to create e | DGENA6 ;ALB/CJM,ISA,KWP,RTK - Enrollment API to create enrol ;;5.3;Registration;**232,327,417,491,513**;Aug 13, 19 | ;;5.3;Registration;**232,327,417**;Aug 13, 1993 .I $G(PRIORITY)'="",'$$ABOVE2^DGENEGT1(DFN,$G(APP),PR | .I $G(PRIORITY)'="",'$$ABOVE^DGENEGT1(PRIORITY,$P(PRI diff -y --suppress-common-lines ./VADemo/r1/DGENA.m ./VADemo/r2/r/DGENA.m DGENA ;ALB/CJM,ISA/KWP,Zoltan,LBD - Enrollment API - Retrie | DGENA ;ALB/CJM,ISA/KWP,Zoltan - Enrollment API - Retrieve D ;;5.3;Registration;**121,122,147,232,314,564**;Aug 13 | ;;5.3;Registration;**121,122,147,232,314**;Aug 13, 19 ; "ELIG","UNEMPLOY" Unemployable < ; "ELIG","CVELEDT" Combat Veteran End Dat < S DGENR("ELIG","UNEMPLOY")=$P(NODE,"^",17) < S DGENR("ELIG","CVELEDT")=$P(NODE,"^",18) < diff -y --suppress-common-lines ./VADemo/r1/DGENCD1.m ./VADemo/r2/r/DGENCD1.m DGENCD1 ;ALB/CJM,Zoltan,PHH,BRM - Catastrophic Disability Pro | DGENCD1 ;ALB/CJM,Zoltan,PHH - Catastrophic Disability Protoco ;;5.3;Registration;**121,232,387,451**;Aug 13,1993 | ;;5.3;Registration;**121,232,387**;Aug 13,1993 N YN,EXIT,PRI,CDSITE | N YN,EXIT,PRI I $$CDTYPE^DGENCDA(DFN) D ;was determination by phys < .S CDSITE=$$CHKSITE^DGENCDA(DFN) < .I CDSITE D ;CD was determined by this site < ..D BMES^XPDUTL("This veteran is currently determined < ..D MES^XPDUTL("Disabled. You may not change this ev < ..D MES^XPDUTL("to an error in data entry.") < ..S YN=$$YN("Is this edit due to an error in data ent < ..D:"N^"[$E($G(YN)) < ...D BMES^XPDUTL("Additional CD evaluations are not n < ...D MES^XPDUTL("Veteran, as they are currently deter < ...D MES^XPDUTL("this is an edit due to an error, ple < ...D MES^XPDUTL("Add/Edit action and answer YES to th < ...S EXIT=1 < .E D ; CD was determined by another site < ..S SITEINF=$$NS^XUAF4($P(CDSITE,"^",2)) < ..D BMES^XPDUTL("This Catastrophic Disability evaluat < ..D MES^XPDUTL("Please Contact Site "_$P(SITEINF,"^") < ..D MES^XPDUTL("if it is necessary to edit this evalu < ..S EXIT=1 < ..S DIR(0)="EA",DIR("A")="Press return to continue... < I EXIT S VALMBCK="R" Q < ; < > I '$D(^XUSEC("CD DELETE",DUZ)) D Q > .W !!,"Sorry, you do not have the required security k > .H 3 > .D INIT^DGENLCD > .S VALMBCK="R" N DIR,SITE,SITEINF,DIROUT,DIRUT,DTOUT,DUOUT,NOERR | N DIR S SITE=$$CHKSITE^DGENCDA(DFN) < I '$P(SITE,"^") D Q 0 ;CD was not determined at th < .S SITEINF=$$NS^XUAF4($P(SITE,"^",2)) < .D BMES^XPDUTL("This Catastrophic Disability evaluati < .D MES^XPDUTL("Please Contact Site "_$P(SITEINF,"^")) < .D MES^XPDUTL("if it is necessary to delete this eval < ; was this entered in error? < I $$CDTYPE^DGENCDA(DFN) D Q:$G(NOERR) 0 < .D BMES^XPDUTL("This Veteran is currently determined < .D MES^XPDUTL("may not delete this evaluation unless < .S DIR(0)="Y",DIR("B")="NO" < .S DIR("A")="Is this deletion due to an error in data < .D ^DIR < .I $G(DIRUT)!$G(DUOUT)!$G(DIROUT)!$G(DTOUT)!('$G(Y)) < .K DIR,Y < ; < diff -y --suppress-common-lines ./VADemo/r1/DGENCDA1.m ./VADemo/r2/r/DGENCDA1.m DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH,BRM - Catastrophi | DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH - Catastrophic Di ;;5.3;Registration;**121,147,232,302,356,387,475,451* | ;;5.3;Registration;**121,147,232,302,356,387,475**;Au Q:DGCDIS("VCD")="@" 1 ;this is a deletion < diff -y --suppress-common-lines ./VADemo/r1/DGENCDA.m ./VADemo/r2/r/DGENCDA.m DGENCDA ;ALB/CJM,Zoltan,JAN,BRM - Catastrophic Disability API | DGENCDA ;ALB/CJM,Zoltan,JAN - Catastrophic Disability API - R ;;5.3;Registration;**121,147,232,387,451**;Aug 13,199 | ;;5.3;Registration;**121,147,232,387**;Aug 13,1993 ; < CHKSITE(DFN) ;is this the facility that made the CD determ < ; < ;Input: < ; DFN - Patient IEN < ;Output: < ; Function Value - returns 1 if CD evaluation was en < ; 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 E < ; < ;Input: < ; DFN - Patient IEN < ;Output: < ; Function Value - returns 1 if CD='Yes' & Method='P < ; otherwise 0 < ; < Q:'$G(DFN) 0 < Q:'$$HASCAT(DFN) 0 < Q $P($G(^DPT(DFN,.39)),"^",5)=3 < ; < diff -y --suppress-common-lines ./VADemo/r1/DGENCD.m ./VADemo/r2/r/DGENCD.m DGENCD ;ALB/CJM,Zoltan,ISA/KWP,JAN,BRM - Catastrophic Disabi | DGENCD ;ALB/CJM,Zoltan,ISA/KWP,JAN - Catastrophic Disability ;;5.3;Registration;**121,122,232,237,302,387,451**;Au | ;;5.3;Registration;**121,122,232,237,302,387**;Aug 13 . S DGCDIS("FACDET")=$$INST^DGENU() | . I DGCDIS("FACDET")="" S DGCDIS("FACDET")=$$INST^DGE 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 diff -y --suppress-common-lines ./VADemo/r1/DGENDD.m ./VADemo/r2/r/DGENDD.m DGENDD ;ALB/CJM,JAN,LBD - Enrollment Data Dictionary Functio | DGENDD ;ALB/CJM,JAN - Enrollment Data Dictionary Functions; ;;5.3;Registration;**121,351,503**;Aug 13,1993 | ;;5.3;Registration;**121,351**;Aug 13,1993 ; < SETREM(DGENRIEN,STATUS) ; < ;This set logic is called by the Enrollment Status fi < ;the Patient Enrollment file (#27.11). If the Enroll < ;contains the word REJECTED, then "**REJECTED**" will < ;into the Remarks field (#.091) of the Patient file ( < ;Enrollment Status does not contain REJECTED, then th < ;"**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 RE < . S REM=REM_"**REJECTED**" < . S $P(^DPT(DFN,0),U,10)=REM < ;The enrollment status does not contain REJECTED, rem < I REM'["**REJECTED**" G SETREMQ < S REM=$P(REM,"**REJECTED**",1)_$P(REM,"**REJECTED**", < S $P(^DPT(DFN,0),U,10)=REM < SETREMQ L -^DPT(DFN,0) < Q < diff -y --suppress-common-lines ./VADemo/r1/DGENEGT1.m ./VADemo/r2/r/DGENEGT1.m DGENEGT1 ;ALB/KCL,ISA/KWP,LBD,RGL,BRM - Enrollment Gro | DGENEGT1 ;ALB/KCL,ISA/KWP,LBD - Enrollment Group Thres ;;5.3;Registration;**232,417,454,491,513,451,564**;Au | ;;5.3;Registration;**232,417,454**;Aug 13, 1993 ABOVE(DPTDFN,ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ; | ABOVE(ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ; ; Description: This function will determine if the en | ;Description: This function will determine if the enr ; the threshold. | ; > ; IMPORTANT NOTE: > ; =============== > ; Due to the timeline of MEGA Regulations Phase I, ch > ; not be made to ^DPTLK to support modifications to t > ; being passed into this function. > ; > ; DO NOT REMOVE THE EGTPRI AND EGTGRP PARAMETERS UNTI > ; BEEN MODIFIED !!! > ; > ; As a work-around, the EGT settings will be obtained > ; to support modifications to the EGT type 2 (STOP NE > ; logic. At a future date, the EGT parameters should > ; they are no longer necessary. [ALB/BRM October 11, ; DPTDFN - Patient File IEN < ; or EGT type 4 - Enrollment Decision (ESP DG*5.3*491 | I EGT("TYPE")=2 D Q ABOVE I EGT("TYPE")=2!(EGT("TYPE")=4) D Q ABOVE | .S:'$G(DFN) DFN=+$G(DPTDFN) .;check previous enrollment record for EGT Override < .I $$OVRRIDE(.DPTDFN,.EGT) S ABOVE=1 Q < ..I EGT("TYPE")=4,ENRPRI=EGT("PRIORITY"),ENRGRP'=$$SU | ..I ENRGRP=EGT("SUBGRP"),ENRGRP'=$$SUBPRI^DGENELA4(DF ..I ENRGRP=EGT("SUBGRP"),ENRGRP'=$$SUBPRI^DGENELA4(DP < ABOVE2(DPTDFN,ENRDT,PRIORITY,SUBGRP) ; | ABOVE2(ENRDT,PRIORITY,SUBGRP) ; ; Input: DPTDFN - Patient File IEN | ; Input: ENRDT - enrollment effective date ; ENRDT - enrollment effective date < Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(ENRDT),.EGT) 1 | Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) 1 Q:EGT("TYPE")#2 $$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","", | Q:EGT("TYPE")'=2 $$ABOVE(PRIORITY,SUBGRP,"","",1) I '$$ABOVE(DPTDFN,PRIORITY,SUBGRP,"","",1) Q 0 | I '$$ABOVE(PRIORITY,SUBGRP,"","",1) Q 0 I PRIORITY=EGT("PRIORITY"),ENRDT,ENRDT'0 < ; < RULES(DPTDFN,EGTENR,EGT,ENRCAT) ;check for new cont enrollmen < 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")=" < .I EGTENR("ELIG","DISRET")!EGTENR("ELIG","MEDICAID")! < .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:'EN < ..Q:'$D(^DGEN(27.11,ENRIEN)) S NODE0=$G(^DGEN(27.11, < ..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," < ..I ($P(NODEE,"^",11)="Y")!($P(NODEE,"^",13)="Y") S R < S CVDT=$$GET1^DIQ(2,DPTDFN_",",.5295,"I") < I CVDT,CVDT'0 < ; < diff -y --suppress-common-lines ./VADemo/r1/DGENEGT3.m ./VADemo/r2/r/DGENEGT3.m DGENEGT3 ;ALB/KCL/RGL - PROCESS INCOMING MFN HL7 MSGS; | DGENEGT3 ;ALB/KCL - PROCESS INCOMING MFN HL7 MSGS; 04- ;;5.3;Registration;**232,306,417,451**;Aug 13, 1993 | ;;5.3;Registration;**232,306,417**;Aug 13, 1993 ; 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 | ; if there is no current EGT, store EGT from HEC and ;; | I 'CURIEN D Q ;N CURIEN | .I $$STORE^DGENEGT(.DGEGT,,1) ;; | ; ;; is there a current EGT setting? | ; if there is a current EGT, delete current, and stor ;S CURIEN=$$FINDCUR^DGENEGT() | I $$DELETE^DGENEGT(CURIEN) D ;; | .I $$STORE^DGENEGT(.DGEGT,,1) ;; if there is no current EGT, store EGT from HEC and < ;I 'CURIEN D Q < ;.I $$STORE^DGENEGT(.DGEGT,,1) < ;; < ;; if there is a current EGT, delete current, and sto < ;I $$DELETE^DGENEGT(CURIEN) D < ;.I $$STORE^DGENEGT(.DGEGT,,1) < diff -y --suppress-common-lines ./VADemo/r1/DGENEGT.m ./VADemo/r2/r/DGENEGT.m DGENEGT ;ALB/KCL/RGL - Enrollment Group Threshold API's ; 11/ | DGENEGT ;ALB/KCL - Enrollment Group Threshold API's ; 03-MAY- ;;5.3;Registration;**232,451**;Aug 13, 1993 | ;;5.3;Registration;**232**;Aug 13, 1993 FINDCUR(ENRDT) ; | FINDCUR() ; ; Description: Used to find a record in the ENROLLMEN | ; Description: Used to find current record in the ENR ; Input: Enrollment Date (optional - if not specifie | ; Input: None N DGEGTDT,STOP,DGEGTIEN,DGEGTF | Q +$O(^DGEN(27.16,0)) 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!( < .F S DGEGTIEN=$O(^(DGEGTDT,DGEGTIEN),-1) Q:DGEGTIEN= < ..S:'$P($G(^DGEN(27.16,+DGEGTIEN,0)),"^",8) STOP=DGEG < S DGEGTF=1 < I $G(ENRDT),ENRDT'>DT,$$INACT(STOP) ;inactivate old < Q +STOP < N ADD,DATA,OLDEGT,INACT | N ADD,DATA S OLDEGT=$$FINDCUR() < ; inactivate "old" EGT settings < S INACT=$$INACT(ADD,.OLDEGT,.DGEGT) < ; < ; < INACT(EGTIEN,OLDIEN,DGEGT) ;inactivate EGT settings that < ; < ; input: EGTIEN -Current EGT ien from 27.16 < ; DGEGT (optional array) - Current EGT setting < ; DGEGTF (optional) - do not inactivate future < ; < 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 set < 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:' < ..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 -y --suppress-common-lines ./VADemo/r1/DGENELA1.m ./VADemo/r2/r/DGENELA1.m DGENELA1 ;ALB/CJM,RTK,TDM,PJR,RGL,LBD - Patient Eligib | DGENELA1 ;ALB/CJM ,RTK- Patient Eligibility API ; 2/5/ ;;5.3;Registration;**147,327,314,367,497,451,564**;Au | ;;5.3;Registration;**147,327,314,367**;Aug 13,1993 .; | .I (DGELG("VACKAMT")'>0),DGELG("VADISAB")_DGELG("VAPE ...S DGTEXT="Patient was previously determined to be | ...S DGTEXT="Patient was previously determined to be ...S DGTEXT=DGTEXT_"VA care. Please update period of < ..I (DGPAT("DOB")>2061231),(NATCODE=16) S ERRMSG="DOB | ..I (DGPAT("DOB")>2200101),(NATCODE=16) S ERRMSG="DOB ..I (DGPAT("DOB")>2071231),(NATCODE=17) S ERRMSG="DOB | ..I (DGPAT("DOB")>2200101),(NATCODE=17) S ERRMSG="DOB .; Only update User Enrollee fields if the incoming U < .; greater than the USER ENROLLEE VALID THROUGH on fi < .I $G(DATA(.3617))<$P($G(^DPT(DFN,.361)),"^",7) K DAT < .; < Q:SUB="UEYEAR" .3617 < Q:SUB="UESITE" .3618 < Q:SUB="AOEXPLOC" .3213 < Q:SUB="CVELEDT" .5295 < diff -y --suppress-common-lines ./VADemo/r1/DGENELA4.m ./VADemo/r2/r/DGENELA4.m ;;5.3;Registration;**232,275,306,327,314,367,417,437, | ;;5.3;Registration;**232,275,306,327,314,367,417,437, ; determination only if the application da | ; determination, if this date is not passe ; APPDATE - The Enrollment Application Date. This d | ; date (APPDATE) must be passed. ; to determine the priority. If the applic | ; APPDATE - The Enrollment Application Date. This d ; is not passed then the enrollment date ( | ; to determine the priority if the enrollm > ; is not passed. .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q ;can not | .I '$D(DGELG),'$$GET^DGENELA(DFN,.DGELG) Q ;can not .;Added for HVE Phase III (DG*5.3*564) < .S DGELGSUB("UNEMPLOY")=DGELG("UNEMPLOY"),DGELGSUB("C < ; single eligibility code. | ; single eligibilty code. ; CODE - pointer to file #8.1, MAS Eligibility Code | ; CODE - pointer to file #8.1, MAS Eligbility Code ; DGELG - local array obtained by calling $$GET, pas | ; DGELG - local array otained by calling $$GET, pass ; determination only if the application da | ; determination, if this date is not passe ; APPDATE - The Enrollment Application Date. This d | ; date (APPDATE) must be passed. ; to determine the priority. If the applic | ; APPDATE - The Enrollment Application Date. This d ; is not passed then the enrollment date ( | ; to determine the priority if the enrollm > ; is not passed. ; use the Application Date when determining the prior | ; use the Enrollment Date when determining the priori ; the Enrollment Date (ESP DG*5,3*491) | ; the Application Date (Re-Enrollment SRS 6.7.1) S ENRDATE=$S($G(APPDATE):APPDATE,1:$G(ENRDATE)) | S ENRDATE=$S($G(ENRDATE):ENRDATE,1:$G(APPDATE)) .I (DGELG("SC")="Y")&(DGELG("SCPER")>0)&(DGELG("UNEMP < .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER | .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER I "^1^3^"[(U_EGT("TYPE")_U) Q SUBGRP | Q:EGT("TYPE")'=2 SUBGRP I EGT("TYPE")=2,(PRIORITY+(SUBGRP*.01))<(EGT("PRIORIT | I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SU I EGT("TYPE")=4 Q:(PRIORITY D SET(DGARY,DGLINE,"",1,,,,,,.DGCNT) > S DGLINE=DGLINE+1 ;Unemployable (added for DG*5.3*564 - HVE Phase III) < D SET(DGARY,DGLINE,"Unemployable: "_$S($G(DGENR("ELIG < diff -y --suppress-common-lines ./VADemo/r1/DGENRPD1.m ./VADemo/r2/r/DGENRPD1.m DGENRPD1 ;ALB/CJM - Veterans with no Application and w | DGENRPD1 ;ALB/CJM - Veterans with no Application and w ;;5.3;Registration;**147,568**;Aug 13,1993 | ;;5.3;Registration;**147**;08/13/93 I Y'>DT W !,"Date must be later than today!" G REPEAT | I Y
,< .S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC) | .S CLINIC=0 ..Q:$P($G(^SC(CLINIC,0)),"^",3)'="C" | .F S CLINIC=$O(^SC(CLINIC)) Q:'CLINIC D ..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) | ..I $P($G(^SC(CLINIC,0)),"^",3)="C" D APPT(CLINIC,DGE ...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(^TMP($J,"SDAMA301",CLINIC) | .S CLINIC=0 ..Q:$P($G(^SC(CLINIC,0)),"^",3)'="C" | .F S CLINIC=$O(^SC(CLINIC)) Q:'CLINIC D ..S DIVISION=$P($G(^SC(CLINIC,0)),U,15) | ..S NODE=$G(^SC(CLINIC,0)) ..S:'DIVISION DIVISION=$O(^DG(40.8,0)) | ..S DIVISION=$P(NODE,"^",15) ..Q:'DIVISION!('$D(DGENRP("DIVISION",DIVISION))) | ..Q:'DIVISION ..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) | ..I $P(NODE,"^",3)="C",$D(DGENRP("DIVISION",DIVISION) ; < ; Get records for specified Clinics only < .S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC) | .S CLINIC=0 ..Q:'CLINIC!('$D(DGENRP("CLINIC",CLINIC))) | .F S CLINIC=$O(DGENRP("CLINIC",CLINIC)) Q:'CLINIC D ..Q:($P($G(^SC(CLINIC,0)),U,3)'="C") | ..D APPT(CLINIC,DGENRP("BEGIN"),DGENRP("END")) ..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)) < K DGARRAY,^TMP($J,"SDAMA301"),SDCNT < Q < ERR101 S NAM="**Appointment Database is Unavailable**" | ;STEP 2 - make list in following formats ;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT | ;^TMP($J,"STEP2",DIVISION NAME,CLINIC NAME,CATEGORY,A S ^TMP($J,"NOENREC"," ",NAM," ",DT," ")="" < K DGARRAY,^TMP($J,"SDAMA301"),SDCNT,NAM < Q < VALREC(CLINIC,DFN) ; | ;for patients without enrollment records > ;^TMP($J,"NOENREC",DIVISION NAME,CLINIC NAME,CATEGORY N APPT,STATUS,JUSTONCE S JUSTONCE=0 | S DFN=0 S APPT=0 F S APPT=$O(^TMP($J,"SDAMA301",CLINIC,DFN,A | F S DFN=$O(^TMP($J,"STEP1",DFN)) Q:'DFN D .S JUSTONCE=+$G(DGENRP("JUSTONCE")) | .S STATUS=$$STATUS^DGENA(DFN) .; Exclude certain appointment statuses < .S STATUS=$P($P(^TMP($J,"SDAMA301",CLINIC,DFN,APPT),U < .Q:"^N^NA^C^CA^PC^PCA^"[(U_STATUS_U) < .; < .; Don't include enrolled veterans or ones that have < > .; > .;don't include enrolled veterans or ones that have p .; Exclude if not an eligible veteran (can not enroll | .;exclude if not an eligible veteran (can not enroll) .D SETTMP(CLINIC,DFN,APPT) | .S TIME=0 Q | .F S TIME=$O(^TMP($J,"STEP1",DFN,TIME)) Q:'TIME D ; | ..S DIVISION="" SETTMP(CLINIC,DFN,APPT) ; | ..F S DIVISION=$O(^TMP($J,"STEP1",DFN,TIME,DIVISION) ; NOENREC is for patients without enrollment records | ...S CLINIC=0 ; SITE2 is for other excluded enrollment records | ...F S CLINIC=$O(^TMP($J,"STEP1",DFN,TIME,DIVISION,C ;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT | ....N DIVNAME,CLNAME ; | ....S DIVNAME=$S(DIVISION:$P($$SITE^VASITE(TIME\1,DIV N DIVNAME,CLNAME | ....S CLNAME=$P($G(^SC(CLINIC,0)),"^") S DIVNAME=$S(DIVISION:$P($$SITE^VASITE(APPT\1,DIVISIO | ....S:CLNAME="" CLNAME=" " S CLNAME=$P($G(^SC(CLINIC,0)),"^") | ....I $$FINDCUR^DGENA(DFN)="" D Q S:CLNAME="" CLNAME=" " | ..... S ^TMP($J,"NOENREC",DIVNAME,CLNAME,CATEGORY,TIM ; | ....S ^TMP($J,"STEP2",DIVNAME,CLNAME,CATEGORY,TIME,DF I $$FINDCUR^DGENA(DFN)="" S ^TMP($J,"NOENREC",DIVNAME | Q S ^TMP($J,"STEP2",DIVNAME,CLNAME,CATEGORY,APPT,DFN)=$ | ; > APPT(CLINIC,BEGIN,END) ; > ;Description: Lists all the appointments for given cl > ; > 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>E > .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 > ..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)=PAT diff -y --suppress-common-lines ./VADemo/r1/DGENRPT1.m ./VADemo/r2/r/DGENRPT1.m DGENRPT1 ;ALB/DW,LBD - EGT Preliminary Summary Impact | DGENRPT1 ;ALB/DW - EGT Preliminary Summary Impact Repo ;;5.3;Registration;**232,306,417,456,491,513**;Aug 13 | ;;5.3;Registration;**232,306,417,456**;Aug 13,1993 S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP | S EGTTP=$S(EGTTP="":"",EGTTP=1:"Annual Fiscal Year",E S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) | S ABV=$$ABOVE^DGENEGT1(PRT,PRTSUB) diff -y --suppress-common-lines ./VADemo/r1/DGENRPT2.m ./VADemo/r2/r/DGENRPT2.m DGENRPT2 ;ALB/DW,LBD - EGT Preliminary Detailed Impact | DGENRPT2 ;ALB/DW - EGT Preliminary Detailed Impact Rep ;;5.3;Registration;**232,306,417,456,491,513,568**;Au | ;;5.3;Registration;**232,306,417,456**;Aug 13,1993 S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP | S EGTTP=$S(EGTTP="":"",EGTTP=1:"Annual Fiscal Year",E D GETAPPT^DGENRPT5("BY2") < S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) | S ABV=$$ABOVE^DGENEGT1(PRT,PRTSUB) I $D(^TMP($J,"SDAMA",101)) S X="Appt. DB Unavail." Q | D CALSDA D BLDUTL^DGENRPT5(DFN) | I VAERR=1 S X="N/A" Q I $D(^TMP($J,"SDAMA",101)) S X="Appt. DB Unavail." Q | D CALSDA D BLDUTL^DGENRPT5(DFN) | I VAERR=1 S X="N/A" Q > CALSDA ;Use API to get appointments. > N X > S VASD("F")=DT,VASD("W")=12 D SDA^VADPT > Q > ; S X=$$PCPRACT^DGSDUTL(DFN) | S X=$$OUTPTPR^SDUTL3(DFN) diff -y --suppress-common-lines ./VADemo/r1/DGENRPT3.m ./VADemo/r2/r/DGENRPT3.m DGENRPT3 ;ALB/DW,LBD - EGT Actual Summary Impact Repor | DGENRPT3 ;ALB/DW - EGT Actual Summary Impact Report ; ;;5.3;Registration;**232,306,417,456,491,513**;Aug 13 | ;;5.3;Registration;**232,306,417,456**;Aug 13,1993 S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP | S EGTTP=$S(EGTTP="":"",EGTTP=1:"Annual Fiscal Year",E S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) | S ABV=$$ABOVE^DGENEGT1(PRT,PRTSUB) diff -y --suppress-common-lines ./VADemo/r1/DGENRPT4.m ./VADemo/r2/r/DGENRPT4.m DGENRPT4 ;ALB/DW,LBD/EG - EGT Actual Detailed Impact R | DGENRPT4 ;ALB/DW - EGT Actual Detailed Impact Report ; ;;5.3;Registration;**232,306,417,456,491,513,568,585* | ;;5.3;Registration;**232,306,417,456**;Aug 13,1993 S EGTTP=$$EXTERNAL^DILFD(27.16,.04,"F",EGTTP) S:EGTTP | S EGTTP=$S(EGTTP="":"",EGTTP=1:"Annual Fiscal Year",E D GETAPPT^DGENRPT5("BY4") < S ABV=$$ABOVE^DGENEGT1(DFN,PRT,PRTSUB) | S ABV=$$ABOVE^DGENEGT1(PRT,PRTSUB) ;if there is lower level data, then it is an error eg | D CALSDA I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." | I VAERR=1 S X="N/A" Q D BLDUTL^DGENRPT5(DFN) < ;in order to be a valid appointment, there must be | D CALSDA ;lower level subscripts. if not, then it is | I VAERR=1 S X="N/A" Q ;an error eg 01/20/2005 < I $D(^TMP($J,"SDAMA",101))=1 S X="Appt. DB Unavail." < D BLDUTL^DGENRPT5(DFN) < > CALSDA ;Call API to get patient appoinments. > N X > S VASD("F")=DT,VASD("W")=12 D SDA^VADPT > Q > ; S X=$$PCPRACT^DGSDUTL(DFN) | S X=$$OUTPTPR^SDUTL3(DFN) Only in ./VADemo/r1/: DGENRPT5.m diff -y --suppress-common-lines ./VADemo/r1/DGENU.m ./VADemo/r2/r/DGENU.m DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD - Enrollment Utilities; 1 | DGENU ;ALB/CJM,ISA/KWP,Zoltan - Enrollment Utilities; 12/11 ;;5.3;Registration;**121,122,147,232,314,564**;Aug 13 | ;;5.3;Registration;**121,122,147,232,314**;Aug 13,199 .I SUB="UNEMPLOY" S FLD=50.17 Q < .I SUB="CVELEDT" S FLD=50.18 Q < diff -y --suppress-common-lines ./VADemo/r1/DGENUPL3.m ./VADemo/r2/r/DGENUPL3.m DGENUPL3 ;ALB/CJM,ISA/KWP,AEG,BRM - PROCESS INCOMING ( | DGENUPL3 ;ALB/CJM,ISA/KWP,AEG - PROCESS INCOMING (Z11 ;;5.3;REGISTRATION;**147,230,232,377,404,451**;Aug 13 | ;;5.3;REGISTRATION;**147,230,232,377,404**;Aug 13,199 N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG,CD | N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG S (ELIG,NSC,POW,CD)=0 | S (ELIG,NSC,POW)=0 .I MSGS(COUNT)["POW" S POW=1 Q | .I MSGS(COUNT)["POW" S POW=1 .I MSGS(COUNT)["CD EVALUATION" S CD=1 Q < .I CD S HEADER="CD Alert: " Q < diff -y --suppress-common-lines ./VADemo/r1/DGENUPL4.m ./VADemo/r2/r/DGENUPL4.m DGENUPL4 ;ALB/CJM,RTK,ISA/KWP,ISD/GSN,PHH,RGL,PJR,BRM, | DGENUPL4 ;ALB/CJM,RTK,ISA/KWP,ISD/GSN - PROCESS INCOMI ;;5.3;REGISTRATION;**147,177,232,253,327,367,377,514, | ;;5.3;REGISTRATION;**147,177,232,253,327,367,377**;Au .; < .; Check for erroneous CD deletion < .I OLDCDIS("VCD")="","@"[DGCDIS("VCD") Q ;no notific < .; < .; CD Determination Changed < .I OLDCDIS("VCD")'=DGCDIS("VCD") D ADDMSG^DGENUPL3(.M < D EP^DGENUPLB < .I $D(DGCDIS(SUB))=1 I ($G(DGCDIS(SUB))'="") S DGCDIS | .I $D(DGCDIS(SUB))=1 I ($G(DGCDIS(SUB))'="") S DGCDIS .I $D(DGCDIS(SUB))=10 D | .I $D(DGCDIS(SUB))=10 S SUB2="" F S SUB2=$O(DGCDIS(S ..S SUB2="" < ..F S SUB2=$O(DGCDIS(SUB,SUB2)) Q:SUB2="" D < ...I ($G(DGCDIS(SUB,SUB2))'="") S DGCDIS3(SUB,SUB2)=D < ...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 < ;Agent Orange Exp. Location, use local database when < D AO^DGENUPL9 < diff -y --suppress-common-lines ./VADemo/r1/DGENUPL5.m ./VADemo/r2/r/DGENUPL5.m DGENUPL5 ;ALB/KCL/GSN - PROCESS INCOMING (Z11 EVENT TY | DGENUPL5 ;ALB/KCL - PROCESS INCOMING (Z11 EVENT TYPE) ;;5.3;Registration;**222,504**;08/13/93 | ;;5.3;Registration;**222**;08/13/93 > ; ;DG*5.3*504 - Now, only updates the DG SECURITY LOG f < ; node, when SECURITY LEVEL [#2] goes fro < ; value to a Sensitive value, i.e. (null < .; if new level = Yes and old level Not = Yes | .I $$UPDATE^DGENSEC(DFN,.DGSEC) .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 sa < ..; Audit record from being created later. < ..M DGSEC=OLDSEC < diff -y --suppress-common-lines ./VADemo/r1/DGENUPL7.m ./VADemo/r2/r/DGENUPL7.m DGENUPL7 ;ISA/KWP/CKN - PROCESS INCOMING (Z11 EVENT TY | DGENUPL7 ;ISA/KWP/CKN - PROCESS INCOMING (Z11 EVENT TY ;;5.3;REGISTRATION;**232,367,397,417,379,431,513,628* | ;;5.3;REGISTRATION;**232,367,397,417,379,431**;Aug 13 ..; < ..; removed EGT consistency check with DG*5.3*628 < ..;I "^11^12^13^14^22^"[("^"_DGENR("STATUS")_"^"),$$A | ..I "^11^12^13^14^22^"[("^"_DGENR("STATUS")_"^"),$$AB ..;.S ERROR=1 | ...S ERROR=1 ..;.S ERRMSG="THE ENROLLMENT RECORD DID NOT PASS THE | ...S ERRMSG="THE ENROLLMENT RECORD DID NOT PASS THE E ..;.D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERR | ...D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),ERRMSG,.ERRC ..; < diff -y --suppress-common-lines ./VADemo/r1/DGENUPL8.m ./VADemo/r2/r/DGENUPL8.m DGENUPL8 ;ISA/KWP,RTK,PHH - PROCESS INCOMING (Z11 EVEN | DGENUPL8 ;ISA/KWP,RTK - PROCESS INCOMING (Z11 EVENT TY ;;5.3;REGISTRATION;**232,266,327,314,365,417,514**;Au | ;;5.3;REGISTRATION;**232,266,327,314,365,417**;Aug 13 > ;Phase II if local enrollment is UNVERIFIED(1) or REJ > I CURENR("STATUS")=1!(CURENR("STATUS")=14),(CURENR("E > .D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"LOCAL SITE RE > .S ERROR=1 > ; diff -y --suppress-common-lines ./VADemo/r1/DGENUPL9.m ./VADemo/r2/r/DGENUPL9.m DGENUPL9 ;ISA/KWP,JAN,BRM,PJR,LBD - CD CONSISTENCY CHE | DGENUPL9 ;ISA/KWP,JAN - CD CONSISTENCY CHECKS ;5/7/99; ;;5.3;REGISTRATION;**232,378,451,564,628**;Aug 13,199 | ;;5.3;REGISTRATION;**232,378**;Aug 13,1993 ; VistA Changes (DG*5.3*451) added CCs listed below i | ;Phase II (SRS 6.5.1.4 a) ; previous Consistency Checks based on new business r | ;If CD is Y on VISTA and update is No or null send er ; | I OLDCDIS("VCD")="Y",DGCDIS("VCD")'="Y" D Q 0 N CDERR | .D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"CD Error: VET ; Reject CD update if required fields are missing | ;Phase II (SRS 6.5.1.4 b) I DGCDIS("VCD")="Y",'$$CHECK^DGENCDA1(.DGCDIS,.CDERR) | ;If CD is Yes and method of determination is 3 on VIS ; | I OLDCDIS("VCD")="Y",OLDCDIS("METDET")=3,DGCDIS("VCD" ; If CD is Yes on VISTA and update is Yes and the cur | .D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"CD Error: Phy ; Decision is more recent than the incoming one, reje | ;Phase II (SRS 6.5.1.4 c) I OLDCDIS("VCD")="Y",DGCDIS("VCD")="Y",DGCDIS("DATE") | ;If CD is Yes and determination of 3 on VISTA and upd ; | ; If the date of decision on update is not greater th ; CD evaluation of 'NO' shall not overwrite a CD eval | I OLDCDIS("VCD")="Y",OLDCDIS("METDET")=3,DGCDIS("VCD" ; 'YES' unless it is from the originating site. | .D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"CD Error: Phy I OLDCDIS("VCD")="Y",DGCDIS("VCD")="N",OLDCDIS("FACDE | ;Phase II (SRS6.5.1.4 d) > ;If CD is Yes or No on VISTA and update is null then > I OLDCDIS("VCD")="Y"!(OLDCDIS("VCD")="N"),DGCDIS("VCD > .D ADDERROR^DGENUPL(MSGID,DGPAT("SSN"),"CD Error: CD AO ;Agent Orange Exp. Location - overflow code from MERG < I DGELG("AO")'="" D < . I DGELG("AO")="Y",OLDELG("AOEXPLOC")="" D < . . S DGELG3("AOEXPLOC")="V" D BULLETIN < . I DGELG("AO")="N",OLDELG("AOEXPLOC")'="" D < . . S DGELG3("AOEXPLOC")="@" D BULLETIN < Q < BULLETIN ;Agent Orange Exposure Location Change < ; >> this function has been removed based on a custo < ; >> the code is being left for reactivation if desi < Q < N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT, < 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 < 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 Loc < D LINE^DGEN("Contact the HEC by phone if you have que < D LINE^DGEN("this information to be incorrect.",.DGLI < D ^XMD < Q < diff -y --suppress-common-lines ./VADemo/r1/DGENUPLA.m ./VADemo/r2/r/DGENUPLA.m DGENUPLA ;ALB/CKN,TDM,PJR,RGL - PROCESS INCOMING (Z11 | DGENUPLA ;ALB/CKN - PROCESS INCOMING (Z11 EVENT TYPE) ;;5.3;REGISTRATION;**397,379,497,451,564**;Aug 13,199 | ;;5.3;REGISTRATION;**397,379**;Aug 13,1993 .N AOERR S AOERR=ERROR ; See SEG(29) belo < .; < . S DGELG("AOEXPLOC")=SEG(29) < .; Logic enhanced during SQA of patch 451. AOERR fro < . I 'AOERR,DGELG("AO")'="Y",DGELG("AOEXPLOC")="" S DG < . S DGELG("UEYEAR")=$$CONVERT^DGENUPL1(SEG(34),"DATE" < . I ERROR D Q < . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VA < . S DGELG("UESITE")=$$CONVERT^DGENUPL1(SEG(35),"INSTI < . I ERROR D Q < . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VA < . S DGELG("CVELEDT")=$$CONVERT^DGENUPL1(SEG(38),"DATE < . I ERROR D Q < . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VA < Only in ./VADemo/r1/: DGENUPLB.m diff -y --suppress-common-lines ./VADemo/r1/DGENUPL.m ./VADemo/r2/r/DGENUPL.m DGENUPL ;ALB/CJM,ISA/KWP,TDM - PROCESS INCOMING (Z11 EVENT TY | DGENUPL ;ALB/CJM,ISA/KWP - PROCESS INCOMING (Z11 EVENT TYPE) ;;5.3;REGISTRATION;**147,222,232,363,472,497,564**;Au | ;;5.3;REGISTRATION;**147,222,232,363,472**;Aug 13,199 .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) diff -y --suppress-common-lines ./VADemo/r1/DGFCPROT.m ./VADemo/r2/r/DGFCPROT.m DGFCPROT ;FLB/ALB-DG Field Monitor cross-reference ini | DGFCPROT ;FLB/ALB-DG Field Monitor cross-reference ini ;;5.3;Registration;**273,526**;AUG 13, 1993 | ;;5.3;Registration;**273**;AUG 13, 1993 N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTSK,DGVAR,BXREF,SUB | N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTSK,DGVAR,BXREF,SUB S ZTIO="DG FIELD MONITOR",ZTDTH=$$NOW^XLFDT | S ZTIO="",ZTDTH=$$NOW^XLFDT I $D(ZTQUEUED) S ZTREQ="@" < Only in ./VADemo/r1/: DGFFP01.m Only in ./VADemo/r1/: DGFFP02.m Only in ./VADemo/r1/: DGFFP03.m Only in ./VADemo/r1/: DGFFP04.m Only in ./VADemo/r1/: DGFFPLM1.m Only in ./VADemo/r1/: DGFFPLM.m Only in ./VADemo/r1/: DGIBDSP.m Only in ./VADemo/r1/: DGJ1P1.m Only in ./VADemo/r1/: DGJCSL.m diff -y --suppress-common-lines ./VADemo/r1/DGLOCK2.m ./VADemo/r2/r/DGLOCK2.m DGLOCK2 ;ALB/MRL - PATIENT FILE DATA EDIT CHECKS ; 28 Jan 200 | DGLOCK2 ;ALB/MRL - PATIENT FILE DATA EDIT CHECKS ; 28 JUL 86 ;;5.3;Registration;**18,244**;Aug 13, 1993 | ;;5.3;Registration;**18**;Aug 13, 1993 I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < EM1 I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN | EM1 I $S('$D(^DPT(DFN,.311)):1,"^3^9^"[$P(^(.311),U,15):1 I $S('$D(^DPT(DFN,.311)):1,"^3^9^"[$P(^(.311),U,15):1 < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN < diff -y --suppress-common-lines ./VADemo/r1/DGLOCK3.m ./VADemo/r2/r/DGLOCK3.m DGLOCK3 ;ALB/BOK - PATIENT FILE MUMPS TRIGGER/DATA EDIT CHECK | DGLOCK3 ;ALB/BOK - PATIENT FILE MUMPS TRIGGER ; 28 NOV 86 ;;5.3;Registration;**489,527**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 CAD ;Confidential Address Edit < I $S('$D(^DPT(DFN,.141)):1,$P(^(.141),U,9)'="Y":1,1:0 < .D EN^DDIOL("Requirement for Confidential Address dat < Q < CADD ;Confidential Address Delete < ;Called from input transform on Confidential Address < Q:'$D(^DPT(DFN,.141)) I $P(^(.141),"^",9)="N"!($P(^( < .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 d < ASK1 ; < Q:%'=1 < ;S DGTEMPH=$P(^DPT(DFN,.141),"^",7,8),^(.141)="^^^^^^ < N DGFDA,DGERR,DGX,DGFLD < F DGFLD=.1411,.1412,.1413,.1414,.1415,.1416,.14111 S < 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 A < Q < diff -y --suppress-common-lines ./VADemo/r1/DGLOCK.m ./VADemo/r2/r/DGLOCK.m ;;5.3;Registration;**108,161,247,485**;Aug 13, 1993 | ;;5.3;Registration;**108,161,247**;Aug 13, 1993 FFP ; DGFFP Access key required < I '$D(^XUSEC("DGFFP ACCESS",DUZ)) D EN^DDIOL("Fugitiv < Q < Only in ./VADemo/r1/: DGMSCK.m Only in ./VADemo/r1/: DGMSRPT1.m Only in ./VADemo/r1/: DGMSRPT2.m Only in ./VADemo/r1/: DGMSRPT.m diff -y --suppress-common-lines ./VADemo/r1/DGMSTR2.m ./VADemo/r2/r/DGMSTR2.m DGMSTR2 ;ALB/SCK - MST DETAILED DEMOGRAPHIC REPORT ; 11/19/03 | DGMSTR2 ;ALB/SCK - MST DETAILED DEMOGRAPHIC REPORT ; 1/14/99 ;;5.3;Registration;**195,555**;Aug 13, 1993 | ;;5.3;Registration;**195**;Aug 13, 1993 .. S X=$$HEADER(MSTST,DGDSP,DGBEG,DGEND) ;DG*5.3*264 | .. S X=$$HEADER("",DGDSP,DGBEG,DGEND) . S X=$$HEADER(MSTST,DGDSP,DGBEG,DGEND) | . S X=$$HEADER("",DGDSP,DGBEG,DGEND) .. S X=$$HEADER(MSTST,DGDSP,DGBEG,DGEND) | .. S X=$$HEADER("",DGDSP,DGBEG,DGEND) diff -y --suppress-common-lines ./VADemo/r1/DGMTA.m ./VADemo/r2/r/DGMTA.m DGMTA ;ALB/RMO/CAW/LD/SCG/AEG/PHH - Add a New Means Test ; | DGMTA ;ALB/RMO/CAW/LD/SCG/AEG - Add a New Means Test ;3/12/ ;;5.3;Registration;**33,45,137,166,177,182,290,344,33 | ;;5.3;Registration;**33,45,137,166,177,182,290,344,33 PRINT I "^P^A^C^G^"[(U_$P(DGLDT,U,4)_U) S %=1 W !,"Do you w | PRINT I "^P^A^C^"[(U_$P(DGLDT,U,4)_U) S %=1 W !,"Do you wis ; 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 DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_ | .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE_ | .S DIC("DR")="2////"_(DGMTYPT'=4)_";2.05////"_DGSITE ;;Patient is Service Connected 50-100%. | ;;Patient has a Primary or Other Eligibility Code of ;;Patient was a POW, automatically exempted. < ;;Patient is Unemployable, automatically exempted. < diff -y --suppress-common-lines ./VADemo/r1/DGMTARR.m ./VADemo/r2/r/DGMTARR.m DGMTARR ;ALB/GRR/PHH - PRINT ROUTINES FOR MEANS TEST VERIFICA | DGMTARR ;ALB/GRR - PRINT ROUTINES FOR MEANS TEST VERIFICATION ;;5.3;Registration;**217,535**;AUG 13, 1993 | ;;5.3;Registration;**217**;AUG 13, 1993 .Q:$P(DGMT0,"^",19)'=1 < .Q:$P(DGMT0,"^",19)'=1 < diff -y --suppress-common-lines ./VADemo/r1/DGMTCOR.m ./VADemo/r2/r/DGMTCOR.m DGMTCOR ;ALB/CAW,SCG,LBD - Check Copay Test Requirements ; 03 | DGMTCOR ;ALB/CAW,SCG - Check Copay Test Requirements ; 01/22/ ;;5.3;Registration;**21,45,182,290,305,330,344,495,56 | ;;5.3;Registration;**21,45,182,290,305,330,344**;Aug ; - Applicants who do not have POW eligibility (DG*5 < ; - Applicants who do not meet criteria for Unemploy < ; Unemployable="Y", SC%>0, not receiving A&A, HB < ; Total VA Check Amount>0 (DG*5.3*564 - HVE III < S IVMZ10F=+$G(IVMZ10F) | I 'DGMTCOR,'$G(DGADDF),'$G(DGMDOD) D NLA I 'DGMTCOR,'$G(DGADDF),'$G(DGMDOD),'IVMZ10F D NLA < CHK N STATUS,DGELIG,DGE,DGI,DGNODE,DGMDOD,DGMTDT,DGMTI,DG | CHK N STATUS,ELIG,ELIGIEN,DGNODE,DGMDOD,DGMTDT S DGMTL=$$LST^DGMTU(DFN),DGMTI=+DGMTL,DGMTDT=$P(DGMTL | S DGMTI="",DGMTI=+$$LST^DGMTU(DFN) > S:DGMTI DGMTDT=$P($G(^DGMT(408.31,DGMTI,0)),U) I '$P($G(^DPT(DFN,.36)),U) S DGMTCOR=0,DGWRT=2 G CHKQ | S DGMTI=0 I '$P($G(^DPT(DFN,.36)),U) S DGMTCOR=0,DGWR S DGI=$P($G(^DPT(DFN,.36)),"^"),DGELIG=U_$P($G(^DIC(8 | S ELIG=$P($G(^DPT(DFN,.36)),"^") I ELIG S DGMTE=$P($G S DGI=0 F S DGI=$O(^DPT(DFN,"E",DGI)) Q:'DGI S DGE= | S ELIGIEN=0 F S ELIGIEN=$O(^DPT(DFN,"E",ELIGIEN)) Q: I (DGELIG["^1^") S DGMTCOR=0,DGWRT=3 G CHKQ ;SC 50-1 | S DGNODE=$$LST^DGMTU(DFN),DGMTI=+DGNODE F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) < I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR= < I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR < I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR= < I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0 < I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(D < I DGMTI,'$$OLD^DGMTU4(DGMTDT) S STATUS=$P($G(^DGMT(40 | I DGMTI,'$$OLD^DGMTU4($P(DGNODE,"^",2)) S STATUS=$P($ > S DGNODE=$G(^DPT(DFN,.362)) > I DGMTCOR,$P(DGNODE,U,12)["Y" S DGMTCOR=0,DGWRT=5 G C > I DGMTCOR,$P(DGNODE,U,13)["Y" S DGMTCOR=0,DGWRT=6 G C > I DGMTCOR,$P(DGNODE,U,14)["Y" S DGMTCOR=0,DGWRT=7 G C diff -y --suppress-common-lines ./VADemo/r1/DGMTCOU1.m ./VADemo/r2/r/DGMTCOU1.m DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES ; 8 | DGMTCOU1 ;ALB/REW,LD,JAN,AEG - COPAY UTILITIES ; 03/22 ;;5.3;Registration;**33,45,54,335,358,401,436,445,564 | ;;5.3;Registration;**33,45,54,335,358,401,436,445**;A ; OUTPUT: (SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PT^NON.V | ; OUTPUT: (SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PATIENT^ ; Piece: ( 1 ^ 2 ^ 3 ^ 4 ^ 5 ^ 6 | ; Piece: ( 1 ^ 2 ^ 3 ^ 4 ^ 5 ^ N DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT,DGI | N DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) | S DGNODE=$G(^DPT(DFN,.362)) I $P(DGNODE(.362),U,12)["Y"!(DGALLEL["^2^") S $P(DGX, | I $P(DGNODE,U,12)["Y"!(DGALLEL["^2^") S $P(DGX,U,2)=1 I $P(DGNODE(.362),U,13)["Y"!(DGALLEL["^15^") S $P(DGX | I $P(DGNODE,U,13)["Y"!(DGALLEL["^15^") S $P(DGX,U,3)= I $P(DGNODE(.362),U,14)["Y"!(DGALLEL["^4^") S $P(DGX, | I $P(DGNODE,U,14)["Y"!(DGALLEL["^4^") S $P(DGX,U,4)=1 I $P(DGNODE(.52),U,5)["Y"!(DGALLEL["^18^") S $P(DGX,U < I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(D < diff -y --suppress-common-lines ./VADemo/r1/DGMTDD2.m ./VADemo/r2/r/DGMTDD2.m DGMTDD2 ;ALB/RMO,LBD - Income Relation file (#408.22) Data Di | DGMTDD2 ;ALB/RMO - Income Relation file (#408.22) Data Dictio ;;5.3;Registration;**33,45,518**;Aug 13, 1993 | ;;5.3;Registration;**33,45**;Aug 13, 1993 ; If the test is a LTC Copay test do not delete the | N DGFLD,DGIN0,DGINI,DGVAL ; burial expenses. Added for LTC Phase III (DG*5.3* < N DGFLD,DGIN0,DGINI,DGVAL,DGMT < S DGMT=+$G(^DGMT(408.21,DGINI,"MT")) | S DGFLD=1.01,DGVAL=$P(DGIN1,U,2) I DGMT,$P($G(^DGMT(408.31,DGMT,0)),U,19)=3 Q < S DGFLD=1.02,DGVAL=$P(DGIN1,U,2) < diff -y --suppress-common-lines ./VADemo/r1/DGMTDEL1.m ./VADemo/r2/r/DGMTDEL1.m DGMTDEL1 ;ALB/CAW,LBD,PHH - Delete MT for a Patient (c | DGMTDEL1 ;ALB/CAW - Delete MT for a Patient (con't) ;1 ;;5.3;Registration;**45,166,182,433,518,531**;Aug 13, | ;;5.3;Registration;**45,166,182,433**;Aug 13, 1993 .; < .; Delete the $0.00 values out of the net worth field < .; 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)'="" AM < ..I 'AMTFLG S DIE="^DGMT(408.21,",DR="31///@;2.01///@ < > . S GIEN=$O(^DGMT(408.31,"AT",IEN4,"")) ;Test type 3 .; Added FOR loop for LTC Phase III to support multi | . I GIEN S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," . S GIEN="" F S GIEN=$O(^DGMT(408.31,"AT",IEN4,GIEN) < . . S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DI < .;Check to see if test type 3 is linked with type 4 | . S GIEN=$O(^DGMT(408.31,"AT",DGMTI,"")) Q:GIEN="" ; .; Added FOR loop for LTC Phase III to support multi | . S DA=GIEN,DIE="^DGMT(408.31,",DR="2.08///@" D ^DIE . S GIEN="" F S GIEN=$O(^DGMT(408.31,"AT",DGMTI,GIEN < . . S DA=GIEN,DR="2.08///@",DIE="^DGMT(408.31," D ^DI < diff -y --suppress-common-lines ./VADemo/r1/DGMTO1.m ./VADemo/r2/r/DGMTO1.m DGMTO1 ;ALB/CAW,AEG/EG - AGREED TO PAY DEDUCTIBLE PRINT (CON | DGMTO1 ;ALB/CAW,AEG - AGREED TO PAY DEDUCTIBLE PRINT (CON'T) ;;5.3;Registration;**33,182,358,568,585**;Aug 13, 199 | ;;5.3;Registration;**33,182,358**;Aug 13, 1993 D ACTIVE < D CLOSE^DGMTUTL | D CLOSE^DGMTUTL Q Q | CATCLST N DGWHEN,DGDT,IEN,NODE0 ; < CATCLST N DGDT,IEN,NODE0 < .S ^TMP("DGMTO",$J,"CNULL",$P(NODE0,U,1),DFN)=";;"_$P | .S DGWHEN="" > .I $$ACTIVE(DGYRAGO,DGTODAY) S $P(DGWHEN,U,1)="X" ;PA > .I +$G(^DPT(DFN,.105)) S $P(DGWHEN,U,2)="X" ;INHOUSE > .I $$ACTIVE(DGTODAY,9999999) S $P(DGWHEN,U,3)="X" ;FU > .S:DGWHEN]"" ^TMP("DGMTO",$J,"CNULL",$P(NODE0,U,1),DF ; | ACTIVE(FROM,TO) ; ACTIVE ; | ;Y=0 IF NOT ACTIVE N APWHEN,I,VETARRAY,PIEN,PNAME,RCNT,ACNT,DGARRAY,SDCN | ;1:DISPOSITION S ACNT=1,RCNT=0 | ;2:CLINIC APPT S PNAME="" F S PNAME=$O(^TMP("DGMTO",$J,"CNULL",PNAM | ;3:SCHEDULED ADMISSION .S PIEN=0 F S PIEN=$O(^TMP("DGMTO",$J,"CNULL",PNAME, | ;4:PATIENT MOVEMENT ..S RCNT=RCNT+1,VETARRAY(ACNT)=$G(VETARRAY(ACNT))_PIE | ; ..; Group DFNs by no more than twenty records | N A,X,Y ..I RCNT>19 S ACNT=ACNT+1,RCNT=0 | S Y=0 ; | S X=$O(^DPT(DFN,"DIS",(9999999-TO))) S:X&(X<(9999999- ; Call SD API by array of Patient DFNs | I 'Y S X=$O(^DPT(DFN,"S",FROM)) S:(+X)&(+X0 S X .S DGARRAY("FLDS")="1",DGARRAY(4)=VETARRAY(I) | I 'Y S X=$O(^DGPM("APRD",DFN,FROM)) S:(+X)&(+XDT S $P(APWHEN,U,3)="X" < ..K PATAPPT < ..I APWHEN']"" D < ...S CK1=$O(^DGPM("APRD",PATIEN,DGYRAGO)) I (+CK1)&(+ < ...S CK3=$O(^DGPM("APRD",PATIEN,DGTODAY)) I (+CK3) S < ..S:APWHEN]"" $P(^TMP("DGMTO",$J,"CNULL",PATNAM,PATIE < ..I APWHEN']"" K ^TMP("DGMTO",$J,"CNULL",PATNAM,PATIE < K ^TMP($J,"SDAMA") < Q < W:$D(^TMP("DGMTO",$J,"CNULL",101)) !,?5,"Appointment < diff -y --suppress-common-lines ./VADemo/r1/DGMTOFA.m ./VADemo/r2/r/DGMTOFA.m DGMTOFA ;ALB/CAW/AEG - Future Appointments who will require M | DGMTOFA ;ALB/CAW/AEG - Future Appointments who will require M ;;5.3;Registration;**3,50,182,326,426,568**;Aug 13, 1 | ;;5.3;Registration;**3,50,182,326,426**;Aug 13, 1993 K DGARRAY,CLNARRAY,^TMP($J,"SDAMA"),I,DGTMP,SDCNT < K ^TMP("DGMTO",$J) S I=1 < I VAUTC=1,VAUTD=1 S DGCLN=0 F S DGCLN=$O(^SC(DGCLN)) < I VAUTC=1,VAUTD=0 S DGDIV="" F S DGDIV=$O(VAUTD(DGDI | K ^TMP("DGMTO",$J) I VAUTC=0 S DGCLN="" F S DGCLN=$O(VAUTC(DGCLN)) Q:'D | I VAUTC=1,VAUTD=1 S DGCLN=0 F S DGCLN=$O(^SC(DGCLN)) D SDAM,CLN1 | I VAUTC=1,VAUTD=0 S DGDIV="" F S DGDIV=$O(VAUTD(DGDI > S DGCLN="" F S DGCLN=$O(VAUTC(DGCLN)) Q:'DGCLN D CL CBLD3(DGCLN) ; Build array of specified Clinics for specif < S CLNARRAY(I)=$G(CLNARRAY(I))_DGCLN_";" < I $L(CLNARRAY(I))>120 S I=I+1 < Q < ; < SDAM ; Build TMP Global with Appointment API Data for Repo < 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 < ; < N DGTMP S DGDATE=DGBEG-.1,DGLST=DGEND+.9 | S DGDATE=DGBEG-.1,DGLST=DGEND+.9 S DGCLN=0 F S DGCLN=$O(^TMP($J,"SDAMA",DGCLN)) Q:'DG | F S DGDATE=$O(^SC(DGCLN,"S",DGDATE)) Q:'DGDATE!(DGDA .S DGDFN=0 F S DGDFN=$O(^TMP($J,"SDAMA",DGCLN,DGDFN) | .Q:DGCLN'=+DGPAT ..S DGDATE=0 F S DGDATE=$O(^TMP($J,"SDAMA",DGCLN,DGD | .Q:$$DOM(DGDFN,DGDATE) ...S DGTMP=^TMP($J,"SDAMA",DGCLN,DGDFN,DGDATE) | .Q:"^N^NA^C^CA^PC^PCA^"[(U_$P(DGPAT,U,2)_U) ...Q:$$DOM(DGDFN,DGDATE) | .D MT ...Q:"^N^NA^C^CA^PC^PCA^"[(U_$P($P(DGTMP,U,3),";")_U) < ...D MT < .S ^TMP("DGMTO",$J,$S(+$P(^SC(DGCLN,0),U,15):$P(^(0), | .S ^TMP("DGMTO",$J,$S(+$P(^SC(DGCLN,0),U,15):$P(^(0), diff -y --suppress-common-lines ./VADemo/r1/DGMTR1.m ./VADemo/r2/r/DGMTR1.m ;;5.3;Registration;**182,344,433,456,564**;Aug 13, 19 | ;;5.3;Registration;**182,344,433,456**;Aug 13, 1993 N DGMTI,DGMTCOR,DGNODE,DGELIG,DGI,DGE | N DGMTI,DGMTE,DGMTCOR,DGNODE,DGMTYPT,STATUS,ELIG,ELIG S DGMTCOR=1 | S DGMTCOR=1,DGMT="",DGMTYPT=2 > ; S DGI=$P($G(^DPT(DFN,.36)),U) I 'DGI S DGMTCOR=0 G CH | S DGMTI=0 I '$P($G(^DPT(DFN,.36)),U) S DGMTCOR=0 G CH 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= | S ELIG=$P($G(^DPT(DFN,.36)),"^") I (DGELIG["^1^") S DGMTCOR=0 G CHKQ ;SC 50-100% | I 'ELIG S DGMTCOR=0 G CHKQ F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) | S DGMTE=$P($G(^DIC(8,ELIG,0)),U,9) I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR= | I "^1^2^4^15^"[("^"_DGMTE_"^") S DGMTCOR=0 G CHKQ I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR | S ELIGIEN=0 I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR= | F S ELIGIEN=$O(^DPT(DFN,"E",ELIGIEN)) Q:'ELIGIEN S I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0 | ; I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(D | 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 ;PEN diff -y --suppress-common-lines ./VADemo/r1/DGMTREM.m ./VADemo/r2/r/DGMTREM.m DGMTREM ;ALB/CAW - Comments for Means Test ; 04/28/2003 2:00 | DGMTREM ;ALB/CAW - Comments for Means Test ;31 DEC 1991 2:00 ;;5.3;Registration;**45,182,513**;Aug 13, 1993 | ;;5.3;Registration;**45,182**;Aug 13, 1993 S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT | S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT, ; < PRIM(DGMTDT,DGMTIEN) ; < ; Find Primary Test for Income Year, and allow for a < ; < I ^DGMT(408.31,DGMTIEN,"PRIM")=1 Q 1 < I DGMTDT>DT,$O(^DGMT(408.31,"AD",1,DFN,DGMTDT,""),-1) < ; < Q 0 < diff -y --suppress-common-lines ./VADemo/r1/DGMTREQB.m ./VADemo/r2/r/DGMTREQB.m DGMTREQB ;ALB/CAW Send mail bulletin if means test req | DGMTREQB ;ALB/CAW Send mail bulletin if means test req ;;5.3;Registration;**3,608**;Aug 13, 1993 | ;;5.3;Registration;**3**;Aug 13, 1993 .S XMSUB="Means Test Required ("_$E($P($G(^DPT($P(SDA | .S XMSUB="Patient: "_$P($G(^DPT($P(SDATA,U,2),0)),U)_ ..D SET("Date of Birth: "_$$FTIME^DGMTUTL($P(^DPT(DF | ..D SET(" Patient ID: "_VA("PID")) ..D SET(" Appointment: "_$$FTIME^DGMTUTL($P(SDATA,U | ..D SET("Appointment: "_$$FTIME^DGMTUTL($P(SDATA,U,3 ..D SET(" Action: "_$P(SDATA("AFTER","STATUS") | ..D SET(" Action: "_$P(SDATA("AFTER","STATUS"),U ..D SET(" Clinic: "_$P($G(^SC($P(SDATA,U,4),0) | ..D SET(" Clinic: "_$P($G(^SC($P(SDATA,U,4),0)), ..D SET(" Entered By: "_$P($G(^VA(200,+$P(SDATA1,U | ..D SET(" Entered By: "_$P($G(^VA(200,+$P(SDATA1,U,6 ..D SET(" Entered On: "_$$FTIME^DGMTUTL($P(SDATA1, | ..D SET(" Entered On: "_$$FTIME^DGMTUTL($P(SDATA1,U, diff -y --suppress-common-lines ./VADemo/r1/DGMTR.m ./VADemo/r2/r/DGMTR.m DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test R | DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test R ;;5.3;Registration;**45,93,114,137,141,147,177,182,14 | ;;5.3;Registration;**45,93,114,137,141,147,177,182,14 .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD),'+$G(I | .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD) D NOL diff -y --suppress-common-lines ./VADemo/r1/DGMTSC4.m ./VADemo/r2/r/DGMTSC4.m DGMTSC4 ;ALB/RMO/CAW,LBD - Means Test Screen Net Worth ; 11/7 | DGMTSC4 ;ALB/RMO/CAW,LBD - Means Test Screen Net Worth ;18 MA ;;5.3;Registration;**45,130,456,540,567**;Aug 13, 199 | ;;5.3;Registration;**45,130,456**;Aug 13, 1993 ;DG*5.3*540 - Skip displaying of calculated Means Tes < ; bottom of screen 4 when in VIEW mode. < ;DG*5.3*567 - Allow bottom to show for all except SOU < ; for IVM display Source is IVM instead. < ; < ; < ;DG*5.3*540 < ;DG*5.3*567 < I DGMTACT="VEW",DGMTI,$$GET1^DIQ(408.31,DGMTI,.23)["I < . W !!!!!!!!,"Source of Test is IVM" < diff -y --suppress-common-lines ./VADemo/r1/DGMTSC.m ./VADemo/r2/r/DGMTSC.m DGMTSC ;ALB/RMO,CAW,RTK,PDJ,LBD - Means Test Screen Driver ; | DGMTSC ;ALB/RMO,CAW,RTK,PDJ - Means Test Screen Driver ;21 J ;;5.3;Registration;**182,327,372,433,463,540,566**;Au | ;;5.3;Registration;**182,327,372,433**;Aug 13, 1993 ;DG*5.3*540 - set 408.21 (Idiv. Ann. Income) ien to 0 < ; linking to old test incomes for IVM con < ; < S DGMTSCI=+$O(DGMTSC(0)) | S DGMTSCI=+$O(DGMTSC(0)) G @($$ROU^DGMTSCU(DGMTSCI)) I DGMTI,$$GET1^DIQ(408.31,DGMTI,.23)["IVM" S DGVINI=0 < G @($$ROU^DGMTSCU(DGMTSCI)) < ; Validate record with consistency checks, when addin < ; completing either a means or copay test. < ; For DG*5.3*566 - added a check for Status field to < ; calling the consistency check API (INCON^DGMTUTL1). < K IVMERR,IVMAR,IVMAR2 < I DGMTACT'="VEW",$P($G(^DGMT(408.31,DGMTI,0)),U,3) D < ; < K DGERR,IVMERR,ARRAY,ZIC,ZIR,ZMT,ZDP,IVMAR,IVMAR2 | K DGERR diff -y --suppress-common-lines ./VADemo/r1/DGMTU3.m ./VADemo/r2/r/DGMTU3.m DGMTU3 ;ALB/MLI/GN/LBD - Internal Entry Number Utility Calls | DGMTU3 ;ALB/MLI - Internal Entry Number Utility Calls ; June ;;5.3;Registration;**33,45,137,182,300,433,499,518**; | ;;5.3;Registration;**33,45,137,182,300,433**;Aug 13, N DFN,I,IEN,INR,MTIEN,LAST,DGDT,LTCIEN | N DFN,I,IEN,INR,MTIEN,LAST ; | S MTIEN=$S($G(DGMTACT)'="VEW":$$LST^DGMTU(DFN,$E(YEAR ;DG*5.3*499, change to if structure and check for pre < ; it is not defined when coming from Bene travel menu < ;LTC Phase III (DG*5.3*518) - add setting of LTCIEN < ; < ; if user selects view option & DGMTI exists, set IEN < 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 < . S LTCIEN=$S($G(DGMTI):DGMTI,1:$$LST^EASECU(DFN,(YEA < ; < . ; If DGMTYPT=3 make sure the IAI record is associat < . ; correct LTC Copay test. Added for LTC Phase III ( < . I $G(DGMTYPT)=3,+^DGMT(408.21,IEN,"MT")'=+LTCIEN S < ; < .. ; If DGMTYPT=3 make sure the IAI record is associa < .. ; correct LTC Copay test. Added for LTC Phase III < .. I $G(DGMTYPT)=3,+^DGMT(408.21,IEN,"MT")'=+LTCIEN S < diff -y --suppress-common-lines ./VADemo/r1/DGMTU4.m ./VADemo/r2/r/DGMTU4.m ;;5.3;Registration;**182,267,285,347,454,456,476**;Au | ;;5.3;Registration;**182,267,285,347,454,456**;Aug 13 ; < CHKPT(DFN) ; < ; Cross check the CURRENT MEANS TEST STATUS in the PA < ; primary means test in the ANNUAL MEANS TEST File (# < ; CURRENT MEANS TEST STATUS if the fields are out of < ; < 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 -y --suppress-common-lines ./VADemo/r1/DGMTU.m ./VADemo/r2/r/DGMTU.m DGMTU ;ALB/RMO,LBD,BRM - Means Test Utilities ; 12/9/03 9:2 | DGMTU ;ALB/RMO,LBD - Means Test Utilities ; 4/03/02 ;;5.3;Registration;**4,33,182,277,290,374,358,420,426 | ;;5.3;Registration;**4,33,182,277,290,374,358,420,426 D CHKPT^DGMTU4(DFN) < ; 1 = Current Test is REQUIRED | ; 1 = Current Test is REQUIRED ; 2 = Test is > 365 days old and is in a status o | ; 2 = Test is > 365 days old and is ; other than REQUIRED or NO LONGER REQUIRED | ; other than REQUIRED or NO LON ; 2 = Pend Adj for GMT, test date is 10/6/99 or | ; 0 = CAT C/Pend Adj for MT, test d ; greater and agreed to the deductible | ; or greater and agreed to the ; 0 = CAT C/Pend Adj for MT, test date is 10/6/99 | ; OR 0 = Cat C, declined income info a ; or greater and agreed to the deductible. | ; to pay deductible. ; OR 0 = Cat C, declined income info and agreed | ; OR 0 = Has a future dated Means Test ; to pay deductible. < ; OR 0 = Has a future dated Means Test < I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DG | I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DG I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DG | I ($P(DGMTDATA,U,4)="C")!($P(DGMTDATA,U,4)="P"&($P(DG ; DGMTYPT Type of Test (Optional - default to | ; DGMTYPT Type of Test (Optional - default to ; current future dated test for the Income Year | ; earliest performed future test for the Income ; MT IEN^Date of Test^Status Name^Status Code^S | ; Future MT IEN^Date of Test (Future)^Status Na > ; Source of Test N DGIDT,Y,MTIEN,SRCE,DONE,MTNOD,ARR,LAST,TYPTST | N DGIDT,Y,MTIEN,SRCE,DONE,MTNOD,ARR,FIRST,TYPTST S (ARR,LAST,Y)="" | S (ARR,FIRST,Y)="" ..I 'DONE,'$D(ARR($P(MTNOD,U),MTIEN)) S ARR($P(MTNOD, | ..I 'DONE,'$D(ARR($P(MTNOD,U))) S ARR($P(MTNOD,U))=MT I 'DONE S LAST=$O(ARR(""),-1) I LAST S Y=ARR(LAST,$O( | I 'DONE S FIRST=$O(ARR("")) I FIRST S Y=ARR(FIRST) Only in ./VADemo/r1/: DGMTUTL1.m Only in ./VADemo/r1/: DGMTUTL2.m diff -y --suppress-common-lines ./VADemo/r1/DGMTXX11.m ./VADemo/r2/r/DGMTXX11.m DGMTXX11 ; COMPILED XREF FOR FILE #408.21 ; 10/15/04 | DGMTXX11 ; COMPILED XREF FOR FILE #408.21 ; 06/26/02 diff -y --suppress-common-lines ./VADemo/r1/DGMTXX12.m ./VADemo/r2/r/DGMTXX12.m DGMTXX12 ; COMPILED XREF FOR FILE #408.21 ; 10/15/04 | DGMTXX12 ; COMPILED XREF FOR FILE #408.21 ; 06/26/02 diff -y --suppress-common-lines ./VADemo/r1/DGMTXX1.m ./VADemo/r2/r/DGMTXX1.m DGMTXX1 ; DRIVER FOR COMPILED XREFS FOR FILE #408.21 ; 10/15/ | DGMTXX1 ; DRIVER FOR COMPILED XREFS FOR FILE #408.21 ; 06/26/ diff -y --suppress-common-lines ./VADemo/r1/DGMTXX21.m ./VADemo/r2/r/DGMTXX21.m DGMTXX21 ; COMPILED XREF FOR FILE #408.22 ; 10/15/04 | DGMTXX21 ; COMPILED XREF FOR FILE #408.22 ; 12/10/01 S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < 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(^ < S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < 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(^ < S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < diff -y --suppress-common-lines ./VADemo/r1/DGMTXX22.m ./VADemo/r2/r/DGMTXX22.m DGMTXX22 ; COMPILED XREF FOR FILE #408.22 ; 10/15/04 | DGMTXX22 ; COMPILED XREF FOR FILE #408.22 ; 12/10/01 S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < 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(^ < S DIKZ(0)=$G(^DGMT(408.22,DA,0)) < 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(^ < diff -y --suppress-common-lines ./VADemo/r1/DGMTXX2.m ./VADemo/r2/r/DGMTXX2.m DGMTXX2 ; DRIVER FOR COMPILED XREFS FOR FILE #408.22 ; 10/15/ | DGMTXX2 ; DRIVER FOR COMPILED XREFS FOR FILE #408.22 ; 12/10/ diff -y --suppress-common-lines ./VADemo/r1/DGMTXX31.m ./VADemo/r2/r/DGMTXX31.m DGMTXX31 ; COMPILED XREF FOR FILE #408.31 ; 10/15/04 | DGMTXX31 ; COMPILED XREF FOR FILE #408.31 ; 12/09/02 diff -y --suppress-common-lines ./VADemo/r1/DGMTXX32.m ./VADemo/r2/r/DGMTXX32.m DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 10/15/04 | DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 12/09/02 S DIKZ(0)=$G(^DGMT(408.31,DA,0)) < S DIKZ(0)=$G(^DGMT(408.31,DA,0)) < diff -y --suppress-common-lines ./VADemo/r1/DGMTXX3.m ./VADemo/r2/r/DGMTXX3.m DGMTXX3 ; DRIVER FOR COMPILED XREFS FOR FILE #408.31 ; 10/15/ | DGMTXX3 ; DRIVER FOR COMPILED XREFS FOR FILE #408.31 ; 12/09/ diff -y --suppress-common-lines ./VADemo/r1/DGNFUNC.m ./VADemo/r2/r/DGNFUNC.m DGNFUNC ;BPCIOFO/CMC-NAME FORMAT FUNCTIONS ; 22 Jan 2002 10:3 | DGNFUNC ;BPCIOFO/CMC-NAME FORMAT FUNCTIONS ;8 MAR 1999 ;;5.3;Registration;**149,244**;Aug 13, 1993 | ;;5.3;Registration;**149**;Aug 13, 1993 N DPTNAME | D DEM^VADPT S DPTNAME("IENS")=DFN_",",DPTNAME("FILE")=2,DPTNAME(" | N NAME,FIRST,MIDDLE,LAST,SUFFIX,TFLG,TNAME,PL Q $$NAMEFMT^XLFNAME(.DPTNAME,"G","") | S TFLG="N" > S NAME=VADM(1) > K VADM > I $E(NAME,($L(NAME)-4),$L(NAME))=" TEST" S NAME=$E(NA > 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 > Q TNAME diff -y --suppress-common-lines ./VADemo/r1/DGOIL1.m ./VADemo/r2/r/DGOIL1.m ;;5.3;Registration;**162,498**;Aug 13, 1993 | ;;5.3;Registration;**162**;Aug 13, 1993 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") diff -y --suppress-common-lines ./VADemo/r1/DGOIL2.m ./VADemo/r2/r/DGOIL2.m ;;5.3;Registration;**93,498**;Aug 13, 1993 | ;;5.3;Registration;**93**;Aug 13, 1993 S $P(X3,"^",10)=$S($P($G(^DGPM(DGPMIFN,"DIR")),"^",1) < diff -y --suppress-common-lines ./VADemo/r1/DGOIL.m ./VADemo/r2/r/DGOIL.m ;;5.3;Registration;**162,279,498**;Aug 13, 1993 | ;;5.3;Registration;**162,279**;Aug 13, 1993 W !,"'+' Before the Patient name indicates patient is | W !,"'+' Before the Patient name indicates patient is diff -y --suppress-common-lines ./VADemo/r1/DGOINPT1.m ./VADemo/r2/r/DGOINPT1.m DGOINPT1 ;ALB/REW - BUILDS,PRINTS INPATIENT ROSTER ; 8 | DGOINPT1 ;ALB/REW - BUILDS,PRINTS INPATIENT ROSTER ; 7 ;;5.3;Registration;**162,498,544**;Aug 13, 1993 | ;;5.3;Registration;**162**;Aug 13, 1993 N DGVAIN7,VAL | N DGVAIN7 S VAL=VADM(1)_U_DGBID_U_VADM(4)_U_DGVAIN7_U_DGDAYS_U_ | S ^TMP($J,DGS1,$S(DGSUBS="R":+$$RM(VAIN(5)),1:VADM(1) S VAL=VAL_U_$P(VAIN(11),U,2)_U_$P(VAIN(3),U,2)_U_$P(V < S ^TMP($J,DGS1,$S(DGSUBS="R":+$$RM(VAIN(5)),1:VADM(1) < W !!?33,"ADMISSION",?78,"PRIMARY",?95,"ATTENDING",?11 | W !!?33,"ADMISSION",?77,"PRIMARY",?94,"ATTENDING",?11 W !,"PATIENT NAME",?21,"ID",?28,"AGE",?33,"DATE",?46, | W !,"PATIENT NAME",?21,"ID",?28,"AGE",?33,"DATE",?46, F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,""" | F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,""" I $Y<(IOSL-5) D LEGEND < W !,$S($P(DGADM,U,12):"!",1:""),$E($P(DGADM,U,1),1,19 | W !,$E($P(DGADM,U,1),1,19),?21,$P(DGADM,U,2),?28,$J($ W ?33,$P(DGADM,U,4),?46,$J($P(DGADM,U,5),4),?52,$E($P | W ?94,$E($P(DGADM,U,9),1,15),?111,$E($P(DGADM,U,10),1 W ?95,$E($P(DGADM,U,9),1,15),?112,$E($P(DGADM,U,10),1 < S VAIP(19,1)=$P($G(^DGPM(+VAIN(1),"DIR")),"^",1) < S:VAIP(19,1)="" VAIP(19,1)=1 < LEGEND F Q:($Y>(IOSL-5)) W ! < W !,"'!' Before the Patient name indicates the patien < Q < diff -y --suppress-common-lines ./VADemo/r1/DGOINPT.m ./VADemo/r2/r/DGOINPT.m DGOINPT ;RWA/SLC,XAK/ALBANY;ALB/MLI;ALB/REW - WARD ROSTER ; 6 | DGOINPT ;RWA/SLC,XAK/ALBANY;ALB/MLI;ALB/REW - WARD ROSTER ; 1 ;;5.3;Registration;**524**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 S DIC="^VA(200,",VAUTSTR="provider",VAUTVB="VAUTW" D | S DIC="^VA(200,",VAUTSTR="provider",VAUTVB="VAUTW",DI diff -y --suppress-common-lines ./VADemo/r1/DGOVBC1.m ./VADemo/r2/r/DGOVBC1.m ;;5.3;Registration;**162,489**;Aug 13, 1993 | ;;5.3;Registration;**162**;Aug 13, 1993 N VAPA < D ADD^VADPT,A W !,"5. Address Information [Street, Ci | D ADD^VADPT,A W !,"5. Address Information [Street, Ci I VAPA(12)=1 D < .D L < .D AC W !,"5A. Confidential Address Information [Stre < S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_VAPA(6) | S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_VAPA(6) K I,J,V 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)= < .S DGA(19)="_________________________________________ < .S DGA(20)="Confidential Start Date: "_$P(VAPA(20),"^ < .S DGA(21)="Confidential End Date: "_$P(VAPA(21),"^", < .S DGA(22)="Confidential Address Categories:" < .S SEQ="",DGASEQ=23 F S SEQ=$O(VAPA(22,SEQ)) Q:SEQ=" < ..I $P(VAPA(22,SEQ),"^",3)="Y" S DGA(DGASEQ)=$P(VAPA( < .I VAPA(13)']"" S DGA(1)="STREET ADDRESS UNKNOWN",DGA < .S DGA(DGA)=$S($L(VAPA(16))&(VAPA(17)):VAPA(16)_", "_ < .S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_$P(VAPA(18),"^ < K I,VAPA Q < Q < Only in ./VADemo/r1/: DGPFAA1.m Only in ./VADemo/r1/: DGPFAA2.m Only in ./VADemo/r1/: DGPFAA3.m Only in ./VADemo/r1/: DGPFAAH1.m Only in ./VADemo/r1/: DGPFAAH.m Only in ./VADemo/r1/: DGPFAA.m Only in ./VADemo/r1/: DGPFALF1.m Only in ./VADemo/r1/: DGPFALF.m Only in ./VADemo/r1/: DGPFALH.m Only in ./VADemo/r1/: DGPFANF.m Only in ./VADemo/r1/: DGPFAPI.m Only in ./VADemo/r1/: DGPFBGR.m Only in ./VADemo/r1/: DGPFDD.m Only in ./VADemo/r1/: DGPFHLL.m Only in ./VADemo/r1/: DGPFHLQ1.m Only in ./VADemo/r1/: DGPFHLQ2.m Only in ./VADemo/r1/: DGPFHLQ3.m Only in ./VADemo/r1/: DGPFHLQ.m Only in ./VADemo/r1/: DGPFHLR.m Only in ./VADemo/r1/: DGPFHLRT.m Only in ./VADemo/r1/: DGPFHLS.m Only in ./VADemo/r1/: DGPFHLU1.m Only in ./VADemo/r1/: DGPFHLU2.m Only in ./VADemo/r1/: DGPFHLU3.m Only in ./VADemo/r1/: DGPFHLU4.m Only in ./VADemo/r1/: DGPFHLU5.m Only in ./VADemo/r1/: DGPFHLU6.m Only in ./VADemo/r1/: DGPFHLU.m Only in ./VADemo/r1/: DGPFHLUT.m Only in ./VADemo/r1/: DGPFLF1.m Only in ./VADemo/r1/: DGPFLF2.m Only in ./VADemo/r1/: DGPFLF3.m Only in ./VADemo/r1/: DGPFLF4.m Only in ./VADemo/r1/: DGPFLF5.m Only in ./VADemo/r1/: DGPFLF6.m Only in ./VADemo/r1/: DGPFLFD1.m Only in ./VADemo/r1/: DGPFLFD.m Only in ./VADemo/r1/: DGPFLF.m Only in ./VADemo/r1/: DGPFLMA1.m Only in ./VADemo/r1/: DGPFLMA2.m Only in ./VADemo/r1/: DGPFLMA3.m Only in ./VADemo/r1/: DGPFLMA4.m Only in ./VADemo/r1/: DGPFLMAD.m Only in ./VADemo/r1/: DGPFLMA.m Only in ./VADemo/r1/: DGPFLMD1.m Only in ./VADemo/r1/: DGPFLMD.m Only in ./VADemo/r1/: DGPFLMU1.m Only in ./VADemo/r1/: DGPFLMU.m Only in ./VADemo/r1/: DGPFPARM.m Only in ./VADemo/r1/: DGPFRFA1.m Only in ./VADemo/r1/: DGPFRFA.m Only in ./VADemo/r1/: DGPFRFR1.m Only in ./VADemo/r1/: DGPFRFR.m Only in ./VADemo/r1/: DGPFUT1.m Only in ./VADemo/r1/: DGPFUT2.m Only in ./VADemo/r1/: DGPFUT.m Only in ./VADemo/r1/: DGPLBL1.m Only in ./VADemo/r1/: DGPLBL.m diff -y --suppress-common-lines ./VADemo/r1/DGPMBSP2.m ./VADemo/r2/r/DGPMBSP2.m DGPMBSP2 ;ALB/LM - BSR PRINT, CONT.; 17 OCT 90 ; 3/29/ | DGPMBSP2 ;ALB/LM - BSR PRINT, CONT.; 17 OCT 90 ;;5.3;Registration;**59,592**;Aug 13, 1993 | ;;5.3;Registration;**59**;Aug 13, 1993 ;F I=3:1:15,18 S $P(X,"^",I)=$P(X,"^",I)+$P(BD("N")," | F I=3:1:15,18 S $P(X,"^",I)=$P(X,"^",I)+$P(BD("N"),"^ F I=3:1:16,18 S $P(X,"^",I)=$P(X,"^",I)+$P(BD("N"),"^ < diff -y --suppress-common-lines ./VADemo/r1/DGPMBSP3.m ./VADemo/r2/r/DGPMBSP3.m DGPMBSP3 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ; 3/31 | DGPMBSP3 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ;;5.3;Registration;**59,85,529,592**;Aug 13, 1993 | ;;5.3;Registration;**59,85**;Aug 13, 1993 I $P(BDAY,"^",2) D CUM F N1=3:1:16,18 S $P(NTOTAL,"^" | I $P(BDAY,"^",2) D CUM F N1=3:1:15,18 S $P(NTOTAL,"^" TWR N DGDNTD | TWR W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL S DGDNTD=$S($P(DGWTOR,"^")["DON'T DISPLAY":1,1:0) | W ! I DGDNTD,TL=1 W:UL["-" ! F L=1:1:131 W UL | I $P(DGWTOR,"^")'["DON'T DISPLAY" D PTOT ; print line I 'DGDNTD D < .W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W U < .W ! < .D PTOT ; print line on BSR < ;F I=3:1:16 W ?+$P(TAB,"^",I),$J($P(W,"^",I),$P(JUS," | F I=3:1:15 W ?+$P(TAB,"^",I),$J($P(W,"^",I),$P(JUS,"^ F I=3:1:15 W ?+$P(TAB,"^",I),$J($P(W,"^",I),$P(JUS,"^ | S X(16)=($P(W,"^",18)/FY("D")) ; Cum Pat Days/Days in 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:((X(16)*100)/($ S X(17)=$S($P(TB(TL,T2),"^",3)'>0:0,1:$P(W,"^",18)*10 | S X(16)=$J(X(16),0,1) ; Cum ADC ;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)) F I=16:1:18 W ?+$P(TAB,"^",I),$J(X(I),$P(JUS,"^",I)) < MTL ;F N1=3:1:15,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1) | MTL F N1=3:1:15,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+ F N1=3:1:16,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+ < diff -y --suppress-common-lines ./VADemo/r1/DGPMBSP4.m ./VADemo/r2/r/DGPMBSP4.m DGPMBSP4 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ; 3/29 | DGPMBSP4 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ;;5.3;Registration;**592**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;S X(16)=($P(X,"^",18)/FY("D")) | 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)/FY("D") | S X(17)=$S(X2'>0:0,1:((X(16)*100)/X2)) 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. < diff -y --suppress-common-lines ./VADemo/r1/DGPMDD1.m ./VADemo/r2/r/DGPMDD1.m DGPMDD1 ;ALB/MRL - FILE 405 'SET' X-REFERENCES; 08 NOV 88 ; 1 | DGPMDD1 ;ALB/MRL - FILE 405 'SET' X-REFERENCES; 08 NOV 88<<= ;;5.3;Registration;**156,555**;Aug 13, 1993 | ;;5.3;Registration;**156**;Aug 13, 1993 diff -y --suppress-common-lines ./VADemo/r1/DGPMDD2.m ./VADemo/r2/r/DGPMDD2.m DGPMDD2 ;ALB/MRL - FILE 405 'KILL' X-REFERENCES; 08 NOV 88 ; | DGPMDD2 ;ALB/MRL - FILE 405 'KILL' X-REFERENCES; 08 NOV 88<<= ;;5.3;Registration;**156,555**;Aug 13, 1993 | ;;5.3;Registration;**156**;Aug 13, 1993 diff -y --suppress-common-lines ./VADemo/r1/DGPMDDCN.m ./VADemo/r2/r/DGPMDDCN.m ;;5.3;Registration;**54,498**;Aug 13, 1993 | ;;5.3;Registration;**54**;Aug 13, 1993 S41 ; -- fac dir x-ref (AFD) < S DGFLD=.109 S DGPMX=$P($G(^DPT(DFN,.109)),"^",1) D K < S DGPMX=$P(VAFD,"^",1) D SET:(DGPMX'="") < Q < ; < K41 ; < I X'="",$P($G(^DPT(DFN,.109)),"^",1)=X S DGPMX=X,DGFL < Q < ; < F DGFLD=.1,.101,.102,.103,.104,.1041,.105,.109 I $D(^ | F DGFLD=.1,.101,.102,.103,.104,.1041,.105 I $D(^DPT(D SETALL D S6,S7,S8,S9,S19,S41 Q | SETALL D S6,S7,S8,S9,S19 Q INPTCK ; check to see if patient is current inpatient | INPTCK ; check so see if patient is current inpatient diff -y --suppress-common-lines ./VADemo/r1/DGPMEVT.m ./VADemo/r2/r/DGPMEVT.m DGPMEVT ;ALB/RMO - MAS MOVEMENT EVENT DRIVER; 26 DEC 89 ; 2/2 | DGPMEVT ;ALB/RMO - MAS MOVEMENT EVENT DRIVER; 26 DEC 89 ;;5.3;Registration;**61,574**;Aug 13, 1993 | ;;5.3;Registration;**61**;Aug 13, 1993 N OROLD D INP^VADPT S X=$O(^ORD(101,"B","DGPM MOVEMEN | N OROLD D INP^VADPT S X=$O(^ORD(101,"B","DGPM MOVEMEN I $P(X,";",1)="" D ERR K VAIN Q < D EN1^XQOR K VAIN,X < Q < ; < ERR ; < W !,"Serious error ! DGPM MOVEMENT EVENTS protocol no < W !,"in Protocol file #101. No events fired !" < W ! < diff -y --suppress-common-lines ./VADemo/r1/DGPMGL5.m ./VADemo/r2/r/DGPMGL5.m DGPMGL5 ;ALB/MRL - G&L PARAMETER ENTRY/EDIT; 29 APR 2003 | DGPMGL5 ;ALB/MRL - G&L PARAMETER ENTRY/EDIT; 28 JUN 89 ;;5.3;Registration;**515**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 W !,"Means Test Copay Applicability Display",?43,": " | W !,"Means Test Display",?43,": ",$S($P(DGPM,"^",3):" diff -y --suppress-common-lines ./VADemo/r1/DGPMGLG5.m ./VADemo/r2/r/DGPMGLG5.m DGPMGLG5 ;ALB/LM - G&L GENERATION, CONT.; 27 APR 2003 | DGPMGLG5 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90 ;;5.3;Registration;**34,137,515,570**;Aug 13, 1993 | ;;5.3;Registration;**34,137**;Aug 13, 1993 I MT,$D(^DGMT(408.31,"C",DFN)) N DGX,X D | I MT,$D(^DGMT(408.31,"C",DFN)) S X=$$MTIENLT^DGMTU3(1 . 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 < . . . I '$D(DGX) S X="U" Q < . . . S X=$$PA^DGMTUTL(DGX),X=$S('$D(X):"U",X="MT":"C < . . I "^A^B^C^G^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=I < S INS=0 | S INS=0 I $O(^DPT(DFN,.312,0)) S INS1=0 F JJ=0:0 S IN N DGINS,DGX < ; API returns ONLY Active and Re-imbursable Insurance < I $$INSUR^IBBAPI(DFN,"","",.DGINS,9) D < . S DGX=0 F S DGX=$O(DGINS("IBBAPI","INSUR",DGX)) Q: < diff -y --suppress-common-lines ./VADemo/r1/DGPMGL.m ./VADemo/r2/r/DGPMGL.m DGPMGL ;ALB/MRL/LM/MJK - G&L ENTRY POINT; 29 APR 2003 | DGPMGL ;ALB/MRL/LM/MJK - G&L ENTRY POINT; 1 FEB 89 ;;5.3;Registration;**85,515**;Aug 13, 1993 | ;;5.3;Registration;**85**;Aug 13, 1993 W !,$E("Means Test Copay Applicability"_L,1,58),$S(MT | W !,$E("Means Test Indicator's"_L,1,58),$S(MT:"",1:"N diff -y --suppress-common-lines ./VADemo/r1/DGPMGLP.m ./VADemo/r2/r/DGPMGLP.m DGPMGLP ;ALB/LM/MJK - G&L PRINT ROUTINE; 27 APR 2003 | DGPMGLP ;ALB/LM/MJK - G&L PRINT ROUTINE; 11 JUNE 90 ;;5.3;Registration;**20,134,515**;Aug 13, 1993 | ;;5.3;Registration;**20,134**;Aug 13, 1993 F I="+","*","#","!","a","b","c","g","r" S C=C+1 I $D( | F I="+","*","#","!","a","b","c","r" S C=C+1 I $D(LEG( ;;MT Copay Exempt | ;;Category 'A' Veteran ;;MT Copay Required | ;;Category 'C' Veteran ;;GMT Copay Required < diff -y --suppress-common-lines ./VADemo/r1/DGPMRBA1.m ./VADemo/r2/r/DGPMRBA1.m DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 10/2 | DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 9 JA ;;5.3;Registration;**544**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 I DGOPT="B" D BEDSPR < S (DGA,DGL)=0,DGNM=$P(^DIC(42,+W,0),"^",1) I 'DGPG!($ | S (DGA,DGL)=0,DGNM=$P(^DIC(42,+W,0),"^",1) I 'DGPG!($ W:DGOPT'="B" !!,DGNM,": " | W !!,DGNM,": " EN F I=0:0 S I=$O(^DG(405.4,"W",W,I)) Q:I'>0!(DGFL) I $ | EN F I=0:0 S I=$O(^DG(405.4,"W",W,I)) Q:I'>0!(DGFL) I $ I DGOPT="B" Q < BEDS ;create TMP for beds - DG*5.3*544 < I DGDESC,'($D(^TMP("DGPMBD",$J,$P(J,U)))#2) S ^TMP("D < I '$D(^TMP("DGPMBD",$J,$P(J,U),DGNM)) S ^(DGNM)="" < Q < ; < BEDSPR ;print report by beds - DG*5.3*544 < N DGBDNM,DGBCNT,DGBDESC,DGWCNT,DGBDNM,DGWRD < D HEAD < S DGBCNT=0,DGBDNM="" F S DGBDNM=$O(^TMP("DGPMBD",$J, < . I $Y>(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, < Q:DGFL < W !!?3,$S(DGBCNT:"There are a total of "_DGBCNT_" bed < I $D(^UTILITY("DGPMLD",$J)) D HEAD Q:DGFL D LD < K ^TMP("DGPMBD",$J) < Q < diff -y --suppress-common-lines ./VADemo/r1/DGPMRBA.m ./VADemo/r2/r/DGPMRBA.m DGPMRBA ;ALB/MIR - ROOM-BED AVAILABILITY; 9 JAN 89 ; 10/21/03 | DGPMRBA ;ALB/MIR - ROOM-BED AVAILABILITY; 9 JAN 89 ;;5.3;Registration;**544**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 S Z="^ABBREVIATED^EXPANDED" D IN^DGHELP I %<0 W !!,"E | S Z="^ABBREVIATED^EXPANDED" D IN^DGHELP I %<0 W !!,"E I X="A" S DGOPT=X D ABB,Q Q | I X="A" D ABB,Q Q WS W !,"Sort by (W)ARD, (S)ERVICE, or (B)EDS: W//" R X: | WS W !,"Sort by (W)ARD or (S)ERVICE: W//" R X:DTIME G Q S Z="^WARD^SERVICE^BEDS" D IN^DGHELP I %<0 D G WS | S Z="^WARD^SERVICE^" D IN^DGHELP I %<0 W !,"ENTER:",! .W !,"ENTER:",!?5,"'W' to see available beds for one, | S DGOPT=X I X="W" S VAUTNI=1 D WARD^VAUTOMA G Q:Y<0,S S DGOPT=X < I DGOPT="W"!(DGOPT="B") S VAUTNI=1 D WARD^VAUTOMA G Q < G:DGOPT="W" SAD G:DGOPT="B" LDG < Q K ^UTILITY("DGPMLD",$J),^TMP("DGPMBD",$J),%,DFN,DGA,D | Q K ^UTILITY("DGPMLD",$J),%,DFN,DGA,DGDESC,DGDT,DGFL,DG diff -y --suppress-common-lines ./VADemo/r1/DGPMV10.m ./VADemo/r2/r/DGPMV10.m DGPMV10 ;ALB/MRL/MIR - PATIENT MOVEMENT, CONT.; 11 APR 89 ; 4 | DGPMV10 ;ALB/MRL/MIR - PATIENT MOVEMENT, CONT.; 11 APR 89 ;;5.3;Registration;**84,498,509**;Aug 13, 1993 | ;;5.3;Registration;**84**;Aug 13, 1993 W ! I +DGPMVI(19,1) W "Patient chose not to be includ | W !!,$S("^4^5^"'[("^"_+DGPMVI(2)_"^"):"Admitted ", W !,$S("^4^5^"'[("^"_+DGPMVI(2)_"^"):"Admitted ",1 < F I=13,19 S DGPMVI(I,1)="" | S DGPMVI(13,1)="" 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 < .S DGPMVI(19,1)=DGX_"^"_$$EXTERNAL^DILFD(405,41,,DGX) < diff -y --suppress-common-lines ./VADemo/r1/DGPMV33.m ./VADemo/r2/r/DGPMV33.m DGPMV33 ;ALB/MIR - DISCHARGE A PATIENT, CONTINUED ; 8/4/03 1: | DGPMV33 ;ALB/MIR - DISCHARGE A PATIENT, CONTINUED ; SEP 15 19 ;;5.3;Registration;**204,544**;Aug 13, 1993 | ;;5.3;Registration;**204**;Aug 13, 1993 I $P(W,"^",14),($P(DGPMA,"^",18)>3) D Q | I $P(W,"^",14),($P(DGPMA,"^",18)>3) S DR="401.3//"_$S .S DR="401.3//"_$S("^22^23^24^"[("^"_$P(DGPMA,"^",18) < .I $P(DR,"//",2)=T S DR=$S("^1^2^"[("^"_DGPMT_"^")&+D < .S DIE="^DPT(",DA=DFN K DQ,DG D ^DIE K DIE,T,W < diff -y --suppress-common-lines ./VADemo/r1/DGPMVBUR.m ./VADemo/r2/r/DGPMVBUR.m DGPMVBUR ;ALB/MIR - UR ADMISSION BULLETIN FOR MCCR ; 9 | DGPMVBUR ;ALB/MIR - UR ADMISSION BULLETIN FOR MCCR ; 1 ;;5.3;Registration;**26,31,483,549,570**;AUG 13, 1993 | ;;5.3;Registration;**26,31**;Aug 13, 1993 S DGPMBLN=DGPMLAST D V72HR ; visits in last 72 hours | S DGPMBLN=DGPMLAST D DIS ;SC disabilities D DIS ;SC disabilities < N DGX,DGDATA,DGIB | D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I) ; < S DGIB=$$INSUR^IBBAPI(DFN,"","",.DGDATA,"*") ; Return < S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGIBINS=@DGX < F I=0:0 S I=$O(DGIBINS(I)) Q:'I D ACT < ; < I DGIBINS(I,11)<+DGPMA,DGIBINS(I,11)]"" Q ;insurance | I $P(X,"^",4)<+DGPMA,$P(X,"^",4) Q ;insurance expire I DGIBINS(I,10)>+DGPMA Q ;insurance effective after | I $P(X,"^",8)>+DGPMA Q ;insurance effective after ad Q:'+DGIBINS(I,1) | Q:'$D(^DIC(36,+X,0)) S X1=^(0),X2=$S($D(^(.13)):^(.1 ; get insurance company information | I $P(X1,"^",5)!($P(X1,"^",2)="N") Q ;insurance compa S DGPMBL="Insurance Co. : "_$P(DGIBINS(I,1),"^",2) D | S DGPMBL="Insurance Co. : "_$P(X1,"^",1) D SETLN S DGTMP=$P(DGIBINS(I,8),U,2) | S DGTMP=$S(($P(X,"^",15)]""):$P(X,"^",15),1:$P(X,"^", I DGTMP']"" S DGTMP=$S($G(DGIBNS(I,18))]"":DGIBINS(I, < I DGTMP']"" S DGTMP="" < S DGPMBL="Policy Holder : "_DGIBINS(I,13) D SETLN | S DGPMBL="Policy Holder : "_$P(X,"^",17) D SETLN S DGPMBL="Subscriber ID : "_DGIBINS(I,14) D SETLN | S DGPMBL="Subscriber ID : "_$P(X,"^",2) D SETLN S DGPMBL="Ins. Co Phone# : "_$S(DGIBINS(I,6)]"":DGIBI | S DGPMBL="Ins. Co Phone# : "_$S($P(X2,"^",2)]"":$P(X2 V72HR ; GET INFORMATION FROM VISITS FOR THE LAST 72 HOURS | SETLN ; -- set line in xmtext array 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 < ; < S Y=+X X ^DD("DD") < S DGPMBL="Previous Visit : "_HSPN_" "_Y < D SETLN < G GVID < Q < SETLN ;--set line in xmtext array < diff -y --suppress-common-lines ./VADemo/r1/DGPMVDD.m ./VADemo/r2/r/DGPMVDD.m DGPMVDD ;ALB/MIR - MISCELLANEOUS DD CALLS FROM FILE 405 AND 4 | DGPMVDD ;ALB/MIR - MISCELLANEOUS DD CALLS FROM FILE 405 AND 4 ;;5.3;Registration;**418,593**;Aug 13, 1993 | ;;5.3;Registration;**418**;Aug 13, 1993 W ;called from input transform for ward location | W ;called form input transform for ward location ;S DGPMWD="",DGPMTYP=40 ; simulate NOIS REN-0304-606 | I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S < diff -y --suppress-common-lines ./VADemo/r1/DGPMVDL.m ./VADemo/r2/r/DGPMVDL.m DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 2/13/04 1:01pm | DGPMVDL ;ALB/MIR - DELETE PATIENT MOVEMENTS ; 28 SEP 89@12 ;;5.3;Registration;**161,517**;Aug 13, 1993 | ;;5.3;Registration;**161**;Aug 13, 1993 1 S DA=$P(DGPMAN,U,16),DIK="^DGPT(",FLAG=1,I=0 F S I=$ | 1 S DGMSG="Patient admission has been deleted for admit I FLAG S I=0 F S I=$O(^DGICD9(46.1,"C",DA,I)) Q:'I | S DIK="^DGPT(",DA=$P(DGPMAN,"^",16) D ^DIK:DA>0 ; del I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE < S DGMSG="Patient admission has been deleted for admit < D MSG^DGPTMSG1 S DA=$P(DGPMAN,U,16),DIK="^DGPT(" D ^D < diff -y --suppress-common-lines ./VADemo/r1/DGPMX11.m ./VADemo/r2/r/DGPMX11.m DGPMX11 ; ;04/03/03 | DGPMX11 ; ;08/08/97 S X=DG(DQ),DIC=DIE | D DE G BEGIN > DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(4)=% S > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 CONDITI > 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 > X3 S ^DISV(DUZ,"^DG(405.1,")=$S($D(^DISV(DUZ,"DGPM1")):^ > Q > 4 S DW="0;4",DV="R*P405.1'X",DU="",DLB="TYPE OF ADMISSI > 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 > C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > Q > X4 S DIC("S")="I $D(DGPMT),($P(^(0),""^"",2)=DGPMT),$P(^ > Q > ; > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y > X5 S ^DISV(DUZ,"DGPM1")=$S($D(^DISV(DUZ,"^DG(405.1,")):^ > Q > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y > 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=" > 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 OPTIO > Q > ; > 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;10",DV="RFX",DU="" > 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",DIF > 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,Y C12S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S DGPMDDF=6,DGPMDDT=1 D ^DGPMDDCN > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0 > S X=DG(DQ),DIC=DIE > S Y=^DGPM(DA,0) I +Y,Y
Q > X12 S DIC("S")="I $S($D(^(""ORDER"")):^(""ORDER""),1:0)" > Q > ; > 13 D:$D(DG)>9 F^DIE17 G ^DGPMX12 diff -y --suppress-common-lines ./VADemo/r1/DGPMX12.m ./VADemo/r2/r/DGPMX12.m DGPMX12 ; ;04/03/03 | DGPMX12 ; ;08/08/97 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(1)=% S | 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 | I $D(^("ODS")) S %Z=^("ODS") S %=$P(%Z,U,1) S:%]"" DE I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE | I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;5",DV="RP4'X",DU=" | 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;7",DV="*P405.4'X", 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 OPTIO < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;10",DV="RFX",DU="" < 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",DIF < 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,Y9 F^DIE17,DE S DQ=7,DW="0;7",DV="*P405.4'X", < S DE(DW)="C7^DGPMX12" < C7 G C7S:$D(DE(7))[0 K DB | C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE S X=DE(7),DIC=DIE < C7S S X="" G:DG(DQ)=X C7F1 K DB | C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S X=DG(DQ),DIC=DIE < C7F1 Q | Q X7 K:'$D(DGPMT) X I $D(X) S DIC("S")="I $D(^DG(405.4,""W | X1 K:'$D(DGPMT) X I $D(X) S DIC("S")="I $D(^DG(405.4,""W 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 G A | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 G A | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 G A 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) | 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y X10 D DFN^DGYZODS S:'DGODS Y="@12" | X4 D DFN^DGYZODS S:'DGODS Y="@12" 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="ODS;1",DV="S",DU="" | 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="ODS;1",DV="S",DU="", S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I X11 Q | X5 Q 12 S DQ=13 ;@12 | 6 S DQ=7 ;@12 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y X13 I DGPMP=^DGPM(DA,0) S Y="" | X7 I DGPMP=^DGPM(DA,0) S Y="" 14 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",D | 8 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",D S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I X14 Q | X8 Q 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 G A | 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 G A 16 S DW="USR;4",DV="RD",DU="",DLB="LAST EDITED ON",DIFLD | 10 S DW="USR;4",DV="RD",DU="",DLB="LAST EDITED ON",DIFLD 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 17 G 0^DIE17 | 11 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/DGPMX1.m ./VADemo/r2/r/DGPMX1.m DGPMX1 ; GENERATED FROM 'DGPM ADMIT' INPUT TEMPLATE(#446), F | DGPMX1 ; GENERATED FROM 'DGPM ADMIT' INPUT TEMPLATE(#446), F I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S I $D(^("DIR")) S %Z=^("DIR") S %=$P(%Z,U,1) S:%]"" DE | I $D(^("PTF")) S %Z=^("PTF") S %=$P(%Z,U,4) S:%]"" DE I $D(^("PTF")) S %Z=^("PTF") S %=$P(%Z,U,4) S:%]"" DE < N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=446,U="^" M DIEZAR=^DIE(446,"AR") S DICRREC="TRIG^DIE17" | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=44 | X1 S:$S(DGPMN:1,DGPMY=+^DGPM(DA,0):1,1:0) Y=.12 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 < X1 S:$S(DGPMN:1,DGPMY=+^DGPM(DA,0):1,1:0) Y=41 < C2 G C2S:$D(DE(2))[0 K DB | C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE S X=DE(2),DIC=DIE < 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 X=DG(DQ),DIC=DIE < C2F1 Q | Q 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="DIR;1",DV="SXR",DU=" | 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;12",DV="R*P43.4'", 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," < S X=DE(4),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0," < 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," < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0," < 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 MOVEME < Q < ; < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;12",DV="R*P43.4'", < X5 S DIC("S")="I '$P(^(0),""^"",4)" D ^DIC K DIC S DIC=D | X4 S DIC("S")="I '$P(^(0),""^"",4)" D ^DIC K DIC S DIC=D 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 G A 7 S DW="PTF;4",DV="P35.2'",DU="",DLB="ADMITTING CATEGOR | 6 S DW="PTF;4",DV="P35.2'",DU="",DLB="ADMITTING CATEGOR S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I X7 Q | X6 Q 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y X8 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:0) | X7 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:0) 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 CONDITI < 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) < X12 S ^DISV(DUZ,"^DG(405.1,")=$S($D(^DISV(DUZ,"DGPM1")):^ < Q < 13 S DW="0;4",DV="R*P405.1'X",DU="",DLB="TYPE OF ADMISSI < 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 < 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(^ < Q < ; < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 S ^DISV(DUZ,"DGPM1")=$S($D(^DISV(DUZ,"^DG(405.1,")):^ < Q < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 I $P(^DGPM(DA,0),"^",18)'=9 S Y=.1 < 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 -y --suppress-common-lines ./VADemo/r1/DGPMX41.m ./VADemo/r2/r/DGPMX41.m DGPMX41 ; ;08/02/04 | DGPMX41 ; ;03/03/97 S X=DE(12),DIC=DIE | D DE G BEGIN > DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(4)=%,DE > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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,Y C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S DGPMDDF=6,DGPMDDT=1 D ^DGPMDDCN > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0 > S X=DG(DQ),DIC=DIE > S Y=^DGPM(DA,0) I +Y,Y
Q > X1 S DIC("S")="I $S($D(^(""ORDER"")):^(""ORDER""),1:0)" > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;7",DV="*P405.4'X", > 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 > Q > ; > 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y > 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=" > 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 > G RD > C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE > 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 OPTIO > Q > ; > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y > 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=" > 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 OPTIO > Q > ; > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y > X8 S:($P(DGPMP,"^",18)=$P(^DGPM(DA,0),"^",18)) Y="@42" > Q > 9 D:$D(DG)>9 F^DIE17 G ^DGPMX42 diff -y --suppress-common-lines ./VADemo/r1/DGPMX42.m ./VADemo/r2/r/DGPMX42.m 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, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,6) S:%]"" DE(1)=% S > I $D(^("LD")) S %Z=^("LD") S %=$P(%Z,U,1) S:%]"" DE(4 > I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > 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,Y C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S DGPMDDF=6,DGPMDDT=1 D ^DGPMDDCN I $P(^DGPM(DA,0),"^",2)=3 S A1B2TAG="ADM" D ^A1B2XFR | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0,0 > S X=DG(DQ),DIC=DIE > S Y=^DGPM(DA,0) I +Y,Y
Q > X1 S DIC("S")="I $S($D(^(""ORDER"")):^(""ORDER""),1:0)" > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;7",DV="*P405.4'X", > 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 > 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 > Q > ; > 3 S DQ=4 ;@42 > 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="LD;1",DV="RP406.41'" > S DU="DG(406.41," > G RE > X4 Q > 5 S DW="LD;2",DV="F",DU="",DLB="LODGING COMMENTS",DIFLD > 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 > X6 I DGPMP=^DGPM(DA,0) S Y="" > Q > 7 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",D > 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 > 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 > S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/100 > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X9 S %DT="STX" D ^%DT S X=Y K:Y<1 X > Q > ; > 10 G 0^DIE17 Only in ./VADemo/r1/: DGPMX43.m diff -y --suppress-common-lines ./VADemo/r1/DGPMX4.m ./VADemo/r2/r/DGPMX4.m DGPMX4 ; GENERATED FROM 'DGPM CHECK-IN LODGER' INPUT TEMPLAT | DGPMX4 ; GENERATED FROM 'DGPM CHECK-IN LODGER' INPUT TEMPLAT I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=450,U="^" M DIEZAR=^DIE(450,"AR") S DICRREC="TRIG^DIE17" | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=45 < 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 < C2 G C2S:$D(DE(2))[0 K DB | C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE S X=DE(2),DIC=DIE < 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 X=DG(DQ),DIC=DIE < C2F1 Q | Q 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y C6 G C6S:$D(DE(6))[0 K DB | C6 G C6S:$D(DE(6))[0 K DB S X=DE(6),DIC=DIE S X=DE(6),DIC=DIE < 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 S X=DG(DQ),DIC=DIE < C6F1 Q | Q 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 | 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;6",DV="R*P42'X",DU | 9 D:$D(DG)>9 F^DIE17 G ^DGPMX41 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,Y9 F^DIE17,DE S DQ=10,DW="0;7",DV="*P405.4'X" < 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 < Q < ; < 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) < 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= < 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 < 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 OPTIO < Q < ; < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 S Y="@42" < Q < 14 S DQ=15 ;@41 < 15 D:$D(DG)>9 F^DIE17 G ^DGPMX43 < Only in ./VADemo/r1/: DGPMXA1.m diff -y --suppress-common-lines ./VADemo/r1/DGPMXA.m ./VADemo/r2/r/DGPMXA.m DGPMXA ; GENERATED FROM 'DGPM ASIH ADMIT' INPUT TEMPLATE(#45 | DGPMXA ; GENERATED FROM 'DGPM ASIH ADMIT' INPUT TEMPLATE(#45 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(2)=% S I $D(^("DIR")) S %Z=^("DIR") S %=$P(%Z,U,1) S:%]"" DE | I $D(^("ODS")) S %Z=^("ODS") S %=$P(%Z,U,1) S:%]"" DE > I $D(^("USR")) S %Z=^("USR") S %=$P(%Z,U,3) S:%]"" DE X1 S:DGPMNA Y=41 | X1 S:DGPMNA Y=.06 C2S S X="" G:DG(DQ)=X C2F1 K DB | C2S S X="" Q:DG(DQ)=X K DB C2F1 Q | Q 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="DIR;1",DV="SXR",DU=" | 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;6",DV="R*P42'X",DU 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," < S X=DE(3),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0," < 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," < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPM(D0," < 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 MOVEME < Q < ; < 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;6",DV="R*P42'X",DU < S DE(DW)="C4^DGPMXA" < C4 G C4S:$D(DE(4))[0 K DB | C3 G C3S:$D(DE(3))[0 K DB 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 X=DE(4),DIC=DIE | S X=DE(3),DIC=DIE C4S S X="" G:DG(DQ)=X C4F1 K DB | C3S S X="" Q:DG(DQ)=X K DB C4F1 Q | Q X4 Q | X3 Q 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;7",DV="*P405.4'X", | 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;7",DV="*P405.4'X", S DE(DW)="C5^DGPMXA" | S DE(DW)="C4^DGPMXA" C5 G C5S:$D(DE(5))[0 K DB | C4 G C4S:$D(DE(4))[0 K DB S X=DE(5),DIC=DIE | S X=DE(4),DIC=DIE C5S S X="" G:DG(DQ)=X C5F1 K DB | C4S S X="" Q:DG(DQ)=X K DB C5F1 Q | Q X5 Q | X4 Q 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;12",DV="R*P43.4'", | 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;12",DV="R*P43.4'", X6 S DIC("S")="I '$P(^(0),""^"",4)" D ^DIC K DIC S DIC=D | X5 S DIC("S")="I '$P(^(0),""^"",4)" D ^DIC K DIC S DIC=D 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 | 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 X7 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:0) | X6 I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:0) 8 S DW="0;11",DV="S",DU="",DLB="ADMITTED FOR SC CONDITI | 7 S DW="0;11",DV="S",DU="",DLB="ADMITTED FOR SC CONDITI X8 Q | X7 Q 9 S DQ=10 ;@1 | 8 S DQ=9 ;@1 10 S DW="0;10",DV="RFX",DU="",DLB="DIAGNOSIS [SHORT]",DI | 9 S DW="0;10",DV="RFX",DU="",DLB="DIAGNOSIS [SHORT]",DI X10 K:$L(X)>30!($L(X)<3)!(X[";") X | X9 K:$L(X)>30!($L(X)<3)!(X[";") X 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 G A | 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 G A 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) | 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) X12 D DFN^DGYZODS S:'DGODS Y=102 | X11 D DFN^DGYZODS S:'DGODS Y=102 13 D:$D(DG)>9 F^DIE17 G ^DGPMXA1 | 12 S DW="ODS;1",DV="S",DU="",DLB="ODS AT ADMISSION",DIFL > 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 $ > G RD:X="@",Z > X12 Q > 13 S DW="USR;3",DV="RP200'",DU="",DLB="LAST EDITED BY",D > 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 $ > 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 > S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/100 > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X15 S %DT="STX" D ^%DT S X=Y K:Y<1 X > Q > ; > 16 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/DGPMXX1.m ./VADemo/r2/r/DGPMXX1.m DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 10/15/04 | DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 11/27/00 S DIKZ(0)=$G(^DGPM(DA,0)) < S DIKZ(0)=$G(^DGPM(DA,0)) < S DIKZ(0)=$G(^DGPM(DA,0)) < S DIKZ("DIR")=$G(^DGPM(DA,"DIR")) < S X=$P(DIKZ("DIR"),U,1) < 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, < S X=$P(DIKZ("DIR"),U,1) < 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, < S X=$P(DIKZ("DIR"),U,1) < I X'="" S DGPMDDF=41,DGPMDDT=0 D ^DGPMDDCN < S DIKZ(0)=$G(^DGPM(DA,0)) < diff -y --suppress-common-lines ./VADemo/r1/DGPMXX2.m ./VADemo/r2/r/DGPMXX2.m DGPMXX2 ; COMPILED XREF FOR FILE #405 ; 10/15/04 | DGPMXX2 ; COMPILED XREF FOR FILE #405 ; 11/27/00 S DIKZ(0)=$G(^DGPM(DA,0)) < S DIKZ(0)=$G(^DGPM(DA,0)) < S DIKZ(0)=$G(^DGPM(DA,0)) < S DIKZ(0)=$G(^DGPM(DA,0)) < S DIKZ(0)=$G(^DGPM(DA,0)) < S DIKZ("DIR")=$G(^DGPM(DA,"DIR")) < S X=$P(DIKZ("DIR"),U,1) < 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, < S X=$P(DIKZ("DIR"),U,1) < 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, < S X=$P(DIKZ("DIR"),U,1) < I X'="" S DGPMDDF=41,DGPMDDT=1 D ^DGPMDDCN < diff -y --suppress-common-lines ./VADemo/r1/DGPMXX.m ./VADemo/r2/r/DGPMXX.m DGPMXX ; DRIVER FOR COMPILED XREFS FOR FILE #405 ; 10/15/04 | DGPMXX ; DRIVER FOR COMPILED XREFS FOR FILE #405 ; 11/27/00 diff -y --suppress-common-lines ./VADemo/r1/DGPREBJ1.m ./VADemo/r2/r/DGPREBJ1.m DGPREBJ1 ;ALB/SCK/EG - PreRegistration Background job | DGPREBJ1 ;ALB/SCK - PreRegistration Background job con ;;5.3;Registration;**109,568,585**;Aug 13, 1993 | ;;5.3;Registration;**109**;Aug 13, 1993 > N DGPTOD,DGPNL,DGPTXT,DGPP,I1,X1,X2 > ; N DGPDT,DGPTOD,DGPNL,DGPTXT,DGPP,I1,X,X1,X2,Y < S DGPNL=0,DGPTOD=DT,DGPDT1=Y | S DGPNL=0,DGPTOD=DT D SDAMAPI(1,DGPDT1) | D ADDNEW(1,Y) D ADDNEW(1,DGPDT1) < ENQ K DIRUT,DUOUT,DTOUT,DIROUT,DGARRAY,SCDNT,^TMP($J,"SDA | ENQ K DIRUT,DUOUT,DTOUT,DIROUT ; Check for Appointment Database Availability | N DGPDT,DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DG ;if there is no lower level data from the 101 subscri | ; ;really is a valid error, otherwise, it could be a pa | S DGPNDY=$P($G(^DG(43,1,"DGPRE")),U,5) ;or clinic eg 01/20/2005 | I DGPNDY']"" D G EXIT I $D(^TMP($J,"SDAMA301")) I $D(^TMP($J,"SDAMA301",101 | . W:DGPREI !!,$P($T(MSG1),";;",2) ; | . D:'DGPREI SETTEXT^DGPREBJ($P($T(MSG1),";;",2)),SETT N DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DGPINP,D | ; N DGPPH,DGPDW,DGPPT,DGPPRDT,DGPNDTW,DGPN5,DGPEXCL,CKA | I DGPREI S DGPDT=DGPDT1 S (DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DGPINP, | E S DGPDT=$$FMADD^XLFDT(DGPTOD,DGPNDY) S DGPN1=0 F S DGPN1=$O(^TMP($J,"SDAMA301",DGPN1)) Q: | ; .S DGPPT=0 F S DGPPT=$O(^TMP($J,"SDAMA301",DGPN1,DGP | S DGPDW=$$DOW^XLFDT(DGPDT,1) ..S CKAPDT=+$O(^TMP($J,"SDAMA301",DGPN1,DGPPT,DGPDT1) | I $P($G(^DG(43,1,"DGPRE")),U,6)'=1&((DGPDW=6)!(DGPDW= ..Q:('CKAPDT!(CKAPDT>$$FMADD^XLFDT(DGPDT1,1))) | . W:DGPREI !!,$P($T(MSG2),";;",2) ..S DGPTOT=DGPTOT+1 | . D:'DGPREI SETTEXT^DGPREBJ($P($T(MSG2),";;",2)),SETT ..I $P($G(^DPT(DGPPT,.35)),U)]"" S DGPTDTH=DGPTDTH+1 | ; ..; *** Check for clinic exclusions in MAS PARAMETER | D SETTEXT^DGPREBJ("Running: Add New Patients to Call ..S (DGPN5,DGPEXCL)=0 | ; ..F S DGPN5=$O(^DG(43,1,"DGPREC",DGPN5)) Q:'DGPN5!(D | S (DGPN1,DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,D ...S:$P(^DG(43,1,"DGPREC",DGPN5,0),U)=DGPN1 DGPEXCL=1 | ; ..I DGPEXCL S DGPTCE=DGPTCE+1 Q | F S DGPN1=$O(^SC(DGPN1)) Q:'DGPN1 D ..; *** Check for eligibility exclusions inthe MAS PA | . S DGPN2=DGPDT F S DGPN2=$O(^SC(DGPN1,"S",DGPN2)) Q ..N DGPAELG S (DGPN5,DGPEXCL)=0 | .. S DGPN3=0 F S DGPN3=$O(^SC(DGPN1,"S",DGPN2,1,DGPN ..F S DGPN5=$O(^DG(43,1,"DGPREE",DGPN5)) Q:'DGPN5!(D | ... S DGPTOT=DGPTOT+1 ...S DGPAELG=$P($G(^DPT(DGPPT,.36)),U) | ... S DGPPT=$P(^SC(DGPN1,"S",DGPN2,1,DGPN3,0),U) ...S:$P(^DG(43,1,"DGPREE",DGPN5,0),U)=DGPAELG DGPEXCL | ... I $P($G(^DPT(DGPPT,.35)),U)]"" S DGPTDTH=DGPTDTH+ ..I DGPEXCL S DGPTPE=DGPTPE+1 Q | ... S DGPEXCL=0 ..; *** Check for inpatient status | ... ; *** Check for clinic exclusions in MAS PARAMET ..K DFN S DFN=DGPPT D INP^VADPT | ... S DGPN5=0 F S DGPN5=$O(^DG(43,1,"DGPREC",DGPN5)) ..I $G(VAIN(1))]"" S DGPINP=DGPINP+1 Q | .... S:$P(^DG(43,1,"DGPREC",DGPN5,0),U)=DGPN1 DGPEXCL ..; *** Check for last update in Pre-Registration Aud | ... I DGPEXCL S DGPTCE=DGPTCE+1 Q ..S DGPPRDT=DGPTOD+.9999,DGPPRDT=$O(^DGS(41.41,"ADC", | ... S DGPEXCL=0 ..S DGPNDTW=$P($G(^DG(43,1,"DGPRE")),U,2) | ... ; *** Check for eligibility exclusions inthe MAS ..I DGPPRDT]""&(DGPNDTW]"") I $$FMDIFF^XLFDT(DGPDT,DG | ... N DGPAELG ..; *** Set up entries for adding to Pre-Registration | ... S DGPN5=0 F S DGPN5=$O(^DG(43,1,"DGPREE",DGPN5)) ..K DFN S DFN=DGPPT D DEM^VADPT | .... S DGPAELG=$S($P($G(^SC(DGPN1,"S",DGPN2,1,DGPN3,0 ..S DGPPH=$P($P($G(^DPT(DGPPT,.13)),U),"~") | .... S:$P(^DG(43,1,"DGPREE",DGPN5,0),U)=DGPAELG DGPEX ..I DGPPH=""!(DGPPH["NO") D | ... I DGPEXCL S DGPTPE=DGPTPE+1 Q ...S DGPPH=$P($G(^DPT(DGPPT,.33)),U,9) | ... ; *** Check for inpatient status ...I DGPPH]"" S DGPPH=$P(DGPPH,"~")_"(E)" | ... ; I $P($G(^DPT(DGPPT,.1)),U)]""!($P($G(^DPT(DGPPT ... E S DGPPH="NO PHONE" | ... K DFN S DFN=DGPPT ..; | ... D INP^VADPT ..I '$D(^DGS(41.42,"B",DFN)) D | ... I $G(VAIN(1))]"" S DGPINP=DGPINP+1 Q ...K DD,DO S DIC="^DGS(41.42,",DIC(0)="ML" | ... ; *** Check for last update in Pre-Registration A ...S X=DFN,DGPAPT=$O(^TMP($J,"SDAMA301",DGPN1,X,DGPDT | ... S DGPPRDT=DGPTOD+.9999,DGPPRDT=$O(^DGS(41.41,"ADC ...S DIC("DR")=$P($T(FIELDS),";;",2) | ... S DGPNDTW=$P($G(^DG(43,1,"DGPRE")),U,2) ...D FILE^DICN | ... I DGPPRDT]""&(DGPNDTW]"") I $$FMDIFF^XLFDT(DGPDT, ...S DGPADD=DGPADD+1 | ... ; *** Set up entries for adding to Pre-Registrati ..E D | ... K DFN S DFN=DGPPT ...S DA="",DA=$O(^DGS(41.42,"B",DFN,DA),-1) | ... D DEM^VADPT ...Q:$P($G(^DGS(41.42,DA,0)),U,6)="Y" | ... S DGPPH=$P($P($G(^DPT(DGPPT,.13)),U),"~") ...S DIE="^DGS(41.42," | ... I DGPPH=""!(DGPPH["NO") D ...S DGPAPT=$O(^TMP($J,"SDAMA301",DGPN1,DGPPT,DGPDT1) | .... S DGPPH=$P($G(^DPT(DGPPT,.33)),U,9) ...S DR=$P($T(FIELDS),";;",2) | .... I DGPPH]"" S DGPPH=$P(DGPPH,"~")_"(E)" ...D ^DIE | .... E S DGPPH="NO PHONE" ...S DGPUPD=DGPUPD+1 | ... ; ..K DA,DR,DIE,DIC,VADM,VA,DFN,VAERR,VAIN | ... I '$D(^DGS(41.42,"B",DFN)) D > .... K DD,DO > .... S DIC="^DGS(41.42,",DIC(0)="ML" > .... S X=DFN,DGPAPT=$P($G(^SC(DGPN1,"S",DGPN2,0)),U) > .... S DIC("DR")=$P($T(FIELDS),";;",2) > .... D FILE^DICN > .... S DGPADD=DGPADD+1 > ... E D > .... S DA="",DA=$O(^DGS(41.42,"B",DFN,DA),-1) > .... Q:$P($G(^DGS(41.42,DA,0)),U,6)="Y" > .... S DIE="^DGS(41.42," > .... S DGPAPT=$P($G(^SC(DGPN1,"S",DGPN2,0)),U) > .... S DR=$P($T(FIELDS),";;",2) > .... D ^DIE > .... S DGPUPD=DGPUPD+1 > ... K DA,DR,DIE,DIC,VADM,VA,DFN,VAERR,VAIN SDAMAPI(DGPREI,DGPDT1) ; < ; Input: DGPDT1 - Date to look for appointments < ; < N DGPNDY S DGPNDY=$P($G(^DG(43,1,"DGPRE")),U,5) < I DGPNDY']"" D G EXIT < . W:DGPREI !!,$P($T(MSG1),";;",2) < . D:'DGPREI SETTEXT^DGPREBJ($P($T(MSG1),";;",2)),SETT < ; < I DGPREI S DGPDT=DGPDT1 < E S DGPDT=$$FMADD^XLFDT(DT,DGPNDY) < ;eg 01/18/2005 if coming from night job tax ('DGPREI) < ;and end date (DGPDT) is on a weekend, and the parame < ;says to not run on weekend, it will never go find ap < S DGPDW=$S(DGPREI:$$DOW^XLFDT(DGPDT),1:$$DOW^XLFDT(DT < I $P($G(^DG(43,1,"DGPRE")),U,6)'=1&((DGPDW=6)!(DGPDW= < . W:DGPREI !!,$P($T(MSG2),";;",2) < . D:'DGPREI SETTEXT^DGPREBJ($P($T(MSG2),";;",2)),SETT < D SETTEXT^DGPREBJ("Running: Add New Patients to Call < ; < N DGARRAY,SDCNT < S:DGPREI DGARRAY(1)=DGPDT1_";"_DGPDT1 < S:'DGPREI DGARRAY(1)=DT_";"_DGPDT < S DGARRAY("FLDS")=3,SDCNT=$$SDAPI^SDAMA301(.DGARRAY) < Q < diff -y --suppress-common-lines ./VADemo/r1/DGPREBJ.m ./VADemo/r2/r/DGPREBJ.m DGPREBJ ;Boise/WRL/ALB/SCK/EG-PreRegistration Night Task Job | DGPREBJ ;Boise/WRL/ALB/SCK-PreRegistration Night Task Job ; 1 ;;5.3;Registration;**109,581,568,585**;Aug 13, 1993 | ;;5.3;Registration;**109**;Aug 13, 1993 ; < ; Get Appointment Information < D SDAMAPI^DGPREBJ1(0) < ; < ; Check for Appointment Database Availability < ;if there is no lower level data from the 101 subscri < ;an error, otherwise it could be a valid patient or c < ;eg 01/20/2005 < I $D(^TMP($J,"SDAMA301")) I $D(^TMP($J,"SDAMA301",101 < ; < ; DG/581 - delete certain entries in DGS(41.42 < N DGTDAY,DGIEN,DGOLD,DGZERO,DGDFN,DGAPDT,DGKFLAG,DGCL < D NOW^%DTC S DGTDAY=% < S (DGIEN,DGOLD)=0 < F S DGIEN=$O(^DGS(41.42,DGIEN)) Q:'DGIEN D < .S DGZERO=$G(^DGS(41.42,DGIEN,0)) Q:DGZERO="" < .S DGDFN=$P(DGZERO,U),DGAPDT=$P(DGZERO,U,8),DGCLN=$P( < .Q:('DGDFN)!('DGAPDT) < .S DGKFLAG=0 < .; delete if appt date less than NOW < .I DGAPDTDGPTDTS S DGPTERC=537 D ERR G:DGPTEDFL EX diff -y --suppress-common-lines ./VADemo/r1/DGPT50DI.m ./VADemo/r2/r/DGPT50DI.m DGPT50DI ;ALB/MTC/ADL - Edit diagnoses.Check ICD DIAGN | DGPT50DI ;ALB/MTC - Edit diagnoses.Check ICD DIAGNOSES ;;5.3;Registration;**510**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;Updated for CSV project;;Mar 24, 2003 < S DGPTTMP=$$ICDDX^ICDCODE(X,$S($G(DGPTMDTS)'="":DGPTM | I '$D(^ICD9(X,0)) S DGPTERC=509+I Q I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q | I ($P(^ICD9(X,0),U,9)=1)&($E(DGPTMDTS,1,7)>$P(^(0),U, I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U | I ($P(^ICD9(X,0),U,10)]"")&(DGPTGEN'=$P(^(0),U,10)) S I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S < S DGPTTMP=$$ICDDX^ICDCODE(X,$S($G(DGPTMDTS)'="":DGPTM | I '$D(^ICD9(X,0)) S DGPTERC=509+I Q I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q | I ($P(^ICD9(X,0),U,9)=1)&($E(DGPTMDTS,1,7)>$P(^(0),U, I ($P(DGPTTMP,U,10)=0)&($E(DGPTMDTS,1,7)>$P(DGPTTMP,U | I ($P(^ICD9(X,0),U,10)]"")&(DGPTGEN'=$P(^(0),U,10)) S I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S < S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIB2,$S($G(DGPTMDTS)'=" | I '$D(^ICD9(DGPTDIB2)) S DGPTERC=509+I Q I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=509+I Q | I '$D(^ICD9(DGPTDIB2,0)) S DGPTERC=509+I Q I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S D | I $P(^ICD9(DGPTDIB2,0),U,10)]""&(DGPTGEN'=$P(^(0),U,1 diff -y --suppress-common-lines ./VADemo/r1/DGPT60PR.m ./VADemo/r2/r/DGPT60PR.m DGPT60PR ;ALB/MTC/ADL - Edit procedure codes. In ICD0 | DGPT60PR ;ALB/MTC - Edit procedure codes. In ICD0 Pro ;;5.3;Registration;**510**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;Update for CSV project;;Mar. 24, 2003 < S DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$S($G(DGPTPDTS)'="": | I '$D(^ICD0(DGPTPP)) S DGPTERC=604+DGPTL3 Q I DGPTTMP<1!('$P(DGPTTMP,U,10)) S DGPTERC=604+DGPTL3 | I '$D(^ICD0(DGPTPP,0)) S DGPTERC=604+DGPTL3 Q I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S D | I $P(^ICD0(DGPTPP,0),U,10)]""&(DGPTGEN'=$P(^(0),U,10) S DGPTTMP=$$ICDOP^ICDCODE(DGPTPP,$S($G(DGPTPDTS)'="": | I ($P(^ICD0(DGPTPP,0),U,9)=1)&($E(DGPTPDTS,1,7)>$P(^( I ($P(DGPTTMP,U,10)=0)&($E(DGPTPDTS,1,7)>$P(DGPTTMP,U < diff -y --suppress-common-lines ./VADemo/r1/DGPT70DI.m ./VADemo/r2/r/DGPT70DI.m DGPT70DI ;ALB/MTC/ADL - Diagnosis edits for 700's - E | DGPT70DI ;ALB/MTC - Diagnosis edits for 700's - E code ;;5.3;Registration;**510**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar. 24, 2003 < S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="" | I '$D(^ICD9(DGPTDIA2,0)) S DGPTERC=719+DGPTL3 Q I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 | I ($P(^ICD9(DGPTDIA2,0),U,9)=1)&($E(DGPTDDS,1,7)>$P(^ I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U, | I ($P(^ICD9(DGPTDIA2,0),U,10)]"")&(DGPTGEN'=$P(^(0),U I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S < S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="" | I '$D(^ICD9(DGPTDIA2,0)) S DGPTERC=719+DGPTL3 Q I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 | I ($P(^ICD9(DGPTDIA2,0),U,9)=1)&($E(DGPTDDS,1,7)>$P(^ I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U, | I ($P(^ICD9(DGPTDIA2,0),U,10)]"")&(DGPTGEN'=$P(^(0),U I ($P(DGPTTMP,U,11)]"")&(DGPTGEN'=$P(DGPTTMP,U,11)) S < S DGPTTMP=$$ICDDX^ICDCODE(DGPTDIA2,$S($G(DGPTDDS)'="" | I '$D(^ICD9(DGPTDIA2)) S DGPTERC=719+DGPTL3 Q I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=719+DGPTL3 | I '$D(^ICD9(DGPTDIA2,0)) S DGPTERC=719+DGPTL3 Q I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S D | I $P(^ICD9(DGPTDIA2,0),U,10)]""&(DGPTGEN'=$P(^(0),U,1 diff -y --suppress-common-lines ./VADemo/r1/DGPT70DX.m ./VADemo/r2/r/DGPT70DX.m DGPT70DX ;ALB/MTC/ADL - DXLS Edit Checks for 701 ; 13 | DGPT70DX ;ALB/MTC - DXLS Edit Checks for 701 ; 13 NOV ;;5.3;Registration;**510**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 24, 2003 < S DGPTTMP=$$ICDDX^ICDCODE(J,$S($G(DGPTDDS)'="":DGPTDD | I '$D(^ICD9(J,0)) S DGPTERC=715 Q I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=715 Q | I ($P(^ICD9(J,0),U,9)=1)&($E(DGPTDDS,1,7)>$P(^(0),U,1 I ($P(DGPTTMP,U,10)=0)&($E(DGPTDDS,1,7)>$P(DGPTTMP,U, < S DGPTTMP=$$ICDDX^ICDCODE(J,$S($G(DGPTDDS)'="":DGPTDD | G:$P(^ICD9(J,0),U,10)']"" DDXE G:$P(DGPTTMP,U,11)']"" DDXE | I $P(^ICD9(J,0),U,10)'=DGPTGEN S DGPTERC=751 G EXIT I $P(DGPTTMP,U,11)'=DGPTGEN S DGPTERC=751 G EXIT < diff -y --suppress-common-lines ./VADemo/r1/DGPTAE04.m ./VADemo/r2/r/DGPTAE04.m DGPTAE04 ;ALB/MTC/ADL - 401 Edit Checks Cont ; 13 NOV | DGPTAE04 ;ALB/MTC - 401 Edit Checks Cont ; 13 NOV 92 ;;5.3;Registration;**510**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;Updated for CSV Project;;Mar 24, 2003 < S DGPTTMP=$$ICDOP^ICDCODE(DGPTOPP,$S($G(DGPTSDD)'="": | I '$D(^ICD0(DGPTOPP,0)) S DGPTERC=451 Q I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=451 Q | I $P(^ICD0(DGPTOPP,0),U,10)]""&(DGPTGEN'=$P(^(0),U,10 I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S D < S DGPTTMP=$$ICDOP^ICDCODE(DGPTOPP,$S($G(DGPTSDD)'="": | I ($P(^ICD0(DGPTOPP,0),U,9)=1)&($P(DGPTSDD,1,7)>$P(^( I ($P(DGPTTMP,U,10)=0)&($P(DGPTSDD,1,7)>$P(DGPTTMP,U, < diff -y --suppress-common-lines ./VADemo/r1/DGPTAEE1.m ./VADemo/r2/r/DGPTAEE1.m ;;5.3;Registration;**338,565**;Aug 13, 1993 | ;;5.3;Registration;**338**;Aug 13, 1993 S X="BIRTHDATE POS AGO ION ST-CNTY ZIP MT INCOM | S X="BIRTHDATE POS AGO ION ST-CNTY ZIP MT INCOM S X=$E(REC,57,58)_SP_$E(REC,59,60)_SP_$E(REC,61,64)_" | S X=$E(REC,57,58)_SP_$E(REC,59,60)_SP_$E(REC,61,64)_" diff -y --suppress-common-lines ./VADemo/r1/DGPTAEE2.m ./VADemo/r2/r/DGPTAEE2.m ;;5.3;Registration;**8,338,415,565**;Aug 13, 1993 | ;;5.3;Registration;**8,338,415**;Aug 13, 1993 S X="SC AO IR EC MST HNC ETH RACE CV" | S X="SC AO IR EC MST HNC ETH RACE " S X=$E(REC,88)_" "_$E(REC,89)_" "_$E(REC,90)_" "_$ | S X=$E(REC,88)_" "_$E(REC,89)_" "_$E(REC,90)_" "_$ Only in ./VADemo/r1/: DGPTDDCR.m diff -y --suppress-common-lines ./VADemo/r1/DGPTDRG.m ./VADemo/r2/r/DGPTDRG.m ;;5.3;Registration;**60,441,510,559,599,606**;Aug 13, | ;;5.3;Registration;**60,441**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 28, 2003 < PAT D EFFDATE G Q:$D(DUOUT),Q:$D(DTOUT) | PAT W !!,"Choose Patient from PATIENT file" S %=1 D YN^DI W !!,"Choose Patient from PATIENT file" S %=1 D YN^DI < DX N DXINF,ICDVDT S ICDVDT=DGDAT | DX S (DGDX,DGSURG)="",DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A S (DGDX,DGSURG)="",DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A | S DIC("A")="Enter SECONDARY diagnosis: " K DIC("S") W W ! D ^DIC G Q:X["^"!(Y'>0) S DGPTTMP=$$ICDDX^ICDCODE | F DGI=2:1:5 D ^DIC Q:X["^"!(X="") I +Y>0 S:'$P(Y(0), S DIC("A")="Enter SECONDARY diagnosis: " S DIC("S")=" | G Q:X["^" S DIC("S")="I '$P(^ICD0(+Y,0),U,9)",DIC="^I F DGI=2:1:5 D ^DIC Q:X["^"!(X="") I +Y>0 S DGPTTMP=$ < G Q:X["^" S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,0 < F DGI=1:1:4 D ^DIC Q:X["^"!(X="") I +Y>0 S DGSURG=+Y < G Q:X["^" I $D(DGPTODR) S DGVAR="AGE^NAME^SEX^DGDMS^D | G Q:X["^" I $D(DGPTODR) S DGVAR="AGE^NAME^SEX^DGDMS^D S DGDRGPRT=1 D ^DGPTICD,Q G PAT ;return DRG code eve | S DGDRGPRT=1 D ^DGPTICD,Q G PAT EFFDATE ;prompts for effective date for DRG grouper? < K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="E < S DIR("?")="The effective to be used when calculating < D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q < S DGDAT=Y < Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTF1.m ./VADemo/r2/r/DGPTF1.m DGPTF1 ;ALB/JDS - PTF ENTRY/EDIT ; 11/24/03 3:29pm | DGPTF1 ;ALB/JDS - PTF ENTRY/EDIT ; 10/4/01 10:12am ;;5.3;Registration;**69,114,195,397,342,415,565**;Aug | ;;5.3;Registration;**69,114,195,397,342,415**;Aug 13, NTR W ?39," N/T Radium: " S L=A("NTR") W $S(L'="":L,1: | NTR W !," N/T Radium: " S L=A("NTR") W $S(L'="":L,1:"U 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: < S A("CV")=$$CVEDT^DGCV(DFN,$P($G(B(0)),U,2)) < diff -y --suppress-common-lines ./VADemo/r1/DGPTF4.m ./VADemo/r2/r/DGPTF4.m DGPTF4 ;ALB/JDS - PTF ENTRY/EDIT-4 ; 2/19/04 9:33am | DGPTF4 ;ALB/JDS - PTF ENTRY/EDIT-4 ; 8/2/01 5:42pm ;;5.3;Registration;**114,115,397,510,517,478**;Aug 13 | ;;5.3;Registration;**114,115,397**;Aug 13, 1993 EN1 ;LOAD AND DISPLAY DIAGNOSES FOR PTF 701 SCREEN | EN1 K DRG S B(70)=$S($D(^DGPT(PTF,70)):^(70),1:"") D WR K DRG S B(70)=$S($D(^DGPT(PTF,70)):^(70),1:""),B(71)= | W ! S Z=1 D Z W " DXLS: ",$S($D(^ICD9(+$P(B(7 S DGPTDAT=$$GETDATE^ICDGTDRG(PTF) ;Get correct effect | W:$P(B(70),U,11)&('$P(B(70),U,10)) !," Principal Dia S DGPTTMP=$$ICDDX^ICDCODE(+$P(B(70),U,10),DGPTDAT) < W ! S Z=1 D Z W " Principal Diagnosis: ",$S(DGPTTMP& < S DGPTTMP=$$ICDDX^ICDCODE(+$P(B(70),U,11),DGPTDAT) < W:$P(B(70),U,11)&('$P(B(70),U,10)) !," Principal Dia < S K=B(70) F I=16:1:24 D DSP < S K=B(71) F I=1:1:4 D DSP < I $D(^DGPT(PTF,0)),$P(^(0),U,11)=1 D | I $D(^DGPT(PTF,0)),$P(^(0),U,11)=1 S DA=DFN D EN1^DGP .S DA=DFN < .D EN1^DGPTFD < .I $D(DRG),$D(^DGP(45.84,PTF,0)),$P(^(0),U,6)'=DRG D < ..N DGFDA,DGMSG < ..S DGFDA(45.84,PTF_",",6)=DRG < ..D FILE^DIE("","DGFDA","DGMSG") < ;F I=$Y:1:18 W ! | F I=$Y:1:18 W ! > ; DSP S J=$$ICDDX^ICDCODE(+$P(K,U,I),DGPTDAT) I J&$P(J,U,10 < .I I#2 W ?40,$P(J,U,4)_"("_$P(J,U,2)_")" Q < .W !,$P(J,U,4)_"("_$P(J,U,2)_")" < Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTFAPI.m ./VADemo/r2/r/DGPTFAPI.m DGPTFAPI ;BAY/JAT/ADL - Returns data from Patient Trea | DGPTFAPI ;BAY/JAT - Returns data from Patient Treatmen ;;5.3;Registration;**309,510**;Aug 13, 1993 | ;;5.3;Registration;**309** ;;ADL;Update for CSV Project;;Mar 24, 2003 < S DGPTDAT=$$GETDATE^ICDGTDRG(DGPTF) | I DGDXLS S DGDXLS=$P($G(^ICD9(DGDXLS,0)),U) I DGDXLS S DGDXLS=$P($$ICDDX^ICDCODE(DGDXLS,DGPTDAT), | S DGDX2=$P(DG70,U,16) I DGDX2 S DGDX2=$P($G(^ICD9(DGD S DGDX2=$P(DG70,U,16) I DGDX2 S DGDX2=$P($$ICDDX^ICDC | S DGDX3=$P(DG70,U,17) I DGDX3 S DGDX3=$P($G(^ICD9(DGD S DGDX3=$P(DG70,U,17) I DGDX3 S DGDX3=$P($$ICDDX^ICDC | S DGDX4=$P(DG70,U,18) I DGDX4 S DGDX4=$P($G(^ICD9(DGD S DGDX4=$P(DG70,U,18) I DGDX4 S DGDX4=$P($$ICDDX^ICDC | S DGDX5=$P(DG70,U,19) I DGDX5 S DGDX5=$P($G(^ICD9(DGD S DGDX5=$P(DG70,U,19) I DGDX5 S DGDX5=$P($$ICDDX^ICDC | S DGDX6=$P(DG70,U,20) I DGDX6 S DGDX6=$P($G(^ICD9(DGD S DGDX6=$P(DG70,U,20) I DGDX6 S DGDX6=$P($$ICDDX^ICDC | S DGDX7=$P(DG70,U,21) I DGDX7 S DGDX7=$P($G(^ICD9(DGD S DGDX7=$P(DG70,U,21) I DGDX7 S DGDX7=$P($$ICDDX^ICDC | S DGDX8=$P(DG70,U,22) I DGDX8 S DGDX8=$P($G(^ICD9(DGD S DGDX8=$P(DG70,U,22) I DGDX8 S DGDX8=$P($$ICDDX^ICDC | S DGDX9=$P(DG70,U,23) I DGDX9 S DGDX9=$P($G(^ICD9(DGD S DGDX9=$P(DG70,U,23) I DGDX9 S DGDX9=$P($$ICDDX^ICDC | S DGDX10=$P(DG70,U,24) I DGDX10 S DGDX10=$P($G(^ICD9( S DGDX10=$P(DG70,U,24) I DGDX10 S DGDX10=$P($$ICDDX^I < diff -y --suppress-common-lines ./VADemo/r1/DGPTFDEL.m ./VADemo/r2/r/DGPTFDEL.m DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 1/15/04 8:23a | DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 18 SEP 84 18 ;;5.3;Registration;**517**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 S DA=DGPTIFN,DIK="^DGPT(",FLAG=1,I=0 F S I=$O(^DGCPT | S DA=DGPTIFN,DIK="^DGPT(" D ^DIK K DIK I FLAG S I=0 F S I=$O(^DGICD9(46.1,"C",DA,I)) Q:'I < I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE < D ^DIK K DA,DIK,I,FLAG < diff -y --suppress-common-lines ./VADemo/r1/DGPTFD.m ./VADemo/r2/r/DGPTFD.m DGPTFD ;ALB/MTC/ADL - Sets Required Variables for DRG on 701 | DGPTFD ;ALB/MTC - Sets Required Variables for DRG on 701 Scr ;;5.3;Registration;**60,441,510**;Aug 13, 1993 | ;;5.3;Registration;**60,441**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 24, 2003 < S DGDAT=$$GETDATE^ICDGTDRG(PTF) < I '+DGPT(70)!(+DGPT(70)>2861000) F DGI=16:1:24 I $P(D | I '+DGPT(70)!(+DGPT(70)>2861000) F DGI=16:1:24 I $P(D I +DGPT(70),+DGPT(70)<2871000 G DRG:'$D(^DGPT(PTF,"40 | I +DGPT(70),+DGPT(70)<2871000 G DRG:'$D(^DGPT(PTF,"40 . F DGI=1:1:5 I $P(X,U,DGI)]"" S DGPTTMP=$$ICDOP^ICDC | ;-- get procedures (601) ;-- get 601 (procedures) < S:'$D(DGCPT) DGDRGPRT=1 D ^DGPTICD ;return DRG code | S:'$D(DGCPT) DGDRGPRT=1 D ^DGPTICD F DGJ=1:1:5 I $P(X,U,DGJ)]"" S DGPTTMP=$$ICDOP^ICDCOD | F DGJ=1:1:5 I $P(X,U,DGJ)]"",$D(^ICD0($P(X,U,DGJ),0)) Only in ./VADemo/r1/: DGPTFEE.m diff -y --suppress-common-lines ./VADemo/r1/DGPTFIC.m ./VADemo/r2/r/DGPTFIC.m DGPTFIC ;ALB/JDS/ADL - PTF CODE SEARCH ; 26 JAN 87 @0800 [7/1 | DGPTFIC ;ALB/JDS - PTF CODE SEARCH ; 26 JAN 87 @0800 ;;5.3;Registration;**510,559,599**; Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;;Update for CSV Project;;Mar 25, 2003 | EN K DG1 S DIC="^ICD9(" G RANGE EN K DG1 S DIC="^ICD9(" S DIC("S")="I $$ISVALID^ICDGTDRG < S DG9=$S('DGR:"I DG1[(U_$P(DG3,U,DGZD)_U)",1:"S DG=$$ | S DG9=$S('DGR:"I DG1[(U_$P(DG3,U,DGZD)_U)",1:"S DG4=$ S XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=$S(DGZD | S DIS("0AA")="I $D(^DGPT(D0,""M"",D1,0)) S DG3=^(0) F S DIS("0AA")="I $D(^DGPT(D0,""M"",D1,0)) S DG3=^(0) F | S DIS("0AAA")="I $D(^DGPT(D0,70)) S DG3=^(70) F DGZD= S XAAA="S DG2=DG2+1,$P(^UTILITY($J,""DG"",D0,""A""),U < S DIS("0AAA")="I $D(^DGPT(D0,70)) S DG3=^(70) F DGZD= < Q K DIS,DGZD,DGZJ,DINS,DXS,DTOUT,DG4,DGR,DIP,DP,%,DGZJJ | Q K DIS,DGZD,DGZJ,DINS,DXS,DTOUT,DG4,DGR,DIP,DP,%,DGZJJ S DIC="^ICD0(" S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DT | S DIC="^ICD0(" G RANGE S DG9=$S('DGR:"I DG1[(U_$P(DG3,U,DGZD)_U)",1:"S DG=$$ | S DG9=$S('DGR:"I DG1[(U_$P(DG3,U,DGZD)_U)",1:"S DG4=$ S XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=(DGZD-7 | S DIS("0AA")="I $D(^DGPT(D0,""S"",D1,0)) S DG3=^(0) F S DIS("0AA")="I $D(^DGPT(D0,""S"",D1,0)) S DG3=^(0) F | S DIS("0AAA")="I $D(^DGPT(D0,""401P"")) S DG3=^(""401 S XAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U | S DIS("0AAAA")="F D1=0:0 S D1=$O(^DGPT(D0,""P"",D1)) S DIS("0AAA")="I $D(^DGPT(D0,""401P"")) S DG3=^(""401 < S XAAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=(DGZD < S DIS("0AAAA")="F D1=0:0 S D1=$O(^DGPT(D0,""P"",D1)) < DHD S DIC("A")="Then search for: ",DIC("S")=$S($G(DIC("S" | DHD S DIC("A")="Then search for: ",DIC("S")="I DG1'[(U_+Y diff -y --suppress-common-lines ./VADemo/r1/DGPTFJC.m ./VADemo/r2/r/DGPTFJC.m DGPTFJC ;ALB/ADL - CLOSED PTF ; 3/25/04 1:08pm | DGPTFJC ;ALB/JDS - CLOSED PTF ; 3/14/85 ;;5.3;Registration;**158,510,517,590**;Aug 13, 1993 | ;;5.3;Registration;**158**;Aug 13, 1993 ;;ADL;;Update for CSV Project;;Mar 25, 2003 < I X="" S (ST,ST1)=J+2 G @($S($D(DGZDIAG):"NDG",$D(DGZ | I X="" S (ST,ST1)=J+2 G @($S($D(DGZDIAG):"NDG",$D(DGZ ;Display screen prompt and process user response for < 801 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">, < D READ G Q^DGPTF:X=U,NEXP^DGPTFM2:X="",^DGPTFJ:X?1"^" < EN S K=$S($D(K):K,1:1),DGER=0 S DGPTDAT=$$GETDATE^ICDGTD | EN S K=$S($D(K):K,1:1),DGER=0 I $P(^ICD9(+Y,0),U,9) S DG I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+ | I $P(^(0),U,10)]""&($P(^(0),U,10)'=$S($D(^DPT(+^DGPT( I 'DG1 W !,$S(+DGPTTMP>0&('$P(DGPTTMP,U,10)):$P(DGPTT | I 'DG1 W !,$S($D(^ICD9(+Y,0)):$P(^(0),U),1:"")," requ EN1 S K=$S($D(K):K,1:1),DGER=0,DGPTDAT=$$GETDATE^ICDGTDRG | EN1 S K=$S($D(K):K,1:1),DGER=0,DGICD0=^ICD0(+Y,0) I $P(DG I $P(DGICD0,U,11)]""&($P(DGICD0,U,11)'=$S($D(^DPT(+^D | I $P(DGICD0,U,10)]""&($P(DGICD0,U,10)'=$S($D(^DPT(+^D F I=0:0 S I=$O(^ICD0(+Y,"N",I)) Q:I'>0 I $D(^DGPT(DA | F I=0:0 S I=$O(^ICD0(+Y,"N",I)) Q:I'>0 I $D(^DGPT(DA I 'DG1 W !,$P(DGICD0,U,2)," requires additional code. | I 'DG1 W !,$P(DGICD0,U)," requires additional code." EN2 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDOP^ICDCODE(+Y | EN2 S K=$S($D(K):K,1:1),DGER=0 I $P(^ICD0(+Y,0),U,9) S DG I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+ | I $P(^(0),U,10)]""&($P(^(0),U,10)'=$S($D(^DPT(+^DGPT( EN3 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDDX^ICDCODE(+Y | EN3 S K=$S($D(K):K,1:1),DGER=0 I $P(^ICD9(+Y,0),U,9) S DG I DGI=1,$P(DGPTTMP,U,5) S DGER=1 Q | I DGI=1,$P(^(0),U,4) S DGER=1 Q I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+ | I $P(^(0),U,10)]""&($P(^(0),U,10)'=$S($D(^DPT(+^DGPT( S %=$S($D(^DGPT(DA,70)):^(70),1:""),%=U_$P(%,U,10)_U_ | S %=$S($D(^DGPT(DA,70)):^(70),1:""),%=U_$P(%,U,10)_U_ S:$G(^DGPT(DA,71))'="" %=%_^(71)_U S $P(%,U,DGI+1)=U < F I=0:0 S I=$O(^ICD9(+Y,"N",I)) Q:I'>0 I %[(U_I_U) S < Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD9(+Y,"R",I)) Q:I'> < I 'DG1 W !,$S(+DGPTTMP>0:$P(DGPTTMP,U,2),1:"")," requ < Q < EN4 S K=$S($D(K):K,1:1),DGER=0,N=$$ICDDX^ICDCODE(+Y,$$GET < I DGI=1,$P(N,U,5) S DGER=1 Q < I $P(N,U,11)]""&($P(N,U,11)'=$S($D(^DPT(+^DGPT(DA(2), < S %=$S($D(^DGPT(DA(2),"C",DA(1),"CPT",DA,0)):^(0),1:" < I 'DG1 W !,$P(N,U,2)," requires additional code." | I 'DG1 W !,$S($D(^ICD9(+Y,0)):$P(^(0),U),1:"")," requ Q < EN5 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDDX^ICDCODE(+Y < I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+ < S K=^DGCPT(46,DA,0) I $P(K,U,4,7)_U_$P(K,U,15,18)[Y S < Q < EN6 I $P($G(^(0)),U,2)?.N S DGER=1 Q < S DGER=0,N=$$CPT^ICPTCOD(+Y,$$GETDATE^ICDGTDRG(DA)) I < S L=0 F S L=$O(^DGCPT(46,L)) Q:L'>0 I +$G(^(L,1))=D < K L Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTFJ.m ./VADemo/r2/r/DGPTFJ.m DGPTFJ ;ALB/MRL - JUMP BETWEEN PTF SCREENS ; 1/15/04 8:06am | DGPTFJ ;ALB/MRL - JUMP BETWEEN PTF SCREENS ; 27 MAR 84 20:5 ;;5.3;Registration;**58,517**;Aug 13, 1993 | ;;5.3;Registration;**58**;Aug 13, 1993 TEST K S,M G Q^DGPTF:X="^" S Z="^101^401^501^601^701^801^M | TEST K S,M G Q^DGPTF:X="^" S Z="^101^401^501^601^701^MAS^C HELP W !!,"PTF Screens are: ",! F I=1,5,4,6,7,8,"M","C" S | HELP W !!,"PTF Screens are: ",! F I=1,5,4,6,7,"M","C" S T= 8 ;;F^DGPTFM2;'801' Screen--CPT entry (CPT and HCPCS) < diff -y --suppress-common-lines ./VADemo/r1/DGPTF.m ./VADemo/r2/r/DGPTF.m DGPTF ;ALB/JDS/AS - PTF LOAD/EDIT DRIVER ; 11/24/03 12:13pm | DGPTF ;ALB/JDS/AS - PTF LOAD/EDIT DRIVER ; 9/18/01 4:06pm ;;5.3;Registration;**26,58,164,195,397,565**;Aug 13, | ;;5.3;Registration;**26,58,164,195,397**;Aug 13, 1993 S A("CV")=$$CVEDT^DGCV(DFN,$P($G(B(0)),U,2)) < D KVAR^DGPTUTL1,KVAR^DGPTC1 K SDCLY | D KVAR^DGPTUTL1,KVAR^DGPTC1 .X DGX Q:DGANUM'=1 | .X DGX Q:DGANUM'=1 S $P(^DGPT(PTF,0),U,5)=DGSUFNAM(D .N DGFDA,DGMSG < .S DGFDA(45,PTF_",",5)=DGSUFNAM(DGANUM) < .D FILE^DIE("","DGFDA","DGMSG") < diff -y --suppress-common-lines ./VADemo/r1/DGPTFM0.m ./VADemo/r2/r/DGPTFM0.m DGPTFM0 ;ALB/MAC/ADL - ROUTINE TO DISPLAY PROCEDURE CODES ON | DGPTFM0 ;ALB/MAC - ROUTINE TO DISPLAY PROCEDURE CODES ON THE ;;5.3;Registration;**510,517**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;;Update for CSV Project;;Mar 25, 2003 < S P2=0,(L6,P)=0 F J=ST:2:(I1-1) S NL=1,L5=0,L6=J D PD | S P2=0,(L6,P)=0 F J=ST:2:(I1-1) S NL=1,L5=0,L6=J D PD PD1 S DGPTTMP=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)) | PD1 S L2=$S($D(^ICD0(+L,0)):^(0),1:""),P2=P2+1,L4=$P(L2," . W:L3 ! S:L3 L3=0 W ?L1*40,$J(P2,3)," ",$J(L4,7)," " < PRC K DGZSER,DGZDIAG,DGZPRO S DGZSUR=1,J=-1 G PRO1^DGPTFM | PRC K DGZSER,DGZDIAG,DGZPRO S DGZSUR=1 G PRO1^DGPTFM:$Y>1 F L=1:1:S2 Q:'$D(S2(L)) I $D(S(+S2(L),1)),$D(^DGPT(P | F L=1:1:S2 Q:'$D(S2(L)) I $D(S(+S2(L),1)),$D(^DGPT(P . W !?5,$J(L,2),": ",$J($P(DGPTTMP,"^",2),7)," - ",$E < F L=1:1:M2 Q:'$D(@UTL@(L)) I $D(^DGPT(PTF,"M",+@UTL@ | F L=1:1:M2 Q:'$D(@UTL@(L)) I $D(^DGPT(PTF,"M",+@UTL@ . W !?5,$J(L,2),": ",$J($P(DGPTTMP,"^",2),7)," - ",$E < W !,"for procedures listed under 'Procedure date:' di | W !,"for procedures listed under 'Procedure date:' di diff -y --suppress-common-lines ./VADemo/r1/DGPTFM1A.m ./VADemo/r2/r/DGPTFM1A.m ;;5.3;Registration;**517**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 R !!,"Enter to continue: ",ANS:DTIME K ANS G ^D | R !!,"Enter to continue: ",ANS:DTIME G ^DGPTFM diff -y --suppress-common-lines ./VADemo/r1/DGPTFM1.m ./VADemo/r2/r/DGPTFM1.m ;;5.3;Registration;**114,517**;Aug 13, 1993 | ;;5.3;Registration;**114**;Aug 13, 1993 I G ADD^DGPTFM2 < Y G DEL^DGPTFM2 < N G N^DGPTFM2 < G G DC^DGPTFM2 < F G F^DGPTFM2 < Only in ./VADemo/r1/: DGPTFM2.m Only in ./VADemo/r1/: DGPTFM3.m diff -y --suppress-common-lines ./VADemo/r1/DGPTFM4.m ./VADemo/r2/r/DGPTFM4.m DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 11/19/03 11:37am | DGPTFM4 ;ALB/MTC - PTF ENTRY/EDIT-2 ; 9/13/01 3:00pm ;;5.3;Registration;**114,195,397,510,565**;Aug 13, 19 | ;;5.3;Registration;**114,195,397**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 26, 2003 < I $P(M3,U,31)'="" W @($S(NL#2:"!",1:"?37")),"Potentia | I $P(M3,U,26)'="" W ?37,"Treated for AO Condition: ", I $P(M3,U,26)'="" W @($S(NL#2:"!",1:"?37")),"Treated < W !! S Z=2 D Z W " DX: " F I=1:1:11 S L=$P(M | W !! S Z=2 D Z W " DX: " F I=1:1:11 S L=$P(M . W $S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,4)_ < diff -y --suppress-common-lines ./VADemo/r1/DGPTFM5.m ./VADemo/r2/r/DGPTFM5.m DGPTFM5 ;ALB/MTK/ADL - PTF ENTRY/EDIT-3 ; 11 MAR 91 15:15 | DGPTFM5 ;ALB/MTC - PTF ENTRY/EDIT-3 ; 11 MAR 91 15:15 ;;5.3;Registration;**510,606**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 26, 2003 < W !! S Z=2 D Z W " Surg/pro: " F I=1:1:5 S L=$P(S1 | W !! S Z=2 D Z W " Surg/pro: " F I=1:1:5 S L=$P(S1 . W $S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,5)_ < N ICDVDT,ICPTVDT < S (ICDVDT,ICPTVDT)=$S($D(PTF):$$GETDATE^ICDGTDRG(PTF) < diff -y --suppress-common-lines ./VADemo/r1/DGPTFM6.m ./VADemo/r2/r/DGPTFM6.m DGPTFM6 ;ALB/BOK/ADL - 601 SCREEN: PROCEDURE ENTER/EDIT ; 21 | DGPTFM6 ;ALB/BOK - 601 SCREEN: PROCEDURE ENTER/EDIT ; 21 JUL ;;5.3;Registration;**164,510**;Aug 13, 1993 | ;;5.3;Registration;**164**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 26, 2003 < W !! S Z=2 D Z^DGPTFM5 W " Procedures: " F I=1:1:5 | W !! S Z=2 D Z^DGPTFM5 W " Procedures: " F I=1:1:5 . W $S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,5)_ < diff -y --suppress-common-lines ./VADemo/r1/DGPTFM7.m ./VADemo/r2/r/DGPTFM7.m DGPTFM7 ;ALB/MJK - Display Phys. CDR mvts ;4/13/04 1:26pm | DGPTFM7 ;ALB/MJK - Display Phys. CDR mvts ; 07 May 90 ;;5.3;Registration;**78,590,594**;Aug 13, 1993 | ;;5.3;Registration;**78**;Aug 13, 1993 D HEADER:$Y>(IOSL-15) S DGLAST("DT")=DGLDT,DGLAST("C" | D HEADER S DGLAST("DT")=DGLDT,DGLAST("C")=DGC S:'$D(DC) DC=0 S PTF=D0,DGPR=1 D EN,KILL K PTF Q:$Y<( | S:'$D(DC) DC=0 S PTF=D0,DGPR=1 D EN,KILL K PTF I $E(IOST,1)="C" W *7 R X:DTIME I X=U S DN=0 Q | I $E(IOST)="C" W ! S DIR(0)="E" D ^DIR K DIR W @IOF,! X:$D(^UTILITY($J,2)) ^(2) W ! F %=1:1:IOM W < W !,"("_$P(^DPT(+^DGPT(D0,0),0),U,1)_")",! < Q < DT I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV < diff -y --suppress-common-lines ./VADemo/r1/DGPTFM.m ./VADemo/r2/r/DGPTFM.m DGPTFM ;ALB/MTC - PTF OP-PRO-DIAG ; 4/1/04 10:57am | DGPTFM ;ALB/MTC - PTF OP-PRO-DIAG ; 12 MAR 91 ;;5.3;Registration;**510,517,590,594,606**;Aug 13, 19 | ;;5.3;Registration;;Aug 13, 1993 K M,S,M1,M2,M3,S1,S2,PS2,SDCLY,^TMP("PTF",$J) | K M,S,M1,M2,M3,S1,S2 K MT D ORDER^DGPTF K MT D GETVAR^DGPTFM6,CL^SDCO21(DF | K MT D ORDER^DGPTF K MT D GETVAR^DGPTFM6 DIAG K DGZSER,DGZPRO,DGZSUR S DGZDIAG=1 F J=ST:2:PM S NL=1 | DIAG K DGZSER,DGZPRO,DGZSUR S DGZDIAG=1 F J=ST:2:PM S NL=1 WD1 S N=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S | WD1 S L2=$S($D(^ICD9(+L,0)):^(0),1:""),M2=M2+1,L4=$P(L2," W:L3 ! S:L3 L3=0 W ?L1*40,$J(M2,3)," ",$J(L4,7)," ",$ < SER K DGZDIAG,DGZPRO,DGZSUR S DGZSER=1 G PRO1:$Y>19 K S1, | SER K DGZDIAG,DGZPRO,DGZSUR S DGZSER=1 G PRO1:$Y>20 K S1, SERV F J=ST:2:SU S NL=1,L5=0,L6=J D SD2 S L5=1,L6=J+1 D:$D | SERV F J=ST:2:SU S NL=1,L5=0,L6=J D SD2 S L5=1,L6=J+1 D:$D SD1 S N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S | SD1 S L2=$S($D(^ICD0(+L,0)):^(0),1:""),S2=S2+1,L4=$P(L2," W:L3 ! S:L3 L3=0 W ?L1*40,$J(S2,3)," ",$J(L4,7)," ",$ < PRO K DGZSER,DGZDIAG,DGZSUR S DGZPRO=1 G PRO1:$Y>14 K P1, | PRO K DGZSER,DGZDIAG,DGZSUR S DGZPRO=1 G PRO1:$Y>15 K P1, PROC D:$Y>14 WR W:PROC]"" !!,"Procedures: ",! | PROC D:$Y>15 WR W:PROC]"" !!,"Procedures: ",! F J1=1:1:5 S L=$P(PROC,"^",J1) I L'="" S P2=P2+1,N=$$ | F J1=1:1:5 S L=$P(PROC,"^",J1) I L'="" S P2=P2+1,L2=$ .W:$X>5 ?40 W $J(P2,3)," ",$J(L4,7)," ",$E($P(L2,"^", | K DGZSER,DGZPRO,DGZDIAG,DGZSUR G PRO1 K DGZSER,DGZPRO,DGZDIAG,DGZSUR < ENC G PRO1:$Y>7,PRO1:'$P(DGZPRF,U,3) < PF S PS2=0,J=+DGZPRF,Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U < D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(D < D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P( < I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Pro < W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D < I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P( < S (L1,PGBRK)=0 < F K=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K)) I '$G(DGZPRF < . W !,?4 S $P(DS,"-",27)="" W DS," Related Diagnosis < . F L1=DGSTRT:1:11 S DGLOC=$S(L1<8:L1,1:L1+7),CD=$P(D < . . S N=$$ICDDX^ICDCODE(CD,$$GETDATE^ICDGTDRG(PTF)),N < . . S CD=$P(N,U) W !,?8,CD," ",$P(N,U,3) < . . D CKSCI($P(DGZPRF(J,K),U,DGLOC)) < . S PS2(PS2)=J_U_K,CD=1,DGLOC=0,DGSTRT=4 < I L1'=11,$S(L1<8:$P($G(DGZPRF(J,K)),U,L1+1,7),1:"")_$ < I L1=11 S $P(DGZPRF,U,1,2)=$S($D(DGZPRF(J,K+1)):J_U_( < E S $P(DGZPRF,U,1,2)=J_U_K,$P(DGZPRF,U,4)=L1+1 < ;I '$D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=$S($P($G(DGZ < ;I $D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=J_U_(K+1) < K I,K,L,L1,CD,N G PRO1 < ; < CKSCI(IEN) ;print SCI for each Diagnosis code < N DGINFO Q:'$D(XREF(IEN)) < S DGINFO=$G(^DGICD9(46.1,(XREF(IEN)),0)),CKSCI=0 < I 'DGINFO Q < F I=3,7,1,2,4:1:6 I $D(SDCLY(I)) S L=$S(I=3:8,I<4:8+I < .W ?45 S M=1,CKSCI=CKSCI+1 < .W $P("Treated for AO Condition^Treated for IR Condit < .I I'=7 W ":",$S($P(DGINFO,U,($S(I<3:I+2,I=3:2,1:I+1) < .I I=7 W ":",$S($P(DGINFO,U,8)="Y":"YES",1:"NO"),! < Q ;CKSCI < NPS D WR G PF < ; < PRO1 ;SET MENU TYPE AND DISPLAY MENU | PRO1 S DGNUM=$S($D(DGZDIAG)!($D(DGZPRO))!($D(DGZSER))!($D( N ICDVDT,ICPTVDT < S (ICDVDT,ICPTVDT)=$S($D(PTF):$$GETDATE^ICDGTDRG(PTF) < S DGNUM=$S($D(DGZDIAG)!($D(DGZPRO))!($D(DGZSER))!($D( < W ! S Z="Procedure Records:" W Z S Z=" T=Add PR R=De | W ! S Z="Procedure Records:" W Z S Z=" T=Add PR R=De W ! S Z="CPT Records:" W Z S Z=" I=Add CR Y=Delete C < A S Z="^C Delete Code^A Add Code^O Add Code^P Add NOP^S | A S Z="^C Delete Code^A Add Code^O Add Code^P Add NOP^S S Z=Z_"T Add PR^R Delete PR^E Edit PR^I Add CR^Y Dele < S X=ANS G Q^DGPTF:ANS="^" G ^DGPTFJ:ANS?1"^".E S (A,X | S X=ANS G Q^DGPTF:ANS="^" G ^DGPTFJ:ANS?1"^".E S (A,X I ANS="" S (ST,ST1)=J+2 D:$D(DGZSUR) WR G @($S($D(DGZ < PRV I $D(^VA(200,L,0)) W $P(^(0),U) Q < W L Q < EN D WR G EN^DGPTFM0 < diff -y --suppress-common-lines ./VADemo/r1/DGPTFMO.m ./VADemo/r2/r/DGPTFMO.m DGPTFMO ;ALB/JDS/ADL - DGPTF PRINT TEMPLATE ; 4/13/04 12:11pm | DGPTFMO ;ALB/JDS - DGPTF PRINT TEMPLATE ; 8/23/01 3:51pm ;;5.3;Registration;**195,397,510,590,594,606**;Aug 13 | ;;5.3;Registration;**195,397**;Aug 13, 1993 ;;ADL;Updated for CSV Project;;Mar 4, 2003 < S DGPT=$G(^DGPT(D0,70)) I DGPT]"" G Q:'DN D DXLS | S DGPT=$S($D(^DGPT(D0,70)):^(70),1:"") I DGPT]"" D HE K %,DGL,DGM,DGPT,DGOP,DGOP1,DGF,DGP,DXLS,DGICD,L1,S1, | K %,DGL,DGM,DGPT,DGOP,DGOP1,DGF,DGP,DXLS,DGICD,L1,S1, W !!,"Movement Date: ",Y,?40,"Losing Specialty: ",DGL | W !!,"Movement Date: ",Y,?40,"Losing Specialty: ",DGL W !,"Treated for SC condition: ",$S($P(DGM,U,18)=1:"Y < W:$P(DGM,U,31)'="" !,"Potentially Related to Combat: < S DGF="" F J=5:1:15 I J#10 S DGPTTMP=$$ICDDX^ICDCODE( | S DGF="" F J=5:1:15 I J#10 S DGICD=$S($D(^ICD9(+$P(DG . W:DGF="" !!?13,"DX: " W $P(DGICD,U,3)_" ("_$P(DGICD < N DXD,DGDX | F DGDS=0:0 S DGDS=$O(^ICD(DGTD,1,DGDS)) Q:DGDS'>0 W S DXD=$$DRGD^ICDGTDRG(DGTD,"DGDX",,$$GETDATE^ICDGTDRG < F S DGDS=$O(DGDX(DGDS)) Q:'+DGDS Q:DGDX(DGDS)=" " < W !!,?7,"Surg/pro: " F K=1:1:5 S L=$P(S1,U,K+7) I L'= | W !!,?7,"Surg/pro: " F K=1:1:5 S L=$P(S1,U,K+7) I L'= PROC S DGF="" F I=1:1:5 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DGOP | PROC S DGF="" F I=1:1:5 S DGOP=$S($D(^ICD0(+$P(DGOP1,U,I), . W:'DGF !!?6,"Procedure: " W $P(DGOP,U,4)_" ("_$P(DG < F J=5:1:9 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DG601,U,J),$$ | F J=5:1:9 S DGPROC=$S($D(^ICD0(+$P(DG601,U,J),0)):^(0 DXLS D HEAD:$Y>(IOSL-16) S DGPTDAT=$$GETDATE^ICDGTDRG(D0) | DXLS S DXLS=$S($D(^ICD9(+$P(DGPT,U,10),0)):^(0),1:"") I DX S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGPT,U,10),DGPTDAT),DXL | I 'DXLS S DGP=$S($D(^ICD9(+$P(DGPT,U,11),0)):^(0),1:" I 'DXLS S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGPT,U,11),DGPT | F %=16:1:24 S DGICD=$S($D(^ICD9(+$P(DGPT,U,%),0)):^(0 S K=DGPT F I=16:1:24 D DSP < S K=$G(^DGPT(D0,71)) F I=1:1:4 D DSP < DSP S J=$$ICDDX^ICDCODE(+$P(K,U,I),DGPTDAT) I J&$P(J,U,10 < .I I#2 W ?40,$P(J,U,4)_"("_$P(J,U,2)_")" Q < .W !,$P(J,U,4)_"("_$P(J,U,2)_")" < Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTFQWK.m ./VADemo/r2/r/DGPTFQWK.m DGPTFQWK ;ALB/AS - QUICK/LOAD PTF DATA ;5/5/04 10:57am | DGPTFQWK ;ALB/AS - QUICK/LOAD PTF DATA ; JAN 7 88@3 ;;5.3;Registration;**517,594**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 W !,"* editing 801 transactions" < D S801 < S801 ;-- set up 801 < F S DIC("A")="Select 801 CPT DATE/TIME: " D D REQ:$ < .S DA(1)=PTF,DIC(0)="AEQLZ",DIC="^DGPT("_PTF_",""C"", < .S:'$D(^DGPT(PTF,"C",0)) ^(0)="^45.06^^" D ^DIC < .K DA,DIC,PSIEN Q:Y'>0 S DGPRD=+Y(0),DGPSM=+Y D MOB^ < .S DA(1)=PTF,DIE="^DGPT("_PTF_",""C"",",(DA,REC,PSIEN < .S DGI=0,DR=".01;" D CL^SDCO21(DFN,DGPRD,"",.SDCLY) D < ..F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 I +^D < ..F S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELQMZ",DLAYGO < K DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,RFL Q < REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS M < S RFL=0 I '$P(^DGPT(PTF,"C",PSIEN,0),U,3) S DA(1)=PTF < .D ^DIK K DA W !!,"No CPT records have been filed bec < S (I,FCPT)=0 < F J=1:1 S I=$O(^DGCPT(46,"C",PTF,I)) Q:'I D:+^DGCPT( < .I $P(^DGCPT(46,I,0),U,4) S FCPT=1 Q < .S DA=I,DIK="^DGCPT(46,",CPT=+^DGCPT(46,I,0) D ^DIK < .W !!,"CPT " S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG < .S RFL=1 < I FCPT K FCPT,I,J,N G REQQ < S DA(1)=PTF,DA=PSIEN,DIK="^DGPT("_PTF_",""C""," < D ^DIK K DA W !!,"No CPT records have been filed beca < REQQ D RESEQ^DGPTFM3(PTF) < Q < SED S DR=".14////"_DGPRD_";.16////"_PTF_";",(DA,REC)=+Y,D < FMDIE L +^DGCPT(46,REC):2 I D ^DIE L -^DGCPT(46,REC) K DIE < ERR W !,"CPT record is being edited by another user" K DI < PTFDIE L +^DGPT(REC):2 I D ^DIE L -^DGPT(REC) K DIE,REC Q < K DIE,REC G ERR < Only in ./VADemo/r1/: DGPTFRU1.m diff -y --suppress-common-lines ./VADemo/r1/DGPTFTR0.m ./VADemo/r2/r/DGPTFTR0.m DGPTFTR0 ;ALB/JDS/ADL - PTF TRANSMISSION ; 10/1/03 6:5 | DGPTFTR0 ;ALB/JDS - PTF TRANSMISSION ; 01 DEC 87 @0800 ;;5.3;Registration;**247,510,524**;Aug 13, 1993 | ;;5.3;Registration;**247**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 26, 2003 < F I=1:1:5 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DG41,U,I),$$G | F I=1:1:5 S Y=Y_$S($D(^ICD0(+$P(DG41,U,I),0)):$J($P($ I ^UTILITY($J,"S",DGSUD)>$S(F:3,1:2) D I Y'=1 S DGER | I ^UTILITY($J,"S",DGSUD)>$S(F:3,1:2) W !,"More than " .W !!,"**There are more than ",$S(F:"three",1:"two"), < .S DIR(0)="Y",DIR("B")="YES",DIR("A")="OK to continue < F K=8:1:12 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DGSUR,U,I),$ | F K=8:1:12 S Y=Y_$S($D(^ICD0(+$P(DGSUR,U,K),0)):$J($P diff -y --suppress-common-lines ./VADemo/r1/DGPTFTR3.m ./VADemo/r2/r/DGPTFTR3.m DGPTFTR3 ;ALB/MJK - TRANSMISSION OF PTF/CENSUS ; 03/12 | DGPTFTR3 ;ALB/MJK - TRANSMISSION OF PTF/CENSUS ; 01 DE ;;5.3;Registration;**568**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 S Y=$TR($$FMTE^XLFDT(DT,"5DF")," ","0") | S Y=DT D DTS^SDUTL S ^UTILITY($J,"DGPTSTAT",1,0)=" S ^UTILITY($J,"DGPTSTAT",1,0)=" | D DTS^SDUTL S %=" RELEASE DATE RANGE SELECTED: S %=" RELEASE DATE RANGE SELECTED: "_Y_" - " S < diff -y --suppress-common-lines ./VADemo/r1/DGPTFTR.m ./VADemo/r2/r/DGPTFTR.m DGPTFTR ;ALB/JDS - TRANSMISSION OF PTF ; 5/3/04 9:00am | DGPTFTR ;ALB/JDS - TRANSMISSION OF PTF ; 01 DEC 87 @0800 ;;5.3;Registration;**37,415,530,601**;Aug 13, 1993 | ;;5.3;Registration;**37,415**;Aug 13, 1993 diff -y --suppress-common-lines ./VADemo/r1/DGPTFUP.m ./VADemo/r2/r/DGPTFUP.m ;;5.3;Registration;**441,478**;Aug 13, 1993 | ;;5.3;Registration;**441**;Aug 13, 1993 S DGTOT=DGTOT-DGPASS-DGLEAVE | S DGTOT=DGTOT-DGPASS-DGLEAVE,$P(^DGPT(PTF,"M",1,"P"), N DGFDA,DGMSG < S DGFDA(45.02,1_","_PTF_",",23)=DGTOT < S DGFDA(45.02,1_","_PTF_",",25)=DGTOT+DGCUM < D FILE^DIE("","DGFDA","DGMSG") < K DGTDD,DGPRD,DGNXD F I=0:0 S I=$O(^DGPT(PTF,"M",I)) | K DGTDD,DGPRD,DGNXD F I=0:0 S I=$O(^DGPT(PTF,"M",I)) .N FLD,DGFDA,DGMSG < .F FLD=20:1:25 S DGFDA(45.02,I_","_PTF_",",FLD)="@" < .D FILE^DIE("","DGFDA","DGMSG") < diff -y --suppress-common-lines ./VADemo/r1/DGPTFVC1.m ./VADemo/r2/r/DGPTFVC1.m DGPTFVC1 ;ALB/AS/ADL - Expanded PTF Close-Out Edits ; | DGPTFVC1 ;ALB/AS - Expanded PTF Close-Out Edits ; Jul ;;5.3;Registration;**52,58,79,114,164,400,342,466,415 | ;;5.3;Registration;**52,58,79,114,164,400,342,466,415 ;;ADL;Updated for CSV Project;;Mar 26, 2003 < ; DG*512, sck/Remove 101-Means Test indocator = 'U' x | I 'DGV("FEE"),$P(DGV(101),"^",10)="U",'DGV(701)!(+DGV ;I 'DGV("FEE"),$P(DGV(101),"^",10)="U",'DGV(701)!(+DG < SCI F X=5:1:15 I X#10 S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGNOD | SCI F X=5:1:15 I X#10 S:$E($P($G(^ICD9(+$P(DGNODE,"^",X), ; sc < 50%, 0% non-comp, sc movements - DG*5.3*544 < I DGX="A",$P(DGZEC,U,4)=3,$$SC^DGMTR(DFN),$$ANYSC^DGP < ;-- sc, >0% - DG*5.3*544 < I DGX="A","^1^3^"[("^"_$P(DGZEC,U,4)_"^"),$P($G(^DPT( < diff -y --suppress-common-lines ./VADemo/r1/DGPTICD.m ./VADemo/r2/r/DGPTICD.m ;;5.3;Registration;**375,441,510,559,599,606**;Aug 13 | ;;5.3;Registration;**375,441**;Aug 13, 1993 ; DGDAT <- Effective date to be used in calculating < . S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGDX,U,DGI),+$G(DGDAT | . I $D(^ICD9(+$P(DGDX,U,DGI),0)) S ICDDX(DGI)=$P(DGDX . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S ICDDX(DGI)=$P(DGD < . S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT)) | .I $D(^ICD0(X,0)) S SUB=SUB+1,ICDPRC(SUB)=X . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC( < . S FLG=0,J=0 F S J=$O(ICDPRC(J)) Q:'J I X=$G(ICDPR | .S FLG=0,J=0 F S J=$O(ICDPRC(J)) Q:'J I X=$G(ICDPRC . I FLG Q | .I FLG Q . S DGPTTMP=$$ICDOP^ICDCODE(X,+$G(DGDAT)) | .I $D(^ICD0(X,0)) S SUB=SUB+1,ICDPRC(SUB)=X . I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,ICDPRC( < S ICDDATE=$S($D(DGDAT):DGDAT,1:DT),DGDAT=ICDDATE ;En < > I '$D(^ICD(+DRG,0)) W !,"Invalid DRG Error" G Q S Y=ICDDATE D DD^%DT ; Y=external representation of e | S DRG(0)=^ICD(DRG,0) W !!,"Diagnosis Related Group: " W !!?9,"Effective Date:"," ",Y < S DRG(0)=$$DRG^ICDGTDRG(DRG,DGDAT) W !!,"Diagnosis Re < N DXD,DGDX | W !!,"DRG: ",DRG,"-" F DGI=0:0 S DGI=$O(^ICD(DRG,1,DG S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DGDAT),DGI=0 | Q K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICD W !!,"DRG: ",DRG,"-" F S DGI=$O(DGDX(DGI)) Q:'+DGI < Q K ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC,ICD < diff -y --suppress-common-lines ./VADemo/r1/DGPTLMU4.m ./VADemo/r2/r/DGPTLMU4.m DGPTLMU4 ;ALB/MTC/ADL - PTF A/P LIST MANAGER UTILITY C | DGPTLMU4 ;ALB/MTC - PTF A/P LIST MANAGER UTILITY CONT. ;;5.3;Registration;**510**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;;Update for CSV Project;;Mar 27, 2003 < . S DGPTTMP=$$ICDDX^ICDCODE(+$P(DG70,U,J),$$GETDATE^I | . S Y=$P(^ICD9($P(DG70,U,J),0),U)_" - "_$P(^ICD9($P(D . S Y=$P(DGPTTMP,U,2)_" - "_$P(DGPTTMP,U,4) < diff -y --suppress-common-lines ./VADemo/r1/DGPTLMU5.m ./VADemo/r2/r/DGPTLMU5.m ;;5.3;Registration;**606**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 N X,X1,Y,I,J,DGDAT,DXD | N X,X1,Y,I,J . S ^TMP("ARCPTFDI",$J,$$NUM^DGPTLMU4(.NUMREC),0)="", | . S ^TMP("ARCPTFDI",$J,$$NUM^DGPTLMU4(.NUMREC),0)="" .. S DXD=$$ICDOP^ICDCODE($P(X,U,J),DGDAT),Y=$P(DXD,U, | .. S Y=$P(^ICD0($P(X,U,J),0),U)_" - "_$P(^ICD0($P(X,U .. S DXD=$$ICDOP^ICDCODE($P(X3,U,J),DGDAT),Y=$P(DXD,U | .. S Y=$P(^ICD0($P(X3,U,J),0),U)_" - "_$P(^ICD0($P(X3 N X,X1,Y,I,J,DGDAT,DXD | N X,X1,Y,I,J . S ^TMP("ARCPTFDI",$J,$$NUM^DGPTLMU4(.NUMREC),0)="", | . S ^TMP("ARCPTFDI",$J,$$NUM^DGPTLMU4(.NUMREC),0)="" .. S DXD=$$ICDOP^ICDCODE($P(X,U,J),DGDAT),Y=$P(DXD,U, | .. S Y=$P(^ICD0($P(X,U,J),0),U)_" - "_$P(^ICD0($P(X,U diff -y --suppress-common-lines ./VADemo/r1/DGPTLMU6.m ./VADemo/r2/r/DGPTLMU6.m ;;5.3;Registration;**606**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 .. S Y=$$ICDDX^ICDCODE($P(X,U,J),$P(X,U,10)),Y=$P(Y,U | .. S Y=$P(^ICD9($P(X,U,J),0),U)_" - "_$P(^ICD9($P(X,U diff -y --suppress-common-lines ./VADemo/r1/DGPTODI3.m ./VADemo/r2/r/DGPTODI3.m ;;5.3;Registration;**51,158,164,375,606**;Aug 13, 199 | ;;5.3;Registration;**51,158,164,375**;Aug 13, 1993 ;W !!,?5,"Description:" F %=0:0 S %=$O(^ICD(DRG,1,%)) | W !!,?5,"Description:" F %=0:0 S %=$O(^ICD(DRG,1,%)) N DXD,DGDX S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,DT) < W !!,?5,"Description:" F %=0:0 S %=$O(DGDX(%)) Q:'+% < diff -y --suppress-common-lines ./VADemo/r1/DGPTODR.m ./VADemo/r2/r/DGPTODR.m DGPTODR ;ALB/ABS/ADL - DRG Information Report ; 17 FEB 89@14: | DGPTODR ;ALB/ABS - DRG Information Report ; 17 FEB 89@14:00 ;;5.3;Registration;**510**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 28, 2003 < S DGPG=DGPG+1 W @IOF,"DRG INFORMATION REPORT",?45,"Da | S DGPG=DGPG+1 W @IOF,"DRG INFORMATION REPORT",?45,"Da S Y=DGDAT D DD^%DT ; Y = external format of effective < W "Effective Date: ",Y,! I NAME]"" W "Patient: ",NAME < diff -y --suppress-common-lines ./VADemo/r1/DGPTOLC2.m ./VADemo/r2/r/DGPTOLC2.m DGPTOLC2 ;ALB/AS/ADL - SUMMARY BY ADM RPT, lists diagn | DGPTOLC2 ;ALB/AS - SUMMARY BY ADM RPT, lists diagnoses ;;5.3;Registration;**164,510,559,599**; Aug 13, 1993 | ;;5.3;Registration;**164**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 27, 2003 < C S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGM,"^",DGC),$$GETDATE^ | C Q:'$D(^ICD9(+$P(DGM,"^",DGC),0)) S DGICD=^(0) I $Y>( . I $Y>($S($D(IOSL):IOSL,1:66)-4) D CRT W !,"Diagnosi < P1 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DGSUR,"^",DGC),$$GETDAT | P1 Q:'$D(^ICD0(+$P(DGSUR,"^",DGC),0)) S DGICD=^(0) Q:DG . I $Y>($S($D(IOSL):IOSL,1:66)-4) D CRT W !,$S('$D(DG < Only in ./VADemo/r1/: DGPTPXRM.m diff -y --suppress-common-lines ./VADemo/r1/DGPTR0.m ./VADemo/r2/r/DGPTR0.m DGPTR0 ;MJK/JS/ADL - PTF TRANSMISSION ; 10/1/03 6:44pm | DGPTR0 ;MJK/JS - PTF TRANSMISSION ; 01 DEC 87 @0800 ;;5.3;Registration;**114,247,338,342,510,524,565**;Au | ;;5.3;Registration;**114,247,338,342**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 27, 2003 < ;Combat Vet < S X=$$CVEDT^DGCV(+DG0,$P(DG0,"^",2)) S Y=Y_$S((+X)>0: < S X=$P(X,"^",2)_" " S Y=Y_$E(X,4,5)_$E(X,6,7)_$ < F I=1:1:5 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DG41,U,I),$$G | F I=1:1:5 S Y=Y_$S($D(^ICD0(+$P(DG41,U,I),0)):$J($P($ I ^UTILITY($J,"S",DGSUD)>$S(F:3,1:2) D I Y'=1 S DGER | I ^UTILITY($J,"S",DGSUD)>$S(F:3,1:2) W !,"More than " .W !,"**There are more than ",$S(F:"three",1:"two")," < .S DIR(0)="Y",DIR("B")="YES",DIR("A")="OK to continue < F K=8:1:12 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DGSUR,U,K),$ | F K=8:1:12 S Y=Y_$S($D(^ICD0(+$P(DGSUR,U,K),0)):$J($P diff -y --suppress-common-lines ./VADemo/r1/DGPTR1.m ./VADemo/r2/r/DGPTR1.m ;;5.3;Registration;**58,247,338,342,423,415,565**;Aug | ;;5.3;Registration;**58,247,338,342,423,415**;Aug 13, T10 ;;1:NAME^2:SOURCE OF ADM^3:TRANS FAC.^4:SOURCE OF PAY | T10 ;;1:NAME^2:SOURCE OF ADM^3:TRANS FAC.^4:SOURCE OF PAY T701 ;;1:PHY SPEC^2:%SC^3:LEGION^4:SUICIDE^5:DRUG^6:AXIS-I | T701 ;;1:PHY SPEC^2:%SC^3:LEGION^4:SUICIDE^5:DRUG^6:AXIS-I 10 ;;6;;12;1^2;1;1;1^5;1;1;1^1;2;1;2^2;2;1;2^4;3;3;3^6;; | 10 ;;6;;12;1^2;1;1;1^5;1;1;1^1;2;1;2^2;2;1;2^4;3;3;3^6;; 701 ;;15;;2;1^1;;3;2^4;;1;3^4;;1;4^12;;1;5^4;;3;5^4;;1;6^ | 701 ;;15;;2;1^1;;3;2^4;;1;3^4;;1;4^12;;1;5^4;;3;5^4;;1;6^ diff -y --suppress-common-lines ./VADemo/r1/DGPTR2.m ./VADemo/r2/r/DGPTR2.m DGPTR2 ;ALB/JDS/MJK/MTC/ADL - ALB/BOK PTF TRANSMISSION ; 01 | DGPTR2 ;ALB/JDS/MJK/MTC - ALB/BOK PTF TRANSMISSION ; 01 DEC ;;5.3;Registration;**183,338,423,510**;Aug 13, 1993 | ;;5.3;Registration;**183,338,423**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 27,2003 < F Z=5:1:9 S DGPTTMP=$$ICDDX^ICDCODE($P(DGM,U,Z),$$GET | F Z=5:1:9 S F=$S($D(^ICD9(+$P(DGM,U,Z),0)):$P(^(0),U, . S F=$S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,2 < F K=5:1:9 S DGPTTMP=$$ICDOP^ICDCODE(+$P(DGPROC,U,K),$ | F K=5:1:9 S Y=Y_$S($D(^ICD0(+$P(DGPROC,U,K),0)):$J($P . S Y=Y_$S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$J($P($P(DGP < diff -y --suppress-common-lines ./VADemo/r1/DGPTR4.m ./VADemo/r2/r/DGPTR4.m DGPTR4 ;ALB/JDS/MJK/MTC/ADL - ALB/BOK PTF TRANSMISSION ; 01 | DGPTR4 ;ALB/JDS/MJK/MTC - ALB/BOK PTF TRANSMISSION ; 01 DEC ;;5.3;Registration;**338,423,415,510,565**;Aug 13, 19 | ;;5.3;Registration;**338,423,415**;Aug 13, 1993 S DGPTDAT=$$GETDATE^ICDGTDRG(J) | S DGXLS=$S($D(^ICD9(+$P(DG70,U,10),0)):$P(^(0),U,1),1 S DGPTTMP=$$ICDDX^ICDCODE(+$P(DG70,U,10),DGPTDAT) S D | S L=$P(DG70,U,16,24) S DG702="" F K=1:1:9 I $D(^ICD9( S L=$P(DG70,U,16,24) S DG702="" F K=1:1:9 S DGPTTMP=$ < ;Combat vet < S Y=Y_$E($P(DG70,U,31)_" ") < diff -y --suppress-common-lines ./VADemo/r1/DGPTSPQ.m ./VADemo/r2/r/DGPTSPQ.m DGPTSPQ ;ALB/MTC - PTF Utility Con; 3/5/93 ; 11/26/03 9:56am | DGPTSPQ ;ALB/MTC - PTF Utility Con; 3/5/93 ; 8/30/01 11:22am ;;5.3;Registration;**195,397,565**;Aug 13, 1993 | ;;5.3;Registration;**195,397**;Aug 13, 1993 ; DGEXQ(6)="" - CV ;treatment for possible comb < ; ;condition < ;-- ADD KILL OF SDCLY(6) TO SKIP COMBAT VETERAN QUEST < ; CV < I $D(SDCLY(7)) S DGEXQ(6)="" < ; INPUT DGFLAG - 1=AO, 2=IR, 3=EC, 4=MST, 5=NTR, 6= | ; INPUT DGFLAG - 1=AO, 2=IR, 3=EC, 4=MST, 5=NTR ; of the SC, AO, IR, EC, MST, NTR, and CV questions | ; of the SC, AO, IR, EC, MST and NTR questions have ; answered. If so, the cooresponding <701> will be | ; If so, the cooresponding <701> will be updated. N I,DGSC,DGAO,DGIR,DGEC,DGMOV,DGMST,DGNTR,DGCV | N I,DGSC,DGAO,DGIR,DGEC,DGMOV,DGMST,DGNTR S (DGSC,DGAO,DGIR,DGEC,DGMST,DGNTR,DGCV)="@" | S (DGSC,DGAO,DGIR,DGEC,DGMST,DGNTR)="@" .;-- cv < .I $P(DGMOV,U,31)'="",DGCV'="Y" S DGCV=$P(DGMOV,U,31) < S DR="79.25////^S X=DGSC;79.26////^S X=DGAO;79.27//// | S DR="79.25////^S X=DGSC;79.26////^S X=DGAO;79.27//// diff -y --suppress-common-lines ./VADemo/r1/DGPTSUD1.m ./VADemo/r2/r/DGPTSUD1.m DGPTSUD1 ;ALB/AS/ADL - Look for the same DRG in consec | DGPTSUD1 ;ALB/AS - Look for the same DRG in consecutiv ;;5.3;Registration;**510,478**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 27, 2003 < G Q:'$D(DGSUDO) S (DGSUNX,DGSUPR)=$O(DGSUDO(0)) F XX= | G Q:'$D(DGSUDO) S (DGSUNX,DGSUPR)=$O(DGSUDO(0)) F %=0 G 88:'$P($$DRG^ICDGTDRG($P(DGSUDO(DGSUNX),"^",2),$$GE | G 88:'$P(^ICD($P(DGSUDO(DGSUNX),"^",2),0),"^",6) KILL N DGFDA,DGMSG,FLD | KILL S $P(^DGPT(PTF,"M",DGSUB,"P"),"^",4)=$P(DGMV1,"^",4)+ S DGFDA(45.02,DGSUB_","_PTF_",",23)=$P(DGMV1,"^",4)+$ | I DGSUB=DG1 S $P(^DGPT(PTF,"M",DG1,"P"),"^",6)=$P(DGM D FILE^DIE("","DGFDA","DGMSG") | K ^DGPT(PTF,"M",DG1,"P"),DGSUDO(DGSUPR) S DGSUPR=DGSU I DGSUB=DG1 D Q < .K DGFDA,DGMSG < .S DGFDA(45.02,DG1_","_PTF_",",25)=$P(DGMV2,"^",6) < .D FILE^DIE("","DGFDA","DGMSG") < .K DGFDA,DGMSG < .F FLD=20:1:25 S DGFDA(45.02,DG2_","_PTF_",",FLD)="@" < .D FILE^DIE("","DGFDA","DGMSG") < .K DGSUDO(DGSUNX) < K DGFDA,DGMSG < F FLD=20:1:25 S DGFDA(45.02,DG1_","_PTF_",",FLD)="@" < D FILE^DIE("","DGFDA","DGMSG") < K DGSUDO(DGSUPR) < S DGSUPR=DGSUNX < Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTSUDO.m ./VADemo/r2/r/DGPTSUDO.m ;;5.3;Registration;**441,510,478**;Aug 13, 1993 | ;;5.3;Registration;**441**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 28, 2003 < S (DGPRD,DGNXD)=$O(^UTILITY($J,"T",0)) G Q:DGPRD'>0 S | S (DGPRD,DGNXD)=$O(^UTILITY($J,"T",0)) G Q:DGPRD'>0 S S DGDAT=$$GETDATE^ICDGTDRG(PTF) < S DGPTDAT=$$GETDATE^ICDGTDRG(PTF) < .. F J=1:1:5 I $P(X,U,J)]"" S DGPTTMP=$$ICDOP^ICDCODE | .. F J=1:1:5 I $P(X,U,J)]"",$D(^ICD0($P(X,U,J),0)) S .. F J=1:1:5 I $P(X,U,J)]"" S DGPTTMP=$$ICDOP^ICDCODE | .. F J=1:1:5 I $P(X,U,J)]"",$D(^ICD0($P(X,U,J),0)) S . F I=1:1:5 I $P(X,U,I)]"" S DGPTTMP=$$ICDOP^ICDCODE( | . F I=1:1:5 I $P(X,U,I)]"",$D(^ICD0($P(X,U,I),0)) S D F I=9:-1:5 I $P(DGNODE,U,I)]"" S DGPTTMP=$$ICDDX^ICDC | F I=9:-1:5 I $P(DGNODE,U,I)]"",$D(^ICD9($P(DGNODE,U,I N DGFDA,DGMSG | S $P(^DGPT(PTF,"M",I1,"P"),U,1,6)=DRG_U_DGPSV_U_DGNXD S DGFDA(45.02,I1_","_PTF_",",20)=DRG < S DGFDA(45.02,I1_","_PTF_",",21)=DGPSV < S DGFDA(45.02,I1_","_PTF_",",22)=DGNXD < S DGFDA(45.02,I1_","_PTF_",",23)=DGLOS < S DGFDA(45.02,I1_","_PTF_",",24)=DGDOC < S DGFDA(45.02,I1_","_PTF_",",25)=DGTLOS < D FILE^DIE("","DGFDA","DGMSG") < diff -y --suppress-common-lines ./VADemo/r1/DGPTTRIM.m ./VADemo/r2/r/DGPTTRIM.m ;;5.3;Registration;**158,606**;Aug 13, 1993 | ;;5.3;Registration;**158**;Aug 13, 1993 ASK ;W !! S DIC="^ICD(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S | ASK W !! S DIC="^ICD(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S D W !! S DIC="^ICD(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S D < diff -y --suppress-common-lines ./VADemo/r1/DGPTTS1.m ./VADemo/r2/r/DGPTTS1.m DGPTTS1 ;ALB/AS/ADL - FACILITY TREATING SPECIALTY AND 501 MOV | DGPTTS1 ;ALB/AS - FACILITY TREATING SPECIALTY AND 501 MOVEMEN ;;5.3;Registration;**26,64,418,510,478**;Aug 13, 1993 | ;;5.3;Registration;**26,64,418**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 28, 2003 < S DGREC1=$S($D(^DGPT(PTF,"M",1,0)):^(0),1:"") | S DGREC1=$S($D(^DGPT(PTF,"M",1,0)):^(0),1:""),DGREC=$ S DGREC=$S($D(^UTILITY($J,"T",DGAD)):^(DGAD),$D(T("AD < I DGREC,$D(^DGPM(+DGREC,0)) D < .N DGFDA,DGMSG < .S DGFDA(405,(+DGREC)_",",53)=1 < .D FILE^DIE("","DGFDA","DGMSG") < MSG S DGMSG="" F X=5:1:15 I X'=10 S DGPTTMP=$$ICDDX^ICDCO | MSG S DGMSG="" F X=5:1:15 S:X'=10 DGMSG=DGMSG_$S($D(^ICD9 diff -y --suppress-common-lines ./VADemo/r1/DGPTTS2.m ./VADemo/r2/r/DGPTTS2.m DGPTTS2 ;ALB/JDS - FACILITY TREATING SPECIALTY AND 501 MOVEME | DGPTTS2 ;ALB/JDS - FACILITY TREATING SPECIALTY AND 501 MOVEME ;;5.3;Registration;**549,478**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 F I=0:0 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 D | F I=0:0 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 K ^(I,"P") .N FLD,DGFDA,DGMSG < .F FLD=20:1:25 S DGFDA(45.02,I_","_PTF_",",FLD)="@" < .D FILE^DIE("","DGFDA","DGMSG") < ADT1 S:'$D(^DGPT(PTF,"M",0)) ^DGPT(PTF,"M",0)="^45.02AI^1^ | ADT1 S:'$D(^DGPT(PTF,"M",0)) ^DGPT(PTF,"M",0)="^45.02AI^1^ S I1=I1+1,J=^DGPT(PTF,"M",0),^(0)=$P(J,U,1,2)_U_I1_U_ | L ^DGPT(PTF,"M",0) S I1=I1+1,J=^DGPT(PTF,"M",0),^(0)= N DGFDA,DGMSG < S DGFDA(45.02,I1_","_PTF_",",.01)=I1 < D FILE^DIE("","DGFDA","DGMSG") < diff -y --suppress-common-lines ./VADemo/r1/DGPTTS3.m ./VADemo/r2/r/DGPTTS3.m DGPTTS3 ;ALB/MJK - Physical Mvt ; 9/19/03 4:23pm | DGPTTS3 ;ALB/MJK - Physical Mvt ; MAY 04, 1990 ;;5.3;Registration;**26,61,549**;Aug 13, 1993 | ;;5.3;Registration;**26,61**;Aug 13, 1993 L +^DGPT(DGPTIFN,535) S Y=^DGPT(DGPTIFN,535,0),I=$P(Y | L ^DGPT(DGPTIFN,535) S Y=^DGPT(DGPTIFN,535,0),I=$P(Y, S X=DGDATA,^DGPT(DGPTIFN,535,I,0)=I_U_$P(X,U,2)_U_$P( | S X=DGDATA,^DGPT(DGPTIFN,535,I,0)=I_U_$P(X,U,2)_U_$P( diff -y --suppress-common-lines ./VADemo/r1/DGPTTS.m ./VADemo/r2/r/DGPTTS.m DGPTTS ;ALB/AS/ADL - UPDATE FACILITY TREATING SPECIALTY/501 | DGPTTS ;ALB/AS - UPDATE FACILITY TREATING SPECIALTY/501 MOVE ;;5.3;Registration;**26,61,164,510**;Aug 13, 1993 | ;;5.3;Registration;**26,61,164**;Aug 13, 1993 ;;ADL;Update for CSV Project;;Mar 28, 2003 < S DGMSG="" F X=5:1:15 I X'=10 S DGPTTMP=$$ICDDX^ICDCO | S DGMSG="" F X=5:1:15 S:X'=10 DGMSG=DGMSG_$S($D(^ICD9 diff -y --suppress-common-lines ./VADemo/r1/DGPTUTL1.m ./VADemo/r2/r/DGPTUTL1.m DGPTUTL1 ;ALB/MJK - PTF Utility ; 2/19/04 3:13pm | DGPTUTL1 ;ALB/MJK - PTF Utility ; 12/13/89@8 ;;5.3;Registration;**33,45,54,517**;Aug 13, 1993 | ;;5.3;Registration;**33,45,54**;Aug 13, 1993 ELIG ; shows eligibility and disabilities < D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S < W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) < .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0) < .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"N < .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P( < Q < DATE ;EDIT CPT DATE/TIME TO BE AFTER ADMISSION DATE BUT BE < I X<$P(^DGPT(DA(1),0),U,2) W !,"Not before admission" < I $G(^(70)),X>^(70) W !,"Not after discharge" K X Q < S I=0 F S I=$O(^DGPT(PTF,"C",I)) Q:I'>0 I X=+^(I,0) < Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTUTL.m ./VADemo/r2/r/DGPTUTL.m DGPTUTL ;ALB/AS - PTF UTILITY ROUTINE ; 8/14/03 11:35am | DGPTUTL ;ALB/AS - PTF UTILITY ROUTINE ; 12/13/89@8 ;;5.3;Registration;**26,114,234,466,544**;Aug 13, 199 | ;;5.3;Registration;**26,114,234,466**;Aug 13, 1993 I $P(DGZEC,U,4)=3,$$SC^DGMTR(DFN),'$$ANYSC^DGPTSCAN(P | I $P(DGZEC,U,4)=3,$$SC^DGMTR(DFN),'$$ANYSC^DGPTSCAN(P ;-- sc, >0% - DG*5.3*544 < I "^1^3^"[("^"_$P(DGZEC,U,4)_"^"),$P($G(^DPT(DFN,.3)) < diff -y --suppress-common-lines ./VADemo/r1/DGPTX110.m ./VADemo/r2/r/DGPTX110.m DGPTX110 ; ;07/02/04 | DGPTX110 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX111.m ./VADemo/r2/r/DGPTX111.m DGPTX111 ; ;07/02/04 | DGPTX111 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX112.m ./VADemo/r2/r/DGPTX112.m DGPTX112 ; ;07/02/04 | DGPTX112 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX113.m ./VADemo/r2/r/DGPTX113.m DGPTX113 ; ;07/02/04 | DGPTX113 ; ;02/04/03 D DE G BEGIN | S X=DE(14),DIC=DIE DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE, < I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,7) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGPTX113",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;7",DV="NJ3,0XOa" < S DQ(1,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11 < S DE(DW)="C1^DGPTX113" < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < S X=DE(1),DIC=DIE | S X=DE(14),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(14),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(14),DIC=DIE S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET | S X=DE(14),DIIX=2_U_DIFLD D AUDIT^DIET C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DG(DQ),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA < I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C1F1 Q < X1 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 < Q < ; < 2 S DQ=3 ;@991 < 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 < X3 I +DGJUMP>2&(+DGJUMP<5) S Y="@"_+DGJUMP_1 < Q < 4 G 1^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/DGPTX11.m ./VADemo/r2/r/DGPTX11.m DGPTX11 ; ;07/02/04 | DGPTX11 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX12.m ./VADemo/r2/r/DGPTX12.m DGPTX12 ; ;07/02/04 | DGPTX12 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX13.m ./VADemo/r2/r/DGPTX13.m DGPTX13 ; ;07/02/04 | DGPTX13 ; ;02/04/03 C1F2 S DIXR=399 D C1X2(U) K X2 M X2=X D C1X2("O") K X1 M X | C1F2 Q D < . D FC^DGFCPROT(.DA,2.06,.01,"KILL",$H,$G(DUZ),.X,.X1 < K X M X=X2 D < . D FC^DGFCPROT(.DA,2.06,.01,"SET",$H,$G(DUZ),.X,.X1, < G C1F3 < C1X2(DION) K X < S X(1)=$G(@DIEZTMP@("V",2.06,DIIENS,.01,DION),$P($G(^ < S X=$G(X(1)) < Q < C1F3 Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTX14.m ./VADemo/r2/r/DGPTX14.m DGPTX14 ; ;07/02/04 | DGPTX14 ; ;02/04/03 S DE(DW)="C1^DGPTX14",DE(DW,"INDEX")=1 | S DE(DW)="C1^DGPTX14" C1F1 N X,X1,X2 S DIXR=398 D C1X1(U) K X2 M X2=X D C1X1("O" | C1F1 Q D < . D FC^DGFCPROT(.DA,2.02,.01,"KILL",$H,$G(DUZ),.X,.X1 < K X M X=X2 D < . D FC^DGFCPROT(.DA,2.02,.01,"SET",$H,$G(DUZ),.X,.X1, < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2.02,DIIENS,.01,DION),$P($G(^ < S X=$G(X(1)) < Q < C1F2 Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTX15.m ./VADemo/r2/r/DGPTX15.m DGPTX15 ; ;07/02/04 | DGPTX15 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX16.m ./VADemo/r2/r/DGPTX16.m DGPTX16 ; ;07/02/04 | DGPTX16 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX17.m ./VADemo/r2/r/DGPTX17.m DGPTX17 ; ;07/02/04 | DGPTX17 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX18.m ./VADemo/r2/r/DGPTX18.m DGPTX18 ; ;07/02/04 | DGPTX18 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGPTX19.m ./VADemo/r2/r/DGPTX19.m DGPTX19 ; ;07/02/04 | DGPTX19 ; ;02/04/03 I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,5) S:%]"" DE(12) | I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,5) S:%]"" DE(12) S DE(DW)="C12^DGPTX19",DE(DW,"INDEX")=1 | S DE(DW)="C12^DGPTX19" C12F1 N X,X1,X2 S DIXR=235 D C12X1(U) K X2 M X2=X D C12X1(" | C12F1 Q D < . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X < G C12F2 < C12X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DP < S X=$G(X(1)) < Q < C12F2 Q < C13F2 S DIXR=231 D C13X2(U) K X2 M X2=X D C13X2("O") K X1 M | C13F2 Q D < . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1, < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,. < G C13F3 < C13X2(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D < S X=$G(X(1)) < Q < C13F3 Q < 14 D:$D(DG)>9 F^DIE17 G ^DGPTX113 | 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".11;7",DV="NJ3,0XOa > S DQ(14,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.1 > S DE(DW)="C14^DGPTX19" > G RE > C14 G C14S:$D(DE(14))[0 K DB > D ^DGPTX113 > C14S S X="" G:DG(DQ)=X C14F1 K DB > D ^DGPTX114 > C14F1 Q > X14 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 > Q > ; > 15 S DQ=16 ;@991 > 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) > X16 I +DGJUMP>2&(+DGJUMP<5) S Y="@"_+DGJUMP_1 > Q > 17 G 1^DIE17 diff -y --suppress-common-lines ./VADemo/r1/DGPTX1.m ./VADemo/r2/r/DGPTX1.m DGPTX1 ; GENERATED FROM 'DG101' INPUT TEMPLATE(#426), FILE 4 | DGPTX1 ; GENERATED FROM 'DG101' INPUT TEMPLATE(#426), FILE 4 diff -y --suppress-common-lines ./VADemo/r1/DGPTX41.m ./VADemo/r2/r/DGPTX41.m DGPTX41 ; ;12/28/04 | DGPTX41 ; ;06/13/96 I S %=$P(%Z,U,9) S:%]"" DE(20)=% S %=$P(%Z,U,10) S:% < N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD | T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")= | SET I X'?.ANP S DDER=1 Q > N DIR S DIR(0)="SMV^"_DU,DIR("V")=1 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 | 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y S DE(DW)="C5^DGPTX41",DE(DW,"INDEX")=1 < C5 G C5S:$D(DE(5))[0 K DB < C5S S X="" G:DG(DQ)=X C5F1 K DB < C5F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=422,423,424,425,426 S DIEZRXR(45.01,DIXR)="" < Q < 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;3",DV="RP45.3'",DU | 6 S DW="0;3",DV="RP45.3'",DU="",DLB="SURGICAL SPECIALTY 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) | 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 G A:$D(Y)[0,A 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) | 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 G A:$D(Y)[0,A 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) | 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 G A:$D(Y)[0,A S DE(DW)="C15^DGPTX41",DE(DW,"INDEX")=1 | S DE(DW)="C15^DGPTX41" C15 G C15S:$D(DE(15))[0 K DB | C15 G C15S:$D(DE(15))[0 K DB S X=DE(15),DIC=DIE S X=DE(15),DIC=DIE < 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 S X=DG(DQ),DIC=DIE < C15F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=422 S DIEZRXR(45.01,DIXR)="" < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) | 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 G A:$D(Y)[0,A 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) | 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 G A:$D(Y)[0,A 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) | 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 G A:$D(Y)[0,A 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="0;9",DV="*P80.1'",D | 20 D:$D(DG)>9 F^DIE17 G ^DGPTX42 S DE(DW)="C20^DGPTX41",DE(DW,"INDEX")=1 < S DU="ICD0(" < G RE < C20 G C20S:$D(DE(20))[0 K DB < S X=DE(20),DIC=DIE < K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) < C20S S X="" G:DG(DQ)=X C20F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" < C20F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=423 S DIEZRXR(45.01,DIXR)="" < Q < X20 S DIC("S")="S DGI=9,DGCR=""AO"",DGSB=""S"" D EN1^DGPT < Q < ; < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 I X K DGPTIT S DGNFLD="@40",Y="@800",DGPTIT(X_$C(59)_ < Q < 22 S DQ=23 ;@40 < 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) < X23 S DGNFLD="@50" < Q < 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) < X24 I DGADD,$P(DGHOLD,U,10)]"" S Y="@50" < Q < 25 D:$D(DG)>9 F^DIE17,DE S DQ=25,DW="0;10",DV="*P80.1'", < S DE(DW)="C25^DGPTX41",DE(DW,"INDEX")=1 < S DU="ICD0(" < G RE < C25 G C25S:$D(DE(25))[0 K DB < D ^DGPTX42 < C25S S X="" G:DG(DQ)=X C25F1 K DB < D ^DGPTX43 < C25F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=424 S DIEZRXR(45.01,DIXR)="" < Q < X25 S DIC("S")="S DGI=10,DGCR=""AO"",DGSB=""S"" D EN1^DGP < Q < ; < 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) < X26 I X K DGPTIT S DGNFLD="@50",Y="@800",DGPTIT(X_$C(59)_ < Q < 27 S DQ=28 ;@50 < 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) < X28 S DGNFLD="@60" < Q < 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE) < X29 I DGADD,$P(DGHOLD,U,11)]"" S Y="@60" < Q < 30 D:$D(DG)>9 F^DIE17 G ^DGPTX44 < diff -y --suppress-common-lines ./VADemo/r1/DGPTX42.m ./VADemo/r2/r/DGPTX42.m DGPTX42 ; ;12/28/04 | DGPTX42 ; ;06/13/96 S X=DE(25),DIC=DIE | D DE G BEGIN > DE S DIE="^DGPT(D0,""S"",",DIC=DIE,DP=45.01,DL=2,DIEL=1, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,9) S:%]"" DE(1)=% S > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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 I X'?.ANP S DDER=1 Q > N DIR S DIR(0)="SMV^"_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="DGPTX42",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;9",DV="*P80.1'",DU > S DE(DW)="C1^DGPTX42" > S DU="ICD0(" > G RE > C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE > C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" > Q > X1 S DIC("S")="S DGI=9,DGCR=""AO"",DGSB=""S"" D EN1^DGPT > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y > X2 I X K DGPTIT S DGNFLD="@40",Y="@800",DGPTIT(X_$C(59)_ > Q > 3 S DQ=4 ;@40 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y > X4 S DGNFLD="@50" > Q > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y > X5 I DGADD,$P(DGHOLD,U,10)]"" S Y="@50" > Q > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;10",DV="*P80.1'",D > S DE(DW)="C6^DGPTX42" > S DU="ICD0(" > G RE > C6 G C6S:$D(DE(6))[0 K DB S X=DE(6),DIC=DIE > K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) > C6S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" > Q > X6 S DIC("S")="S DGI=10,DGCR=""AO"",DGSB=""S"" D EN1^DGP > Q > ; > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y > X7 I X K DGPTIT S DGNFLD="@50",Y="@800",DGPTIT(X_$C(59)_ > Q > 8 S DQ=9 ;@50 > 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 G A:$D(Y)[0,A:Y > X9 S DGNFLD="@60" > Q > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A > X10 I DGADD,$P(DGHOLD,U,11)]"" S Y="@60" > Q > 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="0;11",DV="*P80.1'", > S DE(DW)="C11^DGPTX42" > S DU="ICD0(" > G RE > C11 G C11S:$D(DE(11))[0 K DB S X=DE(11),DIC=DIE > K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) > C11S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" > Q > X11 S DIC("S")="S DGI=11,DGCR=""AO"",DGSB=""S"" D EN1^DGP > Q > ; > 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 G A:$D(Y)[0,A > X12 I X K DGPTIT S DGNFLD="@60",Y="@800",DGPTIT(X_$C(59)_ > Q > 13 S DQ=14 ;@60 > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 G A:$D(Y)[0,A > X14 S DGNFLD="@70" > Q > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 G A:$D(Y)[0,A > X15 I DGADD,$P(DGHOLD,U,12)]"" S Y="@70" > Q > 16 D:$D(DG)>9 F^DIE17 G ^DGPTX43 diff -y --suppress-common-lines ./VADemo/r1/DGPTX43.m ./VADemo/r2/r/DGPTX43.m DGPTX43 ; ;12/28/04 | DGPTX43 ; ;06/13/96 S X=DG(DQ),DIC=DIE | D DE G BEGIN > DE S DIE="^DGPT(D0,""S"",",DIC=DIE,DP=45.01,DL=2,DIEL=1, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,12) S:%]"" DE(1)=% > I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,1) S:%]"" DE(8)= > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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 I X'?.ANP S DDER=1 Q > N DIR S DIR(0)="SMV^"_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="DGPTX43",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;12",DV="*P80.1'",D > S DE(DW)="C1^DGPTX43" > S DU="ICD0(" > G RE > C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE > K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) > C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > Q > X1 S DIC("S")="S DGI=12,DGCR=""AO"",DGSB=""S"" D EN1^DGP > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y > X2 I X K DGPTIT S DGNFLD="@70",Y="@800",DGPTIT(X_$C(59)_ > Q > 3 S DQ=4 ;@70 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y > X4 K DGNFLD S Y="" > Q > 5 S DQ=6 ;@800 > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y > X6 D SCAN^DGPTSCAN I '$D(DGBPC) S Y="@899" > Q > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y > X7 I '$D(DGBPC(1)) S Y="@899" > Q > 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="300;1",DV="SX",DU="" > S DU="1:Live Donor;2:Cadavar;" > G RE > X8 S DGFLAG=1 D 401^DGPTSC01 K:DGER X K DGER,DGFLAG > Q > ; > 9 S DQ=10 ;@899 > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A > X10 K DGPTIT S Y=DGNFLD > Q > 11 G 1^DIE17 Only in ./VADemo/r1/: DGPTX44.m Only in ./VADemo/r1/: DGPTX45.m diff -y --suppress-common-lines ./VADemo/r1/DGPTX4.m ./VADemo/r2/r/DGPTX4.m DGPTX4 ; GENERATED FROM 'DG401' INPUT TEMPLATE(#428), FILE 4 | DGPTX4 ; GENERATED FROM 'DG401' INPUT TEMPLATE(#428), FILE 4 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD | T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")= | SET I X'?.ANP S DDER=1 Q > N DIR S DIR(0)="SMV^"_DU,DIR("V")=1 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=428,U="^" M DIEZAR=^DIE(428,"AR") S DICRREC="TRIG^DIE17" < S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=42 < diff -y --suppress-common-lines ./VADemo/r1/DGPTX51.m ./VADemo/r2/r/DGPTX51.m DGPTX51 ; ;12/28/04 | DGPTX51 ; ;12/10/01 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(5)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(5)=% S 13 S DW="0;18",DV="S",DU="",DLB="WAS TREATMENT FOR A SER | 13 S DW="0;18",DV="S",DU="",DLB="TREATED FOR SC CONDITIO S DE(DW)="C22^DGPTX51",DE(DW,"INDEX")=1 | S DE(DW)="C22^DGPTX51" C22S S X="" G:DG(DQ)=X C22F1 K DB | C22S S X="" Q:DG(DQ)=X K DB C22F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=447 S DIEZRXR(45.02,DIXR)="" < S DE(DW)="C27^DGPTX51",DE(DW,"INDEX")=1 | S DE(DW)="C27^DGPTX51" C27S S X="" G:DG(DQ)=X C27F1 K DB | C27S S X="" Q:DG(DQ)=X K DB C27F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=448 S DIEZRXR(45.02,DIXR)="" < 32 D:$D(DG)>9 F^DIE17 G ^DGPTX52 | 32 D:$D(DG)>9 F^DIE17,DE S DQ=32,DW="0;7",DV="*P80'X",DU > S DE(DW)="C32^DGPTX51" > S DU="ICD9(" > G RE > C32 G C32S:$D(DE(32))[0 K DB > D ^DGPTX52 > C32S S X="" Q:DG(DQ)=X K DB > D ^DGPTX53 > Q > X32 K K S DIC("S")="S DGI=7 D EN^DGPTFJC I 'DGER" D ^DIC > Q > ; > 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE) > X33 I X K DGPTIT S DGNFLD="@60",Y="@800",DGPTIT(X_$C(59)_ > Q > 34 S DQ=35 ;@60 > 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE) > X35 I DGADD,$P(DGHOLD,U,8)]"" S Y="@70" > Q > 36 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=36 D X36 D:$D(DIEFIRE) > X36 S DGNFLD="@70" > Q > 37 D:$D(DG)>9 F^DIE17 G ^DGPTX54 diff -y --suppress-common-lines ./VADemo/r1/DGPTX52.m ./VADemo/r2/r/DGPTX52.m DGPTX52 ; ;12/28/04 | DGPTX52 ; ;12/10/01 D DE G BEGIN | S X=DE(32),DIC=DIE DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1, < I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,7) S:%]"" DE(1)=% S < I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,2) S:%]"" DE(18) < 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGPTX52",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;7",DV="*P80'X",DU= < S DE(DW)="C1^DGPTX52",DE(DW,"INDEX")=1 < S DU="ICD9(" < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < S X=DE(1),DIC=DIE | S X=DE(32),DIC=DIE C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C1F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=449 S DIEZRXR(45.02,DIXR)="" < Q < X1 K K S DIC("S")="S DGI=7 D EN^DGPTFJC I 'DGER" D ^DIC < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 I X K DGPTIT S DGNFLD="@60",Y="@800",DGPTIT(X_$C(59)_ < Q < 3 S DQ=4 ;@60 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 I DGADD,$P(DGHOLD,U,8)]"" S Y="@70" < Q < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 S DGNFLD="@70" < Q < 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;8",DV="*P80'X",DU= < S DE(DW)="C6^DGPTX52",DE(DW,"INDEX")=1 < S DU="ICD9(" < G RE < C6 G C6S:$D(DE(6))[0 K DB < S X=DE(6),DIC=DIE < K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=DE(6),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C6S S X="" G:DG(DQ)=X C6F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C6F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=450 S DIEZRXR(45.02,DIXR)="" < Q < X6 K K S DIC("S")="S DGI=8 D EN^DGPTFJC I 'DGER" D ^DIC < Q < ; < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 < X7 I X K DGPTIT S DGNFLD="@70",Y="@800",DGPTIT(X_$C(59)_ < Q < 8 S DQ=9 ;@70 < 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 < X9 I DGADD,$P(DGHOLD,U,9)]"" S Y="@80" < Q < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S DGNFLD="@80" < Q < 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="0;9",DV="*P80'X",DU < S DE(DW)="C11^DGPTX52",DE(DW,"INDEX")=1 < S DU="ICD9(" < G RE < C11 G C11S:$D(DE(11))[0 K DB < S X=DE(11),DIC=DIE < K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=DE(11),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C11S S X="" G:DG(DQ)=X C11F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C11F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=451 S DIEZRXR(45.02,DIXR)="" < Q < X11 K K S DIC("S")="S DGI=9 D EN^DGPTFJC I 'DGER" D ^DIC < Q < ; < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 I X K DGPTIT S DGNFLD="@80",Y="@800",DGPTIT(X_$C(59)_ < Q < 13 S DQ=14 ;@80 < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 K DGNFLD,DGDUP,DGADD S Y="" < Q < 15 S DQ=16 ;@800 < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 D SCAN^DGPTSCAN S:'$D(DGBPC) Y="@899" < Q < 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) < X17 I '$D(DGBPC(2))!(DGDUP(2)) S Y="@810" < Q < 18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="300;2",DV="SX",DU=" < S DU="1:Attempted Suicide;2:Accomplished Suicide;3:Se < G RE < X18 S DGFLAG=2 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG Q < Q < ; < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 S:X]"" DGDUP(2)=1 < Q < 20 S DQ=21 ;@810 < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 I '$D(DGBPC(3))!(DGDUP(3)) S Y="@820" < Q < 22 S DW="300;3",DV="SX",DU="",DLB="LEGIONNAIRE'S DISEASE < S DU="1:Yes;2:No;" < G RE < X22 S DGFLAG=3 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG Q < Q < ; < 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) < X23 S:X]"" DGDUP(3)=1 < Q < 24 S DQ=25 ;@820 < 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) < X25 I '$D(DGBPC(4))!(DGDUP(4)) S Y="@830" < Q < 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) < X26 D DRUG^DGPTSC01 I $D(DGTX) S Y="@825" < Q < 27 D:$D(DG)>9 F^DIE17 G ^DGPTX53 < diff -y --suppress-common-lines ./VADemo/r1/DGPTX53.m ./VADemo/r2/r/DGPTX53.m DGPTX53 ; ;12/28/04 | DGPTX53 ; ;12/10/01 D DE G BEGIN | S X=DG(DQ),DIC=DIE DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1, | S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,26) S:%]"" DE(30)=%, | S X=DG(DQ),DIC=DIE I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,4) S:%]"" DE(1)= | X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGPTX53",DQ=1 < 1 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE < S DU="DIC(45.61," < G RE < X1 S DGFLAG=4 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S:X]"" DGDUP(4)=1 < Q < 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 < X3 S Y="@830" < Q < 4 S DQ=5 ;@825 < 5 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE < S DU="DIC(45.61," < S X=DGTX < S Y=X < G Y < X5 S DGFLAG=4 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG < Q < ; < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 S:X]"" DGDUP(4)=1 < Q < 7 S DQ=8 ;@830 < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 I '$D(DGBPC(5))!(DGDUP(5)) S Y="@840" < Q < 9 S DW="300;5",DV="SX",DU="",DLB="PSYCHIATRY CLASS. SEV < S DU="0:INADEQUATE INFO OR NO CHANGE;1:NONE;2:MILD;3: < G RE < X9 S DGFLAG=5 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG < Q < ; < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S:X]"" DGDUP(5)=1 < Q < 11 S DQ=12 ;@840 < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 I '$D(DGBPC(6))!(DGDUP(6)) S Y="@850" < Q < 13 S DW="300;6",DV="NJ2,0X",DU="",DLB="CURRENT PSYCH CLA < G RE < X13 S DGFLAG=6 D 501^DGPTSC01 S:DGER X="" K DGFLAG,DGER K < Q < ; < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 S:X]"" DGDUP(6)=1 < Q < 15 S DQ=16 ;@850 < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 I '$D(DGBPC(7))!(DGDUP(7)) S Y="@899" < Q < 17 S DW="300;7",DV="NJ2,0X",DU="",DLB="HIGH LEVEL PSYCH < G RE < X17 S DGFLAG=7 D 501^DGPTSC01 S:DGER X="" K DGER,DGFLAG K < Q < ; < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 S:X]"" DGDUP(7)=1 < Q < 19 S DQ=20 ;@899 < 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) < X20 K DGPTIT,DGTX S Y=DGNFLD < Q < 21 S DQ=22 ;@900 < 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) < X22 K DGEXQ D CHQUES^DGPTSPQ I '$D(DGEXQ) S Y="@999" < Q < 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) < X23 I '$D(DGEXQ(6)) S Y="@904" < Q < 24 S DW="0;31",DV="S",DU="",DLB="WAS TREATMENT RELATED T < S DU="Y:YES;N:NO;" < G RE < X24 Q < 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) < X25 S Y="@905" < Q < 26 S DQ=27 ;@904 < 27 S DW="0;31",DV="S",DU="",DLB="POTENTIALLY RELATED TO < S DU="Y:YES;N:NO;" < S Y="@" < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X27 Q < 28 S DQ=29 ;@905 < 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE) < X29 I '$D(DGEXQ(1)) S Y="@910" < Q < 30 S DW="0;26",DV="SX",DU="",DLB="WAS TREATMENT RELATED < S DU="Y:YES;N:NO;" < G RE < X30 S DGFLAG=1 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG < Q < ; < 31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE) < X31 S Y="@915" < Q < 32 S DQ=33 ;@910 < 33 S DW="0;26",DV="SX",DU="",DLB="TREATED FOR AO CONDITI < S DU="Y:YES;N:NO;" < S Y="@" < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X33 S DGFLAG=1 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG < Q < ; < 34 S DQ=35 ;@915 < 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE) < X35 I '$D(DGEXQ(2)) S Y="@920" < Q < 36 S DW="0;27",DV="SX",DU="",DLB="WAS TREATMENT RELATED < S DU="Y:YES;N:NO;" < G RE < X36 S DGFLAG=2 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG < Q < ; < 37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE) < X37 S Y="@925" < Q < 38 S DQ=39 ;@920 < 39 S DW="0;27",DV="SX",DU="",DLB="TREATED FOR IR CONDITI < S DU="Y:YES;N:NO;" < S Y="@" < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X39 S DGFLAG=2 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG < Q < ; < 40 S DQ=41 ;@925 < 41 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=41 D X41 D:$D(DIEFIRE) < X41 I '$D(DGEXQ(3)) S Y="@930" < Q < 42 D:$D(DG)>9 F^DIE17 G ^DGPTX54 < diff -y --suppress-common-lines ./VADemo/r1/DGPTX54.m ./VADemo/r2/r/DGPTX54.m DGPTX54 ; ;12/28/04 | DGPTX54 ; ;12/10/01 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,28) S:%]"" DE(1)=%,D | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,8) S:%]"" DE(1)=% S > I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,2) S:%]"" DE(13) 1 S DW="0;28",DV="SX",DU="",DLB="WAS TREATMENT RELATED | 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;8",DV="*P80'X",DU= S DU="Y:YES;N:NO;" | S DE(DW)="C1^DGPTX54" > S DU="ICD9(" X1 S DGFLAG=3 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG | C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > S X=DE(1),DIC=DIE > X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D > C1S S X="" Q:DG(DQ)=X K DB > S X=DG(DQ),DIC=DIE > S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > S X=DG(DQ),DIC=DIE > X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D > Q > X1 K K S DIC("S")="S DGI=8 D EN^DGPTFJC I 'DGER" D ^DIC X2 S Y="@935" | X2 I X K DGPTIT S DGNFLD="@70",Y="@800",DGPTIT(X_$C(59)_ > Q > 3 S DQ=4 ;@70 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 > X4 I DGADD,$P(DGHOLD,U,9)]"" S Y="@80" > Q > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 > X5 S DGNFLD="@80" > Q > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;9",DV="*P80'X",DU= > S DE(DW)="C6^DGPTX54" > S DU="ICD9(" > G RE > C6 G C6S:$D(DE(6))[0 K DB > S X=DE(6),DIC=DIE > K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > S X=DE(6),DIC=DIE > X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D > C6S S X="" Q:DG(DQ)=X K DB > S X=DG(DQ),DIC=DIE > S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > S X=DG(DQ),DIC=DIE > X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D > Q > X6 K K S DIC("S")="S DGI=9 D EN^DGPTFJC I 'DGER" D ^DIC > Q > ; > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 > X7 I X K DGPTIT S DGNFLD="@80",Y="@800",DGPTIT(X_$C(59)_ > Q > 8 S DQ=9 ;@80 > 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 > X9 K DGNFLD,DGDUP,DGADD S Y="" > Q > 10 S DQ=11 ;@800 > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 D SCAN^DGPTSCAN S:'$D(DGBPC) Y="@899" 3 S DQ=4 ;@930 < 4 S DW="0;28",DV="SX",DU="",DLB="EXPOSED TO ENVIR CONTA < S DU="Y:YES;N:NO;" < S Y="@" < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X4 S DGFLAG=3 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG < Q < ; < 5 S DQ=6 ;@935 < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 I '$D(DGEXQ(4)) S Y="@940" < Q < 7 S DW="0;29",DV="S",DU="",DLB="WAS TREATMENT RELATED T < S DU="Y:YES;N:NO;" < G RE < X7 Q < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 S Y="@945" < Q < 9 S DQ=10 ;@940 < 10 S DW="0;29",DV="S",DU="",DLB="TREATMENT FOR MST",DIFL < S DU="Y:YES;N:NO;" < S Y="@" < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X10 Q < 11 S DQ=12 ;@945 < X12 I '$D(DGEXQ(5)) S Y="@950" | X12 I '$D(DGBPC(2))!(DGDUP(2)) S Y="@810" 13 S DW="0;30",DV="S",DU="",DLB="WAS TREATMENT RELATED T | 13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="300;2",DV="SX",DU=" S DU="Y:YES;N:NO;" | S DU="1:Attempted Suicide;2:Accomplished Suicide;3:Se X13 Q | X13 S DGFLAG=2 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG Q > Q > ; X14 I X["Y",$D(DFN),$$FILEHNC^DGNTAPI1(DFN) | X14 S:X]"" DGDUP(2)=1 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) | 15 S DQ=16 ;@810 X15 S Y="@955" | 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) > X16 I '$D(DGBPC(3))!(DGDUP(3)) S Y="@820" > Q > 17 S DW="300;3",DV="SX",DU="",DLB="LEGIONNAIRE'S DISEASE > S DU="1:Yes;2:No;" > G RE > X17 S DGFLAG=3 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG Q 16 S DQ=17 ;@950 | ; 17 S DW="0;30",DV="S",DU="",DLB="TREATMENT FOR HEAD/NECK | 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) S DU="Y:YES;N:NO;" | X18 S:X]"" DGDUP(3)=1 S Y="@" | Q S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I | 19 S DQ=20 ;@820 G RD < X17 Q < 18 S DQ=19 ;@955 < 19 S DQ=20 ;@999 < X20 K DGEXQ S Y=DGNFLD | X20 I '$D(DGBPC(4))!(DGDUP(4)) S Y="@830" > Q > 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) > X21 D DRUG^DGPTSC01 I $D(DGTX) S Y="@825" > Q > 22 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE > S DU="DIC(45.61," > G RE > X22 S DGFLAG=4 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG > Q > ; > 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) > X23 S:X]"" DGDUP(4)=1 > Q > 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) > X24 S Y="@830" > Q > 25 S DQ=26 ;@825 > 26 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE > S DU="DIC(45.61," > S X=DGTX > S Y=X > G Y > X26 S DGFLAG=4 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG > Q > ; > 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) > X27 S:X]"" DGDUP(4)=1 > Q > 28 S DQ=29 ;@830 > 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE) > X29 I '$D(DGBPC(5))!(DGDUP(5)) S Y="@840" > Q > 30 S DW="300;5",DV="SX",DU="",DLB="PSYCHIATRY CLASS. SEV > S DU="0:INADEQUATE INFO OR NO CHANGE;1:NONE;2:MILD;3: > G RE > X30 S DGFLAG=5 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG > Q > ; > 31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE) > X31 S:X]"" DGDUP(5)=1 > Q > 32 S DQ=33 ;@840 > 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE) > X33 I '$D(DGBPC(6))!(DGDUP(6)) S Y="@850" 21 G 1^DIE17 | 34 D:$D(DG)>9 F^DIE17 G ^DGPTX55 diff -y --suppress-common-lines ./VADemo/r1/DGPTX55.m ./VADemo/r2/r/DGPTX55.m DGPTX55 ; ;12/28/04 | DGPTX55 ; ;12/10/01 ;; | D DE G BEGIN 1 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K | DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1, I $G(X(1))]"",$G(X(2))]"" D | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,26) S:%]"" DE(12)=%, . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD1") | I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,6) S:%]"" DE(1)= K X M X=X2 I $G(X(1))]"",$G(X(2))]"" D | K %Z Q . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD1") | ; Q | W W !?DL+DL-2,DLB_": " X1(DION) K X | Q S X(1)=$G(@DIEZTMP@("V",45.02,DIIENS,10,DION),$P($G(^ | O D W W Y W:$X>45 !?9 S X(2)=$G(@DIEZTMP@("V",45.02,DIIENS,5,DION),$P($G(^D | I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 S X=$G(X(1)) | W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (N Q | TR R X:DTIME E S (DTOUT,X)=U W $C(7) 2 N X,X1,X2 S DIXR=448 D X2(U) K X2 M X2=X D X2("F") K | Q I $G(X(1))]"",$G(X(2))]"" D | A K DQ(DQ) S DQ=DQ+1 . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD2") | B G @DQ K X M X=X2 I $G(X(1))]"",$G(X(2))]"" D | RE G PR:$D(DE(DQ)) D W,TR . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD2") | N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X Q | RD G QS:X?."?" I X["^" D D G ^DIE17 X2(DION) K X | I X="@" D D G Z^DIE2 S X(1)=$G(@DIEZTMP@("V",45.02,DIIENS,10,DION),$P($G(^ | I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^ S X(2)=$G(@DIEZTMP@("V",45.02,DIIENS,6,DION),$P($G(^D | T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD S X=$G(X(1)) | K DDER G X Q | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ 3 N X,X1,X2 S DIXR=449 D X3(U) K X2 M X2=X D X3("F") K | G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z I $G(X(1))]"",$G(X(2))]"" D | I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5, . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD3") | V D @("X"_DQ) K YS K X M X=X2 I $G(X(1))]"",$G(X(2))]"" D | Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD3") | X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 Q | S X="?BAD" X3(DION) K X | QS S DZ=X D D,QQ^DIEQ G B S X(1)=$G(@DIEZTMP@("V",45.02,DIIENS,10,DION),$P($G(^ | D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ) S X(2)=$G(@DIEZTMP@("V",45.02,DIIENS,7,DION),$P($G(^D | Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" S X=$G(X(1)) | PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP Q | R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D 4 N X,X1,X2 S DIXR=450 D X4(U) K X2 M X2=X D X4("F") K | I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) I $G(X(1))]"",$G(X(2))]"" D | X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":" . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD4") | RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 K X M X=X2 I $G(X(1))]"",$G(X(2))]"" D | I I DV'["I",DV'["#" G RD . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD4") | D E^DIE0 G RD:$D(X),PR Q | Q X4(DION) K X | SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")= S X(1)=$G(@DIEZTMP@("V",45.02,DIIENS,10,DION),$P($G(^ | I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 S X(2)=$G(@DIEZTMP@("V",45.02,DIIENS,8,DION),$P($G(^D | D ^DIR I 'DDER S %=Y(0),X=Y S X=$G(X(1)) | Q Q | SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ 5 N X,X1,X2 S DIXR=451 D X5(U) K X2 M X2=X D X5("F") K | I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/ I $G(X(1))]"",$G(X(2))]"" D | E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD5") | Q K X M X=X2 I $G(X(1))]"",$G(X(2))]"" D | NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD5") | KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") Q | BEGIN S DNM="DGPTX55",DQ=1 X5(DION) K X | 1 S DW="300;6",DV="NJ2,0X",DU="",DLB="CURRENT PSYCH CLA S X(1)=$G(@DIEZTMP@("V",45.02,DIIENS,10,DION),$P($G(^ | G RE S X(2)=$G(@DIEZTMP@("V",45.02,DIIENS,9,DION),$P($G(^D | X1 S DGFLAG=6 D 501^DGPTSC01 S:DGER X="" K DGFLAG,DGER K S X=$G(X(1)) | Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 S:X]"" DGDUP(6)=1 > Q > 3 S DQ=4 ;@850 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 > X4 I '$D(DGBPC(7))!(DGDUP(7)) S Y="@899" > Q > 5 S DW="300;7",DV="NJ2,0X",DU="",DLB="HIGH LEVEL PSYCH > G RE > X5 S DGFLAG=7 D 501^DGPTSC01 S:DGER X="" K DGER,DGFLAG K > Q > ; > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 > X6 S:X]"" DGDUP(7)=1 > Q > 7 S DQ=8 ;@899 > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 > X8 K DGPTIT,DGTX S Y=DGNFLD > Q > 9 S DQ=10 ;@900 > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) > X10 K DGEXQ D CHQUES^DGPTSPQ I '$D(DGEXQ) S Y="@999" > Q > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 I '$D(DGEXQ(1)) S Y="@910" > Q > 12 S DW="0;26",DV="SX",DU="",DLB="TREATED FOR AO CONDITI > S DU="Y:YES;N:NO;" > G RE > X12 S DGFLAG=1 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG > Q > ; > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 S Y="@915" > Q > 14 S DQ=15 ;@910 > 15 S DW="0;26",DV="SX",DU="",DLB="TREATED FOR AO CONDITI > S DU="Y:YES;N:NO;" > S Y="@" > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X15 S DGFLAG=1 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG > Q > ; > 16 S DQ=17 ;@915 > 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) > X17 I '$D(DGEXQ(2)) S Y="@920" > Q > 18 S DW="0;27",DV="SX",DU="",DLB="TREATED FOR IR CONDITI > S DU="Y:YES;N:NO;" > G RE > X18 S DGFLAG=2 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG > Q > ; > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) > X19 S Y="@925" > Q > 20 S DQ=21 ;@920 > 21 S DW="0;27",DV="SX",DU="",DLB="TREATED FOR IR CONDITI > S DU="Y:YES;N:NO;" > S Y="@" > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X21 S DGFLAG=2 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG > Q > ; > 22 S DQ=23 ;@925 > 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) > X23 I '$D(DGEXQ(3)) S Y="@930" > Q > 24 S DW="0;28",DV="SX",DU="",DLB="EXPOSED TO ENVIR CONTA > S DU="Y:YES;N:NO;" > G RE > X24 S DGFLAG=3 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG > Q > ; > 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) > X25 S Y="@935" > Q > 26 S DQ=27 ;@930 > 27 S DW="0;28",DV="SX",DU="",DLB="EXPOSED TO ENVIR CONTA > S DU="Y:YES;N:NO;" > S Y="@" > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X27 S DGFLAG=3 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG > Q > ; > 28 S DQ=29 ;@935 > 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE) > X29 I '$D(DGEXQ(4)) S Y="@940" > Q > 30 S DW="0;29",DV="S",DU="",DLB="TREATMENT FOR MST",DIFL > S DU="Y:YES;N:NO;" > G RE > X30 Q > 31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE) > X31 S Y="@945" > Q > 32 S DQ=33 ;@940 > 33 S DW="0;29",DV="S",DU="",DLB="TREATMENT FOR MST",DIFL > S DU="Y:YES;N:NO;" > S Y="@" > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X33 Q > 34 S DQ=35 ;@945 > 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE) > X35 I '$D(DGEXQ(5)) S Y="@950" > Q > 36 S DW="0;30",DV="S",DU="",DLB="TREATMENT FOR HEAD/NECK > S DU="Y:YES;N:NO;" > G RE > X36 Q > 37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE) > X37 I X["Y",$D(DFN),$$FILEHNC^DGNTAPI1(DFN) > Q > 38 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=38 D X38 D:$D(DIEFIRE) > X38 S Y="@955" > Q > 39 S DQ=40 ;@950 > 40 S DW="0;30",DV="S",DU="",DLB="TREATMENT FOR HEAD/NECK > S DU="Y:YES;N:NO;" > S Y="@" > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X40 Q > 41 S DQ=42 ;@955 > 42 S DQ=43 ;@999 > 43 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=43 D X43 D:$D(DIEFIRE) > X43 K DGEXQ S Y=DGNFLD > 44 G 1^DIE17 Only in ./VADemo/r1/: DGPTX56.m diff -y --suppress-common-lines ./VADemo/r1/DGPTX5.m ./VADemo/r2/r/DGPTX5.m DGPTX5 ; GENERATED FROM 'DG501' INPUT TEMPLATE(#430), FILE 4 | DGPTX5 ; GENERATED FROM 'DG501' INPUT TEMPLATE(#430), FILE 4 S DIFLD=50,DGO="^DGPTX51",DC="36^45.02AI^M^",DV="45.0 | S DIFLD=50,DGO="^DGPTX51",DC="35^45.02AI^M^",DV="45.0 diff -y --suppress-common-lines ./VADemo/r1/DGPTX71.m ./VADemo/r2/r/DGPTX71.m DGPTX71 ; ;12/28/04 | DGPTX71 ; ;10/06/97 S X=DG(DQ),DIC=DIE | D DE G BEGIN X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU | DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,D > I $D(^(70)) S %Z=^(70) S %=$P(%Z,U,19) 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 > D ^DIR I 'DDER S %=Y(0),X=Y > Q > BEGIN S DNM="DGPTX71",DQ=1 > 1 S DW="70;19",DV="*P80'",DU="",DLB="ICD 5",DIFLD=79.19 > S DU="ICD9(" > G RE > X1 S DIC("S")="S DGI=5 D EN3^DGPTFJC I 'DGER" D ^DIC K D > Q > ; > 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 D X3 G A:$D(Y)[0,A:Y > X3 I X K DGPTIT S DGNFLD="@50",Y="@800",DGPTIT(X_$C(59)_ > Q > 4 S DQ=5 ;@50 > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y > X5 S DGNFLD="@55" > Q > 6 S DW="70;20",DV="*P80'",DU="",DLB="ICD 6",DIFLD=79.20 > S DU="ICD9(" > G RE > X6 S DIC("S")="S DGI=6 D EN3^DGPTFJC I 'DGER" D ^DIC K D > Q > ; > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 G A > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y > X8 I X K DGPTIT S DGNFLD="@55",Y="@800",DGPTIT(X_$C(59)_ > Q > 9 S DQ=10 ;@55 > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A > X10 S DGNFLD="@60" > Q > 11 S DW="70;21",DV="*P80'",DU="",DLB="ICD 7",DIFLD=79.21 > S DU="ICD9(" > G RE > X11 S DIC("S")="S DGI=7 D EN3^DGPTFJC I 'DGER" D ^DIC K D > Q > ; > 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 G A > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 G A:$D(Y)[0,A > X13 I X K DGPTIT S DGNFLD="@60",Y="@800",DGPTIT(X_$C(59)_ > Q > 14 S DQ=15 ;@60 > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 G A:$D(Y)[0,A > X15 S DGNFLD="@70" > Q > 16 S DW="70;22",DV="*P80'",DU="",DLB="ICD 8",DIFLD=79.22 > S DU="ICD9(" > G RE > X16 S DIC("S")="S DGI=8 D EN3^DGPTFJC I 'DGER" D ^DIC K D > Q > ; > 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 G A > 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 G A:$D(Y)[0,A > X18 I X K DGPTIT S DGNFLD="@70",Y="@800",DGPTIT(X_$C(59)_ > Q > 19 S DQ=20 ;@70 > 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 G A:$D(Y)[0,A > X20 S DGNFLD="@80" > Q > 21 S DW="70;23",DV="*P80'",DU="",DLB="ICD 9",DIFLD=79.23 > S DU="ICD9(" > G RE > X21 S DIC("S")="S DGI=9 D EN3^DGPTFJC I 'DGER" D ^DIC K D > Q > ; > 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 G A > 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 G A:$D(Y)[0,A > X23 I X K DGPTIT S DGNFLD="@80",Y="@800",DGPTIT(X_$C(59)_ > Q > 24 S DQ=25 ;@80 > 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 G A:$D(Y)[0,A > X25 S DGNFLD="@90" > Q > 26 D:$D(DG)>9 F^DIE17 G ^DGPTX72 diff -y --suppress-common-lines ./VADemo/r1/DGPTX72.m ./VADemo/r2/r/DGPTX72.m DGPTX72 ; ;12/28/04 | DGPTX72 ; ;10/06/97 I $D(^(70)) S %Z=^(70) S %=$P(%Z,U,19) S:%]"" DE(1)=% | I $D(^(70)) S %Z=^(70) S %=$P(%Z,U,24) S:%]"" DE(1)=% > I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,2) S:%]"" DE(10) N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="70;19",DV="*P80'",DU | 1 S DW="70;24",DV="*P80'",DU="",DLB="ICD 10",DIFLD=79.2 S DE(DW)="C1^DGPTX72",DE(DW,"INDEX")=1 < C1 G C1S:$D(DE(1))[0 K DB | X1 S DIC("S")="S DGI=10 D EN3^DGPTFJC I 'DGER" D ^DIC K S X=DE(1),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=437 S DIEZRXR(45,DIXR)="" < Q < X1 S DIC("S")="S DGI=5 D EN3^DGPTFJC I 'DGER" D ^DIC K D < 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y X3 I X K DGPTIT S DGNFLD="@50",Y="@800",DGPTIT(X_$C(59)_ | X3 I X K DGPTIT S DGNFLD="@90",Y="@800",DGPTIT(X_$C(59)_ 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 | 4 S DQ=5 ;@90 X4 S:$P($G(^DGPT(D0,70)),U,19,24)_$P($G(^DGPT(D0,71)),U, | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y > X5 K DGNFLD,DGDUP S Y="" 5 S DQ=6 ;@50 | 6 S DQ=7 ;@800 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y X6 S DGNFLD="@55" | X7 D SCAN^DGPTSCAN,ANYPSY^DGPTSCAN S:'$D(DGBPC) Y="@890" Q | Q 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 G A | 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="70;20",DV="*P80'",DU | X8 I '$D(DGBPC(2))!(DGDUP(2)) S Y="@820" S DE(DW)="C8^DGPTX72",DE(DW,"INDEX")=1 | Q S DU="ICD9(" | 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 G A:$D(Y)[0,A:Y G RE | X9 I $P(DG701,U,2)]"" S Y="@820" C8 G C8S:$D(DE(8))[0 K DB < S X=DE(8),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C8S S X="" G:DG(DQ)=X C8F1 K DB < S X=DG(DQ),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C8F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=438 S DIEZRXR(45,DIXR)="" < X8 S DIC("S")="S DGI=6 D EN3^DGPTFJC I 'DGER" D ^DIC K D | 10 S DW="300;2",DV="SX",DU="",DLB="SUICIDE/SELF INFLICT > S DU="1:Attempted Suicide;2:Accomplished Suicide;3:Se > G RE > X10 S DGFLAG=2 D 701^DGPTSC01 K:DGER X K DGER,DGFLAG 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 | 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 G A:$D(Y)[0,A X9 I X K DGPTIT S DGNFLD="@55",Y="@800",DGPTIT(X_$C(59)_ | X11 S:X]"" DGDUP(2)=1 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) | 12 S DQ=13 ;@820 X10 S:$P($G(^DGPT(D0,70)),U,20,24)_$P($G(^DGPT(D0,71)),U, | 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 G A:$D(Y)[0,A > X13 I '$D(DGBPC(3))!(DGDUP(3)) S Y="@840" 11 S DQ=12 ;@55 | 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 G A:$D(Y)[0,A 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 G A | X14 I $P(DG701,U,3)]"" S Y="@840" 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 S DGNFLD="@60" < 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW="70;21",DV="*P80'",D | 15 S DW="300;3",DV="SX",DU="",DLB="LEGIONNAIRE'S DISEASE S DE(DW)="C14^DGPTX72",DE(DW,"INDEX")=1 | S DU="1:Yes;2:No;" S DU="ICD9(" < C14 G C14S:$D(DE(14))[0 K DB | X15 S DGFLAG=3 D 701^DGPTSC01 K:DGER X K DGER,DGFLAG S X=DE(14),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C14S S X="" G:DG(DQ)=X C14F1 K DB < S X=DG(DQ),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C14F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=439 S DIEZRXR(45,DIXR)="" < Q < X14 S DIC("S")="S DGI=7 D EN3^DGPTFJC I 'DGER" D ^DIC K D < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) | 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 G A:$D(Y)[0,A X15 I X K DGPTIT S DGNFLD="@60",Y="@800",DGPTIT(X_$C(59)_ | X16 S:X]"" DGDUP(3)=1 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) | 17 S DQ=18 ;@840 X16 S:$P($G(^DGPT(D0,70)),U,21,24)_$P($G(^DGPT(D0,71)),U, | 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 G A:$D(Y)[0,A > X18 I '$D(DGBPC(4))!(DGDUP(4)) S Y="@860" 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 G A | 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 G A:$D(Y)[0,A 18 S DQ=19 ;@60 | X19 I $P(DG701,U,4)]"" S Y="@860" 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 S DGNFLD="@70" < 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="70;22",DV="*P80'",D | 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 G A:$D(Y)[0,A S DE(DW)="C20^DGPTX72",DE(DW,"INDEX")=1 | X20 D DRUG^DGPTSC01 I $D(DGTX) S Y="@850" S DU="ICD9(" < G RE < C20 G C20S:$D(DE(20))[0 K DB < S X=DE(20),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C20S S X="" G:DG(DQ)=X C20F1 K DB < S X=DG(DQ),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C20F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=440 S DIEZRXR(45,DIXR)="" < X20 S DIC("S")="S DGI=8 D EN3^DGPTFJC I 'DGER" D ^DIC K D | 21 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE > S DU="DIC(45.61," > G RE > X21 S DGFLAG=4 D 701^DGPTSC01 K:DGER X K DGFLAG,DGER 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) | 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 G A:$D(Y)[0,A X21 I X K DGPTIT S DGNFLD="@70",Y="@800",DGPTIT(X_$C(59)_ | X22 S:X]"" DGDUP(4)=1 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 G A | 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 G A:$D(Y)[0,A 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) | X23 S Y="@860" X23 S:$P($G(^DGPT(D0,70)),U,22,24)_$P($G(^DGPT(D0,71)),U, < Q < 24 S DQ=25 ;@70 < 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) < X25 S DGNFLD="@80" < 26 D:$D(DG)>9 F^DIE17 G ^DGPTX73 | 24 S DQ=25 ;@850 > 25 D:$D(DG)>9 F^DIE17 G ^DGPTX73 diff -y --suppress-common-lines ./VADemo/r1/DGPTX73.m ./VADemo/r2/r/DGPTX73.m DGPTX73 ; ;12/28/04 | DGPTX73 ; ;10/06/97 I $D(^(70)) S %Z=^(70) S %=$P(%Z,U,23) S:%]"" DE(1)=% | I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,4) S:%]"" DE(1)= I $D(^(71)) S %Z=^(71) S %=$P(%Z,U,1) S:%]"" DE(11)=% < N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="70;23",DV="*P80'",DU | 1 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE S DE(DW)="C1^DGPTX73",DE(DW,"INDEX")=1 | S DU="DIC(45.61," S DU="ICD9(" | S X=DGTX G RE | S Y=X C1 G C1S:$D(DE(1))[0 K DB | G Y S X=DE(1),DIC=DIE | X1 S DGFLAG=4 D 701^DGPTSC01 K:DGER X K DGFLAG,DGER X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU | Q C1S S X="" G:DG(DQ)=X C1F1 K DB | ; S X=DG(DQ),DIC=DIE | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU | X2 S:X]"" DGDUP(4)=1 C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE | Q F DIXR=441 S DIEZRXR(45,DIXR)="" | 3 S DQ=4 ;@860 Q | 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y X1 S DIC("S")="S DGI=9 D EN3^DGPTFJC I 'DGER" D ^DIC K D | X4 I '$D(DGBPC(5))!(DGDUP(5)) S Y="@870" Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 I X K DGPTIT S DGNFLD="@80",Y="@800",DGPTIT(X_$C(59)_ < 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y X3 S:$P($G(^DGPT(D0,70)),U,23,24)_$P($G(^DGPT(D0,71)),U, | X5 I $P(DG701,U,5)]"" S Y="@870" 4 S DQ=5 ;@80 | 6 S DW="300;5",DV="SX",DU="",DLB="PSYCHIATRY CLASS. SEV 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 | S DU="0:INADEQUATE INFORMATION OR NO CHANGE IN CONDIT X5 S DGNFLD="@90" < Q < 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="70;24",DV="*P80'",DU < S DE(DW)="C6^DGPTX73",DE(DW,"INDEX")=1 < S DU="ICD9(" < C6 G C6S:$D(DE(6))[0 K DB | X6 S DGFLAG=5 D 701^DGPTSC01 K:DGER X K DGFLAG,DGER S X=DE(6),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C6S S X="" G:DG(DQ)=X C6F1 K DB < S X=DG(DQ),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C6F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=442 S DIEZRXR(45,DIXR)="" < Q < X6 S DIC("S")="S DGI=10 D EN3^DGPTFJC I 'DGER" D ^DIC K < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y X7 I X K DGPTIT S DGNFLD="@90",Y="@800",DGPTIT(X_$C(59)_ | X7 S:X]"" DGDUP(5)=1 Q < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 S:$P($G(^DGPT(D0,70)),U,24)_$P($G(^DGPT(D0,71)),U,1,3 < 9 S DQ=10 ;@90 | 8 S DQ=9 ;@870 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) | 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 G A:$D(Y)[0,A:Y X10 S DGNFLD="@100" | X9 I '$D(DGBPC(6))!(DGDUP(6)) S Y="@880" Q < 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="71;1",DV="*P80'",DU < S DE(DW)="C11^DGPTX73",DE(DW,"INDEX")=1 < S DU="ICD9(" < G RE < C11 G C11S:$D(DE(11))[0 K DB < C11S S X="" G:DG(DQ)=X C11F1 K DB < C11F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=443 S DIEZRXR(45,DIXR)="" < X11 S DIC("S")="S DGI=11 D EN3^DGPTFJC I 'DGER" D ^DIC K | 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A > X10 I $P(DG701,U,6)]"" S Y="@880" ; | 11 S DW="300;6",DV="NJ2,0X",DU="",DLB="CURRENT FUNCTIONA 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 I X K DGPTIT S DGNFLD="@100",Y="@800",DGPTIT(X_$C(59) < Q < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 S:$P($G(^DGPT(D0,71)),U,1,3)?."^" Y="@120" < Q < 14 S DQ=15 ;@100 < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 S DGNFLD="@110" < Q < 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="71;2",DV="*P80'",DU < S DE(DW)="C16^DGPTX73",DE(DW,"INDEX")=1 < S DU="ICD9(" < C16 G C16S:$D(DE(16))[0 K DB | X11 S DGFLAG=6 D 701^DGPTSC01 S:DGER X="" K DGER,DGFLAG K C16S S X="" G:DG(DQ)=X C16F1 K DB < C16F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=444 S DIEZRXR(45,DIXR)="" < Q < X16 S DIC("S")="S DGI=12 D EN3^DGPTFJC I 'DGER" D ^DIC K < 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) | 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 G A:$D(Y)[0,A X17 I X K DGPTIT S DGNFLD="@110",Y="@800",DGPTIT(X_$C(59) | X12 S:X]"" DGDUP(6)=1 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) | 13 S DQ=14 ;@880 X18 S:$P($G(^DGPT(D0,71)),U,2,3)?."^" Y="@120" | 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 G A:$D(Y)[0,A > X14 I '$D(DGBPC(7))!(DGDUP(7)) S Y="@890" 19 S DQ=20 ;@110 | 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 G A:$D(Y)[0,A 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) | X15 I $P(DG701,U,7)]"" S Y="@890" X20 S DGNFLD="@120" < Q < 21 D:$D(DG)>9 F^DIE17,DE S DQ=21,DW="71;3",DV="*P80'",DU < S DE(DW)="C21^DGPTX73",DE(DW,"INDEX")=1 < S DU="ICD9(" < G RE < C21 G C21S:$D(DE(21))[0 K DB < C21S S X="" G:DG(DQ)=X C21F1 K DB < C21F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=445 S DIEZRXR(45,DIXR)="" < X21 S DIC("S")="S DGI=13 D EN3^DGPTFJC I 'DGER" D ^DIC K | 16 S DW="300;7",DV="NJ2,0X",DU="",DLB="HIGH LEVEL PSYCH > G RE > X16 S DGFLAG=7 D 701^DGPTSC01 S:DGER X="" K DGER,DGFLAG K 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) | 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 G A:$D(Y)[0,A X22 I X K DGPTIT S DGNFLD="@120",Y="@800",DGPTIT(X_$C(59) | X17 S:X]"" DGDUP(7)=1 Q < 23 S DQ=24 ;@120 < 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) < X24 K DGNFLD,DGDUP S Y="" < Q < 25 S DQ=26 ;@800 < 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) < X26 D SCAN^DGPTSCAN,ANYPSY^DGPTSCAN S:'$D(DGBPC) Y="@890" < Q < 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) < X27 I '$D(DGBPC(2))!(DGDUP(2)) S Y="@820" < 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) | 18 S DQ=19 ;@890 X28 I $P(DG701,U,2)]"" S Y="@820" | 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 G A:$D(Y)[0,A > X19 K DGII,DGPTIT S Y=DGNFLD 29 D:$D(DG)>9 F^DIE17 G ^DGPTX74 | 20 G 0^DIE17 Only in ./VADemo/r1/: DGPTX74.m Only in ./VADemo/r1/: DGPTX75.m Only in ./VADemo/r1/: DGPTX76.m Only in ./VADemo/r1/: DGPTX77.m diff -y --suppress-common-lines ./VADemo/r1/DGPTX7.m ./VADemo/r2/r/DGPTX7.m DGPTX7 ; GENERATED FROM 'DG701' INPUT TEMPLATE(#432), FILE 4 | DGPTX7 ; GENERATED FROM 'DG701' INPUT TEMPLATE(#432), FILE 4 I $D(^(70)) S %Z=^(70) S %=$P(%Z,U,10) S:%]"" DE(4)=% | I $D(^(70)) S %Z=^(70) S %=$P(%Z,U,10) S:%]"" DE(4)=% N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=432,U="^" M DIEZAR=^DIE(432,"AR") S DICRREC="TRIG^DIE17" | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=43 < 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y 4 S DW="70;10",DV="*P80'",DU="",DLB="PRINCIPAL DIAGNOSI | 4 S DW="70;10",DV="*P80'",DU="",DLB="DXLS",DIFLD=79 S DE(DW)="C4^DGPTX7",DE(DW,"INDEX")=1 < C4 G C4S:$D(DE(4))[0 K DB < S X=DE(4),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C4S S X="" G:DG(DQ)=X C4F1 K DB < S X=DG(DQ),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C4F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=432 S DIEZRXR(45,DIXR)="" < Q < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 | 6 S DQ=7 ;@10 X6 S:$P($G(^DGPT(D0,70)),U,10)_$P($G(^DGPT(D0,70)),U,16, < Q < 8 S DQ=9 ;@10 | 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 | X8 S DGNFLD="@20" X9 S DGNFLD="@20" < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 G A | 9 S DW="70;16",DV="*P80'",DU="",DLB="ICD 2",DIFLD=79.16 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="70;16",DV="*P80'",D < S DE(DW)="C11^DGPTX7",DE(DW,"INDEX")=1 < C11 G C11S:$D(DE(11))[0 K DB | X9 S DIC("S")="S DGI=2 D EN3^DGPTFJC I 'DGER" D ^DIC K D S X=DE(11),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C11S S X="" G:DG(DQ)=X C11F1 K DB < S X=DG(DQ),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C11F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=434 S DIEZRXR(45,DIXR)="" < Q < X11 S DIC("S")="S DGI=2 D EN3^DGPTFJC I 'DGER" D ^DIC K D < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) | 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 G A X12 I X K DGPTIT S DGNFLD="@20",Y="@800",DGPTIT(X_$C(59)_ | 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 G A:$D(Y)[0,A Q | X11 I X K DGPTIT S DGNFLD="@20",Y="@800",DGPTIT(X_$C(59)_ 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 S:$P($G(^DGPT(D0,70)),U,16,24)_$P($G(^DGPT(D0,71)),U, < 14 S DQ=15 ;@20 | 12 S DQ=13 ;@20 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 G A | 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 G A:$D(Y)[0,A 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) | X13 S DGNFLD="@30" X16 S DGNFLD="@30" < 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="70;17",DV="*P80'",D | 14 S DW="70;17",DV="*P80'",DU="",DLB="ICD 3",DIFLD=79.17 S DE(DW)="C17^DGPTX7",DE(DW,"INDEX")=1 < C17 G C17S:$D(DE(17))[0 K DB | X14 S DIC("S")="S DGI=3 D EN3^DGPTFJC I 'DGER" D ^DIC K D S X=DE(17),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C17S S X="" G:DG(DQ)=X C17F1 K DB < S X=DG(DQ),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C17F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=435 S DIEZRXR(45,DIXR)="" < Q < X17 S DIC("S")="S DGI=3 D EN3^DGPTFJC I 'DGER" D ^DIC K D < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) | 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 G A X18 I X K DGPTIT S DGNFLD="@30",Y="@800",DGPTIT(X_$C(59)_ | 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 G A:$D(Y)[0,A > X16 I X K DGPTIT S DGNFLD="@30",Y="@800",DGPTIT(X_$C(59)_ 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) | 17 S DQ=18 ;@30 X19 S:$P($G(^DGPT(D0,70)),U,17,24)_$P($G(^DGPT(D0,71)),U, | 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 G A:$D(Y)[0,A > X18 S DGNFLD="@40" 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 G A | 19 S DW="70;18",DV="*P80'",DU="",DLB="ICD 4",DIFLD=79.18 21 S DQ=22 ;@30 < 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) < X22 S DGNFLD="@40" < Q < 23 D:$D(DG)>9 F^DIE17,DE S DQ=23,DW="70;18",DV="*P80'",D < S DE(DW)="C23^DGPTX7",DE(DW,"INDEX")=1 < C23 G C23S:$D(DE(23))[0 K DB | X19 S DIC("S")="S DGI=4 D EN3^DGPTFJC I 'DGER" D ^DIC K D S X=DE(23),DIC=DIE < X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRU < C23S S X="" G:DG(DQ)=X C23F1 K DB < D ^DGPTX71 < C23F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=436 S DIEZRXR(45,DIXR)="" < Q < X23 S DIC("S")="S DGI=4 D EN3^DGPTFJC I 'DGER" D ^DIC K D < 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) | 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 G A X24 I X K DGPTIT S DGNFLD="@40",Y="@800",DGPTIT(X_$C(59)_ | 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 G A:$D(Y)[0,A > X21 I X K DGPTIT S DGNFLD="@40",Y="@800",DGPTIT(X_$C(59)_ 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 G A | 22 S DQ=23 ;@40 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) | 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 G A:$D(Y)[0,A X26 S:$P($G(^DGPT(D0,70)),U,18,24)_$P($G(^DGPT(D0,71)),U, | X23 S DGNFLD="@50" Q < 27 S DQ=28 ;@40 < 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) < X28 S DGNFLD="@50" < 29 D:$D(DG)>9 F^DIE17 G ^DGPTX72 | 24 D:$D(DG)>9 F^DIE17 G ^DGPTX71 Only in ./VADemo/r1/: DGPTX81.m Only in ./VADemo/r1/: DGPTX8.m diff -y --suppress-common-lines ./VADemo/r1/DGPTXC1.m ./VADemo/r2/r/DGPTXC1.m DGPTXC1 ; ;12/28/04 | DGPTXC1 ; ;06/13/96 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD | T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")= | SET I X'?.ANP S DDER=1 Q > N DIR S DIR(0)="SMV^"_DU,DIR("V")=1 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < Only in ./VADemo/r1/: DGPTXC2.m Only in ./VADemo/r1/: DGPTXC3.m diff -y --suppress-common-lines ./VADemo/r1/DGPTXC.m ./VADemo/r2/r/DGPTXC.m DGPTXC ; GENERATED FROM 'DG PTF CREATE PTF ENTRY' INPUT TEMP | DGPTXC ; GENERATED FROM 'DG PTF CREATE PTF ENTRY' INPUT TEMP N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD | T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")= | SET I X'?.ANP S DDER=1 Q > N DIR S DIR(0)="SMV^"_DU,DIR("V")=1 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=443,U="^" M DIEZAR=^DIE(443,"AR") S DICRREC="TRIG^DIE17" < S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=44 < S DE(DW)="C1^DGPTXC",DE(DW,"INDEX")=1 | S DE(DW)="C1^DGPTXC" S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I G RD:X="@",Z | G Z C1 G C1S:$D(DE(1))[0 K DB | C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE S X=DE(1),DIC=DIE < 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 X=DG(DQ),DIC=DIE < C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=432,433,434,435,436,437,438,439,440,441,442,44 < S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I G RD:X="@",Z | G Z C2 G C2S:$D(DE(2))[0 K DB | C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE S X=DE(2),DIC=DIE < 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 X=DG(DQ),DIC=DIE < C2F1 Q | Q S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I G RD:X="@",Z | G Z C3 G C3S:$D(DE(3))[0 K DB | C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE S X=DE(3),DIC=DIE < C3S S X="" G:DG(DQ)=X C3F1 K DB | C3S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S X=DG(DQ),DIC=DIE < C3F1 Q | Q S DIFLD=50,DGO="^DGPTXC1",DC="36^45.02AI^M^",DV="45.0 | S DIFLD=50,DGO="^DGPTXC1",DC="33^45.02AI^M^",DV="45.0 S DE(DW)="C5^DGPTXC",DE(DW,"INDEX")=1 < S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I G RD:X="@",Z | G Z C5 G C5S:$D(DE(5))[0 K DB < C5S S X="" G:DG(DQ)=X C5F1 K DB < C5F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE < F DIXR=432,433,434,435,436,437,438,439,440,441,442,44 < Q < diff -y --suppress-common-lines ./VADemo/r1/DGPTXX10.m ./VADemo/r2/r/DGPTXX10.m DGPTXX10 ; COMPILED XREF FOR FILE #45.01 ; 12/28/04 | DGPTXX10 ; COMPILED XREF FOR FILE #45.0535 ; 12/09/02 S DA(1)=DA S DA=0 | S DA=0 A S DA=$O(^DGPT(DA(1),"S",DA)) I DA'>0 S DA=0 G END | A S DA=$O(^DGPT(DA(1),535,DA)) I DA'>0 S DA=0 G END S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) | S DIKZ(0)=$G(^DGPT(DA(1),535,DA,0)) S X=$P(DIKZ(0),U,8) | S X=$P(DIKZ(0),U,2) I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" | I X'="" D S X=$P(DIKZ(0),U,9) | .N DIK,DIV,DIU,DIN I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" | .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y > S X=$P(DIKZ(0),U,7) > I X'="" S ^DGPT(DA(1),535,"ADC",$E(X,1,30),DA)="" I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" | I X'="" S ^DGPT(DA(1),535,"AM",$E(X,1,30),DA)="" S X=$P(DIKZ(0),U,11) < I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" < S X=$P(DIKZ(0),U,12) < I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" < CR1 S DIXR=422 < K X < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,8) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT0^DGPTDDCR(.X,.DA,"S",1) < CR2 S DIXR=423 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,9) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT0^DGPTDDCR(.X,.DA,"S",2) < CR3 S DIXR=424 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,10) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT0^DGPTDDCR(.X,.DA,"S",3) < CR4 S DIXR=425 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,11) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT0^DGPTDDCR(.X,.DA,"S",4) < CR5 S DIXR=426 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,12) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT0^DGPTDDCR(.X,.DA,"S",5) < CR6 K X < END G ^DGPTXX11 | END Q Only in ./VADemo/r1/: DGPTXX11.m Only in ./VADemo/r1/: DGPTXX12.m Only in ./VADemo/r1/: DGPTXX13.m Only in ./VADemo/r1/: DGPTXX14.m diff -y --suppress-common-lines ./VADemo/r1/DGPTXX1.m ./VADemo/r2/r/DGPTXX1.m DGPTXX1 ; COMPILED XREF FOR FILE #45 ; 12/28/04 | DGPTXX1 ; COMPILED XREF FOR FILE #45 ; 12/09/02 S DIKZ(0)=$G(^DGPT(DA,0)) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPT(D0, | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPT(D0, S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(70)=$G(^DGPT(DA,70)) < S DIKZ(0)=$G(^DGPT(DA,0)) < CR1 S DIXR=432 < K X < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,10) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"DXLS") < CR2 S DIXR=433 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,11) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"PDX") < CR3 S DIXR=434 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,16) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD1") < CR4 S DIXR=435 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,17) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD2") < CR5 S DIXR=436 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,18) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD3") < CR6 S DIXR=437 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,19) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD4") < CR7 S DIXR=438 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,20) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD5") < CR8 S DIXR=439 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,21) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD6") < CR9 S DIXR=440 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,22) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD7") < CR10 S DIXR=441 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,23) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD8") < CR11 S DIXR=442 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,24) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD9") < CR12 S DIXR=443 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(71)=$G(^DGPT(DA,71)) < S X(4)=$P(DIKZ(71),U,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < diff -y --suppress-common-lines ./VADemo/r1/DGPTXX2.m ./VADemo/r2/r/DGPTXX2.m DGPTXX2 ; COMPILED XREF FOR FILE #45 ; 12/28/04 | DGPTXX2 ; COMPILED XREF FOR FILE #45.01 ; 12/09/02 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D | S DA(1)=DA S DA=0 . K X1,X2 M X1=X,X2=X | A1 ; . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" | I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD10") | 0 ; CR13 S DIXR=444 | A S DA=$O(^DGPT(DA(1),"S",DA)) I DA'>0 S DA=0 G END K X | 1 ; S DIKZ(0)=$G(^DGPT(DA,0)) | S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) S X(1)=$P(DIKZ(0),U,1) | S X=$P(DIKZ(0),U,8) S X(2)=$P(DIKZ(0),U,2) | I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) S X(3)=$P(DIKZ(0),U,11) | S X=$P(DIKZ(0),U,9) S DIKZ(71)=$G(^DGPT(DA,71)) | I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) S X(4)=$P(DIKZ(71),U,2) | S X=$P(DIKZ(0),U,10) S DIKZ(70)=$G(^DGPT(DA,70)) | I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) S X(5)=$P(DIKZ(70),U,1) | S X=$P(DIKZ(0),U,11) S X=$G(X(1)) | I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D | S X=$P(DIKZ(0),U,12) . K X1,X2 M X1=X,X2=X | I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" | G:'$D(DIKLM) A Q:$D(DIKILL) . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD11") < CR14 S DIXR=445 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(71)=$G(^DGPT(DA,71)) < S X(4)=$P(DIKZ(71),U,3) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD12") < CR15 S DIXR=446 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(71)=$G(^DGPT(DA,71)) < S X(4)=$P(DIKZ(71),U,4) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))="" < . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD13") < CR16 K X < diff -y --suppress-common-lines ./VADemo/r1/DGPTXX3.m ./VADemo/r2/r/DGPTXX3.m DGPTXX3 ; COMPILED XREF FOR FILE #45.01 ; 12/28/04 | DGPTXX3 ; COMPILED XREF FOR FILE #45.02 ; 12/09/02 S DA(1)=DA S DA=0 | S DA=0 A S DA=$O(^DGPT(DA(1),"S",DA)) I DA'>0 S DA=0 G END | A S DA=$O(^DGPT(DA(1),"M",DA)) I DA'>0 S DA=0 G END S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) | S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) > S X=$P(DIKZ(0),U,2) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y > S X=$P(DIKZ(0),U,5) > I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > S X=$P(DIKZ(0),U,5) > I X'="" X ^DD(45.02,5,1,992,2) > S X=$P(DIKZ(0),U,6) > I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > S X=$P(DIKZ(0),U,6) > I X'="" X ^DD(45.02,6,1,992,2) > S X=$P(DIKZ(0),U,7) > I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > S X=$P(DIKZ(0),U,7) > I X'="" X ^DD(45.02,7,1,992,2) I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) | I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > S X=$P(DIKZ(0),U,8) > I X'="" X ^DD(45.02,8,1,992,2) > S X=$P(DIKZ(0),U,9) > I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) | I X'="" X ^DD(45.02,9,1,992,2) I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) | I X'="" K ^DGPT(DA(1),"M","AM",$E(X,1,30),DA) I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) | I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > S X=$P(DIKZ(0),U,11) > I X'="" X ^DD(45.02,11,1,992,2) > S X=$P(DIKZ(0),U,12) > I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA) | I X'="" X ^DD(45.02,12,1,992,2) CR1 S DIXR=422 | S X=$P(DIKZ(0),U,13) K X | I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) S X(1)=$P(DIKZ(0),U,1) | S X=$P(DIKZ(0),U,13) S X(2)=$P(DIKZ(0),U,8) | I X'="" X ^DD(45.02,13,1,992,2) S X=$G(X(1)) | S X=$P(DIKZ(0),U,14) I $G(X(1))]"",$G(X(2))]"" D | I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) . K X1,X2 M X1=X,X2=X | S X=$P(DIKZ(0),U,14) . S:$D(DIKIL) (X2,X2(1),X2(2))="" | I X'="" X ^DD(45.02,14,1,992,2) . D KDGPT0^DGPTDDCR(.X,.DA,"S",1) | S X=$P(DIKZ(0),U,15) CR2 S DIXR=423 | I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) K X | S X=$P(DIKZ(0),U,15) S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) | I X'="" X ^DD(45.02,15,1,992,2) S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,9) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"S",2) < CR3 S DIXR=424 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,10) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"S",3) < CR4 S DIXR=425 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,11) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"S",4) < CR5 S DIXR=426 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,12) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"S",5) < CR6 K X < diff -y --suppress-common-lines ./VADemo/r1/DGPTXX4.m ./VADemo/r2/r/DGPTXX4.m DGPTXX4 ; COMPILED XREF FOR FILE #45.02 ; 12/28/04 | DGPTXX4 ; COMPILED XREF FOR FILE #45.05 ; 12/09/02 A S DA=$O(^DGPT(DA(1),"M",DA)) I DA'>0 S DA=0 G END | A S DA=$O(^DGPT(DA(1),"P",DA)) I DA'>0 S DA=0 G END S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) | S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0)) S X=$P(DIKZ(0),U,2) | S X=$P(DIKZ(0),U,3) .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y | .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) | I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) S X=$P(DIKZ(0),U,5) < I X'="" X ^DD(45.02,5,1,992,2) < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X=$P(DIKZ(0),U,6) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < I X'="" X ^DD(45.02,6,1,992,2) | I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X=$P(DIKZ(0),U,7) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < I X'="" X ^DD(45.02,7,1,992,2) | I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) | I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) S X=$P(DIKZ(0),U,8) < I X'="" X ^DD(45.02,8,1,992,2) < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X=$P(DIKZ(0),U,9) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < I X'="" X ^DD(45.02,9,1,992,2) | I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X=$P(DIKZ(0),U,10) < I X'="" K ^DGPT(DA(1),"M","AM",$E(X,1,30),DA) < S X=$P(DIKZ(0),U,11) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=$P(DIKZ(0),U,11) < I X'="" X ^DD(45.02,11,1,992,2) < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X=$P(DIKZ(0),U,12) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=$P(DIKZ(0),U,12) < I X'="" X ^DD(45.02,12,1,992,2) < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X=$P(DIKZ(0),U,13) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=$P(DIKZ(0),U,13) < I X'="" X ^DD(45.02,13,1,992,2) < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X=$P(DIKZ(0),U,14) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=$P(DIKZ(0),U,14) < I X'="" X ^DD(45.02,14,1,992,2) < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X=$P(DIKZ(0),U,15) < I X'="" K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=$P(DIKZ(0),U,15) < I X'="" X ^DD(45.02,15,1,992,2) < CR1 S DIXR=447 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,5) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD1") < CR2 S DIXR=448 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,6) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD2") < CR3 S DIXR=449 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,7) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD3") < CR4 S DIXR=450 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,8) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD4") < CR5 S DIXR=451 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,9) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD5") < CR6 S DIXR=452 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,11) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD6") < CR7 S DIXR=453 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,12) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD7") < CR8 S DIXR=454 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,13) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD8") < CR9 S DIXR=455 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,14) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD9") < CR10 S DIXR=456 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) < S X(1)=$P(DIKZ(0),U,10) < S X(2)=$P(DIKZ(0),U,15) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD10") < CR11 K X < diff -y --suppress-common-lines ./VADemo/r1/DGPTXX5.m ./VADemo/r2/r/DGPTXX5.m DGPTXX5 ; COMPILED XREF FOR FILE #45.05 ; 12/28/04 | DGPTXX5 ; COMPILED XREF FOR FILE #45.0535 ; 12/09/02 A S DA=$O(^DGPT(DA(1),"P",DA)) I DA'>0 S DA=0 G END | A S DA=$O(^DGPT(DA(1),535,DA)) I DA'>0 S DA=0 G END S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0)) | S DIKZ(0)=$G(^DGPT(DA(1),535,DA,0)) S X=$P(DIKZ(0),U,3) | S X=$P(DIKZ(0),U,2) .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y | .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0)) < S X=$P(DIKZ(0),U,5) < I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) < S X=$P(DIKZ(0),U,6) < I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) < I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) | I X'="" K ^DGPT(DA(1),535,"ADC",$E(X,1,30),DA) S X=$P(DIKZ(0),U,8) | S X=$P(DIKZ(0),U,10) I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) | I X'="" K ^DGPT(DA(1),535,"AM",$E(X,1,30),DA) S X=$P(DIKZ(0),U,9) < I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA) < CR1 S DIXR=427 < K X < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,5) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"P",1) < CR2 S DIXR=428 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,6) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"P",2) < CR3 S DIXR=429 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,7) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"P",3) < CR4 S DIXR=430 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,8) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"P",4) < CR5 S DIXR=431 < K X < S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,9) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"" D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < . D KDGPT0^DGPTDDCR(.X,.DA,"P",5) < CR6 K X < END G ^DGPTXX6 | END Q diff -y --suppress-common-lines ./VADemo/r1/DGPTXX6.m ./VADemo/r2/r/DGPTXX6.m DGPTXX6 ; COMPILED XREF FOR FILE #45.0535 ; 12/28/04 | DGPTXX6 ; COMPILED XREF FOR FILE #45 ; 12/09/02 S DA=0 | S DIKZK=1 A1 ; | S DIKZ(0)=$G(^DGPT(DA,0)) I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | S X=$P(DIKZ(0),U,1) 0 ; | I X'="" S ^DGPT("B",$E(X,1,30),DA)="" A S DA=$O(^DGPT(DA(1),535,DA)) I DA'>0 S DA=0 G END < 1 ; < S DIKZ(0)=$G(^DGPT(DA(1),535,DA,0)) < > I X'="" S L=+^DGPT(DA,0) I L>0 S ^DGPT("AAD",L,X,DA)= > S X=$P(DIKZ(0),U,2) > I X'="" S ^DGPT("AF",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,2) > I X'="" S L=$S($D(^DGPT(DA,70)):+^(70),1:0) I L'?7N.E > S X=$P(DIKZ(0),U,2) > I X'="" I $P(^DGPT(DA,0),U,4),$P(^(0),U) S ^DGPT("AFE > S X=$P(DIKZ(0),U,4) > I X'="" I $P(^DGPT(DA,0),U),$P(^(0),U,2) S ^DGPT("AFE > S X=$P(DIKZ(0),U,6) > I X'="" S ^DGPT("AS",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,10) > I X'="" S ^DGPT("AMT",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,12) > I X'="" S ^DGPT("ACENSUS",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,13) .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPT(D0, S DIKZ(0)=$G(^DGPT(DA(1),535,DA,0)) | S DIKZ(101)=$G(^DGPT(DA,101)) S X=$P(DIKZ(0),U,7) | S X=$P(DIKZ(101),U,4) I X'="" K ^DGPT(DA(1),535,"ADC",$E(X,1,30),DA) | I X'="" S %=+^DGPT(DA,0) I %>0 S %C=$S($D(^DPT(%,.3)) S X=$P(DIKZ(0),U,10) | S DIKZ("401P")=$G(^DGPT(DA,"401P")) I X'="" K ^DGPT(DA(1),535,"AM",$E(X,1,30),DA) | S X=$P(DIKZ("401P"),U,1) G:'$D(DIKLM) A Q:$D(DIKILL) | I X'="" S ^DGPT(DA,"AP",X)="" > S X=$P(DIKZ("401P"),U,2) > I X'="" S ^DGPT(DA,"AP",X)="" > S X=$P(DIKZ("401P"),U,3) > I X'="" S ^DGPT(DA,"AP",X)="" > S X=$P(DIKZ("401P"),U,4) > I X'="" S ^DGPT(DA,"AP",X)="" > S X=$P(DIKZ("401P"),U,5) > I X'="" S ^DGPT(DA,"AP",X)="" > S DIKZ(70)=$G(^DGPT(DA,70)) > S X=$P(DIKZ(70),U,1) > I X'="" S ^DGPT("ADS",$E(X,1,30),DA)="" > S X=$P(DIKZ(70),U,1) > I X'="" S %=$S($D(^DGPT(DA,"M",1,0)):^(0),1:""),%D=+$ > S X=$P(DIKZ(70),U,1) > I X'="" S L=$P(^DGPT(DA,0),"^",2) I L?7N.E K ^DGPT("A > S X=$P(DIKZ(70),U,2) > I X'="" I $D(^DGPT(DA,"M",1,0)) S $P(^(0),U,2)=X,$P(^ > S X=$P(DIKZ(70),U,10) > I X'="" X ^DD(45,79,1,992,1) > S X=$P(DIKZ(70),U,16) > I X'="" X ^DD(45,79.16,1,992,1) > S X=$P(DIKZ(70),U,17) > I X'="" X ^DD(45,79.17,1,992,1) > S X=$P(DIKZ(70),U,18) > I X'="" X ^DD(45,79.18,1,992,1) > S X=$P(DIKZ(70),U,19) > I X'="" X ^DD(45,79.19,1,992,1) > S X=$P(DIKZ(70),U,20) > I X'="" X ^DD(45,79.201,1,992,1) > S X=$P(DIKZ(70),U,21) > I X'="" X ^DD(45,79.21,1,992,1) > S X=$P(DIKZ(70),U,22) > I X'="" X ^DD(45,79.22,1,992,1) > S X=$P(DIKZ(70),U,23) > I X'="" X ^DD(45,79.23,1,992,1) > S X=$P(DIKZ(70),U,24) > I X'="" X ^DD(45,79.24,1,992,1) > S X=$P(DIKZ(70),U,11) > I X'="" X ^DD(45,80,1,992,1) diff -y --suppress-common-lines ./VADemo/r1/DGPTXX7.m ./VADemo/r2/r/DGPTXX7.m DGPTXX7 ; COMPILED XREF FOR FILE #45.06 ; 12/28/04 | DGPTXX7 ; COMPILED XREF FOR FILE #45.01 ; 12/09/02 S DA=0 | S DA(1)=DA S DA=0 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 A S DA=$O(^DGPT(DA(1),"C",DA)) I DA'>0 S DA=0 G END | A S DA=$O(^DGPT(DA(1),"S",DA)) I DA'>0 S DA=0 G END S DIKZ(0)=$G(^DGPT(DA(1),"C",DA,0)) | S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0)) S X=$P(DIKZ(0),U,1) | S X=$P(DIKZ(0),U,8) I X'="" K ^DGPT(DA(1),"C","B",$E(X,1,30),DA) | I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" G:'$D(DIKLM) A Q:$D(DIKILL) | S X=$P(DIKZ(0),U,9) END Q | I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,10) > I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,11) > I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,12) > I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)="" > G:'$D(DIKLM) A Q:$D(DISET) > END G ^DGPTXX8 diff -y --suppress-common-lines ./VADemo/r1/DGPTXX8.m ./VADemo/r2/r/DGPTXX8.m DGPTXX8 ; COMPILED XREF FOR FILE #45 ; 12/28/04 | DGPTXX8 ; COMPILED XREF FOR FILE #45.02 ; 12/09/02 S DIKZK=1 | S DA=0 S DIKZ(0)=$G(^DGPT(DA,0)) | A1 ; S X=$P(DIKZ(0),U,1) | I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 I X'="" S ^DGPT("B",$E(X,1,30),DA)="" | 0 ; > A S DA=$O(^DGPT(DA(1),"M",DA)) I DA'>0 S DA=0 G END > 1 ; > S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0)) I X'="" S L=+^DGPT(DA,0) I L>0 S ^DGPT("AAD",L,X,DA)= | I X'="" D S X=$P(DIKZ(0),U,2) | .N DIK,DIV,DIU,DIN I X'="" S ^DGPT("AF",$E(X,1,30),DA)="" | .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y S X=$P(DIKZ(0),U,2) | S X=$P(DIKZ(0),U,5) I X'="" S L=$S($D(^DGPT(DA,70)):+^(70),1:0) I L'?7N.E | I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" S X=$P(DIKZ(0),U,2) | S X=$P(DIKZ(0),U,5) I X'="" I $P(^DGPT(DA,0),U,4),$P(^(0),U) S ^DGPT("AFE | I X'="" X ^DD(45.02,5,1,992,1) S X=$P(DIKZ(0),U,4) < I X'="" I $P(^DGPT(DA,0),U),$P(^(0),U,2) S ^DGPT("AFE < I X'="" S ^DGPT("AS",$E(X,1,30),DA)="" | I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,6) > I X'="" X ^DD(45.02,6,1,992,1) > S X=$P(DIKZ(0),U,7) > I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,7) > I X'="" X ^DD(45.02,7,1,992,1) > S X=$P(DIKZ(0),U,8) > I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,8) > I X'="" X ^DD(45.02,8,1,992,1) > S X=$P(DIKZ(0),U,9) > I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,9) > I X'="" X ^DD(45.02,9,1,992,1) I X'="" S ^DGPT("AMT",$E(X,1,30),DA)="" | I X'="" S ^DGPT(DA(1),"M","AM",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,11) > I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,11) > I X'="" X ^DD(45.02,11,1,992,1) > S X=$P(DIKZ(0),U,12) > I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" I X'="" S ^DGPT("ACENSUS",$E(X,1,30),DA)="" | I X'="" X ^DD(45.02,12,1,992,1) I X'="" D | I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" .N DIK,DIV,DIU,DIN | S X=$P(DIKZ(0),U,13) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGPT(D0, | I X'="" X ^DD(45.02,13,1,992,1) S DIKZ(101)=$G(^DGPT(DA,101)) | S X=$P(DIKZ(0),U,14) S X=$P(DIKZ(101),U,4) | I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" I X'="" S %=+^DGPT(DA,0) I %>0 S %C=$S($D(^DPT(%,.3)) | S X=$P(DIKZ(0),U,14) S DIKZ("401P")=$G(^DGPT(DA,"401P")) | I X'="" X ^DD(45.02,14,1,992,1) S X=$P(DIKZ("401P"),U,1) | S X=$P(DIKZ(0),U,15) I X'="" S ^DGPT(DA,"AP",X)="" | I X'="" S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" S X=$P(DIKZ("401P"),U,2) | S X=$P(DIKZ(0),U,15) I X'="" S ^DGPT(DA,"AP",X)="" | I X'="" X ^DD(45.02,15,1,992,1) S X=$P(DIKZ("401P"),U,3) | G:'$D(DIKLM) A Q:$D(DISET) I X'="" S ^DGPT(DA,"AP",X)="" < S X=$P(DIKZ("401P"),U,4) < I X'="" S ^DGPT(DA,"AP",X)="" < S X=$P(DIKZ("401P"),U,5) < I X'="" S ^DGPT(DA,"AP",X)="" < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,1) < I X'="" S ^DGPT("ADS",$E(X,1,30),DA)="" < S X=$P(DIKZ(70),U,1) < I X'="" S %=$S($D(^DGPT(DA,"M",1,0)):^(0),1:""),%D=+$ < S X=$P(DIKZ(70),U,1) < I X'="" S L=$P(^DGPT(DA,0),"^",2) I L?7N.E K ^DGPT("A < S X=$P(DIKZ(70),U,2) < I X'="" I $D(^DGPT(DA,"M",1,0)) S $P(^(0),U,2)=X,$P(^ < S X=$P(DIKZ(70),U,10) < I X'="" X ^DD(45,79,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,16) < I X'="" X ^DD(45,79.16,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,17) < I X'="" X ^DD(45,79.17,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,18) < I X'="" X ^DD(45,79.18,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,19) < I X'="" X ^DD(45,79.19,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,20) < I X'="" X ^DD(45,79.201,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,21) < I X'="" X ^DD(45,79.21,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,22) < I X'="" X ^DD(45,79.22,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,23) < I X'="" X ^DD(45,79.23,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,24) < I X'="" X ^DD(45,79.24,1,992,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X=$P(DIKZ(70),U,11) < I X'="" X ^DD(45,80,1,992,1) < CR1 S DIXR=432 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,10) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"DXLS") < CR2 S DIXR=433 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,11) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"PDX") < CR3 S DIXR=434 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,16) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD1") < CR4 S DIXR=435 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,17) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD2") < CR5 S DIXR=436 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,18) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD3") < CR6 S DIXR=437 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,19) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD4") < CR7 S DIXR=438 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,20) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD5") < CR8 S DIXR=439 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,21) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD6") < CR9 S DIXR=440 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,22) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD7") < CR10 S DIXR=441 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,23) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD8") < CR11 S DIXR=442 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(4)=$P(DIKZ(70),U,24) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD9") < CR12 S DIXR=443 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(71)=$G(^DGPT(DA,71)) < S X(4)=$P(DIKZ(71),U,1) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD10") < CR13 S DIXR=444 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(71)=$G(^DGPT(DA,71)) < S X(4)=$P(DIKZ(71),U,2) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D < . K X1,X2 M X1=X,X2=X < . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD11") < CR14 S DIXR=445 < K X < S DIKZ(0)=$G(^DGPT(DA,0)) < S X(1)=$P(DIKZ(0),U,1) < S X(2)=$P(DIKZ(0),U,2) < S X(3)=$P(DIKZ(0),U,11) < S DIKZ(71)=$G(^DGPT(DA,71)) < S X(4)=$P(DIKZ(71),U,3) < S DIKZ(70)=$G(^DGPT(DA,70)) < S X(5)=$P(DIKZ(70),U,1) < S X=$G(X(1)) < diff -y --suppress-common-lines ./VADemo/r1/DGPTXX9.m ./VADemo/r2/r/DGPTXX9.m DGPTXX9 ; COMPILED XREF FOR FILE #45 ; 12/28/04 | DGPTXX9 ; COMPILED XREF FOR FILE #45.05 ; 12/09/02 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D | S DA=0 . K X1,X2 M X1=X,X2=X | A1 ; . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD12") | I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 CR15 S DIXR=446 | 0 ; K X | A S DA=$O(^DGPT(DA(1),"P",DA)) I DA'>0 S DA=0 G END S DIKZ(0)=$G(^DGPT(DA,0)) | 1 ; S X(1)=$P(DIKZ(0),U,1) | S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0)) S X(2)=$P(DIKZ(0),U,2) | S X=$P(DIKZ(0),U,3) S X(3)=$P(DIKZ(0),U,11) | I X'="" D S DIKZ(71)=$G(^DGPT(DA,71)) | .N DIK,DIV,DIU,DIN S X(4)=$P(DIKZ(71),U,4) | .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y S DIKZ(70)=$G(^DGPT(DA,70)) | S X=$P(DIKZ(0),U,5) S X(5)=$P(DIKZ(70),U,1) | I X'="" S ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)="" S X=$G(X(1)) | S X=$P(DIKZ(0),U,6) I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D | I X'="" S ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)="" . K X1,X2 M X1=X,X2=X | S X=$P(DIKZ(0),U,7) . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD13") | I X'="" S ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)="" CR16 K X | S X=$P(DIKZ(0),U,8) > I X'="" S ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,9) > I X'="" S ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)="" > G:'$D(DIKLM) A Q:$D(DISET) diff -y --suppress-common-lines ./VADemo/r1/DGPTXX.m ./VADemo/r2/r/DGPTXX.m DGPTXX ; DRIVER FOR COMPILED XREFS FOR FILE #45 ; 12/28/04 | DGPTXX ; DRIVER FOR COMPILED XREFS FOR FILE #45 ; 12/09/02 I $D(DIKKS) D:DIKZ1=DH(1) ^DGPTXX1 S DA=DIKUP D:DIKZ1 | I $D(DIKKS) D:DIKZ1=DH(1) ^DGPTXX1 S DA=DIKUP D:DIKZ1 I $D(DIKST) D:DIKZ1=DH(1) ^DGPTXX8 D:DIKZ1'=DH(1) SET | I $D(DIKST) D:DIKZ1=DH(1) ^DGPTXX6 D:DIKZ1'=DH(1) SET S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU= | S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU= I DIKZ1=45.01,DIKUM'<1 S DIKM1=1 D A1^DGPTXX3 Q | I DIKZ1=45.01,DIKUM'<1 S DIKM1=1 D A1^DGPTXX2 Q I DIKZ1=45.02,DIKUM'<1 S DIKM1=1 D A1^DGPTXX4 Q | I DIKZ1=45.02,DIKUM'<1 S DIKM1=1 D A1^DGPTXX3 Q I DIKZ1=45.05,DIKUM'<1 S DIKM1=1 D A1^DGPTXX5 Q | I DIKZ1=45.05,DIKUM'<1 S DIKM1=1 D A1^DGPTXX4 Q I DIKZ1=45.0535,DIKUM'<1 S DIKM1=1 D A1^DGPTXX6 Q | I DIKZ1=45.0535,DIKUM'<1 S DIKM1=1 D A1^DGPTXX5 Q I DIKZ1=45.06,DIKUM'<1 S DIKM1=1 D A1^DGPTXX7 Q < I DIKZ1=45.01,DIKUM'<1 S DIKM1=1 D A1^DGPTXX10 Q | I DIKZ1=45.01,DIKUM'<1 S DIKM1=1 D A1^DGPTXX7 Q I DIKZ1=45.02,DIKUM'<1 S DIKM1=1 D A1^DGPTXX11 Q | I DIKZ1=45.02,DIKUM'<1 S DIKM1=1 D A1^DGPTXX8 Q I DIKZ1=45.05,DIKUM'<1 S DIKM1=1 D A1^DGPTXX12 Q | I DIKZ1=45.05,DIKUM'<1 S DIKM1=1 D A1^DGPTXX9 Q I DIKZ1=45.0535,DIKUM'<1 S DIKM1=1 D A1^DGPTXX13 Q | I DIKZ1=45.0535,DIKUM'<1 S DIKM1=1 D A1^DGPTXX10 Q I DIKZ1=45.06,DIKUM'<1 S DIKM1=1 D A1^DGPTXX14 Q < Only in ./VADemo/r1/: DGQEBGR.m Only in ./VADemo/r1/: DGQEDD.m Only in ./VADemo/r1/: DGQEDEMO.m Only in ./VADemo/r1/: DGQEHLL.m Only in ./VADemo/r1/: DGQEHLOR.m Only in ./VADemo/r1/: DGQEHLR.m Only in ./VADemo/r1/: DGQEHLRQ.m Only in ./VADemo/r1/: DGQEHLS.m Only in ./VADemo/r1/: DGQEHLUT.m Only in ./VADemo/r1/: DGQEREQ.m Only in ./VADemo/r1/: DGQERPC.m diff -y --suppress-common-lines ./VADemo/r1/DGQESC2.m ./VADemo/r2/r/DGQESC2.m DGQESC2 ;ALB/JFP - VIC OUTPATIENT CLINIC SCAN ROUTINE ; 03/29 | DGQESC2 ;ALB/JFP - VIC OUTPATIENT CLINIC SCAN ROUTINE ; 01/09 ;;5.3;Registration;**73,568**;Aug 13, 1993 | ;;V5.3;REGISTRATION;**73**;DEC 11,1996 .N DATE,DFNARR,CNT,Y,ERR,SDATE,EDATE,DFN,RESULTS | .N DATE,DFNARR,CNT,Y,ERR,SDATE,EDATE,DFN,RESULTS,ZTST .N DGSUB,DGJ,DGUTD,DGWD,DGDV,ZTSTOP | .N DGSUB,DGJ,DGUTD,DGWD,DGDV N CLINIC,CLINDATE,DPTINFO,I,CLNARRAY,DGARRAY,DGDIV,SD | N CLINIC,CLINDATE,DPTINFO K ^TMP($J,"SDAMA"),^TMP($J,"SDAMA301") < I '$D(ZTQUEUED) W !!,"Note: Each Dot equals a clinic" | I '$D(ZTQUEUED) W !!,"Note: Each Dot equals a clinic" I VAUTC,VAUTD D | ; -- Scans OUTPATIENT clinic .S CLINIC=0 F S CLINIC=$O(^SC(CLINIC)) Q:'CLINIC D | S (CLINIC,CLINDATE)="" ..I $P(^SC(CLINIC,0),U,3)="C" D CBLD3(CLINIC) | I VAUTC=1 D ; | .F S CLINIC=$O(^SC("AC","C",CLINIC)) Q:CLINIC="" D I VAUTC,'VAUTD S DGDIV="" D | I VAUTC=0 D .S DGDIV="" F S DGDIV=$O(VAUTD(DGDIV)) Q:'DGDIV D | .F S CLINIC=$O(VAUTC(CLINIC)) Q:CLINIC="" D SCAN1 ..S CLINIC=0 F S CLINIC=$O(^SC(CLINIC)) Q:'CLINIC D | HL7 ; -- Building HL7 batch message ...I $P(^SC(CLINIC,0),U,3)="C",$P(^SC(CLINIC,0),U,15) < ; < I 'VAUTC S CLINIC=0 F S CLINIC=$O(VAUTC(CLINIC)) Q:' < ; < D SDAMA,BLDTMP,BLDHL7 < K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),^TMP($J,"SDAMA") < Q < CBLD3(CLINIC) ; Build array of specified Clinics for specif < S CLNARRAY(I)=$G(CLNARRAY(I))_CLINIC_";" < I $L(CLNARRAY(I))>120 S I=I+1 < I '$D(ZTQUEUED) W "." < Q < ; < SDAMA ; Build TMP Global with Appointment API Data for Repo < S DGARRAY(1)=SDATE_";"_EDATE < S DGARRAY("FLDS")="2;3" < 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 < BLDHL7 ; -- Building HL7 batch message < BLDTMP ; | SCAN1 ; -- ; -- Building Temporary Storage Data | ; -- Check to see if users wants task to stop S (ZTSTOP,CLINIC)=0 F S CLINIC=$O(^TMP($J,"SDAMA",CL | I $$S^%ZTLOAD D Q .I $$S^%ZTLOAD S ZTSTOP=1 Q | .S ZTSTOP=1 .S DFN=0 F S DFN=$O(^TMP($J,"SDAMA",CLINIC,DFN)) Q:' | I VAUTD=0 D CHKDIV Q:'DIVFLAG ..S CLINDATE=0 F S CLINDATE=$O(^TMP($J,"SDAMA",CLINI | ;W !,"CLINIC = ",CLINIC ...I $P($P(^TMP($J,"SDAMA",CLINIC,DFN,CLINDATE),U,3), | I '$D(ZTQUEUED) W "." > S CLINDATE=SDATE > F S CLINDATE=$O(^SC(CLINIC,"S",CLINDATE)) Q:CLINDATE > .I $P(CLINDATE,".")>EDATE Q > .;W !,"CLINDATE = ",CLINDATE > .S DFN=$P($G(^SC(CLINIC,"S",CLINDATE,1,1,0)),"^") Q:D > .S DPTINFO=$P($G(^DPT(DFN,"S",CLINDATE,0)),"^",1,2) > .I $P(DPTINFO,"^")=CLINIC&($P(DPTINFO,"^",2)="") D > ..S @DFNARR@(DFN)="" Only in ./VADemo/r1/: DGQEUT1.m Only in ./VADemo/r1/: DGQEUT2.m Only in ./VADemo/r1/: DGQEUT3.m diff -y --suppress-common-lines ./VADemo/r1/DGQPTQ2.m ./VADemo/r2/r/DGQPTQ2.m DGQPTQ2 ; slc/CLA - Functions which return patient lists and | DGQPTQ2 ; slc/CLA - Functions which return patient lists and ;;5.3;Registration;**447,598**;Aug 13, 1993 | ;;5.3;Registration;**447**;Aug 13, 1993 CLINPTS(Y,CLIN,DGBDATE,DGEDATE) ; RETURN LIST OF PTS W/CLINIC | CLINPTS(Y,CLIN,DGBDATE,OREDATE) ; RETURN LIST OF PTS W/CLINIC S DGEDATE=$P(DGEDATE,".")_.5 | S DGEDATE=$P(DGEDATE,".")_.5 ;ADD 1/2 DAY TO END DAT ; | ;access to SC global granted under DBIA #518: N DGARRAY,SDCNT,SDFN,SAPPT,ASTAT | S DGJ=DGBDATE F S DGJ=$O(^SC(+CLIN,"S",DGJ)) Q:DGJ<1 S DGARRAY(1)=DGBDATE_";"_DGEDATE,DGARRAY(2)=CLIN,DGAR | .I $L($G(^SC(+CLIN,"S",DGJ,1,0))) D S DGARRAY("SORT")="P",SDCNT=$$SDAPI^SDAMA301(.DGARRAY | ..S J=0 F S J=$O(^SC(+CLIN,"S",DGJ,1,J)) Q:+J<1!(I>M I +SDCNT<0 S Y(1)="^Appointment Database is unavailab | ...S DGC=$P(^SC(+CLIN,"S",DGJ,1,J,0),U,9) S SDFN=0 F S SDFN=$O(^TMP($J,"SDAMA301",SDFN)) Q:'SD | ...Q:DGC="C" ; cancelled clinic availability .S SAPPT=0 F S SAPPT=$O(^TMP($J,"SDAMA301",SDFN,SAPP | ...; ..S ^TMP($J,"SDAM",SAPPT,SDFN)=SDFN_"^"_^TMP($J,"SDAM | ...S DFN=+$G(^SC(+CLIN,"S",DGJ,1,J,0)) ; | ...S X=$G(^DPT(DFN,"S",DGJ,0)) I +X'=CLIN Q ; appt c S DGJ=0 F S DGJ=$O(^TMP($J,"SDAM",DGJ)) Q:'DGJ D | ...; .S DFN=0 F S DFN=$O(^TMP($J,"SDAM",DGJ,DFN)) Q:'DFN | ...; quit if appt cancelled or no show: ..S ASTAT=$P($P(^TMP($J,"SDAM",DGJ,DFN),"^",4),";") | ...I $P(X,U,2)'="NT",($P(X,U,2)["C")!($P(X,U,2)["N") ..; quit if appt cancelled or no show: | ...; ..I ASTAT'="NT",(ASTAT["C")!(ASTAT["N") Q | ...S Y(I)=DFN_"^"_$P(^DPT(DFN,0),"^")_"^"_+CLIN_"^"_D ..S Y(I)=DFN_"^"_$P(^DPT(DFN,0),"^")_"^"_+CLIN_"^"_DG < ; < K ^TMP($J,"SDAM"),^TMP($J,"SDAMA301"),SDCNT,DGARRAY,S < Only in ./VADemo/r1/: DGREGAED.m Only in ./VADemo/r1/: DGREGARP.m Only in ./VADemo/r1/: DGREGAZL.m diff -y --suppress-common-lines ./VADemo/r1/DGREGDD1.m ./VADemo/r2/r/DGREGDD1.m ;;5.3;Registration;**454,522**;Aug 13, 1993 | ;;5.3;Registration;**454**;Aug 13, 1993 ZIP(DA,ZIP,CITY) ; update city, state and county based | ZIP(DA,ZIP) ; update city, state, and county based on zip I '$D(EASZIPLK) Q 0 | N EASDATA,FDA,MSG N EASDATA,FDA,MSG,DGN,CNTYIEN < I '$$MLT(ZIP) K EASZIPLK Q 0 < I $$FOREIGN^DGREGAZL() K EASZIPLK Q 0 < > S:$L($G(EASDATA("CITY")))>15 EASDATA("CITY")=$E(EASDA > S FDA(2,DA_",",.114)=$G(EASDATA("CITY")) N ZIP,DGR | N ZIP,EASDATA S DGR=$$ALWEDT(DUZ,ZIP) | I 'ZIP Q 0 Q DGR < ALWEDT(DUZ,ZIP) ; determine if a security key is necessary fo < ; Input: zip code < ; Output: 1: allow edit state and county < ; 0: don't allow edit state and county < N EASDATA < I $G(ZIP)="" Q 0 < I '$D(DUZ) Q 0 < I '$$MLT(ZIP) Q 1 ; > 1 state or county for the zip - < I $$FOREIGN^DGREGAZL() Q 1 ; Foreign location - allow < MLT(ZIP) ;Determine if a zip correspond to multiple st < ;Output: 0: >1 state and\or county for this zip < ; 1: 1 state and 1 county for this zip < N DGN,DGFIPS,DGDATA,POP,DGCNTY,DGST < S (DGN,DGST,DGCNTY,DGFIPS)="" < S POP=0 < D POSTALB^XIPUTIL(ZIP,.DGDATA) < I $D(DGDATA("ERROR")) Q 0 < S DGN=$O(DGDATA(DGN)) < S DGFIPS=$G(DGDATA(DGN,"FIPS CODE")) < F S DGN=$O(DGDATA(DGN)) Q:(DGN="")!POP D < . I $G(DGDATA(DGN,"FIPS CODE"))'=DGFIPS S POP=1 Q < I POP=1 Q 0 < Q 1 < diff -y --suppress-common-lines ./VADemo/r1/DGREGE.m ./VADemo/r2/r/DGREGE.m DGREGE ;ALB/JDS - EDIT REGISTRATIONS/DISPOSITIONS ; 04/30/20 | DGREGE ;ALB/JDS - EDIT REGISTRATIONS/DISPOSITIONS ; 26 AUG 8 ;;5.3;Registration;**24,161,151,459,568**;Aug 13, 199 | ;;5.3;Registration;**24,161,151**;Aug 13, 1993 W1 S DA=DFN1,DA(1)=DFN,L=$G(^DPT(DFN,"DIS",DFN1,0)),DP=2 | W1 S SDISHDL=$$HANDLE^SDAMEVT(3) D BEFORE^DGDIS(DFN,9999 I $P(L,U,18) S (SDISHDL,^TMP("SDEVT HANDLE",$J))=$G(^ < N DGL | I "^0^1^"[("^"_$P($G(^DPT(DFN,"DIS",DFN1,0)),"^",2)_" S DGL=$G(^DPT(DFN,"DIS",DFN1,0)) | D EVT^DGDIS(DFN,9999999-DFN1,9,SDISHDL) I $P(DGL,U,18) D | D VALIDATE^DGDIS(DFN,DFN1) ; -- call c/o validator . I "^0^1^"[(U_$P(DGL,U,2)_U),$P(DGL,U,6) D CO(DFN,99 < . D EVT^DGDIS(DFN,9999999-DFN1,9,SDISHDL) < . D VALIDATE^DGDIS(DFN,DFN1) ; -- call c/o validator < . I $$ASK^SDCO6(SDPMTDF) D EN^SDCO(SDOE,SDISHDL,1) | .I $$ASK^SDCO6(SDPMTDF) D EN^SDCO(SDOE,SDISHDL,1) Only in ./VADemo/r1/: DGREGFAC.m diff -y --suppress-common-lines ./VADemo/r1/DGREGG.m ./VADemo/r2/r/DGREGG.m DGREGG ;ALB/MRL,LBD - CONTINUATION OF REGISTRATION PROCESS ; | DGREGG ;ALB/MRL - CONTINUATION OF REGISTRATION PROCESS ;16 A ;;5.3;Registration;**565**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 I Y D | I Y X ^DD("DD") W !,"Entered Service ",Y,!,"Veteran M .X ^DD("DD") W !,"Entered Service ",Y < .W !,"Veteran must have completed at least 24 consecu < .W !,"military service. If veteran meets an exception < .W !,"as listed on www.va.gov/elig, veteran is eligib < .W !,"Otherwise, enter Ineligible Date and Reason on < .W !,"eligible for care of SC conditions only.",! < .K A < diff -y --suppress-common-lines ./VADemo/r1/DGREG.m ./VADemo/r2/r/DGREG.m DGREG ;ALB/JDS,MRL/PJR-REGISTER PATIENT ; 12/20/04 10:35am | DGREG ;ALB/JDS,MRL-REGISTER PATIENT ; 6/14/00 1:12pm ;;5.3;Registration;**1,32,108,147,149,182,245,250,513 | ;;5.3;Registration;**1,32,108,147,149,182,245,250**;A A D ENDREG($G(DFN)) I '$G(DG1010TF) W !! S DIC=2,DIC(0) | A D ENDREG($G(DFN)) I '$G(DG1010TF) W !! S DIC=2,DIC(0) ; < ;; ask to continue if patient died - DG*5.3*563 - pjr < S DOD="" I $G(DFN) S DOD=$P($G(^DPT(DFN,.35)),"^",1) < I DOD,'$G(DG1010TF) S Y=DOD,DGPME=0 D DIED^DGPMV I DG < I +$G(DGNEW) D < . ; query CMOR for Patient Record Flag Assignments if < . ; display results. < . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN) < ; < D ROMQRY < ; < ; check whether facility applying to (division) is in < I '$$DIVCHK^DGREGFAC(DFN,DFN1) G CONT < ASKDIV W !!?5,"The facility chosen either has no pointer to < W !?5,"file record or the Institution file record is < W !?5,"Please choose another division." < S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="3" D ^ < I $$DIVCHK^DGREGFAC(DFN,DFN1) G ASKDIV < CONT ; continue < ROMQRY ; < I +$G(DGNEW) D < . ; query LST for Patient Demographic Information if < . ; file into patient's record. < . N A < . I $$ROMQRY^DGROAPI(DFN) D < . . ;display busy message to interactive users < . .S DGMSG(1)="Data retrieval from LST site has been < . .S DGMSG(2)="Thank you for your patience." < . .D EN^DDIOL(.DGMSG) R A:5 < . E D < . . ;display busy message to interactive users < . .S DGMSG(1)="Data retrieval from LST site has not b < . .S DGMSG(2)="Please continue the Registration Proce < . .D EN^DDIOL(.DGMSG) R A:5 < . ; < Q < Only in ./VADemo/r1/: DGROAPI.m Only in ./VADemo/r1/: DGRODEBR.m Only in ./VADemo/r1/: DGROHLQ1.m Only in ./VADemo/r1/: DGROHLQ2.m Only in ./VADemo/r1/: DGROHLQ3.m Only in ./VADemo/r1/: DGROHLQ.m Only in ./VADemo/r1/: DGROHLR1.m Only in ./VADemo/r1/: DGROHLR.m Only in ./VADemo/r1/: DGROHLS.m Only in ./VADemo/r1/: DGROHLU1.m Only in ./VADemo/r1/: DGROHLU3.m Only in ./VADemo/r1/: DGROHLU4.m Only in ./VADemo/r1/: DGROHLU.m Only in ./VADemo/r1/: DGROHLUT.m Only in ./VADemo/r1/: DGROMAIL.m Only in ./VADemo/r1/: DGROUT2.m Only in ./VADemo/r1/: DGROUT.m diff -y --suppress-common-lines ./VADemo/r1/DGRP14.m ./VADemo/r2/r/DGRP14.m DGRP14 ;ALB/MRL/EG - REGISTRATION SCREEN 14/APPOINTMENT INFO | DGRP14 ;ALB/MRL - REGISTRATION SCREEN 14/APPOINTMENT INFORMA ;;5.3;Registration;**568,585**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 N DGARRAY,APTDT,CLNAM S DGARRAY("FLDS")="1;2",DGARRAY | F I=0:0 S I2=$O(^DPT(DFN,"S",I2)) Q:I2="" I $S($P(^( ;if there is lower subscripts hanging from the 101 no < ;then it is a valid appointment, otherwise it's an < ;eg 01/20/2005 < I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Databa < S APTDT=0 < F S APTDT=$O(^TMP($J,"SDAMA301",DFN,APTDT)) Q:'APTDT < .;check to see if appointment is cancelled, if so < .;ignore this appointment eg 01/25/2005 < .I $$CANCEL(DFN,APTDT)="Y" Q < .S CLNAM=$P($P(^TMP($J,"SDAMA301",DFN,APTDT),U,2),";" < .S X=$S(CLNAM]"":CLNAM,1:"UNKNOWN CLINIC")_" ("_$$FMT < .Q < Q K I,I1,I2,X,Y,DGARRAY,APTDT,CLNAM G ^DGRPP | Q K I,I1,I2,X,Y G ^DGRPP ; < ;input DFN - patient id < ; APPDATE - appointment date < ;return Y - Yes < ; N - No < CANCEL(DFN,APPDATE) ; < N X,STATUS,U < S U="^" < S X=$G(^DPT(DFN,"S",APPDATE,0)) < I X="" Q "Y" ;probably bad data < S STATUS=$P(X,U,2) < I STATUS="" Q "N" < I STATUS="I" Q "N" < Q "Y" < diff -y --suppress-common-lines ./VADemo/r1/DGRP15.m ./VADemo/r2/r/DGRP15.m DGRP15 ;ALB/MTC - TRICARE DEMOGRAPHIC DATA ;03/05/2004 | DGRP15 ;ALB/MTC - TRICARE DEMOGRAPHIC DATA ;7/25/99 18:55 ;;5.3;Registration;**114,239,568**;Aug 13, 1993 | ;;5.3;Registration;**114,239**;Aug 13, 1993 .D TDATA^DGSDUTL(DFN,.CT,DT) | .D TDATA^SDPPTEM(DFN,.CT,DT) diff -y --suppress-common-lines ./VADemo/r1/DGRP1.m ./VADemo/r2/r/DGRP1.m DGRP1 ;ALB/MRL - DEMOGRAPHIC DATA ; 7/24/03 11:46am | DGRP1 ;ALB/MRL - DEMOGRAPHIC DATA ;06 JUN 88@2300 ;;5.3;Registration;**109,161,506,244,546,570**;Aug 13 | ;;5.3;Registration;**109,161**;Aug 13, 1993 D GETNCAL ;Display name component and alias informat | S (I1,Z1)="",Z=2 D WW^DGRPV W " Alias: " > F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:'I S I1=1 W:$X>40 > W:'I1 "NO ALIAS ON FILE FOR THIS APPLICANT" W !?11 | W !?9 S Z1=40,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW | S Z1=42,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) | S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) S DGCC=$S($D(^DIC(5,+$P(DGRP(.11),U,5),1,+$P(DGRP(.11 | S DGCC=$S($D(^DIC(5,+$P(DGRP(.11),U,5),1,+$P(DGRP(.11 W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13), | W !?2,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13), W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13) | W !?1,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13) W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP < . ; The IB Insurance API does not provide date entere | . I $D(^DPT(DFN,.312,0)) S IN1=0 F S IN1=$O(^DPT(DFN . I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F D | .. S IND=$P($G(^DPT(DFN,.312,IN1,1)),U) W !," [INSURA .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DG | .. I $P($G(^DPT(DFN,.312,IN1,1)),U,5) S INE=$P($G(^DP .. W " EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI < ; < GETNCAL ;Get name component values < N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW < S DGNC="Family^Given^Middle^Prefix^Suffix^Degree" < S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," < I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") < ;Get alias values < S DGA=0 F DGI=1:1:6 D Q:'$D(DGALIAS(DGI)) < A2 .S DGA=$O(^DPT(DFN,.01,DGA)) < .I 'DGA D:DGI=1 Q < ..S DGALIAS(DGI)="< No alias entries on file >" Q < .I DGI=6 S DGALIAS(DGI)="< More alias entries on file < .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2 < .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2) < .I $L(DGX) D < ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6, < ..S $E(DGALIAS(DGI),20)=DGX Q < .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,31) < .Q < ;Display name component and alias data < F DGI=1:1:6 D < .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCO < .I DGI=1 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: " < .W ?48,$G(DGALIAS(DGI)) < .Q < Q < diff -y --suppress-common-lines ./VADemo/r1/DGRP2.m ./VADemo/r2/r/DGRP2.m ;;5.3;Registration;**415,545**;Aug 13, 1993 | ;;5.3;Registration;**415**;Aug 13, 1993 D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHI < W !! < W "<4> Date of Death Information" < W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351," < W !,?5,"Date of Death Source of Notification: ",$G(PD < W !,?5,"Date of Death Last Updated Date/Time: ",$G(PD < W !,?5,"Date of Death Last Edited By: ",$G(PDTHINFO(2 < K PDTHINFO < diff -y --suppress-common-lines ./VADemo/r1/DGRP5.m ./VADemo/r2/r/DGRP5.m ;;5.3;Registration;**190,366,570**;Aug 13, 1993 | ;;5.3;Registration;**190,366**;Aug 13, 1993 W ! D DISP^DGIBDSP | ; *REMOVEW !!?3 S Z=" Insurance",Z1=27 D WW1^DGRPV S > ; *REMOVES I1="" F I=0:0 S I=$O(^DPT(DFN,.312,I)) Q:' > W ! D DISP^IBCNSP2 > ;*REMOVEW:'I1 !?4,"NO ACTIVE (UNEXPIRED) INSURANCE ON IN ; This code is no longer called, replaced by DISP^IBC | IN S J="*" F J(1)=9:1:14 I $P(DGRPX,"^",J(1))]"" S J=" " > S:J="*" DGRPAG="" W !?3,J,$S($D(^DIC(36,+$P(DGRPX,"^" > W ?71,$S($P(DGRPX,"^",6)="v":"APPLICANT",$P(DGRPX,"^" diff -y --suppress-common-lines ./VADemo/r1/DGRP6.m ./VADemo/r2/r/DGRP6.m DGRP6 ;ALB/MRL,LBD - REGISTRATION SCREEN 6/SERVICE INFORMAT | DGRP6 ;ALB/MRL - REGISTRATION SCREEN 6/SERVICE INFORMATION ;;5.3;Registration;**161,247,343,397,342,451**;Aug 13 | ;;5.3;Registration;**161,247,343,397,342**;Aug 13, 19 S N DGRPSB S DGRPSB=+$P(DGRPX,U,DGRPSV+1) ;Service Bra | S W !?4,$S($D(^DIC(23,+$P(DGRPX,"^",DGRPSV+1),0)):$E($P W !?4,$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15 < W ?27,$S($P(DGRPX,"^",DGRPSV+4)]"":$P(DGRPX,"^",DGRPS < diff -y --suppress-common-lines ./VADemo/r1/DGRP7.m ./VADemo/r2/r/DGRP7.m ;;5.3;Registration;**528**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 CONT ; | CONT ;print sc disabilities (per patient) ;display Combat Vet Eiligibility, if present < N DGCV < S DGCV=$$CVEDT^DGCV(DFN) I +$G(DGCV)=1 D < . W !,"<3.1> Combat Vet Elig.: " < . W $S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)=0:"EXPI < . I $P($G(DGCV),U,2)]"" D < . . S Y=$P(DGCV,U,2) D DD^%DT < . . W ", End Date: "_Y < ; < ;print sc disabilities (per patient) < diff -y --suppress-common-lines ./VADemo/r1/DGRP8.m ./VADemo/r2/r/DGRP8.m ;;5.3;Registration;**45,54,487**;Aug 13, 1993 | ;;5.3;Registration;**45,54**;Aug 13, 1993 EN I $D(DVBGUI) G ENQ ; IF CALLED BY CAPRI, SKIP SCREEN | EN ; Start display ; < ; Start display < ; < diff -y --suppress-common-lines ./VADemo/r1/DGRP9.m ./VADemo/r2/r/DGRP9.m ;;5.3;Registration;**45,108,487**;Aug 13, 1993 | ;;5.3;Registration;**45,108**;Aug 13, 1993 ; DVBGUI : CAPRI GUI User < I $D(DVBGUI) U IO ;If called from CAPRI menu set outp < diff -y --suppress-common-lines ./VADemo/r1/DGRPC1.m ./VADemo/r2/r/DGRPC1.m DGRPC1 ;ALB/MRL/PJR - CHECK CONSISTENCY OF PATIENT DATA (CON | DGRPC1 ;ALB/MRL - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; ;;5.3;Registration;**314,342,451,564**;Aug 13, 1993 | ;;5.3;Registration;**314,342**;Aug 13, 1993 I $P(DGP(0),"^",3)'>2061231 S DGSTR=DGSTR_"16^" ;mex | I $P(DGP(0),"^",3)'>2200101 S DGSTR=DGSTR_"16^17^" ;a I $P(DGP(0),"^",3)'>2071231 S DGSTR=DGSTR_"17^" ;allo < 25 ;off | 25 I DGVT,$P(DGP(.321),"^",2)="Y",$P($G(^DIC(21,+$P(DGP( 26 ;off | 26 ; 27 ;off | 27 ; 28 ;off | 28 I 'DGVT S DGD=DGP(.321),X=25 F I=1:1:3 S X=X+1 I $P(D D NEXT I +DGLST>32!('DGLST) G @DGLST | D NEXT I +DGLST>33!('DGLST) G @DGLST ; | 32 ; 32 I 'DGVT S DGD=DGP(.362),X=28 F I=12,13,14,16 S X=X+1 | 33 I 'DGVT S DGD=DGP(.362),X=28 F I=12,13,14,16,17 S X=X S DGLST=32 G:DGCHK'[",32," FIND^DGRPC2 D NEXT G @DGLS < 33 ;off < ; | 34 ; 34 I 'DGVT,$P(DGP(.52),"^",5)="Y",DGCHK[(","_34_",") D C | 35 I 'DGVT S X=33 F I=5,11 S X=X+1 I $P(DGP(.52),"^",I)= 35 ;off < ;;S:'DGVT DGLST=48 G:DGCHK'[",48,"&'DGVT FIND^DGRPC2 | S:'DGVT DGLST=48 G:DGCHK'[",48,"&'DGVT FIND^DGRPC2 D D NEXT I +DGLST>40!('DGLST) G @DGLST < 40 F I=5,11 S I2=0,X=$S(I=5:37,1:39) I $P(DGP(.52),"^",I | 40 I DGVT F I=5,11 S I2=0,X=$S(I=5:37,1:39) I $P(DGP(.52 ;; | S DGLST=40 S:'DGVT DGLST=48 G FIND^DGRPC2:(DGCHK'[",4 41 ;; Inconsistencies 41 and 42 are superseded by 72 thr | 41 I DGVT,$P(DGP(.321),"^",1)="Y",$P(DGP(.321),"^",4)="" 42 ;; | S:'DGVT DGLST=48 G:DGCHK'[",48,"&'DGVT FIND^DGRPC2 D ;; | 42 I DGVT,+$P(DGP(.321),"^",4),+$P(DGP(.321),"^",5),+$P( S DGLST=42 S:'DGVT DGLST=48 G:DGCHK'[",48,"&'DGVT FIN | S:'DGVT DGLST=48 G:DGCHK'[",48,"&'DGVT FIND^DGRPC2 D I DGCHK[(","_X_",") F I1=I+2:1:I+3 I $E($P(DGP(.52)," | S X=X+1 I +$P(DGP(.52),"^",I+2),+$P(DGP(.52),"^",I+3) S X=X+1 I DGCHK[(","_X_","),$P(DGP(.52),"^",I+2),$P(D < NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) | NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,+DGLST<79 S DGLST=DGLST_"^DGRPC2" Q | S:'DGLST DGLST="END^DGRPC2" I +DGLST S DGLST=DGLST_"^ S:'DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^ < diff -y --suppress-common-lines ./VADemo/r1/DGRPC2.m ./VADemo/r2/r/DGRPC2.m DGRPC2 ;ALB/MRL/SCK/PJR - CHECK CONSISTENCY OF PATIENT DATA | DGRPC2 ;ALB/MRL - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; ;;5.3;Registration;**45,69,108,121,205,218,342,387,47 | ;;5.3;Registration;**45,69,108,121,205,218,342,387,47 43 ;off | 43 ; 44 ;off | 44 ; 45 ;off | 45 ; 46 ;off | 46 ; 47 ;off | 47 I DGVT S X=42,DGD=DGP(.362) F I=12:1:14 S X=X+1 I DGC . S INS=$$INSUR^IBBAPI(DFN,DT,"R") | . D ALL^IBCNS1(DFN,"INS",2,DT) . I COV,'INS S X=49 ; yes, but none | . I COV,'$G(INS(0)) S X=49 ; yes, but none . I 'COV,INS S X=50 ; not yes, but some | . I 'COV,$G(INS(0)) S X=50 ; not yes, but some I 'DGFL N DGAPD,DG55 D I 'DGAPD&('DG55) S X=55 D CO | I 'DGFL N DGAPD D I 'DGAPD S X=55 D COMB . S DG55=$$CHECK55(DFN) ; **507, Additional Income Ch < D NEXT G END^DGRPC3:$S('+DGLST:1,+DGLST=99:1,1:0) G @ | D NEXT G END:$S('+DGLST:1,+DGLST=99:1,1:0) ;off | I $P(DGP(.322),U,13)="Y" D > . I $P(DGP(.322),U,10)="Y"!($P(DGP(.322),U,16)="Y") Q > . S X=58 D COMB 63 ;Confidential Address check | 99 ; synonymous with END I $P($$CAACT^DGRPCADD(DFN),U) D | END I DGNCK S X=99 D COMB .N DGI,DGERR | I DGEDCN S DGCON=0 D TIME^DGRPC .S DGERR=0 | K C,C1,C2,DGCD,DGD,DGD1,DGD2,DGDATE,DGDEP,DGCHK,DGFL, .F DGI=1,4,5,6 Q:DGERR I $P(DGP(.141),U,DGI)="" S DG | G ^DGRPCF .I DGERR S X=63 D COMB | ; D NEXT G @DGLST < 64 ;64 - Place of Birth City/State Missing ;**505 < I $P(DGP(0),"^",11)=""!($P(DGP(0),"^",12)="") S X=64 < D NEXT G @DGLST < 65 ;65 - Mother's Maiden Name Missing ;**505 < I $P(DGP(.24),"^",3)="" S X=65 D COMB < D NEXT G @DGLST < 66 ;66 - Pseudo SSN in use ;**505 < I $P(DGP(0),"^",9)["P" S X=66 D COMB < D NEXT G @DGLST < 67 ;67 - Serv Sep Date [Last] missing or imprecise, patc < N DGG < S DGG=$$CVELIG^DGCV(DFN) < I $G(DGG)["A"!($G(DGG)["F") S X=67 D COMB < D NEXT G @DGLST < 68 ;used for 68-71, for Combat Vet, DG*5.3*528 < 69 ; < 70 ; < 71 ; < ;68 - Combat To Date missing or imprecise, patch 528 < ;69 - Yugoslavia To Date missing or imprecise, patch < ;70 - Somalia To Date missing or imprecise, patch 528 < ;71 - Persian Gulf To Date missing or imprecise, patc < N DGG < S DGG=$$CVELIG^DGCV(DFN) < I DGG["B"!(DGG["G") S X=68 D COMB < I DGG["C"!(DGG["H") S X=69 D COMB < I DGG["D"!(DGG["I") S X=70 D COMB < I DGG["E"!(DGG["J") S X=71 D COMB < S DGLST=71 < D NEXT G @DGLST < 72 ;; MSE - Required Fields < S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSERR S X=72 D C < D NEXT G @DGLST < 73 ;; An MSE FROM date precedes an MSE TO date < S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR D NEXT < F I1=6,11,16 I '$$B4^DGRPDT($P(DGP(.32),"^",I1),$P(DG < D NEXT G @DGLST < 74 ;; Conflict Date Missing or Incomplete < S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK I CONERR S X=74 D < D NEXT G @DGLST < 75 ;; Conflict TO date precedes FROM date < 76 ;; Conflict Date out of range for conflict < S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK < S LOC="",(I5,I6)=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q: < .N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA < .S DATA=CONSPEC(LOC) < .S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P( < .S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE < .I '$$B4^DGRPDT(FROMDAT,TODAT,1) S X=75 D COMB:'I5&(D < .I DGCHK'[(",76,") Q < .S:'$G(RANSET) RANSET=$$RANGE^DGMSCK < .I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LO < .Q < S DGLST=76 D NEXT G @DGLST < 77 ;; Date out of range for POW Location < S:'$G(RANSET) RANSET=$$RANGE^DGMSCK < ;; Don't check if POW Data Incomplete or if POW TO pr < I ((","_DGER_",")[(",37,"))!((","_DGER_",")[(",38,")) < I $P(DGP(.52),"^",5)'="Y" D NEXT G @DGLST ;; Don't ch < S LOC=$$COMPOW^DGRPMS($P(DGP(.52),"^",6)) I LOC="" D < I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC < D NEXT G @DGLST < 78 ;; Date out of range for Combat Location < S:'$G(RANSET) RANSET=$$RANGE^DGMSCK < ;; Don't check if Combat Data Incomplete or if Combat < I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) < I $P(DGP(.52),"^",11)'="Y" D NEXT G @DGLST ;; Don't c < S LOC=$$COMPOW^DGRPMS($P(DGP(.52),"^",12)) I LOC="" D < I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC < D NEXT G @DGLST < NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) | NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) S:'DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^ < Q < I I,I<99 S DGLST=I G @(DGLST_$S(DGLST>78:"^DGRPC3",DG | I I,I<99 S DGLST=I G @(DGLST_$S(DGLST>42:"",DGLST>17: G END^DGRPC3 | G END ; < CHECK55(DFN) ;Buisness rules for additional 55-INCOME DATA < ; Modeled from DGMTR checks. < ; Input DFN - IEN from PATIENT File #2 < ; < ; Output 1 - If Income check passes additional buisn < ; 0 - If Income check fails additional buisne < ; < N VAMB,VASV,VA,VADMVT,VAEL,VAINDT,DGRTN,DGMED,DG,DG1, < ; < S DGRTN=0 < D MB^VADPT I +VAMB(7) S DGRTN=1 G Q55 ; Check if rec < D SVC^VADPT I +VASV(4) S DGRTN=1 G Q55 ; check if PO < I +VASV(9),(+VASV(9,1)=3) S DGRTN=1 G Q55 ; Check if < D GETS^DIQ(2,DFN_",",".381:.383","I","DGMED") < I $G(DGMED(2,DFN_",",.381,"I")) S DGRTN=1 G Q55 ; Ch < D ADM^VADPT2 ; Check for current admission to DOM war < I +$G(VADMVT) D G:DGRTN Q55 < . Q:'$$GET1^DIQ(43,1,16,"I") ; Has Dom wards? < . S DGWARD=$$GET1^DIQ(405,VADMVT,.06,"I") ; Get ward < . S DGSRVC=$$GET1^DIQ(42,DGWARD,.03,"I") ; Get ward s < . S:DGSRVC="D" DGRTN=1 ; If ward service is 'D', then < ; < ; Additional checks for 0% SC < D ELIG^VADPT < I +VAEL(3),'$P(VAEL(3),U,2) D ; Check if service con < . I +VAMB(4) S DGRTN=1 Q ; Check if receiving a VA p < . S DG=0 ; Check for secondary eligibilities < . F S DG=$O(VAEL(1,DG)) Q:'DG D Q:DGRTN < . . F DG1=2,4,15,16,17,18 I DG=DG1 S DGRTN=1 Q < Q55 D KVAR^VADPT < Q $G(DGRTN) < Only in ./VADemo/r1/: DGRPC3.m Only in ./VADemo/r1/: DGRPCADD.m diff -y --suppress-common-lines ./VADemo/r1/DGRPCE1.m ./VADemo/r2/r/DGRPCE1.m DGRPCE1 ;ALB/MIR/BRM/LBD - CONSISTENCY CHECKER EDIT ; 6/21/04 | DGRPCE1 ;ALB/MIR/BRM - CONSISTENCY CHECKER EDIT ; 10/17/02 1: ;;5.3;Registration;**108,226,470,454,489,505,522,451, | ;;5.3;Registration;**108,226,470,454**;Aug 13, 1993 N I,J F I=1:1:8,16,53,57,58,61:1:86 D SASK | N I F I=1:1:8,16,53,57,58,61,62 D SASK Q | D SAVE Q SASK I DGER[(","_I_","),DGASK'[(","_I_",") F J=I,I*1000:1 | SASK I DGER[(","_I_","),DGASK'[(","_I_",") S DGD=DGD_$P($T S DGASK=DGASK_I_"," < 8 ;;N FLG S FLG(2)=1 S:$G(DGER)[",61," FLG(1)=1 D EN^DG | 8 ;;.111;S DIE("NO^")="OUTOK";S:X="" Y="@1112";.112;S:X 14 ;;.361;S DGECODE=$S($D(^DIC(8,+X,0)):$P(^(0),"^",1),1 | 14 ;;.361;S DGECODE=$S($D(^DIC(8,+X,0)):$P(^(0),"^",1),1 61 ;;S:$G(DGER)[",8," Y="@619";.131;.132;@619; | 61 ;;.131;.132; 63 ;;.1411;S DIE("NO^")="OUTOK";S:X']"" Y=.1414;.1412;S: < 64 ;;.092;.093; < 65 ;;.2403; < 66 ;;.09; < 67 ;;S:$$DGERCK^DGRPCE1("73^79^80^81^82",.DGER) Y="@67"; < 68 ;;S:$$DGERCK^DGRPCE1("39^40",.DGER) Y="@68";W !!,$C(7 < 69 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@69";W !!,$ < 70 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@70";W !!,$ < 71 ;;S:$$DGERCK^DGRPCE1("74^75^76",.DGER) Y="@71";W !!,$ < 72 ;;.325;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@7201 < ; < 73 ;;S:$$DGERCK^DGRPCE1(72,.DGER) Y="@7302";.325;.326;.3 < 74 ;;S:'$$YN^DGRPCE1(.32101) Y="@7401";.32101;S:X'="Y" Y < 74000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7403";.322019;S:X'="Y" < 74001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7405";.3224;S:X'="Y" Y=" < 74002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7407";.32201;S:X'="Y" Y < 75 ;;S:$$DGERCK^DGRPCE1(74,.DGER) Y="@7507";S:'$$YN^DGRP < 75000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7503";.322019;S:X'="Y" < 75001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7505";.3224;S:X'="Y" Y=" < 75002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7507";.32201;S:X'="Y" Y < 76 ;;S:$$DGERCK^DGRPCE1("74^75",.DGER) Y="@7607";S:'$$YN < 76000 ;;S:'$$YN^DGRPCE1(.322019) Y="@7603";.322019;S:X'="Y" < 76001 ;;S:'$$YN^DGRPCE1(.3224) Y="@7605";.3224;S:X'="Y" Y=" < 76002 ;;S:'$$YN^DGRPCE1(.32201) Y="@7607";.32201;S:X'="Y" Y < 77 ;;S:(($$DGERCK^DGRPCE1("37^38",.DGER))!('$$YN^DGRPCE1 < 78 ;;S:(($$DGERCK^DGRPCE1("39^40^68",.DGER))!('$$YN^DGRP < 79 ;;S:$$DGERCK^DGRPCE1("72^73",.DGER) Y="@7902";.325;.3 < 80 ;;S:(($$DGERCK^DGRPCE1("37^38^77",.DGER))!('$$YN^DGRP < 80000 ;;.325;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8002 < 81 ;;S:(($$DGERCK^DGRPCE1("39^40^78",.DGER))!('$$YN^DGRP < 81000 ;;.325;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8102 < 82 ;;S:($$DGERCK^DGRPCE1("74^75^76",.DGER)) Y="@8207";S: < 82000 ;;S:X'="Y" Y="@8202";.322017;.322018;@8202;S:'$$YN^DG < 82001 ;;S:X'="Y" Y="@8204";.3222;.3223;@8204;S:'$$YN^DGRPCE < 82002 ;;.3228;.3229;@8206;S:'$$YN^DGRPCE1(.32201) Y="@8207" < 82003 ;;.325;.326;.327;.324;S:'$$YN^DGRPCE1(.3285) Y="@8208 < 83 ;;S:$$DGERCK^DGRPCE1(73,.DGER) Y="@83";@8295;.325;S:X < 83000 ;;.3285//NO;S:X'="Y" Y="@83";.3291;S:X']"" Y="@83";S: < 83001 ;;.32945//NO;S:X'="Y" Y="@83";.3296;S:X']"" Y="@83";S < 84 ;;.3214; < 85 ;;1901; < 86 ;;1901; < ; < YN(FLD,DFN,FILE) ; return binary for YES/NO flds in th < N RTN < Q:$G(FLD)']"" "" < S:$G(FILE)="" FILE=2 S:$G(DFN)="" DFN=$G(DA) Q:$G(DFN < S RTN=$$GET1^DIQ(FILE,DFN_",",FLD,"I") < Q $S(RTN=1:1,RTN=0:0,RTN="Y":1,RTN="N":0,1:"") < ; < DGERCK(STR,DGER) ;do any of the STR errors exist in DG < N RTN,X < Q:$G(STR)']"" 0 Q:$G(DGER)']"" 0 < S RTN=0 F X=1:1 Q:RTN!($P(STR,"^",X)="") I DGER[("," < Q RTN < diff -y --suppress-common-lines ./VADemo/r1/DGRPCE.m ./VADemo/r2/r/DGRPCE.m DGRPCE ;ALB/MRL,KV,PJR,BRM - CONSISTENCY CHECKER, EDIT INCON | DGRPCE ;ALB/MRL,KV - CONSISTENCY CHECKER, EDIT INCONSISTENCI ;;5.3;Registration;**121,122,175,297,342,451,626**;Au | ;;5.3;Registration;**121,122,175,297,342**;Aug 13, 19 S DGEK=0 F I=9,10,11,12,13,14,18,19,20,22,24,36,51 Q: | S DGEK=0 F I=9,10,11,12,13,14,18,19,20,21,22,24,36,51 Q K %,C,DA,DGASK,DGCCF,DGCT1,DGCT2,DGCT3,DGD,DGD1,DGD2, | Q K %,C,DA,DGASK,DGCCF,DGCT1,DGCT2,DGCT3,DGD,DGD1,DGD2, K DGCOMLOC,DGCOMBR,FRDT,DGFRDT < D KVAR^VADPT < ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31, | ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,22,24,29,30, 26 ;; | 26 ;;.32101;S:X'="Y" Y="@26";I DGVTYN'="Y" W !,"Patient 27 ;; | 27 ;;.32102;S:X'="Y" Y="@27";I DGVTYN'="Y" W !,"Patient 28 ;; | 28 ;;.32103;S:X'="Y" Y="@28";I DGVTYN'="Y" W !,"Patient 33 ;; | 33 ;;.36265;S:X'="Y" Y="@33";I DGVTYN'="Y" W !,"Patient 35 ;; | 35 ;;.5291;S:X'="Y" Y="@35";I DGVTYN'="Y" W !,"Patient n 43 ;; | 43 ;;.36205;S:X'="Y" Y="@43";.36295;@43; 44 ;; | 44 ;;.36215;S:X'="Y" Y="@44";.36295;@44; 45 ;; | 45 ;;.36235;S:X'="Y" Y="@45";.36295;@45; diff -y --suppress-common-lines ./VADemo/r1/DGRPC.m ./VADemo/r2/r/DGRPC.m DGRPC ;ALB/MRL/PJR/PHH/EG - CHECK CONSISTENCY OF PATIENT DA | DGRPC ;ALB/MRL - CHECK CONSISTENCY OF PATIENT DATA ; 3/27/0 ;;5.3;Registration;**108,121,314,301,470,489,505,451, | ;;5.3;Registration;**108,121,314,301,470**;Aug 13, 19 N ANYMSE,CONARR,CONCHK,CONERR,CONSPEC,LOC < N MSECHK,MSESET,MSERR,MSDATERR,RANGE,RANSET < F I=0,.13,.141,.22,.24,.3,.31,.311,.32,.321,.322,.33, | F I=0,.13,.22,.3,.31,.311,.32,.321,.322,.33,.35,.36,. 17 K DGDATE,DGTIME | 17 K DGDATE,DGTIME S I1=0 I +DGP(.35) S DGD=DT F I=0:0 S N SDARRAY,SDCLIEN,SDDATE < S I1=0,DGD=DT < S SDARRAY("FLDS")=3 < S SDARRAY(4)=DFN < I +DGP(.35),$$SDAPI^SDAMA301(.SDARRAY) D < .;if there is data hanging from the 101 subscript, < .;then this is a valid appointment < .;otherwise it is an error eg 01/21/2005 < .I $D(^TMP($J,"SDAMA301",101))=1 Q < .S SDCLIEN=0 < .F S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:' < ..S SDDATE=0 < ..F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDAT < ...S X=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)," < ...I X=""!(X="I") S I1=1 < K ^TMP($J,"SDAMA301") < S:'+DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_" | S:'+DGLST DGLST="END^DGRPC2" I +DGLST S DGLST=DGLST_" S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER | S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER diff -y --suppress-common-lines ./VADemo/r1/DGRPDB.m ./VADemo/r2/r/DGRPDB.m ;;5.3;Registration;**26,50,358,570**;Aug 13, 1993 | ;;5.3;Registration;**26,50,358**;Aug 13, 1993 N DGINS | S C=$S($D(^DPT(DFN,.312,0)):$P(^(0),"^",4),1:0),C=C+6 I $$INSUR^IBBAPI(DFN,"","AR",.DGINS,1) < S C="",C=$O(DGINS("IBBAPI","INSUR",C),-1),C=+C+6 < W !!," Health Insurance: " | W !!," Health Insurance: " S Z=$$INSURED^IBCNS1(DF S Z=$$INSUR^IBBAPI(DFN,$S($D(DGINSDT):DGINSDT,1:DT)) | D DISP^IBCNSP2 W $S(Z:"YES",1:"NO") < D DISP^DGIBDSP < IN ; Old code | IN W !?3,$S($D(^DIC(36,+$P(DGX,"^",1),0)):$E($P(^(0),"^" > W ?71,$S($P(DGX,"^",6)="v":"APPLICANT",$P(DGX,"^",6)= diff -y --suppress-common-lines ./VADemo/r1/DGRPDD1.m ./VADemo/r2/r/DGRPDD1.m DGRPDD1 ;ALB/JDS - INPUT SYNTAX CHECKS - FORMERLY DGINP ; 9/2 | DGRPDD1 ;ALB/JDS - INPUT SYNTAX CHECKS - FORMERLY DGINP ; 25 ;;5.3;Registration;**72,136,244,621**;AUG 13, 1993 | ;;5.3;Registration;**72,136**;AUG 13, 1993 I X["P",'$D(DPTZNV) D PSEU I X'=L K X,L W:'$D(ZTQUEUE | I X["P" D PSEU I X'=L K X,L W:'$D(ZTQUEUED) *7," Inv I X["P",$D(DPTZNV) D PSEU I X'=L S X=L W:'$D(ZTQUEUED < ; DG*5.3*621 < I DOB="" S DOB=2000000 < diff -y --suppress-common-lines ./VADemo/r1/DGRPD.m ./VADemo/r2/r/DGRPD.m DGRPD ;ALB/MRL/MLR/JAN/LBD/EG-PATIENT INQUIRY (NEW) ; 1/20/ | DGRPD ;ALB/MRL/MLR/JAN-PATIENT INQUIRY (NEW) ; 03/22/02 ;;5.3;Registration;**109,124,121,57,161,149,286,358,4 | ;;5.3;Registration;**109,124,121,57,161,149,286,358,4 ; *545* Add death information near the remarks fiel < SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC | SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0) | K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0) W ?1,"Address: ",$S($D(DGA(1)):DGA(1),1:"NONE ON FILE | W "Address: ",$S($D(DGA(1)):DGA(1),1:"NONE ON FILE"), S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) | S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGC | S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGC W ?42,"From/To: ",X,!?3,"Phone: ",$S($P(DGRP(.13),U,1 | W ?42,"From/To: ",X,!?2,"Phone: ",$S($P(DGRP(.13),U,1 W !?2,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13) | W !?1,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13) W !,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$$BADADR^ < D CA < I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32) < I 'DGABBRV W ! D < .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF < .K ^UTILITY($J,"W") < .S PTR=0 F S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR D < ..S VAL=+$G(^DPT(DFN,.02,PTR,0)) < ..Q:$$INACTIVE^DGUTL4(VAL,1) < ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,P < ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP < .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1, < .K ^UTILITY($J,"W") < .S PTR=0 F S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR D < ..S VAL=+$G(^DPT(DFN,.06,PTR,0)) < ..Q:$$INACTIVE^DGUTL4(VAL,2) < ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,P < ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP < .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETH < .K ^UTILITY($J,"W") < .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0 < .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0)) W !,?9,$G < I '$$OKLINE(16) G Q < I $G(DGPRFLG)=1 G Q:'$$OKLINE(19) D | I $G(DGPRFLG)=1 D . S DGPTM=$$PCTEAM^DGSDUTL(DFN) | . S DGPTM=$$OUTPTTM^SDUTL3(DFN) G Q:'$$OKLINE(14) < ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W ! | I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W ! D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518) < CA ;Confidential Address < W !!?1,"Confidential Address: ",?44,"Confidential Ad < N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR < S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U, < I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND43) < W !?1,"From/To: ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAE < Q < ; | S CT=0 W !!,"Future Appointments: " I $O(^DPT(DFN,"S" N DGARRAY,SDCNT < S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1 < S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future < ;if there is lower subscripts hanging from the 101 no < ;then it is a valid appointment, otherwise it is < ;an error eg 01/20/2005 < I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Databa < I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK < ; < F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:' | F FA=DT:0 S FA=$O(^DPT(DFN,"S",FA)) G RMK:'FA S L=^(F .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3), | .N DGAPPT .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" | .S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z") ..D COV | .W !?22,$P(DGAPPT,"@") ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z") | .W ?33,$P(DGAPPT,"@",2) ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2) | .W ?39,$P($S($D(^SC(C,0)):^(0),1:""),"^")," ",COV ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2), | .Q ..Q | I $O(^DPT(DFN,"S",FA))>0 W !,"See Scheduling options I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Schedulin < D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHI | K ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y kil W !! < W "Date of Death Information" < W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351," < W !,?5,"Date of Death Source of Notification: ",$G(PD < W !,?5,"Date of Death Last Updated Date/Time: ",$G(PD < W !,?5,"Date of Death Last Edited By: ",$G(PDTHINFO(2 < K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN < COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Co | COV S COV=$S($P(L,"^",7)=7:" (Collateral) ",1:""),COV=COV S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N < Only in ./VADemo/r1/: DGRPDT.m diff -y --suppress-common-lines ./VADemo/r1/DGRPE1.m ./VADemo/r2/r/DGRPE1.m DGRPE1 ;ALB/MRL,RTK,BRM,RGL - REGISTRATIONS EDITS (CONTINUED | DGRPE1 ;ALB/MRL,RTK - REGISTRATIONS EDITS (CONTINUED) ;06 JU ;;5.3;Registration;**114,327,451**;Aug 13, 1993 | ;;5.3;Registration;**114,327**;Aug 13, 1993 1104 ;;S:$S('$D(^DPT(DFN,"VET")):0,^("VET")="Y":1,1:0) Y=" | 1104 ;;S:$S('$D(^DPT(DFN,"VET")):0,^("VET")="Y":1,1:0) Y=" MSG W !,"Patient is not a veteran. Can't enter rated dis < ; < BULL ; Rated Disabilities update bulletin < N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT, < 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 < S XMTEXT="DGBULL(" < S XMSUB="RATED DISABILITY UPDATED" < S DGLINE=0 < D LINE^DGEN("Patient: "_DGNAME,.DGLINE) < D LINE^DGEN("SSN: "_DGSSN,.DGLINE) < D LINE^DGEN("",.DGLINE) < D LINE^DGEN("Send updates to SC Disabilities to HEC v < D LINE^DGEN("Outlook mail group so that they can be e < D LINE^DGEN("Authoritative Database. SC Disability i < D LINE^DGEN("into VistA may be overlaid.",.DGLINE) < D ^XMD < Q < diff -y --suppress-common-lines ./VADemo/r1/DGRPE.m ./VADemo/r2/r/DGRPE.m DGRPE ;ALB/MRL,LBD - REGISTRATIONS EDITS ; 10/26/04 11:19am | DGRPE ;ALB/MRL - REGISTRATIONS EDITS ; 10/27/00 12:40pm ;;5.3;Registration;**32,114,139,169,175,247,190,343,3 | ;;5.3;Registration;**32,114,139,169,175,247,190,343,3 K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0 | K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0 F I=1:1 S J=$P(DGDR,",",I) Q:J="" F J1=J,J*1000,J*10 < ;check for Combat Vet status < I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D < . W !!,"**NOTE-Change(s) made in this session deleted < . S DIR(0)="EA" D ^DIR K DIR < Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J | Q K DA,DIE,DR,DGCT,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1 101 ;;K DG20NAME;.01;.01///^S X=$$NCEDIT^DPTNAME(DFN,,.DG | 101 ;;.01;.09;.03; 104 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG); | 104 ;;S DIE("NO^")="OUTOK";.111;S:X="" Y="@1112";.112;S:X 111 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";. | 109 ;;S DIE("NO^")="OUTOK";.111;S:X="" Y="@1112";.112;S:X 111000 ;;K DR(2,2.141);.1411;I X']"" W !?4,$C(7),"I need at < 109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);. < 203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2. | 203 ;;D 203DR^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2. 303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33 | 303 ;;N DGX1;I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),"^",1)'] 303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']" | 303000 ;;I $G(DGX1) S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^( 303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331// | 304 ;;.3311;S:X']"" Y="@34";.3312;.3313;S:X']"" Y=.3316;. 303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336 | 305 ;;N DGX1;I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),"^",1)'] 304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;. | 305000 ;;I $G(DGX1)&($D(^DPT(DFN,.22))) S $P(^(.22),U,2)=$P( 305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37 < 305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" < 305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341/ < 305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346/ < 601 ;;.325;S:X']"" Y="@61";S:$$FV^DGRPMS(X)'=1 Y=".328";. | 601 ;;.325;S:X']"" Y="@61";.328;.326;.327;.324;.3285//NO; 601000 ;;.3285//NO;S:X'="Y" Y="@61";.3291;S:X']"" Y="@61";S: < 601001 ;;.32945//NO;S:X'="Y" Y="@61";.3296;S:X']"" Y="@61";S < DR109 ;Drop through (use same logic as DR203) | 109DR ;Drop through (use same logic as 203DR) DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(D | 203DR S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(D DR111 ;Set DR string for Confidential Address categories < S DR(2,2.141)=".01;1//YES;" < Q < diff -y --suppress-common-lines ./VADemo/r1/DGRPH.m ./VADemo/r2/r/DGRPH.m ;;5.3;Registration;**114,343,397,415,489,545**;Aug 13 | ;;5.3;Registration;**114,343,397,415**;Aug 13, 1993 S Z="DATA GROUPS ON SCREEN "_DGRPS,DGRPCM=1 W ! D WW^ | S Z="DATA GROUPS ON SCREEN "_DGRPS,DGRPCM=1 W ! D WW^ A1 S X="Confidential Address,Dates and Types" Q | 2 S X="Sex, POB, Parents, etc.^Dates/Locations of Previ 2 S X="Sex, POB, Parents, etc.^Dates/Locations of Previ < S X="Demographic^Confidential Address^Patient^Contact | S X="Demographic^Patient^Contact^Employment^Insurance S X=X_"Admission Info^Application Info^Appointment In | S C=0 F I=1:1 S J=$P(X,"^",I) Q:J="" I '$E(DGRPVV,I) ;S C=0 F I=1:1 S J=$P(X,"^",I) Q:J="" I '$E(DGRPVV,I < N DGJ < S DGJ="" < S C=0 F I=1:1 S DGJ=$O(DGRPVV(DGJ)) Q:DGJ="" I '$E(D < .S C=C+1,Z="^"_DGJ,DGRPW=(C#2) < .D WW^DGRPV < .S Z1=$S((C#2)&(DGJ?1N):36,(C#2):35,1:1) < .S Z=$S(DGJ?1N:" ",1:" ")_$P(X,U,I)_" Data" < .D WW1^DGRPV:(C#2) < .I '(C#2) W Z < Only in ./VADemo/r1/: DGRPMS.m diff -y --suppress-common-lines ./VADemo/r1/DGRPP1.m ./VADemo/r2/r/DGRPP1.m ;;5.3;Registration;**489,508**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 S X=+$E(DGRPANN,2,99) I $D(DGRPVV(X)) S X1=$E(DGRPVV, | S X=+$E(DGRPANN,2,99),X1=$E(DGRPVV,X) I X1]"",'X1 G @ S Z="INVALID SCREEN NUMBER...VALID SCREENS ARE " F I= | S Z="INVALID SCREEN NUMBER...VALID SCREENS ARE " F I= G:DGRPS'=1.1 @("^DGRP"_DGRPS) G:DGRPS=1.1 ^DGRPCADD | G @("^DGRP"_DGRPS) ;return to same screen diff -y --suppress-common-lines ./VADemo/r1/DGRPP.m ./VADemo/r2/r/DGRPP.m ;;5.3;Registration;**92,147,343,404,397,489**;Aug 13, | ;;5.3;Registration;**92,147,343,404,397**;Aug 13, 199 JUMP G JUMP^DGRPP1:DGRPANN?1"^"1N.".".1N I DGRPOUT!(DGRPAN | JUMP G JUMP^DGRPP1:DGRPANN?1"^"1N.N I DGRPOUT!(DGRPANN?1"^ I DGRPANN'?1N.E D ^DGRPH G:DGRPS'=1.1 @("^DGRP"_DGRPS | I DGRPANN'?1N.E D ^DGRPH G @("^DGRP"_DGRPS) F I=DGRPS+1:1 S J=$E(DGRPVV,I) Q:J']"" I 'J S X=I Q | F I=DGRPS+1:1 S J=$E(DGRPVV,I) Q:J']"" I 'J S X=I Q I DGRPS=1 S X=1.1 < I X[".",X'=1.1 S X=$P(X,".",1) | G @("^DGRP"_X) ;goto next available screen G:X=1.1 ^DGRPCADD < G:X'=1.1 @("^DGRP"_X) ;goto next available screen < diff -y --suppress-common-lines ./VADemo/r1/DGRPTL3.m ./VADemo/r2/r/DGRPTL3.m ;;5.3;Registration;**108,570**;08/13/93 | ;;5.3;Registration;**108**;08/13/93 N DGX | D ALL^IBCNS1(DFN,"DGINS") I $$INSUR^IBBAPI(DFN,"","AR",.DGX,"*") | S I=0 F S I=$O(DGINS(I)) Q:'I S DGINS=DGINS(I,0) D M DGINS=DGX("IBBAPI","INSUR") < S I=0 F S I=$O(DGINS(I)) Q:'I D < . D SET^DGRPTL1(DGARY,DGLINE,$P(DGINS(I,1),U,2),1,.DG | . D SET^DGRPTL1(DGARY,DGLINE,$S($D(^DIC(36,+DGINS,0)) . D SET^DGRPTL1(DGARY,DGLINE,$E(DGINS(I,14),1,16),20, | . D SET^DGRPTL1(DGARY,DGLINE,$E($P(DGINS,U,2),1,16),2 . N DGGRP S DGGRP=$G(DGINS(I,18)) | . D SET^DGRPTL1(DGARY,DGLINE,$E($$GRP^IBCNS($P(DGINS, . I DGGRP']"" S DGGRP=$P($G(DGINS(I,8)),U,2) | . S X=$P(DGINS,U,6) D SET^DGRPTL1(DGARY,DGLINE,$S(X=" . D SET^DGRPTL1(DGARY,DGLINE,$E(DGGRP,1,10),38,.DGCNT | . D SET^DGRPTL1(DGARY,DGLINE,$S($P(DGINS,U,8)'="":$$F . D SET^DGRPTL1(DGARY,DGLINE,$P(DGINS(I,12),U,2),50,. | . D SET^DGRPTL1(DGARY,DGLINE,$S($P(DGINS,U,4)'="":$$F . D SET^DGRPTL1(DGARY,DGLINE,$S(DGINS(I,10)'="":$$FDA < . D SET^DGRPTL1(DGARY,DGLINE,$S(DGINS(I,11)'="":$$FDA < diff -y --suppress-common-lines ./VADemo/r1/DGRPT.m ./VADemo/r2/r/DGRPT.m DGRPT ;ALB/RMO-10-10T Registration ; 2/20/03 12:05pm | DGRPT ;ALB/RMO-10-10T Registration ;21 NOV 1996 ;;5.3;Registration;**108,149,425**;Aug 13, 1993 | ;;5.3;Registration;**108,149**;Aug 13, 1993 ;check to see if CIRN PD/MPI is installed < ; < I $G(DGNEWPF) D < . ; query CMOR for Patient Record Flag Assignments if < . ; display results. < . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN) < ; < ; < diff -y --suppress-common-lines ./VADemo/r1/DGRPTP2.m ./VADemo/r2/r/DGRPTP2.m ;;5.3;Registration;**108,570**;08/13/93 | ;;5.3;Registration;**108**;08/13/93 ; Modified for IBBAPI call to rtn ins info, DG*570 < N C,DGINS,DGRP,I,Y,DGX,DGDATA,DGIBAPI | N C,DGINS,DGRP,I,Y S Y=$$GET1^DIQ(2,DFN,.3192) | S DGRP(.31)=$G(^DPT(DFN,.31)) ;insurance > S Y=$P(DGRP(.31),U,11),C=$P(^DD(2,.3192,0),U,2) D Y^D S DGIBAPI=$$INSUR^IBBAPI(DFN,DT,"",.DGDATA,1) | D ALL^IBCNS1(DFN,"DGINS",1,DT) S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGINS=@DGX | S (C,I)=0 F S I=$O(DGINS(I)) Q:'I S DGINS=DGINS(I,0 S (C,I)=0 F S I=$O(DGINS(I)) Q:'I S DGINS=DGINS(I,1 < . W ?40,"| ",$P(DGINS,U,2) | . W ?40,"| ",$$POINT^DG1010P0(DGINS,1,36) diff -y --suppress-common-lines ./VADemo/r1/DGRPTU.m ./VADemo/r2/r/DGRPTU.m DGRPTU ;ALB/RMO - 10-10T Registration - Utilities; 04/25/200 | DGRPTU ;ALB/RMO - 10-10T Registration - Utilities;21 NOV 199 ;;5.3;Registration;**108,513**;08/13/93 | ;;5.3;Registration;**108**;08/13/93 W !! D ^DIC S DFN=+Y,DGNEWPF=$P(Y,U,3) N Y W ! D PAUS | W !! D ^DIC S DFN=+Y,DGNEWPF=$P(Y,U,3) diff -y --suppress-common-lines ./VADemo/r1/DGRPTX10.m ./VADemo/r2/r/DGRPTX10.m DGRPTX10 ; ;07/02/04 | DGRPTX10 ; ;02/04/03 S X=DE(8),DIC=DIE | S X=DE(6),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(6),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(6),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".132;" D AVAFC^VA > S X=DE(6),DIC=DIE > S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/DGRPTX11.m ./VADemo/r2/r/DGRPTX11.m DGRPTX11 ; ;07/02/04 | DGRPTX11 ; ;02/04/03 > S X=DG(DQ),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DG(DQ),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DG(DQ),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".132;" D AVAFC^VA > I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ diff -y --suppress-common-lines ./VADemo/r1/DGRPTX12.m ./VADemo/r2/r/DGRPTX12.m DGRPTX12 ; ;07/02/04 | DGRPTX12 ; ;02/04/03 D DE G BEGIN | S X=DE(7),DIC=DIE DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".05;" D AVAFC^VAF I $D(^(.21)) S %Z=^(.21) S %=$P(%Z,U,3) S:%]"" DE(3)= | S X=DE(7),DIC=DIE I S %=$P(%Z,U,11) S:%]"" DE(12)=% < I $D(^(.22)) S %Z=^(.22) S %=$P(%Z,U,7) S:%]"" DE(10) < I $D(^(.33)) S %Z=^(.33) S %=$P(%Z,U,10) S:%]"" DE(15 < 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGRPTX12",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".21;10",DV="RSX",DU= < S DU="Y:YES;N:NO;" < S Y="NO" < G Y < X1 I $D(X),X="Y" S DFN=DA D K1^DGLOCK2 < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011 < Q < 3 S DW=".21;3",DV="FX",DU="",DLB="K-STREET ADDRESS [LIN < S DE(DW)="C3^DGRPTX12" < G RE < C3 G C3S:$D(DE(3))[0 K DB < S X=DE(3),DIC=DIE < X "S DGXRF=.213 D ^DGDDC Q" < S X=DE(3),DIC=DIE < C3S S X="" G:DG(DQ)=X C3F1 K DB | S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET S X=DG(DQ),DIC=DIE < ; < S X=DG(DQ),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C3F1 Q < X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 S:X="" Y=.216 < Q < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".21;4",DV="FX",DU="" < S DE(DW)="C5^DGRPTX12" < G RE < C5 G C5S:$D(DE(5))[0 K DB < S X=DE(5),DIC=DIE < X "S DGXRF=.214 D ^DGDDC Q" < S X=DE(5),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C5S S X="" G:DG(DQ)=X C5F1 K DB < S X=DG(DQ),DIC=DIE < ; < S X=DG(DQ),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C5F1 Q < X5 K:X[""""!($A(X)=45) X I $D(X) 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 D:$D(DIEFIRE)#2 < X6 S:X="" Y=.216 < Q < 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".21;5",DV="FX",DU="" < G RE < X7 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2 < I $D(X),X'?.ANP K X < Q < ; < 8 S DW=".21;6",DV="FX",DU="",DLB="K-CITY",DIFLD=.216 < S DE(DW)="C8^DGRPTX12" < G RE < C8 G C8S:$D(DE(8))[0 K DB < S X=DE(8),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C8S S X="" G:DG(DQ)=X C8F1 K DB < S X=DG(DQ),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C8F1 Q < X8 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2 < I $D(X),X'?.ANP K X < Q < ; < 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".21;7",DV="P5'X",DU= < S DE(DW)="C9^DGRPTX12" < S DU="DIC(5," < G RE < C9 G C9S:$D(DE(9))[0 K DB < S X=DE(9),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C9S S X="" G:DG(DQ)=X C9F1 K DB < S X=DG(DQ),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C9F1 Q < X9 I $D(X) S DFN=DA D K1^DGLOCK2 < Q < ; < 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".22;7",DV="FOX",DU= < S DQ(10,2)="S Y(0)=Y D ZIPOUT^VAFADDR" < S DE(DW)="C10^DGRPTX12" < G RE < C10 G C10S:$D(DE(10))[0 K DB < S X=DE(10),DIC=DIE < D KILL^DGREGDD1(DA,.218,.21,8,$E(X,1,5)) < C10S S X="" G:DG(DQ)=X C10F1 K DB < S X=DG(DQ),DIC=DIE < D SET^DGREGDD1(DA,.218,.21,8,$E(X,1,5)) < C10F1 Q < X10 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D K1^DGLOCK2 I < I $D(X),X'?.ANP K X < Q < ; < 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".21;9",DV="FXa",DU= < S DE(DW)="C11^DGRPTX12" < G RE < C11 G C11S:$D(DE(11))[0 K DB < S X=DE(11),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VA < S X=DE(11),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < S X=DE(11),DIIX=2_U_DIFLD D AUDIT^DIET < C11S S X="" G:DG(DQ)=X C11F1 K DB < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VA < S X=DG(DQ),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < I $D(DE(11))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D < C11F1 Q < X11 K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D K1^DGLOCK2 < I $D(X),X'?.ANP K X < Q < ; < 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".21;11",DV="F",DU=" < G RE < X12 K:$L(X)>20!($L(X)<4) X < I $D(X),X'?.ANP K X < Q < ; < 13 S DQ=14 ;@30 < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),U,1)="":1,1:0) S < Q < 15 S DW=".33;10",DV="RSX",DU="",DLB="E-EMER. CONTACT SAM < S DU="Y:YES;N:NO;" < S Y="NO" < G Y < X15 I $D(X),X="Y" D K1^DGLOCK2 < Q < ; < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 I X'="Y" S Y=.331 < Q < 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) < X17 S X=$S($D(^DPT(DA,.21)):^(.21),1:"") S:X'="" ^(.33)=$ < Q < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7) < Q < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 S Y=.33011 < Q < 20 D:$D(DG)>9 F^DIE17 G ^DGRPTX13 < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX13.m ./VADemo/r2/r/DGRPTX13.m DGRPTX13 ; ;07/02/04 | DGRPTX13 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, < I $D(^(.22)) S %Z=^(.22) S %=$P(%Z,U,1) S:%]"" DE(11) < I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,5) S:%]"" DE(15) < I $D(^(.33)) S %Z=^(.33) S %=$P(%Z,U,1) S:%]"" DE(1)= < I S %=$P(%Z,U,9) S:%]"" DE(12)=% S %=$P(%Z,U,11) S:% < I $D(^(.52)) S %Z=^(.52) S %=$P(%Z,U,5) S:%]"" DE(17) < I $D(^(.53)) S %Z=^(.53) S %=$P(%Z,U,1) S:%]"" DE(19) < 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGRPTX13",DQ=1 < 1 S DW=".33;1",DV="F",DU="",DLB="E-NAME",DIFLD=.331 < S DE(DW)="C1^DGRPTX13",DE(DW,"INDEX")=1 < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < X "S DGXRF=.331 D ^DGDDC Q" < C1S S X="" G:DG(DQ)=X C1F1 K DB < ; | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".05;" D AVAFC^VAF C1F1 N X,X1,X2 S DIXR=225 D C1X1(U) K X2 M X2=X D C1X1("O" < I $G(X(1))]"" D < . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1 D DELCOMP^X < K X M X=X2 I $G(X(1))]"" D < . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1,DG20NAME=X < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.331,DION),$P($G(^DP < S X=$G(X(1)) < Q < C1F2 Q < X1 K:$L(X)>35!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NA < I $D(X),X'?.ANP K X < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S:X="" Y="@40" < Q < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".33;2",DV="FX",DU="" < G RE < X3 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D E1^DGLOCK2 < I $D(X),X'?.ANP K X < Q < ; < 4 S DW=".33;3",DV="FX",DU="",DLB="E-STREET ADDRESS [LIN < S DE(DW)="C4^DGRPTX13" < G RE < C4 G C4S:$D(DE(4))[0 K DB < S X=DE(4),DIC=DIE < X "S DGXRF=.333 D ^DGDDC Q" < C4S S X="" G:DG(DQ)=X C4F1 K DB < ; | D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) C4F1 Q | I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 S:X="" Y=.336 < Q < 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".33;4",DV="FX",DU="" < S DE(DW)="C6^DGRPTX13" < G RE < C6 G C6S:$D(DE(6))[0 K DB < S X=DE(6),DIC=DIE < X "S DGXRF=.334 D ^DGDDC Q" < C6S S X="" G:DG(DQ)=X C6F1 K DB < S X=DG(DQ),DIC=DIE < ; < C6F1 Q < X6 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 < X7 S:X="" Y=.336 < Q < 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".33;5",DV="FX",DU="" < G RE < X8 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2 < I $D(X),X'?.ANP K X < Q < ; < 9 S DW=".33;6",DV="FX",DU="",DLB="E-CITY",DIFLD=.336 < G RE < X9 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2 < I $D(X),X'?.ANP K X < Q < ; < 10 S DW=".33;7",DV="P5'X",DU="",DLB="E-STATE",DIFLD=.337 < S DU="DIC(5," < G RE < X10 I $D(X) S DFN=DA D E1^DGLOCK2 < Q < ; < 11 S DW=".22;1",DV="FOX",DU="",DLB="E-ZIP+4",DIFLD=.2201 < S DQ(11,2)="S Y(0)=Y D ZIPOUT^VAFADDR" < S DE(DW)="C11^DGRPTX13" < G RE < C11 G C11S:$D(DE(11))[0 K DB < S X=DE(11),DIC=DIE < D KILL^DGREGDD1(DA,.338,.33,8,$E(X,1,5)) < C11S S X="" G:DG(DQ)=X C11F1 K DB < S X=DG(DQ),DIC=DIE < D SET^DGREGDD1(DA,.338,.33,8,$E(X,1,5)) < C11F1 Q < X11 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D E1^DGLOCK2 I < I $D(X),X'?.ANP K X < Q < ; < 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".33;9",DV="FX",DU=" < G RE < X12 K:$L(X)>20!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2 < I $D(X),X'?.ANP K X < Q < ; < 13 S DW=".33;11",DV="F",DU="",DLB="E-WORK PHONE NUMBER", < G RE < X13 K:$L(X)>20!($L(X)<4) X < I $D(X),X'?.ANP K X < Q < ; < 14 S DQ=15 ;@40 < 15 S DW=".32;5",DV="P23'X",DU="",DLB="SERVICE BRANCH [LA < S DE(DW)="C15^DGRPTX13" < S DU="DIC(23," < G RE < C15 G C15S:$D(DE(15))[0 K DB < S X=DE(15),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < C15S S X="" G:DG(DQ)=X C15F1 K DB < S X=DG(DQ),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < C15F1 Q < X15 S DFN=DA D SV^DGLOCK Q < Q < ; < 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".32;8",DV="FX",DU=" < G RE < X16 S DFN=DA D SV^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT < I $D(X),X'?.ANP K X < Q < ; < 17 S DW=".52;5",DV="RSX",DU="",DLB="POW STATUS INDICATED < S DE(DW)="C17^DGRPTX13" < S DU="Y:YES;N:NO;U:UNKNOWN;" < G RE < C17 G C17S:$D(DE(17))[0 K DB < S X=DE(17),DIC=DIE < ; < S X=DE(17),DIC=DIE < ; < S X=DE(17),DIC=DIE < ; < S X=DE(17),DIC=DIE < D AUTOUPD^DGENA2(DA) < S X=DE(17),DIC=DIE < X "S DFN=DA D EN^DGMTR K DGREQF" < C17S S X="" G:DG(DQ)=X C17F1 K DB < D ^DGRPTX14 < C17F1 Q < X17 S DFN=DA D SV^DGLOCK < Q < ; < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 I $P($G(^DPT(DFN,.53)),U)]"" S Y="@53" < Q < 19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW=".53;1",DV="SX",DU=" < S DE(DW)="C19^DGRPTX13" < S DU="Y:YES;N:NO;" < G RE < C19 G C19S:$D(DE(19))[0 K DB < D ^DGRPTX15 < C19S S X="" G:DG(DQ)=X C19F1 K DB < D ^DGRPTX16 < C19F1 Q < X19 S DFN=DA D VET^DGLOCK < Q < ; < 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) < X20 I X="Y" S Y="@532",DGPHMULT=1 < Q < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 I X="N" S Y="@533",DGPHMULT=1 < Q < 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) < X22 S:X="" Y="@53" < Q < 23 S DQ=24 ;@532 < 24 D:$D(DG)>9 F^DIE17 G ^DGRPTX17 < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX14.m ./VADemo/r2/r/DGRPTX14.m DGRPTX14 ; ;07/02/04 | DGRPTX14 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(8),DIC=DIE X ^DD(2,.525,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | X "S DGXRF=.211 D ^DGDDC Q" S X=DG(DQ),DIC=DIE | S X=DE(8),DIC=DIE X ^DD(2,.525,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".211;" D AVAFC^VA S X=DG(DQ),DIC=DIE | S X=DE(8),DIC=DIE X ^DD(2,.525,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) S X=DG(DQ),DIC=DIE | S X=DE(8),DIIX=2_U_DIFLD D AUDIT^DIET D AUTOUPD^DGENA2(DA) < S X=DG(DQ),DIC=DIE < X "S DFN=DA D EN^DGMTR K DGREQF" < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX15.m ./VADemo/r2/r/DGRPTX15.m DGRPTX15 ; ;07/02/04 | DGRPTX15 ; ;02/04/03 S X=DE(19),DIC=DIE | S X=DG(DQ),DIC=DIE K ^DPT("D",$E(X,1,30),DA) | ; S X=DE(19),DIC=DIE | S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".211;" D AVAFC^VA > S X=DG(DQ),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > I $D(DE(8))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ diff -y --suppress-common-lines ./VADemo/r1/DGRPTX16.m ./VADemo/r2/r/DGRPTX16.m DGRPTX16 ; ;07/02/04 | DGRPTX16 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, > I $D(^(.21)) S %Z=^(.21) S %=$P(%Z,U,2) S:%]"" DE(1)= > I S %=$P(%Z,U,10) S:%]"" DE(2)=% S %=$P(%Z,U,11) S:% > I $D(^(.22)) S %Z=^(.22) S %=$P(%Z,U,7) S:%]"" DE(11) > I $D(^(.33)) S %Z=^(.33) S %=$P(%Z,U,10) S:%]"" DE(16 > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="DGRPTX16",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".21;2",DV="FX",DU="" > S DE(DW)="C1^DGRPTX16" > G RE > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C1S S X="" G:DG(DQ)=X C1F1 K DB S ^DPT("D",$E(X,1,30),DA)="" | D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C1F1 Q > X1 K:$L(X)>30!($L(X)<1) X I $D(X) S DFN=DA D K1^DGLOCK2 > I $D(X),X'?.ANP K X > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".21;10",DV="RSX",DU= > S DU="Y:YES;N:NO;" > S Y="NO" > G Y > X2 I $D(X),X="Y" S DFN=DA D K1^DGLOCK2 > Q > ; > 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 > X3 I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011 > Q > 4 S DW=".21;3",DV="FX",DU="",DLB="K-STREET ADDRESS [LIN > S DE(DW)="C4^DGRPTX16" > G RE > C4 G C4S:$D(DE(4))[0 K DB > S X=DE(4),DIC=DIE > X "S DGXRF=.213 D ^DGDDC Q" > S X=DE(4),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C4S S X="" G:DG(DQ)=X C4F1 K DB D AUTOUPD^DGENA2(DA) | ; > S X=DG(DQ),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C4F1 Q > X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 > X5 S:X="" Y=.216 > Q > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".21;4",DV="FX",DU="" > S DE(DW)="C6^DGRPTX16" > G RE > C6 G C6S:$D(DE(6))[0 K DB > S X=DE(6),DIC=DIE > X "S DGXRF=.214 D ^DGDDC Q" > S X=DE(6),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C6S S X="" G:DG(DQ)=X C6F1 K DB > S X=DG(DQ),DIC=DIE > ; > S X=DG(DQ),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C6F1 Q > X6 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 > X7 S:X="" Y=.216 > Q > 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".21;5",DV="FX",DU="" > G RE > X8 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2 > I $D(X),X'?.ANP K X > Q > ; > 9 S DW=".21;6",DV="FX",DU="",DLB="K-CITY",DIFLD=.216 > S DE(DW)="C9^DGRPTX16" > G RE > C9 G C9S:$D(DE(9))[0 K DB > S X=DE(9),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C9S S X="" G:DG(DQ)=X C9F1 K DB > S X=DG(DQ),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C9F1 Q > X9 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2 > I $D(X),X'?.ANP K X > Q > ; > 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".21;7",DV="P5'X",DU > S DE(DW)="C10^DGRPTX16" > S DU="DIC(5," > G RE > C10 G C10S:$D(DE(10))[0 K DB > S X=DE(10),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C10S S X="" G:DG(DQ)=X C10F1 K DB > S X=DG(DQ),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > C10F1 Q > X10 I $D(X) S DFN=DA D K1^DGLOCK2 > Q > ; > 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".22;7",DV="FOX",DU= > S DQ(11,2)="S Y(0)=Y D ZIPOUT^VAFADDR" > S DE(DW)="C11^DGRPTX16" > G RE > C11 G C11S:$D(DE(11))[0 K DB > S X=DE(11),DIC=DIE > D KILL^DGREGDD1(DA,.218,.21,8,$E(X,1,5)) > C11S S X="" G:DG(DQ)=X C11F1 K DB > S X=DG(DQ),DIC=DIE > D SET^DGREGDD1(DA,.218,.21,8,$E(X,1,5)) > C11F1 Q > X11 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D K1^DGLOCK2 I > I $D(X),X'?.ANP K X > Q > ; > 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".21;9",DV="FXa",DU= > S DE(DW)="C12^DGRPTX16" > G RE > C12 G C12S:$D(DE(12))[0 K DB > S X=DE(12),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VA > S X=DE(12),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET > C12S S X="" G:DG(DQ)=X C12F1 K DB > S X=DG(DQ),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VA > S X=DG(DQ),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D > C12F1 Q > X12 K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D K1^DGLOCK2 > I $D(X),X'?.ANP K X > Q > ; > 13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".21;11",DV="F",DU=" > G RE > X13 K:$L(X)>20!($L(X)<4) X > I $D(X),X'?.ANP K X > Q > ; > 14 S DQ=15 ;@30 > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) > X15 I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),U,1)="":1,1:0) S > Q > 16 S DW=".33;10",DV="RSX",DU="",DLB="E-EMER. CONTACT SAM > S DU="Y:YES;N:NO;" > S Y="NO" > G Y > X16 I $D(X),X="Y" D K1^DGLOCK2 > Q > ; > 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) > X17 I X'="Y" S Y=.331 > Q > 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) > X18 S X=$S($D(^DPT(DA,.21)):^(.21),1:"") S:X'="" ^(.33)=$ > Q > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) > X19 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7) > Q > 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) > X20 S Y=.33011 > Q > 21 D:$D(DG)>9 F^DIE17 G ^DGRPTX17 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX17.m ./VADemo/r2/r/DGRPTX17.m DGRPTX17 ; ;07/02/04 | DGRPTX17 ; ;02/04/03 I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(12)=% | I $D(^(.22)) S %Z=^(.22) S %=$P(%Z,U,1) S:%]"" DE(11) I $D(^(.321)) S %Z=^(.321) S %=$P(%Z,U,2) S:%]"" DE(8 | I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,5) S:%]"" DE(15) I $D(^(.322)) S %Z=^(.322) S %=$P(%Z,U,13) S:%]"" DE( | I $D(^(.33)) S %Z=^(.33) S %=$P(%Z,U,1) S:%]"" DE(1)= I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,2) S:%]"" DE(11) | I S %=$P(%Z,U,9) S:%]"" DE(12)=% S %=$P(%Z,U,11) S:% I $D(^(.53)) S %Z=^(.53) S %=$P(%Z,U,2) S:%]"" DE(1)= | I $D(^(.52)) S %Z=^(.52) S %=$P(%Z,U,5) S:%]"" DE(17) > I $D(^(.53)) S %Z=^(.53) S %=$P(%Z,U,1) S:%]"" DE(19) 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".53;2",DV="S",DU="", | 1 S DW=".33;1",DV="F",DU="",DLB="E-NAME",DIFLD=.331 S DU="1:PENDING;2:IN PROCESS;3:CONFIRMED;" | G RE S X="PENDING" < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < K ^DPT("C",$E(X,1,30),DA) | X "S DGXRF=.331 D ^DGDDC Q" S ^DPT("C",$E(X,1,30),DA)="" | ; X1 Q | X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".53;4",DV="P4'",DU=" | I $D(X),X'?.ANP K X S DU="DIC(4," | Q S X=$$DIV^DGRPLE() < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X2 Q < 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 < X3 S Y="@53" < Q < 4 S DQ=5 ;@533 < 5 S DW=".53;3",DV="S",DU="",DLB="CURRENT PURPLE HEART R < S DU="1:UNACCEPTABLE DOCUMENTATION;2:NO DOCUMENTATION < S X="VAMC" < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X5 Q < 6 S DW=".53;4",DV="P4'",DU="",DLB="PH DIVISION",DIFLD=. < S DU="DIC(4," < S X=$$DIV^DGRPLE() < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X6 Q < 7 S DQ=8 ;@53 < 8 S DW=".321;2",DV="RSX",DU="",DLB="AGENT ORANGE EXPOS. < S DE(DW)="C8^DGRPTX17" < S DU="Y:YES;N:NO;U:UNKNOWN;" < G RE < C8 G C8S:$D(DE(8))[0 K DB < S X=DE(8),DIC=DIE < S X=DE(8),DIC=DIE | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 S:X="" Y="@40" > Q > 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".33;2",DV="FX",DU="" > G RE > X3 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D E1^DGLOCK2 > I $D(X),X'?.ANP K X > Q S X=DE(8),DIC=DIE | 4 S DW=".33;3",DV="FX",DU="",DLB="E-STREET ADDRESS [LIN > S DE(DW)="C4^DGRPTX17" > G RE > C4 G C4S:$D(DE(4))[0 K DB > S X=DE(4),DIC=DIE > X "S DGXRF=.333 D ^DGDDC Q" > C4S S X="" G:DG(DQ)=X C4F1 K DB > S X=DG(DQ),DIC=DIE S X=DE(8),DIC=DIE | C4F1 Q D AUTOUPD^DGENA2(DA) | X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X S X=DE(8),DIC=DIE | I $D(X),X'?.ANP K X > Q C8S S X="" G:DG(DQ)=X C8F1 K DB | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 S X=DG(DQ),DIC=DIE | X5 S:X="" Y=.336 X ^DD(2,.32102,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT | Q S X=DG(DQ),DIC=DIE | 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".33;4",DV="FX",DU="" X ^DD(2,.32102,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT | S DE(DW)="C6^DGRPTX17" S X=DG(DQ),DIC=DIE | G RE X ^DD(2,.32102,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT | C6 G C6S:$D(DE(6))[0 K DB S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE D AUTOUPD^DGENA2(DA) | X "S DGXRF=.334 D ^DGDDC Q" > C6S S X="" G:DG(DQ)=X C6F1 K DB X ^DD(2,.32102,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DPT | ; C8F1 Q | C6F1 Q X8 S DFN=DA D SV^DGLOCK | X6 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X > I $D(X),X'?.ANP K X 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".321;3",DV="RSX",DU= | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 S DE(DW)="C9^DGRPTX17" | X7 S:X="" Y=.336 S DU="Y:YES;N:NO;U:UNKNOWN;" | Q > 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".33;5",DV="FX",DU="" C9 G C9S:$D(DE(9))[0 K DB | X8 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2 S X=DE(9),DIC=DIE | I $D(X),X'?.ANP K X ; | Q S X=DE(9),DIC=DIE < S X=DE(9),DIC=DIE | 9 S DW=".33;6",DV="FX",DU="",DLB="E-CITY",DIFLD=.336 D AUTOUPD^DGENA2(DA) | G RE C9S S X="" G:DG(DQ)=X C9F1 K DB | X9 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2 S X=DG(DQ),DIC=DIE | I $D(X),X'?.ANP K X X ^DD(2,.32103,1,1,1.3) I X S X=DIV S Y(2)=";"_$S($D( < S X=DG(DQ),DIC=DIE < X ^DD(2,.32103,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA) < C9F1 Q < X9 S DFN=DA D SV^DGLOCK < 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".322;13",DV="RSX",D | 10 S DW=".33;7",DV="P5'X",DU="",DLB="E-STATE",DIFLD=.337 S DE(DW)="C10^DGRPTX17" | S DU="DIC(5," S DU="Y:YES;N:NO;U:UNKNOWN;" < C10 G C10S:$D(DE(10))[0 K DB | X10 I $D(X) S DFN=DA D E1^DGLOCK2 S X=DE(10),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3 < S X=DE(10),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3 < S X=DE(10),DIC=DIE < D AUTOUPD^DGENA2(DA) < C10S S X="" G:DG(DQ)=X C10F1 K DB < S X=DG(DQ),DIC=DIE < X ^DD(2,.322013,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DP < S X=DG(DQ),DIC=DIE < X ^DD(2,.322013,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DP < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA) < C10F1 Q < X10 S DFN=DA D SV^DGLOCK < 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".36;2",DV="RSX",DU= | 11 S DW=".22;1",DV="FOX",DU="",DLB="E-ZIP+4",DIFLD=.2201 > S DQ(11,2)="S Y(0)=Y D ZIPOUT^VAFADDR" S DU="0:NO;1:YES, RECEIVING MILITARY RETIREMENT;2:YES < ; | D KILL^DGREGDD1(DA,.338,.33,8,$E(X,1,5)) S X=DE(11),DIC=DIE < D AUTOUPD^DGENA2(DA) < X "S DFN=DA D EN^DGMTR K DGREQF" | D SET^DGREGDD1(DA,.338,.33,8,$E(X,1,5)) > C11F1 Q > X11 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D E1^DGLOCK2 I > I $D(X),X'?.ANP K X > Q > ; > 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".33;9",DV="FX",DU=" > G RE > X12 K:$L(X)>20!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2 > I $D(X),X'?.ANP K X > Q > ; > 13 S DW=".33;11",DV="F",DU="",DLB="E-WORK PHONE NUMBER", > G RE > X13 K:$L(X)>20!($L(X)<4) X > I $D(X),X'?.ANP K X > Q > ; > 14 S DQ=15 ;@40 > 15 S DW=".32;5",DV="P23'X",DU="",DLB="SERVICE BRANCH [LA > S DE(DW)="C15^DGRPTX17" > S DU="DIC(23," > G RE > C15 G C15S:$D(DE(15))[0 K DB > S X=DE(15),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > C15S S X="" G:DG(DQ)=X C15F1 K DB > S A1B2TAG="PAT" D ^A1B2XFR > C15F1 Q > X15 S DFN=DA D SV^DGLOCK Q > Q > ; > 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".32;8",DV="FX",DU=" > G RE > X16 S DFN=DA D SV^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT > I $D(X),X'?.ANP K X > Q > ; > 17 S DW=".52;5",DV="RSX",DU="",DLB="POW STATUS INDICATED > S DE(DW)="C17^DGRPTX17" > S DU="Y:YES;N:NO;U:UNKNOWN;" > G RE > C17 G C17S:$D(DE(17))[0 K DB > S X=DE(17),DIC=DIE > ; > S X=DE(17),DIC=DIE > ; > S X=DE(17),DIC=DIE > ; > S X=DE(17),DIC=DIE C11F1 Q | S X=DE(17),DIC=DIE X11 S DFN=DA D SV^DGLOCK | X "S DFN=DA D EN^DGMTR K DGREQF" > C17S S X="" G:DG(DQ)=X C17F1 K DB > D ^DGRPTX18 > C17F1 Q > X17 S DFN=DA D SV^DGLOCK 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".3;1",DV="RSXa",DU= | 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) S DE(DW)="C12^DGRPTX17" | X18 I $P($G(^DPT(DFN,.53)),U)]"" S Y="@53" > Q > 19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW=".53;1",DV="SX",DU=" > S DE(DW)="C19^DGRPTX17" C12 G C12S:$D(DE(12))[0 K DB | C19 G C19S:$D(DE(19))[0 K DB D ^DGRPTX18 | S X=DE(19),DIC=DIE C12S S X="" G:DG(DQ)=X C12F1 K DB | K ^DPT("D",$E(X,1,30),DA) D ^DGRPTX19 | S X=DE(19),DIC=DIE C12F1 Q | D AUTOUPD^DGENA2(DA) X12 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK | C19S S X="" G:DG(DQ)=X C19F1 K DB > S X=DG(DQ),DIC=DIE > S ^DPT("D",$E(X,1,30),DA)="" > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) > C19F1 Q > X19 S DFN=DA D VET^DGLOCK 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) | 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) X13 S:X'="Y" Y="@50" | X20 I X="Y" S Y="@532",DGPHMULT=1 > Q > 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) > X21 I X="N" S Y="@533",DGPHMULT=1 > Q > 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) > X22 S:X="" Y="@53" 14 D:$D(DG)>9 F^DIE17 G ^DGRPTX20 | 23 S DQ=24 ;@532 > 24 D:$D(DG)>9 F^DIE17 G ^DGRPTX19 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX18.m ./VADemo/r2/r/DGRPTX18.m DGRPTX18 ; ;07/02/04 | DGRPTX18 ; ;02/04/03 S X=DE(12),DIC=DIE | S X=DG(DQ),DIC=DIE ; | X ^DD(2,.525,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D S X=DE(12),DIC=DIE | S X=DG(DQ),DIC=DIE ; | X ^DD(2,.525,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D S X=DE(12),DIC=DIE | S X=DG(DQ),DIC=DIE > X ^DD(2,.525,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D > S X=DG(DQ),DIC=DIE S X=DE(12),DIC=DIE | S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VA | X "S DFN=DA D EN^DGMTR K DGREQF" S X=DE(12),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX19.m ./VADemo/r2/r/DGRPTX19.m DGRPTX19 ; ;07/02/04 | DGRPTX19 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, > I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(12)=% > I $D(^(.321)) S %Z=^(.321) S %=$P(%Z,U,2) S:%]"" DE(8 > I $D(^(.322)) S %Z=^(.322) S %=$P(%Z,U,13) S:%]"" DE( > I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,2) S:%]"" DE(11) > I $D(^(.53)) S %Z=^(.53) S %=$P(%Z,U,2) 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="DGRPTX19",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".53;2",DV="S",DU="", > S DE(DW)="C1^DGRPTX19" > S DU="1:PENDING;2:IN PROCESS;3:CONFIRMED;" > S X="PENDING" > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > K ^DPT("C",$E(X,1,30),DA) > C1S S X="" G:DG(DQ)=X C1F1 K DB X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | S ^DPT("C",$E(X,1,30),DA)="" > C1F1 Q > X1 Q > 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".53;4",DV="P4'",DU=" > S DU="DIC(4," > S X=$$DIV^DGRPLE() > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X2 Q > 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 > X3 S Y="@53" > Q > 4 S DQ=5 ;@533 > 5 S DW=".53;3",DV="S",DU="",DLB="CURRENT PURPLE HEART R > S DU="1:UNACCEPTABLE DOCUMENTATION;2:NO DOCUMENTATION > S X="VAMC" > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X5 Q > 6 S DW=".53;4",DV="P4'",DU="",DLB="PH DIVISION",DIFLD=. > S DU="DIC(4," > S X=$$DIV^DGRPLE() > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X6 Q > 7 S DQ=8 ;@53 > 8 S DW=".321;2",DV="RSX",DU="",DLB="AGENT ORANGE EXPOS. > S DE(DW)="C8^DGRPTX19" > S DU="Y:YES;N:NO;U:UNKNOWN;" > G RE > C8 G C8S:$D(DE(8))[0 K DB > S X=DE(8),DIC=DIE > ; > S X=DE(8),DIC=DIE > ; > S X=DE(8),DIC=DIE > ; > S X=DE(8),DIC=DIE > D AUTOUPD^DGENA2(DA) > S X=DE(8),DIC=DIE > ; > C8S S X="" G:DG(DQ)=X C8F1 K DB > S X=DG(DQ),DIC=DIE > X ^DD(2,.32102,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT > S X=DG(DQ),DIC=DIE > X ^DD(2,.32102,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT > S X=DG(DQ),DIC=DIE > X ^DD(2,.32102,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) > S X=DG(DQ),DIC=DIE > X ^DD(2,.32102,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DPT > C8F1 Q > X8 S DFN=DA D SV^DGLOCK > Q > ; > 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".321;3",DV="RSX",DU= > S DE(DW)="C9^DGRPTX19" > S DU="Y:YES;N:NO;U:UNKNOWN;" > G RE > C9 G C9S:$D(DE(9))[0 K DB > S X=DE(9),DIC=DIE > ; > S X=DE(9),DIC=DIE > ; > S X=DE(9),DIC=DIE > D AUTOUPD^DGENA2(DA) > C9S S X="" G:DG(DQ)=X C9F1 K DB X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | X ^DD(2,.32103,1,1,1.3) I X S X=DIV S Y(2)=";"_$S($D( > S X=DG(DQ),DIC=DIE > X ^DD(2,.32103,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) > C9F1 Q > X9 S DFN=DA D SV^DGLOCK > Q > ; > 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".322;13",DV="RSX",D > S DE(DW)="C10^DGRPTX19" > S DU="Y:YES;N:NO;U:UNKNOWN;" > G RE > C10 G C10S:$D(DE(10))[0 K DB > S X=DE(10),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3 > S X=DE(10),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3 > S X=DE(10),DIC=DIE > D AUTOUPD^DGENA2(DA) > C10S S X="" G:DG(DQ)=X C10F1 K DB > S X=DG(DQ),DIC=DIE > X ^DD(2,.322013,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DP > S X=DG(DQ),DIC=DIE > X ^DD(2,.322013,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DP > C10F1 Q > X10 S DFN=DA D SV^DGLOCK > Q > ; > 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".36;2",DV="RSX",DU= > S DE(DW)="C11^DGRPTX19" > S DU="0:NO;1:YES, RECEIVING MILITARY RETIREMENT;2:YES > G RE > C11 G C11S:$D(DE(11))[0 K DB > S X=DE(11),DIC=DIE > ; > S X=DE(11),DIC=DIE > D AUTOUPD^DGENA2(DA) > C11S S X="" G:DG(DQ)=X C11F1 K DB I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VA | X "S DFN=DA D EN^DGMTR K DGREQF" D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) | D AUTOUPD^DGENA2(DA) I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D | C11F1 Q > X11 S DFN=DA D SV^DGLOCK > Q > ; > 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".3;1",DV="RSXa",DU= > S DE(DW)="C12^DGRPTX19" > S DU="Y:YES;N:NO;" > G RE > C12 G C12S:$D(DE(12))[0 K DB > D ^DGRPTX20 > C12S S X="" G:DG(DQ)=X C12F1 K DB > D ^DGRPTX21 > C12F1 Q > X12 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK > Q > ; > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 S:X'="Y" Y="@50" > Q > 14 D:$D(DG)>9 F^DIE17 G ^DGRPTX22 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX1.m ./VADemo/r2/r/DGRPTX1.m DGRPTX1 ; ;07/02/04 | DGRPTX1 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX20.m ./VADemo/r2/r/DGRPTX20.m DGRPTX20 ; ;07/02/04 | DGRPTX20 ; ;02/04/03 D DE G BEGIN | S X=DE(12),DIC=DIE DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, < I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,2) S:%]"" DE(1)=% < I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,3) S:%]"" DE(8)= < I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(6)= < I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE( < K %Z Q < W W !?DL+DL-2,DLB_": " | S X=DE(12),DIC=DIE 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGRPTX20",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".3;2",DV="NJ3,0Xa",D < S DE(DW)="C1^DGRPTX20" < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < S X=DE(1),DIC=DIE | S X=DE(12),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(12),DIC=DIE ; | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VA S X=DE(1),DIC=DIE | S X=DE(12),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VA < S X=DE(1),DIC=DIE < S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET | S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < ; < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA) < S X=DG(DQ),DIC=DIE < X "S DFN=DA D EN^DGMTR K DGREQF" < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VA < 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 < C1F1 Q < X1 S DFN=DA D EV^DGLOCK Q:'$D(X) K:+X'=X!(X>100)!(X<0)! < Q < ; < 2 S DQ=3 ;@50 < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;12",DV="SX",DU= < S DE(DW)="C3^DGRPTX20" < S DU="Y:YES;N:NO;U:UNKNOWN;" < G RE < 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 < 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^ < 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 < 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^ < 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 < Q < ; < 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;13",DV="SX",DU= < S DE(DW)="C4^DGRPTX20" < S DU="Y:YES;N:NO;U:UNKNOWN;" < G RE < 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 < 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^ < S X=DE(4),DIC=DIE < D AUTOUPD^DGENA2(DA) < C4S S X="" G:DG(DQ)=X C4F1 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 < 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^ < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA) < C4F1 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;14",DV="SX",DU= < S DE(DW)="C5^DGRPTX20" < S DU="Y:YES;N:NO;U:UNKNOWN;" < G RE < C5 G C5S:$D(DE(5))[0 K DB < S X=DE(5),DIC=DIE < X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT < 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^ < S X=DE(5),DIC=DIE < D AUTOUPD^DGENA2(DA) < C5S S X="" G:DG(DQ)=X C5F1 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 < 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^ < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA) < C5F1 Q < X5 S DFN=DA D MV^DGLOCK < Q < ; < 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".36;1",DV="*P8'Xa",D < S DE(DW)="C6^DGRPTX20" < S DU="DIC(8," < G RE < C6 G C6S:$D(DE(6))[0 K DB < D ^DGRPTX21 < C6S S X="" G:DG(DQ)=X C6F1 K DB < D ^DGRPTX22 < C6F1 Q < X6 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 < Q < ; < 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,D=0 K DE(1) ;361 < S DIFLD=361,DGO="^DGRPTX23",DC="3^2.0361IP^E^",DV="2. < S DU="DIC(8," < G RE:D I $D(DSC(2.0361))#2,$P(DSC(2.0361),"I $D(^UTIL < S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),$O(^(0))'="" < M7 I D>0 S DC=DC_D I $D(^DPT(DA,"E",+D,0)) S DE(7)=$P(^( < G RE < R7 D DE < S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),1:1) G 7+1 < ; < 8 S DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVIC < S DE(DW)="C8^DGRPTX20" < S DU="DIC(21," < G RE < C8 G C8S:$D(DE(8))[0 K DB < D ^DGRPTX24 < C8S S X="" G:DG(DQ)=X C8F1 K DB < D ^DGRPTX25 < C8F1 Q < X8 S DFN=DA D POS^DGLOCK1 < Q < ; < 9 S DQ=10 ;@98 < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S DGFIN="" < Q < 11 G 0^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX21.m ./VADemo/r2/r/DGRPTX21.m DGRPTX21 ; ;07/02/04 | DGRPTX21 ; ;02/04/03 S X=DE(6),DIC=DIE | 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(D S X=DE(6),DIC=DIE | S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I | X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D S X=DE(6),DIC=DIE | S X=DG(DQ),DIC=DIE X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"": < S X=DE(6),DIC=DIE < K ^DPT("AEL",DA,+X) < S X=DE(6),DIC=DIE < S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET | S X=DG(DQ),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VA > S X=DG(DQ),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D diff -y --suppress-common-lines ./VADemo/r1/DGRPTX22.m ./VADemo/r2/r/DGRPTX22.m DGRPTX22 ; ;07/02/04 | DGRPTX22 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, > I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,2) S:%]"" DE(1)=% > I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,3) S:%]"" DE(8)= > I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(6)= > I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE( > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="DGRPTX22",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".3;2",DV="NJ3,0Xa",D > S DE(DW)="C1^DGRPTX22" > G RE > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > ; > S X=DE(1),DIC=DIE > D AUTOUPD^DGENA2(DA) > S X=DE(1),DIC=DIE > ; > S X=DE(1),DIC=DIE > D:($T(AVAFC^VAFCDD01)'="") 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 > ; > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) | D:($T(AVAFC^VAFCDD01)'="") AVAFC^VAFCDD01(DA) > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ > C1F1 Q > X1 S DFN=DA D EV^DGLOCK Q:'$D(X) K:+X'=X!(X>100)!(X<0)! > Q > 2 S DQ=3 ;@50 > 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;12",DV="SX",DU= > S DE(DW)="C3^DGRPTX22" > S DU="Y:YES;N:NO;U:UNKNOWN;" > G RE > 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 > 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^ > 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 S ^DPT("AEL",DA,+X)="" | 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^ I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | C3F1 Q > X3 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK > Q > ; > 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;13",DV="SX",DU= > S DE(DW)="C4^DGRPTX22" > S DU="Y:YES;N:NO;U:UNKNOWN;" > G RE > 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 > 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^ > S X=DE(4),DIC=DIE > D AUTOUPD^DGENA2(DA) > C4S S X="" G:DG(DQ)=X C4F1 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 > 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^ > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) > C4F1 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;14",DV="SX",DU= > S DE(DW)="C5^DGRPTX22" > S DU="Y:YES;N:NO;U:UNKNOWN;" > G RE > C5 G C5S:$D(DE(5))[0 K DB > S X=DE(5),DIC=DIE > X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT > 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^ > S X=DE(5),DIC=DIE > D AUTOUPD^DGENA2(DA) > C5S S X="" G:DG(DQ)=X C5F1 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 > 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^ > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) > C5F1 Q > X5 S DFN=DA D MV^DGLOCK > Q > ; > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".36;1",DV="*P8'Xa",D > S DE(DW)="C6^DGRPTX22" > S DU="DIC(8," > G RE > C6 G C6S:$D(DE(6))[0 K DB > D ^DGRPTX23 > C6S S X="" G:DG(DQ)=X C6F1 K DB > D ^DGRPTX24 > C6F1 Q > X6 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 > Q > ; > 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,D=0 K DE(1) ;361 > S DIFLD=361,DGO="^DGRPTX25",DC="3^2.0361IP^E^",DV="2. > S DU="DIC(8," > G RE:D I $D(DSC(2.0361))#2,$P(DSC(2.0361),"I $D(^UTIL > S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),$O(^(0))'="" > M7 I D>0 S DC=DC_D I $D(^DPT(DA,"E",+D,0)) S DE(7)=$P(^( > G RE > R7 D DE > S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),1:1) G 7+1 > ; > 8 S DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVIC > S DE(DW)="C8^DGRPTX22" > S DU="DIC(21," > G RE > C8 G C8S:$D(DE(8))[0 K DB > D ^DGRPTX26 > C8S S X="" G:DG(DQ)=X C8F1 K DB > D ^DGRPTX27 > C8F1 Q > X8 S DFN=DA D POS^DGLOCK1 > Q > ; > 9 S DQ=10 ;@98 > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) > X10 S DGFIN="" > Q > 11 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX23.m ./VADemo/r2/r/DGRPTX23.m DGRPTX23 ; ;07/02/04 | DGRPTX23 ; ;02/04/03 D DE G BEGIN | S X=DE(6),DIC=DIE DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1, < I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% < K %Z Q < W W !?DL+DL-2,DLB_": " | S X=DE(6),DIC=DIE Q | K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I O D W W Y W:$X>45 !?9 | S X=DE(6),DIC=DIE I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 | X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"": W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (N | S X=DE(6),DIC=DIE TR R X:DTIME E S (DTOUT,X)=U W $C(7) | K ^DPT("AEL",DA,+X) Q | S X=DE(6),DIC=DIE A K DQ(DQ) S DQ=DQ+1 | D AUTOUPD^DGENA2(DA) B G @DQ | S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET RE G PR:$D(DE(DQ)) D W,TR < N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGRPTX23",DQ=1+D G B < 1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD < S DE(DW)="C1^DGRPTX23" < S DU="DIC(8," < G RE:'D S DQ=2 G 2 < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < K ^DPT(DA(1),"E","B",$E(X,1,30),DA) < S X=DE(1),DIC=DIE < K ^DPT("AEL",DA(1),+X) < S X=DE(1),DIC=DIE < D E32^VADPT62 < S X=DE(1),DIC=DIE < X "S DFN=DA(1) D EN^DGMTR K DGREQF" < S X=DE(1),DIC=DIE < D AUTOUPD^DGENA2(DA(1)) < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < S ^DPT(DA(1),"E","B",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < S ^DPT("AEL",DA(1),+X)="" < S X=DG(DQ),DIC=DIE < D E31^VADPT62 < S X=DG(DQ),DIC=DIE < X "S DFN=DA(1) D EN^DGMTR K DGREQF" < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA(1)) < C1F1 Q < X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DP < Q < ; < 2 G 1^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX24.m ./VADemo/r2/r/DGRPTX24.m DGRPTX24 ; ;07/02/04 | DGRPTX24 ; ;02/04/03 S X=DE(8),DIC=DIE | S X=DG(DQ),DIC=DIE K ^DPT("APOS",$E(X,1,30),DA) | X "S DFN=DA D EN^DGMTR K DGREQF" S X=DE(8),DIC=DIE | 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 X=DG(DQ),DIC=DIE S X=DE(8),DIC=DIE | S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VA | S ^DPT("AEL",DA,+X)="" S X=DE(8),DIIX=2_U_DIFLD D AUDIT^DIET | S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) > I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ diff -y --suppress-common-lines ./VADemo/r1/DGRPTX25.m ./VADemo/r2/r/DGRPTX25.m DGRPTX25 ; ;07/02/04 | DGRPTX25 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1, > I $D(^(0)) S %Z=^(0) 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="DGRPTX25",DQ=1+D G B > 1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD > S DE(DW)="C1^DGRPTX25" > S DU="DIC(8," > G RE:'D S DQ=2 G 2 > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > K ^DPT(DA(1),"E","B",$E(X,1,30),DA) > S X=DE(1),DIC=DIE > K ^DPT("AEL",DA(1),+X) > S X=DE(1),DIC=DIE > D E32^VADPT62 > S X=DE(1),DIC=DIE > X "S DFN=DA(1) D EN^DGMTR K DGREQF" > S X=DE(1),DIC=DIE > D AUTOUPD^DGENA2(DA(1)) > C1S S X="" G:DG(DQ)=X C1F1 K DB S ^DPT("APOS",$E(X,1,30),DA)="" | S ^DPT(DA(1),"E","B",$E(X,1,30),DA)="" X ^DD(2,.323,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | S ^DPT("AEL",DA(1),+X)="" I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VA | D E31^VADPT62 I $D(DE(8))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | S X=DG(DQ),DIC=DIE > X "S DFN=DA(1) D EN^DGMTR K DGREQF" > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA(1)) > C1F1 Q > X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DP > Q > ; > 2 G 1^DIE17 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX26.m ./VADemo/r2/r/DGRPTX26.m DGRPTX26 ; ;06/03/03 | DGRPTX26 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(8),DIC=DIE X "S DFN=DA D EN^DGMTR K DGREQF" | K ^DPT("APOS",$E(X,1,30),DA) S X=DG(DQ),DIC=DIE | S X=DE(8),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) < S X=DG(DQ),DIC=DIE < S X=DG(DQ),DIC=DIE | S X=DE(8),DIC=DIE S ^DPT("AEL",DA,+X)="" | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VA S X=DG(DQ),DIC=DIE | S X=DE(8),DIIX=2_U_DIFLD D AUDIT^DIET D AUTOUPD^DGENA2(DA) < I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX27.m ./VADemo/r2/r/DGRPTX27.m DGRPTX27 ; ;06/03/03 | DGRPTX27 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1, < I $D(^(0)) S %Z=^(0) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGRPTX27",DQ=1+D G B < 1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD < S DE(DW)="C1^DGRPTX27" < S DU="DIC(8," < G RE:'D S DQ=2 G 2 < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < K ^DPT(DA(1),"E","B",$E(X,1,30),DA) < S X=DE(1),DIC=DIE < K ^DPT("AEL",DA(1),+X) < S X=DE(1),DIC=DIE < D E32^VADPT62 < S X=DE(1),DIC=DIE < X "S DFN=DA(1) D EN^DGMTR K DGREQF" < S X=DE(1),DIC=DIE < D AUTOUPD^DGENA2(DA(1)) < C1S S X="" G:DG(DQ)=X C1F1 K DB < S ^DPT(DA(1),"E","B",$E(X,1,30),DA)="" | S ^DPT("APOS",$E(X,1,30),DA)="" S ^DPT("AEL",DA(1),+X)="" | X ^DD(2,.323,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D D E31^VADPT62 | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VA S X=DG(DQ),DIC=DIE | I $D(DE(8))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ X "S DFN=DA(1) D EN^DGMTR K DGREQF" < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA(1)) < C1F1 Q < X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DP < Q < ; < 2 G 1^DIE17 < Only in ./VADemo/r1/: DGRPTX28.m Only in ./VADemo/r1/: DGRPTX29.m diff -y --suppress-common-lines ./VADemo/r1/DGRPTX2.m ./VADemo/r2/r/DGRPTX2.m DGRPTX2 ; ;07/02/04 | DGRPTX2 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX3.m ./VADemo/r2/r/DGRPTX3.m DGRPTX3 ; ;07/02/04 | DGRPTX3 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX4.m ./VADemo/r2/r/DGRPTX4.m DGRPTX4 ; ;07/02/04 | DGRPTX4 ; ;02/04/03 D DE G BEGIN | S X=DE(11),DIC=DIE DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, < I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,3) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGRPTX4",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;3",DV="Fa",DU="" < S DE(DW)="C1^DGRPTX4",DE(DW,"INDEX")=1 < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < S X=DE(1),DIC=DIE | S X=DE(11),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(11),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(11),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(11),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(11),DIC=DIE S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET | S X=DE(11),DIIX=2_U_DIFLD D AUDIT^DIET C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DG(DQ),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VA < 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 < C1F1 N X,X1,X2 S DIXR=233 D C1X1(U) K X2 M X2=X D C1X1("O" < D < . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DP < S X=$G(X(1)) < Q < C1F2 Q < X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 2 S DQ=3 ;@1112 < 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 < X3 S EASZIPLK=1 < Q < 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;12",DV="FXOa",DU < S DQ(4,2)="S Y(0)=Y D ZIPOUT^VAFADDR" < S DE(DW)="C4^DGRPTX4",DE(DW,"INDEX")=1 < G RE < C4 G C4S:$D(DE(4))[0 K DB < S X=DE(4),DIC=DIE < D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) < S X=DE(4),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(4),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DE(4),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(4),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V < 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 < D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) < S X=DG(DQ),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V < 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 < C4F1 N X,X1,X2 S DIXR=185 D C4X1(U) K X2 M X2=X D C4X1("O" < D < . N DIEXARR M DIEXARR=X S DIEZCOND=1 < . I X1(1)'=X2(1) < . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND < . K EASDO2 < G C4F2 < C4X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D < S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X( < S:$D(X)#2 X(2)=X < S X=$G(X(1)) < Q < C4F2 S DIXR=231 D C4X2(U) K X2 M X2=X D C4X2("O") K X1 M X < D < . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1, < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,. < G C4F3 < C4X2(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D < S X=$G(X(1)) < Q < C4F3 Q < X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X < I $D(X),X'?.ANP K X < Q < ; < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;4",DV="Fa",DU="" < S DE(DW)="C5^DGRPTX4",DE(DW,"INDEX")=1 < G RE < C5 G C5S:$D(DE(5))[0 K DB < D ^DGRPTX5 < C5S S X="" G:DG(DQ)=X C5F1 K DB < D ^DGRPTX6 < C5F1 N X,X1,X2 S DIXR=234 D C5X1(U) K X2 M X2=X D C5X1("O" < D < . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X < G C5F2 < C5X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DP < S X=$G(X(1)) < Q < C5F2 Q < X5 K:$L(X)>15!($L(X)<2) X < I $D(X),X'?.ANP K X < Q < ; < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 S:'$$KEY^DGREGDD1(DUZ,DA) Y=.131 < Q < 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".11;5",DV="P5'a",DU= < S DE(DW)="C7^DGRPTX4",DE(DW,"INDEX")=1 < S DU="DIC(5," < G RE < C7 G C7S:$D(DE(7))[0 K DB < D ^DGRPTX7 < C7S S X="" G:DG(DQ)=X C7F1 K DB < D ^DGRPTX8 < C7F1 N X,X1,X2 S DIXR=235 D C7X1(U) K X2 M X2=X D C7X1("O" < D < . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X < G C7F2 < C7X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DP < S X=$G(X(1)) < Q < C7F2 Q < X7 Q < 8 D:$D(DG)>9 F^DIE17 G ^DGRPTX9 < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX5.m ./VADemo/r2/r/DGRPTX5.m DGRPTX5 ; ;07/02/04 | DGRPTX5 ; ;02/04/03 S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VA S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET | I $D(DE(11))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D diff -y --suppress-common-lines ./VADemo/r1/DGRPTX6.m ./VADemo/r2/r/DGRPTX6.m DGRPTX6 ; ;07/02/04 | DGRPTX6 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(14),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR | D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) S X=DG(DQ),DIC=DIE | S X=DE(14),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(14),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(14),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(14),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V S X=DG(DQ),DIC=DIE | S X=DE(14),DIC=DIE I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | S X=DE(14),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/DGRPTX7.m ./VADemo/r2/r/DGRPTX7.m DGRPTX7 ; ;07/02/04 | DGRPTX7 ; ;02/04/03 S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 | D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR < S X=DE(7),DIC=DIE < S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET | I $D(DE(14))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D diff -y --suppress-common-lines ./VADemo/r1/DGRPTX8.m ./VADemo/r2/r/DGRPTX8.m DGRPTX8 ; ;07/02/04 | DGRPTX8 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(7)=% > I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,4) S:%]"" DE(1)= > I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(5)= > I $D(^(.21)) S %Z=^(.21) S %=$P(%Z,U,1) S:%]"" DE(8)= > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="DGRPTX8",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;4",DV="Fa",DU="" > S DE(DW)="C1^DGRPTX8" > G RE > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(1),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(1),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DE(1),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(1),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VA > 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 > S A1B2TAG="PAT" D ^A1B2XFR > S X=DG(DQ),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DG(DQ),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DG(DQ),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VA > 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 > C1F1 Q > X1 K:$L(X)>15!($L(X)<2) X > I $D(X),X'?.ANP K X > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 S:'$$KEY^DGREGDD1(DUZ,DA) Y=.131 > Q > 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;5",DV="P5'a",DU= > S DE(DW)="C3^DGRPTX8" > S DU="DIC(5," > 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(^DPT(D0,.1 > S X=DE(3),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(3),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(3),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DE(3),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(3),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VA > 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 I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ > C3F1 Q > X3 Q > 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;7",DV="NJ3,0XOa" > S DQ(4,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11 > S DE(DW)="C4^DGRPTX8" > G RE > C4 G C4S:$D(DE(4))[0 K DB > S X=DE(4),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(4),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(4),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(4),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA > 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 > S A1B2TAG="PAT" D ^A1B2XFR > S X=DG(DQ),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DG(DQ),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DG(DQ),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA > I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ > C4F1 Q > X4 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 > Q > ; > 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".13;1",DV="Fa",DU="" > S DE(DW)="C5^DGRPTX8" > G RE > C5 G C5S:$D(DE(5))[0 K DB > S X=DE(5),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(5),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(5),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VA > 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 > D ^DGRPTX9 > C5F1 Q > X5 K:$L(X)>20!($L(X)<4) X > I $D(X),X'?.ANP K X > Q > ; > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".13;2",DV="Fa",DU="" > S DE(DW)="C6^DGRPTX8" > G RE > C6 G C6S:$D(DE(6))[0 K DB > D ^DGRPTX10 > C6S S X="" G:DG(DQ)=X C6F1 K DB > D ^DGRPTX11 > C6F1 Q > X6 K:$L(X)>20!($L(X)<4) X > I $D(X),X'?.ANP K X > Q > ; > 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="0;5",DV="RP11'a",DU= > S DE(DW)="C7^DGRPTX8" > S DU="DIC(11," > G RE > C7 G C7S:$D(DE(7))[0 K DB > D ^DGRPTX12 > C7S S X="" G:DG(DQ)=X C7F1 K DB > D ^DGRPTX13 > C7F1 Q > X7 Q > 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".21;1",DV="Fa",DU="" > S DE(DW)="C8^DGRPTX8" > G RE > C8 G C8S:$D(DE(8))[0 K DB > D ^DGRPTX14 > C8S S X="" G:DG(DQ)=X C8F1 K DB > D ^DGRPTX15 > C8F1 Q > X8 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 > X9 S:X="" Y="@30" > Q > 10 D:$D(DG)>9 F^DIE17 G ^DGRPTX16 diff -y --suppress-common-lines ./VADemo/r1/DGRPTX9.m ./VADemo/r2/r/DGRPTX9.m DGRPTX9 ; ;07/02/04 | DGRPTX9 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, < I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(5)=% < I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,7) S:%]"" DE(1)= < I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(2)= < I $D(^(.21)) S %Z=^(.21) S %=$P(%Z,U,1) S:%]"" DE(6)= < 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DGRPTX9",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;7",DV="NJ3,0XOa" < S DQ(1,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11 < S DE(DW)="C1^DGRPTX9" < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DE(1),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(1),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(1),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA < 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 < S A1B2TAG="PAT" D ^A1B2XFR < S X=DG(DQ),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA < I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C1F1 Q < X1 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".13;1",DV="Fa",DU="" < S DE(DW)="C2^DGRPTX9" < G RE < C2 G C2S:$D(DE(2))[0 K DB < S X=DE(2),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(2),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(2),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VA < S X=DE(2),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET < C2S S X="" G:DG(DQ)=X C2F1 K DB < I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C2F1 Q < X2 K:$L(X)>20!($L(X)<4) X < I $D(X),X'?.ANP K X < Q < ; < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".13;2",DV="Fa",DU="" < S DE(DW)="C3^DGRPTX9" < G RE < C3 G C3S:$D(DE(3))[0 K DB < S X=DE(3),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(3),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(3),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".132;" D AVAFC^VA < 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 < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".132;" D AVAFC^VA < 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 < C3F1 Q < X3 K:$L(X)>20!($L(X)<4) X < I $D(X),X'?.ANP K X < Q < ; < 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;16",DV="S",DU="" < S DU="1:UNDELIVERABLE;2:HOMELESS;3:OTHER;" < G RE < X4 Q < 5 S DW="0;5",DV="RP11'a",DU="",DLB="MARITAL STATUS",DIF < S DE(DW)="C5^DGRPTX9" < S DU="DIC(11," < G RE < C5 G C5S:$D(DE(5))[0 K DB < S X=DE(5),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".05;" D AVAFC^VAF < 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 < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".05;" D AVAFC^VAF < S X=DG(DQ),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < C5F1 Q < X5 Q < 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".21;1",DV="Fa",DU="" < S DE(DW)="C6^DGRPTX9",DE(DW,"INDEX")=1 < G RE < C6 G C6S:$D(DE(6))[0 K DB < S X=DE(6),DIC=DIE < X "S DGXRF=.211 D ^DGDDC Q" < S X=DE(6),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".211;" D AVAFC^VA < S X=DE(6),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET < C6S S X="" G:DG(DQ)=X C6F1 K DB < S X=DG(DQ),DIC=DIE < ; < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".211;" D AVAFC^VA < S X=DG(DQ),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C6F1 N X,X1,X2 S DIXR=220 D C6X1(U) K X2 M X2=X D C6X1("O" < I $G(X(1))]"" D < . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1 D DELCOMP^X < K X M X=X2 I $G(X(1))]"" D < . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1,DG20NAME=X < G C6F2 < C6X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.211,DION),$P($G(^DP < S X=$G(X(1)) < Q < C6F2 Q < X6 K:$L(X)>35!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NA < I $D(X),X'?.ANP K X < Q < ; < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 < X7 S:X="" Y="@30" < Q < 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".21;2",DV="FX",DU="" < S DE(DW)="C8^DGRPTX9" < G RE < C8 G C8S:$D(DE(8))[0 K DB < D ^DGRPTX10 < C8S S X="" G:DG(DQ)=X C8F1 K DB < D ^DGRPTX11 < C8F1 Q < X8 K:$L(X)>30!($L(X)<1) X I $D(X) S DFN=DA D K1^DGLOCK2 < 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 G ^DGRPTX12 < diff -y --suppress-common-lines ./VADemo/r1/DGRPTX.m ./VADemo/r2/r/DGRPTX.m DGRPTX ; GENERATED FROM 'DGRPT 10-10T REGISTRATION' INPUT TE | DGRPTX ; GENERATED FROM 'DGRPT 10-10T REGISTRATION' INPUT TE I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(7)= | I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(7)= S DR(99,1,9.2)="S (D,D0)=$QS(DIMQ,$QL(DIMQ)) I D,$D(^ < S DR(99,1,9.3)="N DIMQ,DIMSTRT,DIMSCNT S (DIMQ,DIMSTR < S DE(DW)="C7^DGRPTX",DE(DW,"INDEX")=1 | S DE(DW)="C7^DGRPTX" C7F1 N X,X1,X2 S DIXR=230 D C7X1(U) K X2 M X2=X D C7X1("O" | C7F1 Q D < . D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X < G C7F2 < C7X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.111,DION),$P($G(^DP < S X=$G(X(1)) < Q < C7F2 Q < S DE(DW)="C9^DGRPTX",DE(DW,"INDEX")=1 | S DE(DW)="C9^DGRPTX" C9F1 N X,X1,X2 S DIXR=232 D C9X1(U) K X2 M X2=X D C9X1("O" | C9F1 Q D < . D FC^DGFCPROT(.DA,2,.112,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.112,"SET",$H,$G(DUZ),.X,.X1,.X < G C9F2 < C9X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.112,DION),$P($G(^DP < S X=$G(X(1)) < Q < C9F2 Q < 11 D:$D(DG)>9 F^DIE17 G ^DGRPTX4 | 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".11;3",DV="Fa",DU=" > S DE(DW)="C11^DGRPTX" > G RE > C11 G C11S:$D(DE(11))[0 K DB > D ^DGRPTX4 > C11S S X="" G:DG(DQ)=X C11F1 K DB > D ^DGRPTX5 > C11F1 Q > X11 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 12 S DQ=13 ;@1112 > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 S EASZIPLK=1 > Q > 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".11;12",DV="FXOa",D > S DQ(14,2)="S Y(0)=Y D ZIPOUT^VAFADDR" > S DE(DW)="C14^DGRPTX",DE(DW,"INDEX")=1 > G RE > C14 G C14S:$D(DE(14))[0 K DB > D ^DGRPTX6 > C14S S X="" G:DG(DQ)=X C14F1 K DB > D ^DGRPTX7 > C14F1 N X,X1,X2 S DIXR=185 D C14X1(U) K X2 M X2=X D C14X1(" > D > . N DIEXARR M DIEXARR=X S DIEZCOND=1 > . I X1(1)'=X2(1) > . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND > . K EASDO2 > G C14F2 > C14X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D > S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X( > S:$D(X)#2 X(2)=X > S X=$G(X(1)) > Q > C14F2 Q > X14 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X > I $D(X),X'?.ANP K X > Q > ; > 15 D:$D(DG)>9 F^DIE17 G ^DGRPTX8 diff -y --suppress-common-lines ./VADemo/r1/DGRPU1.m ./VADemo/r2/r/DGRPU1.m ;;5.3;Registration;**139,169,415,527,508**;Aug 13, 19 | ;;5.3;Registration;**139,169,415**;Aug 13, 1993 ;;^ADD1^ADD2^ADD^ADD3^ADD4^ | ;;^ADD1^ADD2^ADD^ADD3^ ;;^104^105^109,105^109,105,111^111^ | ;;^104^105^109,105^109,105^ ;;^.11~.13^.121^.11~.121~.13^.11~.121~.13~.141^.141^ | ;;^.11~.13^.121^.11~.121~.13^.11~.121~.13^ ;;^^^.02~.06^.02~.06~.14^.14^ | ;;^^^.02~.06^.02~.06^ diff -y --suppress-common-lines ./VADemo/r1/DGRPU.m ./VADemo/r2/r/DGRPU.m ;;5.3;Registration;**33,114,489**;Aug 13, 1993 | ;;5.3;Registration;**33,114**;Aug 13, 1993 I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SC | W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS I DGRPS=1.1 W @IOF S Z="CONFIDENTIAL ADDRESS DATA, SC < .I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q < diff -y --suppress-common-lines ./VADemo/r1/DGRPV.m ./VADemo/r2/r/DGRPV.m DGRPV ;ALB/MRL,RTK,PJR - REGISTRATION DEFINE VARIABLES ON E | DGRPV ;ALB/MRL,RTK - REGISTRATION DEFINE VARIABLES ON ENTRY ;;5.3;Registration;**109,114,247,190,327,365,343,397, | ;;5.3;Registration;**109,114,247,190,327,365,343,397, S DGRPVV(1.1)=0 < S DGRPVV(2)="0001" < ; | I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 < ;-- commented the line to allow screens 2 & 4 to disp < ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I < I $P($G(^DPT(DFN,.361)),U,3)="H" S DGRPVV(10)=10,DGRP | I $P($G(^DPT(DFN,.361)),U,3)="H" S DGRPVV(10)=10,DGRP I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I | I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"111" F I= diff -y --suppress-common-lines ./VADemo/r1/DGRPX710.m ./VADemo/r2/r/DGRPX710.m DGRPX710 ; ;07/02/04 | DGRPX710 ; ;12/10/01 diff -y --suppress-common-lines ./VADemo/r1/DGRPX71.m ./VADemo/r2/r/DGRPX71.m DGRPX71 ; ;07/02/04 | DGRPX71 ; ;12/10/01 S DE(DW)="C1^DGRPX71" < C1 G C1S:$D(DE(1))[0 K DB | X1 S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P S X=DE(1),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VA < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VA < C1F1 Q < X1 S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P < 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".31;4",DV="*P4'",DU= | 2 S DW=".31;4",DV="*P4'",DU="",DLB="CLAIM FOLDER LOCATI C2S S X="" G:DG(DQ)=X C2F1 K DB | C2S S X="" Q:DG(DQ)=X K DB C2F1 Q | Q C5S S X="" G:DG(DQ)=X C5F1 K DB | C5S S X="" Q:DG(DQ)=X K DB C5F1 Q | Q C6S S X="" G:DG(DQ)=X C6F1 K DB | C6S S X="" Q:DG(DQ)=X K DB C6F1 Q | Q C7S S X="" G:DG(DQ)=X C7F1 K DB | C7S S X="" Q:DG(DQ)=X K DB D ^DGRPX72 | S X=DG(DQ),DIC=DIE C7F1 Q | X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT > 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^ > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) > Q S X=DE(8),DIC=DIE | D ^DGRPX72 X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT( | C8S S X="" Q:DG(DQ)=X K DB S X=DE(8),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ < C8S S X="" G:DG(DQ)=X C8F1 K DB < C8F1 Q | Q C10S S X="" G:DG(DQ)=X C10F1 K DB | C10S S X="" Q:DG(DQ)=X K DB C10F1 Q | Q C11S S X="" G:DG(DQ)=X C11F1 K DB | C11S S X="" Q:DG(DQ)=X K DB C11F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/DGRPX72.m ./VADemo/r2/r/DGRPX72.m DGRPX72 ; ;07/02/04 | DGRPX72 ; ;12/10/01 S X=DG(DQ),DIC=DIE | S X=DE(8),DIC=DIE X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT | X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT( S X=DG(DQ),DIC=DIE | S X=DE(8),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^ < S X=DG(DQ),DIC=DIE < D AUTOUPD^DGENA2(DA) < diff -y --suppress-common-lines ./VADemo/r1/DGRPX73.m ./VADemo/r2/r/DGRPX73.m DGRPX73 ; ;07/02/04 | DGRPX73 ; ;12/10/01 diff -y --suppress-common-lines ./VADemo/r1/DGRPX74.m ./VADemo/r2/r/DGRPX74.m DGRPX74 ; ;07/02/04 | DGRPX74 ; ;12/10/01 diff -y --suppress-common-lines ./VADemo/r1/DGRPX75.m ./VADemo/r2/r/DGRPX75.m DGRPX75 ; ;07/02/04 | DGRPX75 ; ;12/10/01 diff -y --suppress-common-lines ./VADemo/r1/DGRPX76.m ./VADemo/r2/r/DGRPX76.m DGRPX76 ; ;07/02/04 | DGRPX76 ; ;12/10/01 diff -y --suppress-common-lines ./VADemo/r1/DGRPX77.m ./VADemo/r2/r/DGRPX77.m DGRPX77 ; ;07/02/04 | DGRPX77 ; ;12/10/01 diff -y --suppress-common-lines ./VADemo/r1/DGRPX78.m ./VADemo/r2/r/DGRPX78.m DGRPX78 ; ;07/02/04 | DGRPX78 ; ;12/10/01 C4S S X="" G:DG(DQ)=X C4F1 K DB | C4S S X="" Q:DG(DQ)=X K DB C4F1 Q | Q C8S S X="" G:DG(DQ)=X C8F1 K DB | C8S S X="" Q:DG(DQ)=X K DB C8F1 Q | Q C10S S X="" G:DG(DQ)=X C10F1 K DB | C10S S X="" Q:DG(DQ)=X K DB C10F1 Q | Q C11S S X="" G:DG(DQ)=X C11F1 K DB | C11S S X="" Q:DG(DQ)=X K DB C11F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/DGRPX79.m ./VADemo/r2/r/DGRPX79.m DGRPX79 ; ;07/02/04 | DGRPX79 ; ;12/10/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/DGRPX7.m ./VADemo/r2/r/DGRPX7.m DGRPX7 ; GENERATED FROM 'DG LOAD EDIT SCREEN 7' INPUT TEMPLA | DGRPX7 ; GENERATED FROM 'DG LOAD EDIT SCREEN 7' INPUT TEMPLA C2S S X="" G:DG(DQ)=X C2F1 K DB | C2S S X="" Q:DG(DQ)=X K DB C2F1 Q | Q C4S S X="" G:DG(DQ)=X C4F1 K DB | C4S S X="" Q:DG(DQ)=X K DB C4F1 Q | Q C5S S X="" G:DG(DQ)=X C5F1 K DB | C5S S X="" Q:DG(DQ)=X K DB C5F1 Q | Q I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VA | D:($T(AVAFC^VAFCDD01)'="") AVAFC^VAFCDD01(DA) C7S S X="" G:DG(DQ)=X C7F1 K DB | C7S S X="" Q:DG(DQ)=X K DB I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VA | D:($T(AVAFC^VAFCDD01)'="") AVAFC^VAFCDD01(DA) C7F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/DGRUDYN.m ./VADemo/r2/r/DGRUDYN.m DGRUDYN ;ALB/SCK - RAI/MDS COTS DYNAMIC ADDRESSING ROUTINE; 9 | DGRUDYN ;ALB/SCK - RAI/MDS COTS DYNAMIC ADDRESSING ROTUINE; 9 ;;5.3;Registration;**190,328,354,357,473,501**;Aug 13 | ;;5.3;Registration;**190,328,354,357,473**;Aug 13, 19 N DGENTRY,DGDIV,DGSCN,DGSITE,HLNODE,DGSTN,DGWARD,DGIE | N DGENTRY,DGDIV,DGSCN,DGSITE,HLNODE,DGSTN,DGWARD ; S DGAPIEN=$P(HLL("LINKS",1),"^",4) ;changed p-357, | S DGAPIEN=$P(HLL("LINKS",1),"^",4) ;changed p-357 S DGAPIEN=$$GET1^DIQ(771,$P(HLL("LINKS",1),"^",4),.01 | S CLIENT="DGRU-RAI-"_EVENT_"-"_DGAPIEN ;changed p-357 S DGFAC=$$GET1^DIQ(771,$P(HLL("LINKS",1),"^",4),3) ; | S $P(HLL("LINKS",1),"^",1)=CLIENT ;added p-357 ; S CLIENT="DGRU-RAI-"_EVENT_"-"_DGAPIEN ;changed p-3 < S CLIENT="DGRU-RAI-"_EVENT ; added p-501 < S $P(HLL("LINKS",1),"^",1)=CLIENT ;changed p-357 < S HLP("SUBSCRIBER")="^^^"_DGAPIEN_"^"_DGFAC ; added p < N DGAPIEN,DGFAC,CLIENT < ; S DGAPIEN=$P(HLL("LINKS",1),"^",4) ;ADDED P-357, di | S DGAPIEN=$P(HLL("LINKS",1),"^",4) ;ADDED P-357 S DGAPIEN=$$GET1^DIQ(771,$P(HLL("LINKS",1),"^",4),.01 | S CLIENT="DGRU-RAI-"_DGEVENT_"-"_DGAPIEN ;changed p-3 S DGFAC=$$GET1^DIQ(771,$P(HLL("LINKS",1),"^",4),3) ; < ; S CLIENT="DGRU-RAI-"_DGEVENT_"-"_DGAPIEN ;changed p < S CLIENT="DGRU-RAI-"_DGEVENT ; added p-501 < S HLP("SUBSCRIBER")="^^^"_DGAPIEN_"^"_DGFAC ; added p < diff -y --suppress-common-lines ./VADemo/r1/DGRUGS.m ./VADemo/r2/r/DGRUGS.m DGRUGS ;ALB/MLI,PHH - RUG-II STATUS REPORT ; 13 SEPT 88 @200 | DGRUGS ;ALB/MLI - RUG-II STATUS REPORT ; 13 SEPT 88 @2000 ;;5.3;Registration;**89,173,568**;Aug 13, 1993 | ;;5.3;Registration;**89,173**;Aug 13, 1993 D DATE^DGSDUTL G:POP Q K BEGDATE,ENDATE | D DATE^SDUTL G:POP Q K BEGDATE,ENDATE diff -y --suppress-common-lines ./VADemo/r1/DGRUGU1.m ./VADemo/r2/r/DGRUGU1.m ;;5.3;Registration;**89,111,573**;Aug 13, 1993 | ;;5.3;Registration;**89,111**;Aug 13, 1993 .I '$D(DGCNH),$P(^DG(45.9,+Y,0),"^",6)'=3 S FLAG=1 Q < .I '$D(DGCNH),$P(^DG(45.9,+Y,0),"^",6)'=3 S FLAG=1 Q < .I '$D(DGCNH),$P(^DG(45.9,+Y,0),"^",6)'=3 S FLAG=1 Q < Only in ./VADemo/r1/: DGSDUTL.m diff -y --suppress-common-lines ./VADemo/r1/DGSEC.m ./VADemo/r2/r/DGSEC.m DGSEC ;ALB/RMO - MAS Patient Look-up Security Check ; 3/24/ | DGSEC ;ALB/RMO - MAS Patient Look-up Security Check ; 2/3/0 ;;5.3;Registration;**32,46,197,214,249,281,352,391,42 | ;;5.3;Registration;**32,46,197,214,249,281,352,391**; ;DG/582 < I $G(VALM("TITLE"))="Dependents Module" Q < .S X="DGPFAPI" X DGTEST I $T D ;Patient Record Flags < ..N DGPFSAVY S DGPFSAVY=Y < ..D DISPPRF^DGPFAPI(Y) S Y=DGPFSAVY K DGPFSAVY < ;DG/582 < I $G(VALM("TITLE"))="Dependents Module" Q < D ^XMB | N ZTSK,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DGI,X,Y > F DGI="XMB","XMB(","XMY(" S ZTSAVE(DGI)="" > S ZTRTN="EN^XMB",ZTDESC="DG Security Bulletin",ZTIO=" > D ^%ZTLOAD diff -y --suppress-common-lines ./VADemo/r1/DGSSNRP2.m ./VADemo/r2/r/DGSSNRP2.m DGSSNRP2 ;ALB/SEK/PHH - DUPLICATE SPOUSE/DEPENDENT Rep | DGSSNRP2 ;ALB/SEK - DUPLICATE SPOUSE/DEPENDENT Report ;;5.3;Registration;**313,535,568**;Aug 13,1993 | ;;5.3;Registration;**313**;Aug 13,1993 N X S X=$$DT^XLFDT | N X > S X=$$DT^XLFDT > ; .S ZTRTN="PRINT^DGSSNRP2",ZTDESC="Duplicate Spouse/De | .S ZTRTN="PRINT^DGSSNRP2",ZTDESC="Print Duplicate Spo > ; N STATS,CRT,QUIT,PAGE,PART1D,PART2D,PART1ST,SECTION,D | N STATS,CRT,QUIT,PAGE,PART1D,PART2D,PART1ST,SECTION,D > N VA,VADM,VAERR S (QUIT,PAGE)=0,CRT=$S($E(IOST,1,2)="C-":1,1:0) | S QUIT=0 > S PAGE=0 > S CRT=$S($E(IOST,1,2)="C-":1,1:0) > ; S (PAGE,PART1D,PART2D)=1,SECTION="PART1" | S PAGE=1 D CHECKP1,HEADER | S (PART1D,PART2D)=1 > S SECTION="PART1" > D CHECKP1 > D HEADER K ^XTMP("DG-SSNRP2"),^TMP("DGSSNAR",$J) | K ^XTMP("DG-SSNRP2"),^UTILITY("VASD",$J) LINE(LINE) ; Prints header if end of page. | LINE(LINE) ; > ;Description: prints a line. First prints header if a > ; GETDATA ;Setup global with vets included in the report | GETDATA ; > ;Setup global with veterans and spouse/dependents inc > ; > ;Variables used > ;DGCTR1 - counter part 1 > ;DGCTR2 - counter part 2 > ;DGVETSSN - vet's SSN > ;DGVETNM - vet's name > ;DGDEPSSN - dep's SSN > ;DGDEPNM - dep's name > ;DGDEPREL - dep's relationship > ; N DFN,DG40812,DGDEP,DGDEPIEN,DGIEN,DGSSNCTR,VARR | ; K ^TMP("DGSSNAR",$J) S VARR=1 | N DFN,DG40812,DGDEP,DGDEPIEN,DGIEN,DGSSNCTR S DFN=0 F S DFN=$O(^DGPR(408.12,"B",DFN)) Q:'DFN D | S DFN=0 > F S DFN=$O(^DGPR(408.12,"B",DFN)) Q:'DFN D > .K DGSSNAR ..Q:'DGIEN | ..I 'DGIEN D SETTMPA Q ;add to ^TMP ...I '$P(VADM(2),"^") K ^TMP("DGSSNAR",$J,DFN) S DGIE | ...I '$P(VADM(2),"^") K DGSSNAR S DGIEN="" Q ...; Check if patient has a Date of Death | ...; if not OK to report then kill array and get next ...I '$$OKRPT(DFN,.VADM) Q | ...I '$$OKRPT(DFN,.VADM) K DGSSNAR S DGIEN="" Q ...; Check if patient was IN/OUT patient in last 3 ye | ...;DGSSNAR array for vet (subscript "V") = name^SSN ...I $$OKIMP(DFN) | ...;P for veterans with pseudo SSN ...;^TMP("DGSSNAR",$J) for vet (subscript "V") = name | ...S DGSSNAR("V")=VADM(1)_"^"_+VADM(2)_"^"_$P(VADM(2) ...S ^TMP("DGSSNAR",$J,DFN,"V")=VADM(1)_"^"_$TR(VADM( | ...Q ..;^TMP("DGSSNAR",$J) for dependents = SSN or Not Ava | ..;DGSSNAR array for dependents = SSN or Not Availabl ...S ^TMP("DGSSNAR",$J,DFN,"D",DGSSNCTR)=$S($P(DGDEP, | ...S DGSSNAR(DGSSNCTR)=$S($P(DGDEP,"^",9):$P(DGDEP,"^ .D:$D(^TMP("DGSSNAR",$J,DFN)) VBLDARR(DFN) | ...Q ; | ..Q D SDAM,SETTMPA | .Q N DGDEPSSN,DGSCTR,DGTMPN1,DGVETSNP,AFLG,APPCK,APPTYP | ;if true add to ^TMP S DFN=0 F S DFN=$O(^TMP("DGSSNAR",$J,DFN)) Q:'DFN D | N DGDEPSSN,DGSCTR,DGTMPN1,DGVETSNP .; Only want appts kept in the last 3 years | I ('DGSSNCTR)!('$D(DGSSNAR("V"))) K DGSSNAR Q .I '$$OK2RPT(DFN) K ^TMP("DGSSNAR",$J,DFN),^TMP($J,"S | S DGVETSNP=$P(DGSSNAR("V"),"^",2) .S DGSSNCTR=+($O(^TMP("DGSSNAR",$J,DFN,"D",""),-1)) | S DGTMPN1=0 .I ('DGSSNCTR)!('$D(^TMP("DGSSNAR",$J,DFN,"V"))) K ^T | F DGSCTR=1:1:DGSSNCTR D .S DGVETSNP=$P(^TMP("DGSSNAR",$J,DFN,"V"),"^",2) | .S DGDEPSSN=$P(DGSSNAR(DGSCTR),"^") .S DGTMPN1=0 | .Q:((DGDEPSSN'=DGVETSNP)&(DGDEPSSN)) .F DGSCTR=1:1:DGSSNCTR D | .I 'DGTMPN1 S ^XTMP("DG-SSNRP2","DGPART1",("A"_$P(DGS ..S DGDEPSSN=$P(^TMP("DGSSNAR",$J,DFN,"D",DGSCTR),"^" | .S ^XTMP("DG-SSNRP2","DGPART1",("A"_$P(DGSSNAR("V")," ..Q:((DGDEPSSN'=DGVETSNP)&(DGDEPSSN)) | .Q ..I 'DGTMPN1 S ^XTMP("DG-SSNRP2","DGPART1",("A"_$P(^T | K DGSSNAR ..S ^XTMP("DG-SSNRP2","DGPART1",("A"_$P(^TMP("DGSSNAR < ;S ^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN,DGCTR2)=DGDEP | ;S ^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN,DGCTR2)=DGDEP > ; K ^TMP("DGSSNAR",$J) | S DGSSN=0 S DGSSN=0 F S DGSSN=$O(^DGPR(408.13,"SSN",DGSSN)) D | F S DGSSN=$O(^DGPR(408.13,"SSN",DGSSN)) D Q:'DGSSN .Q:'DGSSN | .K DGSSNAR > .I 'DGSSN D SETTMP Q ;add to ^TMP ..Q:'DGSSNDA | ..I 'DGSSNDA D SETTMP Q ..;^TMP("DGSSNAR",$J) array = IEN of INCOME PERSON fi | ..; > ..;DGSSNAR array = IEN of INCOME PERSON file (#408.13 ..S ^TMP("DGSSNAR",$J,DGSSN1,DGSSNCTR)=DGSSNDA_"^"_$P | ..S DGSSNAR(DGSSNCTR)=DGSSNDA_"^"_$P(DGSSND,"^") ; | ..Q D SELPRT2,SDAM,SETTMP | .Q Q | Q ; | ; SETTMP ; Spouse/dependent with the same SSN | SETTMP ;check if >1 spouse/dependent with the same SSN N DGSSNCTR,DGDEPNM,DGDEPREL,DGPAT,DGPATRL,DGSCTR,DGSS | ;if >1 add to ^TMP S DGSSN="" F S DGSSN=$O(^TMP("DGSSNAR",$J,DGSSN)) Q: | ; .S DGSSNCTR=+($O(^TMP("DGSSNAR",$J,DGSSN,""),-1)) | N DGDEPNM,DGDEPREL,DGPAT,DGPATRL,DGSCTR,DGSSNDA1,DGVE .F DGSCTR=1:1:DGSSNCTR D | I DGSSNCTR'>1 K DGSSNAR Q ..S DGSSNDA1=$P(^TMP("DGSSNAR",$J,DGSSN,DGSCTR),"^") | F DGSCTR=1:1:DGSSNCTR D ..S DGDEPNM=$P(^TMP("DGSSNAR",$J,DGSSN,DGSCTR),"^",2) | .S DGSSNDA1=$P(DGSSNAR(DGSCTR),"^") ..S DGPAT=$O(^DGPR(408.12,"C",DGSSNDA1_";DGPR(408.13, | .S DGDEPNM=$P(DGSSNAR(DGSCTR),"^",2) ..S DGPATRL=$G(^DGPR(408.12,+DGPAT,0)) | .S DGPAT=$O(^DGPR(408.12,"C",DGSSNDA1_";DGPR(408.13," ..;missing "C" x-ref or 0 node of 408.12 record | .S DGPATRL=$G(^DGPR(408.12,+DGPAT,0)) ..I 'DGPATRL S DGDEPREL="U",DGVETSN2="UNKNOWN" | .;missing "C" x-ref or 0 node of 408.12 record ..E D I +DGVETSN2 Q:'$$OK2RPT(DFN) | .I 'DGPATRL S DGDEPREL="U",DGVETSN2="UNKNOWN" ...S DFN=+DGPATRL | .E D I +DGVETSN2 Q:'$$OKRPT(DGVETSN2) ...D DEM^VADPT | ..S DFN=+DGPATRL ...S DGVETSN2=$P($G(VADM(2)),"^") | ..D DEM^VADPT ...S DGDEPREL=$P(DGPATRL,"^",2) | ..S DGVETSN2=$P($G(VADM(2)),"^") ..S ^XTMP("DG-SSNRP2","DGPART2",DGSSN,DGSCTR)=DGDEPNM | ..S DGDEPREL=$P(DGPATRL,"^",2) > ..Q > .S ^XTMP("DG-SSNRP2","DGPART2",DGSSN1,DGSCTR)=DGDEPNM > .Q > K DGSSNAR > S DGSSNCTR=0 > ; HEADER ;Description: Prints the report header. | HEADER ; > ;Description: Prints the report header. > ; W ?70,"Page ",PAGE,!,?26,"Date Generated: "_$$FMTE^XL | W ?70,"Page ",PAGE > W !,?26,"Date Generated: "_$$FMTE^XLFDT(DT) W !,$S(SECTION="PART1":" Spouse/Dependent | W ! > W $S(SECTION="PART1":" Spouse/Dependent wi .I 'PART1D,$D(^TMP($J,"SDAMA","ERR")) W !!,?10,"Appoi < > .Q .I 'PART2D,$D(^TMP($J,"SDAMA","ERR")) W !!,?10,"Appoi < > .Q PAUSE N DIR,DIRUT,X,Y | PAUSE ; > ;Description: Screen pause. Sets QUIT=1 if user deci > ; > N DIR,DIRUT,X,Y S DIR(0)="E" D ^DIR | S DIR(0)="E" > D ^DIR PPART1 ;Description: Prints Part 1 - Spouse/Dependent with n | PPART1 ; N DGPART1,DGSCTR,LINE S DGVETSSN=0 | ;Description: Prints Part 1 - Spouse/Dependent with n > ; > N DGPART1,DGSCTR,LINE > S DGVETSSN=0 .S DGSCTR=0,DGVETNM=$G(^XTMP("DG-SSNRP2","DGPART1",DG | .S DGSCTR=0 > .S DGVETNM=$G(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN)) PPART2 ;Description: Prints Part 2 -Spouse/Dependent with th | PPART2 ; > ;Description: Prints Part 2 -Spouse/Dependent with th > ; S DGP2F=1,DGDEPSSN=0 | S DGP2F=1 > S DGDEPSSN=0 > ; N DGNAME S DGNAME=$P($G(^DG(408.11,+DGCODE,0)),"^") | N DGNAME > S DGNAME=$P($G(^DG(408.11,+DGCODE,0)),"^") OKRPT(DFN,VADM) ; Date of Death? | OKRPT(DFN,VADM) ; Check if patient can be reported N X,X1,X2 | ; > ; Input: > ; DFN - Patient (#2) file IEN > ; VADM - VADPT API demographic array for this pati > ; Ouput: > ; 0: do not report > ; 1: report patient > ; > N VAIP,X,X1,X2 > ; > ; if veteran has a Date of Death Q 1 | ; has veteran been an Inpatient or Outpatient in the ; | S VAIP("D")="LAST" D IN5^VADPT OKIMP(DFN) ; Inpatient or Outpatient in the last 3 years | I VAIP(3)'="" S X1=DT,X2=$P(VAIP(3),U)\1 D ^%DTC Q '( N VAIP S VAIP("D")="LAST" D IN5^VADPT | ; if not an inpatient then check for appointment I VAIP(3)'="" D Q '(X>1095) | N VASD .S X1=DT,X2=$P(VAIP(3),U)\1 D ^%DTC | ; want appts kept in the last 3 years & ignore future .I X<1096 S ^TMP($J,"SDAMA",DFN,+VAIP(3))="^^I;INPATI | S VASD("W")=1,VASD("T")=DT Q 1 | S X1=DT,X2=1095 D C^%DTC S VASD("F")=X ; | D SDA^VADPT OK2RPT(DFN) ; Appt kept in the last 3 years? | Q ($D(^UTILITY("VASD",$J))) N APPCK,AFLG S (APPCK,AFLG)=0 < F S APPCK=$O(^TMP($J,"SDAMA",DFN,APPCK)) Q:'APPCK!(A < .S APPTYP=$P($P(^TMP($J,"SDAMA",DFN,APPCK),U,3),";") < .I "^R^I^"[(U_APPTYP_U) S AFLG=1 < Q AFLG < ; < VBLDARR(DFN) ; Build array of specified veterans < S ^TMP($J,"SDAMAPI",VARR)=$G(^TMP($J,"SDAMAPI",VARR)) < I $L(^TMP($J,"SDAMAPI",VARR))>180 S VARR=VARR+1 < Q < ; < SDAM N DGARRAY,I,SDCNT < S DGARRAY(1)=$$FMADD^XLFDT(DT,-1095)_";"_DT,DGARRAY(" < F I=1:1 Q:'$D(^TMP($J,"SDAMAPI",I)) D < .S DGARRAY(4)=^TMP($J,"SDAMAPI",I) < .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) < .I SDCNT'>0 K ^TMP($J,"SDAMA301"),^TMP($J,"SDAMAPI",I < .M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301") < .K ^TMP($J,"SDAMA301"),^TMP($J,"SDAMAPI",I) < I '$D(^TMP($J,"SDAMA")) S ^TMP($J,"SDAMA","ERR")="" < Q < ; < SELPRT2 ; Select records for Part 2 < N DGSSN,DGCNT,DGSSNP,DGPTR,DGPTRL,VARR S VARR=1 < S DGSSN="" F S DGSSN=$O(^TMP("DGSSNAR",$J,DGSSN)) Q: < .S DGCNT=$O(^TMP("DGSSNAR",$J,DGSSN,""),-1) < .I DGCNT<2 K ^TMP("DGSSNAR",$J,DGSSN) Q < .S DGSSNP=$P(^TMP("DGSSNAR",$J,DGSSN,DGCNT),U) < .S DGPTR=$O(^DGPR(408.12,"C",DGSSNP_";DGPR(408.13,",0 < .S DGPTRL=+$G(^DGPR(408.12,+DGPTR,0)) < .I $$OKIMP(DGPTRL) < .Q:$D(^TMP($J,"SDAMA",DGPTRL)) < .D VBLDARR(DGPTRL) < Q < diff -y --suppress-common-lines ./VADemo/r1/DGSTAT.m ./VADemo/r2/r/DGSTAT.m DGSTAT ;ALB/MRL - ADT SYSTEM STATUS DISPLAY ; 03/12/2004 | DGSTAT ;ALB/MRL - ADT SYSTEM STATUS DISPLAY ; 19 JUN 87 13: ;;5.3;Registration;**75,151,568**;Aug 13, 1993 | ;;5.3;Registration;**75,151**;Aug 13, 1993 S X=$$LAST^DGSDUTL,X=$G(^SDD(409.65,+X,0)) ; | S X=$$LAST^SDAMLD,X=$G(^SDD(409.65,+X,0)) ; diff -y --suppress-common-lines ./VADemo/r1/DGUTL3.m ./VADemo/r2/r/DGUTL3.m DGUTL3 ;ALB/MTC - ELIGIBILITY UTILITIES ; 3/10/03 3:41pm | DGUTL3 ;ALB/MTC - ELIGIBILITY UTILITIES ; 20-NOV-96 ;;5.3;Registration;**114,506**;Aug 13, 1993 | ;;5.3;Registration;**114**;Aug 13, 1993 BADADR(DFN) ;does this patient have a bad address? < ; < Q:'$G(DFN) "" < Q $P($G(^DPT(DFN,.11)),"^",16) < ; < DELBAI(DFN) ;delete bad address indicator < N FDA,IENS < Q:'$G(DFN) < S IENS=DFN_",",FDA(2,IENS,.121)="@" < D FILE^DIE("E","FDA") < Q < diff -y --suppress-common-lines ./VADemo/r1/DGUTL.m ./VADemo/r2/r/DGUTL.m ;;5.3;Registration;**279,570**;Aug 13, 1993 | ;;5.3;Registration;**279**;Aug 13, 1993 ; ** NOTE: This procedure appears to be obsolete, but | ; ** NOTE: The line below will cause errors if used. ; for IB/AR Encapsulation anyways. | S DGINS1=0 F DGINS=0:0 S DGINS=$O(^DPT(DFN,.312,DGINS S DGINS=$$INSUR^IBBAPI(DFN,"","A") | S DGINS=DGINS1 K DGINS1 Q Q < ; < diff -y --suppress-common-lines ./VADemo/r1/DGUTQ.m ./VADemo/r2/r/DGUTQ.m DGUTQ ;ALB/AAS - QUEUEING UTILITY (%ZTLOAD) ; 16-JUL-2003 | DGUTQ ;ALB/AAS - QUEUEING UTILITY (%ZTLOAD) ; 26-JUN-89 ;;5.3;Registration;**539**;Aug 13, 1993 | ;;5.3;Registration;;Aug 13, 1993 ZIS W ! K IOP,IO("Q") S POP=0,%ZIS="QMP" S:$D(DGFZIS) IOP | ZIS W ! K IOP,IO("Q") S POP=0,%ZIS="QMP" D ^%ZIS K %ZIS,I D ^%ZIS K %ZIS,IOP Q:POP I $D(IO("Q")) D QUE S POP=1 < FZIS ;Settings for force queuing < N DGFZIS < S DGFZIS=1 G ZIS < diff -y --suppress-common-lines ./VADemo/r1/DGX5F1.m ./VADemo/r2/r/DGX5F1.m DGX5F1 ; ;12/28/04 | DGX5F1 ; ;10/06/97 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(5)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(5)=% S N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y S DE(DW)="C2^DGX5F1",DE(DW,"INDEX")=1 | S DE(DW)="C2^DGX5F1" C2 G C2S:$D(DE(2))[0 K DB | C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE S X=DE(2),DIC=DIE < 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 X=DG(DQ),DIC=DIE < C2F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=447,448,449,450,451,452,453,454,455,456 S DIEZ < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 | 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y C5 G C5S:$D(DE(5))[0 K DB | C5 G C5S:$D(DE(5))[0 K DB S X=DE(5),DIC=DIE S X=DE(5),DIC=DIE < 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 S X=DG(DQ),DIC=DIE < C5F1 Q | Q 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) | 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) | 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 G A:$D(Y)[0,A 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) | 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 G A:$D(Y)[0,A S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) | 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 G A:$D(Y)[0,A 19 S DW="0;18",DV="S",DU="",DLB="WAS TREATMENT FOR A SER | 19 D:$D(DG)>9 F^DIE17 G ^DGX5F2 S DU="1:YES;2:NO;" < S Y="NO" < G Y < X19 Q < 20 S DQ=21 ;@27 < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 S DGNFLD="@28" < Q < 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) < X22 S Y="@900" < Q < 23 S DQ=24 ;@28 < 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) < X24 S DGNFLD="@30" < Q < 25 S DW="0;5",DV="*P80'X",DU="",DLB="ICD 1",DIFLD=5 < S DE(DW)="C25^DGX5F1",DE(DW,"INDEX")=1 < S DU="ICD9(" < G RE < C25 G C25S:$D(DE(25))[0 K DB < S X=DE(25),DIC=DIE < K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=DE(25),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C25S S X="" G:DG(DQ)=X C25F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C25F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=447 S DIEZRXR(45.02,DIXR)="" < Q < X25 K K S DIC("S")="S DGI=5 D EN^DGPTFJC I 'DGER" D ^DIC < Q < ; < 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) < X26 I X K DGPTIT S DGNFLD="@30",Y="@800",DGPTIT(X_$C(59)_ < Q < 27 S DQ=28 ;@30 < 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) < X28 S DGNFLD="@40" < Q < 29 D:$D(DG)>9 F^DIE17,DE S DQ=29,DW="0;6",DV="*P80'X",DU < S DE(DW)="C29^DGX5F1",DE(DW,"INDEX")=1 < S DU="ICD9(" < G RE < C29 G C29S:$D(DE(29))[0 K DB < D ^DGX5F2 < C29S S X="" G:DG(DQ)=X C29F1 K DB < D ^DGX5F3 < C29F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=448 S DIEZRXR(45.02,DIXR)="" < Q < X29 K K S DIC("S")="S DGI=6 D EN^DGPTFJC I 'DGER" D ^DIC < Q < ; < 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE) < X30 I X K DGPTIT S DGNFLD="@40",Y="@800",DGPTIT(X_$C(59)_ < Q < 31 S DQ=32 ;@40 < 32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE) < X32 S DGNFLD="@50" < Q < 33 D:$D(DG)>9 F^DIE17 G ^DGX5F4 < diff -y --suppress-common-lines ./VADemo/r1/DGX5F2.m ./VADemo/r2/r/DGX5F2.m DGX5F2 ; ;12/28/04 | DGX5F2 ; ;10/06/97 S X=DE(29),DIC=DIE | D DE G BEGIN > DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(7)=% S > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 > D ^DIR I 'DDER S %=Y(0),X=Y > Q > BEGIN S DNM="DGX5F2",DQ=1 > 1 S DW="0;18",DV="S",DU="",DLB="TREATED FOR SC CONDITIO > S DU="1:YES;2:NO;" > S Y="NO" > G Y > X1 Q > 2 S DQ=3 ;@27 > 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y > X3 S DGNFLD="@28" > Q > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y > X4 S Y="@900" > Q > 5 S DQ=6 ;@28 > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y > X6 S DGNFLD="@30" > Q > 7 S DW="0;5",DV="*P80'X",DU="",DLB="ICD 1",DIFLD=5 > S DE(DW)="C7^DGX5F2" > S DU="ICD9(" > G RE > C7 G C7S:$D(DE(7))[0 K DB S X=DE(7),DIC=DIE S X=DE(29),DIC=DIE | C7S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D | S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > Q > X7 K K S DIC("S")="S DGI=5 D EN^DGPTFJC I 'DGER" D ^DIC > Q > ; > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y > X8 I X K DGPTIT S DGNFLD="@30",Y="@800",DGPTIT(X_$C(59)_ > Q > 9 S DQ=10 ;@30 > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A > X10 S DGNFLD="@40" > Q > 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="0;6",DV="*P80'X",DU > S DE(DW)="C11^DGX5F2" > S DU="ICD9(" > G RE > C11 G C11S:$D(DE(11))[0 K DB S X=DE(11),DIC=DIE > K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > C11S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > Q > X11 K K S DIC("S")="S DGI=6 D EN^DGPTFJC I 'DGER" D ^DIC > Q > ; > 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 G A:$D(Y)[0,A > X12 I X K DGPTIT S DGNFLD="@40",Y="@800",DGPTIT(X_$C(59)_ > Q > 13 S DQ=14 ;@40 > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 G A:$D(Y)[0,A > X14 S DGNFLD="@50" > Q > 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="0;7",DV="*P80'X",DU > S DE(DW)="C15^DGX5F2" > S DU="ICD9(" > G RE > C15 G C15S:$D(DE(15))[0 K DB S X=DE(15),DIC=DIE > K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > C15S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > Q > X15 K K S DIC("S")="S DGI=7 D EN^DGPTFJC I 'DGER" D ^DIC > Q > ; > 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 G A:$D(Y)[0,A > X16 I X K DGPTIT S DGNFLD="@50",Y="@800",DGPTIT(X_$C(59)_ > Q > 17 S DQ=18 ;@50 > 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 G A:$D(Y)[0,A > X18 S DGNFLD="@60" > Q > 19 D:$D(DG)>9 F^DIE17 G ^DGX5F3 diff -y --suppress-common-lines ./VADemo/r1/DGX5F3.m ./VADemo/r2/r/DGX5F3.m DGX5F3 ; ;12/28/04 | DGX5F3 ; ;10/06/97 S X=DG(DQ),DIC=DIE | D DE G BEGIN > DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,8) S:%]"" DE(1)=% S > I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,2) S:%]"" DE(12) > 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 " (N > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 > D ^DIR I 'DDER S %=Y(0),X=Y > Q > BEGIN S DNM="DGX5F3",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;8",DV="*P80'X",DU= > S DE(DW)="C1^DGX5F3" > S DU="ICD9(" > G RE > C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE > K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S X=DG(DQ),DIC=DIE | Q X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D | X1 K K S DIC("S")="S DGI=8 D EN^DGPTFJC I 'DGER" D ^DIC > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y > X2 I X K DGPTIT S DGNFLD="@60",Y="@800",DGPTIT(X_$C(59)_ > Q > 3 S DQ=4 ;@60 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y > X4 S DGNFLD="@70" > Q > 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;9",DV="*P80'X",DU= > S DE(DW)="C5^DGX5F3" > S DU="ICD9(" > G RE > C5 G C5S:$D(DE(5))[0 K DB S X=DE(5),DIC=DIE > K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) > C5S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE > S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" > Q > X5 K K S DIC("S")="S DGI=9 D EN^DGPTFJC I 'DGER" D ^DIC > Q > ; > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y > X6 I X K DGPTIT S DGNFLD="@70",Y="@800",DGPTIT(X_$C(59)_ > Q > 7 S DQ=8 ;@70 > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y > X8 K DGNFLD,DGDUP S Y="" > Q > 9 S DQ=10 ;@800 > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A > X10 D SCAN^DGPTSCAN S:'$D(DGBPC) Y="@899" > Q > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 G A:$D(Y)[0,A > X11 I '$D(DGBPC(2))!(DGDUP(2)) S Y="@820" > Q > 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="300;2",DV="SX",DU=" > S DU="1:Attempted Suicide;2:Accomplished Suicide;3:Se > G RE > X12 S DGFLAG=2 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG Q > Q > ; > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 G A:$D(Y)[0,A > X13 S:X]"" DGDUP(2)=1 > Q > 14 S DQ=15 ;@820 > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 G A:$D(Y)[0,A > X15 I '$D(DGBPC(3))!(DGDUP(3)) S Y="@830" > Q > 16 S DW="300;3",DV="SX",DU="",DLB="LEGIONNAIRE'S DISEASE > S DU="1:Yes;2:No;" > G RE > X16 S DGFLAG=3 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG Q > Q > ; > 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 G A:$D(Y)[0,A > X17 S:X]"" DGDUP(3)=1 > Q > 18 S DQ=19 ;@830 > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 G A:$D(Y)[0,A > X19 I '$D(DGBPC(4))!(DGDUP(4)) S Y="@840" > Q > 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 G A:$D(Y)[0,A > X20 D DRUG^DGPTSC01 I $D(DGTX) S Y="@835" > Q > 21 D:$D(DG)>9 F^DIE17 G ^DGX5F4 diff -y --suppress-common-lines ./VADemo/r1/DGX5F4.m ./VADemo/r2/r/DGX5F4.m DGX5F4 ; ;12/28/04 | DGX5F4 ; ;10/06/97 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,7) S:%]"" DE(1)=% S | I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,4) S:%]"" DE(1)= I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,2) S:%]"" DE(16) < N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;7",DV="*P80'X",DU= | 1 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE S DE(DW)="C1^DGX5F4",DE(DW,"INDEX")=1 | S DU="DIC(45.61," S DU="ICD9(" < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=DE(1),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C1F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=449 S DIEZRXR(45.02,DIXR)="" < Q < X1 K K S DIC("S")="S DGI=7 D EN^DGPTFJC I 'DGER" D ^DIC < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 I X K DGPTIT S DGNFLD="@50",Y="@800",DGPTIT(X_$C(59)_ < Q < 3 S DQ=4 ;@50 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 S DGNFLD="@60" < Q < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;8",DV="*P80'X",DU= < S DE(DW)="C5^DGX5F4",DE(DW,"INDEX")=1 < S DU="ICD9(" < G RE < C5 G C5S:$D(DE(5))[0 K DB < S X=DE(5),DIC=DIE < K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=DE(5),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C5S S X="" G:DG(DQ)=X C5F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C5F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=450 S DIEZRXR(45.02,DIXR)="" < Q < X5 K K S DIC("S")="S DGI=8 D EN^DGPTFJC I 'DGER" D ^DIC < Q < ; < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 I X K DGPTIT S DGNFLD="@60",Y="@800",DGPTIT(X_$C(59)_ < Q < 7 S DQ=8 ;@60 < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 S DGNFLD="@70" < Q < 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;9",DV="*P80'X",DU= < S DE(DW)="C9^DGX5F4",DE(DW,"INDEX")=1 < S DU="ICD9(" < C9 G C9S:$D(DE(9))[0 K DB | X1 S DGFLAG=4 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG S X=DE(9),DIC=DIE < K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA) < S X=DE(9),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C9S S X="" G:DG(DQ)=X C9F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T N D < C9F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF( < F DIXR=451 S DIEZRXR(45.02,DIXR)="" < Q < X9 K K S DIC("S")="S DGI=9 D EN^DGPTFJC I 'DGER" D ^DIC < Q < ; < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 I X K DGPTIT S DGNFLD="@70",Y="@800",DGPTIT(X_$C(59)_ < Q < 11 S DQ=12 ;@70 < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 K DGNFLD,DGDUP S Y="" < Q < 13 S DQ=14 ;@800 < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 D SCAN^DGPTSCAN S:'$D(DGBPC) Y="@899" < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) | ; X15 I '$D(DGBPC(2))!(DGDUP(2)) S Y="@820" | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y > X2 S:X]"" DGDUP(4)=1 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="300;2",DV="SX",DU=" | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y S DU="1:Attempted Suicide;2:Accomplished Suicide;3:Se | X3 S Y="@840" G RE | Q X16 S DGFLAG=2 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG Q | 4 S DQ=5 ;@835 > 5 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE > S DU="DIC(45.61," > S X=DGTX > S Y=X > G Y > X5 S DGFLAG=4 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) | 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y X17 S:X]"" DGDUP(2)=1 | X6 S:X]"" DGDUP(4)=1 18 S DQ=19 ;@820 | 7 S DQ=8 ;@840 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) | 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y X19 I '$D(DGBPC(3))!(DGDUP(3)) S Y="@830" | X8 I '$D(DGBPC(5))!(DGDUP(5)) S Y="@850" 20 S DW="300;3",DV="SX",DU="",DLB="LEGIONNAIRE'S DISEASE | 9 S DW="300;5",DV="SX",DU="",DLB="PSYCHIATRY CLASS. SEV S DU="1:Yes;2:No;" | S DU="0:INADEQUATE INFO OR NO CHANGE;1:NONE;2:MILD;3: X20 S DGFLAG=3 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG Q | X9 S DGFLAG=5 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) | 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A X21 S:X]"" DGDUP(3)=1 | X10 S:X]"" DGDUP(5)=1 22 S DQ=23 ;@830 | 11 S DQ=12 ;@850 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) | 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 G A:$D(Y)[0,A X23 I '$D(DGBPC(4))!(DGDUP(4)) S Y="@840" | X12 I '$D(DGBPC(6))!(DGDUP(6)) S Y="@860" 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) | 13 S DW="300;6",DV="NJ2,0X",DU="",DLB="CURRENT PSYCH CLA X24 D DRUG^DGPTSC01 I $D(DGTX) S Y="@835" | G RE > X13 S DGFLAG=6 D 501^DGPTSC01 S:DGER X="" K DGFLAG,DGER K 25 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE | ; S DU="DIC(45.61," | 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 G A:$D(Y)[0,A > X14 S:X]"" DGDUP(6)=1 > Q > 15 S DQ=16 ;@860 > 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 G A:$D(Y)[0,A > X16 I '$D(DGBPC(7))!(DGDUP(7)) S Y="@899" > Q > 17 S DW="300;7",DV="NJ2,0X",DU="",DLB="HIGH LEVEL PSYCH X25 S DGFLAG=4 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG | X17 S DGFLAG=7 D 501^DGPTSC01 S:DGER X="" K DGER,DGFLAG K 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) | 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 G A:$D(Y)[0,A X26 S:X]"" DGDUP(4)=1 | X18 S:X]"" DGDUP(7)=1 > Q > 19 S DQ=20 ;@899 > 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 G A:$D(Y)[0,A > X20 K DGPTIT S Y=DGNFLD > Q > 21 S DQ=22 ;@900 > 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 G A:$D(Y)[0,A > X22 K DGEXQ D CHQUES^DGPTSPQ I '$D(DGEXQ) S Y="@999" 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) | 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 G A:$D(Y)[0,A X27 S Y="@840" | X23 I '$D(DGEXQ(1)) S Y="@910" 28 S DQ=29 ;@835 | 24 D:$D(DG)>9 F^DIE17 G ^DGX5F5 29 D:$D(DG)>9 F^DIE17 G ^DGX5F5 < diff -y --suppress-common-lines ./VADemo/r1/DGX5F5.m ./VADemo/r2/r/DGX5F5.m DGX5F5 ; ;12/28/04 | DGX5F5 ; ;10/06/97 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,26) S:%]"" DE(26)=%, | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,26) S:%]"" DE(1)=%,D I $D(^(300)) S %Z=^(300) S %=$P(%Z,U,4) S:%]"" DE(1)= < N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < 1 S DW="300;4",DV="P45.61'X",DU="",DLB="SUBSTANCE ABUSE | 1 S DW="0;26",DV="SX",DU="",DLB="TREATED FOR AO CONDITI S DU="DIC(45.61," | S DU="Y:YES;N:NO;" S X=DGTX < S Y=X < G Y < X1 S DGFLAG=4 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S:X]"" DGDUP(4)=1 < Q < 3 S DQ=4 ;@840 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 I '$D(DGBPC(5))!(DGDUP(5)) S Y="@850" < Q < 5 S DW="300;5",DV="SX",DU="",DLB="PSYCHIATRY CLASS. SEV < S DU="0:INADEQUATE INFO OR NO CHANGE;1:NONE;2:MILD;3: < G RE < X5 S DGFLAG=5 D 501^DGPTSC01 K:DGER X K DGER,DGFLAG < Q < ; < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 S:X]"" DGDUP(5)=1 < Q < 7 S DQ=8 ;@850 < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 I '$D(DGBPC(6))!(DGDUP(6)) S Y="@860" < Q < 9 S DW="300;6",DV="NJ2,0X",DU="",DLB="CURRENT PSYCH CLA < G RE < X9 S DGFLAG=6 D 501^DGPTSC01 S:DGER X="" K DGFLAG,DGER K < Q < ; < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S:X]"" DGDUP(6)=1 < Q < 11 S DQ=12 ;@860 < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 I '$D(DGBPC(7))!(DGDUP(7)) S Y="@899" < Q < 13 S DW="300;7",DV="NJ2,0X",DU="",DLB="HIGH LEVEL PSYCH < X13 S DGFLAG=7 D 501^DGPTSC01 S:DGER X="" K DGER,DGFLAG K | X1 S DGFLAG=1 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y X14 S:X]"" DGDUP(7)=1 | X2 S Y="@915" 15 S DQ=16 ;@899 | 3 S DQ=4 ;@910 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) | 4 S DW="0;26",DV="SX",DU="",DLB="TREATED FOR AO CONDITI X16 K DGPTIT S Y=DGNFLD < Q < 17 S DQ=18 ;@900 < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 K DGEXQ D CHQUES^DGPTSPQ I '$D(DGEXQ) S Y="@999" < Q < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 I '$D(DGEXQ(6)) S Y="@904" < Q < 20 S DW="0;31",DV="S",DU="",DLB="WAS TREATMENT RELATED T < S DU="Y:YES;N:NO;" < G RE < X20 Q < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 S Y="@905" < Q < 22 S DQ=23 ;@904 < 23 S DW="0;31",DV="S",DU="",DLB="POTENTIALLY RELATED TO < X23 Q | X4 S DGFLAG=1 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG 24 S DQ=25 ;@905 < 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) < X25 I '$D(DGEXQ(1)) S Y="@910" < 26 S DW="0;26",DV="SX",DU="",DLB="WAS TREATMENT RELATED | ; > 5 S DQ=6 ;@915 > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y > X6 I '$D(DGEXQ(2)) S Y="@920" > Q > 7 S DW="0;27",DV="SX",DU="",DLB="TREATED FOR IR CONDITI X26 S DGFLAG=1 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG | X7 S DGFLAG=2 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) | 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y X27 S Y="@915" | X8 S Y="@925" 28 S DQ=29 ;@910 | 9 S DQ=10 ;@920 29 S DW="0;26",DV="SX",DU="",DLB="TREATED FOR AO CONDITI | 10 S DW="0;27",DV="SX",DU="",DLB="TREATED FOR IR CONDITI X29 S DGFLAG=1 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG | X10 S DGFLAG=2 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG 30 S DQ=31 ;@915 | 11 S DQ=12 ;@925 31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE) | 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 G A:$D(Y)[0,A X31 I '$D(DGEXQ(2)) S Y="@920" | X12 I '$D(DGEXQ(3)) S Y="@930" 32 S DW="0;27",DV="SX",DU="",DLB="WAS TREATMENT RELATED | 13 S DW="0;28",DV="SX",DU="",DLB="EXPOSED TO ENVIR CONTA X32 S DGFLAG=2 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG | X13 S DGFLAG=3 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE) | 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 G A:$D(Y)[0,A X33 S Y="@925" | X14 S Y="@935" 34 S DQ=35 ;@920 | 15 S DQ=16 ;@930 35 S DW="0;27",DV="SX",DU="",DLB="TREATED FOR IR CONDITI | 16 S DW="0;28",DV="SX",DU="",DLB="EXPOSED TO ENVIR CONTA X35 S DGFLAG=2 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG | X16 S DGFLAG=3 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG Q < ; < 36 S DQ=37 ;@925 < 37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE) < X37 I '$D(DGEXQ(3)) S Y="@930" < Q < 38 S DW="0;28",DV="SX",DU="",DLB="WAS TREATMENT RELATED < S DU="Y:YES;N:NO;" < G RE < X38 S DGFLAG=3 D 501^DGPTSPQ K:DGER X K DGER,DGFLAG < 39 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=39 D X39 D:$D(DIEFIRE) | 17 S DQ=18 ;@935 X39 S Y="@935" | 18 S DQ=19 ;@999 > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 G A:$D(Y)[0,A > X19 K DGEXQ S Y=DGNFLD 40 S DQ=41 ;@930 | 20 G 1^DIE17 41 D:$D(DG)>9 F^DIE17 G ^DGX5F6 < Only in ./VADemo/r1/: DGX5F6.m Only in ./VADemo/r1/: DGX5F7.m diff -y --suppress-common-lines ./VADemo/r1/DGX5F.m ./VADemo/r2/r/DGX5F.m DGX5F ; GENERATED FROM 'DG501F' INPUT TEMPLATE(#429), FILE | DGX5F ; GENERATED FROM 'DG501F' INPUT TEMPLATE(#429), FILE N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=429,U="^" M DIEZAR=^DIE(429,"AR") S DICRREC="TRIG^DIE17" | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=42 < 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 G A:$D(Y)[0,A:Y S DIFLD=50,DGO="^DGX5F1",DC="36^45.02AI^M^",DV="45.02 | S DIFLD=50,DGO="^DGX5F1",DC="33^45.02AI^M^",DV="45.02 Only in ./VADemo/r1/: DGYPSDE1.m Only in ./VADemo/r1/: DGYPSDE2.m diff -y --suppress-common-lines ./VADemo/r1/DIAU.m ./VADemo/r2/r/DIAU.m DIAU ;SFISC/XAK-AUDIT OPTIONS ;24JUNE2003 | DIAU ;SFISC/XAK-AUDIT OPTIONS ;02:57 PM 30 May 2001 ;;22.0;VA FileMan;**76,129**;Mar 30, 1999 | ;;22.0;VA FileMan;**76**;Mar 30, 1999 S DIC("S")="I $D(^DIA(+Y)),'$D(^DD(+Y,0,""AUDPURGEFOR | S DIC("S")="I $D(^DIA(+Y)) S DIAC=""AUDIT"",DIFILE=+Y W ! S L="PURGE AUDIT RECORDS",DIOEND="D ENDKILL^DIAU" | W ! S L="PURGE AUDIT RECORDS",DIOEND="W !!,DIACNT,"" S DHIT="D KILLDIA^DIAU",DIACNT=0 | S DHIT="S DIK=DCC,DA=D0,DIACNT=DIACNT+1 D ^DIK",DIACN KILLDIA ;CALLED FROM DHIT < S X=$G(^DIA(DIA,D0,0)) K ^DIA(DIA,D0) < S Y=$P(X,U) I Y K ^DIA(DIA,"B",Y,D0) < S Y=$P(X,U,2) I Y K ^DIA(DIA,"C",Y,D0) < S Y=$P(X,U,4) K ^DIA(DIA,"D",+Y,D0) < S DIACNT=DIACNT+1 Q < ; < ENDKILL ;CHECK DANGLERS < S $P(^(0),U,4)=$P($G(^DIA(DIA,0)),U,4)-DIACNT < W !!,"...",! W $$DANGLE(DIA)," POINTERS FIXED." < W !!,DIACNT," RECORDS PURGED." < Q < ; < DANGLE(DIA) ;CLEAN DANGLERS < N A,B,D0,AA,C < S C=0 < F AA=1,2,4 S A=$E("BC D",AA),B="" D < .F S B=$O(^DIA(DIA,A,B)) Q:B="" D < ..F D0=0:0 S D0=$O(^DIA(DIA,A,B,D0)) Q:'D0 I $P($G(^ < Q C < ; < S DIC("S")="I '$D(^DD(+Y,0,""DDAUDPURGEFORBID"")) S D | S DIC("S")="S DIAC=""AUDIT"",DIFILE=+Y D ^DIAC I DIAC diff -y --suppress-common-lines ./VADemo/r1/DIAUTL.m ./VADemo/r2/r/DIAUTL.m DIAUTL ;GFT;13AUG2004 | DIAUTL ;SFISC/GFT-AUDITING UTILITIES;03:41 PM 2 May 2002 ;;22.0;VA FileMan;**76,140**;Mar 30, 1999 | ;;22.0;VA FileMan;**76**;Mar 30, 1999 I D Q:$P($G(^DD(+D,.01,0)),U,2)["W" D TURNON(+D,"**" | I D Q:$P($G(^DD(+D,.01,0)),U,2)["W" D TURNON(+D,"**" I DA=.001,DIMODE="y" Q ;CAN'T AUDIT NUMBER FIELD!! < diff -y --suppress-common-lines ./VADemo/r1/DIC1.m ./VADemo/r2/r/DIC1.m DIC1 ;SFISC/GFT/TKW-READ X, SHOW CHOICES ;8:39 AM 22 Jan | DIC1 ;SFISC/GFT/TKW-READ X, SHOW CHOICES ;8:33 AM 24 Sep ;;22.0;VA FileMan;**1,4,17,20,31,48,78,86,70,122**;Ma | ;;22.0;VA FileMan;**1,4,17,20,31,48,78,86,70**;Mar 30 . . I DS>DD W !,"Press to see more, '^' to e | . . I DS>DD W !,"Press to see more, '^' to e diff -y --suppress-common-lines ./VADemo/r1/DICATTD6.m ./VADemo/r2/r/DICATTD6.m DICATTD6 ;GFT;09:51 AM 3 Dec 2002;COMPUTED FIELD | DICATTD6 ;GFT;08:09 PM 28 Dec 2000;COMPUTED FIELD ;;22.0;VA FileMan;**42,118**;Mar 30, 1999 | ;;22.0;VA FileMan;;**42**;Mar 30, 1999 ;83.1 = POINT TO FILE < F I=80:1:83 D UNED^DDSUTL(I,"DICATT6",2.6,DICM) ;If m | F I=79:1:83 D UNED^DDSUTL(I,"DICATT6",2.6,DICM) ;If m D UNED^DDSUTL(83.1,"DICATT6",2.6,Y'["p") < D PUT^DDSVALF(79,"DICATT6",2.6,$$TYPE^DICATT3(S)) | D PUT^DDSVALF(79,"DICATT6",2.6,$S(S["D":"D",S["B":"B" N A,S | N A D UNED^DDSUTL(83.1,"DICATT6",2.6,X'["p") | I X["D"!(X["B")!(X["m") D S A="" I X["p" S A=$P($G(DICATT2N),"p",2) S:'A A=$P(D | .F A=80:1:83 D UNED^DDSUTL(A,"DICATT6",2.6,1) ;for DA D PUT^DDSVALF(83.1,,,A) | E I $$G(79)="" D PUT^DDSVALF(83,,,8) ;default length S S=X["D"!(X["B")!(X["m")!(X["p") < F A=80:1:83 D UNED^DDSUTL(A,"DICATT6",2.6,S) I S D PU < I $$G(79)="" D PUT^DDSVALF(83,,,8) ;default length of < F A=80,81,82 D PUT^DDSVALF(A,,,""),UNED^DDSUTL(A,"DIC | F A=80,81,82 D PUT^DDSVALF(A,,,"") Q | S DDSBR=83 Q S T=$$G(79) | S T=$$G(79) G CHNGD:T["m" F I="D","B","m","mp","p" I T=I S:T["p" T=T_$$G(83.1) | F I="D","B" I T=I S DICATT2N="C"_T G CHNGD ;may be Bo diff -y --suppress-common-lines ./VADemo/r1/DICATTDK.m ./VADemo/r2/r/DICATTDK.m DICATTDK ;SFISC/GFT-DELETE FIELD ;09:52 AM 3 Dec 2002 | DICATTDK ;SFISC/GFT-DELETE FIELD ;09:12 AM 28 Aug 199 ;;22.0;VA FileMan;**8,118**;Mar 30, 1999 | ;;22.0;VA FileMan;**8**;Mar 30, 1999 ;FROM ^DICATTDE | ; MAYBGONE S (A,DA(1))=DICATTA,(D0,DA)=DICATTF I '$D(^DD | S (A,DA(1))=DICATTA,(D0,DA)=DICATTF DELFLD(DICATTA,DA) ;FROM ^DICATTD | DELFLD(DICATTA,DA) ; AUD S:$D(DDA) ^UTILITY("DDA",$J,DICATTA,DA,0)=$G(^DD(DICA < POST9 ;POST-ACTION OF FIELD 99, 'ARE YOU SURE YOU WANT TO D < ;IF THEY DON'T ANSWER "YES", REPAINT FIELD LABEL AND < I 'X D PUT^DDSVALF(1,"DICATT",1,$P(^DD(DICATTA,DICATT < S DICATTDK=1,DDACT="EX" ;FORCE EXIT FROM SCREENMAN < D REQ^DDSUTL(20,"DICATT",1,0) < NOREQ ; < D REQ^DDSUTL(67,"DICATT SCREEN",6,0) < D REQ^DDSUTL(31,"DICATT2",2.2,0) < D REQ^DDSUTL(32,"DICATT2",2.2,0) < D REQ^DDSUTL(68,"DICATT4",2.4,0) < D REQ^DDSUTL(69,"DICATT4",2.4,0) < D REQ^DDSUTL(78,"DICATT6",2.6,0) < Q < ; < diff -y --suppress-common-lines ./VADemo/r1/DICATTDM.m ./VADemo/r2/r/DICATTDM.m DICATTDM ;GFT ;04:56 PM 17 Dec 2002 | DICATTDM ;GFT ;04:31 PM 6 Feb 2001 ;;22.0;VA FileMan;**42,118**;Mar 30, 1999 | ;;22.0;VA FileMan;**42**;Mar 30, 1999 I $G(DICATTLN),$$MAX(DICATTLN,X)>250 Q "Too much to s | I $G(DICATTLN),$$MAX(DICATTLN,X)>245 Q "Too much to s diff -y --suppress-common-lines ./VADemo/r1/DICF1.m ./VADemo/r2/r/DICF1.m DICF1 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 2 (Transfor | DICF1 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 2 (Transfor ;;22.0;VA FileMan;**15,51,70,135**;Mar 30, 1999 | ;;22.0;VA FileMan;**15,51,70**;Mar 30, 1999 . . . S DISTEMP="S %=DIVAL "_DISTEMP Q ;22*135 | . . . S DISTEMP="S %=DIVAL"_DISTEMP Q diff -y --suppress-common-lines ./VADemo/r1/DICOMP.m ./VADemo/r2/r/DICOMP.m DICOMP ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;29APR2003 | DICOMP ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;08:40 AM 3 Fe ;;22.0;VA FileMan;**6,76,114,118** | ;;22.0;VA FileMan;**6,76,114** BINOP I ")"'[$E(I_W,M),$G(K(K))]"",'$D(K(K,2)),'$F($TR(DPUN | BINOP I $E(I,M,999)_W]"",$G(K(K))]"",'$D(K(K,2)),'$F($TR(DP S DICOMPX="",DICOMP=$TR(DICOMP,"F")_"X" ;(Why strip o | S DICOMPX="",DICOMP=$TR(DICOMP,"F")_"X" ;Why strip ou diff -y --suppress-common-lines ./VADemo/r1/DIDH1.m ./VADemo/r2/r/DIDH1.m DIDH1 ;SFISC-HDR FOR DD LISTS ;7:34 AM 29 Sep 2003 | DIDH1 ;SFISC-HDR FOR DD LISTS ;1:51 PM 6 Mar 2002 ;;22.0;VA FileMan;**76,105,131**;Mar 30, 1999 | ;;22.0;VA FileMan;**76,105**;Mar 30, 1999 N DIDHI,DIDHJ,W D ;*131* | N DIDHI,DIDHJ D diff -y --suppress-common-lines ./VADemo/r1/DIE3.m ./VADemo/r2/r/DIE3.m DIE3 ;SFISC/XAK-PROCESS SINGLE-VALUED VARIABLE PNTR ;5:50 | DIE3 ;SFISC/XAK-PROCESS SINGLE-VALUED VARIABLE PNTR ;2:16 ;;22.0;VA FileMan;**4,123**;Mar 30, 1999 | ;;22.0;VA FileMan;**4**;Mar 30, 1999 I Y>0,'DIVPSEL(0),'$D(DB(DQ)),'$P(Y,U,3),'$$CHKO,'$G( | I Y>0,'DIVPSEL(0),'$D(DB(DQ)),'$P(Y,U,3),$P(^DIC(+DIV ; < CHKO() ; New with 22*123. Check for 'O' (Ask 'OK') < ; Backwards compatibility check < I $P(^DIC(+DIVPDIC,0),U,2)["O" Q 1 < ; If $P#2 of the File Header ["O" then Quit True < Q $P(@(^DIC(+DIVPDIC,0,"GL")_"0)"),U,2)["O" < diff -y --suppress-common-lines ./VADemo/r1/DIENVWRN.m ./VADemo/r2/r/DIENVWRN.m DIENVWRN ;IRMFO-SF/FM STAFF-ENVIRONMENT CHECK ROUTINE | DIENVWRN ;IRMFO-SF/FM STAFF-ENVIRONMENT CHECK ROUTINE diff -y --suppress-common-lines ./VADemo/r1/DIET.m ./VADemo/r2/r/DIET.m DIET ;SFISC/XAK-DISPLAY INPUT TEMPLATE ALSO DOES AUDITI | DIET ;SFISC/XAK-DISPLAY INPUT TEMPLATE ;10:49 AM 4 Jun 20 ;;22.0;VA FileMan;**69,49,104,129**;Mar 30, 1999 | ;;22.0;VA FileMan;**69,49,104**;Mar 30, 1999 AUD N DP,DG,DPS,DIEX,DIIX,DIANUM ; DI*22*49 | AUD N DP,%,%D,%F,%T,C,DG,DPS,DIEDA,DIEF,DIEX,DIIX,DIANUM, N C,DIEDA,DIEF,%T,%F,%D,%,Y < K DIIX,DPS,DIEX | K DPS,DIEX,DIEDA,DIEF,%T,DIIX,%F,%D,% I $D(DG),$D(DIANUM($P(DIIX,U,2))) S Y=X,(DIEX(1),C)=$ | I $D(DG),DG]"",$D(DIANUM(DG)) S Y=X,(DIEX(1),C)=$P(^D D ADD I $D(DG),+DIIX=2 S DIANUM($P(DIIX,U,2))="^DIA(" | D ADD I $D(DG),DG]"" S DIANUM(DG)="^DIA("_%F_","_+Y_" ACCESSED(%F,REF) ;WILL FLAG ENTRY 'REF' IN FILE '%F' A < N Y,X,%T,%D < D:'$G(DT) DT^DICRW < Q:'%F!'REF S %F=+%F,(REF,X)=+REF Q:'$D(^DIC(%F)) < D ADD ;COMES BACK WITH %T AND Y--THE AUDIT REF < S ^DIA(%F,Y,0)=REF_U_%T_U_.01_U_DUZ_U_U_"i" < S ^DIA(%F,"B",REF,Y)="" < Q < ; < F Y=Y+1:1 I '$D(^(Y)) L +^DIA(%F,Y):0 I Q:'$D(^(Y)) | F Y=Y+1:1 I '$D(^(Y)) L +^DIA(%F,Y):0 I Q diff -y --suppress-common-lines ./VADemo/r1/DIFROMSK.m ./VADemo/r2/r/DIFROMSK.m DIFROMSK ;SCISC/DCL-DIFROM SERVER DELETE PARTS ;7:25 A | DIFROMSK ;SCISC/DCL-DIFROM SERVER DELETE PARTS ;02:55 ;;22.0;VA FileMan;**128**;Mar 30, 1999 | ;;22.0;VA FileMan;;Mar 30, 1999 ; Dialog .84 ^DI(.84, < .I DIFRFILE=.4!(DIFRFILE=.401)!(DIFRFILE=.402)!(DIFRF | .I DIFRFILE=.4!(DIFRFILE=.401)!(DIFRFILE=.402)!(DIFRF .I DIFRFILE=.84,DIFRDA>10000 D DT(DIFROOT,DIFRDA) Q < DT(DIK,DA) ;Delete Template or Dialog ;22*128 | DT(DIK,DA) ;Delete Template diff -y --suppress-common-lines ./VADemo/r1/DIKZ0.m ./VADemo/r2/r/DIKZ0.m DIKZ0 ;SFISC/XAK-XREF COMPILER ;23AUG2004 | DIKZ0 ;SFISC/XAK-XREF COMPILER ;1:07 PM 9 Sep 1998 ;;22.0;VA FileMan;**140**;Mar 30, 1999 | ;;22.0;VA FileMan;;Mar 30, 1999 K DIK6 F DIKQ=0:0 S DIKQ=$O(^UTILITY("DIK",$J,DH,DIKQ | F DIKQ=0:0 S DIKQ=$O(^UTILITY("DIK",$J,DH,DIKQ)) Q:DI PUT N DIKSET I '$D(DIK6(%)) S ^UTILITY($J,DIKR)=" S DIKZ( | PUT I '$D(DIK6(%)) S ^UTILITY($J,DIKR)=" S DIKZ("_%_")=$G S DIKR=DIKR+1,(DIKSET,^UTILITY($J,DIKR))=" "_$P(^UTIL | S DIKR=DIKR+1,(DIK6,^UTILITY($J,DIKR))=" "_$P(^UTILIT F DIKC=0:0 S DIKC=$O(^UTILITY("DIK",$J,DH,DIKQ,DIKC)) | F DIKC=0:0 S DIKC=$O(^UTILITY("DIK",$J,DH,DIKQ,DIKC)) .S %=^(DIKC) S:$O(^(0))'=DIKC ^UTILITY($J,DIKR)=DIKSE | S DIKR=DIKR+1 Q .I %["Q:"!(%[" Q") K DIK6 S ^UTILITY($J,DIKR)=DIK0_" | ; .I %["D RCR" K DIK6 S ^UTILITY($J,DIKR)=DIK0_" D",DIK | CRF S DIKR=DIKR+1 .I %["S XMB=" S ^UTILITY($J,DIKR)=DIK0_",$D(DIK(0)),D | I %["Q:"!(%[" Q") S ^UTILITY($J,DIKR)=DIK0_" X ^DD("_ .S ^UTILITY($J,DIKR)=DIK0_" "_$S(%[" AUDIT":"S DH="_D | I %["D RCR" S ^UTILITY($J,DIKR)=DIK0_" D",DIKR=DIKR+2 > I %["S XMB=" S ^UTILITY($J,DIKR)=DIK0_",$D(DIK(0)),DI > S ^UTILITY($J,DIKR)=DIK0_" "_$S(%[" AUDIT":"S DH="_DH ; < D LINE($S(DIKCOD]"":" I "_DIKCOD_" D",1:" D")) ;**GFT | I DIKCOD]"" D LINE(" I "_DIKCOD_" D") ..S DIKCOD="",DIKO=0 F S DIKO=$O(DIK01(DIKO)) Q:'DIK | .. S DIKCOD="",DIKO=0 F S DIKO=$O(DIK01(DIKO)) Q:'DI K DIK6 Q | Q ;K DIK01 | K DIK01 . S DIK01(DIKO)="" | . S:$P(^TMP("DIKC",$J,DH,DIKC,DIKO,"F"),U,2)=.01 DIK0 diff -y --suppress-common-lines ./VADemo/r1/DIKZ.m ./VADemo/r2/r/DIKZ.m DIKZ ;SFISC/XAK-XREF COMPILER ;7JUN2004 | DIKZ ;SFISC/XAK-XREF COMPILER ;10:30 AM 5 Jan 1999 ;;22.0;VA FileMan;**140**;Mar 30, 1999 | ;;22.0;VA FileMan;;Mar 30, 1999 S DIKGO="^"_DNM_1 ;starting ROUTINE name | S DIKGO="^"_DNM_1 I '$D(DIKRT),T,$D(%),T+$L(%)>DMAX S DIKZDH=+$P(^UTILI | I '$D(DIKRT)&(T+$L(%)>DMAX) S DIKZDH=+$P(^UTILITY($J, diff -y --suppress-common-lines ./VADemo/r1/DIL.m ./VADemo/r2/r/DIL.m DIL ;SFISC/GFT/XAK-TURN PRINT FLDS INTO CODE ;2DEC2002 | DIL ;SFISC/GFT/XAK-TURN PRINT FLDS INTO CODE ;03:56 PM 1 ;;22.0;VA FileMan;**25,102,119**;Mar 30, 1999 | ;;22.0;VA FileMan**25,102**;Mar 30, 1999 .S DN=-8 Q:DIO=1 | .I DIO=1 S DN=-8 Q diff -y --suppress-common-lines ./VADemo/r1/DINIT013.m ./VADemo/r2/r/DINIT013.m DINIT013 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;9:3 | DINIT013 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;5/2 ;;22.0;VA FileMan;**41,110**;Mar 30, 1999 | ;;22.0;VA FileMan;**41**;Mar 30, 1999 ;;=LANGUAGE^.85I^18^11 | ;;=LANGUAGE^.85I^12^10 ;;^UTILITY(U,$J,.85,7,0) < ;;=7^PORTUGUESE < diff -y --suppress-common-lines ./VADemo/r1/DINIT0F8.m ./VADemo/r2/r/DINIT0F8.m DINIT0F8 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;04: | DINIT0F8 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;12: ;;22.0;VA FileMan;**8,42,76,118**;Mar 30, 1999 | ;;22.0;VA FileMan;**8,42,76**;Mar 30, 1999 ;;^DIST(.404,.00112,40,2,14) < ;;=N % S %=$$CHKSUB^DICATTDM(X) I '% S DDSERROR=1 D H < ;;=K:X?1P.E!(X[" ")!(X[",")!(X[":")!(X[";")!(X["""")! | ;;=K:X?1P.E!(X[" ")!(X[",")!(X[":")!(X[";")!(X["""")! ;;^DIST(.404,.00112,40,3,14) | ;;^DIST(.404,.00112,40,3,22) ;;=N % S %=$$CHKPIEC^DICATTDM(X) I '% S DDSERROR=1 D | ;;=N % S %=$$CHKPIEC^DICATTDM(X) I '% K X D HLP^DDSUT ;;=D POST9^DICATTDK | ;;=D:'X PUT^DDSVALF(1,"DICATT",1,$P(^DD(DICATTA,DICAT ;;^DIST(.404,.00114,40,1,14) < ;;=N % S %=$$CHKSUB^DICATTDM(X) I '% S DDSERROR=1 D H < ;;=K:X?1P.E!(X[",")!(X[":")!(X["""")!(X["=") X | ;;=K:X?1P.E!(X[",")!(X[":")!(X["""")!(X["=") X I $D(X diff -y --suppress-common-lines ./VADemo/r1/DINIT21.m ./VADemo/r2/r/DINIT21.m DINIT21 ;SFISC/GFT-INITIALIZE VA FILEMAN ;1:11 PM 27 Jun 200 | DINIT21 ;SFISC/GFT-INITIALIZE VA FILEMAN ;06/06/2002 13:15 ;;22.0;VA FileMan;**110**;Mar 30, 1999 | ;;22.0;VA FileMan;;Mar 30, 1999 ;;19,0 GT.M(UNIX)^^250^10000^^1^250 | ;;19,0 GT.M(Unix)^^250^10000^^1^250 diff -y --suppress-common-lines ./VADemo/r1/DIO0.m ./VADemo/r2/r/DIO0.m DIO0 ;SFISC/GFT,TKW-BUILD SORT AND SUB-HDR ;1:17 PM 21 Ma | DIO0 ;SFISC/GFT,TKW-BUILD SORT AND SUB-HDR ;08:11 PM 9 De ;;22.0;VA FileMan;**2,23,138**;Mar 30, 1999 | ;;22.0;VA FileMan;**2,23**;Mar 30, 1999 S C=",",Z=Z+1,DE=$P(DN,C,Z)_"=$O("_DI_$P(DN,C,1,Z)_") | S Z=Z+1,DE=$P(DN,C,Z)_"=$O("_DI_$P(DN,C,1,Z)_")),DN=" diff -y --suppress-common-lines ./VADemo/r1/DIO4.m ./VADemo/r2/r/DIO4.m DIO4 ;SFISC/GFT,XAK,TKW-FINISH OUTPUT, CLOSE DEVICE ;9:57 | DIO4 ;SFISC/GFT,XAK,TKW-FINISH OUTPUT, CLOSE DEVICE ;10:46 ;;22.0;VA FileMan;**2,32,45,136**;Mar 30, 1999 | ;;22.0;VA FileMan;**2,32,45**;Mar 30, 1999 S DIOP=IO | S DIOP=IO X $G(^%ZIS("C")) ;VistA Close Logic 22*136 | I $P(IO(0),DIOP)]"" S IOP=IO(0) D ^%ZIS H:POP S X=DI I $G(^%ZIS("C"))="G ^%ZISC" X ^%ZIS("C") K DIOP Q < ;Stand Alone Close Logic < I $P(IO(0),DIOP)]"" S IOP="HOME" D ^%ZIS H:POP S X=D < Only in ./VADemo/r1/: DIPOS140.m Only in ./VADemo/r1/: DIPR110.m Only in ./VADemo/r1/: DIPR129.m diff -y --suppress-common-lines ./VADemo/r1/DIQ1.m ./VADemo/r2/r/DIQ1.m DIQ1 ;SFISC/XAK-INQUIRY WITH COMPUTED FIELDS ;6:09 AM 24 | DIQ1 ;SFISC/XAK-INQUIRY WITH COMPUTED FIELDS ;11:43 AM 4 ;;22.0;VA FileMan;**19,64,76,133**;Mar 30, 1999 | ;;22.0;VA FileMan;**19,64,76**;Mar 30, 1999 .I C["p",Y S Y=$$CP(C,Y) | .I Y,C["p" S Y=$$CP(C,Y) diff -y --suppress-common-lines ./VADemo/r1/DIQG.m ./VADemo/r2/r/DIQG.m DIQG ;SFISC/DCL-DATA RETRIEVAL PRIMITIVE ;5:44 AM 24 Nov | DIQG ;SFISC/DCL-DATA RETRIEVAL PRIMITIVE ;10:56 AM 18 Oct ;;22.0;VA FileMan;**76,118,133**;Mar 30, 1999 | ;;22.0;VA FileMan;**76**;Mar 30, 1999 TRYCOMP N X,DIQGS I 'DIQGIPAR D EXPR(DFF,DR) ;DON'T ALLOW COM | TRYCOMP N X,DIQGS D EXPR(DFF,DR) E S X="" X $P(@DIQGDN@(DIQGDRN,0),"^",5,999) ;HELLEV | E X $P(@DIQGDN@(DIQGDRN,0),"^",5,999) CP I C["p",X S C=+$P(C,"p",2) I C,$D(^DIC(C,0,"GL")),$D( | CP I X,C["p" S C=+$P(C,"p",2) I C,$D(^DIC(C,0,"GL")),$D( REAL I $E($P(DIQGD4,";",2))="E" S Y=$E($G(@DIQGSI@(DA,P)), | REAL I $E($P(DIQGD4,";",2))="E" S Y=$E($G(@DIQGSI@(DA,P)), I 'DIQGPI,$G(Y)["D",Y'["m",$D(X)#2 S X=X_" S X=$$FMTE < diff -y --suppress-common-lines ./VADemo/r1/DIQ.m ./VADemo/r2/r/DIQ.m DIQ ;SFISC/GFT-CAPTIONED TEMPLATE ;05:55 PM 17 Apr 2003 | DIQ ;SFISC/GFT-CAPTIONED TEMPLATE ;13FEB2002 ;;22.0;VA FileMan;**19,64,74,81,99,133**;Mar 30, 1999 | ;;22.0;VA FileMan;**19,64,74,81,99**;Mar 30, 1999 .N D F DIQZ=0:0 S DIQZ=$O(DIQAUD(DIQZ)) Q:'DIQZ W ?2 | .F DIQZ=0:0 S DIQZ=$O(DIQAUD(DIQZ)) Q:'DIQZ W ?2,$P( I S,$G(DIQ(0))["C",$D(@(D_"0)")) D ^DIQ1 ;Computed fi | I S,$G(DIQ(0))["C" D ^DIQ1 ;Computed fields at this l diff -y --suppress-common-lines ./VADemo/r1/DPTLK1.m ./VADemo/r2/r/DPTLK1.m DPTLK1 ;ALB/RMO - MAS Patient Look-up Check Cross-References | DPTLK1 ;ALB/RMO - MAS Patient Look-up Check Cross-References ;;5.3;Registration;**32,50,197,249,317,391,244,532,57 | ;;5.3;Patient File;**32,50,197,249,317,391**;Aug 13, FIND ;Cross reference patient lookup | N DDCOMA,DPTXOLD I DPTX?1.A1","1.A.E S DPTXOLD=DPTX,D ;Optional input: DPTNOFZY='1' to suppress fuzzy looku | K DPTREFS S DPTREFS=$S(DIC(0)'["M":"B",DPTX?1A1N.N:$S ; by patch DG*5.3*244 | S:DPTREFS="" DPTREFS=$S(DPTX?1N.N:$S($L(DPTX)<5:"CN,R ; | S DPTBEG=1,(DPTDFN,DPTNUM)=0 F DPTLP=1:1 S DPTREF=$P( N DDCOMA,DPTXOLD,DPTOUT,DPTOVAL < S (DPTXOLD,DPTX)=$$UCASE(DPTX) < I DPTX?1A.E1","1.A.E S DPTXOLD=DPTX,DDCOMA="I $E($P($ < K DPTREFS S DPTREFS=$S(DIC(0)'["M":"B,NOP",DPTX?1A1N. < S:DPTREFS="" DPTREFS=$S(DPTX?1N.N:$S($L(DPTX)<5:"CN,R < S DPTBEG=1,(DPTDFN,DPTNUM,DPTOUT)=0 < F DPTLP=1:1 S DPTREF=$P(DPTREFS,",",DPTLP) Q:DPTREF=" < .S DPTVAL=DPTX < .I DPTREF="NOP",'$G(DPTNOFZY) S DPTVAL=$$FORMAT^DPTNA < .D LOOK(DPTVAL) < .I DPTREF="B",'$G(DPTNOFZY) S DPTVAL=$$FORMAT^DPTNAME < .Q < K DPTOVAL,DPTOUT,DPTXOLD,^TMP("DPTLK",$J) < LOOK(DPTVAL) ;Look for x-ref matches | CHKVAL S DPTVAL=$S(DPTX?.N:DPTX_" ",1:DPTX) F DPTLP1=0:0 S D ;Input: DPTVAL=lookup seed value < I $L(DPTVAL),$D(^DPT(DPTREF,DPTVAL)) D CHKIFN Q:DPTDF < I $L(DPTVAL),'($D(^DPT(DPTREF,DPTVAL))&(DIC(0)["O"))& < CHKVAL S DPTOVAL=DPTVAL | CHKIFN F DPTIFN=0:0 S DPTIFN=$O(^DPT(DPTREF,DPTVAL,DPTIFN)) N DPTSEED S DPTSEED=DPTVAL < I DPTREF="SSN",(DPTVAL?9N1"p") D Q < .S DPTVAL=$E(DPTVAL,1,9)_"P" D CHKIFN < .Q < I DPTREF="SSN",(DPTVAL?2.9N) D Q < .S DPTVAL=$E(DPTVAL_"0000000",1,9) < .D CV1(DPTVAL),CHKIFN < .S DPTVAL=DPTVAL_"P" D CV1(DPTVAL),CHKIFN < .Q < D CV1(DPTVAL) < I DPTREF="CN"!(DPTREF="RM"),DPTVAL'["E",DPTVAL=+DPTVA < .S DPTVAL=$O(^DPT(DPTREF,DPTVAL_" "),-1) < .D CV1(DPTVAL) < .Q < CV1(DPTVAL) ;Look for input value matches | SETDPT Q:'$D(^DPT(Y,0))!($D(DPTS(Y))&(DIC(0)'["C")&($G(DPTRE I $L(DPTVAL) F DPTLP1=0:0 S DPTVAL=$O(^DPT(DPTREF,DPT | S DPTCNT=DPTCNT+1,DPTS(Y)=$S('$D(DPTREF):$P(^DPT(Y,0) Q | S DPTIFNS(DPTCNT)=Y_U_$P(^DPT(Y,0),U)_U_$S($D(DPTVAL) ; < CHKIFN F DPTIFN=0:0 S DPTIFN=$O(^DPT(DPTREF,DPTVAL,DPTIFN)) < Q < ; < SETDPT Q:($D(DPTS(Y))&($G(DPTREF)'="B"))!'$D(^DPT(Y,0)) < ; screen out MERGED FROM records - DG/574 < Q:$D(^DPT(Y,-9)) < N DPTNVAL I '$D(DPTOVAL) N DPTOVAL S DPTOVAL=DPTX < I 1 S X=DPTOVAL X:$D(DIC("S")) DIC("S") Q:'$T X:($D( < K:$G(DPTCNT)<1 ^TMP("DPTLK",$J) < S DPTS(Y)=$S('$D(DPTREF):$P(^DPT(Y,0),U),1:$P(^DPT(Y, < S DPTNVAL=$P(^DPT(Y,0),U)_U_$S($G(DPTREF)="NOP":$P(^D < Q:$D(^TMP("DPTLK",$J,Y,DPTNVAL)) < S DPTCNT=DPTCNT+1,^TMP("DPTLK",$J,Y,DPTNVAL)="",DPTIF < I $D(DPTLARR) D Q < .I DPTLMAX,DPTCNT>DPTLMAX D Q < ..S @DPTLARR@(DPTCNT)="ADDITIONAL MATCHES FOUND BUT N < ..S DPTOUT=1 < ..Q < .S @DPTLARR@(DPTCNT)=DPTIFNS(DPTCNT)_U_$$SSN(Y)_U_$$D < .Q < F DPTNUM=DPTNUM+1:1:DPTCNT Q:DPTOUT S DPTIFN=+DPTIFN | F DPTNUM=DPTNUM+1:1:DPTCNT S DPTIFN=+DPTIFNS(DPTNUM) .S DPTP2=$P(DPTIFNS(DPTNUM),U,3) | .S DPTP2=DPTX_$P(DPTIFNS(DPTNUM),U,3) W:'$D(DDS) ! W "CHOOSE ",DPTBEG,"-",DPTNUM,": " R X:D | W:'$D(DDS) ! W "CHOOSE ",DPTBEG,"-",DPTNUM,": " R X:D .S:'$T DPTSEL=$S($D(DPTOVAL):DPTOVAL,$D(DPTVAL):DPTVA | .S:'$T DPTSEL=DPTX,DTOUT=1 .S:X="^" (DPTOUT,DUOUT)=1 | .S:X="^" DUOUT=1 S:DPTDFN=-1 DPTXOLD=DPTSEL < LIST(DPTX,DPTLMAX,DPTLARR) ;Silent lookup list < ;Input: DPTX=lookup value (name, SSN, room, ward, DFN < ; "space_return"). < ; DPTLMAX=maximum number of matches to return ( < ; parameter has no effect if DFN or "sp < ; lookup methods are used. < ; DPTLARR=name of array to return list of match < ; be a global if DPTLMAX is a large val < ; This array is returned in the format: < ; @DPTLARR@(n)=DFN^patient_name^xref_lo < ; SSN^Date_of_Birth < ; If more matches exist than the maximu < ; as specified by DPTLMAX, the @DPTLARR < ; will be defined = "ADDITIONAL MATCHES < ; RETURNED". < ; The calling program has the responsib < ; @DPTLARR prior to calling this entry < ;Output: number of matches and array named by DPTLARR < ; < N X,Y,DPTCNT,DIC,DPTSZ,DPTDFN,DPTIFNS,DPTS < S DPTCNT=0,DIC(0)="M",DPTSZ=1000 S:$G(DPTLMAX)<1 DPTL < ;Check for "space_return" or DFN lookup < I DPTX=" "!($E(DPTX)="`") D Q DPTCNT < .I DPTX=" " S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT < .I $E(DPTX)="`" S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$ < .Q:Y<1 Q:'$D(^DPT(Y,0)) D SETDPT S DPTCNT=1 < .Q < D FIND < Q $S(DPTLMAX&(DPTCNT>DPTLMAX):DPTLMAX,1:DPTCNT) < ; < UCASE(DGX) ;Uppercase lookup value < ;Input: DGX=lookup value < ;Output: transformed DGX < N DGI,DGY,DGZ S DGZ=DGX,DGX="" < F DGI=1:1:$L(DGZ) S DGY=$E(DGZ,DGI) D < .S:DGY?1L DGY=$C($A(DGY)-32) < .S DGX=DGX_DGY < Q DGX < ; < diff -y --suppress-common-lines ./VADemo/r1/DPTLK2.m ./VADemo/r2/r/DPTLK2.m DPTLK2 ;ALB/RMO - MAS Patient Look-up Add New Patient ; 9/2/ | DPTLK2 ;ALB/RMO - MAS Patient Look-up Add New Patient ; 22 J ;;5.3;Registration;**32,197,214,244,532,578,615**;Aug | ;;5.3;Patient File;**32,197,214**;Aug 13, 1993 N DPTCT,DGVV,DPTLIDR < N DG20NAME S DG20NAME=DPTX,DPTX=$$FORMAT^DPTNAME(.DG2 < I $L(DPTX)<3!($L(DPTX)>30)!(DPTX?1P.E)!(DPTX'[",")!(D | I $L(DPTX)<3!($L(DPTX)>30)!(DPTX?1P.E)!(DPTX'[",")!(D > F I=1:1:$L(DPTX) S J=$E(DPTX,I) I J?1NP,$A(J)>32,J'=" S X=DPTX,DPT("NO^")=$G(DIE("NO^")) K DD,DO,DPTX N DPT | I $D(DPTLID),DIC(0)["E" W !!?3,"Please enter the foll S:$D(DPT("DR")) DIC("DR")="S DIE(""NO^"")=""BACK"";"_ | S X=DPTX,DPT("NO^")=$G(DIE("NO^")) K DD,DO,DPTX S:$D( D FILE^DICN K:$D(DPT("DR")) DIC("DR") < W ?24,"...new patient added",!?3 < S DPTDFN=Y S:$L(DPT("NO^")) DIE("NO^")=DPT("NO^") < ;offer prompt of patient file components < S DIE="^DPT(",DA=+Y,DR="S DIE(""NO^"")=""BACK"";.01// < D ^DIE K DR < ;look for other (local) identifiers < I '$D(DIC("DR")),DIC(0)["E" D < .F DPTID=0:0 S DPTID=$O(^DD(2,0,"ID",DPTID)) Q:'DPTID < ..I $F(DPTGID,U_DPTID_U) Q < ..I '$D(^DD(2,DPTID,0)) Q < ..S DPTLID="" < ..S DPTLIDR=$S('$D(DPTLIDR):DPTID,1:DPTLIDR_";"_DPTID < I $D(DPTLID) W !!?3,"Please enter the following addit < I %=1 S:$$CONF1^DPTNAME(DPTX)'=1 DPTDFN=-1 < CHKID K DFN S DPTDFN=1,DPTGID="^.02^.03^.09^391^1901^.301^9 | CHKID K DFN S DPTDFN=1,DPTGID="^.02^.03^.09^391^1901^" F DP CHKID1 I $D(^DD(2,DPTID,0)) S DPT("DR")=$S('$D(DPT("DR")):DP | CHKID1 S DPT("DR")=$S('$D(DPT("DR")):DPTID,1:DPT("DR")_";"_D ASKID N DGREC W !?3,"PATIENT ",$P(DPTID0,U),": " R X:DTIME | ASKID N DGREC W !?3,"PATIENT ",$P(DPTID0,U),": " R X:DTIME .Q:$D(DTOUT)!($G(DUOUT)) < ; field 994 is not a required field < I DPTID=994 I X["?" D HLPID G ASKID < I DPTID=994 I X="" G SKIP < SKIP I $P(DPTID0,U,2)["P" D P1 G ASKID:Y'>0 S DPTIDS(DPTID | I $P(DPTID0,U,2)["P" D P1 G ASKID:Y'>0 S DPTIDS(DPTID I DPTID=.301,$D(X) D CHKIT Q:'$D(X) I $D(X) W:$D(DPT | X $P(DPTID0,U,5,99) I $D(X) W:$D(DPTSET) " ",DPTSET S I DPTID'=.301 X $P(DPTID0,U,5,99) I $D(X) W:$D(DPTSET < CHKIT ; do input transform for .301 < I X'="Y" Q < S DGVV=DPTIDS(391),DGVV=$O(^DG(391,"B",DGVV,0)) < S DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"") < I DPTIDS(1901)'="Y",'DGVV D EN^DDIOL("Applicant is NO < Q < diff -y --suppress-common-lines ./VADemo/r1/DPTLK5.m ./VADemo/r2/r/DPTLK5.m ;;5.3;Patient File;**265,276,277,485**;Aug 13, 1993 | ;;5.3;Patient File;**265,276,277**;Aug 13, 1993 ; < FFP ; This function checks if the 'Display Fugitive Felon < ; message is to be displayed. Message displays only < ; menu options < ; < Q:'$D(XQY0) < Q:$E(XQY0,1,2)'="SD"&($E(XQY0,1,2)'="DG") < ; < N X,Y,IORVON,IORVOFF,DIR,DIRUT < S X="IORVON;IORVOFF" < D ENDR^%ZISS < W !?17,$CHAR(7) W:$D(IORVON) IORVON W "*** WARNING - < W !?19,$CHAR(7) W:$D(IORVON) IORVON W "PLEASE NOTIFY < W ! < S DIR(0)="FAO",DIR("A")="Enter to continue." < D ^DIR K DIR < Q < diff -y --suppress-common-lines ./VADemo/r1/DPTLK.m ./VADemo/r2/r/DPTLK.m DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 7/1 | DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 9/2 ;;5.3;Registration;**32,72,93,73,136,157,197,232,265, | ;;5.3;Patient File;**32,72,93,73,136,157,197,232,265, ;Optional input: DPTNOFZY='1' to suppress fuzzy looku < ; by patch DG*5.3*244 < ; < K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(D | K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G Q:DIC(0)["I"!(DI I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. File | I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. File I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable t | I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable t I DIC(0)["A" D G QK:'$T!($E(DPTX)["^")!(DPTX="") | I DIC(0)["A" D G Q:'$T!($E(DPTX)["^")!(DPTX="") I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK | I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",Q I DPTX["?" D G ASKPAT:DIC(0)["A",QK | I DPTX["?" D G ASKPAT:DIC(0)["A",Q > S DPTX=$$CLEAN(DPTX) ; -- Force new entry < I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" G NOPAT < D ^DPTLK1 G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),AS | D ^DPTLK1 G Q:$D(DTOUT),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN I $P(Y,"^",3)'=1 W !,"Could not add patient to patien | I $P(Y,"^",3)'=1 W !,"Could not add patient to patien D QK1 | D Q1 I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A" | I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A" S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN | S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN I DIC(0)["E" D W $S('$D(DPTSEL)&('$D(DIVP)):$P(DPTS( | I DIC(0)["E" D W $S('$D(DPTSEL)&('$D(DIVP))&(DPTX'[" I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) | I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G | I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ;DG*600 | I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning ;I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning < I DIC(0)["E",$$TESTPAT^VADPT(+Y) W *7,!,"WARNING : Yo < ;DG*485 < I $D(^DPT("AXFFP",1,+Y)) D FFP^DPTLK5 < ;Call Combat Vet check < I Y>0,DIC(0)["E" D CV < ; < QK K:'$D(DPTNOFZK) DPTNOFZY G Q < ; < QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1 < ; < > CLEAN(X) ; -- clean up name > N Y,I,DGQUOTES,Q > S Q="""",DGQUOTES=0 I $E(X)=Q&($E(X,$L(X))=Q) S DGQUO > ; -- only uppercase > I X?.E1L.E F I=1:1:$L(X) S:$E(X,I)?1L X=$E(X,0,I-1)_$ > ; -- no space after comma and no double spaces > F Y=", "," " F Q:'$F(X,Y) S X=$E(X,1,($F(X,Y)-2))_ > ; -- no space before comma > S Y=" ," F Q:'$F(X,Y) S X=$E(X,1,$F(X,Y)-3)_$E(X,$F > ; -- no space at the end > F Q:((Q_" ")'[$E(X,$L(X))) S X=$E(X,1,$L(X)-1) Q:'$ > Q $S(DGQUOTES:Q_X_Q,1:X) > ; > S IATA=$$CLEAN(IATA) ;check for Combat Veteran Eligibility, if elig do not < I $$CVEDT^DGCV(+DPTDFN) Q < I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGEN | I '$$ABOVE^DGENEGT1(DGENR("PRIORITY"),$G(DGENR("SUBGR CV ;check for Combat Vet status | ; N DGCV < S DGCV=$$CVEDT^DGCV(+DPTDFN) < I $P(DGCV,U)=1 D Q < . I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W ! < . W ?3,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGI < Q < Only in ./VADemo/r1/: DPTNAME1.m Only in ./VADemo/r1/: DPTNAME.m Only in ./VADemo/r2/r/: _DTC.m Only in ./VADemo/r2/r/: _DT.m Only in ./VADemo/r1/: DVBA2768.m Only in ./VADemo/r1/: DVBA58PI.m diff -y --suppress-common-lines ./VADemo/r1/DVBAADRP.m ./VADemo/r2/r/DVBAADRP.m ;;2.7;AMIE;**17,42,53**;Apr 10, 1995 | ;;2.7;AMIE;**17**;Apr 10, 1995 N DVBGUI < S DVBGUI=0 < Q < ENBROKER(Y) ; < ; Returns some info for the CAPRI GUI to display prio < ; to the user running this report < N DVBGUI < S DVBGUI=1 < K ^TMP($J) < D HOME^%ZIS K NOASK,QUIT1 < D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL < ; < S Y(1)="VARO COMPLETE ADMISSION REPORT" S DTAR=^DVB(3 < S HEAD="TOTAL ADMISSION REPORT",HEAD1="FOR "_$P(DTAR, < S Y(2)=HEAD1,Y(3)="" < S Y(4)="Please enter dates for search, oldest date fi < S Y=$P(DTAR,U,3) X ^DD("DD") < S Y(5)="" < S Y(6)="Last report was run on "_Y < Q < ENBROKE2(MSG,BDATE,EDATE,RO,RONUM) ; < ; This is the entry point to run the actual report fr < ; the CAPRI GUI. < N DVBHFS,DVBERR,DVBGUI,I < K ^TMP("DVBA",$J) < S DVBGUI=1,DVBERR=0,DVBHFS=$$HFS^DVBAB82() < S X=BDATE,Y=EDATE < S BDATE=BDATE+".5",EDATE=EDATE+".5" < K ^TMP($J) < D HOME^%ZIS K NOASK,QUIT1 < D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL < ; < S HEAD="TOTAL ADMISSION REPORT",HEAD1="FOR "_$P(DTAR, < I $D(X) D < . G:X=""!(Y<0) KILL S %ZIS="AEQ" D ^%ZIS K %ZIS < D HFSOPEN^DVBAB82("DVBRP",DVBHFS,"W") I DVBERR D END^ < I POP K DVBAON2,DCHPTR,M,Y,J G KILL^DVBAUTIL < U IO < D DEQUE < D END^DVBAB82 < Q < I DVBGUI=0 W !!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD | W !!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1 I DVBGUI=1 W !! < ..I DVBGUI=0 D | ..W *7,!,"Press RETURN to continue or ""^"" to stop ...W *7,!,"Press RETURN to continue or ""^"" to stop | ..R ANS:DTIME ...R ANS:DTIME | ..S:ANS=U!('$T) QUIT=1 ...S:ANS=U!('$T) QUIT=1 | ..I '$T S DVBAQUIT=1 ...I '$T S DVBAQUIT=1 < ..I DVBGUI=0 D | ..W *7,!,"Press RETURN to continue " ...W *7,!,"Press RETURN to continue " | ..R ANS:DTIME ...R ANS:DTIME < I '$D(^TMP($J)) U IO W !!,*7,"No data found for param | I '$D(^TMP($J)) U IO W !!,*7,"No data found for param I $G(DVBGUI)=1 W !,HEAD,!,HEAD1,! < KILL ; | KILL D ^%ZISC S X=3 K DVBAON2,DCHPTR,M,Y,J D:$D(ZTQUEUED) D ^%ZISC S X=3 K DVBAON2,DCHPTR,M,Y,J D:$D(ZTQUEUED) < diff -y --suppress-common-lines ./VADemo/r1/DVBAB1.m ./VADemo/r2/r/DVBAB1.m ;;2.7;AMIE;**35,37,50,42,53,57**;Apr 10, 1995 | ;;2.7;AMIE;**35,37,50**;Apr 10, 1995 VERSION(ZMSG,DVBGUIV) ; | VERSION(ZMSG) ; ; Must have a letter at the end of the Version for De | ; Must have a letter at the end of the Version for De > ; compatability S ZMSG="CAPRI GUI V2.7*45*1*A^NOOLD" | S ZMSG="CAPRI GUI V2.7*41*1*A^NOOLD" S DVBABVR1="CAPRI Server Version: "+ZMSG < I '$D(DVBGUIV) S DVBGUIV="CAPRI GUI Version: UNKNOWN < S DVBABVR2="CAPRI GUI Version: "+DVBGUIV < S DVBABVR3=$P(^VA(200,DUZ,0),"^",1) < Q < ; < REQUESTS(Y,TYPE) ; < ; TYPE is the internal value of field 17 in file 396. < ; This relates to which status of request should be r < N DVBABCNT,DVBABIEN < S DVBABCNT=0,DVBABIEN=0 < F S DVBABIEN=$O(^DVB(396.3,DVBABIEN)) Q:'DVBABIEN D < .S DVBABST=$P($G(^DVB(396.3,DVBABIEN,0)),"^",18) < .I DVBABST=TYPE D < ..S DVBABNM=$P($G(^DVB(396.3,DVBABIEN,0)),"^",1) < ..S DVBABPT=DVBABNM < ..I DVBABNM'="" S DVBABNM=$P($G(^DPT(DVBABNM,0)),"^", < ..S DVBABDT=$$FMTE^XLFDT($P($G(^DVB(396.3,DVBABIEN,0) < ..S DVBABWHO=$P($G(^DVB(396.3,DVBABIEN,0)),"^",4) < ..I DVBABWHO'="" S DVBABWHO=$P($G(^VA(200,DVBABWHO,0) < ..E S DVBABWHO="UNKNOWN" < ..S DVBABRO=$P($G(^DVB(396.3,DVBABIEN,0)),"^",3) < ..I DVBABRO'="" S DVBABRO=$P($G(^DIC(4,DVBABRO,0)),"^ < ..E S DVBABRO="UNKNOWN" < ..S ^TMP("DVBAREQ",DUZ,DVBABCNT)=DVBABST_"^"_DVBABPT_ < S Y=$NA(^TMP("DVBAREQ",DUZ)) < K DVBABCNT,DVBABIEN,TYPE,DVBABNM,DVBABDT,DVBABST,DVBA < TEAMPTS(DVBORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN | ; > TEAMPTS(DVBORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS ; global root string passed in ORY, and builds the | ; global root string passed in ORY, and builds the N DOTMP,NEWTMP,DVBSSN,DVBORI,DVBORPT,I | N DOTMP,NEWTMP,DVBSSN S (I,DOTMP,DVBORI)=0 | S DOTMP=0 .I DOTMP S NEWTMP=DVBORY_1_")",@NEWTMP="^No team iden | .I DOTMP S NEWTMP=DVBORY_1_")",@NEWTMP="^No team iden .E S DVBORY(1)="^No team identified" | .I 'DOTMP S DVBORY(1)="^No team identified" Q F S DVBORI=$O(^OR(100.21,+TEAM,10,DVBORI)) Q:DVBORI< | N DVBORI,DVBORPT,I > S I=0 > S DVBORI=0 F S DVBORI=$O(^OR(100.21,+TEAM,10,DVBORI) .E S I=I+1,^TMP("DVBATMPT",DUZ,I)=+DVBORPT_U_$P(^DPT | .I 'DOTMP S I=I+1,^TMP("DVBATMPT",DUZ,I)=+DVBORPT_U_$ E S:I<1 ^TMP("DVBATMPT",DUZ,1)="^No patients found." | I 'DOTMP S:I<1 ^TMP("DVBATMPT",DUZ,1)="^No patients f > ; N DVBARR,DVBERR,DVBATP | N DVBARR,DVBERR D GETS^DIQ(4,DUZ(2)_",0",13,"I","DVBARR","DVBERR") < S DVBATP=$G(DVBARR(4,DUZ(2)_",0,",13,"I")) < I DVBATP'="" S DVBATP=$P($G(^DIC(4.1,DVBATP,0)),"^",1 < S Y=Y_"-"_DVBATP < DT(Y,X1,X2) ; Returns date X1 minus X2 days | DT(Y,X1,X2) ; Returns date X1 minus X2 days ;S %DT=$G(%DT,"TS") D ^%DT | ;S %DT=$G(%DT,"TS") D ^%DT K %DT DPA(LIST,DFN,CHOICE) ;Display Patient Appointments | DPA(LIST,DFN,CHOICE) ;Display Patient Appointments . I $D(^DPT(DFN,"S",SDT,"R")) S REMARK=$P(^DPT(DFN,"S < . I $D(REMARK) S ^TMP("DVBAAPPT",$J,DUZ,DVBABCNT)=" < . I $D(REMARK) K REMARK < I +DUZ(2)<1 S Y="Invalid division." | I +DUZ(2)<1 S Y="Invalid division." Q D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)") | D DGINQ^ORCXPND1(DFN) > K DFN TEMPLATE(Y) ; Returns list of CAPRI exam templates < N DVBABCNT,DVBABIEN,DVBABNM,DVBABAD,DVBABDD,DVBABSL,D < K Y,^TMP("DVBALAB1",DUZ) < S DVBABCNT=0,DVBABIEN=0 < F S DVBABIEN=$O(^DVB(396.18,DVBABIEN)) Q:'DVBABIEN < .S DVBABNM=$P($G(^DVB(396.18,DVBABIEN,0)),"^",1) < .S DVBABAD=$P($G(^DVB(396.18,DVBABIEN,2)),"^",1) < .S DVBABDD=$P($G(^DVB(396.18,DVBABIEN,2)),"^",2) < .S DVBABSL=$P($G(^DVB(396.18,DVBABIEN,6)),"^",1) < .S DVBABOC=$P($G(^DVB(396.18,DVBABIEN,6)),"^",2) < .S ^TMP("DVBATMPL",DUZ,DVBABCNT)=DVBABNM_"^"_DVBABAD_ < S Y=$NA(^TMP("DVBATMPL",DUZ)) < Q < ; < N DVBABCNT,DVBABIEN,DVBABLNM | N DVBABCNT,DVBABIEN K Y,^TMP("DVBALAB1",DUZ) < > K DVBABCNT,DVBABLNM,DVBABIEN N DVBABCNT,DVBABIEN,DVBABNM,DVBABSTN,DVBABST,DVBABDS, | N DVBABCNT,DVBABIEN,DVBABNM,DVBABSTN,DVBABST,DVBABDS, K Y,^TMP("DVBAINST",$J,DUZ) | K Y,^TMP("DVBAINST",DUZ) . D GETS^DIQ(4,DVBABIEN_",0",".01:.02:.03:","I","DVBA | . D GETS^DIQ(4,DVBABIEN_",0",".01:.02:.03","I","DVBAR . K DVBARR,DVBERR | . S ^TMP("DVBAINST",DUZ,DVBABCNT)=DVBABNM_"^"_DVBABST . D GETS^DIQ(4,DVBABIEN_",0",13,"I","DVBARR","DVBERR" < . S DVBATP=$G(DVBARR(4,DVBABIEN_",0,",13,"I")) < . I DVBATP'="" D < .. S DVBATP=$P($G(^DIC(4.1,DVBATP,0)),"^",1) < . S ^TMP("DVBAINST",$J,DUZ,DVBABCNT)=DVBABNM_"-"_DVBA < S Y=$NA(^TMP("DVBAINST",$J,DUZ)) | S Y=$NA(^TMP("DVBAINST",DUZ)) S ZMSG=+$G(^DVB(396.1,1,5))+1 | S ZMSG=+$G(^DVB(396.1,1,5)) > S ZMSG=ZMSG+1 S XMDUZ=DUZ,J=0 | S XMDUZ=DUZ > S J=0 I '$$GOTLOCAL^XMXAPIG(MGN) S ERR="NO ACTIVE LOCAL MEM < > S XMY(XMDUZ)="" E S ERR="MESSAGE SENT" | I '$D(XMMG) S ERR="MESSAGE SENT" diff -y --suppress-common-lines ./VADemo/r1/DVBAB2.m ./VADemo/r2/r/DVBAB2.m ;;2.7;AMIE;**35,42**;Apr 10, 1995 | ;;2.7;AMIE;**35**;Apr 10, 1995 ; Next 2 lines check for specific division SPH/ALB - < I DVBDIV'="" I '$D(^DVB(396.3,REQDA,1)) Q < I DVBDIV'="" I $P(^DVB(396.3,REQDA,1),"^",4)'=DVBDIV < diff -y --suppress-common-lines ./VADemo/r1/DVBAB3.m ./VADemo/r2/r/DVBAB3.m ;;2.7;AMIE;**35,42**;Apr 10, 1995 | ;;2.7;AMIE;**35**;Apr 10, 1995 S BDATE=BDATE+".0000" < S EDATE=EDATE+".2359" < S DVBDIV=$P(RONUMB,"^",2) < S RONUMB=$P(RONUMB,"^",1) < I RONUM="" S MSG(1)="Invalid Regional Office number" < S RONAME=RONUMB | S RONAME=$P(^DIC(4,RONUM,0),U) INIT(Y) ; < ; INITS MAILMAN VARIABLES < D INIT^XMVVITAE < S Y=XMV("NETNAME")_"^" < Q < diff -y --suppress-common-lines ./VADemo/r1/DVBAB57.m ./VADemo/r2/r/DVBAB57.m ;;2.7;AMIE;**35,42**;Apr 10, 1995 | ;;2.7;AMIE;**35**;Apr 10, 1995 DATA N REQDTE S REQDTE="",CNT=0 | DATA N REQDTE S REQDTE="" F J=0:0 S REQDTE=$O(^DVB(396,"E",REQDTE)) Q:REQDTE="" | F J=0:0 S REQDTE=$O(^DVB(396,"E",REQDTE)) Q:REQDTE="" S PATDA=$P(^DVB(396,DA,0),"^",1) | S REQDTE=$P(^DVB(396,DA,1),"^",1),PATDA=$P(^DVB(396,D ;S REQDTE=$P(^DVB(396,DA,1),"^",1),PATDA=$P(^DVB(396, < diff -y --suppress-common-lines ./VADemo/r1/DVBAB70.m ./VADemo/r2/r/DVBAB70.m ;;2.7;AMIE;**35,42,57**;Apr 10, 1995 | ;;2.7;AMIE;**35**;Apr 10, 1995 I ADR2'="" S ZMSG(DVBABCNT)=" "_ADR2 | S ZMSG(DVBABCNT)=" "_ADR2,DVBABCNT=D I ADR3'="" S ZMSG(DVBABCNT)=" "_ADR3 | S ZMSG(DVBABCNT)=" "_ADR3,DVBABCNT=D S ZMSG(DVBABCNT)="VHA Division Processing Request: "_ < Only in ./VADemo/r1/: DVBAB82.m Only in ./VADemo/r1/: DVBAB89.m Only in ./VADemo/r1/: DVBABEBD.m Only in ./VADemo/r1/: DVBABFRM.m Only in ./VADemo/r1/: DVBABTIU.m diff -y --suppress-common-lines ./VADemo/r1/DVBACRRR.m ./VADemo/r2/r/DVBACRRR.m ;;2.7;AMIE;**42**;Apr 10, 1995 | ;;2.7;AMIE;;Apr 10, 1995 Q:$G(DVBGUI) D:$D(ZTQUEUED) KILL^%ZTLOAD | D:$D(ZTQUEUED) KILL^%ZTLOAD .I '$D(DVBGUI) D PAUSE^DVBCUTL4 | .D PAUSE^DVBCUTL4 I '$D(DVBGUI) D HOME^%ZIS | D HOME^%ZIS diff -y --suppress-common-lines ./VADemo/r1/DVBADSNT.m ./VADemo/r2/r/DVBADSNT.m ;;2.7;AMIE;**1,14,17,42**;Apr 10, 1995 | ;;2.7;AMIE;**1,14,17**;Apr 10, 1995 N DVBGUI < S DVBGUI=0 < ENBROKER(Y) ; < N DVBGUI,DVBHFS,DVBERR < S DVBGUI=1,DVBERR=0,DVBHFS=$$HFS^DVBAB82() < K ^TMP($J) G TERM < Q < I DVBGUI=0 D | I IOST?1"C-".E W *7,!,"Press RETURN to continue or "" . I IOST?1"C-".E W *7,!,"Press RETURN to continue or < I DVBGUI=1 D END^DVBAB82 < EN1 I DVBGUI=0 D | EN1 W !!,"This program will print out any new NOTICES OF . W !!,"This program will print out any new NOTICES O | I $D(%Y) I %Y["?" W !!,"Enter Y to print out the noti . I $D(%Y) I %Y["?" W !!,"Enter Y to print out the no | G:%'=1 KILL S %ZIS="Q" D ^%ZIS K %ZIS I POP G KILL . G:%'=1 KILL S %ZIS="Q" D ^%ZIS K %ZIS I POP G KILL < I DVBGUI=1 D HFSOPEN^DVBAB82("DVBRP",DVBHFS,"W") I DV < diff -y --suppress-common-lines ./VADemo/r1/DVBADSRT.m ./VADemo/r2/r/DVBADSRT.m ;;2.7;AMIE;**17,59**;Apr 10, 1995 | ;;2.7;AMIE;**17**;Apr 10, 1995 .;I '$D(^TMP("DVBA",$J,"DUP",+TDIS)) Q | .I '$D(^TMP("DVBA",$J,"DUP",+TDIS)) Q .I '$D(DISTYPE(+TDIS)) Q < M DISTYPE=^TMP("DVBA",$J,"DUP") < QUEUE ;I $D(IO("Q")) S ZTRTN="DEQUE^DVBADSRT",ZTIO=ION,NOAS | QUEUE I $D(IO("Q")) S ZTRTN="DEQUE^DVBADSRT",ZTIO=ION,NOASK I $D(IO("Q")) S ZTRTN="DEQUE^DVBADSRT",ZTIO=ION,NOASK < D PRINT I $D(DVBAQUIT) K DVBAON2,DISTYPE G KILL^DVBAU | D PRINT I $D(DVBAQUIT) K DVBAON2 G KILL^DVBAUTIL W !!,"End of the Report" < KILL D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD S X=4 K DVBAON2, | KILL D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD S X=4 K DVBAON2 diff -y --suppress-common-lines ./VADemo/r1/DVBASPD2.m ./VADemo/r2/r/DVBASPD2.m ;;2.7;AMIE;**3,57**;Apr 10, 1995 | ;;2.7;AMIE;**3**;Apr 10, 1995 PRINTB W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF | PRINTB S TO="",MA=$P(DATA,U),RCVAA=$P(DATA,U,2),RCVPEN=$P(DA > W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF W ?10,REP(0),?26,PNAM,!!,?14,REP(1),?26,CNUM,!,?6,REP | S:ADMDT]"" ADMDT=$E(ADMDT,4,5)_"/"_$E(ADMDT,6,7)_"/"_ W ?8,REP(6),?26,DCHGDT,! W:DCHGDT]"" ?5,REP(7),?26,$$ | W ?10,"Patient Name:",?26,PNAM,!!,?14,"Claim No:",?26 W ?11,REP(8),?26,BEDSEC,!,?13,REP(9),?26,$$RAA,! | W ?8,"Discharge Date:",?26,DCHGDT,! W:DCHGDT]"" ?5,"T W ?14,REP(10),?26,$$PEN,! D ELIG^DVBAVDPT | W ?11,"Bed Service:",?26,BEDSEC,!,?13,"Recv A&A?:",?2 > W ?14,"Pension?:",?26,$S(RCVPEN=0:"NO",RCVPEN=1:"YES" RAA() Q $S(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified") | ; PEN() Q $S(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified") | PRINT U IO S QUIT="" DIS() Q TDIS_$S(TO]"":" TO "_$S($D(^DIC(4,+TO,0)):$P(^(0),U | S XCN="" F M=0:0 S XCN=$O(^TMP($J,XCN)) Q:XCN=""!(QUI SP(N,M) S $P(M," ",N-1)=" " Q M ;pass one arg, 2nd for local < PRINTC F J=0:1:7 S ^TMP("DVBSPCRP",$J,DVBC+J)=DVBS(J) ;Naked < S DVBC=DVBC+6,^TMP("DVBSPCRP",$J,DVBC)=$$SP(10)_REP(0 < S ^(DVBC+2)=$$SP(14)_REP(1)_CNUM < S ^(DVBC+3)=$$SP(6)_REP(2)_XCFLOC < S ^(DVBC+4)=$$SP(9)_REP(3)_SSN < S ^(DVBC+5)=$$SP(8)_REP(4)_ADMDT < S ^(DVBC+6)=$$SP(3)_REP(5)_DIAG < S DVBC=DVBC+7,^(DVBC)=$$SP(8)_REP(6)_DCHGDT < I DCHGDT]"" D < .S DVBC=DVBC+1,^(DVBC)=$$SP(5)_REP(7)_$$DIS < S ^(DVBC+1)=$$SP(11)_REP(8)_BEDSEC < S ^(DVBC+2)=$$SP(13)_REP(9)_$$RAA < S DVBC=DVBC+3,^(DVBC)=$$SP(14)_REP(10)_$$PEN < D ELIG^DVBAVDPT < Q < PRINT S QUIT="",XCN="" < F S XCN=$O(^TMP($J,XCN)) Q:XCN=""!(QUIT=1) S XCFLOC < PRINT1 S ADM="" F S ADM=$O(^TMP($J,XCN,XCFLOC,ADM)) Q:ADM=" | PRINT1 S ADM="" F K=0:0 S ADM=$O(^TMP($J,XCN,XCFLOC,ADM)) Q: .S DA="" F S DA=$O(^TMP($J,XCN,XCFLOC,ADM,DA)) Q:DA= < ..S DATA=^(DA),MA=$P(DATA,U),RCVAA=$P(DATA,U,2),RCVPE < ..S CNUM=$P(DATA,U,4),TDIS=$P(DATA,U,5),DFN=DA,TO="", < ..D ADM^DVBAVDPT < ..S:ADMDT]"" ADMDT=$E(ADMDT,4,5)_"/"_$E(ADMDT,6,7)_"/ < ..S:DCHGDT]"" DCHGDT=$E(DCHGDT,4,5)_"/"_$E(DCHGDT,6,7 < ..I $$BROKER^XWBLIB D PRINTC Q < ..D PRINTB < SETUP S RPT="VARO REPORT"_$S(REP="A":" FOR A & A",1:" FOR P < S HEAD="SPECIAL "_$S(REP="A":"A & A",1:"PENSION")_" R < S Y=$P(DTAR,U,9) X ^DD("DD") S REP("LRUN")="Last repo < S REP(0)="Patient Name:",REP(1)="Claim No:" < S REP(2)="Claim Folder Loc:",REP(3)="Social Sec No:" < S REP(4)="Admission Date:",REP(5)="Admitting Diagnosi < S REP(6)="Discharge Date:",REP(7)="Type of Discharge: < S REP(8)="Bed Service:",REP(9)="Recv A&A?:",REP(10)=" < Q < TERM D HOME^%ZIS,SETUP K NOASK < W @IOF,!,RPT,!,HEAD1 < EN1 W !!,"Please enter dates for search, oldest date firs | TERM D HOME^%ZIS K NOASK > ; > SETUP W @IOF,!,"VARO REPORT"_$S(REP="A":" FOR A & A",1:" FO > S HEAD="SPECIAL "_$S(REP="A":"A & A",1:"PENSION")_" R > W !,HEAD1 > EN1 W !!,"Please enter dates for search, oldest date firs GO S MA=BDATE F S MA=$O(^DGPM("AMV1",MA)) Q:$P(MA,".")> | GO S MA=BDATE F J=0:0 S MA=$O(^DGPM("AMV1",MA)) Q:$P(MA, S:'$D(^TMP($J)) ER="No data found for parameters ente | I '$D(^TMP($J)) U IO W !!,*7,"No data found for param G:$$BROKER^XWBLIB BROKER | D PRINT I $D(DVBAQUIT) D:$D(ZTQUEUED) KILL^%ZTLOAD K U IO I $D(ER) W !!,*7,ER,!! G KILL < D PRINT < I $D(DVBAQUIT) D:$D(ZTQUEUED) KILL^%ZTLOAD K ER,DVBAO < ; < KILL D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD S X=9 K ER,DVBAO < ; < INIT F J=0,2,5,6,7 S DVBS(J)=" " < S $P(DVBS(1),"-",70)="-",DVBS(3)=$$SP(70-$L(HEAD)\2)_ < S ^TMP("DVBSPCRP",$J,1)=" ",^(2)=RPT,^(3)=HEAD1,^(4)= < F J=0:1:10 S REP(J)=REP(J)_" " < Q < BROKER I $D(ER) K ^TMP("DVBSPCRP",$J) S ^($J,1)=ER < E D INIT,PRINT < S X=9 G FINAL^DVBAUTIL < ; < SPECRPT(ZMSG,DCTYPES,BDATE,EDATE,RONUM,REP) ; < N I,J,REQ,DVBC,DVBACEPT,DVBS,ER < S ZMSG=$NA(^TMP("DVBSPCRP",$J)),RONUM=+$G(RONUM),REQ= < S MB=" MUST BE ",TYPE="REPORT TYPE",BDT="BEGINNING DA < I $G(BDATE)="" S ER=BDT_REQ < I $G(EDATE)="" S ER=EDT_REQ < I EDATE KILL D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD S X=9 K DVBAON2 > ; > DEQUE K ^TMP($J) G GO Only in ./VADemo/r1/: DVBASRP1.m diff -y --suppress-common-lines ./VADemo/r1/DVBAVDPT.m ./VADemo/r2/r/DVBAVDPT.m ;;2.7;AMIE;**57**;Apr 10, 1995 | ;;2.7;AMIE;;Apr 10, 1995 ELIG N ED S ELIG=DVBAELIG,INCMP="",ED="Eligibility data:" | ELIG S ELIG=DVBAELIG,INCMP="" > W ?6,"Eligibility data:" I INCMP]"",ELIG]"" S ELIG=ELIG_", " | W ?26,ELIG_$S(ELIG]"":", ",1:"") W:$X>60 !?26 W INCMP I '$D(DVBC)!'$$BROKER^XWBLIB W ?6,ED,?26,ELIG W:$X>60 < S DVBC=DVBC+1,ED=" "_ED_" ",^TMP("DVBSPCRP",$J < I $L(^(DVBC))<60 S ^(DVBC)=^(DVBC)_INCMP ;NakedRefs = < E S DVBC=DVBC+1,$P(^(DVBC)," ",25)=" "_INCMP < S DVBC=DVBC+1 < diff -y --suppress-common-lines ./VADemo/r1/DVBCBUL1.m ./VADemo/r2/r/DVBCBUL1.m ;;2.7;AMIE;**42**;Apr 10, 1995 | ;;2.7;AMIE;;Apr 10, 1995 S ^TMP("DVBC","BUL1",$J,L,0)=" Name: "_PNAM_" SSN | S ^TMP("DVBC","BUL1",$J,L,0)=" Name: "_PNAM_" SSN S XMY(DUZ)="",XMSUB="Addition of 2507 Exams",XMTEXT=" | S XMY(DUZ)="",XMSUB="Addition of 2507 Exams",XMTEXT=" I '$D(^VA(200,DUZ,.15)) S XMY(XMDUZ)="" G XMD < I $D(^VA(200,DUZ,.15))&($P(^VA(200,DUZ,.15),"^",1)="" < I $D(^VA(200,DUZ,.15)) S XMY($P(^VA(200,DUZ,.15),"^", < XMD D ^XMD K ^TMP("DVBC","BUL1",$J),XMDUZ,DOTS,L,JI,JY,XM < diff -y --suppress-common-lines ./VADemo/r1/DVBCBULL.m ./VADemo/r2/r/DVBCBULL.m ;;2.7;AMIE;**42**;Apr 10, 1995 | ;;2.7;AMIE;;Apr 10, 1995 S ^TMP("DVBC","BULL",$J,L,0)=" Name: "_PNAM_" SSN | S ^TMP("DVBC","BULL",$J,L,0)=" Name: "_PNAM_" SSN S:REQSTR="" REQSTR=.5 S XMY(REQSTR)="",XMY(DUZ)="",XM | S:REQSTR="" REQSTR=.5 S XMY(REQSTR)="",XMY(DUZ)="",XM I '$D(^VA(200,DUZ,.15)) S XMY(XMDUZ)="" G XMD < I $D(^VA(200,DUZ,.15))&($P(^VA(200,DUZ,.15),"^",1)="" < I $D(^VA(200,DUZ,.15)) S XMY($P(^VA(200,DUZ,.15),"^", < XMD D ^XMD < diff -y --suppress-common-lines ./VADemo/r1/DVBCENQ1.m ./VADemo/r2/r/DVBCENQ1.m ;;2.7;AMIE;**17,57**;Apr 10, 1995 | ;;2.7;AMIE;**17**;Apr 10, 1995 W "VHA Division Processing Request: "_$P($$SITE^VASIT < diff -y --suppress-common-lines ./VADemo/r1/DVBCEXM1.m ./VADemo/r2/r/DVBCEXM1.m ;;2.7;AMIE;**12,16,80**;Apr 10, 1995 | ;;2.7;AMIE;**12,16**;Apr 10, 1995 ;; ( ) Mental Disorders (not PTSD and Eati | ;; ( ) Mental Disorders (not initial PTSD ;; ( ) Initial Evaluation for Post-Traumat | ;; and Eating Disorders) ;; ( ) Review Examination for Post-Traumat < ;; ( ) Eating Disorders (Mental Disorders) < ;; ( ) Social and Industrial Survey < diff -y --suppress-common-lines ./VADemo/r1/DVBCLABR.m ./VADemo/r2/r/DVBCLABR.m ;;2.7;AMIE;**11,42**;Apr 10, 1995 | ;;2.7;AMIE;**11**;Apr 10, 1995 REN2 U IO D SETLAB^DVBCPRNT,LAB S LKILL=1 | REN2 U IO D SETLAB^DVBCPRNT,LAB S LKILL=1 D:$D(ZTQUEUED) K Q:$G(DVBGUI) D:$D(ZTQUEUED) KILL^%ZTLOAD < G KILL^DVBCUTIL < diff -y --suppress-common-lines ./VADemo/r1/DVBCPATA.m ./VADemo/r2/r/DVBCPATA.m ;;2.7;AMIE;**1,23,40,42,55,77**;Apr 10, 1995 | ;;2.7;AMIE;**1,23,40**;Apr 10, 1995 S DVBADA=+Y | S (DVBADA,DA)=+Y I $P(Y,U,3) S DVBCNEW=1 D MPI(,DVBADA) | I $P(Y,U,3) S DVBCNEW=1 S DA=DVBADA < MPI(DVBBKMSG,DFN) ;MPI call to set ICN < ;check to see if CIRN PD/MPI is installed < I $D(DG20NAME) K DG20NAME < N X S X="MPIFAPI" X ^%ZOSF("TEST") Q:'$T < K MPIFRTN < S MPIFS=1 < D MPIQ^MPIFAPI(DFN) < K MPIFRTN < Q < diff -y --suppress-common-lines ./VADemo/r1/DVBCPNDR.m ./VADemo/r2/r/DVBCPNDR.m DVBCPNDR ;ALB/GTS-557/THM-2507 PENDING REQUESTS, PART | DVBCPNDR ;ALB/GTS-557/THM-2507 PENDING REQUESTS, PART ;;2.7;AMIE;**51**;Apr 10, 1995 | ;;2.7;AMIE;;Apr 10, 1995 G CALWRK:DVBCSORT'="R" H 1 W @IOF,!,"Routing Location | G CALWRK:DVBCSORT'="R" H 1 W @IOF,!,"Routing Location diff -y --suppress-common-lines ./VADemo/r1/DVBCROPN.m ./VADemo/r2/r/DVBCROPN.m ;;2.7;AMIE;**42**;Apr 10, 1995 | ;;2.7;AMIE;;Apr 10, 1995 H 1 S Y=REQDT X ^DD("DD") S XREQDT=Y,XMDUZ=DUZ | H 1 S Y=REQDT X ^DD("DD") S XREQDT=Y S XMB="DVBA C 2507 EXAM REOPENED",XMB(1)=PNAM,XMB(2)= | S XMB="DVBA C 2507 EXAM REOPENED",XMB(1)=PNAM,XMB(2)= I '$D(^VA(200,DUZ,.15)) S XMY(XMDUZ)="" G XMB | D ^XMB I $D(^VA(200,DUZ,.15))&($P(^VA(200,DUZ,.15),"^",1)="" < I $D(^VA(200,DUZ,.15)) S XMY($P(^VA(200,DUZ,.15),"^", < XMB D ^XMB K XMDUZ < diff -y --suppress-common-lines ./VADemo/r1/DVBCRPRT.m ./VADemo/r2/r/DVBCRPRT.m ;;2.7;AMIE;**31,42**;Apr 10, 1995 | ;;2.7;AMIE;**31**;Apr 10, 1995 NEXT I '$D(DVBGUI) W !,"Continued on next page",!,"VA Form | NEXT W !,"Continued on next page",!,"VA Form 2507" Only in ./VADemo/r1/: DVBCSIS.m Only in ./VADemo/r1/: DVBCST1.m Only in ./VADemo/r1/: DVBCST2.m diff -y --suppress-common-lines ./VADemo/r1/DVBCUTL4.m ./VADemo/r2/r/DVBCUTL4.m ;;2.7;AMIE;**57**;Apr 10, 1995 | ;;2.7;AMIE;;Apr 10, 1995 S DIE="^DVB(396.4,",DA=EXMDA,DR=".04///C;90///NOW" | S DIE="^DVB(396.4,",DA=EXMDA,DR=".04///C" Only in ./VADemo/r1/: DVBCWAU2.m Only in ./VADemo/r1/: DVBCWAU3.m Only in ./VADemo/r1/: DVBCWCI2.m Only in ./VADemo/r1/: DVBCWCI3.m Only in ./VADemo/r1/: DVBCWCI4.m Only in ./VADemo/r1/: DVBCWDI2.m Only in ./VADemo/r1/: DVBCWDIA.m Only in ./VADemo/r1/: DVBCWEE2.m Only in ./VADemo/r1/: DVBCWEEA.m Only in ./VADemo/r1/: DVBCWGE2.m Only in ./VADemo/r1/: DVBCWGE3.m Only in ./VADemo/r1/: DVBCWHT2.m Only in ./VADemo/r1/: DVBCWHT3.m Only in ./VADemo/r1/: DVBCWHT4.m Only in ./VADemo/r1/: DVBCWHT5.m Only in ./VADemo/r1/: DVBCWHT6.m Only in ./VADemo/r1/: DVBCWHT7.m Only in ./VADemo/r1/: DVBCWJW2.m Only in ./VADemo/r1/: DVBCWJW3.m Only in ./VADemo/r1/: DVBCWLL1.m Only in ./VADemo/r1/: DVBCWLL2.m Only in ./VADemo/r1/: DVBCWLL3.m Only in ./VADemo/r1/: DVBCWLL4.m Only in ./VADemo/r1/: DVBCWLLA.m Only in ./VADemo/r1/: DVBCWLL.m Only in ./VADemo/r1/: DVBCWNS4.m Only in ./VADemo/r1/: DVBCWNS5.m diff -y --suppress-common-lines ./VADemo/r1/DVBCWP1.m ./VADemo/r2/r/DVBCWP1.m ;;2.7;AMIE;**12,56**;Apr 10, 1995 | ;;2.7;AMIE;**12**;Apr 10, 1995 ;; | ;;Narrative: This is the protocol for conducting ini ;;Narrative: This is the protocol for conducting init | ;;on former POWs. It should be faxed in its entirety ;;POWs. Approach these veterans with the greatest se | ;;office. Bear in mind that the POW experience likel ;;POW experience likely resulted in a great deal of p | ;;great deal of psychological and physical trauma. A ;;trauma. Details about beatings, torture, forced ma | ;;veterans with the greatest sensitivity. Details ab ;;disease, brainwashing, extremes of hot and cold, an | ;;torture, forced marches, forced labor, disease, bra ;;significant parts of the veteran's history; eliciti | ;;of hot and cold, and anxiety may be significant par ;;that one establish a trusting relationship with the | ;;history, and eliciting them requires that a trustin ;;veteran for each disability / disease / condition v | ;;the veteran first be established. ;;as a consequence of the POW experience. A former P < ;;to service connection for presumptive POW diseases; < ;;a list of these presumptive diseases. Based on vet < ;;findings, please refer to and follow additional wor < ;;the examination provides information adequate for < ;; < ;; < ;; Beriberi (including beriberi heart disease whic | ;; Beriberi (including beriberi heart disease) ;; heart disease in a former POW who experienced l < ;; during captivity) < ;; Cirrhosis of the liver < > ;; Ischemic heart disease (Beriberi heart disease > ;; heart disease in a former prisoner of war who > ;; localized edema during captivity.) > ;;TOF ;; 5. Describe current treatment (specify type, f | ;; 5. Describe current treatment (specify type, f ;; response, side effects). | ;; duration, response, side effects). diff -y --suppress-common-lines ./VADemo/r1/DVBCWP2.m ./VADemo/r2/r/DVBCWP2.m ;;2.7;AMIE;**12,56**;Apr 10, 1995 | ;;2.7;AMIE;**12**;Apr 10, 1995 ;;1. Complete, review and comment on all laboratory | ;; 1. All laboratory and diagnostic tests should ;; | ;; reviewed prior to completing the summary of ;;2. Provide diagnoses. | ;; 2. The POW Physician Coordinator should comple ;; | ;; findings, diagnoses, and recommendations. ;;3. Where some evidence indicates the disability ma | ;; should also express an opinion, with suppor ;; incurred in service, please provide an opinion | ;; concerning the relationship between the vet ;; the disease or injury was at least as likely as | ;; as a POW and each current medical condition ;; in service. Please base your opinion on sound m | ;; is diagnosed, it should be clarified whethe ;; and complete consideration of all the evidence | ;; post-traumatic osteoarthritis, and, if so, ;; Please discuss your reasoning and the evidence | ;; related to the period of confinement. ;; formulating your opinion. < ;; < ;;___________________________________________________ < Only in ./VADemo/r1/: DVBCWPA1.m Only in ./VADemo/r1/: DVBCWPA2.m Only in ./VADemo/r1/: DVBCWPA.m Only in ./VADemo/r1/: DVBCWSD4.m Only in ./VADemo/r1/: DVBCWSD5.m diff -y --suppress-common-lines ./VADemo/r1/DVBCXFRC.m ./VADemo/r2/r/DVBCXFRC.m ;;2.7;AMIE;**1,6,18,65**;Apr 10, 1995 | ;;2.7;AMIE;**1,6,18**;Apr 10, 1995 K DD,DO D FILE^DICN | S DINUM=X K DD,DO D FILE^DICN diff -y --suppress-common-lines ./VADemo/r1/DVBHCE10.m ./VADemo/r2/r/DVBHCE10.m DVBHCE10 ; ;07/02/04 | DVBHCE10 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE11.m ./VADemo/r2/r/DVBHCE11.m DVBHCE11 ; ;07/02/04 | DVBHCE11 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE12.m ./VADemo/r2/r/DVBHCE12.m DVBHCE12 ; ;07/02/04 | DVBHCE12 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE13.m ./VADemo/r2/r/DVBHCE13.m DVBHCE13 ; ;07/02/04 | DVBHCE13 ; ;02/04/03 I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(1)= | I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(1)= S DE(DW)="C1^DVBHCE13",DE(DW,"INDEX")=1 | S DE(DW)="C1^DVBHCE13" C1F1 N X,X1,X2 S DIXR=230 D C1X1(U) K X2 M X2=X D C1X1("O" | C1F1 Q D < . D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.111,DION),$P($G(^DP < S X=$G(X(1)) < Q < C1F2 Q < S DE(DW)="C2^DVBHCE13",DE(DW,"INDEX")=1 | S DE(DW)="C2^DVBHCE13" C2F1 N X,X1,X2 S DIXR=232 D C2X1(U) K X2 M X2=X D C2X1("O" | C2F1 Q D < . D FC^DGFCPROT(.DA,2,.112,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.112,"SET",$H,$G(DUZ),.X,.X1,.X < G C2F2 < C2X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.112,DION),$P($G(^DP < S X=$G(X(1)) < Q < C2F2 Q < S DE(DW)="C3^DVBHCE13",DE(DW,"INDEX")=1 | S DE(DW)="C3^DVBHCE13" D ^DVBHCE14 | S X=DG(DQ),DIC=DIE C3F1 N X,X1,X2 S DIXR=233 D C3X1(U) K X2 M X2=X D C3X1("O" | S A1B2TAG="PAT" D ^A1B2XFR D | S X=DG(DQ),DIC=DIE . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,. | D EVENT^IVMPLOG(DA) K X M X=X2 D | S X=DG(DQ),DIC=DIE . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 G C3F2 | S X=DG(DQ),DIC=DIE C3X1(DION) K X | S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DP | S X=DG(DQ),DIC=DIE S X=$G(X(1)) | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VA Q | S X=DG(DQ),DIC=DIE C3F2 Q | D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ > C3F1 Q S DE(DW)="C4^DVBHCE13",DE(DW,"INDEX")=1 | S DE(DW)="C4^DVBHCE13" D ^DVBHCE15 | D ^DVBHCE14 > D ^DVBHCE15 > C4F1 Q > X4 K:$L(X)>15!($L(X)<2) X > I $D(X),X'?.ANP K X > Q > ; > 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;5",DV="P5'a",DU= > S DE(DW)="C5^DVBHCE13" > S DU="DIC(5," > G RE > C5 G C5S:$D(DE(5))[0 K DB C4F1 N X,X1,X2 S DIXR=234 D C4X1(U) K X2 M X2=X D C4X1("O" | C5S S X="" G:DG(DQ)=X C5F1 K DB > D ^DVBHCE17 > C5F1 Q > X5 Q > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".11;12",DV="FXOa",DU > S DQ(6,2)="S Y(0)=Y D ZIPOUT^VAFADDR" > S DE(DW)="C6^DVBHCE13",DE(DW,"INDEX")=1 > G RE > C6 G C6S:$D(DE(6))[0 K DB > D ^DVBHCE18 > C6S S X="" G:DG(DQ)=X C6F1 K DB > D ^DVBHCE19 > C6F1 N X,X1,X2 S DIXR=185 D C6X1(U) K X2 M X2=X D C6X1("O" . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,. | . N DIEXARR M DIEXARR=X S DIEZCOND=1 K X M X=X2 D | . I X1(1)'=X2(1) . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X | . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND G C4F2 | . K EASDO2 C4X1(DION) K X | G C6F2 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DP | C6X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D > S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X( > S:$D(X)#2 X(2)=X C4F2 Q | C6F2 Q X4 K:$L(X)>15!($L(X)<2) X | X6 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X 5 D:$D(DG)>9 F^DIE17 G ^DVBHCE17 | 7 D:$D(DG)>9 F^DIE17 G ^DVBHCE20 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE14.m ./VADemo/r2/r/DVBHCE14.m DVBHCE14 ; ;07/02/04 | DVBHCE14 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(4),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(4),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(4),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(4),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(4),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VA S X=DG(DQ),DIC=DIE | S X=DE(4),DIC=DIE I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/DVBHCE15.m ./VADemo/r2/r/DVBHCE15.m DVBHCE15 ; ;07/02/04 | DVBHCE15 ; ;02/04/03 S X=DE(4),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(4),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(4),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(4),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(4),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(4),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET | I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ diff -y --suppress-common-lines ./VADemo/r1/DVBHCE16.m ./VADemo/r2/r/DVBHCE16.m DVBHCE16 ; ;07/02/04 | DVBHCE16 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DE(5),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VA S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/DVBHCE17.m ./VADemo/r2/r/DVBHCE17.m DVBHCE17 ; ;07/02/04 | DVBHCE17 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, < I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,5) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DVBHCE17",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;5",DV="P5'a",DU= < S DE(DW)="C1^DVBHCE17",DE(DW,"INDEX")=1 < S DU="DIC(5," < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DE(1),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DE(1),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(1),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DE(1),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(1),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VA < 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 < I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ C1F1 N X,X1,X2 S DIXR=235 D C1X1(U) K X2 M X2=X D C1X1("O" < D < . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DP < S X=$G(X(1)) < Q < C1F2 Q < X1 Q < 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".11;12",DV="FXOa",DU < S DQ(2,2)="S Y(0)=Y D ZIPOUT^VAFADDR" < S DE(DW)="C2^DVBHCE17",DE(DW,"INDEX")=1 < G RE < C2 G C2S:$D(DE(2))[0 K DB < S X=DE(2),DIC=DIE < D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) < S X=DE(2),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(2),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DE(2),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(2),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V < S X=DE(2),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET < C2S S X="" G:DG(DQ)=X C2F1 K DB < S X=DG(DQ),DIC=DIE < D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) < S X=DG(DQ),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V < S X=DG(DQ),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C2F1 N X,X1,X2 S DIXR=185 D C2X1(U) K X2 M X2=X D C2X1("O" < D < . N DIEXARR M DIEXARR=X S DIEZCOND=1 < . I X1(1)'=X2(1) < . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND < . K EASDO2 < G C2F2 < C2X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D < S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X( < S:$D(X)#2 X(2)=X < S X=$G(X(1)) < Q < C2F2 S DIXR=231 D C2X2(U) K X2 M X2=X D C2X2("O") K X1 M X < D < . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1, < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,. < G C2F3 < C2X2(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D < S X=$G(X(1)) < Q < C2F3 Q < X2 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X < I $D(X),X'?.ANP K X < Q < ; < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;7",DV="NJ3,0XOa" < S DQ(3,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11 < S DE(DW)="C3^DVBHCE17" < G RE < C3 G C3S:$D(DE(3))[0 K DB < S X=DE(3),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DE(3),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(3),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(3),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA < S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET < C3S S X="" G:DG(DQ)=X C3F1 K DB < D ^DVBHCE18 < C3F1 Q < X3 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 < Q < ; < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 S Y="@1001" < Q < 5 S DQ=6 ;@5 < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 D SCRQ^DVBHUTIL < Q < 7 S DQ=8 ;@6 < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 D B^DVBHQEDT R AA:DTIME K AA S Y=$S(DVBJS=11:"@1001", < Q < 9 S DQ=10 ;@8 < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S Y=$S(ANS="^0":"@101",ANS="^1":"@1001",ANS="^2":"@1" < Q < 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) < X11 D A^DVBHQEDT S Z2=Z I ERROR K ERROR S Y=$S(DVBJS=11:" < Q < 12 S DQ=13 ;@20 < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 S JP=1,Y=$S(DVBJS=11:"@11",DVBJS=35:"@40",DVBJS=44:"@ < Q < 14 S DQ=15 ;@21 < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 I $P(Z2,U,JP)'=1 S Y="@22" < Q < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 I '$D(DVBCN) S Y="@22",JP=JP+1 < Q < 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) < X17 I 'DVBCN S Y="@22",JP=JP+1 < Q < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 I $L(DVBCN)=9,(DVBCN'=$P(^DPT(D0,0),U,9)) W !!,*7,"HI < Q < 19 D:$D(DG)>9 F^DIE17 G ^DVBHCE19 < diff -y --suppress-common-lines ./VADemo/r1/DVBHCE18.m ./VADemo/r2/r/DVBHCE18.m DVBHCE18 ; ;07/02/04 | DVBHCE18 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR | D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DE(6),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | S X=DE(6),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/DVBHCE19.m ./VADemo/r2/r/DVBHCE19.m DVBHCE19 ; ;07/02/04 | DVBHCE19 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, < I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(17)=% S < I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,3) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DVBHCE19",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".31;3",DV="FXO",DU=" < S DQ(1,2)="S Y(0)=Y S Y=$E(Y,1,10)" < S DE(DW)="C1^DVBHCE19" < S X=DVBCN < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VA < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VA < C1F1 Q < X1 S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P < I $D(X),X'?.ANP K X < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 W "." S JP=JP+1,DVBJ2=1 < Q < 3 S DQ=4 ;@22 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 I $P(Z2,U,JP)'=2 S Y="@225" < Q < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 I '$D(DVBDOB) S Y="@225",JP=JP+1 < Q < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 I 'DVBDOB!(DVBDOB'>170) S Y="@225",JP=JP+1 < Q < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 < X7 I $E(DVBDOB,3,4)="00" W !!,*7,"HINQ Date of Birth doe < Q < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 S Z1=+$E(DVBDOB,1,2)_" "_+$E(DVBDOB,3,4)_" "_+$E(DVBD < Q < 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;3",DV="RDXOa",DU=" < S DQ(9,2)="S Y(0)=Y S X=Y(0) S:X X=$E(X,4,5)_""/""_$E < S DE(DW)="C9^DVBHCE19",DE(DW,"INDEX")=1 < S X=Z1 < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C9 G C9S:$D(DE(9))[0 K DB < S X=DE(9),DIC=DIE < K ^DPT("ADOB",$E(X,1,30),DA) < S X=DE(9),DIC=DIE < ; < S X=DE(9),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DE(9),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(9),DIC=DIE < S IVMX=X,IVMKILL=3,X="IVMPXFR" X ^%ZOSF("TEST") D:$T < S X=DE(9),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".03;" D AVAFC^VAF < S X=DE(9),DIC=DIE < D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) < S X=DE(9),DIIX=2_U_DIFLD D AUDIT^DIET < C9S S X="" G:DG(DQ)=X C9F1 K DB < S X=DG(DQ),DIC=DIE < S ^DPT("ADOB",$E(X,1,30),DA)="" < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0) | D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) S X=DG(DQ),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".03;" D AVAFC^VAF | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V I $D(DE(9))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ C9F1 N X,X1,X2 S DIXR=178 D C9X1(U) K X2 M X2=X D C9X1("O" < D < . D FC^DGFCPROT(.DA,2,.03,"KILL",$H,$G(DUZ),.X,.X1,.X < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.03,"SET",$H,$G(DUZ),.X,.X1,.X2 < G C9F2 < C9X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.03,DION),$P($G(^DPT < S X=$G(X(1)) < Q < C9F2 Q < X9 S %DT="P" D ^%DT S X=Y K:1701231>X!(DT9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 W "." S JP=JP+1,DVBJ2=1 < Q < 11 S DQ=12 ;@225 < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 I $P(Z2,U,JP)'=3 S Y="@23" < Q < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 I $D(DVBBIR) S DVBSEX=$P(DVBBIR,U,25) < Q < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 I $D(DVBVET),$P(DVBVET,U,1)'="C" S DVBSEX=$P(DVBVET,U < Q < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 I '$D(DVBSEX) S Y="@23",JP=JP+1 < Q < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 I DVBSEX'="M",DVBSEX'="F" S Y="@23",JP=JP+1 < Q < 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="0;2",DV="RSa",DU="" < S DE(DW)="C17^DVBHCE19" < S DU="M:MALE;F:FEMALE;" < S X=DVBSEX < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C17 G C17S:$D(DE(17))[0 K DB < D ^DVBHCE20 < C17S S X="" G:DG(DQ)=X C17F1 K DB < D ^DVBHCE21 < C17F1 Q < X17 Q < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 W "." S JP=JP+1,DVBJ2=1 < Q < 19 S DQ=20 ;@23 < 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) < X20 I $P(Z2,U,JP)'=4 S Y="@24" < Q < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 K Z1 I $D(DVBP(6)),+$P(DVBP(6),U) S Z1=$P(DVBP(6),U), < Q < 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) < X22 I $D(DVBVET),$P(DVBVET,U,1)="B",+$P(DVBVET,U,12) S Z1 < Q < 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) < X23 I '$D(Z1) S Y="@24",JP=JP+1 < Q < 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) < X24 I 'Z1 S Y="@24",JP=JP+1 < Q < 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) < X25 I $D(^DPT(D0,.105)) W !!,"Patient is currently in-hou < Q < 26 D:$D(DG)>9 F^DIE17 G ^DVBHCE22 < diff -y --suppress-common-lines ./VADemo/r1/DVBHCE1.m ./VADemo/r2/r/DVBHCE1.m DVBHCE1 ; ;07/02/04 | DVBHCE1 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE20.m ./VADemo/r2/r/DVBHCE20.m DVBHCE20 ; ;07/02/04 | DVBHCE20 ; ;02/04/03 S X=DE(17),DIC=DIE | D DE G BEGIN K ^DPT("ASX",$E(X,1,30),DA) | DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, S X=DE(17),DIC=DIE | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(25)=% > I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,7) S:%]"" DE(1)= > I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,3) S:%]"" DE(17) > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="DVBHCE20",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;7",DV="NJ3,0XOa" > S DQ(1,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11 > S DE(DW)="C1^DVBHCE20" > G RE > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(1),DIC=DIE S X=DE(17),DIC=DIE | S X=DE(1),DIC=DIE S IVMX=X,IVMKILL=2,X="IVMPXFR" X ^%ZOSF("TEST") D:$T | S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF S X=DE(17),DIC=DIE | S X=DE(1),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".02;" D AVAFC^VAF | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA S X=DE(17),DIC=DIE | S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) | C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DE(17),DIIX=2_U_DIFLD D AUDIT^DIET | S X=DG(DQ),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DG(DQ),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DG(DQ),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DG(DQ),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA > I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ > C1F1 Q > X1 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 S Y="@1001" > Q > 3 S DQ=4 ;@5 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 > X4 D SCRQ^DVBHUTIL > Q > 5 S DQ=6 ;@6 > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 > X6 D B^DVBHQEDT R AA:DTIME K AA S Y=$S(DVBJS=11:"@1001", > Q > 7 S DQ=8 ;@8 > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 > X8 S Y=$S(ANS="^0":"@101",ANS="^1":"@1001",ANS="^2":"@1" > Q > 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 > X9 D A^DVBHQEDT S Z2=Z I ERROR K ERROR S Y=$S(DVBJS=11:" > Q > 10 S DQ=11 ;@20 > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 S JP=1,Y=$S(DVBJS=11:"@11",DVBJS=35:"@40",DVBJS=44:"@ > Q > 12 S DQ=13 ;@21 > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 I $P(Z2,U,JP)'=1 S Y="@22" > Q > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) > X14 I '$D(DVBCN) S Y="@22",JP=JP+1 > Q > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) > X15 I 'DVBCN S Y="@22",JP=JP+1 > Q > 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) > X16 I $L(DVBCN)=9,(DVBCN'=$P(^DPT(D0,0),U,9)) W !!,*7,"HI > Q > 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW=".31;3",DV="FXO",DU= > S DQ(17,2)="S Y(0)=Y S Y=$E(Y,1,10)" > S X=DVBCN > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X17 S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P > I $D(X),X'?.ANP K X > Q > ; > 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) > X18 W "." S JP=JP+1,DVBJ2=1 > Q > 19 S DQ=20 ;@22 > 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) > X20 I $P(Z2,U,JP)'=2 S Y="@225" > Q > 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) > X21 I '$D(DVBDOB) S Y="@225",JP=JP+1 > Q > 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) > X22 I 'DVBDOB!(DVBDOB'>170) S Y="@225",JP=JP+1 > Q > 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) > X23 I $E(DVBDOB,3,4)="00" W !!,*7,"HINQ Date of Birth doe > Q > 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) > X24 S Z1=+$E(DVBDOB,1,2)_" "_+$E(DVBDOB,3,4)_" "_+$E(DVBD > Q > 25 S DW="0;3",DV="RDXOa",DU="",DLB="DATE OF BIRTH",DIFLD > S DQ(25,2)="S Y(0)=Y S X=Y(0) S:X X=$E(X,4,5)_""/""_$ > S DE(DW)="C25^DVBHCE20",DE(DW,"INDEX")=1 > S X=Z1 > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > C25 G C25S:$D(DE(25))[0 K DB > D ^DVBHCE21 > C25S S X="" G:DG(DQ)=X C25F1 K DB > D ^DVBHCE22 > C25F1 N X,X1,X2 S DIXR=178 D C25X1(U) K X2 M X2=X D C25X1(" > D > . D FC^DGFCPROT(.DA,2,.03,"KILL",$H,$G(DUZ),.X,.X1,.X > K X M X=X2 D > . D FC^DGFCPROT(.DA,2,.03,"SET",$H,$G(DUZ),.X,.X1,.X2 > G C25F2 > C25X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.03,DION),$P($G(^DPT > S X=$G(X(1)) > Q > C25F2 Q > X25 S %DT="P" D ^%DT S X=Y K:1701231>X!(DT Q > ; > 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) > X26 W "." S JP=JP+1,DVBJ2=1 > Q > 27 S DQ=28 ;@225 > 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) > X28 I $P(Z2,U,JP)'=3 S Y="@23" > Q > 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE) > X29 I $D(DVBBIR) S DVBSEX=$P(DVBBIR,U,25) > Q > 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE) > X30 I $D(DVBVET),$P(DVBVET,U,1)'="C" S DVBSEX=$P(DVBVET,U > Q > 31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE) > X31 I '$D(DVBSEX) S Y="@23",JP=JP+1 > Q > 32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE) > X32 I DVBSEX'="M",DVBSEX'="F" S Y="@23",JP=JP+1 > Q > 33 D:$D(DG)>9 F^DIE17 G ^DVBHCE23 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE21.m ./VADemo/r2/r/DVBHCE21.m DVBHCE21 ; ;07/02/04 | DVBHCE21 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(25),DIC=DIE S ^DPT("ASX",$E(X,1,30),DA)="" | K ^DPT("ADOB",$E(X,1,30),DA) S X=DG(DQ),DIC=DIE | S X=DE(25),DIC=DIE > ; > S X=DE(25),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(25),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(25),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF | S IVMX=X,IVMKILL=3,X="IVMPXFR" X ^%ZOSF("TEST") D:$T S X=DG(DQ),DIC=DIE | S X=DE(25),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".02;" D AVAFC^VAF | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".03;" D AVAFC^VAF S X=DG(DQ),DIC=DIE | S X=DE(25),DIC=DIE I $D(DE(17))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D | S X=DE(25),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/DVBHCE22.m ./VADemo/r2/r/DVBHCE22.m DVBHCE22 ; ;07/02/04 | DVBHCE22 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, < I $D(^(.29)) S %Z=^(.29) S %=$P(%Z,U,12) S:%]"" DE(9) < I $D(^(.35)) S %Z=^(.35) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DVBHCE22",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".35;1",DV="DXa",DU=" < S DE(DW)="C1^DVBHCE22",DE(DW,"INDEX")=1 < S X=Z1 < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0) < S X=DE(1),DIC=DIE < ; < S X=DE(1),DIC=DIE < D DKBULL^DGDEATH < S X=DE(1),DIC=DIE < K ^DPT("AEXP1",$E(X,1,30),DA) < S X=DE(1),DIC=DIE < ; < S X=DE(1),DIC=DIE < ; < S X=DE(1),DIC=DIE < S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I < S X=DE(1),DIC=DIE < D KILL^DGDEPINA < S X=DE(1),DIC=DIE < D AUTOUPD^DGENA2(DA) < S X=DE(1),DIC=DIE < I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOAUTOC(DA) < S X=DE(1),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(1),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VA < 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 < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0) < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3 < S X=DG(DQ),DIC=DIE < D DSBULL^DGDEATH < S X=DG(DQ),DIC=DIE < S ^DPT("AEXP1",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < D DEATH^DGOERNOT < S X=DG(DQ),DIC=DIE < S XX=X,X="PSJADT" X ^%ZOSF("TEST") S X=XX K XX I D E < S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I | S ^DPT("ADOB",$E(X,1,30),DA)="" D SET^DGDEPINA | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0) D AUTOUPD^DGENA2(DA) | S A1B2TAG="PAT" D ^A1B2XFR I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOCAN3(DA) | D EVENT^IVMPLOG(DA) I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".03;" D AVAFC^VAF I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | I $D(DE(25))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D C1F1 N X,X1,X2 S DIXR=180 D C1X1(U) K X2 M X2=X D C1X1("O" < D < . D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.351,DION),$P($G(^DP < S X=$G(X(1)) < Q < C1F2 Q < X1 S %DT="PT" D ^%DT S X=Y K:Y<1 X I $D(X) D H^DGUTL K:X < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 W "." S JP=JP+1,DVBJ2=1 < Q < 3 S DQ=4 ;@24 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 I $P(Z2,U,JP)'=5 S Y="@25" < Q < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 K DVBSICK I $D(DVBP(6)) S DVBSICK=$P(DVBP(6),U,7) < Q < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 I $D(DVBCI) S DVBSICK=DVBCI < Q < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 < X7 I '$D(DVBSICK) S Y="@25",JP=JP+1 < Q < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 I DVBSICK'=1,DVBSICK'=2,DVBSICK'="N",DVBSICK'="Y" S Y < Q < 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".29;12",DV="S",DU="" < S DU="0:NO;1:YES;" < S X=$S((DVBSICK=2)!(DVBSICK="Y"):1,1:0) < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X9 Q < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 W "." S JP=JP+1,DVBJ2=1 K DVBSICK < Q < 11 S DQ=12 ;@25 < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 I $P(Z2,U,JP)'=6 S Y="@26" < Q < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 I '$D(DVBPOW),'$D(DVBPOWD) S Y="@26",JP=JP+1 < Q < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 I '$D(DVBPOW),$D(DVBPOWD),+DVBPOWD W !!,*7,?17,DVBON, < Q < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 I '$D(DVBPOW),'+DVBPOWD S Y="@26",JP=JP+1 < Q < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 I '$D(DVBPOWD),$D(DVBPOW),DVBPOW>0 W !!,*7,?17,DVBON, < Q < 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) < X17 I $D(DVBPOWD),$D(DVBPOW),DVBPOWD=0,DVBPOW>0 W !!,*7,? < Q < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 I $D(DVBPOWD),$D(DVBPOW),+DVBPOW<1,+DVBPOWD W !!,*7,? < Q < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 D POW^DVBHUTIL < Q < 20 D:$D(DG)>9 F^DIE17 G ^DVBHCE23 < diff -y --suppress-common-lines ./VADemo/r1/DVBHCE23.m ./VADemo/r2/r/DVBHCE23.m DVBHCE23 ; ;07/02/04 | DVBHCE23 ; ;02/04/03 I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,5) S:%]"" DE(14)=% | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,4) S:%]"" DE(8)= | I $D(^(.29)) S %Z=^(.29) S %=$P(%Z,U,12) S:%]"" DE(18 I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,2) S:%]"" DE(21) | I $D(^(.35)) S %Z=^(.35) S %=$P(%Z,U,1) S:%]"" DE(10) I $D(^(.52)) S %Z=^(.52) S %=$P(%Z,U,5) S:%]"" DE(1)= < 1 S DW=".52;5",DV="RSX",DU="",DLB="POW STATUS INDICATED | 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;2",DV="RSa",DU="", S DU="Y:YES;N:NO;U:UNKNOWN;" | S DU="M:MALE;F:FEMALE;" S X=DVBPOW1 | S X=DVBSEX ; | K ^DPT("ASX",$E(X,1,30),DA) ; | D EVENT^IVMPLOG(DA) ; | S IVMX=X,IVMKILL=2,X="IVMPXFR" X ^%ZOSF("TEST") D:$T D AUTOUPD^DGENA2(DA) | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".02;" D AVAFC^VAF X "S DFN=DA D EN^DGMTR K DGREQF" | D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET X ^DD(2,.525,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | S ^DPT("ASX",$E(X,1,30),DA)="" X ^DD(2,.525,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | D EVENT^IVMPLOG(DA) X ^DD(2,.525,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D | S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF D AUTOUPD^DGENA2(DA) | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".02;" D AVAFC^VAF X "S DFN=DA D EN^DGMTR K DGREQF" | D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ X1 S DFN=DA D SV^DGLOCK | X1 Q Q < ; < X2 K DVBPOW1 W "." S JP=JP+1,DVBJ2=1 | X2 W "." S JP=JP+1,DVBJ2=1 3 S DQ=4 ;@26 | 3 S DQ=4 ;@23 X4 I $P(Z2,U,JP)'=7 S Y="@27" | X4 I $P(Z2,U,JP)'=4 S Y="@24" X5 I '$D(DVBFL) S Y="@27",JP=JP+1 | X5 K Z1 I $D(DVBP(6)),+$P(DVBP(6),U) S Z1=$P(DVBP(6),U), X6 I DVBFL']"" S Y="@27",JP=JP+1 | X6 I $D(DVBVET),$P(DVBVET,U,1)="B",+$P(DVBVET,U,12) S Z1 X7 I DVBFL'?3N1" - "1U.E S Y="@27",JP=JP+1 | X7 I '$D(Z1) S Y="@24",JP=JP+1 > Q > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 > X8 I 'Z1 S Y="@24",JP=JP+1 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".31;4",DV="*P4'",DU= | 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 S DE(DW)="C8^DVBHCE23" | X9 I $D(^DPT(D0,.105)) W !!,"Patient is currently in-hou S DU="DIC(4," | Q S X=+DVBFL | 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".35;1",DV="DXa",DU= > S DE(DW)="C10^DVBHCE23",DE(DW,"INDEX")=1 > S X=Z1 C8 G C8S:$D(DE(8))[0 K DB | C10 G C10S:$D(DE(10))[0 K DB S X=DE(8),DIC=DIE | S X=DE(10),DIC=DIE N DGX D CFL4^DGREGDD D KILL^DGREGDD1(DA,.312,.31,2,DG | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0) C8S S X="" G:DG(DQ)=X C8F1 K DB | S X=DE(10),DIC=DIE S X=DG(DQ),DIC=DIE | ; N DGX D CFL4^DGREGDD D SET^DGREGDD1(DA,.312,.31,2,DGX | S X=DE(10),DIC=DIE C8F1 Q | D DEL^DGDEATH X8 S DIC("S")="I $$GET1^DIQ(4,+Y,99)'=""""" D ^DIC K DIC | S X=DE(10),DIC=DIE > K ^DPT("AEXP1",$E(X,1,30),DA) > S X=DE(10),DIC=DIE > ; > S X=DE(10),DIC=DIE > ; > S X=DE(10),DIC=DIE > S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I > S X=DE(10),DIC=DIE > D KILL^DGDEPINA > S X=DE(10),DIC=DIE > D AUTOUPD^DGENA2(DA) > S X=DE(10),DIC=DIE > I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOAUTOC(DA) > S X=DE(10),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(10),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VA > S X=DE(10),DIC=DIE > D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) > S X=DE(10),DIIX=2_U_DIFLD D AUDIT^DIET > C10S S X="" G:DG(DQ)=X C10F1 K DB > D ^DVBHCE24 > C10F1 N X,X1,X2 S DIXR=180 D C10X1(U) K X2 M X2=X D C10X1(" > D > . D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,. > K X M X=X2 D > . D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X > G C10F2 > C10X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.351,DION),$P($G(^DP > S X=$G(X(1)) ; | C10F2 Q 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 | X10 S %DT="PT" D ^%DT S X=Y K:Y<1 X I $D(X) D H^DGUTL K:X X9 W "." S JP=JP+1,DVBJ2=1 < 10 S DQ=11 ;@27 | ; X11 I $P(Z2,U,JP)'=8 S Y="@50" | X11 W "." S JP=JP+1,DVBJ2=1 Q < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 I '$D(DVBEI) S Y="@50",JP=JP+1 < > 12 S DQ=13 ;@24 X13 I DVBEI'=1,(DVBEI'=2) S Y="@50",JP=JP+1 | X13 I $P(Z2,U,JP)'=5 S Y="@25" > Q > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) > X14 K DVBSICK I $D(DVBP(6)) S DVBSICK=$P(DVBP(6),U,7) 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".3;5",DV="S",DU="", < S DU="Y:YES;N:NO;" < S X=$S(DVBEI=2:"Y",1:"N") < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X14 Q < X15 W "." S JP=JP+1,DVBJ2=1 | X15 I $D(DVBCI) S DVBSICK=DVBCI X16 S Y="@50" | X16 I '$D(DVBSICK) S Y="@25",JP=JP+1 Q < 17 S DQ=18 ;@40 < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 I $P(Z2,U,JP)'=1 S Y="@42" < Q < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 I '$D(DVBP(6)) S Y="@42",JP=JP+1 < 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) | 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) X20 I $S($P(DVBP(6),U,8)'="Y":1,'$D(^DPT(DFN,.32)):1,+$P( | X17 I DVBSICK'=1,DVBSICK'=2,DVBSICK'="N",DVBSICK'="Y" S Y 21 S DW=".32;2",DV="DX",DU="",DLB="SERVICE VERIFICATION | 18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW=".29;12",DV="S",DU=" S X="T" | S DU="0:NO;1:YES;" > S X=$S((DVBSICK=2)!(DVBSICK="Y"):1,1:0) X21 S %DT="",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X | X18 Q > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) > X19 W "." S JP=JP+1,DVBJ2=1 K DVBSICK > Q > 20 S DQ=21 ;@25 > 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) > X21 I $P(Z2,U,JP)'=6 S Y="@26" ; < X22 W "." S JP=JP+1,DVBJ2=1 | X22 I '$D(DVBPOW),'$D(DVBPOWD) S Y="@26",JP=JP+1 > Q > 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) > X23 I '$D(DVBPOW),$D(DVBPOWD),+DVBPOWD W !!,*7,?17,DVBON, 23 S DQ=24 ;@42 < X24 I $P(Z2,U,JP)'=2 S Y="@45" | X24 I '$D(DVBPOW),'+DVBPOWD S Y="@26",JP=JP+1 X25 I '$D(DVBP(6)) S Y="@45",JP=JP+1 | X25 I '$D(DVBPOWD),$D(DVBPOW),DVBPOW>0 W !!,*7,?17,DVBON, X26 I $P(DVBP(6),U,4)[" " S Y="@45",JP=JP+1 | X26 I $D(DVBPOWD),$D(DVBPOW),DVBPOWD=0,DVBPOW>0 W !!,*7,? > Q > 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) > X27 I $D(DVBPOWD),$D(DVBPOW),+DVBPOW<1,+DVBPOWD W !!,*7,? > Q > 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) > X28 D POW^DVBHUTIL 27 D:$D(DG)>9 F^DIE17 G ^DVBHCE24 | 29 D:$D(DG)>9 F^DIE17 G ^DVBHCE25 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE24.m ./VADemo/r2/r/DVBHCE24.m DVBHCE24 ; ;07/02/04 | DVBHCE24 ; ;02/04/03 D DE G BEGIN | S X=DG(DQ),DIC=DIE DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0) I $D(^(.321)) S %Z=^(.321) S %=$P(%Z,U,1) S:%]"" DE(1 | S X=DG(DQ),DIC=DIE I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,15) S:%]"" DE( | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3 K %Z Q | S X=DG(DQ),DIC=DIE ; | S %X=X,X="DGDEATH" X ^%ZOSF("TEST") S X=%X I $T S DFN W W !?DL+DL-2,DLB_": " | S X=DG(DQ),DIC=DIE Q | S ^DPT("AEXP1",$E(X,1,30),DA)="" O D W W Y W:$X>45 !?9 | S X=DG(DQ),DIC=DIE I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 | D DEATH^DGOERNOT W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (N | S X=DG(DQ),DIC=DIE TR R X:DTIME E S (DTOUT,X)=U W $C(7) | S XX=X,X="PSJADT" X ^%ZOSF("TEST") S X=XX K XX I D E Q | S X=DG(DQ),DIC=DIE A K DQ(DQ) S DQ=DQ+1 | S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I B G @DQ | S X=DG(DQ),DIC=DIE RE G PR:$D(DE(DQ)) D W,TR | D SET^DGDEPINA N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | S X=DG(DQ),DIC=DIE RD G QS:X?."?" I X["^" D D G ^DIE17 | D AUTOUPD^DGENA2(DA) I X="@" D D G Z^DIE2 | S X=DG(DQ),DIC=DIE I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^ | I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOCAN3(DA) T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD | S X=DG(DQ),DIC=DIE K DDER G X | S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | S X=DG(DQ),DIC=DIE G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VA I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5, | S X=DG(DQ),DIC=DIE V D @("X"_DQ) K YS | D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | I $D(DE(10))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="DVBHCE24",DQ=1 < 1 S DW=".321;1",DV="RSX",DU="",DLB="VIETNAM SERVICE IND < S DE(DW)="C1^DVBHCE24" < S DU="Y:YES;N:NO;U:UNKNOWN;" < S X=$P(DVBP(6),U,4) < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < ; < S X=DE(1),DIC=DIE < ; < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < X ^DD(2,.32101,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT < S X=DG(DQ),DIC=DIE < X ^DD(2,.32101,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT < C1F1 Q < X1 S DFN=DA D SV^DGLOCK < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 W "." S JP=JP+1,DVBJ2=1 < Q < 3 S DQ=4 ;@45 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 I $P(Z2,U,JP)'=3!('$D(DVBDX(1))) S Y="@50" < Q < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 S:'$D(DVBFL) DVBFL="UNKNOWN" < Q < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 I $D(DVBCAP),DVBCAP["No C&P",$P(DVBBIR,U,5)'="Y" D CH < Q < 7 S DQ=8 ;@47 < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 S DVB4=$S($D(^DPT(DFN,.3))>0:$P(^(.3),U),1:0),DVB5=$S < Q < 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 < X9 S DVB8=$O(^DIC(8,"B","SERVICE CONNECTED 50% to 100%", < Q < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 I DVBDXSC I ((DVB8'=DVB5&(DVB9'=DVB5))!(DVB4'="Y")!(D < Q < 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) < X11 W ! K ^DPT(DFN,.372),JP4,JP6 S ^DPT(DFN,.372,0)="^2.0 < Q < 12 S DQ=13 ;@46 < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 S JP=$O(DVBDX(JP)) I 'JP S Y="@50" < Q < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 S JPP=+$P(DVBDX(JP),U,2) I JPP'>0!(+$P(DVBDX(JP),U,4) < Q < 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,D=0 K DE(1) ;.3721 < S DIFLD=.3721,DGO="^DVBHCE25",DC="3^2.04P^.372^",DV=" < S DU="DIC(31," < G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY( < S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'=" < M15 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(15)=$P( < S X="""`"_$P(DVBDX(JP),U,2)_"""" < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < R15 D DE < G A < ; < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 W "." S DVBJ2=1 < Q < 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) < X17 S Y="@46" < Q < 18 S DQ=19 ;@61 < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 I Z2'[1 S Y="@62" < Q < 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) < X20 I '$D(DVBSSA) S Y="@62",JP=JP+1 < Q < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 I DVBSSA S DVBYN="Y",DVBXYN=DVBSSA < Q < 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) < X22 I 'DVBSSA S DVBYN="N",DVBXYN="" < Q < 23 S DW=".362;15",DV="SX",DU="",DLB="RECEIVING SOCIAL SE < S DE(DW)="C23^DVBHCE24" < S DU="Y:YES;N:NO;U:UNKNOWN;" < S X=DVBYN < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C23 G C23S:$D(DE(23))[0 K DB < S X=DE(23),DIC=DIE < X ^DD(2,.36225,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT < C23S S X="" G:DG(DQ)=X C23F1 K DB < D ^DVBHCE26 < C23F1 Q < X23 S DFN=DA D MV^DGLOCK Q < Q < ; < 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) < X24 W "." S JP=JP+1,DVBJ2=1 K DVBYN,DVBXYN < Q < 25 S DQ=26 ;@62 < 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) < X26 I Z2'[2 S Y="@63" < Q < 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) < X27 I '$D(DVBRETT) S Y="@63",JP=JP+1 < Q < 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) < X28 I DVBRETT=""!("BMCROX"'[DVBRETT) S Y="@63",JP=JP+1 < Q < 29 D:$D(DG)>9 F^DIE17 G ^DVBHCE27 < diff -y --suppress-common-lines ./VADemo/r1/DVBHCE25.m ./VADemo/r2/r/DVBHCE25.m DVBHCE25 ; ;07/02/04 | DVBHCE25 ; ;02/04/03 DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU= | DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S | I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,5) S:%]"" DE(14)=% > I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,4) S:%]"" DE(8)= > I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,2) S:%]"" DE(21) > I $D(^(.52)) S %Z=^(.52) S %=$P(%Z,U,5) S:%]"" DE(1)= 1 S DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFL | 1 S DW=".52;5",DV="RSX",DU="",DLB="POW STATUS INDICATED S X=$S($P(DVBDX(JP),U,3)="X0":100,1:+$P(DVBDX(JP),U,3 | S DE(DW)="C1^DVBHCE25" > S DU="Y:YES;N:NO;U:UNKNOWN;" > S X=DVBPOW1 X1 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^D | 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 > ; > S X=DE(1),DIC=DIE > D AUTOUPD^DGENA2(DA) > S X=DE(1),DIC=DIE > X "S DFN=DA D EN^DGMTR K DGREQF" > C1S S X="" G:DG(DQ)=X C1F1 K DB > S X=DG(DQ),DIC=DIE > X ^DD(2,.525,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D > S X=DG(DQ),DIC=DIE > X ^DD(2,.525,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D > S X=DG(DQ),DIC=DIE > X ^DD(2,.525,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D > S X=DG(DQ),DIC=DIE > D AUTOUPD^DGENA2(DA) > S X=DG(DQ),DIC=DIE > X "S DFN=DA D EN^DGMTR K DGREQF" > C1F1 Q > X1 S DFN=DA D SV^DGLOCK 2 S DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFL | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 S DU="0:NO;1:YES;" | X2 K DVBPOW1 W "." S JP=JP+1,DVBJ2=1 S X=$P(DVBDX(JP),U,4) | Q > 3 S DQ=4 ;@26 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 > X4 I $P(Z2,U,JP)'=7 S Y="@27" > Q > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 > X5 I '$D(DVBFL) S Y="@27",JP=JP+1 > Q > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 > X6 I DVBFL']"" S Y="@27",JP=JP+1 > Q > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 > X7 I DVBFL'?3N1" - "1U.E S Y="@27",JP=JP+1 > Q > 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".31;4",DV="*P4'",DU= > S DE(DW)="C8^DVBHCE25" > S DU="DIC(4," > S X=+DVBFL > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > C8 G C8S:$D(DE(8))[0 K DB > S X=DE(8),DIC=DIE > N DGX D CFL4^DGREGDD D KILL^DGREGDD1(DA,.312,.31,2,DG > C8S S X="" G:DG(DQ)=X C8F1 K DB > S X=DG(DQ),DIC=DIE > N DGX D CFL4^DGREGDD D SET^DGREGDD1(DA,.312,.31,2,DGX > C8F1 Q > X8 S DIC("S")="I $$GET1^DIQ(4,+Y,99)'=""""" D ^DIC K DIC > Q > ; > 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 > X9 W "." S JP=JP+1,DVBJ2=1 > Q > 10 S DQ=11 ;@27 > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 I $P(Z2,U,JP)'=8 S Y="@50" > Q > 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) > X12 I '$D(DVBEI) S Y="@50",JP=JP+1 > Q > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 I DVBEI'=1,(DVBEI'=2) S Y="@50",JP=JP+1 > Q > 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".3;5",DV="S",DU="", > S DU="Y:YES;N:NO;" > S X=$S(DVBEI=2:"Y",1:"N") > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > X14 Q > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) > X15 W "." S JP=JP+1,DVBJ2=1 > Q > 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) > X16 S Y="@50" > Q > 17 S DQ=18 ;@40 > 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) > X18 I $P(Z2,U,JP)'=1 S Y="@42" > Q > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) > X19 I '$D(DVBP(6)) S Y="@42",JP=JP+1 > Q > 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) > X20 I $S($P(DVBP(6),U,8)'="Y":1,'$D(^DPT(DFN,.32)):1,+$P( > Q > 21 S DW=".32;2",DV="DX",DU="",DLB="SERVICE VERIFICATION > S X="T" X2 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK | X21 S %DT="",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X 3 G 1^DIE17 | 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) > X22 W "." S JP=JP+1,DVBJ2=1 > Q > 23 S DQ=24 ;@42 > 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) > X24 I $P(Z2,U,JP)'=2 S Y="@45" > Q > 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) > X25 I '$D(DVBP(6)) S Y="@45",JP=JP+1 > Q > 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) > X26 I $P(DVBP(6),U,4)[" " S Y="@45",JP=JP+1 > Q > 27 D:$D(DG)>9 F^DIE17 G ^DVBHCE26 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE26.m ./VADemo/r2/r/DVBHCE26.m DVBHCE26 ; ;07/02/04 | DVBHCE26 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, > I $D(^(.321)) S %Z=^(.321) S %=$P(%Z,U,1) S:%]"" DE(1 > I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,15) S:%]"" DE( > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="DVBHCE26",DQ=1 > 1 S DW=".321;1",DV="RSX",DU="",DLB="VIETNAM SERVICE IND > S DE(DW)="C1^DVBHCE26" > S DU="Y:YES;N:NO;U:UNKNOWN;" > S X=$P(DVBP(6),U,4) > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > ; > S X=DE(1),DIC=DIE > ; > C1S S X="" G:DG(DQ)=X C1F1 K DB X ^DD(2,.36225,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT | X ^DD(2,.32101,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT > S X=DG(DQ),DIC=DIE > X ^DD(2,.32101,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT > C1F1 Q > X1 S DFN=DA D SV^DGLOCK > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 W "." S JP=JP+1,DVBJ2=1 > Q > 3 S DQ=4 ;@45 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 > X4 I $P(Z2,U,JP)'=3!('$D(DVBDX(1))) S Y="@50" > Q > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 > X5 S:'$D(DVBFL) DVBFL="UNKNOWN" > Q > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 > X6 I $D(DVBCAP),DVBCAP["No C&P",$P(DVBBIR,U,5)'="Y" D CH > Q > 7 S DQ=8 ;@47 > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 > X8 S DVB4=$S($D(^DPT(DFN,.3))>0:$P(^(.3),U),1:0),DVB5=$S > Q > 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 > X9 S DVB8=$O(^DIC(8,"B","SERVICE CONNECTED 50% to 100%", > Q > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) > X10 I DVBDXSC I ((DVB8'=DVB5&(DVB9'=DVB5))!(DVB4'="Y")!(D > Q > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 W ! K ^DPT(DFN,.372),JP4,JP6 S ^DPT(DFN,.372,0)="^2.0 > Q > 12 S DQ=13 ;@46 > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 S JP=$O(DVBDX(JP)) I 'JP S Y="@50" > Q > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) > X14 S JPP=+$P(DVBDX(JP),U,2) I JPP'>0!(+$P(DVBDX(JP),U,4) > Q > 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,D=0 K DE(1) ;.3721 > S DIFLD=.3721,DGO="^DVBHCE27",DC="3^2.04P^.372^",DV=" > S DU="DIC(31," > G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY( > S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'=" > M15 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(15)=$P( > S X="""`"_$P(DVBDX(JP),U,2)_"""" > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > R15 D DE > G A > ; > 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) > X16 W "." S DVBJ2=1 > Q > 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) > X17 S Y="@46" > Q > 18 S DQ=19 ;@61 > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) > X19 I Z2'[1 S Y="@62" > Q > 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) > X20 I '$D(DVBSSA) S Y="@62",JP=JP+1 > Q > 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) > X21 I DVBSSA S DVBYN="Y",DVBXYN=DVBSSA > Q > 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) > X22 I 'DVBSSA S DVBYN="N",DVBXYN="" > Q > 23 S DW=".362;15",DV="SX",DU="",DLB="RECEIVING SOCIAL SE > S DE(DW)="C23^DVBHCE26" > S DU="Y:YES;N:NO;U:UNKNOWN;" > S X=DVBYN > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > C23 G C23S:$D(DE(23))[0 K DB > S X=DE(23),DIC=DIE > X ^DD(2,.36225,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT > C23S S X="" G:DG(DQ)=X C23F1 K DB > D ^DVBHCE28 > C23F1 Q > X23 S DFN=DA D MV^DGLOCK Q > Q > ; > 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) > X24 W "." S JP=JP+1,DVBJ2=1 K DVBYN,DVBXYN > Q > 25 S DQ=26 ;@62 > 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) > X26 I Z2'[2 S Y="@63" > Q > 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) > X27 I '$D(DVBRETT) S Y="@63",JP=JP+1 > Q > 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) > X28 I DVBRETT=""!("BMCROX"'[DVBRETT) S Y="@63",JP=JP+1 > Q > 29 D:$D(DG)>9 F^DIE17 G ^DVBHCE29 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE27.m ./VADemo/r2/r/DVBHCE27.m DVBHCE27 ; ;07/02/04 | DVBHCE27 ; ;02/04/03 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE, | DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU= I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,8) S:%]"" DE(7 | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;18",DV="SX",DU= | 1 S DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFL S DU="B:BLACK LUNG;M:MILITARY;C:CIVIL;R:RAILROAD;O:OT | S X=$S($P(DVBDX(JP),U,3)="X0":100,1:+$P(DVBDX(JP),U,3 S X=DVBRETT < X1 S DFN=DA D MV^DGLOCK Q | X1 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^D 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 | 2 S DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFL X2 W "." S JP=JP+1,DVBJ2=1 | S DU="0:NO;1:YES;" Q | S X=$P(DVBDX(JP),U,4) 3 S DQ=4 ;@63 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 I Z2'[3 S Y="@64" < Q < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 I '$D(DVBRETO) S Y="@64",JP=JP+1 < Q < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 S X=DVBRETO I X=""!(X=0) S X="@" < Q < 7 S DW=".362;8",DV="NJ8,2X",DU="",DLB="AMOUNT OF OTHER < S X=X < X7 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>99999)!(X<1) X | X2 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 | 3 G 1^DIE17 X8 W "." S JP=JP+1,DVBJ2=1 < Q < 9 S DQ=10 ;@64 < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 I Z2'[4 S Y="@1006" < Q < 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) < X11 I '$D(DVBOINC) S Y="@1006",JP=JP+1 < Q < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 S X=DVBOINC I X=""!(X=0) S X="@" < Q < 13 S DW=".362;9",DV="NJ8,2X",DU="",DLB="AMOUNT OF OTHER < S X=X < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < X13 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>999999)!(X<1) < Q < ; < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 W "." S JP=JP+1,DVBJ2=1,Y="@1006" < Q < 15 S DQ=16 ;@4 < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 S Y=$S(DVBJS=11:"@1",DVBJS=28:"@2",DVBJS=35:"@3",DVBJ < Q < 17 S DQ=18 ;@70 < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 W !!,*7,"HINQ contains SC disabilities, Patient is NS < Q < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 R !!,?25," to continue.",ZZ:DTIME K ZZ,JP3,JP4 < Q < 20 S DQ=21 ;@50 < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 K DVBJX,JP,JPP S Y=$S(DVBJS=28:"@1",DVBJS=35:"@2",1:" < Q < 22 S DQ=23 ;@10 < 23 G 0^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/DVBHCE28.m ./VADemo/r2/r/DVBHCE28.m DVBHCE28 ; ;07/02/04 | DVBHCE28 ; ;02/04/03 ;; | S X=DG(DQ),DIC=DIE 1 N X,X1,X2 S DIXR=303 D X1(U) K X2 M X2=X D X1("F") K | X ^DD(2,.36225,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT D < . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1 < . I '$$CVELIG^DGCV(DA) S X=1 < . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND < . D DELCV^DGCV(DA) < K X M X=X2 D < . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1 < . S X=$$CVELIG^DGCV(DA) < . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND < . D SETCV^DGCV(DA,X2(1)) < Q < X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.327,DION),$P($G(^DP < S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.5294,DION),$P($G(^D < S X(3)=$G(@DIEZTMP@("V",2,DIIENS,.322021,DION),$P($G( < S X(4)=$G(@DIEZTMP@("V",2,DIIENS,.322018,DION),$P($G( < S X(5)=$G(@DIEZTMP@("V",2,DIIENS,.322012,DION),$P($G( < S X(6)=$G(@DIEZTMP@("V",2,DIIENS,.5291,DION),$P($G(^D < S X(7)=$G(@DIEZTMP@("V",2,DIIENS,.322019,DION),$P($G( < S X(8)=$G(@DIEZTMP@("V",2,DIIENS,.322016,DION),$P($G( < S X(9)=$G(@DIEZTMP@("V",2,DIIENS,.32201,DION),$P($G(^ < S X=$G(X(1)) < Q < diff -y --suppress-common-lines ./VADemo/r1/DVBHCE2.m ./VADemo/r2/r/DVBHCE2.m DVBHCE2 ; ;07/02/04 | DVBHCE2 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE3.m ./VADemo/r2/r/DVBHCE3.m DVBHCE3 ; ;07/02/04 | DVBHCE3 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE4.m ./VADemo/r2/r/DVBHCE4.m DVBHCE4 ; ;07/02/04 | DVBHCE4 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE5.m ./VADemo/r2/r/DVBHCE5.m DVBHCE5 ; ;07/02/04 | DVBHCE5 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE6.m ./VADemo/r2/r/DVBHCE6.m DVBHCE6 ; ;07/02/04 | DVBHCE6 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE7.m ./VADemo/r2/r/DVBHCE7.m DVBHCE7 ; ;07/02/04 | DVBHCE7 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/DVBHCE8.m ./VADemo/r2/r/DVBHCE8.m DVBHCE8 ; ;07/02/04 | DVBHCE8 ; ;02/04/03 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VA | D:($T(AVAFC^VAFCDD01)'="") AVAFC^VAFCDD01(DA) diff -y --suppress-common-lines ./VADemo/r1/DVBHCE9.m ./VADemo/r2/r/DVBHCE9.m DVBHCE9 ; ;07/02/04 | DVBHCE9 ; ;02/04/03 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VA | D:($T(AVAFC^VAFCDD01)'="") AVAFC^VAFCDD01(DA) diff -y --suppress-common-lines ./VADemo/r1/DVBHCE.m ./VADemo/r2/r/DVBHCE.m DVBHCE ; GENERATED FROM 'DVBHINQ UPDATE' INPUT TEMPLATE(#960 | DVBHCE ; GENERATED FROM 'DVBHINQ UPDATE' INPUT TEMPLATE(#960 S DE(DW)="C21^DVBHCE",DE(DW,"INDEX")=1 | S DE(DW)="C21^DVBHCE" C21F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE) | C21F1 Q F DIXR=303 S DIEZRXR(2,DIXR)="" < Q < diff -y --suppress-common-lines ./VADemo/r1/DVBHCG.m ./VADemo/r2/r/DVBHCG.m DVBHCG ; GENERATED FROM 'DVBHINQ PAT-HINQ COMP' PRINT TEMPLA | DVBHCG ; GENERATED FROM 'DVBHINQ PAT-HINQ COMP' PRINT TEMPLA S X=$G(^DPT(D0,.372,D1,0)) D N:$X>35 Q:'DN W ?35 S Y | S X=$G(^DPT(D0,.372,D1,0)) D N:$X>35 Q:'DN W ?35 S Y D N:$X>33 Q:'DN W ?33 S Y=$P(X,U,5) S Y=$S(Y="":Y,$D | D N:$X>33 Q:'DN W ?33 S Y=$P(X,U,5) S Y=$S(Y="":Y,$D D N:$X>47 Q:'DN W ?47 S Y=$P(X,U,4) S Y=$S(Y="":Y,$D | D N:$X>47 Q:'DN W ?47 S Y=$P(X,U,4) S Y=$S(Y="":Y,$D D N:$X>33 Q:'DN W ?33 S Y=$P(X,U,10) S Y=$S(Y="":Y,$ | D N:$X>33 Q:'DN W ?33 S Y=$P(X,U,10) S Y=$S(Y="":Y,$ D N:$X>47 Q:'DN W ?47 S Y=$P(X,U,9) S Y=$S(Y="":Y,$D | D N:$X>47 Q:'DN W ?47 S Y=$P(X,U,9) S Y=$S(Y="":Y,$D D N:$X>33 Q:'DN W ?33 S Y=$P(X,U,15) S Y=$S(Y="":Y,$ | D N:$X>33 Q:'DN W ?33 S Y=$P(X,U,15) S Y=$S(Y="":Y,$ D N:$X>47 Q:'DN W ?47 S Y=$P(X,U,14) S Y=$S(Y="":Y,$ | D N:$X>47 Q:'DN W ?47 S Y=$P(X,U,14) S Y=$S(Y="":Y,$ diff -y --suppress-common-lines ./VADemo/r1/DVBHIQD.m ./VADemo/r2/r/DVBHIQD.m ;;4.0;HINQ;**21,52**;03/25/92 | ;;V4.0;HINQ;**21**;03/25/92 N I,I2,I3,I4,I5 < diff -y --suppress-common-lines ./VADemo/r1/DVBHQD1.m ./VADemo/r2/r/DVBHQD1.m ;;4.0;HINQ;**3,12,16,22,23,32,34,40,46**; 03/25/92 | ;;4.0;HINQ;**3,12,16,22,23,32,34,40**;03/25/92 EN S:$G(IO(0))="" IO(0)=$I S (C,DVBTSK,DVBABORT)=0,DVBXM | EN S (C,DVBTSK,DVBABORT)=0,DVBXM=1,DTIME=30 U IO(0) ASK S:$G(IO(0))="" IO(0)=$I W ! S Y=0,DVBIO=IO D @DVBPRGM | ASK W ! S Y=0,DVBIO=IO D @DVBPRGM S:$G(IO(0))="" IO(0)=$I S E=$L(DVBZ) I '$D(DVBDXX),($ | S E=$L(DVBZ) I '$D(DVBDXX),($E(DVBZ,E-7,E-4)'=DVBNUM) S:$G(IO(0))="" IO(0)=$I S Z1=$O(X(0)) F Q:$E(X(Z1))' | S Z1=$O(X(0)) F Q:$E(X(Z1))'=$C(10) S X(Z1)=$E(X(Z1 DCN S:$G(IO(0))="" IO(0)=$I U IO(0) W !,"..Name, SSN didn | DCN U IO(0) W !,"..Name, SSN didn't work ....retrying usi WRT S:$G(IO(0))="" IO(0)=$I S DVBJIO=IO(0) | WRT S DVBJIO=IO(0) WRT1 S:$G(DVBJIO)="" DVBJIO=$I S:'$D(DVBIOSL) DVBIOSL=IOSL | WRT1 S:'$D(DVBIOSL) DVBIOSL=IOSL S:'$D(DVBIOST) DVBIOST=IO diff -y --suppress-common-lines ./VADemo/r1/DVBHQD2.m ./VADemo/r2/r/DVBHQD2.m ;;4.0;HINQ;**22,33,34,43**;03/25/92 | ;;4.0;HINQ;**22,33,34**;03/25/92 SROLL Q:DVBIOST'["C-"!($D(DVBJDX)) U IO(0) W !,$C(7),"Pres | SROLL Q:DVBIOST'["C-"!($D(DVBJDX)) W !,$C(7),"Press Enter diff -y --suppress-common-lines ./VADemo/r1/DVBHQDE.m ./VADemo/r2/r/DVBHQDE.m ;;4.0;HINQ;**52**;03/25/92 | ;;V4.0;HINQ;;03/25/92 N I,I1,I2,I3,I4,I5 < diff -y --suppress-common-lines ./VADemo/r1/DVBHT1.m ./VADemo/r2/r/DVBHT1.m DVBHT1 ;ISC-ALBANY/PKE - HINQ alert parser ; 5/10/92 | DVBHT1 ;PKE/ISC-ALBANY; HINQ alert parser; 5/10/92 ;;4.0;HINQ;**12,15,20,43**;03/25/92 | ;;V4.0;HINQ;**12,15,20**;03/25/92 S (DVBDXNO,I)=0 F S I=$O(DVBDX(I)) Q:I="" S DVBDXNO < diff -y --suppress-common-lines ./VADemo/r1/DVBHT2.m ./VADemo/r2/r/DVBHT2.m DVBHT2 ;ISC-ALBANY/PKE - HINQ alert parser ; 5/10/92 ; 2/19/ | DVBHT2 ;PKE/ISC-ALBANY; HINQ alert parser; 5/10/92 ;;4.0;HINQ;**12,20,26,43**;03/25/92 | ;;V4.0;HINQ;**12,20,26**;03/25/92 .I $G(LAST)="" S LAST=Y Q | .I '$D(LAST) S LAST=Y Q .I $D(^DVB(395.5,DFN,1,LAST)),($P(^DVB(395.5,DFN,1,Y, | .I $P(^DVB(395.5,DFN,1,Y,0),"^",2)<$P(^DVB(395.5,DFN, Only in ./VADemo/r1/: EAS1043A.m Only in ./VADemo/r1/: EAS122PT.m Only in ./VADemo/r1/: EAS126.m Only in ./VADemo/r1/: EAS136P.m Only in ./VADemo/r1/: EAS150P1.m Only in ./VADemo/r1/: EAS155P1.m Only in ./VADemo/r1/: EAS155PT.m Only in ./VADemo/r1/: EAS1P53.m Only in ./VADemo/r1/: EAS25UEI.m diff -y --suppress-common-lines ./VADemo/r1/EASAILK1.m ./VADemo/r2/r/EASAILK1.m EASAILK1 ;ALB/BRM - Patient Address Inquiry ; 3/10/03 | EASAILK1 ;ALB/BRM - Patient Address Inquiry ; 11/14/02 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**13,29,39**;Mar | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**13**;Mar 15, 20 N PATNAM,IENS,ZTSAVE | N OK,PATNAM,POP,FLD,IENS,ARY,PATADDR,ERR,ARRAY S %ZIS="Q" | S %ZIS="Q" D ^%ZIS Q:POP S ZTSAVE("IENS")="",ZTSAVE("PATNAM")="" | D GETS^DIQ(2,IENS,".111:.12","E","PATADDR","ERR") D EN^XUTMDEVQ("QUE^EASAILK1","PATIENT ADDRESS INQUIRY | U IO Q < QUE ; < N OK,FLD,ARY,PATADDR,ERR,ARRAY < ; < D GETS^DIQ(2,IENS,".111:.121","E","PATADDR","ERR") < W !?2,"Bad Address Indicator: ",?26,$G(PATADDR(2,IENS < diff -y --suppress-common-lines ./VADemo/r1/EASEC100.m ./VADemo/r2/r/EASEC100.m EASEC100 ;ALB/BRM,LBD - Print 1010EC LTC Enrollment fo | EASEC100 ;ALB/BRM - Print 1010EC LTC Enrollment form ; ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,16,40,45**; | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,16**;Mar 15 N EAX,INSUR | S MDATA=$$GETWNR^IBCNSMM1 ; I $$INSUR^IBBAPI(EASDFN,,"RA",.EAX,"*") ; Retrieve al | I +MDATA D ; I $D(EAX) D | .F S EASINS=$O(^DPT(EASDFN,.312,EASINS)) Q:'EASINS . M INSUR=EAX("IBBAPI","INSUR") | ..S INSTMP=$G(^DPT(EASDFN,.312,EASINS,0)) . S EASINS=0 | ..Q:$P(INSTMP,"^")'=+MDATA . F S EASINS=$O(INSUR(EASINS)) Q:'EASINS D | ..I $P(INSTMP,"^",18)=$P(MDATA,"^",3) S MPA="YES",MPA . . Q:$P(INSUR(EASINS,1),U,2)'["MEDICARE (WNR)" ; Lo | ..I $P(INSTMP,"^",18)=$P(MDATA,"^",5) S MPB="YES",MPB . . I $P(INSUR(EASINS,8),U,2)="PART A" S MPA="YES",MP < . . I $P(INSUR(EASINS,8),U,2)="PART B" S MPB="YES",MP < N EASI,EASINS,X,Z,EASROOT2,EASINS,CNT,NUM,EASIN1I,GRP | N EASI,EASINS,X,Z,EASROOT2,EASINS,CNT,NUM,EASIN1I,GRP ; Set up array by defining "null" palce holders < ; < I $$INSUR^IBBAPI(EASDFN,"","ARB",.DGX,"*") ; Call Ins | F S EASI=$O(^DPT(EASDFN,.312,EASI)) Q:'EASI!(CNT>16) M INSUR=DGX("IBBAPI","INSUR") ; Reformat insurance ar | .S EASIN1I=EASI_","_EASDFN_"," F S EASI=$O(INSUR(EASI)) Q:'EASI!(CNT>16) D ; Prin | .D GETS^DIQ(2.312,EASIN1I,".01;.18;1;16;17;","IE","IN . S @EASROOT2@(CNT+3)=$G(INSUR(EASI,13)) ; SUBSCRIBER | .S @EASROOT2@(CNT+3)=$G(INSUR(2.312,EASIN1I,17,"E")) . S @EASROOT2@(CNT+4)=$P($G(INSUR(EASI,19)),U,2) ;rel | .S @EASROOT2@(CNT+4)=$G(INSUR(2.312,EASIN1I,16,"E")) . S @EASROOT2@(CNT+5)=$G(INSUR(EASI,14)) ;policy # (S | .S @EASROOT2@(CNT+5)=$G(INSUR(2.312,EASIN1I,1,"E")) . S @EASROOT2@(CNT+6)=$P($G(INSUR(EASI,8)),U,2) ; GRO | .S GRPIEN=$G(INSUR(2.312,EASIN1I,.18,"I")) ;group ie .; Set Insurance Company Information | .S:GRPIEN @EASROOT2@(CNT+6)=$$GET1^DIQ(355.3,GRPIEN_" . S @EASROOT2@(CNT)=$P($G(INSUR(EASI,1)),U,2) ; Insur | .S EASINS=$G(INSUR(2.312,EASIN1I,.01,"I")) ;pointer . S @EASROOT2@(CNT+2)=$G(INSUR(EASI,6)) ; ins. phone | .D INSDAT(EASINS,CNT) . S @EASROOT2@((CNT+1),.111)=$G(INSUR(EASI,2)) ; INS. < . S @EASROOT2@((CNT+1),.114)=$G(INSUR(EASI,3)) ; INS. < . S @EASROOT2@((CNT+1),.115)=$P($G(INSUR(EASI,4)),U,2 < . S @EASROOT2@((CNT+1),.116)=$G(INSUR(EASI,5)) ; INS. < F X=0:1:11 S @EASROOT3@(X)="" | F X=1:1:11 S @EASROOT3@(X)="" ;Marital Status added for LTC Phase IV (EAS*1*40) < S @EASROOT3@(0)=$$GET1^DIQ(2,EASDFN,".05","E") < S:$$GET1^DIQ(408.22,+$G(DGINR("V")),".17","I") @EASRO < N EASROOT4,EASROOT5,ASSETV,ASSETS,NUM,X,ASSETRT,IENS, | N EASROOT4,EASROOT5,ASSET ;Add subscripts to array to store assets for spouse ( | F I=1:1:4 S @EASROOT4@(I)="" ;10-10EC form). LTC Phase IV (EAS*1*40) | F I=1:1:5 S @EASROOT5@(I)="" F I=1:.5:4.5 S @EASROOT4@(I)="" | Q:'$G(DGINC("V")) F I=1:.5:5.5 S @EASROOT5@(I)="" | D GETS^DIQ(408.21,DGINC("V"),"2.01;2.02;2.06:2.09","I F X="V","S" Q:'$D(DGINC(X)) D | S @EASROOT4@(1)=+$G(ASSET(408.21,DGINC("V")_",",2.06, .D GETS^DIQ(408.21,+DGINC(X),"2.01;2.02;2.06:2.09","I | S @EASROOT4@(2)=+$G(ASSET(408.21,DGINC("V")_",",2.07, .S NUM=$S(X="V":1,1:1.5) | S @EASROOT4@(3)=+$G(ASSET(408.21,DGINC("V")_",",2.08, .S IENS=+DGINC(X)_"," | S @EASROOT4@(4)=@EASROOT4@(1)+@EASROOT4@(2)+@EASROOT4 .S ASSETRT="ASSET"_X_"(408.21,"_""""_IENS_""""_"," | S @EASROOT5@(1)=+$G(ASSET(408.21,DGINC("V")_",",2.01, .;Fixed Assets | S @EASROOT5@(2)=+$G(ASSET(408.21,DGINC("V")_",",2.02, .S @EASROOT4@(NUM)=+$G(@(ASSETRT_"2.06,""I"")")) ;Res | S @EASROOT5@(3)=+$G(ASSET(408.21,DGINC("V")_",",2.09, .S @EASROOT4@(NUM+1)=+$G(@(ASSETRT_"2.07,""I"")")) ;L | S @EASROOT5@(4)=@EASROOT5@(1)+@EASROOT5@(2)+@EASROOT5 .S @EASROOT4@(NUM+2)=+$G(@(ASSETRT_"2.08,""I"")")) ;V | S @EASROOT5@(5)=@EASROOT4@(4)+@EASROOT5@(4) ;Total A .;Liquid Assets < .S @EASROOT5@(NUM)=+$G(@(ASSETRT_"2.01,""I"")")) ;Cas < .S @EASROOT5@(NUM+1)=+$G(@(ASSETRT_"2.02,""I"")")) ;S < .S @EASROOT5@(NUM+2)=+$G(@(ASSETRT_"2.09,""I"")")) ;O < .;Subtotals < .F I=NUM:1:(NUM+2) S @EASROOT4@(NUM+3)=@EASROOT4@(NUM < S @EASROOT5@(5)=@EASROOT4@(4)+@EASROOT5@(4) ;Total A < S @EASROOT5@(5.5)=@EASROOT4@(4.5)+@EASROOT5@(4.5) ;T < diff -y --suppress-common-lines ./VADemo/r1/EASEC101.m ./VADemo/r2/r/EASEC101.m EASEC101 ;ALB/BRM,LBD - Print 1010EC LTC Enrollment Fo | EASEC101 ;ALB/BRM - Print 1010EC LTC Enrollment Form ; ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,40**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5**;Mar 15, 200 ;This section was modified to print Current Marital S < ;new 10-10EC form. Added for LTC Phase IV (EAS*1*40) < I $G(EAINFO("FORM")) D | W !,"9. Spouse's Name (Last,First,MI)" .W !,"9. Current Marital Status" | W !?3,@EAS3@(1),?131,$C(13) X EAINFO("L") .W ?55,"|9A. Spouse's Name (Last, First, MI)" | ; .W !?3,@EAS3@(0),?55,"|",?61,@EAS3@(1),?131,$C(13) X | W !,"9A. Spouse Residing in the Community?" .; | W ?90,"|9B. Spouse's Social Security Number" .W !,"9B. Spouse Residing in the Community?" | W !?4,@EAS3@(2),?90,"|",?95,@EAS3@(3),?131,$C(13) X E .W ?90,"|9C. Spouse's Social Security Number" < .W !?4,@EAS3@(2),?90,"|",?95,@EAS3@(3),?131,$C(13) X < ; < I '$G(EAINFO("FORM")) D < .W !,"9. Spouse's Name (Last,First,MI)" < .W !?3,@EAS3@(1),?131,$C(13) X EAINFO("L") < .; < .W !,"9A. Spouse Residing in the Community?" < .W ?90,"|9B. Spouse's Social Security Number" < .W !?4,@EAS3@(2),?90,"|",?95,@EAS3@(3),?131,$C(13) X < diff -y --suppress-common-lines ./VADemo/r1/EASEC103.m ./VADemo/r2/r/EASEC103.m EASEC103 ;ALB/BRM,LBD - Print 1010EC LTC Enrollment fo | EASEC103 ;ALB/BRM - Print 1010EC LTC Enrollment form ; ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,40**;Mar 15 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 N SECN | W !?42,"SECTION VII - CONSENT FOR ASSIGNMENT OF BENEF S SECN=$S($G(EAINFO("FORM")):"VIII",1:"VII") ;Added < W !?42,"SECTION ",SECN," - CONSENT FOR ASSIGNMENT OF < N I,WPLINE,EAS8,WPCNT,SECN | N I,WPLINE,EAS8,WPCNT S SECN=$S($G(EAINFO("FORM")):"IX",1:"VIII") ; Added | W !?39,"SECTION VIII - CONSENT AND AGREEMENT TO MAKE W !?39,"SECTION ",SECN," - CONSENT AND AGREEMENT TO M < Q:$G(EAINFO("FORM")) ;Added for LTC Phase IV (EAS*1* < diff -y --suppress-common-lines ./VADemo/r1/EASEC10E.m ./VADemo/r2/r/EASEC10E.m EASEC10E ;ALB/BRM,LBD - Print 1010EC LTC Enrollment fo | EASEC10E ;ALB/BRM - Print 1010EC LTC Enrollment form ; ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,40**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5**;Mar 15, 200 ; print pages 2 and 3 | ; print page 2 I $G(EAINFO("FORM")) D G ENQUIT | D PAGE2^EASEC102(.EALNE,.EAINFO,EASDFN) .; new 10-10EC format (LTC Phase IV - EAS*1*40) | ; print page 3 .D PAGE2^EASEC10R(.EALNE,.EAINFO,EASDFN) | D PAGE3^EASEC103(.EALNE,.EAINFO,EASDFN) .D PAGE3^EASEC10R(.EALNE,.EAINFO,EASDFN) < E D < .; old 10-10EC format < .D PAGE2^EASEC102(.EALNE,.EAINFO,EASDFN) < .D PAGE3^EASEC103(.EALNE,.EAINFO,EASDFN) < ;Line added to set new variable to indicate which ver < ;10-10EC form is to be printed. LTC Phase IV (EAS*1* < S EAINFO("FORM")=$$FORM^EASECU(EAINFO("DGMTIEN")) < ;Modified date printed on form if new 10-10EC format. | W !,"VA FORM 10-10EC DEC 2000",?40,"PRINTED: ",EAINFO ;Added for LTC Phase IV (EAS*1*40). < W !,"VA FORM 10-10EC DEC "_$S(EAINFO("FORM"):"2002",1 < Only in ./VADemo/r1/: EASEC10R.m diff -y --suppress-common-lines ./VADemo/r1/EASECA.m ./VADemo/r2/r/EASECA.m EASECA ;ALB/PHH,LBD - Add a New LTC Co-Pay Test ;10 AUG 2001 | EASECA ;ALB/PHH - Add a New LTC Co-Pay Test ;10 AUG 2001 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40**;Mar | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 I $G(DGMDOD) W !!,"Patient died on: ",$$FMTE^XLFDT(DG | I $G(DGMDOD) W !,"Patient died on: ",$$FMTE^XLFDT(DGM ; Is patient a veteran? Added for LTC III (EAS*1*34) < I $P($G(^DPT(DFN,"VET")),U)'="Y" W !!,"Patient is not < DT S %DT("A")="Date of LTC Copay Test: ",%DT="AEX",%DT(0 | DT S %DT("A")="DATE OF LTC COPAY TEST: ",%DT="AEX",%DT(0 I DGLD,DGMTDT'>DGLD W !?3,*7,"The date of test must b | ;I DGMTDT<3011001 W !?3,*7,"The date of test cannot b ; LTC III (EAS*1*34) - change to allow multiple tests | I DGLD,DGMTDTDG .S DIR(0)="Y",DIR("A")="Are you sure you want to add | .S DGTTYP="LTC COPAY " .;S DGTTYP="LTC COPAY " | .W !,$S($P($G(^DG(408.34,+$P($G(^DGMT(408.31,+DGLDT,0 .;W !,$S($P($G(^DG(408.34,+$P($G(^DGMT(408.31,+DGLDT, < ; | ; Is veteran exempt from LTC copayments? EXMPT ; Is veteran exempt from LTC copayments? | W !!,"... checking if veteran is exempt from LTC copa ; Is veteran exempt for reason other than low income? < ; LTC Phase IV (EAS*1*40) < W !! < S DIR("A")="Is veteran EXEMPT from LTC copayments",DI < S DIR("?",1)="Answer 'Yes' if the veteran is exempt f < S DIR("?",2)="for a reason other than low income.",DI < D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D DEL,Q G EN < I Y D D Q G EN < .; Get reason for exemption < .S DIR("A")="Reason for Exemption",DIR(0)="P^714.1:EM < .S DIR("S")="I $P(^(0),U,2),""^1^2^12^""'[(U_Y_U)" < .D ^DIR K DIR I 'Y!($D(DUOUT))!($D(DTOUT)) D D DEL Q < ..W !!,"A reason for exemption must be entered. LTC < .D EXMPT^EASECSCC(DFN,DGMTI,+Y) < W !!,?10,"Veteran is NOT EXEMPT from Long Term Care c | W !!,?10,"Veteran is NOT EXEMPT from Long Term Care c W !,?10,"on last year's income and must complete a 10 | W !,?10,"must complete a 10-10EC form." ; For LTC IV (EAS*1*40) - set 1010EC Form field (#2.1 | S DIC("DR")=".02////"_DFN_";.019////"_DGMTYPT_";.23// S DIC("DR")=".02////"_DFN_";.019////"_DGMTYPT_";.23// < diff -y --suppress-common-lines ./VADemo/r1/EASECCAL.m ./VADemo/r2/r/EASECCAL.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,19,34,39,40 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,19**;Mar 15 N COPAY,DAYS,MX,IPDR,OPDR,IPMAX,OPMAX,LST,DGMT,DGMTI, | N COPAY,DAYS,MX,IPDR,OPDR,IPMAX,OPMAX,LST,DGMT,DGMTI, N ERR,X1,X2,INC,EXP,AST,ALLOW,DGSP,SRIC < S DGEXR=$P($G(^DGMT(408.31,DGMTI,2)),U,7) < ; If LTC copay test is more than a year old and the v | ; If LTC copay test is more than a year old, quit ; not have an exemption for eligibility (Compensable | S X1=MNTH,X2=DGMTDT D ^%DTC I X>365 G Q ; before 11/30/99, quit (Added for LTC Phase III - E < ;S X1=MNTH,X2=DGMTDT D ^%DTC I X>365,"^1^4^"'[(U_DGEX < I DGSTA="EXEMPT" S COPAY=COPAY_DGEXR | I DGSTA="EXEMPT" S COPAY=COPAY_$P($G(^DGMT(408.31,DGM ; Does spouse reside in community? | ; Does spouse reside in community? Does spouse live S SRIC=$P(DGVIR0,U,16) | S SRIC=$P(DGVIR0,U,16),SLIV=$P(DGVIR0,U,15) N CCPY,OPCPY,IPCPY1,IPCPY2,TINC,TEXP,TAST,OVR180,IPRP < . S TINC=INC,TAST=AST,(OVR180,IPRPT)=1,CPYFLG=0 | . ; number of months to spend down assets . S EASADM=$$FMADD^XLFDT(MNTH,-LOS) | . S SD=(LOS-180)/30,SD=((SD+.5)\1)-1 . ; Get value of assets after spenddown is applied | . ; get month to start spend down . S TAST=$$ASSET^EASECPC1 | . S M=+$E(MNTH,4,5)-SD I M<1 F S M=12-M Q:M>0 . S CCPY=CCPY+TAST | . ; calculate asset spend down > . I SD>0 F I=1:1:SD D > . . S DAYS=$S("^4^6^9^11^"[("^"_M_"^"):30,M=2:28,1:31 > . . ;get total expenses + allowance > . . S TEXALL=TEXP+(20*DAYS*(1+SRIC)) > . . S IPMAX=IPDR*DAYS > . . I (INC-TEXALL)'>IPMAX S AST=AST-(IPMAX-(INC-TEXAL > . . S M=M+1 S:M=13 M=1 > . S CCPY=CCPY+AST > K CCPY,INC,ALLOW,EXP,AST,OPCPY,IPCPY1,IPCPY2,DGSP,M,S diff -y --suppress-common-lines ./VADemo/r1/EASECDD.m ./VADemo/r2/r/EASECDD.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40**;Mar | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 15 ; Interest, Dividend or Annuity (Original 10-10EC) | 15 ; Interest, Dividend or Annuity ; Net Income from Farm, Ranch or Business (Revised 10 | W !,?8,"Enter in this field the annual amount of Inte ; Display a different message for the revised 10-10E | W !,?8,"Income received during the current calendar y ; Modified for LTC IV (EAS*1*40) | W !,?8,"income, standard dividend income from non tax I $G(DGFORM) D < .W !,?8,"Enter in this field the annual amount of Net < .W !,?8,"the current calendar year from the operation < .W !,?8,"property or business." < I '$G(DGFORM) D < .W !,?8,"Enter in this field the annual amount of Int < .W !,?8,"Income received during the current calendar < .W !,?8,"income, standard dividend income from non ta < ; Display a different message for the revised 10-10E | W !,?8,"Enter in this field the annual amount of All ; Modified for LTC IV (EAS*1*40) | W !,?8,"received during the current calendar year (i. I $G(DGFORM) D | W !,?8,"tort settlement payments)." .W !,?8,"Enter in this field the annual amount of All < .W !,?8,"during the current calendar year, including < .W !,?8,"income, Social Security Retirement and Socia < .W !,?8,"income, compensation benefits such as unempl < .W !,?8,"Black Lung, or VA disability. Also cash gif < .W !,?8,"payments, inheritance amounts, tort settleme < .W !,?8,"and dividends, including tax exempt earnings < .W !,?8,"Individual Retirement Accounts (IRAs) or ann < I '$G(DGFORM) D < .W !,?8,"Enter in this field the annual amount of All < .W !,?8,"received during the current calendar year (i < .W !,?8,"tort settlement payments)." < W !,?8,"A monthly amount can be entered with an '*' a | W !,?8,"A monthly amount can be entered with an '*' a ; Modified wording for LTC Phase III (EAS*1*34) < W !,?8,"spouse or child, or pre-paid arrangements for | W !,?8,"spouse or child. Do not report amounts paid W !,?8,"Do not report amounts paid for funeral or bur | W !,?8,"burial expenses of other relatives such as pa W !,?8,"relatives such as parents, siblings, etc." < W !,?8,"A monthly amount can be entered with an '*' a | W !,?8,"A monthly amount can be entered with an '*' a W !,?8,"A monthly amount can be entered with an '*' a | W !,?8,"A monthly amount can be entered with an '*' a ; Display a different message for the revised 10-10E < ; Modified for LTC IV (EAS*1*40) < W !,?8,"annuities.",! | W !,?8,"annuities." ;If this is the revised 10-10EC form, also print the < I $G(DGFORM) G 202 < W !,?8,"annuities, self-employed person).",! | W !,?8,"annuities, self-employed person)." Only in ./VADemo/r1/: EASECDEL.m diff -y --suppress-common-lines ./VADemo/r1/EASECDP3.m ./VADemo/r2/r/EASECDP3.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,40**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5**;Mar 15, 200 . ;If this is the new 10-10EC format display Legally < . ;Added for LTC Phase IV (EAS*1*40) < .I $G(DGFORM) D Q:$P(INCPER,U,17)=1 < ..S DGX="",DGX=$$SETSTR^VALM1("Legally Separated: ",D < ..S DGX=$$SETSTR^VALM1($S($P(INCPER,U,17):"Yes",$P(IN < ..D SET^EASECDEP(DGX) < .Q:$P(INCPER,U,16)=0!($G(DGFORM)) | .Q:$P(INCPER,U,16)=0 diff -y --suppress-common-lines ./VADemo/r1/EASECE.m ./VADemo/r2/r/EASECE.m EASECE ;ALB/PHH,LBD - Edit an Existing LTC Co-Pay Test ;17 A | EASECE ;ALB/PHH - Edit an Existing LTC Co-Pay Test ;17 AUG 2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40**;Mar | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 ; If user holds DG MTDELETE security key, allow test | ;Is veteran exempt? ; LTC III (EAS*1*34) < I $D(^XUSEC("DG MTDELETE",+$G(DUZ))) D < .N DIR,DA,DR,DIE,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,DGNEWDT < .S DIR(0)="D^:DT:EX",DIR("A")="DATE OF TEST",DIR("B") < .S DIR("?")="Enter a date that is less than or equal < .S DIR("?",1)="Enter the date of the LTC Copay Test." < .D ^DIR K DIR Q:'Y!(Y=DGMTDT) S DGNEWDT=Y < .S DIR(0)="Y",DIR("A")="Are you sure you want to chan < .S DIE="^DGMT(408.31,",DA=DGMTI,DR=".01////"_DGNEWDT_ < .D ^DIE < ; < EXMPT ; Is veteran exempt? < ; Allow user to edit LTC copay test status or reason < ; If veteran is exempt for reason other than low inco < ; income check. Added for LTC Phase IV (EAS*1*40) < W ! S DGEFLG=1 D STA^EASECSCC K DGEFLG < I $G(DGSTA)="EXEMPT",$G(DGRE),"^2^12^"'[(U_DGRE_U) D < S DGNSTA=$G(DGSTA) < ; < ; Display message for vets who declined to provide in | W !! F I=1:1:80 W "=" ; LTC III (EAS*1*34) | W !!,?10,"Veteran is NOT EXEMPT from Long Term Care c I $P(DGMT0,U,14)=1 D | W !,?10,"must complete a 10-10EC form." .W !! F I=1:1:80 W "=" | W !! F I=1:1:80 W "=" .W !!,?10,"Veteran is NOT EXEMPT from Long Term Care < .W !,?10,"must complete a 10-10EC form." < .W !! F I=1:1:80 W "=" < K DGREF,DGSTA,DGCAT,DGINT,DGDET,DGNWT,I,DGFORM,DGMTS, | K DGREF,DGSTA,DGCAT,DGINT,DGDET,DGNWT Only in ./VADemo/r1/: EASECEXP.m diff -y --suppress-common-lines ./VADemo/r1/EASECPC1.m ./VADemo/r2/r/EASECPC1.m EASECPC1 ;ALB/LBD,CKN - LTC CoPayment Report continuat | EASECPC1 ;ALB/LBD,CKN - LTC Co-Payment Report continua ;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,24,40**;Mar 1 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**7,24**;Mar 15, ; This routine is a continuation of EASECPC. | ; This routine produces a calculated LTC Co-Payment f ; Input: DFN - Patient file IEN | EN ; ; DGMTI - LTC Copay Test IEN (file #408.31) | ; Print explanation of spend down page ; DGMTDT - LTC Copay Test Date | D HEADER^EASECPC,SPNDDWN ; MAXRT - Maximum daily copay rates for LTC ( < ; EASRPT - Report type: 1=Institutional (IP) < ; 2=Non-Institutional < ; EASRDT - Report start date < ; EASADM - LTC admission date (only if EASRPT < ; < START ; Generate Report < N ARRY,IPRPT,DGSP,SRIC,LSEP,DECINF,AGRPAY,ERR < I $G(ZTSK) S ZTREQ="@" < D INIT(EASRDT,.ARRY) < D BLDTBL(.ARRY) Q:$G(ERR) < D PRINT < Q < PRINT ; Print the Report < N CRT,PAGE,RPTDT,LINE,HDR,CALC1,CALC2,SIDX,EIDX,MNTH, < D PRTVAR < U IO < D HEADER < W !,$S(DGSP:"MARRIED",LSEP:"LEGALLY SEPARATED",1:"SIN < W:SRIC ?15,"SPOUSE RESIDING IN THE COMMUNITY" < I DECINF,AGRPAY W !,"*** DECLINED TO PROVIDE INCOME I < I AGRPAY=0 W !,"*** VETERAN IS INELIGIBLE FOR LTC SER < W !,"LTC COPAY TEST DATE: ",$$FMTE^XLFDT(DGMTDT) < W:$G(EASADM) ?47,"LTC ADMISSION DATE: ",$$FMTE^XLFDT( < W !!!,"LTC COPAYMENT CALCULATION"_$S(IPRPT:"S:",1:":" < W ! W:IPRPT "FOR DAYS 1-180 " W CALC1 < I IPRPT W !,"FOR DAYS 181+ " W CALC2 < ; < S SIDX=1,EIDX=6 < W !!," " < F MNTH=1:1:6 W $J($P(ARRY(MNTH),"^"),11) < I IPRPT D PRINTROW("TOT ASSETS ",SIDX,EIDX,9) < D PRINTROW("TOT INCOME ",SIDX,EIDX,3) < I 'IPRPT!($G(LOS)<181)!(DGSP&(SRIC)) D PRINTROW("TOT < D PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5) < W ! D PRINTROW("CALC COPAY ",SIDX,EIDX,6) < D PRINTROW("MAX COPAY ",SIDX,EIDX,7) < W !,LINE < D PRINTROW("VET COPAY ",SIDX,EIDX,8) < W !,LINE < ; < S SIDX=7,EIDX=12 < W !!," " < F MNTH=7:1:12 W $J($P(ARRY(MNTH),"^"),11) < I IPRPT D PRINTROW("TOT ASSETS ",SIDX,EIDX,9) < D PRINTROW("TOT INCOME ",SIDX,EIDX,3) < I 'IPRPT!(DGSP&(SRIC)) D PRINTROW("TOT EXPENSES ",SI < D PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5) < W ! D PRINTROW("CALC COPAY ",SIDX,EIDX,6) < D PRINTROW("MAX COPAY ",SIDX,EIDX,7) < W !,LINE < D PRINTROW("VET COPAY ",SIDX,EIDX,8) < W !,LINE < ; < I CRT Q:$$PAUSE(0) < D:CRT HEADER < D NOTETXT < I CRT Q:$$PAUSE(0) < I IPRPT D HEADER,SPNDDWN I CRT Q:$$PAUSE(0) < Q < PRINTROW(TEXT,SIDX,EIDX,NODE) ; Print the Rows < N MNTH < W !,TEXT < F MNTH=SIDX:1:EIDX W $J($S($P(ARRY(MNTH),"^",NODE)[". < Q < PRTVAR ; Set up variables needed to print report < N PAT0 < S CRT=$S($E(IOST,1,2)="C-":1,1:0) < S PAGE=0,RPTDT=$$FMTE^XLFDT(DT) < S LINE="",$P(LINE,"-",81)="" < S HDR=$$CJ^XLFSTR("LONG TERM CARE ESTIMATED COPAYMENT < S PAT0=$G(^DPT(DFN,0)),NAME=$P(PAT0,"^"),DOB=$P(PAT0, < S SSN=$P(PAT0,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_ < S CALC1="TOTAL INCOME - TOTAL EXPENSES - TOTAL ALLOWA < I DGSP,SRIC S CALC2="(TOTAL ASSETS + TOTAL INCOME) - < E S CALC2="(TOTAL ASSETS + TOTAL INCOME) - TOTAL ALL < S:$G(EASADM) LOS=$$FMDIFF^XLFDT(EASRDT,EASADM) < Q < HEADER ; Print the header < S PAGE=PAGE+1 < W @IOF < W RPTDT,?71,"Page: ",$J(PAGE,3) < W !!,HDR < W !!,NAME,?35,SSN,?62,"DOB: ",$$FMTE^XLFDT(DOB) < Q < PAUSE(RESP) ; Prompt user for next page or quit < N DIR,DIRUT,DUOUT,DTOUT,U,X,Y < S DIR(0)="E" < D ^DIR < I 'Y S RESP=1 < Q RESP < ; < INIT(DATE,ARRY) ; Initialize the Month/Year Table < N IDX,MNYR < S MNYR=$E(DATE,1,5)_"00" < F IDX=1:1:12 D < .S ARRY(IDX)=$$UP^XLFSTR($$FMTE^XLFDT(MNYR)) < .S ARRY(IDX)=$P(ARRY(IDX)," ")_"'"_$E($P(ARRY(IDX)," < .S $P(ARRY(IDX),"^",2)=MNYR < .S MNYR=MNYR+100 < .S:$E(MNYR,4,5)=13 MNYR=$E(MNYR,1,3)+1_"0100" < Q < BLDTBL(ARRY) ; Get the veteran's financial data, do the co < ; build the data table < ; < N DGDC,DGDEP,DGERR,DGFL,DGIN0,DGIN1,DGIN2,DGINI,DGIRI < N DGPRI,DGNC,DGND,DGNWTF,DGVINI,DGVIR0,DGVIRI,DGVPRI, < N OVR180,TAST,TINC,TEXP,ALLOW,CALCCPY,DAYS,MAXCPY,VET < ; < S ERR=0 < S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)) I 'DGPRI < D GETIENS^EASECU2(DFN,DGPRI,DGMTDT) I '$G(DGIRI),'$G( < S DGVIRI=DGIRI,DGVINI=DGINI < D DEP^EASECSU3,INC^EASECSU3 < S IPRPT=$S(EASRPT=1:1,1:0) < S CPYFLG=0 < S DECINF=$P($G(^DGMT(408.31,DGMTI,0)),"^",14) < S AGRPAY=$P($G(^DGMT(408.31,DGMTI,0)),"^",11) < I DECINF=1!(AGRPAY=0) S CPYFLG=1 < S SRIC=$P(DGVIR0,U,16),LSEP=$P(DGVIR0,U,17) < S OPDR=$P(MAXRT,U),IPDR=$P(MAXRT,U,2) < I IPRPT S LOS=$$FMDIFF^XLFDT(EASRDT,EASADM)+1 < ; < S OVR180=$S($G(LOS)>180:1,1:0) < S TINC=DGINT/12,TEXP=DGDET/12 < I OVR180,('DGSP!('SRIC)) S TEXP=0 < S TAST=DGNWT I OVR180 S TAST=$$ASSET < ; < ; Build data table < F IDX=1:1:12 D < .S DAYS=$$DOM($P(ARRY(IDX),"^",2)) < .D CALCALL < .S $P(ARRY(IDX),"^",3)=TINC < .S $P(ARRY(IDX),"^",4)=TEXP < .S $P(ARRY(IDX),"^",5)=ALLOW < .S $P(ARRY(IDX),"^",6)=CALCCPY < .S $P(ARRY(IDX),"^",7)=MAXCPY < .S $P(ARRY(IDX),"^",8)=VETMAX < .S $P(ARRY(IDX),"^",9)=$S(OVR180:TAST,1:"-") < .S:OVR180 TAST=$$ASTSPD < .I $G(LOS) D < ..S LOS=LOS+DAYS < ..S:'OVR180 OVR180=$S(LOS>180:1,1:0) < ..I OVR180,('DGSP!'(SRIC)) S:TEXP TEXP=0 < Q < ; < CALCALL ; Calculate the allowance and all the copayment amoun < S ALLOW=20*DAYS*(1+SRIC) S:CPYFLG ALLOW=0 < S CALCCPY=$$CALCCPY < S MAXCPY=$$CALCMAX(DAYS) < S VETMAX=$$VETMAX(CALCCPY,MAXCPY) < Q < ASSET() ; Initialize asset amount by applying spend-down < N NUM,MNYR,J,DONE,DAYS,ALLOW,CALCCPY,MAXCPY,VETMAX < S DONE=0 < ; Calculate number of months to spend down the assets < S NUM=(LOS-180)\30 < ; Get month to start spend down < S MNYR=$$FMADD^XLFDT(EASADM,180) < I NUM>0 F J=1:1:NUM D Q:DONE < .S DAYS=$$DOM(MNYR) < .D CALCALL < .S TAST=$$ASTSPD I TAST=0 S DONE=1 Q < .S MNYR=MNYR+100 S:$E(MNYR,4,5)=13 MNYR=$E(MNYR,1,3)+ < Q TAST < ASTSPD() ;Asset Spend down for 180+ days < Q:CPYFLG TAST < I (TINC-TEXP-ALLOW)'>VETMAX D < . I DGSP,SRIC S TAST=TAST-(VETMAX-(TINC-TEXP-ALLOW)) < . E S TAST=TAST-(VETMAX-(TINC-ALLOW)) < . S:TAST<0 TAST=0 < Q TAST < ; < CALCCPY() ; Calculate the Co-Pay Amount < ; < Q:CPYFLG 0 < Q:OVR180 TAST+TINC-ALLOW-TEXP < Q TINC-ALLOW-TEXP < DOM(MNYR) ; Days in Month < ; Returns: number of days in a month < N DAYS,MN,YR < S MN=+$E(MNYR,4,5) < I "^4^6^9^11^"[("^"_MN_"^") S DAYS=30 Q DAYS < I MN=2 D Q DAYS < .S DAYS=28 < .S YR=$E(MNYR,1,3)+1700 < .S:YR#4=0 DAYS=29 < S DAYS=31 < Q DAYS < CALCMAX(DAYS) ; Calculate the Maximum Co-Pay Amount < ; < Q $S(IPRPT:IPDR,1:OPDR)*DAYS < VETMAX(CALCCPY,MAXCPY) ; Calculate the Veteran Maximum Co-Pa < ; < Q:CPYFLG MAXCPY < Q:CALCCPY<0 0 < Q:CALCCPY .W !!,"This LTC Copay Test record contains an invalid > .W !,"DFN: ",DGMTI,!,"Test Status: ",LTCTS > Q 0 > MARIT() ; Define Marital Status > N DGPRI,DGVIRI,SRIC > S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)) > D GETIENS^EASECU2(DFN,DGPRI,DGMTDT) > S DGVIRI=DGIRI > D DEP^EASECSU3 > S SRIC=$P(DGVIR0,U,16) > Q DGSP_"^"_SRIC > QUEUE ; Get report device. Queue report if requested. > N MSG > S MSG(1)="" > S MSG(2)="This report may take a long time to generat > S MSG(3)="be queued to print." > S MSG(4)="" > D BMES^XPDUTL(.MSG) W ! < .S ZTRTN="START^EASECPC1" | .S ZTRTN="START^EASECPC" .S (ZTSAVE("DFN"),ZTSAVE("DGMTI"),ZTSAVE("DGMTDT"),ZT | .S (ZTSAVE("DFN"),ZTSAVE("DGMTI"),ZTSAVE("DGMTDT"),ZT .S (ZTSAVE("EASRPT"),ZTSAVE("EASRDT"))="",ZTSAVE("EAS | .S (ZTSAVE("MODE"),ZTSAVE("PAGE"),ZTSAVE("MARIT"),ZTS D START^EASECPC1,^%ZISC | D START,^%ZISC > Q > INITHDR ; Initialize the Report Header > N %,%H,%I,X,CDATE > D NOW^%DTC > S CDATE=X > S HDR(1)=$$FMTE^XLFDT(CDATE) > S HDR(2)="" > I MODE S HDR(3)=" LONG TERM CARE ESTIMATED COP > I 'MODE S HDR(3)=" LONG TERM CARE ESTIMATED COPA > S HDR(4)="" > S HDR(5)="" > Q > HEADER ; Print the header > N LTCIDX,PGHDR > S PAGE=$G(PAGE,0),PAGE=PAGE+1,PGHDR="Page: "_$J(PAGE, > W # > S LTCIDX="",LTCIDX=$O(HDR(LTCIDX)) > W HDR(LTCIDX),?71,PGHDR > F S LTCIDX=$O(HDR(LTCIDX)) Q:LTCIDX="" D > .W !,HDR(LTCIDX) > Q > START ; Generate Report > N CRT,HDR > S CRT=$S($E(IOST,1,2)="C-":1,1:0) > S MODE=1 U IO W ! D PRINT W ! ; Institutional > I CRT Q:$$PAUSE(0) > D:'CRT NOTETXT > S MODE=0 U IO W ! D PRINT W ! ; Non-institutional > I CRT Q:$$PAUSE(0) > D:'CRT NOTETXT > I CRT D Q:$$PAUSE(0) > .K HDR(3),HDR(4),HDR(5) > .D HEADER,NOTETXT > D EN^EASECPC1 > U 0 > I $G(ZTSK) S ZTREQ="@" > Q > PRINT ; Print the Report > N PAT0,NAME,SSN,DOB,ARRY,HDTEXT,IDX,SIDX,EIDX,MNTH,CP > D INITHDR > S PAT0=$G(^DPT(DFN,0)),NAME=$P(PAT0,"^"),SSN=$P(PAT0, > ; > D BLDTBL(DGMTDT,.ARRY) > D DETFIG(.ARRY) > S HDTEXT="TOTAL INCOME - TOTAL EXPENSES - TOTAL ALLOW > D HEADER > W NAME,?35,SSN,?62,"DOB: ",$$FMTE^XLFDT(DOB) > W !,$S(+MARIT:"MARRIED",1:"SINGLE") > I +MARIT,$P(MARIT,"^",2) W ?15,"SPOUSE RESIDING IN TH > I CPYFLG W !,"** DECLINED TO PROVIDE INCOME INFORMATI > W !,"LTC COPAY REPORT START DATE: ",$$FMTE^XLFDT(DGMT > W !!!,"LTC COPAYMENTS FOR DAYS 1-180",!,"COPAY CALC: > S SIDX=1,EIDX=6 > W ! D PRINTROW("TOT INCOME ",SIDX,EIDX,3) > D PRINTROW("TOT EXPENSES ",SIDX,EIDX,4) > D PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5) > W ! D PRINTROW("CALC COPAY ",SIDX,EIDX,6) > D PRINTROW("MAX COPAY ",SIDX,EIDX,7) > D PRINTROW("VET MAX COPAY ",SIDX,EIDX,8) > W !," " > F MNTH=1:1:6 W $J($P(ARRY(MNTH),"^"),11) > ; > I MODE,'+MARIT S HDTEXT="(TOTAL ASSETS + TOTAL INCOME > I MODE,+MARIT S HDTEXT="(TOTAL ASSETS + TOTAL INCOME) > W !!,"LTC COPAYMENTS FOR DAYS 181+" > W !,"COPAY CALC: ",HDTEXT,! > S SIDX=7,EIDX=12 > I MODE D PRINTROW("TOT ASSETS ",SIDX,EIDX,9) > D PRINTROW("TOT INCOME ",SIDX,EIDX,3) > I 'MODE!MARIT D PRINTROW("TOT EXPENSES ",SIDX,EIDX,4 > D PRINTROW("TOT ALLOWANCE ",SIDX,EIDX,5) > W ! D PRINTROW("CALC COPAY ",SIDX,EIDX,6) > D PRINTROW("MAX COPAY ",SIDX,EIDX,7) > D PRINTROW("VET MAX COPAY ",SIDX,EIDX,8) > W !," " > F MNTH=7:1:12 W $J($P(ARRY(MNTH),"^"),11) > Q > PRINTROW(TEXT,SIDX,EIDX,NODE) ; Print the Rows > N MNTH > W !,TEXT > F MNTH=SIDX:1:EIDX W $J($S($P(ARRY(MNTH),"^",NODE)[". > Q > PAUSE(RESP) ; Prompt user for next page or quit > N DIR,DIRUT,DUOUT,DTOUT,U,X,Y > S DIR(0)="E" > D ^DIR > I 'Y S RESP=1 > Q RESP > BLDTBL(DATE,ARRY) ; Build the Month/Year Table > N IDX,FMNYR > K ARRY > S DATE=$$FMTHL7^XLFDT(DGMTDT) > S FMNYR=$E(DATE,1,6)_"00" > F IDX=1:1:12 D > .S ARRY(IDX)=$$UP^XLFSTR($$FMTE^XLFDT($$HL7TFM^XLFDT( > .S ARRY(IDX)=$P(ARRY(IDX)," ")_"'"_$E($P(ARRY(IDX)," > .S $P(ARRY(IDX),"^",2)=$E(FMNYR,5,6) > .S FMNYR=$E(FMNYR,1,4)_$E(FMNYR,5,6)+1_"00" > .S:$E(FMNYR,5,6)=13 FMNYR=$E(FMNYR,1,4)+1_"0100" > Q > DETFIG(ARRY) ; Determine Figures > ; Variables: Marit: 0 = Single 1 = Marri > ; Mode: 0 = Out-Patient 1 = In-Pa > ; FLAG180: 0 = 180 or Less 1 = 181+ > ; SRIC: 0 = Not in Com. 1 = Resid > ; LWP: 0 = Not live w/ 1 = Livin > ; > N DGDC,DGDEP,DGERR,DGFL,DGIN0,DGIN1,DGIN2,DGDET,DGINT > N DGMTSC,DGNC,DGND,DGNWTF,DGSP,DGVINI,DGVIR0,DGVIRI,D > N IDX,INC,FLAG180,FXAST,LQAST,EXP,TAST,TINC,TEXP,DECI > N ALLOW,CALCCPY,DAYS,LWP,MAXCPY,SRIC,VETMAX,IPDR,OPDR > ; > D SETUP^EASECSCU,DEP^EASECSU3,INC^EASECSU3 > S CPYFLG=0 > S DECINF=$P($G(^DGMT(408.31,DGMTI,0)),"^",14) > S AGRPAY=$P($G(^DGMT(408.31,DGMTI,0)),"^",11) > I DECINF,AGRPAY S CPYFLG=1 > S SRIC=$P(MARIT,U,2) > S LWP=+$P(DGVIR0,U,15) > S INC=DGINT,EXP=DGDET > S OPDR=$P(MAXRT,U),IPDR=$P(MAXRT,U,2) > ; > F FLAG180=0,1 D > .I 'MODE S TAST=0 > .I MODE D > ..S TAST=$S(FLAG180:DGNWT,1:0) > ..I 'MARIT,FLAG180 S EXP=0 > .S TINC=INC/12,TEXP=EXP/12 > .; > .; Build both tables: 1-180 days and 181+ days > .F IDX=$S(FLAG180:7,1:1):1:$S(FLAG180:12,1:6) D > ..S DAYS=$$DOM($P(ARRY(IDX),"^",2)) > ..S ALLOW=20*DAYS*(1+SRIC) S:CPYFLG ALLOW=0 > ..S CALCCPY=$$CALCCPY > ..S MAXCPY=$$CALCMAX(DAYS) > ..S VETMAX=$$VETMAX(CALCCPY,MAXCPY) > ..S $P(ARRY(IDX),"^",3)=TINC > ..S $P(ARRY(IDX),"^",4)=TEXP > ..S $P(ARRY(IDX),"^",5)=ALLOW > ..S $P(ARRY(IDX),"^",6)=CALCCPY > ..S $P(ARRY(IDX),"^",7)=MAXCPY > ..S $P(ARRY(IDX),"^",8)=VETMAX > ..S:FLAG180 $P(ARRY(IDX),"^",9)=TAST > ..I FLAG180,MODE S TAST=$$ASTSPD > Q > ; > ASTSPD() ;Asset Spend down for 180+ days > Q:CPYFLG TAST > I (TINC-TEXP-ALLOW)'>VETMAX D > . I MARIT S TAST=TAST-(VETMAX-(TINC-TEXP-ALLOW)) > . I 'MARIT S TAST=TAST-(VETMAX-(TINC-ALLOW)) > . S:TAST<0 TAST=0 > Q TAST > ; > CALCCPY() ; Calculate the Co-Pay Amount > ; > Q:CPYFLG 0 > Q TAST+TINC-ALLOW-TEXP > DOM(MNTH) ; Days in Month > ; Returns: number of days in a month > N DAYS,HL7DATE > I "04060911"[MNTH S DAYS=30 Q DAYS > I MNTH="02" D Q DAYS > .S DAYS=28 > .S HL7DATE=$$FMTHL7^XLFDT(DGMTDT) > .S:$E(HL7DATE,1,4)#4=0 DAYS=29 > S DAYS=31 > Q DAYS > CALCMAX(DAYS) ; Calculate the Maximum Co-Pay Amount > ; > Q $S(MODE:IPDR,1:OPDR)*DAYS > VETMAX(CALCCPY,MAXCPY) ; Calculate the Veteran Maximum Co-Pa > ; > Q:CPYFLG MAXCPY > Q:CALCCPY<0 0 > Q:CALCCPY Q MAXCPY > NOTETXT ; Write the Note message > W !!,"IMPORTANT NOTICE: The copayment amounts shown i > W " estimates",!,"based on calculations of the copaym > W "an entire month. The",!,"copayment amounts will be > W "reflect the actual start date of LTC",!,"services > W "copayment exemption for the first 21 days of servi > W "MAX COPAY amount is based on the assumption that t > W "will be",!,"responsible to pay the lesser of EITHE > W " copayment (CALC COPAY) OR",!,"the maximum copayme > W "In the event that the calculated copayment",!,"(CA > W "negative figure, the veteran maximum copayment (VE > W "will be adjusted to zero (0). If the veteran decli > W " income",!,"information, the veteran will be oblig > W " maximum copayment." diff -y --suppress-common-lines ./VADemo/r1/EASECSC1.m ./VADemo/r2/r/EASECSC1.m EASECSC1 ;ALB/PHH,LBD - LTC Co-Pay Test Screen Militar | EASECSC1 ;ALB/PHH - LTC Co-Pay Test Screen Military Se ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,38**;Mar 15 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 S N DGRPSB S DGRPSB=+$P(DGRPX,U,DGRPSV+1) ;Service Bra | S W !?4,$S($D(^DIC(23,+$P(DGRPX,"^",DGRPSV+1),0)):$E($P W !?4,$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15 < W ?27,$S($P(DGRPX,"^",DGRPSV+4)]"":$P(DGRPX,"^",DGRPS < diff -y --suppress-common-lines ./VADemo/r1/EASECSC2.m ./VADemo/r2/r/EASECSC2.m EASECSC2 ;ALB/PHH,LBD - LTC Copay Test Screen Insuranc | EASECSC2 ;ALB/PHH - LTC Co-Pay Test Screen Eligibility ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,40,45**;Mar 1 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5**;Mar 15, 200 ; ** For LTC Phase IV (EAS*1*40) this routine has bee < ; display the patient's insurance information inst < ; eligibility < ; < D EASECRP5 | D EASECRP7 K DGRP,DGRPCM,DGRPLAST,DGRPNA,DGRPS,DGRPSCE1,DGRPTYPE < N DIR,DIRUT,DUOUT,DTOUT,I,X,Y | N DIR,DIRUT,DUOUT,DTOUT,U,X,Y F I=$Y:1:20 W ! < EASECRP5 ; Display the screen | EASECRP7 ; Display the screen ; Note: This section was copied from ^DGRP5 and modif | ; Note: This section was copied from ^DGRP7 and modif S DGRPW=1,(DGRPS,DGMTSCI)=2 D HD^EASECSCU S Z=1 D WW | N DGCASH,DGMBCK W ! D DISP^DGIBDSP | S (DGRPS,DGMTSCI)=2 D HD^EASECSCU F I=0,.29,.3,.31,.3 W ! S DGRPX=$G(^DPT(DFN,.38)),Z=2 D WW W " Eligible f | S (DGRPW,Z)=1 D WW W " Patient Type: " S DGR S Y=$P(DGRPX,"^",2) I Y X ^DD("DD") W " [last updat | W !?9,"Svc Connected: " S DGRPX=DGRP(.3),X=1,Z1=33,DG ;; *** Added for Medicaid information | .S X=$P(DGRPX,"^",2) W $S(X="":"UNANSWERED",1:+X_"%") W ! S Z=3 D WW W " Medicaid Number: ",$P(DGRPX,U,3) ; | .S X=$P(DGRP(.3),"^",1),DGNA=$S(X'="Y":1,1:0) > .W !?19,"P&T: " S X=4,Z1=31 D YN2 W "Unemployable: " > .W !?9,"SC Award Date: ",$$DATENP^DG1010P0(DGRPX,12) > W !?9,"Rated Incomp.: " S X=$$YN2^DG1010P0(DGRP(.29), > .W " Date (CIVIL): ",$$DATENP^DG1010P0(DGRP(.29),2) > .W " Date (VA): ",$$DATENP^DG1010P0(DGRP(.29),1) > S DGRPX=DGRP(.31) W !?10,"Claim Number: ",$S($P(DGRPX > S Z=2 D WW ;monetary benefits section > W " Aid & Attendance: " S Z=$$YN2^DG1010P0(DGRP( > W "Housebound: ",$$YN2^DG1010P0(DGRP(.362),13) D MBCK > W !?12,"VA Pension: " S Z=$$YN2^DG1010P0(DGRP(.362),1 > W "VA Disability: ",$$YN2^DG1010P0(DGRP(.3),11) D MBC > W !?4,"Total Check Amount: " S X=$$DISP^DG1010P0(DGRP > W !?10,"GI Insurance: " S Z=$$YN2^DG1010P0(DGRP(.362) > W "Amount: " S X=$$DISP^DG1010P0(DGRP(.362),6) W $S(X > S Z=3 D WW S DGRPE=+DGRP(.36),Z=$S($D(^DIC(8,+DGRPE,0 > W " Primary Elig Code: ",Z D AAC1^DGLOCK2 I DGAAC > W !?4,"Other Elig Code(s): " S I1="" F I=0:0 S I=$O(^ > W:'I1 "NO ADDITIONAL ELIGIBILITIES IDENTIFIED" > S DGRPX=+$P(DGRP(.32),"^",3) W !?5,"Period of Service > D ^DGYZODS G:'DGODS CONT S DGRPX=$S($D(^DPT(DFN,"ODS" > W !?18,"Rank: ",$S($D(^DIC(25002.1,+$P(DGRPX,"^",3),0 > CONT ;print sc disabilities (per patient) > W ! S Z=4 D WW W " Service Connected Conditions as > W !?4 S I3=0 F I=0:0 S I=$O(^DPT(DFN,.373,I)) Q:'I S > W:'I3 ?4,"NONE STATED" > Q K DGAAC,DGNA,DGODS,DGRP,DGRPE,DGRPX,I,I1,I2,I3,X,X1,Z > Q > YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N": > Q > YN2 S Z=$S(DGNA:"N/A",$P(DGRPX,"^",X)="Y":"YES",$P(DGRPX, > Q > MBCK ;flag for any MB Y/N fields = yes > S DGMBCK=$S($G(DGMBCK):1,(X="Y"):1,1:0) IN Q ; < ; < diff -y --suppress-common-lines ./VADemo/r1/EASECSC4.m ./VADemo/r2/r/EASECSC4.m EASECSC4 ;ALB/PHH,LBD - LTC Co-Pay Test Screen Assets | EASECSC4 ;ALB/PHH - LTC Co-Pay Test Screen Assets ;10 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,40**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5**;Mar 15, 200 ; DGFORM 10-10EC Format (1=Revised; 0=Ori < S DGRNG=$S($G(DGFORM):"1-5",1:"1-6") G EN^EASECSCR | S DGRNG="1-6" G EN^EASECSCR ; Revised 10-10EC form uses separate columns for vete | W !?39,"Veteran" W:DGSP " and Spouse" W ?73,"Total" ; added for LTC Phase IV (EAS*1*40) < I $G(DGFORM) W !?39,"Veteran" W:DGSP ?56,"Spouse" W ? < E W !?39,"Veteran" W:DGSP " and Spouse" W ?73,"Total < ; Revised 10-10EC format, added for LTC IV (EAS*1*40) | D HIGH^DGMTSCU1(4,DGMTACT),FLD(.DGIN2,1,"Cash") I $G(DGFORM) D | D HIGH^DGMTSCU1(5,DGMTACT),FLD(.DGIN2,2,"Stocks, Bond .D HIGH^DGMTSCU1(4,DGMTACT),FLD(.DGIN2,1,"Cash, Stock | D HIGH^DGMTSCU1(6,DGMTACT),FLD(.DGIN2,9,"Other Liquid .D HIGH^DGMTSCU1(5,DGMTACT),FLD(.DGIN2,9,"Other Liqui < ; Original 10-10EC format < I '$G(DGFORM) D < .D HIGH^DGMTSCU1(4,DGMTACT),FLD(.DGIN2,1,"Cash") < .D HIGH^DGMTSCU1(5,DGMTACT),FLD(.DGIN2,2,"Stocks, Bon < .D HIGH^DGMTSCU1(6,DGMTACT),FLD(.DGIN2,9,"Other Liqui < ; Display spouse amount if married (only applies to n | W " " ; Added for LTC Phase IV (EAS*1*40) | W " ",$S($D(DGIN("D")):$J($$AMT^DGMTSCU1($P(DGIN("D") W " ",$S($D(DGIN("S"))&($G(DGFORM)):$J($$AMT^DGMTSCU1 < W " " < ; If this is the new 10-10EC form use the template [E | S DA=DGINI,DIE="^DGMT(408.21,",DR="[EASEC ENTER/EDIT ; ASSETS NEW]. Added for LTC IV (EAS*1*40). < S DA=DGINI,DIE="^DGMT(408.21,",DR="[EASEC ENTER/EDIT < D ^DIE S:'$D(DGFIN) DGMTOUT=1 < diff -y --suppress-common-lines ./VADemo/r1/EASECSC5.m ./VADemo/r2/r/EASECSC5.m EASECSC5 ;ALB/PHH,LBD - LTC Co-Pay Test Screen Income | EASECSC5 ;ALB/PHH - LTC Co-Pay Test Screen Income ;13 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,40**;Mar 15 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 ; DGFORM 10-10EC Format (1=Revised; 0=Ori < S DGRNG=$S($G(DGFORM):"1-3",1:"1-14") G EN^EASECSCR | S DGRNG="1-14" G EN^EASECSCR ; Revised 10-10EC format, added for LTC IV (EAS*1*40) | D HIGH^DGMTSCU1(1,DGMTACT),FLD(.DGIN0,14,"Current Inc I $G(DGFORM) D | D HIGH^DGMTSCU1(2,DGMTACT),FLD(.DGIN0,8,"Soc. Sec. Re .D HIGH^DGMTSCU1(1,DGMTACT),FLD(.DGIN0,14,"Current Em | D HIGH^DGMTSCU1(3,DGMTACT),FLD(.DGIN0,15,"Interest/Di .D HIGH^DGMTSCU1(2,DGMTACT),FLD(.DGIN0,15,"Income fro | D HIGH^DGMTSCU1(4,DGMTACT),FLD(.DGIN0,6,"Retirement/P .D HIGH^DGMTSCU1(3,DGMTACT),FLD(.DGIN0,17,"All Other | D HIGH^DGMTSCU1(5,DGMTACT),FLD(.DGIN0,9,"Civil Servic ; Original 10-10EC format | D HIGH^DGMTSCU1(6,DGMTACT),FLD(.DGIN0,10,"U.S. Railro I '$G(DGFORM) D | D HIGH^DGMTSCU1(7,DGMTACT),FLD(.DGIN0,7,"VA Pension") .D HIGH^DGMTSCU1(1,DGMTACT),FLD(.DGIN0,14,"Current In | D HIGH^DGMTSCU1(8,DGMTACT),FLD(.DGIN0,19,"Spouse VA D .D HIGH^DGMTSCU1(2,DGMTACT),FLD(.DGIN0,8,"Soc. Sec. R | D HIGH^DGMTSCU1(9,DGMTACT),FLD(.DGIN0,12,"Unemploymen .D HIGH^DGMTSCU1(3,DGMTACT),FLD(.DGIN0,15,"Interest/D | D HIGH^DGMTSCU1(10,DGMTACT),FLD(.DGIN0,16,"Other Comp .D HIGH^DGMTSCU1(4,DGMTACT),FLD(.DGIN0,6,"Retirement/ | D HIGH^DGMTSCU1(11,DGMTACT),FLD(.DGIN0,11,"Military R .D HIGH^DGMTSCU1(5,DGMTACT),FLD(.DGIN0,9,"Civil Servi | D HIGH^DGMTSCU1(12,DGMTACT),FLD(.DGIN0,13,"Other Reti .D HIGH^DGMTSCU1(6,DGMTACT),FLD(.DGIN0,10,"U.S. Railr | D HIGH^DGMTSCU1(13,DGMTACT),FLD(.DGIN0,20,"Court Mand .D HIGH^DGMTSCU1(7,DGMTACT),FLD(.DGIN0,7,"VA Pension" | D HIGH^DGMTSCU1(14,DGMTACT),FLD(.DGIN0,17,"Other Inco .D HIGH^DGMTSCU1(8,DGMTACT),FLD(.DGIN0,19,"Spouse VA < .D HIGH^DGMTSCU1(9,DGMTACT),FLD(.DGIN0,12,"Unemployme < .D HIGH^DGMTSCU1(10,DGMTACT),FLD(.DGIN0,16,"Other Com < .D HIGH^DGMTSCU1(11,DGMTACT),FLD(.DGIN0,11,"Military < .D HIGH^DGMTSCU1(12,DGMTACT),FLD(.DGIN0,13,"Other Ret < .D HIGH^DGMTSCU1(13,DGMTACT),FLD(.DGIN0,20,"Court Man < .D HIGH^DGMTSCU1(14,DGMTACT),FLD(.DGIN0,17,"Other Inc < ; If this is the new 10-10EC form use the template [E | S DA=DGINI,DIE="^DGMT(408.21,",DR="[EASEC ENTER/EDIT ; INCOME NEW]. Added for LTC IV (EAS*1*40). < S DA=DGINI,DIE="^DGMT(408.21,",DR="[EASEC ENTER/EDIT < D ^DIE S:'$D(DGFIN) DGMTOUT=1 < diff -y --suppress-common-lines ./VADemo/r1/EASECSC6.m ./VADemo/r2/r/EASECSC6.m EASECSC6 ;ALB/PHH,LBD - LTC Co-Pay Test Screen Deducti | EASECSC6 ;ALB/PHH - LTC Co-Pay Test Screen Deductible ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34**;Mar 15 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 > ; If veteran is single w/ no dependents do not allow > I DGPCE=2,'$P(DGVIR0,U,8),'$P(DGVIR0,U,14) S AMT="N/A diff -y --suppress-common-lines ./VADemo/r1/EASECSCC.m ./VADemo/r2/r/EASECSCC.m EASECSCC ;ALB/LBD - LTC Co-Pay Test Screen Completion; | EASECSCC ;ALB/LBD - LTC Co-Pay Test Screen Completion; ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40**;Mar | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 ; If veteran's income is below the threshold then exe | ; If veteran's income is below the threshold then exe ; LTC III (EAS*1*34) modified to make vet with $0 | I DGINT,DGINT'>+$$THRES^IBARXEU1(DGMTDT,1,0) D G Q I DGINT'>+$$THRES^IBARXEU1(DGMTDT,1,0) D G Q < CHK ;Check if LTC copay test can be completed | CHK ;Check if LTC co-pay test can be completed ; For LTC III (EAS*1*34) removed check if expenses < S DGM=$P(DGVIR0,"^",14),DGL=$P(DGVIR0,"^",17),DGD=$P( | S DGM=$P(DGVIR0,"^",14),DGL=$P(DGVIR0,"^",15),DGD=$P( I DGM="" W !?3,"Marital section must be completed." S | I DGM']""!(DGM&(DGL']"")) W !?3,"Marital section must ; For LTC IV (EAS*1*40) added check for legally sepa | I DGM,'$D(DGREL("S")) W !?3,"Married is 'YES'. An ac I DGM,'DGL,'$D(DGREL("S")) W !?3,"Married is 'YES'. < > I DGDET>DGINT W !?3,"Patient's deductible expenses ca N DIR,Y,SCRN | N DIR,Y I DGSTA="EXEMPT",$G(DGNSTA)="NON-EXEMPT" S DGSTA="NON < S DIR("A")="Reason for Exemption" | S DIR("A")="REASON FOR EXEMPTION" ; Screen the look-up on file #714.1. Exemption reaso | S DIR("S")="I $P(^(0),U,2)" ; will be screened out unless this is the call from t < ; (DGEFLG=1) and only reason 1 is screened out. < S SCRN="2^12^" S:$G(DGEFLG) SCRN="" < S DIR("S")="I $P(^(0),U,2),""^1^"_SCRN_"""'[(U_Y_U)" < S DATA(.14)=$S($D(DGREF):1,1:0) ;LTC III (EAS*1*3 < diff -y --suppress-common-lines ./VADemo/r1/EASECSCR.m ./VADemo/r2/r/EASECSCR.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,40**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5**;Mar 15, 200 ; Modified next line to allow entry of assets for spo | I DGMTACT'="VEW",DGMTSCI=5 D SEL I DGSEL[$E(DGX),$E(D ; 10-10EC form). Added for LTC Phase IV (EAS*1*40) < I DGMTACT'="VEW",(DGMTSCI=5!($G(DGFORM)&(DGMTSCI=4))) < ;Modified next line to add screen 4 for LTC Phase IV | I DGMTACT'="VEW",DGMTSCI=5,$D(DGSEL) W !,"To edit a s I DGMTACT'="VEW","^4^5^"[(U_DGMTSCI_U),$D(DGSEL) W !, < diff -y --suppress-common-lines ./VADemo/r1/EASECSCU.m ./VADemo/r2/r/EASECSCU.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,40**;Mar 15 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 ; DGFORM 10-10EC Form (1=Revised; < ; Set DGFORM to indicate which 10-10EC form was used < ; the LTC copay test. If DGFORM=1 the revised format < ; for the LTC copay test screens, otherwise the origi < ; used. Added for LTC IV (EAS*1*40). < S DGFORM=$$FORM^EASECU($G(DGMTI)) < N DGHDR,DGIOM,DGLNE,DGMTSCR,DGTAB,Y,IOINHI,IOINLOW | N DGHDR,DGIOM,DGLNE,DGMTSCR,DGTAB,Y ;;2;INSURANCE DATA;EN^EASECSC2;EN1^EASECSC2 | ;;2;ELIGIBILITY STATUS DATA;EN^EASECSC2;EN1^EASECSC2 diff -y --suppress-common-lines ./VADemo/r1/EASECSU3.m ./VADemo/r2/r/EASECSU3.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,40**;Mar 15 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 ; Added next line for LTC Phase IV (EAS*1*40) < S DGNWT=DGNWT+$$TOT^DGMTSCU1(DGIN2("S"),1,4)+$$TOT^DG < ;If vet is legally separated, do not include spouse's | S DGSP=$S('$P(DGVIR0,"^",14):0,'$G(DGREL("S")):0,1:1) ;LTC Phase IV (EAS*1*40) < S DGSP=$S('$P(DGVIR0,U,14):0,$P(DGVIR0,U,17):0,'$G(DG < diff -y --suppress-common-lines ./VADemo/r1/EASECU23.m ./VADemo/r2/r/EASECU23.m EASECU23 ;ALB/PHH,LBD - Display LTC Co-Pay test inform | EASECU23 ;ALB/PHH - Display LTC Co-Pay test informatio ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34**;Mar 15 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,11)=1:"YES",$P(DGM | S X=$$SETSTR^VALM1($S($P(DGMTDIS,U,11)=1:"YES",$P(DGM diff -y --suppress-common-lines ./VADemo/r1/EASECU.m ./VADemo/r2/r/EASECU.m EASECU ;ALB/PHH,LBD - LTC Co-Pay Test Utilities ; 22 AUG 200 | EASECU ;ALB/PHH - LTC Co-Pay Test Utilities ; 22 AUG 2001 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40**;Mar | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7**;Mar 15, 2 ..S DGNOD=$G(^DGMT(408.31,DGMTI,0)) I DGNOD S DGMTFL1 | ..S DGNOD=$G(^DGMT(408.31,DGMTI,0)) I DGNOD S DGMTFL1 MTS(DGMTS) ;LTC Co-Pay test status -- default current | MTS(DFN,DGMTS) ;LTC Co-Pay test status -- default current ; Input -- DGMTS LTC Co-Pay Test Status IEN | ; Input -- DFN Patient IEN > ; DGMTS LTC Co-Pay Test Status IEN I $G(DGMTS) S Y=$P($G(^DG(408.32,DGMTS,0)),"^",1,2) | S DGMTS=$S($G(DGMTS)>0:DGMTS,1:$P($G(^DPT(DFN,0)),"^" > I DGMTS S Y=$P($G(^DG(408.32,DGMTS,0)),"^",1,2) ; < DIS(DFN) ;Display patient's current LTC Copay Test sta < ; Input -- DFN IEN of Patient file < ; Output -- None < N DGX,DGMTI,DGMTDT,DGMTS < Q:'$G(DFN) < S DGX=$$LST(DFN) Q:'DGX < S DGMTI=+DGX,DGMTDT=$P(DGX,U,2),DGMTS=$P(DGX,U,3) S:D < W !,"LTC Copayment Status: ",DGMTS," Last Test: " S < ; If last test is over a year old and patient is not < ; exempt due to eligibility (compensable SC) or LTC b < ; display message that a new test is required < I $$FMDIFF^XLFDT(DT,DGMTDT)>364 D < .I $P($G(^DPT(DFN,.35)),U) Q < .I "^1^4^"[(U_$P($G(^DGMT(408.31,DGMTI,2)),U,7)_U) Q < .W " **NEW TEST REQUIRED**" < I $P($G(^DGMT(408.31,DGMTI,0)),U,11)=0 W !,"Patient I < Q < ; < FORM(DGMTI) ; Return the version of the 10-10EC form used < ; the LTC Copay Test passed in DGMTI < ; Input: DGMTI - LTC Copay Test (IEN file #408.3 < ; Output: 0 = Original format < ; 1 = Revised format < I '$G(DGMTI) Q 0 < Q $P($G(^DGMT(408.31,DGMTI,2)),U,10) < diff -y --suppress-common-lines ./VADemo/r1/EASEZC1.m ./VADemo/r2/r/EASEZC1.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 ;display/file/print varies with version < S EASVRSN=$$VERSION^EASEZU4(EASAPP) ;alb/cmf/51 < > .Q:((ORIG="")&(UPD="")) .Q:((ORIG="")&(UPD="")) < .I 'LINK,$P(FFF,U,1)=2 S LINK=EASDFN < D C206^EASEZC3 ;alb/cmf/51 special for ethnicity mul < D C202^EASEZC3 ;alb/cmf/51 special for race multiple < .;special handling for field #.362 < .I ($P(MAP,U,1)=5)="I;14D3." D < ..I VDATA["IN LIEU OF VA COMP" S VDATA="YES" < ..I VDATA="YES, RECEIVING MILITARY RETIREMENT" S VDAT < diff -y --suppress-common-lines ./VADemo/r1/EASEZC2.m ./VADemo/r2/r/EASEZC2.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 S IENS=$G(INCREL(408,"S",1)) | S IENS=$G(INCREL(408,"S",1)) I IENS="" S IENS=$G(INCR N B,PERS,EZ,PT,TYPE,GRP,GRP1,MAP,M,MM,NSD,OUT,X,IEN,I | N B,PERS,EZ,PT,TYPE,GRP,MAP,M,MM,NSD,OUT,X,IEN,IENS,F ..I ($P(EZ,U,2,3)=$P(PT,U,2,3))!($$CMORE^EASEZC2(EZ,P | ..I ($P(EZ,U,2,3)=$P(PT,U,2,3))!($$CMORE(EZ,PT)) D ...S GRP1=GRP I EASVRSN>5.99,FILE=408.21,".08;.14;.17 < ...;I FILE=408.21 W !,FLD,?8,TYPE,?18,M,?21,VDATA ;in < ...S KEY=$O(^TMP("EZINDEX",$J,GRP1,FILE,SUBF,FLD,0)) | ...S KEY=0 F S KEY=$O(^TMP("EZINDEX",$J,GRP,FILE,SUB ....S MM=M I EASVRSN>5.99,FILE=408.21,".08;.14;.17"[F | ....S ^TMP("EZDATA",$J,KEY,M,2)=VDATA ....;I FILE=408.21 W !,"*",FLD,?8,TYPE,?18,MM,?21,VDA | ....S EASAEL=$P($G(^TMP("EZDATA",$J,KEY,M,1)),U,3) ....S ^TMP("EZDATA",$J,KEY,MM,2)=VDATA < ....S EASAEL=$P($G(^TMP("EZDATA",$J,KEY,MM,1)),U,3) < ....S ^TMP("EZDATA",$J,KEY,MM,2)=VDATA | ....S ^TMP("EZDATA",$J,KEY,M,2)=VDATA ....S EASAEL=$P($G(^TMP("EZDATA",$J,KEY,MM,1)),U,3) | ....S EASAEL=$P($G(^TMP("EZDATA",$J,KEY,M,1)),U,3) diff -y --suppress-common-lines ./VADemo/r1/EASEZC3.m ./VADemo/r2/r/EASEZC3.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**51**;Mar 15, 20 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 ..Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,0,EASVRSN) ;al < ; < C202 ;alb/cmf/51 place race info into local711 array < N M,B,VDATA,KEY,RAC < D GETS^DIQ(2,EASDFN_",","2*","","RAC") < Q:'$D(RAC) < D D202("APPLICANT RACE - AMERICAN INDIAN OR ALASKA NA < D D202("APPLICANT RACE - BLACK OR AFRICAN AMERICAN"," < D D202("APPLICANT RACE - HAWAIIAN OR PAC ISLANDER","N < D D202("APPLICANT RACE - ASIAN","ASIAN") < D D202("APPLICANT RACE - WHITE","WHITE") < D D202("APPLICANT RACE - UNANSWERED","UNKNO") < Q < ; < D202(AKEY,ARACE) ; < S KEY=+$$KEY711^EASEZU1(AKEY) < S M=0 F S M=$O(^TMP("EZDATA",$J,KEY,M)) Q:'M D < .S VDATA="" < .S B=$$Q202(ARACE) I +B S VDATA="YES"_$P(B,U,2) < .S $P(^TMP("EZDATA",$J,KEY,M,2),U,1)=VDATA < Q < ; < Q202(X) ; < N I,FLAG < S FLAG=0 < Q:'$D(RAC) FLAG < D:'$D(RAC("B")) < .S I="" < .F S I=$O(RAC(2.02,I)) Q:I="" D < ..S RAC("B",$E(RAC(2.02,I,.01),1,5))=$E(RAC(2.02,I,.0 < I $D(RAC("B",X)) S FLAG=1_U_" ("_RAC("B",X)_")" < ;S I="" < ;F S I=$O(RAC(2.02,I)) Q:(I="")!(+FLAG) D < ;.I $E(RAC(2.02,I,.01),1,5)=X S FLAG=1_U_" ("_$E(RAC( < Q FLAG < ; < C206 ;alb/cmf/51 place ethnicity info into local711 array < N X,M,B,VDATA,KEY,ETH < D GETS^DIQ(2,EASDFN_",","6*","","ETH") < Q:'$D(ETH) < S KEY=+$$KEY711^EASEZU1("APPLICANT SPANISH, HISPANIC, < S M=0 F S M=$O(^TMP("EZDATA",$J,KEY,M)) Q:'M D < .S VDATA="",B="" < .D S $P(^TMP("EZDATA",$J,KEY,M,2),U,1)=VDATA < ..S B=$$Q206("NOT") I +B S VDATA="NO"_$P(B,U,2) Q < ..S B=$$Q206("HIS") I +B S VDATA="YES"_$P(B,U,2) Q < ..S B=$$Q206("DEC") I +B S VDATA="DECLINED"_$P(B,U,2) < ..S B=$$Q206("UNK") I +B S VDATA="UNKNOWN"_$P(B,U,2) < ..Q < .Q < Q < ; < Q206(X) ; < N I,FLAG < S FLAG=0 < Q:'$D(ETH) FLAG < D:'$D(ETH("B")) < .S I="" < .F S I=$O(ETH(2.06,I)) Q:I="" D < ..S ETH("B",$E(ETH(2.06,I,.01),1,3))=$E(ETH(2.06,I,.0 < I $D(ETH("B",X)) S FLAG=1_U_" ("_ETH("B",X)_")" < ;S I="" < ;F S I=$O(ETH(2.06,I)) Q:(I="")!(+FLAG) D < ;.I $E(ETH(2.06,I,.01),1,3)=X S FLAG=1_U_" ("_$E(ETH( < Q FLAG < ; < diff -y --suppress-common-lines ./VADemo/r1/EASEZF1.m ./VADemo/r2/r/EASEZF1.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 F2(EASAPP,EASDFN) ;file to Patient record in #2 | F2(EASDFN) ;file to Patient record in #2 N KEYIEN,FILE,SUBFILE,FLD,DATAKEY,MULTIPLE,SECT,QUES, | N KEYIEN,FILE,SUBFILE,FLD,DATAKEY,MULTIPLE,SECT,QUES, N DIC,DIQ,DA,DR,X,Y < I '$G(EASVRSN) S EASVRSN=$$VERSION^EASEZU4(EASAPP) < .;call to suppress may be redundant < .Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,EASVRSN) < .Q:'SUBIEN < .;special handling for Designee < .I FLD=.3405 S EZDATA=$S(EZDATA="NEXT OF KIN":"YES",1 < > .Q:EZDATA=PTDATA > .;can't continue w/o ien to subfile #712.01 > .Q:'SUBIEN .I SUBFILE=2.02 D F202^EASEZF1(SUBFILE,DATAKEY,EZDATA < .I SUBFILE=2.06 D F206^EASEZF1(SUBFILE,DATAKEY,EZDATA < .;special for fields #.092 & #.093 < .I FILE=2,((FLD=.092)!(FLD=.093)) D FPOB(DATAKEY,EZDA < .;special for field #.362 < .I FILE=2,FLD=.362,EASVRSN>5.99 I (EZDATA="Y")!(EZDAT < .Q:EZDATA=PTDATA < .;repeat check for verified eligibility; < .;do not file certain fields if eligibility verified < .K ARRAY < .S DA=EASDFN,DIC="^DPT(",DR=".3611;.3613",DIQ(0)="I", < .D EN^DIQ1 K DA,DIC,DIQ,DR < .I $G(ARRAY(2,EASDFN,.3611,"I"))="V",$G(ARRAY(2,EASDF < .I FLD=.313,$G(ARRAY(2,EASDFN,.3611,"I"))="V" Q < .I $G(ELIGVER),((FLD=.301)!(FLD=.302)!(FLD=.36235)) Q < .I $D(ERR) D ERROR^EASEZF2("AP",MULTIPLE,.ERR,"LINK") < ; < F202(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) ;add or edit < ;input SUBFILE = 2.02 < ; DATAKEY = data item identifier, e.g., I;4B. < ; EZDATA = in these cases, either "N(o)" or "Y( < ; SUBIEN = subrecord # for data in #712/#10 < ; KEYIEN = record # for data element in #711 < N X,N,DATANM,EROOT,EAS,EIEN,ERR,FLD,IENS,EASARRAY,LIN < Q:EZDATA'["Y" < Q:SUBFILE'=2.02 < ;covert data to corresponding file #10 pointer < S X=$$KEY711^EASEZU1(DATAKEY) < S K1=$P(X,U,1),DATANM=$P(X,U,2),K3=$P(X,U,3) < Q:(DATANM="") < Q:(K1'=KEYIEN) < Q:(K3'=DATAKEY) < S DATANM=$P(DATANM," - ",2),DATANM=$E(DATANM,1,30) < I DATANM["UNANSWERED" S DATANM="UNKNOWN BY PATIENT" < S EZDATA=$O(^DIC(10,"B",DATANM,0)) < Q:EZDATA="" < D I202^EASEZI(EASDFN,.EASARRAY) < ;if matching race already exists, edit method only < S OUT=0,N=0 F S N=$O(EASARRAY(N)) Q:'N D < .Q:($P(EASARRAY(N),";",2)'=EZDATA) < .K EAS,ERR < .S IENS=EZDATA_","_EASDFN_"," < .S EROOT="EAS("_EASAPP_")" < .S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)=1 < .D FILE^DIE("S",EROOT,"ERR") < .S OUT=1 < ;no matching race in patient record, add new subrecor < I 'OUT D < .K ERR < .S EROOT="EAS("_EASAPP_")" < .S IENS="+1,"_EASDFN_",",EIEN(1)=EZDATA < .S FLD=.01,EAS(EASAPP,SUBFILE,IENS,FLD)=EZDATA < .S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)=1 < .D UPDATE^DIE("S",EROOT,"EIEN","ERR") < .I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q < .S LINK=EASDFN_";"_EZDATA < .S ^EAS(712,EASAPP,10,SUBIEN,2)=U_LINK < Q < ; < F206(SUBFILE,DATAKEY,EZDATA,SUBIEN) ;add subrecord in sub < ;input SUBFILE = 2.06 < ; DATAKEY = data item identifier, e.g., I;4A. < ; EZDATA = in these cases, either "N(o)" or "Y( < N X,EROOT,EAS,EIEN,ERR,FLD,EASARRAY,IENS,LINK,PTDATA < Q:SUBFILE'=2.06 < D I206^EASEZI(EASDFN,.EASARRAY) < S LINK=$P($G(EASARRAY(1)),";",2),PTDATA="" I LINK S P < I DATAKEY="I;4A." S EZDATA=$S(EZDATA["Y":"H",$E(EZDAT < .S EROOT="EAS("_EASAPP_")" < .S IENS="+1,"_EASDFN_"," < .S FLD=.01,EAS(EASAPP,SUBFILE,IENS,FLD)=EZDATA < .S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)="SELF IDENTIF < .D UPDATE^DIE("ES",EROOT,"EIEN","ERR") < .S LINK=EASDFN_";"_$G(EIEN(1)) < .S ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK < Q < ; < FPOB(DATAKEY,EZDATA,SUBIEN,PTDATA) ;add or edit pob city < ;input DATAKEY = data item identifier, either, I;8A. < ; EZDATA = free text if city or < ; state abbrv if state < ;filing for both city & state only done when datakey= < N X,EROOT,EAS,EIEN,ERR,FLD,EASARRAY,IENS,LINK,SECT,QU < Q:(DATAKEY'="I;8A.") < Q:(EZDATA="") < Q:(EZDATA=PTDATA) < ;file pob city < K EAS,ERR < S FLD=.092,LINK=EASDFN < S IENS=EASDFN_"," < S EROOT="EAS("_EASAPP_")" < D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR") < I $D(ERR) D RESOLVE < I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q < D FILE^DIE("ES",EROOT,"ERR") < ;set any replaced data into subfile #712.01 for audit < S ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK < ;file pob state < S (EZDATA,XDATA)="" < S DATAKEY="I;8B.",SECT=$P(DATAKEY,";",1),QUES=$P(DATA < S X=$G(^TMP("EZTEMP",$J,SECT,1,QUES)),EZDATA=$P(X,U,2 < Q:(EZDATA="") < Q:(EZDATA=XDATA) < I (EZDATA["FOREIGN")!(EZDATA="FC")!(EZDATA="FG") S EZ < K EAS,ERR < S FLD=.093 < S IENS=EASDFN_"," < S EROOT="EAS("_EASAPP_")" < D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR") < I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q < D FILE^DIE("ES",EROOT,"ERR") < S ^EAS(712,EASAPP,10,XIEN,2)=XDATA_U_LINK < Q < diff -y --suppress-common-lines ./VADemo/r1/EASEZF2.m ./VADemo/r2/r/EASEZF2.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9,51**;Mar 15 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9**;Mar 15, 2 N DFN,DGPR12,INCYR,TESTYR,LASTINC,XLINK,EROOT,EAS,ERR | N DGPR12,INCYR,TESTYR,LASTINC,XLINK,EROOT,EAS,ERR,IEN Q:($E(TESTYR,1,3)=$E(DT,1,3))&($P(LASTINC,U,5)>1) | Q:($E(TESTYR,1,3)=$E(DT,1,3)) .;S KEY=+$$KEY711^EASEZU1("APPLICANT DATE OF BIRTH") | .S KEY=+$$KEY711^EASEZU1("APPLICANT DATE OF BIRTH") .;S DOB=$P($$DATA712^EASEZU1(EASAPP,KEY,1),U,1) | .S DOB=$P($$DATA712^EASEZU1(EASAPP,KEY,1),U,1) .;use DOB from file #2 < .S X=$P($G(^DPT(EASDFN,0)),U,3),%DT="PX" D ^%DT S DOB < ...S DATAKEY=SECT_";"_QUES < ...;call to suppress may be redundant < ...Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,EASVRSN) < ...I (SECT="IIF")!(SECT="IIG") S MM=MULTIPLE < I $P($G(SP(1,408.22,408.22,.1)),U,1) D | S MM=0 F S MM=$O(CN(MM)) Q:'MM I $D(CN(MM,408.13,40 .I $P($G(SP(1,408.22,408.22,.1)),U,1)>599 S SP(1,408. < S MM=0 F S MM=$O(CN(MM)) Q:'MM D < .I $D(CN(MM,408.13,408.13,.01))'=1 K CN(MM) Q < .;check for amt contributed to child < .I $P($G(CN(MM,408.22,408.22,.1)),U,1) D < ..I +$P($G(CN(MM,408.22,408.22,.1)),U,1)>599 S $P(CN( < ..E S $P(CN(MM,408.22,408.22,.1),U,1)="NO" < ..S CN(MM,408.22,408.22,.06)="NO^2^^^"_$P(CN(MM,408.2 < S DFN=EASDFN < ...I $G(SP(1,408.13,408.13,.01))'="" S EAS(EASAPP,FIL < ...I $G(CN(1,408.13,408.13,.01))'="" S EAS(EASAPP,FIL < diff -y --suppress-common-lines ./VADemo/r1/EASEZF4.m ./VADemo/r2/r/EASEZF4.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 N MULTIPLE,FILE,SUBFILE,FLD,XDATA,ACCEPT,SUBIEN,SEX,S | N MULTIPLE,FILE,SUBFILE,FLD,XDATA,ACCEPT,SUBIEN,SEX,E .;record in file #408.13 is needed for all further da < .Q:(FILE'=408.13)&('$G(FLINK("CN",MULTIPLE,408.13))) < ...I ACCEPT D LINK^EASEZF2(XDATA,FILE,FLD,"CN",MULTIP | ...I ACCEPT D LINK^EASEZF2(XDATA,FILE,FLD) ...S X=$G(EAS(EASAPP,FILE,"+1,",".09")) I X'="" D | ...S X=$G(EAS(EASAPP,FILE,"+1,",".09")) I X'="" S Y=$ ....S SSN=$TR(X,"-","") S EAS(EASAPP,FILE,"+1,",".09" | ...S X=$P($G(CN(MULTIPLE,408.12,408.12,.02)),U,1) S S ....I $D(^DGPR(408.13,"SSN",SSN)) S EAS(EASAPP,FILE," < ...S X=$P($G(CN(MULTIPLE,408.12,408.12,.02)),U,1) S S < ...S X=$P($G(CN(MULTIPLE,FILE,SUBFILE,".1")),U,1) I X | ...S X=$P($G(CN(MULTIPLE,FILE,SUBFILE,".09")),U,1),EA ...S X=$P($G(CN(MULTIPLE,FILE,SUBFILE,".09")),U,1),EA | ...S X=$P($G(CN(MULTIPLE,FILE,SUBFILE,".1")),U,1) I X ...S X=$P($G(CN(MULTIPLE,408.21,408.21,".14")),U,1) I < ...S X=$P($G(CN(MULTIPLE,FILE,SUBFILE,".18")),U,1),EA < > ...;store link to new record in subfile #712.01 > ....S SUBIEN=$P(CN(MULTIPLE,FILE,SUBFILE,FLD),U,1) N SUBIEN,KEYIEN,MULTIPLE,FILE,SUBFILE,FIELD,DATAKEY,D | N SUBIEN,KEYIEN,MULTIPLE,FILE,SUBFILE,DATANM,TYPE,LIN .S DATANM=$P(^EAS(711,KEYIEN,0),U,1),DATAKEY=$P(^(0), | .S DATANM=$P(^EAS(711,KEYIEN,0),U,1),FILE=$P(^EAS(711 .I DATANM["CHILD(N)" D | .I DATANM["CHILD(N)" S MULTIPLE=MULTIPLE+1 ..;necessary because some version 6 income data for c < ..S MULTIPLE=MULTIPLE+1 < ..Q:$G(EASVRSN)<6 < ..I FILE=408.21,(".08;.14;.17"[FIELD) S MULTIPLE=MULT < .S LINK=$G(FLINK(TYPE,MULTIPLE,FILE)) | .S LINK=FLINK(TYPE,MULTIPLE,FILE) .Q:'LINK < .Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,$G(EASVRSN)) < diff -y --suppress-common-lines ./VADemo/r1/EASEZF5.m ./VADemo/r2/r/EASEZF5.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**51**;Mar 15, 20 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 N DATANM,X,IBDATA,OK,PARTA,PARTB,LSTNM,FRSTNM | N DATANM,X,IBDATA,OK,PARTA,PARTB .S IBDATA(1,60.05)=$$INSREL(IBDATA(1,60.07)) < .S X=IBDATA(1,60.05) S IBDATA(1,60.06)=$S(X="v":"01", < .S DATANM="APPLICANT INSURANCE ADDRESS" S X=$$GET(DAT | .S IBDATA(1,60.05)="v" .S IBDATA(1,21.01)=X < .S DATANM="APPLICANT INSURANCE CITY" S X=$$GET(DATANM < .S IBDATA(1,21.04)=X < .S DATANM="APPLICANT INSURANCE STATE" S X=$$GET(DATAN < .S IBDATA(1,21.05)=X < .S DATANM="APPLICANT INSURANCE ZIP" S X=$$GET(DATANM) < .S IBDATA(1,21.06)=X < .S X=$$INSPH^EASEZT2(EASAPP,"APPLICANT",1) < .S IBDATA(1,20.02)=X < .S IBDATA(1,.03)=1 < .S IBDATA(1,60.01)=EASDFN < .S OK=$$BUFF^IBCNBES1(.IBDATA) < ;applicant additional health insurance < K IBDATA < F MM=1:1 S DATANM="OTHER(N) INSURANCE COMPANY" S X=$$ < .S IBDATA(1,20.01)=X < .S DATANM="OTHER(N) INSURANCE GROUP CODE" S X=$$GET(D < .S IBDATA(1,40.03)=X < .S DATANM="OTHER(N) INSURANCE POLICY HOLDER" S X=$$GE < .S IBDATA(1,60.07)=X < .S IBDATA(1,60.05)=$$INSREL(IBDATA(1,60.07)) < .S X=IBDATA(1,60.05) S IBDATA(1,60.06)=$S(X="v":"01", < .S DATANM="OTHER(N) INSURANCE POLICY NUMBER" S X=$$GE < .S IBDATA(1,60.04)=X < .S DATANM="OTHER(N) INSURANCE ADDRESS" S X=$$GET(DATA < .S IBDATA(1,21.01)=X < .S DATANM="OTHER(N) INSURANCE CITY" S X=$$GET(DATANM, < .S IBDATA(1,21.04)=X < .S DATANM="OTHER(N) INSURANCE STATE" S X=$$GET(DATANM < .S IBDATA(1,21.05)=X < .S DATANM="OTHER(N) INSURANCE ZIP" S X=$$GET(DATANM,M < .S IBDATA(1,21.06)=X < .S X=$$INSPH^EASEZT2(EASAPP,"OTHER(N)",MM) < .S IBDATA(1,20.02)=X < > .S IBDATA(1,60.06)="01" ;retain for backward compatibility < GET(DATANM,MM) ;get 1010EZ data as needed by IB | GET(DATANM) ;get 1010EZ data as needed by IB I '$G(MM) S MM=1 < S XDATA=$P($$DATA712^EASEZU1(EASAPP,KEY,MM),U,1) | S XDATA=$P($$DATA712^EASEZU1(EASAPP,KEY,1),U,1) ; < INSREL(INSNM) ; < N FRSTNM,LSTNM < I INSNM="" Q "" < S DATANM="APPLICANT LAST NAME" S LSTNM=$$GET(DATANM) < S DATANM="APPLICANT FIRST NAME" S FRSTNM=$$GET(DATANM < I INSNM[LSTNM,INSNM[FRSTNM Q "v" < S DATANM="SPOUSE LAST NAME" S LSTNM=$$GET(DATANM) < S DATANM="SPOUSE FIRST NAME" S FRSTNM=$$GET(DATANM) < I INSNM[LSTNM,INSNM[FRSTNM Q "s" < Q "o" < diff -y --suppress-common-lines ./VADemo/r1/EASEZI.m ./VADemo/r2/r/EASEZI.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9,44,51**;Mar | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9**;Mar 15, 2 > ; > ; > ; RESET ; | ; ; EAS*1*44 Modifications - SCK | S DA=EASAPP N FDA,ERR | S DIE="^EAS(712," S FDA(712,EASAPP_",",3.4)=DFN | S DR="3.4///^S X=DFN;" I NEW S DR=DR_"3.5///^S X=NEW" I NEW D | D ^DIE . S FDA(712,EASAPP_",",3.5)=NEW < D FILE^DIE("","FDA","ERR") < ;setup tmp array for data mapping < D LOCAL711^EASEZU2 < I '$G(EASVRSN) S EASVRSN=$$VERSION^EASEZU4(EASAPP) < .I KEYIEN S X=$G(^TMP("EZDATA",$J,KEYIEN)),FILE=$P(X, | .I KEYIEN S X=$G(^EAS(711,KEYIEN,1)),FILE=$P(X,U,1),S .I FILE=2,SUBFILE=2,((FLD=.01)!(FLD=.03)!(FLD=.09)!(F | .I FILE=2,((FLD=.01)!(FLD=.03)!(FLD=.09)!(FLD=.531)) .I (EASVRSN>5.99),((SECT="IIC")!(SECT="IIE")) D < ..S QUES=$P(DATAKEY,";",2) < ..I SECT="IIC","1.6;2.3;3.3"[QUES S ACCEPT=-1 Q < ..I SECT="IIE","1.3;2.3;3.3"[QUES S ACCEPT=-1 < > ;setup tmp array for data mapping > D LOCAL711^EASEZU2 Q:$G(EASEZNEW) | Q:EASEZNEW K ALIAS,DISPOS,ENROLL,INCREL,RACE,ETHNC | K ALIAS,DISPOS,ENROLL,INCREL D I202^EASEZI(EASDFN,.RACE) W "." | ; I $D(RACE)>1 D C202^EASEZC3 | ;for all applicants matched to existing patients, D I206^EASEZI(EASDFN,.ETHNC) W "." | ; set file #355.33 data to 'always accept'; I $D(ETHNC)>1 D C206^EASEZC3 | ; ;set unmatched data for files #408.12, #408.13, #4 ;set file #355.33 data to 'always accept'; < ;set unmatched data for files #408.12, #408.13, #408. < .I KEYIEN S X=$G(^TMP("EZDATA",$J,KEYIEN)),FILE=$P(X, | .;S LINK=$P($G(^EAS(712,EASAPP,10,N,2)),U,2) > .S X=$G(^EAS(711,KEYIEN,1)),FILE=$P(X,U,1),FLD=$P(X,U .I FILE=2,SUBFILE=2,((FLD=.01)!(FLD=.03)!(FLD=.09)!(F | .I FILE=2,((FLD=.01)!(FLD=.03)!(FLD=.09)!(FLD=.531)) .I FILE=2,$G(ELIGVER),((FLD=.301)!(FLD=.302)!(FLD=.36 | .I FILE=2,ELIGVER,((FLD=.301)!(FLD=.302)!(FLD=.36235) .I (EASVRSN>5.99),((SECT="IIC")!(SECT="IIE")) D < ..S QUES=$P(DATAKEY,";",2) < ..I SECT="IIC","1.6;2.3;3.3"[QUES S ACCEPT=-1 Q < ..I SECT="IIE","1.3;2.3;3.3"[QUES S ACCEPT=-1 < I201(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.01 | I201(EASDFN,EASARRAY) ;retrieve ien(s) in Alias subfile #2. I202(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.02 | I2101(EASDFN,EASARRAY) ;retrieve ien to Disposition subfile ;input EASDFN = ien to #2 < ;output EASARRAY = ien(s) to #2.01 < ; each array element = EASDFN;subfil < ; < N N,IEN < S IEN=0,N=0 F S IEN=$O(^DPT(EASDFN,.02,IEN)) Q:'IEN < Q < ; < I206(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.06 < ;input EASDFN = ien to #2 < ;output EASARRAY = ien(s) to #2.01 < ; each array element = EASDFN;subfil < ; < N N,IEN < S IEN=0,N=0 F S IEN=$O(^DPT(EASDFN,.06,IEN)) Q:'IEN < Q < ; < I2101(EASDFN,EASARRAY) ;retrieve ien to subfile #2.101 < I2711(EASDFN,EASARRAY) ;retrieve ien to file #27.11 | I2711(EASDFN,EASARRAY) ;retrieve ien to Enrollment file #27. Only in ./VADemo/r1/: EASEZP61.m Only in ./VADemo/r1/: EASEZP62.m Only in ./VADemo/r1/: EASEZP63.m Only in ./VADemo/r1/: EASEZP64.m Only in ./VADemo/r1/: EASEZP6D.m Only in ./VADemo/r1/: EASEZP6F.m Only in ./VADemo/r1/: EASEZP6I.m Only in ./VADemo/r1/: EASEZP6M.m Only in ./VADemo/r1/: EASEZP6U.m diff -y --suppress-common-lines ./VADemo/r1/EASEZPF.m ./VADemo/r2/r/EASEZPF.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**44,51**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 W !!?5,*7,"Do not select a slave device for output." | W !!?5,*7,"This output requires a 132 column output p W !?5,"This output requires a 132 column output print < S %ZIS="Q",%ZIS("S")="I $P($G(^(1)),U)'[""SLAVE""&($P | S %ZIS="Q" D ^%ZIS D ^%ZIS < ;EAS*1*51 -- if version # 6 or greater, use new print < I '$G(EASVRSN) S EASVRSN=$$VERSION^EASEZU4(EASAPP) < I '(EASVRSN<6) S ZTRTN="EN^EASEZP6F" < ; < > ; ("PD") - Print Date of report Only in ./VADemo/r1/: EASEZPU2.m diff -y --suppress-common-lines ./VADemo/r1/EASEZT1.m ./VADemo/r2/r/EASEZT1.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**51**;Mar 15, 20 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 I XDATA="FG" Q "FOREIGN COUNTRY" < ; < ETHNIC(XDATA) ; < N X < I ($L(XDATA)>1)!(XDATA="") Q XDATA < S X=$S(XDATA="Y":"YES",XDATA="N":"NO",XDATA="U":"UNKN < I X'="" S X=X_" (S)" < Q X < ; < RACE(XDATA) ; < N X < I $L(XDATA)>1 Q XDATA < S X=$S(XDATA="Y":"YES (S)",1:"") < Q X < ; < LAST(XDATA) ; return LAST NAME, first middle < Q $$UC($P($G(XDATA),",")) < ; < diff -y --suppress-common-lines ./VADemo/r1/EASEZT2.m ./VADemo/r2/r/EASEZT2.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**51**;Mar 15, 20 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 INSPH(EASAPP,TYPE,MULTIPLE) ; < ;input EASAPP = application ien in file #712 < ; TYPE = "APPLICANT", "OTHER(N)" < ; MULTIPLE = EASMULT Value def=1 < ;output PHONE = formatted home phone; < ; example: (432)987-1234 < ; < N PHONE,AC,NUM,KEY,T < S PHONE="",MULTIPLE=+$G(MULTIPLE) I MULTIPLE<2 S MULT < S KEY=+$$KEY711^EASEZU1(TYPE_" INSURANCE PHONE AREA C < .S AC=$P($$DATA712^EASEZU1(EASAPP,KEY,MULTIPLE),U,1) < S KEY=+$$KEY711^EASEZU1(TYPE_" INSURANCE PHONE NUMBER < .S NUM=$P($$DATA712^EASEZU1(EASAPP,KEY,MULTIPLE),U,1) < .F T=1,2 S ^TMP("EZDATA",$J,KEY,MULTIPLE,T)="" < I AC'="" S AC="("_AC_")" < I NUM="-" S NUM="" < I NUM'="" S:NUM'["-" NUM=$E(NUM,1,3)_"-"_$E(NUM,4,7) < I NUM="" Q PHONE < S PHONE=AC_NUM < Q PHONE < ; < diff -y --suppress-common-lines ./VADemo/r1/EASEZU2.m ./VADemo/r2/r/EASEZU2.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**53**;Mar 15, 20 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 I INDEX="REV" S DR="5.1///^S X=DT;5.2////^S X=DUZ" D | I INDEX="REV" S DR="5.1///^S X=DT;5.2///^S X=DUZ" D ^ I INDEX="PRT" S DR="6.1///^S X=DT;6.2////^S X=DUZ" D | I INDEX="PRT" S DR="6.1///^S X=DT;6.2///^S X=DUZ" D ^ I INDEX="SIG" S DR="4///^S X=DT;4.1///^S X=DT;4.2//// | I INDEX="SIG" S DR="4///^S X=DT;4.1///^S X=DT;4.2///^ I INDEX="FIL" S DR="7.1///^S X=DT;7.2////^S X=DUZ" D | I INDEX="FIL" S DR="7.1///^S X=DT;7.2///^S X=DUZ" D ^ I INDEX="CLS" S DR="9.1///^S X=DT;9.2////^S X=DUZ" D | I INDEX="CLS" S DR="9.1///^S X=DT;9.2///^S X=DUZ" D ^ diff -y --suppress-common-lines ./VADemo/r1/EASEZU4.m ./VADemo/r2/r/EASEZU4.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**51**;Mar 15, 20 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 ; < SUPPRESS(EASAPP,DATAKEY,TYPE,VERSION) ;alb/cmf/51 < ;return 1 if node should not be displayed, filed, or < ;easapp = file 712 ien < ;datakey = file 711/.1 < ;type = 0:display[default], 1:file, 2:accept < N FLAG < Q:$G(EASAPP)="" 0 < Q:$G(DATAKEY)="" 0 < S:$G(VERSION)="" VERSION=$$VERSION(EASAPP) < Q:+VERSION<6 0 < S FLAG=0 < S TYPE=$S($G(TYPE)=1:1,$G(TYPE)=2:2,1:0) < I TYPE=0 D Q FLAG < .I "^I;18A.^I;18B.^I;18C.^I;18D.^"[DATAKEY S FLAG=1 Q < .I "^IIC;1.1^IIC;1.2^IIC;1.3^"[DATAKEY S FLAG=1 Q < .I "^I;1A.5^IIC;3.^I;14D1.^I;17.^"[DATAKEY S FLAG=1 Q < .I "^I;14C.^I;14D.^I;14D2.^I;14H.^"[DATAKEY S FLAG=1 < .I "^IIE;1.^IIE;2.^IIE;3.^"[DATAKEY S FLAG=1 Q < .Q < I TYPE=1 D Q FLAG < .I "^I;14D.^I;14D1.^I;14D2.^"[DATAKEY S FLAG=1 Q < .I "^IIC;1.1^IIC;1.2^IIC;1.3^"[DATAKEY S FLAG=1 Q < .I "^IIE;1.^IIE;2.^IIE;3.^"[DATAKEY S FLAG=1 Q < .I "^IIC;1.6^IIC;2.3^IIC;3.3^"[DATAKEY S FLAG=1 Q < .Q < ; < Q FLAG < ; < VERSION(EASAPP) ;alb/cmf/51 < ;return the version # of an application < Q:$G(EASAPP)="" -1 < Q:'$D(^EAS(712,EASAPP)) -1 < Q +$P(^EAS(712,EASAPP,0),U,12) < ; < diff -y --suppress-common-lines ./VADemo/r1/EASEZU5.m ./VADemo/r2/r/EASEZU5.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 .D ADDMSG ;alb/cmf/51 < ;special handling for field #.362 < I FILE=2,FLD=.362,EASVRSN>5.99 D < .I UPDATE["IN LIEU OF VA COMP" S UPDATE="YES" < .I UPDATE="YES, RECEIVING MILITARY RETIREMENT" S UPDA < S DR="1.5///^S X=UPDATE;1.1///^S X=ACCEPT;1.2///^S X= | S DR="1.5///^S X=UPDATE;1.1///^S X=ACCEPT;1.2///^S X= ; < REMSIG ;remove signature verification from selected Applicat < N APP,STATUS,DA,DIC,DR,DIR,DIRUT,DUOUT,DTOUT,S,X,Y < W @IOF < W !!,"Lookup and selection for Signature Verification < W !,"is by Application # only." < W !!,"Only Applications with a Signature Verification < W !,"Filing Date may be selected.",!! < S DIC="^EAS(712,",DIC(0)="AENQXZ",DIC("S")="I +$P($G( < D ^DIC < S APP=+Y < I APP>0 D < .S DIR(0)="YA",DIR("A")="Are you sure Signature Verif < .Q:$D(DIRUT) < .Q:'Y < .W !!,"One moment please...",! < .;remove signature verification data; update audit fi < .S DA=APP K X,Y < .S DIE=DIC,DR="4///^S X=""@"";4.1///^S X=""@"";4.2/// < .D ^DIE < .D APPINDEX^EASEZU2(APP) < .S S=$$CURRSTAT^EASEZU2(APP),STATUS=$S(S="PRT":"Print < .W !!,"Signature Verification removed..." < .W !!,"Application #"_APP_" STATUS -- ",STATUS < W !! < Q < ; < ADDMSG ;alb/cmf/51 - special update messages by field < N SECT,S1,S2 < Q:EASVRSN<6 < S SECT=$P($P(^EAS(711,KEYIEN,0),U,2),";") < Q:SECT'["II" < ; < I SECT="IIC" D Q < .I DATANM="CHILD1 GROSS ANNUAL INCOME2" D Q < ..D INCTOT("Gross Annual","gross annual") < .I DATANM="CHILD1 OTHER INCOME" D Q < ..D INCTOT("Other","other") < .I DATANM="CHILD1 FARM OR BUSINESS INCOME" D Q < ..D INCTOT("Farm/Business","farm/business") < ; < I SECT="IIE" D Q < .I DATANM="CHILD1 CASH IN BANK" D Q < ..D ASSTOT("Cash in Bank","cash in bank") < .I DATANM="CHILD1 REAL PROPERTY LESS MORTGAGES" D Q < ..D ASSTOT("Real Property","real property") < .I DATANM="CHILD1 STOCKS BONDS ASSETS LESS DEBTS" D < ..D ASSTOT("Other Property","other property") < ; < I SECT="IIG" D Q < .I DATANM="ASSET(N) CHILD CASH" D CHLDASS("Cash in Ba < .I DATANM="ASSET(N) CHILD REAL PROPERTY" D CHLDASS("R < .I DATANM="ASSET(N) CHILD OTHER PROPERTY" D CHLDASS(" < Q < ; < INCTOT(S1,S2) ; income total messages < W !!,?5,"The "_S1_" Income Child Total is the sum of < W !,?5,"individual child "_S2_" income values. The C < W !,?5,"may only be updated by adjusting the individu < W !,?5,S2_" income values. - or..." < Q < ; < ASSTOT(S1,S2) ; asset total messages < W !!,?5,"The "_S1_" Child Total is the sum of the ind < W !,?5,"child "_S2_" values and this total has been a < W !,?5,"the "_S1_" Veteran amount. The Child Total m < W !,?5,"adjusted by updating the "_S1_" Veteran amoun < Q < ; < CHLDASS(S1) ; child asset messages < W !!,?5,"The "_S1_" child amount has been added to th < W !,?5,"Veteran amount. The "_S1_" child amount may < W !,?5,"be adjusted by updating the "_S1_" Veteran am < W !,?5," - or..." < Q < ; < diff -y --suppress-common-lines ./VADemo/r1/EASEZU6.m ./VADemo/r2/r/EASEZU6.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**53**;Mar 15, 20 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;;Mar 15, 2001 .S DR="1///^S X=UNAME(XPART);1.1///^S X=1;1.2///^S X= | .S DR="1///^S X=UNAME(XPART);1.1///^S X=1;1.2///^S X= .S DR="1///^S X=UPHONE(XPART);1.1///^S X=1;1.2///^S X | .S DR="1///^S X=UPHONE(XPART);1.1///^S X=1;1.2///^S X S DR="1///^S X=ABBR;1.1///^S X=1;1.2///^S X=DT;1.3/// | S DR="1///^S X=ABBR;1.1///^S X=1;1.2///^S X=DT;1.3/// S DR="1///^S X=COUNTY;1.1///^S X=1;1.2///^S X=DT;1.3/ | S DR="1///^S X=COUNTY;1.1///^S X=1;1.2///^S X=DT;1.3/ S DR="1.5///^S X=UPDATE;1.1///^S X=ACCEPT;1.2///^S X= | S DR="1.5///^S X=UPDATE;1.1///^S X=ACCEPT;1.2///^S X= diff -y --suppress-common-lines ./VADemo/r1/EASEZW.m ./VADemo/r2/r/EASEZW.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**2,51**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**2**;Mar 15, 200 N ADDINSUR,ADDINCOM,ADDASSET < S ADDINSUR=0,ADDINCOM=0,ADDASSET=0 < .I LINE["ADDITIONAL INSURANCE" S ADDINSUR=ADDINSUR+1 < .I LINE["ADDITIONAL INCOME" S ADDINCOM=ADDINCOM+1 Q < .I LINE["ADDITIONAL ASSET" S ADDASSET=ADDASSET+1 Q < ..S MULTIPLE=1 | ..S MULTIPLE=1 I DATANM["CHILD(N)" S MULTIPLE=ADDCHIL ..;I DATANM["CHILD(N)" S MULTIPLE=ADDCHILD < ..I DATANM["CHILD(N)" S MULTIPLE=$S(ADDINCOM:ADDINCOM < ..I DATANM["OTHER(N)" S MULTIPLE=ADDINSUR < ..;I DATANM["INCOME(N)" S MULTIPLE=ADDINCOM < ..I DATANM["ASSET(N)" S MULTIPLE=ADDASSET < diff -y --suppress-common-lines ./VADemo/r1/EASMTCHK.m ./VADemo/r2/r/EASMTCHK.m EASMTCHK ;ALB/SCK,PJR - MEANS TEST BLOCKING CHECK ; 1 | EASMTCHK ;ALB/SCK - MEANS TEST BLOCKING CHECK ; 8/13/ ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,12,15,38,46** | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,12,15**;MAR 1 I 'EASAPT,EASACT="C",EASDT]"" D | I 'EASAPT,EASACT="C" D .N DGARRAY,SDCNT | . S IENS=EASDT_","_DFN .S DGARRAY(4)=DFN,DGARRAY("SORT")="P",DGARRAY("FLDS") | . S EASAPT=$$GET1^DIQ(2.98,IENS,9.5,"I") .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) < .S EASAPT=+$P($G(^TMP($J,"SDAMA301",DFN,EASDT)),U,10) < .K DGARRAY,SDCNT,^TMP($J,"SDAMA301") < . ;; Condition Check: MT Stat="P" AND GMT Threshold>T | . ;; Condition Check: Cat C or Pending Adj. AND Agree . ;; AND MT Date is after 10/5/1999 AND Agrees to pa < . ;; AND MT Date is older than 365 days, THEN MT is < . I $P(EASTAT,U,4)="P",$$GET1^DIQ(408.31,+EASTAT,.27, < . ;; Condition Check: Cat C or Pending Adj. < . ;; AND Agrees to pay Deductible AND MT date after < . I $P(EASTAT,U,4)="P",$$GET1^DIQ(408.31,+EASTAT,.27, < diff -y --suppress-common-lines ./VADemo/r1/EASMTL10.m ./VADemo/r2/r/EASMTL10.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,15,28**;Mar 1 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,15**;Mar 15, N EASDDD,EASLOC,EATYP,XX | N EASDDD,DIR,DIRUT,EATYP,ZTSAVE,EASLOC,EASKIP,EASLOC, ; < D:'$G(IOF) HOME^%ZIS < W @IOF < F XX=1:1:7 W !?2,$P($T(NOTICE+XX),";;",2) < ; < Q:'$$FILTER(.EASLOC) ; Select Filter action, quit on < Q:'$$LTRTYPE(.EATYP) ; Select type of letter to repr < Q:'$$ASKDT(EATYP,.EASDDD) ; Select date to reprint l < D QUE1 < Q < ; < FILTER(EASLOC) ; Filter by Patient Preferred Location < ; Input: None < ; < ; Output: EASLOC -1 if an error occurred < ; 0 if not filtering by location < ; nnn IEN of filtered facility in the < ; < ; RESULT 1 if result of function Ok < ; 0 if user enters "^" or exits < ; < N DIR,DIRUT < I $$GET1^DIQ(713,1,8,"I") D Q:$D(DIRUT) 0 | I $$GET1^DIQ(713,1,8,"I") D Q:$D(DIRUT) . Q:$D(DIRUT) | . Q:$D(DIRUT)!('Y) . I 'Y S EASLOC=0 Q < Q 1 < ; < ASKDT(EATYP,EASDDD) ; Ask for processing date to look for < ; Input EATYP Type of letter to be reprinted < ; < ; Output EASDDD Selected processing date for type < ; to be reprinted < ; < ; RESULT 1 if result of function Ok < ; 0 if user enters "^" or exits < ; < N EASDT,RSLT,EAX,EASOFST < ; < S RSLT=0 < AGN S EASDT=$$GETDT < G:EASDT<0 ASKQ < ; < S EASOFST=$S(EATYP=2:30,EATYP=4:60,1:0) < S EAX=$$FMADD^XLFDT(EASDT,-EASOFST,0,0,-1) < S EAX=$O(^EAS(713.2,"AD",EAX)) < I 'EAX D G AGN < . W !!,"No valid processing date could be found for " < . W !,"Please select another date." < ; < W !!,"To re-print "_$S(EATYP=2:30,EATYP=4:0,1:60)_"-d < W !,"the Search/Processing date of "_$$FMTE^XLFDT(EAX < W !,"Please note: ALL "_$S(EATYP=2:30,EATYP=4:0,1:60) < ; < S DIR(0)="YAO" < S DIR("?")="Enter 'YES' to use the "_$$FMTE^XLFDT(EAX < S DIR("A")="Do you wish to use this date? " < S DIR("B")="YES" < D ^DIR K DIR < I $D(DIRUT) G ASKQ < I 'Y G AGN < ; < S EASDDD=EAX < S RSLT=1 < ASKQ Q RSLT < ; < GETDT() ; < N DIR,DIRUT < > D LIST^EASMTL10 ; Display available processing dates > ASKDT ; Ask for processing date to look for letters S DIR("?")="Select the date for the letters you wish | S DIR("?")="^D LIST^EASMTL10" S DIR("A")="Enter re-print date: " | S DIR("?",1)="Select Processing Date:" > S DIR("A",1)="" > S DIR("A")="Enter processing date to re-run letters: S:$D(DIRUT) Y=-1 | Q:$D(DIRUT) Q +Y | I '$D(^EAS(713.2,"AD",+Y)) D G ASKDT ; | . W !!?5,$CHAR(7),"There are no entries with this pro LTRTYPE(EATYP) ; Ask for a specific type of letter to print | S EASDDD=+Y ; Input None | Q:'EASDDD ; < ; Output EATYP Type of letter to reprint < ; 1 - 60-day letter < ; 2 - 30-day letter < ; 4 - 0-day letter < ; < ; RESULT 1 if result of function Ok < ; 0 if user enters "^" or exits < ; < N DIR,DIRUT < > TYPE ; Ask for a specific type of letter to print Q:$D(DIRUT) 0 | Q:$D(DIRUT) Q 1 < . Q:'$$THRSHLD^EASMTL6(EATYP,EASIEN) ; Quit if lette < ; < NOTICE ; < ;;Means Test Letters are indexed by the date on which < ;;occurred and is dependent on the frequency the sear < ;;site. When you select the reprint date for a lette < ;;try to determine the appropriate search (processing < ;;the desired letters. If the letters printed are no < ;;you may need to try a later date. < ;; < diff -y --suppress-common-lines ./VADemo/r1/EASMTL1.m ./VADemo/r2/r/EASMTL1.m EASMTL1 ;MIN/TCM ALB/SCK/AEG/PHH - AUTOMATED MEANS TEST LETTE | EASMTL1 ;MIN/TCM ALB/SCK/AEG - AUTOMATED MEANS TEST LETTER - ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,12,20,54**;MA | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,12,20**;MAR 1 > . ; Since this is intended as an interim solution, an > . ; conversion utilities only handle days, to stay wi > . ; will be used to subtract one year. . S EASDT("ANV")=$$FMADD^XLFDT($$SUBLEAP^EASMTUTL(EAS | . S EASDT("ANV")=$$FMADD^XLFDT(EASPRCDT,-305) ; Anv d diff -y --suppress-common-lines ./VADemo/r1/EASMTL2.m ./VADemo/r2/r/EASMTL2.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,12,14,20,22,5 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,12,14,20**;MA K ^TMP("EASERR",$J) < . Q:'$$CHKDFN(DFN,EASIEN) ; Check for valid < . Q:EASPT'>0 ; Safety check | . Q:'EASPT ; Safety check D ERRMSG < K ^TMP("EASERR",$J),^TMP("EASBDPTR",$J) < ; Check for an existing entry for patient and anniver | ;; Check for an existing entry for patient and annive ; Modification for DCD sites which are required to pr | ;; Modification for DCD sites which are required to p ; *** | ;; *** ; TYPE - Letter type (1:60d, 2:30d, 4:0d) | ; TYPE - Letter type N DGFDA,ERRMSG | N DIE,DR,DA S DGFDA(1,713.2,EAS1_",",$S(TYPE=2:12,1:18))=1 | S DIE="^EAS(713.2,",DA=EAS1 D UPDATE^DIE("","DGFDA(1)","","ERRMSG") | S DR=$S(TYPE=2:12,TYPE=4:18,1:0) > Q:'DR > S DR=DR_"///1" > D ^DIE K DIE N EASIEN,DGFDA,FDAIEN,ERROUT | N EASIEN ; < . S DGFDA(1,713.1,"+1,",.01)=DFN | . S X=DFN,DIC="^EAS(713.1,",DIC(0)="Z" . S DGFDA(1,713.1,"+1,",2)=0 | . S DIC("DR")="2///0" . D UPDATE^DIE("","DGFDA(1)","FDAIEN","ERROUT(1)") | . D FILE^DICN K DIC . I $D(ERROUT) D | . S EASPT=+Y . . S ^TMP("EASERR",$J,DFN)=ERROUT(1,"DIERR",1)_" - " < . . S:+$G(FDAIEN(1))'>0 ^TMP("EASERR",$J,DFN)="Unable < . S EASPT=+$G(FDAIEN(1)) < FUTURE(DFN) ; Future Means Test available? | FUTURE(DFN) ; TEST(DFN) ; Test Patient? | TEST(DFN) ; ; < CHKDFN(DFN,MTIEN) ; Checks for a valid zero node in the < ; If no valid zero node, sets bad ptr entry < ; < N RSLT < ; < S DFN=$G(DFN),MTIEN=$G(MTIEN) < S RSLT=$D(^DPT(DFN,0)) < I 'RSLT D < . S ^TMP("EASBDPTR",$J,DFN)=MTIEN < ; < Q $G(RSLT) < ; < ERRMSG ; Send mail message if any errors were generated duri < I $D(^TMP("EASERR",$J)) D ERRORS < I $D(^TMP("EASBDPTR",$J)) D BADPTR < Q < ; < ERRORS ; < N EASDFN,EASERR,MSG,DFN,VA < ; < S MSG(.1)="The following issues were reported by the < S MSG(.9)="" < ; < S EASDFN=0 < F S EASDFN=$O(^TMP("EASERR",$J,EASDFN)) Q:'EASDFN D < . S DFN=EASDFN D PID^VADPT < . S MSG(EASDFN)=$$GET1^DIQ(2,EASDFN,.01)_" ("_VA("BID < . K VA < ; < D SEND(.MSG) < Q < ; < BADPTR ; < N EASDFN,EASERR,MSG,X < ; < S MSG(.1)="During the MT Letter Search, the following < S MSG(.2)="File entries (#408.31) were found which ma < S MSG(.3)="Patient entry in the PATIENT File (#2):" < S MSG(.4)="" < S X=$$SETSTR^VALM1("PATIENT FILE (#2)","",5,20) < S X=$$SETSTR^VALM1("MT FILE (#408.31)",X,35,20) < S MSG(.5)=X < S X=$$SETSTR^VALM1("=================","",5,20) < S X=$$SETSTR^VALM1("=================",X,35,20) < S MSG(.6)=X < ; < S EASDFN=0 < F S EASDFN=$O(^TMP("EASBDPTR",$J,EASDFN)) Q:'EASDFN < . S X=$$SETSTR^VALM1(EASDFN,"",5,20) < . S X=$$SETSTR^VALM1($G(^TMP("EASBDPTR",$J,EASDFN)),X < . S MSG(EASDFN)=X < ; < D SEND(.MSG) < Q < ; < SEND(MSG) ; < S XMSUB="MT LETTERS SEARCH ISSUES - "_$$FMTE^XLFDT($$ < S XMTEXT="MSG(" < S XMY("G.EAS MTLETTERS")="" < S XMDUZ="AUTOMATED MT LETTERS" < D ^XMD < Q < diff -y --suppress-common-lines ./VADemo/r1/EASMTL6A.m ./VADemo/r2/r/EASMTL6A.m EASMTL6A ; MIN/TCM ALB/SCK/PHH - AUTOMATED MEANS TEST | EASMTL6A ; MIN/TCM ALB/SCK - AUTOMATED MEANS TEST LETT ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,14,15,29,28,5 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,14,15**;MAR 1 W ?(IOM-10),$E(EASDEM(1),1,1),EASDEM(2) < . W !!!!?TAB+OFFSET,EASDEM(1) | . W !!!!?TAB+OFFSET,"TEST LETTER (DO NOT MAIL!)" > W " (",EASDEM(2),")" ;; Patch 15 W !!!!,?TAB,"MEANS TEST ANNIVERSARY DATE: ",$$FMTE^XL | W !!!!,?TAB,"MEANS TEST ANNIVERSARY DATE: ",$$FMTE^XL . I LINE["|ANNVDT|" W !?TAB,$P(LINE,"|ANNVDT|",1),$$F | . I LINE["|ANNVDT|" W !?TAB,$P(LINE,"|ANNVDT|",1),$$F . S EASDEM(1)="TEST LETTER (DO NOT MAIL!)" < ;; Check for Bad Address Indicator < S EASADD("BAI")=$$BADADR^DGUTL3(DFN),$P(EASADD("BAI") < S:'RSLT&(EASADD("BAI")) RSLT=1 < diff -y --suppress-common-lines ./VADemo/r1/EASMTL6.m ./VADemo/r2/r/EASMTL6.m EASMTL6 ; ALB/SCK,BRM,LBD,PHH - AUTOMATED MEANS TEST LETTER-I | EASMTL6 ; ALB/SCK - AUTOMATED MEANS TEST LETTER-INTERACTIVE P ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,14,15,29,25,2 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,14,15**;MAR 1 N DIR,DIRUT,POP,EASLOC,Y | N DIR,DIRUT,POP,EASLOC ;; Select facility filter if appropriate | ;; Select facility filter if appropiate LTR ; Main entry point | LTR ; S MSG(4)="Incomplete/Bad Addr : "_$J( | S MSG(4)="Incomplete Addr : "_$J($FN(EASKP( S MSG(5)="Deceased : "_$J( | S MSG(5)="Deceased : "_$J($FN(EASKP( S MSG(6)="MT Changed: "_$J( | S MSG(6)="MT Changed: "_$J($FN(EASKP( S MSG(7)="Prohibit flag set: "_$J( | S MSG(7)="Prohibit flag set: "_$J($FN(EASKP( S MSG(8)="Not a User Enrollee: "_$J( | S MSG(8)="MT not 'owned' by facility: "_$J($FN(EASKP( S MSG(8.5)="Not a User Enrollee of this facility: "_$ < S TOT=0 F X1="I","D","C","P","O","T","U","CNT" S TOT= | S TOT=0 F X1="I","D","C","P","O","T","CNT" S TOT=TOT+ N DFN,EASIEN,COUNT,EAX2,EASPTR,EASABRT,EASUE | N DFN,EASIEN,COUNT,EAX2,EASPTR,EASABRT F EAX2="P","D","C","F","T","I","O","U","CNT" S EASKP( | F EAX2="P","D","C","F","T","I","O","CNT" S EASKP(EAX2 . ; begin checks | . ;; begin checks . Q:EASPTR<0 ; SAFETY CHECK < . S DFN=$$GET1^DIQ(713.1,EASPTR,.01,"I") Q:'DFN | . S DFN=$P(^EAS(713.1,$P(^EAS(713.2,EASIEN,0),U,2),0) > . ;; Quit if the MT is not 'owned' by the facility > . I '$$OWNED($P($G(^EAS(713.1,EASPTR,0)),U,1),EASIEN) > . . S EASKP("O")=EASKP("O")+1 . ; Get User Enrollee status (0=not UE; 1=UE; 2=UE, n < . S EASUE=$$UESTAT^EASUER(DFN) < . I 'EASUE D Q ; Quit if not User Enrollee < . . D NOPRT(EATYP,EASIEN) < . . S EASKP("U")=EASKP("U")+1 < . I EASUE'=1 D Q ; Quit if User Enrollee site is n < . . D NOPRT(EATYP,EASIEN) < . . S EASKP("O")=EASKP("O")+1 < N EASIEN,EASABRT,Y | N EASIEN,EASABRT S ANVDT=$$ADDLEAP^EASMTUTL(MTDT) | S ANVDT=$$FMADD^XLFDT(MTDT,365) NOPRT(EATYP,EASIEN) ; Letter not printed, update Letter S < ; Input < ; EATYP - Letter type to print < ; EASIEN - IEN for file #713.2 < ; < N DIE,DR,DA,LTR < Q:'$G(EATYP) Q:'$G(EASIEN) < S DIE="^EAS(713.2,",DA=EASIEN < S LTR=$S(EATYP=1:9,EATYP=2:12,EATYP=4:18,1:0) < Q:'LTR < ; Set current letter print statuses = "N" < S DR=LTR_"///0;"_(LTR+1)_"///0" < ; If current letter is not 0-day letter, set next let < S:LTR'=18 DR=DR_";"_$S(LTR=9:12,1:18)_"///1" < D ^DIE < Q < ; < N RSLT,DIR,Y | N RSLT,DIR diff -y --suppress-common-lines ./VADemo/r1/EASMTL8.m ./VADemo/r2/r/EASMTL8.m EASMTL8 ;618/TCM ALB/SCK/PHH - AUTOMATED MEANS TEST LETTER, 2 | EASMTL8 ;618/TCM ALB/SCK - AUTOMATED MEANS TEST LETTER, 20-DA ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,54**;MAR 15,2 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3**;MAR 15,2001 W !?5,"Means Test Anniversary Date: ",$$FMTE^XLFDT($$ | W !?5,"Means Test Anniversary Date: ",$$FMTE^XLFDT($$ diff -y --suppress-common-lines ./VADemo/r1/EASMTRP1.m ./VADemo/r2/r/EASMTRP1.m EASMTRP1 ;ALB/SCK - MEANS TEST DAILY EXPIRATION REPORT | EASMTRP1 ;ALB/SCK - MEANS TEST DAILY EXPIRATION REPORT ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,13,46**;MAR 1 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,13**;MAR 15,2 D BLDSD ; Call Scheduling API < K DGARRAY,SDCNT,VARR,I,^TMP($J,"SDAMA") < Q < ; < BLDSD ; < N EDATE,MTREC,PIEN,VARR,RCNT,ACNT,DGARRAY,SDCNT,I < S ACNT=1,RCNT=0 < S EDATE=0 F S EDATE=$O(^TMP("EASEXP",$J,EDATE)) Q:'E < .S MTREC=0 F S MTREC=$O(^TMP("EASEXP",$J,EDATE,MTREC < ..S PIEN=+^TMP("EASEXP",$J,EDATE,MTREC) < ..Q:'$D(^DPT(PIEN,0)) < ..S RCNT=RCNT+1,VARR(ACNT)=$G(VARR(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 < K DGARRAY < S DGARRAY(1)=DT,DGARRAY("SORT")="P",DGARRAY("FLDS")=" < F I=1:1 Q:'$D(VARR(I)) D < .S DGARRAY(4)=VARR(I) < .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) < .M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301") < .K ^TMP($J,"SDAMA301") < N EASAP,EASND,EASCL | N EASBEG,EASAP,EASND,EASCL Q:'$D(^TMP($J,"SDAMA",DFN)) | ; S EASAP=0 F S EASAP=$O(^TMP($J,"SDAMA",DFN,EASAP)) Q | S EASBEG=$$DT^XLFDT,EASAP=EASBEG .S EASND=^TMP($J,"SDAMA",DFN,EASAP) | F EASAP=EASBEG:0 S EASAP=$O(^DPT(DFN,"S",EASAP)) Q:'E .S EASCL=+$P(EASND,U,2),EASAPT(EASCL)=+EASND | . Q:'$D(^DPT(DFN,"S",EASAP,0)) > . S EASND=^DPT(DFN,"S",EASAP,0) > . S EASCL=+EASND > . S EASAPT(EASCL)=EASAP diff -y --suppress-common-lines ./VADemo/r1/EASMTRP2.m ./VADemo/r2/r/EASMTRP2.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,15,22**;MAR 1 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,15**;MAR 15,2 N ZTSAVE,DIR,EASUM,Y | N ZTSAVE,DIR,EASUM N CNT,EASIEN,PCNT,RCNT,EASX,TOT,PAGE,EAS0,EAS4,EAS6,E | N CNT,EASIEN,PCNT,RCNT,EASX,TOT,PAGE,EAS0,EAS4,EAS6,E > ; ; | ;; DETAIL ; Print details section | DETAIL ; . I ($Y+4)>IOSL D Q:$D(DIRUT) | . I ($Y+4)>IOSL D . . I $E(IOST,1,2)="C-" D Q:$D(DIRUT) | . . S DIR(0)="E" . . . S DIR(0)="E" | . . D ^DIR K DIR . . . D ^DIR K DIR | . . Q:$D(DIRUT) diff -y --suppress-common-lines ./VADemo/r1/EASMTRP3.m ./VADemo/r2/r/EASMTRP3.m EASMTRP3 ; ALB/SCK - MEANS TEST ANV DATES BY APPT DATE | EASMTRP3 ; ALB/SCK - MEANS TEST ANV DATES BY APPT DATE ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,15,46**;MAR 1 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,15**;MAR 15,2 N EASSC,PAGE,ACNT,RCNT,DGARRAY,I,CLARR,SDCNT | N EASSC,EASSD,EASEND,PAGE > ; S PAGE=1,^TMP("EASAP",$J,"APDT")=EASDT < ; Build Array of Valid Clinic IENs | S PAGE=1 S ACNT=1,(RCNT,EASSC)=0 F S EASSC=$O(^SC(EASSC)) Q:' | S ^TMP("EASAP",$J,"APDT")=EASDT .Q:'$D(^SC(EASSC,0)) | S EASSD=0 .Q:$P(^SC(EASSC,0),U,3)'="C" | F S EASSD=$O(^SC("B",EASSD)) Q:EASSD']""!($G(EASEND) .S RCNT=RCNT+1,CLARR(ACNT)=$G(CLARR(ACNT))_EASSC_";" | D PRINT .; Group Clinic IENs by no more than thirty | Q .I RCNT>29 S ACNT=ACNT+1,RCNT=0 | ; ; | CLN(EASSD,EASDT) ; Loop through clinics looking for a ; Call SD API by array of Clinic IENs | N EASSC ; Clinic IEN S DGARRAY(1)=EASDT_";"_EASDT,DGARRAY("FLDS")="1;3" | ; F I=1:1 Q:'$D(CLARR(I)) D | S EASSC=0 .S DGARRAY(2)=CLARR(I) | F S EASSC=$O(^SC("B",EASSD,EASSC)) Q:'EASSC>0!$G(EAS .S SDCNT=$$SDAPI^SDAMA301(.DGARRAY) | . I $D(^SC(EASSC,0)),$P(^(0),"^",3)="C" D LOOP(EASSC, .M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301") | Q .K ^TMP($J,"SDAMA301") | ; D LOOP,PRINT | LOOP(EASSC,EASDT) ; Loop through a clinic's appointment K DGARRAY,CLARR,I,^TMP($J,"SDAMA") | N EAX,EAX1,SDT,DFN,EASANV Q | ; ; | S EAX=0 LOOP ; Loop through a clinic's appointment list | F SDT=EASDT:0 S SDT=$O(^SC(EASSC,"S",SDT)) Q:'SDT!(SD N DFN,EASANV,EASAPT | . F EAX1=0:0 S EAX1=$O(^SC(EASSC,"S",SDT,1,EAX1)) Q:' ; | . . Q:$P(^SC(EASSC,"S",SDT,1,EAX1,0),"^",9)["C" ; Qu S EASSC=0 F S EASSC=$O(^TMP($J,"SDAMA",EASSC)) Q:'EA | . . S DFN=$P($G(^SC(EASSC,"S",SDT,1,EAX1,0)),"^",1) .S DFN=0 F S DFN=$O(^TMP($J,"SDAMA",EASSC,DFN)) Q:'D | . . S LASTMT=$$LST^DGMTU(DFN) ; Get patient's last M ..S EASAPT=0 F S EASAPT=$O(^TMP($J,"SDAMA",EASSC,DFN | . . Q:"N,P"[$P(LASTMT,U,4) ; Quit if means test is n ...; Quit if appointment has been cancelled | . . I $P(LASTMT,U,4)="C",$$GET1^DIQ(408.31,+LASTMT,.1 ...Q:$P($P(^TMP($J,"SDAMA",EASSC,DFN,EASAPT),U,3),";" | . . Q:$$FUT^DGMTU(DFN) ; Quit if future MT is on fil ...S LASTMT=$$LST^DGMTU(DFN) ; Get patient's last Me | . . S EASANV=$$FMADD^XLFDT($P(LASTMT,U,2),365) ...; Quit if means test is no longer required or pend | . . I EASDT'IOSL S EASABRT=$$HDR(EACLN) | . . . I ($Y+5)>IOSL S EASABRT=$$HDR(EASCLN) diff -y --suppress-common-lines ./VADemo/r1/EASMTUTL.m ./VADemo/r2/r/EASMTUTL.m EASMTUTL ; ALB/SCK/BRM/PHH - AUTOMATED MEANS TEST LETT | EASMTUTL ; ALB/SCK - AUTOMATED MEANS TEST LETTERS UTIL ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,14,15,29,22,5 | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,14,15**;MAR 1 S MSG(9.5)=" Bad Addr : "_$P(EASADD("BAI"),U,2) < S XMSUB="Incomplete/Bad Addr: "_EASPRF | S XMSUB="Incomplete Addr: "_EASPRF N DIR,DIRUT,EASF,Y,X,EASIEN,DFN,DGFDA,FDAIEN,ERRMSG | N DIR,DIRUT,EASF,DIC,DIE,Y,X,EASIEN,DR,DA,DFN . . S DGFDA(1,713.1,"+1,",.01)=DFN | . . S DIC="^EAS(713.1,",DIC(0)="Z",X=DFN . . D UPDATE^DIE("","DGFDA(1)","FDAIEN","ERRMSG") | . . D FILE^DICN . . S EASIEN=FDAIEN(1) | . . S EASIEN=+Y N DGFDA,DGIEN,DGEFF,DIR,DIRUT,DGERR,DIE | S DIE="^EAS(713.1,",DA=EASIEN ; | S:EASF="S" DR="2///YES;3;5///^S X=$$NOW^XLFDT;4///^S S DGIEN=EASIEN_"," | S:EASF="R" DR="2///@;3///@;5///@;4///@;10///@" I EASF="S" D | D ^DIE K DIE . S DIR(0)="DAO^"_$$DT^XLFDT_"::EX" < . S DIR("A")="Effective Date: " < . D ^DIR K DIR < . Q:$G(DIRUT) < . S DGFDA(1,713.1,DGIEN,3)=Y < . S DGFDA(1,713.1,DGIEN,2)=1 < . S DGFDA(1,713.1,DGIEN,5)=$$NOW^XLFDT < . S DGFDA(1,713.1,DGIEN,4)=DUZ < . D:$D(DGFDA) FILE^DIE("","DGFDA(1)","DGERR") < . I $D(DGERR) D Q < . . D DSPLYER(.DGERR) < . S DIE="^EAS(713.1,",DA=EASIEN,DR="10" < . D ^DIE K DIE < ; < I EASF="R" D < . S DGFDA(1,713.1,DGIEN,2)=0 < . S DGFDA(1,713.1,DGIEN,3)="@" < . S DGFDA(1,713.1,DGIEN,5)="@" < . S DGFDA(1,713.1,DGIEN,4)="@" < . S DGFDA(1,713.1,DGIEN,10)="@" < . D:$D(DGFDA) FILE^DIE("","DGFDA(1)","DGERR") < . I $D(DGERR) D < . . D DSPLYER(.DGERR) < . E W !!?3,"Prohibit Flag Removed from Patient.",! < ; < Q < DSPLYER(ERRARY) ; < N DGER < ; < W !!?3,"The following error(s) occurred:" < S DGER=0 < F S DGER=$O(ERRARY("DIERR",DGER)) Q:'DGER D < . W !?3,ERRARY("DIERR",DGER)," - ",ERRARY("DIERR",DGE < W !?3,"Please check, this record update may not have < N EASIEN,EATYP,DIR,DIRUT,ZTSAVE | N EASIEN,EATYP,DIR,DIRUT ADDLEAP(DATE) ; Adding a year with Leap Year checking < ; Input: < ; DATE - Date passed in. < ; < ; Output: < ; Date passed in plus one year (with leap year < ; < N YEAR < S YEAR=$E($$FMTHL7^XLFDT(DATE),1,4) < I $E(DATE,4,7)="0229",'$$LEAP^XLFDT3(YEAR+1) D < .S DATE=$$FMADD^XLFDT(DATE,-1) < Q $E(DATE,1,3)+1_$E(DATE,4,7) < ; < SUBLEAP(DATE) ; Subtracting a year with Leap Year checking < ; Input: < ; DATE - Date passed in. < ; < ; Output: < ; Date passed in minus one year (with leap year < ; < N YEAR < S YEAR=$E($$FMTHL7^XLFDT(DATE),1,4) < I $E(DATE,4,7)="0229",'$$LEAP^XLFDT3(YEAR-1) D < .S DATE=$$FMADD^XLFDT(DATE,-1) < Q $E(DATE,1,3)-1_$E(DATE,4,7) < Only in ./VADemo/r1/: EASPREC2.m Only in ./VADemo/r1/: EASPREC7.m Only in ./VADemo/r1/: EASPTRN1.m Only in ./VADemo/r1/: EASPTRN5.m diff -y --suppress-common-lines ./VADemo/r1/EASSIGOV.m ./VADemo/r2/r/EASSIGOV.m ;;1.0;ENROLLMENT APPLICATION SYSTEM;**4,8,13,28**;Mar | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**4,8,13**;Mar 15 ..I +$P($G(^DGMT(408.31,MTIEN,2)),"^",5)'=SITE Q | ..I $P($G(^DGMT(408.31,MTIEN,2)),"^",5)'=SITE Q ..I +$P($G(^DGMT(408.31,MTIEN,2)),"^",5)'=SITE Q | ..I $P($G(^DGMT(408.31,MTIEN,2)),"^",5)'=SITE Q W !,?2,"The purpose of this report is to help sites m | W !,?2,"This purpose of this report is to help sites Only in ./VADemo/r1/: EASUER.m Only in ./VADemo/r1/: EASUFNC3.m Only in ./VADemo/r1/: EASUM1.m Only in ./VADemo/r1/: EASUM7.m Only in ./VADemo/r1/: EASUM8.m diff -y --suppress-common-lines ./VADemo/r1/EASXDR1.m ./VADemo/r2/r/EASXDR1.m EASXDR1 ;ALB/BRM/PHH - CHECK RELATIONS DURING XDR PATIENT MER | EASXDR1 ;ALB/BRM - CHECK RELATIONS DURING XDR PATIENT MERGE; ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10,26**;Mar 15, | ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15, 20 S ^XTMP("EASXDR1",0)=$$FMADD^XLFDT($$NOW^XLFDT(),45)_ | S ^XTMP("EASXDR1",0)=$$FMADD^XLFDT($$NOW^XLFDT(),10)_ S DA=IEN,DIK=ROOT D ^DIK,IX^DIK S MSG="0^RECORD DELET | S DA=IEN,DIK=ROOT D ^DIK S MSG="0^RECORD DELETED" Only in ./VADemo/r1/: EC2P48PT.m Only in ./VADemo/r1/: EC2P52PT.m Only in ./VADemo/r1/: EC725U20.m Only in ./VADemo/r1/: EC725U21.m Only in ./VADemo/r1/: EC725U22.m Only in ./VADemo/r1/: EC725U23.m diff -y --suppress-common-lines ./VADemo/r1/ECBEN1B.m ./VADemo/r2/r/ECBEN1B.m ;;2.0; EVENT CAPTURE ;**4,5,10,13,17,23,41,42,50,54** | ;;2.0; EVENT CAPTURE ;**4,5,10,13,17,23,41,42**;8 May . . ; NOIS MWV-0603-21781:line below changed by VMP. | . . W !!,"WARNING ",VADM(7),!! . . W !!,"WARNING "_"[PATIENT DIED ON "_$P(VADM(6),U, < K ECID,ECMST,ECDXS,ECDXIEN,ECHNC,ECCV | K ECID,ECMST,ECDXS,ECDXIEN,ECHNC S (ECDX,ECDXN,ECINP,ECVST,ECSC,ECAO,ECIR,ECZEC,ECMST, | S (ECDX,ECDXN,ECINP,ECVST,ECSC,ECAO,ECIR,ECZEC,ECMST, S ECPT(CNT)=ECPT(CNT)_"^"_ECDX_"^"_$S(ECINP="":$G(ECP | S ECPT(CNT)=ECPT(CNT)_"^"_ECDX_"^"_$S(ECINP="":$G(ECP diff -y --suppress-common-lines ./VADemo/r1/ECBEN2A.m ./VADemo/r2/r/ECBEN2A.m ;;2.0; EVENT CAPTURE ;**1,4,5,13,18,33,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**1,4,5,13,18,33**;8 May 96 . S ECPTCD=$$CPT^ICPTCOD(ECCPT,ECDT) I +ECPTCD>0 S EC | . S ECPTCD=$$CPT^ICPTCOD(ECCPT) I $P(ECPTCD,U)>0 S EC diff -y --suppress-common-lines ./VADemo/r1/ECBEN2U.m ./VADemo/r2/r/ECBEN2U.m ;;2.0; EVENT CAPTURE ;**4,5,7,10,17,18,23,42,47,54**; | ;;2.0; EVENT CAPTURE ;**4,5,7,10,17,18,23,42**;8 May S (ECDX,ECDXN,ECVST,ECSC,ECAO,ECIR,ECZEC,ECMST,ECHNC, | S (ECDX,ECDXN,ECVST,ECSC,ECAO,ECIR,ECZEC,ECMST,ECHNC) . . S MOD=$$MOD^ICPTMOD(MOD,"I",$P(PN,U,3)) I +MOD<0 | . . S MOD=$$MOD^ICPTMOD(MOD,"I") I +MOD<0 Q S ECPP11=$P(PNP,"^",11),ECPP11=$S(ECPP11="Y":1,ECPP11 < ;d/t~dfn~hosp loc~inst~dss id~prov~prov2~prov3~vol~cp | ;d/t~dfn~hosp loc~inst~dss id~prov~prov2~prov3~vol~cp S PNODE=ECP3_"~"_ECP2_"~"_ECP19_"~"_ECP4_"~"_ECP20_"~ | S PNODE=ECP3_"~"_ECP2_"~"_ECP19_"~"_ECP4_"~"_ECP20_"~ K ECP2,ECP3,ECP4,ECP10,ECP11,ECP15,ECP17,ECP19,ECP20, | K ECP2,ECP3,ECP4,ECP10,ECP11,ECP15,ECP17,ECP19,ECP20, diff -y --suppress-common-lines ./VADemo/r1/ECBENF.m ./VADemo/r2/r/ECBENF.m ;;2.0; EVENT CAPTURE ;**4,5,13,17,18,23,42,54**;8 May | ;;2.0; EVENT CAPTURE ;**4,5,13,17,18,23,42**;8 May 96 .S ECPS=$P(ECNODE2,"^"),ECDX=$P(ECNODE2,"^",3),ECINP= | .S ECPS=$P(ECNODE2,"^"),ECDX=$P(ECNODE2,"^",3),ECINP= .S ECHNC=$P(ECNODE2,"^",13),ECCV=$P(ECNODE2,"^",14) < S $P(^ECH(ECFN,"P"),"^",9,11)=ECMST_"^"_ECHNC_"^"_ECC | S $P(^ECH(ECFN,"P"),"^",9)=ECMST,$P(^ECH(ECFN,"P"),"^ diff -y --suppress-common-lines ./VADemo/r1/ECBEN.m ./VADemo/r2/r/ECBEN.m ;;2.0; EVENT CAPTURE ;**4,5,10,17,42,54**;8 May 96 | ;;2.0; EVENT CAPTURE ;**4,5,10,17,42**;8 May 96 .K ECDXN,ECINP,ECVST,ECZEC,ECID,ECPTSTAT,ECMST,ECHNC, | .K ECDXN,ECINP,ECVST,ECZEC,ECID,ECPTSTAT,ECMST,ECHNC diff -y --suppress-common-lines ./VADemo/r1/ECBEP1B.m ./VADemo/r2/r/ECBEP1B.m ;;2.0; EVENT CAPTURE ;**1,4,5,10,13,17,18,42,47,54**; | ;;2.0; EVENT CAPTURE ;**1,4,5,10,13,17,18,42**;8 May D ^ECBEP2A Q:ECOUT K ECA,ECCN,ECEC,ECHOICE,ECJLP,ECP | D ^ECBEP2A Q:ECOUT K ECA,ECCN,ECEC,ECHOICE,ECJLP,ECP . S ECPTCD=$$CPT^ICPTCOD(ECCPT,ECDT) I +ECPTCD>0 S EC | . S ECPTCD=$$CPT^ICPTCOD(ECCPT) I $P(ECPTCD,U)>0 S EC diff -y --suppress-common-lines ./VADemo/r1/ECBEP2A.m ./VADemo/r2/r/ECBEP2A.m ;;2.0; EVENT CAPTURE ;**4,5,10,13,17,18,23,33,41,42,5 | ;;2.0; EVENT CAPTURE ;**4,5,10,13,17,18,23,33,41,42** K ECSC,ECZEC,ECIR,ECDX,ECDXN,ECVST,ECINP,ECAO,ECPTSTA | K ECSC,ECZEC,ECIR,ECDX,ECDXN,ECVST,ECINP,ECAO,ECPTSTA S (ECDX,ECDXN,ECINP,ECVST,ECSC,ECAO,ECIR,ECZEC,ECMST, | S (ECDX,ECDXN,ECINP,ECVST,ECSC,ECAO,ECIR,ECZEC,ECMST, S ECPT(CNT)=ECPT(CNT)_"^"_ECO_"^"_ECON_"^"_ECV_"^"_EC | S ECPT(CNT)=ECPT(CNT)_"^"_ECO_"^"_ECON_"^"_ECV_"^"_EC diff -y --suppress-common-lines ./VADemo/r1/ECBEPF.m ./VADemo/r2/r/ECBEPF.m ;;2.0; EVENT CAPTURE ;**4,5,13,17,18,23,42,54**;8 May | ;;2.0; EVENT CAPTURE ;**4,5,13,17,18,23,42**;8 May 96 S ECMST=$P(ECPT(CNT1),"^",15),ECHNC=$P(ECPT(CNT1),"^" | S ECMST=$P(ECPT(CNT1),"^",15),ECHNC=$P(ECPT(CNT1),"^" S $P(^ECH(ECFN,"P"),"^",9,11)=ECMST_"^"_ECHNC_"^"_ECC | S $P(^ECH(ECFN,"P"),"^",9)=ECMST,$P(^ECH(ECFN,"P"),"^ diff -y --suppress-common-lines ./VADemo/r1/ECBEP.m ./VADemo/r2/r/ECBEP.m ;;2.0; EVENT CAPTURE ;**4,5,10,17,42,54**;8 May 96 | ;;2.0; EVENT CAPTURE ;**4,5,10,17,42**;8 May 96 .K ECAO,ECIR,ECSC,ECCPT,ECDX,ECDXN,ECINP,ECVST,ECZEC, | .K ECAO,ECIR,ECSC,ECCPT,ECDX,ECDXN,ECINP,ECVST,ECZEC, diff -y --suppress-common-lines ./VADemo/r1/ECED1.m ./VADemo/r2/r/ECED1.m ;;2.0; EVENT CAPTURE ;**4,5,8,10,18,23,41,47,50**;8 M | ;;2.0; EVENT CAPTURE ;**4,5,8,10,18,23,41**;8 May 96 . ; NOIS MWV-0603-21781: line below changed by VMP. | . W !!,"WARNING ",VADM(7),!! . W !!,"WARNING "_"[PATIENT DIED ON "_$P(VADM(6),U,2) < N ECPXD < S (ECPTCD,ECPXD)="" I ECCPT'="" D < . S ECPXD=$$CPT^ICPTCOD(ECCPT,ECDTM) I +ECPXD>0 S ECP < . S ECPN=$S($P(ECPXD,U,3)]"":$P(ECPXD,U,3),1:"UNKNOWN | . S ECPN=$S($P($G(^ICPT(ECTEMP,0)),"^",2)]"":$P(^(0), SET1 S ECPN=ECPTCD_" "_ECPN_$S(ECPSYN="":"",1:" ["_ECPSYN | SET1 I ECCPT'="" D > . S ECPTCD=$$CPT^ICPTCOD(ECCPT) I $P(ECPTCD,U)>0 S EC > . S ECPTCD="" > S ECPN=ECPTCD_" "_ECPN_$S(ECPSYN="":"",1:" ["_ECPSYN diff -y --suppress-common-lines ./VADemo/r1/ECED2.m ./VADemo/r2/r/ECED2.m ;;2.0; EVENT CAPTURE ;**1,4,5,13,18,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**1,4,5,13,18**;8 May 96 . S ECPTCD=$$CPT^ICPTCOD(ECCPT,ECDT) | . S ECPTCD=$$CPT^ICPTCOD(ECCPT) I $P(ECPTCD,U)>0 S EC . I +ECPTCD>0 S ECPTCD=$P(ECPTCD,U,2) < diff -y --suppress-common-lines ./VADemo/r1/ECED3.m ./VADemo/r2/r/ECED3.m ;;2.0; EVENT CAPTURE ;**1,4,5,7,10,13,18,23,29,32,47* | ;;2.0; EVENT CAPTURE ;**1,4,5,7,10,13,18,23,29,32**;8 . S ECPTCD=$$CPT^ICPTCOD(ECCPT,ECDT) I +ECPTCD>0 S EC | . S ECPTCD=$$CPT^ICPTCOD(ECCPT) I $P(ECPTCD,U)>0 S EC diff -y --suppress-common-lines ./VADemo/r1/ECEDU.m ./VADemo/r2/r/ECEDU.m ;;2.0; EVENT CAPTURE ;**10,18,23,47,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**10,18,23**;8 May 96 N ECPXD < S ECCPT=$S(ECP["ICPT":+ECP,1:$P($G(^EC(725,+ECP,0)),U | I ECFILE=81 S ECPN=$S($P($G(^ICPT(+ECP,0)),"^",2)]"": S (ECPTCD,ECPXD)="" I ECCPT'="" D < . S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(EC(0),U,3)) I +ECPXD < I ECFILE=81 S ECPN=$S($P(ECPXD,U,3)]"":$P(ECPXD,U,3), < > S ECCPT=$S(ECP["ICPT":+ECP,1:$P($G(^EC(725,+ECP,0)),U > S ECPTCD="" I ECCPT'="" D > . S ECPTCD=$$CPT^ICPTCOD(ECCPT) I $P(ECPTCD,U)>0 S EC N PXUPD,IEN,ECPDX,ECDXS,ECDT | N PXUPD,IEN,ECPDX,ECDXS S EC4=$P($G(^ECH(ECFN,0)),"^",19),(ECDX,ECDXN)="",ECD | S EC4=$P($G(^ECH(ECFN,0)),"^",19),(ECDX,ECDXN)="" diff -y --suppress-common-lines ./VADemo/r1/ECEFPAT.m ./VADemo/r2/r/ECEFPAT.m ;;2.0; EVENT CAPTURE ;**25,32,39,42,47,49,54**;8 May | ;;2.0; EVENT CAPTURE ;**25,32,39,42**;8 May 96 S ^DISV(DUZ,"^VA(200,")=$S(+ECU3>0:ECU3,+ECU2>0:ECU2, < . . S DXCDE=$$ICDDX^ICDCODE(DXSIEN,ECDT) Q:+DXCDE<0 < . . S DXCDE=$P(DXCDE,U,2),ECDXX(DXCDE)=DXSIEN | . . S DXCDE=$$GET1^DIQ(80,DXSIEN,.01,"E"),ECDXX(DXCDE ;File classification AO^IR^SC^EC^MST^HNC^CV | ;File classification AO^IR^SC^EC^MST^HNC . S CLSTR="21^22^24^23^35^39^40",DR="" | . S CLSTR="21^22^24^23^35^39",DR="" .I ECP["ICPT" S ECRRX=$$CPT^ICPTCOD(+ECP,ECDT) I +ECR | .I ECP["ICPT",$D(^ICPT(+ECP,0)) Q diff -y --suppress-common-lines ./VADemo/r1/ECHECK1.m ./VADemo/r2/r/ECHECK1.m ;;2.0; EVENT CAPTURE ;**4,33,47,55,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**4,33**;8 May 96 .I ECPROF=81 S NODE1=$$CPT^ICPTCOD(ECPROPP,$G(ECDT)), | .I ECPROF=81 S NODE1=$G(^ICPT(ECPROPP,0)),ECPRONAM=$S ;The ECACTIV variable allows users to select inactive | ;The ECACTIV variable allows users to select inactiva ;remove inactive procedures < S NODE1=$S(ECPROS[";ICPT(":+ECPROS,1:$P($G(^EC(725,+E < ; ATG-1003-32110 : By VMP < I NODE1'="" S NODE1=$$CPT^ICPTCOD(NODE1,$G(ECDT)) Q:+ < diff -y --suppress-common-lines ./VADemo/r1/ECKILL.m ./VADemo/r2/r/ECKILL.m ;;2.0; EVENT CAPTURE ;**4,5,10,17,18,23,42,54**;8 May | ;;2.0; EVENT CAPTURE ;**4,5,10,17,18,23,42**;8 May 96 PCE K ECAO,ECSC,ECZEC,ECIR,ECINP,ECID,EC4,EC4N,ECDX,ECDXN | PCE K ECAO,ECSC,ECZEC,ECIR,ECINP,ECID,EC4,EC4N,ECDX,ECDXN diff -y --suppress-common-lines ./VADemo/r1/ECMFECS.m ./VADemo/r2/r/ECMFECS.m ;;2.0; EVENT CAPTURE ;**25,33,47,55**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,33**;8 May 96 .; ATG-1003-32110 : by VMP | .I ECP["ICPT",$D(^ICPT(+ECP,0)) Q .I ECP["ICPT" S ECRRX=$$CPT^ICPTCOD(+ECP) I +ECRRX>0 < .S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Synonym" | .S ECERR=1,^TMP($J,"ECMSG",1)="0^Invalid Synonyn" diff -y --suppress-common-lines ./VADemo/r1/ECMLMF.m ./VADemo/r2/r/ECMLMF.m ;;2.0; EVENT CAPTURE ;**5,10,15,13,17,18,23,42,54**;8 | ;;2.0; EVENT CAPTURE ;**5,10,15,13,17,18,23,42**;8 Ma F I="DFN","ORDSEC","IO","CLIN","DX","AO","ENV","IR"," | F I="DFN","ORDSEC","IO","CLIN","DX","AO","ENV","IR"," N ECDSS,I,ECAO,ECELIG,ECEV,ECIR,ECSC,ECNP,ECNPP,ECPCE | N ECDSS,I,ECAO,ECELIG,ECEV,ECIR,ECSC,ECNP,ECNPP,ECPCE ;JAM;10/29/03,Combat Veteran < S ECPTR("CV")=$G(ECPTR("CV")) < S ECCV=$S(ECPTR("CV")="Y":1,ECPTR("CV")="N":0,1:"") < ; < CV ;;17 < diff -y --suppress-common-lines ./VADemo/r1/ECMLMN.m ./VADemo/r2/r/ECMLMN.m ;;2.0; EVENT CAPTURE ;**5,10,15,13,17,18,23,42,47,54* | ;;2.0; EVENT CAPTURE ;**5,10,15,13,17,18,23,42**;8 Ma ; (AO, IR, EC, SC, MST, HNC, CV) | ; (AO, IR, EC, SC, MST, HNC) F ECNODE="I/O","CLIN","CLINNM","DX","DXNM","AO","ENV" | F ECNODE="I/O","CLIN","CLINNM","DX","DXNM","AO","ENV" ; Cnt^DFN^Name^Ord Sect^In/Out^Clin^Clin Nam^DX^DX N | ; Cnt^DFN^Name^Ord Sect^In/Out^Clin^Clin Nam^DX^DX N . I ECCPT'="" S ECCPT=$P($$CPT^ICPTCOD(ECCPT,$P(^TMP( | . I ECCPT'="" S ECCPT=$$GET1^DIQ(81,ECCPT,.01,"E") diff -y --suppress-common-lines ./VADemo/r1/ECMLMP.m ./VADemo/r2/r/ECMLMP.m ;;2.0; EVENT CAPTURE ;**5,18,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5,18**;8 May 96 I ECCPT'="" S ECCPT=$P($$CPT^ICPTCOD(ECCPT,ECPD),U,2) | I ECCPT'="" S ECCPT=$$GET1^DIQ(81,ECCPT,.01,"E") diff -y --suppress-common-lines ./VADemo/r1/ECMUTL1.m ./VADemo/r2/r/ECMUTL1.m ;;2.0; EVENT CAPTURE ;**5,10,15,13,17,23,41,42,50,54* | ;;2.0; EVENT CAPTURE ;**5,10,15,13,17,23,41,42**;8 Ma .. ;NOIS MWV-0603-21781: line below changed by VMP. | .. W !!,"WARNING ",VADM(7),!! .. W !!,"WARNING "_"[PATIENT DIED ON "_$P(VADM(6),U,2 < ; ECPCE("IR") = ionizing radiation indicator | ; ECPCE("IR") = ionizing radiation indicator ; ECPCE("HNC") = head/neck cancer indicator (Y/N) | ; ECPCE("HNC") = Head/Neck Cancer indicator (Y/N) ; ECPCE("CV") = combat veteran indicator (Y/N < S ECPCE("CV")="" < N ECFLG,ECCLFLDS,ECCLVAR,ECX,ECAO,ECIR,ECMST,ECMST,EC | N ECFLG,ECCLFLDS,ECCLVAR,ECX,ECAO,ECIR,ECMST,ECMST,EC N ECMDT,ECY,ECMD,ECDT < S (ECAO,ECIR,ECSC,ECZEC,ECX,ECMST,ECHNC,ECCV)="",ECY= | S (ECAO,ECIR,ECSC,ECZEC,ECX,ECMST,ECHNC)="" F S ECY=$O(^TMP("ECMPIDX",$J,ECY)) Q:'ECY S ECMD=^( < .S ECMDT($P(ECMD,U,2))="" < S ECDT=$O(ECMDT(0)) ;use earliest date to evaluate cl < F ECCLVAR="ECAO","ECIR","ECZEC","ECSC","ECMST","ECHNC | F ECCLVAR="ECAO","ECIR","ECZEC","ECSC","ECMST","ECHNC diff -y --suppress-common-lines ./VADemo/r1/ECMUTL.m ./VADemo/r2/r/ECMUTL.m ;;2.0; EVENT CAPTURE ;**5,10,18,33,47,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5,10,18,33**;8 May 96 N ECX,ECMOD,ECMODS,ECCPT,ECDT | N ECX,ECMOD,ECMODS,ECCPT S ECDT=$O(^TMP("ECPRDT",$J,0)) < . S ECMODF=$$ASKMOD^ECUTL(ECCPT,ECMODS,ECDT,.ECMOD,.E | . S ECMODF=$$ASKMOD^ECUTL(ECCPT,ECMODS,DT,.ECMOD,.ECE diff -y --suppress-common-lines ./VADemo/r1/ECMXP1.m ./VADemo/r2/r/ECMXP1.m ECMXP1 ; ;08/02/04 | ECMXP1 ; ;12/09/02 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(8)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(7)=% S I $D(^("P")) S %Z=^("P") S %=$P(%Z,U,3) S:%]"" DE(1)= | I $D(^("P")) S %Z=^("P") S %=$P(%Z,U,3) S:%]"" DE(1)= 7 S DW="P;11",DV="S",DU="",DLB="COMBAT VETERAN",DIFLD=4 | 7 S DW="0;19",DV="*P44'",DU="",DLB="ASSOCIATED CLINIC", S DU="Y:YES;N:NO;U:UNKNOWN;" < S X=$G(ECPTR("CV")) < S Y=X < S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ < G RD:X="@",Z < X7 Q < 8 S DW="0;19",DV="*P44'",DU="",DLB="ASSOCIATED CLINIC", < X8 Q | X7 Q 9 S DW="0;20",DV="P40.7'",DU="",DLB="DSS ID",DIFLD=27 | 8 S DW="0;20",DV="P40.7'",DU="",DLB="DSS ID",DIFLD=27 X9 Q | X8 Q 10 S DW="0;22",DV="RS",DU="",DLB="IN/OUTPATIENT",DIFLD=2 | 9 S DW="0;22",DV="RS",DU="",DLB="IN/OUTPATIENT",DIFLD=2 X10 Q | X9 Q 11 S DW="0;23",DV="*P720.5'",DU="",DLB="PROCEDURE REASON | 10 S DW="0;23",DV="*P720.5'",DU="",DLB="PROCEDURE REASON X11 Q | X10 Q 12 G 0^DIE17 | 11 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/ECMXPC.m ./VADemo/r2/r/ECMXPC.m ECMXPC ; GENERATED FROM 'EC FILE PCE NODE' INPUT TEMPLATE(#1 | ECMXPC ; GENERATED FROM 'EC FILE PCE NODE' INPUT TEMPLATE(#1 S X=X_"~"_ECAO_"~"_ECIR_"~"_ECEV_"~"_ECSC_"~"_$S(ECNP | S X=X_"~"_ECAO_"~"_ECIR_"~"_ECEV_"~"_ECSC_"~"_$S(ECNP diff -y --suppress-common-lines ./VADemo/r1/ECMXP.m ./VADemo/r2/r/ECMXP.m ECMXP ; GENERATED FROM 'EC CREATE PATIENT ENTRY' INPUT TEMP | ECMXP ; GENERATED FROM 'EC CREATE PATIENT ENTRY' INPUT TEMP C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q C2S S X="" G:DG(DQ)=X C2F1 K DB | C2S S X="" Q:DG(DQ)=X K DB C2F1 Q | Q C3S S X="" G:DG(DQ)=X C3F1 K DB | C3S S X="" Q:DG(DQ)=X K DB C3F1 Q | Q C6S S X="" G:DG(DQ)=X C6F1 K DB | C6S S X="" Q:DG(DQ)=X K DB C6F1 Q | Q 16 S DW="P;2",DV="R*P80'X",DU="",DLB="PRIMARY ICD-9 CODE | 16 S DW="P;2",DV="R*P80'",DU="",DLB="PRIMARY ICD-9 CODE" Only in ./VADemo/r1/: ECNTPCE.m diff -y --suppress-common-lines ./VADemo/r1/ECOSSUM.m ./VADemo/r2/r/ECOSSUM.m ;;2.0; EVENT CAPTURE ;**5,8,18,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5,8,18**;8 May 96 I $D(ECGUI) D EXIT Q < N NLOC,NUNIT,JJ,ECPXD | N NLOC,NUNIT,JJ ..S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)), | ..I ECFILE=81 S ECPN=$S($P($G(^ICPT(+ECP,0)),"^",2)]" ..I ECCPT'="" D < ...S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(EC,"^",3)),ECCPT=$P < ..I ECFILE=81 S ECPN=$S($P(ECPXD,"^",3)]"":$P(ECPXD," < > ..S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)), > ..I ECCPT'="" D > ...S ECCPT=$$GET1^DIQ(81,ECCPT,.01,"E") D:'$D(ECGUI) ^%ZISC | D ^%ZISC diff -y --suppress-common-lines ./VADemo/r1/ECPAT.m ./VADemo/r2/r/ECPAT.m ;;2.0; EVENT CAPTURE ;**5,18,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5,18**;8 May 96 N ECPXD < S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)),"^ | S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)),"^ . S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(ECEC,"^",3)),ECCPT=$ | . S ECCPT=$$GET1^DIQ(81,ECCPT,.01,"E") I ECFILE=81 S ECPN=$S($P(ECPXD,"^",3)]"":$P(ECPXD,"^" | I ECFILE=81 S ECPN=$S($P($G(^ICPT(+ECP,0)),"^",2)]"": END I $D(ECGUI) D ^ECKILL Q | END W ! I $D(ECOUT),'ECOUT D W ! I $D(ECOUT),'ECOUT D < diff -y --suppress-common-lines ./VADemo/r1/ECPCER.m ./VADemo/r2/r/ECPCER.m ;;2.0; EVENT CAPTURE ;**4,18,23,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**4,18,23**;8 May 96 END I $D(ECGUI) D ^ECKILL Q | END W ! I $E(IOST,1,2)="C-" W !!,"Press to continue W ! I $E(IOST,1,2)="C-" W !!,"Press to continue < S ECPS=$$CPT^ICPTCOD(ECCPT,$P(ECEC,"~")),ECPS=$S(+ECP | S ECPS=$S($P($G(^ICPT(ECCPT,0)),"^",2)]"":$P(^(0),"^" S ECDXN=$P($$ICDDX^ICDCODE(ECDX,$P(ECEC,"~")),U,2) S: | S ECDXN=$S($P($G(^ICD9(ECDX,0)),"^")]"":$P(^(0),"^"), . S ECDXSN=$P($$ICDDX^ICDCODE(DXSIEN,$P(ECEC,"~")),"^ | . S ECDXSN=$$GET1^DIQ(80,DXSIEN,.01) I ECDXSN="" Q . S MODESC=$$MODP^ICPTMOD(ECCPT,MOD,"E",$P(ECEC,"~")) | . S MODESC=$$MODP^ICPTMOD(ECCPT,MOD,"E") I +MODESC'>0 diff -y --suppress-common-lines ./VADemo/r1/ECPCEU.m ./VADemo/r2/r/ECPCEU.m ;;2.0; EVENT CAPTURE ;**4,5,7,10,17,18,23,42,54**;8 M | ;;2.0; EVENT CAPTURE ;**4,5,7,10,17,18,23,42**;8 May K DA,DIE,DR,EC4,EC725,ECAO,ECCPT,ECDT,ECDX,ECHL,ECID, | K DA,DIE,DR,EC4,EC725,ECAO,ECCPT,ECDT,ECDX,ECHL,ECID, S ECCPT=$P(ECNODE,"~",10),ECDX=$P(ECNODE,"~",11),ECAO | S ECCPT=$P(ECNODE,"~",10),ECDX=$P(ECNODE,"~",11),ECAO S ECHNC=$P(ECNODE,"~",19),ECCV=$P(ECNODE,"~",20) < S ^TMP("ECPXAPI",$J,"ENCOUNTER",1,"CV")=ECCV < K DA,D0,DIE,DR,EC725,ECAO,ECCPT,ECDT,ECDX,ECHL,ECID,E | K DA,D0,DIE,DR,EC725,ECAO,ECCPT,ECDT,ECDX,ECHL,ECID,E diff -y --suppress-common-lines ./VADemo/r1/ECPROV2.m ./VADemo/r2/r/ECPROV2.m ;;2.0; EVENT CAPTURE ;**5,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5**;8 May 96 N ECPRV < S ECPRV=$S(ECD="SOME":1,ECD="ALL":2,1:0) D ^ECPROV3 | I ECD="SOME" D ^ECPROV3 K ^TMP($J) G:$D(ZTQUEUED) END K ^TMP($J) I $D(ECGUI) D ^ECKILL Q | I ECD="ALL" D ^ECPROV4 K ^TMP($J) G:$D(ZTQUEUED) END G:$D(ZTQUEUED) END | D ^ECPROV5 K ^TMP($J) G:$D(ZTQUEUED) END diff -y --suppress-common-lines ./VADemo/r1/ECPROV3.m ./VADemo/r2/r/ECPROV3.m ;;2.0; EVENT CAPTURE ;**5,8,18,29,47,56,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5,8,18,29**;8 May 96 ;JAM/3/7/03, This routine now combines ECPROV3, ECPRO < ; < I ECL D D LOC,PRINT Q | I ECL D UNIT,LOC,PRINT Q .I ECPRV=1 D UNIT Q | S ECL=0 F I=0:0 S ECL=$O(^ECH("ADT",ECL)) Q:'ECL S E .I 'ECPRV S ECC=+$P(^ECD(ECD,0),U,11) Q | PRINT S (ECLN,ECPN,ECDN)=0,ECCN="" F I=0:0 S ECLN=$O(^TMP($ S ECL=0 D < .F I=0:0 S ECL=$O(^ECH("ADT",ECL)) Q:'ECL D < ..S ECLN=$P(^DIC(4,ECL,0),"^") I ECPRV D UNIT < ..I 'ECPRV S ECC=+$P(^ECD(ECD,0),U,11) < ..D LOC < PRINT ;Changes below were made by VMP to correct NOIS ATG-1 < S (ECLN,ECPN)=0,ECCN="" < F I=0:0 S ECLN=$O(^TMP($J,ECLN)) Q:ECLN=""!(ECOUT)!(E < .I 'ECPRV D CATS Q < . S ECDN="" D NOUNIT F I=0:0 S ECDN=$O(^TMP($J,ECLN,E < W !,?3,ECCN S ECPN=0,(ECPRSN,ECPI)="" | W !,?3,ECCN S ECPN=0,ECPRSN="" > .S ECPNAM=$S($P(ECPN,"~",3)="E":$P($G(^EC(725,+$P(ECP .I ECCPT'="" D | .I ECCPT'="" S ECCPT=$$GET1^DIQ(81,ECCPT,.01,"E") ..;Changes made by VMP to correct NOIS ATG-1003-32545 < ..;use end date/date range to get CPT description; CT < ..S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")),ECCPT=$P(E < .S ECPNAM=$S($P(ECPN,"~",3)="E":$P($G(^EC(725,+$P(ECP < ..;used end date to get description,CTD project | ..S MOD=$$GET1^DIQ(81.3,IEN,.01,"E") I MOD="" Q ..S MODI=$$MOD^ICPTMOD(IEN,"I",$P(ECED,".")) | ..S MODESC=$$GET1^DIQ(81.3,IEN,.02,"E") I MODESC="" S ..S MOD=$P(MODI,"^",2) I MOD="" K MODI Q < ..S MODESC=$P(MODI,"^",3) I MODESC="" S MODESC="UNKNO < .K MODESC,MOD,IEN,MODAMT,MODI | .K MODESC,MOD,IEN,MODAMT F I=0:0 S ECDFN=$O(^ECH("ADT",ECL,ECDFN)) Q:'ECDFN D | F I=0:0 S ECDFN=$O(^ECH("ADT",ECL,ECDFN)) Q:'ECDFN S .I ECPRV D GECD Q < .D GMM < Q < GECD S ECD=0 F I=0:0 S ECD=$O(^ECH("ADT",ECL,ECDFN,ECD)) Q < Q < GMM S MM=ECSD F I=0:0 S MM=$O(^ECH("ADT",ECL,ECDFN,ECD,MM < S ECEC=^ECH(+ECFN,0),ECV=+$P(ECEC,"^",10),ECC=+$P(ECE | S ECEC=^ECH(+ECFN,0),ECV=+$P(ECEC,"^",10),ECC=+$P(ECE S ECP=$P(ECEC,"^",9),ECU=+$P(ECEC,"^",11) < S ECCN=$S($P($G(^EC(726,ECC,0)),"^")]"":$P(^(0),"^"), < S ECD=+$P(ECEC,"^",7) | S ECD=+$P(ECEC,"^",7) I '$D(ECDU(ECD)) Q I ECPRV=1 Q:'$D(ECDU(ECD)) S ECDN=ECDU(ECD) | S ECDN=ECDU(ECD) I ECPRV=2 S ECDN=$S($P($G(^ECD(ECD,0)),"^")]"":$P(^(0 | S ECPSY=+$O(^ECJ("AP",ECL,ECD,ECC,ECP,"")) S ECUN=$S($P($G(^VA(200,ECU,0)),"^")]"":$P(^(0),"^"), < S ECPSY=+$O(^ECJ("AP",ECL,ECD,ECC,ECP,"")),ECPN="" < I ECFILE=81 S ECPN=$P($$CPT^ICPTCOD(+ECP,$P(ECED,".") | I ECFILE="UNKNOWN" S ECPN="UNKNOWN" I ECFILE=725 S ECPN=$P($G(^EC(725,+ECP,0)),"^") | I ECFILE=81 S ECPN=$S($P($G(^ICPT(+ECP,0)),"^",2)]"": I ECFILE="UNKNOWN"!(ECPN="") S ECPN="UNKNOWN" | I ECFILE=725 S ECPN=$S($P($G(^EC(725,+ECP,0)),"^")]"" ;Changes made by VMP to correct NOIS SDC-1003-60397 < > S ECUN=$S($P($G(^VA(200,ECU,0)),"^")]"":$P(^(0),"^"), W !!,"Location: "_ECLN,! W:ECDN]"" "DSS Unit: "_ECDN | W !!,"Location: "_ECLN,! W:ECDN]"" "DSS Unit: "_ECDN I ECPRV,$D(ECUSER) W !!,ECUN,!,ECCN < Only in ./VADemo/r2/r/: ECPROV4.m Only in ./VADemo/r2/r/: ECPROV5.m diff -y --suppress-common-lines ./VADemo/r1/ECPRSUM1.m ./VADemo/r2/r/ECPRSUM1.m ;;2.0; EVENT CAPTURE ;**5,18,33,47,62,63,61**;8 May 9 | ;;2.0; EVENT CAPTURE ;**5,18,33**;8 May 96 N ECPG,ECGT,EC,ECCAT,ECPXD,MODI | N ECPG,ECGT,EC,ECCAT .S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0))," | .I ECFILE=81 S ECPN=$S($P($G(^ICPT(+ECP,0)),"^",2)]"" .I ECCPT'="" D < ..S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")),ECCPT=$P( < .I ECFILE=81 S ECPN=$S($P(ECPXD,"^",3)]"":$P(ECPXD,"^ < > .S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0))," > .I ECCPT'="" D > ..S ECCPT=$$GET1^DIQ(81,ECCPT,.01,"E") > ..I ECCPT'="" S ECCPT=ECCPT_" " .S PRO=ECCPT_ECPN I PRO]"" S V=+$P(EC,"^",10) D | .S PRO=ECPN I PRO]"" S V=+$P(EC,"^",10) D ....S MODI=$$MOD^ICPTMOD(IEN,"I",$P(ECED,".")) | ....S MOD=$$GET1^DIQ(81.3,IEN,.01,"E") I MOD="" Q ....S MOD=$P(MODI,U,2) I MOD="" Q | ....S MODESC=$$GET1^DIQ(81.3,IEN,.02,"E") I MODESC="" ....S MODESC=$P(MODI,U,3) I MODESC="" S MODESC="UNKN < K ^TMP($J) Q:$D(ECGUI) | K ^TMP($J) diff -y --suppress-common-lines ./VADemo/r1/ECRDSSU.m ./VADemo/r2/r/ECRDSSU.m ;;2.0; EVENT CAPTURE ;**5,8,10,14,18,47,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5,8,10,14,18**;8 May 96 I $D(ECGUI) G STRPTQ < ; | ; N ECCPT,ECPI | N ECCPT . S ECPI="" | . S ECPNAM=$S($P(ECPR,";",2)="E":$P($G(^EC(725,+$P(EC . I ECCPT'="" S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECENDDT," | . I ECCPT'="" S ECCPT=$$GET1^DIQ(81,ECCPT,.01,"E") . S ECPNAM=$S($P(ECPR,";",2)="E":$P($G(^EC(725,+$P(EC < N MOD,IEN,MODESC,MODI S IEN="" | N MOD,IEN,MODESC S IEN="" . S MODI=$$MOD^ICPTMOD(IEN,"I",$P(ECENDDT,".")) | . S MOD=$$GET1^DIQ(81.3,IEN,.01,"E") I MOD="" Q . S MOD=$P(MODI,"^",2) I MOD="" Q | . S MODESC=$$GET1^DIQ(81.3,IEN,.02,"E") I MODESC="" S . S MODESC=$P(MODI,"^",3) I MODESC="" S MODESC="Unkno < diff -y --suppress-common-lines ./VADemo/r1/ECRPCLS.m ./VADemo/r2/r/ECRPCLS.m ;;2.0; EVENT CAPTURE ;**5,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5**;8 May 96 I $D(ECGUI) D EXIT Q < D:'$D(ECGUI) ^%ZISC | D ^%ZISC diff -y --suppress-common-lines ./VADemo/r1/ECRPRSN.m ./VADemo/r2/r/ECRPRSN.m ;;2.0; EVENT CAPTURE ;**5,18,47,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**5,18**;8 May 96 W ! S JJ=$$ASKLOC^ECRUTL I 'JJ G EXIT | W ! W ! S JJ=$$ASKDSS^ECRUTL I 'JJ G EXIT | S JJ=$$ASKLOC^ECRUTL W ! S JJ=$$ASKREAS() I 'JJ G EXIT | I 'JJ G EXIT > W ! > S JJ=$$ASKDSS^ECRUTL > I 'JJ G EXIT > W ! > S JJ=$$ASKREAS() > I 'JJ G EXIT W ! D DEVICE I POP G EXIT | W ! > D DEVICE > I POP G EXIT D START,HOME^%ZIS | D START > D HOME^%ZIS > ; U IO D PRINT Q:$D(ECGUI) | U IO D PRINT > ; > ; > ; W ! K IOP,ZTSK S %ZIS="QM" D ^%ZIS | W ! > K IOP,ZTSK S %ZIS="QM" D ^%ZIS ..S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2),ECPI="" | ..S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2) ..S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(725,+ECP,0)), < ..I ECCPT'="" D < ...S ECPI=$$CPT^ICPTCOD(+ECP,$P(ECED,".")),ECCPT=$P(E < ..I ECFILE=81 S ECPN=$S($P(ECPI,"^",3)]"":$P(ECPI,"^" | ..I ECFILE=81 S ECPN=$S($P($G(^ICPT(+ECP,0)),"^",2)]" ..Q:ECPN="" | ..Q:ECPN="" S ECCPT=$S(ECFILE=81:+ECP,1:$P($G(^EC(72 > ..I ECCPT'="" D > ...S ECCPT=$$GET1^DIQ(81,ECCPT,.01,"E") I ECCPT'="" S > ; > ; > ; N MOD,I,MODESC,IEN,MODI | N MOD,I,MODESC,IEN . S MODI=$$MOD^ICPTMOD(IEN,"E",$P(ECED,".")),MOD=$P(M | . S MOD=$$GET1^DIQ(81.3,IEN,.01,"E") I MOD="" Q . S MODESC=$P(MODI,"^",3) I MODESC="UNKNOWN" Q | . S MODESC=$$GET1^DIQ(81.3,IEN,.02,"E") I MODESC="UNK > ; D ^ECKILL D:'$D(ECGUI) ^%ZISC | D ^ECKILL K ^TMP("ECREAS",$J) K JJ,X,Y,ZTSK,IO("Q"),DIR,DIRUT,D | D ^%ZISC K ECED,ECLOOP,ECLOC,ECDSSU,ECLINK,ASK,DIC | K ^TMP("ECREAS",$J) > K JJ,X,Y,ZTSK,IO("Q"),DIR,DIRUT,DTOUT,DUOUT,ECSD,ECED diff -y --suppress-common-lines ./VADemo/r1/ECRRPC.m ./VADemo/r2/r/ECRRPC.m ;;2.0; EVENT CAPTURE ;**25,47,61**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25**;8 May 96 N HLPDA,HND,ECSTR,ECFILER,ECERR,ECDIRY,ECUFILE,ECGUI | N HLPDA,HND,ECSTR,ECFILER,ECERR,ECDIRY,ECUFILE S ECERR=0,ECGUI=1 D PARSE,CHKDT I ECERR Q | S ECERR=0 D PARSE,CHKDT I ECERR Q ECNTPCE ;;Records Failing Transmission to PCE Report;ECNTPCE^ < diff -y --suppress-common-lines ./VADemo/r1/ECRRPT1.m ./VADemo/r2/r/ECRRPT1.m ;;2.0; EVENT CAPTURE ;**25,32,33,61**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,32,33**;8 May 96 ECNTPCE ;ECS Records Failing Transmission to PCE < ; Variables passed in < ; ECSD - Start Date or Report < ; ECED - End Date or Report < ; < ; Variable return < ; ^TMP($J,"ECRPT",n)=report output or to print < N ECV,ECDATE,ECROU,ECDESC < S ECV="ECSD^ECED" D REQCHK^ECRRPT(ECV) I ECERR Q < D DATECHK^ECRRPT(.ECSD,.ECED) < S ECSD=ECSD-.0001,ECED=ECED+.9999 < I ECPTYP="P" D Q < . S ECV="ECSD^ECED",ECROU="START^ECNTPCE" < . S ECDESC="ECS Records Failing Transmission to PCE R < . D QUEUE^ECRRPT < D START^ECNTPCE < Q < diff -y --suppress-common-lines ./VADemo/r1/ECRRPT.m ./VADemo/r2/r/ECRRPT.m ;;2.0; EVENT CAPTURE ;**25,32,41,56,61**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,32,41**;8 May 96 > S ECSD=ECSD-.0001,ECED=ECED+.9999 . ;The line below was changed by VMP for NOIS ANN-100 | . S DIC=4,DIC(0)="QNMZX",X=ECL D ^DIC D:Y<0 Q:Y<0 S . S DIC=4,DIC(0)="QNZX",X=ECL D ^DIC D:Y<0 Q:Y<0 S < diff -y --suppress-common-lines ./VADemo/r1/ECSCR.m ./VADemo/r2/r/ECSCR.m ;;2.0; EVENT CAPTURE ;**1,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**1**;8 May 96 S ECPC=$S($E($P(ECP,";",2),1)="E":1,1:3) | S ECPC=$S($E($P(ECP,";",2),1)="E":1,1:2) S ECPN=$S(ECPC="E":$P(@(ECPF_+ECP_",0)"),U,ECPC),1:$P | S ECPN=$P(@(ECPF_+ECP_",0)"),U,ECPC) diff -y --suppress-common-lines ./VADemo/r1/ECSCRN.m ./VADemo/r2/r/ECSCRN.m ;;2.0; EVENT CAPTURE ;**4,5,33,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**4,5,33**;8 May 96 .I '$P($$CPT^ICPTCOD(+Y),"^",7) W !,"Selected procedu | .I $P($G(ECZERO),U,4) W !,"Selected procedure is inac ; < diff -y --suppress-common-lines ./VADemo/r1/ECSUM1.m ./VADemo/r2/r/ECSUM1.m ;;2.0; EVENT CAPTURE ;**4,19,23,33,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**4,19,23,33**;8 May 96 I ECFILE=81 S ECPI=$$CPT^ICPTCOD(+ECP) D | I ECFILE=81 S ECPN=$S($P($G(^ICPT(+ECP,0)),"^",2)]"": .S ECPN=$S($P(ECPI,"^",3)]"":$P(ECPI,"^",3),1:"UNKNOW < diff -y --suppress-common-lines ./VADemo/r1/ECSUM.m ./VADemo/r2/r/ECSUM.m ;;2.0; EVENT CAPTURE ;**4,19,33,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**4,19,33**;8 May 96 > S ^TMP("JEN",$J,"IO")=IO ;REMOVE LINE D ^ECKILL Q:$D(ECGUI) W @IOF D ^%ZISC S:$D(ZTQUEUED) | D ^ECKILL W @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" diff -y --suppress-common-lines ./VADemo/r1/ECU1RPC.m ./VADemo/r2/r/ECU1RPC.m ;;2.0; EVENT CAPTURE ;**25,30,49,61**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,30**;8 May 96 . I DATA["Override Deceased" S ECDECPAT=+DATA Q < . I DATA["Override Duplicate" S ECFILDUP=+DATA < S ^TMP($J,"COLS","ECDECPAT")=ECDECPAT < S ^TMP($J,"COLS","ECFILDUP")=ECFILDUP < S ECENCV=$P(ECDATA,U,ECENCPC),ECENCV=$TR(ECENCV," "," | S ECENCV=$P(ECDATA,U,ECENCPC) S ECDECPAT=$G(^TMP($J,"COLS","ECDECPAT")) < ; < S ECFILDUP=$G(^TMP($J,"COLS","ECFILDUP")) < ; < diff -y --suppress-common-lines ./VADemo/r1/ECUERPC1.m ./VADemo/r2/r/ECUERPC1.m ;;2.0; EVENT CAPTURE ;**25,33,42,46,47,54**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,33,42**;8 May 96 > ; > ; > ; . S DXSD=$$ICDDX^ICDCODE(DXSIEN,$P($G(^ECH(ECIEN,0)), | . S DXSD=$$GET1^DIQ(80,DXSIEN,.01,"I")_" "_$$GET1^D . S DXSD=$P(DXSD,U,2)_" "_$P(DXSD,U,4) < > ; . S MODS=$$MOD^ICPTMOD(MODIEN,"I",$P($G(^ECH(ECIEN,0) | . S MODS=$$MOD^ICPTMOD(MODIEN,"I") I +MODS<0 Q > ; ; INPUTS ECIEN - Event Capture Patient ien | ;INPUTS ECIEN - Event Capture Patient ien ; OUTPUTS RESULTS - Array of procedure modifiers | ; ; 721 IEN^agent orange^radiation exposure^service co | ;OUTPUTS RESULTS - Array of procedure modifiers ; contaminants^military sexual trauma^eligibility co | ; 721 IEN^agent orange^radiation exposure^se ; description^head/neck cancer^combat veteran | ; environmental contaminants^military sexual > ; eligibility code #8^eligibility descriptio N CLA,ELIG,ELCOD,ECAO,ECIR,ECEC,ECSC,ECMST,STR,ECHNC, | N CLA,ELIG,ELCOD,CLA,ECAO,ECIR,ECEC,ECSC,ECMST,STR,EC S ELIG=$P($G(^ECH(ECIEN,"PCE")),"~",17),ELCOD="",CLA= | S ELIG=$P($G(^ECH(ECIEN,"PCE")),"~",17),ELCOD="" S ECAO=$P(CLA,U,3),ECIR=$P(CLA,U,4),ECEC=$P(CLA,U,5), | S CLA=$G(^ECH(ECIEN,"P")),ECAO=$P(CLA,U,3),ECIR=$P(CL S ECMST=$P(CLA,U,9),ECHNC=$P(CLA,U,10),ECCV=$P(CLA,U, | S ECEC=$P(CLA,U,5),ECSC=$P(CLA,U,6),ECMST=$P(CLA,U,9) S STR=STR_U_ECCV,^TMP($J,"ECLASS",1)=STR,RESULTS=$NA( | S ^TMP($J,"ECLASS",1)=STR,RESULTS=$NA(^TMP($J,"ECLASS > ; ; ^provider #2 IEN^provider #3 IEN < N REAS,PRV2,PRV3,ECX | N REAS,PRV2,PRV3 S ECX=^ECH(ECIEN,0) < S ^TMP($J,"ECOTH",1)=REAS_U_PRV2_U_PRV3_U_$P(ECX,U,15 | S ^TMP($J,"ECOTH",1)=REAS_U_PRV2_U_PRV3 > ; > ; ; 4- SC Condition, 5- Environmental Contamin | ; 4- SC Condition, 5- Environ ; Sexual Trauma 7- Head/Neck Cancer 8- Co | ; 6- Military Sexual Trauma > ; 7- Head/Neck Cancer ; Data after "~" 1- Agent Orange 2- Ionizin | ; Data after "~" 1- Agent Orange 2- Ionizin > ; 3- Environmental Contaminan S ECDFN=$P(ECARY,U),ECD=$P(ECARY,U,2),ECDT=$P(ECARY,U | S ECDFN=$P(ECARY,U),ECD=$P(ECARY,U,2),ECDT=$P(ECARY,U S PATSTAT=$$INOUTPT^ECUTL0(ECDFN,ECDT),RESULTS="^^^^^ | Q:ECDFN="" S (RESULTS,SCDAT)="" I PATSTAT="I" D Q ;added to be consisent w roll-n-s | S PATSTAT=$$INOUTPT^ECUTL0(ECDFN,ECDT),RESULTS="^^^^^ .S RESULTS=PATSTAT_"^"_RESULTS_$S(SCDAT'="":"~"_SCDAT < D CL^SDCO21(ECDFN,ECDT,"",.ECCLARY) F ECX=3,1,2,4,5,6 | D CL^SDCO21(ECDFN,ECDT,"",.ECCLARY) > F ECX=3,1,2,4,5,6 D > ; S IEN=0,STR=1_U_ECDX_U_ECDXN_" "_$P($$ICDDX^ICDCODE | S CNT=1,IEN=0,STR=1_U_ECDX_U_ECDXN_" "_$$GET1^DIQ(8 S CNT=1,^TMP($J,"ECENCDXS",CNT)=STR | S ^TMP($J,"ECENCDXS",CNT)=STR . S CNT=CNT+1,^TMP($J,"ECENCDXS",CNT)=0_U_ECDXS(IEN)_ | . S CNT=CNT+1,^TMP($J,"ECENCDXS",CNT)=0_U_ECDXS(IEN)_ > ; . . . S ECDX=$$ICDDX^ICDCODE(ECDX,DATE) | . . . S ECDX=$$GET1^DIQ(80,ECDX,.01,"I")_" "_$$GET1^ . . . S ECDX=$P(ECDX,U,2)_" "_$P(ECDX,U,4) < diff -y --suppress-common-lines ./VADemo/r1/ECUERPC2.m ./VADemo/r2/r/ECUERPC2.m ;;2.0; EVENT CAPTURE ;**41,39,50**;8 May 96 | ;;2.0; EVENT CAPTURE ;**41,39**;8 May 96 ;NOIS MWV-0603-21781: line below changed by VMP | S DFN=ECDFN D 2^VADPT I +VADM(6) S RESULTS=$P(VADM(6) S DFN=ECDFN D 2^VADPT I +VADM(6) S RESULTS=$P(VADM(6) < diff -y --suppress-common-lines ./VADemo/r1/ECUERPC.m ./VADemo/r2/r/ECUERPC.m ;;2.0; EVENT CAPTURE ;**25,32,33,46,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,32,33**;8 May 96 I ECL'="",ECDUZ="" S ECDUZ=$G(DUZ,U) I ECDUZ="" Q | I ECL'="" S ECDUZ=$G(DUZ,U) I ECDUZ="" Q .I ECL="ALL" S ECL="" < E D | E F S DPT=$O(^VA(200,ECDUZ,"EC",DPT)) Q:'DPT S IEN .I ECL="ALL" S ECL="" < .F S DPT=$O(^VA(200,ECDUZ,"EC",DPT)) Q:'DPT S IEN=D < ; ECDT - Procedure Date < S ECDT=$P(ECARY,U,4) < N ECL,ECD,ECC,ECP,IEN,ASC,ASCNM,MEDSP,MEDSPNM,ECCH | N ECL,ECD,ECC,ECP,IEN,ASC,ASCNM,MEDSP,MEDSPNM ; Provider IEN < N ORS,PRV,PRO | N ORS,PRV K X,Y < . . E S PRO=$$CPT^ICPTCOD($P(PX,";"),PDT) S PX=$P(PR | . . E S PRO=$$CPT^ICPTCOD($P(PX,";")) S PX=$P(PRO,U, . . S:PDX PDXD=$$ICDDX^ICDCODE(PDX,PDT),PDXD=$P(PDXD, | . . S:PDX PDXD=$$GET1^DIQ(80,PDX,.01,"I")_" "_$$GET1^ . . S DATA=DATA_U_$P(NODE,U,10)_U_PRV_U_ORS_U_ASC_U_P | . . S DATA=DATA_U_$P(NODE,U,10)_U_PRV_U_ORS_U_ASC_U_P diff -y --suppress-common-lines ./VADemo/r1/ECUMRPC2.m ./VADemo/r2/r/ECUMRPC2.m ;;2.0; EVENT CAPTURE ;**25,30,42,46,47,49**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,30,42**;8 May 96 ; 3 State Abbreviation | ; 3 State ; 5 Facility Type | N LOC,STAT,CNT,CLOC,ST,NODE,ACT,ECLOC,ELOC ; 6 Station Number < N LOC,STAT,CNT,CLOC,ST,NODE,ACT,ECLOC,ELOC,ECFT,ECSN < . S CNT=CNT+1,ST=$P(NODE,U,2) S:ST'="" ST=$$GET1^DIQ( | . S CNT=CNT+1,ST=$P(NODE,U,2) S:ST'="" ST=$$GET1^DIQ( . S ECFT=$P($G(^DIC(4.1,+$G(^DIC(4,LOC,3)),0)),U) | . S ^TMP($J,"ECLOCATION",CNT)=LOC_U_$P(NODE,U)_U_ST_U . S ECSN=$P($G(^DIC(4,LOC,99)),U) < . S ^TMP($J,"ECLOCATION",CNT)=LOC_U_$P(NODE,U)_U_ST_U < .S ^TMP($J,"ECPXSRCH",CNT)=ECID_U_ECSTR | .S ^TMP($J,"ECPXSRCH",CNT)=ECID_U_ECSTR ;$G(^TMP("EC .D FINDIC(81,"",".01;2","M",CPTSTR,100,"","I $P($$CPT | .D FINDIC(81,"",".01;2","M",CPTSTR,100,"","I '$P(^(0) ; IEN of file 200^Provider Name^occupation^specia < N I,IEN,CNT,FROM,DATE,ECUTN S I=0,CNT=44 ;KEY="PROVI | N I,IEN,CNT,FROM,DATE S I=0,CNT=44 ;KEY="PROVIDER" . . S ECUTN=$$GET^XUA4A72(IEN,DATE) | . . I DATE>0,$$GET^XUA4A72(IEN,DATE)<1 Q . . I DATE>0,ECUTN<1 Q | . . S I=I+1,^TMP($J,"ECFIND",I)=IEN_"^"_FROM . . S I=I+1,^TMP($J,"ECFIND",I)=IEN_"^"_FROM_"^"_$P(E < diff -y --suppress-common-lines ./VADemo/r1/ECUTL1.m ./VADemo/r2/r/ECUTL1.m ;;2.0; EVENT CAPTURE ;**10,13,17,42,54**;8 May 96 | ;;2.0; EVENT CAPTURE ;**10,13,17,42**;8 May 96 D NOW^%DTC S ECVSTDT=$S(+$G(ECDT):ECDT,1:%),ECVST="" | D NOW^%DTC S ECVSTDT=%,ECVST="" .F ECCL="AO","IR","EC","SC","MST","HNC","CV" D | .F ECCL="AO","IR","EC","SC","MST","HNC" D ..S ECCLFLD=$S(ECCL="AO":"Agent Orange",ECCL="IR":"Io | ..S ECCLFLD=$S(ECCL="AO":"Agent Orange",ECCL="IR":"Io ..S ECPIECE=$S(ECCL="AO":3,ECCL="IR":4,ECCL="EC":5,EC | ..S ECPIECE=$S(ECCL="AO":3,ECCL="IR":4,ECCL="EC":5,EC ..F ECCL="SC","CV","AO","IR","EC","MST","HNC" D | ..F ECCL="SC","AO","IR","EC","MST","HNC" D F ECCL="AO","IR","SC","EC","MST","HNC","CV" D | F ECCL="AO","IR","SC","EC","MST","HNC" D .S ECCLFLD=$S(ECCL="AO":21,ECCL="IR":22,ECCL="EC":23, | .S ECCLFLD=$S(ECCL="AO":21,ECCL="IR":22,ECCL="EC":23, .S ECPXB=$S(ECCL="AO":1,ECCL="IR":2,ECCL="EC":4,ECCL= | .S ECPXB=$S(ECCL="AO":1,ECCL="IR":2,ECCL="EC":4,ECCL= ; Classification fields 21,22,23,24,35,39,40 edi | ; Classification fields 21, 22, 23, 24, 35, 39 e . ;- Edit classification fields (AO, IR, EC, SC, MST, | . ;- Edit classification fields (AO, IR, EC, SC, MST, ; EC classification var - ECAO,ECIR,ECZEC,ECSC,E | ; EC classification variables - ECAO,ECIR,ECZEC, S (ECCL,ECAO,ECIR,ECZEC,ECSC,ECMST,ECHNC,ECCV)="" | S (ECCL,ECAO,ECIR,ECZEC,ECSC,ECMST,ECHNC)="" .. ; < .. ;- Combat Veteran < .. S:ECCLFLD=40 ECCV=$P(ECANS(ECCL),"^",2) < ; Classification fields 21,22,23,24,35,39,40 del | ; Classification fields 21,22,23,24,35,39 delete . ;- Delete classification fields (AO, IR, EC, SC, MS | . ;- Delete classification fields (AO, IR, EC, SC, MS . F ECCL=21:1:24,35,39,40 S DR=DR_ECCL_"////@;" | . F ECCL=21:1:24,35,39 S DR=DR_ECCL_"////@;" diff -y --suppress-common-lines ./VADemo/r1/ECUTL2.m ./VADemo/r2/r/ECUTL2.m ;;2.0; EVENT CAPTURE ;**23,33,47,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**23,33**;11 Jan 2000 . S ECDXN=$P($$ICDDX^ICDCODE(ECDX,ECDTX),U,2) | . S ECDXN=$$GET1^DIQ(80,ECDX,.01),ECDXIEN(DA)=ECDXN_U . S ECDXIEN(DA)=ECDXN_U_ECDX,PDXF=1 < ...S DXIEN=$P($G(^ECH(DA,"DX",DXS,0)),U) | . . . S DXIEN=$P($G(^ECH(DA,"DX",DXS,0)),U) ...S DXN=$P($$ICDDX^ICDCODE(DXIEN,ECDTX),U,2) S:DXN'= | . . . S DXN=$$GET1^DIQ(80,DXIEN,.01) S:DXN'="" ECDXS( N Y,X,DEF,DEFX,ECY,DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IC | N Y,X,DEF,DEFX,ECY,DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="FO^^I $$VALSDX^ECUTL2(X)",ICDVDT=$G(ECDT) | S DIR(0)="FO^^I $$VALSDX^ECUTL2(X)" S DIC="^ICD9(",DIC(0)="MEQZ",DIC("S")="I $P($$ICDDX^I | S DIC="^ICD9(",DIC(0)="MEQZ",DIC("S")="I '$P(^(0),U,9 > S DIC("W")="N C,DINAME S:$G(DO(2)) DO(2)=$TR(DO(2),"" DXSHLP ;Help for Diagnoses Code | DXSHLP ;Help for CPT modifiers S DIC="^ICD9(",D="B",DIC(0)="MQEZ",DIC("S")="I $P($$I | S DIC="^ICD9(",D="B",DIC(0)="MQEZ",DIC("S")="I '$P(^( diff -y --suppress-common-lines ./VADemo/r1/ECUTL.m ./VADemo/r2/r/ECUTL.m ;;2.0; EVENT CAPTURE ;**10,18,47,63**;8 May 96 | ;;2.0; EVENT CAPTURE ;**10,18**;8 May 96 S DIC="^ICPT(",DIC(0)="N",X=PROC | S DIC="^ICPT(",DIC(0)="N",X=PROC D ^DIC I +Y=-1 S ECE S DIC("S")="I $P($$CPT^ICPTCOD(+Y,PRDT),""^"",7)" < D ^DIC I +Y=-1 S ECERR=1 G ASKMODQ < S DIC("W")="W "" "" W "" "",$P($$MOD^ICPTMOD(+Y," | S DIC("W")="W "" "" W "" "",$P(^(0),U,2)" S DIC="^DIC(81.3,",DIC("W")="W "" "" W "" "",$P($ | S DIC="^DIC(81.3,",DIC("W")="W "" "" W "" "",$P(^ N MOD,IEN,ECMERR,MODARY,MODESC,SUB,SEQ,ECDT | N MOD,IEN,ECMERR,MODARY,MODESC,SUB,SEQ S ECDT=$P($G(^ECH(ECIEN,0)),U,3) < . S MODESC=$P($$MOD^ICPTMOD(MOD,"E",ECDT),U,3) | . S MODESC=$$GET1^DIQ(81.3,IEN,.02,"E") I MODESC="" S . I MODESC="" S MODESC="Unknown" < diff -y --suppress-common-lines ./VADemo/r1/ECUURPC.m ./VADemo/r2/r/ECUURPC.m ;;2.0; EVENT CAPTURE ;**25,42,49**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,42**;8 May 96 VERSRV(RESULTS,ECARY,VERSION) ; Return server version of < ; minimum GUI client version. < ; < ;Server/client version consist of 4 pieces, namely < ; major version.minor version.release.build (ex. < ; < ;Broker call returns server version of option name < ; RPC: EC GETVERSION < ;INPUTS ECARY - contains the option name < ; VERSION - EC GUI client version ;stay in pa < ; < ;OUTPUTS RESULTS version number OR null ("") < ; current server version^minimum client ver < ; < S ECCLVER=$G(VERSION) < I $G(ECARY)="" Q < N ECLST,ECMINV < S ECMINV="2.0.10.1" ; Minimum version of EC GUI cl < D FIND^DIC(19,"",1,"X",ECARY,1,,,,"ECLST") < I 'ECLST("DILIST",0) S RESULTS="" Q < S RESULTS=ECLST("DILIST","ID",1,1) < S RESULTS=$P(RESULTS,"version ",2)_U_ECMINV < Q < diff -y --suppress-common-lines ./VADemo/r1/ECV1RPC.m ./VADemo/r2/r/ECV1RPC.m ;;2.0; EVENT CAPTURE ;**25,33,49,61**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,33**;8 May 96 ; patient status override flag, ov | ; and patient status override flag ; flag and file duplicate(s) flag. < N ECCLNV,ECPSTATV,ECDECPAT,ECFILDUP | N ECCLNV > N ECPSTATV I '($D(RESULTS(1))) D | I '($G(RESULTS(1))) D diff -y --suppress-common-lines ./VADemo/r1/ECV2RPC.m ./VADemo/r2/r/ECV2RPC.m ;;2.0; EVENT CAPTURE ;**25,30,49**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,30**;8 May 96 I 'ECERRFLG,'ECDECPAT D < . N DFN,VADM S DFN=ECSSNIEN D 2^VADPT I +VADM(6) D < . . S ECERRMSG="WARNING: [PATIENT DIED ON "_$P(VADM(6 < . . S ECCOLERR=ECSSNPC < . . D ERROR < diff -y --suppress-common-lines ./VADemo/r1/ECV3RPC.m ./VADemo/r2/r/ECV3RPC.m ;;2.0; EVENT CAPTURE ;**25,47,49,61**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25**;8 May 96 N ECFOUND,ECPI,ECDT | N ECFOUND S %DT="XST",X=$G(ECENCV,"NOW") D ^%DT S ECDT=+Y < . S ECPI=$P($G(^EC(725,ECPROCV,0)),"^",5) | . S ECFOUND=1 . I ECPI="" S ECFOUND=1 Q < . S ECPI=$$CPT^ICPTCOD(ECPI,ECDT) I +ECPI>0,$P(ECPI," < . S ECPI=$P($G(^EC(725,ECPROCV,0)),"^",5) | . S ECFOUND=1 . I ECPI="" S ECFOUND=1 Q < . S ECPI=$$CPT^ICPTCOD(ECPI,ECDT) I +ECPI>0,$P(ECPI," < I 'ECFOUND S ECPI=$$CPT^ICPTCOD(ECPROCV,ECDT) I +ECPI | I 'ECFOUND,$D(^ICPT("B",ECPROCV)) D . S ECPROCV=$P(ECPI,"^")_";ICPT(" | . S ECPROCV=$O(^ICPT("B",ECPROCV,0))_";ICPT(" I 'ECERRFLG,'ECFILDUP D < .;Check for duplicate uploaded record base on Loc_DSS < .;Date_Procedure < . N ECDUP,ECNAM,ECPNAM,ECI,ECX < . S (ECDA,ECDUP)=0 < . F S ECDA=$O(^ECH("ADT",ECSTAV,ECSSNIEN,ECDSSIEN,EC < . . S ECX=$G(^ECH(ECDA,0)) I ECX="" Q < . . I $P(ECX,U,8)'=ECCATIEN Q < . . I $P(ECX,U,9)'=ECPROCV Q < . . S ECPNAM="",ECDUP=1 < . . F ECI=11,15,17 Q:$P(ECX,U,ECI)="" D < . . . S ECNAM=$$GET1^DIQ(200,$P(ECX,U,ECI),.01,"I") < . . . S ECPNAM=ECPNAM_" "_$P(ECNAM,",")_","_$E($P(ECN < . . S ECERRMSG="**DUPLICATE** " < . . S ECERRMSG=ECERRMSG_" Clinic: "_$$GET1^DIQ(44,$P( < . . S ECERRMSG=ECERRMSG_" Order Sect: "_$$GET1^DIQ(72 < . . S ECERRMSG=ECERRMSG_" Provider: "_ECPNAM < . . S ECNAM=$$GET1^DIQ(200,$P(ECX,U,13),.01,"I") < . . S ECERRMSG=ECERRMSG_" Entered: "_$P(ECNAM,",")_", < . . S ECCOLERR=ECSTAPC ;(???) < . . D ERROR < diff -y --suppress-common-lines ./VADemo/r1/ECV4RPC.m ./VADemo/r2/r/ECV4RPC.m ;;2.0; EVENT CAPTURE ;**25,33,49**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,33**;8 May 96 N ECVOLVN,ECPDT | N ECVOLVN S ECVOLVN=ECVOLV | S ECVOLVN=+ECVOLV I (+ECVOLVN'=ECVOLVN)!(ECVOLVN<1)!(ECVOLVN>99)!(ECVOL | I (ECVOLVN<1!ECVOLVN>99) D S %DT(0)="-NOW",ECENCV=$TR(ECENCV," ","") < S %DT="XST",X=ECENCV D ^%DT S ECPDT=$S(+Y>0:+Y,1:DT) < I 'ECERRFLG,$$GET^XUA4A72(ECPRVIEN,ECPDT)<1 D | I 'ECERRFLG,$P(^VA(200,ECPRVIEN,"USC1",ECPCLASS,0),U, VOL1 ;;Volume must be a whole number from 1 to 99 | VOL1 ;;Volume must be a number from 1 to 99 ENC1 ;;Invalid encounter date/time. Date cannot be in the | ENC1 ;;Invalid encounter date/time diff -y --suppress-common-lines ./VADemo/r1/ECV5RPC.m ./VADemo/r2/r/ECV5RPC.m ;;2.0; EVENT CAPTURE ;**25,30,36,47**;8 May 96 | ;;2.0; EVENT CAPTURE ;**25,30,36**;8 May 96 N ECDT < S %DT="XST",X=$G(ECENCV,"NOW") D ^%DT S ECDT=+Y < . S ECDXIEN=$$ICDDX^ICDCODE(ECDXV,ECDT) | . S ECDXIEN=$O(^ICD9("AB",ECDXV_" ","")) I ECDXIEN'=" . I +ECDXIEN>0,$P(ECDXIEN,"^",10) S ECDXIEN=+ECDXIEN, < Only in ./VADemo/r1/: ECX3049.m Only in ./VADemo/r1/: ECX356D1.m Only in ./VADemo/r1/: ECX356D2.m Only in ./VADemo/r1/: ECX356PT.m Only in ./VADemo/r1/: ECX357PT.m Only in ./VADemo/r1/: ECX3P71.m diff -y --suppress-common-lines ./VADemo/r1/ECX8021.m ./VADemo/r2/r/ECX8021.m ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 12/28/04 | ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8022.m ./VADemo/r2/r/ECX8022.m ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 12/28/04 | ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX802.m ./VADemo/r2/r/ECX802.m ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 12/28 | ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8031.m ./VADemo/r2/r/ECX8031.m ECX8031 ; COMPILED XREF FOR FILE #727.803 ; 10/15/04 | ECX8031 ; COMPILED XREF FOR FILE #727.803 ; 11/12/98 > S X=$P(DIKZ(0),U,1) > I X'="" K ^ECX(727.803,"AINV",-X,DA) diff -y --suppress-common-lines ./VADemo/r1/ECX8032.m ./VADemo/r2/r/ECX8032.m ECX8032 ; COMPILED XREF FOR FILE #727.803 ; 10/15/04 | ECX8032 ; COMPILED XREF FOR FILE #727.803 ; 11/12/98 > S X=$P(DIKZ(0),U,1) > I X'="" S ^ECX(727.803,"AINV",-X,DA)="" diff -y --suppress-common-lines ./VADemo/r1/ECX803.m ./VADemo/r2/r/ECX803.m ECX803 ; DRIVER FOR COMPILED XREFS FOR FILE #727.803 ; 10/15 | ECX803 ; DRIVER FOR COMPILED XREFS FOR FILE #727.803 ; 11/12 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/ECX8041.m ./VADemo/r2/r/ECX8041.m ECX8041 ; COMPILED XREF FOR FILE #727.804 ; 10/15/04 | ECX8041 ; COMPILED XREF FOR FILE #727.804 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8042.m ./VADemo/r2/r/ECX8042.m ECX8042 ; COMPILED XREF FOR FILE #727.804 ; 10/15/04 | ECX8042 ; COMPILED XREF FOR FILE #727.804 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX804.m ./VADemo/r2/r/ECX804.m ECX804 ; DRIVER FOR COMPILED XREFS FOR FILE #727.804 ; 10/15 | ECX804 ; DRIVER FOR COMPILED XREFS FOR FILE #727.804 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8051.m ./VADemo/r2/r/ECX8051.m ECX8051 ; COMPILED XREF FOR FILE #727.805 ; 12/28/04 | ECX8051 ; COMPILED XREF FOR FILE #727.805 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8052.m ./VADemo/r2/r/ECX8052.m ECX8052 ; COMPILED XREF FOR FILE #727.805 ; 12/28/04 | ECX8052 ; COMPILED XREF FOR FILE #727.805 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX805.m ./VADemo/r2/r/ECX805.m ECX805 ; DRIVER FOR COMPILED XREFS FOR FILE #727.805 ; 12/28 | ECX805 ; DRIVER FOR COMPILED XREFS FOR FILE #727.805 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8061.m ./VADemo/r2/r/ECX8061.m ECX8061 ; COMPILED XREF FOR FILE #727.806 ; 10/15/04 | ECX8061 ; COMPILED XREF FOR FILE #727.806 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8062.m ./VADemo/r2/r/ECX8062.m ECX8062 ; COMPILED XREF FOR FILE #727.806 ; 10/15/04 | ECX8062 ; COMPILED XREF FOR FILE #727.806 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX806.m ./VADemo/r2/r/ECX806.m ECX806 ; DRIVER FOR COMPILED XREFS FOR FILE #727.806 ; 10/15 | ECX806 ; DRIVER FOR COMPILED XREFS FOR FILE #727.806 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8081.m ./VADemo/r2/r/ECX8081.m ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 10/15/04 | ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8082.m ./VADemo/r2/r/ECX8082.m ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 10/15/04 | ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX808.m ./VADemo/r2/r/ECX808.m ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 10/15 | ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8091.m ./VADemo/r2/r/ECX8091.m ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 12/28/04 | ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8092.m ./VADemo/r2/r/ECX8092.m ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 12/28/04 | ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX809.m ./VADemo/r2/r/ECX809.m ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 12/28 | ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8101.m ./VADemo/r2/r/ECX8101.m ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 12/28/04 | ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8102.m ./VADemo/r2/r/ECX8102.m ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 12/28/04 | ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX810.m ./VADemo/r2/r/ECX810.m ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 12/28/ | ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 02/05/ diff -y --suppress-common-lines ./VADemo/r1/ECX8111.m ./VADemo/r2/r/ECX8111.m ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 12/28/04 | ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8112.m ./VADemo/r2/r/ECX8112.m ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 12/28/04 | ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX811.m ./VADemo/r2/r/ECX811.m ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 12/28 | ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8131.m ./VADemo/r2/r/ECX8131.m ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 12/28/04 | ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8132.m ./VADemo/r2/r/ECX8132.m ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 12/28/04 | ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX813.m ./VADemo/r2/r/ECX813.m ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 12/28 | ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8141.m ./VADemo/r2/r/ECX8141.m ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 12/28/04 | ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8142.m ./VADemo/r2/r/ECX8142.m ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 12/28/04 | ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX814.m ./VADemo/r2/r/ECX814.m ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 12/28 | ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8151.m ./VADemo/r2/r/ECX8151.m ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 12/28/04 | ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8152.m ./VADemo/r2/r/ECX8152.m ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 12/28/04 | ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX815.m ./VADemo/r2/r/ECX815.m ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 12/28 | ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8171.m ./VADemo/r2/r/ECX8171.m ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 10/15/04 | ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8172.m ./VADemo/r2/r/ECX8172.m ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 10/15/04 | ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX817.m ./VADemo/r2/r/ECX817.m ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 10/15 | ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8191.m ./VADemo/r2/r/ECX8191.m ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 12/28/04 | ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8192.m ./VADemo/r2/r/ECX8192.m ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 12/28/04 | ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX819.m ./VADemo/r2/r/ECX819.m ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 12/28 | ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8201.m ./VADemo/r2/r/ECX8201.m ECX8201 ; COMPILED XREF FOR FILE #727.82 ; 10/15/04 | ECX8201 ; COMPILED XREF FOR FILE #727.82 ; 01/12/98 > S X=$P(DIKZ(0),U,1) > I X'="" K ^ECX(727.82,"AINV",-X,DA) S X=$P(DIKZ(0),U,1) < I X'="" K ^ECX(727.82,"AINV",-X,DA) < diff -y --suppress-common-lines ./VADemo/r1/ECX8202.m ./VADemo/r2/r/ECX8202.m ECX8202 ; COMPILED XREF FOR FILE #727.82 ; 10/15/04 | ECX8202 ; COMPILED XREF FOR FILE #727.82 ; 01/12/98 diff -y --suppress-common-lines ./VADemo/r1/ECX820.m ./VADemo/r2/r/ECX820.m ECX820 ; DRIVER FOR COMPILED XREFS FOR FILE #727.82 ; 10/15/ | ECX820 ; DRIVER FOR COMPILED XREFS FOR FILE #727.82 ; 01/12/ N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/ECX8211.m ./VADemo/r2/r/ECX8211.m ECX8211 ; COMPILED XREF FOR FILE #727.821 ; 10/15/04 | ECX8211 ; COMPILED XREF FOR FILE #727.821 ; 01/12/98 > S X=$P(DIKZ(0),U,1) > I X'="" K ^ECX(727.821,"AINV",-X,DA) S X=$P(DIKZ(0),U,1) < I X'="" K ^ECX(727.821,"AINV",-X,DA) < diff -y --suppress-common-lines ./VADemo/r1/ECX8212.m ./VADemo/r2/r/ECX8212.m ECX8212 ; COMPILED XREF FOR FILE #727.821 ; 10/15/04 | ECX8212 ; COMPILED XREF FOR FILE #727.821 ; 01/12/98 diff -y --suppress-common-lines ./VADemo/r1/ECX821.m ./VADemo/r2/r/ECX821.m ECX821 ; DRIVER FOR COMPILED XREFS FOR FILE #727.821 ; 10/15 | ECX821 ; DRIVER FOR COMPILED XREFS FOR FILE #727.821 ; 01/12 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/ECX8221.m ./VADemo/r2/r/ECX8221.m ECX8221 ; COMPILED XREF FOR FILE #727.822 ; 10/15/04 | ECX8221 ; COMPILED XREF FOR FILE #727.822 ; 01/12/98 > S X=$P(DIKZ(0),U,1) > I X'="" K ^ECX(727.822,"AINV",-X,DA) S X=$P(DIKZ(0),U,1) < I X'="" K ^ECX(727.822,"AINV",-X,DA) < diff -y --suppress-common-lines ./VADemo/r1/ECX8222.m ./VADemo/r2/r/ECX8222.m ECX8222 ; COMPILED XREF FOR FILE #727.822 ; 10/15/04 | ECX8222 ; COMPILED XREF FOR FILE #727.822 ; 01/12/98 diff -y --suppress-common-lines ./VADemo/r1/ECX822.m ./VADemo/r2/r/ECX822.m ECX822 ; DRIVER FOR COMPILED XREFS FOR FILE #727.822 ; 10/15 | ECX822 ; DRIVER FOR COMPILED XREFS FOR FILE #727.822 ; 01/12 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/ECX8231.m ./VADemo/r2/r/ECX8231.m ECX8231 ; COMPILED XREF FOR FILE #727.823 ; 10/15/04 | ECX8231 ; COMPILED XREF FOR FILE #727.823 ; 01/03/01 diff -y --suppress-common-lines ./VADemo/r1/ECX8232.m ./VADemo/r2/r/ECX8232.m ECX8232 ; COMPILED XREF FOR FILE #727.823 ; 10/15/04 | ECX8232 ; COMPILED XREF FOR FILE #727.823 ; 01/03/01 diff -y --suppress-common-lines ./VADemo/r1/ECX823.m ./VADemo/r2/r/ECX823.m ECX823 ; DRIVER FOR COMPILED XREFS FOR FILE #727.823 ; 10/15 | ECX823 ; DRIVER FOR COMPILED XREFS FOR FILE #727.823 ; 01/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8241.m ./VADemo/r2/r/ECX8241.m ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 12/28/04 | ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8242.m ./VADemo/r2/r/ECX8242.m ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 12/28/04 | ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX824.m ./VADemo/r2/r/ECX824.m ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 12/28 | ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8251.m ./VADemo/r2/r/ECX8251.m ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 12/28/04 | ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8252.m ./VADemo/r2/r/ECX8252.m ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 12/28/04 | ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX825.m ./VADemo/r2/r/ECX825.m ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 12/28 | ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8261.m ./VADemo/r2/r/ECX8261.m ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 12/28/04 | ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8262.m ./VADemo/r2/r/ECX8262.m ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 12/28/04 | ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX826.m ./VADemo/r2/r/ECX826.m ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 12/28 | ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX8271.m ./VADemo/r2/r/ECX8271.m ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 12/28/04 | ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8272.m ./VADemo/r2/r/ECX8272.m ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 12/28/04 | ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX827.m ./VADemo/r2/r/ECX827.m ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 12/28 | ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECX89041.m ./VADemo/r2/r/ECX89041.m ECX89041 ; COMPILED XREF FOR FILE #728.904 ; 10/15/04 | ECX89041 ; COMPILED XREF FOR FILE #728.904 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX89042.m ./VADemo/r2/r/ECX89042.m ECX89042 ; COMPILED XREF FOR FILE #728.904 ; 10/15/04 | ECX89042 ; COMPILED XREF FOR FILE #728.904 ; 02/05/03 diff -y --suppress-common-lines ./VADemo/r1/ECX8904.m ./VADemo/r2/r/ECX8904.m ECX8904 ; DRIVER FOR COMPILED XREFS FOR FILE #728.904 ; 10/15 | ECX8904 ; DRIVER FOR COMPILED XREFS FOR FILE #728.904 ; 02/05 diff -y --suppress-common-lines ./VADemo/r1/ECXADM.m ./VADemo/r2/r/ECXADM.m ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 10/25/0 | ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 9/5/02 ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71**;Dec | ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46**;Dec 22 N ADM,W,X,ECXNPRFI | N ADM,W,X ;- Patient Type < S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN) < ; < S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE) | S ECXHI=+$$INSURED^IBCNS1(ECXDFN,ECXDATE) ;get combat veteran data | ;get sharing agreement data I $$CVEDT^ECXUTL5(ECXDFN,ECD) | S (ECXPAYOR,ECXSAI)="" ;get national patient record flag if exist | D VISN19^ECXUTL2(ECXDFN,.ECXPAYOR,.ECXSAI) D NPRF^ECXUTL5 < ;assoc pc prov npi^dom^enrollment cat^enrollment stat | ;assoc pc prov npi^dom^enrollment cat^enrollment stat ;priority^purple heart ind.^obs pat ind^encounter num | ;enrollment prior^purple heart ind.^obs pat ind^encou ;loc^production div^pow loc^source of admission^head | ;agent orange loc^production div^pow loc^source of ad ;^ethnicity^race1^enrollment priority_sub group^user | ;head & neck canc. ind^ethnicity^race1 ;type^combat vet elig^combat vet elig end date^enc cv < ;national patient record flag ECXNPRFI < S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U | S ECODE1=ECODE1_ECXMST_U_U_ECXPAYOR_U_ECXSAI_U_ECXENR S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1 | S ECODE1=ECODE1_ECXSTAT_U_ECXPRIOR_U_ECXPHI_U_ECXOBS_ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U < diff -y --suppress-common-lines ./VADemo/r1/ECXALAR2.m ./VADemo/r2/r/ECXALAR2.m ;;3.0;DSS EXTRACTS;**46,51**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**46**;Dec 22, 1997 .....I ("<>"[$E(ECTRS))!($E(ECTRS,1,2)="GT")!($E(ECTR < diff -y --suppress-common-lines ./VADemo/r1/ECXALAR.m ./VADemo/r2/r/ECXALAR.m ;;3.0;DSS EXTRACTS;**46,51**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**46**;Dec 22, 1997 D SETUP^ECXLABR I ECFILE="" Q < I '$D(ECNODE) S ECNODE=7 < I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D Q < .W !!,$C(7),ECPACK," extract is already scheduled to < S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="R" | S ECXERR=0 D EN^ECXALAR2 Q:ECXERR S ECXERR=0 D EN^ECXALAR2 S $P(^ECX(728,1,ECNODE+.1),U < diff -y --suppress-common-lines ./VADemo/r1/ECXAPHA2.m ./VADemo/r2/r/ECXAPHA2.m ;;3.0;DSS EXTRACTS;**40,49**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**40**;Dec 22, 1997 N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY | N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY S (COUNT,ECDS)=0,ECUNIT="" | S COUNT=0,ECUNIT="" .S ECQTY=+$P(ECDATA1,U,4) | .S ECQTY=+$P(ECDATA1,U,4),ECPRC=+$P(ECDATA1,U,11) .S ECDS=+$P(ECDATA1,U,10) | I 'ECRFL S ECQTY=+$P(ECDATA,U,7),ECPRC=+$P(ECDATA,U,1 .S ECPRC=+$P(ECDATA1,U,11) < I 'ECRFL D < .S ECQTY=+$P(ECDATA,U,7) < .S ECDS=+$P(ECDATA,U,8) < .S ECPRC=+$P(ECDATA,U,17) < .S ECDFN=$P(ECDATA,U,2) | .S ECDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6) .S ECDRG=+$P(ECDATA,U,6) < ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_ | ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_ ...S ^(ECDRG,1)=0 < ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U) | ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U),ECDAY=$P(^(ECDRG) ...S ECDAY=$P(^(ECDRG),U,2) < ...S ECDFN=$P(^(ECDRG),U,3) < ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT < S ECNAME=ECXPAT("NAME") | S ECNAME=ECXPAT("NAME"),ECSSN=ECXPAT("SSN") S ECSSN=ECXPAT("SSN") < S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7) < S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P | S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P S ECNDC=$TR(ECNDC,"*",0) | S ECPROD=$P($G(^PSDRUG(ECDRG,"ND")),U,3),ECPROD=$$RJ^ S ECPROD=$P($G(^PSDRUG(ECDRG,"ND")),U,3) < S ECPROD=$$RJ^XLFSTR(ECPROD,5,0) < > ; get month and day > S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7) S ^TMP($J,ECFKEY,-ECQTY,ECSSN)=ECNAME_U_ECSSN_U_ECDAY | S ^TMP($J,+ECFKEY,-ECQTY,+ECSSN)=ECNAME_U_ECSSN_U_ECD diff -y --suppress-common-lines ./VADemo/r1/ECXAPHA.m ./VADemo/r2/r/ECXAPHA.m ECXAPHA ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 1 | ECXAPHA ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 4 ;;3.0;DSS EXTRACTS;**40,49,66**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**40**;Dec 22, 1997 N X,Y,DATE,ECRUN,ECXOPT,ECXDESC,ECXSAVE,ECXTL,ECTHLD, | N X,Y,DATE,ECRUN,ECXOPT,ECXDESC,ECXSAVE,ECXTL,ECTHLD, N ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG < W !!,"This report requires 132-column format." | W !!,"This report requires 132 column format." W @IOF | W @IOF,!,"This report prints a listing of unusual vol W !,"This report prints a listing of unusual volumes | W !,"value. It shoud be run prior to the generation W !,"generated by the pharmacy extracts (PRE, IVP and < W !,"determined by a user defined threshold value. I < W !,"prior to the generation of the actual extract(s) < W !,"fix as necessary any volumes determined to be er < W !,"IVP Extract: Total Doses Per Day field greater | W !,"IVP Extract: Total Doses Per Day field greater W !,?14,"or less than the negative of the threshold v < W !!,"Run times for this report will vary depending u | W !!,"Run times for this report will vary depending u W !,"the extract and could take as long as 30 minutes | W !!,"The report is sorted by Feeder Key, then by des W !,"complete. This report has no effect on the actu < W !,"can be run as needed." < W !!,"The report is sorted by Feeder Key, descending < ; allow user to select report option (PRE,IVP or UDP) | ; allow user to select report option (PRE,IVP or PRE) ..S SSN="" | ..S SSN="" F S SSN=$O(^TMP($J,FKEY,QTY,SSN)) Q:SSN=" ..F S SSN=$O(^TMP($J,FKEY,QTY,SSN)) Q:SSN=""!QFLG S < ...W !,$P(REC,U),?8,$P(REC,U,2),?20,$P(REC,U,3),?29,$ | ...W !,$P(REC,U),?8,$P(REC,U,2),?21,$P(REC,U,3),?29,$ ...W ?71,$P(REC,U,5),?89,$$RJ^XLFSTR($P(REC,U,6),9)_" < ...I ECXOPT=1 D < ....W ?108,$$RJ^XLFSTR($P(REC,U,8),12),?125,$$RJ^XLFS < ...I ECXOPT'=1 D < ....W ?116,$$RJ^XLFSTR($P(REC,U,8),14) < W !!,"Name",?11,"SSN",?21,"Day",?29,"Generic Name",?7 | W !!,"Name",?8,"SSN",?21,"Day",?29,"Generic Name",?76 I ECXOPT=1 D | I ECXOPT=2 W ?96,"Total Doses",?120,"Total Cost",!,?9 .W ?95,"Quantity",?109,"Total Cost",?120,"Days Supply | I ECXOPT'=2 W ?99,"Quantity",?120,"Total Cost" E D < .I ECXOPT=2 W ?93,"Total Doses",?121,"Total Cost",!,? < .I ECXOPT'=2 W ?96,"Quantity",?121,"Total Cost" < diff -y --suppress-common-lines ./VADemo/r1/ECXDRUG1.m ./VADemo/r2/r/ECXDRUG1.m ECXDRUG1 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder | ECXDRUG1 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder ;;3.0;DSS EXTRACTS;**40,68**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**40**;Dec 22, 1997 W !!,"Section 2: No National Drug Code (NDC) (last 1 | W !,"Section 2: No National Drug Code (NDC) (last 12 W !!,"Section 3: No PSNDF VA Product Name Entry, and | W !,"Section 3: No PSNDF VA Product Name Entry or ND W !,?14,"a. no NDC (all 17 digits are zero), or" < W !,?14,"b. The NDC is prefixed with an 'S', indicati < W !,"Section 3: No PSNDF VA Product Name Entry or ND < I S=2 W !!,"No National Drug Code (NDC) (Last 12 zero | I S=2 W !!,"No National Drug Code (NDC) (Last 12 zero I S=3 W !!,"No PSNDF VA Product Name Entry or Nationa | I S=3 W !!,"No PSNDF VA Product Name Entry or Nationa diff -y --suppress-common-lines ./VADemo/r1/ECXDRUG2.m ./VADemo/r2/r/ECXDRUG2.m ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder | ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder ;;3.0;DSS EXTRACTS;**40,68**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**40**;Dec 22, 1997 N ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK | N ECTYPE,ECNDC,ZERO,K,ECPROD S ECZERO=1,ECSTOCK=0 F K=1:1:$L(ECNDC) D Q:'ECZERO!E | S ZERO=1 F K=1:1:$L(ECNDC) I $E(ECNDC,K)'=0 S ZERO=0 .S ECFCHAR=$E(ECNDC,K) | I ZERO!(ECNDC["N/A") S ECTYPE=2 .I ECFCHAR="S" S ECSTOCK=1 Q < .I ECFCHAR'=0 S ECZERO=0 Q < I ECZERO!ECSTOCK!(ECNDC["N/A") S ECTYPE=2 < diff -y --suppress-common-lines ./VADemo/r1/ECXDVSN2.m ./VADemo/r2/r/ECXDVSN2.m ECXDVSN2 ;ALB/JAP - Division selection utility (cont.) | ECXDVSN2 ;ALB/JAP - Division selection utility (cont.) ;;3.0;DSS EXTRACTS;**14,24,68**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**14,24**;Dec 22, 1997 ..S DIC="^SRO(133,",DIC(0)="AEMQ",DIC("W")="I $P(^(0) | ..S DIC="^SRO(133,",DIC(0)="AEMQ" K X,Y D ^DIC diff -y --suppress-common-lines ./VADemo/r1/ECXEC.m ./VADemo/r2/r/ECXEC.m ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract [ 02/ | ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract [ 02/ ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71**;D | ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46**;Dec 22, N X,Y,ECDCM,ECXNPRFI | N X,Y,ECDCM S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNI | S ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECU S ECDSS=ECAC1S_ECAC2S | S ECDSS=ECAC1S_ECAC2S,ECXDIV="" I ECXLOGIC>2003 I "^18^23^24^36^41^65^94^"[("^"_ECXTS < S ECXDIV="" < ; - Get national patient record flag Indicator if exi | ;- If no encounter number don't file record D NPRF^ECXUTL5 < ; < ; - If no encounter number don't file record < ;enrollment category ECXCAT^ enrollment status ECXSTA | ;enrollment category ECXCAT^ enrollment status ECXSTA ;priority ECXPRIOR^period of service ECXPOS^purple he | ;enrollment priorty ECXPRIOR^period of service ECXPOS ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^ | ;purple heart indicator ECXPHI^observ pat ind ECXOBS^ ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^ | ;encounter num ECXENC^ao loc ECXAOL^ord div ECXODIV^c ;enrollment location ECXENRL^^enrollment priority < ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee < ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig < ;ECXCVEDT^enc cv eligible ECXCVENC^national patient r < ;ECXNPRFI < S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECX | S ECODE1=ECODE1_ECXPRIOR_U_ECXPOS_U_ECXPHI_U_ECXOBS_U I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U | S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1, I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U < I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPR < S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1, < diff -y --suppress-common-lines ./VADemo/r1/ECXKILL.m ./VADemo/r2/r/ECXKILL.m ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49**;Dec 22, 199 | ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39**;Dec 22, 1997 K ECTEMP,ECTM,ECTNTL,ECTOTAL,ECTREAT,ECTRT,ECTS,ECTY, | K ECTEMP,ECTM,ECTNTL,ECTOTAL,ECTREAT,ECTRT,ECTS,ECTY diff -y --suppress-common-lines ./VADemo/r1/ECXLABN.m ./VADemo/r2/r/ECXLABN.m ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - Wi | ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - Wi ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,4 | ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,4 N ECDOCPC < .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLA | .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3) I ECA="I",ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC | I ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC1,U,10), ;ord stop code ECXORDST^ord date ECXORDDT^production | ;ord stop code ECXORDST^ord date ECXORDDT^production ;ECXPDIV^^ordering provider person class < ;ECDOCPC < S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U | S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC < diff -y --suppress-common-lines ./VADemo/r1/ECXLABR.m ./VADemo/r2/r/ECXLABR.m ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - Wi | ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - Wi ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71**;Dec 22, 19 | ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46**;Dec 22, 1997 N X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC | N X,OK,ECTRS,ECTRANS,ECTRIEN ..S ECXDFN=$P(EC1,U,3),ECPTPR=$P($G(EC1),U,11),ECCLAS | ..S ECXDFN=$P(EC1,U,3) ..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE < ;lab results translation ECXTRANS^ordering provider ( | ;lab results translation ECXTRANS ;ordering provider person class (ECCLASS) < I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS < diff -y --suppress-common-lines ./VADemo/r1/ECXLABRS.m ./VADemo/r2/r/ECXLABRS.m ;;3.0;DSS EXTRACTS;**8,51**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 .K EC,ECNM S ECNM=$P(^ECX(727.2,1,1,TST,0),U),EC=$P(^ | .K EC,ECNM S ECNM=$P(^ECX(727.2,1,1,TST,0),U),EC=$P(^ ASKFE ;loop on feces specimen multiple 727.24 < G:$D(DTOUT)!($D(DUOUT)) END < W !!!,"Step #4 - Define all feces specimens used by y < W ! F S DA(1)=1,DIC="^ECX(727.2,"_DA(1)_",""FE"",",D < .S DA=+Y,DA(1)=1,DIE="^ECX(727.2,"_DA(1)_",""FE"",",D < diff -y --suppress-common-lines ./VADemo/r1/ECXLARP.m ./VADemo/r2/r/ECXLARP.m ;;3.0;DSS EXTRACTS;**8,51**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 SPEC F ECFLD="BL","UR","FE" D | SPEC F ECFLD="BL","UR" D ..D:$Y+4>IOSL HDR Q:QFLG W !!!,$S(ECFLD="BL":"BLOOD" | ..D:$Y+4>IOSL HDR Q:QFLG W !!!,$S(ECFLD="BL":"BLOOD" diff -y --suppress-common-lines ./VADemo/r1/ECXMDELE.m ./VADemo/r2/r/ECXMDELE.m ;;3.0;DSS EXTRACTS;**67**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;;Dec 22, 1997 S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",1) | S ECXQUEUE=$G(^ECX(728,1,"QUEUE")) diff -y --suppress-common-lines ./VADemo/r1/ECXMOV.m ./VADemo/r2/r/ECXMOV.m ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; | ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65**;Dec 22, | ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46**;Dec 22, 19 > ...;-If transact=Transfer,ECD (time)=ASIH (7chars) an > ...;-to Admit DT/time before calling funct to get inp > ...I ECM=2,$L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 > ...; > ...;-Subtract 1 second from dischg DT so IN5^VADPT ca > ...;-will pick up discharge movmement record > ...I ECM=3 S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1) > ...; > ...;-Gets inpat/outpat status, DOM, Treating Spec (TS > ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECX ...; | ...;losing ward is either previous xfer ward or admis ...I ECM=2 D < ....;if transact=Transfer,ECD (time)=ASIH (7chars) an < ....;to Admit DT/time before calling funct to get in/ < ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S EC < ....S W=$P(EC,U,6) < ...; < ...I ECM=3 D < ....;subtract 1 second from dischg DT so IN5^VADPT ca < ....;API) will pick up discharge movmement record < ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1) < ....;set losing ward to ward at discharge < ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200) < ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0)) < ...; < ...;-Gets inpat/outpat status, DOM, Treating Spec (TS < ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECX < ...; < ...I W'="" D | ...S W=$P(EC,U,6) I W'="" D diff -y --suppress-common-lines ./VADemo/r1/ECXMTL.m ./VADemo/r2/r/ECXMTL.m ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 11/24/04 10:09 | ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 8/28/02 1:25pm ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71**;Dec 22, 1 | ;;3.0;DSS EXTRACTS;**24,30,33,39,46**;Dec 22, 1997 N ECXADT,JJ,ECXNPRFI | N ECXADT,JJ .I ECXLOGIC>2003 D < ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSS < .;- set national patient record flag if exist < .D NPRF^ECXUTL5 < .; < .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM | .S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) .;Set division to external value if extract is for FY < .I ECXLOGIC>2004 S ECXDIV=$$GETDIV^ECXDEPT(ECXDIV) < ;Combat Veteran Status < S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE < ;encounter num^agent orange loc^dob^production divisi | ;encounter num^agent orange loc^dob^production divisi ;department ECXDEPT^head & neck canc. indi.^ethnicity | ;head & neck canc. ind.^ethnicity^race1 ;enrollment prior ECXPRIOR_enrollment subgroup < ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^pati < ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end < ;enc cv eligible ECXCVENC^national patient record fla < S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXD | S STR=ECXDIV_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_ S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGI | S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U | S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1 I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUE < diff -y --suppress-common-lines ./VADemo/r1/ECXNURS.m ./VADemo/r2/r/ECXNURS.m ECXNURS ;ALB/JAP,BIR/DMA,PTD-Nursing Extract for DSS ; 11/5/0 | ECXNURS ;ALB/JAP,BIR/DMA,PTD-Nursing Extract for DSS ; 11/01/ ;;3.0;DSS EXTRACTS;**8,14,22,24,33,39,46,71**;Dec 22, | ;;3.0;DSS EXTRACTS;**8,14,22,24,33,39,46**;Dec 22, 19 ;mpi^dss dept ECXDSSD^dom (ECXDOM)^observ pat ind (EC | ;mpi^dss dept^dom (ECXDOM)^observ pat ind (ECXOBS) ;product ECXDSSP < > .S ECXDSSD="" ..;Get DSS Department and Product < ..S (ECXDSSD,ECXDSSP)="" < ..;I ECXLOGIC>2004 S X=$$NUR^ECXDEPT(ECD) < ..; < ..S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXEN | ..S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXEN ..S ECODE1=ECODE1_ECINST_U < ..I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP < diff -y --suppress-common-lines ./VADemo/r1/ECXOPRX.m ./VADemo/r2/r/ECXOPRX.m ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS | ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49, | ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46**;D N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP | N X,DA,DIC,DIQ,DR S (ECXCVE,ECXCVEDT,ECXCVENC)="" < ;- Get rx patient status < S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)) < ; < ;- Check non-va provider flag and set to'Y' if exist < S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99)) < ; < ;- Set national patient record flag if exist < D NPRF^ECXUTL5 < ; < I ECXLOGIC>2003 D | D:ECXENC'="" FILE .I ECMW=2,ECXSSN'="" D < ..N TMP < ..S TMP=$S(ECXADMDT:$$JULDT^ECXUTL4(ECXADMDT),1:$$JUL < ..S ECXENC=$E(ECXSSN,1,9)_TMP_"160" < ..S ECXA="O" < I ECXENC'="" D FILE < ;init variables < S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" < .S ECXPHI=$P(PT,U,20) | .S ECXPAYOR=$P(PT,U,18),ECXSAI=$P(PT,U,19),ECXPHI=$P( .I $$ENROLLM^ECXUTL2(ECXDFN) < > .;get sharing agreement data > .S (ECXPAYOR,ECXSAI)="" > .D VISN19^ECXUTL2(ECXDFN,.ECXPAYOR,.ECXSAI) .S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ | .S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ ;mpi^dss dept ECXDSSD^sex^zip+4^provider npi^pc provi | ;mpi^dss dept^sex^zip+4^provider npi^pc provider npi^ ;county^pc prov person class^pow status^pow location^ | ;pc prov person class^pow status^pow location^ ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethn | ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethn ;race ECXRC1^^enrollment priority ECXPRIOR_ < ;enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^ < ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end < ;enc cv eligible ECXCVENC^national patient record fla < ;rx patient status ECRXPTST^non-va prescriber ECNONVA < S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENR | S ECODE1=ECODE1_ECXRST_U_ECXAST_U_ECXPAYOR_U_ECXSAI_U S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1 | S ECODE1=ECODE1_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_ | S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_ S ECODE1=ECODE1_ECXRC1_U | S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1, I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U < I ECXLOGIC>2004 S ECODE2=ECXPTYPE_U_ECXCVE_U_ECXCVEDT < S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1, < diff -y --suppress-common-lines ./VADemo/r1/ECXPIVDN.m ./VADemo/r2/r/ECXPIVDN.m ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTR | ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTR ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71**;D | ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46**;Dec 22, N DIC,DA,DR,DIQ,DFN,ECXNPRFI | N DIC,DA,DR,DIQ,DFN .S ECXDSSI="" | .S ECXDSSI="",ECXDSSD="" > ; > .; .I ECXLOGIC>2003 D < ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSS < ;get BCMA data < S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" < ; < ;get ordering provider person class < S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORD < ; < ;set national patient record flag if exist < S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN < ; < ;set ordering stop code < S ECXIVPO="" ;$$DOIVPO^ECXUTL5(DA,ON) < ; < ;init variables < S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" < .I $$ENROLLM^ECXUTL2(ECXDFN) < > ; > ; > ; ;head & neck cancer ind.^ethnicity^race1^bcma drug di | ;head & neck cancer ind.^ethnicity^race1 ;bcma dose given^bcma unit of administration^bcma ICU < ;ordering provider person class^^user < ;enrollee ECXUESTA^patient type ECXPTYPE^combat vet e < ;ECXCVE^combat vet elig end date ECXCVEDT^enc cv elig < ;national patient record flag ECXNPRFI,ordering stop < S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1 | S ECODE1=ECODE1_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXOPN I ECXLOGIC>2003 D < .S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXB < I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP < > ; > ; Only in ./VADemo/r1/: ECXPROCT.m diff -y --suppress-common-lines ./VADemo/r1/ECXPRO.m ./VADemo/r2/r/ECXPRO.m ECXPRO ;ALB/GTS - Prosthetics Extract for DSS ; 9/20/04 1:31 | ECXPRO ;ALB/GTS - Prosthetics Extract for DSS ; 8/28/02 2:15 ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46,71**;Dec | ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46**;Dec 22, N DIC,DR,DA,DIQ,CPTCODE,ECXNPRFI | N DIC,DR,DA,DIQ,CPTCODE > ..D VISN19^ECXUTL2(ECXDFN,.ECXPAYOR,.ECXSAI) ..; < ..; - set national patient record flag if exist < ..D NPRF^ECXUTL5 < ..; < ;zip^dob^sex^amis grouper^pc prov npi^mpi^dss dept EC | ;zip^dob^sex^amis grouper^pc prov npi^mpi^dss dept^ ;head & neck canc. ind. (ECXHNCI)^ethnicity (ECXETH)^ | ;head & neck canc. ind. (ECXHNCI)^ethnicity (ECXETH)^ ;^enrollment priority (ECXPRIOR)_enrollment sub- < ;group (ECXSBGRP)^user enrollee (ECXUESTA)^patient ty < ;^combat vet elig ECXCVE^combat vet elig end date ECX < ;eligible ECXCVENC^national patient record flag ECXNP < S ECODE1=ECODE1_U_U_ECXMST_U_ECXENRL_U_ECXSTATE_U | S ECODE1=ECODE1_ECXPAYOR_U_ECXSAI_U_ECXMST_U_ECXENRL_ S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:E | S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXPHI_ S ECODE1=ECODE1_ECXHNCI_U_ECXETH_U_ECXRC1_U | S ECODE1=ECODE1_ECXHNCI_U_ECXETH_U_ECXRC1 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U < diff -y --suppress-common-lines ./VADemo/r1/ECXPURG1.m ./VADemo/r2/r/ECXPURG1.m ;;3.0;DSS EXTRACTS;**2,9,8,24,49**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**2,9,8,24**;Dec 22, 1997 S DIR("?",1)="Choose the number(s) of the extract(s) | S DIR("?",1)="Choose the number (or numbers) of the e D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET < CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed pri < N LOOPDA,YYYMMDD < S LOOPDA=0 < F S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0) D < .I ^ECX(727,LOOPDA,"HEAD")="CLI" D < ..S DA(1)=1 < ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4) < ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",L < ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Rep < ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA) < Q < diff -y --suppress-common-lines ./VADemo/r1/ECXPURG.m ./VADemo/r2/r/ECXPURG.m ;;3.0;DSS EXTRACTS;**9,24,33,35,49**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**9,24,33,35**;Dec 22, 1997 .I ECFILE=727.827 D < ..S DA(1)=1 < ..S DA=$O(^ECX(728,DA(1),"CBOC","B",ECDA,0)) < ..S DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_"," < ..I DA'="" D ^DIK K DIK,DA < diff -y --suppress-common-lines ./VADemo/r1/ECXQSR.m ./VADemo/r2/r/ECXQSR.m ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 11/24/04 1:15pm | ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 8/28/02 1:13pm ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46, | ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46* N ERR,ECXQDT,ECXNPRFI | N ERR,ECXQDT I ECXLOGIC>2003 D < .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$ < > S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD), > S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD), S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD) | ;- Observation Patient Indicator (yes/no) S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD) < N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI < F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D < .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR < .S DA=ECXQSR(FILEN,DA,DR,"I"),(DIC,FILEN)=8930.3 D EN < ; < ; -Observation Patient Indicator (yes/no) < ; -CNH status (YES/NO) | ;- CNH status (YES/NO) ; -Head and Neck Cancer Indicator | ; - Head and Neck Cancer Indicator ;get enrollment data (category, status and priority) | ;- If no encounter number don't file record I $$ENROLLM^ECXUTL2(ECXDFN) < ; -Get national patient record flag Indicator if exis < D NPRF^ECXUTL5 < ; < ; -If no encounter number don't file record < ;enrollment status ECXSTAT^enrollment prior ECXPRIOR^ | ;enrollment status ECXSTAT^enrollment priority ECXPRI ;service ECXPOS^purple heart ECXPHI^observ pat ind EC | ;period of service ECXPOS^purple heart ECXPHI^observ ;num ECXENC^ao loc ECXAOL^ord div ECXODIV^contr st dt | ;encounter num ECXENC^ao loc ECXAOL^ord div ECXODIV^c ;race1 ECXRC1^enrollment location ECXENRL^^ | ;race1 ECXRC1 ;enrollment priority ECXPRIOR_enrollment subgroup ECX < ;enrollee ECXUESTA^patient type ECXPTYPE^combat vet e < ;combat vet elig end date ECXCVEDT^enc cv eligible EC < ;national patient record flag ECXNPRFI < S ECODE1=ECODE1_ECXDOB_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOG | S ECODE1=ECODE1_ECXDOB_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_ I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL | S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1, I ECXLOGIC>2004 S ECODE1=ECODE1_U_U_ECXPRIOR_ECXSBGRP < I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPR < S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1, < diff -y --suppress-common-lines ./VADemo/r1/ECXRAD.m ./VADemo/r2/r/ECXRAD.m ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 10/15/04 | ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; [ 11/27/ ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71**;Dec | ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46**;Dec 22, N ECXIEN,X,SUB,TYPE,ECDOCPC | N ECXIEN,X,SUB,TYPE ...S (ECXDSSD,ECXDSSP)="" | ...S ECXDSSD="" ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDO | ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDO > ...;dss department implementation postponed S ECXDSSD ...;check CPT modifier for Department and Product num < ...;I ECXLOGIC>2004 D < ...;.I ECXCMOD'["26"!ECXMOD'["TC" D < ...;..S ECFS="RAD",ECFL=ECXDIV_"-"_ECTY,ECFK=$E(ECXCP < ...;..X $$RAD^ECXDEPT(ECFS,ECFL,ECFK,ECXMDA) < ...;..D FILE < ...;.;check for component '26' < ...;.I ECXCMOD['26' D Q < ...;..S ECFS="RAD",ECFL=ECXDIV_"-"_ECTY,ECFK=$E(ECXCP < ...;..X $$RAD^ECXDEPT(ECFS,ECFL,ECFK,ECXMDA) < ...;..D FILE < ...;.;check for component 'TC' < ...;.I ECXCMOD['TC' D Q < ...;..S ECFS="RAD",ECFL=ECXDIV_"-"_ECTY,ECFK=$E(ECXCP < ...;..X $$RAD^ECXDEPT(ECFS,ECFL,ECFK,ECXMDA) < ...;..D FILE < ...;.;check PROCEDURES if CPT field is "" to generate < ...;.I ECXCPT="" D < ...;..S ECFS="RAD",ECFL=ECXDIV+"-"_ECTY < ...;..S ECFK=$S(ECPRO=468:777777,1:ECPRO) < ...;..X $$RAD^ECXDEPT(ECFS,ECFL,ECFK,ECXMDA) < ...;..D FILE < ...;.;check procedure modifiers for other records to < ...;.I ECMODS D < ...;..;bilateral < ...;..S ECXFS="RAD",ECFL=ECXDIV_"-"_ECTY,ECFK=$E(ECXC < ...;..X $$RAD^ECXDEPT(ECFS,ECFL,ECFK,ECXMDA) < ...;..D FILE < ...;..;bedside < ...;..S ECXFS="RAD",ECFL=ECXDIV_"-"_ECTY,ECFK="888888 < ...;..X $$RAD^ECXDEPT(ECFS,ECFL,ECFK,ECXMDA) < ...;..D FILE < ...;..;operating room < ...;..S ECXFS="RAD",ECFL=ECXDIV_"-"_ECTY,ECFK="999999 < ...;..X $$RAD^ECXDEPT(ECFS,ECFL,ECFK,ECXMDA) < ...;..D FILE < ;observ pat ind^encounter num^ord stop code^ord date^ | ;observ pat ind^encounter num^ord stop code^ord date^ ;dss product ECXDSSP^requesting provider person class < S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U | S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV ;p-46 added ECXPDI I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC < diff -y --suppress-common-lines ./VADemo/r1/ECXSCLD.m ./VADemo/r2/r/ECXSCLD.m ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 | ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ;;3.0;DSS EXTRACTS;**2,8,24,30,71**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**2,8,24,30**;Dec 22, 1997 W !!,?1,"CLINIC",?27,"STOP",?34,"CREDIT",?43,"DSS",?5 | W !!,?1,"CLINIC",?33,"STOP",?40,"CREDIT",?49,"DSS",?5 W !,?27,"CODE",?34,"STOP",?43,"STOP",?50,"CREDIT",?67 | W !,?33,"CODE",?40,"STOP",?49,"STOP",?56,"CREDIT",?73 W !!,$E(ECSC,1,28) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ? | W !!,$E(ECSC,1,30) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ? S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?67,$S | S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?73,$S Only in ./VADemo/r2/r/: ECXSCNS.m Only in ./VADemo/r1/: ECXSCRP.m diff -y --suppress-common-lines ./VADemo/r1/ECXSCX2.m ./VADemo/r2/r/ECXSCX2.m ECXSCX2 ;ALB/ESD DSS Clinic Extract Utilities (continued) ; | ECXSCX2 ;ALB/ESD DSS Clinic Extract Utilities (continued) ; ;;3.0;DSS EXTRACTS;**39,46,49,71**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**39,46**;Dec 22, 1997 S (ECPTTM,ECXVET,ECXRACE,ECXENRL,ECXMPI,ECXSEX)="" | S (ECPTTM,ECXPAYOR,ECXSAI,ECXVET,ECXRACE,ECXENRL,ECXM > ;get sharing agreement data > S (ECXPAYOR,ECXSAI)="" > D VISN19^ECXUTL2(ECXDFN,.ECXPAYOR,.ECXSAI) ;- set national patient record flag if exist < D NPRF^ECXUTL5 < ; < CBOC(MDIV) ;Determine whether patient's facility was CBO < N LOCARR,DIC,DR,DIQ,DA,INST,FTYP < S DIC=40.8,DA=MDIV,DR=".07",DIQ(0)="I",DIQ="LOCARR" D < S INST=$G(LOCARR(40.8,MDIV,.07,"I")) I INST="" Q "" < K LOCARR S DIC=4,DA=INST,DR="13",DIQ(0)="I",DIQ="LOCA < S FTYP=$G(LOCARR(4,INST,13,"I")) I FTYP="" Q "" < K LOCARR S DIC=4.1,DA=FTYP,DR=".01",DIQ(0)="I",DIQ="L < Q $S($G(LOCARR(4.1,FTYP,.01,"I"))="CBOC":"Y",1:"") < Only in ./VADemo/r1/: ECXSCXN1.m diff -y --suppress-common-lines ./VADemo/r1/ECXSCXN.m ./VADemo/r2/r/ECXSCXN.m ECXSCXN ;ALB/JAP Clinic Extract ; 10/26/04 10:26am | ECXSCXN ;ALB/JAP Clinic Extract ; 8/28/02 1:11pm ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52 | ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46**;Dec N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP | N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP N TIU,X,Y,ECXNPRFI < D NOSHOW^ECXSCXN1(ECSD1,ECED),ENCNTR(ECSD1,ECED) | D NOSHOW(ECSD1,ECED),ENCNTR(ECSD1,ECED) N CHKOUT,ECD,JJ,K,OUT,PNODE,PP,STAT,STOP,MDIV | N CHKOUT,ECD,JJ,K,OUT,PNODE,PP,STATUS,STOP ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.11;.12;.13", | ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.12;.13",DIQ( ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.0 | ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.0 ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) | ..S:ECXTI="000000" ECXTI="000300" ..S:ECXTI="000000" ECXTI="000300" S MDIV=+$G(LOCARR(4 | ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I")),CHKOUT=+$ ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I")) | ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I")),STATUS ..S CHKOUT=+$G(LOCARR(409.68,ECXIEN,.07,"I")) < ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I")) < ..S STAT=$G(LOCARR(409.68,ECXIEN,.12,"I")) < ..S:STAT="" STAT="ZZ" S STAT=";"_STAT_";" | ..S:STATUS="" STATUS="ZZ" S STATUS=";"_STATUS_";" ..Q:";3;4;5;6;7;9;10;13;"[STAT | ..Q:";3;4;5;6;7;9;10;13;"[STATUS ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I")) | ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I")),ECXCLI ..S ECXCLIN=+$G(LOCARR(409.68,ECXIEN,.04,"I")) < ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I")) | ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I")),ECXEN ..S ECXENEL=+$G(LOCARR(409.68,ECXIEN,.13,"I")) < ..;get national patient record flag if exist < ..D NPRF^ECXUTL5 < ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXI | ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXI ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV") < ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") < > ....I $P(PNODE,U,1)=ECXCLIN,$P(PNODE,U,5) D > .....S ECXKEY="10700003000000",ECXSTOP="107",ECXOBS=$ > .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,E > NOSHOW(ECXSD,ECXED) ;get noshows from file #44 > ; ECXSD = start date, ECXED = end date > N ALEN,CLIN,JDATE,JJ,NODE,NOSHOW,PP,STATUS > S CLIN=0 > F S CLIN=$O(^TMP($J,"ECXCL",CLIN)) Q:'CLIN D > .Q:$P($G(^TMP($J,"ECXCL",CLIN)),U,3)'="C" > .S (P1,P2,P3)="" > .D FEEDER^ECXSCX1(CLIN,ECXSD,.P1,.P2,.P3,.TOSEND,.ECX > .Q:TOSEND=6 > .;find appts in date range > .S JDATE=ECXSD,(ALEN,NOSHOW)="" > .F S JDATE=$O(^SC(CLIN,"S",JDATE)) Q:'JDATE Q:JDATE > ..S ECXDATE=JDATE,JJ=0,ECXTI=$P($$FMTE^XLFDT(JDATE,1) > ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) > ..S:ECXTI="000000" ECXTI="000300" > ..;get noshows only - no data in check-in/check-out n > ..F S JJ=$O(^SC(CLIN,"S",JDATE,JJ)) Q:'JJ D > ...S K=0 > ...F S K=$O(^SC(CLIN,"S",JDATE,JJ,K)) Q:'K D > ....S PP=$G(^SC(CLIN,"S",JDATE,JJ,K,0)),ECXDFN=$P(PP, > ....S NODE=$G(^DPT(ECXDFN,"S",JDATE,0)) > ....Q:(NODE="")!($P(NODE,U)'=CLIN) > ....S ECXOBI=$G(^SC(CLIN,"S",JDATE,JJ,K,"OB")),STATUS > ....Q:NOSHOW="" D INTPAT^ECXSCX2 S ECXERR=0 > ....D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR > ....S ALEN=$P(PP,U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0) > ....D PAT2^ECXSCX2(ECXDFN,ECXDATE) > ....S ECXPVST=$P(NODE,U,7),ECXATYP=$P(NODE,U,16) ;Ge > ....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",CLIN)),U,2) > ....S ECXCLIN=CLIN,ECXSTOP=P1 S:ECXICD9P="" ECXICD9P= > ....S:ECXCPT1="" ECXCPT1="9919901" > ....S (ECXDSSD,ECXENEL,ECXIR,ECXAO,ECXMIL,ECXPROV,ECX > ....I TOSEND'=3 D > .....S ECXKEY=P1_P2_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^EC > .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,E > ....I TOSEND=3 D > .....S ECXKEY=P1_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT > .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,E > ....I TOSEND=3 D > .....S ECXKEY=P2_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT > .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,E > ....;create a record for noshow appended ekg > ....D:$P(NODE,U,5) > .....S ECXKEY="1070000300000N",ECXSTOP="107",ECXOBS=$ > .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,E > Q > ; S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U | S STR(1)=STR(1)_ECXMIL_U_ECXPAYOR_U_ECXSAI_U_ECXENRL_ S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ | S STR(2)=ECXSTAT_U_ECXPRIOR_U_ECXPHI_U_ECXPOS_U_ECXOB S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_ | D FILE2^ECXSCX2(727.827,EC7,.STR) S ECRN=ECRN+1,$P(^E S STR(2)=STR(2)_ECXHNCI_U_ECXETH_U_ECXRC1 < I ECXLOGIC>2003 S STR(2)=STR(2)_U_ECXCBOC < I ECXLOGIC>2004 S STR(2)=STR(2)_U_U_ECXPRIOR_ECXSBGRP < D FILE2^ECXSCX2(727.827,EC7,.STR) < S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7 < diff -y --suppress-common-lines ./VADemo/r1/ECXSURG.m ./VADemo/r2/r/ECXSURG.m ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 12/8/04 | ECXSURG ;ALB/JAP,BIR/DMA,PTD-Surgery Extract for DSS ; 8/28/0 ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,5 | ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46** N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI < I ECXADMDT="" S ECXADD=ECXADMDT | S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM),EC0=^SRF(EC I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECX < S EC0=^SRF(ECD0,0) < ;-Time patient in OR room (Nurse Time) < ;- If surgery cancelled/aborted quit and go to next r | ;- Cancelled/aborted surgery indicator (C/A) ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30 < .N ECNTIME,ECSTIME,ECATIME < .I (A1&A2)&(+J=10) D TIME S ECNTIME=TIME | .I (A1&A2)&(+J'=2) D TIME .I (A1&A2)&(+J=1) D TIME S ECATIME=TIME < ..;-Operation Time (Surgeon Time) | ..;-Operation Time ..S:TIME ECSTIME=TIME < ; -Recovery Room Time < ; -OR Clean Time in 15 min increments DBIA #103 < S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DA < ; -If no OR clean time recorded set it to 2 < I ECXORCT'>0 S ECXORCT=2 < ; < ; -PT in hold area time in 15 min increments DBIA #10 < I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D < .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(D < .S CON=$P($G(^SRF(ECD0,"CON")),U) < .I CON S ECXPTHA=ECXPTHA/2 < .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ") < ; -If hold time is =<0 set it to "" < S:$G(ECXPTHA)'>0 ECXPTHA="" < ; < ;- set national patient record flag if exist < D NPRF^ECXUTL5 < ; < ; < ;mpi^dss dept ECXDSSD^surgeon npi^attending npi^anes | ;mpi^dss dept^surgeon npi^attending npi^anes supervis ;ethnicity ECXETH^race1 ECXRC1^new quantity ECXQ^ | ;ethnicity ECXETH^race1 ECXRC1^new quantity ECXQ ;^user enrollee ECXUESTA^patient type ECXPTYPE^combat < ;ECXCVE^combat vet elig end date ECXCVEDT^enc cv elig < ;or clean time ECXORCT^time pt in hold area ECXPTHA^n < ;record flag ECXNPRFI < S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:E | S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXPOS_ S ECODE1=ECODE1_ECXETH_U_ECXRC1_U_ECXQ_U | S ECODE1=ECODE1_ECXETH_U_ECXRC1_U_ECXQ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U < diff -y --suppress-common-lines ./VADemo/r1/ECXTAUTO.m ./VADemo/r2/r/ECXTAUTO.m ;;3.0;DSS EXTRACTS;**8,24,49**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**8,24**;Dec 22, 1997 ;do specific extract using appropriate fiscal year lo | ;do specific extract S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD) < S ^ECX(727,EC,"VER")=$G(ECVER)_U_ECXLOGIC | I $D(ECVER) S ^ECX(727,EC,"VER")=ECVER S ECMSG(1,0)="The BACKGROUND DSS-"_ECPACK_" extract ( | S ECMSG(1,0)="The BACKGROUND DSS-"_ECPACK_" extract ( S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECX < S ECMSG(4,0)=" " | S ECMSG(4,0)=" ",ECMSG(5,0)="A total of "_ECRN_" reco S ECMSG(5,0)="A total of "_ECRN_" records were writte | S ECMSG(6,0)=" ",ECMSG(7,0)="Extract time was [HH:MM: S ECMSG(6,0)=" " < S ECMSG(7,0)="Extract time was [HH:MM:SS] "_$$HDIFF^X < S ECMSG(8,0)=" " < S X=$E(ECXLOGIC,5) S X=$S((X="")!(X=" "):"",1:"revisi < S ECMSG(9,0)="The data was extracted using "_X_"fisca < S ECMSG(10,0)=" " < diff -y --suppress-common-lines ./VADemo/r1/ECXTLOCL.m ./VADemo/r2/r/ECXTLOCL.m ;;3.0;DSS EXTRACTS;**8,49**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 ; ECXLOGIC=Fiscal year extract logic to use < I '$D(ECXLOGIC) S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD) < S ^ECX(727,EC,"VER")=$G(ECVER)_"^"_ECXLOGIC < S ECMSG(1,0)="The LOCAL USE DSS-"_ECPACK_" extract fo | S ECMSG(1,0)="The LOCAL USE DSS-"_ECPACK_" extract fo S ECMSG(2,0)=ECEDN_" was completed on "_$P(TIME,"@")_ < S ECMSG(3,0)=" " < S ECMSG(4,0)="A total of "_ECRN_" records were writte < S X=$E(ECXLOGIC,5) S X=$S((X="")!(X=" "):"",1:"revisi < S ECMSG(6,0)="The data was extracted using "_X_"fisca < S ECMSG(7,0)=" " < diff -y --suppress-common-lines ./VADemo/r1/ECXTRAC.m ./VADemo/r2/r/ECXTRAC.m ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49**;Dec 22, 199 | ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33**;Dec 22, 1997 ;Input | ;Input ECPACK printed name of package (e.g. Lab, Pr ; ECPACK printed name of package (e.g. Lab, Prescr | ; ECNODE in file 728 where last date is stored ; ECNODE in file 728 where last date is stored | ; ECPIECE piece of node where last date is stor ; ECPIECE piece of node where last date is stored | ; ECRTN in the form of START^ROUTINE ; ECRTN in the form of START^ROUTINE | ; ECGRP name of local mail group to receive s ; ECGRP name of local mail group to receive summa | ; (MUST BE 1 TO 5 UPPER CASE ALPHA - NO ; (MUST BE 1 TO 5 UPPER CASE ALPHA - NO SPA | ; ECFILE file number of the local editing file ; ECFILE file number of the local editing file | ; generates EC23=2nd and 3rd piece of zero node in lo ; ECXLOGIC Fiscal year extract logic to use (optiona | ; =YYMM of end date^pointer to 727 ; ECXDATES StartDate^EndDate^DoNotUpdate728 (optiona < ;Generates < ; EC23=2nd and 3rd piece of zero node in local editi < ; =YYMM of end date^pointer to 727 < ; ECXLOGIC=Fiscal year extract logic to use < S X=$G(ECXDATES) S ECSD=$P(X,"^",1),ECED=$P(X,"^",2) < I (ECSD="")!(ECED="") F S (ECED,ECSD)="" D Q:OUT | F S (ECED,ECSD)="" D Q:OUT F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S | S (ZTSAVE("ECINST"),ZTSAVE("ECED"),ZTSAVE("ECSD"),ZTS F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTS | S (ZTSAVE("ECPACK"),ZTSAVE("ECPIECE"),ZTSAVE("ECRTN") F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZT | S (ZTSAVE("ECINST"),ZTSAVE("ECXINST"))="" F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)="" < I $G(ECXLOGIC)="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD) | I $D(ECVER) S ^ECX(727,EC,"VER")=ECVER S ^ECX(727,EC,"VER")=$G(ECVER)_"^"_ECXLOGIC < ;Set last date for extract | ;* set last date for all extracts except prosthetics I '$P($G(ECXDATES),"^",3) D | S:(ECGRP'="PRO") $P(^ECX(728,1,ECNODE),U,ECPIECE)=$P( .;* set last date for all extracts except prosthetics | ;* set last date for prosthetics .I ECGRP'="PRO" S $P(^ECX(728,1,ECNODE),U,ECPIECE)=$P | I ECGRP="PRO" D .;* set last date for prosthetics < S X=$E(ECXLOGIC,5) S X=$S((X="")!(X=" "):"",1:"revisi < S ECMSG(9,0)="The data was extracted using "_X_"fisca < S ECMSG(10,0)=" " < N DIR,X,Y < diff -y --suppress-common-lines ./VADemo/r1/ECXTRANS.m ./VADemo/r2/r/ECXTRANS.m ECXTRANS ;ALB/GTS,JAP,BIR/DMA-Extract from Local Editi | ECXTRANS ;ALB/GTS,JAP,BIR/DMA-Extract from Local Editi ;;3.0;DSS EXTRACTS;**2,9,12,8,13,14,23,24,33,49,54,75 | ;;3.0;DSS EXTRACTS;**2,9,12,8,13,14,23,24,33**;Dec 22 N DTOUT,DIRUT,DIC,X,Y,ECXLOGIC,ECSD,FODMN | N DTOUT,DIRUT,DIC,X,Y S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",1) | I $G(^ECX(728,1,"QUEUE"))'?1"DM"1U D Q I ECXQUEUE'?1"DM"1U D Q < > S ECXQUEUE=$G(^ECX(728,1,"QUEUE")) W !,"following divisions:",! | W !," following divisions:",! AGAIN S ECRE="",DIC="^ECX(727,",DIC(0)="AEQM" | S ECRE="",DIC="^ECX(727,",DIC(0)="AEQM" S DR="1;2;3;4;5;6;14;15",(ECDA,DA)=+Y,DIQ(0)="IE",DIQ | S DR="1;2;3;4;5;6;15",(ECDA,DA)=+Y,DIQ(0)="E",DIQ="EC I ECXDIQ(727,ECDA,14,"I")="" D < .S ECXDIQ(727,ECDA,14,"I")=$$FISCAL^ECXUTL1(ECXDIQ(72 < .S ECXDIQ(727,ECDA,14,"E")=ECXDIQ(727,ECDA,14,"I") < S ECXLOGIC=ECXDIQ(727,ECDA,14,"I") < S ECSD=ECXDIQ(727,ECDA,3,"I") < S X=$E(ECXDIQ(727,ECDA,14,"I"),5) S X=$S((X="")!(X=" < W !!,"The data was extracted using "_X_"fiscal year " < S FODMN=$$FODMN() < ;Field office reminder < I FODMN D < .W ! < .W !,"** This extract is being sent from a field offi < .W !,"** Extract message(s) will only be delivered to < .W !,"** will be placed into your 'DSSXMIT' mail bask < .W ! < .;Ensure user has a DSSXMIT mail basket < .N TMPARR < .D LISTBSKT^XMXAPIB(DUZ,,,,"DSSXMIT","TMPARR") < .I '$D(TMPARR("XMLIST","BSKT","DSSXMIT")) D < ..;Create DSSXMIT basket < ..N IEN,XMERR < ..D CRE8BSKT^XMXAPIB(DUZ,"DSSXMIT",.IEN) < ..K ^TMP("XMERR",$J) < ;Test queue clearance < ;I 'FODMN I (ECXLOGIC'=$$FISCAL^ECXUTL1(ECSD))!((ECXL < ;.S OUT=0 < ;.K DIR < ;.S DIR(0)="Y" < ;.S DIR("A",1)="** This extract will be transmitted t < ;.S DIR("A")="Do you want to continue " < ;.W !! D ^DIR < ;.I 'Y S OUT=1 Q < ;.S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",2) < ;.S:ECXQUEUE="" ECXQUEUE="DMT" < ; entry point for task | ; entry point fr task N ECMAX,ECMAXR,ECMSN,ECPACK,ECSIZ,ECVER,ECXDIC,I,J,EX | N ECMAX,ECMAXR,ECMSN,ECPACK,ECSIZ,ECVER,ECXDIC,I,J N STR,STRCNT,X,ECSD,ECXLOGIC | N STR,STRCNT,X S X=^(0),ECPACK=$P(X,U,3),ECSD=$P(X,U,4),ECED=$P(X,U, | S ECED=$P(^(0),U,5),ECPACK=$P(^(0),U,3),ECVER=$G(^("V S X=$G(^("VER")),ECVER=$P(X,"^",1),ECXLOGIC=$P(X,"^", < I ECXLOGIC="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD) < S ECXLOGIC=$$PAD^ECXUTL1(ECXLOGIC,5,"B"," ") < S ECHD(1)=ECINST_ECHEAD_$$ECXYM^ECXUTL(ECED)_ECVER_EC | S ECHD(1)=ECINST_ECHEAD_$$ECXYM^ECXUTL(ECED)_ECVER N ECXDD,DA,DIC,DIE,DINUM,X,Y,Z,XMDUZ,XMTEXT,XMSUB,XMY | N ECXDD,DA,DIC,DIE,DINUM,X,XMDUZ,XMTEXT,XMSUB,XMY,XMZ > ;S XMY(DUZ)="" ;Send extracts done at field offices to user instead < S FODMN=$$FODMN() < I FODMN D < .K XMY < .S XMY(DUZ)="" < ;Move message to DSSXMIT basket if sending from field < I FODMN D < .N XMERR < .D MOVEMSG^XMXAPI(DUZ,,XMZ,"DSSXMIT",.X) < .K ^TMP("XMERR",$J) < .K DIR S DIR(0)="E" W ! D ^DIR K DIR | .S DIR(0)="E" W ! D ^DIR K DIR ; < FODMN(DOMAIN) ;Is domain a field office domain < ;Input : DOMAIN - Domain name to check < ; - Default value pulled from ^XMB("NET < ;Output: 1 = Yes / 0 = No < ; < N X,SUB,OUT < S DOMAIN=$G(DOMAIN) < S:(DOMAIN="") DOMAIN=$G(^XMB("NETNAME")) < S OUT=0 < F X=1:1:$L(DOMAIN,".") D Q:OUT < .S SUB=$P(DOMAIN,".",X) < .I ($E(SUB,1,3)="FO-")!($E(SUB,1,4)="ISC-") S OUT=1 < Q OUT < Only in ./VADemo/r1/: ECXTREX.m diff -y --suppress-common-lines ./VADemo/r1/ECXTRT.m ./VADemo/r2/r/ECXTRT.m ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49**;Dec 2 | ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46**;Dec 22, N LOC,SPC,TRT,WRD | N LOC,SPC,TRT ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) | ..S ECXMVD1=$P(EC,U) ..;- Production Division | ..;- Production Division null for FY2003 ..S ECXPDIV="" | ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI,ECXPDIV)="" ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WR < ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)="" < ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) | ..S ECXMVD1=$P(EC,U) ..;- Production Division | ..;- Production Division null for FY2003 ..S ECXPDIV="" | ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI,ECXPDIV)="" ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WR < ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)="" < NPDIV(WRD) ;National Production Division < N DIV < S DIV=$$GET1^DIQ(42,WRD,.015,"I") < Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV)) < ; < Only in ./VADemo/r1/: ECXUCBOC.m Only in ./VADemo/r1/: ECXUCPT.m diff -y --suppress-common-lines ./VADemo/r1/ECXUD.m ./VADemo/r2/r/ECXUD.m ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT D | ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT D ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71**;Dec 22, | ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46**;Dec 22, 1997 ;Ordering Provider Person Class < S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXPRO,2,999),$P(DATA, < ;BCMA data (place holder) < S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" < ;- Set national patient record flag if exist < D NPRF^ECXUTL5 < ;init variables < S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" < .I $$ENROLLM^ECXUTL2(ECXDFN) < > .S (ECXCAT,ECXSTAT,ECXPRIOR)="" ;race1^bcma drug dispensed^bcma dose given^bcma unit | ;race1 ;administration^bcma icu flag^ordering provider perso < ;^enrollment priority ECXPRIOR_enrollment subgroup < ;ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYP < ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv < ;ECXCVENC^national patient record flag ECXNPRFI < S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:E | S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECPTTM_ I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U < I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP < Only in ./VADemo/r1/: ECXUPRO1.m Only in ./VADemo/r1/: ECXUPRO.m Only in ./VADemo/r1/: ECXUSUR1.m Only in ./VADemo/r1/: ECXUSUR.m diff -y --suppress-common-lines ./VADemo/r1/ECXUTL1.m ./VADemo/r2/r/ECXUTL1.m ;;3.0;DSS EXTRACTS;**9,49**;Dec 22, 1997 | ;;3.0;DSS EXTRACTS;**9**;Dec 22, 1997 FISCAL(DATE) ;Return fiscal year < ; Input: DATE = Date (FileMan format) (defaults to to < ;Output: YYYY = Fiscal year that input date falls wit < ; < N YEAR < I '$G(DATE) S DATE=$$DT^XLFDT() < S DATE=$$ECXYM^ECXUTL(DATE) < S YEAR=$E(DATE,1,4) < I $E(DATE,5,6)>9 S YEAR=YEAR+1 < Q YEAR < ; < diff -y --suppress-common-lines ./VADemo/r1/ECXUTL2.m ./VADemo/r2/r/ECXUTL2.m ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 12/9/ | ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 9/4/0 ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71**;Dec | ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46**;Dec 22, K ECXSBGRP < ENROLLM(DFN,RNDT) ;determines enrollment status, catego | ENROLLM(DFN,RNDT) ;determines enrollment status, catego ;and user enrolle status < ; ECXSBGRP = Enrollment subgroup < ; ECXUESTA = User enrollee < N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP | N CAT,PRIOR,STAT,X,X1,X2,ENRIEN,ENR,FL S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)="" | S (ECXCAT,ECXPRIOR,ECXSTAT)="" ;User enrollee status, if current or future date set < ;DBIA #3989 < S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"") < ;Patient type < S ECXPTYPE=$$TYPE^ECXUTL5(DFN) < ;Combat Veteran Status DBIA #4156 < S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):E < ;enrollment priority DBIA < S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN < S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DG < I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRI | S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN > S CAT=$$CATEGORY^DGENA4(DFN,STAT) > I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRI . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1 | . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=ENR("PRIORITY"), . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN) < . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e" < S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S( | S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT . W !,$G(CNT)+1 | K ECXARY,ECXERR . W !,"The value of ECXPAYOR is: ",ECXPAYOR < ;K ECXARY,ECXERR < . W !,"This is a test" < diff -y --suppress-common-lines ./VADemo/r1/ECXUTL4.m ./VADemo/r2/r/ECXUTL4.m ;;3.0;DSS EXTRACTS;**39,41,46,49**;Dec 22,1997 | ;;3.0;DSS EXTRACTS;**39,41,46**;Dec 22,1997 > ; > ; > .; > ; ; Output: | ;Output: > ; > ; S ECXSTP=+$G(ECXSTP),ECXSTP2=+$G(ECXSTP2) | S ECXSTP=+$G(ECXSTP),ECXSTP2=+$G(ECXSTP2),ECXADT=+$G( S ECXADT=+$G(ECXADT),ECXVDT=+$G(ECXVDT) < > . ; > .. ; > ... ; > ... ; > ... ; > ... ; > ... ; > ; > ; > ; > ; > ; > ; ; Function called after determining CANCEL DATE in SU | ; Function called after determining CANCEL DATE in SU > ; > ; > ; > ; ; < TSMAP(ECXTS) ;Determines DSS Identifier for the following < ; treating speciality < ; Input: < ; ECXTS - Observation Treating Speciality < ; < ; Output: < ; DSS Identifier (Stop Code) < ; < N TS,SC,I < S TS="^18^23^24^36^41^65^94^",SC="^293^295^290^294^29 < F I=1:1:$L(TS) Q:$P(TS,"^",I)=ECXTS < Q $P(SC,"^",I)_"000" < Only in ./VADemo/r1/: ECXUTL5.m diff -y --suppress-common-lines ./VADemo/r1/ENLBL9.m ./VADemo/r2/r/ENLBL9.m ;;7.0;ENGINEERING;**12,35,80**;Aug 17, 1993 | ;;7.0;ENGINEERING;**12,35**;Aug 17, 1993 S IOP=ENEQION D ^%ZIS K IOP | S IOP=ENEQIO D ^%ZIS K IOP diff -y --suppress-common-lines ./VADemo/r1/ESPAJE.m ./VADemo/r2/r/ESPAJE.m ;;1.0;POLICE & SECURITY;**17,18,23,24,32,43**;Mar 31, | ;;1.0;POLICE & SECURITY;**17,18,23,24**;Mar 31, 1994 N DIC,DA,X,Y,FIRST,REC,TME | N DIC,DA,X,Y,FIRST,REC N TIME1,TIME2,ESPT,ESPT1,FCX,FC | N TIME1,TIME2,ESPT S ESPT=$G(^ESP(916,ESPDAT,1)),ESPT1=$P($P(ESPT,"^")," | S ESPT=$G(^ESP(916,ESPDAT,1)) .S TIME1="",TIME2="" | .S TIME1="" ..S X=$S(TIME1TIME2 TIME2=X | .S TIME2=$O(^TMP($J,ESPDAT,ESPT),-1) .Q:$G(TIME2)="" | .I TIME2="" S TIME2=$O(^TMP($J,ESPDAT,9999),-1) .S TIME2=$J($P(TIME2,".",2),4),TIME2=$TR(TIME2," ",0) | .Q:TIME2="" > .S TIME2=$J(TIME2,4),TIME2=$TR(TIME2," ",0) > .K ^TMP($J,ESPDAT) Q $G(TIME2) | Q TIME2 diff -y --suppress-common-lines ./VADemo/r1/ESPCRJO.m ./VADemo/r2/r/ESPCRJO.m ESPCRJO ;DALISC/SED - CREATE DAILY OPERATIONS JOURNAL ;3/99 | ESPCRJO ;DALISC/SED - CREATE DAILY OPERATIONS JOURNAL;3/99 ;;1.0;POLICE & SECURITY;**27,37,39**;Mar 31, 1994 | ;;1.0;POLICE & SECURITY;**27**;Mar 31, 1994 I X?4N S X="" W !!,$C(7),"*********Must key a full da < SET(NEWKEY,TYPE) ;PULL BADGE/RANK FOR SHIFT OFFICERS < S HESPN=DA,DIC="^VA(200,",DA=NEWKEY,DR="910.1;910.2", < S:TYPE=1 SX=POLINF(200,DA,910.1,"E") S:TYPE=2 SX=POLI < S DA=HESPN < K DIC,DIQ,POLINF,HESPN < Q SX < diff -y --suppress-common-lines ./VADemo/r1/ESPJOU1.m ./VADemo/r2/r/ESPJOU1.m ESPJOU1 ;DALISC/RWW - ENHANCED/MODIFIED PRINT DAILY OPERATION | ESPJOU1 ;DALISC/RWW - ENHANCED/MODIFIED PRINT DAILY OPERATION ;;1.0;POLICE & SECURITY;**1,7,12,14,18,32**;Mar 31, 1 | ;;1.0;POLICE & SECURITY;**1,7,12,14,18**;Mar 31, 1994 N ESPTIME,ESPTIME2,ESPT,%T | N ESPTIME,ESPTIME2,ESPT I ESPT S ESPT=$P($P(ESPT,"^"),"-",4) | I ESPT S ESPT=$P($P(^ESP(916,ESPID,1),"^",2),"-",4) > .S ESPT=+$P($P(^ESP(916,ESPID,1),"^",2),"-",4)+1 ...S ESPTIME2=ESPTIME | ...S ESPTIME2=+ESPTIME ...I +ESPTIME20 HDA=DA < S DIC="^VA(200,",DA=NEWKEY,DR="910.1;910.2",DIQ(0)="E < S:TYPE>0 SX=$S(TYPE=1:POLINF(200,DA,910.1,"E"),TYPE=2 < S:TYPE=0 ESPD(.11)=POLINF(200,DA,910.1,"E"),ESPD(.12) < K DIC,DIQ,POLINF < Q:TYPE=0 < S DA=HDA K HDA < Q SX < diff -y --suppress-common-lines ./VADemo/r1/ESPOFP.m ./VADemo/r2/r/ESPOFP.m ;;1.0;POLICE & SECURITY;**14,27,42**;Mar 31, 1994 | ;;1.0;POLICE & SECURITY;**14,27**;Mar 31, 1994 N ESPFACI < I PAGE>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:EN | I $E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END diff -y --suppress-common-lines ./VADemo/r1/ESPORP5.m ./VADemo/r2/r/ESPORP5.m ;;1.0;POLICE & SECURITY;**11,14,17,21,25,39**;Mar 31, | ;;1.0;POLICE & SECURITY;**11,14,17,21,25**;Mar 31, 19 W $G(^UTILITY("DIQ1",$J,200,DA,20.2,"E"))," # ",BAD | W $G(^UTILITY("DIQ1",$J,200,DA,20.2,"E"))," # ",$G( diff -y --suppress-common-lines ./VADemo/r1/ESPORP.m ./VADemo/r2/r/ESPORP.m ;;1.0;POLICE & SECURITY;**14,17,27,36,39,42**;Mar 31, | ;;1.0;POLICE & SECURITY;**14,17,27**;Mar 31, 1994 N ESPFACI < S DIC="^ESP(912,",DA=ESPID,DR=".02;.03;.04;.05;.06;.0 | S DIC="^ESP(912,",DA=ESPID,DR=".02;.03;.04;.05;.06;.0 S BADGE=^UTILITY("DIQ1",$J,912,DA,.11,"E") < EXIT K %ZIS,CL,DA,DIC,DIQ,DIR,DIRUT,DIWF,DIWL,DIWR,DR,END, | EXIT K %ZIS,CL,DA,DIC,DIQ,DIR,DIRUT,DIWF,DIWL,DIWR,DR,END, I PAGE>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:EN | I $E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END S PAGE=PAGE+1 W:PAGE'=1 @IOF W !?25,"DEPARTMENT OF VE | S PAGE=PAGE+1 W @IOF,!?25,"DEPARTMENT OF VETERANS AFF diff -y --suppress-common-lines ./VADemo/r1/ESPUCF.m ./VADemo/r2/r/ESPUCF.m ;;1.0;POLICE & SECURITY;**27,33,35**;Mar 31, 1994 | ;;1.0;POLICE & SECURITY;**27**;Mar 31, 1994 S %DT="AE",%DT(0)="-NOW",%DT("A")=" Beginning DATE : | S %DT="AE",%DT(0)="-NOW",%DT("A")=" Beginning DATE : ..S DIC="40.8",DR="1",DA=+ESPINS,DIQ="STA",DIQ(0)="I" < ..S STN=$G(STA(40.8,DA,DR,"I")) < ..K DA,DIC,DR,DIQ,STA < ...S ^ESP(912.3,ESPIEN,1,ESPINS,0)=ESPINS_"^"_STN | ...S ^ESP(912.3,ESPIEN,1,ESPINS,0)=ESPINS .. S ESPINS=$P($G(^ESP(914,ESPOFN,0)),U,10) S:ESPINS | .. S ESPINS=$P(^ESP(914,ESPOFN,0),U,7) Q:+ESPINS'>0 .. S DIC=40.8,DR="1",DA=+ESPINS,DIQ="STA",DIQ(0)="I" < .. I '$D(^ESP(912.3,ESPIEN,1,ESPINS)) S ^ESP(912.3,E < .. S ^ESP(912.3,ESPIEN,1,ESPINS,171)=$G(^ESP(912.3,E | .. S ^(171)=^ESP(912.3,ESPIEN,1,ESPINS,171)+1 .. I ESPTYPE="C" S ^ESP(912.3,ESPIEN,1,ESPINS,172)=$ | .. I ESPTYPE="C" S ^(172)=^ESP(912.3,ESPIEN,1,ESPINS ... I ESPCL'="M",ESPCL'="P" S ^ESP(912.3,ESPIEN,1,ES | ... I ESPCL'="M",ESPCL'="P" S ^(173)=^ESP(912.3,ESPI ... I ESPCL="M" S ^ESP(912.3,ESPIEN,1,ESPINS,174)=$G | ... I ESPCL="M" S ^(174)=^ESP(912.3,ESPIEN,1,ESPINS, ... I ESPCL="P" S ^ESP(912.3,ESPIEN,1,ESPINS,175)=$G | ... I ESPCL="P" S ^(175)=^ESP(912.3,ESPIEN,1,ESPINS, ... I ESPCAT="E"!(ESPCAT="PO") S ^ESP(912.3,ESPIEN,1 | ... I ESPCAT="E"!(ESPCAT="PO") S ^(176)=^ESP(912.3,E ... I ESPCAT="O"!(ESPCAT="") S ^ESP(912.3,ESPIEN,1,E | ... I ESPCAT="O"!(ESPCAT="") S ^(177)=^ESP(912.3,ESP ... I ESPCAT="P" S ^ESP(912.3,ESPIEN,1,ESPINS,178)=$ | ... I ESPCAT="P" S ^(178)=^ESP(912.3,ESPIEN,1,ESPINS ... I ESPCAT="V" S ^ESP(912.3,ESPIEN,1,ESPINS,179)=$ | ... I ESPCAT="V" S ^(179)=^ESP(912.3,ESPIEN,1,ESPINS .. I ESPTYPE="V" S ^ESP(912.3,ESPIEN,1,ESPINS,180)=$ | .. I ESPTYPE="V" S ^(180)=^ESP(912.3,ESPIEN,1,ESPINS ... I ESPCL'="M",ESPCL'="P" S ^ESP(912.3,ESPIEN,1,ES | ... I ESPCL'="M",ESPCL'="P" S ^(181)=^ESP(912.3,ESPI ... I ESPCL="M" S ^ESP(912.3,ESPIEN,1,ESPINS,182)=$G | ... I ESPCL="M" S ^(182)=^ESP(912.3,ESPIEN,1,ESPINS, ... I ESPCL="P" S ^ESP(912.3,ESPIEN,1,ESPINS,183)=$G | ... I ESPCL="P" S ^(183)=^ESP(912.3,ESPIEN,1,ESPINS, ... I ESPCAT="E"!(ESPCAT="PO") S ^ESP(912.3,ESPIEN,1 | ... I ESPCAT="E"!(ESPCAT="PO") S ^(184)=^ESP(912.3,E ... I ESPCAT="O"!(ESPCAT="") S ^ESP(912.3,ESPIEN,1,E | ... I ESPCAT="O"!(ESPCAT="") S ^(185)=^ESP(912.3,ESP ... I ESPCAT="P" S ^ESP(912.3,ESPIEN,1,ESPINS,186)=$ | ... I ESPCAT="P" S ^(186)=^ESP(912.3,ESPIEN,1,ESPINS ... I ESPCAT="V" S ^ESP(912.3,ESPIEN,1,ESPINS,187)=$ | ... I ESPCAT="V" S ^(187)=^ESP(912.3,ESPIEN,1,ESPINS K STN < diff -y --suppress-common-lines ./VADemo/r1/ESPUCFP3.m ./VADemo/r2/r/ESPUCFP3.m ;;1.0;POLICE & SECURITY;**27,35**;Mar 31, 1994 | ;;1.0;POLICE & SECURITY;**27**;Mar 31, 1994 . W ?40,"$1000 & Above : ",$G(^UTILITY | . W ?40,"$1000 & Above : ",$G(^UTILIT . W !?40,"< $1000 : ",$G(^UTILIT | . W !?40,"< $1000 : ",$G(^UTILI . W ?40,"$1000 & Above : ",$G(^UTILITY | . W ?40,"$1000 & Above : ",$G(^UTILIT . W !?40,"< $1000 : ",$G(^UTILIT | . W !?40,"< $1000 : ",$G(^UTILI diff -y --suppress-common-lines ./VADemo/r1/ESPUCFP.m ./VADemo/r2/r/ESPUCFP.m ;;1.0;POLICE & SECURITY;**27,35**;Mar 31, 1994 | ;;1.0;POLICE & SECURITY;**27**;Mar 31, 1994 I VAUTD=1 K ^ESP(912.3,ESPIEN,1,9999) S ^ESP(912.3,ES < . F ESPN=0:0 S ESPN=$O(^ESP(912.3,ESPIEN,1,ESPN)) Q: < .. F CTR=0:0 S CTR=$O(^ESP(912.3,ESPIEN,1,ESPN,CTR) < ... S CAMT=$G(^ESP(912.3,ESPIEN,1,ESPN,CTR)) < ... S ^ESP(912.3,ESPIEN,1,9999,CTR)=$G(^ESP(912.3, < K:VAUTD=1 CAMT,CTR < S HOF=0,TFAC=0 < F ESPN=0:0 S ESPN=$O(^ESP(912.3,ESPIEN,1,ESPN)) Q:ESP | F ESPN=0:0 S ESPN=$O(^ESP(912.3,ESPIEN,1,ESPN)) Q:ESP .I TFAC=1,ESPN=9999 Q < .S TFAC=TFAC+1 < K %ZIS,BEGDATE,DA,DIC,DIQ,DR,END,ESPIEN,ESPN,HOF,PAGE | K %ZIS,BEGDATE,DA,DIC,DIQ,DR,END,ESPIEN,ESPN,PAGE,TOT S PAGE=PAGE+1 W:HOF=1 @IOF W !?25,"DEPARTMENT OF VETE | S PAGE=PAGE+1 W @IOF,!?25,"DEPARTMENT OF VETERANS AFF S:ESPN=9999 ESPFACI="*** ALL DIVISIONS ***" | S ESPFACI=$P(^ESP(912.3,ESPIEN,1,ESPN,0),U) S:ESPN'=9999 ESPFACI=$P(^ESP(912.3,ESPIEN,1,ESPN,0),U | S ESPFACI=$P($G(^DG(40.8,ESPFACI,0)),U,1) W !!,"VA Facility: ",ESPFACI | W !!,"VA Facility ",ESPFACI W ?52,"BEGINNING DATE: ",$G(^UTILITY("DIQ1",$J,912.3, | W ?45,"BEGINNING DATE: ",$G(^UTILITY("DIQ1",$J,912.3, W !,"Date/Time Printed",?52,"ENDING DATE: ",$G(^UTILI | W !,"Date/Time Printed",?45,"ENDING DATE: ",$G(^UTILI S HOF=1 < diff -y --suppress-common-lines ./VADemo/r1/ESPUCR.m ./VADemo/r2/r/ESPUCR.m ;;1.0;POLICE & SECURITY;**17,22,33**;Mar 31, 1994 | ;;1.0;POLICE & SECURITY;**17,22**;Mar 31, 1994 S %DT="AE",%DT(0)="-NOW",%DT("A")=" Beginning DATE : | S %DT="AE",%DT(0)="-NOW",%DT("A")=" Beginning DATE : diff -y --suppress-common-lines ./VADemo/r1/ESPUVN.m ./VADemo/r2/r/ESPUVN.m ;;1.0;POLICE & SECURITY;**4,35**;Mar 31, 1994 | ;;1.0;POLICE & SECURITY;**4**;Mar 31, 1994 FAC K DIC S DIC("A")="Select Facility: ",DIC(0)="QAEMZ",D < G:$D(DTOUT)!$D(DUOUT)!(+Y'>0) EXIT < S ESPFAC=+Y < D ^DIR K DIR G:$D(DIRUT) EXIT S ESPD(.02)=Y,ESPD(.1)= | D ^DIR K DIR G:$D(DIRUT) EXIT S ESPD(.02)=Y S ^ESP(914,ESPVIO,0)=ESPVIO_"^"_ESPD(.02)_"^V^"_ESPD( | S ^ESP(914,ESPVIO,0)=ESPVIO_"^"_ESPD(.02)_"^V^"_ESPD( S ^ESP(914,ESPVIO,0)=ESPVIO_"^"_ESPD(.02)_"^C^"_ESPD( | S ^ESP(914,ESPVIO,0)=ESPVIO_"^"_ESPD(.02)_"^C^"_ESPD( EXIT K ESPFAC,ESPD,ESPFN,ESPTYPE,ESPVIO,ESPX,^TMP($J) | EXIT K ESPD,ESPFN,ESPTYPE,ESPVIO,ESPX,^TMP($J) diff -y --suppress-common-lines ./VADemo/r1/ESPWR.m ./VADemo/r2/r/ESPWR.m ;;1.0;POLICE & SECURITY;**17,33**;Mar 31, 1994 | ;;1.0;POLICE & SECURITY;**17**;Mar 31, 1994 S %DT="AE",%DT(0)="-NOW",%DT("A")=" Beginning DATE : | S %DT="AE",%DT(0)="-NOW",%DT("A")=" Beginning DATE : diff -y --suppress-common-lines ./VADemo/r1/FBAACCB1.m ./VADemo/r2/r/FBAACCB1.m FBAACCB1 ;AISC/GRR-CLERK CLOSE BATCH CONTINUED ;8/7/20 | FBAACCB1 ;AISC/GRR-CLERK CLOSE BATCH CONTINUED ;09MAR8 ;;3.5;FEE BASIS;**55,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 CMORE N FBADJLR,FBFPPSC,FBFPPSL,FBX,FBY3 | CMORE S K=$P(Z(0),"^",3),J=$P(Z(0),"^",4) D ENV^FBAACCB0 S S K=$P(Z(0),"^",3),J=$P(Z(0),"^",4) D ENV^FBAACCB0 S < S FBY3=$G(^FBAAI(I,3)) < S FBFPPSC=$P(FBY3,U) < S FBFPPSL=$P(FBY3,U,2) < S FBX=$$ADJLRA^FBCHFA(I_",") < S FBADJLR=$P(FBX,U) < W N,?35,S,?60,B(1617) | W N,?35,S,?60,B(1617),!,?3,V,?45,VID,?58,FBIN,?70,$$D W !,?3,V,?45,VID,?58,FBIN,?70,$$DATX^FBAAUTL($E(FBIN( | W:$P(Z(0),"^",24) ?56,"Discharge ",$P($G(^ICD(+$P(Z(0 I FBFPPSC]"" W !,?4,"FPPS Claim ID: ",FBFPPSC," FPP < W !,$S($D(QQ):QQ_")",1:""),FBVP,$S(FBCAN]"":"+",1:"") < W:$P(Z(0),"^",24) ?56,"Discharge ",$$ICD^FBCSV1(+$P(Z < W !,?3,"Vendor Name",?45,"Vendor ID",?57,"Invoice #", | W !,?3,"Vendor Name",?45,"Vendor ID",?57,"Invoice #", WRTDX W ?4,"Dx: ",$$ICD9^FBCSV1($P(FBDX,"^",FBK),$P($G(Z(0) | WRTDX W ?4,"Dx: ",$S($D(^ICD9($P(FBDX,"^",FBK),0)):$P(^(0), WRTPC W ?4,"Proc: ",$$ICD0^FBCSV1($P(FBPROC,"^",FBL),$P($G( | WRTPC W ?4,"Proc: ",$S($D(^ICD0($P(FBPROC,"^",FBL),0)):$P(^ MORE ; | MORE S J=$P(Z(0),"^",5),D=$P(Z(0),"^",3),FBAACPT=$P(Z(0)," N FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBX,TAMT < S J=$P(Z(0),"^",5),D=$P(Z(0),"^",3),FBAACPT=$P(Z(0)," < ; < S FBFPPSC=$P($G(^FBAA(162.1,A,0)),U,13) < S FBFPPSL=$P($G(^FBAA(162.1,A,"RX",B2,3)),U) < S FBX=$$ADJLRA^FBRXFA(B2_","_A_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S TAMT=$FN($P(Z(0),"^",7),"",2) < ; < diff -y --suppress-common-lines ./VADemo/r1/FBAACCB.m ./VADemo/r2/r/FBAACCB.m FBAACCB ;AISC/GRR-CLERK CLOSE BATCH ;8/7/2003 | FBAACCB ;AISC/GRR-CLERK CLOSE BATCH ;6/21/1999 ;;3.5;FEE BASIS;**4,61,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 SET ; | SET S N=$S($D(^DPT(J,0)):$P(^DPT(J,0),"^",1),1:""),S=$S(N N FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBX,FBY3,TAMT < S N=$S($D(^DPT(J,0)):$P(^DPT(J,0),"^",1),1:""),S=$S(N < S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3)) < S FBFPPSC=$P(FBY3,U) < S FBFPPSL=$P(FBY3,U,2) < S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S TAMT=$FN($P(Y,"^",4),"",2) < S CPTDESC=$$CPT^FBAAUTL4($P(Y,U),1,D) | S CPTDESC=$$CPT^FBAAUTL4($P(Y,U),1) I FBTYPE="B3" W ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$S($ | W ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$S($G(FBMODLE)]"": I FBTYPE="B5" W ?4,$$DATX^FBAAUTL(D),?14,FBAACPT_$S($ < W !?4,$J(A1,6),?17,$J(A2,6) < ; write adjustment reasons, if null then write suspen < W ?30,$S(FBADJLR]"":FBADJLR,1:T) < ; write adjustment amounts, if null then write amount < W ?41,$S(FBADJLA]"":FBADJLA,1:TAMT) < I FBTYPE="B3" D | W !,?1,$S(FBTYPE="B3":"SVC DATE CPT-MOD",1:"RX DA . W !,?4,"SVC DATE",?14,"CPT-MOD",?24,"SERVICE PROVID < . W !,?4,"CLAIMED",?17,"PAID",?30,"ADJ CODE",?41,"ADJ < I FBTYPE="B5" D < . W !,?4,"RX DATE",?14,"RX #",?24,"DRUG NAME",?56,"F < . W !,?4,"CLAIMED",?17,"PAID",?30,"ADJ CODE",?41,"ADJ < W !,Q,! < diff -y --suppress-common-lines ./VADemo/r1/FBAACIE.m ./VADemo/r2/r/FBAACIE.m FBAACIE ;AISC/GRR-COMPLETE PHARMACY INVOICE ;7/17/2003 | FBAACIE ;AISC/GRR-COMPLETE PHARMACY INVOICE ;11/1/2001 ;;3.5;FEE BASIS;**38,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**38**;JAN 30, 1995 K FBADJ,FBFPPSC,FBFPPSL,FBRRMK < S FBFPPSC=$P(Y,U,13) < S FBFPPSL=$P($G(^FBAA(162.1,FBIN,"RX",J,3)),U) < W !,"FPPS Claim ID: ",$S(FBFPPSC="":"N/A",1:FBFPPSC) < W ?28,"FPPS Line Item: ",$S(FBFPPSL="":"N/A",1:FBFPPS < ;S DR(1,162.11,2)="S:(FBAC-FBAP)'>0 Y=8;6///^S X=FBAC | S DR(1,162.11,2)="S:(FBAC-FBAP)'>0 Y=8;6///^S X=FBAC- S DR(1,162.11,2)="S FBX=$$ADJ^FBUTL2(FBAC-FBAP,.FBADJ | D ^DIE K DIE Q:$D(Y)'=0 S:$D(FBAP) FBINTOT=FBINTOT+F S DR(1,162.11,3)="S FBX=$$RR^FBUTL4(.FBRRMK,2);8////^ < D ^DIE K DIE Q:$D(Y)'=0 < S:$D(FBAP) FBINTOT=FBINTOT+FBAP < S $P(^FBAA(162.1,FBIN,0),"^",7)=FBINTOT < G:$D(DTOUT) H^XUS < ; file adjustments < D FILEADJ^FBRXFA(DA_","_FBIN_",",.FBADJ) < ; file remittance remarks < D FILERR^FBRXFR(DA_","_FBIN_",",.FBRRMK) < diff -y --suppress-common-lines ./VADemo/r1/FBAACO0.m ./VADemo/r2/r/FBAACO0.m FBAACO0 ;AISC/GRR-DISPLAY PATIENT ADDRESS DATA AND EDIT ;7/13 | FBAACO0 ;AISC/GRR-DISPLAY PATIENT ADDRESS DATA AND EDIT ;10/3 ;;3.5;FEE BASIS;**4,38,52,57,61,75,70**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,38**;JAN 30, 1995 N FBEDPTAD S (FBEDPTAD(1),FBEDPTAD(2))=0 | W @IOF,?19,"Patient: ",$P(^DPT(DFN,0),"^") S (Y(0),H W @IOF,"Patient: ",$P(^DPT(DFN,0),"^") S (Y(0),HY(0) < S FBEDPTAD(1)=$$ISCCADR() | F Z=1:1:3 I VAPA(Z)]"" W !?12,"Address Line ",Z,": " S FBEDPTAD(2)="N" | W !?22,"City: ",VAPA(4),!?21,"State: ",$P(VAPA(5),U I $$CCADR(2) | W !?23,"Zip: ",$S(+$G(VAPA(11)):$P(VAPA(11),U,2),1:V W !!,"Patient's Permanent address:" < F Z=1:1:3 I VAPA(Z)]"" W !?2,"Address Line ",Z,":",?1 < W !?2,"City:",?18,VAPA(4),!?2,"State:",?18,$P(VAPA(5) < W !?2,"Zip:",?18,$S(+$G(VAPA(11)):$P(VAPA(11),U,2),1: < RD W ! S DIR("A")="Want to edit Permanent Address data", | RD W ! S DIR("A")="Want to edit Address data",DIR("B")=" EDIT I $G(FBEDPTAD(2))'="N" W !! S HY(0)=$G(^DPT(DFN,.11)) | EDIT W !! S HY(0)=$G(^DPT(DFN,.11)),DA=DFN,DIC="^DPT(",DIE I $$EDTCCADR()=0 I FBTT'=1 I FBEDPTAD(2)="N" Q < > . . N FBX1 . E W !?2,"Payment is for a contracted service so fe | . . ; use 70% of fee schedule amount if payment under > . . S FBX1=$J(FBFSAMT*$S(FB1725:.7,1:1),0,2) > . . ; set default amount paid to lesser of amt claime > . . S FBAMTPD=$S(FBX1>J:J,FBX1>0:FBX1,1:"") > . ; > . I $G(FBAAMM1) D > . . W !,?2,"Payment is for a contracted service so fe . E W !?2,"Unable to determine a FEE schedule amount | . E W !?2,"Unable to determine a FEE schedule amount . ; < . . W !!?2,"**Payment is for emergency treatment unde | . . W !?2,"**Payment is for emergency treatment under . . I FBFSAMT D | . . I $G(FBFSAMT) W !?2," Therefore, fee schedule am . . . S FBFSAMT=$J(FBFSAMT*.7,0,2) < . . . W !?2," Therefore, fee schedule amount reduced < . ; < . I $G(FBUNITS)>1 D < . . W !!?2,"Units Paid = ",FBUNITS < . . Q:FBFSAMT'>0 < . . N FBFSUNIT < . . ; determine if fee schedule can be multipled by u < . . S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBAADT>3 < . . I FBFSUNIT D < . . . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2) < . . . W !?2," Therefore, fee schedule amount increas < . . E D < . . . W !?2," Fee schedule not complied on per unit < . ; < . I '$G(FBAAMM1) D < . . ; set default amount paid to lesser of amt claime < . . S FBAMTPD=$S(FBFSAMT>J:J,FBFSAMT>0:FBFSAMT,1:"") < . ; < . W ! < ; < Q < ;print Confidential Communication address < ;ADD^VADPT must be invoked before this call < ;FBDFN -patient's DFN < ;FBSTPOS - position to start print < ;returns 0 if there is no active CC address < ;returns 1 if active < CCADR(FBSTPOS) ; < N FBACT < S FBACT=0 < I '$D(VAPA(12)) Q 0 ;if D ADD^VADPT was not invoked < I 'VAERR D < . S FBACT=$$ACTIVECC() < . Q:'FBACT < . W !!,"Confidential Communication address until: "_$ < . I $G(VAPA(13))]"" W !?FBSTPOS,"Line 1: ",$G(VAPA(13 < . I $G(VAPA(14))]"" W " Line 2: ",$G(VAPA(14)) < . I $G(VAPA(15))]"" W !?FBSTPOS,"Line 3: ",$G(VAPA(15 < . W !?FBSTPOS,"City:",?9,$S($G(VAPA(16))]"":$G(VAPA(1 < . W ?40,"State:",?47,$S($P($G(VAPA(17)),U,2)]"":$P($G < . W !?FBSTPOS,"Zip:",?9,$P($G(VAPA(18)),U,2) < . W ?20,"County:",?28,$P($G(VAPA(19)),U,2) < Q $G(FBACT) < ; < ;is called after ADD^VADPT to verify whether confiden < ;active or not to encapsulate the logic related to st < ;input: VAPA < ACTIVECC() ; < Q (+$G(VAPA(12))=1)&($P($G(VAPA(22,3)),"^",3)="Y") < ; < ;edit confidential address < ;returns 1 if CC address has been edited < ;otherwise - 0 < EDTCCADR() ; < Q:'$G(DFN) 0 < I FBEDPTAD(1)=0 D < . N VAPA S VAPA("P")="" D ADD^VADPT S FBEDPTAD(1)=$$I < I FBEDPTAD(1)'="N" D < . W:FBEDPTAD(1)'="B" !!,"WARNING: The Confidential ad < . S DIR("A")="Want to edit Confidential Address data" < E S DIR("A")="Want to add Confidential Address data" < W ! S DIR("B")="No",DIR(0)="Y" < D ^DIR K DIR < Q:($D(DIRUT)) 0 < ;Registration API < I Y D QUES^DGRPU1(+DFN,"ADD4") Q 1 < Q 0 < ; < ;returns "B" if patient has any (active or inactive) < ;returns "Y" if patient has any (active or inactive) < ;otherwise returns "N" < ISCCADR() ; < Q:($P($G(VAPA(22,3)),"^",3)="Y") "B" < Q:'$O(VAPA(22,0)) "N" < Q "Y" < ; < ;FBAACO0 < diff -y --suppress-common-lines ./VADemo/r1/FBAACO1.m ./VADemo/r2/r/FBAACO1.m FBAACO1 ;AISC/GRR-ENTER PAYMENT CONTINUED ;7/17/2003 | FBAACO1 ;AISC/GRR-ENTER PAYMENT CONTINUED ;6/14/1999 ;;3.5;FEE BASIS;**4,61,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 W ! S DLAYGO=162,DIC="^FBAAC("_DFN_",1,"_FBV_",1,"_FB | W ! S DLAYGO=162,DIC="^FBAAC("_DFN_",1,"_FBV_",1,"_FB D < . N ICPTVDT S ICPTVDT=$G(FBAADT) D ^DIC < K DIC,DLAYGO,DA I Y<0 S FBAAOUT=1 Q < I '$D(^FBAAC("AJ",FBAABE,X)) D G GETINV1 < . W !,$C(7),"Only previously entered invoices in the < diff -y --suppress-common-lines ./VADemo/r1/FBAACO2.m ./VADemo/r2/r/FBAACO2.m FBAACO2 ;AISC/GRR-PAYMENT PROCESS FOR DUPLICATE ;7/13/2003 | FBAACO2 ;AISC/GRR-PAYMENT PROCESS FOR DUPLICATE ;5/27/1999 ;;3.5;FEE BASIS;**4,55,61,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 S DR="49///^S X=$G(FBCSID);50///^S X=$G(FBFPPSC);I $G | S DR="I $G(FBDEN) S Y=1;D PPT^FBAACO1();34///^S X=$G( S DR(1,162.03,1)="D PPT^FBAACO1();34///^S X=$G(FBAAMM | S DR(1,162.03,1)="S:J-K=0 Y=6;3//^S X=$S(J-K:J-K,1:"" ;S DR(1,162.03,2)="S:J-K=0 Y=6;3//^S X=$S(J-K:J-K,1:" | S DR(1,162.03,2)="7////^S X=FBAABE;8////^S X=BO;13/// S DR(1,162.03,2)="S FBX=$$ADJ^FBUTL2(J-K,.FBADJ,2);S: < S DR(1,162.03,3)="7////^S X=FBAABE;8////^S X=BO;13/// < .N FBCSVSTR S FBCSVSTR="I X]"""" S:$$INPICD9^FBCSV1(X | .S DR(1,162.03,3)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y .S DR(1,162.03,4)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y | .S DR(1,162.03,4)="15///^S X=FBPT;16////^S X=FBPOV;17 .S DR(1,162.03,5)="15///^S X=FBPT;S FBX=$$RR^FBUTL4(. | S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",DA(3) .S DR(1,162.03,6)="16////^S X=FBPOV;17///^S X=FBTT;18 < S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1," < S DA(3)=DFN,DA(2)=FBV,DA(1)=FBSDI,DA=FBAACPI < D LOCK^FBUCUTL("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_", < D < . N ICDVDT S ICDVDT=$G(FBAADT) D ^DIE < I '$D(DTOUT),$G(FBTST) D < . D FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_ < . D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_" < L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI) < K FBTST,FBDEN,FBAAMM1,DIE,DR,DA,FBX | K FBTST,FBDEN,FBAAMM1,DIE,DR,DA diff -y --suppress-common-lines ./VADemo/r1/FBAACO3.m ./VADemo/r2/r/FBAACO3.m FBAACO3 ;AISC/GRR-ENTER PAYMENT CONTINUED ;7/7/2003 | FBAACO3 ;AISC/GRR-ENTER PAYMENT CONTINUED ;10/31/2001 ;;3.5;FEE BASIS;**4,38,55,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,38**;JAN 30, 1995 N FB1725,FBFPPSC | N FB1725 W ! S FBAACP(0)=FBAACP | W ! S (FBAACP(0),X)=FBAACP,DIC="^FBAAC("_DFN_",1,"_FB S DIC="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1," < S DIC(0)="EQMZ",DA(3)=DFN,DA(2)=FBV,DA(1)=FBSDI < S X=$$CPT^FBAAUTL4(FBAACP) < D ^DIC I Y<0 S FBAAOUT=1 Q < ; load current adjustment data < D LOADADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_", < ; save adjustment data prior to edit session in sorte < S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of or < ; load current remittance remark data < D LOADRR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_"," < ; save remittance remarks prior to edit session in so < S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK) < ; load FPPS data < S FBFPPSC=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3) < S FBFPPSL=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3) < S DR="48;47;S FBUNITS=X;42R;S FBZIP=X;S:$$ANES^FBAAFS | S DR="42R;S FBZIP=X;S:$$ANES^FBAAFS($$CPT^FBAAUTL4(FB ;S DR(1,162.03,3)="3//^S X=$S(J-K:J-K,1:"""");4;S:X'= | S DR(1,162.03,3)="3//^S X=$S(J-K:J-K,1:"""");4;S:X'=4 S DR(1,162.03,3)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ | S DR(1,162.03,3)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y= S DR(1,162.03,4)="S:FBFPPSC="""" Y=13;W !,""FPPS CLAI < S DR(1,162.03,5)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y= < S DR(1,162.03,6)="@7;K FBRRMKD;M FBRRMKD=FBRRMK;S FBX < D ^DIE | D ^DIE L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI) K FBOT, ; if adjustment data changed then file < I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBAAFA(F < ; if remit remark data changed then file < I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBAAFR(F < L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI) K FBOT,DIE,DR, < > . N FBX1 E D | . ; use 70% of fee schedule amount if payment under 3 > . S FBX1=$J(FBFSAMT*$S(FB1725:.7,1:1),0,2) > . ; set default amount paid to lesser of amt claimed > . S FBAMTPD=$S(FBX1'>0:J,FBX1>J:J,1:FBX1) > I $G(FBAAMM1) D E W !?2,"Unable to determine a FEE schedule amount." | E W !?2,"Unable to determine a FEE schedule amount." ; < . W !!?2,"**Payment is for emergency treatment under | . W !?2,"**Payment is for emergency treatment under 3 . I FBFSAMT D | . I $G(FBFSAMT) W !?2," Therefore, fee schedule amou . . S FBFSAMT=$J(FBFSAMT*.7,0,2) < . . W !?2," Therefore, fee schedule amount reduced t < ; < I $G(FBUNITS)>1 D < . W !!?2,"Units Paid = ",FBUNITS < . Q:FBFSAMT'>0 < . N FBFSUNIT < . ; determine if fee schedule can be multipled by uni < . S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBAADT>304 < . I FBFSUNIT D < . . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2) < . . W !?2," Therefore, fee schedule amount increased < . E D < . . W !?2," Fee schedule not complied on per unit ba < ; < I '$G(FBAAMM1) D < . ; set default amount paid to lesser of amt claimed < . S FBAMTPD=$S(FBFSAMT'>0:J,FBFSAMT>J:J,1:FBFSAMT) < W ! < diff -y --suppress-common-lines ./VADemo/r1/FBAACO5.m ./VADemo/r2/r/FBAACO5.m ;;3.5;FEE BASIS;**73,79**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 TRYAGAIN ; < ;if date of service input transform called skip check | S FBSDI=+Y,FBAADT=$P(Y,"^",2) I FBASSOC>0 S $P(^FBAAC I $D(HOLDY) GOTO DONASK < I $D(FBAAID),$P(Y,"^",2)>FBAAID W !!,*7,"Date of Serv < I $D(FBAABDT),$D(FBAAEDT),($P(Y,"^",2)0 S DA(2)=DFN < diff -y --suppress-common-lines ./VADemo/r1/FBAACO.m ./VADemo/r2/r/FBAACO.m FBAACO ;AISC/GRR-ENTER MEDICAL PAYMENT ;7/13/2003 | FBAACO ;AISC/GRR-ENTER MEDICAL PAYMENT ;8/17/1999 ;;3.5;FEE BASIS;**4,61,79**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 ; ask patient account number < S FBCSID=$$ASKPAN^FBUTL5() I FBCSID="^" K FBCSID S FB < ; if U/C then get FPPS Claim ID else ask user < I $D(FB583) S FBFPPSC=$P($G(^FB583(FB583,5)),U) W !," < E S FBFPPSC=$$FPPSC^FBUTL5() I FBFPPSC=-1 K FBFPPSC < SVDT K FBAAOUT,HOLDY W !! D GETSVDT^FBAACO5(DFN,FBV,FBASSO | SVDT K FBAAOUT W !! D GETSVDT^FBAACO5(DFN,FBV,FBASSOC,1) I K FBCSID,FBFPPSC,FBFPPSL,FBADJ,FBADJD,FBADJL,FBRRMK,F < diff -y --suppress-common-lines ./VADemo/r1/FBAACP1.m ./VADemo/r2/r/FBAACP1.m FBAACP1 ;AISC/CMR-C&P PAYMENT DRIVER ;7/17/2003 | FBAACP1 ;AISC/CMR-C&P PAYMENT DRIVER ;5/17/1999 ;;3.5;FEE BASIS;**4,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 S DR(1,162.03,1)="34///^S X=$G(FBAAMM1);28////^S X=FB | S DR(1,162.03,1)="34///^S X=$G(FBAAMM1);28////^S X=FB D LOCK^FBUCUTL("^FBAAC(",DFN,1) | D LOCK^FBUCUTL("^FBAAC(",DFN,1),^DIE L -^FBAAC(DFN) D ^DIE < I $G(FBTST) D < . D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_" < L -^FBAAC(DFN) < diff -y --suppress-common-lines ./VADemo/r1/FBAACP.m ./VADemo/r2/r/FBAACP.m FBAACP ;AISC/CMR-C&P PAYMENT DRIVER ;7/13/2003 | FBAACP ;AISC/CMR-C&P PAYMENT DRIVER ;11/1/2001 ;;3.5;FEE BASIS;**4,38,55,61,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,38**;JAN 30, 1995 ; prompt revenue code < S FBAARC=$$ASKREVC^FBUTL5() I FBAARC="^" S FBAAOUT=1 < ; prompt units paid < S FBUNITS=$$ASKUNITS^FBUTL5() I FBUNITS="^" S FBAAOUT < ; prompt for remittance remarks < I $$RR^FBUTL4(.FBRRMK,2)=0 S FBAAOUT=1 G CLN < K FBAAOUT D G Q:$G(FBAAOUT) | K FBAAOUT S I=28,DIR(0)="PO^80:EMQZ",DIR("A")="PRIMAR . N ICDVDT S ICDVDT=$G(FBAADT) < . F D Q:$G(FBAAOUT) Q:($$INPICD9^FBCSV1(+$G(Y),"", < . . S I=28,DIR(0)="PO^80:EMQZ",DIR("A")="PRIMARY DIAG < ; < E D | . S FBAMTPD=FBFSAMT > I $G(FBAAMM1) D ; < E W !?2,"Unable to determine a FEE schedule amount." | E W !?2,"Unable to determine a FEE schedule amount." ; < I $G(FBUNITS)>1 D < . W !!?2,"Units Paid = ",FBUNITS < . Q:FBFSAMT'>0 < . N FBFSUNIT < . ; determine if fee schedule can be multipled by uni < . S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBAADT>304 < . I FBFSUNIT D < . . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2) < . . W !?2," Therefore, fee schedule amount increased < . E D < . . W !?2," Fee schedule not complied on per unit ba < ; < I '$G(FBAAMM1) S FBAMTPD=FBFSAMT < ; < . W !,"You must use the Enter Payment option for CPT | . W !,"You must use the Enter Payment option for CPT W ! < diff -y --suppress-common-lines ./VADemo/r1/FBAACR.m ./VADemo/r2/r/FBAACR.m ;;3.5;FEE BASIS;**4,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 .F S FBB=$O(^FBAAC("AK",FBDT,DFN,FBA,FBB)) Q:FBB'>0 | .F S FBB=$O(^FBAAC("AK",FBDT,DFN,FBA,FBB)) Q:FBB'>0 ..S FBPTC=$P(FBPMT,"^",17),FBAMT=$P(FBPMT,"^",3),FBNA | ..S FBPTC=$P(FBPMT,"^",17),FBAMT=$P(FBPMT,"^",3),FBNA ..S FBPMT=^TMP($J,"FBAACR",FBNAME,FBA,FBB,FBC),FBPTC= | ..S FBPMT=^TMP($J,"FBAACR",FBNAME,FBA,FBB,FBC),FBPTC= END K FBSRVDT,FBPMT,FBNAME,DFN,FBAAOUT,FBA,FBB,FBC,FBAMT, | END K FBPMT,FBNAME,DFN,FBAAOUT,FBA,FBB,FBC,FBAMT,FBPTC,FB diff -y --suppress-common-lines ./VADemo/r1/FBAADEM1.m ./VADemo/r2/r/FBAADEM1.m ;;3.5;FEE BASIS;**13,51**;JAN 30, 1995 | ;;3.5;FEE BASIS;**13**;JAN 30, 1995 EN N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA | N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA PDF S:Y Y=$$FMTE^XLFDT(Y,5) ; TRANSLATE TO DISPLAY DATE | PDF S:Y Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) diff -y --suppress-common-lines ./VADemo/r1/FBAADEM.m ./VADemo/r2/r/FBAADEM.m FBAADEM ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;2/12/2003 | FBAADEM ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;14MAY92 ;;3.5;FEE BASIS;**52**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 N FBCCADR S FBCCADR=$$CCADR^FBAACO0(0) < I FBCCADR>0,$E(IOST,1,2)="C-" W ! S DIR(0)="E" D ^DIR < Only in ./VADemo/r1/: FBAAEPI1.m diff -y --suppress-common-lines ./VADemo/r1/FBAAEPI.m ./VADemo/r2/r/FBAAEPI.m FBAAEPI ;AISC/GRR-EDIT PREVIOUSLY ENTERED PHARMACY INVOICE ;7 | FBAAEPI ;AISC/GRR-EDIT PREVIOUSLY ENTERED PHARMACY INVOICE ;1 ;;3.5;FEE BASIS;**38,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**38**;JAN 30, 1995 S (DA,FBDA)=+Y,DIE=DIC | S (DA,FBDA)=+Y,DIE=DIC,DR="1;Q;12;3;5" D ^DIE K DIC ; save FPPS data prior to edit session < S (FBFPPSC,FBFPPSC(0))=$P($G(^FBAA(162.1,FBDA,0)),U,1 < S DR="1;Q;12;S FBX=$$FPPSC^FBUTL5(1,FBFPPSC);S:FBX=-1 < D ^DIE K DIC < ; if FPPS CLAIM ID changed, then update Rx's < I FBFPPSC'=FBFPPSC(0) D CKINVEDI^FBAAEPI1(FBFPPSC(0), < ; get current value of FPPS LINE ITEM to use as defau | S DR=".01;1;1.5;1.6;3;S FBJ=X;I $P(^FBAA(162.1,DA(1), S FBFPPSL=$P($G(^FBAA(162.1,FBDA,"RX",DA,3)),U) | S DR(1,162.11,1)="S FBA=$P(^FBAA(162.1,DA(1),""RX"",D ; load current adjustment data | S DR(1,162.11,2)="@12;S FBHAP=$P(^FBAA(162.1,DA(1),"" D LOADADJ^FBRXFA(DA_","_FBDA_",",.FBADJ) | S DR(1,162.11,3)="I FBK>FBJ S $P(^FBAA(162.1,DA(1),"" ; save adjustment data prior to edit session in sorte | S DR(1,162.11,4)="S:FBJ=FBK Y=""@5"";6////^S X=FBJ-FB S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of or < ; load current remittance remark data < D LOADRR^FBRXFR(DA_","_FBDA_",",.FBRRMK) < ; save remittance remarks prior to edit session in so < S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK) < S DR=".01;S:FBFPPSC="""" Y=1;S FBX=$$FPPSL^FBUTL5(FBF < S DR(1,162.11,1)="S FBA=$P($G(^FBAA(162.1,DA(1),""RX" < S DR(1,162.11,2)="@12;S FBHAP=$P(^FBAA(162.1,DA(1),"" < S DR(1,162.11,3)="@20;I FBK>FBJ S $P(^FBAA(162.1,DA(1 < ;S DR(1,162.11,4)="S:FBJ=FBK Y=""@5"";6////^S X=FBJ-F < S DR(1,162.11,4)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ < S DR(1,162.11,5)="K FBRRMKD;M FBRRMKD=FBRRMK;S FBX=$$ < ; if adjustment data changed then file < I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBRXFA(D < ; if remit remark data changed then file < I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBRXFR(D < K FBADJ,FBADJD,FBADJL,FBFPPSC,FBFPPSL,FBRRMK,FBRRMKD, < Only in ./VADemo/r1/: FBAAFA.m Only in ./VADemo/r1/: FBAAFED.m Only in ./VADemo/r1/: FBAAFR.m diff -y --suppress-common-lines ./VADemo/r1/FBAAFS.m ./VADemo/r2/r/FBAAFS.m ;;3.5;FEE BASIS;**4,53,71**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 S FCODE="^21^22^23^24^26^31^34^41^42^51^52^53^56^61^" | S FCODE="^21^22^23^24^25^26^31^32^33^34^51^52^53^54^5 S NFCODE="^03^04^11^12^13^14^15^20^25^32^33^49^50^54^ | S NFCODE="^11^12^41^42^62^" diff -y --suppress-common-lines ./VADemo/r1/FBAAFSR.m ./VADemo/r2/r/FBAAFSR.m ;;3.5;FEE BASIS;**4,53,71,84**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 ;if modifier SG present, don't use RBRVS, patch FB*3. < I MODL["SG" Q FBAMT < ; < ;If date of service in 2004 but prior to Mar 1, 2004 < I $E(DOS,1,3)=304,DOS<3040301 S FBCY=FBCY-1 < ; < diff -y --suppress-common-lines ./VADemo/r1/FBAALU.m ./VADemo/r2/r/FBAALU.m ;;3.5;FEE BASIS;**4,77,85**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 S ICPTVDT=$G(FBDOS) D ^DIR K DIR,ICPTVDT I $D(DTOUT)! | D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) G EXIT S ICPTVDT=$G(FBDOS) D ^DIR K DIR,ICPTVDT I $D(DTOUT)! | D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) G EXIT . . S ICPTVDT=$G(FBDOS) D ^DIR K DIR,ICPTVDT | . . D ^DIR K DIR K FBTX | S X=$$CPTD^ICPTCOD(FBAACP,"FBTX") S X=$$CPTD^ICPTCOD(FBAACP,"FBTX",$G(FBDFN),$G(FBDOS)) < . . S FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",$G(FBDOS), | . . S FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I","",1) diff -y --suppress-common-lines ./VADemo/r1/FBAAMP1.m ./VADemo/r2/r/FBAAMP1.m FBAAMP1 ;AISC/CMR-MULTIPLE PAYMENT ENTRY ;7/6/2003 | FBAAMP1 ;AISC/CMR-MULTIPLE PAYMENT ENTRY ;5/17/1999 ;;3.5;FEE BASIS;**4,55,61,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 N FBX | S DIR(0)="162.5,9",DIR("A")="Amount Suspended: $",DIR ;S DIR(0)="162.5,9",DIR("A")="Amount Suspended: $",DI | I $D(DIRUT) W !!,"Invalid entry, enter a number betwe ;I $D(DIRUT) W !!,"Invalid entry, enter a number betw | S FBAAAS=+Y ;S FBAAAS=+Y | I +Y'=(FBJ-FBK) S FBAAAS=+Y W ! S DIR("A")="Is $"_FBA ;I +Y'=(FBJ-FBK) S FBAAAS=+Y W ! S DIR("A")="Is $"_FB | G SUSP:'Y ;G SUSP:'Y | W !! S DIC="^FBAA(161.27,",DIC(0)="AEQ" D ^DIC I X["^ ;W !! S DIC="^FBAA(161.27,",DIC(0)="AEQ" D ^DIC I X[" | S FBAASC=+Y ;S FBAASC=+Y < S FBX=$$ADJ^FBUTL2(FBJ-FBK,.FBADJ,2) < I FBX=0 S FBAAOUT=1 < Q < W ! F FBSI=28,30,31 D Q:$G(FBAAOUT) | W ! F FBSI=28,30,31 S DIR(0)="P"_$S(FBSI=28&($$EXTPV^ . N ICDVDT S ICDVDT=$G(FBMPDT) < . F S DIR(0)="P"_$S(FBSI=28&($$EXTPV^FBAAUTL5(FBPOV) < diff -y --suppress-common-lines ./VADemo/r1/FBAAMP.m ./VADemo/r2/r/FBAAMP.m FBAAMP ;AISC/CMR-MULTIPLE PAYMENT ENTRY ;9/29/2003 | FBAAMP ;AISC/CMR-MULTIPLE PAYMENT ENTRY ;10/31/2001 ;;3.5;FEE BASIS;**4,21,38,55,61,67**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,21,38**;JAN 30, 1995 ; prompt revenue code < S FBAARC=$$ASKREVC^FBUTL5() I FBAARC="^" S FBAAOUT=1 < ; prompt units paid < S FBUNITS=$$ASKUNITS^FBUTL5() I FBUNITS="^" S FBAAOUT < S FBAAAS=0 K FBADJ I FBJ-FBK D SUSP^FBAAMP1 I $G(FBAA | S FBAAAS=0 I FBJ-FBK D SUSP^FBAAMP1 I $G(FBAAOUT) G Q ; prompt for remittance remarks < I $$RR^FBUTL4(.FBRRMK,2)=0 S FBAAOUT=1 G Q1 < I $$CHKICD9^FBCSV1(+$G(FBHCFA(28)),$G(FBDT))="" G MUL < I FBFPPSC]"" S FBFPPSL=$$FPPSL^FBUTL5() I FBFPPSL=-1 < FILE S TP="",DR="1///^S X=FBJ;Q;2///^S X=FBK;47///^S X=FBU | FILE S TP="",DR="1///^S X=FBJ;Q;2///^S X=FBK" I FBCSID]"" S DR=DR_";49///^S X=FBCSID" | S DR=DR_$S(FBJ-FBK:";3///^S X=FBAAAS;3.5////^S X=DT;4 I FBFPPSC]"" S DR=DR_";50///^S X=FBFPPSC;51///^S X=FB < I FBAARC]"" S DR=DR_";48////^S X=FBAARC" < ;S DR=DR_$S(FBJ-FBK:";3///^S X=FBAAAS;3.5////^S X=DT; < S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1," | S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",DA=FB S DA=FBAACPI,DA(1)=FBSDI,DA(2)=FBV,DA(3)=DFN < D LOCK^FBUCUTL(DIE,FBAACPI,1) < D ^DIE < D FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_", < D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_"," < L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI) < S FBINTOT=FBINTOT+FBK < W " ....OK, DONE...." < Q1 K FBADJ,FBAADT,FBX,FBAACP,DIC,DIE,X,Y,DIRUT,DUOUT,DTO | Q1 K FBAADT,FBX,FBAACP,DIC,DIE,X,Y,DIRUT,DUOUT,DTOUT,FBO S DIR("A")="Enter date to use for CPT/ICD checks and | S DIR("A")="Enter date to use for CPT checks and fee S DIR("?",2)="an active CPT/Modifier/ICD code. Also, | S DIR("?",2)="an active CPT/Modifier code. Also, the ; < > . N FBX1 E D | . ; use 70% of fee schedule amount if payment under 3 > . S FBX1=$J(FBFSAMT*$S(FB1725:.7,1:1),0,2) > . ; set default amount paid to lesser of amt claimed > . S FBAMFS=$S(FBX1>$G(FBJ):$G(FBJ),1:FBX1) > I $G(FBAAMM1) D ; < E W !?2,"Unable to determine a FEE schedule amount." | E W !?2,"Unable to determine a FEE schedule amount." ; < . W !!?2,"**Payment is for emergency treatment under | . W !?2,"**Payment is for emergency treatment under 3 . I FBFSAMT D | . I $G(FBFSAMT) W !?2," Therefore, fee schedule amou . . S FBFSAMT=$J(FBFSAMT*.7,0,2) < . . W !?2," Therefore, fee schedule amount reduced t < ; < I $G(FBUNITS)>1 D < . W !!?2,"Units Paid = ",FBUNITS < . Q:FBFSAMT'>0 < . N FBFSUNIT < . ; determine if fee schedule can be multipled by uni < . S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBMPDT>304 < . I FBFSUNIT D < . . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2) < . . W !?2," Therefore, fee schedule amount increased < . E D < . . W !?2," Fee schedule not complied on per unit ba < ; < I '$G(FBAAMM1) D < . ; set default amount paid to lesser of amt claimed < . S FBAMFS=$S(FBFSAMT>$G(FBJ):$G(FBJ),1:FBFSAMT) < ; < W ! < N FBX,FBRET,FB1725 | N FBX,FBRET ; set FB1725 flag = true if payment for a 38 U.S.C. 1 < S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28), < ; set FB1725 flag = true if payment for a 38 U.S.C. 1 < S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28), < ; adjust amount if mill bill < I FB1725 S $P(FBX,U)=$J($P(FBX,U)*.7,0,2) < ; adjust amount if units > 1 < I $G(FBUNITS) D < . N FBFSUNIT < . ; determine if fee schedule can be multipled by uni < . S FBFSUNIT=$S($P(FBX,U,2)="R":1,$P(FBX,U,2)="F"&(FB < . I FBFSUNIT S $P(FBX,U)=$J($P(FBX,U)*FBUNITS,0,2) < diff -y --suppress-common-lines ./VADemo/r1/FBAAPAA.m ./VADemo/r2/r/FBAAPAA.m FBAAPAA ;AISC/DMK-ADD/EDIT FEE SCHEDULE ;3/17/2003 | FBAAPAA ;AISC/DMK-ADD/EDIT FEE SCHEDULE ;4/17/2000 ;;3.5;FEE BASIS;**4,21,55**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,21**;JAN 30, 1995 ;write CPT & MOD as identifiers | WRITE ;write CPT & MOD as identifiers ; Input: (optional) FBDTSRV - date for Code Set Versi | N FBAAFS,FBAACP,FBCPTX,FBI,FBMOD,FBMODLE,FBMODX WRITE ; if FBDTSRV is not defined then today will be used a < N FBAAFS,FBAACP,FBCPTX,FBI,FBMOD,FBMODLE,FBMODX,FBCPT < S (FBCPTFL,FBMODFL)=0 < I +$G(FBDTSRV)=0 N FBDTSRV D < . N X D NOW^%DTC S FBDTSRV=X < S FBCPTX=$$CPT^ICPTCOD(FBAACP,$G(FBDTSRV),1) | S FBCPTX=$$CPT^ICPTCOD(FBAACP,"",1) I $G(FBDTSRV),+FBCPTX>0,$P(FBCPTX,U,7)=0 S FBCPTFL=1 | W ?20,"CPT: ",$P(FBCPTX,U,3) ; short name of CPT W ?20,"CPT: ",$S(FBCPTFL:$E($P(FBCPTX,U,3),1,25),1:$P < W:FBCPTFL ?50," - INACTIVE on ",$$FMTE^XLFDT(FBDTSRV) < . S FBMODX=$$MOD^ICPTMOD(FBMOD,"E",$G(FBDTSRV)) | . S FBMODX=$$MOD^ICPTMOD(FBMOD,"E") . . S FBY=$$MODP^ICPTMOD(FBAACP,FBMOD,"E",$G(FBDTSRV) | . . S FBY=$$MODP^ICPTMOD(FBAACP,FBMOD,"E") . . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I | . . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I . I $G(FBDTSRV),+FBMODX>0,$P(FBMODX,U,7)=0 S FBMODFL= | . W !?20,"MOD: ",FBMOD," ",$P(FBMODX,U,3) . W !?20,"MOD: ",FBMOD," ",$S(FBMODFL:$E($P(FBMODX,U < . W:FBMODFL ?50," - INACTIVE on ",$$FMTE^XLFDT(FBDTSR < diff -y --suppress-common-lines ./VADemo/r1/FBAAPAY.m ./VADemo/r2/r/FBAAPAY.m ;;3.5;FEE BASIS;**4,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 LOOK N FBUNITS | LOOK S Y(1)=^FBAAC(I,1,J,1,K,1,L,0) S Y(1)=^FBAAC(I,1,J,1,K,1,L,0) < I AP>0 D | I AP>0 S Y=^TMP($J,II),$P(^(II),"^",1)=$P(Y,"^",1)+1, . ; skip if beginning date not after October 2003 < . I BEGDATE>3030930 D < . . S FBUNITS=$P($G(^FBAAC(I,1,J,1,K,1,L,2)),U,14) < . . ; skip if units paid not more than one < . . Q:$G(FBUNITS)'>1 < . . ; divide amount claimed by units and round it to < . . S AC=$J(AC/FBUNITS,"",2) < . . ; divide amount paid by units and round it to cen < . . S AP=$J(AP/FBUNITS,"",2) < . S Y=^TMP($J,II),$P(^(II),"^",1)=$P(Y,"^",1)+1,$P(^( < diff -y --suppress-common-lines ./VADemo/r1/FBAAPCS.m ./VADemo/r2/r/FBAAPCS.m ;;3.5;FEE BASIS;**4,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 W !,"Note: code descriptors will be versioned for the < N ICPTVDT S ICPTVDT=$G(ENDDATE) < ; < . W !,"Note: code descriptors will be versioned for t < Only in ./VADemo/r1/: FBAAPET1.m diff -y --suppress-common-lines ./VADemo/r1/FBAAPET.m ./VADemo/r2/r/FBAAPET.m FBAAPET ;AISC/DMK-EDIT PAYMENT ;7/13/2003 | FBAAPET ;AISC/DMK-EDIT PAYMENT ;10/31/2001 ;;3.5;FEE BASIS;**4,38,55,61,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,38**;JAN 30, 1995 S DIC=FBZ,DIC(0)="AEQMZ" | S DIC=FBZ,DIC(0)="AEQMZ" D ^DIC G GETPT:X="^"!(X=""), D < . N ICPTVDT S ICPTVDT=$G(FBAADT) D ^DIC < G GETPT:X="^"!(X=""),SERV:Y<0 S (FBSV,FBAACPI,FBDA)=+ < ; load current adjustment data < D LOADADJ^FBAAFA(FBDA_","_FBDA(1)_","_FBDA(2)_","_FBD < ; save adjustment data prior to edit session in sorte < S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of or < ; load current remittance remark data < D LOADRR^FBAAFR(FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA < ; save remittance remarks prior to edit session in so < S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK) < ; save FPPS data prior to edit session < S FBFPPSC(0)=$P($G(^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1) < S FBFPPSC=FBFPPSC(0) < S FBFPPSL(0)=$P($G(^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1) < S FBFPPSL=FBFPPSL(0) < S DR="48;47;S FBUNITS=X;42R;S FBZIP=X;S:$$ANES^FBAAFS | S DR="42R;S FBZIP=X;S:$$ANES^FBAAFS($$CPT^FBAAUTL4(FB ;S DR(1,162.03,3)="3////^S X=$S(J-K:J-K,1:"""");I X S | S DR(1,162.03,3)="3////^S X=$S(J-K:J-K,1:"""");I X S S DR(1,162.03,3)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ | S DR(1,162.03,4)="@5;K DIE(""NO^"");W !,""Exit ('^') S DR(1,162.03,4)="S FBX=$$FPPSC^FBUTL5(1,FBFPPSC);S:F | S DR(1,162.03,5)="15;17;16;S:X=1 Y=""@1"";28R;31;32R; S DR(1,162.03,5)="K DIE(""NO^"");W !,""Exit ('^') all | S DIE=FBZ D ^DIE K FBSV W !! G SERV S DR(1,162.03,6)="15;17;16;S:X=1 Y=""@1"";@6;28R;S:$$ < S DR(1,162.03,7)="@7;K FBRRMKD;M FBRRMKD=FBRRMK;S FBX < S DIE=FBZ < D < . N ICPTVDT,ICDVDT S (ICPTVDT,ICDVDT)=$G(FBAADT) D ^D < ; if adjustment data changed then file < I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBAAFA(F < ; if remit remark data changed then file < I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBAAFR(F < ; if FPPS CLAIM ID changed, update other line items o < I FBFPPSC'=FBFPPSC(0) D < . N FBAAIN < . S FBAAIN=$$GET1^DIQ(162.03,FBDA_","_FBDA(1)_","_FBD < . D CKINVEDI^FBAAPET1(FBFPPSC(0),FBFPPSC,FBAAIN,FBDA_ < K FBSV W !! G SERV < K FBFSAMT,FBFSUSD,FBMODA,FBZIP,FBTIME,FBHCFA(30),FBAA | K FBFSAMT,FBFSUSD,FBMODA,FBZIP,FBTIME,FBHCFA(30),FBAA diff -y --suppress-common-lines ./VADemo/r1/FBAAPH.m ./VADemo/r2/r/FBAAPH.m FBAAPH ;AISC/DMK,GRR-LIST PAYMENT HISTORY ;8/10/2003 | FBAAPH ;AISC/DMK,GRR-LIST PAYMENT HISTORY ;7/11/2001 ;;3.5;FEE BASIS;**2,4,32,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**2,4,32**;JAN 30, 1995 SET ; | SET S V=$P($G(^FBAAV(K,0)),"^"),FBVID=$S(V]"":$P(^(0),"^" N FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRR < N FBX,FBY2,FBY3,TAMT < S V=$P($G(^FBAAV(K,0)),"^"),FBVID=$S(V]"":$P(^(0),"^" < S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3)) < S FBFPPSC=$P(FBY3,U) < S FBFPPSL=$P(FBY3,U,2) < S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S TAMT=$FN($P(Y,"^",4),"",2) < S FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",4 < S FBY2=$G(^FBAAC(J,1,K,1,L,1,M,2)) < S FBUNITS=$P(FBY2,U,14) < S FBCSID=$P(FBY2,U,16) < S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",") < W !!,"Vendor: ",$E(V,1,33)," Vendor ID: ",FBVID,? | W !!,"Vendor: ",$E(V,1,33)," Vendor ID: ",FBVID,? W !,$S(FBTYPE="R":"*",1:" "),$S(FBVP="VP":"#",1:""),$ | W ?12,FBAACPTC,FBCP_$S($G(FBMODLE)]"":"-"_$P(FBMODLE, W !?5,$J(A1,6),?18,$J(A2,6),FBAPS < ; write adjustment reasons, if null then write suspen < W ?32,$S(FBADJLR]"":FBADJLR,1:T) < ; write adjustment amounts, if null then write amount < W ?42,$S(FBADJLA]"":FBADJLA,1:TAMT) < W ?58,FBRRMKL,?71,D2 < I FBFPPSC]"" W !,?5,"FPPS Claim ID: ",FBFPPSC,?32,"FP < W !,?2,"Svc Date",?12,"CPT-MOD",?22,"Rev.Code",?31,"U | W !,?2,"Svc Date",?11,"CPT-MOD",?28,"Amount",?38," Am W !?5,"Amt Claimed",?18,"Amt Paid",?32,"Adj Code",?42 < W !,Q,! < diff -y --suppress-common-lines ./VADemo/r1/FBAAPHV.m ./VADemo/r2/r/FBAAPHV.m ;;3.5;FEE BASIS;**69**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 N FBFPPSC < S FBFPPSC=$P($G(^FBAA(162.1,FBAAIN,0)),U,13) < I FBFPPSC]"" W !,?2,"FPPS Claim ID: ",FBFPPSC < diff -y --suppress-common-lines ./VADemo/r1/FBAAPIE1.m ./VADemo/r2/r/FBAAPIE1.m FBAAPIE1 ;AISC/GRR-ENTER FEE PHARMACY INVOICE ;11/13/2 | FBAAPIE1 ;AISC/GRR-ENTER FEE PHARMACY INVOICE ;29JAN86 ;;3.5;FEE BASIS;**68**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 K FB7078,FBASSOC,FBD1,FBLOC,FBVEN,DIRUT,FBAR,FBDA,FBJ | K FB7078,FBASSOC,FBD1,FBLOC,FBVEN,DIRUT,FBAR,FBDA,FBJ S LCNT=+$P(^FBAA(162.1,IN,0),"^",9),TAC=+$P(^(0),"^", | S LCNT=+$P(^FBAA(162.1,IN,0),"^",9),TAC=+$P(^(0),"^", diff -y --suppress-common-lines ./VADemo/r1/FBAAPIE.m ./VADemo/r2/r/FBAAPIE.m FBAAPIE ;AISC/GRR-ENTER FEE PHARMACY INVOICE ;7/8/2003 | FBAAPIE ;AISC/GRR-ENTER FEE PHARMACY INVOICE ;29JAN86 ;;3.5;FEE BASIS;**61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 ; if U/C then get FPPS Claim ID else ask user | S (DIE,DIC)="^FBAA(162.1,",DA=IN,DR="1////^S X=INVDAT I $D(FB583) S FBFPPSC=$P($G(^FB583(FB583,5)),U) W !," < E S FBFPPSC=$$FPPSC^FBUTL5() I FBFPPSC=-1 K FBFPPSC < S (DIE,DIC)="^FBAA(162.1,",DA=IN < S DR="1////^S X=INVDATE;1.5////^S X=DT;2////^S X=DUZ; < D ^DIE < RDP S FBPHARM=1 W:FBINTOT>0 !,?15,"Pharmacy Invoice #: "_ | RDP S FBPHARM=1 W:FBINTOT>0 !,?15,"Pharmacy Invoice #: "_ ; if EDI then ask FPPS Line Item < I FBFPPSC]"" W !!! S FBFPPSL=$$FPPSL^FBUTL5() I FBFPP < D ^FBAASAP K FBPHARM I 'DFN K DFN G CHK < diff -y --suppress-common-lines ./VADemo/r1/FBAAPIN.m ./VADemo/r2/r/FBAAPIN.m FBAAPIN ;AISC/GRR-INVOICE DISPLAY ;7/17/2003 | FBAAPIN ;AISC/GRR-INVOICE DISPLAY ;5/11/1999 ;;3.5;FEE BASIS;**4,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 SET S FBFILE="^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",1,",D= | SET S FBFILE="^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",1,",D= S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3)) | Q S FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",4 | SET2 S N=$S($D(^DPT(J,0)):$P(^(0),"^",1),1:""),S=$S(N]"":$ D SET2 < Q < SET2 ; < N FBX < S N=$S($D(^DPT(J,0)):$P(^(0),"^",1),1:""),S=$S(N]"":$ < S TAMT=$FN($P(FBYY,U,4),"",2) < S FBUNITS=$P(FBY,U,14) < S FBFPPSL=$P(FBY3,U,2) < S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",") < W !!,N,?33,$$DATX^FBAAUTL(D),?43,FBAACPT_$S($G(FBMODL | W !!,N,!,$S(ZS="R":"*",1:""),$S(VP="VP":"#",1:""),$S( I FBAARCE]"" W ?51,"/",FBAARCE | W ?23,"$",$J(A1,8),?35,"$",$J(A2,8),?47,T,?57,FBBN,?7 W ?57,FBBN,?67,$S(FBYY("REJ")]"":"Rejected",1:$$DATX^ < . . W !,?48,"-",FBMOD | . . W !,?17,"-",FBMOD W !,$S(ZS="R":"*",1:""),$S(VP="VP":"#",1:""),$S($G(FB | D:T=4 ^FBAAPIN1 W ?3,FBFPPSL,?14,"$",$J(A1,8),?26,"$",$J(A2,8),?37,FB < ; write adjustment reasons, if null then write suspen < W ?43,$S(FBADJLR]"":FBADJLR,1:T) < ; write adjustment amounts, if null then write amount < W ?53,"$",$S(FBADJLA]"":FBADJLA,1:TAMT) < W ?69,FBRRMKL < ; if adjustment reasons null and suspend code = other < I FBADJLR="",T=4 D ^FBAAPIN1 < HED W @IOF,!,"Invoice Number: ",FBAAIN,?30,"Vendor Name: | HED W @IOF,!,"Invoice Number: ",FBAAIN,?30,"Vendor Name: W !?2,"FPPS Claim ID: ",$S(FBFPPSC]"":FBFPPSC,1:"N/A" < W ?33,"Patient Account #: ",FBCSID < ;W !,"SVC DATE"," CPT-MOD "," AMT CLAIMED",?35,"AMT | W !,"SVC DATE"," CPT-MOD "," AMT CLAIMED",?35,"AMT W !,"PATIENT",?33,"SVC DATE",?43,"CPT-MOD",?51,"/REV" < W !,?3,"FPPS LINE",?14,"AMT CLAIMED",?26,"AMT PAID",? < W !,$$REPEAT^XLFSTR("=",79) < K FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRR < INDAT S L=$O(^FBAAC("C",FBAAIN,J,K,"")),M=$O(^FBAAC("C",FBA | INDAT S L=$O(^FBAAC("C",FBAAIN,J,K,"")),M=$O(^FBAAC("C",FBA S FBINDAT=$P($G(^FBAAC(J,1,K,1,L,1,M,0)),"^",15) < S FBINDAT=$S(FBINDAT="":"Unknown",1:$E(FBINDAT,4,5)_" < S FBFPPSC=$P($G(^FBAAC(J,1,K,1,L,1,M,3)),U,1) < S FBCSID=$P($G(^FBAAC(J,1,K,1,L,1,M,2)),U,16) < S FBSW=0 K L,M Q < diff -y --suppress-common-lines ./VADemo/r1/FBAAPP0.m ./VADemo/r2/r/FBAAPP0.m FBAAPP0 ;AISC/GRR-ENTER FEE PHARMACY DETERMINATION CONT ;7/9/ | FBAAPP0 ;AISC/GRR-ENTER FEE PHARMACY DETERMINATION CONT ;09FE ;;3.5;FEE BASIS;**61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 ;S FBAASC="" | S FBAASC="" ;S DIR(0)="P^161.27:EQM",DIR("A")="Select Suspense Co | S DIR(0)="P^161.27:EQM",DIR("A")="Select Suspense Cod N FBX < ; prompt for adjustments < S FBX=$$ADJ^FBUTL2($P(FBY(0),U,4),.FBADJ,2) Q:FBX=0 < ; prompt for remittance remarks < S FBX=$$RR^FBUTL4(.FBRRMK,2) Q:FBX=0 < ;I $D(^TMP($J,"FBWP",0)) G SUSP1 | I $D(^TMP($J,"FBWP",0)) G SUSP1 ;I $D(^FBAA(162.1,FBJ,"RX",FBK,1)) S:$D(^(0)) ^TMP($J | I $D(^FBAA(162.1,FBJ,"RX",FBK,1)) S:$D(^(0)) ^TMP($J, SUSP1 ;S DIC="^TMP("_$J_",""FBWP"",",DWPK=1 W !,"Suspension | SUSP1 S DIC="^TMP("_$J_",""FBWP"",",DWPK=1 W !,"Suspension GOON ;S ^FBAA(162.1,"AG",VIFN,DT,DFN,FBAASC,FBJ,FBK)="" | GOON S ^FBAA(162.1,"AG",VIFN,DT,DFN,FBAASC,FBJ,FBK)="" S STAT=3,$P(FBY(0),"^",11)=0,$P(FBY(0),"^",14)=DUZ,$P | S STAT=3,$P(FBY(0),"^",8)=FBAASC,$P(FBY(0),"^",11)=0, ;I $O(^TMP($J,"FBWP",0)) S ^FBAA(162.1,FBJ,"RX",FBK,1 | I $O(^TMP($J,"FBWP",0)) S ^FBAA(162.1,FBJ,"RX",FBK,1, I $D(FBADJ) D < . D FILEADJ^FBRXFA(FBK_","_FBJ_",",.FBADJ) ; file adj < . D FILERR^FBRXFR(FBK_","_FBJ_",",.FBRRMK) ; file rem < diff -y --suppress-common-lines ./VADemo/r1/FBAAPPH.m ./VADemo/r2/r/FBAAPPH.m FBAAPPH ;AISC/GRR-PHARMACY HISTORY LIST FOR PATIENT ;7/17/200 | FBAAPPH ;AISC/GRR-PHARMACY HISTORY LIST FOR PATIENT ;1/13/98 ;;3.5;FEE BASIS;**12,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**12**;JAN 30, 1995 LIST ; list prescriptions for patient (DFN) | LIST S Q="" S $P(Q,"=",80)="=" N FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,FBRRMKL,FBSUSPA,FBX < S Q="" S $P(Q,"=",80)="=" < Q:'$D(^FBAA(162.1,K,0))&('$D(^FBAA(162.1,K,"RX",L,0)) | Q:'$D(^FBAA(162.1,K,0))&('$D(^FBAA(162.1,K,"RX",L,0)) S Y(0)=$G(^FBAA(162.1,K,"RX",L,0)) | S Y(2)=$G(^FBAA(162.1,+K,0)) I $D(^FBAA(162.1,K,"RX", S Y(2)=$G(^FBAA(162.1,+K,0)) < I $D(^FBAA(162.1,K,"RX",L,2)) S Y(1)=^(2) < S FBFPPSL=$P($G(^FBAA(162.1,K,"RX",L,3)),U) < S FBX=$$ADJLRA^FBRXFA(L_","_K_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S FBRRMKL=$$RRL^FBRXFR(L_","_K_",") < S FBFPPSC=$P(Y(2),U,13) < S FBSUSPA=$FN($P(Y(0),U,7),"",2) | I FBSUSP=4 S FBI=0 F S FBI=$O(^FBAA(162.1,K,"RX",L,1 I FBSUSP=4,FBADJLR="" S FBI=0 F S FBI=$O(^FBAA(162.1 < W !!,VNAM,?48,FID,?60,CHN | W !!,VNAM,?48,FID,?60,CHN,!,FBREIM,FBPV,?3,$E(FBFD,4, W !,FBREIM,FBPV,?3,$E(FBFD,4,5),"/",$E(FBFD,6,7),"/", | W !,?4,$J(A1,4),?12,$J(A2,4),?20,FBSUSP,?24,FBINVN,?3 W !," Rx: "_FBRX,?15,FBDRUG,?45,FBSTR,?63,FBQTY | I $D(FBSAR) W !?4," Suspension Description: " S FBI=0 W !,?4,$J(A1,6),?13,$J(A2,6) < ; write adjustment reasons, if null then write suspen < W ?22,$S(FBADJLR]"":FBADJLR,1:FBSUSP) < ; write adjustment amounts, if null then write amount < W ?32,$S(FBADJLA]"":FBADJLA,1:FBSUSPA) < W ?47,FBINVN,?58,FBBATCH,?67,FBRRMKL < I FBFPPSC]"" W !,?5,"FPPS Claim ID: ",FBFPPSC," FPP < I $D(FBSAR) W !?5,"Suspension Description: " S FBI=0 < W !,"Patient: ",NAME,?41,"Pt ID: ",FBSSN,?60,"DOB: ", | W !,"Patient: ",NAME,?41,"Pt ID: ",FBSSN,?60,"DOB: ", W !,"('*' Reimbursement to Patient '+' Cancellation | W !,?4,"Fill Date",!,?15,"Drug Name",?44,"Strength",? W !,"Vendor Name",?48,"ID #",?60,"Chain #" < W !,?3,"Fill Date",?64,"Date Certified" < W !,?15,"Drug Name",?43,"Strength",?61,"Quantity" < W !,?3,"Claimed",?15,"Paid",?22,"Adj Code",?32,"Adj A < W !,Q < diff -y --suppress-common-lines ./VADemo/r1/FBAAPP.m ./VADemo/r2/r/FBAAPP.m FBAAPP ;AISC/GRR-ENTER FEE PHARMACY DETERMINATION ;7/9/03 | FBAAPP ;AISC/GRR-ENTER FEE PHARMACY DETERMINATION ;09FEB86 ;;3.5;FEE BASIS;**61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 N FBADJ,FBRRMK < S (FBAAGP,FBNO1,FBNO2)="Yes",FBAAPR="" K FBADJ,FBRRMK | S (FBAAGP,FBNO1,FBNO2)="Yes",(FBAAPR,FBAASC)="" I '$D I '$D(IOM) D HOME^%ZIS | DIR1 S DIR("A")="Is Prescription for an Authorized Conditi DIR1 S DIR("A")="Is Prescription for an Authorized Conditi < S:FBNO2]"" DIR("B")=FBNO2 S DIR("A")="Is this an emer | S:FBNO2]"" DIR("B")=FBNO2 S DIR("A")="Is this an emer I $D(FBADJ) D | I $D(FBAASC),FBAASC W !,"Suspense Code: ",$G(^FBAA(16 . N FBI | I $G(FBAASC),(FBAASC=4) W !,"Suspension Description: . W !!,"Current list of Adjustments: " < . I '$O(FBADJ(0)) W "none" < . S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D < . . W ?30,"Code: " < . . W:$P(FBADJ(FBI),U)]"" $P($G(^FB(161.91,$P(FBADJ(F < . . W ?44,"Group: " < . . W:$P(FBADJ(FBI),U,2)]"" $P($G(^FB(161.92,$P(FBADJ < . . W ?56,"Amount: " < . . W "$",$FN($P(FBADJ(FBI),U,3),"",2),! < . W !!,"Current list of Remittance Remarks: " < . I '$O(FBRRMK(0)) W "none" < . S FBI=0 F S FBI=$O(FBRRMK(FBI)) Q:'FBI D < . . W:$P(FBRRMK(FBI),U)]"" $P($G(^FB(161.93,$P(FBRRMK < I $D(FBADJ) G GOON^FBAAPP0 | I $D(FBAASC),FBAASC G GOON^FBAAPP0 diff -y --suppress-common-lines ./VADemo/r1/FBAARR1.m ./VADemo/r2/r/FBAARR1.m FBAARR1 ;AISC/GRR-FEE BASIS RE-INITIATE ENTIRE BATCH ;7/12/20 | FBAARR1 ;AISC/GRR-FEE BASIS RE-INITIATE ENTIRE BATCH ;8AUG86 ;;3.5;FEE BASIS;**61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 ALLM ; re-initiate all rejected line items in medical (B3) | ALLM S (TM1,TM2)=0 F J=0:0 S J=$O(^FBAAC("AH",B,J)) Q:J'>0 K FBILM < S (TM1,TM2)=0 F J=0:0 S J=$O(^FBAAC("AH",B,J)) Q:J'>0 < ; Assign new invoice number to moved lines if medical < I $$CKSPLIT^FBAARR(B,.FBILM) S DIR(0)="E" D ^DIR K DI < ; update list of invoice lines that were moved to the < S FBILM(FBIN,M_","_L_","_K_","_J_",")="" < diff -y --suppress-common-lines ./VADemo/r1/FBAARR.m ./VADemo/r2/r/FBAARR.m FBAARR ;AISC/GRR-RE-INITIATE REJECTED LINE ITEMS ;9/9/2003 | FBAARR ;AISC/GRR-RE-INITIATE REJECTED LINE ITEMS ;13AUG86 ;;3.5;FEE BASIS;**61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 N FBILM < STUFF I $P(^FBAAC(J,1,K,1,L,1,M,0),"^",21)="VP" S FBIN=+$P( | STUFF I $P(^FBAAC(J,1,K,1,L,1,M,0),"^",21)="VP" S FBIN=+$P( ; update list of invoice lines that were moved to the < S FBILM(FBIN,M_","_L_","_K_","_J_",")="" < ; Assign new invoice number to moved lines if invoice < I $$CKSPLIT(B,.FBILM) S DIR(0)="E" D ^DIR K DIR < CKSPLIT(B,FBILM) ; Check for/Update split invoice < ; Input < ; B - ien of original batch before item moved < ; FBILM( - array of invoice lines that were moved t < ; passed by reference < ; format FBILM(invoice number,iens)="" < ; where < ; invoice number = invoice number < ; iens = iens of subfile 162.03 (a li < ; Result (0 or 1) < ; =0 if no lines were assigned a new invoice number < ; =1 if some lines assigned a new invoice number < ; May change invoice number of line items in subfil < ; and inform user < N FBAAIN,FBFDA,FBIENS,FBIN,FBINL,FBJ,FBK,FBL,FBM,FBRE < S FBRET=0 < ; loop thru invoice numbers in input array < S FBIN="" F S FBIN=$O(FBILM(FBIN)) Q:FBIN="" D < . S FBSPLT=0 ; initialize split flag to false < . ; check if any unrejected invoice lines still in or < . I $D(^FBAAC("AJ",B,FBIN)) S FBSPLT=1 < . ; check if any rejected invoice lines still in orig < . I 'FBSPLT S FBJ=0 F S FBJ=$O(^FBAAC("AH",B,FBJ)) Q < . . S FBK=0 < . . F S FBK=$O(^FBAAC("AH",B,FBJ,FBK)) Q:'FBK D Q: < . . . S FBL=0 < . . . F S FBL=$O(^FBAAC("AH",B,FBJ,FBK,FBL)) Q:'FBL < . . . . S FBM=0 < . . . . F S FBM=$O(^FBAAC("AH",B,FBJ,FBK,FBL,FBM)) Q < . . . . . S FBINL=$P($G(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM, < . . . . . I FBINL=FBIN S FBSPLT=1 < . Q:FBSPLT=0 ; invoice was not split < . S FBRET=1 < . ; assign new invoice number to lines moved to the n < . ; get a new invoice number (FBAAIN) < . D GETNXI^FBAAUTL < . ; loop thru the moved line items and assign the new < . K FBFDA < . S FBIENS="" F S FBIENS=$O(FBILM(FBIN,FBIENS)) Q:FB < . . S FBFDA(162.03,FBIENS,14)=FBAAIN < . W !!,"FYI: Invoice ",FBIN," was split since entire < . W !,"Re-initiated lines are being assigned a new in < . ; update the file < . I $D(FBFDA) D FILE^DIE("","FBFDA"),MSG^DIALOG() < Q FBRET < ; < ;FBAARR < diff -y --suppress-common-lines ./VADemo/r1/FBAASCB.m ./VADemo/r2/r/FBAASCB.m FBAASCB ;AISC/GRR-SUPERVISOR RELEASE ;8/6/2003 | FBAASCB ;AISC/GRR-SUPERVISOR RELEASE ;11/14/2001 ;;3.5;FEE BASIS;**38,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**38**;JAN 30, 1995 ;S DA=FBN,DR="0;ST",DIC="^FBAA(161.7," W !! D EN^DIQ | S DA=FBN,DR="0;ST",DIC="^FBAA(161.7," W !! D EN^DIQ W S DA=FBN,DR="0;ST",DIC="^FBAA(161.7," W !! D EN^DIQ W < ; process batch to queue 0.00 paid EDI invoices for F < D LOG^FBFHLL(FBN,FBTYPE) < D Q G FBAASCB < diff -y --suppress-common-lines ./VADemo/r1/FBAASL1.m ./VADemo/r2/r/FBAASL1.m ;;3.5;FEE BASIS;**12,23,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**12,23**;JAN 30, 1995 N FBACRR,FBSCDT | F K=0:0 S K=$O(^FBAA(162.1,"AG",K)) Q:K'>0 I $S($G(I F K=0:0 S K=$O(^FBAA(162.1,"AG",K)) Q:K'>0 I $S($G(I < WPBOT D:$D(FBACRR) ACT^FBAASLP K FBACRR | WPBOT S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !! S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !! < N FBFPPSC S FBFPPSC=$P($G(^FBAA(162.1,L,0)),U,13) < Q:$S(FBENA=2&(FBFPPSC]""):1,FBENA=1&(FBFPPSC=""):1,1: < N FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,T,TAMT,FBJ,FBAC < S FBFPPSL=$P($G(^FBAA(162.1,L,"RX",M,3)),U) < S FBX=$$ADJLRA^FBRXFA(M_","_L_",") < S FBADJLR=$P(FBX,U) < F FBJ=1:1 S FBAC=$P(FBADJLR,",",FBJ) Q:FBAC="" S FBA < S FBADJLA=$P(FBX,U,2) < S T=$P(Z(0),U,8) < I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U) < S TAMT=$FN($P(Z(0),U,7),"",2) < S FBRRMKL=$$RRL^FBRXFR(M_","_L_",") < ; write adjustment reasons, if null then write suspen | G:FBA=4&($D(^FBAA(162.1,L,"RX",M,1))) WPFT W ?15,$S(FBADJLR]"":FBADJLR,1:T) | S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W") ; write adjustment amounts, if null then write amount | F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FBRR W ?31,$S(FBADJLA]"":FBADJLA,1:TAMT) | D ^DIWW:$D(FBXX) K FBXX W ?49,FBRRMKL | Q I FBFPPSC]"" W !,?15,"FPPS Claim ID: ",FBFPPSC,?43,"F | HED W !,"PATIENT NAME",?36,"SSN",?47,"RX DATE",?61,"RX #" I FBADJLR="" G:FBA=4&($D(^FBAA(162.1,L,"RX",M,1))) WP < . S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W") < . F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FB < . D ^DIWW:$D(FBXX) K FBXX < Q < HED W !,"PATIENT NAME",?36,"SSN",?47,"RX DATE",?61,"RX #" < W !,?15,"ADJ CODE",?30,"ADJ AMOUNT",?49,"MEDICARE REM < W !,UL,! Q < diff -y --suppress-common-lines ./VADemo/r1/FBAASLP.m ./VADemo/r2/r/FBAASLP.m ;;3.5;FEE BASIS;**12,4,23,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**12,4,23**;JAN 30, 1995 ;ask edi/non-edi/all claims | AHEAD S VAR="BEGDATE^ENDDATE^FBSLW",VAL=BEGDATE_"^"_ENDDATE AHEAD S DIR(0)="SA^1:EDI;2:NON-EDI;3:ALL",DIR("A")="Only pr < S DIR("?",1)=" Enter EDI to just print suspension let < S DIR("?",2)=" Enter NON-EDI to just print suspension < S DIR("?",3)=" Enter ALL to print suspension letters < S DIR("?")=" " < D ^DIR K DIR G END:$D(DIRUT) < S FBENA=Y < S VAR="BEGDATE^ENDDATE^FBSLW",VAL=BEGDATE_"^"_ENDDATE < I $G(FBENA) S VAR="FBENA^"_VAR,VAL=FBENA_"^"_VAL < K FBAAOUT,FBCTR,FBPRG,FBY,FBMOD,FBMODLE,DFN,IFN,FBDEN | K FBAAOUT,FBCTR,FBPRG,FBY,FBMOD,FBMODLE,DFN,IFN,FBDEN WPBOT D ACT:$D(FBACRR) K FBACRR | WPBOT S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !! S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !! < N FBY3,FBFPPSC < S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3)) < S FBFPPSC=$P(FBY3,U) < Q:$S(FBENA=2&(FBFPPSC]""):1,FBENA=1&(FBFPPSC=""):1,1: < N FBY,FBX,T,TAMT,FBAC,FBJ,FBCSID,FBUNITS,FBADJLR,FBAD < S T=$P(Z(0),U,5) < I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U) < S TAMT=$FN($P(Z(0),U,4),"",2) < S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",") < S FBY=$G(^FBAAC(J,1,K,1,L,1,M,2)) < S FBFPPSL=$P(FBY3,U,2) < S FBCSID=$P(FBY,U,16) < S FBUNITS=$P(FBY,U,14) < S FBADJLR=$P(FBX,U) < F FBJ=1:1 S FBAC=$P(FBADJLR,",",FBJ) Q:FBAC="" S FBA < S FBADJLA=$P(FBX,U,2) < S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",") < W !!,$E(PNAME,1,26),?33,PSSN,?49,FBCSID | W !!,$E(PNAME,1,26),?28,PSSN,?39,$$FMTE^XLFDT(FBDOS), W !,$$DATX^FBAAUTL(FBDOS),?10,CPT_$S($G(FBMODLE)]"":" < . . W !,?15,"-",FBMOD | . . W !,?57,"-",FBMOD W !,?10,$J(A1,6),?24,$J(A2,6) < ; write adjustment reasons, if null then write suspen < W ?35,$S(FBADJLR]"":FBADJLR,1:T) < ; write adjustment amounts, if null then write amount < W ?49,$S(FBADJLA]"":FBADJLA,1:TAMT) < W ?66,FBRRMKL < I FBFPPSC]"" W !,?10,"FPPS Claim ID: ",FBFPPSC,?38,"F < I FBADJLR="" G:FBA=4&($D(^FBAAC(J,1,K,1,L,1,M,1))) WP | G:FBA=4&($D(^FBAAC(J,1,K,1,L,1,M,1))) WPFT . S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W") | S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W") . F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FB | F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FBRR . D ^DIWW:$D(FBXX) K FBXX | D ^DIWW:$D(FBXX) K FBXX Q < ACT ; print table of adjustment reason descriptions < ; Input < ; FBACRR( - required, array < ; FBACRR(FBADJRE)="" < ; where FBADJRE = adjustment reason code, external < N FBADJRE,FBI,FBACT < W !,"*Adjustment Code Text:" < S FBADJRE="" F S FBADJRE=$O(FBACRR(FBADJRE)) Q:FBADJ < . ; get description of code in FBACT < . I $$AR^FBUTL1(,FBADJRE,FBSCDT,"FBACT")<0 Q ; quit < . ; print code and description < . K ^UTILITY($J,"W") < . S DIWL=1,DIWF="WC79" < . ; include code in output < . S X=$$LJ^XLFSTR("("_FBADJRE_")",7," ") D ^DIWP < . S DIWF="WC79I7" < . ; include description in output < . S FBI=0 F S FBI=$O(FBACT(FBI)) Q:FBI="" S X=FBACT < . D ^DIWW < ; | HED W !,"PATIENT NAME",?32,"SSN",?39,"SVC",?52,"CPT-",?65 HED W !,"PATIENT NAME",?33,"SSN",?49,"PATIENT ACCOUNT NUM < W !,"SVC DATE",?10,"CPT-MOD",?33,"UNITS" < W !,?10,"AMT CLAIMED",?24,"AMT PAID",?35,"ADJ CODE",? < W !,UL Q < STRT N FBACRR,FBSCDT S FBSW=1 S Z=$O(^FBAAC("AI",K,BEGDATE | STRT S FBSW=1 S Z=$O(^FBAAC("AI",K,BEGDATE-.001)) S FBDT=B diff -y --suppress-common-lines ./VADemo/r1/FBAAUTL4.m ./VADemo/r2/r/FBAAUTL4.m ;;3.5;FEE BASIS;**4,32,77,81**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,32**;JAN 30, 1995 CPT(X,Y,FBSRVDT) ;return external format of CPT code | CPT(X,Y) ;return external format of CPT code ;optional FBSRVDT - date of service < S Z=$$CPT^ICPTCOD(X,$S($G(FBSRVDT)>0:+$G(FBSRVDT),1:" | S Z=$$CPT^ICPTCOD(X,"",1) MOD(X,Y,FBSRVDT) ;return external format of modifier | MOD(X,Y) ;return external format of modifier ;optional FBSRVDT - date of service < S Z=$$MOD^ICPTMOD(X,"I",$S($G(FBSRVDT)>0:+$G(FBSRVDT) | S Z=$$MOD^ICPTMOD(X,"I","",1) I $G(Y) Q $S($D(^FBAA(161.7,"B",X)):"",1:1) | I $G(Y),$D(^FBAA(161.7,"B",X)) Q "" I '$G(Y) Q $S($D(^FBAA(162.1,"B",X)):"",$D(^FBAAI("B" | Q $S($D(^FBAA(162.1,"B",X)):"",$D(^FBAAI("B",X)):"",1 diff -y --suppress-common-lines ./VADemo/r1/FBAAV0.m ./VADemo/r2/r/FBAAV0.m ;;3.5;FEE BASIS;**3,4,55**;JAN 30, 1995 | ;;3.5;FEE BASIS;**3,4**;JAN 30, 1995 .N FBDTSR1 S FBDTSR1=+$G(^FBAAC(K,1,L,1,M,0)) < S FBVTOS=+$P(Y(0),"^",24),FBVTOS=$S(FBVTOS:$P(^FBAA(1 | S FBVTOS=+$P(Y(0),"^",24),FBVTOS=$S(FBVTOS:$P(^FBAA(1 ; < diff -y --suppress-common-lines ./VADemo/r1/FBAAV4.m ./VADemo/r2/r/FBAAV4.m FBAAV4 ;AISC/GRR-ELECTRONICALLY TRANSMIT PATIENT MRA'S ;12/1 | FBAAV4 ;AISC/GRR-ELECTRONICALLY TRANSMIT PATIENT MRA'S ;5/31 ;;3.5;FEE BASIS;**13,34,37,70**;JAN 30, 1995 | ;;3.5;FEE BASIS;**13,34,37**;JAN 30, 1995 S FBTXT=0,ZMCNT=1 ;FBTXT , ZMCNT | S FBTXT=0,ZMCNT=1 .; GETBT-prepare header < .; NEWMSG^FBAAV01-get new message number, reset line < .; STORE^FBAAV01- increment line counter and store in < .; FBLN -line counter; FBFEE- "FEE message" counter; < .; prepare and store patient MRA portion (can be more < D:+$G(FBOKTX) XMIT^FBAAV01 | D:+$G(FBOKTX) XMIT^FBAAV01 Q Q | ; ;GETBT - prepare the "header" of the message | GETBT D GETNXB^FBAAUTL GETBT D GETNXB^FBAAUTL ;get next batch # in FBBN < S FBSTR=FBHD_"C2"_$E(DT,4,7)_$E(DT,2,3)_FBSN_FBZBN_"$ | S FBSTR=FBHD_"C2"_$E(DT,4,7)_$E(DT,2,3)_FBSN_FBZBN_"$ Q | ; ; | GOT D PAT^FBAAUTL2 GOT ;patient MRA portion of the message < N FBCCFLG,FBPATICN,FB2NDSTR < ; patient info;input:Y(0);output:FBDOB,FBFI,FBFLNAM,F < D PAT^FBAAUTL2 < S FBFLNAM=$$HL7NAME(DFN),FBFI="",FBMI="" ;name (FBFI, < ; demographic info, output:VADM < S FBBD=$P(VADM(3),"^"),FBBD=$E(FBBD,4,7)_$E(FBBD,2,3) | S FBBD=$P(VADM(3),"^"),FBBD=$E(FBBD,4,7)_$E(FBBD,2,3) S DOD=$P($P(VADM(6),"^"),".") ;DOD | S DOD=$P($P(VADM(6),"^"),".") ; < ;address info, output: VAPA() < S FBADD=$$LRJ($G(VAPA(1)),35)_$$LRJ($G(VAPA(2)),35)_$ | S FBADD=$E(VAPA(1),1,21),FBADD=FBADD_$E(PAD,$L(FBADD) S FBCITY=$$LRJ($G(VAPA(4)),30) ;city | S FBCITY=$E(VAPA(4),1,13),FBCITY=FBCITY_$E(PAD,$L(FBC S STCD=+VAPA(5) I STCD S FBSTAT=$S($D(^DIC(5,STCD,0)) | S STCD=+VAPA(5) I STCD S FBSTAT=$S($D(^DIC(5,STCD,0)) S FBZIP=$S('+$G(VAPA(11)):VAPA(6),+VAPA(11):$P(VAPA(1 | S FBZIP=$S('+$G(VAPA(11)):VAPA(6),+VAPA(11):$P(VAPA(1 ;check for Confidential Communication (CC) address < S FBCCFLG=0 I 'VAERR S FBCCFLG=$$SENDCC() < S FB2NDSTR=$$SECLINE() < S STCC=+VAPA(7),FBCC="000" I STCC,STCD S FBCC=$S($D(^ | S STCC=+VAPA(7),FBCC="000" I STCC,STCD S FBCC=$S($D(^ ; < ; eligibility, output:VAEL() < S POS=$S(+VAEL(2):+VAEL(2),1:"") ;PERIOD OF SERVICE | S POS=$S(+VAEL(2):+VAEL(2),1:"") S POS=$S(POS="":8,$D(^DIC(21,POS,0)):$P(^(0),"^",3),1 | S POS=$S(POS="":8,$D(^DIC(21,POS,0)):$P(^(0),"^",3),1 ; < ; service information < S POW=$S(+VASV(4):+VASV(4),1:""),POW=$S(POW="":2,POW= | S POW=$S(+VASV(4):+VASV(4),1:""),POW=$S(POW="":2,POW= ; < ; remove all variables defined by VADPT < ; < ;using pointer FEE BASIS PATIENT MRA file retrieve in < ;FEE BASIS PATIENT file#161, from its authorization m < ;authorisation FROM | S FBFR=$P(Y(0),"^"),FBTO=$P(Y(0),"^",2),POV=$P(Y(0)," S FBFR=$P(Y(0),"^") < ;authorisation TO < S FBTO=$P(Y(0),"^",2) < ;PURPOSE OF VISIT < S POV=$P(Y(0),"^",7),POV=$S(POV="":"",$D(^FBAA(161.82 < ;TREATMENT TYPE CODE (SHORT TERM,HOME NURSING,I.D. CA < S FBTT=$P(Y(0),"^",13),FBTT=$S(FBTT]"":FBTT,1:1) < ; < ;formatting FORM and TO dates < ;flag that the authorization From Date is being chang < ;master record adjustment (see file #161.26, field #5 < ; < ;if < S FBPATICN=$$ICN(DFN) ;get patient's ICN | S FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_FBFI_FBMI_FBFLNAM_FB S FBSTR=FBRECT_FBTYPE_FBSN_FBSSN_FBFI_FBMI_FBFLNAM_FB < ;if no CC address then send only 1st line of Add and < I FBCCFLG=0 S FBSTR=FBSTR_"$" D ZAP Q < ;save 1st line of Add and Change record < D STORE < ;create 2nd line for CC address < S FBSTR=FB2NDSTR < D ZAP < Q < ;place in XMB for transmission and update FBAA(161.26 < ;--- < ;Patient's INTEGRATION CONTROL NUMBER < ;to be implemented in future < ;meanwhile returns 17 spaces < ICN(FBDFN) ; < Q $$LRJ("",17) < ;--- < ;adds spaces on right/left or truncates to make retur < ;FBST- original string < ;FBLEN - desired length < ;FBCHR -character (default = SPACE) < ;FBSIDE - on which side to add characters (default = < LRJ(FBST,FBLEN,FBCHR,FBSIDE) ; < N Y S $P(Y,$S($L($G(FBCHR)):FBCHR,1:" "),$S(FBLEN-$L( < Q $E($S($G(FBSIDE)="L":Y_FBST,1:FBST_Y),1,FBLEN) < ;--- < ;parse name components < HL7NAME(FBDFN) ; < N FBAR,FBNM < S FBAR("FILE")=2,FBAR("IENS")=FBDFN,FBAR("FIELD")=.01 < S FBNM=$$HLNAME^XLFNAME(.FBAR,"L30","|") < Q $$LRJ(FBNM,30) < ; < ;create 2nd line for CC address < ;VAPA should be determined < SECLINE() ; < N FBSTR1 < S FBSTR1=$$LRJ($G(VAPA(13)),35)_$$LRJ($G(VAPA(14)),35 < S FBSTR1=FBSTR1_$$LRJ($S(+$G(VAPA(17)):$P($G(^DIC(5,+ < S FBSTR1=FBSTR1_$$LRJ($TR($P($G(VAPA(18)),"^",1),"-", < S FBSTR1=FBSTR1_$$LRJ($E(+$G(VAPA(20)),4,5)_$E(+$G(VA < S FBSTR1=FBSTR1_$$LRJ($E(+$G(VAPA(21)),4,5)_$E(+$G(VA < S FBSTR1=FBSTR1_$$LRJ($P($G(^DIC(5,+$G(VAPA(17)),1,+$ < S FBSTR1=FBSTR1_"~$" < Q FBSTR1 < ;------ < ;SENDCC < ;returns 1 if CC address needs to be sent, otherwise < ;is called after ADD^VADPT, i.e. VAPA should be defin < SENDCC() ; < ;if it is currrently active < I $$ACTIVECC^FBAACO0() Q 1 < N X D NOW^%DTC ;set X to TODAY < I ($P($G(VAPA(22,3)),"^",3)="Y"),+$G(VAPA(20))>X Q 1 < Q 0 < ; < diff -y --suppress-common-lines ./VADemo/r1/FBAAV5.m ./VADemo/r2/r/FBAAV5.m ;;3.5;FEE BASIS;**3,55**;JAN 30, 1995 | ;;3.5;FEE BASIS;**3**;JAN 30, 1995 I $D(^FBAAI(K,"DX")) S Y("DX")=^("DX") F M=1:1:5 Q:$P | I $D(^FBAAI(K,"DX")) S Y("DX")=^("DX") F M=1:1:5 Q:$P I $D(^FBAAI(K,"PROC")) S Y("PROC")=^("PROC") F M=1:1: | I $D(^FBAAI(K,"PROC")) S Y("PROC")=^("PROC") F M=1:1: diff -y --suppress-common-lines ./VADemo/r1/FBAAV6.m ./VADemo/r2/r/FBAAV6.m ;;3.5;FEE BASIS;**55**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 .N FBDTSR1 S FBDTSR1=$P($G(Y(0)),"^",6) < S Y("DX")=^("DX") F M=1:1:5 Q:$P(Y("DX"),"^",M)="" S | S Y("DX")=^("DX") F M=1:1:5 Q:$P(Y("DX"),"^",M)="" S S Y("PROC")=^("PROC") F M=1:1:3 Q:$P(Y("PROC"),"^",M) | S Y("PROC")=^("PROC") F M=1:1:3 Q:$P(Y("PROC"),"^",M) diff -y --suppress-common-lines ./VADemo/r1/FBAAVD2.m ./VADemo/r2/r/FBAAVD2.m FBAAVD2 ;AISC/DMK-EDIT VENDOR DEMOGRAPHICS ;10/20/02 | FBAAVD2 ;AISC/DMK-EDIT VENDOR DEMOGRAPHICS ;10/2/97 ;;3.5;FEE BASIS;**9,10,47,65**;JAN 30, 1995 | ;;3.5;FEE BASIS;**9,10**;JAN 30, 1995 RATE K DA W ! S DIR(0)="161.22,.02",DIR("A")="Enter Nursin | RATE K DA W ! S DIR(0)="161.22,.02",DIR("A")="Enter Nursin I $L($$RATE^FBAAVD1($P(^FBAA(161.21,FBCIEN,0),"^",1)) < diff -y --suppress-common-lines ./VADemo/r1/FBAAVLU.m ./VADemo/r2/r/FBAAVLU.m FBAAVLU ;AISC/DMK-LOOK UP VENDOR FOR TIME FRAME ;8/10/2003 | FBAAVLU ;AISC/DMK-LOOK UP VENDOR FOR TIME FRAME ;6/21/1999 ;;3.5;FEE BASIS;**4,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 MORE F L=0:0 S L=$O(^FBAAC(J,DA,"AD",FBK,L)) Q:L'>0!(FBAAO | MORE F L=0:0 S L=$O(^FBAAC(J,DA,"AD",FBK,L)) Q:L'>0!(FBAAO WRT ; | WRT I $E(IOST,1,2)["C-",$Y+4>IOSL S DIR(0)="E" D ^DIR K D N FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRR < N FBX,FBY2,FBY3,TAMT < I $E(IOST,1,2)["C-",$Y+4>IOSL S DIR(0)="E" D ^DIR K D < S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3)) < S FBFPPSC=$P(FBY3,U) < S FBFPPSL=$P(FBY3,U,2) < S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S TAMT=$FN($P(B,"^",4),"",2) < S FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",4 < S FBY2=$G(^FBAAC(J,1,K,1,L,1,M,2)) < S FBUNITS=$P(FBY2,U,14) < S FBCSID=$P(FBY2,U,16) < S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",") < W !,$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""),$S($G(FBC | W !,$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""),$S($G(FBC W !?4,"$",$J(A1,8),?17,"$",$J(A2,8) < ; write adjustment reasons, if null then write suspen < W ?30,$S(FBADJLR]"":FBADJLR,1:T) < ; write adjustment amounts, if null then write amount < W ?40,"$",$S(FBADJLA]"":FBADJLA,1:TAMT) < W ?56,FBRRMKL,?70,FBAAPD < I FBFPPSC]"" W !,?5,"FPPS Claim ID: ",FBFPPSC,?32,"FP < W !?2,"SVC DATE",?12,"CPT-MOD",?22,"REV.CODE",?31,"UN | W !," SVC DATE",?11,"CPT-MOD",?20,"AMT CLAIMED",?32," W !?4,"AMT CLAIMED",?17,"AMT PAID",?30,"ADJ CODE",?40 < W !,Q,! < diff -y --suppress-common-lines ./VADemo/r1/FBAAVP.m ./VADemo/r2/r/FBAAVP.m ;;3.5;FEE BASIS;**4,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 EN2 S FBAAPD=$P(L,"^",14),ZS=$P(L,"^",20),FD=$P(L,"^",6), | EN2 S T=$P(L,"^",5),FBAAPD=$P(L,"^",14),ZS=$P(L,"^",20),F WRT N FBFPPSC S FBFPPSC=$P($G(^FBAAC(DFN,1,DA,1,B,1,K,3)) | WRT S FBDT=$P(^FBAAC(DFN,1,DA,1,B,0),"^"),FBAADT=$E(FBDT, S FBDT=$P(^FBAAC(DFN,1,DA,1,B,0),"^"),FBAADT=$E(FBDT, < W !,CNT_") ",$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""), | W !,CNT_") ",$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""), I FBFPPSC]"" W !,?4,"FPPS Claim ID: ",FBFPPSC < S ^TMP($J,CNT)=FBAADT_"^"_FBAACPT_$S($G(FBMODLE)]"":" | S ^TMP($J,CNT)=FBAADT_"^"_FBAACPT_$S($G(FBMODLE)]"":" W !," SVC DATE",?11,"CPT-MOD",?20,"AMT CLAIMED",?35," | W !," SVC DATE",?11,"CPT-MOD",?20,"AMT CLAIMED",?32," Q K DIC,DIE,DA,DF,DA(1),^TMP($J),A,A1,A2,B,B1,B2,C,CNT, | Q K DIC,DIE,DA,DF,DA(1),^TMP($J),A,A1,A2,B,B1,B2,C,CNT, W !,$P(Y(0),"^",1),?14,$P($P(Y(0),"^",2),","),?23,$P( | W !,$P(Y(0),"^",1),?14,$P($P(Y(0),"^",2),","),?23,$P( I $P(Y(0),U,5)]"" W !,?4,"FPPS Claim ID: ",$P(Y(0),U, < diff -y --suppress-common-lines ./VADemo/r1/FBAAVS.m ./VADemo/r2/r/FBAAVS.m FBAAVS ;AISC/GRR-DISPLAY VENDOR PAYMENT RECORDS ;7/17/2003 | FBAAVS ;AISC/GRR-DISPLAY VENDOR PAYMENT RECORDS ;6/21/1999 ;;3.5;FEE BASIS;**4,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 EN1 ; display payments for veteran (DFN) and vendor (DA) | EN1 S Q="" F A=1:1:79 S Q=Q_"-",FBAAOUT=0 N FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRR < N FBY2,FBY3,TAMT < S Q="" F A=1:1:79 S Q=Q_"-",FBAAOUT=0 < W !,?2,"SVC DATE",?12,"CPT-MOD",?22,"REV.CODE",?32,"U | W !," SVC DATE",?11,"CPT-MODIFIER",?30,"AMT CLAIMED", W !,?12,"AMT CLAIMED",?25,"AMT PAID",?38,"ADJ CODE",? < W !,Q,! < S TAMT=$FN($P(L,U,4),"",2) < S FBUNITS=$P(FBY2,U,14) < S FBCSID=$P(FBY2,U,16) < S FBFPPSC=$P(FBY3,U) < S FBFPPSL=$P(FBY3,U,2) < W !,$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""),$S($G(FBC | W !,$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""),$S($G(FBC W ?2,FBAADT,?12,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMO < W !?12,"$",$J(A1,8),?25,"$",$J(A2,8) < ; write adjustment reasons, if null then write suspen < W ?38,$S(FBADJLR]"":FBADJLR,1:T) < ; write adjustment amounts, if null then write amount < W ?48,"$",$S(FBADJLA]"":FBADJLA,1:TAMT) < W ?65,FBRRMKL < I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"F < MORE N FBX | MORE S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_DA_",1, S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_DA_",1, < S FBY2=$G(^FBAAC(DFN,1,DA,1,B,1,K,2)) < S FBY3=$G(^FBAAC(DFN,1,DA,1,B,1,K,3)) < S FBX=$$ADJLRA^FBAAFA(K_","_B_","_DA_","_DFN_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S FBRRMKL=$$RRL^FBAAFR(K_","_B_","_DA_","_DFN_",") < S FBAARCE=$$GET1^DIQ(162.03,K_","_B_","_DA_","_DFN_", < diff -y --suppress-common-lines ./VADemo/r1/FBCH780.m ./VADemo/r2/r/FBCH780.m FBCH780 ;AISC/DMK-7078/AUTHORIZATION CON'T ;8/18/2004 | FBCH780 ;AISC/DMK-7078/AUTHORIZATION CON'T ;08JUN90 ;;3.5;FEE BASIS;**82**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 ; input | I '$G(DFN)!('$G(FBAA78)) W !?5,*7,"Unable to create N ; DFN - ien of patient in file #2 | S Y=$P($G(^FB7078(+FBAA78,0)),U,4)_"^"_1 ; FBAA78 - ien of 7078 authorization in file #162.4 | D WAIT^DICD,CREATE^DGPTFCR ; | W !?5,*7,$S(Y>0:"Non-VA PTF Record Created.",1:"Unabl N FBDT < ; < ; obtain Authorization From Date from 7078 authorizat < ; as the admission date on the PTF record < S:$G(FBAA78) FBDT=$P($G(^FB7078(+FBAA78,0)),U,4) < ; < ; call utility to attempt creation of a Non-VA PTF re < D PTFC^FBUTL6($G(DFN),$G(FBDT)) < diff -y --suppress-common-lines ./VADemo/r1/FBCHC78.m ./VADemo/r2/r/FBCHC78.m FBCHC78 ;AISC/DMK-CANCEL A 7078 ;8/18/2004 | FBCHC78 ;AISC/DMK-CANCEL A 7078 ;9/23/92 15:05 ;;3.5;FEE BASIS;**82**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 ; if cancelled civil hospital 7078 then delete associ | D PTF I '$G(FBNH) D PTFD^FBUTL6(DFN,FBADDT) < > PTF ;locate and delete PTF record > ;FBADDT=Authorized from Date > ;FBVEN= ien of vendor > S DA=$O(^DGPT("AFEE",DFN,FBADDT,0)) I $S('$G(DA):1,$D > S DIK="^DGPT(" D ^DIK K DA,DIK W "." Q > ; > ERR ;write ptf error and quit > W !?5,"Unable to delete PTF record.",! > K DA Q diff -y --suppress-common-lines ./VADemo/r1/FBCHEAP.m ./VADemo/r2/r/FBCHEAP.m FBCHEAP ;AISC/DMK-ENTER AMOUNT PAID FROM PRICER ;7/8/2003 | FBCHEAP ;AISC/DMK-ENTER AMOUNT PAID FROM PRICER ;11/15/2001 ;;3.5;FEE BASIS;**38,55,61,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**38**;JAN 30, 1995 S DR="26;S FBPAMT=X;W:FB1725 !?2,""**Payment is for e | S DR="26;S FBPAMT=X;W:FB1725 !?2,""**Payment is for e ;S DR(1,162.5,1)="S:(FBJ-FBK)'>0 Y=24;9//^S X=$S(FBJ- | S DR(1,162.5,1)="8;S FBK=X;S:(FBJ-FBK)'>0 Y=24;9//^S S DR(1,162.5,1)="S FBX=$$ADJ^FBUTL2(FBJ-FBK,.FBADJ,1, | G END:$D(DIRUT) S DR(1,162.5,2)="@20;24R;S:$$INPICD^FBCSV1(X,$G(DA),$ < S DR(1,162.5,3)="S FBX=$$RR^FBUTL4(.FBRRMK,2)" < S DIE("NO^")="" < D < . N ICDVDT S ICDVDT=$P($G(FBIN),"^",6) D ^DIE < K DIE("NO^") G END:$D(DTOUT) < ; file adjustment reasons < D FILEADJ^FBCHFA(FBI_",",.FBADJ) < ; file remittance remarks < D FILERR^FBCHFR(FBI_",",.FBRRMK) < K FBADJ,FBRRMK < diff -y --suppress-common-lines ./VADemo/r1/FBCHEP1.m ./VADemo/r2/r/FBCHEP1.m FBCHEP1 ;AISC/DMK-EDIT PAYMENT FOR CONTRACT HOSPITAL ;7/8/200 | FBCHEP1 ;AISC/DMK-EDIT PAYMENT FOR CONTRACT HOSPITAL ;11/1/20 ;;3.5;FEE BASIS;**38,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**38**;JAN 30, 1995 ; get values of FPPS Claim ID and Line Item < S FBFPPSC=$P($G(^FBAAI(FBI,3)),U) < S FBFPPSL=$P($G(^FBAAI(FBI,3)),U,2) < ; load current adjustment data < D LOADADJ^FBCHFA(FBI_",",.FBADJ) < ; save adjustment data prior to edit session in sorte < S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of or < ; load current remittance remark data < D LOADRR^FBCHFR(FBI_",",.FBRRMK) < ; save remittance remarks prior to edit session in so < S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK) < ; if adjustment data changed then file < I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBCHFA(F < ; if remit remark data changed then file < I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBCHFR(F < K FBFPPSC,FBFPPSL,FBADJ,FBADJD,FBRRMK,FBRRMKD < diff -y --suppress-common-lines ./VADemo/r1/FBCHEP.m ./VADemo/r2/r/FBCHEP.m FBCHEP ;AISC/DMK-ENTER PAYMENT FOR CONTRACT HOSPITAL ;8/18/2 | FBCHEP ;AISC/DMK-ENTER PAYMENT FOR CONTRACT HOSPITAL ;5/27/1 ;;3.5;FEE BASIS;**4,61,77,82**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 ; ask patient control number < S FBCSID=$$ASKPCN^FBUTL5() I FBCSID="^" G Q < ; if U/C then get FPPS Claim ID else ask user < I $D(FB583) S FBFPPSC=$P($G(^FB583(FB583,5)),U) W !," < E S FBFPPSC=$$FPPSC^FBUTL5() I FBFPPSC=-1 G Q < ; if EDI claim then ask FPPS line item < I FBFPPSC]"" S FBFPPSL=$$FPPSL^FBUTL5(,1) I FBFPPSL=- < ; compute default Covered Days < S FBCDAYS=$$FMDIFF^XLFDT(FBAAEDT,FBAABDT) < I FBCDAYS=0 S FBCDAYS=1 < S DA=+Y,DIE=DIC,DR="[FBCH ENTER PAYMENT]",DIE("NO^")= | S DA=+Y,DIE=DIC,DR="[FBCH ENTER PAYMENT]",DIE("NO^")= D < . N ICDVDT S ICDVDT=$G(FBAABDT) D ^DIE < ; file adjustment reasons < D FILEADJ^FBCHFA(DA_",",.FBADJ) < ; file remittance remarks < D FILERR^FBCHFR(DA_",",.FBRRMK) < K DIE,DIC,D,DA,DR < K FBCSID,FBFPPSC,FBFPPSL,FBCDAYS,FBAMTP,FBADJ,FBRRMK < PTF I $G(FBVET),$G(FBI7078)["FB583" S:'$G(DFN) DFN=FBVET | PTF I $G(FBVET),$G(FBI7078)["FB583" S:'$G(DFN) DFN=FBVET Only in ./VADemo/r1/: FBCHFA.m Only in ./VADemo/r1/: FBCHFED.m Only in ./VADemo/r1/: FBCHFR.m diff -y --suppress-common-lines ./VADemo/r1/FBCHP78.m ./VADemo/r2/r/FBCHP78.m FBCHP78 ;AISC/DMK-GENERATE 7078 ;2/12/2003 | FBCHP78 ;AISC/DMK-GENERATE 7078 ;9/28/00 ;;3.5;FEE BASIS;**12,23,52**;JAN 30, 1995 | ;;3.5;FEE BASIS;**12,23**;JAN 30, 1995 N FBCONFAD S FBCONFAD=$$ACTIVECC^FBAACO0() I FBCONFAD < . N FBLEN S FBLEN=$L(VAPA(16))+$L($P($G(VAPA(17)),U,2 < W ?66,L,?70,FBNAME,!,UL,!,"Name of Physician or Stati | W ?66,L,?70,FBNAME,!,UL,!,"Name of Physician or Stati W ?66,L,?68,$S(FBCONFAD:VAPA(15),1:VAPA(3)),!?5,FBV(4 | W ?66,L,?68,VAPA(3),!?5,FBV(4)_", "_FBV(5)_" "_FBV(6) W ?66,L,?68,$S(FBCONFAD:$G(VAPA(16)),1:VAPA(4))_", "_ < diff -y --suppress-common-lines ./VADemo/r1/FBCHPET.m ./VADemo/r2/r/FBCHPET.m FBCHPET ;AISC/DMK-EDIT ANCILLARY PAYMENT ;7/13/2003 | FBCHPET ;AISC/DMK-EDIT ANCILLARY PAYMENT ;10/31/2001 ;;3.5;FEE BASIS;**4,38,61,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,38**;JAN 30, 1995 S DIC=FBZ,DIC(0)="AEQMZ" | S DIC=FBZ,DIC(0)="AEQMZ" D ^DIC G GETPT:X="^"!(X=""), D < . N ICPTVDT S ICPTVDT=$G(FBAADT) D ^DIC < G GETPT:X="^"!(X=""),SERV:Y<0 S (FBSV,FBAACPI,FBDA)=+ < ; load current adjustment data < D LOADADJ^FBAAFA(FBDA_","_FBDA(1)_","_FBDA(2)_","_FBD < ; save adjustment data prior to edit session in sorte < S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of or < ; load current remittance remark data < D LOADRR^FBAAFR(FBDA_","_FBDA(1)_","_FBDA(2)_","_FBDA < ; save remittance remarks prior to edit session in so < S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK) < S FBFPPSC(0)=$P($G(^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1) < S FBFPPSC=FBFPPSC(0) < S FBFPPSL(0)=$P($G(^FBAAC(FBDA(3),1,FBDA(2),1,FBDA(1) < S FBFPPSL=FBFPPSL(0) < S DR="48;47;S FBUNITS=X;42R;S FBZIP=X;S:$$ANES^FBAAFS | S DR="42R;S FBZIP=X;S:$$ANES^FBAAFS($$CPT^FBAAUTL4(FB ;S DR(1,162.03,3)="3////^S X=$S(J-K:J-K,1:"""");I X S | S DR(1,162.03,3)="3////^S X=$S(J-K:J-K,1:"""");I X S S DR(1,162.03,3)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ | S DR(1,162.03,4)="@5;K DIE(""NO^"");W !,""Exit ('^') S DR(1,162.03,4)="S FBX=$$FPPSC^FBUTL5(1,FBFPPSC);S:F | S DR(1,162.03,5)="15;16;17////^S X=1" S DR(1,162.03,5)="@5;K DIE(""NO^"");W !,""Exit ('^') | S DIE=FBZ D ^DIE K FBSV W !! G SERV S DR(1,162.03,6)="15;16;17////^S X=1" < S DR(1,162.03,7)="@7;K FBRRMKD;M FBRRMKD=FBRRMK;S FBX < S DIE=FBZ < D < . N ICPTVDT,ICDVDT S (ICPTVDT,ICDVDT)=$G(FBAADT) D ^D < ; if adjustment data changed then file < I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBAAFA(F < ; if remit remark data changed then file < I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBAAFR(F < ; if FPPS CLAIM ID changed, update other line items o < I FBFPPSC'=FBFPPSC(0) D < . N FBAAIN < . S FBAAIN=$$GET1^DIQ(162.03,FBDA_","_FBDA(1)_","_FBD < . D CKINVEDI^FBAAPET1(FBFPPSC(0),FBFPPSC,FBAAIN,FBDA_ < K FBSV W !! G SERV < K FBADJ,FBADJD,FBADJL,FBRRMK,FBRRMKD,FBRRMKL,FBX,FBUN < diff -y --suppress-common-lines ./VADemo/r1/FBCHRJP.m ./VADemo/r2/r/FBCHRJP.m ;;3.5;FEE BASIS;**58,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 ..S FB7078=$S($P(^FBAAI(FBI,0),"^",5)["FB7078":$P($G( | ..S FB7078=$P(^FB7078(+$P(^FBAAI(FBI,0),"^",5),0),"^" END K DFN,FB,FBA,FBAAOUT,FBDX,FBI,FBIN,FBLISTC,FBN,FBPROC | END K DFN,FB,FBA,FBAAOUT,FBDX,FBI,FBIN,FBLISTC,FBN,FBPROC S FBINV=^TMP($J,"FB",6,FBVEN,FBNAME,FBDT,FBI,"FBINV") < ;If adj code found print it, if not then print suspen < I $P(FBINV,U,5)]"" S FBIN(4)=$P(FBINV,U,5) < ;If FPPS Claim ID exists then print it. | W !?3,"DX: ",+^TMP($J,"FB",6,FBVEN,FBNAME,FBDT,FBI,"D I $P(FBINV,U,3)]"" D < .W !?3,"FPPS Claim ID: ",$P(FBINV,U,3)," FPPS Line < W !?3,"DX: ",+$G(^TMP($J,"FB",6,FBVEN,FBNAME,FBDT,FBI < W !?2,"Inv Date",?23,"Amount",?33," Amount",?42,"Adj" | W !?2,"Inv Date",?23,"Amount",?33," Amount",?42,"Susp diff -y --suppress-common-lines ./VADemo/r1/FBCHRR.m ./VADemo/r2/r/FBCHRR.m FBCHRR ;AISC/DMK-RE-INITIATE REJECTS FROM PRICER ;7/17/2003 | FBCHRR ;AISC/DMK-RE-INITIATE REJECTS FROM PRICER;18APR90 ;;3.5;FEE BASIS;**61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 S FBPRICE="" | S FBPRICE="",(DIC,DIE)="^FBAAI(",DA=FBI,DR="[FBCH EDI ; get values of FPPS Claim ID and Line Item | END K DIC,D,DA,DIRUT,DR,DTOUT,DUOUT,FBPRICE,VAL,DIE,FBI,F S FBFPPSC=$P($G(^FBAAI(FBI,3)),U) < S FBFPPSL=$P($G(^FBAAI(FBI,3)),U,2) < ; load current adjustment data < D LOADADJ^FBCHFA(FBI_",",.FBADJ) < ; save adjustment data prior to edit session in sorte < S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of or < ; load current remittance remark data < D LOADRR^FBCHFR(FBI_",",.FBRRMK) < ; save remittance remarks prior to edit session in so < S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK) < S (DIC,DIE)="^FBAAI(",DA=FBI,DR="[FBCH EDIT PAYMENT]" < D ^DIE G H^XUS:$D(DTOUT) < ; if adjustment data changed then file < I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBCHFA(F < ; if remit remark data changed then file < I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBCHFR(F < END K DIC,D,DA,DIRUT,DR,DTOUT,DUOUT,FBPRICE,VAL,DIE,FBI,F < K FBFPPSC,FBFPPSL,FBADJ,FBADJL,FBRRMK,FBRRMKL < D END^FBCHDI < diff -y --suppress-common-lines ./VADemo/r1/FBCHSL1.m ./VADemo/r2/r/FBCHSL1.m ;;3.5;FEE BASIS;**23,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**23**;JAN 30, 1995 N FBACRR,FBSCDT | F K=0:0 S K=$O(^FBAAI("AI",K)) Q:K'>0 I $S($G(IFN):I F K=0:0 S K=$O(^FBAAI("AI",K)) Q:K'>0 I $S($G(IFN):I < WPBOT D:$D(FBACRR) ACT^FBAASLP K FBACRR | WPBOT S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !! S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !! < N FBY3,FBFPPSC < S FBY3=$G(^FBAAI(L,3)) < S FBFPPSC=$P(FBY3,U,1) ; fpps claim id < Q:$S(FBENA=2&(FBFPPSC]""):1,FBENA=1&(FBFPPSC=""):1,1: < N FBCSID,FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,T,TAMT < S FBCSID=$P($G(^FBAAI(L,2)),U,11) ; patient control n < S FBFPPSL=$P(FBY3,U,2) ; fpps line item < S FBX=$$ADJLRA^FBCHFA(L_",") < S T=$P(Z(0),U,11) < I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U) < S TAMT=$FN($P(Z(0),U,10),"",2) < S FBADJLR=$P(FBX,U) < S:FBADJLR]"" FBACRR(FBADJLR)="" < S FBADJLA=$P(FBX,U,2) < S FBRRMKL=$$RRL^FBCHFR(L_",") < W !!,PNAME,?32,PSSN,?56,FBCHAD | W !!,PNAME,?32,PSSN,?56,FBCHAD,!,?2,FBCHDT,?23,"$ ",F W !,FBCSID,?24,FBCHDT,?44,"$ ",FBAMTC,?61,"$ ",FBAMTP | G:FBA=4&($D(^FBAAI(L,1,0))) WPFT ; write adjustment reasons, if null then write suspen | S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W") W ?4,$S(FBADJLR]"":FBADJLR,1:T) | F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FBRR ; write adjustment amounts, if null then write amount | D ^DIWW:$D(FBXX) K FBXX W ?32,"$ ",$S(FBADJLA]"":FBADJLA,1:TAMT) | Q W ?59,FBRRMKL | HED W !,"PATIENT NAME",?36,"SSN",?53,"ADMISSION DATE",!,? I FBFPPSC]"" W !,?4,"FPPS Claim ID: ",FBFPPSC,?32,"FP < I FBADJLR="" G:FBA=4&($D(^FBAAI(L,1,0))) WPFT D < . S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W") < . F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FB < . D ^DIWW:$D(FBXX) K FBXX < Q < HED W !,"PATIENT NAME",?36,"SSN",?53,"ADMISSION DATE" < W !,"PATIENT CONTROL #",?22,"DISCHARGE DATE",?42,"AMO < W !,"ADJUSTMENT CODE",?29,"ADJUSTMENT AMOUNT",?54,"ME < W !,UL,! Q < diff -y --suppress-common-lines ./VADemo/r1/FBCHVH.m ./VADemo/r2/r/FBCHVH.m FBCHVH ;AISC/DMK-VENDOR PAYMENT HISTORY ;7/17/2003 | FBCHVH ;AISC/DMK-VENDOR PAYMENT HISTORY ;02FEB89 ;;3.5;FEE BASIS;**55,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 GETINV ; | GETINV S FBIN=^FBAAI(FBI,0) F J=1,2,3,4,6,7,8,9,11,13,14 S F N FBADJLA,FBADJLR,FBCDAYS,FBCSID,FBFPPSC,FBFPPSL,FBRR | S FBVINDT=$P($G(^FBAAI(+FBI,2)),"^",2) D FBCKI^FBAACC S FBIN=^FBAAI(FBI,0) < S FBY2=$G(^FBAAI(FBI,2)) < S FBY3=$G(^FBAAI(FBI,3)) < F J=1,2,3,4,6,7,8,9,10,11,13,14 S FBIN(J)=$P(FBIN,"^" < S FBVINDT=$P(FBY2,"^",2) D FBCKI^FBAACCB1(FBI) < S FBCDAYS=$P(FBY2,U,10) ; covered days < S FBCSID=$P(FBY2,U,11) ; patient control number < S FBFPPSC=$P(FBY3,U) ; fpps claim id < S FBFPPSL=$P(FBY3,U,2) ; fpps line item < S FBX=$$ADJLRA^FBCHFA(FBI_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S FBRRMKL=$$RRL^FBCHFR(FBI_",") < W VADM(1)_" "_$P(VADM(2),"^",2),?48,FBCSID | W VADM(1)_" "_$P(VADM(2),"^",2),!,?4,FBVEN,?45,FBVID W !,?4,FBVEN,?45,FBVID,?62,FBIN(1) < W !,$S(FBIN(13)["R":"*",1:""),$S(FBIN(14)]"":"#",1:"" < W ?4,FBFPPSC,?18,FBFPPSL,?35,FBIN(2),?46,$$DATX^FBAAU < W !?4,$J(FBIN(8),1,2),?17,$J(FBIN(9),1,2),?29,FBCDAYS < ; write adjustment reasons, if null then write suspen < W ?39,$S(FBADJLR]"":FBADJLR,1:FBIN(11)) < ; write adjustment amounts, if null then write amount < W ?49,$S(FBADJLA]"":FBADJLA,1:$J(FBIN(10),1,2)) < W ?64,FBRRMKL < W ! < WRTDX I $P(FBDX,"^",K)]"" W ?4,"Dx: ",$$ICD9^FBCSV1(+$P(FBD | WRTDX I $P(FBDX,"^",K)]"" W ?4,"Dx: ",$S($D(^ICD9(+$P(FBDX, WRTPC I $P(FBPROC,"^",L)]"" W ?4,"Proc: ",$$ICD0^FBCSV1(+$P | WRTPC I $P(FBPROC,"^",L)]"" W ?4,"Proc: ",$S($D(^ICD0(+$P(F W !,"Veteran's Name",?48,"Patient Control Number" | W !,"Veteran's Name",?17,"('*'Reimbursement to Vetera W !,"('*'Reimbursement to Veteran '+' Cancellation | W !,?3,"Vendor Name",?45,"Vendor ID",?59,"Invoice #", W !,?4,"Vendor Name",?45,"Vendor ID",?59,"Invoice #" < ;W !,?3,"Fr Date",?14,"To Date Claimed Paid",?41," < W !,?4,"FPPS Claim ID",?18,"FPPS Line Item",?35,"Date < W !,?4,"Amt Claimed",?17,"Amt Paid",?29,"Cov.Days",?3 < W !,Q,! < diff -y --suppress-common-lines ./VADemo/r1/FBCHVP.m ./VADemo/r2/r/FBCHVP.m ;;3.5;FEE BASIS;**55,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 WRT N FBX,FBY2,FBY3,FBCDAYS,FBSCID,FBFPPSC,FBFPPSL,FBADJL | WRT S ^TMP($J,"FBCHVP",FBI)=FBINV S FBX=$$ADJLRA^FBCHFA(FBI_",") < S FBY2=$G(^FBAAI(FBI,2)) < S FBY3=$G(^FBAAI(FBI,3)) < S FBCDAYS=$P(FBY2,U,10) ; covered days < S FBSCID=$P(FBY2,U,11) ; patient control number < S FBFPPSC=$P(FBY3,U) ; fpps claim id < S FBFPPSL=$P(FBY3,U,2) ; fpps line item < S FBRRMKL=$$RRL^FBCHFR(FBI_",") ; remit remarks < S FBADJLR=$P(FBX,U) ; adjustment reason < S ^TMP($J,"FBCHVP",FBI)=FBINV < S ^TMP($J,"FBCHVP",FBI,"FBMR")=FBCDAYS_U_FBADJLR_U_FB < WRT1 N FBMRVP S FBMRVP=^TMP($J,"FBCHVP",FBI,"FBMR") | WRT1 S FBREIM=$P(FBINV,"^",13),FBFDT=$P(FBINV,"^",6),FBTDT S FBREIM=$P(FBINV,"^",13),FBFDT=$P(FBINV,"^",6),FBTDT < W ?26,$S($G(FBDRG):$J($$ICD^FBCSV1(FBDRG,$G(FBFDT)),4 | W ?26,$S($G(FBDRG):$J($P(^ICD(FBDRG,0),"^"),4),1:""), W !,?5,$P(FBMRVP,U),?19,$P(FBMRVP,U,2),?34,$P(FBMRVP, < I $P(FBMRVP,U,5)]"" W !,?5,"FPPS Claim ID: ",$P(FBMRV < W !," FROM DATE",?16,"TO DATE",?26,"DRG",?33,"AMT C | W !," FROM DATE",?16,"TO DATE",?26,"DRG",?33,"AMT C W !,?5,"COV.DAYS",?19,"ADJ CODE",?34,"REMIT REMARKS", < W !,Q,! < diff -y --suppress-common-lines ./VADemo/r1/FBCKDIS.m ./VADemo/r2/r/FBCKDIS.m FBCKDIS ;AISC/CMR-OUTPUT BY CHECK # ;8/7/2003 | FBCKDIS ;AISC/CMR- UTPUT BY CHECK # ;6/21/1999 ;;3.5;FEE BASIS;**4,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 ...N FBAARC,FBADJLA,FBADJLR,FBC,FBFPPSC,FBFPPSL,FBSUS < S FBA=^FBAAC(FB(1),1,FB(2),1,FB(3),1,FB(4),0),FBB=^(2 | S FBA=^FBAAC(FB(1),1,FB(2),1,FB(3),1,FB(4),0),FBB=^(2 S FBSUSPA=$FN($P(FBA,U,4),"",2) < S FBFPPSC=$P(FBC,U) < S FBFPPSL=$P(FBC,U,2) < S FBAARCE=$$GET1^DIQ(162.03,FB(4)_","_FB(3)_","_FB(2) < S FBX=$$ADJLRA^FBAAFA(FB(4)_","_FB(3)_","_FB(2)_","_F < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S FBA=^FBAAI(FBDA,0),FBB=^(2),FBC=$G(^(3)),FBDOS=$P(F | S FBA=^FBAAI(FBDA,0),FBB=^(2),FBDOS=$P(FBA,U,6)_"-"_$ S FBSUSPA=$FN($P(FBA,U,10),"",2) < S FBFPPSC=$P(FBC,U) < S FBFPPSL=$P(FBC,U,2) < S FBX=$$ADJLRA^FBCHFA(FBDA_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < S FBA=^FBAA(162.1,FB(1),"RX",FB(2),0),FBB=^(2),FBC=$G | S FBA=^FBAA(162.1,FB(1),"RX",FB(2),0),FBB=^(2),FBDOS= S FBSUSPA=$FN($P(FBA,U,7),"",2) < S FBFPPSC=$P($G(^FBAA(162.1,FB(1),0)),U,13) < S FBFPPSL=$P(FBC,U) < S FBX=$$ADJLRA^FBRXFA(FB(2)_","_FB(1)_",") < S FBADJLR=$P(FBX,U) < S FBADJLA=$P(FBX,U,2) < . I FBPROG["C" D Q | . I FBPROG["C" W ?3,$$DATX^FBAAUTL($P(FBDOS,"-")),?12 . . W ?3,$$DATX^FBAAUTL($P(FBDOS,"-")),?15,$$DATX^FBA < . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD, < . . ; write adjustment reasons, if null then write su < . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP) < . . ; write adjustment amounts, if null then write am < . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA) < . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?4 < . . W ?3,$$DATX^FBAAUTL(FBDOS),?13,$P(FBSRV,","),?23, | . . W ?3,$$DATX^FBAAUTL(FBDOS),?13,$P(FBSRV,",") . . W ?59,+$G(^FBAA(161.7,+FBBAT,0)),?68,FBINV | . . W ?20,$J($FN(FBAMCL,",",2),10),?32,$J($FN(FBAMPD, > . . W ?47,FBSUSP,?53,+$G(^FBAA(161.7,+FBBAT,0)),?65,F . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD, | . W ?3,$$DATX^FBAAUTL(FBDOS) W:FBPROG'="TRAV" ?13,FBS . . ; write adjustment reasons, if null then write su < . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP) < . . ; write adjustment amounts, if null then write am < . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA) < . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?4 < . I FBPROG="PHAR" D Q < . . W ?3,$$DATX^FBAAUTL(FBDOS),?13,FBSRV,?59,+$G(^FBA < . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD, < . . ; write adjustment reasons, if null then write su < . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP) < . . ; write adjustment amounts, if null then write am < . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA) < . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?4 < . W ?3,$$DATX^FBAAUTL(FBDOS) W:FBPROG'="TRAV" ?13,FBS < I FBPROG["C" D Q | I FBPROG["C" W !?3,"From",?12,"To",?23,"Amount",?34," . W !?3,"From Date",?15,"To Date",?59,"Batch #",?68," < . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",? < . W !,QQ < I FBPROG="OPT" D Q | W !?3,$S(FBPROG="OPT":"Svc Date",1:"Fill Dt"),?13,$S( . W !?3,"Svc Date",?13,"CPT-MOD",?23,"Rev.Code",?59," | W ?44,"Code",?50,"Number",?62,"Number",!,QQ Q . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",? < . W !,QQ < I FBPROG="PHAR" D Q < . W !?3,"Fill Dt",?13,"RX #",?56,"Batch #",?68,"Invoi < . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",? < . W !,QQ < Only in ./VADemo/r1/: FBCSV1.m diff -y --suppress-common-lines ./VADemo/r1/FBCTAU1.m ./VADemo/r2/r/FBCTAU1.m FBCTAU1 ; ;06/28/03 | FBCTAU1 ; ;12/31/01 C4S S X="" G:DG(DQ)=X C4F1 K DB | C4S S X="" Q:DG(DQ)=X K DB C4F1 Q | Q C8S S X="" G:DG(DQ)=X C8F1 K DB | C8S S X="" Q:DG(DQ)=X K DB C8F1 Q | Q C14S S X="" G:DG(DQ)=X C14F1 K DB | C14S S X="" Q:DG(DQ)=X K DB D:'$D(DIU(0)) EVENT^IVMPLOG(DA(1)),ENRLLMNT^FBGMT2(DA | D:'$D(DIU(0)) EVENT^IVMPLOG(DA(1)) C14F1 Q | Q C16S S X="" G:DG(DQ)=X C16F1 K DB | C16S S X="" Q:DG(DQ)=X K DB C16F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/FBCTAU2.m ./VADemo/r2/r/FBCTAU2.m FBCTAU2 ; ;06/28/03 | FBCTAU2 ; ;12/31/01 C2S S X="" G:DG(DQ)=X C2F1 K DB | C2S S X="" Q:DG(DQ)=X K DB C2F1 Q | Q C15S S X="" G:DG(DQ)=X C15F1 K DB | C15S S X="" Q:DG(DQ)=X K DB C15F1 Q | Q C19S S X="" G:DG(DQ)=X C19F1 K DB | C19S S X="" Q:DG(DQ)=X K DB C19F1 Q | Q C20S S X="" G:DG(DQ)=X C20F1 K DB | C20S S X="" Q:DG(DQ)=X K DB C20F1 Q | Q C21S S X="" G:DG(DQ)=X C21F1 K DB | C21S S X="" Q:DG(DQ)=X K DB C21F1 Q | Q C24S S X="" G:DG(DQ)=X C24F1 K DB | C24S S X="" Q:DG(DQ)=X K DB C24F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/FBCTAU3.m ./VADemo/r2/r/FBCTAU3.m FBCTAU3 ; ;06/28/03 | FBCTAU3 ; ;12/31/01 diff -y --suppress-common-lines ./VADemo/r1/FBCTAU4.m ./VADemo/r2/r/FBCTAU4.m FBCTAU4 ; ;06/28/03 | FBCTAU4 ; ;12/31/01 diff -y --suppress-common-lines ./VADemo/r1/FBCTAU.m ./VADemo/r2/r/FBCTAU.m FBCTAU ; GENERATED FROM 'FBAA AUTHORIZATION' INPUT TEMPLATE( | FBCTAU ; GENERATED FROM 'FBAA AUTHORIZATION' INPUT TEMPLATE( C7S S X="" G:DG(DQ)=X C7F1 K DB | C7S S X="" Q:DG(DQ)=X K DB C7F1 Q | Q Only in ./VADemo/r1/: FBFHLD3.m Only in ./VADemo/r1/: FBFHLD5.m Only in ./VADemo/r1/: FBFHLD9.m Only in ./VADemo/r1/: FBFHLL.m Only in ./VADemo/r1/: FBFHLP.m Only in ./VADemo/r1/: FBFHLS1.m Only in ./VADemo/r1/: FBFHLS.m Only in ./VADemo/r1/: FBFHLU.m Only in ./VADemo/r1/: FBFHLX1.m Only in ./VADemo/r1/: FBFHLX.m Only in ./VADemo/r1/: FBFPAR.m Only in ./VADemo/r1/: FBFPCI.m Only in ./VADemo/r1/: FBFPTR.m Only in ./VADemo/r1/: FBGMT2.m diff -y --suppress-common-lines ./VADemo/r1/FBHLZFE.m ./VADemo/r2/r/FBHLZFE.m FBHLZFE ;WCIOFO/SAB-CREATE HL7 ZFE SEGMENTS ;7/21/1998 | FBHLZFE ;WCIOFO/SAB - CREATE HL7 ZFE SEGMENTS ; 7/21/1998 ;;3.5;FEE BASIS;**14,78**;JAN 30, 1995 | ;;3.5;FEE BASIS;**14**;JAN 30, 1995 ; If an exception did not occur < ; I will be numeric values greater than < ; If an exception did occur | N FBA,FBDA1,FBGRP,FBI,FBY0 ; FBZFE(0) = -1 ^ exception number ^ exception tex < ; < N FBA,FBDA1,FBGRP,FBI,FBICN,FBY0 < I $G(FBCUT)="" S FBCUT=2961001 | I $G(FBCUT)'?7N S FBCUT=2961001 ; check for required input | ; find authorizations that meet criteria (if any) I $G(FBZFE(0))'<0 D | ; loop thru authorizations . I $G(DFN)="" S FBZFE(0)="-1^103^Patient DFN not spe | S FBDA1=0 F S FBDA1=$O(^FBAAA(DFN,1,FBDA1)) Q:'FBDA1 . I '$D(HLFS)!'$D(HLECH)!'$D(HLQ) S FBZFE(0)="-1^201^ | . Q:$P($G(^FBAAA(DFN,1,FBDA1,"ADEL")),U)="Y" ; ignor ; | . S FBY0=$G(^FBAAA(DFN,1,FBDA1,0)) ; get patient ICN | . Q:$P(FBY0,U,3)="" ; FEE Program required I $G(FBZFE(0))'<0 D | . Q:$P(FBY0,U,2)$P($G(FBA(FBGRP)),U,2) ; already < . . ; save as latest found (so far) for a group < . . S FBA(FBGRP)=FBDA1_U_$P(FBY0,U,2) < . ; < . ; build FBZFE array for selected authorizations < . S FBI=0 ; init number of array elements < . S FBGRP="" F S FBGRP=$O(FBA(FBGRP)) Q:FBGRP="" D < . . S FBDA1=$P(FBA(FBGRP),U) < . . D AUTH < diff -y --suppress-common-lines ./VADemo/r1/FBMRASVR.m ./VADemo/r2/r/FBMRASVR.m ;;3.5;FEE BASIS;**9,39,50**;JAN 30, 1995 | ;;3.5;FEE BASIS;**9,39**;JAN 30, 1995 I FBAC="C",($G(FBICN1)]""),(FBICN1'=FBICN) S DIK="^FB | I FBAC="C",($G(FBICN1)]"") S DIK="^FBAAV(",DA=FBICN D diff -y --suppress-common-lines ./VADemo/r1/FBNHDLAD.m ./VADemo/r2/r/FBNHDLAD.m FBNHDLAD ;AISC/GRR-DELETE ADMISSION FOR NURSING HOME ; | FBNHDLAD ;AISC/GRR-DELETE ADMISSION FOR NURSING HOME ; ;;3.5;FEE BASIS;**82**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 S FB("ADDT")=$P(Y(0),"^") ; admission date/time < S DIK=DIE D ^DIK K DIK W !?5,"...deleted",! | S DIK=DIE D ^DIK W !?5,"...deleted",! D PTFD^FBUTL6(DFN,FB("ADDT")) ; delete associated PTF | K FB,DIK G RD1 K FB < G RD1 < diff -y --suppress-common-lines ./VADemo/r1/FBNHEA.m ./VADemo/r2/r/FBNHEA.m FBNHEA ;AISC/GRR-ENTER ADMISSION TO NURSING HOME ;8/18/2004 | FBNHEA ;AISC/GRR-ENTER ADMISSION TO NURSING HOME ;29AUG88 ;;3.5;FEE BASIS;**82**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 S DR="8////^S X=FBVEN;Q;9////^S X=FTP;1////^S X=DFN;2 | S DR="8////^S X=FBVEN;Q;9////^S X=FTP;1////^S X=DFN;2 > PTF S Y=FBY_"^"_1 D WAIT^DICD,CREATE^DGPTFCR W !,*7,$S(Y> > Q diff -y --suppress-common-lines ./VADemo/r1/FBNHEDPA.m ./VADemo/r2/r/FBNHEDPA.m FBNHEDPA ;AISC/GRR-EDIT PAYMENT FOR COMMUNITY NURSING | FBNHEDPA ;AISC/GRR-EDIT PAYMENT FOR COMMUNITY NURSING ;;3.5;FEE BASIS;**61**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 K FBHAP,FBAP | K FBHAP,FBAP S (DIE,DIC)="^FBAAI(",DIC(0)="AEQM",DA=F S (DIE,DIC)="^FBAAI(",DIC(0)="AEQM",DA=FBI,DR="[FBNH < W ! < N FBHAC < ; get values of FPPS Claim ID and Line Item < S FBFPPSC=$P($G(^FBAAI(FBI,3)),U) < S FBFPPSL=$P($G(^FBAAI(FBI,3)),U,2) < ; load current adjustment data < D LOADADJ^FBCHFA(FBI_",",.FBADJ) < ; save adjustment data prior to edit session in sorte < S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of or < ; load current remittance remark data < D LOADRR^FBCHFR(FBI_",",.FBRRMK) < ; save remittance remarks prior to edit session in so < S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK) < D ^DIE K DIE("NO^") < ; if adjustment data changed then file < I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBCHFA(F < ; if remit remark data changed then file < I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBCHFR(F < K FBADJ,FBADJL,FBRRMK,FBRRMKL,FBFPPSC,FBFPPSL < diff -y --suppress-common-lines ./VADemo/r1/FBNHEP1.m ./VADemo/r2/r/FBNHEP1.m FBNHEP1 ;AISC/GRR-PAYMENT PROCESS CONTINUED ;7/8/2003 | FBNHEP1 ;AISC/GRR-PAYMENT PROCESS CONTINUED ;1/13/98 ;;3.5;FEE BASIS;**12,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**12**;JAN 30, 1995 N FBADJ,FBRRMK,FBX,FBFPPSC,FBFPPSL < > S DR="1////^S X=FBAAID;46////^S X=FBAAVID;47////^S X= > S DR=DR_";6////^S X=FBENDDT;8//^S X=$S(FBNHAC>FBDEFP: S DR="1////^S X=FBAAID;46////^S X=FBAAVID;47////^S X= | S DR(1,162.5,1)="9//^S X=FBNHAC-FBAMTP;10R;S:X'=4 Y=1 S DR(1,162.5,1)="S FBFPPSC=$$FPPSC^FBUTL5();S:FBFPPSC < S DR(1,162.5,2)="7;S FBNHAC=X;5////^S X=$S(FBPAYDT>FB < S DR(1,162.5,3)="S FBX=$$ADJ^FBUTL2(FBNHAC-FBAMTP,.FB < S DR(1,162.5,4)="S FBX=$$RR^FBUTL4(.FBRRMK,2);S:FBX=0 < S DR(1,162.5,5)="11////^S X=7;12////^S X=FBAAPTC;23// < ; file adjustment reasons < D FILEADJ^FBCHFA(DA_",",.FBADJ) < ; file remittance remarks < D FILERR^FBCHFR(DA_",",.FBRRMK) < diff -y --suppress-common-lines ./VADemo/r1/FBPAID.m ./VADemo/r2/r/FBPAID.m FBPAID ;WOIFO/SAB-SERVER ROUTINE TO UPDATE PAYMENTS ;9/9/200 | FBPAID ;AISC - SERVER ROUTINE TO UPDATE PAYMENTS ;3/9/94 ;;3.5;FEE BASIS;**5,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**5**;JAN 30, 1995 N FBINV < ; if any EDI invoices then add to FPPS queue < I $D(FBINV) D PAIDLOG^FBFHLL(.FBINV) < ; if EDI then add invoice to list in FBINV(, patch *6 < I FBACT'="B",$P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA, < . N FBAAIN < . S FBAAIN=$P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,0) < . I FBAAIN]"" S FBINV(3,FBAAIN)="" < ; if EDI then add invoice to list in FBINV(, patch *6 < I FBACT'="B",$P($G(^FBAA(162.1,DA(1),0)),U,13)]"" D < . N FBAAIN < . S FBAAIN=$P($G(^FBAA(162.1,DA(1),0)),U) < . I FBAAIN]"" S FBINV(5,FBAAIN)="" < ; if EDI then add invoice to list in FBINV(, patch *6 < I FBACT'="B",$P($G(^FBAAI(DA,3)),U)]"" D < . N FBAAIN < . S FBAAIN=$P($G(^FBAAI(DA,0)),U) < . I FBAAIN]"" S FBINV(9,FBAAIN)="" < Only in ./VADemo/r1/: FBPATDAT.m diff -y --suppress-common-lines ./VADemo/r1/FBPAY21.m ./VADemo/r2/r/FBPAY21.m ;;3.5;FEE BASIS;**4,32,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,32**;JAN 30, 1995 > ...S FBLOC=1_U_12_U_23_U_33_U_42_U_57_U_63_U_71 ...S FBADJ=$G(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,L,M,"F < ...W ?1,$P(FBDATA,U,1) | ...S I=1 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) ...W ?11,$P($P(FBDATA,U,2),",") | ...S I=2 W ?$P(FBLOC,U,I),$P($P(FBDATA,U,I),",") ...W ?22,$P(FBADJ,U,9) | ...F I=3:1:8 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) ...W ?31,$J($P(FBADJ,U,2),10) < ...W ?43,$P(FBDATA,U,6) < ...W ?54,$P(FBDATA,U,7) < ...W ?64,$P(FBDATA,U,8) < .....I $Y+7>IOSL D PAGE Q:FBOUT W !," (continued)" | .....I $Y+6>IOSL D PAGE Q:FBOUT W !," (continued)" .....W !?16,"-",FBMOD | .....W !,?$P(FBLOC,U,2)+5,"-",FBMOD ...W !,$P(FBDATA,U,3) < ...W ?13,$P(FBDATA,U,4) < ...W ?23,$S($P(FBADJ,U,3)]"":$P(FBADJ,U,3),1:$P(FBDAT < ...W ?33,$J($S($P(FBADJ,U,4)]"":$J($P(FBADJ,U,4),14), < ...W ?48,$P(FBADJ,U,5) < ...W ?60,$P(FBADJ,U,6) < ...I $P(FBADJ,U,7)]"" W !?5,"FPPS Claim ID: ",$P(FBAD < W !,?1,"Svc Date",?11,"CPT-MOD ",?21,"Rev Code",?31," | W !,?2,"Svc Date",?11,"CPT-MOD ",?23,"Amount",?33," A W !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36," | W !,?23,"Claimed",?35,"Paid",?42,"Code",?58,"Num",?64 diff -y --suppress-common-lines ./VADemo/r1/FBPAY2.m ./VADemo/r2/r/FBPAY2.m ;;3.5;FEE BASIS;**4,32,55,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,32**;JAN 30, 1995 K FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ < N FBX < S FBY=$G(^FBAAC(J,1,K,1,L,1,M,2)) < S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3)) < S FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",4 < S FBPDX=$$ICD9EX^FBCSV1(FBPDX,3,18,+$G(^FBAAC(J,1,K,1 | S FBPDX=$S($D(^ICD9(FBPDX,0)):$E($P($G(^(0)),U,3),1,1 I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U) ;suspend code | I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U) S TAMT=$FN($P(Y,U,4),"",2) ;suspend amount < S FBUNITS=$P(FBY,U,14) ;units paid < S FBCSID=$P(FBY,U,16) ;patient control number < S FBFPPSC=$P(FBY3,U) ; fpps claim id < S FBFPPSL=$P(FBY3,U,2) ; fpps line item < S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",") < S FBADJLR=$P(FBX,U) ;adjustment codes < S FBADJLA=$P(FBX,U,2) ;adjustment amounts < S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",") ;remi < S ^TMP($J,"FB",FBP,FBVEN,FBPAT,I,L,M,"FBADJ")=TAMT_U_ < diff -y --suppress-common-lines ./VADemo/r1/FBPAY3.m ./VADemo/r2/r/FBPAY3.m ;;3.5;FEE BASIS;**12,32,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**12,32**;JAN 30, 1995 K FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,TAMT,FBRRMKL < N FBX < S FBFPPSC=$P($G(^FBAA(162.1,+K,0)),U,13) ;FPPS claim < S FBFPPSL=$P($G(^FBAA(162.1,+K,"RX",+L,3)),U) ;FPPS l < S FBX=$$ADJLRA^FBRXFA(+L_","_+K_",") < S FBADJLR=$P(FBX,U) ;adjustment code < S FBADJLA=$P(FBX,U,2) ;adjustment amount < S TAMT=$FN($P(Y(0),"^",7),"",2) ;suspend amount < S FBRRMKL=$$RRL^FBRXFR(+L_","_+K_",") ;remitt remarks < S ^TMP($J,"FB",FBPI,FBVEN,FBPAT,I,L)=FBFD1_U_FBRX_U_F | S ^TMP($J,"FB",FBPI,FBVEN,FBPAT,I,L)=FBFD1_U_FBRX_U_F S ^TMP($J,"FB",FBPI,FBVEN,FBPAT,I,L,"FBADJ")=FBADJLR_ < ..S FBADJ=^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,L,"FBADJ") | ..S FBLOC="0^2^15^45^63^4^12^20^24^35^53" ..; S FBLOC="0^2^15^45^63^4^12^20^24^35^53" | ..W !,$P(FBDATA,U),! F I=2:1:$L(FBLOC,"^") W ?$P(FBLO ..W !,$P(FBDATA,U),?64,$P(FBDATA,U,11),! < ..W ?2,$P(FBDATA,U,2),?15,$P(FBDATA,U,3),?45,$P(FBDAT < ..;F I=2:1:$L(FBLOC,"^") W ?$P(FBLOC,U,I),$P(FBDATA,U < ..W !?4,$P(FBDATA,U,6),?12,$P(FBDATA,U,7) < ..W ?20 I $P(FBADJ,U,1)]"" W $P(FBADJ,U,1),?30,$J($P( < ..I $P(FBADJ,U,1)="" W $P(FBDATA,U,8),?30,$J($P(FBDAT < ..W ?47,$P(FBDATA,U,9),?58,$P(FBDATA,U,10),?66,$P(FBA < ..I $P(FBADJ,U,4)]"" W !?5,"FPPS Claim ID: ",$P(FBADJ < W !?4,"Fill Date",?64,"Date Certified" | W !?4,"Fill Date",!,?15,"Drug Name",?44,"Strength",?6 W !,?15,"Drug Name",?44,"Strength",?60,"Quantity" | W !?2,"Claimed",?12,"Paid",?19,"Code",?24,"Invoice #" W !?2,"Claimed",?12,"Paid",?20,"Adj Code",?33,"Adj Am < diff -y --suppress-common-lines ./VADemo/r1/FBPAY671.m ./VADemo/r2/r/FBPAY671.m ;;3.5;FEE BASIS;**4,32,55,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,32**;JAN 30, 1995 EN1 N FBI,FBINV ;entry point from fbchdi | EN1 N FBI ;entry point from fbchdi ..S FBINV=^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,FBI,"FBINV | ..S FBLOC=2_U_23_U_33_U_42_U_49_U_61_U_71 ..W ?2,$P(FBDATA,U,1),?15,$P(FBDATA,U,5),?31,$P(FBDAT | ..F I=1:1:7 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) ..W ?47,$P(FBDATA,U,7),?57,$P(FBINV,U,2) < ..W !?2,$P(FBDATA,U,2),?15,$P(FBDATA,U,3),?25,$P(FBIN < .. ;Print adj reasons, if null then print suspend cod < ..W ?36,$S($P(FBINV,U,5)]"":$P(FBINV,U,5),1:$P(FBDATA < ..W ?46,$S($P(FBINV,U,5)]"":$J($P(FBINV,U,6),14),1:$J < ..W ?63,$P(FBINV,U,7) < .. ;If FPPS Claim ID exists then print it. < ..I $P(FBINV,U,3)]"" D < ...W !?5,"FPPS Claim ID: ",$P(FBINV,U,3)," FPPS Li < S FBADJ=$G(^TMP($J,"FB",FBPI,FBVI,FBPT,"A",FBK,FBL,FB < W ?1,$P(FBDATA,U,1) | S I=1 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) W ?11,$P($P(FBDATA,U,2),",") | S I=2 W ?$P(FBLOC,U,I),$P($P(FBDATA,U,I),",") W ?22,$P(FBADJ,U,9) | F I=3:1:FBSL W ?$P(FBLOC,U,I),$P(FBDATA,U,I) W ?31,$J($P(FBADJ,U,2),10) < W ?43,$P(FBDATA,U,6) < W ?54,$P(FBDATA,U,7) < W ?64,$P(FBDATA,U,8) < . . I $Y+7>IOSL D PAGE Q:FBOUT D SHA Q:FBOUT D SHA2 | . . I $Y+6>IOSL D PAGE Q:FBOUT D SHA Q:FBOUT D SHA2 . . W !?16,"-",FBMOD | . . W !,?$P(FBLOC,U,2)+5,"-",FBMOD W !,$P(FBDATA,U,3) < W ?13,$P(FBDATA,U,4) < W ?23,$S($P(FBADJ,U,3)]"":$P(FBADJ,U,3),1:$P(FBDATA,U < W ?33,$J($S($P(FBADJ,U,4)]"":$J($P(FBADJ,U,4),14),1:$ < W ?48,$P(FBADJ,U,5) < W ?60,$P(FBADJ,U,6) < ;If FPPS Claim ID exists then print it. < I $P(FBADJ,U,7)]"" D < .W !?5,"FPPS Claim ID: ",$P(FBADJ,U,7)," FPPS Line < > ;W ?71,"Page: ",FBPG W !?1,"Invoice Date",?15,"Invoice No.",?31,"From Date | W !?2,"Inv Date",?23,"Amount",?33," Amount",?42,"Susp W !?1,"Amt Claimed",?15,"Amt Paid",?25,"Cov Days",?36 | W !?23,"Claimed",?35,"Paid",?42,"Code",?53,"Num",?61, W !,?1,"Svc Date",?11,"CPT-MOD ",?21,"Rev Code",?31," | W !,?2,"Svc Date",?11,"CPT Code",?23,"Amount",?33," A W !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36," | W !,?23,"Claimed",?35,"Paid",?42,"Code",?58,"Num",?64 WRTDX I $P(FBDX,"^",K)]"" W ?4,"Dx: ",$$ICD9^FBCSV1($P(FBDX | WRTDX I $P(FBDX,"^",K)]"" W ?4,"Dx: ",$S($D(^ICD9($P(FBDX," WRTPC I $P(FBPROC,"^",L)]"" W ?4,"Proc: ",$$ICD0^FBCSV1($P( | WRTPC I $P(FBPROC,"^",L)]"" W ?4,"Proc: ",$S($D(^ICD0($P(FB diff -y --suppress-common-lines ./VADemo/r1/FBPAY67.m ./VADemo/r2/r/FBPAY67.m ;;3.5;FEE BASIS;**4,32,55,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,32**;JAN 30, 1995 N FBY2,FBY3,FBCDAYS,FBCSID,FBFPPSC,FBFPPSL,FBX,FBADJL < S FBY2=$G(^FBAAI(FBI,2)) < S FBY3=$G(^FBAAI(FBI,3)) < F J=1,2,3,6,7,8,9,10,11,13,14 S FBIN(J)=$P(FBIN,"^",J | F J=1,2,3,6,7,8,9,11,13,14 S FBIN(J)=$P(FBIN,"^",J) SETTMP S ^TMP($J,"FB",+$P(FBIN,U,12),FBVEN,FBPAT,FBM,FBI)=FB | SETTMP S ^TMP($J,"FB",+$P(FBIN,U,12),FBVEN,FBPAT,FBM,FBI)=FB S FBCDAYS=$P(FBY2,U,10) ; covered days | S FBDX=$G(^FBAAI(FBI,"DX")) I FBDX]"" S FBDX1="" F I= S FBCSID=$P(FBY2,U,11) ; patient control number < S FBFPPSC=$P(FBY3,U) ; fpps claim id < S FBFPPSL=$P(FBY3,U,2) ; fpps line item < S FBX=$$ADJLRA^FBCHFA(FBI_",") < S FBADJLR=$P(FBX,U) ;adjustment reason < S FBADJLA=$P(FBX,U,2) ;adjustment amount < S FBRRMKL=$$RRL^FBCHFR(FBI_",") ;remittance remarks < S ^TMP($J,"FB",+$P(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"FB < S FBDX=$G(^FBAAI(FBI,"DX")) I FBDX]"" S FBDX1="" F I= < S FBPROC=$G(^FBAAI(FBI,"PROC")) I FBPROC]"" S FBPROC1 | S FBPROC=$G(^FBAAI(FBI,"PROC")) I FBPROC]"" S FBPROC1 ..S ^TMP($J,"FB",FBPI_"O",FBVEN,FBPAT,(9999999.9999-F < N FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ < ...S ^TMP($J,"FB",FBPI,FBVEN,FBPAT,"A",K,L,M,"FBADJ") < diff -y --suppress-common-lines ./VADemo/r1/FBPAY.m ./VADemo/r2/r/FBPAY.m ;;3.5;FEE BASIS;**32,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**32**;JAN 30, 1995 K FBADJLA,FBADJLR,FBFPPSC,FBFPPSL,TAMT,FBRRMKL,FBADJ, < diff -y --suppress-common-lines ./VADemo/r1/FBPCR2.m ./VADemo/r2/r/FBPCR2.m ;;3.5;FEE BASIS;**4,48,55,69,76**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,48**;JAN 30, 1995 K FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ < N FBPCR,FBX | N FBPCR S FBY=$G(^FBAAC(J,1,K,1,L,1,M,2)) < I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U) ;suspend code < S TAMT=$FN($P(Y,U,4),"",2) ;suspend amount < S FBUNITS=$P(FBY,U,14) ;units paid < S FBCSID=$P(FBY,U,16) ;patient account number < S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",") < S FBADJLR=$P(FBX,U) ;adjustment codes < S FBADJLA=$P(FBX,U,2) ;adjustment amounts < S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",") ;remi < S ^TMP($J,"FB",FBPSF,FBPAT,FBP,FBVEN,I,L_M,"FBADJ")=T < ..S FBADJ=$G(^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,M | ..S FBLOC=1_U_12_U_23_U_33_U_47_U_57_U_63_U_71 ..;S FBLOC=1_U_12_U_23_U_33_U_47_U_57_U_63_U_71 < ..;S I=1 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) | ..S I=1 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) ..W ?1,$P(FBDATA,U,1) | ..S I=2 W ?$P(FBLOC,U,I),$P($P(FBDATA,U,I),",") ..;S I=2 W ?$P(FBLOC,U,I),$P($P(FBDATA,U,I),",") | ..F I=3:1:8 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) ..W ?11,$P($P(FBDATA,U,2),",") < ..;F I=3:1:8 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) < ..W ?31,$J($P(FBADJ,U,2),10) < ..W ?43,$P(FBDATA,U,6) < ..W ?54,$P(FBDATA,U,7) < ..W ?64,$P(FBDATA,U,8) < ....I $Y+7>IOSL D PAGE Q:FBOUT W !," (continued)" | ....I $Y+6>IOSL D PAGE Q:FBOUT W !," (continued)" ....W !,?16,"-",FBMOD | ....W !,?$P(FBLOC,U,2)+5,"-",FBMOD ..W !,$P(FBDATA,U,3) | ..S FBPDX=$P(FBDATA,U,10),FBPDXC=$P($G(^ICD9(FBPDX,0) ..W ?13,$P(FBDATA,U,4) < ..W ?23,$S($P(FBADJ,U,3)]"":$P(FBADJ,U,3),1:$P(FBDATA < ..W ?33,$J($S($P(FBADJ,U,4)]"":$J($P(FBADJ,U,4),14),1 < ..W ?48,$P(FBADJ,U,5) < ..W ?60,$P(FBADJ,U,6) < ..S FBPDX=$P(FBDATA,U,10),FBPDXC=$$ICD9^FBCSV1(FBPDX, < ;W !!,?2,"Svc Date",?11,"CPT-MOD",?23,"Amount",?33," | W !!,?2,"Svc Date",?11,"CPT-MOD",?23,"Amount",?33," A ;W !,?23,"Claimed",?35,"Paid",?42,"Code",?50,"Paid",? | W !,?23,"Claimed",?35,"Paid",?42,"Code",?50,"Paid",?5 W !!,?1,"Svc Date",?11,"CPT-MOD ",?19,"Travel Paid",? < W !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36," < diff -y --suppress-common-lines ./VADemo/r1/FBPCR3.m ./VADemo/r2/r/FBPCR3.m ;;3.5;FEE BASIS;**48,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**48**;JAN 30, 1995 K FBADJLA,FBADJLR,TAMT,FBRRMKL < N FBX < S FBX=$$ADJLRA^FBRXFA(+L_","_+K_",") < S FBADJLR=$P(FBX,U) ;adjustment code < S FBADJLA=$P(FBX,U,2) ;adjustment amount < S TAMT=$FN($P(Y(0),"^",7),"",2) ;suspend amount < S FBRRMKL=$$RRL^FBRXFR(+L_","_+K_",") ;remitt remarks < S ^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,I,K_L,"FBADJ")= < ..S FBADJ=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,L,"F | ..S FBLOC="0^2^15^45^63^4^12^20^24^35^53" ..W !,$P(FBDATA,U),?64,$P(FBDATA,U,11),! | ..W !,$P(FBDATA,U),! F I=2:1:$L(FBLOC,"^") W ?$P(FBLO ..W ?2,$P(FBDATA,U,2),?15,$P(FBDATA,U,3),?45,$P(FBDAT < ..W !?4,$P(FBDATA,U,6),?12,$P(FBDATA,U,7) < ..W ?20 I $P(FBADJ,U,1)]"" W $P(FBADJ,U,1),?30,$J($P( < ..;If no adjustment code then print suspend cpde amd < ..I $P(FBADJ,U,1)="" W $P(FBDATA,U,8),?30,$J($P(FBADJ < ..W ?47,$P(FBDATA,U,9),?58,$P(FBDATA,U,10),?66,$P(FBA < W !?4,"Fill Date",?64,"Date Certified" | W !!?4,"Fill Date",!,?15,"Drug Name",?44,"Strength",? W !,?15,"Drug Name",?44,"Strength",?60,"Quantity" | W !?2,"Claimed",?12,"Paid",?19,"Code",?24,"Invoice #" W !?2,"Claimed",?12,"Paid",?20,"Adj Code",?33,"Adj Am < diff -y --suppress-common-lines ./VADemo/r1/FBPCR4.m ./VADemo/r2/r/FBPCR4.m FBPCR4 ;WOIFO/SS-LTC PHASE 3 UTILITIES ;03/17/04 | FBPCR4 ;WOIFO/SS-LTC PHASE 3 UTILITIES ; 7-OCT-02 ;;3.5;FEE BASIS;**48,76**;JAN 30, 1995 | ;;3.5;FEE BASIS;**48**;JAN 30, 1995 INSURED(FBDFN,FBINDT1,FBINDT2) ;check if the patient has ins | INSURED(FBDFN,FBINDT1,FBINDT2) ; S FBINS1=+$$INSUR^IBBAPI(FBDFN,FBINDT1) | S FBINS1=+$$INSURED^IBCNS1(FBDFN,FBINDT1) I FBINS1<0 D ADDERR(DFN) Q FBINCUNK ;error handling < S FBINS1=+$$INSUR^IBBAPI(FBDFN,FBINDT2) ;otherwise re | Q +$$INSURED^IBCNS1(FBDFN,FBINDT2) ;otherwise return I FBINS1<0 D ADDERR(DFN) Q FBINCUNK ;error handling < Q FBINS1 < ; < ADDERR(FBDFN) ;add error to ^TMP, FBDFN - patient DFN < I FBPARTY=1 Q < N DFN,FBPNAME,FBPID,FBDOB,FBPI < S DFN=FBDFN < D VET^FBPCR < S ^TMP($J,"FBINSIBAPI")=$G(^TMP($J,"FBINSIBAPI"))+1 < S ^TMP($J,"FBINSIBAPI",DFN)=FBPID_"^"_FBDOB_"^"_FBPNA < Q < ; < ERRHDL ;Error handler called from FBPCR < I +$G(^TMP($J,"FBINSIBAPI"))=0 Q ;no errors < D PRNUNKN < Q < PRNUNKN ;write output < N FBDFN,FBDATA < D PAGEINS < I FBPG>1&(($Y+15)>IOSL) D HEADER Q:FBOUT < S FBDFN=0 F S FBDFN=$O(^TMP($J,"FBINSIBAPI",FBDFN)) < . I ($Y+6)>IOSL D PAGEINS Q:FBOUT < . S FBDATA=$G(^TMP($J,"FBINSIBAPI",FBDFN)) < . W !,$P(FBDATA,"^",3),?40,$P(FBDATA,"^",1),?62,$P(FB < Q < PAGEINS ;new page < D CHKPAGE Q:FBOUT < D HEADER Q:FBOUT < Q < CHKPAGE ;form feed when new station/patient < S FBSTA=$G(FBPSF)_$G(FBPT) < I FBCRT&(FBPG'=0) D CR^FBPCR Q:FBOUT < I FBPG>0!FBCRT W @IOF < S FBPG=FBPG+1 < Q < HEADER ;main header < N FBSTR1 S FBSTR1="List of the patients whose insuran < W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" < W !?(IOM-$L(FBSTR1)/2),FBSTR1 < W !?71,"Page: ",FBPG < W !,"Patient",?40,"Pat. ID",?62,"DOB" < W !,FBDASH < Q < diff -y --suppress-common-lines ./VADemo/r1/FBPCR671.m ./VADemo/r2/r/FBPCR671.m ;;3.5;FEE BASIS;**4,48,55,69,76**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,48**;JAN 30, 1995 ..S FBINV=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBI, | ..S FBLOC=2_U_23_U_33_U_42_U_49_U_61_U_71 ..W ! W:$P(FBDATA,U,8)["R" "*" W:$P(FBDATA,U,9)]"" "# | ..W ! W:$P(FBDATA,U,11)["R" "*" W:$P(FBDATA,U,12)]"" ..W ?2,$P(FBDATA,U,1),?15,$P(FBDATA,U,5),?31,$P(FBDAT | ..F I=1:1:7 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) ..W ?47,$P(FBDATA,U,7),?57,$P(FBINV,U,2) < ..W !?2,$P(FBDATA,U,2),?15,$P(FBDATA,U,3),?25,$P(FBIN < .. ;Print adj reasons, if null then print suspend cod < ..W ?36,$S($P(FBINV,U,3)]"":$P(FBINV,U,3),1:$P(FBDATA < ..W ?46,$S($P(FBINV,U,3)]"":$J($P(FBINV,U,4),14),1:$J < ..W ?63,$P(FBINV,U,5) < ...S (FBOV,FBCNT)=0,FBSL=7 D SHA Q:FBOUT | ...S (FBOV,FBCNT)=0,FBSL=7,FBLOC=1_U_12_U_23_U_33_U_4 N FBCATC,FBINS,FBADJ I ($Y+4)>IOSL D PAGE Q:FBOUT D | N FBCATC,FBINS I ($Y+4)>IOSL D PAGE Q:FBOUT D SHA,SH S FBADJ=^TMP($J,"FB",FBPSF,FBPT,FBPI,FBVI,FBDT,FBI,"A < W ?1,$P(FBDATA,U,1) | S I=1 W ?$P(FBLOC,U,I),$P(FBDATA,U,I) W ?11,$P($P(FBDATA,U,2),",") | S I=2 W ?$P(FBLOC,U,I),$P($P(FBDATA,U,I),",") W ?31,$J($P(FBADJ,U,2),10) | F I=3:1:FBSL W ?$P(FBLOC,U,I),$P(FBDATA,U,I) W ?43,$P(FBDATA,U,6) < W ?54,$P(FBDATA,U,7) < W ?64,$P(FBDATA,U,8) < . . I $Y+6>IOSL D PAGE Q:FBOUT D SHA,SHA2 W !," (co | . . I $Y+5>IOSL D PAGE Q:FBOUT D SHA,SHA2 W !," (co . . W !,?16,"-",FBMOD | . . W !,?$P(FBLOC,U,2)+5,"-",FBMOD W !,$P(FBDATA,U,3) < W ?13,$P(FBDATA,U,4) < W ?23,$S($P(FBADJ,U,3)]"":$P(FBADJ,U,3),1:$P(FBDATA,U < W ?33,$J($S($P(FBADJ,U,4)]"":$J($P(FBADJ,U,4),14),1:$ < W ?48,$P(FBADJ,U,5) < W ?60,$P(FBADJ,U,6) < W !?1,"Invoice Date",?15,"Invoice No.",?31,"From Date | W !!?2,"Inv Date",?23,"Amount",?33," Amount",?42,"Sus W !?1,"Amt Claimed",?15,"Amt Paid",?25,"Cov Days",?36 | W !?23,"Claimed",?35,"Paid",?42,"Code",?53,"Num",?61, W !!,?1,"Svc Date",?11,"CPT-MOD ",?19,"Travel Paid",? | W !,?2,"Svc Date",?11,"CPT-MOD",?23,"Amount",?33," Am W !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36," | W !,?23,"Claimed",?35,"Paid",?42,"Code",?58,"Num",?64 WRTDX I $P(FBDX,"^",K)]"" W ?4,"Dx: ",$$ICD9^FBCSV1($P(FBDX | WRTDX I $P(FBDX,"^",K)]"" W ?4,"Dx: ",$S($D(^ICD9($P(FBDX," WRTPC I $P(FBPROC,"^",L)]"" W ?4,"Proc: ",$$ICD0^FBCSV1($P( | WRTPC I $P(FBPROC,"^",L)]"" W ?4,"Proc: ",$S($D(^ICD0($P(FB diff -y --suppress-common-lines ./VADemo/r1/FBPCR67.m ./VADemo/r2/r/FBPCR67.m ;;3.5;FEE BASIS;**4,48,55,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,48**;JAN 30, 1995 N FBY2,FBCDAYS,FBCSID,FBX,FBADJLR,FBADJLA,FBRRMKL < K FBY2,FBCDAYS,FBCSID,FBX,FBADJLR,FBADJLA,FBRRMKL < S FBY2=$G(^FBAAI(FBI,2)) < S FBCDAYS=$P(FBY2,U,10) ; covered days | S FBDX=$G(^FBAAI(FBI,"DX")) I FBDX]"" S FBDX1="" F I= S FBCSID=$P(FBY2,U,11) ; patient control number < S FBX=$$ADJLRA^FBCHFA(FBI_",") < S FBADJLR=$P(FBX,U) ;adjustment reason < S FBADJLA=$P(FBX,U,2) ;adjustment amount < S FBRRMKL=$$RRL^FBCHFR(FBI_",") ;remittance remarks < S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,F < S FBDX=$G(^FBAAI(FBI,"DX")) I FBDX]"" S FBDX1="" F I= < S FBPROC=$G(^FBAAI(FBI,"PROC")) I FBPROC]"" S FBPROC1 | S FBPROC=$G(^FBAAI(FBI,"PROC")) I FBPROC]"" S FBPROC1 ...S ^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI,"A", < diff -y --suppress-common-lines ./VADemo/r1/FBPCR.m ./VADemo/r2/r/FBPCR.m FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIV | FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIV ;;3.5;FEE BASIS;**12,48,76**;JAN 30, 1995 | ;;3.5;FEE BASIS;**12,48**;JAN 30, 1995 ;include patients if their insurance informations is < S FBINCUNK=0 < I FBPARTY=2!(FBPARTY=3) D < . S FBINCUNK=1 < . N Y,X < . W !! < . S DIR("A")="Do you want to include patients whose i < . S DIR("?")="Please answer Yes or No." < . S DIR("B")="YES",DIR(0)="YA^^" < . D ^DIR K DIR < . I $G(DIRUT) S FBINCUNK=-1 Q < . I $G(Y)=0 S FBINCUNK=0 < I FBINCUNK=-1 G EXIT ;uparrow - exit < ; < Q K ^TMP($J,"FB"),^TMP($J,"FBINSIBAPI"),DIC | Q K ^TMP($J,"FB"),DIC S VAR="FBINCUNK^FBARRLTC^FBARRLTC(^FBPARTY^FBCOPAY^FB | S VAR="FBARRLTC^FBARRLTC(^FBPARTY^FBCOPAY^FBNAME^FBIE I $G(^TMP($J,"FBINSIBAPI"))>0 D HDRUNK < OUT I $G(^TMP($J,"FBINSIBAPI"))>0 D ERRHDL^FBPCR4 | OUT I FBOUT!$D(ZTQUEUED) G EXIT I FBOUT!$D(ZTQUEUED) G EXIT < K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,END | K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,END W ! | W !!?3,"('*' Represents Reimbursement to Patient",?50 I FBINCUNK=1,$D(^TMP($J,"FBINSIBAPI",+$G(DFN))) W ">> < W !?3,"('*' Represents Reimbursement to Patient",?50, < HDRUNK ;Warning message if patient's insurance status is unk < D PAGE Q:FBOUT < W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" < W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"D < W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^F < W !?71,"Page: ",FBPG < W !,"------------------------------ !!! WARNING !!! - < W !,"This report is incomplete due to problems with o < W !,"for those patients listed in a separate section < W !,"may want to rerun the report again to get more a < W !,FBDASH < I FBINCUNK=1 D < . W !,"Note: You have chosen to include patients with < . W !,"this report. Please be aware that these patien < . W !,"have billable insurance and their treatment de < . W !,"The names of these patients will be accompanie < . W !,"to order to identify them:" < . W !,">> Warning: accurate insurance information for < . W !,FBDASH < Q < diff -y --suppress-common-lines ./VADemo/r1/FBPHON1.m ./VADemo/r2/r/FBPHON1.m ;;3.5;FEE BASIS;**4,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 N FBCNT,FBI,FBJ,FBK,FBSDI,FBAADT,FBAACPI,FBX,FBMODLE, | N FBCNT,FBI,FBJ,FBK,FBSDI,FBAADT,FBAACPI,FBX,FBMODLE .S FBXAD=$$ADJLRA^FBAAFA(FBAACPI_","_FBSDI_","_FBV_", | .S ^TMP($J,"FBPHON",-FBAADT,FBCNT)="OPT"_"^"_FBAADT_" .S FBXADJC=$P(FBXAD,U,1) ;Adjustment code list < .I FBXADJC["," S FBXADJC=$P(FBXADJC,",",1)_"&" ;More < .I FBXADJC="" S FBXADJC=$P(FBX,U,5) ;No adj codes use < .S ^TMP($J,"FBPHON",-FBAADT,FBCNT)="OPT"_"^"_FBAADT_" < .S FBXAD=$$ADJLRA^FBCHFA(FBI_",") | .S ^TMP($J,"FBPHON",-$P(FBX,U,6),FBCNT)=$S($P(FBX,U,1 .S FBXADJC=$P(FBXAD,U) < .I FBXADJC["," S FBXADJC=$P(FBXADJC,",",1)_"&" ;More < .I FBXADJC="" S FBXADJC=$P(FBX,U,11) ;No adj codes us < .S ^TMP($J,"FBPHON",-$P(FBX,U,6),FBCNT)=$S($P(FBX,U,1 < ..S FBXAD=$$ADJLRA^FBRXFA(FBJ_","_FBI_",") | ..S ^TMP($J,"FBPHON",-(9999999-FBAADT),FBCNT)="PHAR^" ..S FBXADJC=$P(FBXAD,U,1) ;Adjustment code list < ..I FBXADJC["," S FBXADJC=$P(FBXADJC,",",1)_"&" ;More < ..I FBXADJC="" S FBXADJC=$P(FBX,U,8) < ..S ^TMP($J,"FBPHON",-(9999999-FBAADT),FBCNT)="PHAR^" < diff -y --suppress-common-lines ./VADemo/r1/FBPHON2.m ./VADemo/r2/r/FBPHON2.m ;;3.5;FEE BASIS;**4,21,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4,21**;JAN 30, 1995 S FBCPT=$P(FBX,U,3) W !,"Line item #",FBI,!?5,"CPT: " | S FBCPT=$P(FBX,U,3) W !,"Line item #",FBI,!?5,"CPT: " . S FBMODX=$$MOD^ICPTMOD(FBMOD,"E",$P(FBX,U,2)) | . S FBMODX=$$MOD^ICPTMOD(FBMOD,"E") . . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I | . . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I diff -y --suppress-common-lines ./VADemo/r1/FBPHON.m ./VADemo/r2/r/FBPHON.m ;;3.5;FEE BASIS;**4,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**4**;JAN 30, 1995 .S FBTEXT=$$SETSTR^VALM1($J($FN($P(FBX,U,4),",",2),10 | .S FBTEXT=$$SETSTR^VALM1($J($FN($P(FBX,U,4),",",2),10 S VALMHDR(3)="'*' Reimb. to Patient '+' Cancel Activ | S VALMHDR(3)=" '*' Reimb. to Patient '+' Cancel. diff -y --suppress-common-lines ./VADemo/r1/FBPMRG.m ./VADemo/r2/r/FBPMRG.m ;;3.5;FEE BASIS;**19,41,59**;JAN 30, 1995 | ;;3.5;FEE BASIS;**19,41**;JAN 30, 1995 ; < IDCARD ; if both records have id card numbers the pairs are < ; all other cases will be handled by merge. < ; < I $P($G(^FBAAA(FBFR,4)),U) D < .I $P($G(^FBAAA(FBTO,4)),U) D < ..; remove pair from merge when there is a id number < ..S IENFRM=$O(@ARRAY@(FBFR,FBTO,"")) < ..S IENTO=$O(@ARRAY@(FBFR,FBTO,IENFRM,"")) < ..S IEN="" < ..S IEN=+$G(@ARRAY@(FBFR,FBTO,IENFRM,IENTO)) < ..D RMOVPAIR^XDRDVAL1(FBFR,FBTO,IEN,ARRAY) < ..N XMSUB,XMTEXT < ..S XMSUB="MERGE PAIRS EXCLUDED DUE TO BOTH HAVE FEE < ..S ^TMP("DDB",$J,1)=" MERGE PAIR Patient records "_ < ..S XMTEXT="^TMP(""DDB"",$J," < ..D SENDMESG^XDRDVAL1(XMSUB,XMTEXT) < ..K IEN,IENTO,IENFRM < ; < ; < diff -y --suppress-common-lines ./VADemo/r1/FBPRICE1.m ./VADemo/r2/r/FBPRICE1.m ;;3.5;FEE BASIS;**56,55,77**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 F I=1:1:5 D Q:X=""!($D(DTOUT))!($D(DUOUT)) | F I=1:1:5 D ^DIR Q:X=""!($D(DTOUT))!($D(DUOUT)) I Y> . N ICDVDT S ICDVDT=$$STR2FBDT^FBCSV1($G(FBFDT)) ;see | I 'FBDX(1),$D(DTOUT)!($D(DUOUT)) G END^FBPRICE . N FBRT F D ^DIR Q:X=""!($D(DTOUT))!($D(DUOUT))!(+Y | I 'FBDX(1) W !,*7,"Must enter at least a primary diag I FBDX(1)=" ",$D(DTOUT)!($D(DUOUT)) G END^FBPRI < I FBDX(1)=" " W !,*7,"Must enter at least a pri < F I=1:1:3 D Q:X=""!($D(DUOUT))!($D(DTOUT)) | F I=1:1:3 D ^DIR Q:X=""!($D(DUOUT))!($D(DTOUT)) I Y> . N ICDVDT S ICDVDT=$$STR2FBDT^FBCSV1($G(FBFDT)) ;for < . N FBRT F D ^DIR Q:X=""!($D(DUOUT))!($D(DTOUT))!(+Y < Only in ./VADemo/r1/: FBRXFA.m Only in ./VADemo/r1/: FBRXFED.m Only in ./VADemo/r1/: FBRXFR.m Only in ./VADemo/r1/: FBRXUTL.m diff -y --suppress-common-lines ./VADemo/r1/FBUCDD1.m ./VADemo/r2/r/FBUCDD1.m FBUCDD1 ;ALBISC/TET - DD UTILITY (cont'd.) ;5/27/93 | FBUCDD1 ;ALBISC/TET - DD UTILITY (cont'd.) ;;3.5;FEE BASIS;**60,72**;JAN 30, 1995 | ;;3.5;FEE BASIS;;JAN 30, 1995 S FBVAR=$P($G(^FBAAA(DA(1),1,DA,0)),U,9),FBV=+$P($G(^ | S FBVAR=$P($G(^FBAAA(DA(1),1,DA,0)),U,9),FBV=+$P($G(^ I 'FBV="0" S FBV=FBV-1 | F S FBI=$O(^FBAAC(DA(1),1,FBV,1,FBI)) Q:'FBI!($P(M,U F S FBV=$O(^FBAAC(DA(1),1,FBV)) Q:'FBV!($P(M,U,2)) < .S FBI=0 < .F S FBI=$O(^FBAAC(DA(1),1,FBV,1,FBI)) Q:'FBI!($P(M, < Only in ./VADemo/r1/: FBUCDE.m diff -y --suppress-common-lines ./VADemo/r1/FBUCEN.m ./VADemo/r2/r/FBUCEN.m FBUCEN ;ALBISC/TET - ENTER UNAUTHORIZED CLAIM ;7/17/03 | FBUCEN ;ALBISC/TET - ENTER UNAUTHORIZED CLAIM ;6/20/01 ;;3.5;FEE BASIS;**32,61**;JAN 30, 1995 | ;;3.5;FEE BASIS;**32**;JAN 30, 1995 .N FBDA,FBMASTER,FBORDER,FBTFROM,FBTTO,FB1725,FBFPPSC | .N FBDA,FBMASTER,FBORDER,FBTFROM,FBTTO,FB1725 .; ask if claim is an EDI claim (patch *61) < .S FBFPPSC=$$FPPSC^FBUTL5() I FBFPPSC=-1 S FBFPPSC="" < diff -y --suppress-common-lines ./VADemo/r1/FBUCLET2.m ./VADemo/r2/r/FBUCLET2.m ;;3.5;FEE BASIS;**38,46,69**;JAN 30, 1995 | ;;3.5;FEE BASIS;**38,46**;JAN 30, 1995 N FBSCCOL,FBUCPAY,FBX,FBY,FBACRR,FBADJLR,FBFPPSC,FBSC | N FBSCCOL,FBUCPAY,FBX,FBY ; get fpps claim id < S FBFPPSC=$P($G(^FB583(FBDA,5)),U) < S FBSCID="" < . . . Q:FBSCID]"" | . . . S FBSC=$$GET1^DIQ(FBFILE,FBIENS,4) . . . S FBSCID=$$GET1^DIQ(FBFILE,FBIENS,49) < . . . S FBAMT=$$GET1^DIQ(FBFILE,FBIENS,6.5) | . . . S FBAMT=$$GET1^DIQ(FBFILE,FBIENS,16.5) > . . . S FBSC=$$GET1^DIQ(FBFILE,FBIENS,7) . . . Q:FBSCID]"" | . . . S FBSC=$$GET1^DIQ(FBFILE,FBIENS,10) . . . S FBSCID=$$GET1^DIQ(FBFILE,FBIENS,55) ; patien < > . . I FBSC]"" S FBSCA(FBSC)="" > ; > ;set FBSCCOL flag to indicate if the suspend code col > ; = 1 or 0 (1 if there are any suspend codes besid > S FBSCCOL=0 > S FBSC="" F S FBSC=$O(FBSCA(FBSC)) Q:FBSC="" I FBSC . I $Y+$S(FBCC:FBCCI,1:7)>IOSL D PAGE^FBUCLET1 < . W !!?8,"Patient Control Number: ",FBSCID < . I $Y+$S(FBCC:FBCCI,1:7)>IOSL D PAGE^FBUCLET1 < . W !!?8,"Patient Account Number: ",FBSCID < . F S FBIENS=$O(FBUCPAY(FBDA,162.11,FBIENS)) Q:FBIEN | . F S FBIENS=$O(FBUCPAY(FBDA,162.5,FBIENS)) Q:FBIENS ; < ;set FBSCCOL flag to indicate if the suspend code col < ; = 1 or 0 (1 if there are any suspend codes besid < S FBSCCOL=0 < S FBSC="" F S FBSC=$O(FBSCA(FBSC)) Q:FBSC="" I FBSC < ; print relevant suspend code descriptions | ; print relevant suspend code descriptions D ACT:$D(FBACRR) K FBACRR < Q < ; < ACT ; print table of adjustment reason descriptions < ; Input < ; FBACRR( - required, array < ; FBACRR(FBADJRE)="" < ; where FBADJRE = adjustment reason code, external < N FBADJRE,FBI,X,FBACT < I $Y+$S(FBCC:FBCCI,1:10)>IOSL D PAGE^FBUCLET1 < W !,?8,"*Adjustment Code Text:" < S FBADJRE="" F S FBADJRE=$O(FBACRR(FBADJRE)) Q:FBADJ < . ; get description of code in FBACT < . I $$AR^FBUTL1(,FBADJRE,,"FBACT")<0 Q ; quit if err < . ; print code and description < . K ^UTILITY($J,"W") < . S DIWL=1,DIWF="WC79I8" < . ; include code in output < . I $Y+$S(FBCC:FBCCI,1:9)>IOSL D PAGE^FBUCLET1 < . S X=$$LJ^XLFSTR("("_FBADJRE_")",6," ") D ^DIWP < . S DIWF="WC79I14" < . ; include description in output < . S FBI=0 F S FBI=$O(FBACT(FBI)) Q:FBI="" S X=FBACT < . D ^DIWW < W ?67,"Adj Code*" | W:FBSCCOL ?67,"Suspend*" W ?67,"--------" | W:FBSCCOL ?67,"--------" S FBSC="" < S FBFPPSL=$P($G(^FBAAI(DA,3)),U,2) ; fpps line item | I $Y+$S(FBCC:FBCCI,1:8)>IOSL D PAGE^FBUCLET1,CHDHD S FBADJLR=$P($$ADJLRA^FBCHFA(DA_","),U) | W !?8,$$FMTE^XLFDT($P(FBY,U,6)),?24,$$FMTE^XLFDT($P(F S:FBADJLR]"" FBACRR(FBADJLR)="" < I $Y+$S(FBCC:FBCCI,1:10)>IOSL D PAGE^FBUCLET1,CHDHD < W !!?8,$$FMTE^XLFDT($P(FBY,U,6)),?24,$$FMTE^XLFDT($P( < S:FBADJLR="" FBSC=$$GET1^DIQ(162.5,FBIENS,10) | S FBSC=$$GET1^DIQ(162.5,FBIENS,10) S:FBSC]"" FBSCA(FBSC)="" | W ?70,FBSC W ?70,$S(FBADJLR]"":FBADJLR,1:FBSC) < I FBFPPSC]"" W !,?8,"FPPS Claim ID: ",FBFPPSC,?36,"FP < W ?67,"Adj Code*" | W:FBSCCOL ?67,"Suspend*" W ?67,"--------" | W:FBSCCOL ?67,"--------" ; < N FBADJRE < S FBSC="" < S FBFPPSL=$P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,3)) < S FBADJLR=$P($$ADJLRA^FBAAFA(DA_","_DA(1)_","_DA(2)_" < F FBJ=1:1 S FBADJRE=$P(FBADJLR,",",FBJ) Q:FBADJRE="" < I $Y+$S(FBCC:FBCCI,1:10)>IOSL D PAGE^FBUCLET1,ODHD | I $Y+$S(FBCC:FBCCI,1:8)>IOSL D PAGE^FBUCLET1,ODHD W !!?8,$$FMTE^XLFDT(FBDOS) | W !?8,$$FMTE^XLFDT(FBDOS) S:FBADJLR="" FBSC=$$GET1^DIQ(162.03,FBIENS,4) | S FBSC=$$GET1^DIQ(162.03,FBIENS,4) S:FBSC]"" FBSCA(FBSC)="" | W ?70,FBSC W ?70,$S(FBADJLR]"":FBADJLR,1:FBSC) < I FBFPPSC]"" W !,?8,"FPPS Claim ID: ",FBFPPSC,?36,"FP < W ?67,"Adj Code*" | W:FBSCCOL ?67,"Suspend*" W ?67,"--------" | W:FBSCCOL ?67,"--------" N FBADJRE < S FBSC="" < S FBFPPSL=$P($G(^FBAA(162.1,DA(1),"RX",DA,3)),U) | I $Y+$S(FBCC:FBCCI,1:9)>IOSL D PAGE^FBUCLET1,PDHD S FBADJLR=$P($$ADJLRA^FBRXFA(DA_","_DA(1)_","),U) | W !?8,$$FMTE^XLFDT($P(FBY,U,3)),?21,$$FMTE^XLFDT($P(F F FBJ=1:1 S FBADJRE=$P(FBADJLR,",",FBJ) Q:FBADJRE="" < I $Y+$S(FBCC:FBCCI,1:11)>IOSL D PAGE^FBUCLET1,PDHD < W !!?8,$$FMTE^XLFDT($P(FBY,U,3)),?21,$$FMTE^XLFDT($P( < S:FBADJLR="" FBSC=$$GET1^DIQ(162.11,FBIENS,7) | S FBSC=$$GET1^DIQ(162.11,FBIENS,7) S:FBSC]"" FBSCA(FBSC)="" | W ?70,FBSC W ?70,$S(FBADJLR]"":FBADJLR,1:FBSC) < I FBFPPSC]"" W !,?8,"FPPS Claim ID: ",FBFPPSC,?36,"FP < . S FBGL="^FBAA(162.1,"_DA(1)_",""RX""," | . S FBGL="^FBAA(162.1,"_DA(1)_",RX," Q < Only in ./VADemo/r1/: FBUCMBS.m diff -y --suppress-common-lines ./VADemo/r1/FBUCSTAT.m ./VADemo/r2/r/FBUCSTAT.m ;;3.5;FEE BASIS;**32,64**;JAN 30, 1995 | ;;3.5;FEE BASIS;**32**;JAN 30, 1995 .S FBD=+$P(FB(0),"^",11) S PSA=+$P(FB(0),"^",7) S:PSA | .S FBD=+$P(FB(0),"^",11) S PSA=+$P(FB(0),"^",7) S:'$D .S FB("PD")=$$AMTPD^FBUCMBS(J) | .S FB("PD")=0 S FB("J")=J_";FB583(",ZZ=0 F S ZZ=$O(^ .S FB(PSA)=FB(PSA)+FB("PD") | .S ZZ=0 F S ZZ=$O(^FBAA(162.1,"AO",FB("J"),ZZ)) Q:ZZ > .I $O(^FBAAC("AM",FB("J"),0)) F II=0:0 S II=$O(^FBAAC > ..I $D(^FBAAC($P(FB(0),"^",4),1,II,1,JJ,1,KK,0)) S FB > .S FB(PSA)=FB(PSA)+FB("PD") K FB("PD") > .K ZZ,FB("J"),II,JJ,KK S FB=0,PSA=0 F S PSA=$O(FB(PSA)) Q:PSA="PD"!(PSA="") | S FB=0 F PSA=0:0 S PSA=$O(FB(PSA)) Q:PSA'>0 W !?3,$P END K DIRUT,I,J,Q,X,X2,PSA,FBBEG,FBEND,FBSTART,FBFINISH,F | END K DIRUT,I,J,Q,X,X2,FB,PSA,FBBEG,FBEND,FBSTART,FBFINIS DAT W !?17,"Date Range Selected: ",FBSTART," to ",FBFINIS | DAT W !?17,"Date Range Selected: ",FBSTART," to ",FBFINIS Q < diff -y --suppress-common-lines ./VADemo/r1/FBUCUTL2.m ./VADemo/r2/r/FBUCUTL2.m FBUCUTL2 ;ALBISC/TET - UTILITY (CONTINUED) ;2/12/2003 | FBUCUTL2 ;ALBISC/TET - UTILITY (CONTINUED) ;11/15/2001 ;;3.5;FEE BASIS;**23,32,38,52**;JAN 30, 1995 | ;;3.5;FEE BASIS;**23,32,38**;JAN 30, 1995 ;VAPA("CD") - date for ADD^VADPT if not defined then < ; VAPA will be killed! < ; < . . I $$ACTIVECC^FBAACO0() D Q < . . . F FBI=13,14,15 S:$G(VAPA(FBI))]"" FBCT=FBCT+1,F < . . . S FBCT=FBCT+1,FBARR(FBCT)=$S($G(VAPA(16))]"":$G < ; < Only in ./VADemo/r1/: FBUTL1.m Only in ./VADemo/r1/: FBUTL2.m Only in ./VADemo/r1/: FBUTL3.m Only in ./VADemo/r1/: FBUTL4.m Only in ./VADemo/r1/: FBUTL5.m Only in ./VADemo/r1/: FBUTL6.m diff -y --suppress-common-lines ./VADemo/r1/FBUTL.m ./VADemo/r2/r/FBUTL.m FBUTL ;WCIOFO/SAB-FEE BASIS UTILITY ;4/8/2004 | FBUTL ;WCIOFO/SAB-FEE BASIS UTILITY ;2/22/1999 ;;3.5;FEE BASIS;**16,78**;JAN 30, 1995 | ;;3.5;FEE BASIS;**16**;JAN 30, 1995 AUTHL(FBDFN,FBSN,FBDT,FBAR) ; authorization list for pati < ; Integration Agreement #4396 < ; This API returns authorization data for a specified < ; Authorizations that have been Austin Deleted will n < ; < ; input < ; FBDFN - patient DFN (File #2 internal entry numbe < ; FBSN - station number, optional < ; If specified, the station number will be < ; authorizations from the national Fee Repl < ; Only authorizations whose issuing station < ; parameter value will be returned. < ; This parameter will not be evaluated unti < ; modified to obtain data from the fee repl < ; FBDT - cutoff date, optional, VA FileMan interna < ; If specified, only authorizations whose T < ; equal to or after the cutoff date will be < ; FBAR - name of output array, optional, default v < ; closed root, must not equal variables new < ; such as FBAR. < ; examples: "FBAUTH", "DGAUTH(12)", "^TMP($ < ; The array will be initialized by this API < ; output < ; returns string value < ; = count of authorizations in array < ; OR < ; = -1^exception number^exception text < ; < ; If an exception did not occur, then the output ar < ; authorization data subscripted by sequential cano < ; numbers and a header node subscripted by 0. < ; array(0) = count of authorizations in array < ; array(#,"FDT") = authorization # From Date (int < ; array(#,"TDT") = authorization # To Date (inter < ; OR < ; Example if "FBAUTH" used as array name < ; FBAUTH(0)=2 < ; FBAUTH(1,"FDT")=3011021 < ; FBAUTH(1,"TDT")=3011030 < ; FBAUTH(2,"FDT")=3000101 < ; FBAUTH(2,"TDT")=3031231 < ; Note that additional subscripts may be added in t < ; provide more authorization data. The calling appl < ; kill the entire output array so any added subscri < ; cleaned-up (e.g. K FBAUTH). < ; List of exceptions < ; 101^Patient DFN not specified. < ; 104^ICN could not be determined for the specifi < ; 105^Array name conflicts with a variable in the < ; 110^Database Unavailable. < ; The database unavailable exception will not occur < ; is modified to obtain data from the fee replaceme < ; However, calling applications should code to hand < ; now so appropriate action will be taken once the < ; the local VistA system to the remote fee replacem < ; < N FBC,FBDA,FBICN,FBRET,FBY < ; < S FBAR=$G(FBAR,"FBAUTH") < S FBSN=$G(FBSN) < S FBDT=$G(FBDT) < S FBRET="" < ; < ; ensure input array name is not one of the newed var < ; If conflict, then array will not be changed by this < I "^FBDFN^FBAR^FBC^FBDA^FBDT^FBICN^FBRET^FBSN^FBY^"[( < ; < ; initialize output array < I FBRET'<0 K @FBAR < ; < ; check for required input < I FBRET'<0,$G(FBDFN)="" S FBRET="-1^101^Patient DFN n < ; < ; get patient ICN < I FBRET'<0 D < . I $$IFLOCAL^MPIF001(FBDFN) S FBRET="-1^104^ICN coul < . S FBICN=$$GETICN^MPIF001(FBDFN) I FBICN<0 S FBRET=" < ; < ; if optional date passed then check if valid value < I FBRET'<0,FBDT'="" D < . I FBDT'?7N S FBRET="-1^101^Valid date not specified < . I $$FMTHL7^XLFDT(FBDT)<0 S FBRET="-1^101^Valid date < ; < ; get authorization data < I FBRET'<0 D < . S FBC=0 ; initialize count/subscript of authorizati < . ; loop thru AUTHORIZATION multiple of file #161 < . S FBDA=0 F S FBDA=$O(^FBAAA(FBDFN,1,FBDA)) Q:'FBDA < . . Q:$P($G(^FBAAA(FBDFN,1,FBDA,"ADEL")),U)="Y" ; sk < . . S FBY=$G(^FBAAA(FBDFN,1,FBDA,0)) < . . I FBDT,$P(FBY,U,2)0 S Z ;patch #41 < ;F NDT=NOW:0 S NDT=$O(^DPT(DFN,"S",NDT)) Q:NDT'>0 S < K ^TMP($J) < S FHCNT="" < D GETAPPT^SDAMA201(DFN,"1;2;12","R",DT,,.FHCNT,"") < G:'$D(^TMP($J,"SDAMA201","GETAPPT")) NOAPP < I $D(^TMP($J,"SDAMA201","GETAPPT")) S FHTMP=$NA(^TMP( < I $D(@FHTMP@("ERROR")) D PRERR < I $G(FHCNT) F FHI=0:0 S FHI=$O(@FHTMP@(FHI)) Q:FHI'>0 < K ^TMP($J) < ;end changes in patch #41 < NOAPP I 'N1 W !!?5,"No scheduled appointments." | I 'N1 W !!?5,"No scheduled appointments." ;patch #41 | CLIN S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y="" CLIN ;S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y="" | D:$Y'2 D LL Q < I $P(FHPAR,"^",4)="Y" G P4 < LL ; < S FHCOL=$S(LAB=3:3,1:2) < I LABSTART>1 F FHLABST=1:1:(LABSTART-1)*FHCOL D S LA < .I LAB=3 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)="" D LL3^F < .I LAB=4 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)= < .Q < S FHTAB=$S(LAB=3:24,1:37) < S WRD1=$E(WRD,3,99) < S NAM=$E(NAM,1,FHTAB-$L(WRD1)),BIDIS=BID I IS="N" S B < S LNA=NAM_$J(WRD1,FHTAB+1-$L(NAM)),LNB=BIDIS_$J(DTE,F < I $P(FHPAR,"^",4)="Y" D LL2 Q < S NUM=0 F XSF=1:2:7 I $P(Y2,U,XSF)'="" S NUM=NUM+1 < S INDX=0 F XSF=1:2:7 D < .S SFPTR=$P(Y2,U,XSF) I SFPTR="" Q < .S QTY=$P(Y2,U,XSF+1),SFNM=$P($G(^FH(118,SFPTR,0)),U, < .S INDX=INDX+1,ZF(INDX)=$J(QTY,2)_" "_SFNM < .Q < I LAB=3 D < .I NUM=1 S (PCL1,PCL2,PCL6)="",PCL3=LNA,PCL4=LNB,PCL5 < .I NUM=2 S (PCL1,PCL6)="",PCL2=LNA,PCL3=LNB,PCL4=ZF(1 < .I NUM=3 S PCL1="",PCL2=LNA,PCL3=LNB,PCL4=ZF(1),PCL5= < .I NUM=4 S PCL1=LNA,PCL2=LNB,PCL3=ZF(1),PCL4=ZF(2),PC < .D LL3^FHLABEL < I LAB=4 D < .I NUM=1 S (PCL1,PCL2,PCL3,PCL7,PCL8)="",PCL4=LNA,PCL < .I NUM=2 S (PCL1,PCL2,PCL7,PCL8)="",PCL3=LNA,PCL4=LNB < .I NUM=3 S (PCL1,PCL2,PCL8)="",PCL3=LNA,PCL4=LNB,PCL5 < .I NUM=4 S (PCL1,PCL8)="",PCL2=LNA,PCL3=LNB,PCL4=ZF(1 < .D LL4^FHLABEL < Q < LL2 ; < F XSF=1:2:7 D < .S SFPTR=$P(Y2,U,XSF) I SFPTR="" Q < .S QTY=$P(Y2,U,XSF+1),SFNM=$P($G(^FH(118,SFPTR,0)),U, < .S LNC=$J(QTY,2)_" "_SFNM < .I LAB=3 S (PCL1,PCL4,PCL6)="",PCL2=LNA,PCL3=LNB,PCL5 < .I LAB=4 S (PCL1,PCL2,PCL5,PCL7,PCL8)="",PCL3=LNA,PCL < Q < diff -y --suppress-common-lines ./VADemo/r1/FHNO2.m ./VADemo/r2/r/FHNO2.m ;;5.0;Dietetics;**38,39**;Oct 11, 1995 | ;;5.0;Dietetics;;Oct 11, 1995 W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If us < Q:$D(DIRUT) S LABSTART=Y < I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^ | I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^ S COUNT=0,LINE=1 I TIM="ALL" S TIM=10 D Q2 S TIM=2 D | I TIM="ALL" S TIM=10 D Q2 S TIM=2 D Q2 S TIM=8 D Q2 | D Q2 I 'D3 F L=1:1:18 W ! I $G(LAB)>2 D DPLL^FHLABEL,KIL Q < I 'D3 F L=1:1:18 W ! < Q2 K ^TMP($J,"L"),^TMP($J,"I"),^TMP($J,"SF"),C S P1=$S(T | Q2 K ^TMP($J),C S P1=$S(TIM=10:5,TIM=2:13,1:21),T0=$P(DT diff -y --suppress-common-lines ./VADemo/r1/FHNO41.m ./VADemo/r2/r/FHNO41.m ;;5.0;Dietetics;**38,39**;Oct 11, 1995 | ;;5.0;Dietetics;;Oct 11, 1995 S FHLBFLG=1 I LAB D I FHLBFLG=0 Q < .W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If u < .I $D(DIRUT) S FHLBFLG=0 Q < .S LABSTART=Y Q < I $D(IO("Q")) S FHPGM="Q1^FHNO41",FHLST="D1^LAB^LABST | I $D(IO("Q")) S FHPGM="Q1^FHNO41",FHLST="D1^LAB" D EN L0 S S2=LAB=2*5+32,S1=$S(LAB=2:9,1:6),COUNT=0,LINE=1 | L0 S S2=LAB=2*5+32,S1=$S(LAB=2:9,1:6) I LAB>2 D DPLL^FHLABEL Q < I LAB>2 D LL Q < Q < LL ; < S FHCOL=$S(LAB=3:3,1:2) < I LABSTART>1 F FHLABST=1:1:(LABSTART-1)*FHCOL D S LA < .I LAB=3 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)="" D LL3^F < .I LAB=4 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)= < .Q < F C1=1:1:X2 D < .S FHTAB=$S(LAB=3:24,1:37),SPC=$J(" ",70) < .S LNA=$E(SPC,1,FHTAB-$L(X1)/2)_X1,LNB=WRD_$J(DTP,FHT < .I LAB=3 S (PCL1,PCL2,PCL4,PCL6)="",PCL3=LNA,PCL5=LNB < .I LAB=4 S (PCL1,PCL2,PCL3,PCL5,PCL7,PCL8)="",PCL4=LN < .D:LAB=3 LL3^FHLABEL D:LAB=4 LL4^FHLABEL < Q < diff -y --suppress-common-lines ./VADemo/r1/FHORD13.m ./VADemo/r2/r/FHORD13.m ;;5.0;Dietetics;**2,38,39**;Mar 25, 1996 | ;;5.0;Dietetics;**2**;Mar 25, 1996 P0 D ^FHDPA I DFN S FHX1=$G(FHX1)_DFN_"^",FHX2=$G(FHX2)_ | P0 D ^FHDPA I DFN S FHX1=FHX1_DFN_"^",FHX2=FHX2_ADM_"^" P1 ; | P1 W ! K IOP,%ZIS S %ZIS("A")="Select LABEL Printer: ",% W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If us | I $D(IO("Q")) S FHPGM="Q1^FHORD13",FHLST="FHX1^FHX2^F Q:$D(DIRUT) S LABSTART=Y < W ! K IOP,%ZIS S %ZIS("A")="Select LABEL Printer: ",% < I $D(IO("Q")) S FHPGM="Q1^FHORD13",FHLST="FHX1^FHX2^F < S COUNT=0,LINE=1 < I LAB>2 D DPLL^FHLABEL K ^TMP($J) Q < I LAB>2 D DPLL^FHLABEL K ^TMP($J) Q | Q3 F K7=1:1:18 W ! Q3 I LAB<3 F K7=1:1:18 W ! < S FHORD=$P(X0,"^",2),X1=$P(X0,"^",5) Q:FHORD<1 | S FHORD=$P(X0,"^",2),X1=$P(X0,"^",3) Q:FHORD<1 L1 I LAB>2 D LL Q | L1 W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W @F W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W @F < Q < LL D LAB^FHLABEL Q < diff -y --suppress-common-lines ./VADemo/r1/FHORD1.m ./VADemo/r2/r/FHORD1.m ;;5.0;Dietetics;**6,15,27,37,38**;Oct 11, 1995 | ;;5.0;Dietetics;**6,15,27,37**;Oct 11, 1995 I $G(ADM)="" W *7,!!," NOT CURRENTLY AN INPATIENT" D < diff -y --suppress-common-lines ./VADemo/r1/FHORE21.m ./VADemo/r2/r/FHORE21.m ;;5.0;Dietetics;**38,39**;Oct 11, 1995 | ;;5.0;Dietetics;;Oct 11, 1995 S D1=DTE,COUNT=0,LINE=1 K ^TMP($J) S ANS="" | S D1=DTE K ^TMP($J) S ANS="" S ^TMP($J,"EL",D1_"-"_$P(Y(0),"^",6),DFN_"-"_ADM)=WAR | S ^TMP($J,D1_"-"_$P(Y(0),"^",6),DFN_"-"_ADM)=WARD_"^" S N1="" F S N1=$O(^TMP($J,"EL",N1)) Q:N1=""!(ANS="^" | S N1="" F S N1=$O(^TMP($J,N1)) Q:N1=""!(ANS="^") S I LAB>2 D DPLL^FHLABEL K ^TMP($J) Q | F K=1:1:$S('LAB:1,1:18) W ! I LAB<3 F K=1:1:$S('LAB:1,1:18) W ! < S RM=$G(^DPT(DFN,.101)) I LAB>2 D LL Q | S RM=$G(^DPT(DFN,.101)) G:LAB P3 G:LAB P3 < LL ; < S FHCOL=$S(LAB=3:3,1:2) < I LABSTART>1 F FHLABST=1:1:(LABSTART-1)*FHCOL D S LA < .I LAB=3 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)="" D LL3^F < .I LAB=4 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)= < .Q < S SL1=$S(LAB=3:25,1:38) < S MEALTM=$S(M1="B":"Breakfast",M1="N":"Noon",1:"Eveni < S BIDIS=BID_$E(" ",1,12-$L(BID))_IS < S WARD=$E(WARD,1,15),WLN=$L(WARD),RM=$E(RM,1,10) < I LAB=3 D < .S P1=$E(P1,1,24-WLN) < .S (PCL1,PCL6)="",PCL2=MEALTM_$J(L1,25-$L(MEALTM)) < .S PCL3=P1_$J(WARD,25-$L(P1)),PCL4=BIDIS_$J(RM,25-$L( < .S PCL5=$E(O1,1,29) D LL3^FHLABEL < I LAB=4 D < .S P1=$E(P1,1,37-WLN) < .S (PCL1,PCL2,PCL7,PCL8)="",PCL3=MEALTM_$J(L1,38-$L(M < .S PCL4=P1_$J(WARD,38-$L(P1)),PCL5=BIDIS_$J(RM,38-$L( < .S PCL6=$E(O1,1,42) D LL4^FHLABEL < Q < diff -y --suppress-common-lines ./VADemo/r1/FHORE2.m ./VADemo/r2/r/FHORE2.m ;;5.0;Dietetics;**39**;Oct 11, 1995 | ;;5.0;Dietetics;;Oct 11, 1995 S FHLBFLG=1 I LAB D I FHLBFLG=0 Q < .W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If u < .I $D(DIRUT) S FHLBFLG=0 Q < .S LABSTART=Y Q < I $D(IO("Q")) S FHPGM="^FHORE21",FHLST="FHP^LAB^DTE^M | I $D(IO("Q")) S FHPGM="^FHORE21",FHLST="FHP^LAB^DTE^M KIL K %,%H,%I,%DT,A1,ADM,ANS,BAG,D1,D3,DFN,DIC,DP,DTP,DTE | KIL K %,%H,%I,%DT,A1,ADM,ANS,BAG,D1,D3,DFN,DIC,DP,DTP,DTE diff -y --suppress-common-lines ./VADemo/r1/FHORO.m ./VADemo/r2/r/FHORO.m ;;5.0;Dietetics;**6,38**;Oct 11, 1995 | ;;5.0;Dietetics;**6**;Oct 11, 1995 I $L(COM)>160 W *7,!,"Order not accepted! - Enter 1-1 | I $L(COM)>80 W *7,!,"Order not accepted! - Enter 1-80 diff -y --suppress-common-lines ./VADemo/r1/FHORT1.m ./VADemo/r2/r/FHORT1.m ;;5.0;Dietetics;**5,6,15,38**;Oct 11, 1995 | ;;5.0;Dietetics;**5,6,15**;Oct 11, 1995 I $L(X)>160!(X?1"?".E) W *7,!,"Enter a comment of up | I $L(X)>80!(X?1"?".E) W *7,!,"Enter a comment of up t diff -y --suppress-common-lines ./VADemo/r1/FHORT5D.m ./VADemo/r2/r/FHORT5D.m ;;5.0;Dietetics;**38,39,40**;Oct 11, 1995 | ;;5.0;Dietetics;;Oct 11, 1995 S COUNT=0,LINE=1 < I LAB>2 D DPLL^FHLABEL Q < I LAB>2 D LL Q < Q < LL ; < S FHCOL=$S(LAB=3:3,1:2) < I LABSTART>1 F FHLABST=1:1:(LABSTART-1)*FHCOL D S LA < .I LAB=3 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)="" D LL3^F < .I LAB=4 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)= < .Q < S FHTAB=$S(LAB=3:24,1:37) < S NAM=$E(NAM,1,FHTAB-$L(WARD)),X02P=$P(X0,U,2),DTP=$E < S X0DTP=X02P_$E(" ",1,7-$L(X02P))_DTP < S LNA=NAM_$J(WARD,FHTAB+1-$L(NAM)) < S LNB=X0DTP_$J($E(RM,1,8),FHTAB+1-$L(X0DTP)) < I 'MUL D LLB Q < I MUL F X2=1:1:+$P(X1,"^",6) D LLB < Q < LLB ; < S FHST=$S(LAB=3:25,1:38) < S FHN=FHST F CN=FHST:-1:FHST-5 S Y0X=$E(Y0,CN) I Y0X= < I LAB=3 S PCL1="",PCL2=LNA,PCL3=LNB,PCL4=$E(Y0,1,FHN) < I LAB=4 S (PCL1,PCL2,PCL8)="",PCL3=LNA,PCL4=LNB,PCL5= < D:LAB=3 LL3^FHLABEL D:LAB=4 LL4^FHLABEL < Q < diff -y --suppress-common-lines ./VADemo/r1/FHORT5.m ./VADemo/r2/r/FHORT5.m ;;5.0;Dietetics;**39**;Oct 11, 1995 | ;;5.0;Dietetics;;Oct 11, 1995 A5 W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If us | A5 R !!,"Do you want multiple labels? N// ",X:DTIME G:'$ Q:$D(DIRUT) S LABSTART=Y < R !!,"Do you want multiple labels? N// ",X:DTIME G:'$ < I $D(IO("Q")) S FHPGM="Q1^FHORT5A",FHLST="FHXX^FHOPT^ | I $D(IO("Q")) S FHPGM="Q1^FHORT5A",FHLST="FHXX^FHOPT^ diff -y --suppress-common-lines ./VADemo/r1/FHORX1B.m ./VADemo/r2/r/FHORX1B.m ;;5.0;Dietetics;**2,38**;Mar 25, 1996 | ;;5.0;Dietetics;**2**;Mar 25, 1996 S S2=LAB=2*5+36 I LAB<3 D LHD | S S2=LAB=2*5+36 D LHD S COUNT=0,LINE=1 < I LAB<3 F L=1:1:18 W ! | F L=1:1:18 W ! I LAB>2 D DPLL^FHLABEL < S X=$G(^FHPT(DFN,"A",ADM,"DI",FHORD,0)) D CUR | S X=$G(^FHPT(DFN,"A",ADM,"DI",FHORD,0)) D CUR W !,$E( I LAB>2 D LL Q < W !,$E(N1,1,S2-5-$L(W1)),?(S2-3-$L(W1)),W1,!,BID W:NP < LL ; < S X1=TC S:NP BID=BID_" *" < D LAB^FHLABEL Q < diff -y --suppress-common-lines ./VADemo/r1/FHORX1.m ./VADemo/r2/r/FHORX1.m ;;5.0;Dietetics;**19,21,39**;Oct 11, 1995 | ;;5.0;Dietetics;**19,21**;Oct 11, 1995 S FHLBFLG=1 I LAB D I FHLBFLG=0 Q < .W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If u < .I $D(DIRUT) S FHLBFLG=0 Q < .S LABSTART=Y Q < I $D(IO("Q")) S FHPGM="Q1^FHORX1",FHLST="TIM^LAB^FHP^ | I $D(IO("Q")) S FHPGM="Q1^FHORX1",FHLST="TIM^LAB^FHP" diff -y --suppress-common-lines ./VADemo/r1/FHSP11.m ./VADemo/r2/r/FHSP11.m FHSP11 ; HISC/NCA,RTK - Print Standing Orders Labels ;2/26/9 | FHSP11 ; HISC/NCA - Print Standing Orders Labels ;2/26/96 0 ;;5.0;Dietetics;**2,38,39**;Mar 25, 1996 | ;;5.0;Dietetics;**2**;Mar 25, 1996 F SP=0:0 S SP=$O(^TMP($J,"SOL",SP)) Q:SP<1 D P2 | F SP=0:0 S SP=$O(^TMP($J,"SOL",SP)) Q:SP<1 S WRD="" P2 S WRD="" F S WRD=$O(^TMP($J,"SOL",SP,WRD)) Q:WRD="" | P2 S WRD=$O(^TMP($J,"SOL",SP,WRD)) Q:WRD="" S DFN="" Q | P3 S DFN=$O(^TMP($J,"SOL",SP,WRD,DFN)) G:DFN="" P2 S FHL P3 F DFN=0:0 S DFN=$O(^TMP($J,"SOL",SP,WRD,DFN)) Q:DFN<1 | P4 S FHL=$O(^TMP($J,"SOL",SP,WRD,DFN,FHL)) G:FHL="" P3 S Q | S IS=$P(Y,"^",4),FHORD=$P(Y,"^",1) G:'FHORD P4 S M1=$ P4 F FHL=0:0 S FHL=$O(^TMP($J,"SOL",SP,WRD,DFN,FHL)) Q:F | G:$P($G(^FH(118.3,+FHORD,0)),"^",2)'="Y" P4 S NAM=$P( Q < P5 S Y=^(FHL) < S IS=$P(Y,"^",4),FHORD=$P(Y,"^",1) Q:'FHORD S M1=$P( < Q:$P($G(^FH(118.3,+FHORD,0)),"^",2)'="Y" S NAM=$P(^D < I LAB>2 D LL Q < Q | G P4 LL ; < S FHCOL=$S(LAB=3:3,1:2) < I LABSTART>1 F FHLABST=1:1:(LABSTART-1)*FHCOL D S LA < .I LAB=3 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)="" D LL3^F < .I LAB=4 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)= < .Q < S FHTAB=$S(LAB=3:24,1:37) < S WRD1=$E(WRD,3,99) < S NAM=$E(NAM,1,FHTAB-$L(WRD1)),BIDIS=BID I IS="N" S B < S LNA=NAM_$J(WRD1,FHTAB+1-$L(NAM)),LNB=BIDIS_$J(DTE,F < S LNC=$J(Q,2)_" "_$P($G(^FH(118.3,+FHORD,0)),U,1) < I LAB=3 S (PCL1,PCL4,PCL6)="",PCL2=LNA,PCL3=LNB,PCL5= < I LAB=4 S (PCL1,PCL2,PCL5,PCL7,PCL8)="",PCL3=LNA,PCL4 < D:LAB=3 LL3^FHLABEL D:LAB=4 LL4^FHLABEL < Q < diff -y --suppress-common-lines ./VADemo/r1/FHSP1.m ./VADemo/r2/r/FHSP1.m ;;5.0;Dietetics;**38,39**;Oct 11, 1995 | ;;5.0;Dietetics;;Oct 11, 1995 D5 W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If us | D5 W:'D3 !!,"Place Labels in Printer" Q:$D(DIRUT) S LABSTART=Y < W:'D3 !!,"Place Labels in Printer" < I $D(IO("Q")) S FHPGM="Q1^FHSP1",FHLST="D3^FHOPT^FHP^ | I $D(IO("Q")) S FHPGM="Q1^FHSP1",FHLST="D3^FHOPT^FHP^ S COUNT=0,LINE=1,DTP=NOW D DTP^FH S DTR=DTP | S DTP=NOW D DTP^FH S DTR=DTP D Q2 | D Q2 F L=1:1:$S('D3:18,1:1) W ! I $G(LAB)>2 D DPLL^FHLABEL Q < F L=1:1:$S('D3:18,1:1) W ! < diff -y --suppress-common-lines ./VADemo/r1/FHSYSP.m ./VADemo/r2/r/FHSYSP.m ;;5.0;Dietetics;**40**;Oct 11, 1995 | ;;5.0;Dietetics;;Oct 11, 1995 W ! S DR="3;22;100//Y;I X'=""Y"" S Y="""";99" D ^DIE | W ! S DR="3;100//Y;I X'=""Y"" S Y="""";99" D ^DIE G K diff -y --suppress-common-lines ./VADemo/r1/FHWOR1.m ./VADemo/r2/r/FHWOR1.m ;;5.0;Dietetics;**6,28,38**;Oct 11, 1995 | ;;5.0;Dietetics;**6,28**;Oct 11, 1995 S COM=$E(COM,1,160) D ORD^FHORO S $P(^FHPT(DFN,"A",AD | S COM=$E(COM,1,80) D ORD^FHORO S $P(^FHPT(DFN,"A",ADM diff -y --suppress-common-lines ./VADemo/r1/FHWOR2.m ./VADemo/r2/r/FHWOR2.m ;;5.0;Dietetics;**6,28,27,35,38**;Oct 11, 1995 | ;;5.0;Dietetics;**6,28,27,35**;Oct 11, 1995 S D4=0,FHOR="^^^^",FHEVTX="",N1=0 F D0=0:0 S D0=$O(DI | S D4=0,FHOR="^^^^",N1=0 F D0=0:0 S D0=$O(DI(D0)) Q:D0 I '$O(^FH(111.1,"AB",FHOR,0)),$P($G(^FH(119.9,1,4))," | I '$O(^FH(111.1,"AB",FHOR,0)),$P($G(^FH(119.9,1,4))," diff -y --suppress-common-lines ./VADemo/r1/FHWOR51.m ./VADemo/r2/r/FHWOR51.m ;;5.0;Dietetics;**6,15,38**;Oct 11, 1995 | ;;5.0;Dietetics;**6,15**;Oct 11, 1995 S DIET=$P(DATA,"|",4),DIET=$E(DIET,4,$L(DIET)),TFCOM= | S DIET=$P(DATA,"|",4),DIET=$E(DIET,4,$L(DIET)),TFCOM= diff -y --suppress-common-lines ./VADemo/r1/GECSMUT2.m ./VADemo/r2/r/GECSMUT2.m GECSMUT2 ;WISC/RFJ/KLD-maintenance utilities ;13 Oct 9 | GECSMUT2 ;WISC/RFJ/KLD-maintenance utilities ;;2.0;GCS;**19,33**;MAR 14, 1995 | ;;2.0;GCS;**19**;MAR 14, 1995 D ^GECSSITE Q:'$G(GECS("SITE")) | D ^GECSSITE diff -y --suppress-common-lines ./VADemo/r1/GMPL1.m ./VADemo/r2/r/GMPL1.m GMPL1 ; SLC/MKB/AJB -- Problem List actions ; 04/22/03 | GMPL1 ; SLC/MKB -- Problem List actions ;3/13/00 10:43 ;;2.0;Problem List;**3,20,28**;Aug 25, 1994 | ;;2.0;Problem List;**3,20**;Aug 25, 1994 ; added for Code Set Versioning (CSV) < I '+$$STATCHK^ICDAPIU(GMPICD,DT) W !,GMPROB,!,"has an < I '$$CODESTS^GMPLX(GMPIFN,DT) W !,"is inactive. Edit < I '$$CODESTS^GMPLX(GMPIFN,DT) W "has an inactive ICD9 < Only in ./VADemo/r1/: GMPLBLCK.m diff -y --suppress-common-lines ./VADemo/r1/GMPLBLD1.m ./VADemo/r2/r/GMPLBLD1.m GMPLBLD1 ; SLC/MKB -- Bld PL Selection Lists cont ;;3/ | GMPLBLD1 ; SLC/MKB -- Bld PL Selection Lists cont ;;9- ;;2.0;Problem List;**3,28**;Aug 25, 1994 | ;;2.0;Problem List;**3**;Aug 25, 1994 ; < ; This routine invokes IA #3991,#10082 < ; < S DIR("S")="I $$STATCHK^ICDAPIU($P(^(0),U),DT)" < diff -y --suppress-common-lines ./VADemo/r1/GMPLBLD2.m ./VADemo/r2/r/GMPLBLD2.m GMPLBLD2 ; SLC/MKB,JFR -- Bld PL Selection Lists cont | GMPLBLD2 ; SLC/MKB -- Bld PL Selection Lists cont ;;9- ;;2.0;Problem List;**3,28**;Aug 25, 1994 | ;;2.0;Problem List;**3**;Aug 25, 1994 ; < ; This routine invokes IA #3991 < ; < N GMPLQT,LABEL,DA | N LABEL,DA W !!,"Saving ..." S GMPLQT=0 < I $D(GMPLGRP) D I GMPLQT Q < . N ITM,CODE < . S ITM=0 < . F S ITM=$O(^TMP("GMPLIST",$J,ITM)) Q:'ITM!(GMPLQT) < .. S CODE=$P(^TMP("GMPLIST",$J,ITM),U,4) Q:'$L(CODE) < .. I '$$STATCHK^ICDAPIU(CODE,DT) S GMPLQT=1 Q < . I 'GMPLQT Q ;no inactive codes in the category < . D FULL^VALM1 < . W !!,$C(7),"This Group contains problems with inact < . W !,"The codes must be edited and corrected before < . N DIR,DUOUT,DTOUT,DIRUT < . S DIR(0)="E" D ^DIR < . S VALMBCK="R",GMPLQT=1 < . Q < ; < I '$D(GMPLGRP),$D(GMPLSLST) D I GMPLQT Q < . N GRP < . S GRP=0 < . F S GRP=$O(^TMP("GMPLIST",$J,"GRP",GRP)) Q:'GRP!(G < .. I $$VALGRP(GRP) Q ;no inactive codes in the GROUP < .. S GMPLQT=1 < . I 'GMPLQT Q ; all groups and problems OK < . D FULL^VALM1 < . W !!,$C(7),"This Selection List contains problems w < . W !,"them. The codes must be edited and corrected b < . N DIR,DUOUT,DTOUT,DIRUT < . S DIR(0)="E" D ^DIR < . S VALMBCK="R",GMPLQT=1 < . Q < W !!,"Saving ..." < N DIK,DIE,DR,ITEM,TMPITEM | N DIK,DIE,DR,ITEM S DIK="^GMPL(125.12," S DIK="^GMPL(125.12," < . F I=1:1:4 D | . F I=1:1:4 S:$P(^TMP("GMPLIST",$J,DA),U,I)'=$P(ITEM, .. S:$P(^TMP("GMPLIST",$J,DA),U,I)'=$P(ITEM,U,I) DR=D < N DIK,DIE,DR,ITEM,TMPLST | N DIK,DIE,DR,ITEM S DIK="^GMPL(125.1," S DIK="^GMPL(125.1," < . F I=1,2,3,4 D | . F I=1,2,3,4 S:$P(^TMP("GMPLIST",$J,DA),U,I)'=$P(ITE .. S:$P(^TMP("GMPLIST",$J,DA),U,I)'=$P(ITEM,U,I) DR=D < ; < VALGRP(GMPLCAT) ; check all problems in the category for inac < ; Input: < ; GMPLCAT = ien from file 125.11 < ; < ; Output: < ; 1 = category has no problems with inactive c < ; 0 = category has one or more problems with i < ; O^ERR = category is invalid^error message < ; < I '$G(GMPLCAT) Q "0^No category selected" < N PROB,GMPLVALC < S GMPLVALC=1,PROB=0 < F S PROB=$O(^GMPL(125.12,"B",GMPLCAT,PROB)) Q:'PROB! < . N GMPLCOD < . S GMPLCOD=$P(^GMPL(125.12,PROB,0),U,5) < . Q:'$L(GMPLCOD) ; no code there < . I '$$STATCHK^ICDAPIU(GMPLCOD,DT) S GMPLVALC=0 < . Q < Q GMPLVALC < ; < VALLIST(LIST) ;check all categories in list for probs w/ in < ; Input: < ; LIST = ien from file 125 < ; < ; Output: < ; 1 = list has no problems with inactive codes < ; 0 = list has one or more problems with inact < ; O^ERR = list is invalid^error message < ; < N GMPLIEN,GMPLVAL < I '$G(LIST) Q 0 < S GMPLIEN=0,GMPLVAL=1 < F S GMPLIEN=$O(^GMPL(125.1,"B",LIST,GMPLIEN)) Q:'GMP < . N GMPLCAT < . S GMPLCAT=$P(^GMPL(125.1,GMPLIEN,0),U,3) I 'GMPLCAT < . I '$$VALGRP(GMPLCAT) S GMPLVAL=0 < . Q < Q GMPLVAL < ; < ASSIGN ; allow lookup of PROB SEL LIST and assign to users < ; < N DIC,X,Y,DUOUT,DTOUT,GMPLSLST < S DIC="^GMPL(125,",DIC(0)="AEQMZ",DIC("A")="Select LI < D ^DIC < Q:$D(DTOUT)!($D(DUOUT)) < Q:Y<0 < I '$$VALLIST(+Y) D G ASSIGN < . W !!,$C(7),"This Selection List contains problems w < . W !,"them. The codes must be edited and corrected b < ; < S GMPLSLST=+Y < D USERS^GMPLBLD3("1") < Q < diff -y --suppress-common-lines ./VADemo/r1/GMPLBLD3.m ./VADemo/r2/r/GMPLBLD3.m GMPLBLD3 ; SLC/MKB -- Bld PL Selection Lists cont ;3/1 | GMPLBLD3 ; SLC/MKB -- Bld PL Selection Lists cont ;2/2 ;;2.0;Problem List;**28**;Aug 25, 1994 | ;;2.0;Problem List;;Aug 25, 1994 ; < ; This routine invokes IA #3991 < ; < I '$$VALLIST^GMPLBLD2(+GMPLSLST) D G ASQ < . W !!,$C(7),"This Selection List contains problems w < . W !,"them. The codes must be edited and corrected b < . W !!,"If you have edited the list during this sessi < . W !,"save the list prior to attempting to assign it < . N DIR,DUOUT,DTOUT,DIRUT < . S DIR(0)="E" D ^DIR < . Q < ; < N GSEQ,PSEQ,GCNT,PCNT,GROUP,HDR,IFN,LCNT,ITEM,TEXT,CO | N GSEQ,PSEQ,GCNT,PCNT,GROUP,HDR,IFN,LCNT,ITEM . . I $L(CODE),'$$STATCHK^ICDAPIU(CODE,DT) Q ; scree < diff -y --suppress-common-lines ./VADemo/r1/GMPLBLDC.m ./VADemo/r2/r/GMPLBLDC.m GMPLBLDC ; SLC/MKB -- Build Problem Selection Categori | GMPLBLDC ; SLC/MKB -- Build Problem Selection Categori ;;2.0;Problem List;**3,7,28**;Aug 25, 1994 | ;;2.0;Problem List;**3,7**;Aug 25, 1994 ; < ; This routine invokes IA #3991 < ; < . I $L(CODE) D | . S:$L(CODE) ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$ .. S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0 < .. I $$STATCHK^ICDAPIU(CODE,DT) Q ; OK - code is act < .. S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0 < diff -y --suppress-common-lines ./VADemo/r1/GMPLBLD.m ./VADemo/r2/r/GMPLBLD.m GMPLBLD ; SLC/MKB -- Build Problem Selection Lists ; 3/12/03 | GMPLBLD ; SLC/MKB -- Build Problem Selection Lists ;;9-5-95 1 ;;2.0;Problem List;**3,28**;Aug 25, 1994 | ;;2.0;Problem List;**3**;Aug 25, 1994 ; < ;This routine invokes IA #3991 < ; < . . I $L($P(ITEM,U,5)) D | . . S:$L($P(ITEM,U,5)) ^TMP("GMPLST",$J,LCNT,0)=^TMP( ... S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT, < ... I $$STATCHK^ICDAPIU($P(ITEM,U,5),DT) Q ; code is < ... S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT, < . I '$$VALGRP^GMPLBLD2(+GROUP) D Q < .. D FULL^VALM1 < .. W !!,$C(7),"This category contains one or more pro < .. W !,"These codes must be updated before adding the < .. N DIR,DTOUT,DIRUT,DUOUT,X,Y < .. S DIR(0)="E" D ^DIR < .. S VALMBCK="R" < diff -y --suppress-common-lines ./VADemo/r1/GMPLCODE.m ./VADemo/r2/r/GMPLCODE.m GMPLCODE ; SLC/MKB/AJB -- Problem List ICD Code Utilit | GMPLCODE ; SLC/MKB -- Problem List ICD Code Utilities ;;2.0;Problem List;**28**;Aug 25, 1994 | ;;2.0;Problem List;;Aug 25, 1994 W !,IFN,! < ; Added for Code Set Versioning (CSV) - screen allows < S DIR("S")="I +($$STATCHK^ICDAPIU($$CODEC^ICDCODE(+($ < D BUILD^GMPLMGR(.GMPLIST) S VALMBCK="R" < diff -y --suppress-common-lines ./VADemo/r1/GMPLEDT1.m ./VADemo/r2/r/GMPLEDT1.m GMPLEDT1 ; SLC/MKB/KER/AJB -- Edit Problem List fields | GMPLEDT1 ; SLC/MKB/KER -- Edit Problem List fields ; 0 ;;2.0;Problem List;**17,20,26,28**;Aug 25, 1994 | ;;2.0;Problem List;**17,20,26**;Aug 25, 1994 ; added for Code Set Versioning (CSV) < I $G(GMPICD),'+$$STATCHK^ICDAPIU(GMPICD,DT) D Q < . W !!,"This problem has an inactive ICD code. Please < I $G(GMPIFN),'$$CODESTS^GMPLX(GMPIFN,DT) D Q < . W !!,"This problem has an inactive ICD code. Please < diff -y --suppress-common-lines ./VADemo/r1/GMPL.m ./VADemo/r2/r/GMPL.m GMPL ; SLC/MKB/AJB -- Problem List Driver ;;9-5-95 11:47am | GMPL ; SLC/MKB -- Problem List Driver ;;9-5-95 11:47am ;;2.0;Problem List;**3,11,28**;Aug 25, 1994 | ;;2.0;Problem List;**3,11**;Aug 25, 1994 ; Code Set Versioning (CSV) < I '$$CODESTS^GMPLX(GMPIFN,DT) W !!,$$PROBTEXT^GMPLX(G < ; Code Set Versioning (CSV) < ; I '$$CODESTS^GMPLX(GMPIFN,DT) W !!,$$PROBTEXT^GMPLX < diff -y --suppress-common-lines ./VADemo/r1/GMPLMGR2.m ./VADemo/r2/r/GMPLMGR2.m GMPLMGR2 ; SLC/MKB/KER/AJB -- Problem List VALM Utilit | GMPLMGR2 ; SLC/MKB/KER -- Problem List VALM Utilities ;;2.0;Problem List;**26,28**;Aug 25, 1994 | ;;2.0;Problem List;**26**;Aug 25, 1994 ; added for Code Set Versioning (CSV) - checks ICD co | S:STATUS="I" LINE=$$SETFLD^VALM1(STATUS,LINE,"STATUS" I '$$CODESTS^GMPLX(IFN,DT) D < . I STATUS="A" S LINE=$$SETFLD^VALM1(" #",LINE,"STATU < . I STATUS="I" S LINE=$$SETFLD^VALM1(STATUS_"#",LINE, < E S:STATUS="I" LINE=$$SETFLD^VALM1(STATUS,LINE,"STAT < ; S:STATUS="I" LINE=$$SETFLD^VALM1(STATUS,LINE,"STATU < diff -y --suppress-common-lines ./VADemo/r1/GMPLMGR.m ./VADemo/r2/r/GMPLMGR.m GMPLMGR ; SLC/MKB/AJB -- Problem List VALM Utilities ;3/1/00 | GMPLMGR ; SLC/MKB -- Problem List VALM Utilities ;3/1/00 12: ;;2.0;Problem List;**21,28**;Aug 25, 1994 | ;;2.0;Problem List;**21**;Aug 25, 1994 ; added for Code Set Versioning (CSV) - annotates ina < I '$$CODESTS^GMPLX(IFN,DT) S LINE=$E(LINE,1,4)_"#"_$E < W !?4,"Problem statuses: *-Acute I-Inactive #-Inactiv | W !?4,"Problem statuses: * - Acute I - Inactive" W:GMPARAM("VER") " $-Unverified" | W:GMPARAM("VER") " $ - Unverified" Only in ./VADemo/r1/: GMPLP27I.m Only in ./VADemo/r1/: GMPLPXRM.m diff -y --suppress-common-lines ./VADemo/r1/GMPLRPTR.m ./VADemo/r2/r/GMPLRPTR.m GMPLRPTR ; SLC/MKB/AJB -- Problem List Report of Remov | GMPLRPTR ; SLC/MKB -- Problem List Report of Removed P ;;2.0;Problem List;**28**;Aug 25, 1994 | ;;2.0;Problem List;;Aug 25, 1994 . ; added for Code Set Versioning (CSV) < . I '$$CODESTS^GMPLX(IFN,DT) S PROBLEM="#"_PROBLEM < . ; added for Code Set Versioning | . W !,NUM,?4,PROBLEM,?51,$$EXTDT^GMPLX(DATE),?60,$$NA . N GMPLBUF S GMPLBUF=$S(PROBLEM["#":3,1:4) < . W !,NUM,?GMPLBUF,PROBLEM,?51,$$EXTDT^GMPLX(DATE),?6 < . ; added for Code Set Versioning (CSV) < . I '$$CODESTS^GMPLX(GMPLIST(NUM),DT) W !!,$$PROBTEXT < D | W !,"< DONE >",! . N DIR S DIR(0)="E" W ! D ^DIR < diff -y --suppress-common-lines ./VADemo/r1/GMPLX.m ./VADemo/r2/r/GMPLX.m GMPLX ; SLC/MKB/AJB -- Problem List Problem Utilities ; 02/ | GMPLX ; SLC/MKB -- Problem List Problem Utilities ; 04/15/2 ;;2.0;Problem List;**7,23,26,28,27**;Aug 25, 1994 | ;;2.0;Problem List;**7,23,26**;Aug 25, 1994 ; DBIA 2742 GMPLX | ; ; DBIA 3991 $$STATCHK^ICDAPIU < ; < N DIC S:'$L($G(VIEW)) VIEW="PL1" D CONFIG^LEXSET("GMP | N DIC S:'$L($G(VIEW)) VIEW="PL1" D CONFIG^LEXSET("GMP N DIE,DR | S $P(^AUPNPROB(DA,0),U,3)=DT S DIK="^AUPNPROB(",DIK(1 S DR=".03///TODAY",DIE="^AUPNPROB(" < D ^DIE < ; < CODESTS(PROB,ADATE) ;check status of code associated with < ; Input: < ; PROB = pointer to the PROBLEM (#9000011) file < ; ADATE = FM date on which to check the status of < ; < ; Output: < ; 1 = ACTIVE on the date passed or current date if < ; 0 = INACTIVE on the date passed or current date < ; < I '$G(ADATE) S ADATE=DT < I '$D(^AUPNPROB(PROB,0)) Q 0 < S PROB=$P(^AUPNPROB(PROB,0),U) < Q +($$STATCHK^ICDAPIU($$CODEC^ICDCODE(+(PROB)),ADATE) < diff -y --suppress-common-lines ./VADemo/r1/GMRADSP2.m ./VADemo/r2/r/GMRADSP2.m GMRADSP2 ;HIRMFO/RM,WAA-PRINT PATIENT A/AR ;12/22/04 | GMRADSP2 ;HIRMFO/RM,WAA-PRINT PATIENT A/AR ; 3/26/92 ;;4.0;Adverse Reaction Tracking;**21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 I 'GMRAPRNT S GMRASP(1)=7,GMRAHDR(1)="PATIENT: ",GMRA | I 'GMRAPRNT S GMRASP(1)=7,GMRAHDR(1)="PATIENT: ",GMRA S Y=$P(GMRAPA(0),"^",4) S:Y Y=$$FMTE^XLFDT(Y) S GMRAS | S Y=$P(GMRAPA(0),"^",4) D:Y D^DIQ S GMRASP(1)=4,GMRAH I $D(^GMR(120.85,"C",GMRAPA)) D ;21 < .S (GMRASP(1),GMRASP(2))="" ;21 < .N GMRAI,SEVER S (GMRAI,SEVER)=0 F S GMRAI=$O(^GMR(1 < .I $G(SEVER) S GMRASP(1)=6,GMRAHDR(1)="SEVERITY: ",GM < .S GMRASP(2)=49,GMRAHDR(2)="OBS D/T: ",GMRALIN(2)=$$F < .D WRITE^GMRADSP3 G:GMRAOUT EXIT ;21 < .Q ;21 < S GMRASP(1)=0,GMRAHDR(1)="ID BAND MARKED: ",Y="",Y=$O | S GMRASP(1)=0,GMRAHDR(1)="ID BAND MARKED: ",Y="",Y=$O S GMRASP(2)=44,GMRALIN(1)=Y,GMRAHDR(2)="CHART MARKED: | S GMRASP(2)=44,GMRALIN(1)=Y,GMRAHDR(2)="CHART MARKED: diff -y --suppress-common-lines ./VADemo/r1/GMRAEAB.m ./VADemo/r2/r/GMRAEAB.m GMRAEAB ;HIRMFO/RM-BULLETIN SEND FOR E/E REACTIONS ;12/22/04 | GMRAEAB ;HIRMFO/RM-BULLETIN SEND FOR E/E REACTIONS ;11/29/95 ;;4.0;Adverse Reaction Tracking;**21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 S XMB(5)=$S($P(GMRAPA(0),U,5)'="":$$GET1^DIQ(200,$P(G | S XMB(5)=$S($P(GMRAPA(0),U,5)'="":$P($G(^VA(200,$P(GM S XMB(6)=$$GET1^DIQ(200,$P($G(^GMR(120.8,GMRAPA,"ER") | S XMB(6)=$P($G(^VA(200,$P($G(^GMR(120.8,GMRAPA,"ER")) S XMB(9)=$$FMTE^XLFDT($P(GMRAPA(0),U,4)) ;21 | ; All comments: ; Signs/symptoms and comments < N GMRAKIND,GMRACNT,GMRAX,GMRASP,GMRADATA,GMRAI,GMRAP | N GMRAKIND,GMRACNT,GMRAX,GMRASP D EN1^GMRAOR2(GMRAPA,"GMRADATA") ;21 < I $D(GMRADATA("S")) S ^TMP($J,"GMRACOM",GMRACNT)=" < .S GMRAI=0,GMRAP=0 F S GMRAI=$O(GMRADATA("S",GMRAI)) < ..I 'GMRAP S ^TMP($J,"GMRACOM",GMRACNT)=^TMP($J,"GMRA < ..S ^TMP($J,"GMRACOM",GMRACNT)=$$REPEAT^XLFSTR(" ",24 < I $D(^GMR(120.8,GMRAPA,26,"AVER")) S ^TMP($J,"GMRACOM < ;Only send bulletin to verifier groups if reactant st | F %=1:1:$L($P(GMRAPA(0),"^",20)) D I '+$P(GMRAPA(0),U,16)!($P(GMRAPA(0),U,18)) F %=1:1:$ < I $P(GMRAPA(0),U,20)["D"&($P(GMRAPA(0),U,6)="o") S XM < S:GMRAZ'="" GMRAZN=$$GET1^DIQ(200,GMRAZ_",",".01") ;2 | S:GMRAZ'="" GMRAZN=$P($G(^VA(200,GMRAZ,0)),U) S:GMRAZ'="" GMRAT=$$GET1^DIQ(200,GMRAZ_",","8","I") ; | S:GMRAZ'="" GMRAT=$P($G(^VA(200,GMRAZ,0)),U,9) Only in ./VADemo/r1/: GMRAFX1.m Only in ./VADemo/r1/: GMRAFX2.m Only in ./VADemo/r1/: GMRAFX3.m Only in ./VADemo/r1/: GMRAFX.m Only in ./VADemo/r1/: GMRAGUI1.m Only in ./VADemo/r1/: GMRAGUI.m Only in ./VADemo/r1/: GMRAHDR.m diff -y --suppress-common-lines ./VADemo/r1/GMRAHUT0.m ./VADemo/r2/r/GMRAHUT0.m GMRAHUT0 ;HIRMFO/RM,YMP-HELP UTILITY FOR ALLERGY FILES | GMRAHUT0 ;HIRMFO/RM,YMP-HELP UTILITY FOR ALLERGY FILES ;;4.0;Adverse Reaction Tracking;**21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 W !,?8,"MILD - Requires minimal therapeutic inter | W !,?8,"MILD - Requires minimal therapeutic inter W !,?8,"MODERATE - Requires active treatment of adver | W !,?8,"MODERATE - Requires therapeutic intervention W !?19,"extent of non-serious outcome (see SEVERE for | W !,?8,"SEVERE - Life threatening or contributed to W !,?8,"SEVERE - Includes any serious outcome, resu < W !?19,"impairment or damage, or requiring/prolonging < Only in ./VADemo/r1/: GMRAIAD1.m Only in ./VADemo/r1/: GMRAIAD2.m Only in ./VADemo/r1/: GMRAIAL1.m Only in ./VADemo/r1/: GMRAIAL2.m Only in ./VADemo/r1/: GMRAIVDK.m diff -y --suppress-common-lines ./VADemo/r1/GMRAMCB.m ./VADemo/r2/r/GMRAMCB.m GMRAMCB ;HIRMFO/WAA-MARK CHART & ID BAND FIELD EDIT ;9/16/04 | GMRAMCB ;HIRMFO/WAA-MARK CHART & ID BAND FIELD EDIT ;12/1/95 ;;4.0;Adverse Reaction Tracking;**21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 ..I GMRAM1=13 S %=1,%Y="Y" Q ;21 Marked on chart set < diff -y --suppress-common-lines ./VADemo/r1/GMRANKA.m ./VADemo/r2/r/GMRANKA.m GMRANKA ;HIRMFO/WAA-ALLERGY/ADVERSE REACTION PATIENT NKA DRIV | GMRANKA ;HIRMFO/WAA-ALLERGY/ADVERSE REACTION PATIENT NKA DRIV ;;4.0;Adverse Reaction Tracking;**2,21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;**2**;Mar 29, 1996 S DIR("?")=$S(GMAOLD=0:"You may also enter @ to delet < I $G(X)="@" D:GMAOLD=0 CLN W:GMAOLD=0 !,"Assessment d < ; < DELNKA ;Remove assessment of NKA for a selected patient < N Y,DFN,DIR,DIC < S DIC=120.86,DIC(0)="AEMQZ",DIC("A")="Select PATIENT < S DFN=+Y < W ! < I $$NKA^GMRANKA(DFN)'=0 W !,"This patient doesn't cur < S DIR(0)="Y",DIR("A")="Delete NKA assessment for pati < S DIR("?")="Enter Y to delete the NKA assessment and < D ^DIR < I Y=1 D CLN^GMRANKA W "...Done" < Q < diff -y --suppress-common-lines ./VADemo/r1/GMRAOR1.m ./VADemo/r2/r/GMRAOR1.m GMRAOR1 ;HIRMFO/RM,WAA-OERR UTILITIES ;8/2/04 15:13 | GMRAOR1 ;HIRMFO/RM,WAA-OERR UTILITIES ; 2/8/95 ;;4.0;Adverse Reaction Tracking;**21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 ..;Loop through the S/S multiple and get the external | ..;Loop through the S/S multiple and get just the ext ..S %=0 F S %=$O(GMRAL(GMRAIEN,"S",%)) Q:%<1 S GMRA | ..S %=0 F S %=$O(GMRAL(GMRAIEN,"S",%)) Q:%<1 S GMRA diff -y --suppress-common-lines ./VADemo/r1/GMRAOR2.m ./VADemo/r2/r/GMRAOR2.m GMRAOR2 ;HIRMFO/RM-OERR UTILITIES ;12/22/04 10:38 | GMRAOR2 ;HIRMFO/RM-OERR UTILITIES ; 8/1/94 ;;4.0;Adverse Reaction Tracking;**21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 S GMRAL=GMRAL_$S($P(GMRAPA(0),U,5)'="":$$GET1^DIQ(200 | S GMRAL=GMRAL_$S($P(GMRAPA(0),U,5)'="":$P($G(^VA(200, S %=$S($P(GMRAPA(0),U,5)'="":$$GET1^DIQ(200,$P(GMRAPA | S %=$S($P(GMRAPA(0),U,5)'="":$P($G(^VA(200,$P(GMRAPA( S GMRAL=GMRAL_$$OUTTYPE^GMRAUTL($P(GMRAPA(0),U,20))_U | S GMRAL=GMRAL_$$OUTTYPE^GMRAUTL($P(GMRAPA(0),U,20)) S GMRAL=GMRAL_U_$$FMTE^XLFDT($P(GMRAPA(0),U,4)) ;21 a < .S GMRAL("C",%)=$P(GMRACOM,U)_U_$S($P(GMRACOM,U,3)="V | .S GMRAL("C",%)=$P(GMRACOM,U)_U_$S($P(GMRACOM,U,3)="y .S GMRAL("S",%)=$S(+GMRAZ'=GMRAOTH:$P($G(^GMRD(120.83 | .S GMRAL("S",%)=$S(+GMRAZ'=GMRAOTH:$P($G(^GMRD(120.83 diff -y --suppress-common-lines ./VADemo/r1/GMRAOR5.m ./VADemo/r2/r/GMRAOR5.m GMRAOR5 ;HIRMFO/WAA,FPT-OERR HL7 UTILITY ;3/5/04 14:02 | GMRAOR5 ;HIRMFO/WAA,FPT-OERR HL7 UTILITY ;7/8/97 10:25 ;;4.0;Adverse Reaction Tracking;**4,12,13,19**;Mar 29 | ;;4.0;Adverse Reaction Tracking;**4,12,13**;Mar 29, 1 .S ^TMP($J,"GMRASF",1,GMRAPA)="" D RANGE^GMRASIGN(1) < .S GMRASITE(0)=$G(^GMRD(120.84,+GMRASITE,0)) D VAD^GM < diff -y --suppress-common-lines ./VADemo/r1/GMRAOR6.m ./VADemo/r2/r/GMRAOR6.m GMRAOR6 ;HIRMFO/WAA-OERR HL7 UTILITY ;10/15/04 10:59 | GMRAOR6 ;HIRMFO/WAA-OERR HL7 UTILITY ; 2/9/95 ;;4.0;Adverse Reaction Tracking;**17,21**;Mar 29, 199 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 .Q:$P(GMRAL(GMRAL,"S",GMRASN),U)'>0 ;17 Screen out b < .I $P(GMRALN,U)=GMRAOTH S $P(GMRALN,U,2)=$P(GMRAL(GMR | .I $P(GMRALN,U)=GMRAOTH S $P(GMRALN,U,2)=$P(GMRAL(GMR diff -y --suppress-common-lines ./VADemo/r1/GMRAOR7.m ./VADemo/r2/r/GMRAOR7.m GMRAOR7 ;HIRMFO/WAA,FPT-OERR HL7 UTILITY ;8/28/03 13:52 | GMRAOR7 ;HIRMFO/WAA,FPT-OERR HL7 UTILITY ; 2/9/95 ;;4.0;Adverse Reaction Tracking;**4,17**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;**4**;Mar 29, 1996 .K DIK,DA S DIK="^GMR(120.85,",DA=GMRAPA1 D IX^DIK K | .K DIK,DA S DIK="^GMR(120.85,",DA=GMRAPA D IX^DIK K D diff -y --suppress-common-lines ./VADemo/r1/GMRAPED0.m ./VADemo/r2/r/GMRAPED0.m GMRAPED0 ;HIRMFO/RM,WAA-VERIFIER EDIT OF DRUG A/AR ;8/ | GMRAPED0 ;HIRMFO/RM,WAA-VERIFIER EDIT OF DRUG A/AR ; 1 ;;4.0;Adverse Reaction Tracking;**17**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 .I $P(GMRAPA(0),"^",6)'=$P(GMRANEW(0),"^",6) D Q | .I $P(GMRAPA(0),"^",6)'=$P(GMRANEW(0),"^",6) F D Q: ..W !!,"You cannot change the type of reaction. If t | ..W !,"Are you sure you want to make that change" S % ..S DIE="^GMR(120.8,",DR="6////"_$P(GMRAPA(0),"^",6), | ..I %'=1 S GMRAOUT=(%=-1),DIE="^GMR(120.8,",DR="6//// S GMRAOUT=0 G EN1 | G EN1 diff -y --suppress-common-lines ./VADemo/r1/GMRAPEM0.m ./VADemo/r2/r/GMRAPEM0.m GMRAPEM0 ;HIRMFO/WAA,FT-ALLERGY/ADVERSE REACTION PATIE | GMRAPEM0 ;HIRMFO/WAA,FT-ALLERGY/ADVERSE REACTION PATIE ;;4.0;Adverse Reaction Tracking;**2,5,17,21**;Mar 29, | ;;4.0;Adverse Reaction Tracking;**2,5**;Mar 29, 1996 L +^XTMP("GMRAED",DFN):1 I '$T D MESS^GMRAGUI1 Q ;21 < I GMRARP,'GMRAOUT K GMRARP L -^XTMP("GMRAED",DFN) G E | I GMRARP,'GMRAOUT K GMRARP G EN21 L -^XTMP("GMRAED",DFN) ;21 < N GMRAOUT < .;N GMRAOUT | .N GMRAOUT .I GMRAOUT D:$G(GMRANEW)&($$MISSREQ) DELETE S:'$$MISS | .I GMRAOUT D UPOUT^GMRAPEM3 Q ; The user up arrows o .N GMRAOD S GMRAOD=$D(^GMR(120.85,"C",GMRAPA)) ;Exist < OBSDATE .; < .I '$D(^GMR(120.85,"C",GMRAPA)),$G(GMRANEW)!('$G(GMRA < ; < DELETE ;Delete entry if required information is not entered < N DA,DIK,GMRAPA1 < W !!,"Required data not entered, deleting entry...",! < S GMRAPA1=$O(^GMR(120.85,"C",GMRAPA,0)) < I GMRAPA1,$G(^GMR(120.85,GMRAPA1,0))="" K ^GMR(120.85 < I GMRAPA1 S DIK="^GMR(120.85,",DA=GMRAPA1 D ^DIK D UN < I GMRAPA S DIK="^GMR(120.8,",DA=GMRAPA D ^DIK D UNLOC < Q < ; < OBSPROB ;Display help information for missing observed date/t < W !!,"Observed reactions must have at least one obser < Q < ; < MISSREQ() ;Function determines if required data is miss < N GMRA0,TYPE < S GMRA0=$G(^GMR(120.8,+$G(GMRAPA),0)) I GMRA0="" Q 1 < S TYPE=$P(GMRA0,U,6) ;Get observed/historical < I TYPE="" Q 1 ;Type not entered < I TYPE="h" Q 0 ;Historical has no requirements < I TYPE="o" I '$D(^GMR(120.85,"C",GMRAPA))!('$O(^GMR(1 < Q 0 < ; < REQCOM() ;Function determines if comments required < I '$D(GMRASITE) D SITE^GMRAUTL < I +$P(^GMRD(120.84,+GMRASITE,0),U,4)=0 Q 1 ;Comments < I $O(^GMR(120.8,GMRAPA,26,0)) Q 1 < Q 0 < diff -y --suppress-common-lines ./VADemo/r1/GMRAPEO0.m ./VADemo/r2/r/GMRAPEO0.m GMRAPEO0 ;HIRMFO/WAA,RM-EDIT OBSERVED A/AR ;10/15/04 | GMRAPEO0 ;HIRMFO/WAA,RM-EDIT OBSERVED A/AR ;7/23/97 0 ;;4.0;Adverse Reaction Tracking;**8,17,21**;Mar 29, 1 | ;;4.0;Adverse Reaction Tracking;**8**;Mar 29, 1996 I 'GMRAOUT,$O(^GMR(120.8,GMRAPA,10,0)) D | I 'GMRAOUT,GMRAN85,$O(^GMR(120.8,GMRAPA,10,0)) D .K ^GMR(120.85,GMRAPA1,2) ;Clear out s/s before updat < ..S DIK="^GMR(120.85,GMRAPA1,2,",DA(1)=GMRAPA1,DA=GMR < diff -y --suppress-common-lines ./VADemo/r1/GMRAPER0.m ./VADemo/r2/r/GMRAPER0.m GMRAPER0 ;HIRMFO/WAA-REACTIONS SELECT ROUTINE ;11/3/04 | GMRAPER0 ;HIRMFO/WAA-REACTIONS SELECT ROUTINE ;5/20/97 ;;4.0;Adverse Reaction Tracking;**7,21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 S DIC="^GMRD(120.83,",DIC("S")="I $P(^(0),U)'=""OTHER | S DIC="^GMRD(120.83,",DIC(0)="EM",D="B^D",GMRAREAC=X diff -y --suppress-common-lines ./VADemo/r1/GMRAPES0.m ./VADemo/r2/r/GMRAPES0.m GMRAPES0 ;HIRMFO/RM-SELECT PATIENT ALLERGY TO EDIT ;11 | GMRAPES0 ;HIRMFO/RM-SELECT PATIENT ALLERGY TO EDIT ; 2 ;;4.0;Adverse Reaction Tracking;**13,17,19,21**;Mar 2 | ;;4.0;Adverse Reaction Tracking;**13**;Mar 29, 1996 N GMRAGOUT,ROOT,CNT,LST,NAM,DIR,GMRAET | N GMRAGOUT S GMRARET=0 S GMRARET=0 < I GMRALAR?.E1L.E S GMRALAR=$$UP^XLFSTR(GMRALAR) | I GMRALAR?.E1L.E F X=1:1:$L(GMRALAR) I $E(GMRALAR,X)? W !!,"Checking existing PATIENT ALLERGIES (#120.8) fi < NPA W !!,"Now checking GMR ALLERGIES (#120.82) file for m | NPA K Y,DTOUT,DUOUT S X=GMRALAR,DIC="^GMRD(120.82,",DIC(0 S DIC("S")="I $P(^(0),U)'=""OTHER ALLERGY/ADVERSE REA < K Y,DTOUT,DUOUT S X=GMRALAR,DIC="^GMRD(120.82,",DIC(0 < NDF ;find partial matches and select from NDF | ING K Y,DTOUT,DUOUT S D="P",DIC="^PS(50.416,",DIC(0)="SEM K Y,DTOUT,DUOUT < W !!,"Now checking the National Drug File - Generic N < S DIC=50.6,X=GMRALAR,DIC(0)="EZM" D ^DIC K DIC D DIC < I +Y>0 S GMRAAR=+Y_";PSNDF(50.6,",GMRAAR(0)=$P(Y,U,2) < W !!,"Now checking the National Drug File - Trade Nam < K DUOUT,DTOUT,Y < S ROOT=$$T^PSNAPIS,CNT=0,X=GMRALAR < I $D(@ROOT@(X)) S CNT=CNT+1,LST(CNT)=$$TGTOG^PSNAPIS( < S NAM=X F S NAM=$O(@ROOT@(NAM)) Q:NAM=""!($E(NAM,1,$ < .S CNT=CNT+1,LST(CNT)=$$TGTOG^PSNAPIS(NAM)_U_NAM < I 'CNT S Y=-1 ;No matches found < I CNT=1 S Y(0)=LST(1),X=$P(Y(0),U,2),Y=+LST(1) ;Only < I CNT>1 D < .D MATCHES < .S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " < .S DIR("?")="Select the number of desired causative a < .D ^DIR S Y=$S(+Y:+Y,1:-1) S:Y>0 Y(0)=LST(Y),X=$P(Y(0 < D DIC I GMRAOUT S GMRAOUT=GMRAOUT=1 G:GMRAOUT Q1 G EN < I +Y>0 S GMRAAR=+Y(0)_";PSNDF(50.6,",GMRAAR(0)=$P(Y(0 < DRUG W !!,"Now checking the DRUG (#50) file for matches... < S CNT=0,X=GMRALAR K LST < F ROOT="^PSDRUG(""B"")","^PSDRUG(""C"")" D < .I $D(@ROOT@(X)) S CNT=CNT+1,LST(CNT)=$O(@ROOT@(X,0)) < .S NAM=X F S NAM=$O(@ROOT@(NAM)) Q:NAM=""!($E(NAM,1, < ..S CNT=CNT+1,LST(CNT)=$O(@ROOT@(NAM,0))_U_$S(ROOT["C < I 'CNT S Y=-1 ;No matches found < I CNT=1 S Y(0)=LST(1),X=$P(Y(0),U,2),Y=+LST(1) ;Only < I CNT>1 D < .D MATCHES < .S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " < .S DIR("?")="Select the number of desired causative a < .D ^DIR S Y=$S(+Y:+Y,1:-1) S:Y>0 Y(0)=LST(Y),X=$P(Y(0 < D DIC I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN < I +Y>0 S GMRAAR=+Y(0)_";PSDRUG(",GMRAAR(0)=$$GET1^DIQ < ;19 - Moved ING and CLASS code here < ING W !!,"Now checking the INGREDIENTS (#50.416) file for < K Y,DTOUT,DUOUT S D="P",DIC="^PS(50.416,",DIC(0)="SEM < CLASS W !!,"Now checking VA DRUG CLASS (50.605) file for ma | CLASS K Y,DTOUT,DUOUT S X=GMRALAR,DIC="^PS(50.605,",DIC(0)= K Y,DTOUT,DUOUT S X=GMRALAR,DIC="^PS(50.605,",DIC(0)= < YNOTH W !!,"Could not find ",GMRALAR," in any files." | NDF ;find partial matches and select from NDF W !!,"Before sending an email requesting the addition | K Y,DTOUT,DUOUT W !,"Would you like to send an email requesting ",GMR | N CNT,LST S DIR("A")="Send email" | S CNT=$$TGTOG2^PSNAPIS(GMRALAR,.LST) S DIR(0)="Y",DIR("B")="NO",DIR("?")="^D MESS^GMRAPES0 | I 'CNT S Y=-1 D ^DIR | I CNT=1 S Y=+$O(LST(0)),Y(0)=LST(Y) I Y'=+Y S GMRAOUT=1 G Q1 | I CNT>1 D I $D(DTOUT)!($D(DUOUT)) S Y=-1 I '+Y G EN1 | . N CHOICES,DIR YNDRG ; | . D MATCHES D GETINPUT(.GMRAET) | . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " S X=$$SENDREQ(DUZ,DFN,GMRALAR,.GMRAET) | . S DIR("?")="Select the number of the desired causat I '+X W !!,"Error - Message not sent - ",$P(X,U,2) | . D ^DIR S Y=$S(+Y:+CHOICES(Y),1:-1) S:Y>0 Y(0)=LST(Y I +X W !!,"Message sent - NOTE: This reactant was NOT | D DIC I GMRAOUT S GMRAOUT=GMRAOUT-1 G:GMRAOUT Q1 G EN W ! | I +Y>0 S GMRAAR=+Y_";"_$P($$NDFREF^GMRAOR,U,2),GMRAAR > G Q1:GMRAOUT,NDF:X?1"?".E,EN1:Y=0 > DRUG K Y,DTOUT,DUOUT S DIC="^PSDRUG(",DIC(0)="EMZ",X=GMRAL > I +Y>0 S GMRAAR=+Y_";PSDRUG(",GMRAAR(0)=$S(X?1A.E:X,1 > G Q1:GMRAOUT,DRUG:X?1"?".E,EN1:Y=0 > I GMRALAR["," W !,?4,$C(7),"YOU CANNOT ENTER MULTIPLE > YNOTH W !!,"Could not find ",GMRALAR," in any files.",!,"Wo > I '% W !?3,$C(7),"ANSWER YES IF YOU WOULD LIKE TO ADD > YNDRG S GMRAY=$P($G(^GMR(120.8,GMRAPA,0)),U,20) > D EDTTYPE^GMRAUTL(.GMRAY) S:"^^"[GMRAY GMRAOUT=1 G:GM > S GMRAAR=+$O(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE > I Y["," YNOK W !?3,X," OK" S %=1 D YN^DICN S:%=-1 GMRAOUT=1,Y=-1 | YNOK W !?3,X," OK" S %=1 D YN^DICN S:%=-1 GMRAOUT=1,Y=-1 ...D YN^DICN S:%'=1 %=2,GMRAOUT=1 S:%Y?2"^" GMRAOUT= | ...D YN^DICN S:%=-1 %=2,GMRAOUT=1 S:%Y?2"^" GMRAOUT= N I,J,QUIT | N I,J,K,QUIT > S CHOICES=1,K=0 > F S K=$O(LST(K)) Q:'K S CHOICES(CHOICES)=LST(K),CHO S (I,J,QUIT)=0 F S I=$O(LST(I)) Q:I'>0 D Q:QUIT | S (I,J,QUIT)=0 F S I=$O(CHOICES(I)) Q:I'>0 D Q:QUI . S J=J+1 I '(J#(IOSL-5)) S:'$$MORE QUIT=1 Q:QUIT | . S J=J+1 I J>(IOSL-5) S:'$$MORE QUIT=1 Q:QUIT S J=1 . W !,J," ",$P(LST(I),"^",2) | . W !,J," ",$P(CHOICES(I),"^",2) ; | ; ; < SENDREQ(USER,PAT,TEXT,GMRAET) ;Send email to GMRA REQUEST N < ;Returns 0^reason for error < ; 1 if successful < N XMDUZ,XMY,XMSUB,GMRATXT,XMTEXT,XMZ,XMMG,GMRAUI,GMRA < Q:'$G(USER)!('+$G(DUZ))!('$L(TEXT)) "0^Required infor < S XMDUZ="Allergy Package",XMSUB="Request to add new r < S XMY("G.GMRA REQUEST NEW REACTANT")="" < S XMY(DUZ)="" ;Include requestor in message < D GETS^DIQ(200,USER,".01;.132;.138;8","E","GMRAUI"),G < S CNT=1 < S GMRATXT(CNT)="A request to add "_TEXT_" as a new re < S GMRATXT(CNT)="by "_GMRAUI(200,GMRAUS,.01,"E")_" for < S GMRATXT(CNT)="",CNT=CNT+1 < S GMRATXT(CNT)="User's contact information:",CNT=CNT+ < S GMRATXT(CNT)="Title : "_GMRAUI(200,GMRAUS,8, < S GMRATXT(CNT)="Office Phone : "_GMRAUI(200,GMRAUS,.1 < S GMRATXT(CNT)="Digital Pager: "_GMRAUI(200,GMRAUS,.1 < S GMRATXT(CNT)="",CNT=CNT+1 < I $D(GMRAET) S GMRATXT(CNT)="The user added the follo < I $D(GMRAET) S GMRATXT(CNT)="",CNT=CNT+1 < S GMRATXT(CNT)="Please verify with the user the inten < S GMRATXT(CNT)="appropriate action. Be sure to try a < S GMRATXT(CNT)="adding new local allergies.",CNT=CNT+ < S GMRATXT(CNT)="",CNT=CNT+1 < S GMRATXT(CNT)="Please note, a reaction WAS NOT enter < S XMTEXT="GMRATXT(" < D ^XMD < Q $S($D(XMMG):"0^Mail group GMRA REQUEST NEW REACTANT < ; < MESS ;Provide help for sending email message < W !,"Enter YES to send an email to the allergy coordi < Q < ; < GETINPUT(GMRAET) ;Allow user to add comment to message < N DIC,DWLW,DWPK,DIWEPSE < S ^TMP($J,"TEXT",0)="" < S DIC="^TMP($J,""TEXT""," < S DWLW=70,DWPK=1,DIWEPSE="" < W !!,"You may now add any comments you may have to th < W !,"You may want to add things like sign/symptoms, o < D EN^DIWE < I $O(^TMP($J,"TEXT",0)) M GMRAET=^TMP($J,"TEXT") < K ^TMP($J,"TEXT") < Q < diff -y --suppress-common-lines ./VADemo/r1/GMRAPES1.m ./VADemo/r2/r/GMRAPES1.m GMRAPES1 ;HIRMFO/RM,WAA-SELECT PATIENT ALLERGY TO EDIT | GMRAPES1 ;HIRMFO/RM,WAA-SELECT PATIENT ALLERGY TO EDIT ;;4.0;Adverse Reaction Tracking;**13,14,17**;Mar 29, | ;;4.0;Adverse Reaction Tracking;**13,14**;Mar 29, 199 ; < UPDATE ;Updates entry with drug ingredients and/or drug clas < diff -y --suppress-common-lines ./VADemo/r1/GMRAPET0.m ./VADemo/r2/r/GMRAPET0.m GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;12/21/04 | GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;1/14/97 0 ;;4.0;Adverse Reaction Tracking;**6,17,21**;Mar 29, 1 | ;;4.0;Adverse Reaction Tracking;**6**;Mar 29, 1996 N GMRACW,GMRALOC,GMRAHLOC,GMRAXBOS ;21 | N GMRACW,GMRALOC,GMRAHLOC S GMRAPN=-1,GMRAXBOS=$$BROKER^XWBLIB ;21 Got GUI? | S GMRAPN=-1 I GMRACW<1!($T(NEW^TIUPNAPI)']"")!('$$CANPICK^TIULP(G | I GMRACW<1!($T(NEW^TIUPNAPI)']"") S GMRAOUT=1 D EXIT E I '$G(GMRAXBOS) D ASK S:Y<1 GMRAOUT=1 | E D ASK S:Y<1 GMRAOUT=1 .S GMRAPN=0 D NEW^TIUPNAPI(.GMRAPN,GMRADFN,GMRADUZ,GM | .S GMRAPN=0 D NEW^TIUPNAPI(.GMRAPN,GMRADFN,GMRADUZ,GM I GMRAPN=-1,'$G(GMRAXBOS) S GMRAOUT=1 W !,"No Progres | I GMRAPN=-1 S GMRAOUT=1 W !,"No Progress Note was cre I GMRAPN=0,'$G(GMRAXBOS) W !,"Progress note has not b | I GMRAPN=0 W !,"Progress note has not been signed." ; N GMRAI ;21 < S GMRAI=2 D ADDCOM("V",.GMRAI) ;21 | S ^TMP("TIUP",$J,0)=U_U_"2"_U_"2"_U_GMRADT_"^^^" S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" < N GMRAI,GMRAREAC ;21 | N I,X S GMRAREAC=0,GMRAI=3 F S GMRAREAC=$O(GMRAPA(GMRAREAC | S X=0,I=2 F S X=$O(GMRAPA(X)) Q:X<1 S I=I+1,^TMP("T .D ADDCOM("O",.GMRAI) ;21 | S ^TMP("TIUP",$J,1,0)="This patient has had the follo .S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)="" ;21 < S ^TMP("TIUP",$J,1,0)="This patient has had the follo < S ^TMP("TIUP",$J,3,0)="" ;21 | S ^TMP("TIUP",$J,0)=U_U_I_U_I_U_GMRADT_"^^^" S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" < N GMRAER,GMRAI ;21 | N GMRAER S GMRAI=2 D ADDCOM("E",.GMRAI) ;21 | S ^TMP("TIUP",$J,0)=U_U_"2"_U_"2"_U_GMRADT_"^^^" S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" < Q < ; < ADDCOM(TYPE,CNT) ;Add any comments to progress note - < N SUB,ENTRY < S ENTRY=$O(^GMR(120.8,GMRAPA,26,"AVER",TYPE,0)) Q:'+E < S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="",CNT=CNT+1,^TMP(" < S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="" < S SUB=0 F S SUB=$O(^GMR(120.8,GMRAPA,26,ENTRY,2,SUB) < diff -y --suppress-common-lines ./VADemo/r1/GMRARAD.m ./VADemo/r2/r/GMRARAD.m GMRARAD ;HIRMFO/RM-Radiology\ART Interface Routine ;12/8/04 | GMRARAD ;HIRMFO/RM-Radiology\ART Interface Routine ;12/28/93 ;;4.0;Adverse Reaction Tracking;**21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 S ^GMR(120.8,DA,13,0)="^120.813DA^1^1",^GMR(120.8,DA, < diff -y --suppress-common-lines ./VADemo/r1/GMRAROBS.m ./VADemo/r2/r/GMRAROBS.m GMRAROBS ;HIRMFO/RFM,WAA-OBSERVED REACTION DATA EDIT ; | GMRAROBS ;HIRMFO/RFM,WAA-OBSERVED REACTION DATA EDIT ; ;;4.0;Adverse Reaction Tracking;**8,21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;**8**;Mar 29, 1996 S DIE="^GMR(120.85,",DA=GMRAPA1,DR=".01;.5//"_$$GET1^ | S DIE="^GMR(120.85,",DA=GMRAPA1,DR=".01;.5//"_$P($G(^ S GMRAT=$$GET1^DIQ(200,DUZ_",","8","I") ;21 | S GMRAT=$P($G(^VA(200,DUZ,0)),U,9) S DR="43//"_$$GET1^DIQ(200,DUZ_",",".01")_";44;45;46; | S DR="43//"_$P(^VA(200,DUZ,0),U)_";44;45;46;47;48;49; S XMB(3)=$P(GMRAPA(0),U,2),XMB(4)=$$GET1^DIQ(200,DUZ_ | S XMB(3)=$P(GMRAPA(0),U,2),XMB(4)=$P($G(^VA(200,DUZ,0 N GMRACNT S GMRACNT=0 K ^TMP("TIUP",$J) D ADDCOM^GMRA < diff -y --suppress-common-lines ./VADemo/r1/GMRASEN2.m ./VADemo/r2/r/GMRASEN2.m GMRASEN2 ;HIRMFO/WAA-SEND ID BAND/CHART MARK TO BULLET | GMRASEN2 ;HIRMFO/WAA-SEND ID BAND/CHART MARK TO BULLET ;;4.0;Adverse Reaction Tracking;**14,19,21**;Mar 29, | ;;4.0;Adverse Reaction Tracking;**14**;Mar 29, 1996 .S GMRABULL=$$FIND1^DIC(3.8,,"BX","GMRA MARK CHART") | .S GMRABULL=$O(^XMB(3.8,"B","GMRA MARK CHART",0)) .I GMRABULL<1 D:'$D(ZTQUEUED)&('$$BROKER^XWBLIB) Q | .I GMRABULL<1 D:'$D(ZTQUEUED) Q .I '$$GOTLOCAL^XMXAPIG(GMRABULL) D:'$D(ZTQUEUED)&('$$ | .I +$P($G(^XMB(3.8,GMRABULL,1,0)),U,4)=0 D:'$D(ZTQUEU .E S GMRASEND("G.GMRA MARK CHART")="" ;19 | .E S GMRASND=0 F S GMRASND=$O(^XMB(3.8,GMRABULL,1,G I '($D(XMY)\10) W:'$D(ZTQUEUED)&('$$BROKER^XWBLIB) !, | I '($D(XMY)\10) W:'$D(ZTQUEUED) !,"CALL IRM THERE IS S XMB(1)=GMRANAM,XMB(3)=$S(GMRALOC'="":GMRALOC,1:"Out | S XMB(1)=GMRANAM,XMB(3)=$S(GMRALOC'="":GMRALOC,1:"Out .S GMRAPA2=0 S XMTEXT="GMRAPA2",GMRAPA2(.4)="" ;21 | .S GMRAPA2=0 S XMTEXT="GMRAPA2(",GMRAPA2(.4)="" S XMB(6)="chart (due to admission)",XMB(7)="chart" ;2 | D ^XMB M GMRAXMB=XMB,GMRAXMY=XMY ;21 < D SENDBULL^XMXAPI(DUZ,"GMRA MARK CHART",.GMRAXMB,$G(X < diff -y --suppress-common-lines ./VADemo/r1/GMRASEND.m ./VADemo/r2/r/GMRASEND.m GMRASEND ;HIRMFO/WAA-SEND ID BAND/CHART MARK TO BULLET | GMRASEND ;HIRMFO/WAA-SEND ID BAND/CHART MARK TO BULLET ;;4.0;Adverse Reaction Tracking;**14,19,21**;Mar 29, | ;;4.0;Adverse Reaction Tracking;**14**;Mar 29, 1996 .S GMRABULL=$$FIND1^DIC(3.8,,"BX","GMRA MARK CHART") | .S GMRABULL=$O(^XMB(3.8,"B","GMRA MARK CHART",0)) .I GMRABULL<1 D:'$D(ZTQUEUED)&('$$BROKER^XWBLIB) Q | .I GMRABULL<1 D:'$D(ZTQUEUED) Q .I '$$GOTLOCAL^XMXAPIG(GMRABULL) D:'$D(ZTQUEUED)&('$$ | .I +$P($G(^XMB(3.8,GMRABULL,1,0)),U,4)=0 D:'$D(ZTQUEU .E S GMRASEND("G.GMRA MARK CHART")="" ;19 | .E S GMRASND=0 F S GMRASND=$O(^XMB(3.8,GMRABULL,1,G I '($D(XMY)\10) W:'$D(ZTQUEUED)&('$$BROKER^XWBLIB) !, | I '($D(XMY)\10) W:'$D(ZTQUEUED) !,"CALL IRM THERE IS S XMB(1)=GMRANAM,XMB(3)=$S(GMRALOC'="":GMRALOC,1:"Out | S XMB(1)=GMRANAM,XMB(3)=$S(GMRALOC'="":GMRALOC,1:"Out N GMRACHT,GMRAID ;21 | D ^XMB S GMRACHT=$O(^GMR(120.8,GMRAPA,13,0)),GMRAID=$S('$P(G < S (XMB(6),XMB(7))=$S('GMRACHT&('GMRAID):"chart and ID < I XMB(6)="" Q ;21 Don't send bulletin if it's not ne < N GMRAXMB,GMRAXMY ;19 < M GMRAXMB=XMB,GMRAXMY=XMY ;19 < D SENDBULL^XMXAPI(DUZ,"GMRA MARK CHART",.GMRAXMB,,.GM < diff -y --suppress-common-lines ./VADemo/r1/GMRASIG1.m ./VADemo/r2/r/GMRASIG1.m GMRASIG1 ;HIRMFO/WAA-A/AR PATIENT SIGN OFF PART2 ;11/1 | GMRASIG1 ;HIRMFO/WAA-A/AR PATIENT SIGN OFF PART2 ; 1/7 ;;4.0;Adverse Reaction Tracking;**2,17,21**;Mar 29, 1 | ;;4.0;Adverse Reaction Tracking;**2**;Mar 29, 1996 W !,"ADVERSE REACTION",!,"----------------" ;21 | W !,"ADVERSE REACTION",!,"----------------",! .W ! W:GMRACNTT>1 GMRACNT,")" ;21 | .W ! I GMRASIGN W:GMRACNTT>1 GMRACNT,")" .W " ",$P(GMRAG,U,2),! ;21 | .W " ",$P(GMRAG,U,2) .W !,?11,"Obs/Hist:",?21,$S($P(GMRAG,U,6)="o":"OBSERV < ..S GMRAREC=0 F S GMRAREC=$O(^GMR(120.8,GMRAPA,10,GM | ..S GMRAREC=0 F S GMRAREC=$O(^GMR(120.8,GMRAPA,10,GM ...S X=$G(^GMR(120.8,GMRAPA,10,GMRAREC,0)),GMRAREC(GM < ...I $P(X,U,4)>0 S $P(GMRAREC(GMRAREC),U,2)=$$FMTE^XL < ...Q ;21 < .I $D(GMRAREC)=11 S GMRAREC=$O(GMRAREC("")) W !,?5,"S | .I $D(GMRAREC)=11 S GMRAREC=$O(GMRAREC("")) W ?30,"Re .;W ?65,$S($P(GMRAG,U,6)="o":"OBSERVED",$P(GMRAG,U,6) | .W ?65,$S($P(GMRAG,U,6)="o":"OBSERVED",$P(GMRAG,U,6)= .I $G(GMRAREC)>0 F S GMRAREC=$O(GMRAREC(GMRAREC)) Q: | .I $G(GMRAREC)>0 F S GMRAREC=$O(GMRAREC(GMRAREC)) Q: W (GMRACNTT+1),") All of the above",! ;17 | W (GMRACNT+1),") All of the above",! W (GMRACNTT+2),") None of the above",! ;17 | W (GMRACNT+2),") None of the above",! K DIR S DIR(0)="L^1:"_(GMRACNTT+2),GMRALL=GMRACNTT+1, | K DIR S DIR(0)="L^1:"_(GMRACNT+2),GMRALL=GMRACNT+1,GM diff -y --suppress-common-lines ./VADemo/r1/GMRASIGN.m ./VADemo/r2/r/GMRASIGN.m GMRASIGN ;HIRMFO/WAA-ALLERGY/ADVERSE REACTION PATIENT | GMRASIGN ;HIRMFO/WAA-ALLERGY/ADVERSE REACTION PATIENT ;;4.0;Adverse Reaction Tracking;**17,19**;Mar 29, 199 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 N GMRAOUT,GMRACNTT S GMRAOUT=0 ;19 < N GMRATYPE ;19 < ..D INP^VADPT S X=$$FIND1^DIC(101,,"BX","GMRA SIGN-OF | ..D INP^VADPT S X=$O(^ORD(101,"B","GMRA SIGN-OFF ON D D REMAIN ;D DEL^GMRADEL ; Ask user if they want to de | D DEL^GMRADEL ; Ask user if they want to delete given ; < REMAIN ;Review remaining entries that were not signed off. < N GMRAPA,LCVJ,Y,DIR,DIRUT,DUOUT,SIGNED,GMRAOUT,GMRANE < S SIGNED="" < S LCVJ=0 F S LCVJ=$O(^TMP($J,"GMRASF",LCVJ)) Q:'+LCV < .S GMRAPA=$O(^TMP($J,"GMRASF",LCVJ,0)) Q:'+GMRAPA S < .S DIR(0)="SB^Edit:Edit;Delete:Delete",DIR("B")="Edit < .S DIR("A")="For reactant "_$P(GMRAPA(0),U,2) D ^DIR < .I $E(Y)="D" Q ;Do nothing if allergy is to be delet < .S GMRANEW=0 < .F D Q:DONE < ..S DONE=0,GMRAOUT=0 < ..D EDIT^GMRAPEM4 W ! < ..I $P(^GMR(120.8,GMRAPA,0),U,6)="o" I '$D(^GMR(120.8 < ...W !,"Observed reactions require the date of the re < ...S DIR(0)="SA^R:Re-edit;D:Delete",DIR("A")="Do you < ..I $P(^GMR(120.8,GMRAPA,0),U,6)="h",$D(^GMR(120.85," < ..S DIR(0)="Y",DIR("A")="Is this entry now correct",D < ..I Y=0 Q < ..I $G(DIRUT) S DONE=1 Q < ..S SIGNED=SIGNED_LCVJ_",",DONE=1 < I $L(SIGNED)>1 D RANGE(SIGNED) ;Sign off on accepted < I $O(^TMP($J,"GMRASF",0)) D DELETE^GMRADEL ;Delete un < Q < ; < DELOBS ;Delete observed data from 120.85 < N OIEN,DIK,DA < S OIEN=0 F S OIEN=$O(^GMR(120.85,"C",GMRAPA,OIEN)) Q < Q < diff -y --suppress-common-lines ./VADemo/r1/GMRAU851.m ./VADemo/r2/r/GMRAU851.m GMRAU851 ;HIRMFO/RFM,WAA-UTILITIES FOR FILE 120.85 ;12 | GMRAU851 ;HIRMFO/RFM,WAA-UTILITIES FOR FILE 120.85 ; 1 ;;4.0;Adverse Reaction Tracking;**21**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 N GMRAR0 ;21 < D EN1^GMRAPER0 Q:GMRAOUT S:'$D(^GMR(120.85,GMRAPA1,2 | D EN1^GMRAPER0 Q:GMRAOUT S:'$D(^GMR(120.85,GMRAPA1,2 F GMRAREC=0:0 S GMRAREC=$O(GMRARAD(GMRAREC)) Q:GMRARE | S GMRAREC="" F GMRAX=0:0 S GMRAREC=$O(GMRAROT(GMRAREC S GMRAREC="" F GMRAX=0:0 S GMRAREC=$O(GMRAROT(GMRAREC | S DA(1)=GMRAPA1,DIK="^GMR(120.85,"_DA(1)_",2," F GMRA F GMRAREC=0:0 S GMRAREC=$O(GMRARDL(GMRAREC)) Q:GMRARE | S GMRAREC="" F GMRAX=0:0 S GMRAREC=$O(GMRAROTD(GMRARE S GMRAREC="" F GMRAX=0:0 S GMRAREC=$O(GMRAROTD(GMRARE < S ^GMR(120.85,GMRAPA1,2,DA,0)=GMRAR0 S DIK="^GMR(120. | S ^GMR(120.85,GMRAPA1,2,DA,0)=X S DIK="^GMR(120.85,DA S GMRAZN=$P(^GMR(120.8,GMRAPA,10,0),"^",3,4),DA=$P(GM < S ^GMR(120.8,GMRAPA,10,DA,0)=GMRAR0_"^"_DT S DIK="^GM < Q < ; < DELREAC ;Delete reactions from 120.85 and 120.8 entire sectio < S DA(1)=GMRAPA1,DIK="^GMR(120.85,"_DA(1)_",2," < F DA=0:0 S DA=$O(^GMR(120.85,DA(1),2,"B",GMRAREC,DA)) < S DA(1)=GMRAPA,DIK="^GMR(120.8,"_DA(1)_",10," < F DA=0:0 S DA=$O(^GMR(120.8,DA(1),10,"B",GMRAREC,DA)) < Q < ; < DELREACO ;Delete free text reactions, added in 21 < S DA(1)=GMRAPA1,DIK="^GMR(120.85,"_DA(1)_",2," < F DA=0:0 S DA=$O(^GMR(120.85,DA(1),2,"B",GMRAOTH,DA)) < S DA(1)=GMRAPA,DIK="^GMR(120.8,"_DA(1)_",10," < F DA=0:0 S DA=$O(^GMR(120.8,DA(1),10,"B",GMRAOTH,DA)) < diff -y --suppress-common-lines ./VADemo/r1/GMRAUTL.m ./VADemo/r2/r/GMRAUTL.m GMRAUTL ;HIRMFO/YMP,RM,WAA-ALLERGY UTILITIES ;7/28/03 08:40 | GMRAUTL ;HIRMFO/YMP,RM,WAA-ALLERGY UTILITIES ;12/1/95 15:37 ;;4.0;Adverse Reaction Tracking;**17**;Mar 29, 1996 | ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 S DIR(0)="LA^1:3",DIR("A",1)=" 1 Drug",DIR("A",2)= | S DIR(0)="LA^1:3",DIR("A",1)=" 1 Drug",DIR("A",2)= S:$D(DIRUT) GMRAOUT=1,GMRASP=0 | S:$D(DIRUT) GMRAOUT=1 diff -y --suppress-common-lines ./VADemo/r1/GMRAVAM0.m ./VADemo/r2/r/GMRAVAM0.m GMRAVAM0 ;HIRMFO/YMP,WAA,RM-DRIVER FOR VERIFIER ;7/30/ | GMRAVAM0 ;HIRMFO/YMP,WAA,RM-DRIVER FOR VERIFIER ;7/30/ ;;4.0;Adverse Reaction Tracking;**11,21**;Mar 29, 199 | ;;4.0;Adverse Reaction Tracking;**11**;Mar 29, 1996 I $G(GMRAERR),$G(GMRAOUT) S GMRAOUT=0 ;21 < diff -y --suppress-common-lines ./VADemo/r1/GMRCA1.m ./VADemo/r2/r/GMRCA1.m GMRCA1 ;SLC/DLT,DCM - Actions taken from Review Screens ; 7/ | GMRCA1 ;SLC/DLT,DCM - Actions taken from Review Screens ; 11 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,18,35**;DE | ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,18**;DEC 2 I '$G(GMRCA) D Q | I '$G(GMRCA) S GMRCMSG="This Action not defined!" D E . S GMRCMSG="This Action not defined!" < . D EXAC^GMRCADC(GMRCMSG) < . D END < . S GMRCQUT=1 < I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D Q < . N DIR < . W !,"The requesting facility may not take this acti < . W "inter-facility consult." < . S DIR(0)="E" D ^DIR < . D END < . S GMRCQUT=1 < diff -y --suppress-common-lines ./VADemo/r1/GMRCACMT.m ./VADemo/r2/r/GMRCACMT.m GMRCACMT ;SLC/DLT,DCM,MA,JFR - Comment Action and aler | GMRCACMT ;SLC/DLT,DCM,MA - Comment Action and alerting ;;3.0;CONSULT/REQUEST TRACKING;**4,14,18,20,22,29,35* | ;;3.0;CONSULT/REQUEST TRACKING;**4,14,18,20,22,29**;D ; < I '$L(GMRCORTX) D | S GMRCORTX=$S($L(GMRCORTX):GMRCORTX,1:"Comment Added . N TXT < . S TXT="Comment Added to " < . I $P($G(^GMR(123,GMRCO,12)),U,5)='"P" S GMRCORTX=TX < . S GMRCORTX=TXT_"remote consult " < S GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCO) < Only in ./VADemo/r1/: GMRCAD31.m diff -y --suppress-common-lines ./VADemo/r1/GMRCADC.m ./VADemo/r2/r/GMRCADC.m GMRCADC ;SLC/DLT/DCM - DC taken from List Manager ;8/07/03 14 | GMRCADC ;SLC/DLT/DCM - Discontinue Action taken from List Man ;;3.0;CONSULT/REQUEST TRACKING;**1,5,10,12,35**;DEC 2 | ;;3.0;CONSULT/REQUEST TRACKING;**1,5,10,12**;DEC 27, N ND,X | N ND W $C(7),!,MSG I $O(MSG(0)) S ND=0 F S ND=$O(MSG(ND)) | W $C(7),!,MSG I $O(MSG(0)) S ND=0 F S ND=$O(MSG(ND)) . W !,MSG(ND) < N GMRCDA,GMRCACTM,GMRCADUZ,GMRCSERV,GMRCAD,GMRC | N GMRCDA,GMRCACTM,GMRCADUZ,GMRCSERV,GMRCAD I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D Q < . N DIR < . W !,"The requesting facility may not take this acti < . W "inter-facility consult." < . S DIR(0)="E" D ^DIR < . S GMRCQUT=1 < I $D(GMRCA),+GMRCA S GMRCACTM=$S(GMRCA=6:"Discontinue | I $D(GMRCA),+GMRCA S GMRCACTM=$S(GMRCA=6:"Discontinue N DIROUT,DTOUT,DUOUT,GMRCMSG,GMRCFL < diff -y --suppress-common-lines ./VADemo/r1/GMRCAFRD.m ./VADemo/r2/r/GMRCAFRD.m GMRCAFRD ;SLC/DLT,DCM,JFR - LM FORWARD ACTION ;7/11/03 | GMRCAFRD ;SLC/DLT,DCM,JFR - LM FORWARD ACTION ;1/8/02 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,22,35** | ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,22**;DE I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D Q < . N DIR < . W !,"The requesting facility may not take this acti < . W "inter-facility consult." < . S DIR(0)="E" D ^DIR < . D END < . S GMRCQUT=1 < diff -y --suppress-common-lines ./VADemo/r1/GMRCASF.m ./VADemo/r2/r/GMRCASF.m GMRCASF ;SLC/DLT - Significant Findings Action ;7/11/03 13:28 | GMRCASF ;SLC/DLT - Significant Findings Action ;11/15/02 07:2 ;;3.0;CONSULT/REQUEST TRACKING;**4,10,14,22,29,35**;D | ;;3.0;CONSULT/REQUEST TRACKING;**4,10,14,22,29**;DEC I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D Q < . N DIR < . W !,"The requesting facility may not take this acti < . W "inter-facility consult." < . S DIR(0)="E" D ^DIR < . D END < diff -y --suppress-common-lines ./VADemo/r1/GMRCEDT1.m ./VADemo/r2/r/GMRCEDT1.m GMRCEDT1 ;SLC/DCM,JFR - EDIT A CONSULT AND RE-SEND AS | GMRCEDT1 ;SLC/DCM,JFR - EDIT A CONSULT AND RE-SEND AS ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33**;DE | ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22**;DEC 2 ; This routine invokes IA #2638,#3991 | ; This routine invokes IA #2638 . I '$$STATCHK^ICDAPIU(^GMR(123,GMRCO,30.1),DT) D < .. S GMRCDIAG=GMRCDIAG_" " < diff -y --suppress-common-lines ./VADemo/r1/GMRCEDT2.m ./VADemo/r2/r/GMRCEDT2.m GMRCEDT2 ;SLC/JFR,DCM - RESUBMIT A CANCELLED CONSULT ; | GMRCEDT2 ;SLC/JFR,DCM - RESUBMIT A CANCELLED CONSULT ; ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33**;DE | ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22**;DEC 2 I '$$PDOK^GMRCEDT4(GMRCO) D Q < . D EXAC^GMRCADC("Can't resubmit!") < . S GMRCRSUB=1 < . Q < diff -y --suppress-common-lines ./VADemo/r1/GMRCEDT4.m ./VADemo/r2/r/GMRCEDT4.m GMRCEDT4 ;SLC/DCM,JFR - UTILITIES FOR EDITING FIELDS ; | GMRCEDT4 ;SLC/DCM,JFR - UTILITIES FOR EDITING FIELDS ; ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33**;DE | ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22**;DEC 2 ; < ; This routine invokes IA #3991 < ; < I $$PDOK(GMRCO) < H 2 | H 2 Q > I +$P(^GMR(123,+GMRCO,0),U,17)'="P" D Q > . W !,"Procedures may only be selected for Procedure > . H 2 > N DIC,PROCED,X,Y,D > S DIC=101.43,DIC(0)="AEQZ",D="S.PROC",DIC("B")=$P(GMR > S DIC("A")="Select Procedure: " > S DIC("S")="I $D(^GMR(123.3,+$P(^(0),U,2),2,""B"",+GM > D IX^DIC > I $D(DUOUT)!($D(DTOUT)) Q > I Y<1!(+$P(Y(0),U,3)=$P(GMRCPROC,U,2)) W !,$$NOCHG,! > S PROCED=+$P(Y(0),U,2)_U_$$UP^XLFSTR($P(Y(0),U)) > I '$D(^GMR(123.5,"APR",+PROCED,+GMRCSS)) D > . ;never executed; service non-editable > . N GMRCEDD1,GMRCSSV,GMRCPROC > . W !,"The service is no longer appropriate for this > . S GMRCSSV=GMRCSS,GMRCPROC=PROCED > . S:$D(GMRCEDT(1)) GMRCEDD1=GMRCEDT(1) > . D 01 > . I '$D(^GMR(123.3,+PROCED,2,"B",+GMRCSS)) D > .. W !,$C(7),"Unable to change procedure.",! > .. K PROCED,GMRCEDT(1) S GMRCSS=GMRCSSV > .. I $D(GMRCEDD1) S GMRCEDT(1)=GMRCEDD1 > I $D(PROCED) S (GMRCPROC,GMRCED(1))=PROCED . N DIR,X,Y,DTOUT,DUOUT,VAL | . D CONFIG^LEXSET("ICD","ICD") . I $D(GMRCED(6)) D | . S DIR(0)="PA"_$S($P(PRMPT,U)'="R":"O",1:"")_"^757.0 .. I '$L($P(GMRCED(6),U,2)) S DIR("B")=$P(GMRCED(6),U < .. S DIR("B")=$P(GMRCED(6),U)_" ("_$P(GMRCED(6),U,2)_ < . I '$D(DIR("B")) S DIR("B")=$G(^GMR(123,GMRCO,30)) < . K:'$L(DIR("B")) DIR("B") < . S DIR("?")="Enter a code or term for the provisiona < . S DIR(0)="FA"_$S($P(PRMPT,U)'="R":"O",1:"")_"^1:180 | . I $D(GMRCED(6)) S DIR("B")=$P(GMRCED(6),U) . D ^DIR | . I '$D(DIR("B")),$D(^GMR(123,+GMRCO,30.1)) D . I $D(DTOUT)!($D(DUOUT)) Q | .. S DIR("B")=$P(^GMR(123,GMRCO,30),(" ("_^(30.1)_")" . I '$L(Y) W !,?5,"",! S GMRCED(6)="" Q | . D ^DIR Q:$D(DTOUT)!($D(DUOUT)) . I Y=$G(DIR("B")) Q | . I $G(^GMR(123,GMRCO,30.1)),$D(Y(1)),^(30.1)=Y(1) Q . I $E(Y,1)=" " W !,"Leading space not allowed, no ch | . S GMRCED(6)=$S(Y=-1:"",1:$P(Y,U,2)_U_$G(Y(1))) . S VAL=$$LEXLKUP(Y) | . ;I $D(GMRCED(6)) S $P(GMRCED(6),U,2)=$G(Y(1)) . I '$L(VAL),$P(PRMPT,U)="R" W !,"Prov. DX required. | . Q . I VAL=$G(^GMR(123,GMRCO,30)) W !,"No change." Q | Q . I ($P(VAL,U)_" ("_$P(VAL,U,2)_")")=$G(^GMR(123,GMRC < .. W !,"No change." < . I '$L(VAL) W !,?5,"",! < . S GMRCED(6)=VAL < Q < ; < LEXLKUP(GMRCX) ; run input through the Lexicon < ; < N DIC,X,Y,DUOUT,DTOUT < D CONFIG^LEXSET("ICD","ICD",DT) < S DIC="^LEX(757.01,",DIC(0)="EQM",DIC("B")=GMRCX,X=GM < D ^DIC < I $D(DTOUT)!($D(DUOUT))!($G(Y)<1) Q "" < Q $P(Y,U,2)_U_Y(1) < ; < PDOK(GMRCDA) ;check validity of Prov. DX code for active s < N MSG < I '$L($G(^GMR(123,GMRCDA,30.1))) Q 1 < I +$$STATCHK^ICDAPIU(^GMR(123,GMRCDA,30.1),DT) Q 1 ;c < S MSG="The provisional DX code must be edited before < S MSG=MSG_" may be resubmitted." < D EN^DDIOL(MSG,,"!!") < Q 0 < diff -y --suppress-common-lines ./VADemo/r1/GMRCGUIA.m ./VADemo/r2/r/GMRCGUIA.m GMRCGUIA ;SLC/DCM,JFR - File Consult actions from GUI | GMRCGUIA ;SLC/DCM,JFR - File Consult actions from GUI ;;3.0;CONSULT/REQUEST TRACKING;**1,4,12,15,22,35**;DE | ;;3.0;CONSULT/REQUEST TRACKING;**1,4,12,15,22**;DEC 2 . S DR=".07////^S X=GMRCIROU;.125////^S X=GMRCIROL;.1 | . S DR=".07////^S X=GMRCIROU;.125////^S X=GMRCIROL;" diff -y --suppress-common-lines ./VADemo/r1/GMRCGUIB.m ./VADemo/r2/r/GMRCGUIB.m GMRCGUIB ;SLC/DCM,JFR,MA - GUI actions for consults ;8 | GMRCGUIB ;SLC/DCM,JFR,MA - GUI actions for consults ;1 ;;3.0;CONSULT/REQUEST TRACKING;**4,12,18,20,17,22,29, | ;;3.0;CONSULT/REQUEST TRACKING;**4,12,18,20,17,22,29, I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D | S GMRCORTX=GMRCORTX_$$GET1^DIQ(123.5,$P(^GMR(123,+GMR . S GMRCORTX="Comment Added to remote consult " < S GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCO) < diff -y --suppress-common-lines ./VADemo/r1/GMRCGUIC.m ./VADemo/r2/r/GMRCGUIC.m GMRCGUIC ;SLC/DCM,JFR - GUI actions for editing consul | GMRCGUIC ;SLC/DCM,JFR - GUI actions for editing consul ;;3.0;CONSULT/REQUEST TRACKING;**4,12,20,15,22,33**;D | ;;3.0;CONSULT/REQUEST TRACKING;**4,12,20,15,22**;DEC ; This routine invokes IA #2398,#2698,#2713,#2960,#39 | ; This routine invokes IA #2398,#2698,#2713,#2960 . I '$$STATCHK^ICDAPIU($P(GMRCDIAG,U,2),DT) S GMRCDIA < diff -y --suppress-common-lines ./VADemo/r1/GMRCHL7A.m ./VADemo/r2/r/GMRCHL7A.m ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,21,22,33** | ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,21,22**;DE ; < ; < N GMRCTRLC,GMRCAD,ORC,GMRCSBR,GMRCZSS,GMRCSS,GMRCOTXT | N GMRCTRLC,GMRCAD,ORC,GMRCSBR,GMRCZSS,GMRCSS,GMRCOTXT N GMRCREJ,GMRCRECV < I GMRCTRLC="NW" D NEW^GMRCHL7B(.GMRCREJ) D | I GMRCTRLC="NW" D NEW^GMRCHL7B D . D REJECT^GMRCHL7U(.MSG,$G(GMRCREJ)) | . D REJECT^GMRCHL7U(.MSG,"unable to file order") > I $D(GMRCXMF) D > .;Set GMRCO=to the file number at this site for a new > .S GMRCNOD=0 F S GMRCNOD=$O(@GMRCMSG(ND)) Q:GMRCNOD= > .Q diff -y --suppress-common-lines ./VADemo/r1/GMRCHL7B.m ./VADemo/r2/r/GMRCHL7B.m GMRCHL7B ;SLC/DCM,MA,JFR - Process data from GMRCHL7A | GMRCHL7B ;SLC/DCM,MA - Process order parameters from ^ ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,17,22,33** | ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,21,17,22**;DE ; | ; Patch #21 changed Activity title on Consult detail ; This routine invokes IA #3991 | ; from "ENTERED IN CPRS" to "CPRS RELEASED ORDER". ; | NEW ;Add new order NEW(MESSAGE) ;Add new order < ; < ; Output: < ; MESSAGE = rejection message if problems encounte < ; < ; check for inactive ICD-9 code in Prov. DX < I $L($G(GMRCPRCD)) D I $D(MESSAGE) Q ; rejected due < . I +$$STATCHK^ICDAPIU(GMRCPRCD,DT) Q ;code is OK < . S MESSAGE="Provisional DX code is inactive. Unable < ; < Q:'$D(^GMR(123,+GMRCO,0)) < diff -y --suppress-common-lines ./VADemo/r1/GMRCIAC2.m ./VADemo/r2/r/GMRCIAC2.m GMRCIAC2 ;SLC/JFR - FILE IFC ACTIVITIES CONT'D ;07/08/ | GMRCIAC2 ;SLC/JFR - FILE IFC ACTIVITIES CONT'D ;09/05/ ;;3.0;CONSULT/REQUEST TRACKING;**22,28,35**;DEC 27, 1 | ;;3.0;CONSULT/REQUEST TRACKING;**22,28**;DEC 27, 1997 . D UNHLNAME^GMRCIUTL($P(GMRCORC,"|",10),.GMRCEP,0,U) | . D UNHLNAME^GMRCIUTL($P(GMRCORC,"|",10),.GMRCEP,1,U) . D UNHLNAME^GMRCIUTL($P(GMRCORC,"|",12),.GMRCRP,0,U) | . D UNHLNAME^GMRCIUTL($P(GMRCORC,"|",12),.GMRCRP,1,U) diff -y --suppress-common-lines ./VADemo/r1/GMRCIBKG.m ./VADemo/r2/r/GMRCIBKG.m GMRCIBKG ;SLC/JFR - IFC BACKGROUND ERROR PROCESSOR; 07 | GMRCIBKG ;SLC/JFR - IFC BACKGROUND ERROR PROCESSOR; 10 ;;3.0;CONSULT/REQUEST TRACKING;**22,28,30,35**;DEC 27 | ;;3.0;CONSULT/REQUEST TRACKING;**22,28,30**;DEC 27, 1 ... D DELALRT(GMRCLOG) ;delete previous alerts on sam < diff -y --suppress-common-lines ./VADemo/r1/GMRCIERR.m ./VADemo/r2/r/GMRCIERR.m GMRCIERR ;SLC/JFR - process IFC message error alert ;0 | GMRCIERR ;SLC/JFR - process IFC message error alert ;1 ;;3.0;CONSULT/REQUEST TRACKING;**22,28,30,35**;DEC 27 | ;;3.0;CONSULT/REQUEST TRACKING;**22,28,30**;DEC 27, 1 > K ^TMP("GMRCIERR",$J) . D TRIGR^GMRCIEVT($P(GMRCDATA,"|",2),$P(GMRCDATA,"|" | . D TRIGR^GMRCIEVT($P(GMRCDATA,"|",2),$P(GMRCDATA,"|" S DIR("A")="Do you want to delete this alert for all | S DIR("A")="Do you want to delete this alert for your D ^DIR < I $G(Y)=1 Q 0 < W ! < S DIR(0)="YA",DIR("B")="N" < S DIR("A")="Do you want to delete this alert for your < K ^TMP("GMRCIERR",$J) < > ; diff -y --suppress-common-lines ./VADemo/r1/GMRCP5D.m ./VADemo/r2/r/GMRCP5D.m GMRCP5D ;SLC/DCM,RJS,JFR - Print Consult form 513 (Gather Dat | GMRCP5D ;SLC/DCM,RJS,JFR - Print Consult form 513 (Gather Dat ;;3.0;CONSULT/REQUEST TRACKING;**4,12,15,22,29,35**;D | ;;3.0;CONSULT/REQUEST TRACKING;**4,12,15,22,29**;Dec .N GMRCR1,GMRC400,CMT,USER,GMRCDT,RPRV,GMRC402,GMRCIS | .N GMRCR1,GMRC400,CMT,USER,GMRCDT,RPRV,GMRC402 .I $P(^GMR(123,GMRCIFN,0),U,23) D < ..S GMRCISIT=$$GET1^DIQ(4,$P(^GMR(123,GMRCIFN,0),U,23 < ..S GMRCISIT="Entered at: "_GMRCISIT < .D:($L($G(GMRCISIT))) BLD("COM",GMRCR0,1,5,GMRCISIT) < diff -y --suppress-common-lines ./VADemo/r1/GMRCSLM1.m ./VADemo/r2/r/GMRCSLM1.m ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,17,22,3 | ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,17,22** .I $D(GMRCDT1)&($D(GMRCDT2)),GMRCDT1'="ALL" S LNCT=LN | .I GMRCDT1'="ALL",$D(GMRCDT1)&($D(GMRCDT2)) S LNCT=LN diff -y --suppress-common-lines ./VADemo/r1/GMRCTIU1.m ./VADemo/r2/r/GMRCTIU1.m GMRCTIU1 ;SLC/JER - More CT/TIU interface modules ;7/9 | GMRCTIU1 ;SLC/JER - More CT/TIU interface modules ;9/1 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,21,17,34**;DEC 2 | ;;3.0;CONSULT/REQUEST TRACKING;**1,4,21,17**;DEC 27, ; < ;This routine invokes IA #2693 < N DIE,DR,GMRCSTS,GMRCA,GMRCO,GMRCOM,GMRCORNP,GMRCDFN, | N DIE,DR,GMRCSTS,GMRCA,GMRCO,GMRCOM,GMRCORNP,GMRCDFN, ;Following if statement and DO block accomplish the f | I '$G(GMRCLIST(0)) S GMRCSTS=6 ;If there are no other associated TIU Docs then < ;Set status to scheduled if it was last status before < ;Set status to pending if it was the last status befo < ;Set status to active otherwise < I '$G(GMRCLIST(0)) S GMRCSTS=6 D < .S ACTDA=0,ACTREC=0,GMRCRBDA=0,GMRCLER=-1,GMRCLSCH=-1 < .F S ACTDA=$O(^GMR(123,DA,40,ACTDA)) Q:-ACTDA=0 D < ..S ACTREC=$G(^GMR(123,DA,40,ACTDA,0)) < ..I $P(ACTREC,U,2)=9,$P($P(ACTREC,U,9),";",1)=TIUDA S < ..I $P(ACTREC,U,2)=8 S GMRCLSCH=ACTDA < ..I $P(ACTREC,U,2)=11 S GMRCLER=ACTDA < .I GMRCLER'=-1,GMRCLER>GMRCLSCH S GMRCSTS=5 < .I GMRCLSCH'=-1,GMRCLSCH>GMRCLER S GMRCSTS=8 < ;Make status completed if the Consult was Admin. Comp < S ACTDA=0,ACTREC=0 < F S ACTDA=$O(^GMR(123,DA,40,ACTDA)) Q:-ACTDA=0 D < .S ACTREC=$G(^GMR(123,DA,40,ACTDA,0)) < .I $P(ACTREC,U,2)=10,$P(ACTREC,U,9)="" S GMRCSTS=2 < S GMRCTDA=TIUDA | D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,23,.GMRCADUZ,MSGT D EXTRACT^TIULQ(GMRCTDA,"GMRCSTAR",.GMRCERR,.05) < I '$G(GMRCERR) D < .I $G(GMRCSTAR(GMRCTDA,.05,"I"))'=5 D < ..D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,23,.GMRCADUZ,MS < . S GMRCDATA=GMRCDATA_"|"_$G(GMRCRSLT) | . I $$PATCH^XPDUTL("OR*3.0*116") D ;GUI v17 present > .. S GMRCDATA=GMRCDATA_"|"_$G(GMRCRSLT) diff -y --suppress-common-lines ./VADemo/r1/GMRCTIUE.m ./VADemo/r2/r/GMRCTIUE.m GMRCTIUE ;SLC/DCM,DLT,JFR - Complete/Update TIU notes | GMRCTIUE ;SLC/DCM,DLT,JFR - Complete/Update TIU notes ;;3.0;CONSULT/REQUEST TRACKING;**4,10,14,12,15,17,35* | ;;3.0;CONSULT/REQUEST TRACKING;**4,10,14,12,15,17**;D I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D D EDEX Q < . N DIR < . W !,"The requesting facility may not complete an in < . W "consult." < . S DIR(0)="E" D ^DIR < > ; ***Insert logic for being admin and update user**** > ; . N DIRUT < . D COMP^GMRCAAC(+GMRCO) S GMRCQIT=1 | . D COMP^GMRCAAC(+GMRCO) S GMRCQIT=1 . N DUOUT,DTOUT,DIROUT,DIRUT,X,Y,DIR | . N DUOUT,DTOUT,X,Y,DIR . N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT | . N DIR,X,Y,DTOUT,DUOUT diff -y --suppress-common-lines ./VADemo/r1/GMRCYP31.m ./VADemo/r2/r/GMRCYP31.m ;;3.0;CONSULT/REQUEST TRACKING;**31,32**;DEC 27, 1997 | ;;3.0;CONSULT/REQUEST TRACKING;**31**;DEC 27, 1997 ; < ; Re-distributed with GMRC*3*32 to address error with < ; to print when sent to a printer. < . I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" D ^DIR | . N DIR S DIR(0)="E" D ^DIR diff -y --suppress-common-lines ./VADemo/r1/GMRVED2.m ./VADemo/r2/r/GMRVED2.m GMRVED2 ;HIOFO/RM,YH,FT-VITAL SIGNS EDIT SHORT FORM ;11/15/04 | GMRVED2 ;HIRMFO/RM,YH-VITAL SIGNS EDIT SHORT FORM ;8/14/02 1 ;;5.0;GEN. MED. REC. - VITALS;**2**;Oct 31, 2002 | ;;4.0;Vitals/Measurements;**7,14**;Apr 25, 1997 ; #10103 - ^XLFDT calls (supported) < ADDNODE ; add data to the 120.5 file | ADDNODE ; ADD DATA TO THE 120.5 FILE N GMVDTDUN,GMVFDA,GMVIEN | S GMRVIT(1)=$O(^GMRD(120.51,"B",GMRVIT,0)),DA=$P(^GMR S GMVDTDUN=GMRVIDT | B1 S DA=DA+1 L +^GMR(120.5,DA,0):1 I '$T!$D(^GMR(120.5,D S GMRVIT(1)=$O(^GMRD(120.51,"B",GMRVIT,0)) | S $P(^GMR(120.5,0),"^",3,4)=DA_"^"_($P(^GMR(120.5,0), S GMVDTDUN=$$CHKDT(GMRVIDT,GMRVIT(1)) | S ^GMR(120.5,DA,0)=GMRVIDT_"^"_DFN_"^"_GMRVIT(1)_"^"_ S GMVFDA(120.5,"+1,",.01)=GMVDTDUN ;Date/Time < S GMVFDA(120.5,"+1,",.02)=DFN ;Patient < S GMVFDA(120.5,"+1,",.03)=GMRVIT(1) ;Vital Type < S GMVFDA(120.5,"+1,",.04)=GMRDATE ;Date Time entered < S GMVFDA(120.5,"+1,",.05)=GMRVHLOC ;Hospital < S GMVFDA(120.5,"+1,",.06)=DUZ ;Entered by (DUZ) < S GMVFDA(120.5,"+1,",1.2)=GMRDAT(GMRVITY) ;Rate < S GMVFDA(120.5,"+1,",1.4)=$G(GMRO2(GMRVITY)) ;Sup 02 < S GMVIEN="" < D UPDATE^DIE("","GMVFDA","GMVIEN") < ;file any qualifiers < .I $G(GMRSITE(GMRVITY))'="" D | . I '$D(^GMR(120.5,DA,5,0)) S ^GMR(120.5,DA,5,0)="^12 ..S GDATA=+$P(GMRSITE(GMRVITY),U,2) | . S GMRVLST=+$P(^GMR(120.5,DA,5,0),"^",3) ..Q:'GDATA | . I $G(GMRSITE(GMRVITY))'="" S GDATA=+$P(GMRSITE(GMRV ..D ADDQUAL(GMVIEN(1)_"^"_GDATA) | . . S GMRVLST=GMRVLST+1 ..Q | . . S ^GMR(120.5,DA,5,GMRVLST,0)=GDATA .I $D(GMRINF(GMRVITY)) D | . . Q ..S I=0 | . I $D(GMRINF(GMRVITY)) S I=0 F S I=$O(GMRINF(GMRVIT ..F S I=$O(GMRINF(GMRVITY,I)) Q:I'>0 D | . . S GMRVLST=GMRVLST+1 ...S I(1)="" | . . S ^GMR(120.5,DA,5,GMRVLST,0)=GDATA ...F S I(1)=$O(GMRINF(GMRVITY,I,I(1))) Q:I(1)="" D | . . Q ....S GDATA=+$P(GMRINF(GMRVITY,I,I(1)),"^") | . S $P(^GMR(120.5,DA,5,0),"^",3)=GMRVLST,$P(^(0),"^", ....Q:'GDATA | . Q ....D ADDQUAL(GMVIEN(1)_"^"_GDATA) | S $P(^GMR(120.5,DA,0),"^",10)=$G(GMRO2(GMRVITY)) ....Q | L -^GMR(120.5,DA,0) ...Q < ..Q < .Q < S DA=+GMVIEN(1) < > D XREF(DA) ;set the cross-references > D XREF1(DA) ;set x-refs in multiple CHKDT(GMVDT,GMVSAV) ;Check if there is an entry for that < N GMVA,GMVTY < S GMVA=0 < F S GMVA=$O(^GMR(120.5,"B",GMVDT,GMVA)) Q:'GMVA D < .I DFN'=$P($G(^GMR(120.5,GMVA,0)),U,2) Q < .S GMVTY=$P($G(^GMR(120.5,GMVA,0)),"^",3) < .I GMVTY=GMVSAV D < ..S GMVDT=$$FMADD^XLFDT(GMVDT,"","","",1) < ..Q < .Q < Q GMVDT < ; < ADDQUAL(GMRVDATA) ; Add qualifiers to FILE 120.5 entry < ; ADD QUALIFIER TO 120.505 SUBFILE < ; Input: < ; GMRVDATA=120.5 IEN^QUALIFIER (120.52) IEN < ; < N GMVCNT,GMVERR,GMVFDA,GMVOKAY,GMRVIEN,GMRVQUAL < S GMRVIEN=+$P(GMRVDATA,"^",1) ;File 120.5 ien < S GMRVQUAL=+$P(GMRVDATA,"^",2) ;File 120.52 ien < ; Does File 120.5 entry exist? < I '$D(^GMR(120.5,GMRVIEN,0)) Q < ; Is the qualifier already stored? < I $O(^GMR(120.5,GMRVIEN,5,"B",GMRVQUAL,0))>0 Q < ; Legitimate Qualifier? < I '$D(^GMRD(120.52,GMRVQUAL,0)) Q < S GMVCNT=0 ;counter for number of tries to lock an en < B2 ; Lock the entry < I GMVCNT>3 Q ;4 strikes and you're out < L +^GMR(120.5,GMRVIEN,0):1 < S GMVCNT=GMVCNT+1 < I '$T L -^GMR(120.5,GMRVIEN,0) G B2 < ; Store the qualifier < S GMVFDA(120.505,"+1,"_GMRVIEN_",",.01)=GMRVQUAL < D UPDATE^DIE("","GMVFDA","GMVOKAY","GMVERR") < L -^GMR(120.5,GMRVIEN,0) < Q < Only in ./VADemo/r1/: GMRVFIX.m diff -y --suppress-common-lines ./VADemo/r1/GMRVPCE3.m ./VADemo/r2/r/GMRVPCE3.m GMRVPCE3 ;HIRMFO/RM,FT-V/M Data Validation for AICS ;3 | GMRVPCE3 ;HIRMFO/RM,FT-V/M Data Validation for AICS ;6 ;;4.0;Vitals/Measurements;**8,13,16**;Apr 25, 1997 | ;;4.0;Vitals/Measurements;**8,13**;Apr 25, 1997 ; < ; This routine uses the following IAs: < ; #10104 - ^XLFSTR calls (supported) < ; < . I UNIT="F",RATE<45 S FXN="" < diff -y --suppress-common-lines ./VADemo/r1/GMRYED4.m ./VADemo/r2/r/GMRYED4.m GMRYED4 ;HIRMFO/YH - INTRAVENOUS INFUSION PROTOCOL ;10/16/96 | GMRYED4 ;HIRMFO/YH-INTRAVENOUS INFUSION PROTOCOL ;10/16/96 ;;4.0;Intake/Output;**6**;Apr 25, 1997 | ;;4.0;Intake/Output;;Apr 25, 1997 . ;; GMRY*4*6 - RJS TEST FOR GMROUT < .Q:GMROUT < diff -y --suppress-common-lines ./VADemo/r1/GMRYUT0.m ./VADemo/r2/r/GMRYUT0.m GMRYUT0 ;HIRMFO/YH - PATIENT I/O UTILITIES - PATIENT SEARCH A | GMRYUT0 ;HIRMFO/YH-PATIENT I/O UTILITIES - PATIENT SEARCH AND ;;4.0;Intake/Output;**3,6**;Apr 25, 1997 | ;;4.0;Intake/Output;**3**;Apr 25, 1997 KILLV K GMRNO,GMRVNM,II,GMRVN,GMRDATA,GDTEND,GMRVP,GMRVS,GM | KILLV K GMRNO,GMRVNM,II,GMRVN,GMRDATA,GDTEND,GMRVP,GMRVS,GM ;; GMRY*4*6 - RJS ADDED GFLAG TO KILLV < diff -y --suppress-common-lines ./VADemo/r1/GMRYUT8.m ./VADemo/r2/r/GMRYUT8.m GMRYUT8 ;HIRMFO/YH - IV/LOCK/PORT ENTER/EDIT ;2/12/91 | GMRYUT8 ;HIRMFO/YH-IV/LOCK/PORT ENTER/EDIT ;2/12/91 ;;4.0;Intake/Output;**6**;Apr 25, 1997 | ;;4.0;Intake/Output;;Apr 25, 1997 ;; GMRY*4*6 - RJS ADDED THE DA SETS | D ^DIE L -^GMR(126,DFN) K DIE,DR S GMRDA=$P(^GMR(126, D ^DIE L -^GMR(126,DFN) K DIE,DR S GMRDA=$P(^GMR(126, < ;; GMRY*4*6 - RJS ADDED THE DA SETS | S %=1 D YN^DICN I %<0 S DA(2)=DA(1),DA(1)=DA,DA=GREC( S %=1 D YN^DICN I %<0 S DA(2)=DA(1),DA(1)=DA,DA=GREC( < KILLRC S DIK="^GMR(126,"_DA(2)_",""IV"","_DA(1)_",""IN""," D | KILLRC S DIK="^GMR(126,"_DA(2)_",""IV"","_DA(1)_",""IN""," D diff -y --suppress-common-lines ./VADemo/r1/GMTS2.m ./VADemo/r2/r/GMTS2.m GMTS2 ;SLC/SBW - Health Summary Driver Cont. ; 02/11/2003 | GMTS2 ;SLC/SBW - Health Summary Driver Cont. ; 01/06/2003 ;;2.7;Health Summary;**2,58,62**;Oct 20, 1995 | ;;2.7;Health Summary;**2,58**;Oct 20, 1995 D CKP^GMTSUP Q:$D(GMTSQIT) W:'$D(GMTSOBJ) ! | D CKP^GMTSUP Q:$D(GMTSQIT) W ! D CKP^GMTSUP Q:$D(GMTSQIT) W " No data available fo | D CKP^GMTSUP Q:$D(GMTSQIT) W "No data available for diff -y --suppress-common-lines ./VADemo/r1/GMTSDCB.m ./VADemo/r2/r/GMTSDCB.m GMTSDCB ; SLC/TRS,KER - Brief Discharge ; 03/24/2004 | GMTSDCB ; SLC/TRS,KER - Brief Discharge ; 02/27/2002 ;;2.7;Health Summary;**28,49,71**;Oct 20, 1995 | ;;2.7;Health Summary;**28,49**;Oct 20, 1995 ; DBIA 3390 $$ICDDX^ICDCODE < ; DBIA 10015 EN^DIQ1 (file #45) | ; DBIA 10015 EN^DIQ1 (file #80 and #45) I $P(ICD,U,10)'="" N ICDX S ICDX=$$ICDDX^ICDCODE($P(I | I $P(ICD,U,10)'="" D > . N DIC,DIQ,DR,DA,REC > . S DIC=80,DA=$P(ICD,U,10),DIQ="REC(",DIQ(0)="IE",DR= > . D EN^DIQ1 > . Q:'$D(REC) > . S DXL=REC(80,DA,3,"E") diff -y --suppress-common-lines ./VADemo/r1/GMTSDEM2.m ./VADemo/r2/r/GMTSDEM2.m GMTSDEM2 ; SLC/DLT,KER - Demographics (cont) ; 12/11/2 | GMTSDEM2 ; SLC/DLT,KER - Demographics (cont) ; 12/11/2 ;;2.7;Health Summary;**56,58,60,62**;Oct 20, 1995 | ;;2.7;Health Summary;**56,58,60**;Oct 20, 1995 S STR1=$$UP^XLFSTR(VAOA(9)),STR2=$S('$L(VAOA(10)):" REL(X) ; Relation > S X=$$UP^XLFSTR($G(X)) Q:'$L(X) S:X="W" X="SPOUSE" S > S:"WIFE"[X X="SPOUSE" S:"HUSBAND"[X X="SPOUSE" S:"NON > S:"BROTHER"[X X="BROTHER" S:"BROTHER"'[X&("BROTHER-IN > S:"SISTER"[X X="SISTER" S:"SISTER"'[X&("SISTER-IN-LAW > S:"AUNT"[X X="AUNT" S:"UNCLE"[X X="UNCLE" S:"COUSIN"[ > S:"FATHER"'[X&("GRANDFATHER"[X) X="GRANDFATHER" S:"FA > S:"SON"[X X="SON" S:"SON"'[X&("SON-IN-LAW"[X) X="SON- > S:"DAUGHTER"[X X="DAUGHTER" S:"DAUGHTER"'[X&("DAUGHTE > S:"NIECE"'[X&("NIECE IN LAW"[X) X="NIECE" S:"NEPHEW"' > Q X INS ; Insurance Info | INS ; Insuraance Info . ; Insurance Effect Date | . ; Insurace Effect Date diff -y --suppress-common-lines ./VADemo/r1/GMTSDGA.m ./VADemo/r2/r/GMTSDGA.m GMTSDGA ; SLC/MKB,KER/NDBI - Admissions for HS ; 03/24/2004 | GMTSDGA ; SLC/MKB,KER/NDBI - Admissions for HS ; 02/27/2002 ;;2.7;Health Summary;**28,49,71**;Oct 20, 1995 | ;;2.7;Health Summary;**28,49**;Oct 20, 1995 ; DBIA 3390 $$ICDDX^ICDCODE < > ; DBIA 10015 EN^DIQ1 (file #80) Q:TT=2 Q:TT=6 N ICDX,ICDI I DGPMIFN D ^DGPMLOS S LO | Q:TT=2 Q:TT=6 S PTF=$S($D(VAIP(12)):VAIP(12),1:"") Q:'$D(^ICD9) Q: | N DIC,DR,DA,DIQ S ICD=^DGPT(PTF,70) | I DGPMIFN D ^DGPMLOS S LOS=+X S ICDI=+$P(ICD,U,11) I ICDI>0 D | S PTF=$S($D(VAIP(12)):VAIP(12),1:"") . S ICDX=$$ICDDX^ICDCODE(ICDI) | I '$D(^ICD9) Q . S ICD(ADM,1,80,ICDI,.01)=$P(ICDX,"^",2) | I PTF="" Q . S ICD(ADM,1,80,ICDI,3)=$P(ICDX,"^",4) | I '$D(^DGPT(PTF,70)) Q S ICDI=+$P(ICD,U,10) I ICDI>0 D | S ICD=^DGPT(PTF,70),DIC=80,DR=".01;3" . S ICDX=$$ICDDX^ICDCODE(ICDI) | I $P(ICD,U,11)'="" S DA=$P(ICD,U,11),DIQ="ICD(ADM,1," . S ICD(ADM,2,80,ICDI,.01)=$P(ICDX,"^",2) | I $P(ICD,U,10)'="" S DA=$P(ICD,U,10),DIQ="ICD(ADM,2," . S ICD(ADM,2,80,ICDI,3)=$P(ICDX,"^",4) | F GMTSI=16:1:24 I $P(ICD,U,GMTSI)'="" S DA=$P(ICD,U,G F GMTSI=16:1:24 S ICDI=+$P(ICD,U,GMTSI) I ICDI>0 D < . S ICDX=$$ICDDX^ICDCODE(ICDI) < . S ICD(ADM,(GMTSI-13),80,ICDI,.01)=$P(ICDX,"^",2) < . S ICD(ADM,(GMTSI-13),80,ICDI,3)=$P(ICDX,"^",4) < diff -y --suppress-common-lines ./VADemo/r1/GMTSDGC1.m ./VADemo/r2/r/GMTSDGC1.m GMTSDGC1 ; SLC/KER/SBW - Subroutines for Ext ADT Hist | GMTSDGC1 ; SLC/KER/SBW - Subroutines for Ext ADT Hist ;;2.7;Health Summary;**5,35,47,71**;Oct 20, 1995 | ;;2.7;Health Summary;**5,35,47**;Oct 20, 1995 ; DBIA 3390 $$ICDDX^ICDCODE | ; DBIA 17 ^DGPM( ; DBIA 17 ^DGPM( | ; DBIA 1372 ^DGPT( fields 71,73,75 Read w/Filema ; DBIA 1372 ^DGPT( fields 71,73,75 Read w/Fileman | ; DBIA 10082 ^ICD9( fields .01,3 Read w/Fileman ; DBIA 512 ^DGPMLOS | ; DBIA 512 ^DGPMLOS ; DBIA 10015 EN^DIQ1 (file #45) | ; DBIA 10015 EN^DIQ1 (file #45 and #80) ; DBIA 10011 ^DIWP | ; DBIA 10011 ^DIWP S ICDI=+$P(ICD,U,10) I +ICDI>0 D | I $P(ICD,U,11)'="" S DA=$P(ICD,U,11),DIQ="ICD(1," D E . S ICDX=$$ICDDX^ICDCODE(ICDI) | I $P(ICD,U,10)'="" S DA=$P(ICD,U,10),DIQ="ICD(2," D E . S ICD(1,80,ICDI,.01)=$P(ICDX,"^",2) | F GMTSI=16:1:24 I $P(ICD,U,GMTSI)'="" S DA=$P(ICD,U,G . S ICD(1,80,ICDI,3)=$P(ICDX,"^",4) < S ICDI=+$P(ICD,U,11) Q:+ICDI'>0 < S ICDX=$$ICDDX^ICDCODE(ICDI) < S ICD(2,80,ICDI,.01)=$P(ICDX,"^",2) < S ICD(2,80,ICDI,3)=$P(ICDX,"^",4) < F GMTSI=16:1:24 S ICDI=+$P(ICD,U,GMTSI) I ICDI>0 D < . S ICDX=$$ICDDX^ICDCODE(ICDI) < . S ICD((GMTSI-13),80,ICDI,.01)=$P(ICDX,"^",2) < . S ICD((GMTSI-13),80,ICDI,3)=$P(ICDX,"^",4) < D CKP^GMTSUP Q:$D(GMTSQIT) W ?23,GMTO,?69,GMTNO,! | D CKP^GMTSUP Q:$D(GMTSQIT) W ?23,GMTO,?62,GMTNO,! diff -y --suppress-common-lines ./VADemo/r1/GMTSDGC2.m ./VADemo/r2/r/GMTSDGC2.m GMTSDGC2 ; SLC/SBW,KER - Extended ADT Hist (cont) ; 03 | GMTSDGC2 ; SLC/SBW,KER - Extended ADT Hist (cont) ; 02 ;;2.7;Health Summary;**28,49,71**;Oct 20, 1995 | ;;2.7;Health Summary;**28,49**;Oct 20, 1995 ; DBIA 3390 $$ICDOP^ICDCODE | ; DBIA 10083 ^ICD0( ; | ; DBIA 10015 EN^DIQ1 (file 80.1) > ; . . N ICDP,ICDI,ICDX Q:$P(PRX,U,GTA)="" | . . N DIQ,DA,DIQ,ICDP . . S ICDI=+($P(PRX,U,GTA)) Q:+ICDI'>0 | . . Q:$P(PRX,U,GTA)="" . . S ICDX=$$ICDOP^ICDCODE(+ICDI) | . . S DIC=80.1,DR="4;.01",DA=$P(PRX,U,GTA),DIQ="ICDP( . . S ICDP(80.1,ICDI,.01)=$P(ICDX,"^",2) | . . I $D(ICDP(80.1,DA)) S GMP(IX,GTA)=$E(ICDP(80.1,DA . . S ICDP(80.1,ICDI,4)=$P(ICDX,"^",5) < . . I $D(ICDP(80.1,ICDI)) D < . . . S GMP(IX,GTA)=$E(ICDP(80.1,ICDI,4),1,45)_U_ICDP < . F S O1=$O(GMP(O,O1)) Q:O1="" D CKP^GMTSUP Q:$D(GM | . F S O1=$O(GMP(O,O1)) Q:O1="" D CKP^GMTSUP Q:$D(GM . . N ICDS,ICDI,ICDX | . . N DIQ,DA,DIQ,ICDS . . S ICDI=+($P(SURG,U,GMA)) Q:+ICDI'>0 | . . Q:$P(SURG,U,GMA)="" . . S ICDX=$$ICDOP^ICDCODE(+ICDI) | . . S DIC=80.1,DR="4;.01",DA=$P(SURG,U,GMA),DIQ="ICDS . . S ICDS(80.1,ICDI,.01)=$P(ICDX,"^",2) | . . I $D(ICDS(80.1,DA)) S GMS(IX,GMA)=$E(ICDS(80.1,DA . . S ICDS(80.1,ICDI,4)=$P(ICDX,"^",5) < . . I $D(ICDS(80.1,ICDI)) S GMS(IX,GMA)=$E(ICDS(80.1, < . F S O1=$O(GMS(O,O1)) Q:O1="" D CKP^GMTSUP Q:$D(GM | . F S O1=$O(GMS(O,O1)) Q:O1="" D CKP^GMTSUP Q:$D(GM diff -y --suppress-common-lines ./VADemo/r1/GMTSDGP.m ./VADemo/r2/r/GMTSDGP.m GMTSDGP ; SLC/TRS,KER/NDBI - PTF Surgeries/Procedures ; 03/24 | GMTSDGP ; SLC/TRS,KER/NDBI - PTF Surgeries/Procedures ; 12/11 ;;2.7;Health Summary;**28,49,60,71**;Oct 20, 1995 | ;;2.7;Health Summary;**28,49,60**;Oct 20, 1995 ; DBIA 3390 $$ICDOP^ICDCODE < > ; DBIA 10083 ^ICD0( > ; DBIA 10015 EN^DIQ1 (file 80.1) N ICDP,ICDI,ICDX | K DIQ Q:$P(SURG,U,GMA)="" S ICDI=+$P(SURG,U,GMA) Q:ICDI'>0 | S DIC=80.1,DR="4;.01",DA=$P(SURG,U,GMA),DIQ="ICDS(" D S ICDX=$$ICDOP^ICDCODE(+ICDI) | I $D(ICDS(80.1,DA)) S GMS(IX,GMA)=$E(ICDS(80.1,DA,4), S ICDS(80.1,ICDI,.01)=$P(ICDX,"^",2) < S ICDS(80.1,ICDI,4)=$P(ICDX,"^",5) < I $D(ICDS(80.1,ICDI)) D < . S GMS(IX,GMA)=$E($G(ICDS(80.1,ICDI,4)),1,45)_U_$G(I < N ICDP,ICDI,ICDX | K DIQ S ICDI=+$P(PRX,U,GTA) Q:ICDI'>0 | Q:$P(PRX,U,GTA)="" S ICDX=$$ICDOP^ICDCODE(+ICDI) | S DIC=80.1,DR="4;.01",DA=$P(PRX,U,GTA),DIQ="ICDP(" D S ICDP(80.1,ICDI,.01)=$P(ICDX,"^",2) | I $D(ICDP(80.1,DA)) S GMP(IX,GTA)=$E(ICDP(80.1,DA,4), S ICDP(80.1,ICDI,4)=$P(ICDX,"^",5) < I $D(ICDP(80.1,ICDI)) D < . S GMP(IX,GTA)=$E($G(ICDP(80.1,ICDI,4)),1,45)_U_$G(I < diff -y --suppress-common-lines ./VADemo/r1/GMTSMCMA.m ./VADemo/r2/r/GMTSMCMA.m GMTSMCMA ; WAS/DCB\KER - Medicine 2.2 interface routin | GMTSMCMA ; WAS/DCB\KER - Medicine 2.2 interface routin ;;2.7;Health Summary;**4,47,49,61,62,69**;Oct 20, 199 | ;;2.7;Health Summary;**4,47,49,61**;Oct 20, 1995 ; DBIA 3778 HL1^MCORMN | ; DBIA 1236 HL1^MCORMN K ^TMP("MCAR",$J) D:+($G(GMTSG))'>0 SLIT(ARRY) | K ^TMP("MCAR",$J) ;Below the "0" input to slit is a dummy input in this | D SLIT("") D:+($G(GMTSG))>0 SLIT(0) | K ^TMP("MCAR1",$J) K ^TMP("MCAR1",$J) D:+($G(GMTSG))'>0 REMOVE(MESS1,ARR | D:+($G(GMTSG))'>0 REMOVE(MESS1,ARRY) Only in ./VADemo/r1/: GMTSOBX.m Only in ./VADemo/r1/: GMTSPSHO.m diff -y --suppress-common-lines ./VADemo/r1/GMTSPSI5.m ./VADemo/r2/r/GMTSPSI5.m GMTSPSI5 ; SLC/JER,KER - IV Rx Summary Component (V5) | GMTSPSI5 ; SLC/JER,KER - IV Rx Summary Component (V5) ;;2.7;Health Summary;**15,28,56,62**;Oct 20, 1995 | ;;2.7;Health Summary;**15,28,56**;Oct 20, 1995 D ENHS^PSJEEU0 I '$D(^UTILITY("PSIV",$J)) Q | D ENHS^PSJEEU0 > I '$D(^UTILITY("PSIV",$J)) Q I $D(^UTILITY("PSIV",$J,GMTSIDT,"A",1)) D Q:$D(GMTSQ | I $D(^UTILITY("PSIV",$J,GMTSIDT,"A",1)) D CKP^GMTSUP . D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD < . W $E($P($P(^UTILITY("PSIV",$J,GMTSIDT,"A",1),";",2) < D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?50,STAT < Q:$D(GMTSQIT) < F S GMTSAD=$O(^UTILITY("PSIV",$J,GMTSIDT,"A",GMTSAD) | F S GMTSAD=$O(^UTILITY("PSIV",$J,GMTSIDT,"A",GMTSAD) . S GMTSDRUG=^(GMTSAD) D CKP^GMTSUP Q:$D(GMTSQIT) D: < . W $E($P($P(GMTSDRUG,";",2),U),1,36),?38,$P(GMTSDRUG < Q:$D(GMTSQIT) < S SOL=0 F S SOL=$O(^UTILITY("PSIV",$J,GMTSIDT,"S",SO | S SOL=0 . S SLN=^(SOL) D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG | F S SOL=$O(^UTILITY("PSIV",$J,GMTSIDT,"S",SOL)) Q:SO > . D:GMTSNPG HEAD diff -y --suppress-common-lines ./VADemo/r1/GMTSPXFP.m ./VADemo/r2/r/GMTSPXFP.m GMTSPXFP ; SLC/SBW,KER - PCE Health Factors Component | GMTSPXFP ; SLC/SBW,KER - PCE Health Factors Component ;;2.7;Health Summary;**8,10,28,56,58,62,69**;Oct 20, | ;;2.7;Health Summary;**8,10,28,56,58**;Oct 20, 1995 ; DBIA 1243 HF^PXRHS07 | ; DBIA 1243 HF^PXRHS07 ; DBIA 4295 $$GET1^DIQ (file #9999999.64, .01) | ; DBIA 10011 ^DIWP ; DBIA 4295 $$GET1^DIQ (file #9999999.64, .03) < ; DBIA 4295 $$GET1^DIQ (file #9999999.64), .1) < ; DBIA 4295 ^AUTTHF("AC") < ; DBIA 10011 ^DIWP < N HFSEG,GMTSFC,GMW,GMTSHFO Q:$O(GMTSEG(GMTSEGN,999999 | N HFSEG,GMTSFC,GMW S GMTSFC=0,GMW=0 K ^TMP("PXF",$J),^TMP("GMTSPXO",$J) | Q:$O(GMTSEG(GMTSEGN,9999999.64,0))'>0 > S GMTSFC=0,GMW=0 Q:'$D(^TMP("PXF",$J)) D REORD D CKP^GMTSUP Q:$D(GMTS | Q:'$D(^TMP("PXF",$J)) D CKP^GMTSUP Q:$D(GMTSQIT) D Q < REORD ; Re-Order Selected Health Factors < N GMTSI,GMTSHFI,GMTSCAT,GMTSHFT,GMTSMCAT,GMTSHF,GMTSH < S GMTSI=0 F S GMTSI=$O(GMTSEG(GMTSEGN,9999999.64,GMT < . S GMTSHFI=$G(GMTSEG(GMTSEGN,9999999.64,GMTSI)) < . S GMTSCAT=$$GET1^DIQ(9999999.64,(GMTSHFI_","),.03) < . S GMTSHFT=$$GET1^DIQ(9999999.64,(GMTSHFI_","),.1,"I < . I GMTSHFT="C" D Q < . . N GMTSCAT,GMTSMCAT S GMTSMCAT=GMTSHFI N GMTSHFI < . . S GMTSCAT=$$GET1^DIQ(9999999.64,(GMTSMCAT_","),.0 < . . S GMTSHFI=0 F S GMTSHFI=$O(^AUTTHF("AC",+GMTSMCA < . . . S GMTSHF=$$GET1^DIQ(9999999.64,(GMTSHFI_","),.0 < . . . S GMTSHFC=+($O(^TMP("GMTSPXO",$J," "),-1))+1,^T < . Q:'$L(GMTSCAT) S GMTSHF=$$GET1^DIQ(9999999.64,(GMT < . S GMTSHFC=+($O(^TMP("GMTSPXO",$J," "),-1))+1,^TMP(" < K ^TMP("PXF",$J) D HF^PXRHS07(DFN,GMTSEND,GMTSBEG,GMT | K ^TMP("PXF",$J) D CKP^GMTSUP Q:$D(GMTSQIT) D HDR,HFMAIN | D HF^PXRHS07(DFN,GMTSEND,GMTSBEG,GMTSNDM) Q | Q:'$D(^TMP("PXF",$J)) HFMAIN ; Display Health Factors | D CKP^GMTSUP Q:$D(GMTSQIT) D HDR N GMHFC,GMHF,GMDT,GMIFN,GMN0,GMW,X,GMTSDAT,HF,LEVEL,P | D HFMAIN > Q > HFMAIN ; Main Health Factor Display > N GMHFC,GMHF,GMDT,GMIFN,GMN0,GMW,X,GMTSDAT,HF,LEVEL,P > N GMICL,GMTAB,GMTSLN > S GMHFC="",GMW=0 . S GMHF="" F S GMHF=$O(^TMP("PXF",$J,GMHFC,GMHF)) Q | . S GMHF="" . . D BYDT | . F S GMHF=$O(^TMP("PXF",$J,GMHFC,GMHF)) Q:GMHF="" K ^TMP("PXF",$J),^TMP("GMTSPXO",$J) | . . S GMDT=0 Q | . . F S GMDT=$O(^TMP("PXF",$J,GMHFC,GMHF,GMDT)) Q:GM SELECT ; Display Selected Health Factors | . . . S GMIFN=0 N GMO,GMHFC,GMHF,GMDT,GMIFN,GMN0,GMW,X,GMTSDAT,HF,LEV | . . . F S GMIFN=$O(^TMP("PXF",$J,GMHFC,GMHF,GMDT,GMI S GMO=0 F S GMO=$O(^TMP("GMTSPXO",$J,GMO)) Q:+GMO=0 | K ^TMP("PXF",$J) . S GMHFC="" F S GMHFC=$O(^TMP("GMTSPXO",$J,GMO,GMHF < . . S GMHF="" F S GMHF=$O(^TMP("GMTSPXO",$J,GMO,GMHF < . . . D BYDT < K ^TMP("PXF",$J),^TMP("GMTSPXO",$J) < Q < BYDT ; Display Health Factors by Date < N GMDT,GMIFN S GMDT=0 F S GMDT=$O(^TMP("PXF",$J,GMHF < . S GMIFN=0 F S GMIFN=$O(^TMP("PXF",$J,GMHFC,GMHF,GM < . . D HFDSP Q:$D(GMTSQIT) < D CKP^GMTSUP Q:$D(GMTSQIT) W " Health Factor ",?50, | D CKP^GMTSUP Q:$D(GMTSQIT) W " Health Factor ",?50, diff -y --suppress-common-lines ./VADemo/r1/GMTSPXU1.m ./VADemo/r2/r/GMTSPXU1.m GMTSPXU1 ; SLC/SBW - PCE Utilities sub-routines ; 03/2 | GMTSPXU1 ; SLC/SBW - PCE Utilites sub-routines ; 07/18 ;;2.7;Health Summary;**10,37,71**;Oct 20, 1995 | ;;2.7;Health Summary;**10,37**;Oct 20, 1995 ; External References < ; DBIA 3390 $$ICDDX^ICDCODE < ; DBIA 3390 $$ICDOP^ICDCODE < ; DBIA 3390 $$ICDD^ICDCODE < ; DBIA 1995 $$CPT^ICPTCOD < ; DBIA 10026 ^DIR < ; DBIA 10011 ^DIWP < ; < N REC,CODE,NAME,DESC,ICDX,ICDI,ICDA | N DIC,DIQ,DR,DA,REC,CODE,NAME,DESC S GMTSICD=$G(GMTSICD),GMTSICF=$G(GMTSICF),GMMOD=$G(GM | S DIC=80,DA=GMTSICD,DIQ="REC(",DIQ(0)="IE",DR=".01;3; S ICDX=$$ICDDX^ICDCODE(+GMTSICD) | ; DBIA 10015 call EN^DIQ1 S REC(80,GMTSICD,.01,"E")=$P(ICDX,"^",2) | D EN^DIQ1 S REC(80,GMTSICD,.01,"I")=$P(ICDX,"^",2) | Q:'$D(REC) S REC(80,GMTSICD,3,"E")=$P(ICDX,"^",4) | S CODE=REC(80,DA,.01,"I") S REC(80,GMTSICD,3,"I")=$P(ICDX,"^",4) | S NAME=REC(80,DA,3,"E") S ICDI=$$ICDD^ICDCODE($P(ICDX,"^",2),"ICDA") | S DESC=REC(80,DA,10,"E") S REC(80,GMTSICD,10,"E")=$G(ICDA(1)) < S REC(80,GMTSICD,10,"I")=$G(ICDA(1)) < S CODE=REC(80,GMTSICD,.01,"I") < S NAME=REC(80,GMTSICD,3,"E") < S DESC=REC(80,GMTSICD,10,"E") < GETICDOP(GMTSICD,GMTSICF,GMMOD) ; Entry point to get ICD0 dat | GETICDOP ; Entry point to get ICD0 data S GMTSICD=$G(GMTSICD),GMTSICF=$G(GMTSICF),GMMOD=$G(GM | N DIC,DIQ,DR,DA,REC,CODE,NAME,DESC N REC,CODE,NAME,DESC,ICDX,ICDI,ICDA | S DIC=80.1,DA=GMTSICD,DIQ="REC(",DIQ(0)="IE",DR=".01; S ICDX=$$ICDOP^ICDCODE(+GMTSICD) | ; DBIA 10015 call EN^DIQ1 S REC(80.1,GMTSICD,.01,"E")=$P(ICDX,"^",2) | D EN^DIQ1 S REC(80.1,GMTSICD,.01,"I")=$P(ICDX,"^",2) | Q:'$D(REC) S REC(80.1,GMTSICD,4,"E")=$P(ICDX,"^",5) | S CODE=REC(80.1,DA,.01,"I") S REC(80.1,GMTSICD,4,"I")=$P(ICDX,"^",5) | S NAME=REC(80.1,DA,4,"E") S ICDI=$$ICDD^ICDCODE($P(ICDX,"^",2),"ICDA") | S DESC=REC(80.1,DA,10,"E") S REC(80.1,GMTSICD,10,"E")=$G(ICDA(1)) < S REC(80.1,GMTSICD,10,"I")=$G(ICDA(1)) < S CODE=REC(80.1,GMTSICD,.01,"I") < S NAME=REC(80.1,GMTSICD,4,"E") < S DESC=REC(80.1,GMTSICD,10,"E") < N ICPT S GMTSCPT=+($G(GMTSCPT)) Q:GMTSCPT=0 "" | N DIC,DIQ,DR,DA,REC S ICPT=$$CPT^ICPTCOD(+GMTSCPT),ICPT=$P(ICPT,"^",2)_"- | S DIC=81,DA=GMTSCPT,DIQ="REC(",DIQ(0)="IE",DR=".01;2" Q ICPT | ; DBIA 10015 call EN^DIQ1 > D EN^DIQ1 > Q:'$D(REC) "" > Q REC(81,DA,.01,"I")_"-"_REC(81,DA,2,"E") > . ; DBIA 10011 call ^DIWP > . ; DBIA 10011 call ^DIWP ; | ; ; | ; LM ; Entry Point - for GMTS Measurement Panel | LM ; Entry Point - for GMTS Measurement Panel DSPLST ; Common code for Health Summary MNX Lists | DSPLST ; Common code for Health Summary MNX Lists CONT ; Continue | CONT F S GMTSCNT=$O(@(GMTSLST_"""B"",GMTSCNT)")) Q:GMTSCN F S GMTSCNT=$O(@(GMTSLST_"""B"",GMTSCNT)")) Q:GMTSCN < > . . ; DBIA 10026 call ^DIR > ; DBIA 10026 call ^DIR QUIT ; Quit | QUIT K DIR,X,Y,GMTSLST,GMTSCNT K DIR,X,Y,GMTSLST,GMTSCNT < diff -y --suppress-common-lines ./VADemo/r1/GMTSRM1.m ./VADemo/r2/r/GMTSRM1.m ;;2.7;Health Summary;**7,36,37,62**;Oct 20, 1995 | ;;2.7;Health Summary;**7,36,37**;Oct 20, 1995 ; External References < ; DBIA 10006 ^DIC < ; DBIA 10026 ^DIR < ; DBIA 10018 ^DIE < ; < > ; DBIA 10006 call ^DIC > ; DBIA 10026 call ^DIR > . . ; DBIA 10026 call ^DIR N IEN,MAXOCC,TIME,OCC,HOSP,ICD,PROV,CPT,SELCNT,GMTSNC | N IEN,MAXOCC,TIME,OCC,HOSP,ICD,PROV,CPT,SELCNT,GMTSNC > ; DBIA 10018 call ^DIE > ; DBIA 10018 call ^DIE S (GMTSNCNT,GMTSN)=0 F S GMTSN=$O(^GMT(142,DA(1),1,D < I +GMTSNCNT>1 D REITEM^GMTSRM3(DA(1),DA) < > ; DBIA 10026 call ^DIR diff -y --suppress-common-lines ./VADemo/r1/GMTSRM3.m ./VADemo/r2/r/GMTSRM3.m ;;2.7;Health Summary;**56,62**;Oct 20, 1995 | ;;2.7;Health Summary;**56**;Oct 20, 1995 REITEM(GMTST,GMTSS) ; Resequence Items < Q:+($G(GMTST))'>0 Q:'$D(^GMT(142,+($G(GMTST)))) < Q:+($G(GMTSS))'>0 Q:'$D(^GMT(142,+GMTST,1,+($G(GMTSS < N DIR,DTOUT,DUOUT,DIRUT,DIROUT,GMTSA,GMTSCN,GMTSCA,GM < D ARY(GMTST,GMTSS,.GMTSA) Q:+($G(GMTSA(0)))'>1 < S GMTSCN=$P($G(^GMT(142,GMTST,1,GMTSS,0)),"^",2),GMTS < W !,?1,GMTSCN," ",$S($L(GMTSCA):"(",1:""),GMTSCA,$ < S GMTSN=0 F S GMTSN=$O(GMTSA(GMTSN)) Q:+GMTSN=0 W ! < S DIR(0)="YAO",DIR("?")="^D RIH^GMTSRM3",DIR("A")=" D < W ! D ^DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DI < Q:+Y'>0 < N DA S DA(2)=+($G(GMTST)),DA(1)=+($G(GMTSS)) D RSI^GM < Q < RIH ; Resequence Items Help < W !,?4,"Enter either 'Y' or 'N'." Q < ARY(GMTST,GMTSS,ARY) ; Array of Items < N GMTSC,GMTSI,GMTSVAL,GMTSPTR,GMTSFRT,GMTSCRT,GMTSFFR < N GMTSRT,GMTSUB S ARY(0)=0 Q:+($G(GMTST))'>0 Q:'$D(^ < S (GMTSC,GMTSI)=0 F S GMTSI=$O(^GMT(142,GMTST,1,GMTS < . S GMTSVAL=$G(^GMT(142,GMTST,1,GMTSS,1,GMTSI,0)),GMT < . S GMTSCRT=$$CREF^DILF(GMTSFRT),GMTSFFRT=GMTSFRT_GMT < . S GMTSFCRT=$$CREF^DILF(GMTSFFRT) Q:'$D(@GMTSFCRT) < . S GMTSUB=$P($G(@($P(GMTSFCRT,")",1)_",0)")),"^",1), < Q < diff -y --suppress-common-lines ./VADemo/r1/GMTSROB.m ./VADemo/r2/r/GMTSROB.m GMTSROB ; SLC/JER,KER - Surgery Reports Brief ; 06/24/2002 | GMTSROB ; SLC/JER,KER - Surgery Reports Brief ; 11/02/1998 ;;2.7;Health Summary;**9,11,28,57**;Oct 20, 1995 | ;;2.7;Health Summary;**9,11,28**;Oct 20, 1995 ; < ; External References < ; DBIA 2491 ^SRF("B") < ; DBIA 2491 ^SRF( file #130 < ; DBIA 10011 ^DIWP < ; DBIA 2056 $$GET1^DIQ (file #130) < ; < N MAX,GMCOUNT,GMIDT,GMN,SURG Q:'$D(^SRF("B",DFN)) | N MAX,GMCOUNT,GMIDT,GMN,SURG S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:999) | I '$D(^SRF("B",DFN)) Q > S MAX=999 I $D(GMTSNDM),(GMTSNDM>0) S MAX=GMTSNDM N GMDT S GMDT=$$GET1^DIQ(130,(+(GMN)_","),.09,"I") | N GMDT I GMDT>GMTSBEG&(GMDTGMTSBEG&(GMDT I +$P(GMTSNON,U,4)&'+$P(GMTSNON,U,5) S STATUS="INCOMP diff -y --suppress-common-lines ./VADemo/r1/GMTSROE.m ./VADemo/r2/r/GMTSROE.m GMTSROE ; SLC/KER - Surgery Extract ; 06/24 | GMTSROE ; SLC/KER - Surgery Extract ; 07/18 ;;2.7;Health Summary;**37,57,71**;Oct 20, 1995 | ;;2.7;Health Summary;**37**;Oct 20, 1995 ; External References < ; DBIA 2491 ^SRF( file #130 < ; DBIA 10103 $$HTFM^XLFDT < ; DBIA 10015 EN^DIQ1 < ; DBIA 1996 $$CPT^ICPTCOD < ; DBIA 10011 ^DIWP < ; DBIA 2056 $$GET1^DIQ (file #81.3) < ; DBIA 2056 $$GET1^DIQ (file #81) < ; DBIA 2056 $$GET1^DIQ (file #130) < ; DBIA 2052 FILE^DID < ; < ONE(X) ; Extract One Surgery Report | ONE(X) ; > ; DBIA 641 access ^SRF > ; DBIA 10103 call $$HTFM^XLFDT > ; DBIA 10015 call EN^DIQ1 WP(X,Y,Z) ; Word Processing | WP(X,Y,Z) ; . S X=$G(REC(130,GMTSI,GMTSF,GMI)) D ^DIWP | . S X=$G(REC(130,GMTSI,GMTSF,GMI)) > . ; DBIA 10011 call ^DIWP > . D ^DIWP SUB ; Surgery Subfiles | SUB ; . ; ^SRF(DO,14,I) .72 | . ; . ; Other Preop Diagnosis 14;0 130.17 | . ;-------------------------------------------------- . ; $P(^SRF(DO,14,I,0),U) .01 | . ; . ; Other Preop Diagnosis 0;1 Text | . ; ^SRF(DO,14,I) .72 Other Preop Dia > . ; $P(^SRF(DO,14,I,0),U) .01 Other Preop Dia > . ; > . ; DBIA 2491 access ^SRF . . S DA(SUB)=GMTSI D EN^DIQ1 | . . S DA(SUB)=GMTSI > . . ; DBIA 10015 call EN^DIQ1 > . . D EN^DIQ1 . ; ^SRF(DO,15,I) .74 | . ; . ; Other Postop Diagnosis 15;0 130.18 | . ;-------------------------------------------------- . ; $P(^SRF(DO,15,I,0),U) .01 | . ; . ; Other Postop Diagnosis 0;1 Text | . ; ^SRF(DO,15,I) .74 Other Postop Di > . ; $P(^SRF(DO,15,I,0),U) .01 Other Postop Di > . ; > . ; DBIA 2491 access ^SRF . . S DA(SUB)=GMTSI D EN^DIQ1 | . . S DA(SUB)=GMTSI > . . ; DBIA 10015 call EN^DIQ1 > . . D EN^DIQ1 ; ^SRF(GMN,"OPMOD",I) 28 | ; ; Primary Proc CPT Mod OPMOD;0 130.028 | ;---------------------------------------------------- ; $P(^SRF(GMN,"OPMOD",I,0),U) .01 | ; ; Primary Proc CPT Mod 0;1 Ptr 81.3 | ; ^SRF(GMN,"OPMOD",I) 28 Pri Pro CPT Mod > ; $P(^SRF(GMN,"OPMOD",I,0),U) .01 Pri Pro CPT Mod > ; > . ; DBIA 2491 access ^SRF . . S DA(SUB)=GMTSI D EN^DIQ1 | . . S DA(SUB)=GMTSI > . . ; DBIA 10015 call EN^DIQ1 > . . D EN^DIQ1 . . . N GMTSMOD S GMTSMOD=$$MOD^ICPTMOD(+GMTSM) | . . . ; DBIA 2056 call $$GET1^DIQ . . . S GMTSC=$P(GMTSMOD,"^",2) | . . . S GMTSC=$$GET1^DIQ(81.3,+GMTSM,.01,"E") . . . S GMTSS=$P(GMTSMOD,"^",3) | . . . ; DBIA 2056 call $$GET1^DIQ > . . . S GMTSS=$$GET1^DIQ(81.3,+GMTSM,.02,"E") ; ^SRF(DO,13,I) .42 | ; ; Other Proc 13;0 130.16 | ;---------------------------------------------------- ; $P(^SRF(DO,13,I,0),U) .01 | ; ; Other Proc 0;1 Text | ; ^SRF(DO,13,I) .42 Other Proc ; $P(^SRF(DO,13,I,2),U) 3 | ; $P(^SRF(DO,13,I,0),U) .01 Other Proc ; Other Proc CPT Code 2;1 Ptr 81 | ; $P(^SRF(DO,13,I,2),U) 3 Other Proc CPT Co > ; > ; DBIA 2491 access ^SRF . N GMTSCPT S DA(SUB)=GMTSI | . S DA(SUB)=GMTSI > . ; DBIA 10015 call EN^DIQ1 . S GMTSCPT=$$CPT^ICPTCOD(+GMTSM) | . ; DBIA 2056 call $$GET1^DIQ . S:GMTSM>0 REC(130,IEN,130.16,GMTSI,3,"N")=$P(GMTSCP | . S:GMTSM>0 REC(130,IEN,130.16,GMTSI,3,"N")=$$GET1^DI . ; ^SRF(8,13,2,"MOD",0) 4 | . ; . ; Oth Proc CPT Mod MOD;0 130.164 | . ;-------------------------------------------------- . ; ^SRF(8,13,2,"MOD",1,0) .01 | . ; . ; Oth Proc CPT Mod 0;1 Ptr 81.3 | . ; ^SRF(8,13,2,"MOD",0) 4 Oth Proc CPT Mo > . ; ^SRF(8,13,2,"MOD",1,0) .01 Oth Proc CPT Mo > . ; > . . ; DBIA 2491 access ^SRF > . . . ; DBIA 10015 call EN^DIQ1 . . . . N GMTSMOD S GMTSMOD=$$MOD^ICPTMOD(+GMTSM) | . . . . ; DBIA 2056 call $$GET1^DIQ . . . . S GMTSC=$P(GMTSMOD,"^",2) | . . . . S GMTSC=$$GET1^DIQ(81.3,+GMTSM,.01,"E") . . . . S GMTSS=$P(GMTSMOD,"^",3) | . . . . ; DBIA 2056 call $$GET1^DIQ > . . . . S GMTSS=$$GET1^DIQ(81.3,+GMTSM,.02,"E") N GMDT S GMDT=$P(^SRF(GMN,0),U,9) I GMDT>GMTSBEG&(GMD | N GMDT > ; DBIA 641 access ^SRF > S GMDT=$P(^SRF(GMN,0),U,9) I GMDT>GMTSBEG&(GMDT ; DBIA 2052 call FILE^DID > D FILE^DID(130,"N","GLOBAL NAME","FIL","FIL(""ERR"")" > ; DBIA 2056 call $$GET1^DIQ diff -y --suppress-common-lines ./VADemo/r1/GMTSRO.m ./VADemo/r2/r/GMTSRO.m GMTSRO ; SLC/JER,KER - All Surgery Reports ; 06/24/2002 [8/3 | GMTSRO ; SLC/JER,KER - All Surgery Reports ; 07/18/2000 ;;2.7;Health Summary;**9,11,28,37,57**;Oct 20, 1995 | ;;2.7;Health Summary;**9,11,28,37**;Oct 20, 1995 ; | ; ; External References | ENSRO ;Entry point for Surgery Only Component ; DBIA 3590 HS^SROGMTS < ; < ENSRO ; Entry Point for Surgery Only Component < ENSR ; Entry Point for SURGERY REPORT component | ENSR ; Entry point for SURGERY REPORT component, includes ; (includes NON-OR procedures) < ; | ; SORT ; Sort Surgeries by Inverse Date | SORT ; Sort surgeries by inverted date WRT ; Write Surgical Case Record | WRT ; Write surgical case record N REC,X,GMI,GMJ,GMDT,GMTSTR | N REC,X,GMI,GMJ,GMDT,GMTSTR D ONE^GMTSROE(GMN) D:+($$PROK^GMTSU("SROGMTS",100))>0 HS^SROGMTS(GMN) | ; D:+($$PROK^GMTSU("SROGMTS",100))'>0 ONE^GMTSROE(GMN) < ; Quit if Surgery Only < Q:$G(REC(130,GMN,118,"I"))="Y"&(+($G(GMTSSO))>0) < ; Print if SR*3*100 < ;G:+($$PROK^GMTSU("SROGMTS",100))>0 OPER < I $G(REC(130,GMN,118,"I"))'="Y" G OPER < ; Print if NOT SR*3*100 < > ; D:$L($G(REC(130,GMN,15,"I")))!($L($G(REC(130,GMN,39," | D:$L(REC(130,GMN,15,"I"))!($L(REC(130,GMN,39,"I"))) C S GMCOUNT=+($G(GMCOUNT))+1 < . I +($$PROK^GMTSU("SROGMTS",100))=0 N GMI D CKP^GMTS | . N GMI D CKP^GMTSUP Q:$D(GMTSQIT) W "Surgeon's Dict . S GMI=$S(+($$PROK^GMTSU("SROGMTS",100))=1:1,1:0) F | . S GMI=0 F S GMI=$O(REC(130,GMN,1.15,GMI)) Q:+GMI=0 diff -y --suppress-common-lines ./VADemo/r1/GMTSRON.m ./VADemo/r2/r/GMTSRON.m GMTSRON ; SLC/JER,KER - Surgery Reports ; 06/24/2002 [7/27/04 | GMTSRON ; SLC/JER,KER - Surgery Reports ; 07/18/2000 ;;2.7;Health Summary;**11,28,37,57**;Oct 20, 1995 | ;;2.7;Health Summary;**11,28,37**;Oct 20, 1995 ; External References < ; DBIA 3590 HS^SROGMTS < ; DBIA 2056 $$GET1^DIQ (file #130) < ; < . S GMN=SURG(GMIDT) K REC I $$CHK D WRT | . S GMN=SURG(GMIDT) K REC D WRT:$$CHK S GMN=+($G(GMN)) | S GMN=+($G(GMN)) D:'$D(REC) ONE^GMTSROE(GMN) D:+($$PROK^GMTSU("SROGMTS",100))>0 HS^SROGMTS(GMN) < D:+($$PROK^GMTSU("SROGMTS",100))'>0 ONE^GMTSROE(GMN) < > ; DBIA 2056 call $$GET1^DIQ Only in ./VADemo/r1/: GMTSRS1B.m Only in ./VADemo/r1/: GMTSRS1.m Only in ./VADemo/r1/: GMTSRS2B.m Only in ./VADemo/r1/: GMTSRS2.m Only in ./VADemo/r1/: GMTSRS3.m Only in ./VADemo/r1/: GMTSRS4.m Only in ./VADemo/r1/: GMTSRS.m diff -y --suppress-common-lines ./VADemo/r1/GMTSXAB.m ./VADemo/r2/r/GMTSXAB.m ;;2.7;Health Summary;**47,49,58,66**;Oct 20, 1995 | ;;2.7;Health Summary;**47,49,58**;Oct 20, 1995 ; ^TMP($J,"GMTSTYP", List Input Array | ; GMTSTYP( List Input Array ; ROOT( List Output Array | ; GMTSL( List Output Array S GMTSC=+($O(@ROOT@(" "),-1)) | S GMTSC=+($O(GMTSL(" "),-1)) S GMTSC=+($O(@ROOT@(" "),-1)) | S GMTSC=+($O(GMTSL(" "),-1)) F S GMTSID=$O(^TMP($J,"GMTSTYP","NAT","B",GMTSID)) Q | F S GMTSID=$O(GMTSTYP("NAT","B",GMTSID)) Q:GMTSID="" . S GMTSI=0 F S GMTSI=$O(^TMP($J,"GMTSTYP","NAT","B" | . S GMTSI=0 F S GMTSI=$O(GMTSTYP("NAT","B",GMTSID,GM . . S GMTSV=$$VAL($G(^TMP($J,"GMTSTYP","NAT",GMTSI))) | . . S GMTSV=$$VAL($G(GMTSTYP("NAT",GMTSI))) . . Q:$D(@ROOT@("B",GMTSV)) | . . Q:$D(GMTSL("B",GMTSV)) . . S @ROOT@(GMTSC)=GMTSV,@ROOT@("B",GMTSV,GMTSC)="" | . . S GMTSL(GMTSC)=GMTSV,GMTSL("B",GMTSV,GMTSC)="" . . S @ROOT@("C",GMTSC)="NAT" | . . S GMTSL("C",GMTSC)="NAT" K ^TMP($J,"GMTSTYP","NAT") | K GMTSTYP("NAT") N GMTSC S GMTSC=+($O(@ROOT@(" "),-1)) F GMTSAT="ADH", | N GMTSC S GMTSC=+($O(GMTSL(" "),-1)) F GMTSAT="ADH"," . F S GMTSI=$O(^TMP($J,"GMTSTYP",GMTSE,GMTSAT,GMTSI) | . F S GMTSI=$O(GMTSTYP(GMTSE,GMTSAT,GMTSI)) Q:+GMTSI . . S GMTSV=$$VAL($G(^TMP($J,"GMTSTYP",GMTSE,GMTSAT,G | . . S GMTSV=$$VAL($G(GMTSTYP(GMTSE,GMTSAT,GMTSI))) Q: . . Q:$D(@ROOT@("B",GMTSV)) S GMTSC=GMTSC+1,@ROOT@(G | . . Q:$D(GMTSL("B",GMTSV)) S GMTSC=GMTSC+1,GMTSL(GMT N GMTSC S GMTSC=+($O(@ROOT@(" "),-1)) F S GMTSID=$O( | N GMTSC S GMTSC=+($O(GMTSL(" "),-1)) F S GMTSID=$O(G . Q:'$L(GMTSID) S GMTSI=0 F S GMTSI=$O(^TMP($J,"GMT | . Q:'$L(GMTSID) S GMTSI=0 F S GMTSI=$O(GMTSTYP(GMTS . . S GMTSV=$$VAL($G(^TMP($J,"GMTSTYP",GMTSE,GMTSI))) | . . S GMTSV=$$VAL($G(GMTSTYP(GMTSE,GMTSI))) Q:'$L(GMT . . Q:'$L($$TRIM^GMTSXA($P(GMTSV,"^",2)," ")) K:$D(@ | . . Q:'$L($$TRIM^GMTSXA($P(GMTSV,"^",2)," ")) K:$D(G S GMTSI=0 F S GMTSI=$O(^TMP($J,"GMTSTYP",GMTSE,GMTSI | S GMTSI=0 F S GMTSI=$O(GMTSTYP(GMTSE,GMTSI)) Q:+GMTS . S GMTSV=$$VAL($G(^TMP($J,"GMTSTYP",GMTSE,GMTSI))) Q | . S GMTSV=$$VAL($G(GMTSTYP(GMTSE,GMTSI))) Q:'$L(GMTSV . Q:$D(@ROOT@("B",GMTSV)) | . Q:$D(GMTSL("B",GMTSV)) . S GMTSC=GMTSC+1,@ROOT@(GMTSC)=GMTSV,@ROOT@("B",GMTS | . S GMTSC=GMTSC+1,GMTSL(GMTSC)=GMTSV,GMTSL("B",GMTSV, S:+($G(GMTSOVR))>0&($D(@ROOT@("B"))) GMTSOK=1 | S:+($G(GMTSOVR))>0&($D(GMTSL("B"))) GMTSOK=1 K ^TMP($J,"GMTSTYP",GMTSE) | K GMTSTYP(GMTSE) diff -y --suppress-common-lines ./VADemo/r1/GMTSXAL.m ./VADemo/r2/r/GMTSXAL.m ;;2.7;Health Summary;**47,49,66**;Oct 20, 1995 | ;;2.7;Health Summary;**47,49**;Oct 20, 1995 GETLIST(GMTSL,GMTSUSR,GBL,ERR) ; Get Health Summary Type Par | GETLIST(GMTSL,GMTSUSR) ; Get Health Summary Type Parameter L N GMTSCP,GMTSCPL,GMTSPRE,GMTSDEF,ROOT | N GMTSCP,GMTSCPL,GMTSPRE,GMTSDEF I '$G(GBL) K GMTSL S ROOT=$NA(GMTSL) < I $G(GBL) D Q:$G(ERR) < . I $E($G(GMTSL),1)'="^" S ERR="19^"_$$EZBLD^DIALOG(1 < . S ROOT=GMTSL < S @ROOT=0 < D GETLST(.ROOT,GMTSUSR,GMTSCPL,GMTSPRE) | D GETLST(.GMTSL,GMTSUSR,GMTSCPL,GMTSPRE) . S @ROOT@("AC","PRE")=GMTSPRE,@ROOT@("AC","CPL")=GMT | . S GMTSL("AC","PRE")=GMTSPRE,GMTSL("AC","CPL")=GMTSC . N GMTSI,GMTST,GMTSTO,GMTSTC,GMTSTCT,GMTSV,GMTSC | . N GMTSI,GMTST,GMTSTO,GMTSTC,GMTSTCT,GMTSV,GMTSC S G . S GMTSTO="",(GMTSC,GMTSTC,GMTSTCT,GMTSI)=0 | . . S GMTSV=$G(GMTSL(GMTSI)),GMTST=$G(GMTSL("C",GMTSI . F S GMTSI=$O(@ROOT@(GMTSI)) Q:+GMTSI=0 D | . . S GMTSC=GMTSC+1,GMTSL("A",GMTST,0)=GMTSC,GMTSL("A . . S GMTSV=$G(@ROOT@(GMTSI)),GMTST=$G(@ROOT@("C",GMT | . . S GMTSL("AB",0)=GMTSTC,GMTSL("AB",+GMTSTC,0)=GMTS . . S GMTSC=GMTSC+1,@ROOT@("A",GMTST,0)=GMTSC,@ROOT@( | . K GMTSL("B"),GMTSL("C") S GMTST="" F S GMTST=$O(GM . . S:GMTST'=GMTSTO GMTSTC=GMTSTC+1,GMTSTCT=0 | . . S GMTSI=0 F S GMTSI=$O(GMTSL("A",GMTST,GMTSI)) Q . . S GMTSTCT=GMTSTCT+1 | . . . S GMTSC=+($G(GMTSL("A",GMTST,GMTSI))) . . S @ROOT@("AB",0)=GMTSTC,@ROOT@("AB",+GMTSTC,0)=GM | . . . S GMTSV=$P($G(GMTSL("A",GMTST,GMTSI)),"^",2) . K @ROOT@("B"),@ROOT@("C") S GMTST="" F S GMTST=$O( | . . . S:+GMTSC>0 GMTSL("B",+GMTSC,GMTSI)="" . . S GMTSI=0 F S GMTSI=$O(@ROOT@("A",GMTST,GMTSI)) | . . . S:$L(GMTSV)>0 GMTSL("BA",GMTSV,GMTSI)="" . . . S GMTSC=+($G(@ROOT@("A",GMTST,GMTSI))) < . . . S GMTSV=$P($G(@ROOT@("A",GMTST,GMTSI)),"^",2) < . . . S:+GMTSC>0 @ROOT@("B",+GMTSC,GMTSI)="" < . . . S:$L(GMTSV)>0 @ROOT@("BA",GMTSV,GMTSI)="" < ; | ; GETLST(ROOT,GMTSUSR,GMTSCPL,GMTSPRE) ; Get List | GETLST(GMTSL,GMTSUSR,GMTSCPL,GMTSPRE) ; Get List N GMTSPAR,GMTSYS,GMTSAD,GMTSAR,GMTST,GMTSV,GMTSVAL,GM | N GMTSPAR,GMTSYS,GMTSAD,GMTSAR,GMTST,GMTSTYP,GMTSV,GM K ^TMP($J,"GMTSLL"),^TMP($J,"GMTSLN"),^TMP($J,"GMTSTY < K @ROOT D BUILD^GMTSXAB | K GMTSL D BUILD^GMTSXAB K:'$D(GMTSIDX) @ROOT@("B"),@ROOT@("C") S (GMTSI,GMTSN | K:'$D(GMTSIDX) GMTSL("B"),GMTSL("C") S (GMTSI,GMTSN)= F S GMTSI=$O(@ROOT@(GMTSI)) Q:+GMTSI=0 S GMTSN=GMTS | F S GMTSI=$O(GMTSL(GMTSI)) Q:+GMTSI=0 S GMTSN=GMTSN K ^TMP($J,"GMTSLL"),^TMP($J,"GMTSLN"),^TMP($J,"GMTSTY | Q Q < S GMTSND=$S(GMTSPRE["NAT"&(+($G(^GMT(142,+GMTSIV,"VA" | S GMTSND=$S(GMTSPRE["NAT"&(+($G(^GMT(142,+GMTSIV,"VA" S GMTSI=(+($O(@GMTSND@(" "),-1)+1)) | S GMTSI=(+($O(@(GMTSND_"("" "")"),-1)+1)) S @GMTSND@(GMTSI,"N")=$G(GMTSL(GMTSLI,"N")) | S @(GMTSND_"("_GMTSI_",""N"")")=$G(GMTSL(GMTSLI,"N")) S @GMTSND@(GMTSI,"V")=$G(GMTSVAL) | S @(GMTSND_"("_GMTSI_",""V"")")=$G(GMTSVAL) S @GMTSND@(GMTSI,"E")=$G(GMTSENT) | S @(GMTSND_"("_GMTSI_",""E"")")=$G(GMTSENT) S ^TMP($J,"GMTSTYP",GMTST,GMTSI)=$G(GMTSVAL) | S GMTSTYP(GMTST,GMTSI)=$G(GMTSVAL) S:$L(GMTSNM) ^TMP($J,"GMTSTYP",GMTST,"B",GMTSNM,GMTSI | S:$L(GMTSNM) GMTSTYP(GMTST,"B",GMTSNM,GMTSI)="" S:GMTSHT>0 ^TMP($J,"GMTSTYP",GMTST,"C",GMTSHT,GMTSI)= | S:GMTSHT>0 GMTSTYP(GMTST,"C",GMTSHT,GMTSI)="" N GMTSAT,GMTSC,GMTSI S GMTSND=$G(GMTSND) Q:'$L(GMTSND | N GMTSAT,GMTSC,GMTSI S GMTSND=$G(GMTSND) Q:'$L(GMTSND I GMTSNM=GMTSAD S GMTSI=(+($O(@GMTSND@("ADH"," "),-1) | I GMTSNM=GMTSAD S GMTSI=(+($O(@(GMTSND_"(""ADH"","" " I GMTSNM=GMTSAR S GMTSI=(+($O(@GMTSND@("RAD"," "),-1) | I GMTSNM=GMTSAR S GMTSI=(+($O(@(GMTSND_"(""RAD"","" " Q:'$L($G(GMTST)) Q:'$L($G(GMTSAT)) Q:'$L($G(GMTSNM) | Q:'$L($G(GMTST)) Q:'$L($G(GMTSAT)) Q:'$L($G(GMTSNM) S @GMTSND@("GMTSAT",GMTSI,"N")=$G(GMTSL(GMTSLI,"N")) | S @(GMTSND_"("""_GMTSAT_""","_GMTSI_",""N"")")=$G(GMT S @GMTSND@("GMTSAT",GMTSI,"V")=$G(GMTSL(GMTSLI,"V")) | S @(GMTSND_"("""_GMTSAT_""","_GMTSI_",""V"")")=$G(GMT S @GMTSND@("GMTSAT",GMTSI,"E")=$G(GMTSENT) | S @(GMTSND_"("""_GMTSAT_""","_GMTSI_",""E"")")=$G(GMT S @GMTSND@("GMTSAT","B",GMTSVAL,GMTSI)="" | S @(GMTSND_"("""_GMTSAT_""",""B"","""_GMTSVAL_""","_G S @GMTSND@("GMTSAT","C",GMTSEI_"^"_GMTSVAL,GMTSI)="" | S @(GMTSND_"("""_GMTSAT_""",""C"","""_GMTSEI_"^"_GMTS S GMTSC=+($O(@GMTSND@("GMTST",GMTSAT," "),-1))+1 | S GMTSC=+($O(@(GMTSND_"("""_GMTST_""","""_GMTSAT_""", S ^TMP($J,"GMTSTYP",GMTST,GMTSAT,GMTSC)=$G(GMTSVAL) | S GMTSTYP(GMTST,GMTSAT,GMTSC)=$G(GMTSVAL) S:$L(GMTSNM) ^TMP($J,"GMTSTYP",GMTST,GMTSAT,"B",GMTSN | S:$L(GMTSNM) GMTSTYP(GMTST,GMTSAT,"B",GMTSNM,GMTSC)=" S:GMTSHT>0 ^TMP($J,"GMTSTYP",GMTST,GMTSAT,"C",GMTSHT, | S:GMTSHT>0 GMTSTYP(GMTST,GMTSAT,"C",GMTSHT,GMTSC)="" diff -y --suppress-common-lines ./VADemo/r1/GMTSXAR.m ./VADemo/r2/r/GMTSXAR.m ;;2.7;Health Summary;**49,62**;Oct 20, 1995 | ;;2.7;Health Summary;**49**;Oct 20, 1995 S DIR(0)="NAO^1:"_GMTSMAX_":0",DIR("?")="^D SOH1^GMTS | S DIR(0)="NAO^1:"_GMTSMAX_":0",DIR("?")="^D SOH1^ZZKR S (DIR("?"),DIR("??"))="^D CONTH^GMTSXAR",DIR("B")="Y | S (DIR("?"),DIR("??"))="^D CONTH^ZZKREP",DIR("B")="Y" W ! N DIR,DIROUT,DUOUT,DTOUT S (DIR("?"),DIR("??"))=" | W ! N DIR,DIROUT,DUOUT,DTOUT S (DIR("?"),DIR("??"))=" Only in ./VADemo/r1/: GMV1PST.m Only in ./VADemo/r1/: GMV5ENV.m Only in ./VADemo/r1/: GMV6PST.m diff -y --suppress-common-lines ./VADemo/r1/GMVCLIN.m ./VADemo/r2/r/GMVCLIN.m GMVCLIN ;HOIFO/YH,FT-RETURNS A LIST OF PATIENTS WITH CLINIC A | GMVCLIN ;HOIFO/YH,FT-FUNCTION WHICH RETURNS A LIST OF PATIENT ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 ; #3869 - ^SDAMA202 calls (controlled) | ; #908 - ^SC( references (controlled) ; #10040 - ^SC( references (supported) | ; #1846 - ^SC( references (controlled) > ; #10035 - FILE 2 references (supported) > ; #10060 - FILE 200 references (supported) > ; #10061 - ^VADPT calls (supported) CLINPTS(RESULT,CLIN,BDATE) ; GMV CLINIC PT [RPC entry po | CLINPTS(RESULT,CLIN,BDATE) ;GMV CLINIC PT [RPC entry poi ; Return list of patients with clinic appointments wi | ;CLIN - SELECTED CLINIC ; Input: | ;BDATE - TODAY, TOMORROW, YESTERDAY, PAST WEEK, OR PA ; RESULT - array name to return data in | ;RETURN LIST OF PATIENTS WITH CLINIC APPOINTMENTS WIT ; CLIN - clinic name | N GMVOUT K RESULT I '$D(^SC("B",CLIN)) S RESULT(1)="E ; BDATE - TODAY, TOMORROW, YESTERDAY, PAST WEEK, O | N GMVCLIN S GMVCLIN=$O(^SC("B",CLIN,0)) I GMVCLIN'>0 ; | I $$ACTLOC^GMVUTL1(CLIN)'=1 S RESULT(1)="ERROR^Clinic ; Output: | N GMVPAT,DFN,NAME,GMVI,J,X,GMVJ,GMVSRV,GMVNOW,CHKX,CH ; RESULT(n)=DFN^patient name^clinic name^appt date/ | S MAXAPPTS=200 ; SSN^DOB (external)^sex, age^^...^^^^^.. | N GMVNOW,EDATE S GMVNOW=$$NOW^XLFDT,EDATE=$P(GMVNOW," ; | S GMVSRV=+$$GET1^DIQ(200,DUZ,29,"I") ; RESULT(1)=contains any error message | S DFN=0,GMVI=1 ; < N DFN,EDATE,GMVCLIN,GMVCNT,GMVDT,GMVI,GMVJ,GMVNODE,GM < N GMVOUT,GMVPAT,GMVRESLT,NAME,X < K RESULT < I '$D(^SC("B",CLIN)) S RESULT(1)="ERROR^No clinic ide < S GMVCLIN=$O(^SC("B",CLIN,0)) < I GMVCLIN'>0 S RESULT(1)="ERROR^No clinic identified" < S GMVNOW=$$NOW^XLFDT,EDATE=$P(GMVNOW,".")_".24" < ; convert bdate and edate into fileman date/time | ;CONVERT BDATE AND EDATE INTO FILEMAN DATE/TIME ; call scheduling api to get appt data | ;access to SC global granted under DBIA #518: D GETPLIST^SDAMA202(GMVCLIN,"1;4;","R",BDATE,EDATE,.G | S GMVJ=BDATE F S GMVJ=$O(^SC(+GMVCLIN,"S",GMVJ)) Q:G ; if GMVRESLT < 0, scheduling api returned an error | . I $L($G(^SC(+GMVCLIN,"S",GMVJ,1,0))) D I GMVRESLT<0 D G QCLIN | ..S J=0 F S J=$O(^SC(+GMVCLIN,"S",GMVJ,1,J)) Q:+J<1! .S RESULT(1)="ERROR"_U_$O(^TMP($J,"SDAMA202","GETPLIS | ...; .Q | ...S DFN=+$G(^SC(+GMVCLIN,"S",GMVJ,1,J,0)) ; generate error message if # of appts > 200 | ...Q:$$SDA(DFN,BDATE,EDATE,+GMVCLIN)=0 I $D(^TMP($J,"SDAMA202","GETPLIST",201,0)) D G QCLIN | ...; .S RESULT(1)="ERROR^Too many appointments found. Plea | ...S GMVOUT($P(^DPT(DFN,0),"^"))=DFN_"^"_$P(^DPT(DFN, .Q | I GMVI=0 S RESULT(1)="ERROR^No appointments." G QCLIN S (GMVCNT,GMVI)=0 | I GMVI>MAXAPPTS S RESULT(1)="ERROR^Too many appointme F S GMVI=$O(^TMP($J,"SDAMA202","GETPLIST",GMVI)) Q:' < .S GMVNODE=^TMP($J,"SDAMA202","GETPLIST",GMVI,4) ;dfn < .Q:$P(GMVNODE,U,1)=""!($P(GMVNODE,U,2)="") < .S DFN=$P(GMVNODE,U,1),NAME=$P(GMVNODE,U,2) < .S GMVDT=$P(^TMP($J,"SDAMA202","GETPLIST",GMVI,1),U,1 < .S GMVOUT(NAME,DFN)=DFN_"^"_NAME_"^"_CLIN_"^"_$$FMTE^ < .S GMVCNT=GMVCNT+1 < .Q < .S GMVI=0,NAME="" | . S GMVI=0,J="" .F S NAME=$O(GMVOUT(NAME)) Q:NAME="" D | . F S J=$O(GMVOUT(J)) Q:J="" D ..S DFN=0 | .. S GMVPAT="" ..F S DFN=$O(GMVOUT(NAME,DFN)) Q:'DFN D | .. D PTINFO^GMVUTL3(.GMVPAT,$P(GMVOUT(J),"^",1)) ...S GMVPAT="" | .. S GMVI=GMVI+1,RESULT(GMVI)=GMVOUT(J)_"^"_GMVPAT ...D PTINFO^GMVUTL3(.GMVPAT,DFN) | .. Q ...S GMVI=GMVI+1,RESULT(GMVI)=GMVOUT(NAME,DFN)_"^"_GM | . Q ...Q | QCLIN I '$D(RESULT(1)) S RESULT(1)="No patients found" ..Q < .Q < QCLIN ; called from above < I '$D(RESULT(1)) S RESULT(1)="No patients found" < K ^TMP($J,"SDAMA202") < > SDA(DFN,BDATE,EDATE,GMVCLIN) ; This function calls SDA^VAD > ; if the patient has clinic appointments. > ; DFN - patient id > ; BDATE - start date of search > ; EDATE - end date of search > ; GMVCLIN - Clinic ien (File 44) > ; Returns: 0 - no appointments > ; 1 - appointments > N GMVADPT > D KVAR^VADPT ;kill any VADPT variables > S VASD("T")=EDATE ;"to" date > S VASD("F")=BDATE ;"from" date > S VASD("C",+GMVCLIN)="" ;ien of clinic > ; Since VASD("W") is not defined, this call should re > ; appointments for both in- and outpatients. Cancelle > ; appointments will be ingnored. > D SDA^VADPT > ; If there is an error or no data in ^UTILITY, then n > S GMVADPT=$S(VAERR=1:0,'$D(^UTILITY("VASD",$J)):0,1:1 > D KVAR^VADPT > Q GMVADPT > Q diff -y --suppress-common-lines ./VADemo/r1/GMVGETD2.m ./VADemo/r2/r/GMVGETD2.m GMVGETD2 ;HOIFO/YH-EXTRACT VITALS/MEASUREMENT RECORDS | GMVGETD2 ;HOIFO/YH-EXTRACT VITALS/MEASUREMENT RECORDS ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 N GMVUSER < S GMVUSER=$$PERSON^GMVUTL1(+$P(GMRDAT,U,6)) ;user nam < . S ^TMP($J,"GRPC",GJ)=^(GJ)_$P(GMRDAT,"^",8)_" "_$S | . S ^TMP($J,"GRPC",GJ)=^(GJ)_$P(GMRDAT,"^",8)_" "_$S I (+$P(GMRDAT,"^",8)'>0)&($P(GMRDAT,"^",8)'="0") D Q | Q:(+$P(GMRDAT,"^",8)'>0)&($P(GMRDAT,"^",8)'="0") S G .S ^TMP($J,"GRPC",GJ)=^TMP($J,"GRPC",GJ)_" _"_GMVUSE < .Q < S GMRVITY=+$P(GMRDAT,"^",3) < S ^TMP($J,"GRPC",GJ)=^TMP($J,"GRPC",GJ)_" _"_GMVUSER < K Z,GMRBMI | K Z,GMRBMI Q Q < diff -y --suppress-common-lines ./VADemo/r1/GMVGR1.m ./VADemo/r2/r/GMVGR1.m GMVGR1 ;HIOFO/YH,FT-SET ^TMP($J) GLOBAL ;11/29/02 13:34 | GMVGR1 ;HIOFO/YH,FT-SET ^TMP($J) GLOBAL ;9/30/02 15:00 ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 . . S:^TMP($J,"GMRK","G"_(GJ*16+GCNTD+1))<1.6!(^("G"_ | . . S:^("G"_(GJ*16+GCNTD+1))<1.6!(^("G"_(GJ*16+GCNTD+ diff -y --suppress-common-lines ./VADemo/r1/GMVHB3.m ./VADemo/r2/r/GMVHB3.m GMVHB3 ;HIOFO/YH,FT-HP LASER B/P GRAPH - ID ;11/8/02 13:35 | GMVHB3 ;HIOFO/YH,FT-HP LASER B/P GRAPH - ID ;11/6/01 15:37 ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 W !,"PA-1,-5.2;LB"_GMVWRD_"#;PA7,-5.2;LB"_GMVRMBD_"#; | W !,"PA-1,-5.2;LB"_GMVWRD_"#;PA7,-5.2;LB"_GMVRMBD_"#; Only in ./VADemo/r1/: GMVHDR.m diff -y --suppress-common-lines ./VADemo/r1/GMVLAT0.m ./VADemo/r2/r/GMVLAT0.m GMVLAT0 ;HOIFO/YH,FT-DISPLAY LATEST VITALS/MEASUREMENTS FOR A | GMVLAT0 ;HOIFO/YH,FT-DISPLAY LATEST VITALS/MEASUREMENTS FOR A ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 ;CALLED BY GETLAT^GMVGETD | ;CALLED BY GMVGETD GETLAT N GJ,GBLANK,GAPICAL,GRADIAL,GBRACH,GMVUSER | N GJ,GBLANK,GAPICAL,GRADIAL,GBRACH . S GMVUSER=$P($G(^GMR(120.5,+GMVD(1),0)),U,6) ;user < . S GMVUSER=$$PERSON^GMVUTL1(GMVUSER) ;user name < . I X="WT",$G(GMRVWT)>0,$G(GMRVHT)>0 D | . I X="WT",$G(GMRVWT)>0,$G(GMRVHT)>0 S GJ=GJ+1,GMRVHT . . S ^TMP($J,"GRPC",GJ)=^TMP($J,"GRPC",GJ)_" _"_GMV | . . S GBLANK=$$REPEAT^XLFSTR(" ",29-$L(^TMP($J,"GRPC" . . S GJ=GJ+1,GMRVHT(1)=$J(GMRVWT/(GMRVHT*GMRVHT),0,0 < . . .S GBLANK=$$REPEAT^XLFSTR(" ",29-$L(^TMP($J,"GRPC < . . . Q < . . Q < .S ^TMP($J,"GRPC",GJ)=^TMP($J,"GRPC",GJ)_" "_$S(GMVU < . S ^TMP($J,"GRPC",GJ)=^TMP($J,"GRPC",GJ)_" "_$S(GPO2 | . I GPO2[" l/min" S ^TMP($J,"GRPC",GJ)=^TMP($J,"GRPC" Only in ./VADemo/r1/: GMVPXRM.m diff -y --suppress-common-lines ./VADemo/r1/GMVRPCM.m ./VADemo/r2/r/GMVRPCM.m GMVRPCM ; HOIFO/DP - RPC for Vitals Manager ;6/20/03 12:08 | GMVRPCM ; HOIFO/DP - RPC for Vitals Manager ;8/9/02 15:21 ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 > ; #908 [Controlled] ^SC references > ; #10039 [Supported] File 42 references > ; #10045 [Supported] XUSHSHP > ; #2241 [Supported] XUSRB1 Call ; #4084 [Private] File 44 AC x-ref < > ; > ; > ; > ; > ; > ; > ; I +DATA=44 S DATA2=$P(DATA,U,2),DATA=+DATA < .S GMVSCRN="I $$VITALIEN^GMVUTL8()[("",""_+Y_"","")" | .S GMVSCRN="I "",8,9,21,20,5,21,3,22,1,2,19,""[("","" .N CNT S X=DATA2,CNT=0 | .F X=0:0 S X=$O(^SC(X)) Q:'X D:$P(^(X,0),U,3)="C" .F S X=$O(^SC("AC","C",X)) Q:'X!(CNT>100) D < ..S @RESULTS@($O(@RESULTS@(""),-1)+1)=DATA_";"_X_U_$P | ..S @RESULTS@($O(@RESULTS@(""),-1)+1)=DATA_";"_X_U_$P > ; .S GMVIEN=$O(^GMRD(120.52,"AA",GMVIT,GMVCAT,GMVNAM,0) | .S GMVIEN=$O(^(GMVNAM,0)) ; Assume on one of this na > ; > ; NEWQUAL ; [Procedure] Create New Qualifier | ; > NEWQUAL ; [Procedure] Creatre New Qualifier > ; > ; > ; > ; > ; > ; > ; > ; > ; Q:X="DIC(4.2," 1 ;Domain | Q:X="DIC(4.2," 1 ; Domain Q:X="DIC(4," 2 ; Institution | Q:X="DIC(4," 2 ; Institution Q:X="SC(" 3 ; Hospital Location | Q:X="SC(" 3 ; Hospital Location Q:X="VA(200," 4 ; New Person | Q:X="VA(200," 4 ; New Person Q 0 ; Unknown | Q 0 ; Unknown ; | ; VT ;VitalTypeIENS < N X,Y,Z < S Y=0,@RESULTS@(0)="-1" < F X="T","P","R","BP","HT","WT","PN","PO2","CVP","CG" < .S Z=$O(^GMRD(120.51,"C",X,0)) < .Q:'Z < .S Y=Y+1,@RESULTS@(Y)=Z < Q < diff -y --suppress-common-lines ./VADemo/r1/GMVRPCP.m ./VADemo/r2/r/GMVRPCP.m GMVRPCP ;HOIFO/DP-RPC for GMV_PtSelect.pas ;6/24/03 13:04 | GMVRPCP ;HOIFO/DP-RPC for GMV_PtSelect.pas ;8/14/02 15:38 ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 > ; IA# 3020 [Supported] Calls to GUIBS5A^DPTLK6 > ; IA# 3023 [Supported] Calls to GUIMTD^DPTLK6 ; IA# 3266 [Controlled] Calls to DOB^DPTLK1 | ; IA# 3266 [Supported] Calls to DOB^DPTLK1 ; IA# 3267 [Controlled] Calls to SSN^DPTLK1 | ; IA# 3267 [Supported] Calls to SSN^DPTLK1 ; IA# 10039 [Supported] Reads of ^DIC(42,#,44) | ; IA# 10037 [Supported] Calls to EN~DGRPD ; IA# 10061 [Supported] Calls to VADPT | ; IA# 10039 [Supported] Reads of ^DIC(42,#,33) Only in ./VADemo/r2/r/: GMVTBL0.m Only in ./VADemo/r2/r/: GMVTBL1.m Only in ./VADemo/r2/r/: GMVTBL2.m Only in ./VADemo/r2/r/: GMVTBL3.m Only in ./VADemo/r2/r/: GMVTBL4.m diff -y --suppress-common-lines ./VADemo/r1/GMVUTL1.m ./VADemo/r2/r/GMVUTL1.m GMVUTL1 ;HOIFO/YH,FT-EXTRACT CLINIC LIST AND MARK VITALS ENTE | GMVUTL1 ;HOIFO/YH,FT-EXTRACT CLINIC LIST AND MARK VITALS ENTE ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 > ; #908 - ^SC( references (controlled) Only in ./VADemo/r2/r/: GMVUTL5.m diff -y --suppress-common-lines ./VADemo/r1/GMVUTL8.m ./VADemo/r2/r/GMVUTL8.m GMVUTL8 ;HIOFO/DS-RPC API TO RETURN ALL VITALS/CATOGORIES/QUA | GMVUTL8 ;HIOFO/DS-RPC API TO RETURN ALL VITALS/CATOGORIES/QUA ;;5.0;GEN. MED. REC. - VITALS;**1**;Oct 31, 2002 | ;;5.0;GEN. MED. REC. - VITALS;;Oct 31, 2002 TYPE(RESULT,GMVTYPE) ;GMV GET VITAL TYPE IEN [RPC entry po < ; Input: < ; RESULT = variable name to hold result < ; GMVTYPE = Name of Vital Type (from FILE 120.51) (e < ; Output: Returns the IEN if GMVTYPE exists in FILE 1 < ; else returns -1 < ; < I GMVTYPE="" S RESULT=-1 Q < S RESULT=+$O(^GMRD(120.51,"B",GMVTYPE,0)) < Q < CATEGORY(RESULT,GMVCAT) ;GMV GET CATEGORY IEN [RPC entry poin < ; Input < ; RESULT = variable name to hold result < ; GMVCAT = Name of Category (from FILE 120.53) (e.g. < ; Output: Returns the IEN if GMVTYPE exists in FILE 1 < ; else returns -1 < I GMVCAT="" S RESULT=-1 Q < S RESULT=+$O(^GMRD(120.53,"B",GMVCAT,0)) < Q < VITALIEN() ;Returns the Vital Type IENS in a list separa < ; ex: ",,8,9,21,20,5,3,22,1,2,19," < ; < N GMVABB,GMVIEN,GMVLIST < S GMVLIST="" < F GMVABB="BP","T","R","P","HT","WT","CVP","CG","PO2", < .S GMVIEN=$O(^GMRD(120.51,"C",GMVABB,0)) < .Q:'GMVIEN < .S GMVLIST=GMVLIST_","_GMVIEN < .Q < I $L(GMVLIST)'="," S GMVLIST=GMVLIST_"," < Q GMVLIST < ; < Only in ./VADemo/r1/: GMVVDEF1.m Only in ./VADemo/r1/: GMVVDEFK.m diff -y --suppress-common-lines ./VADemo/r1/HLCHK.m ./VADemo/r2/r/HLCHK.m HLCHK ;AISC/SAW-Validate HL7 Messages Received ;3/24/2004 | HLCHK ;AISC/SAW-Validate HL7 Messages Received ;4/28/95 09 ;;1.6;HEALTH LEVEL SEVEN;**1,108**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**1**;Oct 13, 1995 ; patch HL*1.6*108 start | S HLDAP=+$O(^HL(771,"B",HLDAN,0)) I 'HLDAP S HLDAN=$$ ;S HLDAP=+$O(^HL(771,"B",HLDAN,0)) I 'HLDAP S HLDAN=$ < S HLDAP=+$O(^HL(771,"B",$E(HLDAN,1,30),0)) I 'HLDAP S < ; patch HL*!.6*108 end < ; < diff -y --suppress-common-lines ./VADemo/r1/HLCS2.m ./VADemo/r2/r/HLCS2.m HLCS2 ;SF/JC - More Communication Server utilities ; 12/31/ | HLCS2 ;SF/JC - More Communication Server utils ;09/20/2001 ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,10 | ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82**;29- . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$ | . I $P(HLPARM4,U,3)="M",^%ZOSF("OS")'["OpenM" Q . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109 | . D FILE^DIE("","HLJ") . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$ | . I $P(HLPARM4,U,3)="M",^%ZOSF("OS")'["OpenM" Q .. D FILE^HLDIE("","HLJ","","STRT","HLCS2") ; HL*1.6* | .. D FILE^DIE("","HLJ") diff -y --suppress-common-lines ./VADemo/r1/HLCSAS1.m ./VADemo/r2/r/HLCSAS1.m HLCSAS1 ;ISCSF/RWF - Read data ;02/05/2004 08:06 | HLCSAS1 ;ISCSF/RWF - Read data ;08/24/99 08:06 ;;1.6;HEALTH LEVEL SEVEN;**43,57,91,109**;Oct 13, 199 | ;;1.6;HEALTH LEVEL SEVEN;**43,57,91**;Jul 17,1995 D FILE^HLDIE("K","HLJ","","SAVE","HLCSAS1") ;HL*1.6*1 | D FILE^DIE("K","HLJ") D FILE^HLDIE("","HLJ","","SNMSP","HLCSAS1") ; HL*1.6* | D FILE^DIE("","HLJ") diff -y --suppress-common-lines ./VADemo/r1/HLCSDR2.m ./VADemo/r2/r/HLCSDR2.m ;;1.6;HEALTH LEVEL SEVEN;**2,9,62,109**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**2,9,62**;Oct 13, 1995 . D FILE^HLDIE("","HLJ","","MONITOR","HLCSDR2") ; HL* | . D FILE^DIE("","HLJ") diff -y --suppress-common-lines ./VADemo/r1/HLCSHDR1.m ./VADemo/r2/r/HLCSHDR1.m ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93**;Oct 13 | ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80**;Oct 13, 1 D RESET^HLCSHDR3 ;HL*1.6*93 < D RESET^HLCSHDR3 ;HL*1.6*93 < ; < Only in ./VADemo/r1/: HLCSHDR3.m Only in ./VADemo/r1/: HLCSHDR4.m Only in ./VADemo/r1/: HLCSHDR5.m Only in ./VADemo/r1/: HLCSHDR6.m diff -y --suppress-common-lines ./VADemo/r1/HLCSIN.m ./VADemo/r2/r/HLCSIN.m ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115**;Oc | ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62**;Oct 13, 19 N HLXX,HLD0,HLPCT | N HLXX,HLD0 . ; HL*1.6*109 | . L +^HLCS(870,HLXX,"INFILER"):1 Q:'$T ;Does another . L +^HLMA("AC","I",HLXX):0 Q:'$T ;*109*Does another < . ; HL*1.6*109 changes in for loop below, and post-qu | . F S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0 D . ; on following lines. | . L -^HLCS(870,HLXX,"INFILER") . S HLPCT=0 ; Counter whether filer should stop every < .;**109 - insure queue last processed at least 2 seco < . I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2) < . F S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0!(HL < . . S HLPCT=HLPCT+1 < . . I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEX < . . L +^HLMA(HLD0):0 Q:'$T < . . I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q ;-> < . . D DEFACK^HLTP3(HLXX,HLD0) < . . D DEQUE^HLCSREP(HLXX,"I",HLD0) < . . L -^HLMA(HLD0) < . ;**109 -add dt/tm stamp to time queue last processe < . S ^XTMP("HL7-AC","I",HLXX)=$H < . ;**109 -unlock the queue < . L -^HLMA("AC","I",HLXX) < ; < CHECKAC(WAY,IEN870,IEN773) ; If AC xref shouldn't exist, < ; < ; Check status and if 3 (processed) kill XREF... < I $P($G(^HLMA(+IEN773,"P")),U)=3 D QUIT "" ;-> < . D DEQUE^HLCSREP(IEN870,WAY,IEN773) < ; < ; Add other checks here in the future... < ; < Q 1 < ; < .; HL*1.6*109 | . L +^HLCS(870,HLXX,"INFILER"):1 Q:'$T ;Does another . L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T ;Does another < . L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T | . F L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):1 Q: diff -y --suppress-common-lines ./VADemo/r1/HLCSLM.m ./VADemo/r2/r/HLCSLM.m HLCSLM ;SFCIOFO/AC - HL7 LINK MANAGER ;02/04/2004 07:57 | HLCSLM ;SFCIOFO/AC - HL7 LINK MANAGER ;12/01/99 07:57 ;;1.6;HEALTH LEVEL SEVEN;**49,57,109**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**49,57**;JUL 17,1995 ; < N %,HLEVLCHK,HLTSKCNT | N %,HLTSKCNT D SAVDOLRH | D SAVDOLRH H 10 D CHECKMST^HLEVMST ;HL*1.6*109 - Make sure event moni < H 10 < D FILE^HLDIE("","HLJ","","EXIT","HLCSLM") ;HL*1.6*109 | D FILE^DIE("","HLJ") D FILE^HLDIE("","HLJ","","SAVDOLRH","HLCSLM") ;HL*1.6 | D FILE^DIE("","HLJ") D FILE^HLDIE("","HLJ","","INIT","HLCSLM") ;HL*1.6*109 | D FILE^DIE("","HLJ") ; | F L +^HLCS(870,+DA,0):2 Q:$T ;**109** < ;F L +^HLCS(870,+DA,0):2 Q:$T < ; < ; | L -^HLCS(870,+DA,0) ;**109 < ;L -^HLCS(870,+DA,0) < ; < ; < ;**109** < ; < D FILE^HLDIE("","HLJ","","SAVTSK","HLCSLM") ; HL*1.6* | D FILE^DIE("","HLJ") ; < ;**109** < ; < diff -y --suppress-common-lines ./VADemo/r1/HLCSLNCH.m ./VADemo/r2/r/HLCSLNCH.m HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;12/31/2 | HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;04/27/2 ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109**; | ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75**;Oct 13, I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be | I 'HLTYPTR W !,*7,"A Lower Layer Protocol must be sel I HLBGR="" W !,$C(7),"No routine has been specified f | I HLBGR="" W !,*7,"No routine has been specified for I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$ | ;JG GTM COMBINE WITH PATCH 84 . W !,$C(7),"This LLP is a multi-threaded server. It | I $P(HLPARM4,U,3)="M",^%ZOSF("OS")'["OpenM"&(^%ZOSF(" > . W !,*7,"This LLP is an Multi-Threaded Server. It is I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last starte | I $P(HLPARM0,U,10) W !,*7,"The LLP was last started o . W !,$C(7),"NOTE: The lower level protocol for this | . W !,*7,"NOTE: The lower level protocol for this app .;4=status 9=Time Started, 10=Time Stopped, 11=Task N | .;4=status 9=Time Started, 10=Time Stopped, 11=Task N .E W !,$C(7),"Unable to enable this LLP !" Q | .E W !,*7,"Unable to enable this LLP !" Q .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6 | .D FILE^DIE("","HLJ") I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$ | I $P(HLPARM4,U,3)="M",^%ZOSF("OS")'["OpenM"&(^%ZOSF(" . W !,$C(7),"This LLP is a multi-threaded server. It | . W !,*7,"This LLP is an Multi Server. It is controll I $P(HLPARM0,U,15) W !,$C(7),"The lower level protoco | I $P(HLPARM0,U,15) W !,*7,"The lower level protocol i I $P(HLPARM0,U,10) W !,$C(7),"The lower level protoco | I $P(HLPARM0,U,10) W !,*7,"The lower level protocol w D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6* | D FILE^DIE("","HLJ") I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%Z | I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPAR . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logi | . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logi diff -y --suppress-common-lines ./VADemo/r1/HLCSLSM.m ./VADemo/r2/r/HLCSLSM.m HLCSLSM ;SFCIOFO/AC - HL7 LINK SUBMANAGER ;02/05/2004 07:42 | HLCSLSM ;SFCIOFO/AC - HL7 LINK SUBMANAGER ;12/01/99 07:42 ;;1.6;HEALTH LEVEL SEVEN;**49,57,109**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**49,57**;JUL 17,1995 D FILE^HLDIE("","HLJ","","EN","HLCSLSM") ; HL*1.6*109 | D FILE^DIE("","HLJ") diff -y --suppress-common-lines ./VADemo/r1/HLCS.m ./VADemo/r2/r/HLCS.m HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;05/09/200 | HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;11/09/99 ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109**;Oct | ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57**;Oct 13, .D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR | .D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR diff -y --suppress-common-lines ./VADemo/r1/HLCSMON1.m ./VADemo/r2/r/HLCSMON1.m HLCSMON1 ;SF-Utilities for Driver Program ;02/04/2004 | HLCSMON1 ;SF-Utilities for Driver Program ;06/12/2000 ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109**;Oct 13, | ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65**;Oct 13, 1995 D WDATA(45,19,IOELEOL,"",$$SLM^HLEVUTIL) ; HL*1.6*109 < diff -y --suppress-common-lines ./VADemo/r1/HLCSMON.m ./VADemo/r2/r/HLCSMON.m ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109** | ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73**;Oct R X#1:3 | R X#1:1 ; | L +^HLCS(870,HLXX,0):0 L -^HLCS(870,HLXX,0) D CHKLOCK ;**109** < ;L +^HLCS(870,HLXX,0):0 L -^HLCS(870,HLXX,0) D CHKLOC < ;**109** | L +^HLCS(870,HLXX,"IN QUEUE BACK POINTER"):0 D CHKLOC ;L +^HLCS(870,HLXX,"IN QUEUE BACK POINTER"):0 D CHKLO | L -^HLCS(870,HLXX,"IN QUEUE BACK POINTER") ;L -^HLCS(870,HLXX,"IN QUEUE BACK POINTER") < ; < ;**109** | L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 D CHKLO ;L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 D CHKL | L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER") ;L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER") < ; < ;**109** | L +^HLCS(870,HLXX,"OUT QUEUE BACK POINTER"):0 D CHKLO ;L +^HLCS(870,HLXX,"OUT QUEUE BACK POINTER"):0 D CHKL | L -^HLCS(870,HLXX,"OUT QUEUE BACK POINTER") ;L -^HLCS(870,HLXX,"OUT QUEUE BACK POINTER") < ; < ;**109** | L +^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER"):0 D CHKL ;L +^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER"):0 D CHK | L -^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER") ;L -^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER") < ; < diff -y --suppress-common-lines ./VADemo/r1/HLCSREP.m ./VADemo/r2/r/HLCSREP.m ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;;Oct 13, 1995 ; < ENQUE(LINK,DIR,IEN773) ; < ;This routine will place the message=IEN773 on the "A < ;Input: < ; DIR = "I" or "O", denoting the direction that the < ; LINK = the ien of the logical link < ; IEN773 = ien of the message in file 773 < ; < Q:'$G(LINK) < I DIR'="I",DIR'="O" Q < Q:'$G(IEN773) < S ^HLMA("AC",DIR,LINK,IEN773)="" < S $P(^HLMA(+IEN773,0),U,17)=+LINK ; HL*1.6*109 - lja < I DIR="O" D LLCNT^HLCSTCP(LINK,3) < Q < ; < DEQUE(LINK,DIR,IEN773) ; < ;This routine will remove the message=IEN773 on the " < ;Input: < ; DIR = "I" or "O", denoting the direction that the < ; LINK = the ien of the logical link < ; IEN773 = ien of the message in file 773 < ; < Q:'$G(LINK) < I DIR'="I",DIR'="O" Q < Q:'$G(IEN773) < K ^HLMA("AC",DIR,LINK,IEN773) < Q < diff -y --suppress-common-lines ./VADemo/r1/HLCSRPT1.m ./VADemo/r2/r/HLCSRPT1.m HLCSRPT1 ;ISC-SF/RAH-TRANS LOG PENDING MSG LIST;05/12/ | HLCSRPT1 ;ISC-SF/RAH-TRANS LOG PENDING MSG LIST;06/23/ ;;1.6;HEALTH LEVEL SEVEN;**19,50,107**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**19,50**;Oct 13, 1995 .. ;HL*1.6*107 start: to fix the multiple lines per | .. S LN2=LN2+1,LN1=LN1+1 .. ;S LN2=LN2+1,LN1=LN1+1 < .. S LN2=LN2+1 < .. ;HL*1.6*107 end < .. ;HL*1.6*107 start: to fix the multiple lines per s | .. S LN2=LN2+1,LN1=LN1+1 .. ;S LN2=LN2+1,LN1=LN1+1 < .. S LN2=LN2+1 < .. ;HL*1.6*107 end < diff -y --suppress-common-lines ./VADemo/r1/HLCSRPT2.m ./VADemo/r2/r/HLCSRPT2.m HLCSRPT2 ;ISC-SF/RAH-TRANS LOG ERROR LIST ;05/12/03 0 | HLCSRPT2 ;ISC-SF/RAH-TRANS LOG ERROR LIST ;06/23/99 1 ;;1.6;HEALTH LEVEL SEVEN;**50,85,107**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**50,85**;Oct 13, 1995 .. ;HL*1.6*107 start: to fix the multiple lines per s | .. S LN2=LN2+1,LN1=LN1+1 .. ;S LN2=LN2+1,LN1=LN1+1 < .. S LN2=LN2+1 < .. ;HL*1.6*107 end < .. ;HL*1.6*107 start: to fix the multiple lines per s | .. S LN2=LN2+1,LN1=LN1+1 .. ;S LN2=LN2+1,LN1=LN1+1 < .. S LN2=LN2+1 < .. ;HL*1.6*107 end < diff -y --suppress-common-lines ./VADemo/r1/HLCSTCP1.m ./VADemo/r2/r/HLCSTCP1.m HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/21/2001 | HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;20 Aug 200 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71**;JUL 17,19 | ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64**;JUL 17,1995 N HLMIEN,HLASTMSG | N HLMIEN,HLASTMSG,HLDEVICE ;JG GTM F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle | ;JG > S HLDEVICE=0 > F D Q:$$STOP^HLCSTCP!HLDEVICE I 'HLMIEN D MON^HLCS > . ;I $DEVICE D LOG^%ZISTCP("DEVICE: "_$DEVICE_" KEY: I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0 < > ;JG GTM > ;I $DEVICE D LOG^%ZISTCP("DEVICE: "_$DEVICE_" KEY: "_ > I $DEVICE S HLDEVICE=1 D CLEAN Q I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT | I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT .. D:HLMSG(HLINE,0)[HLDSTRT | .. S:'HLHDR HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT, ... S X=$L(HLMSG(HLINE,0),HLDSTRT) < ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HL < ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2) < ... D RESET:(HLINE>1) < .. ;mark that end block has been received < .. ;HLIND1=ien in 773^ien in 772^1 if end block was r < .. S $P(HLIND1,U,3)=1 < ;If the line is long and no move it into the arr | ;If the line is long and no move it into the arr . D RESET:(HLHDR&(HLINE>1)) < DELMSG(HLMAMT) ;delete message from Message Administration/M < N DIK,DA < S DA=+HLMAMT,DIK="^HLMA(" < D ^DIK < S DA=$P(HLMAMT,U,2),DIK="^HL(772," < D ^DIK < Q < . S:$P(HLIND1,U,3) $P(HLIND1,U,3)="" < I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOS | I $ZE["READ"!($ZE["NOTOPEN")!($ZE["DEVNOTOPN") D UNWI I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q | I $ZE["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q > D:$DEVICE UNWIND^%ZTER Q ;JG GTM RESET ;reset info as a result of no end block < N % < S HLMSG(1,0)=HLMSG(HLINE,0) < F %=2:1:HLINE K HLMSG(%,0) < S HLINE=1 < Q < diff -y --suppress-common-lines ./VADemo/r1/HLCSTCP2.m ./VADemo/r2/r/HLCSTCP2.m HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/17/2003 | HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;12 Nov 200 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76 | ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76 ;**109** < ;L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q | L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q ;L -^HLMA(HLMSG) | L -^HLMA(HLMSG) ; < K HLJ M HLJ=^HLMA(HLMSG,"MSH") | M HLJ=^HLMA(HLMSG,"MSH") I HLN("ACAT")="NE",HLN("APAT")="NE" D Q | I HLN("ACAT")="NE",HLN("APAT")="NE" D DONE(3) H $G(HL .D DONE(3) < .; < .; < .H $G(HLDWAIT) < ; < . ;HL*1.6*87: Read acknowledgement. | . ;HL*1.6*87: Read acknowledgement. .. Q:'X | .. Q:'X ... I "NE"[HLN("APAT") D Q | ... I "NE"[HLN("APAT") D DONE(3) Q ....D DONE(3) < ....; < ...; < ...; < ..; < ; < ;**109** < D DEQUE^HLCSREP(HLDP,"O",HLMSG) < ; < ; | F L +^HLMA(HLMSG,"P"):1 Q:$T H 1 ;**109** < ;F L +^HLMA(HLMSG,"P"):1 Q:$T H 1 < ; < .; | . L -^HLMA(HLMSG,"P") .;**109** < . D DEQUE^HLCSREP(HLDP,"O",HLMSG) < .;L -^HLMA(HLMSG,"P") < ;**end 109** < ; < ; | S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0 ;**109** < ;S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0 < S X=+^HLMA(HLMSG,"P") Q:X=3 0 < ; < ; | L -^HLMA(HLMSG,"P") ;**109** < ;L -^HLMA(HLMSG,"P") < ; < .. I X]"" W X,! | .. I X]"" W X,@IOF ;JG U IO W X,! | U IO W X,@IOF ;JG RDERR D RDERR^HLCSTCP4 Q ; Exceeded 10,000 bytes, so split | RDERR ; Error during read process, decrement counter ERROR D ERROR^HLCSTCP4 Q ; Exceeded 10,000 bytes, so split | D LLCNT^HLCSTCP(HLDP,4,1) > ERROR ; Error trap > ; OPEN ERROR-retry. > ; WRITE ERROR (SERVER DISCONNECT)-close channel, retr > I $G(HLMSG) L -^HLMA(HLMSG) > S $ETRAP="D UNWIND^%ZTER" > I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^% > I $$EC^%ZOSV["WRITE" D Q ;HL*1.6*77 modifications s > . D CC("Wr-err") > . S:$G(HLPRIO)="I" HLERROR="108^Write Error" > . D UNWIND^%ZTER ;HL*1.6*77 modifications end here > I $$EC^%ZOSV["READ" D CC("Rd-err") S:$G(HLPRIO)="I" H > S HLCSOUT=1 D ^%ZTER,CC("Error"),SDFLD^HLCSTCP > S:$G(HLPRIO)="I" HLERROR="9^Error" > D UNWIND^%ZTER > Q Only in ./VADemo/r1/: HLCSTCP4.m Only in ./VADemo/r1/: HLCSTCPA.m diff -y --suppress-common-lines ./VADemo/r1/HLCSTCP.m ./VADemo/r2/r/HLCSTCP.m HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;12/31/2003 | HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;15 Aug 2002 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109** | ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64**;JUL 17 ;multi-threaded listener (OpenM) | ;multi-threaded listener (OpenM,GTM) JG I $G(HLTCPCS)="M",^%ZOSF("OS")["OpenM" D Q | I $G(HLTCPCS)="M",^%ZOSF("OS")["OpenM"!(^%ZOSF("OS")[ > ;Q:$DEVICE ;JG GTM CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called fro | GTM ;Entry point for VMS TCPIP to GT.M, Called from the H ;listener, % = HLDP | ;U $P S K=$KEY D LOG("$P",$P),LOG("KEY",K) I $G(%)="" D ^%ZTER Q | S $ET="D LOG^HLCSTCP(""ERROR"",$$EC^%ZOSV) Q" S (IO,IO(0))="SYS$NET",HLDP=% | S IO="SYS$NET" D LOG("EP","GTM^HLSCTCP") ; **Cache'/VMS specific code** | O IO U IO:(WIDTH=512:DELIMITER=$C(4)) S K=$KEY D LOG( O IO::5 E D MON("Openfail") Q | U IO R X#4:4 W X,# X "U IO:(::""-M"")" ;Packet mode like DSM | Q D LISTEN C IO Q | LOG(IX,V) ;LOG ; | Q ;4=status 9=Time Started, 10=Time Stopped, 11=Task Nu | ;4=status 9=Time Started, 10=Time Stopped, 11=Task Nu D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109 | D FILE^DIE("","HLJ") I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ", | I X S HLJ(870,HLDP_",",3)="MS" D FILE^DIE("","HLJ") D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*1 | D FILE^DIE("","HLJ") D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6* | D FILE^DIE("","HLJ") I $D(ZTQUEUED) S ZTREQ="@" < I $D(ZTQUEUED) S ZTREQ="@" < Only in ./VADemo/r1/: HLDIE772.m Only in ./VADemo/r1/: HLDIE773.m Only in ./VADemo/r1/: HLDIEDB0.m Only in ./VADemo/r1/: HLDIEDB1.m Only in ./VADemo/r1/: HLDIEDB2.m Only in ./VADemo/r1/: HLDIEDB3.m Only in ./VADemo/r1/: HLDIEDBG.m Only in ./VADemo/r1/: HLDIE.m Only in ./VADemo/r1/: HLEMDD.m Only in ./VADemo/r1/: HLEME1.m Only in ./VADemo/r1/: HLEME.m Only in ./VADemo/r1/: HLEMEP.m Only in ./VADemo/r1/: HLEMP1.m Only in ./VADemo/r1/: HLEMP.m Only in ./VADemo/r1/: HLEMRCV.m Only in ./VADemo/r1/: HLEMSA.m Only in ./VADemo/r1/: HLEMSE1.m Only in ./VADemo/r1/: HLEMSE.m Only in ./VADemo/r1/: HLEMSH.m Only in ./VADemo/r1/: HLEMSL1.m Only in ./VADemo/r1/: HLEMSL.m Only in ./VADemo/r1/: HLEMSND.m Only in ./VADemo/r1/: HLEMST.m Only in ./VADemo/r1/: HLEMSU.m Only in ./VADemo/r1/: HLEMT.m Only in ./VADemo/r1/: HLEMU.m diff -y --suppress-common-lines ./VADemo/r1/HLERCHK.m ./VADemo/r2/r/HLERCHK.m HLERCHK ;SFCIOFO/JC - Interface Debugger ;02/25/2004 14:25 | HLERCHK ;SFCIOFO/JC - Interface Debugger ;09/15/99 11:04 ;;1.6;HEALTH LEVEL SEVEN;**57,96,108**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**57**;Oct 13, 1995 ;patch HL*1.6*96 start: add application ack for HL7 v | S HLACK="ACK,ADR,MCF,MFK,MFR,ORF,ORR,RRA,RRD,RRE,RRG" S HLACK="ACK,ADR,ARD,EDR,ERP,MCF,MFK,MFR,ORF,ORG,ORR, < S HLACK=HLACK_"RDR,RDY,RER,RGR,ROR,RRA,RRD,RRE,RRG,RR < S HLACK=HLACK_"TBR,VXR,VXX" < ;patch HL*1.6*96 end < ;patch HL*1.6*108 start: add application ack for HL7 < S HLACK=HLACK_",BRP,BRT,ORB,ORI" < ;patch HL*1.6*108 end < Only in ./VADemo/r1/: HLEVAPI0.m Only in ./VADemo/r1/: HLEVAPI1.m Only in ./VADemo/r1/: HLEVAPI2.m Only in ./VADemo/r1/: HLEVAPI3.m Only in ./VADemo/r1/: HLEVAPI.m Only in ./VADemo/r1/: HLEVMNU.m Only in ./VADemo/r1/: HLEVMST0.m Only in ./VADemo/r1/: HLEVMST.m Only in ./VADemo/r1/: HLEVREP0.m Only in ./VADemo/r1/: HLEVREP1.m Only in ./VADemo/r1/: HLEVREP2.m Only in ./VADemo/r1/: HLEVREP3.m Only in ./VADemo/r1/: HLEVREP.m Only in ./VADemo/r1/: HLEVSRV0.m Only in ./VADemo/r1/: HLEVSRV1.m Only in ./VADemo/r1/: HLEVSRV2.m Only in ./VADemo/r1/: HLEVSRV3.m Only in ./VADemo/r1/: HLEVSRV4.m Only in ./VADemo/r1/: HLEVSRV.m Only in ./VADemo/r1/: HLEVSTUP.m Only in ./VADemo/r1/: HLEVUTI0.m Only in ./VADemo/r1/: HLEVUTI1.m Only in ./VADemo/r1/: HLEVUTI2.m Only in ./VADemo/r1/: HLEVUTI3.m Only in ./VADemo/r1/: HLEVUTIL.m Only in ./VADemo/r1/: HLEVX000.m Only in ./VADemo/r1/: HLEVX001.m Only in ./VADemo/r1/: HLEVX002.m Only in ./VADemo/r1/: HLEVX003.m Only in ./VADemo/r1/: HLEVX.m diff -y --suppress-common-lines ./VADemo/r1/HLFNC2.m ./VADemo/r2/r/HLFNC2.m HLFNC2 ;AISC/SAW-Continuation of HLFNC, Additional Functions | HLFNC2 ;AISC/SAW-Continuation of HLFNC, Additional Functions ;;1.6;HEALTH LEVEL SEVEN;**2,26,57,59,101**;Oct 13, 1 | ;;1.6;HEALTH LEVEL SEVEN;**2,26,57,59**;Oct 13, 1995 S HL("PID")=$S($P(X,"^",6)="D":"D",1:$P($$PARAM^HLCS2 | S HL("PID")=$TR($P(X,"^",6),"dtp","DTP"),HL("VER")=$P RSPINIT(EIDS,HL) ;Initialize Variables in HL array for < ; < ;This is a subroutine call with parameter passing tha < ;array of values in the variable specified by the par < ;error occurs, the array of values is returned. Othe < ;value HL is returned equal to the following: error < ; < ;Required Input Parameters < ; EIDS = Name or IEN of the subscriber protocol in < ; Protocol file for which the initializati < ; to be returned < ; HL = The variable in which the array of values < ; This parameter must be passed by referen < ; < ;Check for required input parameter < I $G(EIDS)="" S HL="7^Missing EIDS Input Parameter" Q < ;Convert EIDS to IEN if necessary < I 'EIDS S EIDS=$O(^ORD(101,"B",EIDS,0)) I 'EIDS S HL= < N X0,X,X1,X2 < ;Get node 770 from file 101 and node 0 from file 771 < S X0=$G(^ORD(101,EIDS,0)) < S X=$G(^ORD(101,EIDS,770)),X1=$G(^HL(771,+$P(X,"^",2) < I X1']"" S HL="15^"_"Subscriber Application Missing i < ;Set HL array variables < S HL("RFS")=$G(^HL(771,+$P(X,"^",2),"FS")),HL("RECH") < S HL("RAN")=$P(X1,"^") < S HL("RMTN")=$P($G(^HL(771.2,+$P(X,"^",11),0)),"^"),H < Q < Only in ./VADemo/r1/: HLLOG.m diff -y --suppress-common-lines ./VADemo/r1/HLMA0.m ./VADemo/r2/r/HLMA0.m HLMA0 ;AISC/SAW-Message Administration Module (Cont'd) ;7/1 | HLMA0 ;AISC/SAW-Message Administration Module (Cont'd) ;05/ ;;1.6;HEALTH LEVEL SEVEN;**34,109**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**34**;Oct 13, 1995 D STATUS^HLTF0(HLMTIEN,$S(HLRESLT:4,1:3),$S(HLRESLT:+ | D STATUS^HLTF0(HLMTIEN,$S(HLRESLT:4,1:3),$S(HLRESLT:+ diff -y --suppress-common-lines ./VADemo/r1/HLMA1.m ./VADemo/r2/r/HLMA1.m ;;1.6;HEALTH LEVEL SEVEN;**19,43,91,109,108**;Oct 13, | ;;1.6;HEALTH LEVEL SEVEN;**19,43,91**;Oct 13, 1995 ; < ;HLRESLTA is to return the results and should not be < K HLRESLTA < ; < diff -y --suppress-common-lines ./VADemo/r1/HLMA2.m ./VADemo/r2/r/HLMA2.m HLMA2 ;AISC/SAW-Message Administration Module ;10/24/2003 | HLMA2 ;AISC/SAW-Message Administration Module ;09/20/2001 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,64,65,76,82,91 | ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,64,65,76,82,91 .; | . F L +^HLMA(MTIENS):1 Q:$T H 1 .;**109 < .; F L +^HLMA(MTIENS):1 Q:$T H 1 < .; < ..;**109** | .. D STATUS^HLTF0(MTIENS,4,12,HLERROR) L -^HLMA(MTIEN ..; D STATUS^HLTF0(MTIENS,4,12,HLERROR) L -^HLMA(MTIE < .. D STATUS^HLTF0(MTIENS,4,12,HLERROR) < ..; < . K HLJ < . D FILE^HLDIE("","HLJ","","SEND","HLMA2") ;HL*1.6*10 | . D FILE^DIE("","HLJ") .D ENQUE^HLCSREP(LOGLINK,"O",MTIENS) | . L -^HLMA(MTIENS) .; < .;**109 < .; L -^HLMA(MTIENS) < ; | F L +^HLMA(MTIENS):1 Q:$T H 1 ;**109** < ;F L +^HLMA(MTIENS):1 Q:$T H 1 < ; < .; | . D STATUS^HLTF0(MTIENS,4,12,HLERROR) L -^HLMA(MTIENS .;**109** < .; D STATUS^HLTF0(MTIENS,4,12,HLERROR) L -^HLMA(MTIEN < . D STATUS^HLTF0(MTIENS,4,12,HLERROR) < .; < .; | . L -^HLMA(HLMSG) D MON^HLCSTCP("Idle") .;**109** < .; L -^HLMA(HLMSG) D MON^HLCSTCP("Idle") < . D MON^HLCSTCP("Idle") < .; < K HLJ S X=MTIENS_",",HLJ(773,X,7)=LOGLINK,HLJ(773,X,2 | S X=MTIENS_",",HLJ(773,X,7)=LOGLINK,HLJ(773,X,200)="H ; | D FILE^DIE("","HLJ") D FILE^HLDIE("","HLJ","","DC","HLMA2") ; HL*1.6*109 < ; < ;**109** < D LLCNT^HLCSTCP(LOGLINK,3) < ; < S X=HLRESP D INIT^HLTP3A ;patch HL*1.6*109 - hltp3 r | S X=HLRESP D INIT^HLTP3 EXIT2 ; | EXIT2 L -^HLMA(HLMSG) ;**109** < ;L -^HLMA(HLMSG) < diff -y --suppress-common-lines ./VADemo/r1/HLMA.m ./VADemo/r2/r/HLMA.m HLMA ;AISC/SAW-Message Administration Module ;02/27/2004 | HLMA ;AISC/SAW-Message Administration Module ;12 Nov 2002 ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,1 | ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66**;Oct 13, 1 ; HLP("NAMESPACE") = Passed in by application namespa < ; < I $D(HLL("LINKS")) D G:$G(HLRESLT)]"" EXIT < . N I,HLPNAM,HLPIEN,HLLNAM,HLLIEN < . S I=0 < . F S I=$O(HLL("LINKS",I)) Q:'I D Q:$G(HLRESLT)]"" < . . S HLPNAM=$P(HLL("LINKS",I),U) < . . S HLPIEN=+$O(^ORD(101,"B",HLPNAM,0)) < . . I $P($G(^ORD(101,HLPIEN,0)),U,4)'="S" S HLRESLT=" < . . S HLLNAM=$P(HLL("LINKS",I),U,2) < . . S HLLIEN=+$O(^HLCS(870,"B",HLLNAM,0)) < . . I '$D(^HLCS(870,HLLIEN,0)) S HLRESLT="0^15^Invali < . W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, rest | . W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF ;JG ;I $ZE["READ" S HLCS="-1^Error during read" | I $ZE["READ" S HLCS="-1^Error during read" ;I $ZE["WRITE" S HLCS="-1^Error during write" | I $ZE["WRITE" S HLCS="-1^Error during write" ; HL*1.6*115, SACC compliance < I $$EC^%ZOSV["READ" S HLCS="-1^Error during read" < I $$EC^%ZOSV["WRITE" S HLCS="-1^Error during write" < Only in ./VADemo/r1/: HLP109EN.m Only in ./VADemo/r1/: HLP109.m Only in ./VADemo/r2/r/: HLPAT96A.m Only in ./VADemo/r2/r/: HLPAT96B.m Only in ./VADemo/r2/r/: HLPAT96.m diff -y --suppress-common-lines ./VADemo/r1/HLSUB.m ./VADemo/r2/r/HLSUB.m HLSUB ;IRMFO-SF/JC - Subscription Registry ;03/24/2004 14: | HLSUB ;IRMFO-SF/JC - Subscription Registry ;09/27/2001 10: ;;1.6;HEALTH LEVEL SEVEN;**14,57,58,59,66,83,108**;Oc | ;;1.6;HEALTH LEVEL SEVEN;**14,57,58,59,66,83**;Jan 29 ; | I $G(HLRAP)]"",'$O(^HL(771,"B",HLRAP,0)) S HLER(6)="I ; patch HL*1.6*108 start < ;I $G(HLRAP)]"",'$O(^HL(771,"B",HLRAP,0)) S HLER(6)=" < I $G(HLRAP)]"",'$O(^HL(771,"B",$E(HLRAP,1,30),0)) S H < ; patch HL*1.6*108 end < ; < diff -y --suppress-common-lines ./VADemo/r1/HLTF0.m ./VADemo/r2/r/HLTF0.m ;;1.6;HEALTH LEVEL SEVEN;**12,19,64,91,109**;Oct 13, | ;;1.6;HEALTH LEVEL SEVEN;**12,19,64,91**;Oct 13, 1995 STATUS(MTIEN,STATUS,ERR,ERRTEXT,COMDT,NOEVENT) ;Update Statu | STATUS(MTIEN,STATUS,ERR,ERRTEXT,COMDT) ;Update Status of Ent ; NOEVENT = 1 if an event should NOT be logged. Pre < ;**109** F L +@HLOCK:1 Q:$T H 1 | F L +@HLOCK:1 Q:$T H 1 D FILE^HLDIE("","HLJ","","STATUS","HLTF0") ;HL*1.6*10 | D FILE^DIE("","HLJ") ;**109** L -@HLOCK | L -@HLOCK ; < ;if the status is error, and the event is not being s < ;application, log a new event < I '$G(NOEVENT),$G(STATUS)=4 D < .N CODE,HL7MSGID,ERROR,PARENT,EVENT < .S CODE=$G(ERR) < .S (HL7MSGID,PARENT)="" < .I $G(MTIEN) D < ..N NODE < ..I $G(HLTCP) D < ...S NODE=$G(^HLMA(MTIEN,0)) < ...S HL7MSGID=$P(NODE,"^",2) < ...S PARENT=$P(NODE,"^",6) < ..E D < ...S NODE=$G(^HL(772,MTIEN,0)) < ...S HL7MSGID=$P(NODE,"^",6) < ...S PARENT=$P(NODE,"^",8) < .; < .S EVENT=$$EVENT^HLEME(CODE,"HEALTH LEVEL SEVEN",HL7M < .;I 'EVENT,'$D(ZTQUEUED) W !,"Failed to create an Eve < .; < .I EVENT D < ..I $L($G(ERRTEXT)),$$ADDNOTE^HLEME(EVENT,"Applicatio < ..;If this message was not the initial message in a t < ..I PARENT,PARENT'=$G(MTIEN) D < ...N PLINK,PMSGID,PMSGTYPE,PNODE,PEVENT,PNOTES < ...I $D(HLTCP) D < ....S PNODE=$G(^HLMA(PARENT,0)) < ....S PLINK=$P(PNODE,"^",7) < ....S PMSGID=$P(PNODE,"^",2) < ....S PMSGTYPE=$P(PNODE,"^",13) < ....S PEVENT=$P(PNODE,"^",14) < ...E D < ....S PNODE=$G(^HL(772,PARENT,0)) < ....S PLINK=$P(PNODE,"^",11) < ....S PMSGID=$P(PNODE,"^",6) < ....S PMSGTYPE="" < ....S PEVENT="" < ...S PNOTES(1)="Initial Message in this transaction p < ...S PNOTES(2)=" Initial Message ID: "_PMSGID < ...S PNOTES(3)=" Logical Link of Initial Message: " < ...S:PLINK PNOTES(3)=PNOTES(3)_$P($G(^HLCS(870,PLINK, < ...S:PMSGTYPE PNOTES(4)=" Inital Message Type: "_$P( < ...S:PEVENT PNOTES(5)=" Inital Message Event: "_$P($ < ...I $$ADDNOTE^HLEME(EVENT,.PNOTES) ;then notes succe < ; < ;**109** F L +^HL(772,MTIEN):1 H:'$T 1 I $T D Q | F L +^HL(772,MTIEN):1 H:'$T 1 I $T D Q D < ;**109** . L -^HL(772,MTIEN) | . L -^HL(772,MTIEN) ;**109** F L +@HLOCK:1 Q:$T H 1 | F L +@HLOCK:1 Q:$T H 1 D FILE^HLDIE("","HLJ","","UPDATE","HLTF0") ; HL*1.6*1 | D FILE^DIE("","HLJ") ;**109** L -@HLOCK | L -@HLOCK diff -y --suppress-common-lines ./VADemo/r1/HLTF.m ./VADemo/r2/r/HLTF.m ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109**;Oct 13, 1 | ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55**;Oct 13, 1995 . S Y=$$STUB772(X) ; This call substituted for D FILE | . D FILE^DICN . S Y=$$STUB773(X) ; This call substituted for D FILE | . D FILE^DICN D FILE^HLDIE("","HLJ","","MAID","HLTF") ;HL*1.6*109 | D FILE^DIE("","HLJ") D FILE^HLDIE("","HLJ","","CHNGMID","HLTF") ; HL*1.6*1 | D FILE^DIE("","HLJ") ; < STUB772(FLD01,OS) ; < ;This function creates a new stub record in file 772. < ;Inputs: < ; OS (optional), the value of ^%ZOSF("OS") < ; FLD01 (optional), the value for the .01 field < ;Output - the function returns the ien of the newly c < ; < N IEN < I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) < I OS'["DSM",OS'["OpenM" D < .F L +^HLCS(869.3,1,772):10 S IEN=+$G(^HLCS(869.3,1, < E D < .F S IEN=$I(^HLCS(869.3,1,772),1) S:$D(^HL(772,IEN)) < S ^HL(772,IEN,0)=$G(FLD01)_"^" < I $L($G(FLD01)) S ^HL(772,"B",FLD01,IEN)="" < Q IEN < ; < STUB773(FLD01,OS) ; < ;This function creates a new stub record in file 772. < ;Inputs: < ; OS (optional), the value of ^%ZOSF("OS") < ; FLD01 (optional), the value for the .01 field < ;Output - the function returns the ien of the newly c < ; < N IEN < I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) < I OS'["DSM",OS'["OpenM" D < .F L +^HLCS(869.3,1,773):10 S IEN=+$G(^HLCS(869.3,1, < E D < .F S IEN=$I(^HLCS(869.3,1,773),1) S:$D(^HLMA(IEN)) I < S ^HLMA(IEN,0)=$G(FLD01)_"^" < I $L($G(FLD01)) S ^HLMA("B",FLD01,IEN)="" < Q IEN < diff -y --suppress-common-lines ./VADemo/r1/HLTP2.m ./VADemo/r2/r/HLTP2.m ;;1.6;HEALTH LEVEL SEVEN;**34,109**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**34**;Oct 13, 1995 D STATUS^HLTF0(HLMTIEN,$S($D(HLERR):4,1:3),$S($D(HLER | D STATUS^HLTF0(HLMTIEN,$S($D(HLERR):4,1:3),$S($D(HLER diff -y --suppress-common-lines ./VADemo/r1/HLTP31.m ./VADemo/r2/r/HLTP31.m HLTP31 ;SFIRMFO/RSD - Cont. Transaction Processor for TCP ;1 | HLTP31 ;SFIRMFO/RSD - Cont. Transaction Processor for TCP ;0 ;;1.6;HEALTH LEVEL SEVEN;**57,58,66,109**;Oct 13, 199 | ;;1.6;HEALTH LEVEL SEVEN;**57,58,66**;Oct 13, 1995 D INIT^HLTP3A ;patch HL*1.6*109: hltp3 routine split | D INIT^HLTP3 ;**109** | I $G(HLMTIENS) L -^HLMA(HLMTIENS) ;I $G(HLMTIENS) L -^HLMA(HLMTIENS) < Q < ; < SETINQUE ; < ;**HL*1.6*109*** < ;Called from HLTP3 for message that utilize enhanced < ;Sets the incoming message on the in queue. < ;Does not use the listener, instead, arranges multipl < ;by using the sending link. < ; < N HLI,HLINST,HLDOMAIN,HLLINK < ; < ;Override value of logical link based on sending faci < ;a queue (^HLMA("AC","I",llnk ien,msg ien)) different < ;listener < S HLINST=$P(HL("SFN"),$E(HL("ECH"))) < S HLDOMAIN=$P(HL("SFN"),$E(HL("ECH")),2) < I HLDOMAIN]"" D ;logical link lookup by domain < . D LINK^HLUTIL3(HLDOMAIN,.HLI,"D") < . S HLLINK=$O(HLI(0)) ;client link for sending facili < ;logical link lookup by station number < I $G(HLLINK)']"",HLINST]"" D < . D LINK^HLUTIL3(HLINST,.HLI,"I") < . S HLLINK=$O(HLI(0)) ;client link for sending facili < ; < ; find the logical link of the subscriber protocol < ; then set the link field of this message to the link < I $G(HL("EIDS")),$P(^ORD(101,HL("EIDS"),770),"^",7) S < ; < I $L($G(HLLINK)) D < .D ENQUE^HLCSREP(HLLINK,"I",HLMTIENS) < E D < .D ENQUE^HLCSREP(HLDP,"I",HLMTIENS) < Only in ./VADemo/r1/: HLTP3A.m diff -y --suppress-common-lines ./VADemo/r1/HLTP3.m ./VADemo/r2/r/HLTP3.m HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;01/04/2 | HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;11/08/2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,1 | ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69**;Oct D INIT^HLTP3A ;patch HL*1.6*109 - hltp3 routine split | D INIT .; D LLCNT^HLCSTCP(HLDP,3) ;**109** done in ACK^HLTP4 | . D LLCNT^HLCSTCP(HLDP,3) ; | I $G(HL("MID")),$G(HL("RAP")) S X=$O(^HLMA("AH",HL("R ; patch HL*1.6*125 - change from $G to $L($G) for non < I $L($G(HL("MID"))),$G(HL("RAP")) S X=$O(^HLMA("AH",H < .; patch 117 & 125 | . ;if MSH is not identical, then msg. are different, .;if MSH is not identical, then msg. are different, q | . I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q < .; < . ;msg was resent during another connection, resend o | . ;msg was resent during another connection .;**115** L +^HLMA(OIENS):0 | . ;if status of original msg wasn't success then proc .;**115** I $T L -^HLMA(OIENS) I +$G(^HLMA(OIENS,"P") | . Q:+$G(^HLMA(OIENS,"P"))'=3 .I $G(HLASTRSP) D | . I $G(HLASTRSP) S HLTCP=HLASTRSP ..S HLTCP=HLASTRSP | . E D ACK^HLTP4("CA") Q:'$G(HLTCP) ..D LLCNT^HLCSTCP(HLDP,3) | . D LLCNT^HLCSTCP(HLDP,3) . E D Q:'$G(HLTCP) < ..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) ca < . ;if not an ack, set status to awaiting processing * | . ;if not an ack, set status to awaiting processing & . I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HL | . I '$G(HL("MTIENS")) D STATUS^HLTF0(HLMTIENS,9),EXIT . ;set status to awaiting processing, **109** and put | . ;set status to awaiting processing & unlock . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SET | . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT ; < . ;Update status of original subscriber message and r | . ;Update status of original subscriber message . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7) < ..; < ..;**108** < .. N TEMP < .. S TEMP=HLMTIENS < .. N HLMTIENS < .. S HLMTIENS=TEMP < ..;**END 108** < ..; < D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT: | D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT: N HLERR ;patch HL*1.6*109 < ;**109 START** < ;L +^HLMA(X):0 Q:'$T | L +^HLMA(X):1 Q:'$T ;L +^HLMA("AC","I",HLDP,X):0 I '$T L -^HLMA(X) Q | L +^HLMA("AC","I",HLDP,X):1 I '$T L -^HLMA(X) Q ;L -^HLMA("AC","I",HLDP,X) | L -^HLMA("AC","I",HLDP,X) ;I '$D(^HLMA("AC","I",HLDP,X)) L -^HLMA(X) Q | I '$D(^HLMA("AC","I",HLDP,X)) L -^HLMA(X) Q Q:'$D(^HLMA("AC","I",HLDP,X)) < ;**109 END** < ; < ; if no header quit | ;if no header kill x-ref and quit ;**109** | I '$O(HLHDRO(0)) K ^HLMA("AC","I",HLDP,HLMTIENS) L -^ ;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q < Q:'$O(HLHDRO(0)) < ; < ; < ; patch HL*1.6*109 start < ; quit if ien of #772 is not defined < Q:'HLMTIEN < ; quit if field separator is not defined < Q:HL("FS")="" < ; quit if this is a commit ack < ; Q:$P(^HL(772,HLMTIEN,"IN",1,0),HL("FS"),2)["C" ; hl < ; patch HL*1.6*109 end < ; < ; < ; HL*1.6*108 < ; quit if this is a commit ack < I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA", < ; ** < ; < ;** HL*1.6*117 ** < K HLL("SET FOR APP ACK"),HLL("LINKS") < ;** END HL*1.6*117 ** < ; < ;*** HL*1.6*116 - moves this block to ^HLTP4 *** < ;I $G(HL("SAP")) D | I $G(HL("SAP")) D ;.N HLSF,HLINST,HLLINK,HLI | .N HLSF,HLINST,HLLINK,HLI ;.N HLDOMAIN ; patch HL*1.6*109 | .S HLSF=$P(^HL(771,HL("SAP"),0),U,3) ;.S HLSF=$P(^HL(771,HL("SAP"),0),U,3) | .Q:HLSF]"" ;application-defined facility ;.Q:HLSF]"" ;application-defined facility | .S HLINST=+HL("SFN") Q:'HLINST ;. ; patch HL*1.6*109 | .D LINK^HLUTIL3(HLINST,.HLI,"I") S HLLINK=$O(HLI(0)) ;.S HLDOMAIN=$P(HL("SFN"),$E(HL("ECH")),2) | .S HLL("LINKS",1)="^"_HLLINK ;.I HLDOMAIN]"" D < ;.. D LINK^HLUTIL3(HLDOMAIN,.HLI,"D") < ;.. S HLLINK=$O(HLI(0)) < ;.. I HLLINK S HLL("LINKS",1)="^"_HLLINK < ;.Q:$G(HLLINK) < ;.S HLINST=$P(HL("SFN"),$E(HL("ECH"))) < ;.Q:HLINST']"" < ;.D LINK^HLUTIL3(HLINST,.HLI,"I") < ;.S HLLINK=$O(HLI(0)) < ;.Q:'HLLINK < ;. ; patch HL*1.6*109 end < ;. ; < ;.S HLL("LINKS",1)="^"_HLLINK < ;** end HL*1.6*116 ** < ; < > INIT ;initialize variables, get MSA & header, returns HLRE > N HLJ > K HLRESLT,HL > S HLMTIENS=+X,HLMTIEN=+$P(X,U,2),HLMSA=$$MSA(HLMTIEN) > F L +^HLMA(HLMTIENS):1 Q:$T H 1 > ;get header and validate > M HLHDRO=^HLMA(HLMTIENS,"MSH") > ;HLMSA is by ref., for a batch msg HLMSA will be setu > D CHK^HLTPCK2(.HLHDRO,.HL,.HLMSA) > ;Update Message Administration file #773, for incomin > ;3=trans type, 20=status > S X="HLJ(773,"""_HLMTIENS_","")",@X@(3)="I",@X@(20)=9 > ;HL=error #^error text, 21=date process, 22=error msg > S:$G(HL) @X@(20)=4,@X@(21)=$$NOW^XLFDT,@X@(22)=$P(HL, > ;8=protocol, 13=sending app > S:$G(HL("EIDS")) @X@(8)=HL("EIDS") S:$G(HL("SAP")) @X > ;14=receiving app, 12=acknowledgement to > S:$G(HL("RAP")) @X@(14)=HL("RAP") S:$G(HL("MTIENS")) > ;6=initial message, 7=logical link > S:$G(HLTCPI) @X@(6)=HLTCPI S @X@(7)=HLDP > ;15=message type, 16=event type > S:$G(HL("MTP")) @X@(15)=HL("MTP") S:$G(HL("ETP")) @X@ > S:$G(HL("MTP_ETP")) @X@(17)=HL("MTP_ETP") > D FILE^DIE("","HLJ") > ;Update Message Text file #772 > ;4=trans type > K HLJ S X="HLJ(772,"""_HLMTIEN_","")",@X@(4)="I" > ;10=event protocol > S:$G(HL("EID")) @X@(10)=HL("EID") > D FILE^DIE("","HLJ") > ;set HLRESLT to error > S:HL'="" HLRESLT=HL > Q ;*109* release all locks created by inbound filer < L -^HLMA("AC","I",+$G(HLXX)) < ; < ; < ONAC(IEN773) ; < ;Returns 1 if the message is on the "AC","I" xref < ;Returns 0 otherwise < ; < N LINK < S LINK=$P($G(^HLMA(IEN773,0)),"^",17) < Q:'LINK 0 < Q $D(^HLMA("AC","I",LINK,IEN773)) < diff -y --suppress-common-lines ./VADemo/r1/HLTP4.m ./VADemo/r2/r/HLTP4.m HLTP4 ;SFIRMFO/RSD - Transaction Processor for TCP ;01/03/2 | HLTP4 ;SFIRMFO/RSD - Transaction Processor for TCP ;03/07/2 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,91,109,116,117,12 | ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,91**;Oct 13, 1995 ; < ;**109** < ;F L +^HLMA(HLMTIENA):1 Q:$T H 1 | F L +^HLMA(HLMTIENA):1 Q:$T H 1 ; < ; < ;**** HL*1.6*116 **** < S X=$G(^ORD(101,HLEIDS,770)),HLP("MTYPE")=$P(X,U,11), | I 'HLOGLINK,$D(HLL("LINKS")) D Q:'HLOGLINK ; | . S HLOGLINK=$P(HLL("LINKS",1),"^",2) Q:HLOGLINK="" ; patch HL*1.6*125- change from $G to $D | . I +HLOGLINK'=HLOGLINK S HLOGLINK=$O(^HLCS(870,"B",H I '$D(HLL("SET FOR APP ACK")) D Q:'HLOGLINK | . K HLL("LINKS") .K HLL("LINKS") | ;get message type and event type from protocol .I 'HLOGLINK D | S X=$G(^ORD(101,HLEIDS,770)),HLP("MTYPE")=$P(X,U,11), .. S HLOGLINK=$P(X,U,7) < .. Q:HLOGLINK < .. N DOMAIN,SFAC,MSH,FS,CS,HLI,INST < .. S MSH=$G(^HLMA(HLMTIENS,"MSH",1,0)) < .. Q:'$L(MSH) < .. S FS=$E(MSH,4) < .. Q:'$L(FS) < .. S CS=$E(MSH,5) < .. Q:'$L(CS) < .. S DOMAIN=$P($P(MSH,FS,4),CS,2) < .. I $L(DOMAIN) D < ... D LINK^HLUTIL3(DOMAIN,.HLI,"D") < ... S HLOGLINK=$O(HLI(0)) < .. Q:HLOGLINK < .. S INST=$P($P(MSH,FS,4),CS,1) < .. I $L(INST) D < .. .D LINK^HLUTIL3(INST,.HLI,"I") < ... S HLOGLINK=$O(HLI(0)) < ;*** END HL*1.6*116 *** < ; < ;** HL*1.6*117 ** < ; patch HL*1.6*125- change from $G to $D < I $D(HLL("SET FOR APP ACK")) D Q:'HLOGLINK < .N I < .S I=$O(HLL("LINKS",0)) < .I 'I S HLOGLINK="" Q < .S HLOGLINK=$P(HLL("LINKS",I),"^",2) Q:HLOGLINK="" < .I +HLOGLINK'=HLOGLINK S HLOGLINK=$O(^HLCS(870,"B",HL < ;**END HL*1.6*117 ** < ; < ; | ;tcp link is open, don't need x-ref, msg will be sent > I $G(HLTCPO) K ^HLMA("AC","O",HLOGLINK,HLTCP) ; < ;**109** < ;tcp link is open, don't need x-ref, msg will be sent < ;I $G(HLTCPO) K ^HLMA("AC","O",HLOGLINK,HLTCP) < ; < D FILE^HLDIE("","HLQ","","GENACK","HLTP4") ;HL*1.6*10 | D FILE^DIE("","HLQ") ;D FILE^DIE("","HLQ") < ; | EXIT L -^HLMA(HLMTIENA) ;**109** < ;tcp link is NOT open, need x-ref < I '$G(HLTCPO) D ENQUE^HLCSREP(HLOGLINK,"O",HLTCP) < ; < EXIT ;**109** < ;L -^HLMA(HLMTIENA) < ;**109** | F L +^HLMA(HLMTIENA):1 Q:$T H 1 ;F L +^HLMA(HLMTIENA):1 Q:$T H 1 < ; < ; HL*1.6*117 start < ; change the order of when updates are done on file 7 < ;D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS, | D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,H ; < ;**109** | K ^HLMA("AC","O",HLDP,HLTCP) ;D LLCNT^HLCSTCP(HLDP,3) < ;K ^HLMA("AC","O",HLDP,HLTCP) < ; < ;D STATUS^HLTF0(HLTCP,8) | D STATUS^HLTF0(HLTCP,8) ; HL*1.6*117 end < D FILE^HLDIE("","HLQ","","ACK","HLTP4") ; HL*1.6*109 | D FILE^DIE("","HLQ") ;D FILE^DIE("","HLQ") < ; HL*1.6*117 start < ; finally commit updates to 773 that will affect beha < ;Update status to Being Generated < D STATUS^HLTF0(HLTCP,8) < ;Update zero node of Message Admin file #773 < D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,H < ; update message sent count < D LLCNT^HLCSTCP(HLDP,3) < ; HL*1.6*117 end < diff -y --suppress-common-lines ./VADemo/r1/HLTPCK1A.m ./VADemo/r2/r/HLTPCK1A.m HLTPCK1A ;SAW/AISC-Message Header Validation Routine f | HLTPCK1A ;SAW/AISC-Message Header Validation Routine f ;;1.6;HEALTH LEVEL SEVEN;**2,25,34,57,59,108**;Oct 13 | ;;1.6;HEALTH LEVEL SEVEN;**2,25,34,57,59**;Oct 13, 19 ; | S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",ARY("RA ; patch HL*1.6*108 start < ;S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",ARY("R < S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",$E(ARY( < .;S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0)) | .S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0)) .S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0)) < ; patch HL*1.6*108 end < ; < ; | S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("SA ; patch HL*1.6*108 start < ;S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("S < S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",$E(ARY( < .;S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0)) | .S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0)) .S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0)) < ; patch HL*1.6*108 end < ; < ;. ;N HLZMID,HLZEP,HLZ770 | . ;N HLZMID,HLZEP,HLZ770 ;. ;S HLZMID=$O(^HL(772,"C",+$P(MSA,FS,2),0)) | . ;S HLZMID=$O(^HL(772,"C",+$P(MSA,FS,2),0)) ;. ;I HLZMID D | . ;I HLZMID D ;.. ;I '$G(^HL(772,HLZMID,0)) S:(ERR="") ERR="Origin | .. ;I '$G(^HL(772,HLZMID,0)) S:(ERR="") ERR="Origina ;.. ;S HLZEP=$P($G(^HL(772,HLZMID,0)),U,10) | .. ;S HLZEP=$P($G(^HL(772,HLZMID,0)),U,10) ;.. ;I HLZEP'>0 S:(ERR="") ERR="Event Protocol point | .. ;I HLZEP'>0 S:(ERR="") ERR="Event Protocol pointe ;.. ;S HLZ770=$G(^ORD(101,HLZEP,770)) | .. ;S HLZ770=$G(^ORD(101,HLZEP,770)) ;.. ;S ARY("ETN")=$P($G(^HL(779.001,+$P(HLZ770,U,4), | .. ;S ARY("ETN")=$P($G(^HL(779.001,+$P(HLZ770,U,4),0 ;. ;K HLZMID,HLZEP,HLZ770 | . ;K HLZMID,HLZEP,HLZ770 diff -y --suppress-common-lines ./VADemo/r1/HLTPCK2A.m ./VADemo/r2/r/HLTPCK2A.m HLTPCK2A ;SF/RSD - Message Header Validation (Con't) ; | HLTPCK2A ;SF/RSD - Message Header Validation (Con't) ; ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,66,108**;Oct 13, | ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,66**;Oct 13, 1995 ; | S:ARY("RAN")'="" ARY("RAP")=+$O(^HL(771,"B",ARY("RAN" ; patch HL*1.6*108 start < ;S:ARY("RAN")'="" ARY("RAP")=+$O(^HL(771,"B",ARY("RAN < S:ARY("RAN")'="" ARY("RAP")=+$O(^HL(771,"B",$E(ARY("R < .;S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0)) | .S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0)) .S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0)) < ; patch HL*1.6*108 end < ; < ; | S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("SA ; patch HL*1.6*108 start < ;S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("S < S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",$E(ARY( < .;S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0)) | .S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0)) .S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0)) < ; patch HL*1.6*108 end < ; < diff -y --suppress-common-lines ./VADemo/r1/HLTRANS.m ./VADemo/r2/r/HLTRANS.m HLTRANS ;AISC/SAW-Create Mail Message and Entry in the HL7 Tr | HLTRANS ;AISC/SAW-Create Mail Message and Entry in the HL7 Tr ;;1.6;HEALTH LEVEL SEVEN;**108**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;;Oct 13, 1995 ; | I $D(HLDAP) S:'HLDAP HLDAN=HLDAP S HLDAP=$S('HLDAP:$O ; patch HL*1.6*108 start < ;I $D(HLDAP) S:'HLDAP HLDAN=HLDAP S HLDAP=$S('HLDAP:$ < I $D(HLDAP) S:'HLDAP HLDAN=HLDAP S HLDAP=$S('HLDAP:$O < ; patch HL*1.6*108 end < ; < diff -y --suppress-common-lines ./VADemo/r1/HLUCM001.m ./VADemo/r2/r/HLUCM001.m ;;1.6;HEALTH LEVEL SEVEN;**79,88,103**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**79,88**;Oct 13, 1995 ; FAC,ORIGETM,ORIGSTM,TYPEHR,TYPEIO,TYPELR -- req | ; ORIGETM,ORIGSTM,TYPEHR,TYPEIO,TYPELR -- req N CHAR,ERRFLAG,FAC,SEC,START,TOTCURR,TYPEHR,TYPEIO,TY | N CHAR,ERRFLAG,SEC,START,TOTCURR S CHAR=$G(DATA("CHAR")),SEC=$G(DATA("DIFF")),FAC=$G(D | S CHAR=$G(DATA("CHAR")) S TYPEHR=$G(DATA("HR")),TYPEIO=$G(DATA("IO")),TYPELR= | S SEC=$G(DATA("DIFF")) ;I STARTORIGETM S START=ORIGETM | I START>ORIGETM S START=ORIGETM I SEC>1799 D | I SEC>1799 S X=TOTALS N TOTALS S TOTALS=X_"ERRTIME",E . S X=TOTALS N TOTALS S TOTALS=X_"ERRTIME",ERRFLAG=1 < . D ERRMOVE^HLUCM009(+IEN772) ; Move into ^TMP($J,"H < ; Maybe, this IEN772 has already been ERRd by ERRMOVE < I $D(^TMP($J,"HLUCMSTORE","ERR","X",+IEN772)) D QUIT < . D ERRMOVE^HLUCM009(+IEN772) ; Just to be sure < ; < ; Should this entry even be counted? < I (HLAPI="CMF"!(HLAPI="CM2F"))&(TYPELR'="R") QUIT ;- < ; < ; Accumulating and totaling here... < I TYPELR="R" D ACCUMFAC^HLUCM090 < D TOTALING < ; < Q < TOTALING ; Grand totals | ; Grand totals... Q | ; > QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;-> > QUIT:$G(IEN772)'>0 ;-> > ; > S $P(^TMP($J,"HLUCMSTORE","E",IEN772),U,1,5)=DATA("CH > I ERRFLAG S ^TMP($J,"HLUCMSTORE","E",IEN772,"ERR")=TO > ; > QUIT ; DATA(),FAC,START,TYPEHR -- req | ; DATA(),START,TYPEHR -- req I HLAPI="CM"!(HLAPI="CM2") D ACCUMLAT^HLUCM009("HR"," | D ACCUMLAT("HR","TM",TYPEHR,START,DATA("PCKG"),DATA(" I HLAPI="CMF"!(HLAPI="CM2F") D ACCUMLAT^HLUCM009("HR" < ; DATA(),FAC,TYPEIO,TYPELR -- req | ; DATA(),TYPEIO,TYPELR -- req I HLAPI="CM"!(HLAPI="CM2") D | D ACCUMLAT("NMSP","IO",TYPEIO,DATA("PCKG"),START,DATA . D ACCUMLAT^HLUCM009("NMSP","IO",TYPEIO,DATA("PCKG" | D ACCUMLAT("NMSP","LR",TYPELR,DATA("PCKG"),START,DATA . D ACCUMLAT^HLUCM009("NMSP","LR",TYPELR,DATA("PCKG" < I HLAPI="CMF"!(HLAPI="CM2F") D < . D ACCUMLAT^HLUCM009("NMSP","IO",TYPEIO,FAC,DATA("P < . D ACCUMLAT^HLUCM009("NMSP","LR",TYPELR,FAC,DATA("P < ; DATA(),FAC,START -- req | ; DATA(),START -- req I HLAPI="CM"!(HLAPI="CM2") D ACCUMLAT^HLUCM009("PROT" | D ACCUMLAT("PROT","PR","P",DATA("PROT"),DATA("PCKG"), I HLAPI="CMF"!(HLAPI="CM2F") D ACCUMLAT^HLUCM009("PRO < > ACCUMLAT(CATEGORY,TYPE,SORT,SUB1,SUB2,SUB3) ; Generic acc > ; Totals level 3 for SUB... > ; > S TOTCURR=$G(^TMP(TOTALS,$J,CATEGORY,TYPE,SORT,SUB1,S > D INCR > S ^TMP(TOTALS,$J,CATEGORY,TYPE,SORT,SUB1,SUB2,SUB3)=T > ; > ; Totals level 2 for SUB... > S TOTCURR=$G(^TMP(TOTALS,$J,CATEGORY,TYPE,SORT,SUB1,S > D INCR > S ^TMP(TOTALS,$J,CATEGORY,TYPE,SORT,SUB1,SUB2)=TOTCUR > ; > ; Totals level 1 for SUB... > S TOTCURR=$G(^TMP(TOTALS,$J,CATEGORY,TYPE,SORT,SUB1)) > D INCR > S ^TMP(TOTALS,$J,CATEGORY,TYPE,SORT,SUB1)=TOTCURR > ; > ; Total level TYPE/SORT... > S TOTCURR=$G(^TMP(TOTALS,$J,CATEGORY,TYPE,SORT)) > D INCR > S ^TMP(TOTALS,$J,CATEGORY,TYPE,SORT)=TOTCURR > ; > ; Total level TYPE > S TOTCURR=$G(^TMP(TOTALS,$J,CATEGORY,TYPE)) > D INCR > S ^TMP(TOTALS,$J,CATEGORY,TYPE)=TOTCURR > ; > ; Total level CATEGORY > ; [Don't subtotal here, for NMSP holds two different > ; if totalled here, it would double count.] > ; > QUIT > ; > PAR(PAR) ; > I PAR="START" QUIT $$HR(+DATA("START")) ;-> > I PAR="PROT" QUIT $S($G(IEN101)="ZZZ":"ZZZ",1:DATA("P > I PAR="PCKG" QUIT $S($G(PNMSP)="ZZZ":"ZZZ",1:DATA("PC > QUIT "ZZZ" > ; I $G(HLUCMADD)'="DON'T ADD. COLLECT3~HLUCM003" D | S $P(TOTCURR,U,2)=$P(TOTCURR,U,2)+1 ; Number messages . S $P(TOTCURR,U,2)=$P(TOTCURR,U,2)+1 < S $P(TOTCURR,U,4)=$P(TOTCURR,U,4)+1 < TYPELR(IEN772,FACNM) ; Is this Local or Remote or Unknown? | FIND101(VAL) ; No checking for upp/lowercase. Must be pas ; SITENM -- req | ; VAL = Protocol name... N D772,I773,IEN,IEN870,IO,MIEN,NM,TXT,TYPE,X | N FIEN,IEN,LNM,PNM > ; > S VAL=$P(VAL,"0^",2) > ; > ; Passed as IEN? > I VAL=+VAL,$D(^ORD(101,+VAL,0)) QUIT +VAL ;-> ; If SITENM=FACNM, then it isn't remote... | ; Passed as NAME? I $G(SITENM)]"",$G(FACNM)]"",SITENM=FACNM QUIT "L" ;- | S FIEN=0 > S LNM=$E(VAL,1,$S($L(VAL)>30:29,1:$L(VAL)-1)) > F S LNM=$O(^ORD(101,"B",LNM)) Q:LNM]VAL!(LNM']"")!(F > . S IEN=0 > . F S IEN=$O(^ORD(101,"B",LNM,IEN)) Q:IEN'>0!(FIEN) > . . QUIT:$P($G(^ORD(101,+IEN,0)),U)'=VAL ;-> > . . S FIEN=+IEN > QUIT $S(FIEN:FIEN,1:"") > PCKG(IEN772) ; Return package namespace, or ZZZ if suppose > ; NMSPTYPE,PNMSP -- req > ; > N IEN101,IEN94,NMSP > ; > ; Include ALL, but lump every namespace into ZZZ... > I $G(PNMSP)=2 QUIT "ZZZ" ;-> > ; > ; Best way (Get NMSP from stored namespace) > S NMSP=$P($G(^HL(772,+IEN772,0)),U,13) > ; > ; Get actual namespace. Determine below what to retu > I NMSP']"" S NMSP=$$NMSP101(IEN772) > ; > ; Maybe a Mail only message? > I NMSP']"",$P($G(^HL(772,+IEN772,0)),U,5)>0 S NMSP="X > ; > ; Include ALL, subdivide by individual namespaces... > I $G(PNMSP)=1 QUIT $S(NMSP]"":NMSP,1:"ZZZ") ;-> Want > ; > ; Must be a specific namespace... > I $G(PNMSP)?1"0^".E D QUIT PROT(1) ;-> > . S PROT(1)="" ; Set up default in case of failure.. > . I $P(PNMSP,U,2)=NMSP S PROT(1)=NMSP > ; > ; Passed namespaces by array, so anything here is OK. > I NMSPTYPE=1 QUIT NMSP ;-> > ; > QUIT "" > ; > NMSP101(IEN772) ;From 772->101->9.4, find 9.4's namespace... > N IEN101,IEN94 > S IEN101=+$P($G(^HL(772,+IEN772,0)),U,10) QUIT:IEN101 > S IEN94=$P($G(^ORD(101,+IEN101,0)),U,12) QUIT:IEN94'> > QUIT $P($$NMSP94(IEN94),U,2) > ; > NMSP94(IEN94) ; From 9.4 find it's namespace... > N D0,DA,DIC,DIQ,DR,NMSP > S DIC=9.4,DR=".01;1",DA=IEN94,DIQ="NMSP(",DIQ(0)="E" > D EN^DIQ1 > QUIT $G(NMSP(9.4,+IEN94,.01,"E"))_U_$G(NMSP(9.4,+IEN9 > ; > TYPELR(IEN772) ; Is this Local or Remote or Unknown? > N D772,I773,IEN,IEN870,IO,MIEN,NM,TXT,TYPE,X I MIEN S X=$$MAILTYPE^HLUCM009(MIEN) QUIT:X="R" $$SLR | I MIEN S X=$$MAILTYPE(MIEN) QUIT:X="R" "R" ;-> Mailma I $$MAIL870^HLUCM090(IEN772)="R" QUIT $$SLR(IEN772,"R | I $$MAIL870(IEN772)="R" QUIT "R" ;-> I $$INST870^HLUCM090(+IEN772,+$P($$SITE^VASITE,U,3))= | I $$INST870(+IEN772,+$P($$SITE^VASITE,U,3))="R" QUIT . S X=$$SITESMSH^HLUCM009(TXT),P4=$P(X,U),P6=$P(X,U, | . S X=$$SITESMSH(TXT),P4=$P(X,U),P6=$P(X,U,2) QUIT:TYPE'="L" $$SLR(IEN772,TYPE) ;-> | QUIT:TYPE'="L" TYPE ;-> S IEN870=$$IEN870^HLUCM009(+IEN772) I IEN870 D | S IEN870=$$IEN870(+IEN772) I IEN870 D QUIT $$SLR(IEN772,TYPE) | QUIT TYPE ; < SLR(IEN772,LR) ; Store the L/R type for use for FACILITY sor < N FAC,HLDATA,PARENT,TYPE,X < Q LR < ; < PREPARE() ; Called by $$CM & $$CM2 and other APIs... < ; < S ORIGSTM=$G(START),ORIGETM=$G(END) < S SITENM=$P($$SITE^VASITE,U,2) < ; < ; Summarize by DAY instead of hour? < I ORIGSTM?7N,ORIGETM']"" D < . S ^TMP($J,"HLUCMDT")="" < . S ORIGETM=ORIGSTM_".24" < ; < D ZEROUP < ; < ; Miscellaneous KILLs... < D KILLS^HLUCM009("START") < ; < ; Build namespace xref < D NMSPXRF^HLUCM009 < ; < ; This is where results are returned to caller... < KILL ERRINFO < ; < ; Perform all setup chores. If errors found, they wi < ; in ERRINFO(ERROR-REASON)="" array < QUIT:$$SETUP^HLUCM009 "" ;-> Some errors occurred... < Q 1 | SITESMSH(TXT) ; Return location pieces, slightly modified.. > N DIV,P4,P6 > S DIV=$E(TXT,4),P4=$P(TXT,DIV,4),P6=$P(TXT,DIV,6) > S P4=$S(P4?1.N1"~"!(P4?1.N):+P4,1:"") > S P6=$S(P6?1.N1"~"!(P6?1.N):+P6,1:"") > QUIT P4_U_P6 > ; > MAILTYPE(MIEN) ; Is MSH in Mailman message local or remote.. > N IEN,RECNO,TO,TOID,TYPE > S TYPE="L" > KILL ^TMP($J,"HLMAILTYPE") > D QD^XMXUTIL3(+MIEN,,,,,"^TMP($J,""HLMAILTYPE"")") > S RECNO=0 > F S RECNO=$O(^TMP($J,"HLMAILTYPE","XMLIST",RECNO)) Q > . S TO=$G(^TMP($J,"HLMAILTYPE","XMLIST",+RECNO,"TO") > . S TOID=$G(^TMP($J,"HLMAILTYPE","XMLIST",+RECNO,"TO > . I TO["@"!(TOID="R") S TYPE="R" > KILL ^TMP($J,"HLMAILTYPE") > QUIT TYPE > ; > IEN870(IEN772) ; Given 772 find 870... > N DATA,I773,I870,IEN > S DATA=$G(^HL(772,+IEN772,0)) > ; > ; Logical Link field... > S IEN=$P(DATA,U,11) I IEN QUIT IEN ;-> > ; > ; Related Event Protocol... > S IEN=$P(DATA,U,10),IEN=$P($G(^ORD(101,+IEN,770)),U,7 > ; > S I773=0 > F S I773=$O(^HLMA("B",IEN772,I773)) Q:I773'>0 D QU > . S I870=$P($G(^HLMA(+I773,0)),U,7) > I $G(I870) QUIT +I870 ;-> ZEROUP ; If didn't add 0^... < I $G(IEN101)]"",IEN101'?1N,IEN101'?1"0^".E S IEN101=" < I $G(PNMSP)]"",PNMSP'?1N,PNMSP'?1"0^".E S PNMSP="0^"_ < Q < ; < FIND101(VAL) ; No checking for upp/lowercase. Must be pas < ; VAL = Protocol name... < N FIEN,IEN,LNM,PNM < ; < S VAL=$P(VAL,"0^",2) < ; < ; Passed as IEN? < I VAL=+VAL,$D(^ORD(101,+VAL,0)) QUIT +VAL ;-> < ; < ; Passed as NAME? < S FIEN=0 < S LNM=$E(VAL,1,$S($L(VAL)>30:29,1:$L(VAL)-1)) < F S LNM=$O(^ORD(101,"B",LNM)) Q:LNM]VAL!(LNM']"")!(F < . S IEN=0 < . F S IEN=$O(^ORD(101,"B",LNM,IEN)) Q:IEN'>0!(FIEN) < . . QUIT:$P($G(^ORD(101,+IEN,0)),U)'=VAL ;-> < . . S FIEN=+IEN < QUIT $S(FIEN:FIEN,1:"") < ; < REFPROT(PROT) ; If passed by reference, is PROT in array? 0 < ; PROTYPE -- req < N X < I PROTYPE'=1 QUIT 1 ;-> Not passed by reference... < S X=$P(PROT,"~") I X]"" I $D(IEN101(X)) QUIT 1 ;-> fo < S X=$P(PROT,"~",2) I X]"" I $D(IEN101(+X)) QUIT 1 ;-> < REFPCKG(PCKG) ; If passed by reference, is PCKG in array? 0 | TYPEMSH(TXT) ; From MSH segment, is it local or remote? ; NMSPTYPE -- req | N VAL I NMSPTYPE'=1 QUIT 1 ;-> Not passed by reference... | S VAL=$$SITESMSH(TXT) I PCKG]"" I $D(PNMSP(PCKG)) QUIT 1 ;-> found in array | QUIT $S(+VAL=$P(VAL,U,2):"R",1:"L") QUIT "" | ; > MAIL870(IEN772) ; > N LINK,MAIL > S LINK=$$LINK(IEN772) QUIT:LINK'>0 "" ;-> > S MAIL=$P($G(^HLCS(870,+LINK,0)),U,3) > QUIT $S(MAIL=1:"R",1:"L") > ; > INST870(IEN772,INST) ; > N INST870,LINK > S LINK=$$LINK(IEN772) QUIT:LINK'>0 "" ;-> > S INST870=+$P($G(^HLCS(870,+LINK,0)),U,2) > QUIT $S(INST870>0&(INST870'=INST):"R",1:"L") > ; > LINK(IEN772) ; > N IEN773,LINK > S LINK=$P($G(^HL(772,IEN772,0)),U,11) > I LINK'>0 D > . S IEN773=$O(^HLMA("B",IEN772,0)) QUIT:IEN773'>0 ; > . S LINK=$P($G(^HLMA(+IEN773,0)),U,7) > QUIT LINK diff -y --suppress-common-lines ./VADemo/r1/HLUCM002.m ./VADemo/r2/r/HLUCM002.m ;;1.6;HEALTH LEVEL SEVEN;**79,88,103**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**79,88**;Oct 13, 1995 N DEB,GBL,IOINHI,IOINORM,JOBN,SUB,TOT,WAY,X,XTMPGBL | I $G(SUB)']"" N SUB S SUB="TOT" ; | I $G(JOBN)'>0 N JOBN S JOBN=$J S X="IOINHI;IOINORM" D ENDR^%ZISS | D PRINT1 ; | QUIT W @IOF,$$CJ^XLFSTR("Print Totals Report & Debug Data < W !,$$REPEAT^XLFSTR("=",IOM) < ; < S XTMPGBL="" < ; < ; What is the SUB for the Totals Report... < S SUB=$$SUB < I SUB']"" W !!,"OK! No ^TMP(TOTALS,$J) totals report < I SUB]"" D PTOT < ; < ; Debug data... < I '$D(^TMP($J,"HLUCMSTORE")) D < . W !!,"No ^TMP($J,""HLUCMSTORE"") debug data exists < I $D(^TMP($J,"HLUCMSTORE")) D PSTORE < ; < I SUB']"",'$D(^TMP($J,"HLUCMSTORE")) D QUIT ;-> < . S X=$$BTE^HLCSMON("Press RETURN to exit... ",1) < ; < QUIT:$$BTE^HLCSMON("Press RETURN to restart, or '^' t < ; < G PRINTREG ;-> < ; < PSTORE ; < W !!,$$CJ^XLFSTR("----------- "_IOINHI_"Debug Data fr < R !!,"Print raw DEBUG DATA (Y/N): Yes// ",X:999 S:X=" < I DEB="Y" D PRINTDBG^HLUCM090 < ; < R !!,"Print filtered DEBUG DATA (Y/N): Yes// ",X:999 < I DEB="Y" D LOOPU^HLUCM004 < Q < ; < PTOT ; < W !!,"You will be allowed to print report totals (fro < W !,"may print the debug data (in ^TMP($J,""HLUCMSTOR < W !!,$$CJ^XLFSTR("------------ "_IOINHI_"Report Total < R !!,"Print REPORT TOTALS (Y/N): Yes// ",X:999 S:X="" < I TOT="Y" D < . S SUB="TOT",JOBN=$J < . I '$D(^TMP(SUB,JOBN)) S SUB="KMPDH" < . R !,"Include subtotals (Y/N): NO// ",WAY:999 QUIT: < . S:WAY']"" WAY="N" < . S WAY=$$UP^XLFSTR($E(WAY_" ")),WAY=$S(WAY="N":0,1: < . S X=$$XTMPGBL^HLUCM004(0) I X]"" S (GBL,XTMPGBL)=X < . D PRINT1 < Q < ; < SUB() ; What subscript holds the ^TMP(SUB,$J) data? < N SUB < I $D(^TMP("KMPDH",$J)) QUIT "KMPDH" ;-> < I $D(^TMP("TOT",$J)) QUIT "TOT" ;-> < R !!,"Enter subscript holding the ^TMP(TOTALS,$J) dat < Q SUB < ; < PRINT(SUB,JOBN,WAY) ; Print data in ^TMP(SUB,...) to scre < ; WAY -- 0 = No totals < ; 1 = Totals for every section < N L1,L2,L3 < ; < S WAY=$S($G(WAY)'>0:0,$G(WAY)=1:1,1:0) < > PRINT(SUB,JOBN) ; Print data in ^TMP(SUB,...) to screen PRINT1 D PRINT1^HLUCM090 | PRINT1 ; ; | N GBL,L1,L2,L3,L4,TOT S GBL=$NA(^TMP($J,"HLUCMSTORE","T")) | S GBL="^TMP("""_SUB_""","_JOBN_")" S L1=0 F L2="CCX","CXC","CXX","XCC","XCX","XXC","XXX" | I '$O(@GBL@(""))']"" D QUIT ;-> QUIT:'L1 ;-> | . W !!,"No data found..." ; | . W ! W !!,"Some entries were not included in the totals. | W !!," Total Total Total Main" W !,"for entries being excluded: (1) The beginning ti | W !,"#Chars #Msgs #Sec Sort Sub1 Sub2 Sub3" W !,"before the report's start time, (2) The number o < W !,"message is over 1799 seconds, and (3) The protoc < W !,"the search criteria." < W !!,"Failure Reason",?30,"#Characters",?42,"#Msg/Uni < ; | S L1="" F LAST="CCX","CXC","CXX","XCC","XCX","XXC","XXX" I $G | F S L1=$O(@GBL@(L1)) Q:L1']"" D ; | . S L2="" S TYP="XXX",DATA=$G(@GBL@(TYP)) I DATA]"" D | . F S L2=$O(@GBL@(L1,L2)) Q:L2']"" D . D SHOW("Beginning time too early",DATA) | . . S L3="" . D SHOW("Excessive xmit time") | . . F S L3=$O(@GBL@(L1,L2,L3)) Q:L3']"" D . D SHOW("Prot/Nmsp mismatch","",1) | . . . S L4="" S TYP="XXC",DATA=$G(@GBL@("XXC")) I DATA]"" D | . . . F S L4=$O(@GBL@(L1,L2,L3,L4)) Q:L4']"" D . D SHOW("Beginning time too early",DATA) | . . . . S TOT=$G(@GBL@(L1,L2,L3,L4)) . D SHOW("Excessive xmit time","",1) | . . . . W !,$J(+TOT,6),?8,$J($P(TOT,U,2),6),?16,$ S TYP="XCX",DATA=$G(@GBL@("XCX")) I DATA]"" D | . . . . W ?24,L1,?29,L2,?34,L3,?39,$S($L(L4)<42:L . D SHOW("Beginning time too early",DATA) < . D SHOW("Prot/Nmsp mismatch","",1) < S TYP="XCC",DATA=$G(@GBL@("XCC")) I DATA]"" D < . D SHOW("Beginning time too early",DATA,1) < S TYP="CXX",DATA=$G(@GBL@("CXX")) I DATA]"" D < . D SHOW("Excessive xmit time",DATA) < . D SHOW("Prot/Nmsp mismatch","",1) < S TYP="CXC",DATA=$G(@GBL@("CXC")) I DATA]"" D < . D SHOW("Excessive xmit time",DATA,1) < S TYP="CCX",DATA=$G(@GBL@("CCX")) I DATA]"" D < . D SHOW("Prot/Nmsp mismatch",DATA,1) < I L1!L2!L3 W !,$$REPEAT^XLFSTR("=",IOM),!,"Totals:",? < ; < Q < ; < SHOW(REA,DATA,LINE) ; < ; LAST,TYP -- req < S DATA=$G(DATA),LINE=$G(LINE) < W !,REA < I $G(DATA)]"" W ?30,$J($P(DATA,U),7),?42,$J($P(DATA,U < I $G(LINE),TYP'=LAST W !,$$REPEAT^XLFSTR("-",IOM) < S L1=$G(L1)+$P(DATA,U),L2=$G(L2)+$P(DATA,U,2),L3=$G(L < ADD(TL) ; Add to TOT... | PRINTDBG(JOBN) ; Print data in ^TMP($J,"DEBUG") S $P(TOT,U)=$P(TOT,U)+$P(TL,U) | N CHAR,IEN772,IEN773,S1,S2,VAL S $P(TOT,U,2)=$P(TOT,U,2)+$P(TL,U,2) | S IEN772=0 S $P(TOT,U,3)=$P(TOT,U,3)+$P(TL,U,3) | F S IEN772=$O(^TMP($J,"HLUCMSTORE","E",IEN772)) Q:'I Q | . W !,IEN772 > . S CHAR=$G(^TMP($J,"HLUCMSTORE","E",IEN772)) > . W ?15,$J(CHAR,4),?21 > . S IEN773=$O(^TMP($J,"HLUCMSTORE","E",IEN772,773,0) > . W:IEN773 "773s..." > . W ?28 > . S S1="" > . F S S1=$O(^TMP($J,"HLUCMSTORE","E",IEN772,772,S1) > . . QUIT:S1="PR" ;-> > . . S S2="" > . . S S2=$O(^TMP($J,"HLUCMSTORE","E",IEN772,772,S1, > . . . S VAL=$$LOW^XLFSTR(S1)_"-"_S2 > . . . W $J(VAL,6) > QUIT I $P($G(^HLCS(870,+$$IEN870^HLUCM009(+IEN772),0)),U,3 | I $P($G(^HLCS(870,+$$IEN870^HLUCM001(+IEN772),0)),U,3 S PROT=$S(IEN101'=2:$$GETPROT^HLUCM050(+IEN772),1:"ZZ | S PROT=$S(IEN101'=2:$$PROT101(+IEN772),1:"ZZZ") > D ACTUAL(IEN772,1,PROT) > ; > ; If not lumping (PROT=2), and no valid protocol so f > I PROT=""!(PROT="ZZZ"),PROT'=2 D > . S PROT=$$INFERPR^HLUCM004(+IEN772,PROT) > . D ACTUAL(IEN772,2,PROT) S CTPROT=$$CTPROT^HLUCM003(PROT) | S CTPROT=$$CTPROT(PROT) S PCKG=$S(PNMSP'=2:$$GETNMSP^HLUCM050(+IEN772),1:"ZZZ | S PCKG=$S(PNMSP'=2:$$PCKG^HLUCM001(+IEN772),1:"ZZZ") > D ACTUAL(IEN772,3,PCKG) > ; > ; Don't reset a ZZZ if supposed to lump (PNMSP=2)... > I PCKG="ZZZ",$G(PNMSP)'=2 D > . S PCKG=$$INFERNM^HLUCM004(+IEN772,PCKG) > . I PCKG["ZZZ",PROT[9999999 S PCKG="XMB" > . D ACTUAL(IEN772,4,PCKG) S CTPCKG=$$CTPCKG^HLUCM003(PCKG) | S CTPCKG=$$CTPCKG(PCKG) > D ACTUAL(IEN772,5,PROT),ACTUAL(IEN772,6,PCKG) > ; > CTPCKG(PCKG) ; Should entry be counted on basis of package > ; (Might be countable if protocol matches remember.) > ; If list of packages passed by reference, is PCKG in > ; IEN101,NMSPTYPE,PNMSP -- req > N CTPCKG > ; > ; Must count everything... > I $G(PNMSP)=1!($G(PNMSP)=2) QUIT 1 ;-> > ; > ; If passed namspace by array, is PCKG in array? > I NMSPTYPE=1 QUIT $S($$REFPCKG(PCKG):1,1:"") ;-> > ; > ; If passed in "0^NAMESPACE" format... > I $$OK0CALL(PNMSP) D QUIT $S(PCKG]"":1,1:"") ;-> > . I $P(PNMSP,U,2)'=PCKG S PCKG="" > ; > QUIT "" > ; > CTPROT(PROT) ; Should entry be counted on basis of protoco > ; (Might be countable if package matches remember.) > ; IEN,PROTYPE -- req > ; > N CTPROT > ; > ; Must count everything... > I $G(IEN101)=1!($G(IEN101)=2) QUIT 1 ;-> > ; > ; If passed protocols by array, is PROT in array? > I PROTYPE=1 QUIT $S($$REFPROT(PROT):1,1:"") ;-> > ; > ; If PROT not found, and passed 0^PROTNM or 0^PROTIEN > ; can't do anything more... > I $$OK0CALL(IEN101) D QUIT $S(PROT]"":1,1:"") ;-> > . N VAL > . QUIT:PROT']"" ;-> > . S VAL=$P(IEN101,U,2) > . I $P(PROT,"~")'=VAL&($P(PROT,"~",2)'=VAL) S PROT=" > ; > QUIT "" > ; > PP() QUIT $G(PROT)_U_$G(PCKG) > ; > REFPROT(PROT) ; If passed by reference, is PROT in array? 0 > ; PROTYPE -- req > N X > I PROTYPE'=1 QUIT 1 ;-> Not passed by reference... > S X=$P(PROT,"~") I X]"" I $D(IEN101(X)) QUIT 1 ;-> fo > S X=$P(PROT,"~",2) I X]"" I $D(IEN101(+X)) QUIT 1 ;-> > QUIT "" > ; > REFPCKG(PCKG) ; If passed by reference, is PCKG in array? 0 > ; NMSPTYPE -- req > I NMSPTYPE'=1 QUIT 1 ;-> Not passed by reference... > I PCKG]"" I $D(PNMSP(PCKG)) QUIT 1 ;-> found in array > QUIT "" > ; > ACTUAL(IEN772,PCE,DATA) ; Store data in ^TMP($J,"ACTUAL") > N NEW,NODE,VAL > S (NEW,NODE)=$G(^TMP($J,"ACTUAL",IEN772)) > S VAL=$P(NODE,U,PCE) QUIT:DATA=VAL ;-> > S $P(NEW,U,PCE)=DATA > S ^TMP($J,"ACTUAL",IEN772)=NEW > QUIT > ; diff -y --suppress-common-lines ./VADemo/r1/HLUCM003.m ./VADemo/r2/r/HLUCM003.m ;;1.6;HEALTH LEVEL SEVEN;**88,103**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**88**;Oct 13, 1995 ADJTIME ; Adjust ^TMP times on basis of unit... | LOOP() ; Loop thru 772's .01... (Called from LOOP^HLUCM) N IENPAR | N CTDBG,HLWHERE S IENPAR=0 < F S IENPAR=$O(^TMP($J,"HLPARENT",IENPAR)) Q:'IENPAR < . D ADJPAR(+IENPAR) < Q < ; < ADJPAR(IENPAR) ; Adjust times for one unit... < N BEG,DATA,END,IEN772,NUM,PREVTM,TIME < ; < S NUM=0,IEN772=0 < F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q: < . S NUM=NUM+1 < ; No adjustments necessary if only one message... | S HLWHERE="HLUCM003",CTDBG=0 QUIT:NUM'>1 ;-> < ; Find all times... | ; Collect related messages... > D FINDCMII^HLUCM007(START,END) QUIT:'$D(^TMP($J,"CMII > ; ^TMP($J,"CMII") killed in FINDCMII > ; > ; Find namespace,numberspace for ^TMP($J,"CMII") entr > D CMIINMNO > ; > ;Lump on basis of MSGID... > D CMIIMORE > ; > ; If debugging, create ^TMP($J,"HLUCMSTORE","E",..) e > ;D MAKEE > ; > ; Final totalling... > D TOTAL^HLUCM008 > ; > ; Debugging actions... > I $G(^TMP($J,"HLUCM"))="DEBUG GLOBAL" D > . MERGE ^TMP($J,"HLUCMSTORE","U")=^TMP($J,"CMII","N" > . MERGE ^TMP($J,"HLUCMSTORE","X")=^TMP($J,"CMII","X" > . MERGE ^TMP($J,"HLUCMSTORE","N")=^TMP($J,"RECNM") > . D PACKDGBL^HLUCM005(2) ; Pack global... > . D ADJTIME^HLUCM008 ; Adjust times in units... > . D OUTLYER^HLUCM007 ; Entries outside STARTtoEND ra > ; > I $G(^TMP($J,"HLUCM"))="DEBUG GLOBAL" D HLUCMSHW > ; > KILL ^TMP($J,"CMII") > KILL ^TMP($J,"HLUCM") > KILL ^TMP($J,"RECNM") > ; > QUIT $G(^TMP(TOTALS,$J)) > ; > OKVAR(I772) ; Set up variables for later. Leave "hanging > S PP=$$PROTNMSP^HLUCM002(+I772) > I $P(PP,U)']""!($P(PP,U,2)']"") QUIT "" ;-> > S TYPEHR=$$TYPETMO^HLUCM002(+I772) > S TYPEIO=$$TYPEIO^HLUCM002(+I772) > S TYPELR=$$TYPELR^HLUCM001(+I772) > QUIT 1 > ; > MSGIDADD(MSGID) ; Add entries from MSGID to LOAD772... > N CT,HOLD,IEN > QUIT:MSGID']"" ;-> > S IEN=0,CT=0 > F S IEN=$O(^HL(772,"C",MSGID,IEN)) Q:IEN'>0!(CT>30) > . QUIT:$P($G(^HL(772,+IEN,0)),U)'?7N.E ;-> > . S CT=CT+1 > . S HOLD(IEN)="" > QUIT:CT>30 ;-> > MERGE ^TMP($J,"LOAD772")=HOLD > QUIT > ; > CMIIMORE ; > N IEN772C,IEN772P,IEN772PS,VAL > S IEN772PS=0 > F S IEN772PS=$O(^TMP($J,"C",IEN772PS)) Q:IEN772PS'>0 > . S IEN772C=0 > . F S IEN772C=$O(^TMP($J,"C",IEN772PS,IEN772C)) Q:I > . . S IEN772P=0 > . . F S IEN772P=$O(^TMP($J,"C",IEN772PS,IEN772C,IE > . . . QUIT:IEN772PS=IEN772P ;-> Actual = Current > . . . S VAL=$G(^TMP($J,"CMII","N",+IEN772P)) > . . . MERGE ^TMP($J,"CMII","N",+IEN772PS,+IEN772C) > . . . S ^TMP($J,"CMII","N",+IEN772PS,+IEN772C)=VAL > . . . KILL ^TMP($J,"CMII","N",+IEN772P,+IEN772C) > . . . KILL ^TMP($J,"CMII","N",+IEN772P,+IEN772P) > . . . QUIT:$O(^TMP($J,"CMII","N",+IEN772P,0))>0 ; > . . . KILL ^TMP($J,"CMII","N",+IEN772P) > ; > KILL ^TMP($J,"C") > ; > ; > QUIT > ; > CMIINMNO ; Find namespace and protocol for each "unit" > N IEN772 F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q: | F S IEN772=$O(^TMP($J,"CMII","N",IEN772)) Q:IEN772'> . S DATA=$P($G(^TMP($J,"HLCHILD",+IEN772)),"~",2,999 | . S ^TMP($J,"CMII","N",IEN772)=$$UNITS(+IEN772) . S X=$P(DATA,U,4) I X?7N.E S TIME(X)="" | QUIT . S X=$P(DATA,U,5) I X?7N.E S TIME(X)="" | ; ; | MAKEE ; Loop thru entries, creating ^TMP($J,"HLUCMSTORE","E S BEG=$O(TIME(0)),END=$O(TIME(":"),-1) | N DATA,DBGBL,IEN772,IEN773,LOOP772,PP,TYPEHR,TYPEIO,T ; | ; ; Set 1st time and last time... | QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;-> S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,0)) Q:IEN772'> | ; D CORRECT(+IENPAR,+IEN772,4,BEG) | ; Loop, make E entries... S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,":"),-1) QUIT: | S LOOP772=0 D CORRECT(+IENPAR,+IEN772,5,END) | F S LOOP772=$O(^TMP($J,"CMII","N",LOOP772)) Q:LOOP77 ; | . S IEN772=0 ; Make other corrections... | . F S IEN772=$O(^TMP($J,"CMII","N",LOOP772,IEN772)) S IEN772=0,PREVTM="" | . . KILL DATA F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q: | . . QUIT:'$$OKVAR(+LOOP772) ;-> Creates PP,TYPEHR, . S DATA=$P($G(^TMP($J,"HLCHILD",+IEN772)),"~",2,999 | . . S DBGBL=1 . S TIME(1)=$P(DATA,U,4),TIME(2)=$P(DATA,U,5) | . . D TOT772^HLUCM(+IEN772) . | . . ; Loop thru all associated 773s and put #s in D . ; If first time thru... | . . S IEN773=0 . I PREVTM="" D QUIT ;-> | . . F S IEN773=$O(^TMP($J,"CMII","N",LOOP772,IEN77 . . I TIME(1)=TIME(2) S PREVTM=TIME(2) QUIT ;-> | . . . S DBGBL=1 ; Allow E creation... . . ; Set 1st entry's time to START=START (0 second | . . . D TOT773^HLUCM(IEN773) . . D CORRECT(+IENPAR,+IEN772,5,TIME(1)) | . . MERGE ^TMP($J,"HLUCMSTORE","E")=^TMP("HLUCMSTOR . . S PREVTM=TIME(1) | . . D TMDIFF^HLUCM . | . . S $P(^TMP($J,"HLUCMSTORE","E",IEN772),U,5)=$G(D . I TIME(1)'=PREVTM D | . KILL ^TMP("HLUCMSTORE",$J) . . D CORRECT(+IENPAR,+IEN772,4,PREVTM) | ; . . S TIME(1)=PREVTM | KILL ^TMP("HLUCMSTORE",$J) > ; > QUIT > ; > DATATM(IEN772) ; > N DBGBL,IEN773 > KILL DATA > S DBGBL=0 ; Disallow E entry creation... > D TOT772T^HLUCM(IEN772) > S IEN773=0 > F S IEN773=$O(^HLMA("B",IEN772,IEN773)) Q:IEN773'>0 > . D TOT773T^HLUCM(IEN773) > S DATA("START")=$O(DATA("TIME",0)) > S DATA("END")=$O(DATA("TIME",":"),-1) > KILL DATA("TIME") > QUIT > ; > COLLECT3(LOOP772,IEN772) ; Collect 772 data and associ > ; PP,TYPEHR,TYPEIO,TYPELR -- req > N DATA,DBGBL,IEN773,TOT772,TOT772T,TOT773,X > ; > ;S (DATA("PROT"),PROT)=$P(PP,U),PROT=$S(PROT]"":PROT, > ;S (DATA("PCKG"),PCKG)=$P(PP,U,2),PCKG=$S(PCKG]"":PCK > ; > ; Place 772 numbers in DATA(...) > ;S DBGBL=0 > ;D TOT772^HLUCM(IEN772) > ; > ; Loop thru all associated 773s and put #s in DATA(.. > ;S IEN773=0 > ;F S IEN773=$O(^TMP($J,"CMII","N",LOOP772,IEN772,IEN > ;. D TOT773^HLUCM(IEN773) > ; > ; Data OK? > ;QUIT:$G(DATA("CHAR"))'>0 ;-> > ;S DATA("START")=$O(DATA("TIME",0)) QUIT:DATA("START" > ; > ; A few % of entries have .01 times way out of "kilte > ;S X=+$G(^HL(772,+LOOP772,0)) I X>DATA("START") S DAT > ; > ;S DATA("END")=$O(DATA("TIME",":"),-1) > ;S DATA("DIFF")=$$SEC^HLUCM(DATA("END"))-$$SEC^HLUCM( > ; > ; Store DATA() info in ^TMP(TOTALS,$J,...) > ;D ADDTMP^HLUCM001 > ; > D COLLECT^HLUCM(IEN772) > ; > ; Store for future corrections... > S DTBEG=DATA("START"),DTEND=DATA("END") > ; > QUIT > ; > UNITS(IEN772) ; > N HOLD,IEN,NMSP,PROT,VALUE > ; > ; Ensure IEN772 is evaluated... > D:'$D(^TMP($J,"CMII","N",IEN772,IEN772)) > . S ^TMP($J,"CMII","N",IEN772,IEN772)="" > ; > ; Loop thru IEN772 subentries... > S (HOLD("NMSP"),HOLD("PROT"))="" > S IEN=0 > F S IEN=$O(^TMP($J,"CMII","N",IEN772,IEN)) Q:'IEN D . I TIME(1)>TIME(2) D | . S VALUE=$$PROTNMSP^HLUCM002(IEN772) . . D CORRECT(+IENPAR,+IEN772,5,TIME(1)) | . S PROT=$P(VALUE,U) . . S TIME(2)=TIME(1) | . S:HOLD("PROT")']""&(PROT]"") HOLD("PROT")=PROT . S PREVTM=TIME(2) | . S NMSP=$P(VALUE,U,2) . | . S:HOLD("NMSP")']""&(NMSP]"") HOLD("NMSP")=NMSP Q < ; < CORRECT(PAR,CHLDIEN,PCE,NEW) ; Change CHILD data... < N BEG,CHILD,DIFF,END,SEC,STORE < ; < ; Get CHILD and quit if no changes... < S HLCHILD=$G(^TMP($J,"HLCHILD",+CHLDIEN)) QUIT:$P(HLC < ; < ; Put new value into CHILD... < S $P(CHILD,U,PCE)=NEW < ; < ;Calculate SEC difference and set into CHILD... < S BEG=$P(CHILD,U,4),END=$P(CHILD,U,5) < S DIFF=$$FMDIFF^XLFDT(END,BEG,2) < S $P(CHILD,U,3)=DIFF < ; < ; Store data... < S ^TMP($J,"HLCHILD",+CHLDIEN)=HLCHILD < ; < Q < ; < RECNM(PFX,IEN772,FULLNM,REPNM,SRCE) ; Record where name f < ; PFX - [n] for namespace, and [p] for protocol < ; IEN772 - IEN of 772 < ; FULLNM - What is in entry itself, uninferred... < ; REPNM - What is to be reported < ; SRCE - Where it was inferred from < QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;-> | S HOLD=HOLD("PROT")_U_HOLD("NMSP") > ; > QUIT HOLD S REPNM=$G(PFX)_REPNM | LOAD772(IEN772) ; > N N0,PARENT S ^TMP($J,"HLRECNM")=$G(^TMP($J,"HLRECNM"))+1 | S N0=$G(^HL(772,+IEN772,0)) Q:N0']"" ;-> S ^TMP($J,"HLRECNM",REPNM)=$G(^TMP($J,"HLRECNM",REPNM | S PARENT=$P(N0,U,8),PARENT=$S(PARENT:PARENT,1:IEN772) S ^TMP($J,"HLRECNM",REPNM,SRCE)=$G(^TMP($J,"HLRECNM", | QUIT:$P($G(^HL(772,+PARENT,0)),U)'?7N1"."1.N ;-> S ^TMP($J,"HLRECNM",REPNM,SRCE,IEN772)=FULLNM | ; > ; If there's no 773... > I $O(^HLMA("B",IEN772,0))'>0 D QUIT ;-> > . S ^TMP($J,"CMII","N",PARENT,IEN772)="" > ; > S IEN773=0 > F S IEN773=$O(^HLMA("B",IEN772,IEN773)) Q:'IEN773 D > . D LOAD773C(PARENT,IEN773) MSHMAIL(IEN772) ; | LOAD773C(IEN772,IEN773) ; N CT,INOUT,MIEN,NIEN,PCKG,RECNM,TXT,X,XMER,XMPOS,XMRG | N N0,INITIAL,MSGID S MIEN=$P($G(^HL(772,+IEN772,0)),U,5) QUIT:MIEN'>0 "" | ; S INOUT=$P(^HL(772,+IEN772,0),U,4) | S N0=$G(^HLMA(+IEN773,0)) Q:N0']"" ;-> S INOUT=$S(INOUT="I":5,1:3) | ; S CT=0,PCKG="",XMZ=+MIEN,XMER=0 | ; Get 773 IEN for parent of parent and get 772 from i F D QUIT:CT>10!(PCKG]"")!($E(TXT,1,3)="MSH")!(XMER' | S INITIAL=$O(^HLMA("B",IEN772,0)) . S CT=CT+1 | S X=$P($G(^HLMA(+INITIAL,0)),U,10),INITIAL=$S(X:X,INI . D REC^XMS3 | S INITIAL(1)=+$G(^HLMA(+INITIAL,0)) . S TXT=$G(XMRG) QUIT:$E(TXT,1,3)'="MSH" ;-> | S X=$O(^TMP($J,"CMII","X",INITIAL(1),0)),INITIAL=$S(X . S X=$E(TXT,4),RECNM=$P(TXT,X,INOUT) | ; . S PCKG=$$PCKGMSH(TXT,INOUT) | S MSGID=$P(N0,U,2) . D RECNM("[n]",IEN772,RECNM,PCKG,"MAIL") | ; QUIT PCKG | S ^TMP($J,"CMII","N",INITIAL,IEN772,IEN773)=MSGID_U_I ; | S ^TMP($J,"CMII","X",IEN772,INITIAL,+$O(^HLMA("B",INI MSH772(IEN772) ; Get PCKG from MSH segment in 772... | ; ; Call here ONLY if can't get MSH segment from 773... | QUIT N CT,IN,INOUT,PCKG,RECNM,TXT,X | ; S IN=0,CT=0,PCKG="" | HLUCMSTR ; Store debug information... S INOUT=$$INOUT(+IEN772) | N TM772 F S IN=$O(^HL(772,+IEN772,"IN",IN)) Q:IN'>0!(CT>10)! | ; . S CT=CT+1 | QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;-> . S TXT=$G(^HL(772,+IEN772,"IN",+IN,0)) QUIT:TXT']"" | ; (Remember! this data is killed, including the ^TMP . QUIT:$E(TXT,1,3)'="MSH" ;-> | ; global which causes the debug data collect at the e . S X=$E(TXT,4),RECNM=$P(TXT,X,INOUT) | ; execution of the $$CM call.) . S PCKG=$$PCKGMSH(TXT,INOUT) | ; . D RECNM("[n]",IEN772,RECNM,PCKG,772) | ; store debug info... QUIT PCKG | S TM772=+$G(^HL(772,+IEN772,0)) Q:TM772'?7N.E ;-> ; | S:$G(^TMP($J,"HLUCM","FIRST"))']"" ^TMP($J,"HLUCM","F MSH773(IEN772) ; Get PCKG from MSH segment in 773... | S:$G(^TMP($J,"HLUCM","LAST"))']"" ^TMP($J,"HLUCM","LA N IEN773,INOUT,MSH,PCKG,RECNM,X | S X=$G(^TMP($J,"HLUCM","FIRST")) I +X>TM772 S ^TMP($J S IEN773=$O(^HLMA("B",IEN772,0)) QUIT:IEN773'>0 "" ;- | S X=$G(^TMP($J,"HLUCM","LAST")) I +X < QUIT $$FIXNMSP^HLUCM003(PFROM) < ; < ERRCHK ; Error checks... < ; < ; DATE checks... < S START=+$G(START),END=+$G(END) < I START'?7N&(START'?7N1"."1.N) D ERR^HLUCM("INVALID S < I END'?7N&(END'?7N1"."1.N) D ERR^HLUCM("INVALID END T < I '$D(ERRINFO("INVALID START TIME")) D < . I '$D(ERRINFO("INVALID END TIME")) D < . . I START=END!(START < . . D ERR^HLUCM("END TIME PRECEDES START TIME") < ; < ; If condition=BOTH, can't be ALL(1/2) and ALL(1/2) o < ; ALL(1/2) and SPECIFIC. BOTH can only be SPECIFIC an < I COND="BOTH" D < . N P1,P2,P3 < . S P1=$S($G(PNMSP)>0:1,1:0) ; namespace 0/1 < . S P2=$S($G(IEN101)>0:1,1:0) ; protocol 0/1 < . S P3=P1+P2 QUIT:P3'>0 ;-> < . D ERR^HLUCM("BOTH NAMESPACES(S) AND PROTOCOL(S) MU < QUIT < ; < SETMORE ; More defaults... < ; < ; Check format of PNMSP... < ; If not passed by reference... < I 'NMSPTYPE D ; Namespace(s) not passed as an array < . ; Passed as 1 or 2 or O^NMSP, but is it valid? < . I '$$OKPAR^HLUCM002(PNMSP) D < . . D ERR^HLUCM("INVALID NAMESPACE PARAMETER") < ; < ; Check format of IEN101... < ; If not passed by reference... < I 'PROTYPE D ; Protocol(s) not passed as an array < . ; Passed as 1 or 2 or 0^PROT or 0^IEN, but is it v < . I '$$OKPAR^HLUCM002(IEN101) D ; Check format... < . . D ERR^HLUCM("INVALID PROTOCOL PARAMETER") < . S IEN101=$$OKPAR101^HLUCM001($G(IEN101)) I IEN101' < . . I $D(ERRINFO("INVALID PROTOCOL PARAMETER")) QUI < . . QUIT:IEN101["0^9999999" ;-> < . . D ERR^HLUCM("CAN'T FIND PROTOCOL") < QUIT < ; < FIXNMSP(PCKG,I772) ; First space piece, strip _ < N APPR,APPS,FACR,FACS,I773,MSH < ; < S I772=+$G(I772) < ; < ; Get 773 (or 772)-related information... < S I773=$O(^HLMA("B",+I772,0)) < S MSH=$G(^HLMA(+I773,"MSH",1,0)) < I MSH']"" S X=$G(^HL(772,+I772,"IN",1,0)) S:$E(X,1,3) < S X=$E(MSH,4),APPS=$P(MSH,X,3),FACS=$P(MSH,X,4),APPR= < ; < S PCKG=$$NMSPCHG^HLUCM050(PCKG) < ; < QUIT $TR($E($P($P(PCKG," "),"-"),1,4),"_ ","") ;-> < ; < CTPCKG(PCKG) ; Should entry be counted on basis of package < ; (Might be countable if protocol matches remember.) < ; If list of packages passed by reference, is PCKG in < ; IEN101,NMSPTYPE,PNMSP -- req < N CTPCKG < ; < ; Must count everything... < I $G(PNMSP)=1!($G(PNMSP)=2) QUIT 1 ;-> < ; < ; If passed namspace by array, is PCKG in array? < I NMSPTYPE=1 QUIT $S($$REFPCKG^HLUCM001(PCKG):1,1:"") < ; < ; If passed in "0^NAMESPACE" format... < I $$OK0CALL^HLUCM002(PNMSP) D QUIT $S(PCKG]"":1,1:"" < . I $P(PNMSP,U,2)'=PCKG S PCKG="" < ; < QUIT "" < ; < CTPROT(PROT) ; Should entry be counted on basis of protoco < ; (Might be countable if package matches remember.) < ; IEN,PROTYPE -- req < ; < N CTPROT < ; < ; Must count everything... < I $G(IEN101)=1!($G(IEN101)=2) QUIT 1 ;-> < ; < ; If passed protocols by array, is PROT in array? < I PROTYPE=1 QUIT $S($$REFPROT^HLUCM001(PROT):1,1:"") < ; < ; If PROT not found, and passed 0^PROTNM or 0^PROTIEN < ; can't do anything more... < I $$OK0CALL^HLUCM002(IEN101) D QUIT $S(PROT]"":1,1:" < . N VAL < . QUIT:PROT']"" ;-> < . S VAL=$P(IEN101,U,2) < . I $P(PROT,"~")'=VAL&($P(PROT,"~",2)'=VAL) S PROT=" < QUIT "" | HLUCMSHW ; Show debug information > QUIT:'$D(^TMP($J,"HLUCM")) ;-> > W !!,"First: ",?20 > S X=$G(^TMP($J,"HLUCM","FIRST")) > F Q:X']"" W $E(X,1,60) S X=$E(X,61,999) W:X]"" !,?2 > W !,"Last: ",?20 > S X=$G(^TMP($J,"HLUCM","LAST")) > F Q:X']"" W $E(X,1,60) S X=$E(X,61,999) W:X]"" !,?2 > W !,"Number units:",?20,$J($P(^TMP(TOTALS,$J),U,2),7) > W !,"Number entries:",?20,$J($P(^TMP(TOTALS,$J),U,4), > W !! > QUIT diff -y --suppress-common-lines ./VADemo/r1/HLUCM004.m ./VADemo/r2/r/HLUCM004.m HLUCM004 ;CIOFO-O/LJA - HL7/Capacity Mgt API ;3/13/03 | HLUCM004 ;CIOFO-O/LJA - HL7/Capacity Mgt API-II ;10/23 ;;1.6;HEALTH LEVEL SEVEN;*88,103**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**88**;Oct 13, 1995 LOOPU ; Loop thru ^TMP($J,"HLUCMSTORE","U") data. Full-scr | INFERPR(IEN772,DEFAULT) ; Infer protocol... N CT,DATA,EXCL,IEN772,IENPAR,INCL,IOINHI,IOINORM,RNOM | N HL772,NUM772,PROTW,RECNM,X S X="IOINHI;IOINORM" D ENDR^%ZISS < ; < LOOPU1 KILL DATA,EXCL,INCL,IEN772,IENPAR,INCL,RNOMSG,STOP,TY < W @IOF,$$CJ^XLFSTR("Display of ^TMP($J,""HLUCMSTORE"" < W !,$$REPEAT^XLFSTR("=",IOM) < ; < W !!,$$CJ^XLFSTR("Type Totals",IOM) < W !,$$CJ^XLFSTR("--------------------------------",IO < S TYPE="" < F S TYPE=$O(^TMP($J,"HLUCMSTORE","T",TYPE)) Q:TYPE'] < . S DATA=$G(^TMP($J,"HLUCMSTORE","T",TYPE)) < . W !,$$CJ^XLFSTR(TYPE_" "_DATA,IOM) < ; < W !!,"Enter text in messages to include and exclude.. < W ! < D EXCL(.EXCL) < W ! < D INCL(.INCL) < ; < R !!,"Restrict # messages: 999// ",RNOMSG:999 < S:RNOMSG']"" RNOMSG=999 < QUIT:RNOMSG'?1.N ;-> < ; < S (CT,CT(1))=0,IENPAR=0,STOP=0 < F S IENPAR=$O(^TMP($J,"HLUCMSTORE","U",IENPAR)) Q:'I < . S CT(1)=CT(1)+1 < . QUIT:'$$OK(+IENPAR,RNOMSG,.EXCL,.INCL) ;-> < . S CT=CT+1 < . D SHOWU(+IENPAR,"FULL") < . R X:999 I X[U S STOP=1 < I CT(1)'>0 W !!,"No data exists..." H 2 | ; This IEN772 already inferred > S X=$P($G(^TMP($J,"ACTUAL",IEN772)),U,2) I X]"" QUIT I CT(1)>0 D | S RECNM=$G(DEFAULT) . W !!,$S('CT:"No matching entries found...",1:"#"_C | ; . S CT=CT(1)-CT W !,"#"_CT_" entries skipped..." | S X=$$LOAD772S^HLUCM005(IEN772,.HL772) QUIT:X'>0 $G(D ; | ; Q | S NUM772=0,PROTW="" ; | F S NUM772=$O(HL772(NUM772)) Q:NUM772'>0!(PROTW]"") OK(IENPAR,RNOMSG,EXCL,INCL) ; Exclude and INcludes.. | . S PROTW=$P(HL772(NUM772),U,2) N DATA,FAIL,HOLDEXCL,IEN772,NUM | ; ; | I PROTW]"" D RECNM("[p]",IEN772,RECNM,PROTW,"PROT") ; Count messages... | ; S NUM=0,IEN772=0 | QUIT $S(PROTW]"":PROTW,1:$G(DEFAULT)) F S IEN772=$O(^TMP($J,"HLUCMSTORE","U",+IENPAR,IEN77 | ; . S NUM=NUM+1 | INFERNM(IEN772,DEFAULT) ; Call here ONLY if can't get PCKG fr ; | ; PCKG -- req ; Quit if number messages in unit isn't right... | N HL772,NUM772,PCKGW,PROTW,X I RNOMSG=999 QUIT:NUM>RNOMSG "" ;-> Should never happ | ; I RNOMSG'=999 QUIT:NUM'=RNOMSG "" ;-> | ; This IEN772 already inferred ; | S X=$P($G(^TMP($J,"ACTUAL",IEN772)),U,4) I X]"" QUIT ; Parent node check... | ; S DATA=$G(^TMP($J,"HLUCMSTORE","U",+IENPAR)) | S DEFAULT=$G(DEFAULT),DEFAULT=$S(DEFAULT]"":DEFAULT,1 ; | S X=$$LOAD772S^HLUCM005(IEN772,.HL772) QUIT:X'>0 $G(D ; Exclusions... | ; QUIT:$$HOLDEXCL(DATA,.EXCL) "" ;-> | S NUM772=0,PCKGW="" ; | F S NUM772=$O(HL772(NUM772)) Q:NUM772'>0!(PCKGW]"") ; Child nodes check... | . S PCKGW=$$INFERW(NUM772,$G(DEFAULT)) QUIT:PCKGW]"" I $O(EXCL(""))]"" D | . . S IEN772=0,HOLDEXCL=0 | . ; Final MAIL inferral after all else fails... . F S IEN772=$O(^TMP($J,"HLUCMSTORE","U",+IENPAR,IE | . QUIT:$P($G(^HL(772,+NUM772,0)),U,5)'>0 ;-> . . S DATA=$$DATA(+IEN772) | . S PCKGW="XWB" . . S HOLDEXCL=$$HOLDEXCL(DATA,.EXCL) | ; ; | QUIT $S(PCKGW]"":PCKGW,1:DEFAULT) QUIT:$G(HOLDEXCL) "" ;-> | ; ; | INFERW(IEN772,DEFAULT) ; Called from $$INFER... ; Quit, if no INCLUDES... | N NAME,PACK,PCKG,PIEN,PROT,RECNM,VALUES QUIT:$O(INCL(""))']"" 1 ;-> | ; ; | ; See "Final Mail inferral" in above FOR loop... ; Inclusion check for parent node... | ; QUIT:$$HOLDINCL(DATA,.INCL) 1 ;-> | S VALUES=$$NMSP772(+IEN772) ; | S NAME=$P(VALUES,U,5) ; Child node inclusion checks... | I NAME]"" QUIT $$FIXNMSP^HLUCM008(NAME,IEN772) ;-> S IEN772=0,HOLDINCL=0 | ; F S IEN772=$O(^TMP($J,"HLUCMSTORE","U",+IENPAR,IEN77 | ; Is this an SPR message? Then, get PCKG by extracti . S DATA=$$DATA(+IEN772) | ; (Do this BEFORE any other attemps made on MSH, etc) . S HOLDINCL=$$HOLDINCL(DATA,.INCL) | S PCKG(1)=$$SPR(IEN772) ; | I PCKG(1)]"" D QUIT PCKG ;-> Q HOLDINCL | . S PCKG=PCKG(1) ; | . S PCKG=$$ADJUST(IEN772,$$FIXNMSP^HLUCM008(PCKG,IEN EXCL(EXCL) ; What entries to exclude? (Searches PARENT n | . D RECNM("[n]",IEN772,DEFAULT,PCKG,"SPR") W !!,"Every parent node that includes one of the EXCL | ; W !,"will not be included in the entries displayed." | ; Try to get namespace from 773's MSH first... W ! | S PCKG=$$MSH773(IEN772) D ASK("EXCLUDE",.EXCL) | I PCKG]"" D QUIT PCKG ;-> Q | . S PCKG=$$ADJUST(IEN772,$$FIXNMSP^HLUCM008(PCKG,IEN ; | . D RECNM("[n]",IEN772,DEFAULT,PCKG,"MSH773") HOLDEXCL(DATA,EXCL) ; Includes text that should be exclud | ; N HOLD | ; Try to get namespace from 772'S MSH next... S EXCL="",HOLD=0 | S PCKG=$$MSH772(IEN772) F S EXCL=$O(EXCL(EXCL)) Q:EXCL']""!(HOLD) D | I PCKG]"" D QUIT PCKG ;-> . I DATA[EXCL S HOLD=1 | . S PCKG=$$ADJUST(IEN772,$$FIXNMSP^HLUCM008(PCKG,IEN Q HOLD | . D RECNM("[n]",IEN772,DEFAULT,PCKG,"MSH772") ; | ; INCL(INCL) ; What entries to include? (Searches PARENT n | ; Is there a Mail message ptr with a MSH? W !!,"Every parent node that doesn't include one of t | S PCKG=$$MSHMAIL(IEN772) W !,"enter now will not be included in the entries di | I PCKG]"" D QUIT PCKG ;-> W ! | . S PCKG=$$ADJUST(IEN772,$$FIXNMSP^HLUCM008(PCKG,IEN D ASK("INCLUDE",.INCL) | . D RECNM("[n]",IEN772,DEFAULT,PCKG,"MSHMAIL") Q | ; ; | ; Maybe, it can be found from the protocol name? HOLDINCL(DATA,INCL) ; Does DATA hold one of the INCLUDEs? | S PCKG=$P(VALUES,U,2) N HOLD | I PCKG]"" D QUIT PCKG ;-> S INCL="",HOLD=0 | . S RECNM=PCKG F S INCL=$O(INCL(INCL)) Q:INCL']""!(HOLD) D | . S PCKG=$$ADJUST(IEN772,$$FIXNMSP^HLUCM008(PCKG,IEN . I DATA[INCL S HOLD=1 | . D RECNM("[n]",IEN772,RECNM,PCKG,101) Q HOLD | ; ; | ; Oh, well! ASK(TYPE,ENTRY) ; Repeatedly ask... | ; N ANS | QUIT $G(DEFAULT) F D QUIT:ANS']"" | ; . W !,TYPE,": " | SPR(IEN772) ; Evaluate SPR segment for RPC for package, p . R ANS:999 S:ANS=U ANS="" Q:ANS']"" ;-> | ; resetting the PCKG variable... . S ENTRY(ANS)="" | ; PCKG -- req Q | N CHAR,DEL,IN ; | S IN=$G(^HL(772,+IEN772,"IN",1,0)) SHOWU(IENPAR,VIEW) ; Show one entry in VIEW format... | QUIT:$E(IN,1,4)'="SPR^" "" ;-> N HL,X | QUIT:IN'["REMOTE RPC^" "" ;-> MERGE HL=^TMP($J,"HLUCMSTORE","U",+IENPAR) | S DEL=$E(IN,4) S X="D "_VIEW_"(.HL)" X X | S IN=$P(IN,DEL,5) QUIT:IN']"" "" ;-> Q | S IN=$P(IN,"003RPC",2) QUIT:IN']"" "" ;-> ; | S CHAR=+IN,IN=$TR($E(IN,4,CHAR+4),"&","") QUIT:IN']"" FULL(HL) ; Display one entry in FULL format... | I $E(IN,1,2)="IB" D QUIT "IB" ;-> ; IOINHI,IOINORM -- req | . D RECNM("[n]",IEN772,IN,"IB","SPR") N COUNT,DATA,DATA4,DATAN,DATAP,DATAR,IEN772,L,LEN | I $E(IN,1,2)="OR" D QUIT "OR" ;-> N PNO,PROTP,PROTC,RES,STOP | . D RECNM("[n]",IEN772,IN,"OR","SPR") ; | QUIT "" ; Header... | ; W @IOF | RECNM(PFX,IEN772,FULLNM,REPNM,SRCE) ; Record where name f S DATA=HL | ; PFX - [n] for namespace, and [p] for protocol F D Q:DATA']"" | ; IEN772 - IEN of 772 . W !,$$CJ^XLFSTR($E(DATA,1,70),IOM) | ; FULLNM - What is in entry itself, uninferred... . S DATA=$E(DATA,71,999) | ; REPNM - What is to be reported W !,$$REPEAT^XLFSTR("=",IOM) | ; SRCE - Where it was inferred from ; | ; S PROTP=$P(HL,U,7) | QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;-> ; | ; ; Body... | S REPNM=$G(PFX)_REPNM S COUNT=0,IEN772=0,STOP=0 | ; F S IEN772=$O(HL(IEN772)) Q:'IEN772!(STOP) D | S ^TMP($J,"RECNM")=$G(^TMP($J,"RECNM"))+1 . S COUNT=COUNT+1 | S ^TMP($J,"RECNM",REPNM)=$G(^TMP($J,"RECNM",REPNM))+1 . S DATA=$$DATA(+IEN772) | S ^TMP($J,"RECNM",REPNM,SRCE)=$G(^TMP($J,"RECNM",REPN . S L=$L(DATA),X=$E(DATA,L-2,L) I X?3U,X'="CCC" S DA | S ^TMP($J,"RECNM",REPNM,SRCE,IEN772)=FULLNM . S PROTC=$P(DATA,U,7) | ; . S $P(DATA,U,7)=$S(PROTP=PROTC:"...",1:"~hi~"_PROTC | QUIT . W !,IEN772,?12,"-",?14 | ; . F PNO=1:1:$L(DATA,U) D | MSHMAIL(IEN772) ; . . S DATAP=$P(DATA,U,+PNO) | N CT,INOUT,MIEN,NIEN,PCKG,RECNM,TXT,X,XMER,XMPOS,XMRG . . S DATAN=$P(DATA,U,+PNO+1) | S MIEN=$P($G(^HL(772,+IEN772,0)),U,5) QUIT:MIEN'>0 "" . . I DATAP["~hi~" D | S INOUT=$P(^HL(772,+IEN772,0),U,4) . . . S DATAP=$P(DATAP,"~hi~",2),LEN=$L(DATAP)+1 | S INOUT=$S(INOUT="I":5,1:3) . . . S DATAP=IOINHI_DATAP_IOINORM | S CT=0,PCKG="",XMZ=+MIEN,XMER=0 . . E S LEN=$L(DATAP)+1 | F D QUIT:CT>10!(PCKG]"")!($E(TXT,1,3)="MSH")!(XMER' . . S DATAP=DATAP_$S(DATAN]"":U,1:"") | . S CT=CT+1 . . W:(IOM-$X-LEN)'>0 !,?14 | . D REC^XMS3 . . W DATAP | . S TXT=$G(XMRG) QUIT:$E(TXT,1,3)'="MSH" ;-> . I '(COUNT#4) W " ",IOINHI,"<",IOINORM R X:120 I X[ | . S X=$E(TXT,4),RECNM=$P(TXT,X,INOUT) . W !,$$REPEAT^XLFSTR($S($O(HL(IEN772)):"-",1:"="),I | . S PCKG=$$PCKGMSH(TXT,INOUT) ; | . D RECNM("[n]",IEN772,RECNM,PCKG,"MAIL") ; Trailer... | QUIT PCKG S RES="C" | ; F S RES=$O(HL(RES)) Q:RES'?3U D | MSH772(IEN772) ; Get PCKG from MSH segment in 772... . S DATAR=HL(RES) | ; Call here ONLY if can't get MSH segment from 773... . W $$CJ^XLFSTR(RES_" - "_DATAR,IOM) | N CT,IN,INOUT,PCKG,RECNM,TXT,X ; | S IN=0,CT=0,PCKG="" Q | S INOUT=$$INOUT(+IEN772) ; | F S IN=$O(^HL(772,+IEN772,"IN",IN)) Q:IN'>0!(CT>10)! DATA(IEN772) ; Return what is displayed... | . S CT=CT+1 N DATA,IENPAR,RES | . S TXT=$G(^HL(772,+IEN772,"IN",+IN,0)) QUIT:TXT']"" S IENPAR=+$G(^TMP($J,"HLUCMSTORE","X",+IEN772)) QUIT: | . QUIT:$E(TXT,1,3)'="MSH" ;-> S RES=$O(^TMP($J,"HLUCMSTORE","U",+IENPAR,+IEN772,"") | . S X=$E(TXT,4),RECNM=$P(TXT,X,INOUT) S DATA=$G(^TMP($J,"HLUCMSTORE","U",+IENPAR,+IEN772,RE | . S PCKG=$$PCKGMSH(TXT,INOUT) I $TR(DATA," <>","")']"" S DATA="" | . D RECNM("[n]",IEN772,RECNM,PCKG,772) Q DATA | QUIT PCKG ; | ; XTMPGBL(SHOW) ; Display XTMP data totals? | MSH773(IEN772) ; Get PCKG from MSH segment in 773... N ANS,API,BEG,COND,DATA,END,HOLD,NO,RUN,SVNO,TIME,XTM | N IEN773,INOUT,MSH,PCKG,RECNM,X ; | S IEN773=$O(^HLMA("B",IEN772,0)) QUIT:IEN773'>0 "" ;- S XTMP="HLUCM ",SHOW=+$G(SHOW),HOLD=0 | S INOUT=$$INOUT(IEN772) QUIT:$O(^XTMP(XTMP))'?1"HLUCM "7N ;-> | S MSH=$G(^HLMA(+IEN773,"MSH",1,0)) QUIT:MSH']"" "" ;- W !!,$$CJ^XLFSTR(" XTMP-stored Reports ",IOM),!,$$REP | S X=$E(MSH,4),RECNM=$P(MSH,X,INOUT) W !,"#",?4,"Run-time",?20,"API Call" | S PCKG=$$PCKGMSH(MSH,INOUT) W !,$$REPEAT^XLFSTR("=",IOM) | D RECNM("[n]",IEN772,RECNM,PCKG,773) F S XTMP=$O(^XTMP(XTMP)) Q:XTMP'?1"HLUCM "7N D | QUIT PCKG . S BEG=0 | ; . F S BEG=$O(^XTMP(XTMP,"P",BEG)) Q:'BEG D | INOUT(IEN772) ; . . S END=0 | N INOUT . . F S END=$O(^XTMP(XTMP,"P",BEG,END)) Q:'END D | S INOUT=$P($G(^HL(772,+IEN772,0)),U,4) . . . S COND="" | S INOUT=$S(INOUT="I":5,1:3) ; Default to O, which is . . . F S COND=$O(^XTMP(XTMP,"P",BEG,END,COND)) Q | QUIT INOUT . . . . S DATA=$G(^XTMP(XTMP,"P",BEG,END,COND)) Q | ; . . . . S SVNO=+DATA,TIME=$P(DATA,U,2) QUIT:TIME' | PCKGMSH(MSH,INOUT) ; Extract PCKG namespace from MSH seg . . . . S DATA=$G(^XTMP(XTMP,"N",+SVNO)),API=$P(D | N DEL,PFROM . . . . S HOLD=HOLD+1 | S DEL=$E(MSH,4),INOUT=$S($G(INOUT):INOUT,1:3) . . . . S HOLD(TIME,HOLD)=XTMP_U_SVNO_"~"_$E(TIME | S PFROM=$P(MSH,DEL,INOUT) QUIT:PFROM']"" "" ;-> . . . . S RUN(+SVNO)=XTMP | QUIT $$FIXNMSP^HLUCM008(PFROM) S TIME=0,HOLD=0 | ; F S TIME=$O(HOLD(TIME)) Q:'TIME D | ADJUST(IEN772,PCKG) ; Miscellaneous final adjustments and . S NO=0 | ; . F S NO=$O(HOLD(TIME,NO)) Q:NO'>0 D | ; None, now... . . S DATA=HOLD(TIME,NO),XTMP=$P(DATA,U) | ; . . S SVNO=$P($P(DATA,"~"),U,2),DATA=$P(DATA,"~",2, | QUIT PCKG . . S HOLD=HOLD+1 | ; . . S HOLD("N",HOLD)=XTMP_U_SVNO | DEBUGP ; Display debug data... . . W !,$E("#"_HOLD_" ",1,4),DATA | N COL,SUB ; | S SUB=$$SUBDBG QUIT:SUB']"" ;-> QUIT:HOLD'>0 "" ;-> | D DEBUGC(SUB,15) ; | QUIT W !!,"You may choose to print the totals report from | ; W !,"If so, enter the number of the XTMP report from | SUBDBG() ; W !,"press RETURN.)" | N DIR,DIRUT,DTOUT,DUOUT,X,Y > S DIR(0)="S^1:Print TMP($J,""HLUCMSTORE"",""E"") data > D ^DIR > QUIT:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) "" ;-> > QUIT:+Y=4 "" ;-> > QUIT:+Y<1 "" ;-> > QUIT $P("E^U^X",U,+Y) > ; > DEBUGC(SUB,COL) ; Display debug data > S SUB=$E($G(SUB)_" ") QUIT:"EUX"'[SUB ;-> > S COL=$S($G(COL):+COL,1:15) > I SUB="E" D DEBUGE^HLUCM008(COL) > I SUB="U" D DEBUGU(COL) > I SUB="X" D DEBUGX(COL) > QUIT > ; > DEBUGU(COL) ; Print ^TMP($J,"HLUCMSTORE","U") data... > N CT,DATA,GBL,IEN772,IEN773,LP772,POSX > S GBL="^TMP("_$J_",""HLUCMSTORE"",""U"")" > S IEN772=0 > F S IEN772=$O(@GBL@(IEN772)) Q:IEN772'>0 D > . W !,$$REPEAT^XLFSTR("-",IOM) > . W !,IEN772," " > . S POSX=$X > . D PRT(POSX,$G(@GBL@(IEN772))) > . S LP772=0 > . F S LP772=$O(@GBL@(IEN772,LP772)) Q:LP772'>0 D > . . D PRT(POSX,LP772_": "_$G(@GBL@(IEN772,LP772))_$ > QUIT > ; > CHAR773(IEN772,LP772) ; Number characters in associated 773 > N CHAR,IEN773 > S IEN773=0,CHAR=0 > F S IEN773=$O(^TMP($J,"HLUCMSTORE","U",IEN772,LP772, > . S CHAR=CHAR+$G(^TMP($J,"HLUCMSTORE","U",IEN772,LP7 > QUIT $S(CHAR:" ["_CHAR_"]",1:"") > ; > DEBUGX(COL) ; Print ^TMP($J,"HLUCMSTORE","X") data... > N CHILD,GBL,I773,PARENT > W !!,"Child 772",?16,"Parent 772",?32,"Child 772s Ass > W !,$$REPEAT^XLFSTR("-",IOM) > S GBL="^TMP("_$J_",""HLUCMSTORE"",""X"")" > S CHILD=0 > F S CHILD=$O(@GBL@(CHILD)) Q:CHILD'>0 D > . W !,CHILD > . S PARENT=0 > . F S PARENT=$O(@GBL@(CHILD,PARENT)) Q:PARENT'>0 D > . . W:$X>16 ! W:$X<16 ?16 > . . W "-> ",PARENT > . . QUIT:$O(@GBL@(CHILD,PARENT,0))'>0 ;-> > . . W:$X>32 ! W:$X<32 ?32 > . . S I773=0 > . . F S I773=$O(@GBL@(CHILD,PARENT,I773)) Q:I773'> > . . . I ($X+$L(I773)+2)>IOM W !,?32 > . . . W:$X>32 ", " > . . . W I773 > QUIT > ; > PRT(COL,DATA) ; Print data... > W:$X>COL ! W:$X F Q:DATA']"" D > . W:$X>COL ! W:$X . S DATA(1)=$E(DATA,IOM-$X+1,999) > . W $E(DATA,1,IOM-$X) > . S DATA=DATA(1),DATA=$S(DATA]"":" "_DATA,1:"") > QUIT > ; > NMSP772(IEN772) ; Return 101-IEN ^ 101-NAME ^ PCKG-IEN ^ PCKG > N MIEN,NAME,PACK,PROT > ; > S MIEN=$P($G(^HL(772,+IEN772,0)),U,5) > ; > S PROT=$P($G(^HL(772,+IEN772,0)),U,10) QUIT:'MIEN&(PR > S PROT(1)=$P($G(^ORD(101,+PROT,0)),U) QUIT:'MIEN&(PRO > S PACK=$P($G(^ORD(101,+PROT,0)),U,12) QUIT:'MIEN&(PAC > S PACK(1)=$$NMSP94^HLUCM001(+PACK),NAME=$P(PACK(1),U, > QUIT:'MIEN&(PACK(1)']"") PROT_U_PROT(1) ;-> R !!,"Enter XTMP Report#: ",NO:999 Q:'$D(HOLD("N",+NO | ; Give it a pseudo mail protocol S XTMP=$P(HOLD("N",+NO),U),SVNO=$P(HOLD("N",+NO),U,2) | I 'PROT,MIEN S PROT=9999999,PROT(1)="XWB" Q $NA(^XTMP(XTMP,"D",SVNO)) | QUIT $G(PROT)_U_$G(PROT(1))_U_$G(PACK)_U_$G(PACK(1))_ EOR ; HLUCM004 - HL7/Capacity Mgt API ;3/13/03 09:37 | EOR ; HLUCM004 - HL7/Capacity Mgt API-II ;10/23/01 12:01 Only in ./VADemo/r2/r/: HLUCM005.m Only in ./VADemo/r2/r/: HLUCM006.m Only in ./VADemo/r2/r/: HLUCM007.m Only in ./VADemo/r2/r/: HLUCM008.m Only in ./VADemo/r1/: HLUCM009.m Only in ./VADemo/r1/: HLUCM050.m Only in ./VADemo/r1/: HLUCM090.m diff -y --suppress-common-lines ./VADemo/r1/HLUCM.m ./VADemo/r2/r/HLUCM.m HLUCM ;CIOFO-O/LJA - HL7/Capacity Mgt API ;09/13/04 14:01 | HLUCM ;CIOFO-O/LJA - HL7/Capacity Mgt API ;2/27/01 10:15 ;;1.6;HEALTH LEVEL SEVEN;**79,88,103,114**;Oct 13, 19 | ;;1.6;HEALTH LEVEL SEVEN;**79,88**;Oct 13, 1995 N NMSPTYPE,PROTYPE,RESULTS,SITENM | N CTPCKG,ERR,DATA,IEN772,IEN773,LOOPDT,ORIGETM,ORIGST I '$D(HLAPI) N HLAPI S HLAPI="CM" | N PCKG,PROT,PROTOCOL,PROTYPE,RESULTS,V1,V2,X,Y QUIT:'$$PREPARE^HLUCM001 "" ;-> | ; NEWs above for $$SETUP and subcalls, and for $$LOOP D KILLS^HLUCM009("START") | ; > S ORIGSTM=$G(START),ORIGETM=$G(END) > ; > ; Summarize by DAY instead of hour? > I ORIGSTM?7N,ORIGETM']"" D > . S ^TMP($J,"HLUCMDT")="" > . S ORIGETM=ORIGSTM_".24" > ; > ; If didn't add 0^... > I $G(IEN101)]"",IEN101'?1N,IEN101'?1"0^".E S IEN101=" > I $G(PNMSP)]"",PNMSP'?1N,PNMSP'?1"0^".E S PNMSP="0^"_ > ; > ; Miscellaneous KILLs... > D KILLS("START") > ; > ; This is where results are returned to caller... > KILL ERRINFO > ; > ; Perform all setup chores. If errors found, they wi > ; in ERRINFO(ERROR-REASON)="" array > QUIT:$$SETUP "" ;-> Some errors occurred... > ; > ; Loop and count here... (MAIN WORK LOOP) D XTMP | I $D(^TMP(TOTALS,$J)) S ^TMP(TOTALS,$J)=$P($G(^TMP(TO D KILLS^HLUCM009("END") | ; KILL HLAPI | ; If debugging, add REMOTE... Q RESULTS | D REMOTE^HLUCM006 ; | ; CMF(START,END,PNMSP,IEN101,TOTALS,COND,ERRINFO) ; Collect Rem | D KILLS("END") N HLAPI < S HLAPI="CMF" < Q $$CM(START,END,.PNMSP,.IEN101,TOTALS,COND,.ERRINFO) < CM2(START,END,PNMSP,IEN101,TOTALS,COND,ERRINFO) ; Capacity ma < N NMSPTYPE,PROTYPE,RESULTS,SITENM < I '$D(HLAPI) N HLAPI S HLAPI="CM2" < QUIT:'$$PREPARE^HLUCM001 "" ;-> < D KILLS^HLUCM009("START") < S RESULTS=$P($$LOOP,U,1,3) ; Counts are aggregate < D XTMP < D KILLS^HLUCM009("END") < KILL HLAPI < CM2F(START,END,PNMSP,IEN101,TOTALS,COND,ERRINFO) ; Col | CM2(START,END,PNMSP,IEN101,TOTALS,COND,ERRINFO) ; Capacity ma N HLAPI < S HLAPI="CM2F" < Q $$CM2(START,END,.PNMSP,.IEN101,TOTALS,COND,.ERRINFO < LOOP() ; Loop thru 772's .01... (Called from LOOP^HLUCM) | ; PHASE II - Counts are by "units", not individual en N ANS,API,CHAR,COUNTED,CTDBG,CTPCKG,D0,DATA,DEF,ERR,F | ; A unit equals the msg and all related CA N HLUCMADD,IEN772,IEN773,LEN,LOOP772,LOOPDT,NMSP,NUM, | ; N ORIGETM,ORIGSTM,PCKG,PROT,PROTOCOL,QUES,SEC | N COUNTED,CTPCKG,ERR,DATA,HLUCMADD,IEN772,IEN773,LOOP N SP,SUB,SVNO,TIMEP,TM772,TOT,V1,V2,VAL,VALUE,X,Y | N LOOPDT,NMSPTYPE,ORIGETM,ORIGSTM,PCKG,PROT,PROTOCOL ; | N PROTYPE,RESULTS,V1,V2,VALUE,X D LOAD | ; NEWs above for $$SETUP and subcalls, and for $$LOOP D ADJTIME^HLUCM003 | ; D CMDBD | S ORIGSTM=$G(START),ORIGETM=$G(END) D TOTALCM ; Already stored in X (no counted) or C (co | ; S RESULTS=$G(^TMP(TOTALS,$J)) | D KILLS("START") > ; > ; This is where results are returned to caller... > KILL ERRINFO > ; > ; Perform all setup chores. If errors found, they wi > ; in ERRINFO(ERROR-REASON)="" array > QUIT:$$SETUP "" ;-> Some errors occurred... > ; > ; Loop and count here... (MAIN WORK LOOP) > S RESULTS=$P($$LOOP^HLUCM003,U,1,3) ; Counts are aggr > I $D(^TMP(TOTALS,$J)) S ^TMP(TOTALS,$J)=$P($G(^TMP(TO > ; > ; If debugging, add REMOTE... > D REMOTE^HLUCM006 > ; > D KILLS("END") CMDBD ; Create $$CM debug data... | SETUP() ; Perform checks, which can return error conditions, ; HLAPI,START,END -- req | ; set up variables for $$LOOP. This extrinsic functi N DATA,IENPAR,IEN772,OKPP,S1,S2,S3,SUB,TOT,VALNMSP,VA | ; "" if no errors, or the # errors found. (Note that ; | ; details placed in ERRINFO(ERROR-REASON)="") S API=$S($G(API)["CM2":1,1:0) ; Async=1, Sync=0 | N NOERR ; | S NOERR="" S IENPAR=0 | D SETDEF ; Set defaults for parameters, if not passed F S IENPAR=$O(^TMP($J,"HLPARENT",IENPAR)) Q:'IENPAR | D FINDWAY ; Find way NMSP and PROT parameters passed . S DATA=$G(^TMP($J,"HLPARENT",+IENPAR)) QUIT:DATA'] | D SETMORE^HLUCM007 ; Additional var sets based on par . S VALPROT=$P(DATA,U,7),VALNMSP=$P(DATA,U,9) | D ERRCHK^HLUCM007 ; Check for errors... . F S1="C","X" F S2="C","X" F S3="C","X" S TOT(S1_S2 | KILL ^TMP(TOTALS,$J) ; Clear out storage location... . S ^TMP($J,"HLUCMSTORE","U",+IENPAR)=DATA | QUIT NOERR . S IEN772=0 | ; . F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) | SETDEF ; Set various defaults... . . S ^TMP($J,"HLUCMSTORE","X",+IEN772)=+IENPAR | I '$D(PNMSP) S PNMSP=1 . . S (OKPP,OKPP(1))=$$PP(+IEN772) | I '$D(IEN101) S IEN101=1 . . S OKPP=$S(OKPP=U:"X",1:"C") | I $G(TOTALS)']"" S TOTALS="HLTOTALS" . . S OK=$$COLLSYNC(+IEN772,START,END) ; Outside ti | S COND=$$UP^XLFSTR(COND) . . S SUB=$S(OK:"C",1:"X") | S COND=$S($G(COND)="BOTH":COND,1:"EITHER") ; Default . . S DATA=$P($G(^TMP($J,"HLCHILD",+IEN772)),"~",2, | QUIT . . ; If # seconds exceeds 1799... | ; . . S SUB=SUB_$S($P(DATA,U,3)>1799:"X",1:"C")_OKPP | FINDWAY ; How were NMSP and PROT passed? By reference? (If . . S:$P(DATA,U,7)']"" $P(DATA,U,7)=VALPROT | ; Passed by reference? . . S:$P(DATA,U,9)']"" $P(DATA,U,9)=VALNMSP | S NMSPTYPE=$S($G(PNMSP)']""&($O(PNMSP(""))]""):1,1:0) . . S ^TMP($J,"HLUCMSTORE","U",+IENPAR,+IEN772,SUB) | S PROTYPE=$S($G(IEN101)']""&($O(IEN101(""))]""):1,1:0 . . F I=1:1:3 S $P(TOT(SUB),U,I)=$P(TOT(SUB),U,I)+$ | QUIT . . S DATA=$G(^TMP($J,"HLPARENT",+IENPAR,+IEN772)) | ; . . S X=OKPP(1),$P(DATA,U,5)=$P(X,U),$P(DATA,U,6)=$ | LOOP() ; Loop thru 772's .01... (Called from LOOP^HLUCM) . . S ^TMP($J,"HLUCMSTORE","U",+IENPAR,+IEN772,SUB, | N CTDBG,IEN772,LOOPDT,RESULTS,TM772,X . < . ; Position #1 C=Count (Message BEGIN is not be < . ; X=Outside (Msg BEGIN is before STA < . ; #2 C=Count (#Seconds<1800) < . ; X=Greater (#Seconds>1799) < . ; #3 C=Count (Protocol/Namespace matc < . ; X=Mismatch (Protocol/Namespace mism < . F S1="C","X" F S2="C","X" F S3="C","X" S SUB=S1_S2 < . . QUIT:$TR(TOT(SUB),"0^","")']"" ;-> < . . S ^TMP($J,"HLUCMSTORE","U",+IENPAR,SUB)=TOT(SUB < . . < . . S TOT=$G(^TMP($J,"HLUCMSTORE","T",SUB)) < . . D UPTOT < . . S ^TMP($J,"HLUCMSTORE","T",SUB)=TOT < . . < . . S ^TMP($J,"HLUCMSTORE","T",SUB,IENPAR)=TOT(SUB) < . . < . . S TOT=$G(^TMP($J,"HLUCMSTORE","T")) < . . D UPTOT < . . S ^TMP($J,"HLUCMSTORE","T")=TOT < ; < KILL ^TMP($J,"HLCHILD"),^TMP($J,"HLPARENT") < ; < Q < ; < UPTOT ; Up the totals... < ; TOT,TOT(SUB) -- req < S $P(TOT,U)=$P(TOT,U)+$P(TOT(SUB),U) < S $P(TOT,U,2)=$P(TOT,U,2)+$P(TOT(SUB),U,2) < S $P(TOT,U,3)=$P(TOT,U,3)+$P(TOT(SUB),U,3) < Q < PP(IEN772) ; Get store value for NMSP and PROT... < N PCKG,PP,PROT,X < S PP=$$PROTNMSP^HLUCM002(+IEN772) < I $P(PP,U)']""!($P(PP,U,2)']"") QUIT U ;-> < S X=$P(PP,U),PROT=$S(X]"":X,1:"ZZZ") < S X=$P(PP,U,2),PCKG=$S(X]"":X,1:"ZZZ") < Q PROT_U_PCKG < ; < LOAD ; Load data (Called by $$CM, $$CM2, and all other API < ; START,END -- req < N IEN772,LOOPDT,X < . . QUIT:'$$OK772(+IEN772) ;-> | . . QUIT:$P($G(^HL(772,+IEN772,0)),U)'?7N.E ;-> . . S X=$$LOAD772S^HLUCM009(IEN772) | . . D COLLECT(IEN772) ; All 772 & 773 actions perfo Q | . . ; | . . ; trap debug data? TOTALCM ; Loop, total for $$CM... | . . D HLUCMSTR^HLUCM003 ; HLAPI -- req | ; N IEN772,IENPAR | S RESULTS=$G(^TMP(TOTALS,$J)) S IENPAR=0 < F S IENPAR=$O(^TMP($J,"HLUCMSTORE","U",IENPAR)) Q:'I < . ; Don't count anything unless the entire unit is O < . QUIT:$O(^TMP($J,"HLUCMSTORE","U",+IENPAR,"CCC"))]" < . S IEN772=0,HLUCMADD="" < . F S IEN772=$O(^TMP($J,"HLUCMSTORE","U",IENPAR,IEN < . . ;QUIT:'$D(^TMP($J,"HLUCMSTORE","U",+IENPAR,+IEN < . . D COLLECT(+IENPAR,+IEN772) < . . I HLAPI["CM2" S HLUCMADD="DON'T ADD. COLLECT3~ < Q < ; < COLLSYNC(IEN772,START,END) ; Does entry fall in START/EN < N DATA,X < S DATA=$G(^TMP($J,"HLCHILD",+IEN772)) QUIT:DATA']"" " < S X=$P($P(DATA,"~",2,999),U,4) Q:X'?7N.E!(X < I $P(D,U,2)']"",$P(D,U,3)']"",$P(D,U,4)']"",$P(D,U,5) < Q 1 < ; < COLLECT(PAR,IEN772) ; Collect 772 data and associated 773 < N CT,CTPCKG,DATA,DBGBL,IEN773,PP,TOT772,TOT772T,TYPEH < ; < ; ^("U",PARENT-IEN,CHILD-IEN,"CCC") < S DATA=$G(^TMP($J,"HLUCMSTORE","U",+PAR,+IEN772,"CCC" < S DATA("CHAR")=$P(DATA,U),DATA("DIFF")=$P(DATA,U,3) < S DATA("START")=$P(DATA,U,4),DATA("END")=$P(DATA,U,5) < S DATA("FAC")=$P(DATA,U,11) < ; < ; ^("U",PARENT-IEN,CHILD-IEN,"CCC",772) < S DATA=$G(^TMP($J,"HLUCMSTORE","U",+PAR,+IEN772,"CCC" < S DATA("HR")=$P(DATA,U),DATA("IO")=$P(DATA,U,2),DATA( < S (DATA("PROT"),PROT)=$P(DATA,U,5) < S (DATA("PCKG"),PCKG)=$P(DATA,U,6) < > ; Not debugging... > I $G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" D QUIT RESULT > . KILL ^TMP($J,"HLUCM") > ; > ; Debugging... > D PACKDGBL^HLUCM005(1) > KILL ^TMP($J,"HLUCM"),^TMP($J,"RECNM") > D HLUCMSHW^HLUCM003 > ; > QUIT RESULTS > ; > COLLECT(IEN772) ; Collect 772 data and associated 773 data... > N CT,CTPCKG,DBGBL,IEN773,PP,TOT772,TOT772T,TYPEHR,TYP > ; > KILL DATA > KILL ^TMP("HLUCMSTORE",$J) > ; > ; Get protocol and package namespace for storing in ^ > S PP=$$PROTNMSP^HLUCM002(+IEN772) > I $P(PP,U)']""!($P(PP,U,2)']"") QUIT ;-> > S (DATA("PROT"),PROT)=$P(PP,U),PROT=$S(PROT]"":PROT,1 > S (DATA("PCKG"),PCKG)=$P(PP,U,2),PCKG=$S(PCKG]"":PCKG > ; > ; Get variable used as sorting value in ^TMP(..."HR". > S TYPEHR=$$TYPETMO^HLUCM002(IEN772) > ; > ; Get variable used as I/O sorting value in ^TMP("... > S TYPEIO=$$TYPEIO^HLUCM002(IEN772) > ; > ; Get variable used as L/R sorting value in ^TMP("... > S TYPELR=$$TYPELR^HLUCM001(IEN772) > ; > ; Place 772 numbers in DATA(...) > S DBGBL=1 > D TOT772(IEN772) > ; > ; Loop thru all associated 773s and put #s in DATA(.. > S IEN773=0,CT=0 > F S IEN773=$O(^HLMA("B",IEN772,IEN773)) Q:IEN773'>0 > . S CT=CT+1 > . D TOT773(IEN773) > . I CT>1 S DATA("CHAR")=DATA("CHAR")+DATA("CHAR",772 > ; > ; Data OK? > S DATA("CHAR")=$G(DATA("CHAR")) > D TMDIFF > ; > ; Store ^TMP($J,"HLUCMSTORE") data... > I $G(^TMP($J,"HLUCM"))="DEBUG GLOBAL" D > . MERGE ^TMP($J,"HLUCMSTORE","E")=^TMP("HLUCMSTORE", > ; > KILL ^TMP("HLUCMSTORE",$J) > TOT772(IEN772) ; Total 772 message size and process time... > ; DATA() -- passed in (see COLLECT) > N TOT772,TOT773 > ; > D TOT772C(IEN772) ; total # characters... > D TOT772T(IEN772) ; total processing time... > ; > S TOT772=$G(DATA("CHAR")) > ; > QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;-> > QUIT:$G(DBGBL)'=1 ;-> Create global entries? > ; > S ^TMP("HLUCMSTORE",$J,"E",IEN772,772,"TM",TYPEHR)=$G > S ^TMP("HLUCMSTORE",$J,"E",IEN772,772,"IO",TYPEIO)=$G > S ^TMP("HLUCMSTORE",$J,"E",IEN772,772,"LR",TYPELR)=$G > S ^TMP("HLUCMSTORE",$J,"E",IEN772,772,"PR","PR")=$G(D > ; > QUIT > ; > TOT773(IEN773) ; Total # charactes and times... > ; DATA() -- passed in (See COLLECT) > N TOT773 > ; > D TOT773C(IEN773) ; Total characters... > D TOT773T(IEN773) ; Set times... > ; > QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;-> > QUIT:$G(DBGBL)'=1 ;-> Create global entries? > S ^TMP("HLUCMSTORE",$J,"E",IEN772,773,IEN773)=$G(TOT7 > ; > QUIT > ; . S NCH=NCH+$L($G(^HLMA(+IEN773,"MSH",+NO,0))) | . S NCH=NCH+$L(^HLMA(+IEN773,"MSH",+NO,0)) TMDIFF ; DATA("TIME",...) -- req --> DATA("DIFF") | KILLS(WHEN) ; Kills of ^TMP data WHEN (START or END or AL S (DATA("DIFF"),DATA("END"),DATA("START"))="" ; Defau | N DATA S DATA("START")=$O(DATA("TIME",0)) QUIT:DATA("START") < S DATA("END")=$O(DATA("TIME",":"),-1) < S DATA("DIFF")=$$SEC(DATA("END"))-$$SEC(DATA("START") < QUIT < ; < XTMP ; Store in ^XTMP... < ; API Parameters -- req < N XTMP < QUIT:PNMSP'=1!(IEN101'=1) ;-> Must be ALL,ALL | ; If ALL, set WHEN to include START and END... > S:WHEN="ALL" WHEN="STARTandEND" S XTMP="HLUCM "_$$DT^XLFDT | ; Always KILLs... S:'$D(^XTMP(XTMP,0)) ^XTMP(XTMP,0)=$$FMADD^XLFDT($$DT | F DATA="ACTUAL",$G(TOTALS)_"ERRTIME","N","RECNM","U", > . KILL ^TMP(DATA,$J),^TMP($J,DATA) > ; > ; START-only KILLs... > I WHEN["START" D > . F DATA="HLUCMSTORE",$G(TOTALS) D > . . QUIT:DATA']"" ;-> Sometimes TOTALS might not b > . . KILL ^TMP(DATA,$J),^TMP($J,DATA) > ; > ; END-only KILLs... > I WHEN["END" D > . F DATA="HLUCM","HLUCMDT" D > . . KILL ^TMP($J,DATA),^TMP(DATA,$J) S SVNO=$G(^XTMP(XTMP,"P",+START,+END,COND)) < I SVNO'>0 S SVNO=$O(^XTMP(XTMP,"N",":"),-1)+1 < S ^XTMP(XTMP,"P",+START,+END,COND)=SVNO_U_$$NOW^XLFDT < S ^XTMP(XTMP,"N",+SVNO)=START_U_END_U_COND_U_HLAPI < KILL ^XTMP(XTMP,"D",+SVNO) < MERGE ^XTMP(XTMP,"D",+SVNO)=^TMP(TOTALS,$J) | QUIT Q | TMDIFF ; DATA("TIME",...) -- req --> DATA("DIFF") > S DATA("START")=$O(DATA("TIME",0)) QUIT:DATA("START") > S DATA("END")=$O(DATA("TIME",":"),-1) > S DATA("DIFF")=$$SEC(DATA("END"))-$$SEC(DATA("START") > QUIT diff -y --suppress-common-lines ./VADemo/r1/HLUOPT1.m ./VADemo/r2/r/HLUOPT1.m HLUOPT1 ;AISC/SAW - Purging Entries in file #772 and #773 ;02 | HLUOPT1 ;AISC/SAW - Purging Entries in file #772 and #773 ;09 ;;1.6;HEALTH LEVEL SEVEN;**10,13,21,36,19,47,62,109,1 | ;;1.6;HEALTH LEVEL SEVEN;**10,13,21,36,19,47,62**;Oct ; < ; < ; HL*1.6*109 lock logic... < L +^HL("HLUOPT1"):2 I '$T D:'$D(ZTQUEUED) LOCKTELL^HL < L -^HL("HLUOPT1") ; Locked again at the top of DQ < ; < ; HL*1.6*109 < I '$D(ZTQUEUED) I $$BTE^HLCSMON("Press RETURN to "_$S < . I HLTASK W " no task started..." < . I 'HLTASK W " exiting..." < ; < ; < ; < D INIT^HLUOPT4 ; HL*1.6*109 | ; If no data are stored in file 869.3, fields 41, 42, Q | ; the default number for these fields is 7, 30, 90, r > N I,HLIEN,HLREC,HLDEF > S HLDEF="7^30^90" > S HLIEN=+$O(^HLCS(869.3,0)) > S HLREC=$S(HLIEN:$G(^HLCS(869.3,HLIEN,4)),1:"") > F I=1:1:3 I '$P(HLREC,U,I) S $P(HLREC,U,I)=$P(HLDEF,U > I $P(HLREC,U,2)<$P(HLREC,U,1)!($P(HLREC,U,3)<$P(HLREC > I $D(ZTQUEUED) D Q > . S HLPDT("COMP")=$$FMADD^XLFDT(DT,-$P(HLREC,U,1))_.9 > . S HLPDT("WAIT")=$$FMADD^XLFDT(DT,-$P(HLREC,U,2))_.9 > . S HLPDT("ALL")=$$FMADD^XLFDT(DT,-$P(HLREC,U,3))_.9 > . S HLPDT("ERR")=0 > ; get input data from user > N DIR,X,Y,DIRUT > ; input cutoff date for "Successfully Completed" mess > S DIR(0)="D^:"_$$FMADD^XLFDT(DT,-1)_":EX" > S DIR("A",1)=" Enter inclusive date up to which to p > S DIR("A")=" messages" > S DIR("B")="T"_-$P(HLREC,U,1) > S DIR("?",1)=" The suggested cutoff date to purge 'S > S DIR("?",2)=" is seven days prior to today." > S DIR("?")=" Must be on or before "_$$FMTE^XLFDT($$F > W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q > S HLPDT("COMP")=Y > K DIR > ; > ; input cutoff date for "Awaiting Acknowledgement" me > S DIR(0)="D^:"_HLPDT("COMP")_":EX" > S DIR("A",1)=" Enter inclusive date up to which to p > S DIR("A")=" messages" > S DIR("B")="T"_-$P(HLREC,U,2) > S DIR("?",1)=" The suggested cutoff date to purge 'A > S DIR("?",2)=" is thirty days prior to today." > S DIR("?")=" Must be on or before "_$$FMTE^XLFDT(HLP > W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q > S HLPDT("WAIT")=Y > K DIR > ; > ; Input for Vaporization Date > S DIR(0)="D^:"_HLPDT("WAIT")_":EX" > S DIR("A",1)=" Enter inclusive date up to which to p > S DIR("A")=" of status (except for ERROR status)" > S DIR("B")="T"_-$P(HLREC,U,3) > S DIR("?",1)=" The suggested cutoff date to purge al > S DIR("?",2)=" is 90 days prior to today." > S DIR("?")=" Must be on or before "_$$FMTE^XLFDT(HLP > W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q > S HLPDT("ALL")=Y+.9 > K DIR > ; > ; prompt whether to purge "Error" messages > S DIR(0)="Y" > S DIR("A")=" Do you also want to purge messages with > S DIR("B")="NO" > S DIR("?",1)=" Enter 'Yes' to purge entries whose st > S DIR("?",2)=" If you have reviewed/resolved the cau > W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q > K DIR > I 'Y S HLPDT("ERR")=0 > E D Q:HLEXIT > . ; input cutoff date for "Error" messages > . S DIR(0)="D^:"_HLPDT("WAIT")_":EX" > . S DIR("A",1)=" WARNING: You should have investig > . S DIR("A",2)=" these messages permanent > . S DIR("A",3)=" " > . S DIR("A",4)=" Enter inclusive date up to which > . S DIR("A")=" messages" > . S DIR("B")="T"_-$P(HLREC,U,3) > . S DIR("?",1)=" The suggested cutoff date to purge > . S DIR("?",2)=" is 90 days prior to today." > . S DIR("?")=" Must be on or before "_$$FMTE^XLFDT(H > . W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q > . S HLPDT("ERR")=Y+.9 > . K DIR > ; > ; prompt whether to run this purge in the background > S DIR(0)="YA" > S DIR("A")=" Would you like to queue this purge? " > S DIR("B")="YES" > S DIR("?")=" If run in the foreground, you will see > W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q > S HLTASK=Y > K DIR > W !," " > S HLPDT("COMP")=HLPDT("COMP")+.9,HLPDT("WAIT")=HLPDT( > Q I $D(ZTSK) W !," Task #",ZTSK," queued to run now... | I $D(ZTSK) W !," Purge task ",ZTSK," queued to run n W !," Queuing of Purge task failed.",! ; HL*1.6*109 | W !," Queueing of Purge task failed.",! N HLDELCNT,HLEXIT,HLOOPCT | N HLDELCNT,HLEXIT ; < S HLOOPCT=0 < ; < ; HL*1.6*109 < N XTMP D XTMPBEGN^HLUOPT4 < ; < ; Lock to ensures no other purge job can run... < L +^HL("HLUOPT1"):10 I '$T D QUIT ;-> < . D XTMPUPD^HLUOPT4(.XTMP,"NO-LOCK","DONE") < . I $D(ZTQUEUED) S ZTREQ="@" < ; < ; Purge 773s... < ; < ; Update piece 4 of file's zero node... < D UPDP4(773) < ; < ; Purge 772s... < ; < ; Update piece 4 of file's zero node... < D UPDP4(772) < ; < ; HL*1.6*109 < L -^HL("HLUOPT1") < ; < D XTMPUPD^HLUOPT4(.XTMP,"FINISHED","DONE") < ; | W !," ",HLDELCNT," entries purged.",! W !!," #",HLDELCNT," entries purged...",! ; HL*1.6*1 < ; < Q < ; < UPDP4(FNO) ; Update piece 4 of file's zero node... < N GBL,NODE,NODEL,P4 < S GBL=$S(+FNO=772:"^HL(772,0)",+FNO=773:"^HLMA(0)",1: < S NODEL=$G(XTMP(+FNO,"DEL")) QUIT:NODEL'>0 ;-> < L +@GBL:30 ; If don't get lock, update piece 4 anyway < S NODE=$G(@GBL) ; Get node... < S P4=$P(NODE,U,4)-NODEL,P4=$S(P4>0:+P4,1:"") ; Recalc < S $P(NODE,U,4)=P4 ; Reset node's piece 4... < S @GBL=NODE ; Store in file's zero node... < L -@GBL < ; < N FPDATE,HLIEN,HLPTR,HLMADT,HLY,HLMADT1,HLLT773 | N HLIEN,HLPTR,HLMADT,HLY,HLMADT1,HLLT773 ; | S HLLT773=$P(^HLMA(0),U,3) ; last ien for 773 ; HL*1.6*109 < I '$G(HLTASK) W !,"Looping through file 773..." < D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","START-773") < ; < ;calculate cuttoff date for records reserved by Fast < S FPDATE=$$FMADD^XLFDT(DT,-2) < ; < S HLLT773=$O(^HLMA(";"),-1) ; last ien for 773 < F S HLIEN=$O(^HLMA(HLIEN)) Q:'HLIEN D Q:HLEXIT Q: | F S HLIEN=$O(^HLMA(HLIEN)) Q:'HLIEN D Q:HLEXIT . S XTMP(773,"REV")=$G(XTMP(773,"REV"))+1,XTMP(773,"L < . ; < . ;check if the record is reserved for FAST PURGE < . I ($P($G(^HLMA(HLIEN,2)),"^",2)\1)>FPDATE Q < . ; < D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","END-773") ; HL*1.6 < ; < ; | N DIK,DA S X=$G(^HLMA(+HLIEN,0)),X=+$G(^HL(772,+X,0)),XTMP(773 | S DA=HLIEN,DIK="^HLMA(" ; | D ^DIK D DEL773^HLUOPT3(HLIEN) ; Purge w/direct kills... < ; < ; | I '$D(ZTQUEUED) W:'(HLDELCNT#5) "." S XTMP(773,"DEL")=$G(XTMP(773,"DEL"))+1,XTMP(773,"FAI < ; < ; < N FPDATE,HLOOP2,HLPTR,HLINK,HLIEN,HLMADT,HLY,HLLT772 | N HLOOP2,HLPTR,HLINK,HLIEN,HLMADT,HLY,HLLT772 ; | S HLLT772=$P(^HL(772,0),U,3) ; last ien for 772 ; HL*1.6*109 < I '$G(HLTASK) W !,"Looping through file 772..." < D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","START-772") < ; < ;calculate cuttoff date for records reserved by Fast < S FPDATE=$$FMADD^XLFDT(DT,-2) < ; < S HLLT772=$O(^HL(772,";"),-1) ; last ien for 772 < . S XTMP(772,"FAIL")=0 ; HL*1.6*109 < . F S HLPTR=$O(^HL(772,"B",HLPTR)) Q:HLPTR'>0 D Q: | . F S HLPTR=$O(^HL(772,"B",HLPTR)) Q:HLPTR'>0 D Q: . . . S XTMP(772,"REV")=$G(XTMP(772,"REV"))+1,XTMP(77 < ... ; < ... ;check if the record is reserved for FAST PURGE < ... I ($P($G(^HL(772,+HLIEN,2)),"^",2)\1)>FPDATE Q < ... ; < D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","END-772") ; HL*1.6 < ; < ; < ; < ; < ; | S DA=HLIEN,DIK="^HL(772," S XTMP(772,"LAST","TIME")=$S(+HLX?7N1"."1.N:+HLX,1:"" | D ^DIK ; < D DEL772^HLUOPT3(+HLIEN) < ; < S XTMP(772,"DEL")=$G(XTMP(772,"DEL"))+1,XTMP(772,"FAI | I '$D(ZTQUEUED) W:'(HLDELCNT#5) "." ; < ; < ; HL*1.6*109 modified from 60 to 120... | Q:$$HDIFF^XLFDT($H,$G(HLEXIT("LASTCHK")),2)<60 ; | I $$S^%ZTLOAD S HLEXIT=1 Q S HLOOPCT=HLOOPCT+1 < I '$D(ZTQUEUED) W:'(HLOOPCT#2000) "." < ; < S:$G(HLEXIT("LASTCHK"))']"" HLEXIT("LASTCHK")=$H < ; < Q:$$HDIFF^XLFDT($H,$G(HLEXIT("LASTCHK")),2)<120 < ; < ; HL*1.6*109 modified... < I $$S^%ZTLOAD D Q < . S HLEXIT=1 < . D XTMPUPD^HLUOPT4(.XTMP,"ABORTED-TASKMAN","CHK4STO < ; < ; < D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","CHK4STOP") ; HL*1. < ; < ; < FAIL(FILE) ; Has number entries w/o purging any been exc < QUIT $S($G(XTMP(FILE,"FAIL"))>200000:1,1:"") < ; < Only in ./VADemo/r1/: HLUOPT3.m Only in ./VADemo/r1/: HLUOPT4.m Only in ./VADemo/r1/: HLUOPT5.m Only in ./VADemo/r1/: HLUOPT6.m Only in ./VADemo/r1/: HLUOPTF1.m Only in ./VADemo/r1/: HLUOPTF2.m diff -y --suppress-common-lines ./VADemo/r1/HLUTIL3.m ./VADemo/r2/r/HLUTIL3.m HLUTIL3 ;ALB/MTC - VARIOUS HL7 UTILITIES ;11/19/2003 15:37 | HLUTIL3 ;ALB/MTC - VARIOUS HL7 UTILITIES - 2/1/95 ;06/16/98 ;;1.6;HEALTH LEVEL SEVEN;**2,41,109**;Oct 13, 1995 | ;;1.6;HEALTH LEVEL SEVEN;**2,41**;Oct 13, 1995 ; If HLFLG="I", institution number is | ; If HLFLG="I", institution number is . ;patch HL*1.6*109 | .S DIC=4,DIC(0)="MQZ",X=HLINST D ^DIC S HLINST=+Y . N X ;to protect the variable from calling routine < . S DIC=4,DIC(0)="MXZ",X=HLINST D ^DIC S HLINST=+Y < . ;patch HL*1.6*109 end < ;patch HL*1.6*109 start | I 'HLINST S DIC=4.2,DIC(0)="MQZ",X=HLINST D ^DIC S HL ;to protect the variable from calling routine < N X < I 'HLINST S DIC=4.2,DIC(0)="MXZ",X=HLINST D ^DIC S HL < ;patch HL*1.6*109 end < ; < Q ; patch HL*1.6*109: add "Q" to quit DOM < diff -y --suppress-common-lines ./VADemo/r1/HLUTIL.m ./VADemo/r2/r/HLUTIL.m ;;1.6;HEALTH LEVEL SEVEN;**36,19,57,64,66,109**;Oct 1 | ;;1.6;HEALTH LEVEL SEVEN;**36,19,57,64,66**;Oct 13, 1 N HLIEN,HLIEN0,HLSTAT,HLTCP,Y,LINK | N HLIEN,HLIEN0,HLSTAT,HLTCP,Y ; < ;**109** < S LINK=$P($G(^HLMA(HLIEN,0)),"^",7) < ; < .; < .;**109** < . D DEQUE^HLCSREP(LINK,"O",HLIEN) < .; < . D FILE^HLDIE("","HLJ","","MSGACT","HLUTIL") ; HL*1. | . D FILE^DIE("","HLJ") . ;**109** < .; S DA=HLIEN,DIK="^HLMA(",DIK(1)="7^AC" | . S DA=HLIEN,DIK="^HLMA(",DIK(1)="7^AC" .; D EN1^DIK | . D EN1^DIK .; < .;**109** < . D ENQUE^HLCSREP(LINK,"O",HLIEN) < Only in ./VADemo/r1/: IB20P210.m Only in ./VADemo/r1/: IB20P213.m Only in ./VADemo/r1/: IB20P229.m Only in ./VADemo/r1/: IB20P244.m Only in ./VADemo/r1/: IB20P247.m Only in ./VADemo/r1/: IB20P266.m Only in ./VADemo/r1/: IB20P297.m Only in ./VADemo/r1/: IB20R244.m Only in ./VADemo/r1/: IBACSV.m diff -y --suppress-common-lines ./VADemo/r1/IBACUS1.m ./VADemo/r2/r/IBACUS1.m IBACUS1 ;ALB/CPM - TRICARE PATIENT RX COPAY CHARGES ; 02-AUG- | IBACUS1 ;ALB/CPM - CHAMPUS PATIENT RX COPAY CHARGES ; 02-AUG- ;;2.0;INTEGRATED BILLING;**52,240**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94 BILL(IBKEY,IBCHTRN) ; Create the TRICARE Rx copay charge. | BILL(IBKEY,IBCHTRN) ; Create the CHAMPUS Rx copay charge. S IBATYP=$O(^IBE(350.1,"E","TRICARE RX COPAY",0)) | S IBATYP=$O(^IBE(350.1,"E","CHAMPUS RX COPAY",0)) S IBDESC="TRICARE RX COPAY",IBUNIT=1 | S IBDESC="CHAMPUS RX COPAY",IBUNIT=1 CANC(IBCHTRN) ; Cancel the TRICARE Rx copay charge. | CANC(IBCHTRN) ; Cancel the CHAMPUS Rx copay charge. diff -y --suppress-common-lines ./VADemo/r1/IBACUS2.m ./VADemo/r2/r/IBACUS2.m IBACUS2 ;ALB/CPM - TRICARE FISCAL INTERMEDIARY RX CLAIMS ;02- | IBACUS2 ;ALB/CPM - CHAMPUS FISCAL INTERMEDIARY RX CLAIMS ;02- ;;2.0;INTEGRATED BILLING;**52,91,51,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,91,51**;21-MAR-94 BILL(IBKEY,IBCHTRN) ; Create the TRICARE claim for the Fi | BILL(IBKEY,IBCHTRN) ; Create the CHAMPUS claim for the Fi S IB(.07)=$O(^DGCR(399.3,"B","TRICARE",0)) | S IB(.07)=$O(^DGCR(399.3,"B","CHAMPUS",0)) S IBCRES="TRICARE PRESCRIPTION REVERSED" | S IBCRES="CHAMPUS PRESCRIPTION REVERSED" BULL ; Generate a bulletin if there is an error in canceli | BULL ; Generate a bulletin if there is an error in cancell S IBT(1)="An error occurred while cancelling the Phar | S IBT(1)="An error occurred while cancelling the Phar diff -y --suppress-common-lines ./VADemo/r1/IBACUS.m ./VADemo/r2/r/IBACUS.m IBACUS ;ALB/CPM - TRICARE BILLING UTILITIES ; 02-AUG-96 | IBACUS ;ALB/CPM - CHAMPUS BILLING UTILITIES ; 02-AUG-96 ;;2.0;INTEGRATED BILLING;**52,240,274**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94 CUS(DFN,IBDT) ; Does the patient have TRICARE coverage? | CUS(DFN,IBDT) ; Does the patient have CHAMPUS coverage? ; Output: IBCOV -- 0, if the vet has no billable T | ; Output: IBCOV -- 0, if the vet has no billable C ; - find a billable TRICARE policy | ; - find a billable CHAMPUS policy TRI() ; Is the Tricare Billing engine up and running? | TRI() ; Is the CHAMPUS/Tricare Billing engine up and runnin CHPUS(DFN,DATE,IBRX,IBREF,IBLAB,IBRSITE,IBDUZ) ; Bill this p | CHPUS(DFN,DATE,IBRX,IBREF,IBLAB,IBRSITE,IBDUZ) ; Bill this p ; - make sure system is running and the patient has T | ; - make sure system is running and the patient has C ; TRICARE Rx Billing engine. The following two varia | ; CHAMPUS Rx Billing engine. The following two varia RXLAB ; Queued entry point to print the TRICARE Rx label. | RXLAB ; Queued entry point to print the CHAMPUS Rx label. RXBIL ; Queued entry point to create TRICARE Rx Billing cha | RXBIL ; Queued entry point to create CHAMPUS Rx Billing cha RXCAN ; Queued entry point to cancel TRICARE Rx Billing cha | RXCAN ; Queued entry point to cancel CHAMPUS Rx Billing cha N DIQUIET S DIQUIET=1 D DT^DICRW | S DIQUIET=1 D DT^DICRW diff -y --suppress-common-lines ./VADemo/r1/IBACVA2.m ./VADemo/r2/r/IBACVA2.m ;;2.0;INTEGRATED BILLING;**27,52,240**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**27,52**; 21-MAR ERRMSG(IBIND,IBMSG) ; Process CHAMPVA/TRICARE Error Messa | ERRMSG(IBIND,IBMSG) ; Process CHAMPVA/CHAMPUS Error Messa ; Input: IBIND -- 1=>billing 0=>canceling | ; Input: IBIND -- 1=>billing 0=>cancelling ; IBMSG -- 1=>CHAMPVA msg 2=> TRICARE ms | ; IBMSG -- 1=>CHAMPVA msg 2=> CHAMPUS ms S IBMSGT=$S($G(IBMSG)=1:"CHAMPVA inpatient subsistenc | S IBMSGT=$S($G(IBMSG)=1:"CHAMPVA inpatient subsistenc Only in ./VADemo/r1/: IBACV.m diff -y --suppress-common-lines ./VADemo/r1/IBAECC.m ./VADemo/r2/r/IBAECC.m ;;2.0;INTEGRATED BILLING;**176,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**176**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBAECP.m ./VADemo/r2/r/IBAECP.m ;;2.0;INTEGRATED BILLING;**171,176,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**171,176**;21-MAR-94 . N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuz < Only in ./VADemo/r1/: IBAHVE3.m diff -y --suppress-common-lines ./VADemo/r1/IBAMTC.m ./VADemo/r2/r/IBAMTC.m IBAMTC ;ALB/CPM-MEANS TEST NIGHTLY COMPILATION JOB ;09-OCT-9 | IBAMTC ;ALB/CPM-MEANS TEST NIGHTLY COMPILATION JOB ; 09-OCT- V ;;2.0;INTEGRATED BILLING;**34,52,70,93,100,118,115,13 | V ;;2.0;INTEGRATED BILLING;**34,52,70,93,100,118,115,13 D RELPR^IBAMTV3 ; auto-release patient charges on hol < ; < K IBDT D BJ^IBJDE ; Automated DM extract monthly bac | K IBDT D BJ^IBJDE ; Automated DM extract monthly back S (IBWARD,DFN)="" F S IBWARD=$O(^DPT("CN",IBWARD)) Q | S (IBWARD,DFN)="" F S IBWARD=$O(^DPT("CN",IBWARD)) Q ; < ;send inpatients' CV (CombatVet) expiration e-mail al < D CVEXMAIL^IBACV(DT) < ; < D IFCVEXP^IBACV(DFN,DT,IBA) ;if CV has expired (see C < D ORIG ; find "original" admission date | D ORIG ; find "original" admission date diff -y --suppress-common-lines ./VADemo/r1/IBAMTD.m ./VADemo/r2/r/IBAMTD.m V ;;2.0;INTEGRATED BILLING;**45,52,93,115,132,153,164,1 | V ;;2.0;INTEGRATED BILLING;**45,52,93,115,132,153,164,1 .N IBCLSF D CL^IBACV(DFN,IBADMDT,"",.IBCLSF) | .N IBCLSF D CL^SDCO21(DFN,IBADMDT,"",.IBCLSF) .I IBCLSF=7 D ADM^IBAMTI(DFN,IBA,IBCLSF) ;CV has the < Only in ./VADemo/r1/: IBAMTED2.m diff -y --suppress-common-lines ./VADemo/r1/IBAMTED.m ./VADemo/r2/r/IBAMTED.m IBAMTED ;ALB/CPM,GN - MEANS TEST EVENT DRIVER INTERFACE ; 6/1 | IBAMTED ;ALB/CPM - MEANS TEST EVENT DRIVER INTERFACE ; 21-FEB ;;2.0;INTEGRATED BILLING;**15,255,269**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**15**; 21-MAR-94 ;IB*2*269 add IVM converted RX Copay Test update call < ; < ; | D ^IBAMTED1 ;Z06 processing for RX Copay then Quit < I $D(EASZ06),DGMTYPT=2 D ^IBAMTED2 G END < ;Original Non-Z06 Copay processing < D:'$D(EASZ06) ^IBAMTED1 < ; < ; -- end medication copayment exemption processing < diff -y --suppress-common-lines ./VADemo/r1/IBAMTI1.m ./VADemo/r2/r/IBAMTI1.m ;;2.0;INTEGRATED BILLING;**52,132,156,199,234**;21-MA | ;;2.0;INTEGRATED BILLING;**52,132,156**;21-MAR-94 W !!,"This option is used to disposition case records | W !!,"This option is used to disposition case records W !,"HNC/CV) inpatient episodes of care which are not | W !,"inpatient episodes of care which are not to be b N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < W ?38,"Care related to ",$S(IBCL=1:"AO",IBCL=2:"IR",I | W ?38,"Care related to ",$S(IBCL=1:"AO",IBCL=2:"IR",I diff -y --suppress-common-lines ./VADemo/r1/IBAMTI.m ./VADemo/r2/r/IBAMTI.m ;;2.0;INTEGRATED BILLING;**52,132,153,156,234,247**;2 | ;;2.0;INTEGRATED BILLING;**52,132,153,156**;21-MAR-94 ; IBCL -- Patient class [1-ao|2-ir|3-sc| | ; IBCL -- Patient class [1-ao|2-ir|3-sc| ; IBCL -- Patient class [1-ao|2-ir|3-ec| | ; IBCL -- Patient class [1-ao|2-ir|3-ec| ;---CV < I IBCL=7,$G(IBEV)=2 D < . N Y,X,IBZ,IBFL,IBEXP,IBTODAY,IBDIS < . S (Y,X,IBZ,IBFL,IBEXP,IBTODAY,IBDIS)=0 < . D NOW^%DTC S IBTODAY=%\1 < . S IBZ=$$CVEDT^IBACV(DFN,IBTODAY) < . I +IBZ=1 Q ;patient is still CV < . S IBEXP=+$P(IBZ,"^",2)\1 < . S IBDIS=+$G(^DGPM(+$P($G(^DGPM(+$G(IBPM),0)),"^",17 < . ; if CV expired during inpatient stay < . I IBDIS>0,IBEXP'>IBDIS D < . . S IBFL=1 < . . S Y=IBEXP D DD^%DT S IBEXP=Y < . . S IBC=IBC+1,IBT(IBC)="" < . . S IBC=IBC+1,IBT(IBC)="WARNING: Patient's CV statu < . . S IBC=IBC+1,IBT(IBC)="inpatient stay. Billing nee < . ; if discharge move was entered after actual discha < . I IBFL=0 D < . . S Y=IBEXP D DD^%DT S IBEXP=Y < . . S IBC=IBC+1,IBT(IBC)="" < . . S IBC=IBC+1,IBT(IBC)="WARNING: Patient CV status < ;--- < ; IBCL -- Patient class [1-ao|2-ir|3-ec| | ; IBCL -- Patient class [1-ao|2-ir|3-ec| ; Input: X -- Patient class [1-ao|2-ir|3-ec| | ; Input: X -- Patient class [1-ao|2-ir|3-ec| Q $S('$G(X):"SPECIAL",1:$$PATTYPE^IBACV(X)) | Q $S('$G(X):"SPECIAL",X=1:"AGENT ORANGE",X=2:"IONIZIN ; Input: X -- Patient class [1-ao|2-ir|3-ec| | ; Input: X -- Patient class [1-ao|2-ir|3-ec| Q $S('$G(X):"Special",1:$$PATTYPE^IBACV(X,"M")) | Q $S('$G(X):"Special",X=1:"Agent Orange",X=2:"Ionizin ; < diff -y --suppress-common-lines ./VADemo/r1/IBAMTS1.m ./VADemo/r2/r/IBAMTS1.m ;;2.0;INTEGRATED BILLING;**20,52,132,153,166,156,167, | ;;2.0;INTEGRATED BILLING;**20,52,132,153,166,156,167* ; - quit if AO/IR/EC/MST/HNC/CV exposure is indicated | ; - quit if AO/IR/EC/MST/HNC exposure is indicated, o ; Output: indicators returned as ao^ir^sc^ec^mst^h | ; Output: indicators returned as ao^ir^sc^ec^mst^h diff -y --suppress-common-lines ./VADemo/r1/IBAMTS2.m ./VADemo/r2/r/IBAMTS2.m ;;2.0;INTEGRATED BILLING;**52,91,117,132,153,156,167, | ;;2.0;INTEGRATED BILLING;**52,91,117,132,153,156,167* I IBCLSF[1 Q ; care was related to ao/ir/ec/sc/mst/h | I IBCLSF[1 Q ; care was related to ao/ir/ec/sc/mst/h F I=1,2,3,4,5,6,7 I '$P(IBCLSF("BEFORE"),U,I),$P(IBCL | F I=1,2,3,4,5,6 I '$P(IBCLSF("BEFORE"),U,I),$P(IBCLSF F I=1,2,3,4,5,6,7 I $P(IBCLSF("BEFORE"),U,I),'$P(IBCL | F I=1,2,3,4,5,6 I $P(IBCLSF("BEFORE"),U,I),'$P(IBCLSF ; Output: ao^ir^sc^ec^mst^hnc^cv, where, for each | ; Output: ao^ir^sc^ec^mst^hnc, where, for each pie diff -y --suppress-common-lines ./VADemo/r1/IBAMTS.m ./VADemo/r2/r/IBAMTS.m ;;2.0;INTEGRATED BILLING;**52,115,132,153,164,156,171 | ;;2.0;INTEGRATED BILLING;**52,115,132,153,164,156,171 S IBT(1)="The following patient, who "_$S(IBX="SC":"h | S IBT(1)="The following patient, who "_$S(IBX="SC":"h S IBC=IBC+1,IBT(IBC)="was related to the "_$S(IBX="SC | S IBC=IBC+1,IBT(IBC)="was related to the "_$S(IBX="SC I $D(IBARR(3)) S Y="SC" G CLTYQ < I $D(IBARR(7)),+$$CVEDT^IBACV(DFN,IBDAT) S Y="CV" G C < > I $D(IBARR(3)) S Y="SC" G CLTYQ I $D(IBARR(6)) S Y="Head/Neck Cancer" G CLTYQ | I $D(IBARR(6)) S Y="Head/Neck Cancer" diff -y --suppress-common-lines ./VADemo/r1/IBAMTV3.m ./VADemo/r2/r/IBAMTV3.m ;;2.0;INTEGRATED BILLING;**15,153,183,215**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**15,153,183**;21-MAR-94 ; < RELPR ; Release charges on hold at least 60 days old. < K ^TMP($J,"IBHOLD") D NOW^%DTC S TDY=% < S IBN=0 F S IBN=$O(^IB("AC",21,IBN)) Q:'IBN D < .S DFN=+$P($G(^IB(IBN,0)),U,2),X2=+$P($G(^IB(IBN,1)), < .S X1=TDY D ^%DTC Q:X<60 S ^TMP($J,"IBHOLD",DFN,IBN) < ; < I '$D(^TMP($J,"IBHOLD")) G RELQ < S IBR60=1 D REL^IBOHRL ; Release c < S IBSTJB=$$DAT2^IBOUTL(TDY) D MAIL^IBOHRL ; Send bull < ; < RELQ K DFN,IBDUZ,IBEND,IBN,IBDIFROM,IBNOS,IBNUM,IBRCOUNT,I < K IBT,TDY,XMDUZ,XMGRP,XMSUB,XMTEXT,XMY,X,X1,X2,%,^TMP < Q < diff -y --suppress-common-lines ./VADemo/r1/IBARX1.m ./VADemo/r2/r/IBARX1.m IBARX1 ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFA | IBARX1 ;ALB/AAS - INTEGRATED BILING, PHARMACY COPAY INTERFAC ;;2.0;INTEGRATED BILLING;**34,101,150,158,156,234,247 | ;;2.0;INTEGRATED BILLING;**34,101,150,158,156**;21-MA ;if Combat Vet send alert e-mail to mailgroup "IB COM < D < . N Y D NOW^%DTC S Y=%\1 < . D RXALRT^IBACV(DFN,Y,+$P($P($G(IBSAVX(1)),"^",1),": < ; < diff -y --suppress-common-lines ./VADemo/r1/IBARXEI.m ./VADemo/r2/r/IBARXEI.m ;;2.0; INTEGRATED BILLING ;**34,199**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBARXEL1.m ./VADemo/r2/r/IBARXEL1.m IBARXEL1 ;ALB/CPM - RX COPAY EXEMPTION REMINDER REPRIN | IBARXEL1 ;ALB/CPM - RX COPAY EXEMPTION REMINDER REPRIN ;;2.0;INTEGRATED BILLING;**34,199,217**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < ; check for Cat C or Pending Adj. and has agreed to p < I $$BIL^DGMTUB(DFN,DT) W !!,"**Please note that this < ; < diff -y --suppress-common-lines ./VADemo/r1/IBARXEL.m ./VADemo/r2/r/IBARXEL.m IBARXEL ;ALB/CPM - RX COPAY EXEMPTION INCOME TEST REMINDERS ; | IBARXEL ;ALB/CPM - RX COPAY EXEMPTION INCOME TEST REMINDERS ; ;;2.0;INTEGRATED BILLING;**34,139,206,217**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**34,139**; 21-MAR-94 ..Q:$$BIL^DGMTUB(DFN,IBD) ; vet is cat c or pend. ad < ..S IBZIP=$P(VAPA($S($$CONFADD():18,1:11)),"^",2) S:I | ..S IBZIP=$P(VAPA(11),"^",2) S:IBZIP="" IBZIP="99999- ; < CONFADD() ; Determine, does the patient have a Confiden < ; Input: VAPA() local array (by ADD^VADPT) < I '$G(VAPA(12)) Q 0 ; The Conf Address is not active < I $P($G(VAPA(22,3)),U,3)'="Y" Q 0 ; The Conf Address < Q 1 < diff -y --suppress-common-lines ./VADemo/r1/IBARXEPL.m ./VADemo/r2/r/IBARXEPL.m ;;2.0;INTEGRATED BILLING;**34,54,190,206**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**34,54**; 21-MAR END I $D(ZTQUEUED) Q | ; D ^%ZISC,KVAR^VADPT | END Q:$D(ZTQUEUED) K C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IB | D ^%ZISC K IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX | D KVAR^VADPT K BY,DHD,DIOEND,FLDS,FR,I,L,TO,VAPA,^TMP("IBEX LIST", | K C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IB > K ^TMP("IBEX LIST",$J) N IBCONF ; Confidential Address Flag < W !?(IOM-28),$E($P(IBDATA,"^")),$P($P(IBDATA,"^",2)," | W !?(IOM-28),$P(IBDATA,"^",2) S IBCNT=IBCNT+1 S IBCNT=IBCNT+2 | W ! S IBCNT=IBCNT+1 S IBCONF=$$CONFADD^IBARXEL() ; Should we use Confiden | W !?TAB,VAPA(1) S IBCNT=IBCNT+1 W !?TAB,VAPA($S(IBCONF:13,1:1)) S IBCNT=IBCNT+1 | I VAPA(2)'="" W !?TAB,VAPA(2) I VAPA(3)'="" W ", ",VA I VAPA($S(IBCONF:14,1:2))'="" W !?TAB,VAPA($S(IBCONF: | W !?TAB,VAPA(4),", ",$P($G(^DIC(5,+VAPA(5),0)),"^",2) W !?TAB,VAPA($S(IBCONF:16,1:4)),", ",$P($G(^DIC(5,+VA < diff -y --suppress-common-lines ./VADemo/r1/IBARXEPV.m ./VADemo/r2/r/IBARXEPV.m IBARXEPV ;ALB/AAS - RX COPAY EXEMPTION VERIFY STATUS ; | IBARXEPV ;ALB/AAS - RX COPAY EXEMPTION VERIFY STATUS ; ;;2.0;INTEGRATED BILLING;**262**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 ; < N DGMT,CONV,CLN S (CLN,CONV)=0,DGMT=$$LST^DGMTU(DFN,+ < I $P(DGMT,U,5)=2 D G:CONV CHKQ ; skip Edb < .; Loop through the MT comments, Check for EDB conver < .; No comments to check < .Q:'$D(^DGMT(408.31,+DGMT,"C",1,0)) < .F S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CON < ..I ^DGMT(408.31,+DGMT,"C",CLN,0)["Z06 MT via Edb" S < ; < diff -y --suppress-common-lines ./VADemo/r1/IBARXEU1.m ./VADemo/r2/r/IBARXEU1.m IBARXEU1 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT | IBARXEU1 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT ;;2.0;INTEGRATED BILLING;**26,112,74,275**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**26,112,74**; 21-MAR-94 ; sc>50% ^ rec a&a ^ rec hb ^ rec pen ^ n/a ^ non-vet | ; := sc>50% ^ rec a&a ^ rec hb ^ rec pen ^ n/a ; 1 1 1 1 1 | ; 1 1 1 1 > ; I IBEXMT[1 F I=1,2,3,4,6,8,9 I $P(IBEXMT,"^",I)=1 S I | I IBEXMT[1 F I=1,2,3,4,6 I $P(IBEXMT,"^",I)=1 S IBEXR diff -y --suppress-common-lines ./VADemo/r1/IBARXEU.m ./VADemo/r2/r/IBARXEU.m IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ;2-NOV-92 | IBARXEU ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE ; 2-NOV-92 ;;2.0;INTEGRATED BILLING;**20,222**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**20**; 21-MAR-94 N X,Y,Z,IBX,IBON | N X,Y,IBX,IBON S X=$G(^IBA(354,DFN,0)) | S X=$G(^IBA(354,DFN,0)) I X=""!('$D(^IBA(354.1,"AP",D I X=""!('$D(^IBA(354.1,"AP",DFN))) S IBX="-1^UNKNOWN^ < I IBDT'<$P(X,U,3),IBDT'>$$PLUS^IBARXEU0($P(X,U,3)) S | I IBDT'<$P(X,"^",3),IBDT'>$$PLUS^IBARXEU0($P(X,U,3)) I IBDT'<$P(X,U,3),IBDT>$$PLUS^IBARXEU0($P(X,U,3)) D | I IBDT'<$P(X,"^",3),IBDT>$$PLUS^IBARXEU0($P(X,U,3)) D .; -- see if patient was SC>50, can't be updated so d | .; - see if patient was SC>50, can't be updated so d .I $L($$ACODE^IBARXEU0(Y))<3 S IBX=+$P(X,U,4)_U_$$TEX | .I $L($$ACODE^IBARXEU0(Y))<3 S IBX=+$P(X,"^",4)_"^"_$ .S IBX=+$P(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($P( | .S IBX=+$P(X,"^",4)_"^"_"Previously "_$$TEXT^IBARXEU0 I IBDT<$P(X,U,3) D G RXSTQ | I IBDT<$P(X,"^",3) D G RXSTQ .S Z=$G(^IBA(354,DFN,0)),Z=$P(Z,U,5)_U_$P(Z,U,3) ; ge | .; --if old exemption is current for copay date .; < .; -- if old exemption is current for copay date < ..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ; exemption reason | ..S X=$G(^IBE(354.2,+$P(Y,"^",5),0)) ; exemption reas ..S IBX=+$P(X,U,4)_U_$$TEXT^IBARXEU0($P(X,U,4))_U_$$A | ..S IBX=+$P(X,"^",4)_"^"_$$TEXT^IBARXEU0($P(X,"^",4)) ..S X=$G(^IBE(354.2,+$P(Y,U,5),0)) ;exemption reason | ..S X=$G(^IBE(354.2,+$P(Y,"^",5),0)) ;exemption reaso ..I $L($$ACODE^IBARXEU0(Y))<3 S IBX=+$P(X,U,4)_U_$$TE | ..I $L($$ACODE^IBARXEU0(Y))<3 S IBX=+$P(X,"^",4)_"^"_ ..S IBX=+$P(X,U,4)_U_"Previously "_$$TEXT^IBARXEU0($P | ..S IBX=+$P(X,"^",4)_"^"_"Previously "_$$TEXT^IBARXEU W !,"Medication Copayment Exemption Status: ",$P(X,U, | W !,"Medication Copayment Exemption Status: ",$P(X,"^ W !,$P(X,U,4) G:NO<3 DISPQ | W !,$P(X,"^",4) G:NO<3 DISPQ I $P(X,U,5) W !,"Last test date: " S Y=$P(X,U,5) D DT | I $P(X,"^",5) W !,"Test date: " S Y=$P(X,"^",5) D DT^ STDATE() ; -- legislative start date for income exempt | STDATE() ; -- legislative start date for income exemp S IBY=$O(^IBA(354.1,"AIVDT",+$P(IBX,U,3),+$P(IBX,U,2) | S IBY=$O(^IBA(354.1,"AIVDT",+$P(IBX,"^",3),+$P(IBX,"^ diff -y --suppress-common-lines ./VADemo/r1/IBARXEX.m ./VADemo/r2/r/IBARXEX.m ;;2.0; INTEGRATED BILLING ;**199**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBARX.m ./VADemo/r2/r/IBARX.m ;;2.0;INTEGRATED BILLING;**101,150,156,168,186,237**; | ;;2.0;INTEGRATED BILLING;**101,150,156,168,186**;21-M ; -- check rx exemption in case refill is exempt | ; -- check rx exemption incase refill is exempt C1 K Y,IBSAVX N I,J,X1,X2,DA,DFN I '$G(IBUPDATE) N IBCAP | C1 K Y,IBSAVX N I,J,X1,X2,DA,DFN I '$G(IBUPDATE) N IBCAP M IBSAVXMC=Y < ; now that I have cancelled lets see if there are som | ; now that I have cancelled lets see if there is some I '$G(IBUPDATE),$D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCA | I '$G(IBUPDATE),$D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCA U1 K Y,IBSAVX N I,J,X1,X2,DA,DFN,IBEXMP,IBUPDATE,IBCAP,I | U1 K Y,IBSAVX N I,J,X1,X2,DA,DFN,IBEXMP,IBUPDATE,IBCAP,I ; -- check rx exemption in case refill is exempt | ; -- check rx exemption incase refill is exempt ; now that I have the update done lets see if there a | ; now that I have the update done lets see if there i I $D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCAP,.IBSAVXMC) | I $D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCAP) diff -y --suppress-common-lines ./VADemo/r1/IBARXMC.m ./VADemo/r2/r/IBARXMC.m IBARXMC ;LL/ELZ-PHARMACY COPAY CAP FUNCTIONS ;26-APR-2001 | IBARXMC ;LL/ELZ-PHARMCAY COPAY CAP FUNCTIONS ;26-APR-2001 ;;2.0;INTEGRATED BILLING;**156,186,237**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**156,186**;21-MAR-94 NET(X) ; returns net amount billed for a parent and its chil | NET(X) ; returns net amount billed for a parent and it's chi CANCEL(DFN,IBDT) ; receives notification of a cancella | CANCEL(DFN,IBDT) ; receives notification of a cancella ; if more need to be billed. IBDT should be in fm fo | ; if more needs to be billed. IBDT should be in fm f .. ; check, am I the parent and still have some unbil | .. ; check, am i the parent and still have some unbil QCAN(DFN,IBCAP,IBSAVXMC) ; queue off job to look for b | QCAN(DFN,IBCAP) ; queue off job to look for back billing in t S (ZTSAVE("DFN"),ZTSAVE("IBCAP("),ZTSAVE("IBSAVXMC(") | S (ZTSAVE("DFN"),ZTSAVE("IBCAP("),ZTIO)="" D ^%ZTLOAD N IBD,IBL,IBPAT,IBREF,IBSSN,IBTAG,Y | N IBD,IBL,IBTAG,Y I 'IBL D Q | I 'IBL S IBTAG=3,Y="^^Unable to lock for back billing .S IBTAG=3 < .S IBPAT=$P($G(^DPT(DFN,0)),"^",1) I IBPAT="" S IBPAT < .S IBSSN=$P($G(^DPT(DFN,0)),"^",9) I IBSSN="" S IBSSN < .S (X,IBREF)="" < .F S X=$O(IBSAVXMC(X)) Q:X="" D < ..I IBREF'="" S IBREF=IBREF_", "_$P(IBSAVXMC(X),"^",1 < ..I IBREF="" S IBREF=$P(IBSAVXMC(X),"^",1) < .S Y="^^Unable to lock the IB PATIENT COPAY ACCOUNT ( < .D ^IBAERR Q < Only in ./VADemo/r1/: IBARXMO1.m diff -y --suppress-common-lines ./VADemo/r1/IBARXMO.m ./VADemo/r2/r/IBARXMO.m IBARXMO ;LL/ELZ - PHARMACY COPAY CAP REPORTS ;21-JAN-2001 | IBARXMO ;LL/ELZ - PHARMCAY COPAY CAP REPORTS ;21-JAN-2001 ;;2.0;INTEGRATED BILLING;**156,261**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**156**;21-MAR-94 . W !,IBNAM,?37,$J($FN(+IBDATA,",",2),12),?53,$S($P(I | . W !,IBNAM,?37,$J($FN(+IBDATA,","),12,2),?53,$S($P(I W !!,?12,"Patient Count At Cap: ",$J($FN(IBAT,",",0), | W !!,?12,"Patient Count At Cap: ",$J($FN(IBAT,","),12 W !,?9,"Patient Count Above Cap: ",$J($FN(IBAB,",",0) | W !,?9,"Patient Count Above Cap: ",$J($FN(IBAB,","),1 W !,?18,"Total Unbilled: ",?37,$J($FN(IBTOT,",",2),12 | W !,?18,"Total Unbilled: ",?37,$J($FN(IBTOT,","),12,2 . W !,$E(VADM(1),1,25)_" ("_VA("BID")_")",?32,$P($P(I | . W !,$E(VADM(1),1,25)_" ("_VA("BID")_")",?32,$P($P(I diff -y --suppress-common-lines ./VADemo/r1/IBARXMQ.m ./VADemo/r2/r/IBARXMQ.m ;;2.0;INTEGRATED BILLING;**150,156,186,199**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**150,156,186**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBATEI.m ./VADemo/r2/r/IBATEI.m ;;2.0;INTEGRATED BILLING;**115,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94 N X,IBBEDPTR,IBLOS,IBDATE,CALCDATE,DRGHIGH,IBBEDRT,IB | N X,IBBEDPTR,IBLOS,CALCDATE,DRGHIGH,IBBEDRT,IBDIFF,IB S IBDATE=$P($P($G(^DGPM(+Y,0)),U),".") ; Date of pati < . S CALCDATE=IBDATE | . S CALCDATE=$P($P($G(^DGPM(+Y,0)),U),".") . ; do look up calculate drg value | . ; do look up calculate drg value . S DRGHIGH=$P($$DRG^IBACSV(+V,IBDATE),U,4) | . S DRGHIGH=$P($G(^ICD(+V,0)),U,4) diff -y --suppress-common-lines ./VADemo/r1/IBATLM1B.m ./VADemo/r2/r/IBATLM1B.m ;;2.0;INTEGRATED BILLING;**115,261**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94 .. W ?65,$J($FN($P(IBDAT,"^",5)*$P(IBDAT,"^",6),",",2 | .. W ?65,$J($FN($P(IBDAT,"^",5)*$P(IBDAT,"^",6),","), . W ?65,$J($FN($P(IBDATA,"^",16),",",2),12) | . W ?65,$J($FN($P(IBDATA,"^",16),","),12,2) diff -y --suppress-common-lines ./VADemo/r1/IBATLM2A.m ./VADemo/r2/r/IBATLM2A.m ;;2.0;INTEGRATED BILLING;**115,210,266**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94 > ; N IBX,IBDXLIST,IBSCE,IBPROV,IBDATE | N IBX,IBDXLIST,IBSCE,IBPROV S IBDATE=$P($G(IBDATA(0)),U,4) ; Event date | D DX(.IBDXLIST) D DX(.IBDXLIST,IBDATE) < . S IBX(1)=$$PROC^IBATUTL($P(IBX(0),U),IBDATE) | . S IBX(1)=$$PROC^IBATUTL($P(IBX(0),"^")) DX(IBDX,IBDATE) ; -- diagnosis info | DX(IBDX) ; -- diagnosis info . S IBX(0)=$$ICD9^IBACSV(+IBDX(IBX),$G(IBDATE)) | . S IBX(0)=^ICD9(+IBDX(IBX),0) ; dbia 10082 diff -y --suppress-common-lines ./VADemo/r1/IBATLM2B.m ./VADemo/r2/r/IBATLM2B.m ;;2.0;INTEGRATED BILLING;**115,266**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94 N DA,DIE,DR,DTOUT,ICDVDT,ICPTVDT | N DA,DIE,DR,DTOUT S (ICDVDT,ICPTVDT)=$P(IBDATA(0),U,4) ; Code Text Vers | S DR=$S($P(IBDATA(0),"^",12)["DGPM":"1.01;D DRGDSP^IB S DR=$S($P(IBDATA(0),U,12)["DGPM":"1.01;D DRGDSP^IBAT < diff -y --suppress-common-lines ./VADemo/r1/IBATO1.m ./VADemo/r2/r/IBATO1.m ;;2.0;INTEGRATED BILLING;**115,266**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94 . S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)) | . S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)) N IBX,IBB,IBDATE S IBB="UNIT DESCRIPTION" | N IBX,IBB S IBB="UNIT DESCRIPTION" . S IBD(1,IBO,IBB)=$E($$DRGTD^IBACSV(+IBA(1),$P(IBA(0 | . S IBD(1,IBO,IBB)=$E($G(^ICD(+IBA(1),1,1,0)),1,18) S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Da < . S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0),IBD | . S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0)),"^ diff -y --suppress-common-lines ./VADemo/r1/IBATUTL.m ./VADemo/r2/r/IBATUTL.m ;;2.0;INTEGRATED BILLING;**115,266**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94 PROC(X,IBDATE) ; -- returns CPT and descriptive name for cpt | PROC(X) ; -- returns ICD or CPT and descriptive name for cpts S X=$$CPT^ICPTCOD(X,$G(IBDATE)) | S X=$$CPT^ICPTCOD(X) Only in ./VADemo/r1/: IBBAPI.m Only in ./VADemo/r1/: IBBDOC.m Only in ./VADemo/r1/: IBBFAPI.m diff -y --suppress-common-lines ./VADemo/r1/IBCB1.m ./VADemo/r2/r/IBCB1.m ;;2.0;INTEGRATED BILLING;**70,106,51,137,161,182,155* | ;;2.0;INTEGRATED BILLING;**70,106,51,137,161**;21-MAR I '$$IICM^IBCB2(IBIFN) G END ; Ingenix ClaimsManager | ; Send the bill to ClaimsManager when IBAC=1 I '$$IIQMED^IBCB2(IBIFN) G END ; DSS QuadraMed Claims | ; We will stay in this routine if the IBCISTAT variab > ; 3 - Passed CM with no errors > ; 5 - User overriding the CM errors > ; 7 - the CM interface isn't working > ; 11 - User overriding the CM errors (CM not u > ; > I $$CM^IBCIUT1(IBIFN) S IBCISNT=1 D ST2^IBCIST I '$F( I $G(IBAC)'=1,'$$IICM^IBCB2(IBIFN) G END ; Ingenix Cl | ; Send the bill to ClaimsManager when IBAC'=1 I $G(IBAC)'=1,'$$IIQMED^IBCB2(IBIFN) G END ; DSS Quad | ; We will stay in this routine if the IBCISTAT variab > ; 3 - Passed CM with no errors > ; 5 - User overriding the CM errors > ; 7 - the CM interface isn't working > ; 11 - User overriding the CM errors (CM not u > ; > I $$CM^IBCIUT1(IBIFN),$G(IBAC)'=1 S IBCISNT=1 D ST2^I . N DIR,Y,X,IBINS,NXTINS | . N DIR,Y,X,IBINS . S NXTINS=+$$POLICY^IBCEF(IBIFN,1,$$COBN^IBCEF(IBIFN | . S IBINS=$P($G(^DIC(36,+$$POLICY^IBCEF(IBIFN,1,$$COB . S IBINS=$P($G(^DIC(36,NXTINS,0)),U) ; name of nex | . Q:$$MCRWNR^IBEFUNC(+IBINS) . Q:$$MCRWNR^IBEFUNC(NXTINS) ; quit if its | . S DIR(0)="YA",DIR("B")="YES",DIR("A",1)="" . ; | . S DIR("A",2)="THIS BILL HAS PRIOR INSURANCE OF MEDI . S DIR(0)="YO",DIR("B")="YES",DIR("A",1)=" " | . S DIR("?",1)="If you answer NO, the bill will not b . S DIR("A",2)="This bill has prior insurance of MEDI | . S DIR("?")="If you answer YES, this bill will autom .. S DIR("A",3)="Ins Co, "_IBINS_", does not want/nee | .. S DIR(2)="THE INSURANCE CO: ",DIR("A",3)=IBINS_" D .. S DIR("A",3)="the site parameter for MRA Requests | .. S DIR("A",2)="THE SITE PARAMETER",DIR("A",3)="FOR . S DIR("A")="Do you want this bill to go directly to | . S DIR("A")="DO YOU WANT THIS BILL TO GO DIRECTLY TO . S DIR("?",1)="If you answer NO, the bill will not b | . I Y'=1 S IBEND=1 W !,"Can't continue",! Q . S DIR("?")="If you answer YES, this bill will autom < . D ^DIR K DIR < . I 'Y S IBEND=1 W !,"Can't continue",! Q < . Q < ; Update the review status for all EOB's on file < D STAT^IBCEMU2(IBIFN,3) ; Accepted - Complete EOB < ; < .W:+IBTXSTAT=2 "test " W "bill to BILL TRANSMISSION F | .W:+IBTXSTAT=2 "test" W " bill to BILL TRANSMISSION F ; | S IBRESUB=$$RESUB^IBCECSA4($S($G(IBCNCOPY):$P($G(^DGC ; Check to see if any unreviewed status messages or E | I IBRESUB>0 D ; what to do about them | . N IBDA,IB N IBTXBARR | . S IB=+$S('$G(IBCNCOPY):IBIFN,1:$P($G(^DGCR(399,IBIF S IBRESUB=$$RESUB^IBCECSA4($S($G(IBCNCOPY):$P($G(^DGC | . S IBDA=+$$LAST364^IBCEF4(IB) I IBRESUB=2 D ; update review statuses to be | . I IBDA D UPDEDI^IBCEM(IBDA,$S($G(IBCNCOPY):"R",1:"E . N IBDA S IBDA=0 < . F S IBDA=$O(IBTXBARR(IBDA)) Q:'IBDA D UPDEDI^IBCE < . Q < ; < ; | I 'IBPNT D:$D(IBTXPRT) TXPRTS D EN1^IBCF D:$D(IBTXPRT ; Bill has never been printed. First time print. < I 'IBPNT D G END < . I $D(IBTXPRT) D TXPRTS < . D EN1^IBCF < . I $D(IBTXPRT) D TXPRT < . D MRA^IBCEMU1(IBIFN) ; Printing the MRA < . I +$G(IBAC)=1 D END,CTCOPY^IBCCCB(IBIFN) < . Q < ; < ; Below section is for re-prints < D MRA^IBCEMU1(IBIFN) ; Printing the MRA < ; < K IBRESUB,IBOPV1,IBOPV2,IBCHG,DGBIL1,DGU,DDH,IBA1,IBI | K IBOPV1,IBOPV2,IBCHG,DGBIL1,DGU,DDH,IBA1,IBINS,IBPRO . N XMSUB,XMY,XMTEXT,XMDUZ,IBT | . N XMSUB,XMY,XMTEXT,XMDUZ diff -y --suppress-common-lines ./VADemo/r1/IBCB2.m ./VADemo/r2/r/IBCB2.m ;;2.0;INTEGRATED BILLING;**52,51,161,182,155**;21-MAR | ;;2.0;INTEGRATED BILLING;**52,51,161**;21-MAR-94 ;IBREEDIT = Flag to indicate Bill has been re-edited < I $G(IBREEDIT)=1,'IBV S IBREEDIT=2 ; set flag indic < N IBREEDIT < ED1 ; < ; | D:'$D(IBVIEW) VIEW ; If claim re-edit, then call the IB edit checks agai < I '$D(IBVIEW) S IBREEDIT=1 D VIEW I $G(IBREEDIT)=2 K < IICM(IBIFN) ; Ingenix ClaimsManager: Claim Scrubber < ; Send the bill to ClaimsManager, the IBCISTAT variab < ; 3 - Passed CM with no errors < ; 5 - User overriding the CM errors < ; 7 - the CM interface isn't working < ; 11 - User overriding the CM errors (CM not u < ; < ; Returns False (0) if the bill fails the ClaimsManag < ; Returns True (1) if the bill passed the ClaimsManag < ; < N IBOK S IBOK=1 < I +$G(IBIFN),$$CM^IBCIUT1(IBIFN) S IBCISNT=1 D ST2^IB < Q IBOK < ; < IIQMED(IBIFN) ; DSS QuadraMed Interface: QuadraMed Claim Sc < ; Send the bill to the QuadraMed Claim Scrubber < ; Returns False (0) if the bill fails the QuadraMed S < ; Returns True (1) if the bill passed the QuadraMed S < ; < ; QuadraMed Scrubber EN^VEJDIBSC returns IBQMED = 1 i < ; < N IBQMED S IBQMED=1 < I +$G(IBIFN),$$QMED^IBCU1("EN^VEJDIBSC",IBIFN) D EN^V < Q IBQMED < diff -y --suppress-common-lines ./VADemo/r1/IBCBB1.m ./VADemo/r2/r/IBCBB1.m ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148 | ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148 N Z,Z0,Z1 < ; if inpat - from date must not be prior to admit dat | ; if inpat then from date must not be prior to the ad I IBTDT>DT!(IBTDTDT!(IBTDT ;I IBFY=""!($L(IBFY)'=2)!(IBFY'=IBFFY) S IBER=IBER_"I > ; > ;FY 1 Charges > ;I +IBFYC'>0!(+IBFYC'=IBFYC) S IBER=IBER_"IB051;" > ; > ;FY 1 Charges minus offset greater than 0 > ;I +IBFYC-$P(IBNDU1,"^",2)'>0 S IBER=IBER_"IB052;" ; If ins bill, must have valid COB sequence < I $P(IBND0,U,11)="i",$S($P(IBND0,U,21)="":1,1:"PST"'[ < ; Check for valid sec provider id for current ins | ; Rendering provider id is required for HCFA 1500 for S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z S Z0= | I $$FT^IBCEF(IBIFN)=2,'$$CKPROV^IBCEU(IBIFN,3) S IBER . I '$$SECIDCK^IBCEF74(IBIFN,Z1,$P(Z0,U,11+Z1),Z) D W < ; < N IBCOBN,IBZ < S IBCOBN=+$$COBN^IBCEF(IBIFN),Z=$$GETTYP^IBCEP2A(IBIF < I Z,$P(Z,U,2) D ; Rendering/attending prov secondary < . ; for current insurance < . N Q,Q0,IBID,IBOK < . S IBOK=0 < . D PROVINF^IBCEF74(IBIFN,IBCOBN,.IBID,IBCOBN,"C") < . S Q0=0,Q=$S($$FT^IBCEF(IBIFN)=3:4,1:3) F S Q0=$O(I < . I 'IBOK S IBER=IBER_"IB303;" < I $$TXMT^IBCEF4(IBIFN) D < . D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN < . I $P(IBZ,U,3)=""&($P(IBZ,U,4)="") S IBER=IBER_"IB32 < . ; < N IBZPRC,IBZPRC92 | N IBZPRC ; Procedure Clinic is required for Surgical Procedure | ; Procedure Clinic is required for Surgical Procedure ; < . K IBZ < ; Check that COB sequences are not skipped < K Z < F Z=1:1:3 S:+$G(^DGCR(399,IBIFN,"I"_Z)) Z(Z)="" < F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0 I Z0'=(Z+1) S IBER=IBE < K Z < I $P($G(^DGCR(399,IBIFN,0)),U,21)="" S IBER=IBER_"IB3 < ;Other things that could be added: Rev Code - calcul | ;Other things that could be added: Revenue Code - ca I $P(IBNDTX,U,8),$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_ | I $P(IBNDTX,U,8) D WARN^IBCBB11("Bill has been forced I $P(IBNDTX,U,8)!$P(IBNDTX,U,9) D WARN^IBCBB11($S($$R < N IBNDI1 < ; Check that this is a secondary or tertiary bill and | ;I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1) D ; COB sequence is Medicare WNR and MRA is active --> | ;. N Z,Z0,Z1,Z2 I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1),$$EDIACT | ;. ; This is a secondary or tertiary bill and insuran > ;. ; COB sequence is MCR WNR > ;. S Z=0 F S Z=$O(^IBM(361.1,"B",IBIFN,Z)) Q:'Z S Z > ;.. S PRCASV("MEDCA")=$P(Z2,U,4)-$P(Z2,U,3),PRCASV("M MRA N IBEOB S IBEOB=0 < ; < K PRCASV("MEDURE"),PRCASV("MEDCA") < ; Get EOB data < F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB < . D MRACALC^IBCEMU2(IBEOB,IBIFN,1,.PRCASV) < Q ;MRA < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCBB21.m ./VADemo/r2/r/IBCBB21.m ;;2.0;INTEGRATED BILLING;**51,137,210,232,155,291**;2 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N ECODE,IBTXMT,IBXDATA,IBLPRT,IBI,Z,Z0,Z1,IBREQMRA | N ECODE,IBTXMT,IBXDATA,IBLPRT,IBI,Z,Z0,Z1 I '$D(IBZPRC92) D ALLPROC^IBCVA1(IBIFN,.IBZPRC92) | S IBQUIT=0 S IBREQMRA=$$REQMRA^IBEFUNC(IBIFN) ; MRA? < K IBQUIT S IBQUIT=0 < S IBTXMT=$$TXMT^IBCEF4(IBIFN) | S IBTXMT=$$TXMT^IBCEF4(IBIFN),IBLPRT=$P(IBNDTX,U,8) ; More than 50 procedures on a bill - must print loca | ; More than 6 procedures on a bill - must print local I IBTXMT,(+IBZPRC92>50!(+$P(IBZPRC92,U,2)>50)) D Q:I | I IBTXMT,IBLPRT'=1,(+IBZPRC92>6!(+IBZPRC92>6)) S IBQU . I 'IBREQMRA S IBQUIT=$$IBER^IBCBB3(.IBER,308) Q | ; Rx's on a UB92 bill must be printed locally . I '$P(IBNDTX,U,9) S IBQUIT=$$IBER^IBCBB3(.IBER,325) | I IBTXMT,$$ISRX^IBCEF1(IBIFN),IBLPRT'=1 S IBER=IBER_" I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'= | I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'= ; < . I $E($$ICD9^IBACSV(+$P(IBXDATA(Z),U)))="E" S:ECODE | . I $E($P($G(^ICD9(+$P(IBXDATA(Z),U),0)),U))="E" S:EC . ; max DX check does not apply to MRAs | . I IBTXMT,IBLPRT'=1,IBI>9 S IBER=IBER_"IB309;" . I IBTXMT,IBI>9 D < .. I 'IBREQMRA Q:$P(IBNDTX,U,8) S IBER=IBER_"IB309;" < .. I '$P(IBNDTX,U,9) S IBER=IBER_"IB326;" < I 'IBI S IBER=IBER_"IB071;" ;Require Diag code NOIS | I IBI,$$INPAT^IBCEF(IBIFN,1),$E($P($G(^ICD9(+$P(IBXDA I IBI,$$INPAT^IBCEF(IBIFN,1),$E($$ICD9^IBACSV(+$P(IBX < I IBTXMT D < . ; Force UB92 to print local if SSN ID required and < . ; printed at clearinghouse < . N IBZ < . I 'IBREQMRA Q:$S('$P($G(^DIC(36,+$$CURR^IBCEF2(IBIF < . I IBREQMRA Q:$S('$P($G(^DIC(36,+$P($G(^DGCR(399,IBI < . D F^IBCEF("N-"_$S('IBREQMRA:"CURRENT",1:"ALL")_" IN < . I IBREQMRA S IBZ=$G(IBI($$COBN^IBCEF(IBIFN)+1)) < . I $S(IBZ="":0,$E(IBZ,$L(IBZ)-3,$L(IBZ))="PRNT":0,1: < . S IBER=IBER_"IB327;" < diff -y --suppress-common-lines ./VADemo/r1/IBCBB2.m ./VADemo/r2/r/IBCBB2.m ;;2.0;INTEGRATED BILLING;**51,137,210,245,232**;21-MA | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLA | N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLA I IBI,$$INPAT^IBCEF(IBIFN,1),$E($$ICD9^IBACSV(+$P(IBD | I IBI,$$INPAT^IBCEF(IBIFN,1),$E($G(^ICD9(+$P(IBDXO(IB . ;I IBER'["IB089",$P(IBCPT,U,10)=7,$S('$P(IBCPT,U,16 | . I IBER'["IB089",$P(IBCPT,U,10)=7,$S('$P(IBCPT,U,16) I IBTX S IBI=4 F S IBI=$O(IBDXO(IBI)) Q:'IBI S Z=+$ < I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'= | I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'= S (IBLCT,IBOLAB)=0,IBPS="",IBSP=$$BILLSPEC^IBCEU3(IBI | S IBOLAB=0,IBPS="",IBSP=$$BILLSPEC^IBCEU3(IBIFN) . S IBLCT=IBLCT+1 < I IBTX,IBLCT>50 S IBER=IBER_"IB308;" < . S Z=$E($P($$ICD9^IBACSV(IBDX),U),1,3),Z1=$E(Z,2,3) | . S Z=$E($P($G(^ICD9(IBDX,0)),U),1,3),Z1=$E(Z,2,3) diff -y --suppress-common-lines ./VADemo/r1/IBCBB3.m ./VADemo/r2/r/IBCBB3.m ;;2.0;INTEGRATED BILLING;**51,137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,I | N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,I ; Medicare is the current payer, but no diagnosis cod < I $$WNRBILL^IBEFUNC(IBIFN) D SET^IBCSC4D(IBIFN,.IBDX, < ; < . D NONMCR(.IBPR,.IBLABS) ; Remove Oxygen, labs, infl | . D NONMCR(.IBPR) ; Remove Oxygen, labs, influenza sh . ;I $O(IBPR(""))="" D | . I $O(IBPR(""))="" S IBQUIT=$$IBER(.IBER,"098") . I $G(IBLABS) D WARN^IBCBB11("The only possible bill < . I $O(IBPR(""))="" D < .. S IBQUIT=$$IBER(.IBER,"098") < NONMCR(IBPR,IBLABS) ; Delete all oxygen and lab, flu sho | NONMCR(IBPR) ; Delete all oxygen and lab, flu shot CPT en ; IBLABS = flag returned =1 if labs found on bill | N Z N Z S IBLABS=0 < ;S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N K IBPR(Z | S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N K IBPR(Z) S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N S IBLABS= < S IBI=$P($G(^DGCR(399,IBIFN,"U")),U,11) | S IBI=$P($G(^DGCR(399,IBIFN,DA,"U")),U,11) I +X,$$COBN^IBCEF(IBIFN)=IBFLD,$$WNRBILL^IBEFUNC(IBIF | I +X,$$COBN^IBCEF(DA)=IBFLD,$$WNRBILL^IBEFUNC(DA,IBFL diff -y --suppress-common-lines ./VADemo/r1/IBCBB7.m ./VADemo/r2/r/IBCBB7.m ;;2.0;INTEGRATED BILLING;**51,137,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 S IBRATYP=$S(IBZ="":1,IBZ["TRICARE"!(IBZ["CHAMPVA")!( | S IBRATYP=$S(IBZ="":1,IBZ["CHAMPUS"!(IBZ["CHAMPVA")!( . . ; Accommodation revenue code edits | . . ; Accomodation revenue code edits diff -y --suppress-common-lines ./VADemo/r1/IBCBB8.m ./VADemo/r2/r/IBCBB8.m ;;2.0;INTEGRATED BILLING;**51,137,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 . S IBDXC=$P($$ICD9^IBACSV(+$P(IBXDATA(IBI),U)),U) | . S IBDXC=$P($G(^ICD9(+$P(IBXDATA(IBI),U),0)),U) diff -y --suppress-common-lines ./VADemo/r1/IBCBB9.m ./VADemo/r2/r/IBCBB9.m ;;2.0;INTEGRATED BILLING;**51,137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N IBXDATA,IBXERR,IBXIEN,IBXSAVE,IBPR,IBDTFLG | N IBXDATA,IBXERR,IBXIEN,IBXSAVE,IBPR . I $$REQMRA^IBEFUNC(IBIFN),$O(IBXDATA(""),-1)>12 D W | . D NONMCR^IBCBB3(.IBPR) ; Oxygen, labs, influenza sh . I $$REQMRA^IBEFUNC(IBIFN),$E(IBFDT,1,3)'=$E(IBTDT,1 < . D NONMCR^IBCBB3(.IBPR,.IBLABS) ; Oxygen, labs, infl < . S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N S IBLAB < . I $G(IBLABS) D WARN^IBCBB11("The only possible bill < ; Specialty code 99 is not valid for Medicare MRA req < I $$REQMRA^IBEFUNC(IBIFN),$$BILLSPEC^IBCEU3(IBIFN)=99 < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCBB.m ./VADemo/r2/r/IBCBB.m ;;2.0;INTEGRATED BILLING;**80,51,137,288**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**80,51,137**;21-MAR-94 N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,I | N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT ; All insurance subscribers must have a birthdate on < ; - 11/10/04 - IB*2.0*288 < F IBISEQ=1:1:3 D < . I '$P($G(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1) Q ; no < . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J) < . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ) < . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J) < . I $P(IDDATA,U,1) Q ; birthdate exists < . ; IB error codes < . ; IB221 - primary insured's dob missing < . ; IB222 - secondary insured's dob missing < . ; IB223 - tertiary insured's dob missing < . S IBERRNO=220+IBISEQ < . S IBER=IBER_"IB"_IBERRNO_";" < . Q < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCB.m ./VADemo/r2/r/IBCB.m ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,161,199** | ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,161**;21- N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBCBULL.m ./VADemo/r2/r/IBCBULL.m ;;2.0;INTEGRATED BILLING;**124,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**124**;21-MAR-94 S IB("S")=$G(^DGCR(399,IBIFN,"S")) < diff -y --suppress-common-lines ./VADemo/r1/IBCCC2.m ./VADemo/r2/r/IBCCC2.m IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/0 | IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JA ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137, | ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137, F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DG | F I="CC","OC","OP","RC","CP","CV","PRV" I $D(^DGCR(39 I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBI | I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D BILL^IBCRBC(IBI OT S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) < S IBDD=399.048 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) < Q < . F K=1:1:7,9:1:14,16:1:22 S $P(^DGCR(399,IBIFN,I,J,0 | . F K=1:1:7,9:1:13,15:1:19 S $P(^DGCR(399,IBIFN,I,J,0 N I,IBFRMTYP | N I . S IBCOB("TX",1)="",IBCOB("TX",2)="" | . S IBCOB("TX",1)="",IBCOB("TX",2)="",IBCOB("TX",6)=" . I IBX=0 S IBCOB("TX",5)=0 ; | . I IBX=0 S IBCOB("TX",5)=0 . I IBX["R" S IBCOB("TX",5)="A" ; | . I IBX["R" S IBCOB("TX",5)="A" . I IBX=1,$$CHK^IBCEMU1(IBIFN) S IBCOB("TX",5)="C" ; | . I IBX=1 D . I $G(IBPRCOB) S IBCOB("TX",5)="C" ; | .. N Z,Z0,IBOK > .. S (IBOK,Z)=0 > .. F S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z > ... S Z0=$G(^IBM(361.1,Z,0)) > ... I "23"[$P(Z0,U,16) S IBOK=1 > .. I 'IBOK S IBCOB("TX",5)=$E("AC",IBOK+1) . Q < ; IB*2.0*211 < ; save off Form Type < S IBFRMTYP=$P($G(^DGCR(399,IBIFN,0)),U,19) < ; < ; Restore Form Type if changed, but don't restore For < ; creating HCFA bill from CTCOPY1^IBCCCB < I $G(IBCTCOPY)'=1,IBFRMTYP'=$P($G(^DGCR(399,IBIFN,0)) < ; < ; Restore Claim MRA Status field since triggers in fi < ; will overwrite the correct value when processing < ; If we're processing the MRA/EOB, then a valid MRA h < I $G(IBPRCOB) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399," < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCCCB0.m ./VADemo/r2/r/IBCCCB0.m ;;2.0;INTEGRATED BILLING;**51,137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 I IBCTYPE=1 D CTCOPY1(IBIFN) Q | I IBCTYPE=1 D CTCOPY1^IBCCCB(IBIFN) Q I IBCTYPE=2 D CTCOPY2(IBIFN) Q | I IBCTYPE=2 D CTCOPY2^IBCCCB(IBIFN) Q CTCOPY1(IBIFN) ; Copy a Reasonable Charges inst bill to cre | FINALEOB(IBIFN) ; Returns 1 if user indicates final EOB/MRA h ; - Billing Rate must be Reasonable Charges < ; - Bill being copied must be an inst bill < ; - Prof bill must not already exist for the event < ; - If the bill is outpt at least one CPT must have < ; - Procedure codes are copied only if the care is < ; < N IB0,IBU,IBBTYPE,IBBCTO,IBBCTN,IBBCTOD,IBBCTND,IBNOC < ; < S IBCTCOPY=1 ; flag - the copy function entered to au < ; < S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G( < S IBBTYPE=$S($P(IB0,U,5)<3:"Inpatient",1:"Outpatient" < ; < S IBBCTO=$P(IB0,U,27),IBBCTN=0 I 'IBBCTO Q < I IBBCTO=1 S IBBCTN=2 ; inst defined, create prof < I 'IBBCTN Q < ; < I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U < ; < S IBBCTOD=$S(IBBCTO=1:"INSTITUTIONAL",2:"PROFESSIONAL < ; < I $P(IB0,U,5)>2,'$$CPTCHG^IBCRCU1(IBIFN,"PROF") W !!! < ; < W !!!,"This ",IBBTYPE," ",IBBCTOD," bill may have cor < ; < I '$G(^DGCR(399,IBIFN,"U1")) W !!,"The current bill h < ; < S IBX=$$CTCHK^IBCU41(IBIFN) I +IBX W !!,"There is an < ; < W !,"Creating an ",IBBTYPE," ",IBBCTND," bill.",!! < ; < S IBCOB(0,27)=IBBCTN < S IBIDS(.15)=IBIFN D KVAR^IBCCCB < ; < I $P(IB0,U,5)<3 S IBNOCPT=1 ; do not copy inpt facili < S IBNOTC=1 ; don't copy TC modifier from inst to prof < D STEP2^IBCCC ; copy/create second bill < ; < I $G(IBHV("IBIFN1"))!(IBCTCOPY=1) D FTPRV^IBCEU5(+$G( < S IBV=0,IBAC=1 < ; < ; DSS QuadraMed Interface: CPT Sequence and Diagnosis < I +$G(IBHV("IBIFN1")),$$QMED^IBCU1("CTCOPY^VEJDIBE1", < Q < ; < CTCOPY2(IBIFN) ; Copy a Reasonable Charges prof bill to crea < ; - Billing Rate must be Reasonable Charges < ; - Bill being copied must be a prof bill < ; - Procedures are not copied < ; < N IB0,IBU,IBBTYPE,IBBCTO,IBNOCPT,IBCTCOPY,IBX,DIR,DIR < ; < S IBCTCOPY=2 ; flag indicating the copy function is e < ; < S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G( < S IBBTYPE=$S($P(IB0,U,5)<3:"Inpatient",1:"Outpatient" < S IBBCTO=$P(IB0,U,27) I IBBCTO'=2 Q ; prof bills onl < ; < I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U < ; < I '$G(^DGCR(399,IBIFN,"U1")) Q ; if the current bill < ; < ; ask if they want a second prof bill < S DIR("?",1)="If answered Yes, the current bill will < S DIR("?",2)="to create another Professional bill for < S DIR("?")="Enter Yes if multiple professional bills < S DIR("A")="Copy this bill to create another Professi < W !! S DIR(0)="Y",DIR("B")="No" D ^DIR I $D(DIRUT)!(' < ; < W !,"Creating an ",IBBTYPE," Professional bill.",!! < ; < S IBIDS(.15)=IBIFN D KVAR^IBCCCB < ; < S IBNOCPT=1 < D STEP2^IBCCC ; copy/create second prof bill < S IBV=0,IBAC=1 < Q < ; < ; < FINALEOB(IBIFN) ; Returns 1 if user indicates final EOB has b < I '$$MCRONBIL^IBEFUNC(IBIFN) D G FEOBQ | S DIR(0)="YA",DIR("B")="NO",DIR("A")="Has the final " . S DIR(0)="YA",DIR("B")="NO",DIR("A")="Has the final | S DIR("?",1)="COB should not normally be performed un . S DIR("?",1)="COB should not normally be performed | D ^DIR K DIR . D ^DIR K DIR | I Y'=0 S IBOK=$S(Y>0:1,1:0) G FEOBQ . I Y'=0 S IBOK=$S(Y>0:1,1:0) < I $$SPLTMRA^IBCEMU1(IBIFN)=1 D G FEOBQ < . W !!," Only one MRA has been received for this clai < . W !," that it is a 'split MRA' meaning that additio < . W !," Processing cannot continue until all MRA's ha < . W ! S DIR(0)="E" D ^DIR K DIR < . Q < ; < I $$SPLTMRA^IBCEMU1(IBIFN)>1 D < . W !!," At least 2 MRA's have been received for this < . W !,"Please verify that all possible MRA's have bee < ; < I "^1^2"'[(U_IBSTAT_U) S IBOK=1 G COBOKQ | I "^1^2^"'[(U_IBSTAT_U) S IBOK=1 G COBOKQ diff -y --suppress-common-lines ./VADemo/r1/IBCCCB.m ./VADemo/r2/r/IBCCCB.m ;;2.0;INTEGRATED BILLING;**80,106,51,151,137,182,155* | ;;2.0;INTEGRATED BILLING;**80,106,51,151,137**;21-MAR ; Restrict access to this process for REQUEST MRA bil < ; 1. No MRA EOB's on File for bill < I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,'$$CHK^IBCEMU1(IB < . W !!?4,"This bill is in a status of REQUEST MRA and < . W !?4,"on file. Access to this bill is restricted. < ; < ; 2. At least one MRA EOB appears on the MRA manageme < I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,$$MRAWL^IBCEMU2(I < . W !!?4,"This bill is in a status of REQUEST MRA and < . W !?4,"MRA Management Work List. Please use the 'M < . W !?4,"for all processing related to this bill." < . Q < ; < ; If MRA is Activated and bill is in Entered/Not Revi < ; ask if user wants to continue < I $$EDIACTV^IBCEF4(2),$P($G(^DGCR(399,IBIFN,0)),U,13) < . W !!?4,"This bill is in a status of ENTERED/NOT REV < . W !?4,"MEDICARE (WNR). No MRA has been requested fo < . S DIR(0)="YA",DIR("B")="NO",DIR("A")=" Are you s < . D ^DIR K DIR < ; < ; Display related bills < I '$$FINALEOB^IBCCCB0(IBIFN) S IBSECHK=1 | I '$$FINALEOB^IBCCCB0(IBIFN) G EXIT I $G(IBSECHK)=1,$$MCRONBIL^IBEFUNC(IBIFN) G EXIT < ; < I '$$MCRONBIL^IBEFUNC(IBIFN) I '$$COBOK^IBCCCB0(IBIFN | I '$$COBOK^IBCCCB0(IBIFN) G EXIT ; < CHKB1 ; Entry point for Automatic/Silent COB Processing. < ; No writes or reads can occur from this point forwar < ; IBSILENT=1. Any and all error messages should be p < ; the ERROR procedure below. < ; < ; check to see if the bill has been cancelled | I IB("S")]"",+$P(IB("S"),U,16),$P(IB("S"),U,17)]"" W I $P(IB("S"),U,16),$P(IB("S"),U,17) D G ASK1 < . N WHO < . S IBER="This bill was cancelled on " < . S IBER=IBER_$$FMTE^XLFDT($P(IB("S"),U,17),"1Z")_" b < . S WHO="UNSPECIFIED" < . I $P(IB("S"),U,18) S WHO=$P($G(^VA(200,$P(IB("S"),U < . S IBER=IBER_WHO_"." < . D ERROR < . Q < ; If processing in silent mode, skip over the followi < I $G(IBSILENT) G SKIP < ; < S DIR("?")="Enter Yes to "_$S('$G(IBMRAO):"create a n | S DIR("?")="Enter Yes to "_$S('$G(IBMRAO):"create a n S DIR(0)="YO",DIR("A")=$S('$G(IBMRAO):"Copy "_$P(IB(0 | S DIR(0)="YO",DIR("A")=$S('$G(IBMRAO):"Copy "_$P(IB(0 S IBQ=0 | S DIR("?")=" This will be added to the new bill as a I '$G(IBMRAO) D G:IBQ ASK1 | ; > I '$G(IBMRAO) D . S DIR("?")="Enter the amount of the payment from th | .S DIR("?")="Enter the amount of the payment from the . S DIR("?")=DIR("?")_" This will be added to the ne | .S DIR("A")="Prior Payment from "_$P(IB(0),U,1)_" "_I . S DIR("A")="Prior Payment from "_$P(IB(0),U,1)_" "_ | . S Z=$$EOBTOT^IBCEU1(IBIFN,$$COBN^IBCEF(IBIFN)) > . S:Z DIR("B")=Z > E D > . N Z > .S DIR("?")="Enter the MEDICARE allowed amt from the > . S DIR("A")="MRA Allowed Amount from "_$P(IB(0),U,1) . S DIR(0)="NOA^0:99999999:2" < . D ^DIR K DIR I Y=""!$D(DIRUT) S IBQ=1 < . K IBCOB < . S IBCOB("U2",IBCOBN+2)=Y < . Q < ; < SKIP ; Jump here if skipping over the preceeding reads < ; < ; If payer is Medicare (WNR) update payer sequence an < I IBMRAO D G END < . N IBPRTOT,IBTOTCHG,IBPTRESP < . S IBTOTCHG=0 < . ; Get Total Submitted Charges from EOB file < . I $G(IBDA) S IBTOTCHG=$P($G(^IBM(361.1,IBDA,2)),U,4 < . ; Calculate Patient Responsibility for Bill < . S IBPTRESP=$$PREOBTOT^IBCEU0(IBIFN) < . ; Calculate Patient Primary/Secondary Prior Payment < . ; These fields are stored in DGCR(399,IBIFN,"U2") p < . ; Calculate: Prior Payment= Total Submitted Charges < . S IBPRTOT=IBTOTCHG-IBPTRESP < . I IBPRTOT<0 S IBPRTOT=0 ; don't allow negative < . S IBCOB("U2",IBCOBN+2)=IBPRTOT < . D COBCHG^IBCCC2(IBIFN,IBMRAIO,.IBCOB) < . D STAT^IBCEMU2(IBIFN,1.5,1) ; mra eob status up < . I $G(IBSILENT) S IBERRMSG="" < . Q < ; < ; We should NOT get to here in silent mode .... just < I $G(IBSILENT) G END ; currently only MCRWNR in si < ; < ; Payer is not Medicare (WNR) - Perform additional st < S IBCOB(0,15)="" < S IBCOB(0,21)=$S(IBCOBN=2:"S",IBCOBN=3:"T",1:"") < I IBCOB(0,21)="" G END < S IBCOB("M1",IBCOBN+3)=IBIFN < S IBIDS(.15)=IBIFN < D KVAR < G STEP2^IBCCC < ; < END ; < Q < > S DIR(0)="NOA^0:99999999:2" > D ^DIR K DIR I Y=""!$D(DIRUT) G ASK1 > K:'IBMRAO IBCOB > S IBCOB("U2",IBCOBN+2)=Y > ; > I 'IBMRAO D > . S IBCOB(0,15)="" > . S IBCOB(0,21)=$S(IBCOBN=2:"S",IBCOBN=3:"T",1:"") Q: > . S IBCOB("M1",IBCOBN+3)=IBIFN > . ; > . S IBIDS(.15)=IBIFN > I 'IBMRAO Q:IBCOB(0,21)="" D KVAR G STEP2^IBCCC > D COBCHG^IBCCC2(IBIFN,IBMRAIO,.IBCOB) > END Q ERROR ; Display/Save error message | ERROR ; I '$G(IBSILENT) W !,IBER,! | W !,IBER,! S IBER="" E S IBERRMSG=IBER < S IBER="" < I $D(IBSECHK) S IBSECHK=1 < > CTCOPY1(IBIFN) ; Copy a Reasonable Charges inst bill to cre > ; - Billing Rate must be Reasonable Charges > ; - Bill being copied must be an inst bill > ; - Prof bill must not already exist for the event > ; - If the bill is outpt at least one CPT must have > ; - Procedure codes are copied only if the care is > ; > N IB0,IBU,IBBTYPE,IBBCTO,IBBCTN,IBBCTOD,IBBCTND,IBNOC > ; > S IBCTCOPY=1 ; flag - the copy function entered to au > ; > S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G( > S IBBTYPE=$S($P(IB0,U,5)<3:"Inpatient",1:"Outpatient" > ; > S IBBCTO=$P(IB0,U,27),IBBCTN=0 I 'IBBCTO Q > I IBBCTO=1 S IBBCTN=2 ; inst defined, create prof > I 'IBBCTN Q > ; > I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U > ; > S IBBCTOD=$S(IBBCTO=1:"INSTITUTIONAL",2:"PROFESSIONAL > ; > I $P(IB0,U,5)>2,'$$CPTCHG^IBCRCU1(IBIFN,"PROF") W !!! > ; > W !!!,"This ",IBBTYPE," ",IBBCTOD," bill may have cor > ; > I '$G(^DGCR(399,IBIFN,"U1")) W !!,"The current bill h > ; > S IBX=$$CTCHK^IBCU41(IBIFN) I +IBX W !!,"There is an > ; > W !,"Creating an ",IBBTYPE," ",IBBCTND," bill.",!! > ; > S IBCOB(0,27)=IBBCTN > S IBIDS(.15)=IBIFN D KVAR > ; > I $P(IB0,U,5)<3 S IBNOCPT=1 ; do not copy inpt facili > S IBNOTC=1 ; don't copy TC modifier from inst to prof > D STEP2^IBCCC ; copy/create second bill > I $G(IBHV("IBIFN1"))!(IBCTCOPY=1) D FTPRV^IBCEU5(+$G( > S IBV=0,IBAC=1 > Q > ; > CTCOPY2(IBIFN) ; Copy a Reasonable Charges prof bill to crea > ; - Billing Rate must be Reasonable Charges > ; - Bill being copied must be a prof bill > ; - Procedures are not copied > ; > N IB0,IBU,IBBTYPE,IBBCTO,IBNOCPT,IBCTCOPY,IBX,DIR,DIR > ; > S IBCTCOPY=2 ; flag indicating the copy function is e > ; > S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G( > S IBBTYPE=$S($P(IB0,U,5)<3:"Inpatient",1:"Outpatient" > S IBBCTO=$P(IB0,U,27) I IBBCTO'=2 Q ; prof bills onl > ; > I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U > ; > I '$G(^DGCR(399,IBIFN,"U1")) Q ; if the current bill > ; > ; ask if they want a second prof bill > S DIR("?",1)="If answered Yes, the current bill will > S DIR("?",2)="to create another Professional bill for > S DIR("?")="Enter Yes if multiple professional bills > S DIR("A")="Copy this bill to create another Professi > W !! S DIR(0)="Y",DIR("B")="No" D ^DIR I $D(DIRUT)!(' > ; > W !,"Creating an ",IBBTYPE," Professional bill.",!! > ; > S IBIDS(.15)=IBIFN D KVAR > ; > S IBNOCPT=1 > D STEP2^IBCCC ; copy/create second prof bill > S IBV=0,IBAC=1 > Q > ; diff -y --suppress-common-lines ./VADemo/r1/IBCC.m ./VADemo/r2/r/IBCC.m ;;2.0;INTEGRATED BILLING;**2,19,77,80,51,142,137,161, | ;;2.0;INTEGRATED BILLING;**2,19,77,80,51,142,137,161* > ;I '$D(IBCAN) W !!,?3,"***** BILLS MAY ONLY BE CANCEL N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < . Q | F I=0,"S","U1" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I) ; < F I=0,"S","U1" S IB(I)=$G(^DGCR(399,IBIFN,I)) < S IBSTAT=$P(IB(0),U,13) < ; < ; Restrict access to this process for REQUEST MRA bil < I IBSTAT=2,'$G(IBCE("EDI")),$$MRAWL^IBCEMU2(IBIFN) D < . W !!?4,"This bill is in a status of REQUEST MRA and < . W !?4,"MRA Management Work List. Please use the 'M < . W !?4,"for all processing related to this bill." < . Q < ; < ; Warning message if in a REQUEST MRA status with no < I IBSTAT=2,'$$MRACNT^IBCEMU1(IBIFN) D < . N REJ < . D TXSTS^IBCEMU2(IBIFN,,.REJ) < . W *7,!!?4,"Warning! This bill is in a status of RE < . W !?4,"No MRAs have been received" < . I REJ W ", but the most recent transmission of this < . I 'REJ W " and there are no rejection messages on f < . Q < ; < > S IBSTAT=$P(IB(0),"^",13) N PRCABILL | I $$TPR^PRCAFN(IBIFN) D S PRCABILL=$$TPR^PRCAFN(IBIFN) | . W !!,"Please note a PAYMENT of **$"_$$TPR^PRCAFN(IB I PRCABILL=-1 W !!,"Please note: PRCA was unable to d < I PRCABILL>0 W !!,"Please note a PAYMENT of **$"_$$TP < > ;W !!,"LAST CHANCE TO CHANGE YOUR MIND..." S DIE("NO^ diff -y --suppress-common-lines ./VADemo/r1/IBCCPT.m ./VADemo/r2/r/IBCCPT.m IBCCPT ;ALB/LDB/AAS - MCCR OUTPATIENT VISITS LISTING CONT. ; | IBCCPT ;ALB/LDB/AAS - MCCR OUTPATIENT VISITS LISTING CONT. ; ;;2.0;INTEGRATED BILLING;**55,62,52,91,106,125,51,148 | ;;2.0;INTEGRATED BILLING;**55,62,52,91,106,125,51,148 N ICPTVDT S ICPTVDT=$$BDATE^IBACSV($G(IBIFN)) ; Code < S DR=$$SPCUNIT^IBCU7(IBIFN,IBPROCP) I DR'="" D ^DIE ; < ; < ; DSS QuadraMed Interface: CPT Sequence and Diagnosis < I $$QMED^IBCU1("DX^VEJDIBE1",IBIFN) D DX^VEJDIBE1(IBI < ; < N IBCPTNM,IBNBM,IBMODS,J,IBZ,IBDATE | N IBCPTNM,IBNBM,IBMODS,J,IBZ S IBNBM="",IBCPTNM=$$CPT S IBDATE=$$BDATE^IBACSV($G(IBIFN)) < S IBNBM="",IBCPTNM=$$CPT^ICPTCOD(DGCPT,IBDATE) Q:IBCP < S IBMODS=$P($G(DGNOD),U,10) F J=1:1 S IBZ=$P(IBMODS," | S IBMODS=$P($G(DGNOD),U,10) F J=1:1 S IBZ=$P(IBMODS," N IBI,IBL,IBMODS,IBMOD,IBPRVTYP,IBPRV,IBDATE | N IBI,IBL,IBMODS,IBMOD,IBPRVTYP,IBPRV I $G(CPTNM)=""! I $G(CPTNM)=""!($G(NOD)="") Q < S IBDATE=$$BDATE^IBACSV($G(IBIFN)) | I IBMODS'="" F IBI=1:1 S IBMOD=$P(IBMODS,",",IBI) Q:' I IBMODS'="" F IBI=1:1 S IBMOD=$P(IBMODS,",",IBI) Q:' < diff -y --suppress-common-lines ./VADemo/r1/IBCD3.m ./VADemo/r2/r/IBCD3.m IBCD3 ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - CREATE BI | IBCD3 ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - CREATE BI ;;2.0;INTEGRATED BILLING;**14,55,52,91,106,125,51,148 | ;;2.0;INTEGRATED BILLING;**14,55,52,91,106,125,51,148 ... S IBZ=^TMP("IBDX",$J,IBX,IBY) Q:($$ICD9^IBACSV(+I | ... S IBZ=^TMP("IBDX",$J,IBX,IBY) Q:'$D(^ICD9(+IBZ,0) S IBAUTO=1,DGPTUPDT="" I '$G(IBCHTRN) D PROC^IBCU7A(I | S IBAUTO=1,DGPTUPDT="" D:'$G(IBCHTRN) ^IBCU6 ; auto c diff -y --suppress-common-lines ./VADemo/r1/IBCE277.m ./VADemo/r2/r/IBCE277.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 > ; I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,"CLAIM",IBCL < Only in ./VADemo/r1/: IBCE835A.m diff -y --suppress-common-lines ./VADemo/r1/IBCE835.m ./VADemo/r2/r/IBCE835.m IBCE835 ;ALB/TMP - 835 EDI EXPLANATION OF BENEFITS MSG PROCES | IBCE835 ;ALB/TMP - 277 EDI EXPLANATION OF BENEFITS MSG PROCES ;;2.0;INTEGRATED BILLING;**137,135,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 ; ,"D1",1,0)=header < N CT,IB399,IBD0,IBBILL,LINE,L,X,Y,Z,%DT | N CT,IB399,IBD0,IBBILL,LINE,L,X,Y,Z ; | S (IBBILL,Z0)="" S IBBILL=$$LAST364^IBCEF4(IB399) | F S Z0=$O(^IBA(364,"B",IB399,Z0),-1) Q:Z0="" I $E($ S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D1",1,0)="##RAW DAT < ; ,"D1",msg seq #,5) < . N XQA,XQAMSG < S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D",5,1)="##RAW DATA < S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D1",1,5)="##RAW DAT < ; ,"D1",msg seq #,10 < N IBCLM,CT,LINE,L,Z,Z0,IBDATA,IBSTAT | N IBCLM,CT,LINE,L,Z,Z0,IBFLD,IBDATA > ;S IBFLD="10;2.04^11;1.01^12;.1^13;.11^14;.12^15;4.01 > ; > ;F Z=1:1:$L(IBFLD,U) S Z0=$P(IBFLD,U,Z),IBDATA=$P(IBD > ; . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,10)="##RAW D < ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,15 < N IBCLM,Z,Z0,IBDATA | N IBCLM,Z,Z0,IBFLD,IBDATA > ;S IBFLD="3;1.02^4;1.03^5;1.04^6;1.06^7;1.07^8;1.08^9 > ; > ;F Z=1:1:$L(IBFLD,U) S Z0=$P(IBFLD,U,Z),IBDATA=$P(IBD > ; S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,15)="##RAW DAT < ; ,"D1",seq#,20)= < S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),20)= < D 37^IBCE835A(.IBD) | ; Claim must have been referenced by a previous '05' > ; > ; INPUT: > ; IBD must be passed by reference = entire message > ; > ; OUTPUT: > ; IBD("LINE") = The last line # populated in the m > ; ^TMP("IBMSG",$J,"CLAIM",claim #,line #)=claim lev > ; ,"D",37,seq#)= > ; claim leve > ; > N IBCLM > S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) > Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) > S IBD("LINE")=$G(IBD("LINE"))+1 > S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))=$S($D(^T > S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",37,IBD("LINE"))=" D 40^IBCE835A(.IBD) | ; > ; INPUT: > ; IBD must be passed by reference = entire message > ; > ; OUTPUT: > ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D",40,msg seq #) > ; claim status > ; IBD("LINE") = The last line # populated in the m > ; > N IBCLM > S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) > S IBD("LINE")=$G(IBD("LINE"))+1 > ; > I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",40)) D > . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))="Line > . S IBD("LINE")=IBD("LINE")+1 > ; > S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",40,IBD("LINE"))=" > ; D 45^IBCE835A(.IBD) < Q < 17(IBD) ; Process claim contact data segment | ; INPUT: D XX(.IBD,17) | ; IBD must be passed by reference = entire message > ; > ; OUTPUT: > ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D",45,msg seq #) > ; claim status > ; IBD("LINE") = The last line # populated in the m > ; > N IBCLM > S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) > S IBD("LINE")=$G(IBD("LINE"))+1 > ; > I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",45)) D > . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))="Line > . S IBD("LINE")=IBD("LINE")+1 > ; > S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",45,IBD("LINE"))=" > ; 42(IBD) ; Process service line data (part 3) < D XX(.IBD,42) < Q < ; < 99(IBD) ; Process trailer record for non-MRA EOB < D XX(.IBD,99) < Q < ; < ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,IB < S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),IBID < diff -y --suppress-common-lines ./VADemo/r1/IBCE837A.m ./VADemo/r2/r/IBCE837A.m IBCE837A ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION - CONT | IBCE837A ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION - CONT ;;2.0;INTEGRATED BILLING;**137,191,211,232**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**137,191**;21-MAR-94 N DIC,DIE,DR,DA,IBBATCH,IBIFN,IBIEN,IBYY,IBTXTEST,IBM | N DIC,DIE,DR,DA,IBBATCH,IBIFN,IBIEN,IBYY,IBTXTEST .S DA=IBIEN,DIE="^IBA(364,",DR=".02////"_IBBATCH_";.0 | .S DA=IBIEN,DIE="^IBA(364,",DR=".02///"_IBBATCH_";.03 .S IBMRA=$$NEEDMRA^IBEFUNC(IBIFN) | .S:'$D(IBMRA) IBMRA=$$NEEDMRA^IBEFUNC(IBIFN) .I IBMRA="C",$P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBMR < N DIK,DA,XMTO,XMZ,XMBODY,XMDUZ,XMSUBJ,IBBDA,IBBNO | N DIK,DA,XMTO,XMZ,XMBODY,XMDUZ,IBBDA,IBBNO . I IBQUEUE["@" S XMTO(IBQUEUE)="" < . N XMTO,XMBODY,XMDUZ,XMSUBJ,XMZ,IBFUNC | . N XMTO,XMBODY,XMDUZ,XMSUBJ,IBFUNC K ZTREQ S ZTREQ="@" | S ZTREQ="@" CHKBTCH(IBBNO) ; Delete batch whose batch # is IBBNO if no e | CHKBTCH(IBBNO) ; Delete batch whose ien = IBBNO if no entrie N IBZ,DA,DIK | N IBZ diff -y --suppress-common-lines ./VADemo/r1/IBCE837.m ./VADemo/r2/r/IBCE837.m IBCE837 ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION ;8/6/03 10:48a | IBCE837 ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION ;05-FEB-96 ;;2.0;INTEGRATED BILLING;**137,191,197,232**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**137,191,197**;21-MAR-94 EN ; Auto-txmt | EN ; Run auto-transmit N IBSITE8,IBRUN,X,X1,X2,DA,DIE,DR | N IBSITE8,IBRUN,X,X1,X2 ; IBEXTRP=1 prnt 837 data | ; IBEXTRP = 1 print 837 data ; Chk extract running | ; Check if extract job running FIND ; Find bills/sort by HCFA 1500/UB92, test/live, ins I | FIND ; Find bills/sort by HCFA 1500/UB92, test/live, ins c ..N IB3,DA,DIK | ..N IB3 OUTPUT ; 837 | OUTPUT ;Output 837 ...I $P(IBSITE,U,7) D ; 1 ins/batch | ...I $P(IBSITE,U,7) D ; 1 ins per batch ... N DIE,DA,DR < I $O(^TMP("IBXERR",$J,"")) D ;Error to mail grp | I $O(^TMP("IBXERR",$J,"")) D ;Error msg to mail grou .N IB,IB0,IBL,IBT,XMTO,XMDUZ,XMSUBJ,IBRESUB,XMZ | .N IB,IB0,IBL,IBT,XMTO,XMDUZ,XMSUBJ,IBRESUB MESSAGE(IBLCNT,IBIEN,IBBILL,IBCTM,IBSIZE,IBSIZEM,IBDUZ,IBBTYP | MESSAGE(IBLCNT,IBIEN,IBBILL,IBCTM,IBSIZE,IBSIZEM,IBDUZ,IBBTYP ;IBBILL = array file 364 ien's of bills being sent | ;IBBILL = array of file 364 ien's of bills in batch b ;IBSIZE = # bytes in msg | ;IBSIZE = # bytes in mail msg ;IBSIZEM = # bytes in record to be added to msg | ;IBSIZEM = # bytes in record to be added to mail msg ; y = 1 for test, 0 for live txmt | ; y = 1 for test, 0 for live txmt ..F S IB3=$O(^TMP("IBXDATA",$J,1,IB1,IB2,IB3)) D:IB3 | ..F S IB3=$O(^TMP("IBXDATA",$J,1,IB1,IB2,IB3)) D:IB3 SETHDR ; hdr for curr batch | SETHDR ; hdr for current batch SETHDR1 ; hdr node for curr ins | SETHDR1 ; hdr node for current ins diff -y --suppress-common-lines ./VADemo/r1/IBCEBUL.m ./VADemo/r2/r/IBCEBUL.m ;;2.0;INTEGRATED BILLING;**137,250**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB | N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB D NOW^%DTC S IBDTM=% < F S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI S IB | F S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI S IB diff -y --suppress-common-lines ./VADemo/r1/IBCECOB1.m ./VADemo/r2/r/IBCECOB1.m ;;2.0;INTEGRATED BILLING;**137,155,288**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N I,IBFND,IBB,IBIFN,IB364,IBDA1,IBDTN,IBDA,IBDAY,IBHI | N I,IBFND,IBB,IBIFN,IB364,IBDA1,IBDTN,IBDA,IBDAY,IBHI N IBEOBREV,IBDENDUP | K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBS K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBS < D CLEAN^VALM10 ; kill data and video control arr < ; since 0 is a valid Review Status, init w/null | I IBNY D S IBEOBREV="" | . S (IB364,IBIFN)=0 F S IBIFN=$O(^IBM(361.1,"ABD",IB ; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 o | E S IBIFN=0 F S IBIFN=$O(^IBA(364,"ACOB",IBIFN)) Q: F S IBEOBREV=$O(^IBM(361.1,"AMRA",1,IBEOBREV)) Q:IBE | I $O(^TMP("IBCOBST",$J,0))="" D NMAT Q . S IBDA="A" F S IBDA=$O(^IBM(361.1,"AMRA",1,IBEOBRE < ; no data accumulated < I $O(^TMP("IBCOBST",$J,""))="" D NMAT Q < ; display accumulated data < I '$$ELIG(IBDA) Q | S IBDT=+$O(^IBM(361.1,"ABD",IBIFN,""),-1) ;last rec. S IBDENDUP=$$DENDUP^IBCEMU4(IBDA) | Q:'IBDT I '$G(IBMRADUP),IBDENDUP Q ; don't include denied | S IBDA=+$O(^IBM(361.1,"ABD",IBIFN,IBDT,0)) > S:'IB364 IB364=$P($G(^IBM(361.1,IBDA,0)),U,19) S IBIFN=+IB3611,IB364=$P(IB3611,U,19),IBDT=+$P(IB3611 | Q:$P(IB3611,U,16)>2 ; EOB already accepted completel I $D(^TMP("IBCOBSTX",$J,IBIFN)) Q ;show each bill on < S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2) | S IBAUT=+$P(IBNDS,U,11),IBMUT=+$P(IBNDS,U,8) . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36, | . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$S(Q:"<",1:"") ; Get the payer/insurance company that comes after Me < ; If WNR is Primary, get the secondary ins. co. < ; If WNR is secondary, get the tertiary ins. co. < D I $P(IBINS2,U,2)="" S $P(IBINS2,U,2)="UNKNOWN" < . I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P( < . S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U) < ; biller entry not ALL and no biller, then get entere | ; biller entry not ALL and no biller, then get reques . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP | . S IBFND=$S($D(^TMP("IBBIL",$J,IBAUT)):IBAUT,$D(^TMP S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT) | S Z=$S(IBFND:IBFND,1:IBAUT) S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z | S IBAUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0" | S:'$P(IBAUT,"~",2) IBAUT="UNKNOWN~0" D ;I IBQ Q | D I 'IBNY,IBQ Q ; | Q:$P(IBB,U,13)'=4&($P(IBB,U,13)'=2) ;status=prn/tx o ; Days since transmission of latest bill in COB - IBD | ; days since transmission of latest bill in COB S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S | S IBDAY=$$FMDIFF^XLFDT(DT,$P($G(^DGCR(399,IBIFN,"TX") ; if no Last Electronic Extract Date on file 399, get < I 'IBDAY D I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1 < . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBD < ; < S IBEXPY=+$G(^IBM(361.1,IBDA,1)) ; payer paid a | S IBEXPY=+$G(^IBM(361.1,IBDA,1)),IBMRA=$$WNRBILL^IBEF S IBPTRSP=$$PREOBTOT^IBCEU0(IBIFN) ; patient resp < S IBOAM=+$G(^DGCR(399,IBIFN,"U1")) ; total charge | S IBOAM=$$ORI^PRCAFN(IBIFN) ;original amt from AR > I IBMRA S IBOAM=+$G(^DGCR(399,IBIFN,"U1"))-$P($G(^("U I IBNBAL'>0 S IBQ=2 | ; Quit if no balance remaining and not currently MCR S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0 | I IBNBAL'>0,'IBMRA Q:'IBNY S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U) | I IBNBAL'>0,IBNY S IBQ=2 S Z0=$S(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$P | S Z0=$S(IBSRT="A":IBAUT,IBSRT="D":IBDAY,IBSRT="B":-IB S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_ | S ^TMP("IBCOBST",$J,Z0,IBIFN)=$P($G(^DGCR(399,IBIFN," S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361. < S ^TMP("IBCOBSTX",$J,IBIFN)=IBDA ;keep track of comp < ; < ; Save some data when there are multiple MRA's on fil < S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN) < I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)= < S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT < S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=IBDENDUP < S ^TMP("IBCECOB",$J,2,0)=" No MRA's Matching Selec | S ^TMP("IBCECOB",$J,2,0)=" No MRA/EOB's Matching S N IBX,IBCNT,IBIFN,IBDA,IB,X,IBS1,IBPAT,Z,IBK | N IBX,IBCNT,IBIFN,IBDA,IB,X,IBS1,IBPAT,Z S IBS1=$S(IBSRT="B":"BILLER",IBSRT="D":"Days Since La | S IBS1=$S(IBSRT="A":"AUTHORIZING BILLER",IBSRT="B":"R . I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D | . I IBSRT="A"!(IBSRT="I") D .. S IBPAT=$$LJ^XLFSTR($E($P(Z,U),1,18),18," ")_" "_$ | .. S IBPAT=$E($P(Z,U),1,25)_"/"_$E($P(Z,U,9),6,9) .. S IBQ=$P(IB,U,14),IB364=$P(IB,U,15) | .. S IBQ=$P(IB,U,14),IB364=$P(IB,U,15),IBINS1=$P(IB,U .. S IBPTRSP=$P(IB,U,18) < .. S IBAMT=$P(IB,U,2) < .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBPTRSP,"",2),9 | .. S X=$$SETFLD^VALM1(" "_$P("PRI^SEC^TER",U,+$P(IB, .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBAMT,"",2),9," | .. S X=$$SETFLD^VALM1(" "_$$TYPE^IBJTLA1($P(IB,U,5)) .. S X=$$SETFLD^VALM1($$TYPE^IBJTLA1($P(IB,U,5))_"/"_ < .. ;For R (Pt Resp), P (Pt Name) and S (Service Date) | .. I "AI"'[IBSRT D .. I "BIMRPS"'[IBSRT D | ... S Z=$S(IBSRT="B":$J(-IBX,0,2),IBSRT="L":$$DAT1^IB ... S Z=$S(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IB < .. S X=$$SETSTR^VALM1("Insurers: "_$P(IB,U,9),"",7,7 | .. S X=$$SETSTR^VALM1("Insurers On Bill: "_$P(IB,U,9) .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) < .. ; < .. ; line 3 of display: MRA status/date/split claim < .. S X=$$SETSTR^VALM1("MRA Status: ","",5,13) < .. S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1)) < .. S X=$$SETSTR^VALM1($P(IBK,U,1),X,18,63) < .. I $P(IBK,U,2)=2 S X=$$SETSTR^VALM1("** SPLIT CLAIM < .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 S X=$$S < .. ; | .. I $P(IB,U,9)["<",$P(IB,U,9)[">" D .. ; conditionally update video attributes of line 3 | ... S Z=$F(X,"<",+$G(IBST))-1 .. I '$D(IOINHI) D ENS^%ZISS | ... S Z0=$F(X,">",Z)-1 .. ; split claim | ... I Z>0,Z0>0 D CNTRL^VALM10(VALMCNT,Z,(Z0-Z)+1,IOIN .. I $P(IBK,U,2)=2 D CNTRL^VALM10(VALMCNT,63,17,IOINH | K ^TMP("IBCOBST",$J) .. ; multiple mra's on file < .. I $P(IBK,U,3)>1 D CNTRL^VALM10(VALMCNT,18,22,IOINH < .. ; Denied for Duplicate - no split claim and single < .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 D CNTRL < .. Q < PTRESPI(IBEOB) ; Function - Computes the Patient's Responsib < ; of 361.1 for Claims/Bills with form type 3=UB92 < ; Input IBEOB - a single EOB ien; Required < ; Output - Function Returns IBPTRES - Patient Re < ; < N IBPTRES,IBC,EOBADJ < S IBPTRES=0,IBEOB=+$G(IBEOB) < I 'IBEOB Q IBPTRES ;PTRESPI < ; < ; get claim level adjustments < K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10) < S IBPTRES=$$CALCPR^IBCEU0(.EOBADJ) < ; < ; get line level adjustments < S IBC=0 F S IBC=$O(^IBM(361.1,IBEOB,15,IBC)) Q:'IBC < . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,IBC,1) < . S IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ) < Q IBPTRES < ; < ELIG(IBEOB) ; Function to determine if an EOB entry is el < ; inclusion on the MRA management worklist or not. < ; IBEOB - ien into file 361.1 (required) < ; Returns 1 if EOB should appear on the worklist < ; Returns 0 if EOB should not appear on the worklist < ; < NEW ELIG,IB3611,IBIFN < S ELIG=0,IBEOB=+$G(IBEOB) < S IB3611=$G(^IBM(361.1,IBEOB,0)) < I $P(IB3611,U,4)'=1 G ELIGX ; eob type must be Med < I $P(IB3611,U,16)>2 G ELIGX ; review status must b < S IBIFN=+IB3611 < I $P($G(^DGCR(399,IBIFN,0)),U,13)'=2 G ELIGX ; Reque < I $D(^IBM(361.1,IBEOB,"ERR")) G ELIGX ; filin < ; < S ELIG=1 ; this EOB is eligible for the worklist < ; < ELIGX ; < Q ELIG < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCECOB2.m ./VADemo/r2/r/IBCECOB2.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-1994 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994 I IBCMT'="" D EN^VALM("IBCEM MRA REVIEW") | I IBCMT'="" D EN^VALM("IBCEM EOB REVIEW") PMRA ;Print MRA < N IBIFN,IBDA < D SEL(.IBDA,1) < S IBDA=$O(IBDA(0)),IBIFN=+$G(IBDA(+IBDA)) < G:'IBIFN PRMQ < D MRA^IBCEMRAA(.IBIFN) < PRMQ S VALMBCK="R" < Q < ; IBDA(IBDA)=IBIFN^IB364^ien of 361.1^user selection | N IBIFN,IBDA,IB364 ; < N IBIFN,IBDA,IB364,IBEOBIFN < ; < ; Check for security key < I '$$KCHK^XUSRB("IB AUTHORIZE") D G CANCELQ < . D FULL^VALM1 S VALMBCK="R" < . W !!?5,"You don't hold the proper security key to a < . W !?5,"The necessary key is IB AUTHORIZE. Please s < . D PAUSE^VALM1 < . Q < ; < S IBEOBIFN=$P($G(IBDA(+IBDA)),U,3) < . I '$$LOCK^IBCEU0(361.1,IBEOBIFN) Q | . Q:'$$LOCK^IBCEU0(361.1,IBDA) . D UNLOCK^IBCEU0(361.1,IBEOBIFN) | . D UNLOCK^IBCEU0(361.1,IBDA) N IBDA,IBQ,IBEOBIFN | N IBDA,IBQ ; < ; Check for security key < I '$$KCHK^XUSRB("IB AUTHORIZE") D G CLONEQ < . D FULL^VALM1 S VALMBCK="R" < . W !!?5,"You don't hold the proper security key to a < . W !?5,"The necessary key is IB AUTHORIZE. Please s < . D PAUSE^VALM1 < . Q < ; < S IBEOBIFN=$P($G(IBDA(+IBDA)),U,3) | G:'$$LOCK^IBCEU0(361.1,IBDA) CLONEQ I '$$LOCK^IBCEU0(361.1,IBEOBIFN) G CLONEQ < D UNLOCK^IBCEU0(361.1,IBEOBIFN) | D UNLOCK^IBCEU0(361.1,IBDA) > D FULL^VALM1 K IBCE("EDI") S IBQ=1 | K IBCE("EDI") N VALMY,IBDA,Z,IBIFN,IBIFNH,IB364,IBCE | N VALMY,IBDA,IBIFN,Z,IBIFNH,IB364,IBCE,IBDA I '$P($G(^IBE(350.9,1,8)),U,12) D G PROQ < . D FULL^VALM1 < . W !!?5,"MRA's may not be processed at this time." < . W !?5,"The IB site parameter ""Allow MRA Processing < . D PAUSE^VALM1 < . Q < S Z=$O(IBDA(0)),Z=$G(IBDA(+Z)) G:'Z PROQ | S Z=$O(IBDA(0)),Z=$G(IBDA(+Z)) I 'IBIFN G PROQ | G:'IBIFN PROQ I '$$LOCK^IBCEU0(361.1,IBDA) G PROQ | Q:'$$LOCK^IBCEU0(361.1,IBDA) N IBCBASK,IBCBCOPY,IBCAN,IBIFNH,IBNSTAT,IBOSTAT,IBPRC | N IBCBASK,IBCBCOPY,IBCAN,IBIFNH,IBNSTAT,IBOSTAT N IBCOB,IBCOBIL,IBCOBN,IBINS,IBINSN,IBINSOLD,IBMRAIO, | S IBCBASK=1,(IBCBCOPY,IBCAN)=1 S (IBCBASK,IBCBCOPY,IBCAN,IBAUTO)=1,(IBPRCOB,IBSECHK) | I IB364,IBIFN D I 'IB364!'IBIFN W !,"Transmission record is missing f | . S IBIFNH=IBIFN ; | . S IBOSTAT=$S($G(IBFROM)=1:$P($G(^IBM(361,+$G(IBIEN) S IBIFNH=IBIFN | . I $D(^DGCR(399,IBIFN,"I"_($$COBN^IBCEF(IBIFN)+1))) I IBFROM=2 S IBPRCOB=1 | .. D DSPRB^IBCCCB0(IBIFN) ; | .. S IBCE("EDI")=1 I $$PREOBTOT^IBCEU0(IBIFN)'>0 D G COBCOPX | .. D CHKB^IBCCCB . D FULL^VALM1 | .. S IBIFN=IBIFNH . W !!?5,"There is no patient responsibility for this | .. S IBNSTAT=$S($G(IBFROM)=1:$P($G(^IBM(361,+$G(IBIEN . W !?5,"This claim may not be processed." | .. I $P($G(^DGCR(399,IBIFNH,"M1")),U,$$COBN^IBCEF(IBI . D PAUSE^VALM1 | ... D UPDEDI^IBCEM(IB364,"Z") . Q | ... I $G(IBBLD)'="" D @IBBLD ; | . E D I $P($G(^IBM(361.1,IBDA,0)),U,16)="1.5" D G COBCOPX | .. W !,"There is no next payer for this bill" . W !!,"This claim has already been processed as a se < . W !,"You will need to complete the authorization pr < . D AUTH < . Q < ; < ; Get out if no next payer < I '$P($G(^DGCR(399,IBIFN,"I"_($$COBN^IBCEF(IBIFN)+1)) < . W !,"There is no next payer for this bill" < . D PAUSE^VALM1 < . Q < ; < D DSPRB^IBCCCB0(IBIFN) ; display related bills < S IBCE("EDI")=1 < D CHKB^IBCCCB ; process COB, create s < S IBIFN=IBIFNH < I IBSECHK G COBCOPX < S IBV=1 D VIEW^IBCB2 ; display billing scree < D AUTH ; authorize bill < COBCOPX ; < Q < ; < AUTH ; procedure to authorize the claim and refresh the sc < K ^UTILITY($J) S IBAC=1,IBQUIT=0 D 3^IBCB1 < I '$D(IOUON)!'$D(IORVON) D ENS^%ZISS < I $P($G(^IBM(361.1,IBMRAIEN,0)),U,16)=3 D UPDEDI^IBCE < I $G(IBBLD)'="" D @IBBLD < D PAUSE^VALM1 < AUTHX ; < EBI ;View an unauthorized transmitted bill | EBI ;Edit an unauthorized transmitted bill N IBFLG,IBDA,IBIFN,IB364,DFN | N IBFLG,IBDA,IBIFN,IB364 S IBDA=+$O(IBDA("")) | S IBDA=$O(IBDA("")) S IBIFN=+$G(IBDA(IBDA)),IB364=+$P($G(IBDA(IBDA)),U,2) | S IBIFN=+$G(IBDA(IBDA)),IB364=+$P($G(IBDA(IBDA)),U,2) S IBV=1 D VIEW^IBCB2 | S IBFLG=1 D I IBFLG S IBDA="" D PAUSE^VALM1 G EDITQ I '$D(IOUON)!'$D(IORVON) D ENS^%ZISS | . I $P($G(^DGCR(399,IBIFN,0)),U,13)>2 W !,*7,"An auth > . I '$D(^XUSEC("IB EDIT",DUZ)) W !,*7,"You are not au > . S IBFLG=0 > S IB3611=$P(IBDA(IBDA),U,4) > G:'$$LOCK^IBCEU0(361.1,IB3611) EDITQ > D EBILL^IBCEM3(.IBDA,IBIFN,IB364) > D UNLOCK^IBCEU0(361.1,IB3611) diff -y --suppress-common-lines ./VADemo/r1/IBCECOB3.m ./VADemo/r2/r/IBCECOB3.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 W ?42,"SORT BY: "_$S(IBSRT="A":"AUTHORIZING/REQUESTIN | W ?42,"SORT BY: "_$S(IBSRT="A":"AUTHORIZING/REQUESTIN W !,?13,"DATE OF",?24,"BILLED",?36,"AMOUNT",?48,"BALA | W !,?13,"DATE OF",?24,"BILLED",?36,"AMOUNT",?48,"BALA diff -y --suppress-common-lines ./VADemo/r1/IBCECOB5.m ./VADemo/r2/r/IBCECOB5.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N IB,IBIFN,IBVCNT,X,Z,IBCNT,CNT,IBREC,IBIFN1,IBPTRESP | N IB,IBIFN,IBVCNT,X,Z S IB=$G(^TMP("IBCECOB1",$J,IBDA)),IBCNT=$P(IB,"^",10) | S IB=$G(^TMP("IBCECOB1",$J,IBDA)) S X=$E(" Original Billed Amt: $"_$$A10^IBCECSA5(+$P(I | S X=$E(" Original Billed Amt: $"_$J(+$P(IB,U,2),0,2)_ S X=X_$S($G(IBSRC):" Total A/R Payments: $"_$$A10^I | S X=X_" Total A/R Payments: $"_$J($P(IB,U,3),0,2) ; | S X=$E(" Bill Balance: $"_$J(+$P(IB,U,4),0,2)_ S IBIFN1=$P($G(^IBM(361.1,IBCNT,0)),U,1) ; bill# | S X=X_$S('$$WNRBILL^IBEFUNC(IBIFN):" Total Amt S IBPTRESP=$P($G(^IBM(361.1,IBCNT,1)),U,2) ; Pt Re < ; Override Pt Resp Amt for bills with Form Type UB92 < I $$FT^IBCEF(IBIFN1)=3 S IBPTRESP=$$PTRESPI^IBCECOB1( < ; < S X=$E($S($G(IBSRC):" Bill Balance: $"_$$A10^I < I '$G(IBSRC) N IBCALC,IBIFN S IBIFN=+$G(^IBM(361.1,IB < S X=X_$S($G(IBSRC):" Total Amt This EOB: $"_$$A < I $G(IBSRC) D | S X=" Days Since Last Transmit: "_+$P(IB,U,12) . S X=" Days Since Last Transmit: "_+$P(IB,U,12) | D SET(X) . D SET(X) | S X=" Authorizing Biller: "_$P(IB,U,8) . S X=" Authorizing Biller: "_$P(IB,U,8) | D SET(X) . D SET(X) | S X=" COB History: " . S X=" COB History: " | I $P(IB,U,11)'="" D . I $P(IB,U,11)'="" D | . F Z=1:1:$L($P(IB,U,11),";") S X=X_$P($P(IB,U,11),"; .. F Z=1:1:$L($P(IB,U,11),";") S X=X_$P($P(IB,U,11)," | E D . E D | . S X=X_"NONE FOUND" D SET(X) .. S X=X_"NONE FOUND" D SET(X) < I '$G(IBSRC) S CNT=20,IBREC=$G(^IBM(361.1,IBCNT,0)) K < ; < S VALMHDR(3)=" "_IOUON_"Svc Date Patient Name/Last | S VALMHDR(3)=" "_IOUON_"Svc Date Patient Name/Last diff -y --suppress-common-lines ./VADemo/r1/IBCECOB.m ./VADemo/r2/r/IBCECOB.m ;;2.0;INTEGRATED BILLING;**137,155,288**;21-MAR-1994 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994 K IBSRT,IBMRADUP | K IBSRT D EN^VALM("IBCEM MRA MANAGEMENT") | D EN^VALM("IBCEM EOB MANAGEMENT") S IB1=1 | S DIR("A",1)="Select: (O)nly bills where COB may be p W ! | S DIR("A")=$J("",8)_"(B)oth COB possible bills and ot F S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Select "_ | S DIR(0)="SMA^0:Only bills with COB possibility;B:Bot > S DIR("?",1)="Enter 'O' for only bills that may have > S DIR("?",3)=$J("",30)_"or" > S DIR("?",4)=$J("",6)_"'B' for both bills with COB po > D ^DIR K DIR > I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q > S IBNY=(Y="B"),IB1=1 > F S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Select "_ ; | S DIR("A")="Sort By: ",DIR("B")="AUTHORIZING BILLER" S DIR("A")="Sort By: ",DIR("B")="BILLER" | S DIR(0)="SBA^A:AUTHORIZING BILLER;D:DAYS SINCE TRANS S DIR(0)="SBA^B:BILLER;D:DAYS SINCE TRANSMISSION OF L < ; < W ! < S IBMRADUP=0 < S DIR("A")="Do you want to include Denied MRAs for Du < D ^DIR K DIR < I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 G INITQ < I Y S IBMRADUP=1 < ; < K ^TMP("IBCECOB1",$J),^TMP("IBCOBSTX",$J) < ; < NEW IBDA,IBIFN,LSTENTRY | D SEL^IBCECOB2(.IBDA,1) D SEL^IBCECOB2(.IBDA,1) ; selec | I '$O(IBDA(0)) G EXPQ S LSTENTRY=+$O(IBDA(0)) I 'LSTENTRY G EXPQ ; list | D EN^VALM("IBCEM EOB DETAIL") S IBIFN=+$G(IBDA(LSTENTRY)) I 'IBIFN G EXPQ ; bill# | EXPQ S VALMBCK="R" ; | ; ; If only one MRA on file, call the listman screen an < I $$MRACNT^IBCEMU1(IBIFN)=1 D EN^VALM("IBCEM MRA DETA < ; < EXPLOOP ; At this point, we know there are multiple MRA's on < ; < D FULL^VALM1 < I $$SEL^IBCEMU1(IBIFN,1,LSTENTRY) D G EXPLOOP ; MRA < . NEW IBIFN,LSTENTRY,IBDASAVE ; pro < . M IBDASAVE=IBDA ; sav < . D EN^VALM("IBCEM MRA DETAIL") ; cal < . M IBDA=IBDASAVE ; res < . Q < EXPQ ; < S VALMBCK="R" < diff -y --suppress-common-lines ./VADemo/r1/IBCECSA1.m ./VADemo/r2/r/IBCECSA1.m ;;2.0;INTEGRATED BILLING;**137,283,288**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N IBDA,IBREV,IBIFN,IBPAY,IBSSN,IBSER,IB399,IBLOC,IBDI | N IBDA,IBREV,IBIFN,IBPAY,IBSSN,IBSER,IB399,IBLOC,IBDI S IBSEV=$G(IBSEV,"R") < S SEVERITY="" | S IBREV="" F S IBREV=$O(^IBM(361,"AREV",IBREV)) Q:$S F S SEVERITY=$O(^IBM(361,"ACSA",SEVERITY)) Q:SEVERIT < > . I $G(IBSEV)="R",$P(IB,U,3)'="R" Q > . ;add No EOB bill check here in future . ; < . ; no cancelled claims allowed on the CSA screen < . ; if we find one, then update the appropriate EDI f < . I $P(IB399,U,13)=7 D UPDEDI^IBCEM(+$P(IB,U,11),"C") < . ; < . ; < . ; If Request MRA bill, pull the MRA Requestor user < . I 'IBUER,$P(IB399,U,13)=2 S IBUER=+$P($G(^DGCR(399, < . I IBPAY="" S IBPAY=$P($G(^DIC(36,+$$CURR^IBCEF2(IBI < . I IBPAY="" S IBPAY="UNKNOWN PAYER" < diff -y --suppress-common-lines ./VADemo/r1/IBCECSA4.m ./VADemo/r2/r/IBCECSA4.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-1994 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994 N IBIFN,IBX,IBA,IBRESUB | N IBIFN,IBX,IBA,IBESUB I "34"'[$P($G(^DGCR(399,IBIFN,0)),U,13) W !!,"Bill st < N IBIFN,IB364,IBX,IBA,MRACHK | N IBIFN,IB364,IBX,IBA ; Check for security key < I '$$KCHK^XUSRB("IB AUTHORIZE") D G CANCELQ < . W !!?5,"You don't hold the proper security key to a < . W !?5,"The necessary key is IB AUTHORIZE. Please s < . D PAUSE^VALM1 < . Q < D MRACHK I MRACHK G CANCELQ < CANCELQ S VALMBCK="R" | S VALMBCK="R" N IBX,IBA,IB364,MRACHK,IBIFN | N IBX,IBA,IB364 S IBDAX=$O(IBDAX("")),IBIFN=+$P($G(IBDAX(IBDAX)),U) | S IBDAX=$O(IBDAX("")) ; Check for security key < I '$$KCHK^XUSRB("IB AUTHORIZE") D G CLONEQ < . W !!?5,"You don't hold the proper security key to a < . W !?5,"The necessary key is IB AUTHORIZE. Please s < . D PAUSE^VALM1 < . Q < D MRACHK I MRACHK G CLONEQ < ; < I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D G PROQ < . W !!?4,"This bill is in a status of REQUEST MRA." < . I $$CHK^IBCEMU1(IBIFN) W !?4,"MRA EOBs must be proc < . E W !?4,"There are no MRA EOBs on file." < . D PAUSE^VALM1 < . Q < ; < I IBIFN D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364),PAUSE^VA | I IBIFN D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364),INIT^IBC RESUB(IBIFN,TXMT,IBFUNC,IBTBA) ; Function asks if resubmit a | RESUB(IBIFN,TXMT,IBFUNC) ; Function asks if resubmit a ; IBTBA = transmit bill array returned to calling rou < ; parameter to be passed by reference. < ; IBTBA(364ptr)="" < ; 1 = don't update the review status (user choice) | ; 1 = not resubmit by print ; 2 = Yes, update the review status (user choice), o | ; 2 = resubmit by print ; < NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,STAT < KILL IBTBA < I '$G(TXMT),'$$TXMT^IBCEF4(IBIFN) S Y=0 G RESUB1 ; < > I '$G(TXMT),'$$TXMT^IBCEF4(IBIFN) S Y=0 G RESUB1 S STAT=$$STATUS^IBCEF4(IBIFN) | I '$TR($$STATUS^IBCEF4(IBIFN),U) S Y=0 G RESUB1 I '$TR(STAT,U) S Y=0 G RESUB1 ; no unr < I $P(STAT,U,1) S IBTBA($P(STAT,U,1))="" ; 364 ie < I $P(STAT,U,2) S IBTBA($P(STAT,U,2))="" ; 364 ie < . I $D(DTOUT)!$D(DUOUT) S Y=-1 Q | . I $D(DTOUT)!$D(DUOUT) S Y=-1 N IB364,IBIFN | N IB364 S IBDAX=$O(IBDAX(0)),IB364=+$P($G(IBDAX(IBDAX)),U,5), | S IB364=+$P($G(IBDAX(+$O(IBDAX(0)))),U,5) I 'IB364!('IBIFN) G RETXMTQ < D MRACHK I MRACHK G RETXMTQ < RETXMTQ S VALMBCK="R" | S VALMBCK="R" MRACHK ; Restrict access to process REQUEST MRA claims < S MRACHK=0 < ; At least one MRA EOB appears on the MRA management < I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,$$MRAWL^IBCEMU2(I < . W !,?4,"This bill is in a status of REQUEST MRA and < . W !,?4,"the MRA Management Worklist. Please use th < . W !,?4,"options for all processing related to this < Q < diff -y --suppress-common-lines ./VADemo/r1/IBCECSA5.m ./VADemo/r2/r/IBCECSA5.m ;;2.0;INTEGRATED BILLING;**137,135,263,280,155**;21-M | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994 I '$G(IBIFN) S VALMQUIT="" G INITQ ; bill# is requ | I '$G(IBIFN) S VALMQUIT="" G INITQ D HDR^IBCEOB2 ; build the VAL | D HDR^IBCEOB2,BLD^IBCEOB2 K IBCNT,IBONE,^TMP("IBCECSD",$J) ; kill vars and | K IBCNT,IBONE,^TMP("IBCECSD",$J) ; < ; 8/13/03 - If variable IBEOBIFN is set, then this is < ; that the user selected from a list. Buil < I $G(IBEOBIFN) S IBCNT=IBEOBIFN,IBONE=1 D BLD^IBCECSA < ; < D BLD^IBCEOB2 ; build ^TMP("IBCEOB",$J) containing < ; < ; 4/7/03 - If only 1 EOB record found for this bill, < ; IBCNT variable, the IBONE one-time flag, a < ; detail sections of this list. < I $G(VALMCNT)=1 S IBCNT=$P($G(^TMP("IBCECSD",$J,1)),U < ; < N IBREC1,IBRM1,IBRM2,IBRM3,IBRM4,IBRM5,IBRL,IBTYPE,IB | N IBREC1,IBRM1,IBRM2,IBRM3,IBRM4,IBRM5 ; flag for inpatient mra < S IBTYPE=$S($G(IBSRC):1,$$INPAT^IBCEF(+IBREC):1,1:0) < ; < D SET(IB) | D SET^IBCECSA6(IB,CNT,IBCNT) I '$G(IBSRC) D | D CNTRL^VALM10(VALMCNT,1,21,IORVON,IORVOFF) . D CNTRL^VALM10(VALMCNT,1,21,IORVON,IORVOFF) | S ^TMP("IBCECSD",$J,"X",5)=VALMCNT . S ^TMP("IBCECSD",$J,"X",5)=VALMCNT | I '$D(^IBM(361.1,IBCNT,4)) Q I $G(IBSRC),'$D(^IBM(361.1,IBCNT,4)) Q | D SET^IBCECSA6(" INPATIENT:",CNT,IBCNT) I '$G(IBSRC),'$$INPAT^IBCEF(+IBREC) Q | S IBREC1=$G(^IBM(361.1,IBCNT,4)) D SET(" INPATIENT:") | S IB=$$SETSTR^VALM1("Cov Days/Visit Ct : "_$P(IBREC1 S IBREC1=$G(^IBM(361.1,IBCNT,4)),(IB,IBRL)="" | S IB=$$SETSTR^VALM1("Claim DGR Amt : "_$J($P(IBR ; | D SET^IBCECSA6(IB,CNT,IBCNT) F IBT=2:1 S IBTX=$P($T(MINDAT+IBT),";",3) Q:IBTX="" | S IB=$$SETSTR^VALM1("Lifetm Psych Dy Ct : "_$P(IBREC1 . S IBD=$P(IBREC1,"^",+IBTX) | S IB=$$SETSTR^VALM1("Disprop Share Amt : "_$J($P(IBR . I $L($P(IBTX,"^",4)) X $P(IBTX,"^",4) E N IBFULL S | D SET^IBCECSA6(IB,CNT,IBCNT) . I $S(IBFULL:1,1:IBD) D | S IB=$$SETSTR^VALM1("Cap Exception Amt : "_$J($P(IBR .. I $L($P(IBTX,"^",4)) X $P(IBTX,"^",4) I Q | S IB=$$SETSTR^VALM1("PPS Capital Amt : "_$J($P(IBR .. X "S IBD="_$S($L($P(IBTX,"^",3)):$P(IBTX,"^",3),1: | D SET^IBCECSA6(IB,CNT,IBCNT) .. S IB=$$SETSTR^VALM1($P(IBTX,"^",2)_IBD,IB,$S('IBRL | S IB=$$SETSTR^VALM1("MSP Pass Thru Amt : "_$J($P(IBR .. S IBRL=$S(IBRL:0,1:1) | S IB=$$SETSTR^VALM1("PPS Cap HSP-DRG Amt: "_$J($P(IBR .. I 'IBRL D SET(IB,IBRL) S IB="" | D SET^IBCECSA6(IB,CNT,IBCNT) ; | S IB=$$SETSTR^VALM1("PPS Cap FSP-DRG Amt: "_$J($P(IBR D:IBRL'="" SET(IB) | S IB=$$SETSTR^VALM1("Old Capital Amt : "_$J($P(IBR D REMARK | D SET^IBCECSA6(IB,CNT,IBCNT) > S IB=$$SETSTR^VALM1("PPS Cap DSH-DRG Amt: "_$J($P(IBR > S IB=$$SETSTR^VALM1("PPS Op Hos DRG Amt : "_$J($P(IBR > D SET^IBCECSA6(IB,CNT,IBCNT) > S IB=$$SETSTR^VALM1("PPS Capital IME Amt: "_$J($P(IBR > S IB=$$SETSTR^VALM1("PPS Op Fed DRG Amt : "_$J($P(IBR > D SET^IBCECSA6(IB,CNT,IBCNT) > S IB=$$SETSTR^VALM1("Cost Report Day Ct : "_$P(IBREC1 > S IB=$$SETSTR^VALM1("Indirect Teach Amt : "_$J($P(IBR > D SET^IBCECSA6(IB,CNT,IBCNT) > S IB=$$SETSTR^VALM1("PPS Cap Outlier Amt: "_$J($P(IBR > S IB=$$SETSTR^VALM1("Non-Pay Prof Comp : "_$J($P(IBR > D SET^IBCECSA6(IB,CNT,IBCNT) > D SET^IBCECSA6(" REMARK:",CNT,IBCNT) > D SET^IBCECSA6(" CODE SHORT DESCRIPTION",CNT,IBC > S IBREC1=$G(^IBM(361.1,IBCNT,5)) > S IB=$$SETSTR^VALM1($P(IBREC1,U),"",4,11) > F I=1:1:5 S @("IBRM"_I)=$G(^IBM(361.1,IBCNT,"RM"_I)) > S IB=$$SETSTR^VALM1($E(IBRM1,1,67),IB,12,79) > D SET^IBCECSA6(IB,CNT,IBCNT) > D TXT(IBRM1,67,12) > S IB=$$SETSTR^VALM1($P(IBREC1,U,2),"",4,11) > S IB=$$SETSTR^VALM1($E(IBRM2,1,67),IB,12,79) > D SET^IBCECSA6(IB,CNT,IBCNT) > D TXT(IBRM2,67,12) > S IB=$$SETSTR^VALM1($P(IBREC1,U,3),"",4,11) > S IB=$$SETSTR^VALM1($E(IBRM3,1,67),IB,12,79) > D SET^IBCECSA6(IB,CNT,IBCNT) > D TXT(IBRM3,67,12) > S IB=$$SETSTR^VALM1($P(IBREC1,U,4),"",4,11) > S IB=$$SETSTR^VALM1($E(IBRM4,1,67),IB,12,79) > D SET^IBCECSA6(IB,CNT,IBCNT) > D TXT(IBRM4,67,12) > S IB=$$SETSTR^VALM1($P(IBREC1,U,5),"",4,11) > S IB=$$SETSTR^VALM1($E(IBRM5,1,67),IB,12,79) > D SET^IBCECSA6(IB,CNT,IBCNT) > D TXT(IBRM5,67,12) > Q > LLVLA ;line level adjustment > N Y,Z,I,J,IBREC > S IB=$$SETSTR^VALM1("LINE LEVEL ADJUSTMENTS:","",1,50 > D SET^IBCECSA6(IB,CNT,IBCNT) > D CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF) > S ^TMP("IBCECSD",$J,"X",7)=VALMCNT > I '$D(^IBM(361.1,IBCNT,15)) D SET^IBCECSA6(" NONE",CN > D SET^IBCECSA6(" PAYER ID: "_$P($G(^IBM(361.1,IBCNT,0 > D SET^IBCECSA6(" ---------- AMOUNT ----------",CNT,I > S IB=$$SETSTR^VALM1("#","",2,2) > S IB=$$SETSTR^VALM1("ALLOWED",IB,5,11) > S IB=$$SETSTR^VALM1("PAID",IB,17,11) > S IB=$$SETSTR^VALM1("PER DIEM",IB,29,10) > S IB=$$SETSTR^VALM1("PROCEDURE/MODS",IB,40,19) > S IB=$$SETSTR^VALM1("REV CD",IB,60,8) > S IB=$$SETSTR^VALM1("PD UNITS",IB,69,79) > D SET^IBCECSA6(IB,CNT,IBCNT) > S Y=0 F J=1:1 S Y=$O(^IBM(361.1,IBCNT,15,Y)) Q:'Y D > . S IBREC=$G(^IBM(361.1,IBCNT,15,Y,0)) > . S IB=$$SETSTR^VALM1(J,"",2,2) > . S IB=$$SETSTR^VALM1($E($J($P(IBREC,U,13),0,2),1,10) > . S IB=$$SETSTR^VALM1($E($J($P(IBREC,U,3),0,2),1,10), > . S IB=$$SETSTR^VALM1($E($J($P(IBREC,U,14),0,2),1,10) > . S Z=0,I="" F S Z=$O(^IBM(361.1,IBCNT,15,Y,2,Z)) Q: > . S IB=$$SETSTR^VALM1($E($P($G(^ICD0(+$P(IBREC,U,4),0 > . S IB=$$SETSTR^VALM1($E($P($G(^DGCR(399.2,+$P(IBREC, > . S IB=$$SETSTR^VALM1($E($P(IBREC,U,11),1,10),IB,69,7 > . D SET^IBCECSA6(IB,CNT,IBCNT) > D SET^IBCECSA6(" DESCRIPTION: "_$E($P(IBREC,U,9),1, > Q > RDATA ; > N IBRM,IBREC,IBFLG,IBFST > S IB=$$SETSTR^VALM1("REVIEW DATA:","",1,50) > D SET^IBCECSA6(IB,CNT,IBCNT) > D CNTRL^VALM10(VALMCNT,1,12,IORVON,IORVOFF) > S ^TMP("IBCECSD",$J,"X",8)=VALMCNT > S (Y,IBFLG)=0 F S Y=$O(^IBM(361.1,IBCNT,21,Y)) Q:'Y > . S IBREC=$G(^IBM(361.1,IBCNT,21,Y,0)),IBFLG=1 > . D SET^IBCECSA6(" REVIEW DATE/TIME: "_$$FMTE^XLFDT( > . S Z=0,IBFST=1 F S Z=$O(^IBM(361.1,IBCNT,21,Y,1,Z)) > .. S IBRM=$G(^IBM(361.1,IBCNT,21,Y,1,Z,0)) > .. D:IBFST SET^IBCECSA6(" COMMENT:"_$E(IBRM,1,68),CN > .. D TXT(IBRM,68,11) > .. S IBFST=0 > D:'IBFLG SET^IBCECSA6(" NONE",CNT,IBCNT) ; | TXT(IBRM,IBLN,IBXY) ;display text over 79 chars MINDAT ; data for MIN tag < ; format: piece^lable^special format code^special de < ;;1^Cov Days/Visit Ct : ^$$RJ(+IBD)^I $G(IBSRC) < ;;3^Claim DRG Amt : < ;;2^Lifetm Psych Dy Ct : ^$$RJ(IBD) < ;;5^Disprop Share Amt : ^^I IBTYPE < ;;4^Cap Exception Amt : < ;;7^PPS Capital Amt : ^^I IBTYPE < ;;6^MSP Pass Thru Amt : < ;;9^PPS Cap HSP-DRG Amt: ^^I IBTYPE < ;;8^PPS Cap FSP-DRG Amt: ^^I IBTYPE < ;;11^Old Capital Amt : ^^I IBTYPE < ;;10^PPS Cap DSH-DRG Amt: ^^I IBTYPE < ;;13^PPS Op Hos DRG Amt : < ;;12^PPS Capital IME Amt: ^^I IBTYPE < ;;15^PPS Op Fed DRG Amt : ^^I IBTYPE < ;;14^Cost Report Day Ct : ^$$RJ(IBD)^I IBTYPE < ;;17^Indirect Teach Amt : ^^I IBTYPE < ;;16^PPS Cap Outlier Amt: ^^I IBTYPE < ;;18^Non-Pay Prof Comp : ^$$RJ(IBD) < ;;19^Non-Covered Days Ct: ^$$RJ(+IBD)^I IBTYPE < ;; < ; < REMARK ; set up remarks and line level details < N IBREC1,IBP,IBT,IBX,RCODE,RDESC,REXIST < Q:$G(IBREM) S IBREM=1 < D SET(" ") < D SET(" Claim Level Remark Information") < D SET(" Code Description") < I '$G(IBSRC) D < . D CNTRL^VALM10(VALMCNT,4,4,IOUON,IOUOFF) < . D CNTRL^VALM10(VALMCNT,13,11,IOUON,IOUOFF) < . Q < ; < S IBREC1=$P($G(^IBM(361.1,IBCNT,3)),U,3,7) < I $P(IBREC1,U,1)="" S IBREC1=$P($G(^IBM(361.1,IBCNT,5 < S REXIST=0 < ; < F IBP=1:1:5 D < . S RCODE=$P(IBREC1,U,IBP) < . S RDESC=$G(^IBM(361.1,IBCNT,"RM"_IBP)) < . I RCODE="",RDESC="" Q < . S REXIST=1 < . K IBT < . S IBT(IBP)=RDESC < . D TXT1(.IBT,0,60) < . D SET(" "_$$LJ^XLFSTR(RCODE,6)_"- "_$G(IBT(1))) < . S IBX=1 < . F S IBX=$O(IBT(IBX)) Q:'IBX D SET($J("",12)_IBT(I < . Q < ; < I 'REXIST D SET(" No claim level remarks on file") < D SET(" ") < Q:$G(IBSRC) ; MRA Only < ; < MRALLA S IB=$$SETSTR^VALM1("LINE LEVEL ADJUSTMENTS:","",1,50 < D SET(IB) < I '$G(IBSRC) D < . D CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF) < . S ^TMP("IBCECSD",$J,"X",7)=VALMCNT < I '$D(^IBM(361.1,IBCNT,15,0)) D SET("NONE") Q ; only < ; < ; look up all billed data < N IBZDATA,IBFORM,IBX2,IBX3,IBREC2,IBREC3,IBTX,IBT,IBR < S IBFORM=0 ; hcfa-1500 < I $$FT^IBCEF(+IBREC)=3 S IBFORM=1 ; ub92 < D F^IBCEF("N-"_$S(IBFORM:"UB92",1:"HCFA 1500")_" SERV < ; < S IBX=0 F S IBX=$O(^IBM(361.1,IBCNT,15,IBX)) Q:IBX<1 < . NEW RVL < . D SET(" # SV DT REVCD PROC MOD UNITS BILLE < . S RVL=+$P(IBREC1,U,12) ; referenced Vista lin < . I 'RVL S RVL=IBX ; use the EOB line# if < . S IBT=$$RJ($P(IBREC1,"^"),3) ; line num < . S IBT=IBT_" "_$$DAT1^IBOUTL($P($P(IBREC1,"^",16),". < . S IBT=IBT_" "_$$RJ($$EXTERNAL^DILFD(361.115,.1,"",$ < . S IBT=IBT_" "_$$RJ($P(IBREC1,"^",4),5) ; procedur < . S IBT=IBT_" "_$$RJ($P($G(^IBM(361.1,IBCNT,15,IBX,2, < . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",11),"",0),5) ; < . S IBT=IBT_" "_$$RJ($FN($S(IBFORM:$P($G(IBZDATA(RVL) < . S IBT=IBT_" "_$$RJ($FN($P($G(^IBM(361.1,IBCNT,15,IB < . S IBT=IBT_" "_$$RJ($FN($P($G(^IBM(361.1,IBCNT,15,IB < . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",13),"",2),8) ; < . S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",3),"",2),8) ; < . D SET(IBT) < . S IBX2=0 F S IBX2=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX < .. S IBREC2=^IBM(361.1,IBCNT,15,IBX,1,IBX2,0),IBX3=0 < .. F S IBX3=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3 < ... S IBREC3=^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3,0) < ... ; line level adjustments; don't display kludges ( < ... I $P(IBREC2,U,1)="PR",$P(IBREC3,U,1)="AAA" Q < ... I $P(IBREC2,U,1)="OA",$P(IBREC3,U,1)="AB3" Q < ... I $P(IBREC2,U,1)="LQ" Q < ... S IBTX(1)="ADJ: "_$P(IBREC2,"^")_" "_$P(IBREC3," < ... K IBTX < ... D SET("ADJ AMT: "_$FN($P(IBREC3,"^",2),"",2)) < . S IBRC=0 < . F S IBRC=$O(^IBM(361.1,IBCNT,15,IBX,4,IBRC)) Q:'IB < .. S IBTX(1)=IBTX(1)_$P(IBREC2,U,2)_" "_$P(IBREC2,U, < .. I $L(IBTX(1))>79 D < ... D TXT1(.IBTX,0,79) D SET(IBTX(1)) M IBZ=IBTX K IB < .. E D < ... S IBTXL=0 < .. D TXT1(.IBTX,IBTXL,79) S IBT=0 F S IBT=$O(IBTX(IB < . D SET(" ") < D SET(" ") < Q < ; < TXT(IBRM,IBLN,IBXY) ;display text over 79 chars < REP I $E(IBRM,1,IBLN)'="" S IB=$$SETSTR^VALM1($E(IBRM,1,I | REP I $E(IBRM,1,IBLN)'="" S IB=$$SETSTR^VALM1($E(IBRM,1,I Q < ; < SET(IB,IBSAV) ; < I '$G(IBSAV) D SET^IBCECSA6($G(IBSRC),IB,CNT,IBCNT) < ; < A10(X) ; < Q $$A10^IBCECSA6(X) < ; < A7(X) ; returns a dollar amount right justified to 7 charac < Q $$RJ($FN(X,"",2),7) < ; < TXT1(IBT,DIWL,DIWR) ; sets up text for over 79 chars < ; IBT - pass by ref, array of text to be formatted ba < ; DIWL - left margin, DIWR = right margin < N IBX,X,DIWF,IBS K ^UTILITY($J,"W") < S DIWF="|I"_DIWL < S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 S X=IBT(IBX) D < K IBT F S IBX=$O(^UTILITY($J,"W",DIWL,IBX)) Q:IBX<1 < K ^UTILITY($J,"W") < Q < ; < RJ(X,Y) ; right just, default is 10 < Q $$RJ^XLFSTR(X,$G(Y,10)," ") < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCECSA6.m ./VADemo/r2/r/IBCECSA6.m ;;2.0;INTEGRATED BILLING;**137,135,155**;21-MAR-1994 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994 ; | BLD ;build EOB data BLD ;build EOB data display | N IBREC,IBTYP D GETEOB(IBCNT,0) | S VALMCNT=0,CNT=0,VALMBG=1 Q < ; < GETEOB(IBCNT,IBSRC,IBFULL,IBJTIBLN) ; Get EOB data in dis < ; IBCNT = the ien of the entry in file 361.1 < ; IBSRC = 1 if called from AR, 0 if List Manager form < ; = 2 if called from AR and header data is desi < ; If IBSRC > 0 ^TMP("PRCA_EOB",$J,IBCNT,n)=line n' < ; IBFULL = 1 if no check should be made to eliminate < ; IBJTIBLN = line number to start VALMCNT with (optio < ; used by IBJTBA1 < ; < N IBREC,IBTYP,CNT,IBREM < S IBFULL=$G(IBFULL),IBSRC=$G(IBSRC) < I IBSRC N VALMBG,VALMCNT < S VALMCNT=0,VALMBG=1,CNT=0 < I $G(IBJTIBLN)>0 S VALMCNT=IBJTIBLN < I IBSRC K ^TMP("PRCA_EOB",$J,IBCNT) | D GEN,PAY,CLVL,CLVLA,MIN^IBCECSA5,MOUT,LLVLA^IBCECSA5 ; Once we're displaying a single EOB, remove the mult < ; the View EOB screen that was set in HDR^IBCEOB2 - V < I 'IBSRC,$G(VALMHDR(4))'="" S VALMHDR(4)="" < D GEN,PAY,ARCP^IBCECSA7,CLVL,CLVLA,MIN^IBCECSA5,MOUT, < ; < I '$G(IBONE) D SEL(.IBCNT,1) D BLD:$G(IBCNT) | I 'IBONE D SEL(.IBCNT,1) D BLD:$G(IBCNT) SET(IBSRC,X,CNT,IBCNT) ;set list manager arrays | SET(X,CNT,IBCNT) ;set list manager arrays S VALMCNT=VALMCNT+1,IBSRC=$G(IBSRC) | S VALMCNT=VALMCNT+1 ; < I IBSRC D Q < . S ^TMP("PRCA_EOB",$J,IBCNT,VALMCNT)=X < ; < ; < S IBSRC=$G(IBSRC) Q:IBSRC=1 | N IBREC1,IBTMP N IBREC1,IBTMP,IBSPL < S IBSPL=+$O(^IBM(361.1,IBCNT,8,0)),IBSPL=(+$O(^(IBSPL < D SET(IBSRC,IB,CNT,IBCNT) | D SET(IB,CNT,IBCNT) I 'IBSRC D | D CNTRL^VALM10(VALMCNT,1,24,IORVON,IORVOFF) . D CNTRL^VALM10(VALMCNT,1,24,IORVON,IORVOFF) | S ^TMP("IBCECSD",$J,"X",1)=VALMCNT . S ^TMP("IBCECSD",$J,"X",1)=VALMCNT | S IB=$$SETSTR^VALM1("Type : "_$S(IBTYP:"MEDICA S IB=$$SETSTR^VALM1("Type : "_$S(IBTYP:"MEDICA | S IB=$$SETSTR^VALM1("EOB Dt/Tm : "_$$FMTE^XLFDT($P S IB=$$SETSTR^VALM1("EOB Paid DT : "_$$DAT1^IBOUTL($ | D SET(IB,CNT,IBCNT) D SET(IBSRC,IB,CNT,IBCNT) | S IB=$$SETSTR^VALM1("Entry Dt/Tm : "_$$FMTE^XLFDT($P( I IBSRC D | S IBTMP=$P(IBREC,U,13) . S IB=$$SETSTR^VALM1($S(IBSRC:"Entry Dt/Tm :"_$$DAT1 | S IB=$$SETSTR^VALM1("Claim Status : "_$S(IBTMP=1:"PRO . S IBTMP=$P(IBREC,U,13) | D SET(IB,CNT,IBCNT) . S IB=$$SETSTR^VALM1("Claim Status : "_$$EXTERNAL^DI | S IB=$$SETSTR^VALM1("Manual Entry: "_$S($P(IBREC,U,17 . D SET(IBSRC,IB,CNT,IBCNT) | S IBTMP=$P(IBREC,U,16) . S IBTMP=$P(IBREC,U,16) | S IB=$$SETSTR^VALM1("Review Status: "_$S(IBTMP=1:"REV . S IB=$$SETSTR^VALM1("Review Status: "_$$EXTERNAL^DI | D SET(IB,CNT,IBCNT) . D SET(IBSRC,IB,CNT,IBCNT) | S IB=$$SETSTR^VALM1("Entered By : "_$P($G(^VA(200,+$ . S IB=$$SETSTR^VALM1("Entered By : "_$P($G(^VA(200, | S IBTMP=$P(IBREC,U,15) . S IBTMP=$P(IBREC,U,15) | S IB=$$SETSTR^VALM1("Insurance Seq: "_$S(IBTMP=1:"PRI . S IB=$$SETSTR^VALM1("Insurance Seq: "_$$EXTERNAL^DI | D SET(IB,CNT,IBCNT) . D SET(IBSRC,IB,CNT,IBCNT) < I 'IBSRC D < . S IB=$$SETSTR^VALM1($S($P(IBREC,U,17):"Manual Entry < . S IBTMP=$P(IBREC,U,13) < . S IB=$$SETSTR^VALM1("Claim Status : "_$$EXTERNAL^DI < . D SET(IBSRC,IB,CNT,IBCNT) < . S IBTMP=$P(IBREC,U,15) < . S IB=$$SETSTR^VALM1("Insurance Seq: "_$$EXTERNAL^DI < . D SET(IBSRC,IB,CNT,IBCNT) < I $S($G(IBFULL):1,1:$P(IBREC1,U,4)'=""!($P(IBREC1,U,3 | S IB=$$SETSTR^VALM1("Last Edited : "_$$DAT1^IBOUTL($P . S IB=$$SETSTR^VALM1("Last Edited : "_$$DAT1^IBOUTL( | S IB=$$SETSTR^VALM1("Last Edit By : "_$P($G(^VA(200,+ . S IB=$$SETSTR^VALM1("Last Edit By : "_$P($G(^VA(200 | D SET(IB,CNT,IBCNT) . D SET(IBSRC,IB,CNT,IBCNT) | S IB=$$SETSTR^VALM1("New Pat. Nm.: "_$P($G(^IBM(361.1 ; | S IB=$$SETSTR^VALM1("New Pat. Id : "_$P($G(^IBM(361. D INSINF^IBCECSA7(+IBREC,CNT,IBCNT) | D SET(IB,CNT,IBCNT) ; < I $S($G(IBFULL):1,1:$P($G(^IBM(361.1,IBCNT,6)),U)'="" < . S IB=$$SETSTR^VALM1("New Pat. Nm.: "_$P($G(^IBM(361 < . S IB=$$SETSTR^VALM1("New Pat. Id : "_$P($G(^IBM(36 < . D SET(IBSRC,IB,CNT,IBCNT) < D:IBSRC SET(IBSRC,"",CNT,IBCNT) < ; < S IBSRC=$G(IBSRC) Q:IBSRC=1 < D SET(IBSRC,IB,CNT,IBCNT) | D SET(IB,CNT,IBCNT) I 'IBSRC D | D CNTRL^VALM10(VALMCNT,1,18,IORVON,IORVOFF) . D CNTRL^VALM10(VALMCNT,1,18,IORVON,IORVOFF) | S ^TMP("IBCECSD",$J,"X",2)=VALMCNT . S ^TMP("IBCECSD",$J,"X",2)=VALMCNT | S IB=$$SETSTR^VALM1("Payer Name : "_$P($G(^DIC(36,+ S IB=$$SETSTR^VALM1("Payer Name : "_$P($G(^DIC(36,+ | S IB=$$SETSTR^VALM1("Payer Id : "_$P(IBREC,U,3),IB S IB=$$SETSTR^VALM1("Payer Id : "_$P(IBREC,U,3),IB | D SET(IB,CNT,IBCNT) D SET(IBSRC,IB,CNT,IBCNT) | S IB=$$SETSTR^VALM1("ICN : "_$P(IBREC,U,14), S IB=$$SETSTR^VALM1("ICN : "_$P(IBREC,U,14), | D SET(IB,CNT,IBCNT) D SET(IBSRC,IB,CNT,IBCNT) | S IB=$$SETSTR^VALM1("Cross Ovr ID : "_$P(IBREC,U,9)," I $P(IBREC,U,9)'=""!($P(IBREC,U,8)'="") D | S IB=$$SETSTR^VALM1("Cross Ovr Nm: "_$P(IBREC,U,8),IB . S IB=$$SETSTR^VALM1("Cross Ovr ID : "_$P(IBREC,U,9) | D SET(IB,CNT,IBCNT) . S IB=$$SETSTR^VALM1("Cross Ovr Nm: "_$P(IBREC,U,8), < . D SET(IBSRC,IB,CNT,IBCNT) < D:IBSRC SET(IBSRC,"",CNT,IBCNT) < ; < N IBREC1,IBTMP,IBRL | N IBREC1,IBTMP S IB=$$SETSTR^VALM1("CLAIM LEVEL PAY STATUS:","",1,50 | S IB=$$SETSTR^VALM1("CLAIM LEVEL PAY STATUS:","",1,50 D SET(IBSRC,IB,CNT,IBCNT) | D SET(IB,CNT,IBCNT) I 'IBSRC D | D CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF) . D CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF) | S ^TMP("IBCECSD",$J,"X",3)=VALMCNT . S ^TMP("IBCECSD",$J,"X",3)=VALMCNT | I '$D(^IBM(361.1,IBCNT,2)),'$D(^IBM(361.1,IBCNT,1)) D I '$D(^IBM(361.1,IBCNT,2)),'$D(^IBM(361.1,IBCNT,1)) D | S IB=$$SETSTR^VALM1("Tot Submitted Chrg: "_$P($G(^IBM S IB=$$SETSTR^VALM1("Tot Submitted Chrg: "_$$A10($P($ < S IB=$$SETSTR^VALM1("Covered Amt : "_$$A10($P(I | S IB=$$SETSTR^VALM1("Covered Amt : "_$J($P(IBRE D SET(IBSRC,IB,CNT,IBCNT) | D SET(IB,CNT,IBCNT) S IB=$$SETSTR^VALM1("Payer Paid Amt : "_$$A10($P(I | S IB=$$SETSTR^VALM1("Payer Paid Amt : "_$J($P(IBRE S IB=$$SETSTR^VALM1("Patient Resp. Amt : "_$$A10($S(I | S IB=$$SETSTR^VALM1("Patient Resp. Amt : "_$J($P(IBRE D SET(IBSRC,IB,CNT,IBCNT) | D SET(IB,CNT,IBCNT) S (IB,IBRL)="" | S IB=$$SETSTR^VALM1("Discount Amt : "_$J($P(IBRE I $S(IBFULL:1,1:$P(IBREC1,U,4)) S IB=$$SETSTR^VALM1(" | S IB=$$SETSTR^VALM1("Per Day Limit Amt : "_$J($P(IBRE I $S(IBFULL:1,1:$P(IBREC1,U,5)) S IB=$$SETSTR^VALM1(" | D SET(IB,CNT,IBCNT) I $S(IBFULL:1,1:$P(IBREC1,U,8)) S IB=$$SETSTR^VALM1(" | S IB=$$SETSTR^VALM1("Interest Amt : "_$J($P(IBRE I $S(IBFULL:1,1:$P(IBREC1,U,9)) S IB=$$SETSTR^VALM1(" | S IB=$$SETSTR^VALM1("Tax Amt : "_$J($P(IBRE I $S(IBFULL:1,1:$P($G(^IBM(361.1,IBCNT,2)),U,3)) S IB | D SET(IB,CNT,IBCNT) I $S(IBFULL:1,1:$P($G(^IBM(361.1,IBCNT,2)),U,5)) S IB | S IB=$$SETSTR^VALM1("Tot Before Tax Amt: "_$J($P(IBRE I $G(IBSRC) I $S(IBFULL:1,1:$P(IBREC,U,12)) S IB=$$SE | S IB=$$SETSTR^VALM1("Total Allowed Amt : "_$J($P($G(^ I $S(IBFULL:1,1:$P(IBREC,U,10)) S IB=$$SETSTR^VALM1(" | D SET(IB,CNT,IBCNT) I $S(IBFULL:1,1:$P(IBREC,U,11)) S IB=$$SETSTR^VALM1(" | S IB=$$SETSTR^VALM1("Negative Reimb Amt: "_$J($P($G(^ D:IBRL'="" SET(IBSRC,IB,CNT,IBCNT) | S IB=$$SETSTR^VALM1("Discharge Fraction: "_$P(IBREC,U D:IBSRC SET(IBSRC,"",CNT,IBCNT) | D SET(IB,CNT,IBCNT) > S IB=$$SETSTR^VALM1("DRG Code Used : "_$P(IBREC,U > S IB=$$SETSTR^VALM1("DRG Weight Used : "_$P(IBREC,U > D SET(IB,CNT,IBCNT) ; < N IBREC1,IBRL | N IBREC1 S IBREC1=$G(^IBM(361.1,IBCNT,3)),IBSRC=$G(IBSRC) | S IBREC1=$G(^IBM(361.1,IBCNT,3)) I 'IBSRC,$$INPAT^IBCEF(+IBREC),$TR(IBREC1,"0^")="" Q | I IBREC1="" D:'$D(^IBM(361.1,IBCNT,4)) SET(" NONE",C I IBREC1="" D:'$D(^IBM(361.1,IBCNT,4)) SET(IBSRC," N | D SET(" OUTPATIENT:",CNT,IBCNT) D SET(IBSRC," OUTPATIENT:",CNT,IBCNT) | S IB=$$SETSTR^VALM1("Reimburse Rate : "_$J($P(IBRE S IBRL="" | S IB=$$SETSTR^VALM1("Hcpcs Pay Amt : "_$J($P(IBRE I $S(IBFULL:1,1:$P(IBREC1,U)) S IB=$$SETSTR^VALM1("Re | D SET(IB,CNT,IBCNT) I $S(IBFULL:1,1:$P(IBREC1,U,2)) S IB=$$SETSTR^VALM1(" | S IB=$$SETSTR^VALM1("Esrd Paid Amt : "_$J($P(IBRE D:IBRL=0 SET(IBSRC,IB,CNT,IBCNT) | S IB=$$SETSTR^VALM1("Non-Pay Prof Comp : "_$J($P(IBRE I $S(IBFULL:1,1:$P(IBREC1,U,8)) S IB=$$SETSTR^VALM1(" | D SET(IB,CNT,IBCNT) D:IBRL=0 SET(IBSRC,IB,CNT,IBCNT) | D SET(" REMARK:",CNT,IBCNT) I $S(IBFULL:1,1:$P(IBREC1,U,9)) S IB=$$SETSTR^VALM1(" | D SET(" CODE SHORT DESCRIPTION",CNT,IBCNT) D:IBRL'="" SET(IBSRC,IB,CNT,IBCNT) | I $P(IBREC1,U,3) D D REMARK^IBCECSA5 | . S IB=$$SETSTR^VALM1($P(IBREC1,U,3),"",4,79) D SET(IBSRC,"",CNT,IBCNT) | . D SET(IB,CNT,IBCNT) > I $P(IBREC1,U,4) D > . S IB=$$SETSTR^VALM1($P(IBREC1,U,4),"",4,79) > . D SET(IB,CNT,IBCNT) > I $P(IBREC1,U,5) D > . S IB=$$SETSTR^VALM1($P(IBREC1,U,5),"",4,79) > . D SET(IB,CNT,IBCNT) > I $P(IBREC1,U,6) D > . S IB=$$SETSTR^VALM1($P(IBREC1,U,6),"",4,79) > . D SET(IB,CNT,IBCNT) > I $P(IBREC1,U,7) D > . S IB=$$SETSTR^VALM1($P(IBREC1,U,7),"",4,79) > . D SET(IB,CNT,IBCNT) ; < N IBREC,IBFLG,GR,RSN,Z | N IBREC,IBFLG S IB=$$SETSTR^VALM1("CLAIM LEVEL ADJUSTMENTS:","",1,5 | S IB=$$SETSTR^VALM1("CLAIM LEVEL ADJUSTMENTS:","",1,5 D SET(IBSRC,IB,CNT,IBCNT) | D SET(IB,CNT,IBCNT) I 'IBSRC D | D CNTRL^VALM10(VALMCNT,1,24,IORVON,IORVOFF) . D CNTRL^VALM10(VALMCNT,1,24,IORVON,IORVOFF) | S ^TMP("IBCECSD",$J,"X",4)=VALMCNT . S ^TMP("IBCECSD",$J,"X",4)=VALMCNT < . S IBREC=$G(^IBM(361.1,IBCNT,10,Y,0)),GR=$P(IBREC,U, | . S IBREC=$G(^IBM(361.1,IBCNT,10,Y,0)),IBFLG=1 . I GR="OA",$P($G(^IBM(361.1,IBCNT,10,Y,1,0)),U,4)=1, | . S IBREC=$S(IBREC="CO":"CONTRACTUAL OBLIGATIONS",IBR . S IBREC=$$EXTERNAL^DILFD(361.11,.01,"",GR),IBFLG=1 | . D SET(" GROUP CODE: "_IBREC,CNT,IBCNT) . D SET(IBSRC," GROUP CODE: "_IBREC,CNT,IBCNT) < .. S IBREC=$G(^IBM(361.1,IBCNT,10,Y,1,Z,0)),RSN=$P(IB | .. S IBREC=$G(^IBM(361.1,IBCNT,10,Y,1,Z,0)) .. I GR="OA",RSN="AB3" Q ; kludge | .. S IB=$$SETSTR^VALM1("REASON CODE: "_$P(IBREC,U)_" .. S IB=$$SETSTR^VALM1("REASON CODE: "_RSN_" "_$P(IB | .. D SET(IB,CNT,IBCNT) .. D SET(IBSRC,IB,CNT,IBCNT) | .. S IB=$$SETSTR^VALM1("Amount: "_$J($P(IBREC,U,2),0, .. S IB=$$SETSTR^VALM1("Amount: "_$$A10($P(IBREC,U,2) | .. S IB=$$SETSTR^VALM1("Quantity: "_$P(IBREC,U,3),IB, .. S IB=$$SETSTR^VALM1("Quantity: "_$P(IBREC,U,3),IB, | I 'IBFLG D SET(" NONE",CNT,IBCNT) .. D SET(IBSRC,IB,CNT,IBCNT) < I 'IBFLG D SET(IBSRC," NONE",CNT,IBCNT) < D:IBSRC SET(IBSRC,"",CNT,IBCNT) < ; < A10(X) ; returns a dollar amount right justified to 10 chara < Q $$RJ^XLFSTR($FN(X,"",2),10," ") < ; < P10(X) ; returns a % right just 10 < ; X is a decimal between 0-1 < Q $$RJ^XLFSTR((X*100)_"%",10," ") < ; < Only in ./VADemo/r1/: IBCECSA7.m diff -y --suppress-common-lines ./VADemo/r1/IBCEF11.m ./VADemo/r2/r/IBCEF11.m ;;2.0;INTEGRATED BILLING;**51,137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 . I '$G(IBPRINT) D COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA, | . I '$G(IBPRINT) D COBLINE^IBCEU1(IBIFN,IBI,.IBXDATA, diff -y --suppress-common-lines ./VADemo/r1/IBCEF1.m ./VADemo/r2/r/IBCEF1.m ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155**;21 | ;;2.0;INTEGRATED BILLING;**52,124,51,137**;21-MAR-94 . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S | . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U) | I $G(TYPE)="ICD",T["ICD0" S Q=$P($G(^ICD0(+T,0)),U) ; EDT = Effective date to check (not used if +$G(ALL) | ; EDT = Effective date to check N CODE,IBX | N CODE ;Modified for Code Set Versioning | I PRIEN["CPT" S CODE=$$CPT^ICPTCOD(+PRIEN,$G(EDT)),CO I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G: | I PRIEN["ICD" S CODE=$S($G(ALL):U,1:"")_$P($G(^ICD0(+ I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G: < diff -y --suppress-common-lines ./VADemo/r1/IBCEF22.m ./VADemo/r2/r/IBCEF22.m ;;2.0;INTEGRATED BILLING;**51,137,135,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 ; ^ modifiers specific to rev code/proc (separated | ; ^ modifiers specific to rev code/proc (separated N IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBY,IBZ,IBS,IBSS,IBXTR | N IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBZ,IBS,IBSS,IBXTRA,IB . I $$COBN^IBCEF(IBIFN)>1 D COBLINE^IBCEU6(IBIFN,IBLN | . I $$COBN^IBCEF(IBIFN)>1 D COBLINE^IBCEU1(IBIFN,IBLN diff -y --suppress-common-lines ./VADemo/r1/IBCEF2.m ./VADemo/r2/r/IBCEF2.m IBCEF2 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;8/6/03 | IBCEF2 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB- ;;2.0;INTEGRATED BILLING;**52,85,51,137,232,155**;21- | ;;2.0;INTEGRATED BILLING;**52,85,51,137**;21-MAR-94 S NUM="ENVOY"_IBPH ; 155 version | S NUM="ENVOY"_IBPH I NUM["ENVOY",$$MCRWNR^IBEFUNC(+$$CURR(IBIFN)) D ;Fi | I NUM["ENVOY",$$MCRWNR^IBEFUNC(+$$CURR(IBIFN)) D ;Fi . Q:$P(Z1,U,8)=1!$S('$P(Z1,U,9):0,1:$$MRASEC^IBCEF4(I | . Q:$P(Z1,U,8)=1 ;Forced local print . S A=$$UP^XLFSTR(A) < . ; RPRNT = HCFA 1500 Rx bills | . ; RPRNT = HCFA 1500 Rx bills IPRNT = Inst with MR . ; IPRNT = Inst with MRA < . ; Default to appropriate 'xPRNT' if Rx bill or COB | . ; Default to appropriate 'xPRNT' if RX bill or COB . ; print - claims must print at clearinghouse | . ; print - claims must print at Envoy . ; If not a primary bill force to print | . I Z>1,IBMCR=1,Z1="C" S A=$S(IBINST:"I",1:"P")_"PRNT . I Z>1,IBMCR=1,$P(Z1,U,5)="C" S A=$S(IBINST:"I",1:"P | . I A="",$$WNRBILL^IBEFUNC(IBIFN,Z) S A=$S(IBINST:"12 . I $$WNRBILL^IBEFUNC(IBIFN,Z) S A=$S(IBINST:"12M61", < . ; If not a primary bill force to print < . I Z>1,Z=$$COBN^IBCEF(IBIFN) S A=$S(IBINST:"H",1:"S" < ; Determine the current ins co's # to identify at WEB | ; Determine the current ins co's # to identify at Env ; Envoy changed to WEBMD in patch 232 < ; a dx code is an e-code. | ; a dx code is an e-code and to check for max 4 cod ; LN is last entry # output, returned as the entry # | ; LN is the entry # (IBXLINE) to assign to this entry ; DX = the actual Dx code array(RECORD ID). Pass by r | ; DX = the actual Dx code array. Pass by reference, D S VAL="DC"_CT ; **232** | S VAL="DC"_$S(CT<5:CT,1:CT+1) ;Skip 5 for dx ;I 'IBINS,CT>8 S CT="" ;Only 8 codes for professiona | I 'IBINS,CT>4 S CT="" ;Only 4 codes for professional/ . I CT>8 S CT="" Q ;Only 8 codes for institutional/U | . I CT>9 S CT="" Q ;Only 9 codes for institutional/U I 'IBINS,CT>4 S ^TMP("IBXSAVE",$J,"DX",IBXIEN)=$G(^TM | I CT'="",DX'="" D ID(LN,VAL) S ^TMP("IBXSAVE",$J,"DX" I CT'="",DX'="" S LN=LN+1 D ID(LN,VAL) S ^TMP("IBXSAV < AMTOUT(A,B,C,IBXSAVE) ; format output amount < ; < N Z,K,IBZ,IBARR K IBXDATA S (IBZ,K)=0,IBARR="IBXSAVE( < Q < Only in ./VADemo/r1/: IBCEF31.m diff -y --suppress-common-lines ./VADemo/r1/IBCEF3.m ./VADemo/r2/r/IBCEF3.m ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155** | ;;2.0;INTEGRATED BILLING;**52,84,121,51,152**;21-MAR- .. D SETGBL^IBCEFG(PG,57,63,$G(IBXSAVE("PAID")),.IBXS < .. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),I | .. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE") ; esg - 11/14/03 - Moved the below functions due to s | ALLTYP(IBIFN) ; returns codes to translate to ALL ins types ; | ; IBIFN = ien of bill ALLTYP(IBIFN) Q $$ALLTYP^IBCEF31(IBIFN) | N IBX,Z INSTYP(IBIFN,SEQ) Q $$INSTYP^IBCEF31(IBIFN,$G(SEQ)) | F Z=1:1:3 S $P(IBX,U,Z)=$$INSTYP(IBIFN,Z) POLTYP(IBIFN,IBSEQ) Q $$POLTYP^IBCEF31(IBIFN,$G(IBSEQ)) | ; IBX = primary code^secondary code^tertiary code ALLPTYP(IBIFN) Q $$ALLPTYP^IBCEF31(IBIFN) | Q IBX > ; > INSTYP(IBIFN,SEQ) ; Returns insurance type code for an > ; IBIFN = ien of bill > ; SEQ = sequence (1,2,3) of insurance wanted - prim, > ; Default is current insurance co > ; > N IBA,Z > ; > I '$G(SEQ) S SEQ=$$COBN^IBCEF(IBIFN) > S Z=+$G(^DGCR(399,IBIFN,"I"_SEQ)) > ;Codes 1:HMO;2:COMMERCIAL;3:MEDICARE;4:MEDICAID;5:GRO > I Z D > . S IBA=$P($G(^DIC(36,Z,3)),U,9) > . I IBA="" S IBA=5 ;Default is group policy - 5 if bl > ; > Q $G(IBA) > ; > POLTYP(IBIFN,IBSEQ) ; Returns ins electronic policy type > ; ins policy on a bill > ; IBIFN = ien of bill > ; IBSEQ = sequence (1,2,3) of ins policy wanted - pri > ; Default is current insurance co > ; > N IBPLAN,IBPLTYP > ; > I '$G(IBSEQ) S IBSEQ=+$$COBN^IBCEF(IBIFN) > S IBPLAN=$G(^IBA(355.3,+$P($G(^DGCR(399,IBIFN,"I"_IBS > S IBPLTYP=$P(IBPLAN,U,15) > I IBPLTYP="" S IBPLTYP="CI" ;Default is commercial - > I IBPLTYP="MX" D > . I $P(IBPLAN,U,14)'="","AB"[$P(IBPLAN,U,14) S IBPLTY > . S IBPLTYP="CI" > Q $G(IBPLTYP) > ; > ALLPTYP(IBIFN) ; returns insurance policy type codes for ALL > ; IBIFN = ien of bill > N IBX,Z > F Z=1:1:3 I $D(^DGCR(399,IBIFN,"I"_Z)) S $P(IBX,U,Z)= > ; IBX = primary code^secondary code^tertiary code > Q IBX S DATA=$P($$ICD9^IBACSV(+DATA),U) | S DATA=$P($G(^ICD9(+DATA,0)),U) diff -y --suppress-common-lines ./VADemo/r1/IBCEF4.m ./VADemo/r2/r/IBCEF4.m ;;2.0;INTEGRATED BILLING;**51,137,232,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 EDIACTV(IBEDIMRA) ; Returns 0 if EDI or MRA is not acti | EDIACTV(IBIFN,IBMRA) ; Returns 0 if EDI is off or if EDI/M ; otherwise, returns 1 | ; is not active, otherwise, returns 1 ; IBEDIMRA : 1= checking if EDI is active, 2= checkin | ; IBMRA = 1 if EDI bill, 2 if MRA bill Q $S('IBEDI:0,IBEDI=3:1,1:IBEDI=IBEDIMRA) | Q $S('IBEDI:0,IBEDI=3:1,1:IBEDI=IBMRA) ; 6 if Rx with missing/invalid NDC | N IB,IB0,IBOK,IBCOB,IBMCR ; < N IB,IB0,IBOK,IBCOB,IBMCR,X1 < S IBMCR=$$MCRWNR^IBEFUNC(IB(.07)) | S IBMCR=0 ;$$MCRWNR^IBEFUNC(IB(.07)) ; Does bill have force local print flag set? | ; Does bill have force local print flag set? - never I 'IBMCR D G:IBWHY TXMTQ ; MCR WNR not curr ins | I 'IBMCR,$P($G(^DGCR(399,IBIFN,"TX")),U,8)=1 S IBOK=0 . I $S($$MRASEC(IBIFN):$P($G(^DGCR(399,IBIFN,"TX")),U | ; Don't transmit prosthetics bills - must print local > ; I $$ISPROS^IBCEF1(IBIFN) S IBOK=0 G TXMTQ S X1=$$EDIACTV(IB(.03)) | S X1=$$EDIACTV(IBIFN,IB(.03)) I 'IBWHY,$$ISRX^IBCEF1(IBIFN) D ;S:'X1 IBWHY=6 < . ; Check for Rxs and NDC # format valid (5-4-2) < . ;IF THIS IS A UB92 DO NOT SEND ELECTRONIC < . I $$FT^IBCEF(IBIFN)=3 S IBWHY=1 < . ; < . Q ;;CHECK REMOVAL SO NON NDC FORMAT NUMBERS WILL G < . N Z,Z0,Z00 < . S Z="" F S Z=$O(^IBA(362.4,"AIFN"_IBIFN,Z)) Q:Z="" < .. S Z0=0 F S Z0=$O(^IBA(362.4,"AIFN"_IBIFN,Z,Z0)) Q < ... S Z00=$G(^IBA(362.4,Z0,0)) < ... Q:$S($P(Z00,U,8)="":1,1:$L($P(Z00,U,8))=11) < ... I $P(Z00,U,9)'=4 S X1=0 < MRASEC(IBIFN) ; Returns 1 if current bill is secondary to M < N IBSEQ,IB,Z < S IB=0 < ; Chk if MCR WNR is prev insurer with MRA on file < S IBSEQ=$$COBN^IBCEF(IBIFN)-1 < S Z=$$MCRONBIL^IBEFUNC(IBIFN,IBSEQ) I +Z=1,$P(Z,U,2)= < Q IB < ; < ; If found, returns a pieced string as follows: | ; If found, returns ien of message (file 361) ^ ien o ; < ; [1] ien of transmit bill entry (file 364) associa < ; entry in file 361 with an unreviewed status m < ; [2] ien of transmit bill entry (file 364) associa < ; entry in file 361.1 with an unreviewed EOB < Only in ./VADemo/r1/: IBCEF71.m Only in ./VADemo/r1/: IBCEF72.m Only in ./VADemo/r1/: IBCEF73.m Only in ./VADemo/r1/: IBCEF74.m Only in ./VADemo/r1/: IBCEF7.m diff -y --suppress-common-lines ./VADemo/r1/IBCEFG1.m ./VADemo/r2/r/IBCEFG1.m ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288* | ;;2.0;INTEGRATED BILLING;**52,51,137,181,197**;21-MAR N IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ,IB1 | N IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ I DATE1=0 S DATE1="" < NAME(IBNM1,COMB) ; Parse person's nm into 5 pieces LAS | NAME(IBNM1,COMB) ; Parse person's nm into 4 pieces LAS ; OR FIRST MIDDLE LAST^vp file ien (200 | ; FIRST MIDDLE LAST^vp file ien (200 o . S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC) | . D NAMECOMP^XLFNAME(.IBNMC) . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$ | . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$ S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G( | S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G( I $P(IBNM1,U,2)["355.93",$P($G(^IBA(355.93,+$P(IBNM1, | I $G(COMB)=1,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U . S IBNM=$P(IBNM1,U)_U_U_U_IBCRED_U | I $G(COMB)=2,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U I $G(COMB)=1,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U < I $G(COMB)=2,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U < ; the decimal and commas. | ; the decimal. Q $TR(AMT,",") | Q AMT S:CODE'="" X12=$P($S(CODE="01":"18^SELF",CODE="02":"0 | S:CODE'="" X12=$P($S(CODE="01":"18^SELF",CODE="02":"0 diff -y --suppress-common-lines ./VADemo/r1/IBCEF.m ./VADemo/r2/r/IBCEF.m ;;2.0;INTEGRATED BILLING;**52,80,51,137,288**;21-MAR- | ;;2.0;INTEGRATED BILLING;**52,80,51,137**;21-MAR-94 S $P(IBDEM,U,4,5)=$P(A,U,2)_U_$P(A,U,3) | S $P(IBDEM,U,4,5)=$P(A,U,2,3) diff -y --suppress-common-lines ./VADemo/r1/IBCE.m ./VADemo/r2/r/IBCE.m ;;2.0;INTEGRATED BILLING;**137,283**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 D EN^IBCEMPRG ; purge status messages from file < N DIR,X,Y,IBLAST,IBTASK,IBOPTX,DTOUT,DUOUT | N DIR,X,Y,IBLAST,IBTASK,IBOPTX N DIR,X,Y,IBBTCH,DTOUT,DUOUT | N DIR,X,Y,IBBTCH . S IBBTCH=$O(^TMP("IBCE-BATCH",$J,0)) | . S IBBTCH=$O(^TMP("IBCE-BATCH",$J,0)) . I IBBTCH'="" S IBBTCH=+$G(^TMP("IBCE-BATCH",$J,IBBT < .. N DIE,DR,DA < diff -y --suppress-common-lines ./VADemo/r1/IBCEM03.m ./VADemo/r2/r/IBCEM03.m ;;2.0;INTEGRATED BILLING;**137,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 ASK N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy | ASK S DIC="^DGCR(399,",DIC(0)="AEMQ",DIC("S")="I $P($G(^( S DIC="^DGCR(399,",DIC(0)="AEMQ",DIC("S")="I $P($G(^( < diff -y --suppress-common-lines ./VADemo/r1/IBCEM1.m ./VADemo/r2/r/IBCEM1.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N IBCNT,IBEOB,IBMSGT,IBMSG,X,IB0 | N IBCNT,IBMSG,X,IB0 S (IBCNT,IBMSG,VALMCNT)=0,IBEOB=+$O(^IBE(364.3,"B","8 | S (IBCNT,IBMSG,VALMCNT)=0 . N IBSTOP < . S IBSTOP=0 < . S IBMSGT=$P(IB0,U,2) < . I IBMSGT,IBEOB,IBMSGT=IBEOB D Q:IBSTOP < .. N Z,Z0 ; Only allow MRA EOB's to be viewed < .. S Z=0 F S Z=$O(^IBA(364.2,IBMSG,2,Z)) Q:'Z!(IBSTO < . S Z=$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U,6) S:Z="EOB | . S X=$$SETFLD^VALM1($E($P($G(^IBE(364.3,+$P(IB0,U,2) . S X=$$SETFLD^VALM1($E(Z_$J("",6),1,6),X,"TYPE") < I '$D(^TMP("IBCEM-837",$J)) S VALMCNT=2,IBCNT=2,^TMP( | I '$D(^TMP("IBCEM-837",$J)) S VALMCNT=2,IBCNT=2,^TMP( diff -y --suppress-common-lines ./VADemo/r1/IBCEM3.m ./VADemo/r2/r/IBCEM3.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-1994 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994 . S DIR("A")="Are you sure this is the bill you want | . S DIR("A")="Are you sure this is this the bill you diff -y --suppress-common-lines ./VADemo/r1/IBCEM.m ./VADemo/r2/r/IBCEM.m ;;2.0;INTEGRATED BILLING;**137,191,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137,191**;21-MAR-94 N IB0,IBBA,IBBDA,IBCT,IBM,IBTDA,IBNEW,DA,DIE,DR,Z,IBT | N IB0,IBBA,IBBDA,IBCT,IBM,IBTDA,IBNEW,DA,DIE,DR,Z,IBT Q:IB0="" S IBIFN=+IB0 | Q:IB0="" ; | S DR=".03////"_$S("NP"'[FUNC:FUNC,1:"Z")_";.04///NOW" S IBSTAT=$P(IB0,U,3) ; current status | S DA=+IBDA,DIE="^IBA(364," D ^DIE ;Update the transmi I '$F(".C.R.E.Z.","."_IBSTAT_".") D ; don't update < . S DR=".03////"_$S(FUNC="E":"R","NP"'[FUNC:FUNC,1:"Z < . S DA=+IBDA,DIE="^IBA(364," D ^DIE ;Update the trans < . Q < ; Update file 361.1 with the Cancel Status, to cancel | S IBZ=0 F S IBZ=$O(^IBM(361.1,"AERR",+IBDA,IBZ)) Q:' I FUNC="C" D STAT^IBCEMU2(IBIFN,9,0) | . S DIE="^IBM(361.1,",DR=".16////2;.2////"_$TR(FUNC," > . I FUNC'="","ECRPIBZ"[FUNC D ; Update review status > .. D NOTECHG^IBCECSA2(IBZ,1,.IBTEXT) Only in ./VADemo/r1/: IBCEMMR.m Only in ./VADemo/r1/: IBCEMQA.m Only in ./VADemo/r1/: IBCEMQC.m Only in ./VADemo/r1/: IBCEMRAA.m Only in ./VADemo/r1/: IBCEMRAB.m Only in ./VADemo/r1/: IBCEMRAX.m Only in ./VADemo/r1/: IBCEMSR1.m Only in ./VADemo/r1/: IBCEMSR.m Only in ./VADemo/r1/: IBCEMU1.m Only in ./VADemo/r1/: IBCEMU2.m Only in ./VADemo/r1/: IBCEMU3.m Only in ./VADemo/r1/: IBCEMU4.m Only in ./VADemo/r1/: IBCEMVU.m Only in ./VADemo/r1/: IBCEOB00.m Only in ./VADemo/r1/: IBCEOB0.m diff -y --suppress-common-lines ./VADemo/r1/IBCEOB1.m ./VADemo/r2/r/IBCEOB1.m IBCEOB1 ;ALB/TMP - 835 EDI EOB MSG PROCESSING ;18-FEB-99 | IBCEOB1 ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;18-FEB-99 ;;2.0;INTEGRATED BILLING;**137,135,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 .. S VAL=$S($P(IBPC,";",3):$$DOLLAR^IBCEOB($P(IB0,U,+ | .. S VAL=$S($P(IBPC,";",3):$$DOLLAR^IBCEOB($P(IB0,U,+ HDR(IB0,IBEGBL,IBEOB) ; Store header data for EOB | HDR(IB0,IBEOB) ; Store header data for EOB ; IB0 = the record being processed from the msg | ; IB0 = the record being processed from the message S DR=$S($P(IB0,U,7)'="":".03////"_$P(IB0,U,7)_";",1:" | S DR=".03////"_$P(IB0,U,7)_";.05////"_IBDT_";.04////" I $D(Y)'=0 D | I $D(Y)'=0 S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EO . S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad | Q $D(Y)=0 Q ($D(Y)=0) < FINDLN(IB0,IBEOB,IBZDATA) ; Find the corresponding bill | 45(IB0,IBEOB,IBOK) ; Process record type 45 for EOB ; NOTE: pieces 3,4,16 are already reformatted < ; IBZDATA = the array from the output formatter conta | ; IBOK = Returned as 1 if record filed OK, 0 if error > ; > N IBDA,LEVEL,A > I '$G(^TMP($J,40)) S ^TMP("IBCERR-EOB",$J,+$O(^TMP("I > ; > I $P(IB0,U,3)'="" S $P(^TMP($J,40),U,2)=$P(IB0,U,3) > I $P(IB0,U,3)="" S $P(IB0,U,3)=$P(^TMP($J,40),U,2) > I $P(IB0,U,3)="" S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBC > ; > S IBDA(2)=+^TMP($J,40) > S IBDA(1)=+$O(^IBM(361.1,IBEOB,15,IBDA(2),1,"B",$P(IB > ; > I 'IBDA(1) D ;Needs a new entry at group level > . N X,Y,DA,DD,DO,DIC,DLAYGO > . S DIC="^IBM(361.1,"_IBEOB_",15,"_IBDA(2)_",1,",DIC( > . S DIC("P")=$$GETSPEC^IBEFUNC(361.115,1) > . S X=$P(IB0,U,3) > . D FILE^DICN K DIC,DO,DD,DLAYGO > . I Y<0 K IBDA S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCER > . S IBDA(1)=+Y > ; > ;Add a new entry at the reason code level > I $G(IBDA(1)) D > . S DIC="^IBM(361.1,"_IBEOB_",15,"_IBDA(2)_",1,"_IBDA > . S DIC("P")=$$GETSPEC^IBEFUNC(361.1151,1) > . S X=$P(IB0,U,4) > . D FILE^DICN K DIC,DO,DD,DLAYGO > . I Y<0 K IBDA S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCER > . S IBDA=+Y > ; > I $G(IBDA) D > . S LEVEL=15,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",15,"_ > . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBDA(2),L > . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0" > . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL) > . I 'IBOK S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB > ; > Q45 Q > ; > FINDLN(IB0,IBEOB,IBZDATA) ; Find the corresponding bill > ; IB0 = the record being processed > ; IBEOB = the ien of the EOB entry in file 361.1 > ; IBZDATA = the array from the output formatter conta ; ^ paid procedure code if different from or | ; ^ paid procedure code if different from or ; paid rev code if different from original < N IBLN,IBLN1,IBBNDL,OCHG,OCHG2,OPROC,OREVCD,IBIFN,IBX | N IBLN,IBHI,IBBNDL,OCHG,OPROC S (IBLN,IBLN1)="",IBIFN=+$G(^IBM(361.1,IBEOB,0)) | S IBLN="" S EOBCHG=+$$DOLLAR^IBCEOB($P(IB0,U,15)) ; charges o | I '$D(IBZDATA) D F^IBCEF("N-UB92 SERVICE LINE (EDI)", > S IBBNDL=$S($P(IB0,U,11)="":0,1:$P(IB0,U,11)'=$P(IB0, > ; > I $P(IB0,U,4)'="" D ; UB92 format if revenue code ex > . N Z > . S Z=0 F S Z=$O(IBZDATA(Z)) Q:'Z D:$G(IBZDATA(Z))' > .. S OCHG=$P(IBZDATA(Z),U,3)*$P(IBZDATA(Z),U,4) ; Tot > .. S OPROC=$$PRCD^IBCEF1(+$P(IBZDATA(Z),U,2)_";ICPT(" > .. I 'IBBNDL,$P(IBZDATA(Z),U)=$P(IB0,U,4),$S(OPROC'=" > .. I IBBNDL,$P(IBZDATA(Z),U)=$P(IB0,U,4),$S(OPROC="": ; if original procedure exists and is different than | I $P(IB0,U,4)="" D ; HCFA 1500 format ; the procedure or revenue code originally billed wil | . N Z,UNITS,Z0,IBMOD ; of the '40' record of the 835 flat file. Otherwise < S IBBNDL=$S($P(IB0,U,10)'="":1,1:0) < ; < I $P($G(^DGCR(399,IBIFN,0)),U,19)=3 D G FINDLNX < . I '$D(IBZDATA) D F^IBCEF("N-UB92 SERVICE LINE (EDI) < . I $P(IB0,U,22),$D(IBZDATA(+$P(IB0,U,22))) S IBLN=+$ < . ; < .. ; Quit if processing an MRA and this VistA line# h | .. S OCHG=$P(IBZDATA(Z),U,8)*$P(IBZDATA(Z),U,9) ; Sub .. I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1, | .. S UNITS=$S('$P(IBZDATA(Z),U,12):$P(IBZDATA(Z),U,9) .. I $G(IBZDATA(Z))="" Q | .. S OPROC=$$PRCD^IBCEF1(+$P(IBZDATA(Z),U,5)_";ICPT(" .. S OCHG=$P(IBZDATA(Z),U,3)*$P(IBZDATA(Z),U,4) ; Tot | .. I 'IBBNDL,OCHG=$P(IB0,U,16),UNITS=$P(IB0,U,17),$P( .. S OCHG2=+$P(IBZDATA(Z),U,5) | ... ;Original chg/units/service date match .. I OCHG'=EOBCHG,OCHG2=EOBCHG S OCHG=OCHG2 ; upd | ... ;Check matching original modifiers ?????????????? .. ; | ... N MODOK,Q,Q1,MOD,MODLST,OMOD .. S CPT=$P(IBZDATA(Z),U,2) ; | ... S MODOK=1,MODLST=$P(IBZDATA,U,10) .. I CPT'?.N,CPT'="" S CPT=$O(^ICPT("B",CPT,"")) ; | ... S (Q,Z0)=0 F S Z0=$O(^IBM(361.1,IBEOB,2,Z0)) Q:' .. S OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(") ; | ... ; Check mods on 2 records match, in order .. S OREVCD=+$P($G(^DGCR(399.2,+IBZDATA(Z),0)),U) ; | ... F Q=1:1:$L(MODLST,",") Q:Q>4 S MOD=$$MOD^ICPTMOD .. ; | ... Q:'MODOK .. ; if not bundled/unbundled | ... I 'IBBNDL,OPROC=$P(IB0,U,3) S IBLN=Z Q ;Exact ma .. I 'IBBNDL D Q | ... I IBBNDL,OPROC=$P(IB0,U,11) S IBLN=Z_U_OPROC ;Bun ... I OPROC="",OREVCD,OREVCD'=$P(IB0,U,4) Q ; re < ... I OPROC'="",OPROC'=$P(IB0,U,3) Q ; pr < ... I +$P(IBZDATA(Z),U,4)'=$P(IB0,U,16) Q ; or < ... I +OCHG'=EOBCHG Q ; or < ... I '$$MODMATCH($P(IBZDATA(Z),U,9),$P(IB0,U,5,8)),' < ... S IBLN=Z < ... Q < .. ; < .. ; if bundled/unbundled < .. I IBBNDL D Q < ... I OPROC="",OREVCD,OREVCD'=+$P(IB0,U,10) Q ; re < ... I OPROC'="",OPROC'=$P(IB0,U,10) Q ; pr < ... I +$P(IBZDATA(Z),U,4)'=$P(IB0,U,16) Q ; or < ... I +OCHG'=EOBCHG Q ; or < ... I '$$MODMATCH($P(IBZDATA(Z),U,9),$P(IB0,U,11,14)) < ... S IBLN=Z_U_$S(OPROC'="":OPROC,1:OREVCD) < ... Q < .. Q < . ; When dealing with Inpatient UB92's, check for rev < . I 'IBLN,$$INPAT^IBCEF(IBIFN,1) D RCRU^IBCEOB00(.IBZ < . ; If only 1 rev code and charges are the same, assu < . I 'IBLN,'$P($G(^IBM(361.1,IBEOB,0)),U,4),$O(IBZDATA < ; < ; At this point, we can assume the claim is HCFA 1500 < I '$D(IBZDATA) D F^IBCEF("N-HCFA 1500 SERVICE LINE (E < I $P(IB0,U,22),$D(IBZDATA(+$P(IB0,U,22))) S IBLN=+$P( < S Z=0 F S Z=$O(IBZDATA(Z)) Q:'Z D Q:IBLN < . ; Quit if processing an MRA and this VistA line# ha < . I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,$D(^IBM(361.1,I < . S OCHG=$P(IBZDATA(Z),U,8)*$P(IBZDATA(Z),U,9) ; char < . S UNITS=$S('$P(IBZDATA(Z),U,12):$P(IBZDATA(Z),U,9), < . I $P(UNITS,".",2) S UNITS=$FN(UNITS,"",1) ; roun < . I $P($P(IB0,U,16),".",2) S $P(IB0,U,16)=$FN($P(IB0, < . S UNITS2=$P(IBZDATA(Z),U,9) ; just the units < . ; UNITS3 is the number of anesthesia minutes divide < . ; Solution to get around the Trailblazers bug for M < . S UNITS3="" < . I $P(IBZDATA(Z),U,12) S UNITS3=$P(IBZDATA(Z),U,12)/ < . ; < . S CPT=$P(IBZDATA(Z),U,5) ; proc from bill < . I CPT'?.N,CPT'="" S CPT=$O(^ICPT("B",CPT,"")) ; n < . S OPROC=$$PRCD^IBCEF1(+CPT_";ICPT(") ; e < . Q:OPROC'=$S('IBBNDL:$P(IB0,U,3),1:$P(IB0,U,10)) < . ; < . S MODOK=0 < . I $$DOLLAR^IBCEFG1(OCHG)=+$P(IB0,U,15),UNITS=$P(IB0 < .. ;Original procedure/chg/units/date match to get he < .. ;Check matching original modifiers < .. S MODOK=$$MODMATCH($$MODLST^IBEFUNC2($P(IBZDATA(Z) < .. I 'MODOK,'IBLN1 S IBLN1=Z_$S(IBBNDL:U_OPROC,1:"") < .. Q:'MODOK < .. S IBLN=Z_$S(IBBNDL:U_OPROC,1:"") < I 'IBLN,IBLN1 S IBLN=IBLN1 < ; < FINDLNX ; < MODMATCH(IB,MODLST) ; Match modifiers | UPDNM(IBEOB,IB0,IBBULL,IBDR) ; Update name on claim if it ; IB = the list of modifiers iens from the bill, comm | ; IBEOB = the internal entry # of the entry in file 3 ; MODLST = the 4 '^' pieces of the reported modifiers | ; IB0 = the raw data returned from the 835 flat file ; | ; IBBULL = holds result of name change check in piece N MODOK,Q,Z0,IBMOD,MMOD | ; changed, first '^' piece is 1, 3rd '^' pie S MODOK=1 | ; insured's name I $TR(IB,",")'="" F Q=1:1:$L(IB,",") S Z0=$P(IB,",",Q | ; IBDR = returned as the updated 'DR' string with the I $TR(MODLST,U)="",$O(IBMOD(""))="" G MODQ ; No modif | ; fields to use to update the EOB file (361.1) ; | ; ; No match if no VistA modifiers, but there are MRA m | N IBCHGED,IBIFN,IBNEW,IBCOB,DIE,DR,X,Y I $TR(MODLST,U)'="",$O(IBMOD(""))="" S MODOK=0 G MODQ | I $P(IB0,U,7) D ; | . S IBNEW=$P(IB0,U,3)_","_$P(IB0,U,4)_$S($P(IB0,U,5)' ; Evaluate each MRA modifier | . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15) F Z0=1:1:4 D | . S IBIFN=+$G(^IBM(361.1,+IBEOB,0)) . S MMOD=$P(MODLST,U,Z0) Q:MMOD="" ; individual M | . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB)) . I '$D(IBMOD(MMOD)) Q ; not in array | . ; . S IBMOD(MMOD)=IBMOD(MMOD)-1 ; decrement ar | . I IB'="",$P(IB,U,17)'=IBNEW D . I 'IBMOD(MMOD) KILL IBMOD(MMOD) ; if 0, then k | .. ; Update the claim data only . Q | .. S $P(IBBULL,U,3)=$P(IB,U,17) ; save old value > .. S $P(IB,U,17)=IBNEW > .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_I > .. D:DA ^DIE > .. S IBCHGED=1 > . S IBDR=$G(IBDR)_"6.01////"_$P(IB0,U,3)_","_$P(IB0,U > ; > Q $G(IBCHGED) > ; > UPDID(IBEOB,IB0,IBBULL,IBDR) ; Update id # on claim and po > ; changed > ; IBEOB = the internal entry # of the entry in file 3 > ; IB0 = the raw data returned from the 835 flat file > ; IBBULL = holds result of id change check in piece 2 > ; second '^' piece = 1,4th '^' piece is the > ; IBDR = returned as the updated 'DR' string with the > ; to use to update the EOB file (361.1) - pass > ; > N IBCHGED,IBNEW,IBCOB,IB,DIE,DR,DA,X,Y > I $P(IB0,U,8) D > . S IBNEW=$P(IB0,U,6),$P(IBBULL,U,2)=1 > . S IBIFN=+$G(^IBM(361.1,+IBEOB,0)) > . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15) > . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB)) > . ; > . I IB'="",$P(IB,U,2)'=IBNEW D > .. ; Update the claim > .. S $P(IBBULL,U,4)=$P(IB,U,2) ; save old value > .. S $P(IB,U,2)=IBNEW > .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_I > .. ; > .. ; Update the policy > .. S DA(1)=$P($G(^DGCR(399,IBIFN,0)),U,2),DA=$P($G(^( > .. I DA(1),DA D ^DIE > .. S IBCHGED=1 > . S IBDR=$G(IBDR)_"6.02////"_$P(IB0,U,6)_";" I $O(IBMOD(""))'="" S MODOK=0 ; All submitted mods no | Q $G(IBCHGED) MODQ Q MODOK < diff -y --suppress-common-lines ./VADemo/r1/IBCEOB21.m ./VADemo/r2/r/IBCEOB21.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N IB0,IBDA,IBE,DIR,X,Y,DA,DIK | N IB0,IBDA,DIR,X,Y,DA,DIK VIEW ; View an MRA | VIEW ; View an EOB N IBDA,IBSEL,IBIFN,IBEOBIFN,IBIFNSAV | N IBDA,IB0,DIE,DR,X,Y,DA ; < D FULL^VALM1 < D SEL(.IBDA,1) ; select a bill from the main list < S IBSEL=+$O(IBDA(0)) I 'IBSEL G VIEWQ < S IBIFN=$P($G(IBDA(IBSEL)),U,1) I 'IBIFN G VIEWQ < S IBEOBIFN=$P($G(IBDA(IBSEL)),U,3) I 'IBEOBIFN G VIEW < ; < ; If only one MRA on file, then call the Listman and < I $$MRACNT^IBCEMU1(IBIFN)=1 D EN^VALM("IBCEM VIEW EOB < VLOOP ; Multiple MRA's on file. Allow user to select the M < S IBEOBIFN=$$SEL^IBCEMU1(IBIFN,1) | S IBDA=$$SEL(.IBDA) I 'IBEOBIFN G VIEWQ | G:'IBDA VIEWQ S IBIFNSAV=IBIFN ; save off the bill# | D EN^VALM("IBCEM VIEW EOB") D EN^VALM("IBCEM VIEW EOB") ; call the Listman | VIEWQ S VALMBCK="R" S IBIFN=IBIFNSAV ; restore the bill# < G VLOOP < ; < VIEWQ ; < S VALMBCK="R" < SEL(IBDA,ONE) ; Select entry(s) from list | SEL(IBE) ; Select entry from list ; IBDA = array returned if selections made | ; IBE = returned as the display line for the entry if ; ONE = if set to 1, only one selection can be made a | N VALMY,Z N VALMY | K IBDA,IBE K IBDA | D EN^VALM2($G(XQORNOD(0))) D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S")) | S IBDA=+$O(VALMY(0)) S IBDA=0 F S IBDA=$O(VALMY(IBDA)) Q:'IBDA S IBDA(IB | I IBDA S Z=+$O(^TMP("IBCEOB",$J,"IDX",+IBDA,0)),IBE=$ Q | Q IBDA diff -y --suppress-common-lines ./VADemo/r1/IBCEOB2.m ./VADemo/r2/r/IBCEOB2.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 S VALMHDR(2)=" CURRENT INSURANCE COMPANY ("_IBCOB_"): < > . S VALMHDR(2)=" CURRENT INSURANCE COMPANY ("_IBCOB_" . S VALMHDR(4)=" # SEQ PAYER"_$J("",15)_"EOB PAID DA | . S VALMHDR(4)=" # SEQ PAYER"_$J("",15)_"EOB DATE/TI N IB0,X,Y,IBCOB,IBCOBN,IB,IBCNT,IBEOB,IBSEQ,IBPDDT | N IB0,X,Y,IBCOB,IBCOBN,IB,IBCNT,IBEOB,IBSEQ .. S ^TMP("IB",$J,+$P(IB0,U,6),IBEOB)=IB0 ; Sort by E | .. S ^TMP("IB",$J,+$P(IB0,U,15),IBEOB)=IB0 ; Sort by . ; | . S IBSEQ="" F S IBSEQ=$O(^TMP("IB",$J,IBSEQ)) Q:IBS . S IBPDDT="" F S IBPDDT=$O(^TMP("IB",$J,IBPDDT)) Q: < .. S IBSEQ=+$P(IB0,U,15) < .. S IB=IB_$E($$FMTE^XLFDT($P(IB0,U,6),"2")_$J("",18) | .. S IB=IB_$E($$FMTE^XLFDT($P(IB0,U,6),"2")_$J("",18) Only in ./VADemo/r1/: IBCEOBAR.m diff -y --suppress-common-lines ./VADemo/r1/IBCEOB.m ./VADemo/r2/r/IBCEOB.m IBCEOB ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;20-JAN-99 | IBCEOB ;ALB/TMP - 837 EDI EOB MESSAGE PROCESSING ;20-JAN-99 ;;2.0;INTEGRATED BILLING;**137,135,265,155**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 UPDEOB(IBTDA) ; Update EXPLANATION OF BENEFITS file (#361.1 | UPDEOB(IBTDA) ; Update EXPLANATION OF BENEFITS file (#361) ; Function returns ien of EOB file entry or "" if err | ; Function returns ien of EOB file entry or "" if err ; the data. Any errors found are | ; encountered filing the data. Any errors f ; n = seq # and are stored with the EOB in a | ; n = sequential # and are stored with the E > ; processing field N IB0,IB100,IBBTCH,IBE,IBMNUM,IBT,DLAYGO,DIC,DD,DO,X, | N IB0,IB100,IBBTCH,IBE,IBMNUM,IBT,DLAYGO,DIC,DD,DO,X, ; Duplicate EOB Check | I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock message in file 3 S IBFILE="^IBA(364.2,"_IBTDA_",2)" < I $$DUP(IBFILE,X) G UPDQ < I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock msg file 364.2 | S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1 S IBEOB=+$$ADD3611(IBMNUM,$P(IB0,U,5),$P(IB0,U,4),X,0 | S DIC("DR")=".16////0;.17////0;.19////"_+$P(IB0,U,5)_ > D FILE^DICN K DIC,DLAYGO,DA,DO,DD > G:Y<0 UPDQ > I Y>0 S IBEOB=+Y I IBEOB<0 S IBEOB="" G UPDQ | S IBA1=0 D UPD3611(IBEOB,IBTDA,0) | F S IBA1=$O(^IBA(364.2,IBTDA,2,IBA1)) Q:'IBA1 S IB0 > . S IBREC=+IB0 > . I IBREC'=37 K ^TMP($J,37) > . I IBREC S IB="S IBOK=$$"_IBREC_"(IB0,IBEOB)",Q=IBRE UPDQ I IBEOB,$O(^TMP("IBCERR-EOB",$J,0)) D ERRUPD(IBEOB,"I | UPDQ I IBEOB,$O(^TMP("IBCERR-EOB",$J,0)) D WP^DIE(361.1,IB ; | 835(IB0,IBEOB) ; Store header ; NOTE: **** For all variables IB0,IBEGBL,IBEOB below < ; IBEGBL = subscript to use in error global < 835(IB0,IBEGBL,IBEOB) ; Store header | Q $$HDR^IBCEOB1(IB0,IBEOB) Q $$HDR^IBCEOB1(IB0,IBEGBL,IBEOB) | 5(IB0,IBEOB) ; Store data on record '05' ; | ; IB0 = raw data received for this record type on the 5(IB0,IBEGBL,IBEOB) ; Record '05' | ; IBEOB = ien in file 361.1 for this EOB I $$UPDNM^IBCEOB00(IBEOB,IB0,.IBBULL,.DR)!$$UPDID^IBC | I $$UPDNM^IBCEOB1(IBEOB,IB0,.IBBULL,.DR)!$$UPDID^IBCE I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U, < I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0, < I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1 | I 'IBOK S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB", 10(IB0,IBEGBL,IBEOB) ; Record '10' | 10(IB0,IBEOB) ; Store data on record '10' > ; IB0 = raw data received for this record type on the > ; IBEOB = ien in file 361.1 for this EOB N DA,DR,DIE,X,Y,VAL,IBOK | N DA,DR,DIE,X,Y,VAL S DR=".13////"_$S($P(IB0,U,3)="Y":1,$P(IB0,U,4)="Y":2 | S DR=".13////"_$S($P(IB0,U,3)="Y":1,$P(IB0,U,4)="Y":2 S DR=DR_";2.04////"_$$DOLLAR($P(IB0,U,10))_";1.01//// | S DR=DR_";2.04////"_$$DOLLAR($P(IB0,U,10))_";1.01//// S DR=DR_$S($P(IB0,U,13)'="":";.1///"_$P(IB0,U,13),1:" | I $P(IB0,U,8)'="" S DR=DR_";.08////"_$P(IB0,U,8)_";.0 I $P(IB0,U,8)'="" S DR=DR_";.08////"_$P(IB0,U,8)_$S($ < S IBOK=($D(Y)=0) | I $D(Y)'=0 S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EO I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1 | Q10 Q $D(Y)=0 ; < ; File ICN in Bill < D ICN^IBCEOB00(IBEOB,$P(IB0,U,12),$P($G(^IBM(361.1,IB < Q10 Q IBOK | 15(IB0,IBEOB) ; Store data on record '15' ; | ; IB0 = raw data received for this record type on the 15(IB0,IBEGBL,IBEOB) ; Record '15' | ; IBEOB = ien in file 361.1 for this EOB S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1; | S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1; I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1 | I 'IBOK S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB", ; < ; For Medicare MRA's only: < ; If the Covered Amount is present (15 record, piece < ; a claim level adjustment with Group code=OA, Reason < ; < I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D < . N IB20 < . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3 < . S IB20=IB20_U_"Covered Amount" < . S IBOK=$$20(IB20,IBEGBL,IBEOB) < . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1) < . K ^TMP($J,20) < . Q < ; < 17(IB0,IBEGBL,IBEOB) ; Record '17' | 20(IB0,IBEOB) ; Store data on record '20' N A,IBOK | ; IB0 = raw data received for this record type on the S A="3;25.01;0;1;0^4;25.02;0;1;0^5;25.03;0;1;0^6;25.0 | ; IBEOB = ien in file 361.1 for this EOB S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) < I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1 < Q17 Q IBOK < ; < 20(IB0,IBEGBL,IBEOB) ; Record '20' < I IBGRP'="" S ^TMP($J,20)=IBGRP < I IBGRP="" S IBGRP=$G(^TMP($J,20)) < I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1 < ; < . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,"" | . I Y<0 K IBDA S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCER . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,"" | . I Y<0 K IBDA S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCER . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1) | . I 'IBOK S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB 30(IB0,IBEGBL,IBEOB) ; Record '30' | 30(IB0,IBEOB) ; Store data on record '30' > ; IB0 = raw data received for this record type on the > ; IBEOB = ien in file 361.1 for this EOB N IBOK | N A,IBOK D 30^IBCEOB0(IB0,IBEOB,.IBOK) | ; > S A="3;4.01;0;1;1^5;4.02;0;1;1^6;4.03;1;0;0^7;4.05;1; > ; > S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) > I 'IBOK S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB", 35(IB0,IBEGBL,IBEOB) ; Record '35' | 35(IB0,IBEOB) ; Store data on record '35' ; Moved due to space constraints | ; IB0 = raw data received for this record type on the Q35 Q $$35^IBCEOB00(IB0,IBEGBL,IBEOB) | ; IBEOB = ien in file 361.1 for this EOB ; < 37(IB0,IBEGBL,IBEOB) ; Record '37' < ; Moved due to space constraints < Q37 Q $$37^IBCEOB00(IB0,IBEGBL,IBEOB) < 40(IB0,IBEGBL,IBEOB) ; Record '40' | N A,IBOK N IBOK | S A="3;4.12;1;0;0^4;4.13;1;0;0^5;4.14;0;1;1^6;4.15;1; D 40^IBCEOB0(IB0,IBEOB,.IBOK) < Q40 Q $G(IBOK) < 41(IB0,IBEGBL,IBEOB) ; Record '41' | S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) > I 'IBOK S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB", > Q35 Q $G(IBOK) N IBOK | 37(IB0,IBEOB) ; Store data on record '37' D 41^IBCEOB0(IB0,IBEOB,.IBOK) | ; IB0 = raw data received for this record type on the Q41 Q $G(IBOK) | ; IBEOB = ien in file 361.1 for this EOB 42(IB0,IBEGBL,IBEOB) ; Record '42' | N IBOK,IBCT > S IBCT=$G(^TMP($J,37))+1 > I IBCT>5 S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB" > S A="3;"_$S($P(IB0,U,3)="O":"3.0"_(IBCT+2),1:"5.0"_IB > S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) > I 'IBOK S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB", > Q37 S ^TMP($J,37)=$G(^TMP($J,37))+1 ; Saves the # of entr > Q $G(IBOK) N IBOK | 40(IB0,IBEOB) ; Store data on record '40' D 42^IBCEOB0(IB0,IBEOB,.IBOK) | ; IB0 = raw data received for this record type on the Q42 Q $G(IBOK) | ; IBEOB = ien in file 361.1 for this EOB > ; IBZDATA is also assumed to exist or if not, it is c 45(IB0,IBEGBL,IBEOB) ; Record '45' | N A,LEVEL,IBSEQ,IBDA,IBPC,IBLREF,IBIFN,Q,X,Y,DA,DD,DO > K ^TMP($J,40) ; the entry # for corresponding 41 and N IBOK | S IBIFN=+$G(^IBM(361.1,IBEOB,0)) D 45^IBCEOB0(IB0,IBEOB,.IBOK) | F A=1:1:5 L +^IBM(361.1,IBEOB,15):0 I $T S IBSEQ=+$O( Q $G(IBOK) | I '$G(IBSEQ) S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR- > ; > ; Find the line item from original bill for this adju > S IBLREF=+$$FINDLN^IBCEOB1(IB0,IBEOB,.IBZDATA) > I '$G(IBSEQ)!'IBLREF S ^TMP("IBCERR-EOB",$J,+$O(^TMP( > ; > S DIC="^IBM(361.1,"_IBEOB_",15,",DIC(0)="L",DLAYGO=36 > S DIC("P")=$$GETSPEC^IBEFUNC(361.1,15) > S X=IBSEQ > S DIC("DR")=".12////"_+IBLREF_$S($P(IBLREF,U,2)="":"" > D FILE^DICN K DIC,DO,DD,DLAYGO ;Add a new LINE LEVEL > I Y<0 S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-EOB",$J > ; > L -^IBM(361.1,IBEOB,15) > ; > S LEVEL=15.1,LEVEL(0)=+Y,LEVEL(1)=IBEOB,LEVEL("DIE")= > S A="3;.04;0;0;0^4;.1;0;0;0^9;.09;0;0;0^17;.03;1;0;0^ > I $$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL) S ^TMP($J,40)=L > I $G(IBOK) D ;Store modifiers in multiple > . S DIC="^IBM(361.1,"_IBEOB_",15,"_LEVEL(0)_",2,",DIC > . S DIC("P")=$$GETSPEC^IBEFUNC(361.115,2) > . F Q=5:1:8 S X=$P(IB0,U,Q) D FILE^DICN K DO,DD I Y<0 > . K DLAYGO,DIC,DR,DA > I '$G(IBOK) S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-E > Q40 Q $G(IBOK) DOLLAR(X) ; Convert value in X to dollar format XXX.XX | 41(IB0,IBEOB) ; Store data on record '41' Q $S(+X:$J(X/100,$L(+X),2),1:0) | ; IB0 = raw data received for this record type on the > ; IBEOB = ien in file 361.1 for this EOB ADD3611(IBMNUM,IBTBILL,IBBATCH,X,IBAR,IBFILE) ; Add stub re | N IBOK,DA,DR,DIE,X,Y ; X = the ien of the referenced bill in file 399 | I '$G(^TMP($J,40)) S ^TMP("IBCERR-EOB",$J,+$O(^TMP("I ; IBTBILL = ien of transmitted bill (optional) < ; IBBATCH = ien of batch # the transmitted bill was i < ; IBMNUM = the message # from which this record origi < ; IBAR = 1 only if called from AR < ; IBFILE = array reference of raw EOB data < ; < N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS < F L +^IBM(361.1,0):10 Q:$T < ; < ; default proper review status < S BS=$P($G(^DGCR(399,X,0)),U,13) ; bill status < S REVSTAT=$S(BS=7:9,BS=3:3,BS=4:3,1:0) < S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1 < S DIC("DR")=".16////"_REVSTAT_";.17////0"_";100.02/// < S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1( < D FILE^DICN < L -^IBM(361.1,0) < Q +Y < ; < UPD3611(IBEOB,IBTDA,IBAR) ; From flat file 835 format, < ; IBEOB = the ien of the entry in file 361.1 being up < ; IBTDA = the ien in the source file < ; IBAR = 1 if being called from AR < N IBA1,IBFILE,IBEGBL,Z,IBREC,Q < S IBFILE=$S('$G(IBAR):"^IBA(364.2,"_IBTDA_",2)",1:"^T < S IBEGBL=$S('$G(IBAR):"IBCERR-EOB",1:"RCDPERR-EOB") < I $G(IBAR),'$$HDR^IBCEOB1($G(^TMP($J,"RCDPEOB","HDR") < S IBA1=0 < F S IBA1=$O(@IBFILE@(IBA1)) Q:'IBA1 S IB0=$S('$G(IB < . S IBREC=+IB0 < . I IBREC'=37 K ^TMP($J,37) < . I IBREC S IB="S IBOK=$$"_IBREC_"(IB0,IBEGBL,IBEOB)" < Q | S DR="",IBOK=1 > S DA=+^TMP($J,40),DA(1)=IBEOB > S DIE="^IBM(361.1,"_DA(1)_",15,"_DA_"," > I $P(IB0,U,3)'="" S DR=".13///"_$$DOLLAR($P(IB0,U,3)) > I $P(IB0,U,4)'="" S DR=DR_$S(DR="":"",1:";")_".14///" > I DR'="" D ^DIE S IBOK=($D(Y)=0) > I '$G(IBOK) S ^TMP("IBCERR-EOB",$J,+$O(^TMP("IBCERR-E > Q41 Q $G(IBOK) ERRUPD(IBEOB,IBEGBL) ; Update error text in entry, if need | 45(IB0,IBEOB) ; Store data on record '45' D WP^DIE(361.1,IBEOB_",",20,"","^TMP(IBEGBL,$J)","") | ; IB0 = raw data received for this record type on the Q | ; IBEOB = ien in file 361.1 for this EOB > ; > N IBOK > D 45^IBCEOB1(IB0,IBEOB,.IBOK) > Q $G(IBOK) DUP(IBARRAY,IBIFN) ; Duplicate Check | DOLLAR(X) ; Convert value in X to dollar format XXX.XX ; This function determines if the EOB data already ex | Q $S(+X:$J(X/100,$L(+X),2),1:0) ; 361.1 by comparing the checksums of the raw 835 dat < ; < ; IBARRAY = Literal array reference where the raw 835 < ; The data exists at @IBARRAY@(n,0), where < ; For example, IBARRAY = "^IBA(364.2,IBIEN, < ; < ; IBIFN = the bill # (ptr to 399). The checksums of < ; file for this bill will be compared to the < ; 835 raw data in the IBARRAY reference. < ; < ; This function returns 0 if the entry is not found ( < ; Otherwise, the IEN of the entry in file 361.1 is re < ; is a duplicate EOB. < ; < NEW DUP,IBEOB,CHKSUM1,CHKSUM2 < S DUP=0,IBIFN=+$G(IBIFN) < I $G(IBARRAY)=""!'IBIFN G DUPX < I '$D(^IBM(361.1,"B",IBIFN)) G DUPX ; no EOB's on < S CHKSUM1=$$CHKSUM^IBCEMU1(IBARRAY) ; checksum of < I 'CHKSUM1 G DUPX ; must be abl < S IBEOB=0 < F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB < . S CHKSUM2=+$P($G(^IBM(361.1,IBEOB,100)),U,5) ; ch < . I 'CHKSUM2 Q < . I CHKSUM1=CHKSUM2 S DUP=IBEOB Q < . Q < DUPX ; < Q DUP < diff -y --suppress-common-lines ./VADemo/r1/IBCEP0A.m ./VADemo/r2/r/IBCEP0A.m ;;2.0;INTEGRATED BILLING;**137,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IBQ,IBIEN,IBCU | N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IBQ,IBIEN,IBCU . S DIR(0)="PA^355.97:AEMQ",DIR("A")="Select Provider | . S DIR(0)="PA^355.97:AEMQ",DIR("A")="Select Provider diff -y --suppress-common-lines ./VADemo/r1/IBCEP0.m ./VADemo/r2/r/IBCEP0.m ;;2.0;INTEGRATED BILLING;**137,191,239,232**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**137,191**;21-MAR-94 N DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT | N DIC,DIR,DA,X,Y,IBOK .... S Z0=Z0_" "_$S(FT=1:"UB-92",FT=2:"HCFA ",1:"BOT | .... S Z0=Z0_" "_$S(FT=1:"UB-92",FT=2:"HCFA ",1:"BOT N DIC,DIE,DR,DA,X,Y,DLAYGO | N DIC,DA,X,Y,DLAYGO diff -y --suppress-common-lines ./VADemo/r1/IBCEP2A.m ./VADemo/r2/r/IBCEP2A.m ;;2.0;INTEGRATED BILLING;**137,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 ; Get it from rendering facility or if none, the bill | ; I IBXDATA D | I IBXDATA S STATE=$P($G(^DIC(4,+IBXDATA,0)),U,2) . I '$P(IBXDATA,U,2) S STATE=+$P($G(^DIC(4,+IBXDATA,0 < . S STATE=+$P($G(^IBA(355.93,+IBXDATA,0)),U,7) < E D < . D F^IBCEF("N-AGENT CASHIER STATE",,,IBIFN) < . S STATE=IBXDATA < ; < D EN^DDIOL("THIS FUNCTION HAS BEEN DISABLED",,"!") Q < ; < ; < . D EN^DDIOL("> Secondary Perf Prov ID Type (HCFA): | . D EN^DDIOL("> Performing Provider ID Type: "_$$E . D EN^DDIOL("> Secondary Perf Prov ID Type (UB92): | . D EN^DDIOL("> Performing Provider ID Source: "_$$E . D EN^DDIOL("> Secondary Perf Prov IDs Required: | . S Z0=$P(Z4,U,3) > . D EN^DDIOL("> Alternate ID If Missing?: "_$$E > . I Z0=2 D > .. D EN^DDIOL("> Alternate Provider ID Type: "_$$E > .. D EN^DDIOL("> Alternate Provider ID Source: "_$$E GETTYP(IBXIEN,IBCOBN) ; Function returns provider id type f < ; with COB of IBCOBN on claim ien IBXIEN in first ^ p < ; ^ piece if the id is required < ; < N A,R,Z,Z0 < S A="",R=0 < S:'$G(IBCOBN)!(IBCOBN>3) IBCOBN=$$COBN^IBCEF(IBXIEN) < S Z=+$G(^DGCR(399,IBXIEN,"I"_+IBCOBN)) < I Z D < . S Z0=$$FT^IBCEF(IBXIEN) < . S A=+$P($G(^DIC(36,Z,4)),U,$S(Z0=2:1,1:2)) < . I A S R=$P($G(^DIC(36,Z,4)),U,3),R=$S('R:0,R=3:1,R= < Q A_U_R < ; < Only in ./VADemo/r1/: IBCEP2B.m diff -y --suppress-common-lines ./VADemo/r1/IBCEP2.m ./VADemo/r2/r/IBCEP2.m ;;2.0;INTEGRATED BILLING;**137,181,232,280**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**137,181**;21-MAR-94 GETID(IBIFN,IBTYPE,IBPROV,IBSEQ,IBT,IBT1) ; Extract IBT | GETID(IBIFN,IBTYPE,IBPROV,IBSEQ) ; Extract the IBTYPE ; IBIFN = bill ien (file 399) | ; IBIFN = ien of bill (file 399) ; IBTYPE = 2:PERFORMING PROVIDER ID (1 and 3 deleted) | ; IBTYPE = 1:EMC ID 2:PERFORMING PROVIDER ID 3:N ; IBSEQ = numeric COB sequence of the insurance on bi | ; IBPROV = (variable pointer syntax) provider on bill ; Returns IBT = ien of the provider id type^ien of en | ; IBSEQ = the numeric COB sequence of the insurance o > ; > N IBID,IB0,IBPTYP > S IB0=$G(^DGCR(399,IBIFN,0)) > S (IBID,IBPTYP)="" > ; > I IBTYPE=1!(IBTYPE=3) D ; EMC ID # or NETWORK ID # > . S IBPTYP=$S(IBTYPE=1:$$EMCID^IBCEP(),1:$$NETID^IBCE S IBT=0 | I $S(IBTYPE'=2:IBPTYP,1:1) S IBID=$$IDFIND(IBIFN,IBPT Q:IBTYPE'=2 "" < N IBID,IBPTYP < S IBID=$$IDFIND(IBIFN,"",IBPROV,IBSEQ,1,.IBT) < I IBID="" S IBT="" < IDFIND(IBIFN,IBPTYP,IBPROV,IBSEQ,IBPERF,IBT) ;Loop thru so | IDFIND(IBIFN,IBPTYP,IBPROV,IBSEQ,IBPERF) ; Loop throug ; IBIFN = bill ien (file 399) | ; IBIFN = ien of bill (file 399) ; IBPTYP = ien of the provider id type in file 355.97 | ; IBPTYP = the ien of the provider id type in file 35 ; IBSEQ = numeric COB sequence of the bill | ; IBSEQ = the numeric COB sequence of the bill ; Returns IBT = ptr to file 355.97^entry #^file # < S IBT=+$G(IBPTYP) | N IBSPEC,IBINS,IBINS4,IBSRC,IBUP,IBID,IBALT,Z Q:'$G(IBPERF)!'$G(IBPROV) "" < N IBSPEC,IBINS,IBINS4,IBSRC,IBUP,IBID,IBALT,IBPROF,Z < S IBPROF=($$FT^IBCEF(IBIFN)=2) S:'IBPROF IBPROF=2 | I $G(IBPTYP)="" S IBPTYP=+IBINS4 ;Default to performi ; form type is HCFA (prof)=1, UB92 (inst)=2 | D IDSET^IBCEP2A(IBPTYP,IBINS4,$G(IBPERF),.IBSPEC,.IBS I $G(IBPTYP)="" S (IBT,IBPTYP)=+$P(IBINS4,U,IBPROF) ; < I 'IBPTYP Q "" ; No default id type < S IBSPEC=$G(^IBE(355.97,IBPTYP,1)),IBSRC=$P($G(^IBE(3 < F D Q:'IBUP!($G(IBID)'="") S IBSRC=IBSRC-1 Q:'IBSR | F D Q:IBALT!'IBUP!($G(IBID)'="") S IBSRC=$$ALT^IBC ... S $P(IBT,U,2,3)=(IBPROV_U_200) | .. S IBSTATE=$$CAREST^IBCEP2A(IBIFN) .. S IBSTATE=+$$CAREST^IBCEP2A(IBIFN) < ... S $P(IBT,U,2,3)=(+IBPROV_";"_Z_U_200) < ... I IBPROV["VA(200" S Z=+$O(^VA(200,+IBPROV,"PS1"," | ... S Z=+$O(^VA(200,+IBPROV,"PS1","B",IBSTATE,0)),IBI ... I IBPROV["IBA(355.93" S IBID=$P($G(^IBA(355.93,+I < .. S IBID=IBXDATA,$P(IBT,U,2,3)=(U_350.9) | .. S IBID=IBXDATA . I IBSRC=1 S IBID=$$SRC1(IBIFN,"*ALL*",IBPTYP,IBPROV | . I IBSRC=1 S IBID=$$SRC1(IBIFN,"*ALL*",IBPTYP,IBPROV . I IBSRC=2 S IBID=$$SRC2(IBPTYP,.IBT) Q | . I IBSRC=2 S IBID=$$SRC2(IBPTYP) Q . I IBSRC=3 S IBID=$$SRC3(IBIFN,IBINS,IBPTYP,.IBT) Q | . I IBSRC=3 S IBID=$$SRC3(IBIFN,IBINS,IBPTYP) Q . I IBSRC=4 S IBID=$$SRC4(IBIFN,IBINS,IBPTYP,IBPROV,. | . I IBSRC=4 S IBID=$$SRC4(IBIFN,IBINS,IBPTYP,IBPROV) . I IBSRC=5 S IBID=$$SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,.I | . I IBSRC=5 S IBID=$$SRC5(IBIFN,IBINS,IBPTYP,IBSEQ) Q . I IBSRC=6 S IBID=$$SRC6(IBIFN,IBINS,IBPTYP,IBPROV,I | . I IBSRC=6 S IBID=$$SRC6(IBIFN,IBINS,IBPTYP,IBPROV,I ; IBPID(COB SEQ #,1)=ien of id type (ptr to 355.97) | ; IBPID = the current insurance co's id ; IBPID = current insurance co's id < N Z,COB,Z1,IBT | N Z,COB,Z1 F Z=1:1:3 Q:'$D(^DGCR(399,IBIFN,"I"_Z)) S IBPID(Z)=$ | F Z=1:1:3 Q:'$D(^DGCR(399,IBIFN,"I"_Z)) S IBPID(Z)=$ SRC1(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Licensing/gov't iss | SRC1(IBIFN,IBINS,IBPTYP,IBPROV) ; Licensing/gov't issued # - ; IBPTYP = ien of the provider id type in file 355. | ; IBPTYP = the ien of the provider id type in file ; IBT = returned as type ien^file ien^file # < N IBID,IB,IBRX,IBIDSV | N IBID,IB S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV="" | S IBID="",IB=0 I $G(IBPROV) F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV | F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q . I IBRX,$P($G(^IBA(355.9,IB,0)),U,5)'=3 S:IBIDSV="" < I IBID="",IBIDSV'="" S IBID=IBIDSV < SRC2(IB35597,IBT) ; Facility default - all providers | SRC2(IB35597) ; Facility default - all providers ; IB35597 = ien of the provider id type entry in file | ; IB35597 = the ien of the provider id type entry in ; IBT = returned as type ien^file ien^file # < S $P(IBT,U,2,3)=(+IB35597_U_355.97) < SRC3(IBIFN,IBINS,IBPTYP,IBT) ; Ins co/all providers | SRC3(IBIFN,IBINS,IBPTYP) ; Ins co/all providers N IB,IBID,IBRX,IBIDSV | ; S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV="" | N IB,IBID > S IBID="",IB=0 . S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,"",IB,.IBT) | . S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,"",IB) . I IBRX,$P($G(^IBA(355.91,IB,0)),U,5)'=3 S:IBIDSV="" < I IBID="",IBIDSV'="" S IBID=IBIDSV < SRC4(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Insurance co/indiv | SRC4(IBIFN,IBINS,IBPTYP,IBPROV) ; Insurance co/individual pr N IBID,IB,IBRX,IBIDSV | N IBID,IB S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV="" | S IBID="",IB=0 . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB,.IBT | . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB) . I IBRX,$P($G(^IBA(355.9,IB,0)),U,5)'=3 S:IBIDSV="" < I IBID="",IBIDSV'="" S IBID=IBIDSV < SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,IBT) ; Ins co/all provider | SRC5(IBIFN,IBINS,IBPTYP,IBSEQ) ; Ins co/all providers/care u N IBP,IBUNIT,IBID,IB,Z,IBIDSV,IBRX | N IBP,IBUNIT,IBID,IB,Z S IBID="",Z=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV="" | S IBID="",Z=0 .. S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IB,.IBT) | .. S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IB) .. I IBRX,$P($G(^IBA(355.91,IB,0)),U,5)'=3 S:IBIDSV=" < I IBID="",IBIDSV'="" S IBID=IBIDSV < SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,IBT) ; Ins co/ind | SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ) ; Ins co/ind provider I $G(IBPROV),IBUNIT'="" F S IB=$O(^IBA(355.9,"AD",IB | I IBUNIT'="" F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IB, | . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IB) UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU,IBT) ; Mat | UNIQ(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU) ; Match on most-least ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 *** | ; Start in file 355.96 (All providers) > ; Parameter definitions for UNIQ and UNIQ1: > ; IBIFN = ien of bill (file 399) > ; IBINS = ien of insurance co (file 36) or *ALL* fo > ; IBPTYP = the ien of the provider id type in file > ; IBUNIT = the value of the specific care unit to u > ; or *N/A* if none needed > ; IBCU = the ien of the entry being matched in star > ; > N Q,Z0,Z1,Z2,IBID,IBX > S IBID="" > S IBX=$P($G(^IBA(355.96,+IBCU,0)),U) S:IBX="" IBX="*N > S Z0=$$FT^IBCEF(IBIFN),Z0=$S(Z0=2:2,Z0=3:1,1:0),Z1=$$ > ; > ; Match all elements > F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. > G:IBID'="" UNIQQ > ; > ; Match specific form type, both I/O element or Rx > F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.96 > G:IBID'="" UNIQQ > ; Match both form types,specific I/O element > F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.96 > ; > ; Match both form types,specific I/O element > F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.96 > ; > UNIQQ Q IBID > ; > UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU) ; Match on mo > ; Refer to UNIQ for missing parameter definitions S IBX=$P($G(^IBA(355.9,+IBCU,0)),U,3) S:"0"[IBX IBX=" | S IBX=$P($G(^IBA(355.9,+IBCU,0)),U,3) S:IBX="" IBX="* F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. | F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. | F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9, | F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9, F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9, | F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9, UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on mo | UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU) ; Match on most-least ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 *** < ; < > ; Refer to UNIQ for missing parameter definitions S IBID="" S:"0"[$G(IBUNIT) IBUNIT="*N/A*" | S IBID="" S:$G(IBUNIT)="" IBUNIT="*N/A*" F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. | F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. | F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355. F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91 | F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91 F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91 | F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91 diff -y --suppress-common-lines ./VADemo/r1/IBCEP3.m ./VADemo/r2/r/IBCEP3.m ;;2.0;INTEGRATED BILLING;**137,207,232,280**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 ; IBEMC = no longer used | ; IBEMC = sent as 1 if check for EMC id instead of pe Q:$G(IBEMC) 0 | N Q,Z,Z0,Z4,IB,IBCTYP,IBFTYP,IBQ,IBRX N Q,Z,Z0,Z4,IB,IBCTYP,IBFTYP,IBQ,IBRX,IBPT < S IBPT=$G(IBPTYP) < . I '$G(IBSEQ) S Z=Z+1,IBPTYP=IBPT I Z>3 S IBQ=1 Q ; | . I '$G(IBSEQ) S Z=Z+1 I Z>3 S IBQ=1 Q ; Up to 3 tim . I '$G(IBPTYP) S IBPTYP=+Z4 | . I '$G(IBPTYP) S IBPTYP=$S('$G(IBEMC):+Z4,1:$$EMCID^ . S Q=+$$CAREUN(Z0,IBPTYP,IBFTYP,IBCTYP,IBRX) | . S Q=$S($P(Z4,U,$S('$G(IBEMC):2,1:6))=5:$$CAREUN(Z0, ; IBTYPE = 2:PERFORMING PROVIDER ID | ; IBTYPE = 1:EMC ID 2:PERFORMING PROVIDER ID I $G(IBTYPE)'=2 Q "" | I '$G(IBTYPE) S IBTYPE=2 ;Default if not passed is pe Q $P($G(^DIC(36,+IBINS,4)),U,9) | Q $P($G(^DIC(36,+IBINS,4)),U,(IBTYPE+7)) DELID(IBIFN,IBSEQ,IBX) ; Delete all provider data specific t | DELID(IBIFN,IBSEQ) ; Delete all provider data specific t ; IBX = 1 if called from care unit prompt - don't del | N IBZ,IBDR,X,Y N IBZ,IBDR,X,Y,Z0,Z1 < . ; Delete provider id types | . ; Delete perf prov care unit . I $P(Z0,U,11+IBSEQ)'="" S IBDR(399.0222,IBZ_","_IBI | . I $P(Z0,U,8+IBSEQ)'="" S IBDR(399.0222,IBZ_","_IBIF > . ; Delete EMC care units > . I $P(Z1,U,IBSEQ)'="" S IBDR(399.0222,IBZ_","_IBIFN_ N IBZ,X,Y,IBDR,IBT | N IBZ,X,Y,IBDR Q ; No longer used as of patch 232 | Q:'$G(IBSEQ)!($G(IBSEQ)>3) ;Q:'$G(IBSEQ)!($G(IBSEQ)>3) | F S IBZ=$O(^DGCR(399,IBIFN,"PRV",IBZ)) Q:'IBZ S Z0= ;F S IBZ=$O(^DGCR(399,IBIFN,"PRV",IBZ)) Q:'IBZ S Z0 | . ; Update provider id's if no care unit is needed ;. ; Update provider id's if no care unit is needed | . I $P(Z0,U,2)'="" S IBDR(399.0222,IBZ_","_IBIFN_",", ;. I $P(Z0,U,2)'="" D | . I $D(IBDR) D FILE^DIE(,"IBDR") ;.. S Z=$$GETID^IBCEP2(IBIFN,2,$P(Z0,U,2),IBSEQ,.IBT) < ;.. I Z'="",IBT S IBDR(399.0222,IBZ_","_IBIFN_",",(4+ < ;. I $D(IBDR) D FILE^DIE(,"IBDR") < N Z,Z0,IBC,IBDR,IBT | N Z,Z0,IBC,IBDR . F IBC=5:1:7 I $S(IBFUNC=2:$P(Z0,U,IBC)'="",1:1) S I | . F IBC=5:1:7 I $S(IBFUNC=2:$P(Z0,U,IBC)'="",1:1) S I N D,DIE,DIC,DIK,DIR,DA,X,Y,IB,IBINS,IBF,IBCT,IBOK,IBP | N D,DIE,DIC,DIK,DIR,DA,X,Y,IB,IBINS,IBF,IBCT,IBOK,IBP ; used for insurance co at COB seq IBSEQ for bill ien | ; used for insurance co at COB seq IBSEQ for bill ie ; < ; Parameter definitions for UNIQ1 and UNIQ2 in IBCEP2 < ; IBIFN = ien of bill (file 399) < ; IBINS = ien of insurance co (file 36) or *ALL* fo < ; IBPTYP = the ien of the provider id type in file < ; IBUNIT = the value of the specific care unit to u < ; or *N/A* if none needed < ; IBCU = the ien of the entry being matched in star < ; IBT = the second and third pieces are set to the < diff -y --suppress-common-lines ./VADemo/r1/IBCEP4A.m ./VADemo/r2/r/IBCEP4A.m ;;2.0;INTEGRATED BILLING;**137,232,280**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 S DIC("A")="SELECT CARE UNIT FOR THE INSURANCE CO: ", | S DIR("?",1)="A CARE UNIT MUST BE DEFINED FOR AN INSU G:Y'>0 NEWQ | S DIR("?",2)=" COMBINATION CAN BE ADDED. A CARE UNIT S IB95=3,IB95("IBCU")=+Y | S DIR("?",4)=" UNIQUE PROVIDER ID EXISTS. ONCE A CAR D INSASS(IBINS,.IB95) | S DIR(0)="SA^I:CARE UNIT FOR INSURANCE;C:CARE UNIT CO > S DIR("B")=$P($P($P(DIR(0),":",$S($O(^IBA(355.95,"C", > S DIR("S")="I $S(Y=""C"":$O(^IBA(355.95,""C"",+$G(IBI > S DIR("A")="ADD (I)NS. CO. CARE UNIT OR CARE UNIT (C) > I $D(DTOUT)!$D(DUOUT) G NEWQ > I Y="C" D G NEWQ ; Adds a combination for an existin > . S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S" > . Q:Y'>0 > . S IB95=3,IB95("IBCU")=+Y > . D INSASS(IBINS,.IB95) > W ! S DIR("A")="CARE UNIT NAME: ",DIR(0)="355.95,.01A > I $D(DTOUT)!$D(DUOUT) G NEWQ > S IBOK=1,Z=0 F S Z=$O(^IBA(355.95,"B",Y,Z)) Q:'Z I > . S DIR("A",1)="CAN'T ADD THIS CARE UNIT - IT ALREADY > G NEWQ:'IBOK > W !!,"*** ADDING NEW CARE UNIT: ",$$EXPAND^IBTRE(355. > S DIC(0)="L",DLAYGO=355.95,DIC="^IBA(355.95,",X=Y,DIC > G NEWQ:Y'>0 > S IB95("IBCU")=+Y > S DIR(0)="YA",DIR("A")="DO YOU WANT TO ADD A COMBINAT > I Y=1 S IB95=3 D INSASS(IBINS,.IB95) N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK, | N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK, S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")= | S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")= I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""))="" S IB95= < N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBI | N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBI .. K IBDICS | .. S DIR(0)="355.96,"_Z D ^DIR K DIR .. I Z=.04 D < ... I $P($G(^IBE(355.97,+$G(IB95("IBPTYP")),0)),U,3)= < .. S DIR(0)="355.96,"_Z_$S($G(IBDICS)="":"",1:"^^"_IB < diff -y --suppress-common-lines ./VADemo/r1/IBCEP5A.m ./VADemo/r2/r/IBCEP5A.m ;;2.0;INTEGRATED BILLING;**137,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N DIC,DIR,X,Y,DA,DO,DD,DLAYGO,IBQ,IBIEN,IBPRV0,DTOUT, | N DIC,DIR,X,Y,DA,DO,DD,DLAYGO,IBQ,IBIEN S IBQ=0,IBPRV0=$S(IBPRV'["355.93":"",1:$G(^IBA(355.93 | S IBQ=0 S DIR("S")=$S($G(IBINS):"I ""04""[+$P($G(^(0)),U,2)", | S DIR("S")=$S($G(IBINS):"I ""04""[+$P($G(^(0)),U,2)", I $P($G(^IBE(355.97,+Y,1)),U,3),IBPRV["355.93" D G N < . K DIE,DR < . S DIE="^IBA(355.93,",DA=+IBPRV < . S DR="S Y=""@5"";@1;.07;@5;I $P($G(^IBA(355.93,DA,0 < . D ^DIE < . I '$D(Y) D BLD^IBCEP5 < K IB3559(.06) < NEWQ K VALMBCK | NEWQ S VALMBCK="R" S VALMBCK="R" < N IBDA,DA,DIE,DR | N IBDA G:'IBDA&($E($P(IBDA,U),1,3)'="LIC") DEL1Q | G:'IBDA&($P(IBDA,U)'="LIC") DEL1Q . D DEL^IBCEP5B(355.9,IBDA,""),BLD^IBCEP5 | . D DEL^IBCEP5B(355.9,IBDA),BLD^IBCEP5 . Q:$E($P(IBDA,U),1,3)'="LIC" | . Q:$P(IBDA,U)'="LIC" . I $P(IBDA,U,2)["IBA(355.93" D | . D PRVED(+$P(IBDA,U,2)),BLD^IBCEP5 .. S DA=+$P(IBDA,U,2),DR=".12///@",DIE="^IBA(355.93," < . E D < .. D PRVED(+$P(IBDA,U,2)) < . D BLD^IBCEP5 < N IBDA,DIR,DA,DIE,DR,Z | N IBDA,DIR,Z . Q:$E($P(IBDA,U),1,3)'="LIC" | . Q:$P(IBDA,U)'="LIC" . I $P(IBDA,U,2)["IBA(355.93" D | . D PRVED(+$P(IBDA,U,2)),BLD^IBCEP5 .. S DA=+$P(IBDA,U,2),DIE="^IBA(355.93," < .. S DR="S Y=""@5"";@1;.07;@5;I $P($G(^IBA(355.93,DA, < .. D ^DIE < . E D < .. D PRVED(+$P(IBDA,U,2)) < . D BLD^IBCEP5 < diff -y --suppress-common-lines ./VADemo/r1/IBCEP5B.m ./VADemo/r2/r/IBCEP5B.m IBCEP5B ;ALB/TMP - EDI UTILITIES for prov ID ;29-SEP-00 | IBCEP5B ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 ;;2.0;INTEGRATED BILLING;**137,239,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 NEWID(IBFILE,IBINS,IBPRV,IBPTYP,IBIEN,IBF) ; Generic add | NEWID(IBFILE,IBINS,IBPRV,IBPTYP,IBIEN,IBF) ; Generic add ; at both prov (file 355.9) and ins co levels (355.91 | ; at both prov (file 355.9) and ins co levels (file 3 ; IBFILE = 355.9 or 355.91 - the file being edited | ; IBFILE = 355.9 or 355.91 for the file being edited ; IBINS = ien of ins co (36) or *ALL* for all ins co | ; IBINS = ien of ins co (file 36) or *ALL* for all in ; IBPRV = vp ien of billing prov | ; IBPRV = vp ien of billing prov. ; IBPTYP = ien of prov type (file 355.96) | ; IBPTYP = ien of billing prov type (file 355.96) ; IBIEN = ien of entry being added (req'd) | ; IBIEN = ien of entry being added (required) ; IBF = 1 if deleting from ins-related options, "" fr | ; IBF = 1 if deleting from ins co-related options, "" N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,DTOUT,DUOUT,IB | ; from provider-related options S IB35591(.03)="",IBPTYP=$G(IBPTYP) | N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IBQ,IBCUND,IB3 .. I Z=.03 D | .. I Z=.03,IBFILE'=355.9 D ... S DIR(0)="PAO^355.95:AEMQ" | ... S DIR(0)="PA^355.95:AEMQ" ... S DIR("S")="I $O(^IBA(355.96,""AUNIQ"","_IBINS_", | ... S DIR("S")="I $O(^IBA(355.96,""AUNIQ"","_IBINS_", ... S DIR("S")=DIR("S")_"!($O(^IBA(355.96,""AUNIQ""," | ... S DIR("?",1)="Care unit describes areas of servic ... S DIR("?",1)="Care unit describes areas of servic < .. I Z=.04,$P($G(^IBE(355.97,+IBPTYP,0)),U,3)="1A" D < .. I $D(DTOUT)!$D(DUOUT) S Z="" K IB3559,IB35591 Q | .. I $D(DTOUT)!$D(DUOUT) S Z="" K IB3559 Q .. S IB3559(Z)=$S(Z'=.03:$P(Y,U),1:$S($P(Y,U)>0:$P(Y, | .. S IB3559(Z)=$P(Y,U) .. S:'IBCUND!($G(IB3559(.03))=0) IB3559(.03)="*N/A*" | .. S:'IBCUND IB3559(.03)="*N/A*" . I Z=.03 D CAREUN^IBCEP5C | . I Z=.03,IBFILE'=355.9 D > .. I $D(^IBA(355.91,"AUNIQ",IBINS,IB3559(.03),IB3559( > ... S DIR(0)="EA",DIR("A",1)="This record already exi . W !!,"THE FOLLOWING WAS CHOSEN:" | . W !!,"THE FOLLOWING COMBINATION WAS CHOSEN:" . S Z2=IBINS,Z3=IB35591(.03),Z4=IB3559(.04),Z5=IB3559 | . S Z2=IBINS,Z3=IB3559(.03),Z4=IB3559(.04),Z5=IB3559( . ; If both forms, chk for specific | . ; If both form types, check for specific . ; If specific form, chk for all | . ; If specific form type, check for 'all' . ; If both care types, chk for specific | . ; If both care types, check for specific . ; If specific care type, chk for all | . ; If specific care type, check for 'all' . I 'IBOK K IB3559,IB35591 | . I 'IBOK K IB3559 .. I $D(DTOUT)!$D(DUOUT) K IB3559,IB35591 S IBOK=0 Q | .. I $D(DTOUT)!$D(DUOUT) K IB3559 S IBOK=0 Q .. S IBDR=$S(IBFILE=355.9:$S($G(IBINS):".02////"_IBIN | .. S IBDR=$S(IBFILE=355.9:$S($G(IBINS):".02////"_IBIN ... I $D(Y) K IB3559,IB35591 S IBOK=0 | ... I $D(Y) K IB3559 S IBOK=0 . N DIR,DIK,DA,X,Y < . S DIR(0)="EA",DIR("A",1)=$S('$G(IBOK):"",1:"PROBLEM | . S DIR(0)="EA",DIR("A",1)=$S('$G(IBOK):"",1:"PROBLEM CHG(IBFILE,IBDA) ; Generic call - edit prov id | CHG(IBFILE,IBDA) ; Generic call to edit prov id's ; IBFILE = 355.9 or 355.91 (file being edited) | ; IBFILE = 355.9 or 355.91 for the file being edited ; IBDA = ien in file | ; IBDA = ien of entry in file IBFILE N DIR,DIE,DA,DR,IBCUCHK,IBOK,IB0,IBOLD,X,Y,Z | N DIR,DIE,DA,DR,IBOK,IB0,IBOLD,X,Y,Z . W !,"RECORD LOCKED BY ANOTHER USER - TRY AGAIN LATE | . W !,"RECORD IS LOCKED BY ANOTHER USER - TRY AGAIN L . D ENTER(.DIR) | . S DIR(0)="EA",DIR("A")="PRESS THE ENTER KEY TO CONT F Z=.04,.05,.06,.03 S IBOK=$$EDIT(IBFILE,Z,IB0,IBOLD, | F Z=.04,.05,.06,.03 I $S(Z'=.03:1,1:IBFILE=355.91) S I $P(IBOK,U,2)!(IB0=IBOLD) S DIR(0)="EA",DIR("A")="NO < S IBCUCHK=$$CUCHK^IBCEP5C(IBDA,IB0) G:IBCUCHK CHGQ < F Z=2,4:1:7,3 I $P(IB0,U,Z)'=$P(IBOLD,U,Z) S DR=DR_$S | F Z=2:1:7 I $P(IB0,U,Z)'=$P(IBOLD,U,Z) S DR=DR_$S(DR' ; IBFILE = 355.9 or 355.91 for the file | ; IBFILE = 355.9 or 355.91 for the file being edited ; from prov-related options | ; from provider-related options D DEL^IBCEP5C(IBFILE,IBDA,$G(IBF)) | N IB0,IBLAST,IBX,DIK,DA,DIR,X,Y,Z > F Z=1:1:3 L +^IBA(IBFILE,IBDA):5 Q:$T > I '$T D G DELQ > . W !,"RECORD IS LOCKED BY ANOTHER USER - PLEASE TRY > . S DIR(0)="EA",DIR("A")="PRESS THE ENTER KEY TO CONT > . W ! D ^DIR K DIR W ! > S IB0=$G(^IBA(IBFILE,IBDA,0)) > S IBX=0 > S IBX=IBX+1,DIR("A",IBX)=" PROVIDER: "_$S(IBFILE=355. > D DISP^IBCEP4("DIR(""A"")",$P(IB0,U,$S(IBFILE=355.9:2 > I $P(IB0,U,3)'="" S DIR("A",IBLAST+1)="CARE UNIT: "_$ > S DIR("A",IBLAST+2)=" PROV ID: "_$P(IB0,U,7),DIR("A" > S DIR("A")="OK TO DELETE THIS "_$S($G(IBF):"INSURANCE > S DIR(0)="YA" > W ! D ^DIR K DIR W ! > I Y'=1 G DELQ > I IBDA>0 S DA=IBDA,DIK="^IBA("_IBFILE_"," D ^DIK > DELQ L -^IBA(IBFILE,IBDA) EDIT(IBFILE,IBFLD,IB0,IBOLD,IBIEN,IBCK1) ; Generic edi | EDIT(IBFILE,IBFLD,IB0,IBOLD,IBIEN,IBCK1) ; Generic edi N DIR,Y,X,IB,IB1,IBCUVAL,IBCUY,IBFLD0,IBNEW,IBPRV,IBV | N DIR,Y,X,IB,IB1,IBFLD0,IBNEW,IBPRV,IBVAL,IBIVAL,IBIN I IBFILE=355.91,IBFLD=.02 S IBNEW="" G EDITQ ; No .02 | I IBFILE=355.91,IBFLD=.02 S IBNEW="" G EDITQ ; No fld S IBCUCHK=1,IBCUVAL="" < I IBFLD=.03,$S('IBINS:1,1:'$$CAREUN^IBCEP3(IBINS,$P(I | I IBFLD=.03 G:$S('IBINS:1,1:'$$CAREUN^IBCEP3(IBINS,$P I IBFLD=.03 S IBVAL=$P($G(^IBA(355.95,+$G(^IBA(355.96 < . S IBCUCHK=0,IBCUVAL=$P($G(^IBA(355.96,+IBIVAL,0)),U < . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4), < . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4), < . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$P(IB0,U,5 < . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$P(IB0,U < . S IBIVAL="@" < .. S DIR("S")="I $D(^IBA(355.96,""AUNIQ"",IBINS,Y,$P( | .. S DIR("S")="I $D(^IBA(355.96,""AUNIQ"",IBINS,Y,$P( .. S DIR("S")=DIR("S")_"!($D(^IBA(355.96,""AUNIQ"",IB < . S:IBVAL'=""&(IBCUCHK) DIR("A")=DIR("A")_IBVAL_"// " | . S:IBVAL'="" DIR("A")=DIR("A")_IBVAL_"// " . F D ^DIR S IBOK=0 D Q:IBOK | . D ^DIR K DIR .. I $D(DUOUT)!$D(DTOUT) S IBOK=1 Q | . I IBFLD=.03,'$D(DTOUT),'$D(DUOUT),X'="" S Y=+$O(^IB .. I X="",$P(IB0,U,(IBFLD*100))'="" S (X,Y)=$P(IB0,U, | . I IBIVAL'="",($P(Y,U)=IBIVAL!(X="")) S IBNEW=IBIVAL .. I IBFLD=.06,$P(IB0,U,4)'=1,$P($G(^IBE(355.97,$S(+Y < .. S IBOK=1 < . K DIR < . I IBFLD=.03,'$D(DTOUT),'$D(DUOUT) D S Y=IBCUY < .. S IBCUVAL=+$G(^IBA(355.96,+Y,0)) < .. S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(I < .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBC < .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBC < .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBC < .. I 'IBCUY S IBCUY="@" < . I IBIVAL'="",IBCUCHK,($P(Y,U)=IBIVAL!(X="")) S IBNE < . I 'IBCUCHK,X="" S IBNEW=IBIVAL Q < . I IBFLD=.03,X="" S IBNEW="" ; No care unit selected < SETDIR(DIR) ; Sets dir for BLUE CROSS only UB92 form type < S DIR("B")="UB92",$P(DIR(0),U,3)="K:Y'=1 X",DIR("?")= < Q < ; < ENTER(DIR) ; < S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE: " < Q < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCEP5C.m ./VADemo/r2/r/IBCEP5C.m ;;2.0;INTEGRATED BILLING;**137,239,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N X,Y,Q,DIR,Z,IBD,IBDD,IBOK,IBSPEC | N X,Y,DIR,Z,IBD,IBDD,IBOK,IBSPEC . F S X1=$O(^IBA(IBFILE,"AC",$S(IBFILE=355.9:Z(6),1: | . F S X1=$O(^IBA(IBFILE,"AC",$S(IBFILE=355.9:Z(6),1: CAREUN ;Called from NEWID^IBCEP5B to check for existing reco < N DIR < I IBFILE'=355.9 D < . S IB35591(.03)=IB3559(.03) < . I "0"[IB35591(.03) S IB35591(.03)="*N/A*" < . I IB35591(.03)'="*N/A*" S IB35591(.03)=$O(^IBA(355. < .. S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559 < ... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB355 < .... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB35 < . I $D(^IBA(355.91,"AUNIQ",IBINS,IB35591(.03),IB3559( < .. S DIR(0)="EA",DIR("A",1)="This record already exis < I IBFILE=355.9 D < . S IB35591(.03)=IB3559(.03) < . I "0"[IB35591(.03) S IB35591(.03)="*N/A*" < . I IB35591(.03)'="*N/A*" S IB35591(.03)=$O(^IBA(355. < .. S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559 < ... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB355 < .... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB35 < . I $D(^IBA(355.9,"AUNIQ",IBPRV,IBINS,IB35591(.03),IB < .. S DIR(0)="EA",DIR("A",1)="This record already exis < Q < ; < DEL(IBFILE,IBDA,IBF) ; Delete prov specific ID's < ; IBFILE = 355.9 or 355.91 for the file < ; IBDA = ien of entry in file IBFILE < ; IBF = 1 if deleting from ins co-related options, "" < ; from prov-related options < N IB0,IBLAST,IBX,DIK,DA,DIR,X,Y,Z < F Z=1:1:3 L +^IBA(IBFILE,IBDA):5 Q:$T < I '$T D G DELQ < . W !,"RECORD IS LOCKED BY ANOTHER USER - TRY AGAIN L < . D ENTER^IBCEP5B(.DIR) < . W ! D ^DIR K DIR W ! < S IB0=$G(^IBA(IBFILE,IBDA,0)) < S IBX=0 < S IBX=IBX+1,DIR("A",IBX)=" PROVIDER: "_$S(IBFILE=355. < D DISP^IBCEP4("DIR(""A"")",$P(IB0,U,$S(IBFILE=355.9:2 < I $P(IB0,U,3)'="" S DIR("A",IBLAST+1)="CARE UNIT: "_$ < S DIR("A",IBLAST+2)=" PROV ID: "_$P(IB0,U,7),DIR("A" < S DIR("A")="OK TO DELETE THIS "_$S($G(IBF):"INSURANCE < S DIR(0)="YA" < W ! D ^DIR K DIR W ! < I Y'=1 G DELQ < I IBDA>0 S DA=IBDA,DIK="^IBA("_IBFILE_"," D ^DIK < DELQ L -^IBA(IBFILE,IBDA) < Q < ; < CUCHK(IBDA,IB0) ;Called from CHG^IBCEP5B to check for existin < ; during edit < ; IBDA = the ien of the record being edited < ; IB0 = Proposed changed 0 node of the entry in the f < ; FUNCTION RETURNS 0 if no duplicate found, 1 if reco < N Z,IBCUCHK,DIR,X,Y < S IBCUCHK=0 < I IBFILE=355.91 S Z=+$O(^IBA(355.91,"AUNIQ",$P(IB0,U, < I IBFILE=355.9 D < . N X,X1 < . S X=$S($P(IB0,U,2):$P(IB0,U,2),1:$P(IB0,U,15)) S:X= < . S X1=$S($P(IB0,U,3):$P(IB0,U,3),$P(IB0,U,3)="@":"", < . S Z=+$O(^IBA(355.9,"AUNIQ",$P(IB0,U,1),X,X1,$P(IB0, < I IBCUCHK D < . S DIR(0)="EA",DIR("A",1)="This combination already < Q IBCUCHK < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCEP5.m ./VADemo/r2/r/IBCEP5.m ;;2.0;INTEGRATED BILLING;**137,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT | N IBFILE,DIR,Y,X N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1 | N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z K Z0 < I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPR < .. S CU="" F S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT, | .. S CU="" F S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT, ... S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(3 | ... S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(3 ... S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OU < ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^ | ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=Z BLDQ K VALMCNT,VALMBG | BLDQ S VALMCNT=IBLCT,VALMBG=1 S VALMCNT=IBLCT,VALMBG=1 < diff -y --suppress-common-lines ./VADemo/r1/IBCEP6.m ./VADemo/r2/r/IBCEP6.m ;;2.0;INTEGRATED BILLING;**137,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N IBLCT,IBCT,Z,Z0 | N IBCT,Z,Z0 S Z0=$J("",14)_"-- NON/OTHER VA ENTITY EDITS --" D SE | S Z0=$J("",17)_"-- NON-VA ENTITY EDITS --" D SET1(.IB S Z0=$J("",10)_"6 > NON/OTHER VA PROVIDER ID INFORMAT | S Z0=$J("",10)_"6 > NON-VA PROVIDER ID INFORMATION" D K VALMBG,VALMCNT | S Z0=$J("",10)_"7 > NON-VA FACILITY ID INFORMATION" D N Z,Z1,DIR | N Z,Z1 SELQ K VALMBCK,XQORM("B") | SELQ S VALMBCK="R",XQORM("B")="Quit" S VALMBCK="R",XQORM("B")="Quit" < ;S IBEDIT=1 | S IBEDIT=1 ;S DIR(0)="YA",DIR("B")="NO",DIR("A",1)="WANT TO ATTE | S DIR(0)="YA",DIR("B")="NO",DIR("A",1)="WANT TO ATTEM ;Q:$D(DTOUT)!$D(DUOUT) | Q:$D(DTOUT)!$D(DUOUT) ;I Y=1 S IBEDIT=0 D RECALCA^IBCEP2A(IBIFN) W ! | I Y=1 S IBEDIT=0 D RECALCA^IBCEP2A(IBIFN) W ! ; | ; I '$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",D | I '$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",D ;I 'IBEDIT D | I 'IBEDIT D ;. S DIR(0)="YA",DIR("A")="WANT TO CONTINUE WITH GENE | . S DIR(0)="YA",DIR("A")="WANT TO CONTINUE WITH GENER ;. I $D(DTOUT)!$D(DUOUT)!'Y Q | . I $D(DTOUT)!$D(DUOUT)!'Y Q ;. S IBEDIT=1 | . S IBEDIT=1 D EN | I IBEDIT D EN > ;;NON-VA FACILITY EDIT^NVAFAC^IBCEP8 Only in ./VADemo/r1/: IBCEP7A.m diff -y --suppress-common-lines ./VADemo/r1/IBCEP7.m ./VADemo/r2/r/IBCEP7.m IBCEP7 ;ALB/TMP - Functions for fac level PROVIDER ID MAINT | IBCEP7 ;ALB/TMP - Functions for facility level PROVIDER ID M ;;2.0;INTEGRATED BILLING;**137,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 EN ; -- main entry IBCE PRVFAC MAINT | EN ; -- main entry point for IBCE PRVFAC MAINT N DIC,X,Y,DIR,DUOUT,DTOUT < K ^TMP("IBCE_PRVFAC_MAINT_INS",$J) < S DIR(0)="SA^F:FACILITY SECONDARY BILLING IDS;P:PROVI < S DIR("?",1)="FACILITY SECONDARY BILLING IDs are thos < S DIR("?",3)=" ",DIR("?",4)="PROVIDER IDS are those i < S DIR("B")="FACILITY" W ! D ^DIR K DIR < Q:$D(DUOUT)!$D(DTOUT) < S ^TMP("IBCE_PRVFAC_MAINT_INS",$J)=Y_"^^2" < I Y="F" D Q:'$P(^TMP("IBCE_PRVFAC_MAINT_INS",$J),U,2 < . S DIC="^DIC(36,",DIC(0)="AEMQ" D ^DIC < . I Y>0 S $P(^TMP("IBCE_PRVFAC_MAINT_INS",$J),U,2)=+Y < HDR ; -- hdr code | HDR ; -- header code I $P($G(^TMP("IBCE_PRVFAC_MAINT_INS",$J)),U)="F" D < . S VALMHDR(1)="INSURANCE CO: "_$P($G(^DIC(36,+$P($G( < . S VALMHDR(1)=VALMHDR(1)_" BILLING FACILITY "_$P(" < INIT ; Initialize | INIT ; Initialization N IBCT,IBD,Z,Z0,Z00,Z1,IBS,IBX,IBDIV | N IBCT,Z,Z0,Z1,IBS,IBX I $P($G(^TMP("IBCE_PRVFAC_MAINT_INS",$J)),U)'="F" D | S Z=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z S Z0=$G(^(Z,0)) . S Z=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z S Z0=$G(^(Z,0 | S Z="" F S Z=$O(IBS(Z),-1) Q:Z="" S Z0="" F S Z0=$ ; < I $P($G(^TMP("IBCE_PRVFAC_MAINT_INS",$J)),U)="F" D < . N IBINS,IBPARAM < . S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J)) < . S IBINS=+$P(IBPARAM,U,2) < . S Z=0 F S Z=$O(^IBA(355.92,"B",IBINS,Z)) Q:'Z D < .. S Z0=$G(^IBA(355.92,Z,0)) < .. Q:'$P(Z0,U,6)!($P(Z0,U,7)="")!$S($P(IBPARAM,U,3)=1 < .. S Z1=$G(^IBE(355.97,+$P(Z0,U,6),0)) < .. S IBS(+$P(Z0,U,5),+$P(Z1,U,2)_";"_Z,$P(Z1,U))=+$P( < ; < S IBD="" F S IBD=$O(IBS(IBD)) Q:IBD="" D:IBCT SET1( < . I $P(Z,";",2) D Q | . S Z1=$E(IBCT_$J("",3),1,3)_" "_$E(Z0_$J("",30),1,3 .. S Z00=$G(^IBA(355.92,+$P(Z,";",2),0)) | . D SET1(.IBLCT,Z1,IBCT) .. S Z1=$E(IBCT_$J("",3),1,3)_" "_$E(Z0_$J("",25),1, | . S ^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",IBCT)=IBX .. D SET1(.IBLCT,Z1,IBCT) < .. S ^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",IBCT)=+$P(Z," < . I '$P(Z,";",2) D < .. S Z1=$E(IBCT_$J("",3),1,3)_" "_$E(Z0_$J("",25),1, < .. D SET1(.IBLCT,Z1,IBCT) < .. S ^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",IBCT)=+IBX < . D SET1(2,"No Facility Provider IDs found") | . D SET1(2,"No Facility Default Provider ID Types fou . S IBLCT=2 | . S IBLCNT=2 DIV(IBD) ; Returns 'ALL/DEFAULT' or div NAME whose ien | IDNUM(IBIEN) ; Find site-default id number Q $S(IBD:$$EXTERNAL^DILFD(355.92,.05,"",IBD),1:"ALL/D | ; IBIEN = the ien of the provider ID type (file 355.9 ; | N IBID,Z0,Z1 EDIT1 ; | S IBID="" N IBFUNC,IBINS,IBDA,Z,DIR,X,Y,DTOUT,DUOUT,DP | S Z0=$G(^IBE(355.97,IBIEN,0)),Z1=$G(^(1)) D FULL^VALM1 | I $P(Z0,U,4)'="" S IBID=$P(Z0,U,4) G IDNUMQ I $P($G(^TMP("IBCE_PRVFAC_MAINT_INS",$J)),U)'="F" D | I $P(Z1,U,4) S IBID=$P($G(^IBE(350.9,1,1)),U,5) . D SEL < . I $G(IBDA) S Z=$$EDITFAC(IBDA,"") I Z D INIT < ; < S IBINS=+$P($G(^TMP("IBCE_PRVFAC_MAINT_INS",$J)),U,2) < S DIR("A")="DO YOU WANT TO (A)DD, (E)DIT, or (D)ELETE < S DIR(0)="SA^A:ADD;E:EDIT;D:DELETE",DIR("B")=$S(+$O(^ < D ^DIR K DIR < I $D(DTOUT)!$D(DUOUT) G EDIT1Q < ; < S IBFUNC=Y < I IBFUNC="E"!(IBFUNC="D") D < . D SEL < . I $G(IBDA) S Z=$$EDITFAC(IBDA,IBFUNC) I Z D INIT < I IBFUNC="A" D | IDNUMQ Q IBID . S Z=$$ADDFAC^IBCEP7A(IBINS) I Z D INIT < EDIT1Q S VALMBCK="R" | EDIT1 ; > N IBDA,Z > D SEL > I $G(IBDA) S Z=$$EDITFAC(IBDA) I Z D INIT > S VALMBCK="R" > ; > ; > ; K ^TMP("IBCE_PRVFAC_MAINT",$J),^TMP("IBCE_PRVFAC_MAIN | K ^TMP("IBCE_PRVFAC_MAINT",$J) > ; D FULL^VALM1,EN^VALM2($G(XQORNOD(0)),"OS") | D FULL^VALM1 S Z=+$O(VALMY(0)) Q:'Z | D EN^VALM2($G(XQORNOD(0)),"OS") S IBDA=$G(^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",Z)) | S Z=+$O(VALMY(0)) I $P($G(^TMP("IBCE_PRVFAC_MAINT_INS",$J)),U)'="F",$P( | I Z D ; fac/ins co default | . S IBDA=$G(^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",Z)) S IBDA=$G(^TMP("IBCE_PRVFAC_MAINT",$J,"ZIDX",Z)) | . I $P($G(^IBE(355.97,+IBDA,0)),U,5) D NOEDIT(IBDA) K Q | Q ; | ; EDITFAC(IBDA,IBFUNC) ; Edits fac def entry in file 355.97 | EDITFAC(IBDA) ; Edits facility default entry in file 355.97 ; OR edits ins co facility id (355.92), entry IBDA | N IBRBLD,Z,DIR,X,Y N IBRBLD,Z,Z0,DIK,DIE,DP,DA,DR,DIR,X,Y,IBDA0,IBDIV,IB | S IBRBLD=0 S IBRBLD=0 S:$G(IBDA) IBDA0=$G(^IBA(355.92,+IBDA,0)) | S Z=$$IDNUM(IBDA) I IBFUNC="" D | S DIR(0)="FAO^1:15" . S Z=$$IDNUM^IBCEP7A(IBDA) | S DIR("A")=$P($G(^IBE(355.97,IBDA,0)),U)_": "_$S(Z'=" . S DIR(0)="FAO^1:15" | S DIR("?")="^N IBHELP,Z D HELP^DIE(355.97,,.04,""A"", . S DIR("A")=$P($G(^IBE(355.97,IBDA,0)),U)_": "_$S(Z' | W ! D ^DIR K DIR W ! . S DIR("?")="^N IBHELP,Z D HELP^DIE(355.97,,.04,""A" | I Y'=""!(X="@") D . W ! D ^DIR K DIR W ! | . N IBOUT . I Y'=""!(X="@") D | . S:X="@" Y=X,IBOUT=0 .. N IBOUT | . I Y="@" D .. S:X="@" Y=X,IBOUT=0 | .. N Y .. I Y="@" D | .. S DIR(0)="YA",DIR("B")="NO",DIR("A")="Are you sure ... N Y | .. I Y'=1!$D(DUOUT)!$D(DTOUT) S IBOUT=1 Q ... S DIR(0)="YA",DIR("B")="NO",DIR("A")="Are you sur | .. S IBRBLD=1 ... I Y'=1!$D(DUOUT)!$D(DTOUT) S IBOUT=1 Q | . I '$G(IBOUT) S DIE="^IBE(355.97,",DA=IBDA,DR=".04// ... S IBRBLD=1 < .. I '$G(IBOUT) S DIE="^IBE(355.97,",DA=IBDA,DR=".04/ < ; < I IBFUNC="E" D < . S Z0=$TR(IBDA0,U) < . Q:'$$FACFLDS(IBDA,IBINS,.IBITYP,.IBFORM,.IBDIV,"E") < . S DIE="^IBA(355.92,",DR=".04////"_IBFORM_$S(IBDIV:" < . I $TR($G(^IBA(355.92,IBDA,0)),U)'=Z0 S IBRBLD=1 < . ; < I IBFUNC="D" D < . W !!,"INSURANCE CO: ",$P($G(^DIC(36,+IBDA0,0)),U) < . W !," DIVISION: ",$$DIV($P(IBDA0,U,5)) < . W !," ID TYPE: ",$$EXTERNAL^DILFD(355.92,.06,"" < . W !," FORM TYPE: ",$$EXTERNAL^DILFD(355.92,.04,"" < . W !," ID: ",$P(IBDA0,U,7),! < . S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DE < . S DIR("A")="NOTHING DELETED - PRESS RETURN TO CONTI < . I Y=1 S DIK="^IBA(355.92,",DA=IBDA D ^DIK S DIR("A" < . S DIR(0)="EA" W ! D ^DIR K DIR < ; < FACID(Y) ; | NOEDIT(IBDA) ; Display no edit message for entries in file N Z,Z1,Z2 < S Z=U_$P($G(^IBE(355.97,+Y,0)),U,3)_U,Z1=$$SUB2^IBCEF < I Z1[Z!(Z2[Z) Q 1 < Q 0 < ; < FACFLDS(IBDA,IBINS,IBITYP,IBFORM,IBDIV,IBFUNC) ; Chk for dup < N IB,IB,IBOK,DIC,DIR,X,Y,DTOUT,DUOUT,Z,Z0,DIE,DA,IBMA < S IBPARAM=$G(^TMP("IBCE_PRVFAC_MAINT_INS",$J)) < S (IBQUIT,IBOK)=0,DA=$G(IBDA),IBMAIN=$$MAIN^IBCEP2B() < S DIR("A")="DIVISION: ",DIR(0)="355.92,.05AO",DIR("B" < G:$D(DTOUT)!$D(DUOUT) FLDSQ < S IBDIV=+$S(Y>0:+Y,1:0) < I IBDIV=IBMAIN S IBDIV=0 < I $P(IBPARAM,U,3)'=1 D < . S DIR("?")="CANNOT BE STATE LIC # or BILLING FACILI < . S DIR("A")="TYPE OF ID: ",DIR(0)="355.92,.06A^^K:'$ < . I $D(DTOUT)!$D(DUOUT) S IBQUIT=1 < E D < . S Y=$$BF^IBCU() < . W !,"TYPE OF ID: ",$P($G(^IBE(355.97,+Y,0)),U) < G:IBQUIT FLDSQ < S IBITYP=$P(Y,U) < S DIR("A")="FORM TYPE APPLIED TO: ",DIR(0)=$S($P(IBPA < S:$P(IBPARAM,U,3)=1&$G(IBDA) DIR("B")=$P("UB92^HCFA 1 < I $P($G(^IBE(355.97,+IBITYP,0)),U,3)="1B"!($P($G(^IBE < . S $P(DIR(0),U,3)="I +Y'=3 K:+Y'="_$S($P(^IBE(355.97 < . S DIR("?")="FOR AN ID TYPE OF "_$$EXTERNAL^DILFD(35 < D ^DIR K DIR < G:$D(DTOUT)!$D(DUOUT) FLDSQ < S IBFORM=$P(Y,U) < S Z=0 F S Z=$O(^IBA(355.92,"B",IBINS,Z)) Q:'Z S Z0= < S IBOK=1 < I IBFUNC="E" S Z0=$G(^IBA(355.92,IBDA,0)) I IBFORM=$P < I $G(IB(IBFORM,IBDIV)) S IBOK="0^DUPLICATE" < I IBOK,IBFORM=0,$S($D(IB(1,IBDIV))!$D(IB(2,IBDIV)):1, < I IBOK,IBFORM'=0,IBFORM'=3,$S($D(IB(0,IBDIV)):1,1:0) < ; < I 'IBOK D < . I $P(IBOK,U,2)="DUPLICATE" D Q < .. S DIR("A",1)="THIS ID COMBINATION ALREADY EXISTS"_ < . ; < . I $P(IBOK,U,2)="BOTH" D Q < .. S DIR("A",1)="AN ID COMBINATION FOR BOTH FORM TYPE < . ; < . I $P(IBOK,U,2)="FORM" D Q < .. I $P(IBOK,U,3)="BOTH" S DIR("A",1)="THIS ID ALREAD < .. S DIR("A",1)="THIS ID ALREADY EXISTS FOR A SPECIFI < . ; < ; < I 'IBOK S DIR(0)="EA",DIR("A")="PRESS RETURN TO CONTI < ; < FLDSQ Q +IBOK < ; < NOEDIT(IBDA) ; Display no edit msg for entries in file 355 < diff -y --suppress-common-lines ./VADemo/r1/IBCEP8.m ./VADemo/r2/r/IBCEP8.m ;;2.0;INTEGRATED BILLING;**51,137,232,288**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT | N DIC,DA,X,Y,DLAYGO S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA | S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=2",DIC( I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ | S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON S IBIF=Y < S DIC="^IBA(355.93,",DIC("DR")=".02////"_$S(IBIF'="F" < S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1) < S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON < S Z1=$J("",10)_" TYPE: "_$S($P(Z,U,2)=2:"INDIVI | S Z1=$J("",10)_"CREDENTIALS: "_$P(Z,U,3) D SET1(.IBLC I $P(Z,U,2)=2 D | S IBCT=IBCT+1 . S IBCT=IBCT+1 | S Z1=$J("",10)_" SPECIALTY: "_$P(Z,U,4) D SET1(.IBLC . S Z1=$J("",10)_"CREDENTIALS: "_$P(Z,U,3) D SET1(.IB < . S IBCT=IBCT+1 < . S Z1=$J("",10)_" SPECIALTY: "_$P(Z,U,4) D SET1(.IB < E D < . S IBCT=IBCT+1 < . S Z1=" " D SET1(.IBLCT,Z1,IBCT) < . S IBCT=IBCT+1 < . S Z1=$J("",10)_" ADDRESS: "_$P(Z,U,5) D SET1(.IB < . I $P(Z,U,10) D < .. S IBCT=IBCT+1 < .. S Z1=$J("",23)_$P(Z,U,10) < . S IBCT=IBCT+1 < . S Z1=$J("",23)_$P(Z,U,6)_$S($P(Z,U,6)'="":", ",1:"" < K VALMBG,VALMCNT < EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demog | EDIT1(IBNPRV) ; Edit non-VA provider/facility demographics ; IBNOLM = 1 if not called from list manager < I '$G(IBNOLM) D FULL^VALM1 | D FULL^VALM1 . I '$G(IBNOLM) D CLEAR^VALM1 | . D CLEAR^VALM1 . S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08; | . S DR=".01;"_$S(IBP:".03;.04",1:".05;.06;.07;.08;.09 . Q:$G(IBNOLM) | . D:IBP BLD . D BLD | S VALMBCK="R" I '$G(IBNOLM) K VALMBCK S VALMBCK="R" < S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON | S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON D EDIT1(IBNPRV,1) | D EDIT1(IBNPRV) I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_ | I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_ ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for p < ; for all provider id types or for id type in IBPTYP < ; IBPRV = vp ien of provider < ; IBPTYP = ien of provider id type to return or "" fo < ; IBZ = array returned with internal data: < ; IBZ(file 355.9 ien)=ID type^ID#^ins co^form typ^bi < N Z,Z0 < K IBZ < G:'$G(IBPRV) ALLIDQ < S IBPTYP=$G(IBPTYP) < S Z=0 F S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z S Z0=$ < . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($ < ; < ALLIDQ Q < ; < CLIA() ; Returns ien of CLIA # provider id type < N Z,IBZ < S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^ < Q IBZ < ; < STLIC() ; Returns ien of STLIC# provider id type < N Z,IBZ < S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^ < Q IBZ < ; < TAXID() ; Returns ien of Fed tax id provider id type < N Z,IBZ < S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^ < Q IBZ < ; < CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bil < N IBCLIA,IBZ,IBNVA,Z < S IBCLIA="",IBZ=$$CLIA() < I IBZ D < . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA < . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355. < Q IBCLIA < ; < VALFAC(X) ; Function returns 1 if format is valid for X < ; Alpha/numeric/certain punctuation valid. Must star < N OK,VAL < S OK=1 < S VAL("A")="",VAL("N")="",VAL=",.- " < I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0 < Q OK < ; < VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not < ; X = data to be examined < ; VAL = a 'string' of valid characters AND/OR (passed < ; if VAL("A") defined ==> Alpha < ; if VAL("A") defined ==> Numeric valid < ; if VAL("A") defined ==> Punctuation valid < ; any other character included in the string is che < N Z < I $D(VAL("A")) D < . N Z0 < . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)="" < . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" < I $D(VAL("N")) D < . N Z0 < . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)="" < . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" < I $D(VAL("P")) D < . N Z0 < . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)="" < . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" < I $G(VAL)'="" S X=$TR(X,VAL,"") < Q (X="") < ; < PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the < ; < Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC")) < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCEP9B.m ./VADemo/r2/r/IBCEP9B.m ;;2.0;INTEGRATED BILLING;**137,200**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 > ; If IBQUOTES=1, quoted strings are double quoted wit ; IBX = array returned if passed by reference, subscr < ; If IBQUOTES=1, quoted strings are double quoted wit | ; IBX = array returned if passed by reference, subscr N FC,I,PC,QCT,QM,QM2,QM4,STR,TPC | N A,B,C,D,E,Z,Z0 S FC=0,TPC=$L(X,IBDEL),QM=$C(34),QM2=QM_QM,QM4=QM2_QM | S Z0=0 F PC=1:1:TPC D | F Z=1:1:$L(X,IBDEL) S Z0=Z0+1,IBX(Z0)=$P(X,IBDEL,Z) D . S STR=$P(X,IBDEL,PC) | . ; re-combine pieces where comma was embedded in fie . S FC=FC+1 | . I $E(IBX(Z0))="""" D . I (STR=QM2)!(STR=QM4) S IBX(FC)="" Q | .. I $E(IBX(Z0),2)="""",$L(IBX(Z0))=2 S IBX(Z0)="" Q . I $E(STR,1)=QM D | .. F Q:($L(IBX(Z0),"""")#2) S IBX(Z0)=IBX(Z0)_IBDEL .. F QCT=0:1 Q:$E(STR,QCT+1)'=QM | .. ; Field begins,ends with a quote if comma containe .. F Q:($E(STR,1,QCT)=$E(STR,$L(STR)-(QCT-1),$L(STR) | .. I IBX(Z0)[IBDEL S IBX(Z0)=$E(IBX(Z0),2,$L(IBX(Z0)) .. I PC>TPC S IBX(0)="-1^UNMATCHED QUOTE MARKS" Q | .. Q:'$G(IBQUOTES) .. F Q:$E(STR,1)'=QM I $E(STR,$L(STR))=QM S STR=$E( | .. ; Get rid of any double quotes around quoted strin . I IBQUOTES,STR[QM2 D | .. S E=IBX(Z0) .. F I=1:1:$L(STR) I $E(STR,I,I+1)=QM2 S STR=$E(STR,1 | .. F B=1:1:($L(IBX(Z0),"""""")\2) D . S IBX(FC)=STR | ... S E="",D=0 > ... F S C=$F(IBX(Z0),"""""",D) S:'C E=E_$E(IBX(Z0),D > .... S E=E_$E(IBX(Z0),D,C-2) > .... F A=C:1:$L(IBX(Z0)) I $E(IBX(Z0),A)'="""" S A=$F > .... S D=A > .. S IBX(Z0)=E N IBCRED,IBDA,IBNAM,IBSSN | N DIR,Y,IBSORT,IBSTART,Z ; S IBCNT=0 ; this looks like extraneous code, IBCNT | S DIR(0)="SAO^N:PROVIDER NAME;S:PROVIDER SSN;X:NO SOR F D I X=""!(X["^") Q | S DIR("A")="SORT PROVIDER LIST BY: ",DIR("B")="PROVID . S Y=$$LOOKUP^XUSER Q:X="" I X["^" S IBQUIT1=1 Q | S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1,,1,1) . S IBDA=+Y,IBNAM=$P(Y,U,2) | Q:IBQUIT1 . S IBSSN=$$GET1^DIQ(200,IBDA_",",9,"I") | S IBSORT=$S(Y="N":1,Y="S":2,1:0) . S IBCRED=$$GET1^DIQ(200,IBDA_",",10.6,"I") | D START^IBCEP9A(1) . S ^TMP("IBPID_IN",$J,U,IBDA)=IBSSN_U_IBNAM_" "_IBCR | I '$O(^TMP("IBPID",$J,0)) D Q > . S DIR(0)="AE",DIR("A",1)="NO PROVIDER ID RECORDS FO > . S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1,,1,1) > . Q:IBQUIT1 > . ; > S IBSTART="" > I IBSORT D Q:IBQUIT1 > . S DIR(0)="FA^1:30",DIR("A")="START WITH PROVIDER "_ > . S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1,,1,1) > . Q:IBQUIT1 > . S IBSTART=$S(Y="FIRST":"",1:Y) > S Z=0 F S Z=$O(^TMP("IBPID",$J,Z)) Q:'Z S Z0=$G(^(Z > . N IBNAM,IBSSN,IBCRED,S1 > . S IBNAM=$P($G(^VA(200,Z,0)),"^") > . S IBSSN=$P($G(^VA(200,Z,1)),"^",9) > . S IBCRED=$P($G(^VA(200,Z,3.1)),"^",6) > . S S1=$S(IBSORT=1:IBNAM,IBSORT=2:IBSSN,1:"")_U > . S:$S('IBSORT:1,S1=IBSTART:1,1:S1]IBSTART) ^TMP("IBP > . ; S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1) | S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1,,1,1) DISP(Q,IBID,IBINS,IBPTYP,IBFT,IBCT,IBCU,IBPID,IBSRC) ; Dis | DISP(Q,IBID,IBINS,IBPTYP,IBFT,IBCT,IBCU,IBPID) ; Display pro ; Q = SSN^provider name from input^provider name from | ; Q = provider name^SSN^credentials S $P(Q,U,2)=$$FLEN($P(Q,U,2)) | S Q0(1)="PROVIDER : "_$P(Q,U)_$S($P(Q,U,3)'="":" ("_$ S Q0(1)="PROVIDER : "_$P(Q,U)_$S($P(Q,U,2)'="":" ("_$ < S Q0(2)="" S:IBSRC="F" Q0(2)=$J("("_$P(Q,U,3),22+$L($ < D DISP^IBCEP4("Q0",IBINS,IBPTYP,IBFT,IBCT,3,.IBL) | D DISP^IBCEP4("Q0",IBINS,IBPTYP,IBFT,IBCT,2,.IBL) .. W !,$S(Z="TID":"TAX ID NUMBER",Z="INST_ID":"INSTIT | .. W !,$S(Z="TID":"TAX ID NUMBER",Z="INST_ID":"INSTIT . S P(Q)=$$FLEN($E(X,+Z,$S($P(Z,U,2):$P(Z,U,2),1:+Z)) | . S P(Q)=FLEN($E(X,+Z,$S($P(Z,U,2):$P(Z,U,2),1:+Z))) ADDID(IB200,IBINS,IBCU,IBFT,IBCT,IBPTYP,IBQUIT,IBQUIT1) ; Add | ADDID(IB200,IBINS,IBCU,IBFT,IBCT,IBPTYP,IBQUIT,IBQUIT1) ; Add S Y=+$O(^IBA(355.9,"AUNIQ",X,$S(IBINS:IBINS,1:"*ALL*" | S DIC(0)="L",DIC="^IBA(355.9,",DLAYGO=355.9,DIC("DR") I 'Y D | D FILE^DICN K DIC,DO,DD,DLAYGO . S DIC(0)="L",DIC="^IBA(355.9,",DLAYGO=355.9,DIC("DR < . D FILE^DICN K DIC,DO,DD,DLAYGO < N IBPAGE,Z,Z0,Z1,Z2,Z3,IBLCT,IBSTOP,IBHDT | N IBPG,Z,Z0,Z1,IBLCT,IBSTOP,IBHDT I $D(^TMP("IBPID-ERR",$J)) D | S IBSTOP=0,IBLCT=$$HDR(.IBPG,.IBSTOP,.IBHDT) . S IBSTOP=0,IBLCT=$$HDR(.IBPAGE,.IBSTOP,.IBHDT) | S Z=0 F S Z=$O(^TMP("IBPID-ERR",$J,Z)) Q:'Z W !!,$P . S Z=0 F S Z=$O(^TMP("IBPID-ERR",$J,Z)) Q:'Z W !!, < .. S Z0="" < .. F S Z0=$O(^TMP("IBPID-ERR",$J,Z,Z0)) Q:Z0="" S I < ... S Z1="" F S Z1=$O(^TMP("IBPID-ERR",$J,Z,Z0,Z1)) < .... S Z2="" F S Z2=$O(^TMP("IBPID-ERR",$J,Z,Z0,Z1,Z < ..... W " "_$S(Z2="CU":"CARE UNIT",Z2="CRED":"CREDEN < FILED ; Prints all filed records < I $D(^TMP("IBPID_IN",$J)) D < . S IBSTOP=0,IBLCT=$$HDR(.IBPAGE,.IBSTOP,.IBHDT) < . W !!," RECORDS SELECTED FOR FILING:" < . F S Z0=$O(^TMP("IBPID_IN",$J,U,Z0)) Q:Z0="" S IBL | . F S Z=$O(^TMP("IBPID-ERR",$J,Z,Z0)) Q:Z0="" W !,Z .. I $G(^TMP("IBPID_IN",$J,U,Z0,0))="NO PRINT" S:IBLC | . W " "_$S(Z2="INST_ID":"INSTITUTIONAL ID",Z2="PROF_ .. S Z=^TMP("IBPID_IN",$J,U,Z0) | . I ($Y+5)>IOSL S IBLCT=$$HDR(.IBPAGE,.IBSTOP) Q:IBST .. W !,$P(Z,U,1),?12,$P(Z,U,2),?52,$G(^TMP("IBPID_IN" < ; < I $E(IOST,1,2)["C-",'IBSTOP K DIR S DIR(0)="E" D ^DIR < I '$G(PG) S IBHDT="RUN DATE: "_$$FMTE^XLFDT($$NOW^XLF | I '$G(PG) S IBHDT="RUN DATE: "_$$FMTE^XLFDT("NOW",2)_ diff -y --suppress-common-lines ./VADemo/r1/IBCEP9.m ./VADemo/r2/r/IBCEP9.m ;;2.0;INTEGRATED BILLING;**137,200**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N A,DA,DIC,DIE,DIK,DIR,DR,POP,Q,Q0,X,Y,Y3,Z,Z0 | N DIC,DIR,DIE,DIK,DA,DR,A,Q,Q0,S1,X,Y,Z,Z0 N IBCND,IBCU,IBCT,IBDELIM,IBFILE,IBFILEN,IBFILEP,IBFO | N IBINS,IBSRC,IBPT,IBFT,IBCT,IBCU,IBPOS,IBCND,IBQUIT, N IBFT,IBINFILE,IBINS,IBL,IBN,IBOK,IBOPEN,IBPOS,IBPT, | N IBFILE,IBINFILE,IBFILEN,IBFILEP,IBOPEN,IBS,IBN,IBST N IBQUIT1,IBQUOTES,IBRA,IBS,IBSA,IBSTART,IBSRC,IBVERI | N IBDELIM,IBQUOTES,IBFORMAT S IBQUIT=0 | S (IBOPEN,IBQUIT)=0 1 ; Select INSURANCE COMPANY NAME: | 1 G:IBQUIT ENQ G:IBQUIT ENQ < 2 ; get data source | ; G:IBQUIT ENQ | 2 G:IBQUIT ENQ S DIR(0)="SA^M:Manual Entry;F:Entry from file" | S DIR(0)="SA^M:Manual Entry;P:Entry from PHOEBE File; I Y=""!("FM"'[Y)!IBQUIT1 G 1 | I Y=""!("MPO"'[Y)!IBQUIT1 G 1 > I Y'="M" W !,"SORRY - ONLY 'M' CURRENTLY WORKS" G 2 S IBVERIFY=(Y="M") | S IBVERIFY=(Y=1) I 'IBVERIFY D G:IBQUIT ENQ G:IBQUIT 2 < . S DIR(0)="YA",DIR("A")="DO YOU WANT TO VIEW/VERIFY < . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1) < . I Y=1 S IBVERIFY=1 < 21 ; get parameters for file type | G:IBSRC="P" 3 G:IBQUIT ENQ | ; > 21 G:IBQUIT ENQ S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1) | S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,1,1) . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1) | . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,1,1) . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1) | . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,1,1) 3 ; select external file name | 3 G:IBQUIT ENQ G:IBQUIT ENQ < S IBSA("*")="" | S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1) S DIR("?")="^S Y3=$$LIST^%ZISH(IBFILEP,""IBSA"",""IBR < S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1) < K ^TMP($J),IBRA,Y3 | D OPEN^%ZISH("IBINFILE",IBFILEP,IBFILEN,"R") N Y S Y=$$FTG^%ZISH(IBFILEP,IBFILEN,$NA(^TMP($J,1)),2 | I POP W !,"FILE ",IBFILEP,IBFILEN," COULD NOT BE FOUN I Y=0 W !,"FILE ",IBFILEP,IBFILEN," COULD NOT BE FOUN | S IBFILE=IO,IBOPEN=1 S IBFILE=IO | ; 4 ; select Provider ID Type | ; ***** PHOEBE file extract to create ^TMP("IBPID_IN" G:IBQUIT ENQ | I IBSRC="P" D G P1 > . ; Load IBPOS with the specifics of the PHOEBE file > . S IBPOS="D^,^1" > . S IBPOS("SSN")="4",IBPOS("NAM")="1^3",IBPOS("TID")= > . D READFILE(IBFILE,IBSRC,,,,,0,.IBPOS) > ; > 4 G:IBQUIT ENQ I IBSRC="M" S Z=$P($G(^IBE(355.97,+$$PPTYP^IBCEP0(IBI | S Z=$P($G(^IBE(355.97,+$$PPTYP^IBCEP0(IBINS),0)),U) S 5 ; select Forms Type | ; G:IBQUIT ENQ | 5 G:IBQUIT ENQ S DIR(0)="355.9,.04r",DIR("B")="BOTH UB92 AND HCFA 15 | S DIR(0)="355.9,.04",DIR("B")="BOTH UB92 AND HCFA 150 6 ; select Bill Care Type | ; G:IBQUIT ENQ | 6 G:IBQUIT ENQ S DIR(0)="355.9,.05r",DIR("B")="BOTH INPATIENT AND OU | S DIR(0)="355.9,.05",DIR("B")="BOTH INPATIENT AND OUT 7 ; get Care Unit | 7 G:IBQUIT ENQ G:IBQUIT ENQ < I IBSRC="F" D I IBQUIT1 G:'IBCND 6 G 7 | I IBSRC="O" D G:IBQUIT1 7 . F Z="PROV. SSN^SSN^15^1","PROV. NAME^NAM^30","PROV. | . F Z="PROV. SSN^SSN^15^1","PROV. NAME^NAM^30","PROV. .. I $P(IBPOS,U)'="D" D | .. I $P(IBPOS,U)="D" D ... I IBFT=0!(IBFT=1) Q:Z["PROF_ID" I Z["INST_ID" S < ... I IBFT=2 Q:Z["INST_ID" < ... S DIR(0)="NA"_$S($P(Z,U,4)!($P(Z,U)["PROV. ID")!( | ... S DIR(0)="NA"_$S($P(Z,U,4):"",1:"O")_"^1:250" ... W ! S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1) | ... S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1) .. I $P(IBPOS,U)="D" D | .. I $P(IBPOS,U)'="D" D ... I IBFT=0!(IBFT=1) Q:Z["PROF_ID" I Z["INST_ID" S | ... S DIR("A")="STARTING '"_$P(IBPOS,U,2)_"' PIECE # ... I IBFT=2 Q:Z["INST_ID" | ... S DIR(0)="NA"_$S($P(Z,U,4):"",1:"O") ... W ! S DIR("A")="STARTING '"_$P(IBPOS,U,2)_"' PIEC < ... S DIR(0)="NA"_$S($P(Z,U,4)!($P(Z,U)["PROV. ID")!( < .... W ! I Y>0,Y'=IBPOS($P(Z,U,2)) S $P(IBPOS($P(Z,U, | .... I Y>0,Y'=IBPOS($P(Z,U,2)) S $P(IBPOS($P(Z,U,2)), . D READFILE | . D READFILE(IBFILE,IBSRC,IBFT,IBPTYP,IBCT,$G(IBCU),0 .. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU) | .. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU) .. S IBID=$P($G(^IBA(355.9,+IBN,0)),U,7) < .. S:$L(IBID) ^TMP("IBPID_IN",$J,U,Z0,"INST_ID")=IBID < .. I IBID="" K ^TMP("IBPID_IN",$J,U,Z0) < .. I IBQUIT=1 F S Z0=$O(^TMP("IBPID_IN",$J,U,Z0)) Q: < . N IBX,IBID < . M IBX=^TMP("IBPID_IN",$J,Z,Z0) < . I IBSRC="F" S IBID=$S(IBFT=0!(IBFT=1):$G(IBX("INST_ < .. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU) | .. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU) .. W !,"PROVIDER ID: ",IBID | .. S DIR("A")="OK TO FILE THESE ID'S FOR THIS PROVIDE .. S DIR("A")="OK TO FILE THIS ID FOR THIS PROVIDER?: < ... S ^TMP("IBPID-ERR",$J,2,$P(IBX,U),$P(IBX,U,2)_" " < ... S ^TMP("IBPID_IN",$J,U,Z0,0)="NO PRINT" < ... S Z1="" F S Z1=$O(IBX(Z1)) Q:Z1="" I $G(IBX(Z1) | ... F Z1="INST_ID","PROF_ID","CU","CRED","TID","LIC_S > .... I $G(IBX(Z1))'="" S ^TMP("IBPID-ERR",$J,2,P(1),P .. I IBSRC="F" D | .. F Z1="INST_ID^1","PROF_ID^2","TID^3","UPIN^4","LIC ... I IBID'="" D | ... N IBPC2 .... S IBN=$$ADDID^IBCEP9B(+Z0,IBINS,$G(IBCU),IBFT,IB | ... S IBPC2=$P(Z1,U,2) .... I IBQUIT D:IBN>0 Q | ... Q:IBPC2>4 ..... S DA=+IBN,DIK="^IBA(355.9," D ^DIK | ... S IBFT=$S(IBPC2>3:0,1:$P("1^2",U,IBPC2)) .... I IBN>0 S DIE="^IBA(355.9,",DA=+IBN,DR=".07////" | ... S IBCT=0,IBCU=$G(P("CU")) > ... S IBPTYP=$S(IBPC2=3:+$O(^IBE(355.97,"B","PROVIDER > ... Q:'IBPTYP > ... S IBN=$$ADDID^IBCEP9B(+Z0,IBINS,IBCU,IBFT,IBCT,IB > ... I IBQUIT D Q > ... I IBN>0 D > .... S DIE="^IBA(355.9,",DA=+IBN,DR=$S(IBPTYP="":"",1 ENQ ; Print report, exit | ENQ I $G(IBOPEN) D CLOSE^%ZISH("IBINFILE") I ($D(^TMP("IBPID-ERR",$J)))!($D(^TMP("IBPID_IN",$J)) | I $D(^TMP("IBPID-ERR",$J)) D . I $D(IO("Q")) K IO("Q") D D ^%ZTLOAD K ZTSK D HOME | . I $D(IO("Q")) K IO("Q") S ZTRTN="PRTERR^IBCEP9B",ZT .. S ZTRTN="PRTERR^IBCEP9B",ZTSAVE("^TMP(""IBPID-ERR" < .. S ZTSAVE("^TMP(""IBPID_IN"",$J,")="",ZTSAVE("IB*") < .. S ZTDESC="IB - PROVIDER ID BATCH UPDATE ERROR LOG" < READFILE ; Read records stored in ^TMP($J | READFILE(IBFILE,IBSRC,IBFT,IBPT,IBCT,IBCU,IBSORT,IBPOS) ; Rea ; | ; and store them in ^TMP global N D,DA,DIC,IBCT,IBP,IBQUIT,IBS,IBX,P,P3,X,Y,Z < S (IBCT,IBQUIT,IBQUIT1,IBS)=0 < U IO(0) < F S IBCT=$O(^TMP($J,IBCT)) Q:'IBCT S X=$G(^(IBCT)) | N DIC,D,X,Y,DA,IBS,IBQUIT,P,P3,Z,IBP,IBX . D Q:IBQUIT | U IBFILE > S (IBS,IBQUIT,IBQUIT1)=0 > F R X:DTIME Q:$$STATUS^%ZISH I X'="" D Q:IBQUIT > . I IBSRC="P" D Q:IBQUIT1 ; PHOEBE file format > .. F Z=1:1:10 S IBX(Z)="" > .. D CSV^IBCEP9B(X,.IBX,",",1) ; Parse comma-delimite > .. D DSETUP^IBCEP9B(.IBX,.IBPOS,.P) > .. I $G(P("TID"))="",$G(P("UPIN"))="" S IBQUIT1=1 ; N > . ; > . I IBSRC'="P" D Q:IBQUIT ; OTHER FORMATS ... D DSETUP^IBCEP9B(.IBX,.IBPOS,.P) K IBX | ... D DSETUP^IBCEP9B(.IBX,.IBPOS,.P) .. I $P($G(IBPOS),U)'="D" D FSETUP^IBCEP9B(X,.IBPOS,. | .. I $P($G(IBPOS),U)'="D" D FSETUP^IBCEP9B(.IBX,.IBPO . I $G(P(1))'="" S P(1)=$$NOPUNCT^IBCEF(P(1),1),X=P(1 | . I $G(P(1))'="" S X=P(1),D="SSN",DIC="^VA(200,",DIC( . S IBP=+Y,IBVNAME=$P(Y,U,2) | . S IBP=+Y . I $S($G(P(1))="":1,1:Y'>0) D Q | . I $S($G(P(1))="":1,1:Y'>0) S ^TMP("IBPID-ERR",$J,1, .. S ^TMP("IBPID-ERR",$J,1,$S($G(P(1))'="":P(1),1:"NO < .. N IBID < .. S IBID=$S(IBFT=0!(IBFT=1):$G(P("INST_ID")),1:$G(P( < .. S ^TMP("IBPID-ERR",$J,1,$S($G(P(1))'="":P(1),1:"NO < . S ^TMP("IBPID_IN",$J,U,IBP)=P(1)_U_P(2)_U_IBVNAME | . S S1=$S('$G(IBSORT):U,IBSORT=1:P(2)_U,1:P(1)_U) . F Q0=0,"TID","UPIN","INST_ID","PROF_ID","CU","CRED" | . S ^TMP("IBPID_IN",$J,S1,0)=P(1)_U_P(2) > . F Q0=0,"TID","UPIN","INST_ID","PROF_ID","CU","CRED" > I IBOPEN D CLOSE^%ZISH("IBINFILE") S IBOPEN=0 > U IO(0) ERREOF ; Traps EOF error on file read for non-DSM systems < N IBERROR S IBERROR=$$EC^%ZOSV < I IBERROR["ENDOFFILE" D CLOSE(.IBOPEN) G ENQ < D ^%ZTER < Q < ; < CLOSE(IBOPEN) ; Close file < D CLOSE^%ZISH("IBINFILE") S IBOPEN=0 < Q < ; < > ; diff -y --suppress-common-lines ./VADemo/r1/IBCEP.m ./VADemo/r2/r/IBCEP.m ;;2.0;INTEGRATED BILLING;**137,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N DIR,DIC,DA,X,Y,DTOUT,DUOUT | N DIC,DA,X,Y S Z0="Perf Prov Secondary ID Type (HCFA): "_$E($$EXPA | S Z0="Performing Provider ID Type: "_$E($$EXPAND^IBTR S Z0="Perf Prov Secondary ID Type (UB92): "_$E($$EXPA | S Z0=$J("",22)_"Source: "_$$EXPAND^IBTRE(36,4.02,$P(I S Z0=$J("",20)_"Required: "_$$EXPAND^IBTRE(36,4.03,$P | S Z0=$J("",8)_"Default?: "_$$EXPAND^IBTRE(36,4.03,+$P > S Z0="EMC ID Source: "_$$EXPAND^IBTRE(3 > S Z0=$J("",8)_"Default?: "_$$EXPAND^IBTRE(36,4.07,+$P > S Z0=$J("",10)_"Care Unit Name: "_$$EXPAND^IBTRE(36,4 > S Z0="" D SET1(.IBLCT,Z0) > S Z0="Network ID Source: "_$$EXPAND^IBTRE(3 > S Z0=$J("",8)_"Default?: "_$$EXPAND^IBTRE(36,4.05,+$P > S Z0="" D SET1(.IBLCT,Z0) . S Z0=$J("",7)_"*** NO CARE UNITS DEFINED FOR THIS I | . S Z0=$J("",7)_"*** NO CARE UNIT NEEDED FOR THIS INS S Z0=$J("",17)_"VALID CARE UNITS FOR THIS INSURANCE C | S Z0=$J("",17)_"VALID CARE UNIT FOR THIS INSURANCE CO N X,Y,Z4,DIR | N Z,Z0,Z4,X,Y,DIE,DR,DA,DIR,IBPTYP,IBPSRC,IBP,IBSET,I I 'Z4,'$P(Z4,U,2) Q | I 'Z4,'$P(Z4,U,4),'$P(Z4,U,6) Q S DIR("A",1)="USE PROVIDER ID MAINTENANCE TO ENTER/ED | S DIR("A")="DO YOU WANT TO ENTER/EDIT PROVIDER ID'S N > Q:Y'=1 > I 'Z4 S DIR("?")="Performing provider id type must be > I '$P(Z4,U,4) S DIR("?")=$G(DIR("?"))_"Network id sou > I '$P(Z4,U,6) S DIR("?")=$G(DIR("?"))_"EMC id source > S DIR("A")="TYPE OF PROVIDER ID: " S:Z4 DIR("B")="PER > Q:"PEN"'[Y > S IBPTYP=$S(Y="P":$P(Z4,U),Y="N":$$NETID(),1:$$EMCID( > S IBP=$S(Y="P":2,Y="E":4,1:6) > Q:'IBPTYP > D FIELD^DID(36,"4.0"_IBP,"","POINTER","IBSET") > S Z0=$P(Z4,U,IBP),IBSET=$G(IBSET("POINTER")) > I Z0'="",IBSET'="" S DIR("B")=$P($P(IBSET,Z0_":",2)," > S DIR("A")="SOURCE OF ID: ",DIR(0)="36,4.0"_IBP_"A" D > Q:$D(DUOUT)!$D(DTOUT) > S IBPSRC=+Y > I IBPSRC=1 S DIR("A",1)="CAN'T EDIT PROVIDER DEFAULTS > ; Ask for id(s) > S IBPROV="",IBINS=$S(IBPSRC'>3:"*ALL*",1:IBCNS) > F D Q:IBPSRC'>3 S DIR("A")="Enter/Edit Another ID? > . I IBPSRC'<4&(IBPSRC'>6) D Q:'IBPROV ; Get provide > .. S DIR("A")="(V)A or (N)on-VA Provider?: ",DIR("B") > .. I $D(DTOUT)!$D(DUOUT) Q > .. S (IBFILE,DIC)=$S(Y="V":"^VA(200,",1:"^IBA(355.93, > .. Q:Y'>0 > .. S IBPROV=+Y_";"_$P(IBFILE,U,2) > . I IBPSRC=2 D Q ; Facility Default > .. S X=$$EDITFAC^IBCEP7(IBPTYP) > . S:IBPSRC=3 IBPROV="" > . S Z0=$S(IBPSRC'=3:$O(^IBA(355.9,"AD",IBPTYP,IBPROV, > . I Z0="" S X=$$ADDID^IBCEP0A(IBCNS,IBPROV,IBPTYP) Q > . D CHG^IBCEP5B($S(IBPSRC'=3:355.9,1:355.91),Z0) Only in ./VADemo/r1/: IBCEQ1A.m Only in ./VADemo/r1/: IBCEQ1.m Only in ./VADemo/r1/: IBCEQ2A.m Only in ./VADemo/r1/: IBCEQ2.m diff -y --suppress-common-lines ./VADemo/r1/IBCERP4.m ./VADemo/r2/r/IBCERP4.m IBCERP4 ;ALB/TMP - EDI RECEIPT/REJECTION MSGS STILL PENDING/U | IBCERP4 ;ALB/TMP - EDI RECEIPT/REJECTION MSGS STILL PENDING/U ;;2.0;INTEGRATED BILLING;**137,211**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 .; IB*2.0*211 - kill off records with dangling nodes < . I IB0="",IB1'="" N DA,DIK,Y S DA=IBDA,DIK="^IBA(364 < diff -y --suppress-common-lines ./VADemo/r1/IBCERP6.m ./VADemo/r2/r/IBCERP6.m IBCERP6 ;ALB/JEH - MRA/EDI CLAIMS READY FOR EXTRACT ;12/10/99 | IBCERP6 ;ALB/JEH - EDI CLAIMS READY FOR EXTRACT ;12/10/99 ;;2.0;INTEGRATED BILLING;**137,211,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 W !,"the EDI/MRA Parameters being turned off." | W !,"the EDI Parameters being turned off." .S ZTRTN="BLD^IBCERP6",ZTDESC="IB - EDI/MRA Claims in | .S ZTRTN="BLD^IBCERP6",ZTDESC="IB - EDI Claims in Wai .I IBSEL=2 D I IBQUIT Q | .I IBSEL=2 D ..I 'IBSTAT,13[IBPARAM S IBQUIT=1 Q | ..I IBSTAT S IBQUIT=1 Q ..I IBSTAT,23[IBPARAM S IBQUIT=1 Q | ..I 'IBSTAT,1[IBPARAM S IBQUIT=1 Q > ..;I IBSTAT,23[IBPARAM S IBQUIT=1 Q > .Q:IBSTAT!(IBQUIT) I '$D(^TMP("IBCERP6",$J)) W !!,"There are no "_$S(IBP | I '$D(^TMP("IBCERP6",$J)) W !!,"There are no EDI reco S IBPARAM=$P($G(^IBE(350.9,1,8)),U,10) ;Get MRA/EDI s | S IBPARAM=$P($G(^IBE(350.9,1,8)),U,10) ;Get EDI site .W !!,"Your EDI/MRA site parameter setting is incompl | .W !!,"Your EDI site parameter setting is incomplete. .W !!,"Your site parameters are set to allow both EDI | .W !!,"Your site parameters are set to allow EDI tran .W !,"transmissions. There is no need to run this re | .W !,"There is no need to run this report.",! ; IB*2.0*211 | I $E(IOST,1,2)="C-" W @IOF,*13 ;I $E(IOST,1,2)="C-" W @IOF,*13 < I $S(IBPG:1,1:$E(IOST,1,2)="C-") W @IOF,*13 < S DIR("A",4)=" 2 - Bills trapped due to EDI/MRA p | S DIR("A",4)=" 2 - Bills trapped due to EDI param diff -y --suppress-common-lines ./VADemo/r1/IBCESRV2.m ./VADemo/r2/r/IBCESRV2.m ;;2.0;INTEGRATED BILLING;**137,191,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137,191**;21-MAR-94 Q:"CREZ"[IBSTAT ;Don't update status of completed tr | Q:"CRDZ"[IBSTAT ;Don't update status of completed tr ; | Q:$S(IBSTAT?1"A".N:"PX"[IBTYP!($P(IBTYP,"A",2)<$P(IBS ; Don't allow the status to go backwards < I $E(IBSTAT)="A","PX"[IBTYP Q < I $E(IBSTAT)="A",$E(IBTYP)="A",$P(IBTYP,"A",2)<$P(IBS < Q:"CREZ"[IBSTAT ;Don't update status of completed tr | Q:"CRDZ"[IBSTAT ;Don't update status of completed tr N IB,IBINC,IBBILL,DIE,DR,DA,Z,Z0 | N IB,IBINC,IBBILL,DIE,DR,DA,Z diff -y --suppress-common-lines ./VADemo/r1/IBCESRV3.m ./VADemo/r2/r/IBCESRV3.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 ; IA 4129 for call to DUZ^XUP < ; Input expected: IBTDA = the ien of the message entr | ;Input expected: IBTDA = the ien of the message entry ; < ; This is the background task that is queued to run b < ; The call which queues this task is found in TRTN^IB < ; called by ADD^IBCESRV. < ; < N IB0,IBBDA,IBBILL,IBMSG,IBFLAG,IBTYP,IBBST,DR,DA,DIE < > N IB0,IBBDA,IBBILL,IBMSG,IBFLAG,IBTYP,IBBST,DR,DA,DIE S IB0=$G(^IBA(364.2,IBTDA,0)),IBBDA=+$P(IB0,U,4) ; B | S IB0=$G(^IBA(364.2,IBTDA,0)),IBBDA=+$P(IB0,U,4) ;Bat S IBTYP=$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U) ; I | S IBTYP=$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U) Q:IBTYP'="835EOB" < ; The MRA Project is using a specific non-human user | Q:IBTYP'="835EOB" ; 835 EOB/MRA filing processes. Change the DUZ to be < ; *** VA SACC approved this exemption 5-June-2003 *** < ; *** Integration Agreement 4129 - Activated on 30-Ju < ; < S MRAUSER=$$MRAUSR^IBCEMU1() < I MRAUSER>0,$$ISITMRA(IBTDA) NEW DUZ D DUZ^XUP(MRAUSE < ; IBTDA = ien of message in file 364.2 | ; IBTDA = ien of message N IBBILL,PRCASV,DA,DIE,DR,DA,X,Y,IBFLAG,IB0,IBS | N IBBILL,PRCASV,DA,DIE,DR,IBFLAG,IB0,IBS N IBEOB,IBAUTO,IBIFN,IBERRMSG < D UPDMSG^IBCESRV2(IBTDA,"U",0) ; updating data in | D UPDMSG^IBCESRV2(IBTDA,"U",0) I '$P(IB0,U,5) G UPDEOBX ; no transmit bill# | I $P(IB0,U,5) D ; Add message data to EOB file 361.1 S IBEOB=$$UPDEOB^IBCEOB(IBTDA) ; new entry in file | . I $$UPDEOB^IBCEOB(IBTDA) D I 'IBEOB G UPDEOBX ; exit if some fa | .. N DIE,DR,DA,X,Y ; | .. D BILLSTAC^IBCESRV2($P(IB0,U,5),"C") ;Upd indiv tr ; update transmission status of transmission Bill# in | .. D DELMSG^IBCESRV2(IBTDA) ; status is closed (code "Z") < D BILLSTAC^IBCESRV2($P(IB0,U,5),"Z") ;Upd indiv trans < ; < ; Delete the entry from file 364.2 < D DELMSG^IBCESRV2(IBTDA) < ; < ; If the EOB is not a Medicare MRA, then we can stop < I $P($G(^IBM(361.1,IBEOB,0)),U,4)'=1 G UPDEOBX < ; < ; *** Medicare MRA processing *** < ; < ; update the claim MRA status of the file 399 bill < ; to be "C" - Valid MRA received < D MRASTAT(IBEOB,"C") < ; < ; Invoke the EOB criteria check and attempt to create < ; the secondary bill < S IBAUTO=$$CRIT^IBCEMQC(IBEOB) < I 'IBAUTO D AUTOMSG(IBEOB,$P(IBAUTO,U,2)) G UPDEOBX < S IBIFN=$P($G(^IBA(364,+$P(IB0,U,5),0)),U,1) ; bill < ; < ; Process COB, create secondary bill < S IBERRMSG="" < D AUTOCOB^IBCEMQA(IBIFN,IBEOB,.IBERRMSG) < I IBERRMSG'="" D AUTOMSG(IBEOB,IBERRMSG) G UPDEOBX < ; < ; Authorize the secondary bill < D AUTH^IBCEMQA(IBIFN,.IBERRMSG) < I IBERRMSG'="" D AUTOMSG(IBEOB,IBERRMSG) G UPDEOBX < UPDEOBX ; < AUTOMSG(IBEOB,MSG) ; File the automatic bill generation < NEW DIE,DA,DR,D,D0,DI,DIC,DQ,X,Y < S IBEOB=+$G(IBEOB),MSG=$G(MSG) < I '$D(^IBM(361.1,IBEOB)) G AUMSGX < I MSG="" G AUMSGX < S DIE=361.1,DA=IBEOB,DR="30.01////"_MSG_";30.02////"_ < D ^DIE < AUMSGX ; < Q < ; < MRASTAT(IBEOB,STAT) ; Update the claim MRA status field o < ; File 399, Field 24 - CLAIM MRA STATUS < NEW DIE,DA,DR,D,D0,DI,DIC,DIG,DIH,DIU,DIV,DQ,X,Y,IBIF < S IBEOB=+$G(IBEOB),STAT=$G(STAT) < I '$D(^IBM(361.1,IBEOB)) G MRASTX < I STAT="" G MRASTX < S IBIFN=+$P($G(^IBM(361.1,IBEOB,0)),U,1) < I '$D(^DGCR(399,IBIFN,"TX")) G MRASTX < ; < S DIE=399,DA=IBIFN,DR="24////"_STAT < D ^DIE < MRASTX ; < Q < ; < ISITMRA(IBTDA) ; Function to return whether or not this tran < ; is a Medicare MRA or a normal EOB < NEW IEN,MRA,STOP,DATA < S (IEN,MRA,STOP)=0 < F S IEN=$O(^IBA(364.2,IBTDA,2,IEN)) Q:'IEN D Q:STO < . S DATA=$$EXT^IBCEMU1($G(^IBA(364.2,IBTDA,2,IEN,0))) < . I $P(DATA,U,1)'="835EOB" Q < . I $P(DATA,U,5)="Y" S MRA=1 < . S STOP=1 < . Q < ISMRAX ; < Q MRA < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCESRV.m ./VADemo/r2/r/IBCESRV.m IBCESRV ;ALB/TMP - Server interface to IB from Austin ;8/6/03 | IBCESRV ;ALB/TMP - Server interface to IB from Austin ;03/04/ ;;2.0;INTEGRATED BILLING;**137,181,196,232**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**137,181,196**;21-MAR-94 N ZTREQ < N IBLAST,IBTYP,IBTYP1,IB0,IBBTCH,IBDATE,IBHD,IBMG,IBR | N IBLAST,IBTYP,IBTYP1,IB0,IBBTCH,IBDATE,IBHD,IBMG,IBR S (IBEFLG,IBERR,IBTXN)="",IBGBL="IBTXN",IBLAST=0 | S (IBEFLG,IBERR,IBE,IBTXN)="",IBGBL="IBTXN",IBLAST=0 . N %DT < I $G(IBD("SUBJ"))?.E1(1" MCR",1" MCT",1" MCH")1" Conf | I $G(IBD("SUBJ"))?.E1(1" MCR",1" MCT")1" Confirmation . D LOADDET(IBA,IBB,.IBTDA,IBGBL,.IBERR,$P(IBHDR,U,1) | . D LOADDET(IBA,IBB,.IBTDA,IBGBL,.IBERR) LOADDET(IB1,IB2,IBTDA,IBGBL,IBERR,IBTNM) ; Load the re | LOADDET(IB1,IB2,IBTDA,IBGBL,IBERR) ; Load the rest of th ; IBTNM = message name (i.e. "835EOB","837REC0","REPO < S IB3=0 F S IB3=$O(^TMP("IBMSG-H",$J,IB1,IB2,IB3)) Q | S IB3=0 F S IB3=$O(^TMP("IBMSG-H",IB1,IB2,IB3)) Q:'I ; Put raw data into msg | S IBZ="" ;Put raw data into msg I $G(IBTNM)'="835EOB" D | F S IBZ=$O(@IBGBL@(IB1,IB2,"D",IBZ)) Q:IBZ="" S IB3 . S IBZ="" F S IBZ=$O(@IBGBL@(IB1,IB2,"D",IBZ)) Q:IB < I $G(IBTNM)="835EOB" D < . S IB3=0 F S IB3=$O(@IBGBL@(IB1,IB2,"D1",IB3)) Q:'I < diff -y --suppress-common-lines ./VADemo/r1/IBCEST.m ./VADemo/r2/r/IBCEST.m ;;2.0;INTEGRATED BILLING;**137,189,197,135,283**;21-M | ;;2.0;INTEGRATED BILLING;**137,189,197**;21-MAR-94 ; IA 4042 for call to AUDITX^PRCAUDT < ; Auto-audit bills based on status code on '10' recor < ; flat file < I IBBILL,$P($T(PRCAUDT+1^PRCAUDT),"**",2)[",173" D < . N Z,Z0,Z1,OK < . Q:+$$STA^PRCAFN(IBBILL)'=104 < . S (Z,OK)=0 < . F S Z=$O(^IBA(364.2,IBTDA,2,Z)) Q:'Z S Z0=$P($G(^ < .. ; Strip leading spaces < .. F S Z0=$P(Z0," ",2,99) Q:$E(Z0)'=" " < .. Q:Z0="" < .. I "A3^AC^A7^A8^AA^2P^10^11"[Z0,$P($G(^DGCR(399.3,+ < ; < S IBFLDS=IBFLDS_";.03////"_$S($$EXTERNAL^DILFD(364.2, | S IBFLDS=IBFLDS_";.03////"_$S($E(IBPID,2,5)="PRNT":"I .. N IB0,IBT < . K IBE("DIERR"),IBT | . K IBE("DIERR") . D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO) | . I '$D(IBT) D . ; if info msg, ck for no review needed based on fir | .. D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO) . I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D | .. ; if info msg, ck for no review needed based on fi .. S DIE="^IBM(361,",DR=".09////2;.14////1;.1////F",D | .. I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11),$$PRINTUPD^IBC | ... S DIE="^IBM(361,",DR=".09////2;.14////1",DA=+IBY > ... I IB1,$P($G(^IBM(361,+IBY,0)),U,11),$$PRINTUPD^IB ; < ; Convert Message Lines in IBT to be no longer than 7 < D MSGLNSZ(.IBT) < MSGLNSZ(MSG) ; Change Input Message Lines to be no more th < ; < ; Input/Output: MSG - array of Input Message Lines < ; which is an array of Converted Message Lines (with < ; < N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP < S LN="",CNT=0 < F S LN=$O(MSG(LN)) Q:LN="" D ; < . ; < . ; Find any leading spaces in original message line, < . ; to be used if line got split below < . S TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ") ;Trim Lead < . S LDNGSP=$P(MSG(LN),TMPMSG,1) ;get leading spaces < . ; < . ; Converts a single line to multiple lines with a m < . ; If line is 70 chars or less, this call returns th < . K XARY D FSTRNG^IBJU1(MSG(LN),70,.XARY) < . ; < . ; Scan lines and merge them into the final output a < . ; On lines 2 and higher, add Leading Spaces found a < . S XARYLN="" < . F S XARYLN=$O(XARY(XARYLN)) Q:XARYLN="" S CNT=CNT < ; < ; Move the final Message Lines (OUTMSG) into MSG arra < K MSG M MSG=OUTMSG < Q ;MSGLNSZ < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCEU0.m ./VADemo/r2/r/IBCEU0.m ;;2.0;INTEGRATED BILLING;**137,197,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137,197**;21-MAR-94 N OK | N OK,Z L +^IBM(IBFILE,IBREC):3 I $T S OK=1 | F Z=1:1:3 L +^IBM(IBFILE,IBREC):5 I $T S OK=1 Q . F Z=1:1:IBSEQ-1 I $$WNRBILL^IBEFUNC(IBIFN,Z) D | ;. F Z=1:1:IBSEQ-1 I $$WNRBILL^IBEFUNC(IBIFN,Z) D .. S IBTOT=+$$MCRPAY(IBIFN) | ;.. S Q=0 F S Q=$O(^IBM(361.1,"B",IBIFN,Q)) Q:'Q S I $G(IBTEXT)["CLAIM RECEIVED, PRINTED AND MAILED BY P | I $G(IBTEXT)[" PRINT CENTER"!IBP1 D MCRPAY(IBIFN) ; Calculate MRA total for the bill IBIFN < N IBPAY,Q,Z0 < S IBPAY=0 < S Q=0 F S Q=$O(^IBM(361.1,"B",IBIFN,Q)) Q:'Q S Z0=$ < Q IBPAY < ; < PREOBTOT(IBIFN) ; Function - Calculates Patient Responsibilit < ; Input: IBIFN - ien of Bill Number (ien of file 399 < ; Output Function returns: Patient Responsibility Amo < ; < N FRMTYP,IBPTRES < S IBPTRES=0 < ; Form Type 2=HCFA 1500; 3=UB92 < S FRMTYP=$$FT^IBCEF(IBIFN) < ; < ; For bills w/HCFA 1500 Form Type, total up Pt Resp a < ; level of EOB (field 1.02) for All MRA type EOB's on < ; bill (IBIFN) < ; < I FRMTYP=2 D Q IBPTRES < . N IBEOB,EOBREC,EOBREC1,IBPRTOT < . S (IBEOB,IBPRTOT,IBPTRES)=0 < . F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB < . . S EOBREC=$G(^IBM(361.1,IBEOB,0)),EOBREC1=$G(^(1)) < . . I $P(EOBREC,U,4)'=1 Q ;make sure it's an MRA < . . ; Total up Pt Resp Amounts on all valid MRA's < . . S IBPTRES=IBPTRES+$P(EOBREC1,U,2) < ; < ; For bills w/UB92 Form Type, loop through all EOB's < ; on both Line level and on Claim level < N EOBADJ,IBEOB,LNLVL < S IBEOB=0 < F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB < . I $P($G(^IBM(361.1,IBEOB,0)),U,4)'=1 Q ; must be < . ; < . ; get claim level adjustments < . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10) < . S IBPTRES=IBPTRES+$$CALCPR(.EOBADJ) < . ; < . ; get line level adjustments < . S LNLVL=0 < . F S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL < . . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1) < . . S IBPTRES=IBPTRES+$$CALCPR(.EOBADJ) < Q IBPTRES < ; < CALCPR(EOBADJ) ; Function - Calculate Patient Responsibilty < ; For Group Code PR; Ignore the PR-AAA kludge < ; Input - EOBADJ = Array of Group Codes & Reason Code < ; Level (10) or Service Line Level (1 < ; Output - Function returns Patient Responsibility Am < ; < N GRPLVL,RSNCD,RSNAMT,PTRESP < S (GRPLVL,PTRESP)=0 < F S GRPLVL=$O(EOBADJ(GRPLVL)) Q:'GRPLVL D < . I $P($G(EOBADJ(GRPLVL,0)),U)'="PR" Q ;grp code mus < . S RSNCD=0 < . F S RSNCD=$O(EOBADJ(GRPLVL,1,RSNCD)) Q:'RSNCD D < . . I $P($G(EOBADJ(GRPLVL,1,RSNCD,0)),U,1)="AAA" Q < . . S RSNAMT=$P($G(EOBADJ(GRPLVL,1,RSNCD,0)),U,2) < . . S PTRESP=PTRESP+RSNAMT < Q PTRESP < ; < COBMOD(IBXSAVE,IBXDATA,SEQ) ; output the modifiers from t < ; SEQ is which modifier we're extracting (1-4) < ; Build IBXDATA(line#)=Modifier# SEQ < NEW LN,N,Z,MOD < KILL IBXDATA < I '$G(SEQ) Q < S LN=0 F S LN=$O(IBXSAVE("LCOB",LN)) Q:'LN D < . S (N,Z)=0 < . F S Z=$O(IBXSAVE("LCOB",LN,"COBMOD",Z)) Q:'Z D < .. S N=N+1 < .. S MOD(LN,N)=$P($G(IBXSAVE("LCOB",LN,"COBMOD",Z,0)) < .. Q < . S MOD=$G(MOD(LN,SEQ)) < . I MOD'="" S IBXDATA(LN)=MOD < . Q < Q < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCEU1.m ./VADemo/r2/r/IBCEU1.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94 N IB,IBN,IBBILL,IBS,A,B,C | N IB,IBN,IBDATA,IBBILL,IBS,A,B,C . I '$$EOBELIG(C) Q ; eob not eligible for secon | . S IBDATA=$G(^IBM(361.1,C,0)) . S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance se | . Q:$P(IBDATA,U,16)=""!("23"'[$P(IBDATA,U,16)) . I $S('$G(SEQ):1,1:SEQ=IBS) D | . S IBS=+$$SEQ($P(IBDATA,U,15)) > . Q:'IBS > . I $S('SEQ:1,1:SEQ=IBS) D N IB,IBA,IBS,IB0,IB00,IBBILL,B,C,D,E | N IB,IBA,IBS,IB0,IB00,IBDATA,IBBILL,B,C,D,E . I '$$EOBELIG(C) Q ; eob not eligible for secon | . S IBDATA=$G(^IBM(361.1,C,0)) . S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance se | . I $P(IBDATA,U,16)'=3,$P(IBDATA,U,16)'=2 Q ;EOB not . I $S('$G(SEQ):1,1:SEQ=IBS) D | . S IBS=+$$SEQ($P(IBDATA,U,15)) > . Q:'IBS ; COB sequence invalid > . I $S('SEQ:1,1:SEQ=IBS) D > COBLINE(IBIFN,IBI,IBXDATA,SORT,IBXTRA) ; Extract all COB dat > ; from file 361.1 (EOB), subfile 15 into IBXDATA(IBI > ; > ; IBIFN = bill entry # > ; IBI = line item # > ; IBXDATA = array returned with COB line item data/pa > ; SORT = flag that determines whether the data should > ; output for the 837 record ('PR' group always > ; a reason code for deductible first and co-in > ; even if they are 0). > ; 1 = sort, 0 = no sort needed > ; > ; Returns IBXDATA(IBI,"COB",COB,n) with COB data fo > ; found in an accepted EOB for the bill and = th > ; file 361.115 (LINE LEVEL ADJUSTMENTS) > ; -- AND -- > ; IBXDATA(IBI,"COB",COB,n,z,p)= > ; the data on the '0' node for each subordi > ; 361.11511 (REASONS) (Only first 3 pieces > ; z = this is either piece 1 of the 0-n > ; 361.1151 (ADJUSTMENTS) > ; OR > ; for the 837 COB 'sorted' output, > ; for the forced/extracted entries > ; and co-insurance so they are alw > ; The space needs to be stripped o > ; -- AND -- > ; IBXTRA = array returned if passed by reference if l > ; associated with line IBI due to bundling/u > ; IBXTRA("ALL",x,paid procedure)=COB SEQ ^ s > ; to subscript n in IBXDATA(," > ; (x = line #-original proc-service dt > ; > N A,B,B1,C,D,IBDATA,IB0,IB00,IBA,IBB,IBDED,IBCOI,IBLA > S (IBLAST,A)=0 > ; > ; If multiple EOB's reference this line for the same > ; extract only the last one marked accepted contain > ; > F S A=$O(^IBM(361.1,"B",IBIFN,A)) Q:'A D > . S IBA=0 > . S IBDATA=$G(^IBM(361.1,A,0)),IBLAST=$S('$P(IBDATA,U > . Q:'IBLAST > . S IBS=+$$SEQ($P(IBDATA,U,15)) > . S IBN=+$O(IBXDATA(IBI,"COB",IBS,0)) > . I IBN D Q:IBN ; check for later EOB > .. I $G(IBDT(IBI,IBS)),IBDT(IBI,IBS)<$P(IBDATA,U,6) K > . ; > . S IBDT(IBI,IBS)=$P(IBDATA,U,6) > . S B=0 > . F S B=$O(^IBM(361.1,A,15,"AC",IBI,B)) Q:'B S IB0= > .. Q:$TR(IB0,U)="" > .. S IBA=IBA+1,IBXDATA(IBI,"COB",IBS,IBA)=IBI_U_IB0 > .. I $P(IB0,U,15)'="" D ;Line involved in bundling/u > ... S Z0=IBI_"-"_$P(IB0,U,15)_"-"_$P(IB0,U,16) > ... S IBXTRA("ALL",Z0,$P(IB0,U,4))=IBS_U_IBA,$P(IBXDA > .. S C=0,(IBDED(IBA),IBCOI(IBA))="0^0" ;Assume 0 if n > .. F S C=$O(^IBM(361.1,A,15,B,1,C)) Q:'C S IB0=$G(^ > ... S D=0 > ... F S D=$O(^IBM(361.1,A,15,B,1,C,1,D)) Q:'D S IB0 > .... I $G(SORT),$P(IB0,U)="PR" D ;Check for deductib > ..... I 'IBDED(IBA),$P(IB00,U)=1 S IBDED(IBA)=IB00,IB > ..... I 'IBCOI(IBA),$P(IB00,U)=2 S IBCOI(IBA)=IB00,IB > .... I $TR(IB00,U)'="" S IBB=$O(IBXDATA(IBI,"COB",IBS > .. Q:'$G(SORT) > .. S IBXDATA(IBI,"COB",IBS,IBA," PR",1)=IBDED(IBA) > .. S IBXDATA(IBI,"COB",IBS,IBA," PR",2)=IBCOI(IBA) > Q > ; .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,2) | .. S Z0=$G(^IBM(361.1,Z,0)) > .. Q:"23"'[$P(Z0,U,16) > .. S IBTOT=IBTOT+$G(^IBM(361.1,Z,1)) ; < N LINE,COBSEQ,RECCT,GRPCD,SEQ,RCCT,RCPC,DATA,RCREC,SE | N LINE,COBSEQ,RECCT,GRPCD,SEQ,RCPC,RCCT,DATA,RCREC K S RCREC=$S(COL'<4:COL-1\3,1:0) | S RCREC=$S(COL'<4:COL+5\6-1,1:0) ;S RCREC=$S(COL'<4:COL+5\6-1,1:0) < . F S COBSEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ)) Q | . F S COBSEQ=$O(IBXSAVE("LCOB",LINE,COBSEQ)) Q:'COBS .. F S SEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLI | .. F S SEQ=$O(IBXSAVE("LCOB",LINE,COBSEQ,GRPCD,SEQ)) ... S DATA=$S(COL=2:LINE,COL=3:$TR(GRPCD," "),1:$P($G | ... S DATA=$S(COL=2:LINE,COL=3:$TR(GRPCD," "),1:$P($G COBOUT(IBXSAVE,IBXDATA,CL) ; < N Z,M,N,P,PCCL < S (N,Z,P)=0 F S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z D < . S N=N+1 < . S M=$O(IBXSAVE("LCOB",Z,"COB",""),-1) Q:'M < . S P=$O(IBXSAVE("LCOB",Z,"COB",M,""),-1) Q:'P < . S PCCL=$P($G(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL) < . S:PCCL'="" IBXDATA(N)=PCCL < . Q < Q < ; < COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance compa < N Z,N,NUM < K IBXDATA < I '$D(IBXSAVE("LCOB")) G COBPYRX < D ALLPAYID^IBCEF2(IBXIEN,.NUM,1) < S Z=$$COID^IBCEF2(IBXIEN),NUM=$G(NUM(1)) < S:Z="" Z="0000" < S NUM=$E(NUM_$J("",5),1,5)_$E(Z_$J("",4),1,4) < S N=0 < F S N=$O(IBXSAVE("LCOB",N)) Q:'N S IBXDATA(N)=NUM < COBPYRX ; < Q < ; < EOBELIG(IBEOB) ; EOB eligibility for secondary claim < ; Function to decide if EOB entry in file 361.1 (ien= < ; eligible to be included for secondary claim creatio < ; The EOB is not eligible if the review status is not < ; is no insurance sequence indicator, or if the EOB h < ; and the patient responsibility for that EOB is $0. < ; < NEW ELIG,IBDATA,PTRESP < S ELIG=0 < I '$G(IBEOB) G EOBELIGX < S IBDATA=$G(^IBM(361.1,IBEOB,0)) < I $P(IBDATA,U,16)'=3 G EOBELIGX ; review status - < I '$P(IBDATA,U,15) G EOBELIGX ; insurance seque < S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2) ; Pt Res < I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(I < I PTRESP'>0,$P(IBDATA,U,13)=2 G EOBELIGX ; Denied < I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX ; filing < ; < S ELIG=1 < EOBELIGX ; < Q ELIG < ; < EOBCNT(IBIFN) ; This function counts up the number of EOBs < ; for the secondary claim creation process for a give < NEW CNT,IEN < S (CNT,IEN)=0 < F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D < . I $$EOBELIG(IEN) S CNT=CNT+1 < . Q < EOBCNTX ; < Q CNT < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCEU2.m ./VADemo/r2/r/IBCEU2.m ;;2.0;INTEGRATED BILLING;**51,137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 ; < AUTOCK(IBIFN,IBQUIET) ; Auto add any codes necessary based < ; existing on bill, if needed. < ; IBQUIET - optional parameter - equals 1 to suppress < > AUTOCK(IBIFN) ; Auto add any codes necessary based on data > ; if needed. ;I IBCOBN>1 D PRPAY(IBIFN,IBCOBN,$G(IBQUIET)) | ;I IBCOBN>1 D PRPAY(IBIFN,IBCOBN) D SUBDOB(IBIFN,IBCOBN,$G(IBQUIET)) | D SUBDOB(IBIFN,IBCOBN) PRPAY(IBIFN,IBCOBN,IBQUIET) ; Output value cd A1 or A2 fo | PRPAY(IBIFN,IBCOBN) ; Output value cd A1 or A2 for prior ; IBQUIET = 1 to suppress screen display < . W:'$G(IBQUIET) !,"Adding occurrence code 24 and pri | . W !,"Adding occurrence code 24 and primary insuranc . W:'$G(IBQUIET) !!,"Adding value code",$S(IBCT=2:"s | . W !!,"Adding value code",$S(IBCT=2:"s A1 and A2",1: SUBDOB(IBIFN,IBCOBN,IBQUIET) ; Add occurrence codes A1,B1, | SUBDOB(IBIFN,IBCOBN) ; Add occurrence codes A1,B1,C1 as ne ; IBQUIET = 1 to suppress screen display < . W:'$G(IBQUIET) !,"Adding occurrence code '"_IBOC_"' | . W !,"Adding occurrence code '"_IBOC_"' for "_$P("pr diff -y --suppress-common-lines ./VADemo/r1/IBCEU3.m ./VADemo/r2/r/IBCEU3.m ;;2.0;INTEGRATED BILLING;**51,137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N Z,IBSPEC,IBINS,IBDT | N Z,IBSPEC,IBINS S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use state < . S IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT) | . S IBSPEC=$$SPEC^IBCEU(IBPRV,$$SERVDT^IBCEF(IBIFN,,2 . I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IB | . I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IB Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V | Q $S($$FT^IBCEF(IBIFN)=2&$$WNRBILL^IBEFUNC(IBIFN):"V" diff -y --suppress-common-lines ./VADemo/r1/IBCEU4.m ./VADemo/r2/r/IBCEU4.m ;;2.0;INTEGRATED BILLING;**51,137,210,155,290**;21-MA | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N IBZ,IBDT | N IBZ S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use state < I $G(IBPIEN) S:$P(IBPIEN,";",2)="" IBPIEN=IBPIEN_";VA | I $G(IBPIEN) S:$P(IBPIEN,";",2)="" IBPIEN=IBPIEN_";VA S CD=$P($$ICD9^IBACSV(+IBP),U) | S CD=$P($G(^ICD9(+IBP,0)),U) ; < ; Find Providers and store them (if found) in this or < ; Attending/Rendering, Operating, Referring, Other < . I Z=4,$$FT^IBCEF(IBIFN)=2 S Z=3 ; Find rendering | . I Z=4,$$FT^IBCEF(IBIFN)=2 S Z=3 ; Find rendering fo diff -y --suppress-common-lines ./VADemo/r1/IBCEU5.m ./VADemo/r2/r/IBCEU5.m ;;2.0;INTEGRATED BILLING;**51,137,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N IBZ,IBQUIT,IB,IB1,DIR | N IBZ,IBQUIT,IB . I $Y>(IB-3) N DIR,X,Y S IB1=0,DIR(0)="E" D ^DIR K D | . I $Y>(IB-3) S IB1=0,DIR(0)="E" D ^DIR K DIR S IB=IB I IB1 D | I IB1 S DIR(0)="E" D ^DIR K DIR . N DIR,X,Y S DIR(0)="E" D ^DIR K DIR < F IBZ=1:1:5,9 I $$PRVOK^IBCEU(IBZ,IBIFN) D | F IBZ=1:1:4,9 I $$PRVOK^IBCEU(IBZ,IBIFN) D ;; | ;; UB-92 (both inpatient and outpatient): O ;; | ;; The provider who requested that the serv ;;SUPERVISING: HCFA 1500 (both inpatient and outpatie | ;; be performed. Data will be printed in b ;; Required only when the rendering provide < ;; by a physician. Data will not be printe < ;; < ;; < ;;OTHER: UB92 (both inpatient and outpatient): OPTION < ;; Used to report providers with functions < ;; designated here. < N DIR,X,Y,IBZ,IBCP,Z,Z0,Z1,DA,IBRC,IBP | N DIR,X,Y,IBZ,IBCP,Z,Z0,Z1,DA,IBRC INSFT(IBIFN) ; Returns 1 if form type is UB92, 0 if HCFA 1 < Q ($$FT^IBCEF(IBIFN)=3) < ; < Only in ./VADemo/r1/: IBCEU6.m diff -y --suppress-common-lines ./VADemo/r1/IBCEU.m ./VADemo/r2/r/IBCEU.m ;;2.0;INTEGRATED BILLING;**51,137,207,232**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 TESTPT(DFN) ; Determine if pt is test pt | TESTPT(DFN) ;Determine if pt is test pt ; Returns 1 if a test pt, 0 if not | ; Returns 1 if a test pt, 0 if not ; OTHER(9) valid on institutional(UB92) bills | ; OTHER(9) and REFERRING(1) valid all bills ; REFERRING(1) valid only on professional (HCFA) clai < ; OUTPATIENT/HCFA 1500 : RENDERING(3), SUPERVISING(5 | ; OUTPATIENT/HCFA 1500 : RENDERING(3) ; INPATIENT/HCFA 1500 : RENDERING(3), SUPERVISING(5 | ; INPATIENT/HCFA 1500 : RENDERING(3) S IBUB92=($$FT^IBCEF(IBIFN)=3) ; 1 if UB-92 ; 0 if HC | I VAL=9!(VAL=1) G PRVQ I VAL=1 S:IBUB92 OK=0 G PRVQ | S IBUB92=($$FT^IBCEF(IBIFN)=3) ; 1 if UB-92 ; 0 if HC I "249"[VAL,'IBUB92 S OK=0 G PRVQ | I "24"[VAL,'IBUB92 S OK=0 G PRVQ I $S(VAL=3:1,1:VAL=5),IBUB92 S OK=0 G PRVQ | I VAL=3,IBUB92 S OK=0 G PRVQ . F Z=1:1:3,5,6,7,8,9 S:Z=3&($$FT^IBCEF(IBIFN)=3) Z=4 | . F Z=1:1:3 S:Z=3&($$FT^IBCEF(IBIFN)=3) Z=4 S IBPRV(Z . Q:'$P(IBD,U,2) < . S IBPRV(IBY,IBCT)=IBPNM_U_$S($P(IBD,U,IBID)'="":$P( | . S IBPRV(IBY,IBCT)=IBPNM_U_$S($P(IBD,U,IBID)'="":$P( .. I $S(Z=1:1,1:$D(^DGCR(399,IBIFN,"I"_Z))) S IBPRV(I | .. I $S(Z=1:1,1:$D(^DGCR(399,IBIFN,"I"_Z))) S IBPRV(I S IBMRAND=$$WNRBILL^IBEFUNC(IBIFN) ;$$MCRONBIL^IBEFUN | S IBMRAND=$$MCRONBIL^IBEFUNC(IBIFN) N OK,IBFT,Z,R | N OK,IBFT . ; Only outpt UB-92 can have SLF000 as prov ID with | . ;Only outpt UB-92 can have SLF000 as prov ID with n diff -y --suppress-common-lines ./VADemo/r1/IBCEXTR2.m ./VADemo/r2/r/IBCEXTR2.m ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-1994 | ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994 ; < ; Check for security key < I '$$KCHK^XUSRB("IB AUTHORIZE") D G CANCELQ < . D FULL^VALM1 < . W !!?5,"You don't hold the proper security key to a < . W !?5,"The necessary key is IB AUTHORIZE. Please s < . D PAUSE^VALM1 < . Q < ; < N IBIFN,IBDA,IB364,IBCEAUTO,IBNIEN,IBYY | N IBIFN,IBDA,IB364,IBCEAUTO,IBNIEN ; < ; Check for security key < I '$$KCHK^XUSRB("IB AUTHORIZE") D G CPYCLNQ < . D FULL^VALM1 < . W !!?5,"You don't hold the proper security key to a < . W !?5,"The necessary key is IB AUTHORIZE. Please s < . D PAUSE^VALM1 < . Q < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCEXTRP.m ./VADemo/r2/r/IBCEXTRP.m IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ; 4/22 | IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ;06-JU ;;2.0;INTEGRATED BILLING;**137,197,211**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**137,197**;21-MAR-94 ;IB*2.0*211 - rely on form type instead of bill charg | S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/ ;S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_" < N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN) < S IBFMTYP=$S(IBFMTYP=2:"HCFA",IBFMTYP=3:"UB-92",1:"OT < S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/ < ;S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_" | S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/ N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN) < S IBFMTYP=$S(IBFMTYP=2:"HCFA",IBFMTYP=3:"UB-92",1:"OT < S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/ < W !!,?25,"EDI Transmitted Bill Extract Data",!,"Bill | W !!,?25,"EDI Transmitted Bill Extract Data",!,"Bill W !,$P(IBREC1,U)_" "_"("_IBILL_")",?27,$P($G(^DPT(+$P | W !,$P(IBREC1,U)_" "_"("_IBILL_")",?22,$P($G(^DPT(+$P diff -y --suppress-common-lines ./VADemo/r1/IBCF10.m ./VADemo/r2/r/IBCF10.m ;;2.0;INTEGRATED BILLING;**133,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**133**;21-MAR-94 N IBINDXX,IBEVDT | N IBINDXX D SET^IBCSC4D(IBIFN,"",.IBINDXX) I $D(IBIND D SET^IBCSC4D(IBIFN,"",.IBINDXX) I $D(IBINDXX)>2 D | . S I=$O(IBINDXX(0)) Q:'I W $P($G(^ICD9(+IBINDXX(I), . S IBEVDT=$$BDATE^IBACSV(IBIFN) ; Event Date < . S I=$O(IBINDXX(0)) Q:'I < . W $P($$ICD9^IBACSV(+IBINDXX(I),IBEVDT),U,3) < D 13^IBCF11 | D 13^IBCF11 Q Q | ICW S X=$S($D(^ICD9(+X,0)):$P(^(0),"^",1),1:"") S:$D(X2) ICW S X=$P($$ICD9^IBACSV(+X),U) S:$D(X2) X2=X2+7 < Q:'$P(DGTEXT,U,3) S IBCPT="" | Q:'$P(DGTEXT,"^",3) S IBCPT="" I DGTEXT["ICD" S IBCPT=$$ICD0^IBACSV(+$P(DGTEXT,U,3), | I DGTEXT["ICD" S IBCPT=$G(@(U_$P($P(DGTEXT,"^",3),";" I DGTEXT["ICPT" S IBCPT=$$CPT^IBACSV(+$P(DGTEXT,U,3), | I DGTEXT["ICPT" S IBCPT=$P($$CPT^ICPTCOD(+$P(DGTEXT,U W ?11,$P(IBCPT,U) | W ?11,$P(IBCPT,"^") diff -y --suppress-common-lines ./VADemo/r1/IBCF11.m ./VADemo/r2/r/IBCF11.m IBCF11 ;ALB/MJB - PRINT UB-82 BILL (CONT.) ;25 JAN 89 12:54 | IBCF11 ;ALB/MJB - PRINT UB-82 BILL (CONT.) ;25 JAN 89 12:54 ;;2.0;INTEGRATED BILLING;**133,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**133**;21-MAR-94 . I IBPROC(J)["ICD" S X=$$ICD0^IBACSV(+IBPROC(J),+$P( | . I IBPROC(J)["ICD" S X=$G(@(U_$P($P(IBPROC(J),"^")," . I IBPROC(J)["ICPT" S X=$$CPT^IBACSV(+IBPROC(J),+$P( | . I IBPROC(J)["ICPT" S X=$$CPT^ICPTCOD(+IBPROC(J),+$P . S Y=$E($P(IBPROC(J),U,2),4,7) | . S Y=$E($P(IBPROC(J),"^",2),4,7) . I I=1 W ?3,$E($P(X,U,$S(IBPROC(J)["ICD":4,1:2)),1,3 | . I I=1 W ?3,$S(IBPROC(J)["ICD":$E($P(X,"^",4),1,30), . W ?(TAB+(I-1*11)),$P(X,U),?(TAB+6+(I-1*11)),Y | . W ?(TAB+(I-1*11)),$P(X,"^"),?(TAB+6+(I-1*11)),Y diff -y --suppress-common-lines ./VADemo/r1/IBCF12.m ./VADemo/r2/r/IBCF12.m ;;2.0;INTEGRATED BILLING;**133,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**133**;21-MAR-94 ;Input: DGBS - bedsection, IBIFN - Bill/Claim < N DGRV,DGDA,IBCODE | S DGRV=0 F J=0:0 S DGRV=$O(^DGCR(399,IBIFN,"RC","ABS" S DGRV=0 F S DGRV=$O(^DGCR(399,IBIFN,"RC","ABS",DGBS | .S X=" Procedure: "_$P($$CPT^ICPTCOD($P(^ . S DGDA=0 F S DGDA=$O(^DGCR(399,IBIFN,"RC","ABS",DG | .D SET .. S X=U_DGDA D SET < .. S IBCODE=$P($G(^DGCR(399,IBIFN,"RC",DGDA,0)),U,6) < ... S X=" Procedure: "_$P($$CPT^IBACSV(IB < ... D SET < diff -y --suppress-common-lines ./VADemo/r1/IBCF22.m ./VADemo/r2/r/IBCF22.m ;;2.0;INTEGRATED BILLING;**52,80,122,51,210**;21-MAR- | ;;2.0;INTEGRATED BILLING;**52,80,122,51**;21-MAR-94 N IBDXX,IBPOX | N IBDXX,IBPOX D SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX) S X= D SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX) | F IBI=1:1:4 S IBFLD(21,IBI)="" I IBI'>$P(IBPOX,U,2) S S X=0 F IBI=1:1:4 S IBFLD(21,IBI)="" I IBI'>$P(IBPOX, < . S X=$O(IBPOX(X)) Q:X="" < . S IBFLD(21,IBI)=$P($$ICD9^IBACSV(+IBPOX(X)),U) < . S IBDXI(+$G(IBDXX(+IBPOX(X))))=IBI < diff -y --suppress-common-lines ./VADemo/r1/IBCF32.m ./VADemo/r2/r/IBCF32.m IBCF32 ;ALB/BGA-UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993 | IBCF32 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993 ;;2.0;INTEGRATED BILLING;**210**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 N IBINDXX | N IBINDXX D SET^IBCSC4D(IBIFN,"",.IBINDXX) S IBX=0 F D SET^IBCSC4D(IBIFN,"",.IBINDXX) < S IBX=0 F IBI=1:1:9 S IBX=$O(IBINDXX(IBX)) Q:'IBX D < . S IBFL(66+IBI)=$P($$ICD9^IBACSV(+IBINDXX(IBX)),U) < S IBX=$P(IBCU2,U) ; Admitting Diagnosis (fld #215) IB | S IBX=$P(IBCU2,U,1) S IBFL(76)=$S(+IBX:$P($G(^ICD9(+I I 'IBX S IBFL(76)=$P(IBCBCOMM,U,5) ; Form Locator 9 ( < E S IBFL(76)=$P($$ICD9^IBACSV(+IBX),U) < diff -y --suppress-common-lines ./VADemo/r1/IBCF331.m ./VADemo/r2/r/IBCF331.m ;;2.0;INTEGRATED BILLING;**52,210**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94 S IBX=0 F IBI=1:1 S IBX=$O(IBARRAY(IBX)) Q:IBX="" I | S (IBI,IBX)=0 F IBI=1:1 S IBX=$O(IBARRAY(IBX)) Q:IBX= . S IBY=$$ICD9^IBACSV(+$G(IBARRAY(IBX)),$$BDATE^IBACS | . S IBY=+IBARRAY(IBX),IBY=$G(^ICD9(IBY,0)) Q:IBY="" . S IBZ=$P(IBY,U)_$J(" ",(10-$L($P(IBY,U))))_$P(IBY,U | . S IBZ=$P(IBY,U,1)_$J(" ",(10-$L($P(IBY,U,1))))_$P(I diff -y --suppress-common-lines ./VADemo/r1/IBCF33.m ./VADemo/r2/r/IBCF33.m ;;2.0;INTEGRATED BILLING;**52,80,109,51,230**;21-MAR- | ;;2.0;INTEGRATED BILLING;**52,80,109,51**;21-MAR-94 . I $P(IBXDATA(Z),U)="001",'$O(IBXDATA(Z)) S IBZ="001 | . I $P(IBXDATA(Z),U)="001",'$O(IBXDATA(Z)) S IBZ="001 diff -y --suppress-common-lines ./VADemo/r1/IBCF4.m ./VADemo/r2/r/IBCF4.m ;;2.0;INTEGRATED BILLING;**52,137,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,137**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBCFP1.m ./VADemo/r2/r/IBCFP1.m ;;2.0;INTEGRATED BILLING;**54,52,80,121,51,137,155**; | ;;2.0;INTEGRATED BILLING;**54,52,80,121,51,137**;21-M . S ^XTMP("IBCFP"_IBFT,0)=IBXP,^XTMP("IBCFP"_IBFT,$J, | . S ^XTMP("IBCFP"_IBFT,0)=IBXP,^XTMP("IBCFP"_IBFT,$J, . S XIBFT=IBFT ;save off curent value of IBFT < . ; < . ; set MRA queue to print < . S IBFT=$$FNT^IBCU3("MRA") < . ; Merge the data from ^XTMP("IBCFP" queue, into "IB < . I +IBFT,$P($G(^IBE(353,+IBFT,0)),U,2)'="" S ^XTMP(" < . ; < . ; Print Bill Addendums only for HCFA 1500's < . I $$FTN^IBCU3(XIBFT)'["HCFA 1500" Q < . Q | K IBIFN,IBFT,IBX,IBY,IBPAT,IBZIP,IBINS,IBS1,IBS2,IBS3 K IBIFN,IBFT,XIBFT,IBX,IBY,IBPAT,IBZIP,IBINS,IBS1,IBS < I 'IBQ D | I 'IBQ S IBIX="IBCFP" F S IBIX=$O(^XTMP(IBIX)) Q:(IB . ; queue a job for each form type | . S ZTIO=$P($G(^IBE(353,+IBFT,0)),U,2),IBFTP=IBIX,IBJ . S IBIX="IBCFP" F S IBIX=$O(^XTMP(IBIX)) Q:(IBIX'?1 | . S ZTDTH=$H,ZTSAVE("IBFTP")="",ZTSAVE("IBFT")="",ZTS . . S ZTIO=$P($G(^IBE(353,+IBFT,0)),U,2),IBFTP=IBIX,I | . S ZTDESC="BATCH PRINTING "_$$FTN^IBCU3(+IBFT),ZTRTN . . S ZTDTH=$H,ZTSAVE("IBFTP")="",ZTSAVE("IBFT")="",Z < . . S ZTDESC="BATCH PRINTING "_$$FTN^IBCU3(+IBFT),ZTR < . ; Also queue a job to print MRA's, if any, for each < . S IBIX="IBMRA" F S IBIX=$O(^XTMP(IBIX)) Q:(IBIX'?1 < . . S ZTIO=$P($G(^IBE(353,+IBFT,0)),U,2),IBFTP=IBIX,I < . . S ZTDTH=$H,ZTSAVE("IBFTP")="",ZTSAVE("IBFT")="",Z < . . S ZTDESC="BATCH PRINTING MRA'S",ZTRTN="QMRA^IBCEM < GCLEAN ; Clean up XTMP global for $J of IBCFP and IBMRA entr | GCLEAN ; Clean up XTMP global for $J S I="IBMRA" F S I=$O(^XTMP(I)) Q:I'?1"IBMRA"1N.N K < diff -y --suppress-common-lines ./VADemo/r1/IBCFP.m ./VADemo/r2/r/IBCFP.m ;;2.0;INTEGRATED BILLING;**41,54,137,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**41,54,137**;21-MAR-94 BEG S DIR("A")="Begin printing bills",DIR("?",1)=" Enter | BEG S DIR("A")="Begin printing bills",DIR("?")="Enter 'Y' S DIR("?",2)=" Enter NO to quit this option." | W ! S DIR(0)="YBO",DIR("??")="^D DISP1^IBCF" D ^DIR K S DIR("?")=" Enter ?? to list the authorized bills t < W ! S DIR(0)="YBO",DIR("??")="^D DISPX^IBCF" D ^DIR K < diff -y --suppress-common-lines ./VADemo/r1/IBCIADD1.m ./VADemo/r2/r/IBCIADD1.m ;;2.0;INTEGRATED BILLING;**161,203,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**161,203**;21-MAR-94 NEW IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC < S (IBRFID,IBRFLN,IBRFMN,IBRFFN,IBRFDEPT,IBRFSPEC)="" < ; < ; Add referring provider fields < S FDA(351.9,IENS,3.08)=IBRFID ; ID < S FDA(351.9,IENS,3.09)=IBRFLN ; last name < S FDA(351.9,IENS,3.1)=IBRFMN ; middle name < S FDA(351.9,IENS,3.11)=IBRFFN ; first name < S FDA(351.9,IENS,4.01)=IBRFDEPT ; department < S FDA(351.9,IENS,4.02)=IBRFSPEC ; specialty < ; < ; | INIT1 ;initialize variables for adding entry in 351.9 INIT1 ; Initialize variables for adding entry in 351.9 < NEW IBZ,IBPRV < ; capture referring provider information < D GETPRV^IBCEU(IBIFN,1,.IBZ) ; "1" signifies ref < S IBZ=$G(IBZ(1,1)) < I IBZ'="" D < . S IBPRV=$P(IBZ,U,3) < . S IBRFLN=$$NAME^IBCEFG1($P(IBZ,U,1)),IBRFMN=$P(IBRF < . S IBRFSPEC=$$BILLSPEC^IBCEU3(IBIFN,IBPRV) ; ref pr < . I IBPRV'["IBA(355.93" D ; va provider data < .. S IBRFID=+IBPRV < .. S IBRFDEPT=$P($G(^VA(200,+IBPRV,5)),U,1) < .. Q < . I IBPRV["IBA(355.93" D ; non-va provider data < .. S IBRFID="NVA"_+IBPRV < .. S IBRFDEPT="NVA" < .. Q < . Q < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCIUT1.m ./VADemo/r2/r/IBCIUT1.m ;;2.0;INTEGRATED BILLING;**161,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94 ..S ^TMP(SUB1,$J,IBIFN,"ICD",LITM,DNUM)=$P($$ICD9^IBA | ..S ^TMP(SUB1,$J,IBIFN,"ICD",LITM,DNUM)=$P(^ICD9(ICDI diff -y --suppress-common-lines ./VADemo/r1/IBCIUT3.m ./VADemo/r2/r/IBCIUT3.m ;;2.0;INTEGRATED BILLING;**161,226**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94 NEW ACK,CH,CHAR,CNT,DATA,ERRLN,ERRTXT,INGTO,J,K,MAXSI | NEW ACK,NAK,CNT,RESP,SUB2,INGTO,MINSTORE,STORERR,SGT, NEW POP,RESP,SEGMENT,SEGNUM,SEQ,SGT,SGTNUM,STOP,STORE < NEW $ESTACK,$ETRAP S $ETRAP="D ERRTRP^IBCIUT3" ; ib*2 < ERRTRP ; Error trap processing ; ib*226 TJH/EG < S Z(1,1)=$$EC^%ZOSV ; mumps error location and descri < S Z="A SYSTEM ERROR HAS BEEN DETECTED AT THE FOLLOWIN < S PROBLEM=7 < D CLOSE^%ZISTCP ; close the tcp/ip port < L -^IBCITCP(IBCISOCK) ; unlock the current port < K ^TMP($J,"CMRESP2") ; kill scratch global < D ^%ZTER ; record the error in the trap < G UNWIND^%ZTER ; unwind stack levels < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCIUT4.m ./VADemo/r2/r/IBCIUT4.m ;;2.0;INTEGRATED BILLING;**161,226**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94 ;pull error msg from 351.9 based on mnemonic (IBCIETP | ;pull error msg from 351.9 based on mnemnonic (IBCIET I IBCICODE=7 S IBCIDESC="Fatal System Error",IBCIMSG= < I "^1^2^3^4^5^6^7^99^"'[IBCICODE S IBCIDESC="Unknown | I "^1^2^3^4^5^6^99^"'[IBCICODE S IBCIDESC="Unknown Er diff -y --suppress-common-lines ./VADemo/r1/IBCIUT5.m ./VADemo/r2/r/IBCIUT5.m ;;2.0;INTEGRATED BILLING;**161,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94 . S MOD=$$MOD^ICPTMOD(IEN,"I") | . S MOD=$P($G(^DIC(81.3,IEN,0)),U,1) . I MOD<1 Q | . I MOD="" Q . I IBMOD="" S IBMOD=$P(MOD,U,2) | . I IBMOD="" S IBMOD=MOD . E S IBMOD=IBMOD_","_$P(MOD,U,2) | . E S IBMOD=IBMOD_","_MOD diff -y --suppress-common-lines ./VADemo/r1/IBCNBAA.m ./VADemo/r2/r/IBCNBAA.m ;;2.0;INTEGRATED BILLING;**82,184,246**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**82**;21-MAR-94 ; c) if ins record exists user selects method | ; c) if ins record exists user selects method K ^TMP($J,"IB BUFFER SELECTED") ; initialize selecti < I +IBMVINS=4 D INS^IBCNBAC(IBBUFDA,IBINSDA,1) ; Ind. < ; < I +IBMVGRP=4 D GRP^IBCNBAC(IBBUFDA,IBGRPDA,1) ; Ind. < ; < I +IBMVPOL=4 D POLICY^IBCNBAC(IBBUFDA,IBPOLDA,1) ; In < ; < ACCPTQ K ^TMP($J,"IB BUFFER SELECTED") ; cleanup selection | ACCPTQ Q IBDONE Q IBDONE < ; returns 1^merge, 2^overwrite, 3^replace, 4^individu | ; returns 1^merge, 2^overwrite, 3^replace, 0^no chang ; 0^no change, < ; or "" if none of the methods was chosen < ; DAOU/BHS - 08/28/2002 - Added INDIVIDUALLY ACCEPT m | W ! S DIR(0)="SOB^M:MERGE;O:OVERWRITE;R:REPLACE;N:NO W ! S DIR(0)="SOB^M:MERGE;O:OVERWRITE;R:REPLACE;N:NO | S IBX=$S(Y="M":1,Y="O":2,Y="R":3,Y="N":0,1:"") I IBX' S IBX=$S(Y="M":1,Y="O":2,Y="R":3,Y="I":4,Y="N":0,1:"" < Only in ./VADemo/r1/: IBCNBAC.m diff -y --suppress-common-lines ./VADemo/r1/IBCNBAR.m ./VADemo/r2/r/IBCNBAR.m ;;2.0;INTEGRATED BILLING;**82,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**82**;21-MAR-94 D POL^IBCNSU41(DFN) ; | D POL^IBCNSU41(DFN) ; I +IBINSDA,+IBPOLDA S IBX=$$DUPCO^IBCNSOK1(DFN,IBINSD | I +IBINSDA,+IBPOLDA S IBX=$$DUPCO^IBCNSOK1(DFN,IBINSD diff -y --suppress-common-lines ./VADemo/r1/IBCNBCD.m ./VADemo/r2/r/IBCNBCD.m ;;2.0;INTEGRATED BILLING;**82,251**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**82**;21-MAR-94 D DISPLAY(40.1,355.3,6.02,"BIN:") ;;Daou/EEN - adding < D DISPLAY(40.11,355.3,6.03,"PCN:") < diff -y --suppress-common-lines ./VADemo/r1/IBCNBEE.m ./VADemo/r2/r/IBCNBEE.m ;;2.0;INTEGRATED BILLING;**82,184,252,251**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**82**;21-MAR-94 N DIC,DIE,DA,DR,X,Y,IBCNEXT1 | N DIC,DIE,DA,DR,X,Y I $P($G(^IBA(355.33,+$G(IBBUFDA), I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q < ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match whe < ; - the insurance company name in the buffer. Al < ; - input transform (see below) to clean up the d < ; - fetch the current buffer ins co name < ; < I FLDS="MR" S IBCNEXT1=$P($G(^IBA(355.33,IBBUFDA,20)) < ; < ; < I FLDS="MR" Q:$$INSNAME(IBBUFDA)<0 S DR=$P($T(@(FLDS < ; < INSNAME(IBBUFDA) ; Reset insurance company name < N DR,DIE,DA,Y,X,IBX,IBNEW,IBNAME < S IBX=-1 < S DR=20.01,DIE="^IBA(355.33,",DA=IBBUFDA < D ^DIE < I '$D(Y) S IBNEW=$$CHECK(IBBUFDA) < I +$G(IBNEW)'<0,$G(IBNEW)'=0,$D(IBNEW) S DR=$P(DR,";" < ; BHS - 10/15/03 - If user entered a caret during $$C < ; return value to 0 so the user can < ; INS fields < I $G(IBNEW)=0!($G(IBNEW)=-1) S IBX=0 < Q IBX < ; < CHECK(IBBUFDA) ; Select Insurance Company Name and Automatch < ; Buffer file (#355.33), field# 20.01. < ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match whe < ; insurance company name. Also, display the in < ; name lookup/lister and the Auto Match lookup/ < ; < NEW IBNEW,IBNAME,AMLIST < ; < S IBNEW=0,IBNAME=$P($G(^IBA(355.33,$G(IBBUFDA),20)),U < I IBNAME="" G CHECKQ < ; < ; Perform an insurance company lookup/lister < ; BHS - 10/15/03 - Removed quits when user enters a c < ; the ins lister or Auto Match liste < S IBNEW=$$DICINS^IBCNBU1(IBNAME,1,10) < I IBNEW=0!(IBNEW<0) D < . I '$$AMLOOK^IBCNEUT1(IBNAME,1,.AMLIST) Q < . S IBNEW=$$AMSEL^IBCNEUT1(.AMLIST) < ; < ; user chose a valid insurance company - possible Aut < I IBNEW'<0,IBNEW'=0 D AMADD^IBCNEUT6(X,IBCNEXT1) < ; < CHECKQ Q IBNEW < ; < MRGRP ; Group/Plan fields asked of MCCR users in the Buffer | MRGRP ; Group/Plan fields asked of MCCR users in the Buffer ;;40.01:40.03;40.1;40.11;40.09;40.04:40.08 | ;;40.01:40.03;40.09;40.04:40.08 OTGRP ; Group/Plan fields asked of non-MCCR users entering | OTGRP ; Group/Plan fields asked of non-MCCR users entering ;;40.02;40.03;40.1;40.11;40.09 | ;;40.02;40.03;40.09 diff -y --suppress-common-lines ./VADemo/r1/IBCNBES.m ./VADemo/r2/r/IBCNBES.m ;;2.0;INTEGRATED BILLING;**82,184**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**82**;21-MAR-94 ; 5 = eiiv < ; delete leftover ESGHP data if ESGHP? is not Yes < I +$G(IBBUFDA),$D(^IBA(355.33,$G(IBBUFDA),61)),'$G(^I < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCNBLA1.m ./VADemo/r2/r/IBCNBLA1.m ;;2.0;INTEGRATED BILLING;**82,133,149,184,252**;21-MA | ;;2.0;INTEGRATED BILLING;**82,133,149**;21-MAR-94 N DIC,DIR,DIRUT,DUOUT,X,Y,IBIN,DFN,IBBUFDA,IBDATA,AML | N DIC,DIR,DIRUT,DUOUT,X,Y,IBIN,DFN,IBBUFDA,IBDATA ; Patient lookup < > S DIR("A")="Insurance Company",DIR(0)="FO^1:30" D ^DI INS ; Insurance company lookup | S DIR(0)="Y",DIR("A")="Add a new Insurance Buffer ent S DIR("A")="Insurance Company",DIR(0)="FO^1:30" < S DIR("?",1)="Please enter the name of the insurance < S DIR("?",2)="patient. This response is a free text < S DIR("?")="company name look-up is available here." < ; BHS - 10/15/03 - Removed quit condition when user e < ; during the insurance lister and on < ; when a valid selection is made < D ^DIR K DIR Q:$D(DIRUT) S IBIN=Y,Y=$$DICINS^IBCNBU1 < ; < ; ESG - 6/17/02 - Usage of Auto Match file when addin < ; - SDD 5.1.3 < ; < ; BHS - 10/15/03 - Added condition to allow Auto Matc < ; entered a caret during the insuran < I Y=0!(Y<0),$$AMLOOK^IBCNEUT1(IBIN,1,.AMLIST) S Y=$$A < I '$$INPTTR(355.33,20.01,$$UP^XLFSTR(IBIN)) D G INS < . D FIELD^DID(355.33,20.01,"","HELP-PROMPT","IBHELP") < . W !?5,IBHELP("HELP-PROMPT") Q < S DIR(0)="Y",DIR("A")="Add a new Insurance Buffer ent | S IBDATA(20.01)=$$UP^XLFSTR(IBIN),IBDATA(60.01)=DFN S ; < S IBDATA(20.01)=$$UP^XLFSTR(IBIN),IBDATA(60.01)=DFN < S IBBUFDA=+$$ADDSTF^IBCNBES(1,DFN,.IBDATA) K IBDATA Q < D BUFF^IBCNEUT2(IBBUFDA,+$$INSERROR^IBCNEUT3("B",IBBU < . ; WCW - 04/11/2003 Clear out IIV Status when manual < . D CLEAR^IBCNEUT4(IBBUFDA,.IIVERR,1) K IIVERR < REJECT(IBBUFDA,DIRUT) ; process a reject and then delete a | REJECT(IBBUFDA) ; process a reject and then delete a buffer e ; Output parameter DIRUT is optional and passed in by < ; variable will be defined if the user enters a leadi < ; times out, or enters a null response. This is so t < ; can detect if the user did something other than say < ; this question. < N DIR,X,Y,IBX Q:'$G(IBBUFDA) | N DIR,DIRUT,X,Y,IBX Q:'$G(IBBUFDA) I $D(DIRUT) G REJX < REJX ; | ; ; < RESP(BUFF) ; List Response Report for Trace # associated < ; BUFF = buffer IEN < N NG,IBRSP,IBSTR,IBTRC,STOP,IBCNERTN,POP,IBCNESPC < S NG=0 < I $G(BUFF)="" S NG=1 < I 'NG S IBRSP=$O(^IBCN(365,"AF",BUFF,"")) I IBRSP="" < I 'NG S IBSTR=$G(^IBCN(365,IBRSP,0)),IBTRC=$P(IBSTR,U < I NG W !!,"This entry does not have an associated IIV < S STOP=0,IBCNERTN="IBCNERP1",IBCNESPC("TRCN")=IBTRC_U < D R100^IBCNERP1 < RESPX S VALMBCK="R" < Q < INPTTR(FILE,FLD,X) ; Does value X pass input transform f < N XCUTE < S XCUTE=$$GET1^DID(FILE,FLD,,"INPUT TRANSFORM") < X XCUTE < Q $D(X) < Only in ./VADemo/r1/: IBCNBLA2.m diff -y --suppress-common-lines ./VADemo/r1/IBCNBLA.m ./VADemo/r2/r/IBCNBLA.m ;;2.0;INTEGRATED BILLING;**82,149,153,184**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**82,149,153**;21-MAR-94 LNXTSCRN(TEMPLAT,TMPARR) ; select entries from list to | LNXTSCRN(TEMPLAT,TMPARR) ; user select entry from list ; | D NEWSCRN^IBCNBLA(TEMPLAT,TMPARR) ; This procedure is called from the ListMan action pr < ; processing and expanding buffer entries. < ; TEMPLAT - list template name for associated acti < ; TMPARR - subscript in scratch global < ; < NEW IBCNEZAR,IBCNEZEN,IBCNEZCT,IBCNEZGD,IBCNEZBF,IBCN < NEW ACT,REMAIN,DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT < D FULL^VALM1 < D MULSEL^IBCNBLA2(TMPARR,.IBCNEZAR,.IBCNEZGD) < I '$D(IBCNEZAR) G LNXTX < ; < ; loop through the list of selected buffer entries < S IBCNEZEN=0,IBCNEZCT=0 < F S IBCNEZEN=$O(IBCNEZAR(IBCNEZEN)) Q:'IBCNEZEN D < . I 'IBCNEZAR(IBCNEZEN) Q ; user could not get t < . S IBCNEZBF=$P(IBCNEZAR(IBCNEZEN),U,3) ; buffer i < . S IBBUFDA=IBCNEZBF ; just in case IB rtns < . S IBCNEZCT=IBCNEZCT+1 < . I '$D(IBCNEZQ) D < .. D EN^VALM(TEMPLAT) ; invoke l < .. I $G(IBFASTXT) S IBCNEZQ=1 Q ; Fast Exi < .. S ACT="expand" < .. I TEMPLAT["PROCESS" S ACT="process" < .. S REMAIN=IBCNEZGD-IBCNEZCT < .. I 'REMAIN Q < .. W @IOF < .. W !!!,"You are ",ACT,"ing multiple insurance buffe < .. W !,"You just completed entry number ",IBCNEZEN," < .. S DIR(0)="Y" < .. S DIR("A")="Do you want to "_ACT_" the remaining e < .. I REMAIN>1 S DIR("A")="Do you want to "_ACT_" the < .. S DIR("B")="YES" < .. W ! D ^DIR K DIR < .. I 'Y S IBCNEZQ=1 ; User said NO so set the Q < .. Q < . ; < . ; Make sure to unlock the buffer entry in all cases < . ; even if the user wants to quit out of this loop < . D UNLOCK^IBCNBU1(IBCNEZBF) < . Q < LNXTX ; < LREJECT(TMPARR) ; user select entries from list then reject/d | LREJECT(TMPARR) ; user select entry from list then reject/del ; | N IBBUFDA I $G(TMPARR)'="" S IBBUFDA=$$SEL(TMPARR) ; This procedure is called from the ListMan action pr | I +IBBUFDA,$$LOCK^IBCNBU1(IBBUFDA,1) D REJECT^IBCNBLA ; rejecting buffer entries. < ; TMPARR - subscript in scratch global < ; < NEW IBCNEZAR,IBCNEZEN,IBCNEZCT,IBCNEZGD,IBCNEZBF,IBCN < D FULL^VALM1 < D MULSEL^IBCNBLA2(TMPARR,.IBCNEZAR,.IBCNEZGD) < I '$D(IBCNEZAR) G LREJX < ; < ; loop through the list of selected buffer entries < S IBCNEZEN=0,IBCNEZCT=0 < F S IBCNEZEN=$O(IBCNEZAR(IBCNEZEN)) Q:'IBCNEZEN D < . I 'IBCNEZAR(IBCNEZEN) Q ; user could not get t < . S IBCNEZBF=$P(IBCNEZAR(IBCNEZEN),U,3) < . S IBBUFDA=IBCNEZBF ; just in case IB rtns < . S IBCNEZCT=IBCNEZCT+1 < . I '$D(IBCNEZQ) D < .. W @IOF,!?2,$G(IORVON) < .. W " Entry ",IBCNEZEN," (",IBCNEZCT," of ",IBCNEZG < .. W $G(IORVOFF) < .. D REJECT^IBCNBLA1(IBCNEZBF,.IBCNEZQ) < .. ; < .. ; If the user wants to stop and we're not processi < .. ; then determine if we should process the remainin < .. ; < .. I $D(IBCNEZQ),IBCNEZCT ;S IBCNS0=$G(^DIC(36,+IBCNS,0)) > ;D SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF > ;D SET^IBCNSP(START+1,OFFSET," "_$P(IBCNS0,"^",12)) N OFFSET,START,SYN,SYNOI | N OFFSET,START,IBSN,SYN S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2 | S START=71+$G(IBLCNT),OFFSET=2 S IB1ST("SYN")=START | ;F I=START:1:START+8 D BLANK^IBCNSC(.I) S SYN="" F SYNOI=1:1:8 S SYN=$O(^DIC(36,+IBCNS,10,"B" | S SYN="" F I=1:1:8 S SYN=$O(^DIC(36,+IBCNS,10,"B",SYN > ;S IBSN=0 F I=1:1:8 S IBSN=+$O(^DIC(36,+IBCNS,10,IBSN diff -y --suppress-common-lines ./VADemo/r1/IBCNSC1.m ./VADemo/r2/r/IBCNSC1.m ;;2.0;INTEGRATED BILLING;**62,137,232,291**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**62,137**;21-MAR-94 N DIR,X,Y,DTOUT,DUOUT < S Y=1 < I $G(IBY)'=",12," S DIR(0)="YA",DIR("B")="YES",DIR("A < G:$D(DTOUT)!$D(DUOUT) MAINQ < I Y D FACID < N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT | N DIE S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS C FACID ; -- Edit facility ids < D FACID^IBCEP2B(+IBCNS) < Q < ; < PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z | PROVID N OFFSET,START,IBCNS4,IBDISP,Z S START=53,OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS | S START=53,OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)) D PARAMS(IBCNS4,IBCNS3,.IBDISP) | D PARAMS(IBCNS4,.IBDISP) PARAMS(IBCNS4,IBCNS3,IBDISP) ; Returns array containing pr | PARAMS(IBCNS4,IBDISP) ; Returns array containing prov id pa ; IBCNS3,IBCNS4 = '3','4' nodes of ins co | ; IBCNS4 = '4' node of insurance co S IBDISP(1)="0^Perf Provider Secondary ID Type (HCFA) | S IBDISP(1)="0^Performing Provider ID Type: "_$$EXPAN S IBDISP(2)="0^Perf Provider Secondary ID Type (UB92) | S IBDISP(2)="18^ID Source: "_$$EXPAND^IBTRE(36,4.02,$ S IBDISP(3)="0^Perf Provider Secondary ID Requirement | S IBDISP(3)="7^Default If Not Found: "_$S($P(IBCNS4,U S IBDISP(4)="0^Require Provider's SSN To Print (HCFA) | S IBQ=3 S IBDISP(5)="0^Require Provider's SSN To Print (UB92) | I $P(IBCNS4,U,3)=2 D S IBDISP(6)="22^Care Unit Prompt: "_$$EXPAND^IBTRE(36 | . S IBQ=IBQ+1 > . S IBDISP(IBQ)="10^Alternate ID Type: "_$$EXPAND^IBT > . S IBQ=IBQ+1 > . S IBDISP(IBQ)="8^Alternate ID Source: "_$S($P(IBCNS > S IBDISP(IBQ+1)="11^Care Unit Prompt: "_$$EXPAND^IBTR > S IBDISP(IBQ+2)=" " > S IBDISP(IBQ+3)="0^EMC ID ID Source: "_$$E > S IBDISP(IBQ+4)="7^Default If Not Found: "_$S($P(IBCN > S IBDISP(IBQ+5)="11^Care Unit Prompt: "_$$EXPAND^IBTR > S IBDISP(IBQ+6)="" > S IBDISP(IBQ+7)="0^Network ID ID Source: "_$$E > S IBDISP(IBQ+8)="7^Default If Not Found: "_$S($P(IBCN diff -y --suppress-common-lines ./VADemo/r1/IBCNSC4.m ./VADemo/r2/r/IBCNSC4.m ;;2.0;INTEGRATED BILLING;**43,85,103,251**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**43,85,103**;21-MAR-94 S IBCPOLD2=$G(^IBA(355.3,IBCPOL,6)) ;; Daou/EEN addin < S START=10+$S($P($G(IBCPOLD),U,14)]"":1,1:0),OFFSET=2 | S START=8+$S($P($G(IBCPOLD),U,14)]"":1,1:0),OFFSET=2 S START=14+$G(IBLCNT),OFFSET=2 | S START=12+$G(IBLCNT),OFFSET=2 S START=17+$G(IBLCNT),OFFSET=2 | S START=15+$G(IBLCNT),OFFSET=2 S START=23+$G(IBLCNT),OFFSET=2,LINE=1 | S START=21+$G(IBLCNT),OFFSET=2,LINE=1 diff -y --suppress-common-lines ./VADemo/r1/IBCNSCD.m ./VADemo/r2/r/IBCNSCD.m IBCNSCD ;ALB/CPM - DELETE INSURANCE COMPANY ;01-FEB-95 | IBCNSCD ;ALB/CPM - DELETE INSURANCE COMPANY ; 01-FEB-95 ;;2.0;INTEGRATED BILLING;**28,46,232**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**28,46**; 21-MAR N I,IBC,IBDAT,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE < I $O(^IBA(355.9,"AE",IBCNS,""))!$O(^IBA(355.91,"AC",I < .W !!,"There are still provider ids defined for this < .W !,"be deleted before you can delete this company." < I $O(^IBA(355.96,"AC",IBCNS,""))!$O(^IBA(355.95,"C",I < .W !!,"There are still provider id care units defined < .W !,"care unit entries must be deleted before you ca < I $O(^IBA(355.92,"B",IBCNS,"")) D G DELQ < .W !!,"There are still facility ids defined for this < .W !,"deleted before you can delete this company." < diff -y --suppress-common-lines ./VADemo/r1/IBCNSC.m ./VADemo/r2/r/IBCNSC.m ;;2.0;INTEGRATED BILLING;**46,137,184**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**46,137**;21-MAR-94 NEW IB1ST < NEW BLNKI < F BLNKI=1:1:69 D BLANK(.BLNKI) | F I=1:1:76 D BLANK(.I) ; ESG - 7/29/02 - IIV project - Added payer section | S VALMCNT=76 D PARAM^IBCNSC01,MAIN^IBCNSC01,CLAIMS1^IBCNSC0,CLAIMS | D PARAM^IBCNSC01,MAIN^IBCNSC01,CLAIMS1^IBCNSC0,CLAIMS NEW DLAYGO,DIC,X,Y,DTOUT,DUOUT < ; | CC ; -- change insurance company > S IBCNS1=IBCNS D INSCO > Q diff -y --suppress-common-lines ./VADemo/r1/IBCNSM3.m ./VADemo/r2/r/IBCNSM3.m IBCNSM3 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 4/7/03 9: | IBCNSM3 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 28-MAY-93 ;;2.0;INTEGRATED BILLING;**6,28,85,211,251**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**6,28,85**;21-MAR-94 .;DAOU/EEN-Adding BIN and PCN (6.02,6.03) | .S DR="S IBAD=$P($G(^IBA(355.3,DA,0)),U,2),Y=$S(IBAD= .S DR="S IBAD=$P($G(^IBA(355.3,DA,0)),U,2),Y=$S(IBAD= | .I $D(IBREG),'$G(IBNEWP) S DR="S IBAD=$P($G(^IBA(355. .;DAOU/EEN-Adding BIN and PCN (6.02,6.03) < .I $D(IBREG),'$G(IBNEWP) S DR="S IBAD=$P($G(^IBA(355. < .I $D(IBREG),'$G(IBNEWP) S DR=DR_".15;S Y=$S($$CATOK^ < diff -y --suppress-common-lines ./VADemo/r1/IBCNSM4.m ./VADemo/r2/r/IBCNSM4.m ;;2.0;INTEGRATED BILLING;**56,82,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**56,82**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBCNSM.m ./VADemo/r2/r/IBCNSM.m ;;2.0;INTEGRATED BILLING;**28,46,56,52,82,103,199**;2 | ;;2.0;INTEGRATED BILLING;**28,46,56,52,82,103**;21-MA N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBCNSMM.m ./VADemo/r2/r/IBCNSMM.m ;;2.0;INTEGRATED BILLING;**103,133,184**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**103,133**;21-MAR-94 ; IBSOUR = Source of Information | ; IBSOUR = Source of Information (Code with diff -y --suppress-common-lines ./VADemo/r1/IBCNSMR.m ./VADemo/r2/r/IBCNSMR.m ;;2.0;INTEGRATED BILLING;**92,240**;21-MAR-94 | ;;2.0; INTEGRATED BILLING ;**92**; 21-MAR-94 I $S(RN["MEANS":1,RN["DENTAL":1,RN["TORT":1,RN["TRICA | I $S(RN["MEANS":1,RN["DENTAL":1,RN["TORT":1,RN["CHAMP STOP() ; -- determine if user requested task to stop | STOP() ; -- deterimine if user requested task to stop diff -y --suppress-common-lines ./VADemo/r1/IBCNSP01.m ./VADemo/r2/r/IBCNSP01.m ;;2.0;INTEGRATED BILLING;**43,52,85,251**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**43,52,85**;21-MAR-94 S START=19,OFFSET=2 | S START=16,OFFSET=2 S START=41+$G(IBLCNT),OFFSET=2 | S START=38+$G(IBLCNT),OFFSET=2 S START=53+$G(IBLCNT),OFFSET=2,IBL=0 | S START=50+$G(IBLCNT),OFFSET=2,IBL=0 diff -y --suppress-common-lines ./VADemo/r1/IBCNSP0.m ./VADemo/r2/r/IBCNSP0.m ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229 | ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137**;2 S START=41+$G(IBLCNT),OFFSET=42 | S START=38+$G(IBLCNT),OFFSET=42 D SET(START+5,OFFSET," Contact Date: "_$$EXPAND^I | D SET(START+4,OFFSET," Contact Date: "_$$EXPAND^I D SET(START+4,OFFSET," BIN: "_$P(IBCPOLD2 | D SET(START+4,OFFSET," Type of Plan: "_$E($P($G(^I D SET(START+5,OFFSET," PCN: "_$P(IBCPOLD2 | S IBX=5 D SET(START+6,OFFSET," Type of Plan: "_$E($P($G(^I < S IBX=7 < S START=30,OFFSET=4 | S START=27,OFFSET=4 diff -y --suppress-common-lines ./VADemo/r1/IBCNSP11.m ./VADemo/r2/r/IBCNSP11.m ;;2.0;INTEGRATED BILLING;**28,43,85,103,137,251**;21- | ;;2.0;INTEGRATED BILLING;**28,43,85,103,137**;21-MAR- ;;Daou/EEN - adding BIN (#355.3,6.02) and PCN (#355.3 | S DR=".03"_IBTL_" NAME;.04"_IBTL_" NUMBER;.09;.15;S Y S DR=".03"_IBTL_" NAME;.04"_IBTL_" NUMBER;6.02;6.03;. < diff -y --suppress-common-lines ./VADemo/r1/IBCNSP2.m ./VADemo/r2/r/IBCNSP2.m IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATI | IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATI ;;2.0;INTEGRATED BILLING;**6,28,75,82,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**6,28,75,82**;21-MAR-94 N DLAYGO,DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D, | N DLAYGO,DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D, S IBCNP=1,IBMCR=$$WNRBILL^IBEFUNC(IBIFN) | S IBCNP=1 I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1 < diff -y --suppress-common-lines ./VADemo/r1/IBCNSP3.m ./VADemo/r2/r/IBCNSP3.m ;;2.0;INTEGRATED BILLING;**28,52,85,251**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**28,52,85**;21-MAR-94 ;;Daou/EEN - adding BIN and PCN < S ^TMP($J,"IBCNSP",355.3,+IBCPOL,6)=$G(^IBA(355.3,+IB < ;;Daou/EEN - adding BIN and PCN < I $G(^IBA(355.3,+IBCPOL,6))'=$G(^TMP($J,"IBCNSP",355. < diff -y --suppress-common-lines ./VADemo/r1/IBCNSP.m ./VADemo/r2/r/IBCNSP.m ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251**;21-MAR | ;;2.0;INTEGRATED BILLING;**6,28,43,52,85**;21-MAR-94 S IBCPOLD2=$G(^IBA(355.3,+$G(IBCPOL),6)) ;; Daou/EEN < D POLICY^IBCNSP0,INS^IBCNSP0,SPON^IBCNSP0,LIMBLD^IBCN | D POLICY^IBCNSP0,INS^IBCNSP0,SPON^IBCNSP0,LIMBLD^IBCN S START=49+$G(IBLCNT),OFFSET=2,IBL=0 | S START=46+$G(IBLCNT),OFFSET=2,IBL=0 S START=12,OFFSET=45 | S START=9,OFFSET=45 S START=12,OFFSET=2 | S START=9,OFFSET=2 S START=19,OFFSET=40 | S START=16,OFFSET=40 K IBPPOL,VALMQUIT,IBCNS,IBCPOL,IBCPOLD,IBCPOLD1,IBCPO | K IBPPOL,VALMQUIT,IBCNS,IBCPOL,IBCPOLD,IBCPOLD1,IBCDF diff -y --suppress-common-lines ./VADemo/r1/IBCNSU1.m ./VADemo/r2/r/IBCNSU1.m ;;2.0;INTEGRATED BILLING;**103,133,244**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**103,133**;21-MAR-94 N NODE,L,R,CHAR,X1 | N NODE,L,R S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """ < S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"") | S L=$P(^DPT(DA(1),0),U,9) ; - if subscriber ID is the SSN of patient, remove al < ; characters < S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1 < ; < .; 8/18/2003 - Added translation code to remove hyphe | .I $P(IB0,U,2)]"" S IBY=$P(IB0,U,2) .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","") < diff -y --suppress-common-lines ./VADemo/r1/IBCNSU41.m ./VADemo/r2/r/IBCNSU41.m IBCNSU41 ;ALB/CPM - SPONSOR UTILITIES (CON'T) ; 5/9/03 | IBCNSU41 ;ALB/CPM - SPONSOR UTILITIES (CON'T) ; 23-JAN ;;2.0;INTEGRATED BILLING;**52,211,240**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94 POL(DFN) ; Update TRICARE policies with Sponsor inform | POL(DFN) ; Update CHAMPUS policies with Sponsor inform ; - update any policies with TRICARE plans | ; - update any policies with CHAMPUS plans .; - only consider TRICARE plans | .; - only consider CHAMPUS plans .;IB*2*211 | .I $P(IBX,"^",17)="" S DR=DR_"17////"_Z("NAME")_";" .I $P(IBY,"^",17)="" S DR=DR_"17////"_Z("NAME")_";" < diff -y --suppress-common-lines ./VADemo/r1/IBCNSUR1.m ./VADemo/r2/r/IBCNSUR1.m IBCNSUR1 ;ALB/CPM/CMS - MOVE SUBSCRIBERS TO DIFFERENT | IBCNSUR1 ;ALB/CPM/CMS - MOVE SUBSCRIBERS TO DIFFERENT ;;2.0;INTEGRATED BILLING;**103,225**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**103**;21-MAR-94 ..S X=+IBIAB,DIC(0)="L",DLAYGO=355.4,DIC="^IBA(355.4, | ..S X=+IBIAB,DIC(0)="",DLAYGO=355.4,DIC="^IBA(355.4," ; - should plan comments be copied over to the new pl < S (IBAB,IBQ)=0 < I $P($G(^IBA(355.3,IBP1,11,0)),U,4),'$P($G(^IBA(355.3 < .S DIR(0)="Y" < .S DIR("A")="Okay to add "_IBC1N_"'s Comments to "_IB < .S DIR("?")="If you wish to move these Comments, ente < .S DIR("?")=DIR("?")_" - otherwise, ente" < .W ! D ^DIR K DIR I $D(DIRUT)!$D(DIROUT)!$D(DUOUT)!$D < .S:Y IBAB=1 K DIRUT,DUOUT,DTOUT,DIROUT < ; < ; - copy plan comments over to the new plan < I IBAB D < .S DIC="^IBA(355.3,"_IBP2_",11,",DIC(0)="L",DIC("P")= < .S IBI=0 F S IBI=$O(^IBA(355.3,IBP1,11,IBI)) Q:'IBI < ..I $G(^IBA(355.3,IBP1,11,IBI,0))]"" S X=^(0) D FILE^ < ; < K DIK,DLAYGO < diff -y --suppress-common-lines ./VADemo/r1/IBCNSUR2.m ./VADemo/r2/r/IBCNSUR2.m ;;2.0;INTEGRATED BILLING;**103,238**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**103**;21-MAR-94 W !,?11,"ELECTRONIC PLAN TYPE: ",$$EXPAND^IBTRE(355. < S DR=".09;.15;I $P($G(^IBE(355.1,+$P($G(^IBA(355.3,DA | S DR=".09;I $P($G(^IBE(355.1,+$P($G(^IBA(355.3,DA,0)) diff -y --suppress-common-lines ./VADemo/r1/IBCONS2.m ./VADemo/r2/r/IBCONS2.m IBCONS2 ;ALB/CPM - NSC W/INSURANCE OUTPUT (CON'T) ;31-JAN-92 | IBCONS2 ;ALB/CPM - NSC W/INSURANCE OUTPUT (CON'T) ; 31-JAN-92 ;;2.0;INTEGRATED BILLING;**19,36,54,66,91,99,108,120, | ;;2.0;INTEGRATED BILLING;**19,36,54,66,91,99,108,120, . I IB0'="",$P(IB0,"^",5)<3,$P(IB0,"^",13)<7,$P($P(IB | . I IB0'="",$P(IB0,"^",5)<3,$P(IB0,"^",13)<7,$P($P(IB . I IB0'="",$P(IB0,"^",13)<7,$P(IB0,"^",11)="i" S B=B | . I IB0'="",$P(IB0,"^",13)<7,$P(IB0,"^",11)="i" S B=B diff -y --suppress-common-lines ./VADemo/r1/IBCRBC11.m ./VADemo/r2/r/IBCRBC11.m IBCRBC11 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE E | IBCRBC11 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE E ;;2.0;INTEGRATED BILLING;**106,245,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94 ; - if bedsection is ICU then allow ICU Charge Set on < D INPTPTF^IBCRBG(IBIFN,CS) | D INPTPTF^IBCRBG(IBIFN) S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) | S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")),IBIDRC=$G(^DIC(3 I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IB < S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) < .. I '$$CHGICU^IBCRBC2(CS,IBBS) Q ; check icu charge < .. ; < S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) | S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")),IBIDRC=$G(^DIC(3 I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IB < S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) < diff -y --suppress-common-lines ./VADemo/r1/IBCRBC1.m ./VADemo/r2/r/IBCRBC1.m IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; | IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ;2 ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,2 | ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148**;21- N IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBDIV,IBITM,IB | N IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBITM,IBTYPE,IB D INPTPTF^IBCRBG(IBIFN,CS) | D INPTPTF^IBCRBG(IBIFN) S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's de < ; < .. S IBX=$G(^TMP($J,"IBCRC-INDT",IBEVDT)),IBITM=+$P(I | .. S IBX=$G(^TMP($J,"IBCRC-INDT",IBEVDT)),IBITM=+$P(I .. ; | .. S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT .. I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check divi < .. ; < .. S IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^^"_IBCMPNT < ; - different sets of charges apply to SNF and Inpati < ; - the Default Rx CPT should not be billed the CPT c < N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX I '$G | N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE I '$G(IBIFN)!'$G(CS) S IBBR=$P(IBX,U,3) S IBCPTRX="" I $O(^IBA(362.4,"C",I | S IBBR=$P(IBX,U,3) D INPTPTF^IBCRBG(IBIFN,CS) ; get inpatient bedsection | D INPTPTF^IBCRBG(IBIFN) ; get inpatient bedsections I IBBLITEM=2 D ; cpt/count/minutes/miles/hours | I IBBLITEM=2,IBCHGMTH=1 D ; cpt/count ... ; < ... I '$$CHGOTH^IBCRBC2(IBIFN,RS,IBEVDT) Q < ... I +IBCPTRX,'IBOE,IBCPT=IBCPTRX Q ; site paramete < ... ; < ... S IBUNIT=$$CPTUNITS^IBCRBC2(CS,IBCHGMTH,IBX) Q:'I < ... ; < ... I +IBMOD S IBMOD=$P($$CPTMOD^IBCRCU1(CS,IBCPT,IBM | ... I +IBMOD,'$$CPTMOD^IBCRCU1(IBBR,IBCPT,IBMOD) S IB ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD | ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,1,IBMOD,"",I diff -y --suppress-common-lines ./VADemo/r1/IBCRBC2.m ./VADemo/r2/r/IBCRBC2.m ;;2.0;INTEGRATED BILLING;**52,106,138,148,245**;21-MA | ;;2.0;INTEGRATED BILLING;**52,106,138,148**;21-MAR-94 N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBR | N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBR . S IBLN=IBCHGARR(IBI),IBCI=+IBLN,IBCHRG=$P(IBLN,U,3) | . S IBLN=IBCHGARR(IBI),IBCI=+IBLN,IBCHRG=$P(IBLN,U,3) . S IBCHRG=IBCHRG*UNITS | . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRC . S IBCHRG=IBCHRG+IBBASE | . S IBTCHRG=IBCHRG*UNITS . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRC < . S (IBCHRG,IBTCHRG)=+IBPCHRG < . ; | . I $P(IBPCHRG,U,2)'="" S $P(^TMP($J,"IBCRCC",IBCNT," . I (UNITS>1)!(+IBBASE) S IBCOM=$$COMMUB(CS,UNITS,IBB | . I $P(IBRCHRG,U,2)'="" S $P(^TMP($J,"IBCRCC",IBCNT," . I $P(IBPCHRG,U,2)'="" S IBCOM=$P(IBPCHRG,U,2) I IBC < . I $P(IBRCHRG,U,2)'="" S IBCOM=$P(IBRCHRG,U,2) I IBC < Q < ; < COMMENT(LINE,COMM) ; set comment into charge array for a < I +$D(^TMP($J,"IBCRCC",+$G(LINE))) N IBX D < . S IBX=$O(^TMP($J,"IBCRCC",+LINE,"CC",9999),-1) S IB < . S ^TMP($J,"IBCRCC",+LINE,"CC",IBX)=$G(COMM) < COMMUB(CS,UNITS,BASE) ; return comment for special units an < N IBX,IBY,IBCM S IBX="",IBY="Charge calculated" < S IBCM=$P($G(^IBE(363.1,+CS,0)),U,2),IBCM=$P($G(^IBE( < S IBCM=$S(IBCM=4:"Miles",IBCM=5:"SubUnits",IBCM=6:"Ho < I +$G(UNITS) S IBX=IBY_" for "_UNITS_" "_IBCM,IBY="" < I +$G(BASE) S IBX=IBY_IBX_" with a Base Charge="_$J(B < Q IBX < ; < > MULTCPT ; calculate the multiple surgical procedure discount > ; if multiple surgical procedures are performed for t > ; this can only be calculated after all charges on th > ; Billing Rate = RC OUTPATIENT F > ; Billable Event = PROCEDURE > ; Surgical CPT Range = 10000-69999, 93 > ; > N IBI,IBLN,IBCS,IBCPT,IBCSBR,IBGRP,IBCNT,IBC,IBDSCNT, > N IBDT,IBCLIN,IBOE,IBTMPA,IBTMPS > ; > S IBI=0 F S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI D > . S IBLN=$G(^TMP($J,"IBCRCC",IBI)),IBCS=$P(IBLN,U,2), > . S IBCHRG=+$P(IBLN,U,9),IBDT=+$P(IBLN,U,8),IBCLIN=+$ > . S IBCSBR=$$CSBR^IBCRU3(IBCS) > . ; > . I $P($G(^IBE(363.3,+$P(IBCSBR,U,3),0)),U,1)'["RC OU > . I $P(IBCSBR,U,1)'["PROCEDURE" Q > . I '((IBCPT'<10000)&(IBCPT'>69999))&'((IBCPT'<93501) > . ; > . S IBTMPA(IBI)=IBCHRG_U_IBDT_U_IBCLIN_U_IBOE I +IBOE CPTUNITS(CS,CHGMTH,ITLINE) ; return CPT units based on C | S IBI=0 F S IBI=$O(IBTMPA(IBI)) Q:'IBI D ; Input: CS is the related Charge Set | . S IBLN=IBTMPA(IBI),IBCHRG=+$P(IBLN,U,1),IBDT=+$P(IB ; CHGMTH is the Rate Schedule Charge Method ( | . I 'IBOE S IBOE=$O(IBTMPS(IBDT,IBCLIN,IBOE)) ; ITLINE is item data from CPT^IBCRBG1 | . S IBGRP=IBDT_U_IBCLIN_U_IBOE ; Output: calculated units for CPT, 1 or calculated f | . S IBCHGARR(IBGRP,-IBCHRG,IBI)="" N IBUNIT S IBUNIT=1,CHGMTH=$G(CHGMTH),ITLINE=$G(ITLIN | ; I CHGMTH=4 S IBUNIT=+$P(ITLINE,U,8) ; miles | S IBGRP=0 F S IBGRP=$O(IBCHGARR(IBGRP)) Q:'IBGRP D I CHGMTH=5 S IBUNIT=+$P(ITLINE,U,7) ; minutes | . S IBCNT=0,IBC="" F S IBC=$O(IBCHGARR(IBGRP,IBC)) Q I CHGMTH=6 S IBUNIT=+$P(ITLINE,U,9) ; hours | .. S IBI=0 F S IBI=$O(IBCHGARR(IBGRP,IBC,IBI)) Q:'IB S IBUNIT=$$CPTUNITS^IBCRCU1(CS,IBUNIT) | ... S IBCNT=IBCNT+1,IBDSCNT=$S(IBCNT=1:1,IBCNT=2:.25, Q IBUNIT | ... S IBLN=$G(^TMP($J,"IBCRCC",IBI)) Q:IBLN="" ; | ... S IBCHRG=$P(IBLN,U,9),IBUNITS=$P(IBLN,U,10),IBRS= CHGOTH(IBIFN,RS,EVDT) ; check if the Rate Schedule charges | ... ; ; this is relevent to RC v2.0 and type of care of Oth | ... S IBCHRG=IBCHRG*IBDSCNT ; both Rate Schedule is SNF and event date is SNF car | ... S IBTCHRG=IBCHRG*IBUNITS ; SNF charges can't be used for non-SNF care and non- | ... S IBACHRG=IBTCHRG I +IBRS S IBRCHRG=$$RATECHG^IBC ; Output: returns true if charges and bill date are o | ... ; N IBOK,IBRSTY,IBDTTY S (IBRSTY,IBDTTY)=0,IBOK=1 | ... ;I IBCHRG'>0 K ^TMP($J,"IBCRCC",IBI) S ^TMP($J,"I I $G(EVDT)<$$VERSDT^IBCRU8(2) G CHGOTHQ | ... S $P(^TMP($J,"IBCRCC",IBI),U,9)=+$FN(IBCHRG,"",2) I '$G(IBIFN)!'$G(RS) G CHGOTHQ | ... S $P(^TMP($J,"IBCRCC",IBI),U,11)=+$FN(IBTCHRG,"", ; | ... S $P(^TMP($J,"IBCRCC",IBI),U,12)=+$FN(IBACHRG,"", S IBRSTY=$$RSOTHER^IBCRU8(RS) ; are charges for other | ... S $P(^TMP($J,"IBCRCC",IBI,"CC"),U,2)="Multiple Su S IBDTTY=$$BOTHER^IBCU3(IBIFN,EVDT) ; is date other t | ... I $P(IBRCHRG,U,2)'="" S $P(^TMP($J,"IBCRCC",IBI," ; | ; I +IBRSTY,'IBDTTY S IBOK=0 | Q I 'IBRSTY,+IBDTTY S IBOK=0 < ; < CHGOTHQ Q IBOK < ; < CHGICU(CS,BS) ; check if charge and bedsection match relati < ; both the charge set and the bedsection have to be I < ; ICU charges can't be used with non-ICU bedsections < ; Output: returns true if charges and bedsection are < N IBCSICU,IBCSN,IBICU,IBOK S (IBOK,IBCSICU)=0,BS=+$G( < S IBICU=$$MCCRUTL^IBCRU1("ICU",5) < S IBCSN=$G(^IBE(363.1,+$G(CS),0)) I $E(IBCSN,1,2)'="R < I $P(IBCSN,U,1)["ICU" S IBCSICU=1 ; charge set is icu < ; < I BS=IBICU,+IBCSICU S IBOK=1 ; both bedsection and ch < I BS'=IBICU,'IBCSICU S IBOK=1 ; niether bedsection no < Q IBOK < Only in ./VADemo/r1/: IBCRBCA1.m Only in ./VADemo/r1/: IBCRBCA2.m Only in ./VADemo/r1/: IBCRBCA3.m Only in ./VADemo/r1/: IBCRBCAP.m diff -y --suppress-common-lines ./VADemo/r1/IBCRBC.m ./VADemo/r2/r/IBCRBC.m IBCRBC ;ALB/ARH - RATES: BILL CALCULATION OF CHARGES ; 22-MA | IBCRBC ;ALB/ARH - RATES: BILL CALCULATION OF CHARGES ;22-MAY ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245**;21- | ;;2.0;INTEGRATED BILLING;**52,80,106,51,137**;21-MAR- D MULTCPT^IBCRBCA1 ; adjust charges for Multiple Surg | D MULTCPT^IBCRBC2 D PSB^IBCRBCA2 ; adjust charges for Primary/Secon < D MODADJ^IBCRBCA3 ; adjust charges for Modifier Adju < ; ^TMP($J,"IBCRCC",X,"CC",x) = comments explaining c | ; ^TMP($J,"IBCRCC",X,"CC") = 1 comment explaining ch > ; 2 comment explaining ch > ; 3 comment explaining ch ; < ; < ; Inpatient Bill Dates use follow rules: < ; - admission date is counted as billable < ; - the discharge date is not billable and is not cou < ; < ; - if admission movement is found in the Patient Mov < ; will be used as the outside limits of the LOS, ev < ; < ; - a day is counted as billable to the bedsection th < ; in LOS of next movement after midnight) < ; - if there is a movement on any given date that dat < ; moved into (same as admission date) < ; - if there is a movement on any given date that dat < ; patient moved out of (same as discharge date) < ; < ; - if the time frame of the bill is: < ; - either interim-first or interim-continuous the < ; - if the last date is counted it is added to th < ; of the day < ; - either NOT interim-first or interim-continuous < ; should NOT be billed (i.e. this is considered t < ; < ; - start with first bedsection after begin date, day < ; - continuous: last bedsection counted is the bedsec < ; - final:last bedsection counted is the bedsection t < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCRBE.m ./VADemo/r2/r/IBCRBE.m ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 .. I IBRSN'="",IBCSN'="" S ARRX(IBS_IBRSN_IBRS_IBCS,I | .. I IBRSN'="",IBCSN'="" S ARRX(IBS_IBRSN,IBCSN)=IBRS diff -y --suppress-common-lines ./VADemo/r1/IBCRBG1.m ./VADemo/r2/r/IBCRBG1.m ;;2.0;INTEGRATED BILLING;**52,106,148,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106,148**;21-MAR-94 ; returns ARR = cnt of CPT's found | ; returns ARR = cnt of CPT's found ; ARR(CPT,DA of CPT) = date ^ modifiers ^ division ^ | ; ARR(CPT, DA of CPT) = date ^ modifier . I +IBX,IBX[";ICPT(" S ARR=ARR+1,ARR(+IBX,IBI)=$P(IB | . I +IBX,IBX[";ICPT(" S ARR=ARR+1,ARR(+IBX,IBI)=$P(IB Only in ./VADemo/r1/: IBCRBG2.m diff -y --suppress-common-lines ./VADemo/r1/IBCRBG.m ./VADemo/r2/r/IBCRBG.m IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY | IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ;21 MAY 9 ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,2 | ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159**;21- INPTPTF(IBIFN,CS) ; search PTF record for billable beds | INPTPTF(IBIFN) ; search PTF record for billable bedsections, ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOV | ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOV D INPTRSET^IBCRBG2(IBIFN,$G(CS)) < ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/T | ; Output: ^TMP($J,"IBCRC-PTF", MOVE DATE/TIME)=MOVE . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U | . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U ; Input: ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT | ; Input: ^TMP($J,"IBCRC-PTF", MOVE/TRANSFER DT/TM) ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOV | ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOV > ; dates used follow rules: > ; - admission date is counted as billable > ; - the discharge date is not billable and is not cou > ; > ; - if admission movement is found in the Patient Mov > ; will be used as the outside limits of the LOS, ev > ; > ; - a day is counted as billable to the bedsection th > ; in LOS of next movement after midnight) > ; - if there is a movement on any given date that dat > ; moved into (same as admission date) > ; - if there is a movement on any given date that dat > ; patient moved out of (same as discharge date) > ; > ; - if the time frame of the bill is: > ; - either interim-first or interim-continuous the > ; - if the last date is counted it is added to th > ; of the day > ; - either NOT interim-first or interim-continuous > ; should NOT be billed (i.e. this is considered t > ; > ; - start with first bedsection after begin date, day > ; - continuous: last bedsection counted is the bedsec > ; - final:last bedsection counted is the bedsection t > ; ; Input: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt | ; Input: ^TMP($J,"IBCRC-PTF", move dt/time) = move ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt | ; Output: ^TMP($J,"IBCRC-PTF", move/TRANS dt/time) = . I 'IBMVDT Q ; - transfer movement dates after the | . I 'IBMVDT Q ; - Prevent a problem where there are N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC | N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,IC | N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG S IBDRG="" < S IBJ=0 F IBI=5:1:9 S IBDX=$P(PTFM0,U,IBI) I +IBDX,($ | S IBJ=0 F IBI=5:1:9 S IBDX=$P(PTFM0,U,IBI) I +IBDX,$D .. F IBI=8:1:12 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ | .. F IBI=8:1:12 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,$D( .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$I | .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,$D(^ S ICDDATE=$P(PTFM0,U,10) ; use the movement date for < diff -y --suppress-common-lines ./VADemo/r1/IBCRBH1.m ./VADemo/r2/r/IBCRBH1.m ;;2.0;INTEGRATED BILLING;**106,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94 D NOTES(IBIFN,1) < D MULTCPT^IBCRBCA1 | D MULTCPT^IBCRBC2 D PSB^IBCRBCA2 < D MODADJ^IBCRBCA3 < ; TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustm | ; TMP($J,"IBCRCSX",X,"CC") = adjustment messa N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT, | N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT, . S IBY=0 F S IBY=$O(^TMP($J,"IBCRCC",IBI,"CC",IBY)) | . I $D(^TMP($J,"IBCRCC",IBI,"CC")) S ^TMP($J,"IBCRCSX N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBD | N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBD ... S IBY=0 F S IBY=$O(^TMP($J,"IBCRCSX",IBK,"CC",IB | ... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC")) I IBX'="" D .... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) I IBX' < ... I $O(^TMP($J,"IBCRCSX",IBK,"CC",0)) D DISPLNC("") < W !,?18,$G(LN) | N IBI,IBX F IBI=1:1:3 S IBX=$P(LN,U,IBI) I IBX'="" W > W ! ; < ; < ; < ; < NOTES(IBIFN,PAUSE) ; compile and print charge notes for < ; < ; Current Checks are for those Treating Specialties t < ; - Inpatient Institutional Reasonable Charges bill c < ; - Inpatient Institutional Reasonable Charges bill c < ; < I $D(ZTQUEUED)!(+$G(IBAUTO)) Q < N IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBM < S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G( < ; < I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U < ; < ; Outpatient Freestanding bill: display message if th < I $P(IB0,U,5)=3,$P(IB0,U,3)'<$$VERSDT^IBCRU8(2),$P($$ < . S IBFND=IBFND+1,IBX=">>> Bill Division is Freestand < ; < ; Inpatient Institutional bill: check for treating sp < I +$P(IB0,U,8),$P(IB0,U,5)<3,$P(IB0,U,27)<2 D < . ; < . S PTF=+$P(IB0,U,8),BEG=+$P(IBU,U,1)\1,END=$S(+$P(IB < . ; < . D PTF^IBCRBG(PTF) < . ; < . S IBENDDT=BEG F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",I < .. I (IBENDDT\1)=BEG,BEG'=END Q < .. ; < .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVLN=+ < .. S IBMDRG=$$NODRG^IBCRBG2(IBMVLN) Q:'IBMDRG < .. ; < .. S IBFND=IBFND+1,IBX=">>> "_$P(IBMDRG,U,2)_" ("_$$F < .. S:IBMDRG["Nursing" IBX=IBX_", use SNF." S:IBMDRG[" < .. S IBMSG(IBFND)=$G(IBX) < ; < I +IBFND D I +$G(PAUSE) S IBFND=$$PAUSE(21) < . W ! S IBX="" F S IBX=$O(IBMSG(IBX)) Q:IBX="" W !, < K ^TMP($J,"IBCRC-PTF") < Q < Only in ./VADemo/r1/: IBCRBH2.m diff -y --suppress-common-lines ./VADemo/r1/IBCRCC.m ./VADemo/r2/r/IBCRCC.m IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY- | IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ; 22-MAY ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223**;21 | ;;2.0;INTEGRATED BILLING;**52,80,106,138**;21-MAR-94 ; returns ARR = count of items in array ^ total charg | ; returns ARR = count of items in array ^ total charg ; ARR(x) = charge item IFN (if any) ^ rev cod | ; ARR(x) = charge item IFN (if any) ^ rev cod .. I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IB | .. I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IB SETARR(CI,RVCD,CHRG,ARR,CHRGB) ; set charges into an array, | SETARR(CI,RVCD,CHRG,ARR) ; set charges into an array, N CNT,TCHRG,TCHRGB | N CNT,TCHRG S CNT=+$G(ARR)+1,TCHRG=$P($G(ARR),U,2)+$G S CNT=+$G(ARR)+1,TCHRG=$P($G(ARR),U,2)+$G(CHRG) I +$G | I +$G(CHRG) S ARR=CNT_U_+TCHRG,ARR(CNT)=$G(CI)_U_+$G( I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)= < RATECHG(RS,CHG,EVDT,FEE) ; returns modifed item charge | RATECHG(RS,CHG,EVDT) ; returns modifed item charge based o ; if FEE passed by reference, returns disp fee^admin < S FEE=$P($G(^IBE(363,+$G(RS),1)),"^",1,2) < ; < HRUNIT(HRS) ; returns Hour Units based on the Hours passe < ; Hour Units are the hours rounded to the nearest who < N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0) < Q IBX < ; < MLUNIT(MLS) ; returns Miles Units based on the Miles pass < ; Mile Units are the miles rounded to the nearest who < N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S I < Q IBX < ; < MNUNIT(MNS) ; return Minute Units based on the Minutes pa < ; Minute Units are 15 minute intervals, rounded down < N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:(MNS#15)>4 < Q IBX < diff -y --suppress-common-lines ./VADemo/r1/IBCRCI.m ./VADemo/r2/r/IBCRCI.m IBCRCI ;ALB/ARH - RATES: CALCULATION ITEM/EVENT COST FNCTNS | IBCRCI ;ALB/ARH - RATES: CALCULATION ITEM/EVENT COST FNCTNS; ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 ; Output: total item charge on EVDT ^ effective date | ; Output: total item charge on EVDT ^ effective date N IBX,IBITMARR,IBCHGARR,IBITEM,IBI,IBLN,IBCHG,IBCHGB, | N IBX,IBITMARR,IBCHGARR,IBITEM,IBI,IBLN,IBCHG,IBCI,IB S (IBCHG,IBCHGB,IBCI,IBITEM)=0 F S IBITEM=$O(IBITMAR | S (IBCHG,IBCI,IBITEM)=0 F S IBITEM=$O(IBITMARR(IBITE . S IBI=0 F S IBI=$O(IBCHGARR(IBI)) Q:'IBI D | . S IBI=0 F S IBI=$O(IBCHGARR(IBI)) Q:'IBI S IBLN=I .. S IBLN=IBCHGARR(IBI) S IBCHG=IBCHG+$P(IBLN,U,3),IB < I +IBCHG S IBX=+$FN(+IBCHG,"",2)_U_$G(IBEFDT) I +IBCH | I +IBCHG S IBX=+$FN(+IBCHG,"",2)_U_$G(IBEFDT) ; units should be 1 or undefined unless the Charge Me | ; units should be 1 or undefined unless the Charge Me N IBCOST,IBBCOST,IBDT S IBCOST=0,EVDT=$G(EVDT)\1,UNIT | N IBCOST,IBDT S IBCOST=0,EVDT=$G(EVDT)\1,UNIT=$S(+$G( S UNIT=$$CPTUNITS^IBCRCU1(CS,UNIT) < S IBCOST=$$ITCHG(CS,$G(ITEM),EVDT,$G(MOD)),IBDT=$P(IB | S IBCOST=$$ITCHG(CS,$G(ITEM),EVDT,$G(MOD)),IBDT=$P(IB I +IBBCOST S IBCOST=IBCOST+IBBCOST < diff -y --suppress-common-lines ./VADemo/r1/IBCRCU1.m ./VADemo/r2/r/IBCRCU1.m ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 I IBBEVNT["PROCEDURE",IBBLITEM=2,IBCHGMTH=4 S IBX=1 G < I IBBEVNT["PROCEDURE",IBBLITEM=2,IBCHGMTH=5 S IBX=1 G < I IBBEVNT["PROCEDURE",IBBLITEM=2,IBCHGMTH=6 S IBX=1 G < CPTUNITS(CS,UNIT) ; return raw data returns CPT units b | CPTMOD(BR,CPT,MOD) ; check to see if the CPT-Modifier co ; Input: CS - Charge Set of charge determines Charge | N IBITEM,IBCI,IBCIN,IBX S IBX="" I '$G(BR)!'$G(CPT)!' ; UNIT - total miles/minutes/hours of item | S IBITEM=CPT_";ICPT(" ; Output: UNIT or calculated for miles/minutes/hours | S IBCI=0 F S IBCI=$O(^IBA(363.2,"B",IBITEM,IBCI)) Q: N IBUNITS,IBCSBR,IBCHGMTH S IBUNITS=+$G(UNIT) I 'IBUN | . S IBCIN=$G(^IBA(363.2,IBCI,0)) S CS=$G(CS) S IBCSBR=$$CSBR^IBCRU3(CS),IBCHGMTH=$P(IB | . I +MOD=+$P(IBCIN,U,7),+BR=+$P($G(^IBE(363.1,+$P(IBC I +IBCHGMTH=4 S IBUNITS=$$MLUNIT^IBCRCC(UNIT) ; miles < I +IBCHGMTH=5 S IBUNITS=$$MNUNIT^IBCRCC(UNIT) ; minut < I +IBCHGMTH=6 S IBUNITS=$$HRUNIT^IBCRCC(UNIT) ; hours < CPTUNITQ Q IBUNITS < ; < CPTMOD(CS,CPT,MODS,DATE) ; check to see if a CPT-Modif < ; Input MODS is a list of modifiers to check separate < ; Output "" or list of modifiers with active charges < N IBMOD,IBI,IBX,IBY S (IBX,IBY)="" I '$G(CS)!'$G(CPT) < F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:IBMOD="" D < . I +$$FNDCI^IBCRU4(CS,CPT,DATE,,IBMOD) S IBX=IBX_IBY < CHGMOD(IBIFN,CPT,EFFDT,CT) ; find charges for a procedur | CPTCHG(IBIFN,CT) ; return true if bill has auto add CP ; returns: count of charges ':' list of charge items | N IBFND,IB0,IBU,IBBILLDV,IBBCT,IBCT,ARRCPT,ARRCS,IBRS N IB0,IBU,IBBDV,IBBCT,ARRCS,IBRS,IBCS,ARRCHG,IBFND,IB < S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBU=$G(^DGCR(399,+$ < I IB0'="",+IBU,+IBBDV,+$G(CPT),+$G(EFFDT) D RT^IBCRU3 < . S IBRS=0 F S IBRS=$O(ARRCS(IBRS)) Q:'IBRS D < .. S IBCS=0 F S IBCS=$O(ARRCS(IBRS,IBCS)) Q:'IBCS I < ... I $$CSDV^IBCRU3(IBCS,IBBDV)<0 Q ; check division < ... I '$$CHGOTH^IBCRBC2(IBIFN,IBRS,EFFDT) Q ; ckeck < ... I +$$FNDCI^IBCRU4(IBCS,CPT,EFFDT,.ARRCHG) S IBFND < .... S IBX=0 F S IBX=$O(ARRCHG(IBX)) Q:'IBX S IBCI < I +IBFND S IBFND=IBFND_":"_IBCIS_":"_IBMODS < CHGMODQ Q IBFND < ; < CPTCHG(IBIFN,CT) ; return true if bill has auto add CP < N IBFND,IB0,IBU,IBBILLDV,IBBCT,IBCT,ARRCPT,ARRCS,IBRS < > ; .... I $$CSDV^IBCRU3(IBCS,$P(IBCPT0,U,3),IBBILLDV)<0 | .... S IBDV=$S(+$P(IBCPT0,U,3):$P(IBCPT0,U,3),1:IBBIL > .... S IBMOD=+$P(IBCPT0,U,2) I +IBMOD,'$$CPTMOD^IBCRC .... I +$$CHKIPB^IBCU7A1(IBCPT,IBCT) S IBFND=1 Q | .... I $$ITCOST^IBCRCI(IBRS,IBCS,IBCPT,$P(IBCPT0,U,1) .... I +$$FNDCI^IBCRU4(IBCS,IBCPT,$P(IBCPT0,U,1)) S I < diff -y --suppress-common-lines ./VADemo/r1/IBCREE1.m ./VADemo/r2/r/IBCREE1.m ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 S DR=$$DR01(+$P(IBITEM,U,4))_";.03;.04;.05;.06" | S DR=$$DR01(+$P(IBITEM,U,4))_";.03;.04;.05;.06;" I $P(IBITEM,U,4)=81 S DR=DR_";.07" | I $P(IBITEM,U,4)=81 S DR=DR_".07" I +$P(IBBR0,U,6) S DR=DR_";.08" < diff -y --suppress-common-lines ./VADemo/r1/IBCREE.m ./VADemo/r2/r/IBCREE.m IBCREE ;ALB/ARH - RATES: CM ENTER/EDIT ;16-MAY-1996 | IBCREE ;ALB/ARH - RATES: CM ENTER/EDIT ; 16-MAY-1996 ;;2.0;INTEGRATED BILLING;**52,106,115,223**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106,115**;21-MAR-94 ; < I $P($G(^DGCR(399.1,+$P(^IBE(363,+IBRSFN,0),"^",4),0) < . W !,"The adjustment you entered may have included a < . W !,"fee. If that is the case, please record the a < . W !,"used in the adjustment calculation above." < . S DIE="^IBE(363,",DA=+IBRSFN,DR="1.01;1.02" D ^DIE < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCREF.m ./VADemo/r2/r/IBCREF.m ;;2.0;INTEGRATED BILLING;**52,106,138,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106,138**;21-MAR-94 ADDCI(CS,ITEM,EFDT,CHG,RVCD,MOD,INAC,BASE) ; adds new ch | ADDCI(CS,ITEM,EFDT,CHG,RVCD,MOD,INAC) ; adds new charge ite S IBCI=+Y D EDITCI(IBCI,$G(CHG),$G(RVCD),$G(MOD),$G(I | S IBCI=+Y D EDITCI(IBCI,$G(CHG),$G(RVCD),$G(MOD),$G(I EDITCI(CI,CHG,RVCD,MOD,INAC,BASE) ; edit certain fields | EDITCI(CI,CHG,RVCD,MOD,INAC) ; edit certain fields of a ch S:$G(INAC)'="" DR=".04////"_INAC_";" S:$G(CHG)'="" DR | S:$G(INAC)'="" DR=".04////"_INAC_";" S:$G(CHG)'="" DR diff -y --suppress-common-lines ./VADemo/r1/IBCRHBR3.m ./VADemo/r2/r/IBCRHBR3.m ;;2.0;INTEGRATED BILLING;**106,138,148,169**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**106,138,148**;21-MAR-94 S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'? | S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'? S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'? | S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'? S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'? | S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'? S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'? | S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'? I IBXRF1="IBCR RC SITE" S ^XTMP(IBXRF1,"VERSION")=$G( | I IBXRF1="IBCR RC SITE" S ^XTMP(IBXRF1,"VERSION")=$G( diff -y --suppress-common-lines ./VADemo/r1/IBCRHBR5.m ./VADemo/r2/r/IBCRHBR5.m ;;2.0;INTEGRATED BILLING;**106,138,148,169**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**106,138,148**;21-MAR-94 D LAB^IBCRHBRB ; move selected Lab charges from Physi < diff -y --suppress-common-lines ./VADemo/r1/IBCRHBR6.m ./VADemo/r2/r/IBCRHBR6.m ;;2.0;INTEGRATED BILLING;**106,138,148,169,245**;21-M | ;;2.0;INTEGRATED BILLING;**106,138,148**;21-MAR-94 INPT(SITE) ; use Inpatient Facility National Rates to ca | INPT(SITE) ; loop through Inpatient Facility national ra OPT(SITE) ; use Outpatient Facility National Rates to c | OPT(SITE) ; loop through Outpatient Facility national r S IBRATE="RC FACILITY PR" | S IBRATE="RC OUTPATIENT FACILITY" PCE(SITE) ; use Physician (General) National Rates to c | PCE(SITE) ; loop through Physician (General) national r S IBRATE="RC PHYSICIAN PR" | S IBRATE="RC PHYSICIAN" S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W: | S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W: PCF(SITE) ; use Physician (Path & Anesthesia) National | PCF(SITE) ; loop through Physician (Path & Anesthesia) S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W: | S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W: PCG(SITE) ; use Physician (Total RVU) National Rates to | PCG(SITE) ; loop through Physician (Total RVU) national > ; > ; S ^XTMP(IBXRF1,IBXRF2,IBK)=ITEM_U_$$DATE(EFFDT)_U_$$E | S ^XTMP(IBXRF1,IBXRF2,IBK)=ITEM_U_$$DATE(EFFDT)_U_$$D I '$G(IBCGP) W !," *** Fatal Error: ",$G(TXT),!,? | I '$G(IBCGP) W !," *** Error: ",$G(TXT),!,?16,"co > ERROR ; > W !!,?5,"A fatal Error was found, can not continue ca > Q > ; ENDDT(X) ; return yyyymmdd date in FM format, check ve < N Y,V S Y=$$DATE($G(X)) I 'Y S V=$G(^XTMP("IBCR RC SI < Q Y < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCRHBRA.m ./VADemo/r2/r/IBCRHBRA.m ;;2.0;INTEGRATED BILLING;**138,169**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**138**;21-MAR-94 N IBI,IBLN,IBOLD,IBNEW,IBITM,IBCI,IBCIN,IBCS,IBCSN,IB | N IBI,IBLN,IBOLD,IBNEW,IBITM,IBCI,IBCIN,IBCS,IBCSN,IB S IBENDDT=$$VERSEDT^IBCRHBRV(1) < .. I $$ADDCI^IBCREF(IBCS,IBNEW,IB2000DT,$P(IBCIN,U,5) | .. I $$ADDCI^IBCREF(IBCS,IBNEW,IB2000DT,$P(IBCIN,U,5) Only in ./VADemo/r1/: IBCRHBRB.m diff -y --suppress-common-lines ./VADemo/r1/IBCRHBR.m ./VADemo/r2/r/IBCRHBR.m ;;2.0;INTEGRATED BILLING;**106,138,148,245**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**106,138,148**;21-MAR-94 I IBLOAD=1 S IBVERS=$$SELVERS^IBCRHBRV Q:'IBVERS | I IBLOAD=1 S IBVERS=$$SELVERS^IBCRHBRV Q:'IBVERS S I ; < I ($G(IBVERS)>1.9)!($$VERSION^IBCRHBRV>1.9) G ^IBCRHB < ; < I IBLOAD=1 S IBLOAD=$$HOSTLOAD^IBCRHBR1(IBVERS) I 'IB < ; IBCR RC site: item ptr ^ effective date ^ inactive | ; IBCR RC site: item ptr ^ effective date ^ inactive diff -y --suppress-common-lines ./VADemo/r1/IBCRHBRV.m ./VADemo/r2/r/IBCRHBRV.m ;;2.0;INTEGRATED BILLING;**148,169,245,270**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**148**;21-MAR-94 S DIR("?")="Enter a code from the list corresponding | S DIR(0)="SO^1:Reasonable Charges version 1;1.1:Reaso S DIR(0)="SO^1:Reasonable Charges version 1.0;1.1:Rea | D ^DIR K DIR S IBX=$S(Y=1:1,Y=1.1:1.1,Y=1.2:1.2,1:0) D ^DIR K DIR S IBX=$S(Y=1:1,Y=1.1:1.1,Y=1.2:1.2,Y=1.4 < N IBX S:'$G(VERS) VERS=$$VERSION S IBX=$S(VERS=1:2990 | N IBX S:'$G(VERS) VERS=$$VERSION S IBX=$S(VERS=1.1:30 Q IBX < ; < VERSEDT(VERS) ; return Inactive Date of a version of RC fil < N IBX S:'$G(VERS) VERS=$$VERSION S IBX=$S(VERS=1:3001 < N IBX S IBX="1;2990901^1.1;3001102^1.2;3010508^1.4;30 | N IBX S IBX="1;2990901^1.1;3001102^1.2;3010508" Q IBX < ; < VERSEND() ; returns all Reasonable Charges versions and < N IBX S IBX="1;3001101^1.1;3010507^1.2;3030428^1.4;30 < N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY S IB | N IBCS,IBXRF,IBITM,IBVERS,IBI,IBV,IBX S IBX="" S IBVERS=$$VERSALL,IBITM=99201 | S IBCS="RC-PHYSICIAN "_$G(SITE),IBCS=$O(^IBE(363.1,"B ; | S IBVERS=$$VERSALL I $G(SITE)'="" S IBCS="RC-PHYSICIAN" F S IBCS=$O(^IB | F IBI=1:1 S IBV=$P(IBVERS,U,IBI) Q:'IBV I $O(^IBA(36 . S IBV=$L(IBCS," ") I $P(IBCS," ",IBV)'=SITE Q < . S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN S IB < . F IBI=1:1 S IBV=$P(IBVERS,U,IBI) Q:'IBV I $O(^IBA( < S IBV="" F S IBV=$O(IBY(IBV)) Q:'IBV S IBX=IBX_IBV_ < ; < > ; N IBVERS,IBVDTC,IBVERSIN,IBVERSO Q:'$G(SITE) | N IBCS,IBXRF,IBITM,IBVERS,IBVDTC,IBVERSO,IBVDTO Q:'$G > S IBCS="RC-PHYSICIAN "_SITE,IBCS=$O(^IBE(363.1,"B",IB > S IBXRF="AIVDTS"_IBCS,IBITM=99201 S IBVERS=$$VERSION Q:'IBVERS S IBVDTC=$$VERSDT,IBVER | S IBVERS=$$VERSION,IBVDTC=$$VERSDT Q:'IBVERS I IBVERSIN[(","_IBVERS_",") D | I $O(^IBA(363.2,IBXRF,IBITM,-IBVDTC,0)) D F IBVERSO=1,1.1,1.2,1.4,2,2.1 I IBVERSO>IBVERS D | F IBVERSO=1,1.1,1.2 I IBVERSO>IBVERS D . I IBVERSIN[(","_IBVERSO_",") D | . S IBVDTO=$$VERSDT(IBVERSO) I $O(^IBA(363.2,IBXRF,IB F IBVERSO=2.1,2,1.4,1.2,1.1,1 I IBVERS>IBVERSO D Q | F IBVERSO=1.2,1.1,1 I IBVERS>IBVERSO D Q . I IBVERSIN'[(","_IBVERSO_",") D | . S IBVDTO=$$VERSDT(IBVERSO) I '$O(^IBA(363.2,IBXRF,I > ; I $G(VERS)=1.4 G FDREAL < I $G(VERS)=2 G FEREAL < I $G(VERS)=2.1 G FFREAL < ; < ; < FDREAL S IBFILES("IBRC0304A.TXT")="RC v1.4 Inpatient Facilit < S IBFILES("IBRC0304B.TXT")="RC v1.4 Inpatient Facilit < S IBFILES("IBRC0304C.TXT")="RC v1.4 Outpatient Facili < S IBFILES("IBRC0304D.TXT")="RC v1.4 Outpatient Facili < S IBFILES("IBRC0304E.TXT")="RC v1.4 Physician Charges < S IBFILES("IBRC0304F.TXT")="RC v1.4 Physician Charges < S IBFILES("IBRC0304G.TXT")="RC v1.4 Physician Charges < S IBFILES("IBRC0304H.TXT")="RC v1.4 Physician Area Fa < S IBFILES("IBRC0304I.TXT")="RC v1.4 Physician Unit Ar < Q < ; < FEREAL S IBFILES("IBRC0312A.TXT")="RC v2.0 Inpatient Facilit < S IBFILES("IBRC0312B.TXT")="RC v2.0 Outpatient Facili < S IBFILES("IBRC0312C.TXT")="RC v2.0 Professional Char < S IBFILES("IBRC0312D.TXT")="RC v2.0 Service Category < S IBFILES("IBRC0312E.TXT")="RC v2.0 Area Factors^E^41 < S IBFILES("IBRC0312F.TXT")="RC v2.0 VA Sites and Zip < Q < ; < FFREAL S IBFILES("IBRC0404A.TXT")="RC v2.1 Inpatient Facilit < S IBFILES("IBRC0404B.TXT")="RC v2.1 Outpatient Facili < S IBFILES("IBRC0404C.TXT")="RC v2.1 Professional Char < S IBFILES("IBRC0404D.TXT")="RC v2.1 Service Category < S IBFILES("IBRC0404E.TXT")="RC v2.1 Area Factors^E^41 < S IBFILES("IBRC0404F.TXT")="RC v2.1 VA Sites and Zip < Q < Only in ./VADemo/r1/: IBCRHBS1.m Only in ./VADemo/r1/: IBCRHBS2.m Only in ./VADemo/r1/: IBCRHBS3.m Only in ./VADemo/r1/: IBCRHBS4.m Only in ./VADemo/r1/: IBCRHBS5.m Only in ./VADemo/r1/: IBCRHBS6.m Only in ./VADemo/r1/: IBCRHBS7.m Only in ./VADemo/r1/: IBCRHBS8.m Only in ./VADemo/r1/: IBCRHBS.m Only in ./VADemo/r1/: IBCRHBSZ.m diff -y --suppress-common-lines ./VADemo/r1/IBCRHL.m ./VADemo/r2/r/IBCRHL.m IBCRHL ;ALB/ARH - RATES: UPLOAD CHECK & ADD TO CM SEARCH ; 2 | IBCRHL ;ALB/ARH - RATES: UPLOAD CHECK & ADD TO CM SEARCH; 22 ;;2.0;INTEGRATED BILLING;**52,106,138,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106,138**;21-MAR-94 .. S IBCI=$$FINDCI^IBCRU4(IBCS,IBITM,$P(IBLN,U,2),$P( | .. S IBCI=$$FINDCI^IBCRU4(IBCS,IBITM,$P(IBLN,U,2),$P( .. I $$ADDCI^IBCREF(IBCS,IBITM,$P(IBLN,U,2),+$P(IBLN, | .. I $$ADDCI^IBCREF(IBCS,IBITM,$P(IBLN,U,2),+$P(IBLN, diff -y --suppress-common-lines ./VADemo/r1/IBCRHU1.m ./VADemo/r2/r/IBCRHU1.m ;;2.0;INTEGRATED BILLING;**52,106,138,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106,138**;21-MAR-94 ; check on same charge but different date removed so < I $$FINDCI^IBCRU4(CS,IBITEM,$P(IBLN,U,2),$P(IBLN,U,5) | I $$FINDCI^IBCRU4(CS,IBITEM,$P(IBLN,U,2),$P(IBLN,U,5) ; do not have to check if NDC is in source, since it | ;do not have to check if NDC is in source, since it i ; check on cpt-modifier pair removed with RC v2.0, ch < ;I +$G(BI)=2,+$P(IBLN,U,5),+$$MODP^ICPTMOD(+IBITEM,+$ | I +$G(BI)=2,+$P(IBLN,U,5),+$$MODP^ICPTMOD(+IBITEM,+$P diff -y --suppress-common-lines ./VADemo/r1/IBCRHU2.m ./VADemo/r2/r/IBCRHU2.m ;;2.0;INTEGRATED BILLING;**106,138,245,175**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**106,138**;21-MAR-94 RG(NAME,DIV,ID,TY) ; add a new Billing Region for Reason | RG(NAME,DIV,ID) ; add a new Billing Region for Reasonable Cha I $G(ID)'="" S DIC("DR")=".02////"_$E(ID,1,10)_";" | I $G(ID)'="" S DIC("DR")=".02////"_$E(ID,1,10) I $G(TY)'="" S DIC("DR")=DIC("DR")_".03////"_$E(TY,1, < S IBFND=+$O(^IBE(363.1,"B",$E(NAME,1,30),0)) I +IBFND | S IBFND=+$O(^IBE(363.1,"B",$E(NAME,1,30),0)) I +IBFND > D RS(IBCSN) CSQ I +$G(IBFN),$G(IBCSN)'="" D RS(IBCSN) | CSQ S IBA(1)=" >> "_$E(NAME,1,30)_" Charge Set "_$S('$G( ; < S IBA(1)=" >> "_$E(NAME,1,30)_" Charge Set "_$S('$G( < ; | RS(CSN) ; add new Charge Sets to RC Rate Schedules, input Cha RS(CSN) ; add new RC Charge Sets to Rate Schedules, input Cha | ; finds the RS to add the CS to based on the Billing ; finds the RS to add the CS to based on the effectiv | ; only adds physician to inpt if there was also inpat ; for RC 1.x only adds physician to inpt if there was | N IBCSFN,IBSITE,IBRSN,IBRS,IBRSCS,IBFND,IBI,DINUM,DD, ; Tort Feasor began using Reasonable Charges on 01/07 < N IBCSFN,IBRSN,IBRS,IBRS0,IBRSLST,IBVBEG,IBVEND,IBVER < ; < I $G(CSN)="" Q < S IBAUTO=1 I $P($G(^IBE(363.3,+$P($G(^IBE(363.1,+IBCS | S IBSITE="" F IBI=1:1 S IBSITE=$P(CSN," ",IBI) I IBSI S IBVERS=$$VERSION^IBCRHBRV,IBVBEG=$$VERSDT^IBCRHBRV, | ; S IBI=$L(CSN," "),IBSITE=$P(CSN," ",IBI) | I (CSN["INPT")!(CSN["PHYS")!(CSN["SNF") D ; | . I CSN["PHYS",'$O(^IBE(363.1,"B","RC-INPT ANC "_IBSI I IBVERS<2 D | . F IBRSN="RI-INPT","NF-INPT","WC-INPT" D . I CSN["INPT " S IBRSLST="RI-INPT,NF-INPT,WC-INPT" | .. S IBRS=0 F S IBRS=$O(^IBE(363,"B",IBRSN,IBRS)) Q: . I CSN["SNF " S IBRSLST="RI-INPT,NF-INPT,WC-INPT" | ... S IBFND=1 I $O(^IBE(363,+IBRS,11,"B",+IBCSFN,0)) . I CSN["OPT " S IBRSLST="RI-OPT,NF-OPT,WC-OPT" | ... S IBRSCS=$O(^IBE(363,+IBRS,11,"B",0)) . I CSN["PHYS" S IBRSLST="RI-OPT,NF-OPT,WC-OPT" | ... I +IBRSCS,$P($G(^IBE(363.3,+$P($G(^IBE(363.1,+IBR . I CSN["PHYS",$O(^IBE(363.1,"B","RC-INPT ANC "_IBSIT | ... I CSN'["SNF" S DIC("DR")=".02////"_1 ; | ... S DLAYGO=363,DA(1)=+IBRS,DIC="^IBE(363,"_DA(1)_", I IBVERS'<2 D | ; . I CSN["INPT " S IBRSLST="RI-INPT,NF-INPT,WC-INPT,TF | I (CSN["OPT")!(CSN["PHYS") D . I CSN["SNF " S IBRSLST="RI-SNF,NF-SNF,WC-SNF,TF-SNF | . F IBRSN="RI-OPT","NF-OPT","WC-OPT" D . I CSN["OPT " S IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT | .. S IBRS=0 F S IBRS=$O(^IBE(363,"B",IBRSN,IBRS)) Q: . I CSN[" FS " S IBRSLST="RI-OPT,NF-OPT,WC-OPT,TF-OPT | ... S IBFND=1 I $O(^IBE(363,+IBRS,11,"B",+IBCSFN,0)) I $G(IBRSLST)="" Q | ... S IBRSCS=$O(^IBE(363,+IBRS,11,"B",0)) ; | ... I +IBRSCS,$P($G(^IBE(363.3,+$P($G(^IBE(363.1,+IBR F IBI=1:1 S IBRSN=$P(IBRSLST,",",IBI) Q:IBRSN="" D | ... S DIC("DR")=".02////"_1 . S IBRS=0 F S IBRS=$O(^IBE(363,"B",IBRSN,IBRS)) Q:' | ... S DLAYGO=363,DA(1)=+IBRS,DIC="^IBE(363,"_DA(1)_", .. S IBRS0=$G(^IBE(363,IBRS,0)) < .. I $E(IBRSN,1,3)="TF-",+$P(IBRS0,U,6),$P(IBRS0,U,6) < .. I +$P(IBRS0,U,6),$P(IBRS0,U,6)IBVEND S IB < .. S IBFND=1 I $O(^IBE(363,+IBRS,11,"B",+IBCSFN,0)) Q < .. I +IBAUTO S DIC("DR")=".02////"_1 < .. S DLAYGO=363,DA(1)=+IBRS,DIC="^IBE(363,"_DA(1)_",1 < diff -y --suppress-common-lines ./VADemo/r1/IBCRLG.m ./VADemo/r2/r/IBCRLG.m ;;2.0;INTEGRATED BILLING;**52,115,138,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,115,138**;21-MAR-94 .. S IBX=$P(IBRG0,U,2)_"-"_$P(IBRG0,U,3),IBY=$$SETFLD | .. S IBX=$P(IBRG0,U,2),IBY=$$SETFLD^VALM1(IBX,IBY,"ID diff -y --suppress-common-lines ./VADemo/r1/IBCRLI.m ./VADemo/r2/r/IBCRLI.m ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 ... S IBX=$J($P(IBLN,U,8),8,2),IBY=$$SETFLD^VALM1(IBX < diff -y --suppress-common-lines ./VADemo/r1/IBCROI1.m ./VADemo/r2/r/IBCROI1.m IBCROI1 ;ALB/ARH - RATES: REPORTS CHARGE ITEM (SRCH) ; 11/22/ | IBCROI1 ;ALB/ARH - RATES: REPORTS CHARGE ITEM (SRCH); 11/22/9 ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 ; ^TMP($J,SUB1, SUB2, SUB3, SUB4, CI IFN) = itm ^ cs | ; ^TMP($J,SUB1, SUB2, SUB3, SUB4, CI IFN) = itm ^ cs S IBITEM=$G(^IBA(363.2,+CI,0)) Q:IBITEM="" ;S $P(IBI | S IBITEM=$G(^IBA(363.2,+CI,0)) Q:IBITEM="" S $P(IBIT diff -y --suppress-common-lines ./VADemo/r1/IBCROI.m ./VADemo/r2/r/IBCROI.m ;;2.0;INTEGRATED BILLING;**52,106,121,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106,121**;21-MAR-94 N IBLNX,IBITEM,IBCSN,IBEFDT,IBINDT,IBCHG,IBCHGB,IBRVC | N IBLNX,IBITEM,IBCSN,IBEFDT,IBINDT,IBCHG,IBRVCD I '$D .... S IBCHG=$P(IBLNX,U,5),IBCHGB=$P(IBLNX,U,8) I IBC | .... S IBCHG=$P(IBLNX,U,5) .... I +$P(IBLNX,U,7) S IBITEM=IBITEM_"-"_$P($$MOD^IC | .... I +$P(IBLNX,U,7) S IBITEM=IBITEM_" - "_$P($$MOD^ .... I +IBSORT1=1 W ?(55-IBSP1),$E(IBCSN,1,(27-IBSP2) | .... I +IBSORT1=1 W ?(55-IBSP1),$E(IBCSN,1,(27-IBSP2) .... I +IBSORT1'=1 W ?(55-IBSP1),$J(IBCHG,10,2),IBCHG | .... I +IBSORT1'=1 W ?(55-IBSP1),$J(IBCHG,10,2),?(72- S IBS=$G(^TMP($J,IBSCRPT)),IBSORT1=$P(IBS,U,2),IBSORT | S IBS=$G(^TMP($J,IBSCRPT)),IBSORT1=$P(IBS,U,2),IBSORT I +IBSORT1=1 S IBHDR2=IBHDR2_" "_$E("Charge Set | I +IBSORT1=1 S IBHDR2=IBHDR2_" "_$E("Charge Set I +IBSORT1=2 S IBHDR2=IBHDR2_" Charge Rv | I +IBSORT1=2 S IBHDR2=IBHDR2_" Charge Rv Cd diff -y --suppress-common-lines ./VADemo/r1/IBCRTN.m ./VADemo/r2/r/IBCRTN.m ;;2.0;INTEGRATED BILLING;**51,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51**;21-MAR-94 LOOK N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy | LOOK S DIC="^DGCR(399,",DIC(0)="AEQMZ",DIC("S")="I $S($P(^ S DIC="^DGCR(399,",DIC(0)="AEQMZ",DIC("S")="I $S($P(^ < diff -y --suppress-common-lines ./VADemo/r1/IBCRU1.m ./VADemo/r2/r/IBCRU1.m ;;2.0;INTEGRATED BILLING;**52,106,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 S DIC("A")=$J("",$G(COL))_"Select CPT: " I '$G(ALL) S | S DIC("A")=$J("",$G(COL))_"Select CPT: " I '$G(ALL) S GETDRG(COL,ALL) ; ask and return DRG (80.2): (-1 if ^, 0 if | GETDRG(COL) ; ask and return DRG (80.2): (-1 if ^, 0 if ; ALL: Default is 1 (disable screening) < S DIC("A")=$J("",$G(COL))_"Select DRG: " I '$G(ALL,1) | S DIC("A")=$J("",$G(COL))_"Select DRG: " diff -y --suppress-common-lines ./VADemo/r1/IBCRU2.m ./VADemo/r2/r/IBCRU2.m ;;2.0;INTEGRATED BILLING;**52,106,138,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106,138**;21-MAR-94 I BI=2,NAME'="" S IBX=$$CPTIEN^IBACSV(NAME) | I BI=2,NAME'="" S IBX=+$$CPT^ICPTCOD(NAME,DT) I IBX<1 I BI=4,NAME'="" S IBX=$$DRGIEN^IBACSV(NAME) | I BI=4,NAME'="" S IBX=$O(^ICD("B",NAME,0)) I BI=2,+ITEM,$$CPTACT^IBACSV(ITEM,EFFDT) S IBX=ITEM | I BI=2,+ITEM S IBY=$$CPT^ICPTCOD(ITEM,DT) I +$P(IBY,U I BI=4,+ITEM,$$DRGACT^IBACSV(ITEM,EFFDT) S IBX=ITEM | I BI=4,+ITEM S IBY=$G(^ICD(ITEM,0)) I IBY'="" S IBX=I diff -y --suppress-common-lines ./VADemo/r1/IBCRU3.m ./VADemo/r2/r/IBCRU3.m IBCRU3 ;ALB/ARH - RATES: UTILITIES (CS/BR) ;22-MAY-1996 | IBCRU3 ;ALB/ARH - RATES: UTILITIES (CS/BR) ; 22-MAY-1996 ;;2.0;INTEGRATED BILLING;**52,106,223**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 ; < EVNTITM(RT,BT,BE,EFDT,ARR) ; return the billable item (3 < ; EFDT may be passed as 'begin dt^end dt' to get CSs < ; returns: string of billing items (code;name;quanti < ; for VA Cost, code = 'VA COST' so returns < ; output (if ARR passed by reference): ARR(billable < N IBRS,IBCS,IBRSARR,IBCS0,IBBR0,IBBI,IBFND K ARR S IB < ; < I $G(BE)'="" D RT(+$G(RT),+$G(BT),$G(EFDT),.IBRSARR,$ < ; < S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D < . S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS < .. S IBCS0=$G(^IBE(363.1,IBCS,0)),IBBR0=$G(^IBE(363.3 < .. S IBBI=$P(IBBR0,U,4) I IBBI="",$P(IBBR0,U,5)=2 S I < .. I IBBI'="" S IBFND=IBFND_IBBI_";"_$$EXPAND^IBCRU1( < Q IBFND < diff -y --suppress-common-lines ./VADemo/r1/IBCRU4.m ./VADemo/r2/r/IBCRU4.m ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94 FINDCI(CS,ITEM,EFDT,MOD,RVCD,CHG,INAC,ARR,BASE) ; find charge | FINDCI(CS,ITEM,EFDT,MOD,RVCD,CHG,INAC,ARR) ; find charge . I $D(BASE),+BASE'=+$P(IBLN,U,8) Q < ; < ITMUNIT(ITM,UNIT,CT) ; return true if the Item has the req < ; Input: ITM - pointer to Item Code < ; UNIT - Number of type of unit, or Charge Met < ; CT - Charge Type (optional) 1 for Inst, 2 < ; < N IBFND,IBCS,IBCSN S IBFND=0 S ITM=+$G(ITM),UNIT=+$G( < ; < I +ITM,+UNIT S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) < . S IBCSN=$G(^IBE(363.1,IBCS,0)) < . ; < . I +$G(CT),+$P(IBCSN,U,4),$P(IBCSN,U,4)'=CT Q < . I +$P($G(^IBE(363.3,+$P(IBCSN,U,2),0)),U,5)'=UNIT Q < . ; < . I $O(^IBA(363.2,"AIVDTS"_IBCS,+ITM,"")) S IBFND=1 < ; < Q IBFND < Only in ./VADemo/r1/: IBCRU8.m diff -y --suppress-common-lines ./VADemo/r1/IBCSC3.m ./VADemo/r2/r/IBCSC3.m ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232** | ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137**;21- EN N IB,IBX,IBINS,Y,Z | EN I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL < . W ?45,"Transmit: " S Z=0,X=$$TXMT^IBCEF4(IBIFN,.Z) | . W ?46,"Transmit: " S Z=0,X=$$TXMT^IBCEF4(IBIFN,.Z) . W $S(X:"Yes",1:"No-"_$S(Z=1:"Forced to print local" | . W $S(X:"Yes",1:"No-"_$S(Z=1:"Forced to print local" diff -y --suppress-common-lines ./VADemo/r1/IBCSC4A.m ./VADemo/r2/r/IBCSC4A.m ;;2.0;INTEGRATED BILLING;**106,228**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94 PRO S IBNC="NO PRO CODES ENTERED FOR THIS DATE",IBOPC=0 K | PRO S IBNC="NO PRO CODES ENTERED FOR THIS DATE",IBOPC=0 K D PTFPS(DFN,IBPTF,+IB("U"),$P(IB("U"),"^",2)) < ODDP S X=^UTILITY($J,"IB",IBP,1),IBWO(0)=$P(X,U,3)_U_$P(X, | ODDP S X=^UTILITY($J,"IB",IBP,1),IBWO(0)=$P(X,U,3)_U_$P(X, EVENP S X=^UTILITY($J,"IB",IBP,1),IBWE(0)=$P(X,U,3)_U_$P(X, | EVENP S X=^UTILITY($J,"IB",IBP,1),IBWE(0)=$P(X,U,3)_U_$P(X, ; < PTFPS(DFN,IBPTF,IBFDT,IBTDT) ; this will return a list of < ; services from the ptf records. If no date range sp < ; it will return all services for that ptf entry. < ; return: ^utility($j,"IB",count for event,count fo < ; pices: 1 = procedure < ; 2 = date (only if new date) < ; 3 = sequentual grouping letter (on < ; 4 = "+" to flag as CPT 4 procedure < ; 5 = if exemption applicable, info < ; 6-9 = assoc dx in order < ; 10 = quantity < ; 11-12 = modifiers < ; 13 = provider < ; 14 = location < ; < ; the exemption information returned will be first ev < ; dx level and if nothing there to exempt, it will be < ; level. < ; < N IBX,IBY,IBDT,IBXX,IBP,IBC,IBRMARK,IBDX,IBDXX,IBPP,I < K ^TMP("PTF",$J),^TMP("IBPTFPS",$J) < S IBFDT=$G(IBFDT),IBTDT=$G(IBTDT,9999999)_".99999" < ; < ; get starting place for ^utility global < S IBC=+$O(^UTILITY($J,"IB",":"),-1) < ; < D PTFINFOR^DGAPI(DFN,IBPTF) I '$D(^TMP("PTF",$J)) G P < ; < S IBX=0 F S IBX=$O(^TMP("PTF",$J,IBX)) Q:IBX<1 S IB < I '$D(^TMP("IBPTFPS",$J)) G PTFPSQ < ; < K ^TMP("PTF",$J) < D ICDINFO^DGAPI(DFN,IBPTF) ;get the dx's for the ptf < ; < S IBDT=0 F S:'IBC!($D(^UTILITY($J,"IB",IBC))) IBC=IB < . ; < . S IBD=0 < . D CPTINFO^DGAPI(DFN,,IBDT) I '$D(^TMP("PTF",$J,46)) < . S IB46=$P($G(^TMP("PTF",$J,46,0)),"^",2)_"^"_$P($G( < . ; < . S IBX=0 F S IBX=$O(^TMP("PTF",$J,46,IBX)) Q:IBX<1 < .. S IBRMARK="" < .. F IBP=5:1:8,16:1:19 S IBDX=$P(IBY,"^",IBP),IBDXX=0 < ... F IBPP=3:1:9 I $P(^TMP("PTF",$J,46.1,IBDXX),"^",I < .. S IBD=IBD+1,^UTILITY($J,"IB",IBC,IBD)=$P(IBY,"^",2 < . S IBD=0 < . K ^TMP("PTF",$J,46) < ; < ; < PTFPSQ K ^TMP("PTF",$J),^TMP("IBPTFPS",$J),^TMP("CPT",$J) < Q < ; < EXEMPT ; exemption reasons < ;;SC < ;;AO < ;;IR < ;;EC < ;;MT < ;;HC < ;;CV < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCSC4B.m ./VADemo/r2/r/IBCSC4B.m IBCSC4B ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 89 9:52 | IBCSC4B ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 89 9:52 ;;2.0;INTEGRATED BILLING;**210,228**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 WR N IBDATE | WR I '$D(IBWE(0)) F B=0:1:5 S IBWE(B)="" S IBDATE=$$PTFDATE^IBACSV(+$G(IBPTF)) ; Date to be us < I '$D(IBWE(0)) F B=0:1:5 S IBWE(B)="" < S IBAO=$P(IBWO(0),U,1) I IBAO']"" W:'$D(IBDXY) !,"* " | S IBAO=$P(IBWO(0),U,1) I IBAO']"" W:'$D(IBDXY) !,"* " I IBAO]"" F K=1:1:5 Q:IBWO(K)=""&(IBWE(K)="") D | I IBAO]"" F K=1:1:5 Q:IBWO(K)']""&(IBWE(K)']"") S X= . W ! < . I IBWO(K) S X=$S($P(IBWO(0),"^",3)["+":$$CPT^IBACSV < .. W IBAO,K," - ",$S(X]"":$J($P(X,U),6)_" "_$E($S($P < . I IBDIA'="" D WE < WE S IBAE=$P(IBWE(0),U) | WE S IBAE=$P(IBWE(0),U,1) I IBAE']"",'$D(IBDXX),IBWE(0)] I IBAE="",'$D(IBDXX),IBWE(0)]"" W ?43,"* ",IBNC S (IB | I IBAE]"",IBWE(K)]"" S X=$S($D(^ICD9((+IBWE(K)),0)):^ I IBAE]"",IBWE(K)]"" S X=$S($P(IBWE(0),"^",3)["+":$$C < . W ?43,IBAE,K," - ",$S(X]"":$J($P(X,U),6)_" "_$E($S < PRO Q:'$D(IBPTF) D TYPE S IBUC="UNSPECIFIED CODE",IBNC=" | PRO Q:'$D(IBPTF) S IBUC="UNSPECIFIED CODE",IBNC="NO PRO Q K IB3,IB4,IB5,IB6,IB7,IB8,IB9,IBAE,IBAO,IBCT,IBDIA,IB | Q K IB3,IB4,IB5,IB6,IB7,IB8,IB9,IBAE,IBAO,IBCT,IBDIA,IB K %DT,A,B,DIC,F,I,J,K,M,S,X,Y | K %DT,A,B,DIC,F,I,J,K,M,S,X,Y Q Q | WRP I '$D(IBWE(0)) F B=0:1:5 S IBWE(B)="" WRP N IBDATE | W !!,$S($P(IBWO(0),U,3)["*":IBNOR,1:IBSD) S Y=$P(IBWO S IBDATE=$$PTFDATE^IBACSV(+$G(IBPTF)) ; Date to be us < I '$D(IBWE(0)) F B=0:1:5 S IBWE(B)="" < W !!,$S($P(IBWO(0),U,3)["*":IBNOR,$P(IBWO(0),U,3)["+" < I IBAO]"" F K=1:1:5 Q:IBWO(K)']""&(IBWE(K)']"") D | I IBAO]"" F K=1:1:5 Q:IBWO(K)']""&(IBWE(K)']"") S X= . S X=$S($P(IBWO(0),U,3)["+":$$CPT^IBACSV(+IBWO(K),IB < .. W:IBWO(K)]"" !,IBAO,K,"-",$S(X]"":$J($P(X,U,1),5)_ < I IBAE]"",IBWE(K)]"" S X=$S($P(IBWE(0),"^",3)["+":$$C | I IBAE]"",IBWE(K)]"" S X=$S($D(^ICD0((+IBWE(K)),0)):^ . W ?43,IBAE,K,"-",$S(X]"":$J($P(X,U,1),5)_$S($L($P(I < Q < ; < TYPE ; cleans up the ^utility based on the type of coding < ; save in ^tmp < N IBA,IBB,IBC,IBD,IBE < I '$D(^TMP("IBTYPE",$J)) M ^TMP("IBTYPE",$J)=^UTILITY < K ^UTILITY($J,"IB") < S (IBA,IBB)=0 F S IBA=$O(^TMP("IBTYPE",$J,IBA)) Q:IB < . I $P($G(^TMP("IBTYPE",$J,IBA,1)),"^",4)["+",IBPROT= < .. S IBB=IBB+1,(IBC,IBD)=0 F S IBC=$O(^TMP("IBTYPE", < . I $P($G(^TMP("IBTYPE",$J,IBA,1)),"^",4)["+" Q < . I IBPROT'=5 S IBB=IBB+1,(IBC,IBD)=0 F S IBC=$O(^TM < .. S IBE=^TMP("IBTYPE",$J,IBA,IBC),IBD=IBD+1,^UTILITY < diff -y --suppress-common-lines ./VADemo/r1/IBCSC4C.m ./VADemo/r2/r/IBCSC4C.m IBCSC4C ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43 | IBCSC4C ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43 ;;2.0;INTEGRATED BILLING;**210,266**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 N IBZ,IBQ | F I=1:1:3 W !,"ICD PROCEDURE CODE (",I,"): " S IBPX=$ S IBQ=0 ; Quit flag < F I=1:1:3 W !,"ICD PROCEDURE CODE (",I,"): " D Q:IBQ < . S IBPX=$P(IB("C"),U,(I+3)) < . I IBPX S IBZ=$$ICD0^IBACSV(+IBPX) W $S(IBZ'="":$J($ < . R X:DTIME I '$T!(X["^") S IBQ=1 Q < . D CHP < . I $D(IB3) D PD < . D S < ; < ; Select Diagnosis codes < N IBZ,IBQ | F I=1:1:5 W !,"DIAGNOSIS CODE (",I,"): " S IBPY=$S($P S IBQ=0 < F I=1:1:5 W !,"DIAGNOSIS CODE (",I,"): " D Q:IBQ < . S IBPY=$P(IB("C"),U,(I+13)) < . I IBPY S IBZ=$$ICD9^IBACSV(+IBPY) W $S(IBZ'="":$J($ < . R X:DTIME I '$T!(X["^")!((X="")&(IBPY="")) S IBQ=1 < . D CHD,S < CHP N IBDATE,ICDVDT | CHP I X="?" D 3^IBCSCH1 S I=I-1 Q I X="?" D 3^IBCSCH1 S I=I-1 Q < S:X["?" X="??" | S:X["?" X="??" S IBI=I,DIC="^ICD0(" D DIC I Y'>0 S I= S IBI=I < S IBDATE=$P(^DGCR(399,IBIFN,"C"),U,I+10) < I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN) < S ICDVDT=IBDATE ; for DD identifier (date of service) < S DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(I < S DIC="^ICD0(" D DIC I Y'>0 S I=IBI-1 Q < ; | CHD I X="?" D 3^IBCSCH1 S I=I-1 Q CHD N IBDATE,ICDVDT < I X="?" D 3^IBCSCH1 S I=I-1 Q < S:X["?" X="??" | S:X["?" X="??" S IBI=I,DIC="^ICD9(" D DIC I Y'>0 S I= S IBI=I < S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service < S ICDVDT=IBDATE ; For the DD identifier < S DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(I < S DIC="^ICD9(" D DIC I Y'>0 S I=IBI-1 Q < ; | DT S $P(^DGCR(399,IBIFN,"C"),U,(I+10))=$S($P(IB5,U,2)]"" ; Check the sex of procedure and the patients | PAR W:X'["?" " ??" W !?7,"You may only choose codes foun SEXSCR(IBZ,DFN) ; | DIC S DIC(0)="EMQ",DIC("S")="I $S($P(^(0),U,9):0,$P(^(0), N IBCODSEX,IBPTSEX < S IBCODSEX=$P(IBZ,U,10) ; Sex of the ICD0/ICD9 code, < I IBCODSEX'="M",IBCODSEX'="F" Q 1 ; No assigned sex < I '$G(DFN) Q 1 < S IBPTSEX=$E($P($G(^DPT(+DFN,0)),U,2)) ; Patient's se < I IBPTSEX'="M",IBPTSEX'="F" S IBPTSEX="M" ; Male is d < Q IBPTSEX=IBCODSEX < ; < DT S $P(^DGCR(399,IBIFN,"C"),U,(I+10))=$S($P(IB5,U,2)]"" < Q < PAR W:X'["?" " ??" W !?7,"You may only choose codes foun < Q < DIC S DIC(0)="EMQ" D ^DIC < Q < Q < diff -y --suppress-common-lines ./VADemo/r1/IBCSC4D.m ./VADemo/r2/r/IBCSC4D.m ;;2.0;INTEGRATED BILLING;**55,62,91,106,124,51,210**; | ;;2.0;INTEGRATED BILLING;**55,62,91,106,124,51**;21-M N X,Y,IBDATE,IBDTTX | N X,Y S IBDATE=$$BDATE^IBACSV(IBIFN) < S IBDTTX=$$DAT1^IBOUTL(IBDATE) < AD S DIR("??")="^D HELP^IBCSC4D" | AD S DIR("??")="^D HELP^IBCSC4D",DIR("?",1)="Enter a dia S DIR("?",1)="Enter a diagnosis for this bill. Dupli < S DIR("?")="Only diagnosis codes active on "_IBDTTX_" < D ^DIR K DIR | D ^DIR K DIR I Y>0,'$D(IBDXA(+Y)),+$P($G(^ICD9(+Y,0)) I Y>0,'$D(IBDXA(+Y)),'$$ICD9ACT^IBACSV(+Y,IBDATE) D < . W !!,*7,"The Diagnosis code is inactive for the dat < N IBX,IBY,IBZ,IBDATE | N IBX,IBY,IBZ S IBDATE=$$BDATE^IBACSV(+$G(IBIFN)) ; The bill date o < S IBX=0 F S IBX=$O(POARR(IBX)) Q:'IBX S IBZ=POARR(I | S IBX=0 F S IBX=$O(POARR(IBX)) Q:'IBX S IBZ=POARR(I . W !,?12,$P(IBY,U),?26,$P(IBY,U,3),?60,$S($P(IBZ,U,2 | . W !,?12,$P(IBY,U,1),?26,$P(IBY,U,3),?60,$S($P(IBZ,U N IBCNT,IBDX,IBX,IBY,IBDATE | N IBCNT,IBDX,IBX,IBY W @IOF,!,"===================== W @IOF,!,"============================= DIAGNOSIS SCR < S IBDATE=$$BDATE^IBACSV(+$G(IBIFN)) ; The bills date < . S IBY=OEARR(IBCNT),IBDX=$$ICD9^IBACSV(+IBY,IBDATE) | . S IBY=OEARR(IBCNT),IBDX=$G(^ICD9(+IBY,0)) . W !,$J(IBCNT,2),")",?5,IBX,?6,$P(IBDX,U),?14,$E($P( | . W !,$J(IBCNT,2),")",?5,IBX,?6,$P(IBDX,U,1),?14,$E($ I +$P(X,U,11) S I=+$G(^IBA(362.3,+$P(X,U,11),0)) W " | I +$P(X,U,11) S I=+$G(^IBA(362.3,+$P(X,U,11),0)) W " diff -y --suppress-common-lines ./VADemo/r1/IBCSC4E.m ./VADemo/r2/r/IBCSC4E.m IBCSC4E ;ALB/ARH - ADD/ENTER PTF/OE DIAGNOSIS ;3/2/94 | IBCSC4E ;ALB/ARH - ADD/ENTER PTF/OE DIAGNOSIS ; 3/2/94 ;;2.0;INTEGRATED BILLING;**8,106,121,124,210,266**;21 | ;;2.0;INTEGRATED BILLING;**8,106,121,124**;21-MAR-94 . I ($$ICD9^IBACSV(+IBDX)'=""),'$D(^IBA(362.3,"AIFN"_ | . I $D(^ICD9(+IBDX,0)),'$D(^IBA(362.3,"AIFN"_IBIFN,+I N IBDX,IBID,IBON,IBY,IBMDRG,X,IBDATE | N IBDX,IBID,IBON,IBY,IBMDRG,X K ^TMP($J,"IBDX") S IBW K ^TMP($J,"IBDX") S IBW=41 < ; < S IBDATE=$$BDATE^IBACSV(IBIFN) ; The Event Date of th < .. S IBDX=^TMP($J,"IBDX",IBN,IBMDT,IBI),IBY=$$ICD9^IB | .. S IBDX=^TMP($J,"IBDX",IBN,IBMDT,IBI),IBY=$G(^ICD9( . I IBMDRG S IBLN=$P($$DRG^IBACSV(+IBMDRG,IBDATE),U,1 | . I +IBMDRG S IBLN=$P($G(^ICD(+IBMDRG,0)),U,1)_" - "_ I IBDSCH,IBTDT ;IBCSC4 Q | DX(ORDER) ; ; | N IBX,IBY S IBX="" I $D(IBPOARR)>2 S ORDER=$O(IBPOARR DX(ORDER,IBDATE) ; Get next diagnosis data < N IBX < S IBX="" < S ORDER=$O(IBPOARR(ORDER)) < I ORDER S IBX=ORDER_U_$$ICD9^IBACSV(+IBPOARR(ORDER),$ < ; < OT ; print Other Care (SNF) multiple < N IBX,IBY,IBN I '$O(^DGCR(399,IBIFN,"OT",0)) W !,?4," < S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"OT",IBX)) Q:'IBX < . S IBY=$G(^DGCR(399,IBIFN,"OT",IBX,0)) Q:'IBY < . S IBN=$P($G(^DGCR(399.1,+IBY,0)),U,1),IBN=$S(IBN["S < . W !,?4,IBN," : ",$$FMTE^XLFDT(+$P(IBY,U,2))," - ", < Q < ; < DXREQ(IBIFN) ; Is the principle diagnosis code required or < ; Function returns true (1) if DX is required for thi < NEW REQ,IBFT < S REQ=0,IBFT=$$FT^IBCEF(IBIFN) < I IBFT=2 S REQ=1 G DXREQX < I IBFT=3,$$WNRBILL^IBEFUNC(IBIFN) S REQ=1 G DXREQX < DXREQX ; < Q REQ < ; < ;IBCSC4 < diff -y --suppress-common-lines ./VADemo/r1/IBCSC5A.m ./VADemo/r2/r/IBCSC5A.m IBCSC5A ;ALB/ARH - ADD/ENTER PRESCRIPTION FILLS ; 12/27/93 | IBCSC5A ;ALB/ARH - ADD/ENTER PRESCRIPTION FILLS ;12/27/93 ;;2.0;INTEGRATED BILLING;**27,52,106,51,160,137,245** | ;;2.0;INTEGRATED BILLING;**27,52,106,51,160,137**;21- N IBX,IBY,IBZ,IBS,IBP,IBIFN | N IBX,IBY,IBZ,IBS,IBIFN . S IBZ=$P($G(^PSDRUG(+$P(RXARR(IBX,IBY),U,2),0)),U,1 | . S IBZ=$P($G(^PSDRUG(+$P(RXARR(IBX,IBY),U,2),0)),U,1 . W !,?5,$E(IBP,1,25),?35,"(Rx Procedure ",$S($P(IBZ, | . W !,?5,"(Rx Procedure ",$S($P(IBZ,U,15):"#"_$P(IBZ, PRVNM(PIFN) ; return provider name for an rx, if one defi < N IBX,IBPRV,IBRXIFN S IBPRV="" < S IBRXIFN=$P($G(^IBA(362.4,+$G(PIFN),0)),U,5) I +IBRX < Q IBPRV < diff -y --suppress-common-lines ./VADemo/r1/IBCSC5.m ./VADemo/r2/r/IBCSC5.m ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288**;21 | ;;2.0;INTEGRATED BILLING;**52,125,51**;21-MAR-94 N IBPOARR,IBDATE | ;S Z=2,IBW=1 X IBWW W " Prin. Diag.: ",$S('$D(^DGCR(3 D SET^IBCSC4D(IBIFN,"",.IBPOARR) | N IBPOARR D SET^IBCSC4D(IBIFN,"",.IBPOARR) S IBDATE=$$BDATE^IBACSV(IBIFN) ; Event date | S Z=2,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX^IBCSC4 S Z=2,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX^IBCSC4 | F I=1:1:4 S Y=$$DX^IBCSC4(+Y) Q:Y="" W !?4,"Other Di F I=1:1:4 S Y=$$DX^IBCSC4(+Y,IBDATE) Q:Y="" W !?4,"O | I +Y S Y=$$DX^IBCSC4(+Y) I +Y W !?4,"***There are mor I +Y S Y=$$DX^IBCSC4(+Y,IBDATE) I +Y W !?4,"***There | ;S Z=2,IBW=1 X IBWW W " Prin. Diag.: ",$S($D(^ICD9(+$ > ;F I=15:1:18 I $P(IB("C"),U,I)]"" W !?4,"Other Diag.: > ;I $D(IBCPT),$P(IB(0),U,9)=4 F I=1:1:3 I $D(IBCPT(I)) > ;I $D(IBICD),$P(IB(0),U,9)=9 F I=4:1:6 I $D(IBICD(I)) > ;I $D(IBHC),$P(IB(0),U,9)=5 F I=7:1:9 I $D(IBHC(I)) W MORE W !?4,*7,"***There are more procedures associated wit | MORE W !?4,*7,"***There are more procedures associated wit Q < N IBDATE < .S IBDATE=$P(IBPROC(J),U,2) I 'IBDATE S IBDATE=$$BDAT | .S X=$$PRCD^IBCEF1($P(IBPROC(J),U),1) .S X=$$PRCD^IBCEF1($P(IBPROC(J),U),1,IBDATE) < .I $P(IB(0),U,19)=2 S Y=+$P(IBPROC(J),U,11) S:+Y Y=+$ | .I $P(IB(0),U,19)=2 S Y=+$P(IBPROC(J),U,11) S:+Y Y=+$ diff -y --suppress-common-lines ./VADemo/r1/IBCSC61.m ./VADemo/r2/r/IBCSC61.m ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230**;21- | ;;2.0;INTEGRATED BILLING;**52,80,106,51**;21-MAR-94 I $P(IBREVC(I),"^",6) S DGRCD=DGRCD_$J("",21-$L(DGRCD | I $P(IBREVC(I),"^",6) S DGRCD=DGRCD_$J("",21-$L(DGRCD I '$P(IBREVC(I),U,6),$P(IBREVC,U,11) S DGRCD=DGRCD_$J | I '$P(IBREVC(I),U,6),$P(IBREVC,U,11) S DGRCD=DGRCD_$J I IB("U1")]"" S X=$P(IB("U1"),"^",1),X1=$P(IB("U1")," | I IB("U1")]"" S X=$P(IB("U1"),"^",1),X1=$P(IB("U1")," I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($$DRG^IBACSV(+ITEM | I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($G(^ICD(+ITEM,0)), diff -y --suppress-common-lines ./VADemo/r1/IBCSC82.m ./VADemo/r2/r/IBCSC82.m ;;2.0;INTEGRATED BILLING;**51,137,210,232,155**;21-MA | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 N I,IB,IBX,Z < N IBZ,IBPRV,IBREQ,IBMRASEC | N IBZ,IBPRV W !,?3," Admitting Dx : " S IBX=$$ICD9^IBACSV(+I | W !,?3," Admitting Dx : " S IBX=$P(IB("U2"),U,1) . N Z,IBT,IBQ,IBARR | . N Z,IBT,IBQ . D DEFSEC^IBCEF74(IBIFN,.IBARR) < .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E( | .. I $P($G(IB("PRV",IBZ,1)),U,3) F Z=1:1:3 D > ... I Z=1,$G(IB("PRV",IBZ,1,1))="",$P($G(IB("PRV",IBZ > ... I $G(^DGCR(399,IBIFN,"I"_Z))'="" D > .... N IBID > .... S IBID=$S($G(IB("PRV",IBZ,1,Z))'="":IB("PRV",IBZ > .... S IBQ=IBQ_$S(IBID'="":" ["_$E("PST",Z)_"]"_IBID, S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1 | S Z=6,IBW=1 X IBWW W " Force To Print? : " S IBZ=$$ S IBMRASEC=$$MRASEC^IBCEF4(IBIFN) < S Z=6,IBW=1 X IBWW W " ",$S('IBREQ:"Force To Print? < S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8 < I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ=" < W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT < S Z=8,IBW=1 X IBWW < W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(3 < W $S(IBZ'="":IBZ,$$PSRV^IBCEU(IBIFN):IBU,1:IBUN) < diff -y --suppress-common-lines ./VADemo/r1/IBCSC8H.m ./VADemo/r2/r/IBCSC8H.m ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155**;2 | ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 ; HCFA 1500 screen 8 | ;HCFA 1500 screen 8 ; MAP TO DGCRSC8H | ;MAP TO DGCRSC8H EN N I,IB,Y,Z | EN D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="0000000" S:IBV IBV D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="0000000" S:IBV IBV | N IBZ,IBPRV N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC < S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for < S Z=2,IBW=1 X IBWW W " Admitting Dx : " S IBZ=$ | S Z=2,IBW=1 X IBWW W " Admitting Dx : " S IBZ=$ . N IBQ,A,A1,IBARR | . N IBQ,A,A1 . D DEFSEC^IBCEF74(IBIFN,.IBARR) < .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E( | .. I $P($G(IB("PRV",IBZ,1)),U,3) F Z=1:1:3 D > ... I Z=1,$G(IB("PRV",IBZ,1,1))="",$P($G(IB("PRV",IBZ > ... I $G(^DGCR(399,IBIFN,"I"_Z))'="" D > .... N IBID > .... S IBID=$S($G(IB("PRV",IBZ,1,Z))'="":IB("PRV",IBZ > .... S IBQ=IBQ_$S(IBID'="":" ["_$E("PST",Z)_"]"_IBID, W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(3 | W " Non-VA Facility : " S IBZ=$$EXPAND^IBTRE(399,2 W !,?4,"Lab CLIA # : ",$S($P(IB("U2"),U,13)=" < S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1 | W !,?4,"Force To Print? : " S IBZ=$$EXTERNAL^DILFD S IBMRASEC=$$MRASEC^IBCEF4(IBIFN) < W !,?4,$S('IBREQ:"Force To Print? : ",1:"Force MRA < S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8 < I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ=" < W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT < ; < WRT1(IBCRED) ; Write credentials mismatch < W !,*7," **Warning** Credentials differ from those f < W !,$J("",14),"Changes will print local, but only cre < Q < ; < NSAME(DA) ; Returns 1 if div on bill is not the default < Q ($P($G(^IBE(350.9,1,0)),U,2)'=$P($G(^DG(40.8,+$P(^D < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCSCE.m ./VADemo/r2/r/IBCSCE.m ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,24 | ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137**;21-M TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB | TMPL S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^D S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^D < I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^ < ;Edit patient's address using DGREGAED API < EDADDR(IBDFN) ; < I $G(IBFLIAE)'=1!(IBDFN=0) Q 0 < N IBFL S IBFL(1)=1 < N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR < D EN^DGREGAED(IBDFN,.IBFL) < Q 1 < diff -y --suppress-common-lines ./VADemo/r1/IBCSCH1.m ./VADemo/r2/r/IBCSCH1.m IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:0 | IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ;01 JUN 88 12:00 ;;2.0;INTEGRATED BILLING;**106,125,51,245,266**;21-MA | ;;2.0;INTEGRATED BILLING;**106,125,51**;21-MAR-94 N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IB | N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IB S IBQ=0 < S IBDATE=$$BDATE^IBACSV(IBIFN) | S IBHDR="W @IOF,!,""Procedures Assigned to this Bill" S IBHDR="W @IOF,!,""Procedures Assigned to this Bill" < ... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,I | ... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,I ... S IBX=$$PRCNM($P(IBLN,U,1),IBD),IBPR=$P(IBX,U,1), | ... S IBX=$$PRCNM($P(IBLN,U,1),+$P(IBLN,U,2)),IBPR=$P ... I +$P(IBLN,U,16) S IBSUS=$P(IBLN,U,16)_"mn" < ... I +$P(IBLN,U,21) S IBSUS=$P(IBLN,U,21)_"ml" < ... I +$P(IBLN,U,22) S IBSUS=$P(IBLN,U,22)_"hr" < ... W !,$E(IBPR,1,6),?7,$E(IBPRD,1,20),?29,IBSUS,?35, | ... W !,$E(IBPR,1,9),?10,$E(IBPRD,1,20),?32,$P(IBLN,U ... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IB | ... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IB ... I IBX'="" F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX, | ... F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX,",",IBMOD) diff -y --suppress-common-lines ./VADemo/r1/IBCSCH.m ./VADemo/r2/r/IBCSCH.m ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,1 | ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,1 N I,C,IBSCNNZ,IBQ,IBPRNT,Z S IBSCNNZ=$$UP^XLFSTR($G(I | N IBSCNNZ,IBQ,IBPRNT S IBSCNNZ=$$UP^XLFSTR($G(IBSCNN) . I $G(IBSCNNZ)="?CPT" S IBQ=1 D BCPTCHG^IBCRBH2(IBIF < . I $G(IBSCNNZ)="?MRA",$$MCRONBIL^IBEFUNC(IBIFN),$T(S < . I $G(IBSCNNZ)="?ID" S IBQ=1 D DISPID^IBCEF74(IBIFN) < W !,?5,"Enter '?CPT' to view all charges for selected < I $$MCRONBIL^IBEFUNC(IBIFN) W !?5,"Enter '?MRA' to vi < W !,?5,"Enter '?ID' to view all IDs to be electronica < M1 N I,Z S Z="DATA GROUPS ON PARAMETER SCREEN" W !! X IB | M1 S Z="DATA GROUPS ON PARAMETER SCREEN" W !! X IBWW D @ S N C,I,Z,J W !! S Z="AVAILABLE SCREENS" X IBWW | S W !! S Z="AVAILABLE SCREENS" X IBWW W N I,J,Z | W F I=1:1 S J=$P(X,"^",I) Q:J="" S Z=I,IBW=(I#2) W:'(I F I=1:1 S J=$P(X,"^",I) Q:J="" S Z=I,IBW=(I#2) W:'(I < N DIC,DA,X,Y,IBI,IBJ,IBPRV,IBPX,IBDT,IBARR | N DIC,DA,X,Y,IBI,IBPRV,IBPX,IBDT,IBARR diff -y --suppress-common-lines ./VADemo/r1/IBCSCP.m ./VADemo/r2/r/IBCSCP.m ;;2.0;INTEGRATED BILLING;**52,51,161,266**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,51,161**;21-MAR-94 S (ICDVDT,ICPTVDT)=$$BDATE^IBACSV(IBIFN) ;ICD/CPT ver < Q K IBSR,IBVV,VADM,IBVI,IBVO,ICDVDT,ICPTVDT | Q K IBSR,IBVV,VADM,IBVI,IBVO diff -y --suppress-common-lines ./VADemo/r1/IBCU1.m ./VADemo/r2/r/IBCU1.m ;;2.0;INTEGRATED BILLING;**27,52,106,138,51,182,210,2 | ;;2.0;INTEGRATED BILLING;**27,52,106,138,51**; 21-MAR N Z,IBZ,DIC,IBDATE | N Z,IBZ S IBDATE=$$BDATE^IBACSV(+$G(DA(1))) ; The date of ser < . I $P(Z,";")'="" S Q=Q+1,IBZ(Q)=" "_$P(Z,";")_" "_ | . I $P(Z,";")'="" S Q=Q+1,IBZ(Q)=" "_$P(Z,";")_" "_ . I $P(Z,";",2)'="" S Q=Q+1,IBZ(Q)=" "_$P(Z,";",2)_" | . I $P(Z,";",2)'="" S Q=Q+1,IBZ(Q)=" "_$P(Z,";",2)_" S DIC="^DIC(81.3,",DIC(0)="E" | N DIC S DIC="^DIC(81.3,",DIC(0)="E",DIC("S")="I $$MOD S DIC("S")="I $$MODP^ICPTMOD($P($G(^DGCR(399,DA(1),"" < S DIC("W")="W ?14,$P($$MOD^ICPTMOD(Y,""I"",IBDATE),U, < D ^DIC < QMED(IBRTN,IBIFN) ; DSS QuadraMed Interface: DSS/Quadra < ; return 1 if QuadraMed Interface is On and available < ; - routine must exist on the system (interface is 'O < ; Input: IBRTN = tag^routine, if it exists then Inter < ; IBIFN = Bill IFN, bill to check if appropria < ; < N IBON S IBON=0 < I +$G(IBIFN),$G(IBRTN)'="",$T(@IBRTN)'="" S IBON=1 < Q IBON < diff -y --suppress-common-lines ./VADemo/r1/IBCU3.m ./VADemo/r2/r/IBCU3.m IBCU3 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ; 4/4/ | IBCU3 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ;12-FE ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,211,24 | ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137**;21-M I 'INS,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IFN)) S INS=+$$ | I 'INS,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S INS=+ BOTHER(IBIFN,IBDT) ; return Bedsection of Type of Care i < ; Other care is not inpatient or outpatient, SNF and < ; as with all other bedsection movements, the last da < N IBX,IBY,IBFND S IBFND=0,IBDT=$G(IBDT)\1 < I +$G(IBIFN),+IBDT S IBX=0 F S IBX=$O(^DGCR(399,IBIF < . S IBY=$G(^DGCR(399,IBIFN,"OT",IBX,0)) Q:'IBY < . I IBDT'<$P(IBY,U,2),IBDT<$P(IBY,U,3) S IBFND=+IBY < Q IBFND < diff -y --suppress-common-lines ./VADemo/r1/IBCU41.m ./VADemo/r2/r/IBCU41.m ;;2.0;INTEGRATED BILLING;**80,106,51,294**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**80,106,51**;21-MAR-94 . S IB01=$G(^DGCR(399,IBIFN1,0)) | . S IB01=$G(^DGCR(399,IBIFN1,0)) I $P(IB01,U,13)=7 Q . I $P(IB01,U,13)=7 Q ; cancelled bill | . I IBCT1=$P(IB01,U,27),IBDFN=$P(IB01,U,2),IBBT=$P(IB . I IBDFN'=$P(IB01,U,2) Q ; patient < . I IBCT1'=$P(IB01,U,27) Q ; charge type < . I IBBT'=$P(IB01,U,5) Q ; bill type/classificat < . I IBRT'=$P(IB01,U,7) Q ; rate type < . I '$P($G(^DGCR(399,IBIFN1,"S")),U,7),IBSEQ'=$P(IB01 < . I IBSTDTS'=$P($G(^DGCR(399,IBIFN1,"U")),U,1,2) Q < . S IBFND=IBIFN1 ; found a match < . Q < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCU4.m ./VADemo/r2/r/IBCU4.m IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ; 12-F | IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ;12-F ;;2.0;INTEGRATED BILLING;**109,122,137,245**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**109,122,137**;21-MAR-94 OTDAT ; Input transform for Other Care Start Date (399,48,. < I ('$G(DA(1)))!('$G(X)) Q < N IBX S IBX=$G(^DGCR(399,DA(1),"U")) < I +X<+IBX W !,?4,"Can Not Precede Bill Start Date!",! < I +X>+$P(IBX,U,2) W !,?4,"Can not be after Bill End D < Q < ; < ; < diff -y --suppress-common-lines ./VADemo/r1/IBCU5.m ./VADemo/r2/r/IBCU5.m ;;2.0;INTEGRATED BILLING;**8,52,80,117,51,206**;21-MA | ;;2.0;INTEGRATED BILLING;**8,52,80,117,51**;21-MAR-94 S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA) | S DA=$S('$D(DA):IBIFN,DA']"":IBIFN,1:DA),IB01=+$G(^DG G MAILQ:$P(^DGCR(399,DA,0),U,11)="p" ; Patient is res | G MAILQ:'$D(^DIC(36,+IB01,0)) G MAILQ:$P(^DGCR(399,DA,0),U,11)="o" ; Other party is | ;S IB02=$S($D(^DIC(36,+IB01,.11)):^(.11),1:"") ; < S IB01=+$G(^DGCR(399,DA,"MP")) < G MAILQ:'$D(^DIC(36,+IB01,0)) ; Bad insurance data < N DFN,VAPA,DGNAM,IBCONF < S DFN=$P(^DGCR(399,DA,0),"^",2),VAPA("P")="" D DEM^VA | N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),VAPA("P")="" D S IBCONF=$S('$G(VAPA(12)):0,$P($G(VAPA(22,3)),U,3)'=" < S $P(^DGCR(399,DA,"M"),"^",4)=DGNAM | S $P(^DGCR(399,DA,"M"),"^",4,9)=DGNAM_"^"_VAPA(1)_"^" I IBCONF D ; use conf. address for mailing | S $P(^DGCR(399,DA,"M1"),"^",1)=VAPA(3) . S $P(^DGCR(399,DA,"M"),"^",5,9)=VAPA(13)_"^"_VAPA(1 | MAILPQ K VAPA,DGNAM Q . S $P(^DGCR(399,DA,"M1"),"^",1)=VAPA(15) < I 'IBCONF D < . S $P(^DGCR(399,DA,"M"),"^",5,9)=VAPA(1)_"^"_VAPA(2) < . S $P(^DGCR(399,DA,"M1"),"^",1)=VAPA(3) < MAILPQ Q < diff -y --suppress-common-lines ./VADemo/r1/IBCU6.m ./VADemo/r2/r/IBCU6.m IBCU6 ;ALB/AAS - UTILITY ROUTINE TO SET BEDSECTIONS/REVENUE | IBCU6 ;ALB/AAS - UTILITY ROUTINE TO SET BEDSECTIONS/REVENUE ;;2.0;INTEGRATED BILLING;**14,52,138,245,155**;21-MAR | ;;2.0;INTEGRATED BILLING;**14,52,138**;21-MAR-94 I $P($G(^DGCR(399,IBIFN,0)),U,13)'=1 Q ; Do not calc < S X=$$DVTYP^IBCU71(IBIFN) I '$D(ZTQUEUED),$P(X,U,2)'= < diff -y --suppress-common-lines ./VADemo/r1/IBCU71.m ./VADemo/r2/r/IBCU71.m ;;2.0;INTEGRATED BILLING;**41,60,91,106,125,138,210,2 | ;;2.0;INTEGRATED BILLING;**41,60,91,106,125,138**;21- N I,J,X,IBDX,IBDXL,IBDATE | N I,J,X,IBDX,IBDXL S IBDATE=$$BDATE^IBACSV(IBIFN) | F I=1:1:4 S IBDX=$P($G(^DGCR(399,IBIFN,"C")),"^",(I+1 F I=1:1:4 S IBDX=$P($G(^DGCR(399,IBIFN,"C")),"^",(I+1 < ; < DVTYP(IBIFN) ; reset Bill Charge Type (399, .27) based on < ; if bill division is type 3 - Freestanding then rese < ; with RC 2.0+ Type 3 sites have only professional ch < N IB0,IBDV,IBCHGTYP,IBDVTYP,DIC,DIE,DA,DR,X,Y < S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBDV=$P(IB0,U,22),I < I +$G(^DGCR(399,+$G(IBIFN),"U"))<$$VERSDT^IBCRU8(2) G < I +IBDV,+IBCHGTYP S IBDVTYP=$$RCDV^IBCRU8(+IBDV) I +$ < . S DIE="^DGCR(399,",DA=IBIFN,DR=".27////"_2 D ^DIE K < . S IBCHGTYP="2^Bill Charge Type Changed to Professio < DVTYPQ Q IBCHGTYP < diff -y --suppress-common-lines ./VADemo/r1/IBCU72.m ./VADemo/r2/r/IBCU72.m IBCU72 ;ALB/CPM - ADD/EDIT/DELETE PROCEDURE DIAGNOSES ;18-JU | IBCU72 ;ALB/CPM - ADD/EDIT/DELETE PROCEDURE DIAGNOSES ; 18-J ;;2.0;INTEGRATED BILLING;**62,210**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**62**; 21-MAR-94 S IBI=0 F S IBI=$O(IBDX(IBI)) Q:'IBI S IBDX(IBI)=IB | S IBI=0 F S IBI=$O(IBDX(IBI)) Q:'IBI S IBDX(IBI)=IB S IBDEF="" F I=11:1:14 S X=$P(IBPROCD,U,I) I X D | S IBDEF="" F I=11:1:14 S X=$P(IBPROCD,"^",I) I X D . S J=0 F S J=$O(IBDX(J)) Q:'J I +IBDX(J)=X S IBDEF | .S J=0 F S J=$O(IBDX(J)) Q:'J I +IBDX(J)=X S IBDEF= N IBX,IBY,IBZ,IBDATE | N IBX,IBY,IBZ S IBDATE=$$BDATE^IBACSV($G(IBIFN)) < S IBX=0 F S IBX=$O(X(IBX)) Q:'IBX S IBZ=X(IBX),IBY= | S IBX=0 F S IBX=$O(X(IBX)) Q:'IBX S IBZ=X(IBX),IBY= . W !?5,IBX,".",?12,$P(IBY,U),?26,$P(IBY,U,3),?60,$S( | .W !?5,IBX,".",?12,$P(IBY,U,1),?26,$P(IBY,U,3),?60,$S diff -y --suppress-common-lines ./VADemo/r1/IBCU73.m ./VADemo/r2/r/IBCU73.m IBCU73 ;ALB/ARH - ADD/DELETE MODIFIER 26 TO SPECIFIED CPTS ; | IBCU73 ;ALB/ARH - ADD/DELETE MODIFIER 26 TO SPECIFIED CPTS ; ;;2.0;INTEGRATED BILLING;**138,51,148,169,245**;21-MA | ;;2.0;INTEGRATED BILLING;**138,51,148**;21-MAR-94 N IB0,IBEVDT,IBBCT,IBCSI,IBCSP,IBBCPT,IBLN,IBMODS,IB2 | N IB0,IBEVDT,IBBCT,IBCSI,IBCSP,IBBCPT,IBLN,IBMODS,IB2 S IBBU=$G(^DGCR(399,+IBIFN,"U")),IBEND=$$VERSDT^IBCRU | I 3001102>$P($G(^DGCR(399,+IBIFN,"U")),U,2) Q I 3001102>$P(IBBU,U,2) Q ; starts with v1.1 < I +IBBU>IBEND Q ; ends with v2 < . S IBLN=$G(^DGCR(399,IBIFN,"CP",IBBCPT,0)),IBEVDT=$P | . S IBLN=$G(^DGCR(399,IBIFN,"CP",IBBCPT,0)),IBEVDT=$P . I 3001102>IBEVDT Q < . I IBEVDT'3030428,",75952,75953,"[IBCPTX S IBX=1 ; shoul < Only in ./VADemo/r1/: IBCU74.m Only in ./VADemo/r1/: IBCU7A1.m Only in ./VADemo/r1/: IBCU7A.m diff -y --suppress-common-lines ./VADemo/r1/IBCU7.m ./VADemo/r2/r/IBCU7.m ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,2 | ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137**;21- ASKCOD N Z,Z0,DA,IBACT,IBQUIT | ASKCOD N Z,Z0,DA K DGCPT | K DGCPT S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^", S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^",19),DGAD < ; | F S DIC("A")=" Select PROCEDURE: ",DIC="^DGCR(399, F S IBQUIT=0 D Q:IBQUIT | . I Y["ICD0",$P(^ICD0(+$P(Y,"^",2),0),"^",11),$P(^(0) . S DIC("A")=" Select PROCEDURE: " | .I Y["ICPT",'$P($$CPT^ICPTCOD(+$P(Y,"^",2),DGPROCDT), . S DIC="^DGCR(399,"_IBIFN_",""CP""," | .S DGCPTNEW=$P(Y,"^",3),DGADDVST=$S($P(Y,"^",3):1,$D( . S DIC(0)="AEQMNL" < . S DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCD < . S DIC("DR")="1///^S X=DGPROCDT" < . S DA(1)=IBIFN,DLAYGO=399 < . W ! D ^DIC I Y<1 S IBQUIT=1 Q < . ; If we just added inactive code - it must be delet < . S IBACT=0 ; Active flag < . I Y["ICD0" S IBACT=$$ICD0ACT^IBACSV(+$P(Y,U,2),DGPR < . I Y["ICPT" S IBACT=$$CPTACT^IBACSV(+$P(Y,U,2),DGPRO < . S DGCPTNEW=$P(Y,"^",3) ;Was the procedure just adde < . I DGCPTNEW,'IBACT D DELPROC Q < . I 'IBACT W !,*7,"Warning: Procedure code is inacti < . I DGCPTNEW,$D(^UTILITY($J,"IB")),$$INPAT^IBCEF(IBIF < . S DGADDVST=$S(DGCPTNEW:1,$D(DGADDVST):DGADDVST,1:0) < . S DR=".01;"_DR_$S(IBFT=2:"8;9;17//NO;",1:"")_3,DIE= | .S DR=".01;"_DR_$S(IBFT=2:"8;9;17//NO;",1:"")_3,DIE=D . ; | .; . S DR=$$SPCUNIT(IBIFN,IBPROCP) I DR'="" D ^DIE ; mil < . ; < . ;add procedures to array for download to PCE: dgcpt | .;add procedures to array for download to PCE: dgcpt( . S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0)) | .S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0)) . S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,1 | .S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,11 . I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2 | .I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2 . I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^", | .I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^",7 . ; add visit date to bill | .; add visit date to bill . I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K | .I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K D ; Delete modifers with only a sequence #, no code | ;Delete modifers with only a sequence #, no code K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNE | K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNE Q < ; < DELPROC ; Remove the selected procedure, because of inactive < W !!,*7,"The Procedure code is inactive on ",$$DAT1^I < W !,"Please select another Procedure." < S DA(1)=IBIFN,DA=+Y,DIK="^DGCR(399,"_IBIFN_",""CP""," < D ^DIK < Q < ;S DR="19;S:$P($G(^IBE(353.2,+$P($G(^DGCR(399,DA(1)," | S DR="19;S:$P($G(^IBE(353.2,+$P($G(^DGCR(399,DA(1),"" S DR="19;50.01;50.08" D ^DIE < SPCUNIT(IBIFN,DA) ; return fields for special units if < N IB0,IBCPT,IBDR,IBCT,IBFT S IBDR="" < S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),I < S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IB < I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" G SPC < I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPC < I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22;" G SPC < I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)=" < SPCUNTQ Q IBDR < Only in ./VADemo/r1/: IBCU7U.m diff -y --suppress-common-lines ./VADemo/r1/IBCU.m ./VADemo/r2/r/IBCU.m ;;2.0;INTEGRATED BILLING;**52,106,51,191,232**;21-MAR | ;;2.0;INTEGRATED BILLING;**52,106,51,191**;21-MAR-94 PRVNUM(IBIFN,IBINS,COB) ; Trigger code for Bill Primary/Secon | PRVNUM(IBIFN,IBINS,COB) ; Trigger code for Bill Primary/Secon ; returns the Provider Number for the Insurance Compa | ; returns the Provider Number for the Insurance Compa ; Hospital Provider Number for prov id in fil | ; Hospital Provider Number (36,.11) ; or Medicare A provider Number (psych/non-ps | ; or Professional Provider Number (36,.17) fo ; | ; or Medicare A provider Number (psych/non-ps > ; ; IBINS - insurance company ifn (opt) | ; IBINS - insurance company ifn > ; > N IBX,IBB0,IBI0 S IBX="" > S IBB0=$G(^DGCR(399,+$G(IBIFN),0)) > S IBI0=$G(^DIC(36,+$G(IBINS),0)) > I IBB0'="",IBI0'="" S IBX=$P(IBI0,U,11) I $$FT^IBCEF( N IBX,IBB0,IBBF,IBFT,Z,Z0 | I +$G(IBIFN),+$G(COB) N DA S DA=IBIFN I $$MCRACK^IBCB S:'$G(COB) COB=1 < S IBX=$P($G(^DGCR(399,+$G(IBIFN),"M1")),U,COB+1),IBB0 < I $G(IBINS)="" S IBINS=+$G(^DGCR(399,+$G(IBIFN),"I"_C < G:'IBINS PRVNQ < ; < I +$G(IBIFN),COB N DA S DA=IBIFN I $$MCRACK^IBCBB3(+I < ; < S IBX=$$FACNUM^IBCEP2B(IBIFN,COB) < I IBX="" S IBX=$P($G(^DIC(36,IBINS,0)),U,$S($$FT^IBCE < ; < PRVNQ Q IBX < ; < BF() ; Returns ien of billing fac primary id type < N Z,IBX < S IBX="",Z=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G( < N IBDR | N IBBM,IBDR > ; > S IBBM=$G(^DGCR(399,+$G(IBIFN),"M")) I +$G(^DGCR(399,+$G(IBIFN),"I1")) S IBDR(399,IBIFN_", | I +$P(IBBM,U,1) S IBDR(399,IBIFN_",",122)=$$PRVNUM(I I +$G(^DGCR(399,+$G(IBIFN),"I2")) S IBDR(399,IBIFN_", | I +$P(IBBM,U,2) S IBDR(399,IBIFN_",",123)=$$PRVNUM(I I +$G(^DGCR(399,+$G(IBIFN),"I3")) S IBDR(399,IBIFN_", | I +$P(IBBM,U,3) S IBDR(399,IBIFN_",",124)=$$PRVNUM(I diff -y --suppress-common-lines ./VADemo/r1/IBCVA1.m ./VADemo/r2/r/IBCVA1.m ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210**;21- | ;;2.0;INTEGRATED BILLING;**52,80,109,51,137**;21-MAR- OCC I $D(^DGCR(399,IBIFN,"C")) D | OCC I $D(^DGCR(399,IBIFN,"C")) F I=14:1:18 S IBDI(I)=$P(^ . N IBDATE,IBC | K IBO S:'$D(^DGCR(399,IBIFN,"OC")) IBO="" G:$D(IBO) C . S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of servic < . S IBC=^DGCR(399,IBIFN,"C") < . F I=14:1:18 S IBDI(I)=$P(IBC,U,I) Q:IBDI(I)="" D < .. S IBDIN(I)=IBDI(I) < .. S IBDI(I)=$P($$ICD9^IBACSV(IBDI(I),IBDATE),U,3) < K IBO S:'$D(^DGCR(399,IBIFN,"OC")) IBO="" G:$D(IBO) C < ; | ; Only in ./VADemo/r1/: IBDF18A2.m diff -y --suppress-common-lines ./VADemo/r1/IBDF18A.m ./VADemo/r2/r/IBDF18A.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38,51**;APR | ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, GLL(CLINIC,INTRFACE,ARY,FILTER,PAR5,PAR6,ENCDATE) ; -- | GLL(CLINIC,INTRFACE,ARY,FILTER) ; -- get lots of lists in one ; -- PAR5 => not currently used < ; -- PAR6 => not currently used < ; < S X="" F S X=$O(INTRFACE(X)) Q:X="" D GETLST(CLINIC | S X="" F S X=$O(INTRFACE(X)) Q:X="" D GETLST(CLINIC GETLST(CLINIC,INTRFACE,ARY,FILTER,COUNT,MODIFIER,ENCDATE) | GETLST(CLINIC,INTRFACE,ARY,FILTER,COUNT,MODIFIER) ; -- ; ENCDATE = encounter date < ; @ARY@(k+1) = problem ien or cpt or icd code | ; @ARY@(k+1) = problem ien or cpt or icd code^u N LIST1,PACKAGE < S PACKAGE=$E(INTRFACE,1,30) < ; < ;Setup array containing NAME of the Package Interface < ;This is the second paramenter passed by PCE, TIU, & < S LIST1("DG SELECT CPT PROCEDURE CODES")="" < S LIST1("DG SELECT ICD-9 DIAGNOSIS CODE")="" < S LIST1("DG SELECT VISIT TYPE CPT PROCE")="" < S LIST1("GMP INPUT CLINIC COMMON PROBLE")="" < S LIST1("GMP PATIENT ACTIVE PROBLEMS")="" < ; < ;This routine checks list that have CPT & ICD codes f < D CHKLST^IBDF18A2:$D(LIST1(PACKAGE)) < TEST1 K VAR D GETLST(573,"DG SELECT ICD-9 DIAGNOSIS CODES", | TEST1 K VAR D GETLST(573,"DG SELECT ICD-9 DIAGNOSIS CODES", X "ZW VAR" < Q < ; < TEST2 K VAR D GETLST(301,"DG SELECT ICD-9 DIAGNOSIS CODES", < TEST4 K VAR D GETLST(300,"DG SELECT VISIT TYPE CPT PROCEDUR | TEST2 K VAR D GETLST(301,"DG SELECT ICD-9 DIAGNOSIS CODES", TEST5 K VAR D GETLST(300,"PX SELECT IMMUNIZATIONS","VAR",1, | TEST4 K VAR D GETLST(300,"DG SELECT VISIT TYPE CPT PROCEDUR TEST5A K VAR D GETLST(300,"PX SELECT SKIN TESTS","VAR",1,DT) | TEST5 K VAR D GETLST(300,"PX SELECT IMMUNIZATIONS","VAR",1) TEST6 K VAR D GETLST(573,"DG SELECT CPT PROCEDURE CODES","V | TEST6 K VAR D GETLST(573,"DG SELECT CPT PROCEDURE CODES","V TEST7 K VAR D GETLST(573,"DG SELECT VISIT TYPE CPT PROCEDUR | TEST7 K VAR D GETLST(573,"DG SELECT VISIT TYPE CPT PROCEDUR diff -y --suppress-common-lines ./VADemo/r1/IBDF18E2.m ./VADemo/r2/r/IBDF18E2.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**25,51**;APR 24, | ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 19 ; < W !,?4,"** This option is OUT OF ORDER **" QUIT ;Co < ; < diff -y --suppress-common-lines ./VADemo/r1/IBDF4C.m ./VADemo/r2/r/IBDF4C.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,51**;APR 24, | ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24,199 ; $p($$mod^icptmod,"^",7) -- check status of the | ; .;;S DIC=81.3,DIC("S")="I ($$MODP^ICPTMOD(CPT,+Y,""I" | .S DIC=81.3,DIC("S")="I ($$MODP^ICPTMOD(CPT,+Y,""I"") .S DIC=81.3 < .; < .;Is the modifier active and can it be used with this < .S DIC("S")="I ($$MODP^ICPTMOD(CPT,+Y,""I""))>0,$P($$ < ;;S X="??",DIC=81.3,DIC("S")="I ($$MODP^ICPTMOD(CPT,+ | S X="??",DIC=81.3,DIC("S")="I ($$MODP^ICPTMOD(CPT,+Y, S X="??",DIC=81.3 < ; < ;Is the modifier active and can it be used with this < S DIC("S")="I ($$MODP^ICPTMOD(CPT,+Y,""I""))>0,$P($$M < diff -y --suppress-common-lines ./VADemo/r1/IBDF4.m ./VADemo/r2/r/IBDF4.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**19,38,56**;APR | ;;3.0;AUTOMATED INFO COLLECTION SYS;**19,38**;APR 24, .S DIE="^IBE(357.3,",DA=SLCTN,DR=2.01 D ^DIE K DIE,DA | .S DIE="^IBE(357.3,",DA=SLCTN,DR=2.01 D ^DIE K DIC < diff -y --suppress-common-lines ./VADemo/r1/IBDFDE6.m ./VADemo/r2/r/IBDFDE6.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**11,51**;APR 24, | ;;3.0;AUTOMATED INFO COLLECTION SYS;**11,37**;APR 24, ; < W !,?4,"** This option is OUT OF ORDER **" QUIT ;Co < > N GAFCNT diff -y --suppress-common-lines ./VADemo/r1/IBDFDE7.m ./VADemo/r2/r/IBDFDE7.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**36,51**;APR 24, | ;;3.0;AUTOMATED INFO COLLECTION SYS;**36,37**;APR 24, ; < W !,?4,"** This option is OUT OF ORDER **" QUIT ;Co < > N GAFCNT diff -y --suppress-common-lines ./VADemo/r1/IBDFDE8.m ./VADemo/r2/r/IBDFDE8.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 19 | ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997 ; < W !,?4,"** This option is OUT OF ORDER **" QUIT ;Co < diff -y --suppress-common-lines ./VADemo/r1/IBDFDE9.m ./VADemo/r2/r/IBDFDE9.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 19 | ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997 ; < W !,?4,"** This option is OUT OF ORDER **" QUIT ;Co < diff -y --suppress-common-lines ./VADemo/r1/IBDFDE.m ./VADemo/r2/r/IBDFDE.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,51**;APR 24, | ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,37**;APR 24, ; < W !,?4,"** This option is OUT OF ORDER **" QUIT ;Co < N ANS1,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX | N ANS1,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,GAFCN diff -y --suppress-common-lines ./VADemo/r1/IBDFFV.m ./VADemo/r2/r/IBDFFV.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 19 | ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997 W !,?4,"** This option is OUT OF ORDER **" QUIT ;Co < ; < diff -y --suppress-common-lines ./VADemo/r1/IBDFLST.m ./VADemo/r2/r/IBDFLST.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,38,51**;APR 2 | ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,38**;APR 24, ; -- Use api for ICD9 | ICD9 F IBDFIFN=0:0 S IBDFIFN=$O(^ICD9(IBDFIFN)) Q:'IBDFIFN ICD9 ;;F IBDFIFN=0:0 S IBDFIFN=$O(^ICD9(IBDFIFN)) Q:'IBDFI | .S IBDFCODE=$P(IBDFNODE,"^",1),IBDFDESC=$P(IBDFNODE," ; < ;Use ICD API to check the status for CSV. No date is < ;default day is DT (today). $P10 = status 0-inactive < F IBDFIFN=0:0 S IBDFIFN=$O(^ICD9(IBDFIFN)) Q:'IBDFIFN < .S IBDFCODE=$P(IBDFNODE,"^",2),IBDFDESC=$P(IBDFNODE," < . Q:$P(IBDFNODE,U,7)=1 ;(CSV) status 0-inactive 1-ac | . Q:+IBDFNODE=-1 . ;;Q:+IBDFNODE=-1 < diff -y --suppress-common-lines ./VADemo/r1/IBDFN12.m ./VADemo/r2/r/IBDFN12.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**12,38,40,51**;A | ;;3.0;AUTOMATED INFO COLLECTION SYS;**12,38,40**;APR N NODE,SCRN | N NODE ;;D LOOKUP(81,"I '$P(^(0),U,4)",.X,.NODE) | D LOOKUP(81,"I '$P(^(0),U,4)",.X,.NODE) ; < ;List only active code. (CSV) < S SCRN="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;Check status f < D LOOKUP(81,SCRN,.X,.NODE) < N NODE,SCRN | N NODE ;;D LOOKUP(80,"I '$P(^(0),U,9)",.X,.NODE) | D LOOKUP(80,"I '$P(^(0),U,9)",.X,.NODE) ; < ;List only active code. (CSV) < S SCRN="I $P($$ICDDX^ICDCODE(Y),U,10)=1" ;Check statu < D LOOKUP(80,SCRN,.X,.NODE) < N NODE,SCREEN | N NODE ;;D LOOKUP(357.69,"I '$P(^(0),U,4)",.X,.NODE) | D LOOKUP(357.69,"I '$P(^(0),U,4)",.X,.NODE) ; < ;List only active code. (CSV) < S SCRN="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;Check status f < D LOOKUP(357.69,SCRN,.X,.NODE) < ; < diff -y --suppress-common-lines ./VADemo/r1/IBDFN14.m ./VADemo/r2/r/IBDFN14.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**12,38,51**;APR | ;;3.0;AUTOMATED INFO COLLECTION SYS;**12,38**;APR 24, N ICDNODE < ;;I $G(^ICD9(X,0))]"" S IBID=$P(^(0),"^"),IBLABEL=$P( | I $G(^ICD9(X,0))]"" S IBID=$P(^(0),"^"),IBLABEL=$P(^( S ICDNODE=$$ICDDX^ICDCODE(X) < Q:+ICDNODE=-1 < S IBID=$P(ICDNODE,U,2) ;ICD code < S IBLABEL=$P(ICDNODE,U,4) ;ICD description < S STATUS=$P(ICDNODE,U,10) ;ICD status, 0-Not Active, < ; < ;Set inactive flag to 1, if the ICD code is not activ < I STATUS=0 S IBINACT=1 < diff -y --suppress-common-lines ./VADemo/r1/IBDFN4.m ./VADemo/r2/r/IBDFN4.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,51**;APR 24, | ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 19 ;;I '$D(@IBARY@("SCREEN")) D CPTSCRN Q:QUIT | I '$D(@IBARY@("SCREEN")) D CPTSCRN Q:QUIT ;;E S SCREEN=$G(@IBARY@("SCREEN")) | E S SCREEN=$G(@IBARY@("SCREEN")) S SCREEN="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;List only ac < CPTSCRN ;This code is probably not called, but will modify to | CPTSCRN ; ;;S SCREEN="I '$P(^(0),U,4)" | S SCREEN="I '$P(^(0),U,4)" S SCREEN="I $P($$CPT^ICPTCOD(Y),U,7)=1" < ;;I $D(@IBARY@("SCREEN")) S SCREEN=$G(@IBARY@("SCREEN | I $D(@IBARY@("SCREEN")) S SCREEN=$G(@IBARY@("SCREEN") ;;E D ICD9SCRN Q:QUIT | E D ICD9SCRN Q:QUIT S SCREEN="I $P($$ICDDX^ICDCODE(Y),U,10)=1" ;List only < ICD9SCRN ;This code is probably not called, but will m | ICD9SCRN ; ;;S SCREEN="I '$P(^(0),U,9)" | S SCREEN="I '$P(^(0),U,9)" S SCREEN="I $P($$ICDDX^ICDCODE(Y),U,10)=1" < ;;S DIC="^IBE(357.69,",DIC(0)="AEMQZ",DIC("S")="I '$P | S DIC="^IBE(357.69,",DIC(0)="AEMQZ",DIC("S")="I '$P(^ S DIC="^IBE(357.69,",DIC(0)="AEMQZ" < S DIC("S")="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;List only < ;;S SCREEN="I '$P(^(0),U,5)" | S SCREEN="I '$P(^(0),U,5)" ;;I '$D(@IBARY@("SCREEN")) S @IBARY@("SCREEN")=SCREEN | I '$D(@IBARY@("SCREEN")) S @IBARY@("SCREEN")=SCREEN ; < ;List only active modifiers < S SCREEN="I $P($$MOD^ICPTMOD(Y,""I""),U,7)=1" < diff -y --suppress-common-lines ./VADemo/r1/IBDFN7.m ./VADemo/r2/r/IBDFN7.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,51**;APR 24, | ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 19 N CODE,STATUS < ;;I $P($G(^ICD9(X,0)),"^",9) S Y=$P(^ICD9(X,0),"^",3) | I $P($G(^ICD9(X,0)),"^",9) S Y=$P(^ICD9(X,0),"^",3) K S CODE=$$ICDDX^ICDCODE(X) < S STATUS=$P(CODE,U,10) I STATUS'=1 S Y=$P(CODE,U,4) K < diff -y --suppress-common-lines ./VADemo/r1/IBDFN8.m ./VADemo/r2/r/IBDFN8.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**25,38,51**;APR | ;;3.0;AUTOMATED INFO COLLECTION SYS;**25,38**;APR 24, ;;S X=+$$CPT^ICPTCOD(X) | S X=+$$CPT^ICPTCOD(X) S X=$$CPT^ICPTCOD(X) < I $P(X,U,7)'=1 K X ;(CSV) status 0-inactive 1-active < S X=$O(^ICD9("BA",ICD_" ",0)) I 'X K X Q | S X=$O(^ICD9("BA",ICD_" ",0)) ;;K:'X X | K:'X X ; < ;(CSV) status 0-inactive 1-active < I $P($$ICDDX^ICDCODE(X),U,10)'=1 K X < diff -y --suppress-common-lines ./VADemo/r1/IBDFN9.m ./VADemo/r2/r/IBDFN9.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,36,51**;APR | ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,36**;APR 24, ;;I +CODE=-1 S CODE="" | I +CODE=-1 S CODE="" ;;E S CODE=$P(CODE,U,2) | E S CODE=$P(CODE,U,2) ; < ;Check status for CSV < I $P(CODE,U,7)'=1 S CODE="" Q CODE < S CODE=$P(CODE,U,2) < ;;Q $P($G(^ICD9(+$G(IEN),0)),"^") | Q $P($G(^ICD9(+$G(IEN),0)),"^") ; < ;Use API for CSV < Q $P($$ICDDX^ICDCODE(IEN),"^",2) < diff -y --suppress-common-lines ./VADemo/r1/IBDFOSG.m ./VADemo/r2/r/IBDFOSG.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**29,51**;APR 24, | ;;3.0;AUTOMATED INFO COLLECTION SYS;**29**;APR 24, 19 ; < W !,?4,"** This option is OUT OF ORDER **" QUIT ;Co < diff -y --suppress-common-lines ./VADemo/r1/IBDFUTL1.m ./VADemo/r2/r/IBDFUTL1.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**32,23,51**;APR | ;;3.0;AUTOMATED INFO COLLECTION SYS;**32,23**;APR 24, ......;;S IBY=$S(+XX=-1:"",1:$P(XX,"^",3)) | ......S IBY=$S(+XX=-1:"",1:$P(XX,"^",3)) ......S IBY=$S($P(XX,U,7)'=1:"",1:$P(XX,"^",3)) | .....I $G(IBDFCODE)="ICD-9 " N IBY S IBY=$P($G(^ICD9( .....;;I $G(IBDFCODE)="ICD-9 " N IBY S IBY=$P($G(^ICD < .....I $G(IBDFCODE)="ICD-9 " N IBY S IBY=$P($$ICDDX^I < diff -y --suppress-common-lines ./VADemo/r1/IBDFUTL.m ./VADemo/r2/r/IBDFUTL.m ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,32,51**;APR 2 | ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,32**;APR 24, .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="CPT" S DIC=" | .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="CPT" S DIC="^I .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" S DIC=" | .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" S DIC="^I .;;I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="VST" S DIC=" | .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="VST" S DIC="^I .; < .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="CPT" S DIC="^I < .; < .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" S DIC="^I < .; < .I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="VST" S DIC="^I < .; < diff -y --suppress-common-lines ./VADemo/r1/IBDX01.m ./VADemo/r2/r/IBDX01.m IBDX01 ; COMPILED XREF FOR FILE #357 ; 10/15/04 | IBDX01 ; COMPILED XREF FOR FILE #357 ; 06/26/97 > S X=$P(DIKZ(0),U,1) > I X'="" K ^IBE(357,"B",$E(X,1,30),DA) S X=$P(DIKZ(0),U,1) < I X'="" K ^IBE(357,"B",$E(X,1,30),DA) < diff -y --suppress-common-lines ./VADemo/r1/IBDX02.m ./VADemo/r2/r/IBDX02.m IBDX02 ; COMPILED XREF FOR FILE #357.02 ; 10/15/04 | IBDX02 ; COMPILED XREF FOR FILE #357.02 ; 06/26/97 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) diff -y --suppress-common-lines ./VADemo/r1/IBDX03.m ./VADemo/r2/r/IBDX03.m IBDX03 ; COMPILED XREF FOR FILE #357 ; 10/15/04 | IBDX03 ; COMPILED XREF FOR FILE #357 ; 06/26/97 diff -y --suppress-common-lines ./VADemo/r1/IBDX04.m ./VADemo/r2/r/IBDX04.m IBDX04 ; COMPILED XREF FOR FILE #357.02 ; 10/15/04 | IBDX04 ; COMPILED XREF FOR FILE #357.02 ; 06/26/97 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 diff -y --suppress-common-lines ./VADemo/r1/IBDX0.m ./VADemo/r2/r/IBDX0.m IBDX0 ; DRIVER FOR COMPILED XREFS FOR FILE #357 ; 10/15/04 | IBDX0 ; DRIVER FOR COMPILED XREFS FOR FILE #357 ; 06/26/97 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/IBDX110.m ./VADemo/r2/r/IBDX110.m IBDX110 ; COMPILED XREF FOR FILE #357.14 ; 10/15/04 | IBDX110 ; COMPILED XREF FOR FILE #357.14 ; 05/01/97 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 diff -y --suppress-common-lines ./VADemo/r1/IBDX11.m ./VADemo/r2/r/IBDX11.m IBDX11 ; COMPILED XREF FOR FILE #357.1 ; 10/15/04 | IBDX11 ; COMPILED XREF FOR FILE #357.1 ; 05/01/97 > S X=$P(DIKZ(0),U,1) > I X'="" K ^IBE(357.1,"B",$E(X,1,30),DA) S X=$P(DIKZ(0),U,1) < I X'="" K ^IBE(357.1,"B",$E(X,1,30),DA) < diff -y --suppress-common-lines ./VADemo/r1/IBDX12.m ./VADemo/r2/r/IBDX12.m IBDX12 ; COMPILED XREF FOR FILE #357.11 ; 10/15/04 | IBDX12 ; COMPILED XREF FOR FILE #357.11 ; 05/01/97 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) diff -y --suppress-common-lines ./VADemo/r1/IBDX13.m ./VADemo/r2/r/IBDX13.m IBDX13 ; COMPILED XREF FOR FILE #357.12 ; 10/15/04 | IBDX13 ; COMPILED XREF FOR FILE #357.12 ; 05/01/97 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) diff -y --suppress-common-lines ./VADemo/r1/IBDX14.m ./VADemo/r2/r/IBDX14.m IBDX14 ; COMPILED XREF FOR FILE #357.13 ; 10/15/04 | IBDX14 ; COMPILED XREF FOR FILE #357.13 ; 05/01/97 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) diff -y --suppress-common-lines ./VADemo/r1/IBDX15.m ./VADemo/r2/r/IBDX15.m IBDX15 ; COMPILED XREF FOR FILE #357.14 ; 10/15/04 | IBDX15 ; COMPILED XREF FOR FILE #357.14 ; 05/01/97 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) diff -y --suppress-common-lines ./VADemo/r1/IBDX16.m ./VADemo/r2/r/IBDX16.m IBDX16 ; COMPILED XREF FOR FILE #357.1 ; 10/15/04 | IBDX16 ; COMPILED XREF FOR FILE #357.1 ; 05/01/97 diff -y --suppress-common-lines ./VADemo/r1/IBDX17.m ./VADemo/r2/r/IBDX17.m IBDX17 ; COMPILED XREF FOR FILE #357.11 ; 10/15/04 | IBDX17 ; COMPILED XREF FOR FILE #357.11 ; 05/01/97 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 diff -y --suppress-common-lines ./VADemo/r1/IBDX18.m ./VADemo/r2/r/IBDX18.m IBDX18 ; COMPILED XREF FOR FILE #357.12 ; 10/15/04 | IBDX18 ; COMPILED XREF FOR FILE #357.12 ; 05/01/97 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 diff -y --suppress-common-lines ./VADemo/r1/IBDX19.m ./VADemo/r2/r/IBDX19.m IBDX19 ; COMPILED XREF FOR FILE #357.13 ; 10/15/04 | IBDX19 ; COMPILED XREF FOR FILE #357.13 ; 05/01/97 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 diff -y --suppress-common-lines ./VADemo/r1/IBDX1.m ./VADemo/r2/r/IBDX1.m IBDX1 ; DRIVER FOR COMPILED XREFS FOR FILE #357.1 ; 10/15/0 | IBDX1 ; DRIVER FOR COMPILED XREFS FOR FILE #357.1 ; 05/01/9 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/IBDX21.m ./VADemo/r2/r/IBDX21.m IBDX21 ; COMPILED XREF FOR FILE #357.2 ; 10/15/04 | IBDX21 ; COMPILED XREF FOR FILE #357.2 ; 02/01/99 > S X=$P(DIKZ(0),U,1) > I X'="" K ^IBE(357.2,"B",$E(X,1,30),DA) S X=$P(DIKZ(0),U,1) < I X'="" K ^IBE(357.2,"B",$E(X,1,30),DA) < diff -y --suppress-common-lines ./VADemo/r1/IBDX22.m ./VADemo/r2/r/IBDX22.m IBDX22 ; COMPILED XREF FOR FILE #357.21 ; 10/15/04 | IBDX22 ; COMPILED XREF FOR FILE #357.21 ; 02/01/99 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) diff -y --suppress-common-lines ./VADemo/r1/IBDX23.m ./VADemo/r2/r/IBDX23.m IBDX23 ; COMPILED XREF FOR FILE #357.22 ; 10/15/04 | IBDX23 ; COMPILED XREF FOR FILE #357.22 ; 02/01/99 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) diff -y --suppress-common-lines ./VADemo/r1/IBDX24.m ./VADemo/r2/r/IBDX24.m IBDX24 ; COMPILED XREF FOR FILE #357.2 ; 10/15/04 | IBDX24 ; COMPILED XREF FOR FILE #357.2 ; 02/01/99 diff -y --suppress-common-lines ./VADemo/r1/IBDX25.m ./VADemo/r2/r/IBDX25.m IBDX25 ; COMPILED XREF FOR FILE #357.21 ; 10/15/04 | IBDX25 ; COMPILED XREF FOR FILE #357.21 ; 02/01/99 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 diff -y --suppress-common-lines ./VADemo/r1/IBDX26.m ./VADemo/r2/r/IBDX26.m IBDX26 ; COMPILED XREF FOR FILE #357.22 ; 10/15/04 | IBDX26 ; COMPILED XREF FOR FILE #357.22 ; 02/01/99 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 diff -y --suppress-common-lines ./VADemo/r1/IBDX2.m ./VADemo/r2/r/IBDX2.m IBDX2 ; DRIVER FOR COMPILED XREFS FOR FILE #357.2 ; 10/15/0 | IBDX2 ; DRIVER FOR COMPILED XREFS FOR FILE #357.2 ; 02/01/9 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/IBDX31.m ./VADemo/r2/r/IBDX31.m IBDX31 ; COMPILED XREF FOR FILE #357.3 ; 10/15/04 | IBDX31 ; COMPILED XREF FOR FILE #357.3 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX32.m ./VADemo/r2/r/IBDX32.m IBDX32 ; COMPILED XREF FOR FILE #357.31 ; 10/15/04 | IBDX32 ; COMPILED XREF FOR FILE #357.31 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX33.m ./VADemo/r2/r/IBDX33.m IBDX33 ; COMPILED XREF FOR FILE #357.33 ; 10/15/04 | IBDX33 ; COMPILED XREF FOR FILE #357.33 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX34.m ./VADemo/r2/r/IBDX34.m IBDX34 ; COMPILED XREF FOR FILE #357.3 ; 10/15/04 | IBDX34 ; COMPILED XREF FOR FILE #357.3 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX35.m ./VADemo/r2/r/IBDX35.m IBDX35 ; COMPILED XREF FOR FILE #357.31 ; 10/15/04 | IBDX35 ; COMPILED XREF FOR FILE #357.31 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX36.m ./VADemo/r2/r/IBDX36.m IBDX36 ; COMPILED XREF FOR FILE #357.33 ; 10/15/04 | IBDX36 ; COMPILED XREF FOR FILE #357.33 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX3.m ./VADemo/r2/r/IBDX3.m IBDX3 ; DRIVER FOR COMPILED XREFS FOR FILE #357.3 ; 10/15/0 | IBDX3 ; DRIVER FOR COMPILED XREFS FOR FILE #357.3 ; 03/13/0 diff -y --suppress-common-lines ./VADemo/r1/IBDX41.m ./VADemo/r2/r/IBDX41.m IBDX41 ; COMPILED XREF FOR FILE #357.4 ; 10/15/04 | IBDX41 ; COMPILED XREF FOR FILE #357.4 ; 05/01/97 > S X=$P(DIKZ(0),U,1) > I X'="" K ^IBE(357.4,"B",$E(X,1,30),DA) S X=$P(DIKZ(0),U,1) < I X'="" K ^IBE(357.4,"B",$E(X,1,30),DA) < diff -y --suppress-common-lines ./VADemo/r1/IBDX42.m ./VADemo/r2/r/IBDX42.m IBDX42 ; COMPILED XREF FOR FILE #357.4 ; 10/15/04 | IBDX42 ; COMPILED XREF FOR FILE #357.4 ; 05/01/97 diff -y --suppress-common-lines ./VADemo/r1/IBDX4.m ./VADemo/r2/r/IBDX4.m IBDX4 ; DRIVER FOR COMPILED XREFS FOR FILE #357.4 ; 10/15/0 | IBDX4 ; DRIVER FOR COMPILED XREFS FOR FILE #357.4 ; 05/01/9 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/IBDX51.m ./VADemo/r2/r/IBDX51.m IBDX51 ; COMPILED XREF FOR FILE #357.5 ; 10/15/04 | IBDX51 ; COMPILED XREF FOR FILE #357.5 ; 05/01/97 S X=$P(DIKZ(0),U,2) < I X'="" K ^IBE(357.5,"C",$E(X,1,30),DA) < > S X=$P(DIKZ(0),U,2) > I X'="" K ^IBE(357.5,"C",$E(X,1,30),DA) diff -y --suppress-common-lines ./VADemo/r1/IBDX52.m ./VADemo/r2/r/IBDX52.m IBDX52 ; COMPILED XREF FOR FILE #357.52 ; 10/15/04 | IBDX52 ; COMPILED XREF FOR FILE #357.52 ; 05/01/97 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) diff -y --suppress-common-lines ./VADemo/r1/IBDX53.m ./VADemo/r2/r/IBDX53.m IBDX53 ; COMPILED XREF FOR FILE #357.5 ; 10/15/04 | IBDX53 ; COMPILED XREF FOR FILE #357.5 ; 05/01/97 diff -y --suppress-common-lines ./VADemo/r1/IBDX54.m ./VADemo/r2/r/IBDX54.m IBDX54 ; COMPILED XREF FOR FILE #357.52 ; 10/15/04 | IBDX54 ; COMPILED XREF FOR FILE #357.52 ; 05/01/97 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:$D(DA(1)) DIKLM=1 G:$D(DA(1)) 1 diff -y --suppress-common-lines ./VADemo/r1/IBDX5.m ./VADemo/r2/r/IBDX5.m IBDX5 ; DRIVER FOR COMPILED XREFS FOR FILE #357.5 ; 10/15/0 | IBDX5 ; DRIVER FOR COMPILED XREFS FOR FILE #357.5 ; 05/01/9 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ | N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZ I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T D | S DIKLK=DIK_DA_")" L @("+"_DIKLK) D DI L @("-"_DIKLK) D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK < G Q < S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU | S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ | C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_ SET S DISET=1,DIKZK=1 K DIKPUSH | SET S DISET=1,DIKZK=1 diff -y --suppress-common-lines ./VADemo/r1/IBDX9510.m ./VADemo/r2/r/IBDX9510.m IBDX9510 ; COMPILED XREF FOR FILE #357.9511 ; 10/15/04 | IBDX9510 ; COMPILED XREF FOR FILE #357.9511 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX9511.m ./VADemo/r2/r/IBDX9511.m IBDX9511 ; COMPILED XREF FOR FILE #357.952 ; 10/15/04 | IBDX9511 ; COMPILED XREF FOR FILE #357.952 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX9512.m ./VADemo/r2/r/IBDX9512.m IBDX9512 ; COMPILED XREF FOR FILE #357.953 ; 10/15/04 | IBDX9512 ; COMPILED XREF FOR FILE #357.953 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX951.m ./VADemo/r2/r/IBDX951.m IBDX951 ; COMPILED XREF FOR FILE #357.95 ; 10/15/04 | IBDX951 ; COMPILED XREF FOR FILE #357.95 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX952.m ./VADemo/r2/r/IBDX952.m IBDX952 ; COMPILED XREF FOR FILE #357.9501 ; 10/15/04 | IBDX952 ; COMPILED XREF FOR FILE #357.9501 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX953.m ./VADemo/r2/r/IBDX953.m IBDX953 ; COMPILED XREF FOR FILE #357.951 ; 10/15/04 | IBDX953 ; COMPILED XREF FOR FILE #357.951 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX954.m ./VADemo/r2/r/IBDX954.m IBDX954 ; COMPILED XREF FOR FILE #357.9511 ; 10/15/04 | IBDX954 ; COMPILED XREF FOR FILE #357.9511 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX955.m ./VADemo/r2/r/IBDX955.m IBDX955 ; COMPILED XREF FOR FILE #357.952 ; 10/15/04 | IBDX955 ; COMPILED XREF FOR FILE #357.952 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX956.m ./VADemo/r2/r/IBDX956.m IBDX956 ; COMPILED XREF FOR FILE #357.953 ; 10/15/04 | IBDX956 ; COMPILED XREF FOR FILE #357.953 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX957.m ./VADemo/r2/r/IBDX957.m IBDX957 ; COMPILED XREF FOR FILE #357.95 ; 10/15/04 | IBDX957 ; COMPILED XREF FOR FILE #357.95 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX958.m ./VADemo/r2/r/IBDX958.m IBDX958 ; COMPILED XREF FOR FILE #357.9501 ; 10/15/04 | IBDX958 ; COMPILED XREF FOR FILE #357.9501 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX959.m ./VADemo/r2/r/IBDX959.m IBDX959 ; COMPILED XREF FOR FILE #357.951 ; 10/15/04 | IBDX959 ; COMPILED XREF FOR FILE #357.951 ; 03/13/00 diff -y --suppress-common-lines ./VADemo/r1/IBDX95.m ./VADemo/r2/r/IBDX95.m IBDX95 ; DRIVER FOR COMPILED XREFS FOR FILE #357.95 ; 10/15/ | IBDX95 ; DRIVER FOR COMPILED XREFS FOR FILE #357.95 ; 03/13/ Only in ./VADemo/r1/: IBDY358.m diff -y --suppress-common-lines ./VADemo/r1/IBECEA2.m ./VADemo/r2/r/IBECEA2.m ;;2.0;INTEGRATED BILLING;**57,52,150,176,183,240**;21 | ;;2.0;INTEGRATED BILLING;**57,52,150,176,183**;21-MAR ; - don't allow edit of TRICARE charges | ; - don't allow edit of CHAMPUS charges I $P($G(^IBE(350.1,+$P($G(^IB(IBN,0)),"^",3),0)),"^", | I $P($G(^IBE(350.1,+$P($G(^IB(IBN,0)),"^",3),0)),"^", diff -y --suppress-common-lines ./VADemo/r1/IBECEA35.m ./VADemo/r2/r/IBECEA35.m IBECEA35 ;ALB/CPM - Cancel/Edit/Add... TRICARE Support | IBECEA35 ;ALB/CPM - Cancel/Edit/Add... CHAMPUS Support ;;2.0;INTEGRATED BILLING;**52,240**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94 CUS ; Process all TRICARE copayment charges. | CUS ; Process all CHAMPUS copayment charges. ; - display TRICARE coverage | ; - display CHAMPUS coverage I IBATYPN["RX" D AMT^IBECEAU2 S IBDESC="TRICARE RX CO | I IBATYPN["RX" D AMT^IBECEAU2 S IBDESC="CHAMPUS RX CO .S IBDESC="TRICARE OPT COPAY",(IBEVDT,IBTO)=IBFR,IBEV | .S IBDESC="CHAMPUS OPT COPAY",(IBEVDT,IBTO)=IBFR,IBEV .S IBDG=$$ADSEL^IBECEA31(DFN),IBDESC="TRICARE INPT CO | .S IBDG=$$ADSEL^IBECEA31(DFN),IBDESC="CHAMPUS INPT CO W !,"Billing the TRICARE patient copayment charge..." | W !,"Billing the CHAMPUS patient copayment charge..." DISP(DFN,INS) ; Display TRICARE beneficiary insurance infor | DISP(DFN,INS) ; Display CHAMPUS beneficiary insurance infor I '$G(INS) W *7,!!,"Please note that this patient doe | I '$G(INS) W *7,!!,"Please note that this patient doe W !!," TRICARE coverage for ",$P($G(^DPT(DFN,0)),"^") | W !!," CHAMPUS coverage for ",$P($G(^DPT(DFN,0)),"^") diff -y --suppress-common-lines ./VADemo/r1/IBECEA3.m ./VADemo/r2/r/IBECEA3.m ;;2.0;INTEGRATED BILLING;**7,57,52,132,150,153,166,15 | ;;2.0;INTEGRATED BILLING;**7,57,52,132,150,153,166,15 ; - process TRICARE charges | ; - process CHAMPUS charges . I IBFR<$P(IBCLZ,"^",3) S IBCLDA=$O(^IBA(351.81,"AE" | . I IBFR<$P(IBCLZ,"^",3) S IBCLDA=$O(^IBA(351.81,"AE" ; - if LTC outpatient calculate the charge | ; - if LTC outpatient calcuate the charge diff -y --suppress-common-lines ./VADemo/r1/IBECEA4.m ./VADemo/r2/r/IBECEA4.m ;;2.0;INTEGRATED BILLING;**27,52,150,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**27,52,150**;21-MAR-94 ; - handle CHAMPVA/TRICARE charges | ; - handle CHAMPVA/CHAMPUS charges diff -y --suppress-common-lines ./VADemo/r1/IBECEA.m ./VADemo/r2/r/IBECEA.m IBECEA ;ALB/RLW - Cancel/Edit/Add Patient Charges ;12-JUN-92 | IBECEA ;ALB/RLW - Cancel/Edit/Add Patient Charges ; 12-JUN-9 ;;2.0; INTEGRATED BILLING ;**199,135**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 K XQORS,VALMEVL < EN1 ; Entrypoint to avoid killing XQORS < D EN^VALM("IB CHARGES") | K XQORS,VALMEVL D EN^VALM("IB CHARGES") EN1AR ; AR entry for charge maintenance < N DIR,X,Y < D EN1 < S DIR(0)="EA",DIR("A")="PRESS RETURN TO CONTINUE. " < W ! D ^DIR K DIR < Q < ; < N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBECEAU5.m ./VADemo/r2/r/IBECEAU5.m ;;2.0;INTEGRATED BILLING;**132,153,156,167,247**;21-M | ;;2.0;INTEGRATED BILLING;**132,153,156,167**;21-MAR-9 S IBTYP=$$UCCL^IBAMTI(IBTYP) S:IBTYP="SPECIAL" IBTYP= | S IBTYP=$S(IBTYP=1:"AGENT ORANGE",IBTYP=2:"IONIZING R diff -y --suppress-common-lines ./VADemo/r1/IBECPF.m ./VADemo/r2/r/IBECPF.m ;;2.0; INTEGRATED BILLING ;**199**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBECUS1.m ./VADemo/r2/r/IBECUS1.m IBECUS1 ;RLM/DVAMC - TRICARE PHARMACY BILLING ENGINES ; 14-AU | IBECUS1 ;RLM/DVAMC - CHAMPUS PHARMACY BILLING ENGINES ; 14-AU ;;2.0;INTEGRATED BILLING;**52,88,240,274**;21-MAR-94 | ;;2.0; INTEGRATED BILLING ;**52,88**; 21-MAR-94 S ZTDESC="IB - TRICARE Secondary Billing Task" | S ZTDESC="IB - CHAMPUS Secondary Billing Task" .N DIQUIET S DIQUIET=1,IBG=0 D DT^DICRW | .S DIQUIET=1,IBG=0 D DT^DICRW S ZTDESC="IB - TRICARE Secondary AWP Update Task" | S ZTDESC="IB - CHAMPUS Secondary AWP Update Task" diff -y --suppress-common-lines ./VADemo/r1/IBECUS21.m ./VADemo/r2/r/IBECUS21.m IBECUS21 ;RLM/DVAMC - FILE TRICARE PHARMACY TRANSACTIO | IBECUS21 ;RLM/DVAMC - FILE CHAMPUS PHARMACY TRANSACTIO ;;2.0;INTEGRATED BILLING;**52,240,274**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94 N DIQUIET S DIQUIET=1 D DT^DICRW S $P(^IBA(351.5,IBCH | S DIQUIET=1 D DT^DICRW S $P(^IBA(351.5,IBCHTRN,0),U,7 diff -y --suppress-common-lines ./VADemo/r1/IBECUS22.m ./VADemo/r2/r/IBECUS22.m IBECUS22 ;RLM/DVAMC - TRICARE PHARMACY BILLING UTILITI | IBECUS22 ;RLM/DVAMC - CHAMPUS PHARMACY BILLING UTILITI ;;2.0;INTEGRATED BILLING;**52,89,240,274**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,89**; 21-MAR-94 S XMDUN="TRICARE PHARMACY BILLING",XMDUZ=.5,XMSUB="Tr | S XMDUN="CHAMPUS PHARMACY BILLING",XMDUZ=.5,XMSUB="Tr N DIQUIET S DIQUIET=1 D DT^DICRW,^XMD | S DIQUIET=1 D DT^DICRW,^XMD diff -y --suppress-common-lines ./VADemo/r1/IBECUS2.m ./VADemo/r2/r/IBECUS2.m IBECUS2 ;DVAMC/RLM - TRICARE PHARMACY BILL TRANSACTION ;14-AU | IBECUS2 ;DVAMC/RLM - CHAMPUS PHARMACY BILL TRANSACTION ;14-AU ;;2.0;INTEGRATED BILLING;**52,89,143,162,240,274**;21 | ;;2.0;INTEGRATED BILLING;**52,89,143,162**; 21-MAR-94 N DIQUIET S DIQUIET=1 D DT^DICRW | S DIQUIET=1 D DT^DICRW ; - is patient covered by TRICARE? | ; - is patient covered by CHAMPUS? diff -y --suppress-common-lines ./VADemo/r1/IBECUS3.m ./VADemo/r2/r/IBECUS3.m IBECUS3 ;RLM/DVAMC - CANCEL TRICARE PHARMACY TRANSACTION ; 14 | IBECUS3 ;RLM/DVAMC - CANCEL CHAMPUS PHARMACY TRANSACTION ; 14 ;;2.0;INTEGRATED BILLING;**52,89,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,89**; 21-MAR-94 ; - is patient covered by TRICARE? | ; - is patient covered by CHAMPUS? diff -y --suppress-common-lines ./VADemo/r1/IBECUS.m ./VADemo/r2/r/IBECUS.m IBECUS ;RLM/DVAMC - TRICARE PHARMACY ENGINE OPTIONS ; 14-AUG | IBECUS ;RLM/DVAMC - CHAMPUS PHARMACY ENGINE OPTIONS ; 14-AUG ;;2.0;INTEGRATED BILLING;**52,240**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94 START ; Start the TRICARE Transaction and AWP Update engine | START ; Start the CHAMPUS Transaction and AWP Update engine .W !!,"The TRICARE Billing engines cannot be started! | .W !!,"The CHAMPUS Billing engines cannot be started! S ZTDESC="IB - TRICARE Primary Billing Task" | S ZTDESC="IB - CHAMPUS Primary Billing Task" W !!,"The TRICARE billing engine has been queued as t | W !!,"The CHAMPUS billing engine has been queued as t S ZTDESC="IB - TRICARE Primary AWP Update Task" | S ZTDESC="IB - CHAMPUS Primary AWP Update Task" STOP ; Shut down the TRICARE Transaction and AWP Update en | STOP ; Shut down the CHAMPUS Transaction and AWP Update en W !!,"The TRICARE Billing and AWP Update engines will | W !!,"The CHAMPUS Billing and AWP Update engines will diff -y --suppress-common-lines ./VADemo/r1/IBECUSM.m ./VADemo/r2/r/IBECUSM.m IBECUSM ;DVAMC/RLM - TRICARE PHARMACY BILLING OPTIONS; 20-AUG | IBECUSM ;DVAMC/RLM - CHAMPUS PHARMACY BILLING OPTIONS; 20-AUG ;;2.0;INTEGRATED BILLING;**52,162,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,162**;21-MAR-94 I '$P($G(^IBE(350.9,1,9)),"^",4) W !!,"Please note th | I '$P($G(^IBE(350.9,1,9)),"^",4) W !!,"Please note th I '$P($G(^IBE(350.9,1,9)),"^",4) W !!,"Please note th | I '$P($G(^IBE(350.9,1,9)),"^",4) W !!,"Please note th I '$P($G(^IBE(350.9,1,9)),"^",4) W !!,"Please note th | I '$P($G(^IBE(350.9,1,9)),"^",4) W !!,"Please note th diff -y --suppress-common-lines ./VADemo/r1/IBECUSO.m ./VADemo/r2/r/IBECUSO.m IBECUSO ;RLM/DVAMC - TRICARE PHARMACY BILLING OUTPUTS ; 21-AU | IBECUSO ;RLM/DVAMC - CHAMPUS PHARMACY BILLING OUTPUTS ; 21-AU ;;2.0;INTEGRATED BILLING;**52,240**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94 .S ZTRTN="REJDQ^IBECUSO",ZTDESC="IB - LIST TRICARE PH | .S ZTRTN="REJDQ^IBECUSO",ZTDESC="IB - LIST CHAMPUS PH .S ZTRTN="TRNDQ^IBECUSO",ZTDESC="IB - LIST TRICARE PH | .S ZTRTN="TRNDQ^IBECUSO",ZTDESC="IB - LIST CHAMPUS PH diff -y --suppress-common-lines ./VADemo/r1/IBEFUNC2.m ./VADemo/r2/r/IBEFUNC2.m ;;2.0;INTEGRATED BILLING;**51,266**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**51**;21-MAR-94 MODLST(MODS,DESC,IBMOD,IBDATE) ; Function returns string of | MODLST(MODS,DESC,IBMOD) ; Function returns string of actual m ; IBDATE = Date of Service (opt) for the versioned te < ; < . S Z0=$$MOD^ICPTMOD(IBP,"I",$G(IBDATE)) Q:Z0<0 | . S Z0=$$MOD^ICPTMOD(IBP,"I") Q:Z0<0 diff -y --suppress-common-lines ./VADemo/r1/IBEFUNC.m ./VADemo/r2/r/IBEFUNC.m ;;2.0;INTEGRATED BILLING;**55,91,106,139,51,153,232,1 | ;;2.0;INTEGRATED BILLING;**55,91,106,139,51,153**;21- I $$COB^IBCEF(IBIFN)="A" S IBOK=0 G REQMRAQ ; paye < I '$$EDIACTV^IBCEF4(2) S IBOK="R1" G REQMRAQ ; Site p | I '$$EDIACTV^IBCEF4(,2) S IBOK="R1" G REQMRAQ ; Site F Z=1:1:3 I $$WNRBILL(IBIFN,Z) S IBON=$S(Q'Z:1,1:2)_ diff -y --suppress-common-lines ./VADemo/r1/IBEMTBC.m ./VADemo/r2/r/IBEMTBC.m ;;2.0;INTEGRATED BILLING;**153,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**153**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBEPAR.m ./VADemo/r2/r/IBEPAR.m ;;2.0;INTEGRATED BILLING;**133,51,153,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**133,51,153**;21-MAR-94 W ?4,"Default RX Dx Cd : " S X=$$ICD9^IBACSV(+$P(IB | W ?4,"Default RX Dx Cd : " S X=$G(^ICD9(+$P(IBEPAR( W ?47,"Default RX CPT Cd : " S X=$$CPT^IBACSV(+$P(IB | W ?47,"Default RX CPT Cd : " S X=$$CPT^ICPTCOD(+$P(I diff -y --suppress-common-lines ./VADemo/r1/IBJDB21.m ./VADemo/r2/r/IBJDB21.m ;;2.0;INTEGRATED BILLING;**123,159,185**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94 ...I IBEP=1,IBSISP'="A",'$D(IBSISP(+$P(IBPRSP,U,3))) | ...I IBEP=1,IBSISP'="A",'$D(IBSISP(+$P(IBPRSP,"^",3)) ...I IBEP=2,IBSOSP'="A",'$D(IBSOSP(+$P(IBPRSP,U,3))) | ...I IBEP=2,IBSOSP'="A",'$D(IBSOSP(+$P(IBPRSP,"^",3)) ...S IBPRV=$S($P(IBPRSP,U,2)'="":$P(IBPRSP,U,2),1:"** | ...S IBPRV=$S($P(IBPRSP,"^",2)'="":$P(IBPRSP,"^",2),1 ...S IBSPC=$S($P(IBPRSP,U,4)'="":$P(IBPRSP,U,4),1:"** | ...S IBSPC=$S($P(IBPRSP,"^",4)'="":$P(IBPRSP,"^",4),1 ..D DEM^VADPT S IBPT=$E(VADM(1),1,25),IBSSN=$P(VADM(2 | ..D DEM^VADPT S IBPT=$E(VADM(1),1,25),IBSSN=$P(VADM(2 ..S ^TMP("IBJDB2",$J,IBDIV,IBEP,IBSORT1,IBPT_"@@"_$E( | ..S ^TMP("IBJDB2",$J,IBDIV,IBEP,IBSORT1,IBPT_"@@"_$E( S ENC=+$P(X,U,4) ; Encounter (Pointer to #409. | S ENC=+$P(X,"^",4) ; Encounter (Pointer to #40 S ADM=+$P(X,U,5) ; Admission (Pointer to #405) | S ADM=+$P(X,"^",5) ; Admission (Pointer to #40 S PRST=+$P(X,U,9) ; Prothetics (Pointer to #660) | S PRST=+$P(X,"^",9) ; Prothetics (Pointer to #66 S EPDT=$P(X,U,6) ; Episode Date (FM format) | S EPDT=$P(X,"^",6) ; Episode Date (FM format) S X=$G(^DGPM(ADM,0)) G QAMT:X="" S PTF=$P(X,U,16) G Q | S X=$G(^DGPM(ADM,0)) G QAMT:X="" S PTF=$P(X,"^",16) G S ADMDT=$P(X,U)\1,DFN=+$P(X,U,3) | S ADMDT=$P(X,"^")\1,DFN=+$P(X,"^",3) I $P(X,U,17) S DCHD=$P($G(^DGPM(+$P(X,U,17),0)),U)\1 | I $P(X,"^",17) S DCHD=$P($G(^DGPM(+$P(X,"^",17),0))," .S X=^TMP($J,"IBCRC-INDT",BLDT) | . S X=^TMP($J,"IBCRC-INDT",BLDT) .S BLBS=$P(X,U,2),DRG=$P(X,U,4),DIV=$P(X,U,5) | . S BLBS=$P(X,"^",2),DRG=$P(X,"^",4),DIV=$P(X,"^",5) .; | . ; .; - Tort Liable Charge (prior to 09/01/99) | . ; - Tort Liable Charge (prior to 09/01/99) .I BLDT<2990901 D Q | . I BLDT<2990901 D Q ..S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATI | . . S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPA .; | . ; .; - Reasonable Charges (on 09/01/99 or later) | . ; - Reasonable Charges (on 09/01/99 or later) .S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATIE | . S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATI S AMOUNT=AMOUNT-$$CLAMT(DFN,EPDT,1) | S AMOUNT=AMOUNT-$$CLAMT(DFN,EPDT) S X=$$GETOE^SDOE(ENC),ENCDT=+$P(X,U),DFN=+$P(X,U,2),D | S X=$$GETOE^SDOE(ENC),ENCDT=+$P(X,"^"),DFN=+$P(X,"^", .S CPT=+CPTLST(VCPT) | . S CPT=+CPTLST(VCPT) .S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,3,ENCDT,"PROCED | . S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,3,ENCDT,"PROCE S AMOUNT=AMOUNT-$$CLAMT(DFN,EPDT,0) | S AMOUNT=AMOUNT-$$CLAMT(DFN,EPDT) QAMT I AMOUNT<0 S AMOUNT=0 | QAMT S:AMOUNT<0 AMOUNT=0 Q AMOUNT Q AMOUNT < CLAMT(DFN,EPDT,PT) ; Returns the Total Amount of Claims | CLAMT(DFN,EPDT) ; Returns the Total Amount of Claims for th P ; Input: DFN - Pointer to the Patient File #2 | ; Input: DFN - Pointer to the Patient File #2 ; EPDT - Episode Date | ; EPDT- Episode Date ; PT - 0=Outpatient, 1=Inpatient < > ; F S CLM=$O(^DGCR(399,"C",DFN,CLM)) Q:'CLM D | F S DAY=$O(^DGCR(399,"AOPV",DFN,DAY)) Q:'DAY D .S X=$G(^DGCR(399,CLM,0)) | . F S CLM=$O(^DGCR(399,"AOPV",DFN,DAY,CLM)) Q:'CLM .I $P($P(X,U,3),".")=$P(EPDT,".") D | . . S IBD=$$CKBIL^IBTUBOU(CLM) I IBD="" Q ..S IBD=$$CKBIL^IBTUBOU(CLM,PT) Q:IBD="" | . . I '$P(IBD,"^",3) Q ; Not Authorized ..I '$P(IBD,U,3) Q ; Not authorized | . . I $P(IBD,"^",5)'=EPDT Q ; Event date and Episode ..S CLAMT=CLAMT+$G(^DGCR(399,CLM,"U1")) | . . S CLAMT=CLAMT+$G(^DGCR(399,CLM,"U1")) S Z=$G(^IBE(356.19,M,1)) I $P(Z,U,12) S AVG=$P(Z,U,11 | S Z=$G(^IBE(356.19,M,1)) I $P(Z,"^",12) S AVG=$P(Z,"^ ; Input: EPS - Episode(1 = Inpatient OR 2 = Outpatie | ; Input: EPS - Episode(1 = Inpatient OR 2 = Outpatien ; CLM - Pointer to Claim Tracking File (#356) | ; CLM - Pointer to Claim Tracking File (#356) ; Output: Provider Code (Pointer to #200) ^ Provider | ;Output: Provider Code (Pointer to #200) ^ Provider N ; Specialty Code (Pointer to #40.7 or #45.7) | ; Specialty Code (Pointer to #40.7 or #45.7) ^ S DFN=$P(X,U,2),ENC=$P(X,U,4),ADM=$P(X,U,5),PRS=$P(X, | S DFN=$P(X,"^",2),ENC=$P(X,"^",4),ADM=$P(X,"^",5),PRS .S X=$G(^DGPM(ADM,0)),VAINDT=$P(X,U)\1 I 'VAINDT Q | . S X=$G(^DGPM(ADM,0)),VAINDT=$P(X,"^")\1 I 'VAINDT Q .D INP^VADPT S PRV=$G(VAIN(11)),SPC=$G(VAIN(3)) | . D INP^VADPT S PRV=$G(VAIN(11)),SPC=$G(VAIN(3)) .S:PRV="" PRV="^" S:SPC="" SPC="^" | . S:PRV="" PRV="^" S:SPC="" SPC="^" .D GETPRV^SDOE(ENC,"PRVLST") | . D GETPRV^SDOE(ENC,"PRVLST") .S (X,PRI)="" | . S (X,PRI)="" .F S X=$O(PRVLST(X),-1) Q:X=""!PRI D | . F S X=$O(PRVLST(X),-1) Q:X=""!PRI D ..N IBX S PRV=+PRVLST(X) | . . S PRV=+PRVLST(X) ..I $P(PRVLST(X),U,4)="P" S PRI=1 ; Primary provider | . . I $P(PRVLST(X),"^",4)="P" S PRI=1 ; - Primary ..I PRV S PRV=PRV_U_$P($G(^VA(200,+PRV,0)),U) | . I PRV S PRV=PRV_"^"_$P($G(^VA(200,+PRV,0)),"^") ..S IBX=$$GETOE^SDOE(ENC),STP=$P(IBX,U,3) | . S X=$$GETOE^SDOE(ENC),STP=$P(X,"^",3) ..I STP'="" S SPC=STP_U_$P($G(^DIC(40.7,STP,0)),U) | . I STP'="" S SPC=STP_"^"_$P($G(^DIC(40.7,STP,0)),"^" ; | QPS Q (PRV_"^"_SPC) QPS Q (PRV_U_SPC) < diff -y --suppress-common-lines ./VADemo/r1/IBJDB2.m ./VADemo/r2/r/IBJDB2.m ;;2.0;INTEGRATED BILLING;**123,185**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94 ENQ1 K IBBDT,IBCLK,IBD,IBEDT,IBEPD,IBEPS,IBEXCEL,IBPRT,IBR | ENQ1 K IBBDT,IBCLK,IBD,IBEDT,IBEPD,IBEXCEL,IBRPT,IBSD,IBSE K IBSORT,IBSISP,IBSOSP,IBSPRV,IBSRNB | K IBSOSP,IBSPRV,IBSRNB diff -y --suppress-common-lines ./VADemo/r1/IBJDE1.m ./VADemo/r2/r/IBJDE1.m ;;2.0;INTEGRATED BILLING;**100,118,123,159,254,244**; | ;;2.0;INTEGRATED BILLING;**100,118,123,159**;21-MAR-9 S DT=$$DT^XLFDT | F S IB0=$O(^IBE(351.71,IB0)) Q:'IB0 S IBN=^(IB0,0) F S IB0=$O(^IBE(351.71,IB0)) Q:'IB0 S IBN=$G(^(IB0, | .; - Do not process for future months .; - Do not process for invalid (day not equal 00 or | .I IB0>DT Q .; and remove data. | .; .I (+$E(IB0,6,7)>0)!(IB0>DT) D Q < ..W !,"** Invalid date entry found. Entry ("_IB0_") < ..S DIK="^IBE(351.71,",DA=IB0 < ..D ^DIK < .; - Check for missing zero node. < .I IBN="" W !,"Zero node data missing for "_IB0_" ent < ..I $D(^IBE(351.71,"B",IB2,IB2))!(IB2>DT) Q | ..I $D(^IBE(351.71,"B",IB2,IB2)) Q .Q:IB0=37 ; No unbilled report needed < diff -y --suppress-common-lines ./VADemo/r1/IBJDE.m ./VADemo/r2/r/IBJDE.m ;;2.0;INTEGRATED BILLING;**100,118,123,235,248,254,24 | ;;2.0;INTEGRATED BILLING;**100,118,123**;21-MAR-94 I $E(DT,6,7)=$E($$LDATE(DT)+1,6,7) S IBDT=$E($P($$M1( < I $E(IBDT,6,7)'="00" S IBDT=$E(IBDT,1,5)_"00" < N IBUNBILL | S IBA0=0 F S IBA0=$O(^IBE(351.7,IBA0)) Q:'IBA0 S IB I $E(DT,6,7)=$E($$LDATE(DT)+1,6,7) S IBA0=$O(^IBE(351 | .; S IBA0=0 F S IBA0=$O(^IBE(351.7,IBA0)) Q:'IBA0 S IB | .I $P(IBN0,U,2) Q ; Report has G ENQ | .I $D(^IBE(351.71,"AD",3,IBDT,IBA0)) Q ; Extract of ; | .; EXTRACT I $P(IBN0,U,2) Q ; Report has b | .I '$D(^IBE(351.71,IBDT,1,IBA0,0)) D ; Create REPORT I $D(^IBE(351.71,"AD",3,IBDT,IBA0)) Q ; Extract of r | ..S DIC="^IBE(351.71,"_IBDT_",1,",DIC(0)="L",DIC("DR" ; | ..S DIC("P")="351.711P",DA(1)=IBDT,(DA,DINUM,X)=IBA0 I '$D(^IBE(351.71,IBDT,1,IBA0,0)) D ; Create REPORT | ..D FILE^DICN K DA,DIC,DINUM,DD,DO .S DIC="^IBE(351.71,"_IBDT_",1,",DIC(0)="L",DIC("DR") | .; .S DIC("P")="351.711P",DA(1)=IBDT,(DA,DINUM,X)=IBA0 K | .; - Set input variables. .D FILE^DICN K DA,DIC,DINUM,DD,DO | .S IBA1=0 N ZTIO,ZTDESC,ZTSK,ZTDTH,ZTRTN,ZTSAVE ; | .F S IBA1=$O(^IBE(351.7,IBA0,1,IBA1)) Q:'IBA1 S IBN ; - Set input variables. | ..I $D(^IBE(351.7,IBA0,1,IBA1,1)) X ^(1) S IBA1=0 N ZTIO,ZTDESC,ZTSK,ZTDTH,ZTRTN,ZTSAVE | ..E S IBV=$P(IBN1,U),@(IBV)=$P(IBN1,U,2),ZTSAVE(IBV) F S IBA1=$O(^IBE(351.7,IBA0,1,IBA1)) Q:'IBA1 S IBN1 | .; .I $D(^IBE(351.7,IBA0,1,IBA1,1)) X ^(1) | .; - Set other ZT* variables for queueing. .E S IBV=$P(IBN1,U),@(IBV)=$P(IBN1,U,2),ZTSAVE(IBV)= | .S ZTDESC=$P(IBN0,U),ZTSAVE("IBXTRACT")=1,ZTIO="" ; | .I $G(IBX) S ZTSAVE("IBXDATE")=IBDT ; Date from DME m ; - Set other ZT* variables for queueing. | .S ZTRTN=$G(^IBE(351.7,IBA0,2)) Q:ZTRTN="" I ZTRTN'[ S ZTSAVE("IBUNBILL")="" | .S IBS=IBS+300,%=IBS D S^%DTC S ZTDTH=$P(IBRD,".")_% S ZTDESC=$P(IBN0,U),ZTSAVE("IBXTRACT")=1,ZTIO="" | .D ^%ZTLOAD I $G(IBX) S ZTSAVE("IBXDATE")=IBDT ; Date from DME ma < S ZTRTN=$G(^IBE(351.7,IBA0,2)) Q:ZTRTN="" I ZTRTN'[" < S IBS=IBS+300,%=IBS D S^%DTC S ZTDTH=$P(IBRD,".")_% ; < D ^%ZTLOAD < Q < > G ENQ S IBDT=$S($G(IBXDATE):$E(IBXDATE,1,5)_"00",'$G(IBUNBI | S IBDT=$S($G(IBXDATE):IBXDATE,1:$$M1(DT,1)) I 'J G E1 I $G(IBUNBILL) G E2 < E2 D NOW^%DTC S DIE="^IBE(351.71,"_IBDT_",1,",DR=".02/// | D NOW^%DTC S DIE="^IBE(351.71,"_IBDT_",1,",DR=".02/// M3(X) ;Beginning date 365 days prior < N X1,X2 < S X1=X,X2=-365 D C^%DTC < Q X < LDATE(X) ; DETERMINE CUT-OFF DATE FOR THE MONTH < S X=$E(X,1,5)_$P("31^28^31^30^31^30^31^31^30^31^30^31 < I +$E(X,6,7)=28,$E(X,2,3)#4=0 S $E(X,6,7)=29 < S X=$$WORKPLUS^XUWORKDY(X,-3) < Q X < diff -y --suppress-common-lines ./VADemo/r1/IBJDF11.m ./VADemo/r2/r/IBJDF11.m ;;2.0;INTEGRATED BILLING;**69,80,118,128,204,205,227* | ;;2.0;INTEGRATED BILLING;**69,80,118,128,204**;21-MAR .I IBSMN S:"Aa"[IBSDATE IBARD=$$ACT^IBJDF2(IBA) S:"Dd | .I IBSMN S IBARD=+$$ACT^IBJDF2(IBA) S:IBARD IBARD=$$F .S IBWRC=$S('$P(IBWRC,U,4):"",$P(IBWRC,U,22):$P(IBWRC | .S IBWRC=$S($P(IBWRC,U,22):$P(IBWRC,U,22),1:$P(IBWRC, diff -y --suppress-common-lines ./VADemo/r1/IBJDF12.m ./VADemo/r2/r/IBJDF12.m ;;2.0;INTEGRATED BILLING;**69,118,128,123,204,205**;2 | ;;2.0;INTEGRATED BILLING;**69,118,128,123,204**;21-MA W "Third Party Follow-Up Report"_$S(IBSDATE="D":" ( d | W "Third Party Follow-Up Report" diff -y --suppress-common-lines ./VADemo/r1/IBJDF1H.m ./VADemo/r2/r/IBJDF1H.m ;;2.0;INTEGRATED BILLING;**69,118,128,205**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**69,118,128**;21-MAR-94 ; < ; - 'Run report for (D)ATE OF CARE or (A)CTIVE IN AR. < ;; Enter: '' - To calculate report by Days < ;; 'D' - To to calculate report by D < ;; '^' - To quit this option < ;;*END* < diff -y --suppress-common-lines ./VADemo/r1/IBJDF1.m ./VADemo/r2/r/IBJDF1.m ;;2.0;INTEGRATED BILLING;**69,118,128,205**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**69,118,128**;21-MAR-94 DATE ; - Choose date to use for calculation < W !!,"Calculate report using (D)ATE OF CARE or (A)CTI < G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X) < I "ADad"'[X S IBOFF=99 D HELP^IBJDF1H G DATE < W " ",$S("Dd"[X:"DATE OF CARE",1:"(DAYS) ACTIVE IN A < S IBSDATE=$S("Dd"[X:"D",1:"A") < ; < AGE ;-Determine the active receivable age range. | AGE ; - Determine the active receivable age range. K IBSAM,IBSDATE,IBSMN,IBSMX,IBSRC,IBTEXT,IBI,POP,VAUT | K IBSAM,IBSMN,IBSMX,IBSRC,IBTEXT,IBI,POP,VAUTD,%ZIS,Z K DIROUT,DTOUT,DUOUT,DIRUT < diff -y --suppress-common-lines ./VADemo/r1/IBJDF2.m ./VADemo/r2/r/IBJDF2.m ;;2.0;INTEGRATED BILLING;**69,91,100,118,133,205**;21 | ;;2.0;INTEGRATED BILLING;**69,91,100,118,133**;21-MAR DATE ; - Choose date to use for calculation < W !!,"Calculate report using (D)ATE OF CARE or (A)CTI < G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X) < I "ADad"'[X S IBOFF=99 D HELP^IBJDF1H G DATE < W " ",$S("Dd"[X:"DATE OF CARE",1:"(DAYS) ACTIVE IN A < S IBSDATE=$S("Dd"[X:"D",1:"A") < ; < .F I="IBSEL","IBSDATE","IBSORT","VAUTD","VAUTD(" S ZT | .F I="IBSEL","IBSORT","VAUTD","VAUTD(" S ZTSAVE(I)="" .S:"Aa"[IBSDATE IBARD=$$ACT(IBA) S:"Dd"[IBSDATE IBARD | .S IBARD=$$ACT(IBA) I 'IBARD Q ; No activation date. ENQ1 K IB,IBOFF,IBQ,IBSDATE,IBSEL,IBSORT,IBTEXT,IBA,IBAR,I | ENQ1 K IB,IBQ,IBSEL,IBSORT,IBA,IBAR,IBARD,IBDIV,IBAGE,IBOU .S IBTYPH=$S(IBTYP=1:"INPATIENT",IBTYP=2:"OUTPATIENT" | .S IBTYPH=$S(IBTYP=1:"INPATIENT",IBTYP=2:"OUTPATIENT" DATE1(X) ; - Determine the Date of Care < N Y S Y=0 I '$G(X) G DATEQ < S Y=$P($G(^DGCR(399,X,"U")),U,2) I Y G DATEQ < DATEQ Q Y < ; < diff -y --suppress-common-lines ./VADemo/r1/IBJDF4H.m ./VADemo/r2/r/IBJDF4H.m IBJDF4H ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (HELP) ;15-APR | IBJDF4H ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (HELP);15-APR- ;;2.0;INTEGRATED BILLING;**123,220**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94 ;; (Zero "0" not a valid minimum) < diff -y --suppress-common-lines ./VADemo/r1/IBJDF4.m ./VADemo/r2/r/IBJDF4.m IBJDF4 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT ;15-APR-00 | IBJDF4 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT;15-APR-00 ;;2.0;INTEGRATED BILLING;**123,204,220**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123,204**;21-MAR-94 W !,"EXAMPLE Range: 31-60 days" | S DIR(0)="NA^0:99999" S DIR(0)="NA^1:99999" < ; reports: Emergency/Humanitarian, Ineligible receiva | ; reports: Emergency/Humanitarian, Inelible receivabl diff -y --suppress-common-lines ./VADemo/r1/IBJDF51.m ./VADemo/r2/r/IBJDF51.m IBJDF51 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (COMPILE); | IBJDF51 ;ALB/RB - CHAMPVA/CHAMPUS-TRICARE FOLLOW-UP REPORT (C ;;2.0;INTEGRATED BILLING;**123,185,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94 . . S IBQ=$$STOP^IBOUTL("CHAMPVA/Tricare Follow-Up Re | . . S IBQ=$$STOP^IBOUTL("CHAMPVA/CHAMPUS (Tricare) Fo . . S IBDIV=$$DIV(IBA) | . . S IBDIV=$$DIV^IBJD1(IBA) ENQ1 K IB,IBA,IBA1,IBAR,IBARD,IBBU,IBC,IBCAT,IBCAT1,IBDIV, | ENQ1 K IBA,IBA1,IBAR,IBARD,IBBU,IBC,IBCAT,IBCAT1,IBDIV,IBD K IBDP,IBKEY,IBVA,IBAC,IBBA,IBBN,IBFR,IBIN,IBOI,IBOR, | K IBKEY,IBVA,IBAC,IBBA,IBBN,IBFR,IBIN,IBOI,IBOR,IBSID K COM,COM1,DAT,DFN,J,X,X1,X2,Y,Z D KVA^VADPT | K COM,COM1,DAT,DFN,J,X,X1,X2,Y,Z DIV(CLM) ;Find the default division of the bill. < S DIV=$P($G(^DGCR(399,CLM,0)),"^",22) < QDIV S:'DIV DIV=$$PRIM^VASITE() S:DIV'>0 DIV=0 < Q DIV < diff -y --suppress-common-lines ./VADemo/r1/IBJDF52.m ./VADemo/r2/r/IBJDF52.m IBJDF52 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (PRINT) ;1 | IBJDF52 ;ALB/RB - CHAMPVA/CHAMPUS-TRICARE FOLLOW-UP REPORT (P ;;2.0;INTEGRATED BILLING;**123,159,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94 . W "CHAMPVA/TRICARE Follow-Up Report" | . W "CHAMPVA/CHAMPUS (Tricare) Follow-Up Report" S IBQ=$$STOP^IBOUTL("CHAMPVA/TRICARE Follow-Up Report | S IBQ=$$STOP^IBOUTL("CHAMPVA/CHAMPUS-Tricare Follow-U diff -y --suppress-common-lines ./VADemo/r1/IBJDF53.m ./VADemo/r2/r/IBJDF53.m IBJDF53 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (SUMMARY); | IBJDF53 ;ALB/RB - CHAMPVA/CHAMPUS (TRICARE) FOLLOW-UP REPORT ;;2.0;INTEGRATED BILLING;**123,185,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94 . I IBCT=31 S IBTP=1 ; TRICARE Patient | . I IBCT=31 S IBTP=1 ; CHAMPUS/Tricare Patient . I IBCT=30 S IBTP=2 ; TRICARE | . I IBCT=30 S IBTP=2 ; CHAMPUS . I IBCT=32 S IBTP=3 ; TRICARE THIRD PARTY | . I IBCT=32 S IBTP=3 ; CHAMPUS THIRD PARTY N IBDH,IBTYP,IBTYPH,I,J | N IBTYP,IBTYPH,I,J W "CHAMPVA/TRICARE FOLLOW-UP SUMMARY REPORT" | W "CHAMPVA/CHAMPUS-TRICARE FOLLOW-UP SUMMARY REPORT" diff -y --suppress-common-lines ./VADemo/r1/IBJDF5H.m ./VADemo/r2/r/IBJDF5H.m IBJDF5H ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (HELP);15- | IBJDF5H ;ALB/RB - CHAMPVA/CHAMPUS-TRICARE FOLLOW-UP REPORT (H ;;2.0;INTEGRATED BILLING;**123,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94 diff -y --suppress-common-lines ./VADemo/r1/IBJDF5.m ./VADemo/r2/r/IBJDF5.m IBJDF5 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT;15-APR-00 | IBJDF5 ;ALB/RB - CHAMPVA/CHAMPUS-TRICARE FOLLOW-UP REPORT;15 ;;2.0;INTEGRATED BILLING;**123,185,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94 S IBCTG(1)="TRICARE PATIENT" | S IBCTG(1)="CHAMPUS/TRICARE PATIENT" S IBCTG(3)="TRICARE" | S IBCTG(3)="CHAMPUS" S IBCTG(4)="TRICARE THIRD PARTY" | S IBCTG(4)="CHAMPUS THIRD PARTY" . W !!,"NOTE: Tricare Patient receivables will NOT be | . W !!,"NOTE: CHAMPUS/Tricare Patient receivables wil .S ZTRTN="DQ^IBJDF5",ZTDESC="IB - CHAMPVA/TRICARE FOL | .S ZTRTN="DQ^IBJDF5",ZTDESC="IB - CHAMPVA/CHAMPUS FOL ; reports: Tricare Patient, Sharing Agreements, TRICA | ; reports: CHAMPUS/Tricare, Sharing Agreements, CHAMP K IBPRT,IBCTG,IBRPT,IBTPR,IBSMN,IBSMX,IBTEXT,IBI,IBEX | K IBCTG,IBRPT,IBTPR,IBSMN,IBSMX,IBTEXT,IBI,IBEXCEL,DI K DTOUT,DIRUT,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X, | K DIRUT,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X,Y diff -y --suppress-common-lines ./VADemo/r1/IBJDF7H.m ./VADemo/r2/r/IBJDF7H.m ;;2.0;INTEGRATED BILLING;**123,240**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94 ; - 'Minimum number of days defaulted:' prompt (Offse | ; - 'Minimun number of days defaulted:' prompt (Offse ;; TRICARE TRICARE Patient TRICAR | ;; CHAMPUS CHAMPUS Patient CHAMPU ;; Enter: 'Y' - To print the total for patien | ;; Enter: 'Y' - To print the total for patien diff -y --suppress-common-lines ./VADemo/r1/IBJDF811.m ./VADemo/r2/r/IBJDF811.m IBJDF811 ;ALB/RRG - AR PRODUCTIVITY REPORT (COMPILE-co | IBJDF811 ;ALB/RRG- AR PRODUCTIVITY REPORT (COMPILE-con ;;2.0;INTEGRATED BILLING;**123,159,192**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94 . S TRXCAT=5,TRXCATN="DEC.ADJ./CONTR",TRXTYPN="DEC.AD | . S TRXCAT=5,TRXCATN="DEC.ADJ./CONTR",TRXTYPN="DECREA . S TRXCAT=6,TRXCATN="DEC.ADJ./NON-CONTR",TRXTYPN="DE | . S TRXCAT=6,TRXCATN="DEC.ADJ./NON-CONTR",TRXTYPN="DE diff -y --suppress-common-lines ./VADemo/r1/IBJDF81.m ./VADemo/r2/r/IBJDF81.m ;;2.0;INTEGRATED BILLING;**123,159,192**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94 . . . S IBTR0=$G(^PRCA(433,IBTRDA,0)) | . . . S IBTR0=$G(^PRCA(433,IBTRDA,0)),IBARDA=$P(IBTR0 . . . S IBARDA=$P(IBTR0,"^",2) Q:IBARDA="" < . . . S IBAR0=$G(^PRCA(430,IBARDA,0)) | . . . S IBAR0=$G(^PRCA(430,IBARDA,0)) Q:'IBAR0 . . . I 'IBAR0!($P(IBAR0,"^",8)=8) Q ; No AR bill/bi < ;F S IBACTDT=$O(^PRCA(430,"ACTDT",IBACTDT)) Q:'IBACT | F S IBACTDT=$O(^PRCA(430,"ACTDT",IBACTDT)) Q:'IBACTD F S IBACTDT=$O(^PRCA(430,"ACTDT",IBACTDT)) Q:'IBACTD < I $T(@IBTRTP^IBJDF811)'="" D @(IBTRTP_"^IBJDF811") | I $T(@IBTRTP^IBJDF811)'="" D @IBTRTP^IBJDF811 diff -y --suppress-common-lines ./VADemo/r1/IBJDF8.m ./VADemo/r2/r/IBJDF8.m ;;2.0;INTEGRATED BILLING;**123,159,192**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94 ;;OTHER;;1|3|4|5|6|7|12|13|15|16|17|18|19|20|21|22|24 | ;;OTHER;;3|4|5|6|7|12|13|15|16|17|18|19|20|21|22|24|2 diff -y --suppress-common-lines ./VADemo/r1/IBJDF8R.m ./VADemo/r2/r/IBJDF8R.m ;;2.0;INTEGRATED BILLING;**123,159,192**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**159**;21-MAR-94 Only in ./VADemo/r1/: IBJDIPR.m Only in ./VADemo/r1/: IBJPI2.m Only in ./VADemo/r1/: IBJPI.m diff -y --suppress-common-lines ./VADemo/r1/IBJPM.m ./VADemo/r2/r/IBJPM.m ;;2.0;INTEGRATED BILLING;**39,137,184**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**39,137**;21-MAR-94 ; DAOU/BHS - Added 13-JUN-2002 < S IBLR=2,IBLN=IBGRPB < ; < ; DAOU/BHS - Added 13-JUN-2002 < ; - IIV Parameters < S IBLN=$$SETN("Insurance Id and Verification",IBLN,IB < S IBLN=$$SET("","General Parameters",IBLN,IBLR) < S IBLN=$$SET("","Batch Extracts Parameters",IBLN,IBLR < S IBLN=$$SET("","Patients Without Insurance",IBLN,IBL < S IBLN=$$SET("","Most Popular Insurance",IBLN,IBLR) < ; < diff -y --suppress-common-lines ./VADemo/r1/IBJPS2.m ./VADemo/r2/r/IBJPS2.m ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,1 | ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161** S IBLN=$$SET(" Allow MRA Processing?",$$YN(+$P(IBPD8, < S IBLN=$$SET(" Enable Automatic MRA Processing?",$$YN < diff -y --suppress-common-lines ./VADemo/r1/IBJPS.m ./VADemo/r2/r/IBJPS.m ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,16 | ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,16 15 ;;2.11;8.01;8.09;8.03;8.06;8.04;8.07;8.02;8.12T;8.11T | 15 ;;8.1;2.11;8.01;8.09;8.03;8.06;8.04;8.07;8.02 Only in ./VADemo/r1/: IBJTBA1.m diff -y --suppress-common-lines ./VADemo/r1/IBJTBA.m ./VADemo/r2/r/IBJTBA.m ;;2.0;INTEGRATED BILLING;**39,80,51,137,135**;21-MAR- | ;;2.0;INTEGRATED BILLING;**39,80,51,137**;21-MAR-94 N IBOK,IBEOBDET < S IBFT=+$P($G(^DGCR(399,+IBIFN,0)),U,19),IBOK=1 | S IBFT=+$P($G(^DGCR(399,+IBIFN,0)),U,19) I $D(^IBM(361.1,"B",IBIFN))!$D(^IBM(361.1,"C",IBIFN)) < . S DIR("A")="DO YOU WANT ALL EEOB DETAILS?: ",DIR("B < . D FULL^VALM1 W ! D ^DIR K DIR < . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q < . S IBEOBDET=+Y < ; < N IBI,Z,IBSTR,IBSHEOB,IBCT | N X,IBFST,IBPT,IBCN,IBM,IBM1,IBM2,IBI,IBTY,IBPY,IBPR, S IBCT=0 | S IBFST=0 S IBI=0 F S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI | S IBI=0 F S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI S IBI=0 F S IBI=$O(^IBM(361.1,"C",IBIFN,IBI)) Q:'IBI | . S X="0.00",IBFST=1 I 'IBCT D | . S IBM=$G(^IBM(361.1,IBI,0)) . S IBSTR=$$SETLN("No EEOB/MRA Information","",1,79) | . S IBTY=$P(IBM,U,4),IBTY=$S(IBTY:"MEDICARE MRA",1:"N > . S IBCN=$P(IBM,U,14),IBPY=$P(IBM,U,2) > . S:IBPY IBPY=$P($G(^DIC(36,IBPY,0)),U) > . S IBPR=$$FMTE^XLFDT($P(IBM,U,6)),IBST=$P(IBM,U,16) > . S IBST=$$EXPAND^IBTRE(361.1,.16,+IBST) > . S IBM1=$G(^IBM(361.1,IBI,1)) > . S IBPT=$P(IBM1,U,2),IBCA=$P(IBM1,U) > . S IBM2=$G(^IBM(361.1,IBI,2)),IBTA=$P(IBM2,U,3) > . S IBTS=$P(IBM2,U,4) > . D MRA2 > I 'IBFST D > . S IBSTR=$$SETLN("No EOB/MRA Information","",1,79) I IBCT D < . S Z=0 < . S IBI=0 F S IBI=$O(IBSHEOB(IBI)) Q:'IBI S Z=Z+1 D < ; < N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE | N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE S Z="" F S Z=$O(^TMP("IBXDISP",$J,1,Z),-1) Q:Z="" S < S:Z ^TMP("IBXDISP",$J,1,Z+1)=" " < ; | MRA2 ; > S IBLN=$$SET("",IBLN) > S IBD="EOB/MRA Information" > S IBSTR=$$SETLN(IBD,"",30,45),IBLN=$$SET(IBSTR,IBLN) > S IBD="EOB Type: "_IBTY,IBSTR=$$SETLN(IBD,"",4,38) > S IBLN=$$SET(IBSTR,IBLN) > S IBD="ICN: "_IBCN,IBSTR=$$SETLN(IBD,"",9,38) > S IBD="Patient Resp Amount: "_$S('IBPT:X,1:IBPT) > S IBSTR=$$SETLN(IBD,IBSTR,44,35) > S IBLN=$$SET(IBSTR,IBLN) > S IBD="Payer Name: "_IBPY,IBSTR=$$SETLN(IBD,"",2,38) > S IBD="Total Allowed Amount: "_$S('IBTA:X,1:IBTA) > S IBSTR=$$SETLN(IBD,IBSTR,43,36) > S IBLN=$$SET(IBSTR,IBLN) > S IBD="EOB Date: "_IBPR,IBSTR=$$SETLN(IBD,"",4,38) > S IBD="Total Submitted Charges: "_$S('IBTS:X,1:IBTS) > S IBSTR=$$SETLN(IBD,IBSTR,40,39) > S IBLN=$$SET(IBSTR,IBLN) > S IBD="EOB Status: "_IBST,IBSTR=$$SETLN(IBD,"",2,38) > S IBD="Claim Payment Amount: "_$S('IBCA:X,1:IBCA) > S IBSTR=$$SETLN(IBD,IBSTR,43,36) > S IBLN=$$SET(IBSTR,IBLN) > S IBD=$TR($J("",35)," ","-")_"Review"_$TR($J("",38)," > S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) > S (IBST,IBCN)=0 F S IBCN=$O(^IBM(361.1,IBI,21,IBCN)) > . S IBST=0 > . S IBD="Review Date: "_$$DAT1^IBOUTL($P(X,U)) > . S IBSTR=$$SETLN(IBD,"",1,30) > . S IBD="Reviewed By: "_$P($G(^VA(200,+$P(X,U,2),0)), > . S IBSTR=$$SETLN(IBD,IBSTR,40,39) > . S IBLN=$$SET(IBSTR,IBLN) > . S IBD=0 F S IBD=$O(^IBM(361.1,IBI,21,IBCN,1,IBD)) > I 'IBST D > . S IBSTR=$$SETLN("None","",1,10) > . S IBLN=$$SET(IBSTR,IBLN) > Q ; < diff -y --suppress-common-lines ./VADemo/r1/IBJTBB.m ./VADemo/r2/r/IBJTBB.m IBJTBB ;ALB/ARH - TPI BILL DIAGNOSIS SCREEN ;01-MAR-1995 | IBJTBB ;ALB/ARH - TPI BILL DIAGNOSIS SCREEN ; 01-MAR-1995 ;;2.0;INTEGRATED BILLING;**39,210**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94 N IBADX,IBI,IBX,IBCNT,IBLN,IBSTR,IBDATE | N IBADX,IBI,IBX,IBCNT,IBLN,IBSTR S IBDATE=$$BDATE^IBACSV(IBIFN) < . S IBCNT=IBCNT+1,IBX=$$ICD9^IBACSV(+IBADX(IBI),IBDAT | . S IBCNT=IBCNT+1,IBX=$G(^ICD9(+IBADX(IBI),0)) diff -y --suppress-common-lines ./VADemo/r1/IBJTBC.m ./VADemo/r2/r/IBJTBC.m ;;2.0;INTEGRATED BILLING;**39,80,51,137,210**;21-MAR- | ;;2.0;INTEGRATED BILLING;**39,80,51,137**;21-MAR-94 . N IBDATE ; Date of procedure < . S IBDATE=$P(IBX,U,2) I 'IBDATE S IBDATE=$$BDATE^IBA | . I $P(IBX,U)["ICD0" S IBPRC=$G(^ICD0(+IBX,0)) Q:IBPR . S IBPRC=$$PRCD^IBCEF1($P(IBX,U),1,IBDATE) Q:IBPRC=" | . I $P(IBX,U)'["ICD0" S IBPRC=$P($$PRCD^IBCEF1($P(IBX . S IBT=0,IBSTR=" "_$P(IBPRC,U,2) | . S IBT=0,IBSTR=" "_$P(IBPRC,U) . S IBT=20,IBD=$P(IBPRC,U,3) S IBSTR=$$SETLN(IBD,IBST | . S IBT=20,IBD=$P(IBPRC,U,2) S IBSTR=$$SETLN(IBD,IBST .. S IBY=+$G(IBZDX(+IBY)) Q:'IBY S IBY=$$ICD9^IBACSV | .. S IBY=+$G(IBZDX(+IBY)) Q:'IBY S IBY=$G(^ICD9(+IBY diff -y --suppress-common-lines ./VADemo/r1/IBJTCA1.m ./VADemo/r2/r/IBJTCA1.m ;;2.0;INTEGRATED BILLING;**39,80,106,137,223**;21-MAR | ;;2.0;INTEGRATED BILLING;**39,80,106,137**;21-MAR-94 N X,IBY,IBZ,IBZ0,IBI,IBT,IBD,IBLN,IBLR,IBD0,IBDI1,IBD | N X,IBY,IBZ,IBI,IBT,IBD,IBLN,IBLR,IBD0,IBDI1,IBDM,IBD I $P(IBDM1,"^",8) S IBT=" ECME No: ",IBD=+$P(IBDM1," | I IBWNR S IBT="MRA Status: ",IBD=$S($P(IBDTX,U,5):$P( I $L($P(IBDM1,"^",9)) S IBT="ECME Ap No: ",IBD=$P(IBD < I IBWNR S IBT="MRA Status: ",IBD=$S($P(IBDTX,U,5)'="" < diff -y --suppress-common-lines ./VADemo/r1/IBJTCA2.m ./VADemo/r2/r/IBJTCA2.m IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;16-FEB-1995 | IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ; 16-FEB-1995 ;;2.0;INTEGRATED BILLING;**39,80,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**39,80**;21-MAR-94 .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bil | .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) S IB .... ; if MRA active & bill pyr seq >1 & dsply'g prmr < .... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1 < ..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & re < .... S IBD=$$SLINE(IBD,IBX,30,3) < diff -y --suppress-common-lines ./VADemo/r1/IBJTU2.m ./VADemo/r2/r/IBJTU2.m IBJTU2 ;ALB/ARH - TPI UTILITIES ; 6/6/03 1:05pm | IBJTU2 ;ALB/ARH - TPI UTILITIES ; 2/14/95 ;;2.0;INTEGRATED BILLING;**39,106,199,211**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**39,106**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < . N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuz < N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy | S DIC="^DGCR(399,",DIC(0)="EQM",X=IBX D ^DIC K DIC I S DIC="^DGCR(399,",DIC(0)="EQ",X=IBX D ^DIC K DIC I Y < Only in ./VADemo/r1/: IBJVDEQ.m Only in ./VADemo/r1/: IBNCPDP1.m Only in ./VADemo/r1/: IBNCPDP2.m Only in ./VADemo/r1/: IBNCPDP3.m Only in ./VADemo/r1/: IBNCPDP.m Only in ./VADemo/r1/: IBNCPDPU.m diff -y --suppress-common-lines ./VADemo/r1/IBOA31.m ./VADemo/r2/r/IBOA31.m ;;2.0; INTEGRATED BILLING ;**95,199**; 21-MAR-94 | ;;2.0; INTEGRATED BILLING ;**95**; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBOBCRT.m ./VADemo/r2/r/IBOBCRT.m ;;2.0;INTEGRATED BILLING;**153,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**153**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBOCPD.m ./VADemo/r2/r/IBOCPD.m IBOCPD ;ALB/ARH - CLERK PRODUCTIVITY REPORTS ;10/8/91 | IBOCPD ;ALB/ARH - CLERK PRODUCTIVITY REPORTS ; 10/8/91 ;;2.0;INTEGRATED BILLING;**44,63,118,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**44,63,118**;21-MAR-94 S DIR("B")="A" < W !?9,"MRA REQUESTS COLUMN INCLUDES TOTALS OF ALL BIL < diff -y --suppress-common-lines ./VADemo/r1/IBOCPDS.m ./VADemo/r2/r/IBOCPDS.m IBOCPDS ;ALB/ARH - CLERK PRODUCTIVITY REPORT (SUMMARY) ;10/8/ | IBOCPDS ;ALB/ARH - CLERK PRODUCTIVITY REPORT (SUMMARY) ; 10/8 ;;2.0;INTEGRATED BILLING;**44,118,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**44,118**;21-MAR-94 K ^TMP("IB",$J),IBMRAUSR < ; < ; 5/28/04 - esg - MRA project - patch 155 - get MRA r < ; < S IBCDT=IBBEG-.001,IBE=IBEND+.3 < F S IBCDT=$O(^DGCR(399,"APM",IBCDT)) Q:'IBCDT!(IBCDT < . S IBQUIT=$$STOP Q:IBQUIT < . S IFN=0 < . F S IFN=$O(^DGCR(399,"APM",IBCDT,IFN)) Q:'IFN D F < . Q < ; < K DTOUT,DUOUT,DIRUT,DIROUT,IBMRAUSR | K DTOUT,DUOUT,DIRUT,DIROUT S IBNODE=$G(^TMP("IB",$J)),$P(^($J),U,1,4)=($P(IBNODE | S IBNODE=$G(^TMP("IB",$J)),^($J)=($P(IBNODE,U,1)+1)_U S IBNODE=$G(^TMP("IB",$J,IBCLK)),$P(^(IBCLK),U,1,4)=( | S IBNODE=$G(^TMP("IB",$J,IBCLK)),^(IBCLK)=($P(IBNODE, S IBNODE=$G(^TMP("IB",$J,IBCLK,IBRT)),$P(^(IBRT),U,1, | S IBNODE=$G(^TMP("IB",$J,IBCLK,IBRT)),^(IBRT)=($P(IBN S IBNODE=$G(^TMP("IB",$J,"~~")),$P(^("~~"),U,1,4)=($P | S IBNODE=$G(^TMP("IB",$J,"~~")),^("~~")=($P(IBNODE,U, S IBNODE=$G(^TMP("IB",$J,"~~",IBRT)),$P(^(IBRT),U,1,4 | S IBNODE=$G(^TMP("IB",$J,"~~",IBRT)),^(IBRT)=($P(IBNO ; < ; 7/26/04 - ESG - MRA Project - Capture division data < I IBCLK["AUTHORIZER,IB MRA" D < . N DIV < . S DIV=+$P($G(^DGCR(399,IFN,0)),U,22) ; division < . S DIV=$P($G(^DG(40.8,DIV,0)),U,1) ; division < . I DIV="" S DIV="~UNKNOWN" < . S IBNODE=$G(IBMRAUSR(IBCLK,IBRT,DIV)) < . S $P(IBMRAUSR(IBCLK,IBRT,DIV),U,1,4)=($P(IBNODE,U,1 < . Q < Q < ; < FILEMRA ; Capture and file MRA data into the scratch global < ; 9/9/03 - ESG - MRA Project < NEW IBRT,IBTD,MRAUSR,IBNODE < S IBRT=$P($G(^DGCR(399,IFN,0)),U,7) I 'IBRT G FMX < S IBTD=$P($G(^DGCR(399,IFN,"U1")),U,1)-$P($G(^DGCR(39 < S MRAUSR=+$P($G(^DGCR(399,IFN,"S")),U,8) < I 'MRAUSR G FMX < S MRAUSR=$P($G(^VA(200,MRAUSR,0)),U,1) < I MRAUSR="" G FMX < S IBNODE=$G(^TMP("IB",$J)),$P(^($J),U,5,6)=($P(IBNODE < S IBNODE=$G(^TMP("IB",$J,MRAUSR)),$P(^(MRAUSR),U,5,6) < S IBNODE=$G(^TMP("IB",$J,MRAUSR,IBRT)),$P(^(IBRT),U,5 < S IBNODE=$G(^TMP("IB",$J,"~~")),$P(^("~~"),U,5,6)=($P < S IBNODE=$G(^TMP("IB",$J,"~~",IBRT)),$P(^(IBRT),U,5,6 < ; < FMX ; < ; < N IBT,IBH1,L1,L2,T1,T2,T3,T4,T5,T6 | N IBT,IBH1 S L1=7 ; length of count fields < S L2=13 ; length of dollar amount fields < S T1=50 ; tab stop 1 - total count < S T2=59 ; tab stop 2 - total dollar amount < S T3=78 ; tab stop 3 - cancelled count < S T4=87 ; tab stop 4 - cancelled dollar amount < S T5=106 ; tab stop 5 - MRA request count < S T6=115 ; tab stop 6 - MRA request dollar amoun < W !!,"TOTAL:",?T1,$J(+$P(IBT,U,1),L1),?T2,$J($P(IBT,U | W !!,"TOTAL:",?50,$J($P(IBT,U,1),8),?60,$J($P(IBT,U,2 N IBT,DIV | N IBT S IBRT="" F S IBRT=$O(^TMP("IB",$J,IBCLK,IBRT)) Q:IB | S IBRT="" F S IBRT=$O(^TMP("IB",$J,IBCLK,IBRT)) Q:IB . S IBT=$G(^TMP("IB",$J,IBCLK,IBRT)) | .S IBT=$G(^TMP("IB",$J,IBCLK,IBRT)) . W ?30,$E($P(^DGCR(399.3,IBRT,0),U,1),1,20),?T1,$J(+ | .W ?30,$E($P(^DGCR(399.3,IBRT,0),U,1),1,20),?50,$J($P . W ?T5,$J(+$P(IBT,U,5),L1),?T6,$J($P(IBT,U,6),L2,2), < . ; divisional display < . I '$D(IBMRAUSR(IBCLK,IBRT)) Q < . W ?T1," -----",?T2," -----------",?T3," -----",? < . S DIV="" < . F S DIV=$O(IBMRAUSR(IBCLK,IBRT,DIV)) Q:DIV=""!IBQU < .. S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR:'IBQUIT < .. I IBQUIT Q < .. S IBT=$G(IBMRAUSR(IBCLK,IBRT,DIV)) < .. W !?7,DIV,?T1,$J(+$P(IBT,U,1),L1),?T2,$J($P(IBT,U, < .. Q < . I IBQUIT Q < . W ! < . Q < ; < W ?T1," -----",?T2," -----------",?T3," -----",?T4 | W ?50," ------",?60," ------------",?83," ------" W ?T5," -----",?T6," -----------" < W !,?30,"SUBTOTAL:",?T1,$J(+$P(IBT,U,1),L1),?T2,$J($P | W !,?30,"SUBTOTAL:",?50,$J($P(IBT,U,1),8),?60,$J($P(I W ?T5,$J(+$P(IBT,U,5),L1),?T6,$J($P(IBT,U,6),L2,2),! < S IBLN=IBLN+2 < W !,?T1,"---",$S(IBORDER'="A":"-",1:""),"TOTAL ",IBH2 | W !,?53,"--",$S(IBORDER'="A":"-- ",1:" "),"TOTAL ",IB W ?T5,"-----MRA REQUESTS-----" | W !,IBH1," BY",?30,"RATE TYPE",?53,"COUNT",?69,"AMOUN W !,IBH1," BY",?30,"RATE TYPE",?T1,$J("COUNT",L1),?T2 < W ?T5,$J("COUNT",L1),?T6,$J("AMOUNT",L2),! < diff -y --suppress-common-lines ./VADemo/r1/IBODISP.m ./VADemo/r2/r/IBODISP.m ;;2.0; INTEGRATED BILLING ;**17,199**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**17**; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBOHPT1.m ./VADemo/r2/r/IBOHPT1.m ;;2.0;INTEGRATED BILLING;**70,95,142,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**70,95,142**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBOHRAR.m ./VADemo/r2/r/IBOHRAR.m IBOHRAR ;ALB/EMG-RELEASED CHARGES REPORT;APR 11 1997 | IBOHRAR ;ALB/EMG - RELEASED CHARGES REPORT ;APR 11 1997 ;;2.0;INTEGRATED BILLING;**70,95,215**;21-MAR-94 | ;;2.0; INTEGRATED BILLING ;**70,95**; 21-MAR-94 EN ; - Option entry point. | EN ; N X,Y,ZTIO < S (IBCRT,IBQUIT)=0,IBLINE="",$P(IBLINE,"-",IOM)="" < D NOW^%DTC S Y=X X ^DD("DD") S IBNOW=Y D HOME^%ZIS < W @IOF,!,"List of On Hold/Hold-Review Charges Release < W !!?5,"This report will list all charges that were p < W !?5,"ON HOLD or HOLD-REVIEW status and currently ha < W !?5,"of BILLED and the DATE LAST UPDATED is within < W !?5,"you specify." < ; < SELECT W !!,"Print former (O)N HOLD charges," < R !?13,"(H)OLD-REVIEW charges, or (B)OTH: BOTH// ",X: < G:'$T!(X["^") END S:X="" X="B" S X=$E(X) < I "BHObho"'[X D HELP G SELECT < W " ",$S("Hh"[X:"HOLD-REVIEW","Oo"[X:"ON HOLD",1:"BO < S IBSEL=$S("Hh"[X:"H","Oo"[X:"O",1:"HO") < RANGE S DIR(0)="DA^:NOW:EX",DIR("A")="Start with DATE: " | N IBSDT,IBEDT,IBPAGE,IBNOW,DFN,IBNAME,IBATYPE,IBN,ZTI > S IBCRT=0,IBQUIT=0 > S IBLINE="",$P(IBLINE,"-",IOM)="" > D NOW^%DTC S Y=X X ^DD("DD") S IBNOW=Y > ; > D HOME^%ZIS W @IOF,!,"List of On Hold Charges Release > W ?5,"This report will list all charges identified as > W !,?5,"ON HOLD (after the install of patch IB*2*70) > W !,?5,"have a status of BILLED and the DATE LAST UPD > W !,?5,"within the date range you specify.",!! > S DIR(0)="DA^:NOW:EX",DIR("A")="Start with DATE: " W ! D ^DIR K DIR G:$D(DIRUT) END S IBSDT=+Y | D ^DIR K DIR G:$D(DIRUT) END S IBSDT=+Y S DIR(0)="DA^+Y:NOW:EX",DIR("A")=" Go to DATE: " | S DIR(0)="DA^+Y:NOW:EX",DIR("A")="Go to DATE: " S DIR("?")="Enter the ending date for this report." | S DIR("?")="Enter the ending date for this report." D D ^DIR K DIR G:$D(DIRUT) END S IBEDT=+Y < QUEUED ; - Entry point if queued. < K ^TMP($J) < I '$G(IBQUIT) D DEVICE < I '$G(IBQUIT) D CHRGS,PRINT < END D ^%ZISC | QUEUED ; entry point if queued K DFN,DIRUT,DUOUT,I,IBACT,IBATYPE,IBBILL,IBCHG,IBCNT, | ;*** K IBGBL,IBHDR,IBHR,IBLINE,IBN,IBNAME,IBND,IBND1,IBNOW | K ^TMP($J) K IBRDT,IBRF,IBRX,IBRXN,IBSEL,IBSDT,IBSSN,IBTO,IBTYPE | D:'$G(IBQUIT) DEVICE D:'$G(IBQUIT) CHRGS,PRINT > D END > Q > ;*** > END ; > D ^%ZISC > K ^TMP($J) > K DFN,I,IBACT,IBATYPE,IBBILL,IBCHG,IBCNT,IBCRT,IBDT > K IBFR,IBLINE,IBN,IBNAME,IBND,IBND1,IBNOW,IBPAGE > K IBOH,IBQUIT,IBSDT,IBSSN,IBTO,IBTYPE > K IBRX,IBRXN,IBRF,IBRDT > K POP,VA,X,DUOUT,DIRUT DEVICE I $D(ZTQUEUED) Q | DEVICE ; > I $D(ZTQUEUED) Q I $D(IO("Q")) D Q | I $D(IO("Q")) S ZTRTN="QUEUED^IBOHRAR",ZTIO=ION,ZTDES .S ZTRTN="QUEUED^IBOHRAR",ZTIO=ION,ZTDESC="CHARGES RE < .S ZTSAVE("IB*")="" D ^%ZTLOAD < .W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUE < .D HOME^%ZIS K ZTSK S IBQUIT=1 < ; < CHRGS ; - Indexes charges released to AR within date range. | CHRGS ; indexes charges released to AR within date range S IBSDT=IBSDT+.000001,IBEDT=IBEDT+.24 Q:IBQUIT | ; > S IBPAGE=0,IBSDT=IBSDT+.000001,IBEDT=IBEDT+.24 Q:IBQU .S IBND=$G(^IB(IBN,0)),IBND1=$G(^IB(IBN,1)) Q:'IBND!( | .S IBND=$G(^IB(IBN,0)) Q:'IBND .S IBOH=$P(IBND1,U,6),IBHR=$P(IBND1,U,7) | .S IBND1=$G(^IB(IBN,1)) Q:'IBND .I IBOH,IBSEL["O" S IBGBL="IBOH" D CHRGS1 Q | .S IBOH=$P(IBND1,"^",6) Q:'IBOH .I IBHR,IBSEL["H" S IBGBL="IBHR" D CHRGS1 | .S DFN=$P(IBND,"^",2) Q:'DFN D PAT ; | .S IBDT=$P(IBND1,"^",4) Q:'IBDT!(IBDTIB > .S ^TMP($J,"IBREL",IBNAME,DFN,IBN)="" CHRGS1 ; - Set global for report. < S IBDT=$P(IBND1,U,4) Q:'IBDT!(IBDTIBEDT < S DFN=$P(IBND,U,2) Q:'DFN < D PAT S ^TMP($J,IBGBL,IBNAME,DFN,IBN)="" < Q < PRINT ; - Print charges released to AR. | PRINT ; print charges released to AR N IENS Q:IBQUIT | S IBCNT=0 N IENS > Q:IBQUIT S IBGBL="" F S IBGBL=$O(^TMP($J,IBGBL)) Q:IBGBL="" | D HEADER .S (IBCNT,IBPAGE)=0 D HEADER Q:IBQUIT | S IBNAME="" F S IBNAME=$O(^TMP($J,"IBREL",IBNAME)) Q .S IBNAME="" F S IBNAME=$O(^TMP($J,IBGBL,IBNAME)) Q: | .S IBND=$G(^IB(IBN,0)) ..D PRNTPAT Q:IBQUIT | .S IBND1=$G(^IB(IBN,1)) ..S IBN=0 F S IBN=$O(^TMP($J,IBGBL,IBNAME,DFN,IBN)) | .S (IBRX,IBRXN,IBRF,IBRDT)=0 ...S IBND=$G(^IB(IBN,0)),IBND1=$G(^IB(IBN,1)) | .S IBACT=+IBND ...S (IBRX,IBRXN,IBRF,IBRDT)=0,IBACT=+IBND | .S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTY ...S IBTYPE=$P(IBND,U,3),IBTYPE=$P($G(^IBE(350.1,IBTY | .S IBBILL=$P($P(IBND,"^",11),"-",2) ; bill # ...S IBTYPE=$S(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO S | .I $P(IBND,"^",4)["52:" S IBRXN=$P($P(IBND,"^",4),":" ...S IBBILL=$P($P(IBND,U,11),"-",2) | .I IBRF>0 S IENS=+IBRF_","_+IBRXN_",",IBRDT=$$GET1^DI ...I $P(IBND,U,4)["52:" S IBRXN=$P($P(IBND,U,4),":",2 | .E S IENS=+IBRXN_",",IBRDT=$$GET1^DIQ(52,IENS,22,"I" ...I IBRF>0 S IENS=+IBRF_","_+IBRXN_",",IBRDT=$$GET1^ | .S IBFR=$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^", ...E S IENS=+IBRXN_",",IBRDT=$$GET1^DIQ(52,IENS,22," | .S IBTO=$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":$P(IBND, ...S IBFR=$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,U, | .S IBCHG=$J(+$P(IBND,"^",7),9,2) ...S IBTO=$$DAT1^IBOUTL($S($P(IBND,U,15)'="":$P(IBND, | .Q:IBQUIT ...S IBCHG=$J(+$P(IBND,U,7),9,2) | .W ?27,IBACT,?37,IBBILL,?46,IBTYPE W:IBRX>0 ?52,"Rx # ...I IBQUIT Q | .W ?52,IBFR,?62,IBTO,?70,IBCHG,! ...W ?27,IBACT,?37,IBBILL,?46,IBTYPE W:IBRX>0 ?52,"Rx | .S IBCNT=IBCNT+1 D:($Y+4)>IOSL HEADER ...W ?52,IBFR,?62,IBTO,?70,IBCHG,! | .Q ...S IBCNT=IBCNT+1 | W:IBCNT=0 !?10,"No charges were released in this time ...I ($Y+4)>IOSL,$O(^TMP($J,IBGBL,IBNAME,DFN,IBN)) D < .; < .I IBCNT=0 W !?10,"No charges were released in this t < ; < PAT ; - Print patient data during processing. | PAT ; print patient data N VADM,VAERR D DEM^VADPT K:VAERR VADM | N VAERR,VADM D DEM^VADPT I VAERR K VADM PRNTPAT ; - Print patient data on report. | PRNTPAT ; print patient data N VADM,VAERR | N VAERR,VADM,IBSSN D DEM^VADPT S:'VAERR IBSSN=VA("BID D DEM^VADPT S IBSSN=$S('VAERR:VA("BID"),1:"") | D:($Y+4)>IOSL HEADER Q:IBQUIT I ($Y+4)>IOSL D HEADER Q:IBQUIT < HEADER ; - Report header. | HEADER ; report header I IBQUIT Q | Q:IBQUIT S IBHDR=$S(IBGBL="IBHR":"HOLD-REVIEW",1:"ON HOLD"),IB | S IBPAGE=IBPAGE+1 W !,@IOF | I IBPAGE>1 W !,@IOF W "List of ",IBHDR," charges released to AR from ",$P | W "List of ON HOLD Charges released to AR between PAUSE ; - Pause for screen output. | PAUSE ;pause for screen output I $E(IOST,1,2)'="C-" Q | Q:$E(IOST,1,2)'="C-" HELP ; - 'Print former (O)N HOLD...' prompt help text. < W !!?5,"Enter: '' - To select both On Hold and Ho < W !?15,"'O' - To select only On Hold charges" < W !?15,"'H' - To select only Hold-Review charges" < W !?15,"'^' - To quit this option",! < Q < diff -y --suppress-common-lines ./VADemo/r1/IBOHRL.m ./VADemo/r2/r/IBOHRL.m IBOHRL ;ALB/EMG-AUTO-RELEASE CHARGES ON HOLD > 90 DAYS ;APR | IBOHRL ;ALB/EMG - AUTO-RELEASE CHARGES ON HOLD > 90 DAYS ;A ;;2.0;INTEGRATED BILLING;**70,215**;21-MAR-94 | ;;2.0; INTEGRATED BILLING ;**70**; 21-MAR-94 .I $P($G(^IB(IBNUM,0)),"^",5)=3 D | .S:$P($G(^IB(IBNUM,0)),"^",5)=3 IBRCOUNT=IBRCOUNT+1 ..S IBRCOUNT=IBRCOUNT+1 < ..I $G(IBR60) S IBNDE=^IB(IBNUM,0) D IVM^IBAMTV32(IBN < S XMSUB=$S($G(IBR60):"CHARGES PENDING REIVEW",1:"HELD | S XMSUB="HELD CHARGES PASSED TO AR "_$P(IBSTJB,"@",1) S IBT(1)="The job that passes "_$S($G(IBR60):"charges | S IBT(1)="The job that passes held charges to account I IBRCOUNT>0 D | I IBRCOUNT>0 S IBT(8)="* Use option 'On Hold Charges .S IBT(8)="* Use option 'On Hold/Hold-Review Charges < .S IBT(9)=" list of charges auto-released by this ta < ; < diff -y --suppress-common-lines ./VADemo/r1/IBOLK.m ./VADemo/r2/r/IBOLK.m ;;2.0; INTEGRATED BILLING ;**199**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBOMTP.m ./VADemo/r2/r/IBOMTP.m ;;2.0;INTEGRATED BILLING;**153,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**153**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBOSTUS1.m ./VADemo/r2/r/IBOSTUS1.m ;;2.0;INTEGRATED BILLING;**31,118,128,153,137,161,183 | ;;2.0;INTEGRATED BILLING;**31,118,128,153,137,161,183 N IBSUB,IBHDR,IBST1,IBST2,IBCAT,IBAMT,IBBEF,IBCRT,IBQ | N IBSUB,IBHDR,IBST1,IBST2,IBCAT,IBAMT,IBBEF,IBCRT,IBQ I IBDTP="MRA Request" S IBSUB="APM",IBHDR=0 < SET ; This section is called for a single bill - IBIFN | SET S IBS=$G(^DGCR(399,IBIFN,"S")),IBAPP=1 S IBS=$G(^DGCR(399,IBIFN,"S")),IBAPP=1 < I $P(IBS,U,7)'="" S IBBS="* REQUEST MRA",IBBSDT=$P(IB | I $P(IBS,U,7)'="" S IBBS="* REQUEST MRA",IBAPP=$P(IBS . ; if user answered No to 'print Bills with No MRA R < . I 'IBNOEOB D PRINT Q < . ; if user answered Yes (IBNOEOB=1), check two thing < . ; 1) if MRA on file, don't print < . I $$CHK^IBCEMU1(IBIFN) Q < . ; 2) if the most recent transmission for this c < . D TXSTS^IBCEMU2(IBIFN,,.REJFLG) < . I REJFLG Q < . ; < . ; otherwise, print bill < . D PRINT < ; < ; if user answered Yes to 'No MRA Received and No Rej < I IBNOEOB W !,"**** Bills with No MRA Received and No < diff -y --suppress-common-lines ./VADemo/r1/IBOSTUS.m ./VADemo/r2/r/IBOSTUS.m ;;2.0;INTEGRATED BILLING;**118,128,137,161,155**;21-M | ;;2.0;INTEGRATED BILLING;**118,128,137,161**;21-MAR-9 S IBNOEOB=0 ;init. < ; < MRA ; If user chose MRA Request status, check if user wan < I IBBST'="R" G SORT < S DIR(0)="Y",DIR("A")="Print ONLY Bills with No MRA R < S DIR("B")="No",DIR("?")="Enter (Y)es or (N)o" < S DIR("??")="^D HELP4^IBOSTUS" < D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROU < S IBNOEOB=Y < ; < S DIR(0)="S^1:EVENT DATE;2:BILL DATE;3:ENTERED DATE;4 | S DIR(0)="S^1:EVENT DATE;2:BILL DATE;3:ENTERED DATE" S IBDTP=$S(Y=1:"Event",Y=2:"Bill",Y=3:"Entered",Y=4:" | S IBDTP=$S(Y=1:"Event",Y=2:"Bill",Y=3:"Entered",1:"") K IBDTP,IBBY,VAERR,DIRUT,DUOUT,DTOUT,DIROUT,IBCICOMM, | K IBDTP,IBBY,VAERR,DIRUT,DUOUT,DTOUT,DIROUT,IBCICOMM W !!," MRA REQUEST DATE is the date the MRA request < HELP4 ; Help for No MRA on file prompt. < W !,"Enter YES if you would like to see bills that ar < W !,"with no MRAs and no CSA rejection messages on fi < W !!,"Enter NO if you would like to see ALL bills tha < Q < ; < diff -y --suppress-common-lines ./VADemo/r1/IBOVOP1.m ./VADemo/r2/r/IBOVOP1.m ;;2.0;INTEGRATED BILLING;**52,91,99,132,156,176,234** | ;;2.0;INTEGRATED BILLING;**52,91,99,132,156,176**;21- D CL^IBACV(DFN,IBDATE,"",.IBY) | D CL^SDCO21(DFN,IBDATE,"",.IBY) I $D(IBY(7)) S IBZ=IBZ_$S(IBZ]"":"/",1:"")_"CV" < diff -y --suppress-common-lines ./VADemo/r1/IBOVOP2.m ./VADemo/r2/r/IBOVOP2.m ;;2.0;INTEGRATED BILLING;**52,132,153,156,167,176,234 | ;;2.0;INTEGRATED BILLING;**52,132,153,156,167,176**;2 N IBCOMBAT < .S IBFLD2="" F S IBFLD2=$O(^TMP("IBOVOP",$J,IBFLD1,I | .S IBFLD2="" F S IBFLD2=$O(^TMP("IBOVOP",$J,IBFLD1,I ....S IBCOMBAT=$$CVEDT^IBACV(DFN,IBDATE) I +IBCOMBAT < ....W !?5,IBFLD2 < I IBCLSD]"" F I=1,2,3,4,5,6,7 S IBCLS=$P(IBCLSD,"^",I | I IBCLSD]"" F I=1,2,3,4,5,6 S IBCLS=$P(IBCLSD,"^",I) diff -y --suppress-common-lines ./VADemo/r1/IBRFN3.m ./VADemo/r2/r/IBRFN3.m IBRFN3 ;ALB/ARH - PASS BILL/CLAIM TO AR ;3/18/96 | IBRFN3 ;ALB/ARH - PASS BILL/CLAIM TO AR ; 3/18/96 ;;2.0;INTEGRATED BILLING;**61,133,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**61,133**;21-MAR-94 N IBI,IBJ,IBK,IBX,IBY,IBTMP,IBD0,IBDU,IBDU1,IBDI1,IBD | N IBI,IBJ,IBK,IBX,IBY,IBTMP,IBD0,IBDU,IBDU1,IBDI1,IBD . S IBDATE=$P(IBX,U,2) I 'IBDATE S IBDATE=$$BDATE^IBA | . I IBX[";ICPT(" S IBY=$$CPT^ICPTCOD(+IBX),IBY=$P(IBY . S IBY=$P($$PRCD^IBCEF1($P(IBX,U),1,IBDATE),U,2,3) | . I IBX[";ICD0(" S IBY=$G(^ICD0(+IBX,0)),IBY=$P(IBY,U . Q:$P(IBY,U)="" | . Q:$P(IBY,U,1)="" . S IBY=$G(^IBE(353.1,+$P(IBX,U,9),0)),ARRAY("PRC",IB | . S IBY=$G(^IBE(353.1,+$P(IBX,U,9),0)),ARRAY("PRC",IB . S IBY=$G(^IBE(353.2,+$P(IBX,U,10),0)),ARRAY("PRC",I | . S IBY=$G(^IBE(353.2,+$P(IBX,U,10),0)),ARRAY("PRC",I S IBDATE=$$BDATE^IBACSV(IBIFN) < . S IBX=IBTMP(IBI),IBY=$$ICD9^IBACSV(+IBX,IBDATE) Q:I | . S IBX=IBTMP(IBI),IBY=$G(^ICD9(+IBX,0)) Q:IBY="" . S ARRAY("DXS",IBJ)=$P(IBY,U)_U_$P(IBY,U,3) | . S ARRAY("DXS",IBJ)=$P(IBY,U,1)_U_$P(IBY,U,3) diff -y --suppress-common-lines ./VADemo/r1/IBRFN.m ./VADemo/r2/r/IBRFN.m IBRFN ;ALB/AAS - Supported functions for AR ;5-MAY-1992 | IBRFN ;ALB/AAS - Supported functions for AR ; cinco de mayo ;;2.0;INTEGRATED BILLING;**52,130,183,223**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**52,130,183**;21-MAR-94 REC(IBSTR,IBTYPE) ; Find the AR for an Authorization or | REC(IBSTR) ; Find the AR for an Authorization or Rx numb ; IBTYPE (by ref) - how the IBSTR was recog < S IBTYPE=0 < S IBAR=$$AREC(IBSTR) I IBAR>0 S IBTYPE=1 G RECQ | S IBAR=$$AREC(IBSTR) I IBAR>0 G RECQ ; < ; - look for ecme number < S IBAR=$$EREC(IBSTR) I IBAR>0 S IBTYPE=2 G RECQ < S IBTYPE=3 < AREC(AUTH) ; Find the Receivable for a TRICARE FI Author | AREC(AUTH) ; Find the Receivable for a CHAMPUS FI Author EREC(AUTH) ; Find the Receivable for an ECME FI Number < ; Input: AUTH -- Fiscal Intermediary ECME Num < ; Output: IBIFN -- >0 => ptr to claim/AR in fil < ; -1 => No receivable found < ; < N IBIFN,IBC,IBX,IBA,IBE,IBES < S IBIFN=-1,IBC=0 < I $G(AUTH)="" G ARECQ < S (IBE,IBES)=AUTH_";" < F S IBE=$O(^DGCR(399,"AG",IBE)) Q:IBE'[IBES D < . S IBX=0 F S IBX=$O(^DGCR(399,"AG",IBE,IBX)) Q:'IBX < . . I $P($G(^DGCR(399,IBX,"S")),U,16) Q ; Exclude ca < . . S IBA(IBX)="",IBC=IBC+1 < I IBC'>1 S IBIFN=$O(IBA(0)) G ERECQ ; only one found < W !!,"More than one fill for ECME# ",AUTH," has been < S IBIFN=$$SEL(.IBA) < ERECQ S:'IBIFN IBIFN=-1 < D EDTL(IBIFN,AUTH) ;details < Q IBIFN < ; < EDTL(IBIFN,AUTH) ;Details < Q:IBIFN'>0 Q:AUTH="" < N IBZ,IBBIL,IBPAT,IBPATN,IBRX,IB3624,IBDRUG,IBQTY,IBD < S IBZ=$G(^DGCR(399,IBIFN,0)) < S IBBIL=$P(IBZ,U),IBPAT=$P(IBZ,U,2),IBDAT=$P(IBZ,U,3) < S IBPATN=$P($G(^DPT(+IBPAT,0)),U) < S IB3624=$G(^IBA(362.4,+$O(^IBA(362.4,"C",IBIFN,"")), < S IBDRUG=$P($G(^PSDRUG(+$P(IB3624,U,4),0)),U) < S IBRX=$P($G(^PSRX(+$P(IB3624,U,5),0)),U) < S IBQTY=+$P(IB3624,U,7) < W !!,"Found IB Bill ",IBBIL," matching to ECME# '",AU < W !,"Rx#",IBRX," ",$$DAT3^IBOUTL(IBDAT),", ",IBPATN," < Q < ; < ; - handle TRICARE charges first | ; - handle CHAMPUS charges first ; < SEL(IBARR) ; Select a bill for a auth. < ; Input: IBARR -- Array of bill passed by refere < ; Output: IBNUM -- One of the bill iens, or -1 (n < ; < N DIR,DIRUT,DIROUT,DTOUT,DUOUT,IBSTR,IBKEY,IBNUM,IBX, < ; < ; - build string for DIR(0) < S (IBSTR,IBKEY,IBC)="",IBNUM=-1 < F S IBKEY=$O(IBARR(IBKEY)) Q:IBKEY="" D < . S IBB=$P($G(^DGCR(399,IBKEY,0)),"^") Q:IBB="" < . S IBX=0 F S IBX=$O(^IBA(362.4,"C",IBKEY,IBX)) Q:'I < .. S IBY=$G(^IBA(362.4,IBX,0)) Q:IBY="" < .. S IBC=IBC+1 < .. S IBSTR=IBSTR_IBC_":"_IBB_" "_$P(IBY,"^")_" "_$$DA < ; < I IBSTR="" G SELQ < ; < S DIR("A")="Select one of the bills by number",DIR(0) < D ^DIR I $D(DUOUT)!$D(DIROUT)!$D(DTOUT) G SELQ < ; < S:$L($P(Y(0)," ")) IBNUM=$O(^DGCR(399,"B",$P(Y(0)," " < ; < SELQ Q IBNUM < diff -y --suppress-common-lines ./VADemo/r1/IBRREL.m ./VADemo/r2/r/IBRREL.m ;;2.0;INTEGRATED BILLING;**95,153,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**95,153**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBRUTL.m ./VADemo/r2/r/IBRUTL.m ;;2.0;INTEGRATED BILLING;**70,82,132,142,176,179,202, | ;;2.0;INTEGRATED BILLING;**70,82,132,142,176,179,202* I IBCOV,'$P($G(^IBE(350.9,1,0)),"^",15),'$$ECME(IBN) | I IBCOV,'$P($G(^IBE(350.9,1,0)),"^",15) D ^IBRBUL ; < ECME(IBN) ; return 1 if ECME billed already and bulleti < N IBX,IBR,IBZ < S (IBR,IBX)=0,IBZ=^IB(IBN,0) < F S IBX=$O(^IBA(362.4,"B",$P($P(IBZ,"^",8),"-"),IBX) < Q IBR < diff -y --suppress-common-lines ./VADemo/r1/IBTOAT.m ./VADemo/r2/r/IBTOAT.m ;;2.0; INTEGRATED BILLING ;**1,199**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**1**; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBTOBI2.m ./VADemo/r2/r/IBTOBI2.m IBTOBI2 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT | IBTOBI2 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;;2.0;INTEGRATED BILLING;**210**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 S IBD(5,1)="Authorized Diag: "_$$DIAG^IBTRE6($P(IBTRC | S IBD(5,1)="Authorized Diag: "_$$DIAG^IBTRE6($P(IBTRC diff -y --suppress-common-lines ./VADemo/r1/IBTOBI4.m ./VADemo/r2/r/IBTOBI4.m ;;2.0;INTEGRATED BILLING;**91,125,51,210,266**;21-MAR | ;;2.0;INTEGRATED BILLING;**91,125,51**;21-MAR-94 N IBXY,SDDXY,ICDVDT | N IBXY,SDDXY I $G(IBOE) D SET^SDCO4(IBOE) W:'$D(SDDXY) !?6,"Nothin | I $G(IBOE) D SET^SDCO4(IBOE) W:'$D(SDDXY) !?6,"Nothin N I,IBXD,IBMODS,J,IBM,IBDATE | N I,IBXD,IBMODS,J,IBM S I=0 F S I=$O(IBXY(I)) Q:'I D | S I=0 F S I=$O(IBXY(I)) Q:'I S IBXD=$$PRCD^IBCEF1(+ . S IBDATE=$P(IBXY(I),U,2) | .W !?2,I," ",$P(IBXD,"^",2),?15,$E($P(IBXD,"^",3),1, . S IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE) | . S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMOD . W !?2,I," ",$P(IBXD,U,2),?15,$E($P(IBXD,U,3),1,40) < . S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMOD < ..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$ | ..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$ diff -y --suppress-common-lines ./VADemo/r1/IBTOBI.m ./VADemo/r2/r/IBTOBI.m ;;2.0;INTEGRATED BILLING;**91,160,199**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**91,160**;21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBTOSUM.m ./VADemo/r2/r/IBTOSUM.m ;;2.0;INTEGRATED BILLING;**118,133,217**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**118,133**;21-MAR-94 F I=0:1:13,20,21,80,81,82,99,30:1:34 S IBCNT(I)=0 | F I=0:1:13 S IBCNT(I)=0 S IBCNT(3,0)=0 | F I=20,21,80,81,82,99 S IBCNT(I)=0 > F I=0:1:4 S IBCNT(30+I)=0 S IBCNT(1)=IBCNT(1)+1 ; Admissions or discharges. | S IBCNT(1)=IBCNT(1)+1 ; Admsisions or discharges. I '$P(IBTRND,U,20) Q ; Must be an active visit. | I '$P(IBTRND,U,20) Q ; Must be an active S IBCNT(2)=IBCNT(2)+1 ; Insured admissions or dis | S IBCNT(2)=IBCNT(2)+1 ; Insured admissions diff -y --suppress-common-lines ./VADemo/r1/IBTOTR.m ./VADemo/r2/r/IBTOTR.m ;;2.0; INTEGRATED BILLING ;**40,199**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**40**; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBTRCD.m ./VADemo/r2/r/IBTRCD.m ;;2.0;INTEGRATED BILLING;**210**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 D SET^IBCNSP(START+IBLCNT,OFFSET,"Authorized Diag: "_ | D SET^IBCNSP(START+IBLCNT,OFFSET,"Authorized Diag: "_ diff -y --suppress-common-lines ./VADemo/r1/IBTRD.m ./VADemo/r2/r/IBTRD.m ;;2.0; INTEGRATED BILLING ;**1,199**; 21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**1**; 21-MAR-94 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy < diff -y --suppress-common-lines ./VADemo/r1/IBTRE3.m ./VADemo/r2/r/IBTRE3.m IBTRE3 ;ALB/AAS - CLAIMS TRACKING EDIT DIAGNOSIS ;1-SEP-93 | IBTRE3 ;ALB/AAS - CLAIMS TRACKING EDIT DIAGNOSIS ; 1-SEP-93 ;;2.0;INTEGRATED BILLING;**10,60,210,266**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**10,60**; 21-MAR N IBADG,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM,IBDATE | N IBADG,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM S IBDATE=$$TRNDATE^IBACSV(IBTRN) ; Service date for C < ; < W !!,"--- ",IOINHI,"Admitting Diagnosis",IOINORM," -- | W !!,"--- ",IOINHI,"Admitting Diagnosis",IOINORM," -- I 'IBADG W "Unspecified" < E D < . N IBDX < . S IBDX=$$ICD9^IBACSV(+IBADG,IBDATE) < . W $P(IBDX,U)_" -"_$P(IBDX,U,3) < N DTOUT,DUOUT,X,Y,DIC,IBDATE,ICDVDT | N DTOUT,DUOUT,X,Y,DIC ;Service date (for CSV) < S IBDATE=$$TRNDATE^IBACSV(IBTRN) S:'IBDATE IBDATE=DT < S ICDVDT=IBDATE ; for DD ID (versioned text) < ; < ;All DX codes are visible - no screen ;S DIC("S")="I | S DIC("S")="I '$P(^(0),U,9)" I Y,'$$ICD9ACT^IBACSV(+Y,IBDATE) W !!,*7,$P(Y,U,2)," < ; < N I,IBXD,IBDATE | N I,IBXD S I=0 F S I=$O(IBXY(I)) Q:'I D | S I=0 F S I=$O(IBXY(I)) Q:'I S IBXD=$G(^ICD9(+$P(IB . S IBTNOD=$G(^IBT(356.9,+IBXY(I),0)) | .S IBTNOD=$G(^IBT(356.9,+IBXY(I),0)) . S IBDATE=$P($P(IBTNOD,U,3),".") | .W !?2,I," ",$P(IBXD,"^"),?15,$E($P(IBXD,"^",3),1,30 . S IBXD=$$ICD9^IBACSV(+$P(IBXY(I),U,2),IBDATE) < . W !?2,I," ",$P(IBXD,U),?15,$E($P(IBXD,U,3),1,30),? < diff -y --suppress-common-lines ./VADemo/r1/IBTRE4.m ./VADemo/r2/r/IBTRE4.m IBTRE4 ;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ;1-SEP-93 | IBTRE4 ;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ; 1-SEP-93 ;;2.0;INTEGRATED BILLING;**10,210,266**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**10**; 21-MAR-94 I IBSEL D EDT(+$G(IBXY(+IBSEL)),".01;.03;"),CHECK(+$G | D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;") CHECK(IBADG) ; Check active status of the ICD0 code (Code < N IBZ,DIR,X,Y < S IBZ=$G(^IBT(356.91,+$G(IBADG),0)) Q:'IBZ < Q:$$ICD0ACT^IBACSV(+IBZ,$P(IBZ,U,3)) < W !!,*7,"Warning! The Procedure Code ",$P($$ICD0^IBAC < S DIR(0)="EA",DIR("A")="Press to continue" D < Q < ; < N DTOUT,DUTOU,X,Y,DIC,DIR,IBDATE,IBP,IBPN,IBPDT,IBADT | N DTOUT,DUTOU,X,Y,DIC ;Service date (for CSV) < S IBDATE=$$TRNDATE^IBACSV(IBTRN) < S IBADT=$G(^DGPM(+$$DGPM^IBTRE3(IBTRN),0)) ;Admission < NXT ; The Procedure Date has to be asked first for the Co | NXT S DIC("A")=$S(IBCNT<1:"Select Procedure: ",1:"Next Pr ; Input Procedure Date | S DIC("S")="I '$P(^(0),U,9)" S DIR(0)="D",DIR("A")=$S(IBCNT<1:"Procedure Date",1:" < S DIR("B")=$$DAT3^IBOUTL(IBDATE) < W:$G(IBCNT) ! < S IBPDT=IBDATE D ^DIR K DIR G ADDQ:Y'?7N S IBPDT=+Y W < ; The same checking as in the Data Dictionary, file # < I IBADT,(IBPDT+.9)0 | W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0 S IBP=+Y,IBPN=$P(Y,U,2) ; Procedure IEN and name | I $D(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),+Y)) W ;I '$$ICD0ACT^IBACSV(IBP,IBPDT) W !!,*7,IBPN," is not < I $D(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),IBP)) W < S IBADG=$$NEW(IBP,IBTRN,TYPE,IBPDT) | S IBADG=$$NEW(+Y,IBTRN,TYPE) I IBADG>0,TYPE'=3 G NXT ;D EDT(IBADG) G NXT | I IBADG,TYPE'=3 D EDT(IBADG) G NXT NEW(ICDI,IBTRN,TYPE,IBPDT) ; -- file new entry | NEW(ICDI,IBTRN,TYPE) ; -- file new entry D FILE^DICN S IBADG=+Y I Y'>0 G NEWQ | D FILE^DICN S IBADG=+Y I '$G(IBPDT) S IBPDT=$P($P(^IBT(356,IBTRN,0),"^",6)," | I IBADG>0 L +^IBT(356.91,IBADG) S $P(^IBT(356.91,IBAD L +^IBT(356.91,IBADG) S $P(^IBT(356.91,IBADG,0),"^",2 < N I,IBXD,IBDATE | N I,IBXD S I=0 F S I=$O(IBXY(I)) Q:'I D | S I=0 F S I=$O(IBXY(I)) Q:'I S IBXD=$G(^ICD0(+$P(IB . S IBTNOD=$G(^IBT(356.91,+IBXY(I),0)) | .S IBTNOD=$G(^IBT(356.91,+IBXY(I),0)) . S IBDATE=$P($P(IBTNOD,U,3),".") ; Procedure date | .W !?2,I," ",$P(IBXD,"^"),?15,$E($P(IBXD,"^",4),1,43 . S IBXD=$$ICD0^IBACSV(+$P(IBXY(I),U,2),IBDATE) < . W !?2,I," ",$P(IBXD,U),?15,$E($P(IBXD,U,4),1,43),? < diff -y --suppress-common-lines ./VADemo/r1/IBTRE6.m ./VADemo/r2/r/IBTRE6.m IBTRE6 ;ALB/AAS - CLAIMS TRACKING OUTPUT CLIN DATA ;2-SEP-19 | IBTRE6 ;ALB/AAS - CLAIMS TRACKING OUTPUT CLIN DATA ; 2-SEP-1 ;;2.0;INTEGRATED BILLING;**210**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 N IBRES,IBDX,X | N X S X="" S IBRES="" < S IBDX=+$O(^IBT(356.9,"ADG",+$P(^IBT(356,+IBTRN,0),"^ | S X=$$DIAG(+$O(^IBT(356.9,"ADG",+$P(^IBT(356,+IBTRN,0 I $D(VAIN(9)) S IBRES=VAIN(9) G ADMDQ | I $D(VAIN(9)) S X=VAIN(9) N VAIN,VAINDT,VA200 | I '$D(VAIN(9)) D S VAINDT=$P($G(^IBT(356,+IBTRN,0)),U,6) | .N VAIN,VAINDT S VA200="" D INP^VADPT | .S VAINDT=$P(^IBT(356,IBTRN,0),U,6) S IBRES=VAIN(9) | .S VA200="" D INP^VADPT ADMDQ Q IBRES | .S X=VAIN(9) > ADMDQ Q X N IBRES,IBDX | N X S X="" S IBRES="" < S IBDX=+$G(^IBT(356.9,+$O(^IBT(356.9,"ATP",+$P(^IBT(3 | S X=$$DIAG(+$G(^IBT(356.9,+$O(^IBT(356.9,"ATP",+$P(^I S IBRES=$$DIAG(IBDX,1,$$TRNDATE^IBACSV(IBTRN)) | PDIAGQ Q X PDIAGQ Q IBRES < DIAG(IBDX,IBTXT,IBDT) ; -- Expand diagnosis from pointer | DIAG(X,Y) ; -- Expand diagnosis from pointer ; -- input IBDX = pointer to diag | ; -- input x = pointer to diag ; IBTXT = if want text added (zero = number | ; y = if want text added (zero = number only N IBRES,IBZ | I '$G(X) Q "" I '$G(IBDX) Q "" | Q $P($G(^ICD9(+$G(X),0)),"^")_$S($G(Y):" - "_$P($G(^I S IBZ=$$ICD9^IBACSV(+IBDX,$G(IBDT)) I IBZ="" Q "" < S IBRES=$P(IBZ,U) < I $G(IBTXT) S IBRES=IBRES_" - "_$P(IBZ,U,3) < Q IBRES < PROC(IBPR,IBTXT) ; -- Expand procedure from pointer | PROC(X,Y) ; -- Expand procedure from pointer ; input IBPR=proc^^date (format of ^IBT(356.91,IEN,0) | ; input x=proc^^date ; IBTXT = if want text added (zero = number onl | ; y= 1= exand N IBRES,IBZ | ; I '$G(Z) S Z=1 ; what is that? | I '$G(Z) S Z=1 I '$G(IBPR) Q "" | I '+$G(X) Q "" S IBZ=$$ICD0^IBACSV(+IBPR,$P(IBPR,U,3)) | Q $P($G(^ICD0(+X,0)),"^")_$S($G(Y):" - "_$P($G(^ICD0( S IBRES=$P(IBZ,U) < I $G(IBTXT),IBZ'="" S IBRES=IBRES_" - "_$P(IBZ,U,4) < Q IBRES < ; < diff -y --suppress-common-lines ./VADemo/r1/IBTRED0.m ./VADemo/r2/r/IBTRED0.m IBTRED0 ;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY - CONT. | IBTRED0 ;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY - CONT. ;;2.0;INTEGRATED BILLING;**160,210**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**160**;21-MAR-94 N IBDATE ; Date of service for CSV < S IBDATE=$$TRNDATE^IBACSV(IBTRN) < D SET^IBCNSP(START+3,OFFSET," Diagnosis: "_$E($$D | D SET^IBCNSP(START+3,OFFSET," Diagnosis: "_$E($$D D SET^IBCNSP(START+4,OFFSET," Diagnosis: "_$E($$D | D SET^IBCNSP(START+4,OFFSET," Diagnosis: "_$E($$D diff -y --suppress-common-lines ./VADemo/r1/IBTRED.m ./VADemo/r2/r/IBTRED.m ;;2.0;INTEGRATED BILLING;**71,91,160,247**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**71,91,160**;21-MAR-94 F I=1:1:7 S X=$P(IBCL1,"^",I) S:X IBCL=IBCL_$S(I=1:"A | F I=1:1:4 S X=$P(IBCL1,"^",I) S:X IBCL=IBCL_$S(I=1:"A diff -y --suppress-common-lines ./VADemo/r1/IBTRKR2.m ./VADemo/r2/r/IBTRKR2.m ;;2.0;INTEGRATED BILLING;**43,62,214**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**43,62**; 21-MAR ..I $P(IBTRKR,"^",2)=1,$S('$$INSURED^IBCNS1(DFN,+IBI) | ..I $P(IBTRKR,"^",2)=1,$S('$$INSURED^IBCNS1(DFN,+IBI) ..D TRKR^IBCNRDV(DFN,IBI,IBJ,$P(IBDATA,"^",11)) < ; add cleanup of ARDV < S X=0 F S X=$O(^IBT(356,"ARDV",X)) Q:X<1 S Y=0 F S < diff -y --suppress-common-lines ./VADemo/r1/IBTRKR3.m ./VADemo/r2/r/IBTRKR3.m IBTRKR3 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK RX FILLS ;13-A | IBTRKR3 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK RX FILLS ; 13- ;;2.0;INTEGRATED BILLING;**13,43,121,160,247,275**;21 | ;;2.0;INTEGRATED BILLING;**13,43,121,160**;21-MAR-94 ;if the patient is covered by insurance for pharmacy < ;AND if no copay in #350 < ;then we need to determine the non billable reason an < ; < ;IF VAEL(3) -- if this is a veteran with SC(service c < .;in case of POW and Unempl.vet we cannot decide if t | .I $P(VAEL(3),"^",2)<50 S IBRMARK="SC TREATMENT" .N IBPOWUNV,IBAUTRET S IBAUTRET=$$AUTOINFO^DGMTCOU1(D < .I $P(VAEL(3),"^",2)<50 S IBRMARK=$S(IBPOWUNV:"NEEDS < ;IF +VAEL(3)=0 if the veteran doesn't have SC status, < ;the veteran still may have CV status active < I $G(IBRMARK)="",+VAEL(3)=0,'$G(^PSRX(IBRXN,"IB")) D < .I $$CVEDT^IBACV(DFN,IBDT) S IBRMARK="NEEDS SC DETERM < ; < diff -y --suppress-common-lines ./VADemo/r1/IBTRKR41.m ./VADemo/r2/r/IBTRKR41.m ;;2.0;INTEGRATED BILLING;**43,55,91,132,174,247**;21- | ;;2.0;INTEGRATED BILLING;**43,55,91,132,174**;21-MAR- I $G(IBRMARK)="" S IBENCL=$$ENCL^IBAMTS2(IBOE) I IBEN | I $G(IBRMARK)="" S IBENCL=$$ENCL^IBAMTS2(IBOE) I IBEN .I $P(IBENCL,"^",6) S IBRMARK="HEAD/NECK CANCER" Q < .I $P(IBENCL,"^",7) S IBRMARK="COMBAT VETERAN" Q < S IBT(9)="*The SC, Agent Orange, Environmental Contam | S IBT(9)="*The SC, Agent Orange, Environmental Contam S IBT(10)="Military Sexual Trauma,Head Neck Cancer an | S IBT(10)="Military Sexual Trauma visits have been ad S IBT(11)="visits have been added for insured patient | S IBT(11)="automatically indicated as not billable" S IBT(12)="indicated as not billable" < diff -y --suppress-common-lines ./VADemo/r1/IBTRKR.m ./VADemo/r2/r/IBTRKR.m ;;2.0;INTEGRATED BILLING;**23,43,45,56,214**;21-MAR-9 | ;;Version 2.0 ; INTEGRATED BILLING ;**23,43,45,56**; ; inpatient claims tracking = insured and ur only, b < ; need to send off RDV in background < N IBT < I $P(IBTRKR,"^",2)=1,'$$INSURED^IBCNS1(DFN,+DGPMA),$$ < ; < ; < diff -y --suppress-common-lines ./VADemo/r1/IBTRV2.m ./VADemo/r2/r/IBTRV2.m IBTRV2 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ;19-JUL- | IBTRV2 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ; 19-JUL ;;2.0;INTEGRATED BILLING ;**60,210,266**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**60**; 21-MAR-94 .W !!,"DRG computes to: ",IBDRG," - ",$$DRGTD^IBACS | .W !!,"DRG computes to: ",IBDRG," - ",$G(^ICD(IBDRG N SEX,ICDEXP,ICDTRS,ICDDMS,ICDDX,ICDPRC,DX,PR,I,J,IBC | N SEX,ICDEXP,ICDTRS,ICDDMS,ICDDX,ICDPRC,DX,PR,I,J,IBC I $D(ICDDX(1)) S ICDDATE=$$TRNDATE^IBACSV(IBTRN) D ^I | I $D(ICDDX(1)) D ^ICDDRG .W !?5,$$DAT1^IBOUTL($P(IBDRG,"^",3)),?16,+IBDRG," - | .W !?5,$$DAT1^IBOUTL($P(IBDRG,"^",3)),?16,+IBDRG," - diff -y --suppress-common-lines ./VADemo/r1/IBTRVD.m ./VADemo/r2/r/IBTRVD.m IBTRVD ;ALB/AAS - CLAIMS TRACKING - EXPANDED REVIEW SCREEN;0 | IBTRVD ;ALB/AAS - CLAIMS TRACKING - EXPANDED REVIEW SCREEN ; ;;2.0;INTEGRATED BILLING;**266**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 D SET^IBCNSP(START+6,OFFSET," Interim DRG: "_$S(+IB | D SET^IBCNSP(START+6,OFFSET," Interim DRG: "_$S(+IB diff -y --suppress-common-lines ./VADemo/r1/IBTRV.m ./VADemo/r2/r/IBTRV.m ;;2.0;INTEGRATED BILLING;**40,121,124,250**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**40,121,124**;21-MAR-94 .I VAIN(4)="" S VAINDT=$P(IBTRND,"^",6) D INP^VADPT < diff -y --suppress-common-lines ./VADemo/r1/IBTUBO1.m ./VADemo/r2/r/IBTUBO1.m ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,247,15 | ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159**;21-M ; IBX=ien of CLAIMS TRACKING ent | I '$G(DFN)!('$G(IBDT))!('$G(IBRT)) G OPTQ ; | N IBCN,IBCPT,IBCT,IBDATA,IBDAY,IBDIV,IBFL,IBNAME,IBQU I '$G(DFN)!('$G(IBDT))!('$G(IBRT))!'$G(IBX) G OPTQ < N IBCN,IBCPT,IBCT,IBDATA,IBDAY,IBDIV,IBFL,IBNAME,IBQU < I $G(IBOE),$$ENCL^IBAMTS2(IBOE)["1" G OPTQ ; "ao^ir^s | I $G(IBOE),$$ENCL^IBAMTS2(IBOE)["1" G OPTQ ; "ao^ir^s . S IBDATA=$$CKBIL^IBTUBOU(IBXX) Q:IBDATA="" | . S IBDATA=$$CKBIL^IBTUBOU(IBXX) Q:IBDATA="" S IBNCF . I $P(IBDATA,U,2)=2 S IBMRA(IBXX)=IBDATA ; MRA reque < . S IBNCF=IBNCF+1 < . ; If Compile/Store & Not authorized/MRA requested b | . ; If Compile/Store & Not authorized before reportin . I $G(IBCOMP),$S('$G(IBMRA(IBXX)):$P(IBDATA,U,3),1:$ | . I $G(IBCOMP),$P(IBDATA,U,3)>IBEDT Q . . I $G(IBMRA(IBXX))'="" S:$D(IBCPT(IBZ)) IBCPT("MRA < S IBMRA=$S($D(IBCPT("MRA")):1,1:0) | S IBUNB("ENCNTRS")=IBUNB("ENCNTRS")+1 S:$G(IBXTRACT) S:'IBMRA IBUNB("ENCNTRS")=IBUNB("ENCNTRS")+1 < S:$G(IBXTRACT) IB(14)=IB(14)+1 < . S IBMRA=$S($D(IBCPT("MRA",IBZ)):1,1:0) < . . S:'IBMRA IBUNB("CPTMS-I")=IBUNB("CPTMS-I")+1 | . . S IBUNB("CPTMS-I")=IBUNB("CPTMS-I")+1 . . S:'IBMRA IBUNB("UNBILOP")=IBUNB("UNBILOP")+IBCPT( | . . S IBUNB("UNBILOP")=IBUNB("UNBILOP")+IBCPT(IBZ,1) . . S:IBMRA IBUNB("CPTMS-I-MRA")=IBUNB("CPTMS-I-MRA") < . . S:IBMRA IBUNB("UNBILOP-MRA")=IBUNB("UNBILOP-MRA") < . . S:'IBMRA IBUNB("CPTMS-P")=IBUNB("CPTMS-P")+1 | . . S IBUNB("CPTMS-P")=IBUNB("CPTMS-P")+1 . . S:'IBMRA IBUNB("UNBILOP")=IBUNB("UNBILOP")+IBCPT( | . . S IBUNB("UNBILOP")=IBUNB("UNBILOP")+IBCPT(IBZ,2) . . S:IBMRA IBUNB("CPTMS-P-MRA")=IBUNB("CPTMS-P-MRA") < . . S:IBMRA IBUNB("UNBILOP-MRA")=IBUNB("UNBILOP-MRA") < ; NO MRA Extract code needed for pre-RC processes < ; NON-MRA: < ; MRA: < ; ^TMP($J,"IBTUB-OPT_MRA",NAME@@DFN,DATE,IBX,CPT no) < N IBCTF,IBCPTNM | N IBCTF I $S($G(IBINMRA):1,1:'$O(IBCPT("MRA",""))) S ^TMP($J, | S ^TMP($J,"IBTUB-OPT",IBNAME_"@@"_DFN,IBDAY,IBX)=IBNC I $G(IBINMRA),$O(IBCPT("MRA","")) S ^TMP($J,"IBTUB-OP < G:'IBDET SETUBQ < . S IBCPTNM=$$CODEC^ICPTCOD(IBXX) I IBCPTNM=-1 S IBCP < . I $S($G(IBINMRA):1,1:'$O(IBCPT("MRA",""))) S ^TMP($ | . S ^TMP($J,"IBTUB-OPT",IBNAME_"@@"_DFN,IBDAY,IBX,IBX . I $G(IBINMRA) S:$G(IBCPT("MRA",IBXX)) ^TMP($J,"IBTU < diff -y --suppress-common-lines ./VADemo/r1/IBTUBO2.m ./VADemo/r2/r/IBTUBO2.m IBTUBO2 ;ALB/AAS - UNBILLED AMOUNTS - GENERATE UNBILLED REPOR | IBTUBO2 ;ALB/AAS - UNBILLED AMOUNTS - GENERATE UNBILLED REPOR ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,15 | ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159**;21-M ; ^TMP($J,"IBTUB-INPT_MRA",NAME@@DFN,DATE,IBX)=1 if < N IBIP,IBDATA,IBNAME,IBNCF,IBXX,X,Y,IBMRA | N IBIP,IBNAME,IBNCF,IBXX,X,Y . S IBNCF=IBNCF+1 ; Increment the number of bills on | . S IBNCF=IBNCF+1 ; Increment the number of bills on . I $G(IBCOMP),$S($P(IBDATA,U,2)'=2:$P(IBDATA,U,3),1: | . I $G(IBCOMP),$P(IBDATA,U,3)>IBEDT Q . S IBIP($P(IBDATA,U,4))=$S($P(IBDATA,U,2)'=2:1,1:2) | . S IBIP($P(IBDATA,U,4))=1 ; Episode billed for bil I IBIP(1)=1 G:IBIP(2)=1!(IBDT<2990901) INPTQ ; Episod | I IBIP(1) G:IBIP(2)!(IBDT<2990901) INPTQ ; Episode is S (IBXX,IBMRA)="" | S IBXX="" I 'IBIP(1) D ; | . S IBUNB("EPISM-I")=IBUNB("EPISM-I")+1 S:IBDET IBXX= I IBIP(1)'=1 D < . I 'IBIP(1) S IBUNB("EPISM-I")=IBUNB("EPISM-I")+1 S: < . I IBIP(1)=2 S IBUNB("EPISM-I-MRA")=IBUNB("EPISM-I-M < I IBIP(2)'=1,IBDT'<2990901 D | I 'IBIP(2),IBDT'<2990901 D . I 'IBIP(2) S IBUNB("EPISM-P")=IBUNB("EPISM-P")+1 S: | . S IBUNB("EPISM-P")=IBUNB("EPISM-P")+1 > . I IBDET S IBXX=$S(IBXX="I":"I,P",1:"P") . I IBIP(2)=2 S IBUNB("EPISM-P-MRA")=IBUNB("EPISM-P-M < I $S('IBIP(1):1,'IBIP(2):1,1:0) S IBUNB("EPISM-A")=IB | S IBUNB("EPISM-A")=IBUNB("EPISM-A")+1 ; Number of Ad S:IBIP(1)=2!(IBIP(2)=2) IBUNB("EPISM-A-MRA")=IBUNB("E < I '$G(IBINMRA),IBIP(1)=2 G:IBIP(2)=1 INPTQ < I '$G(IBINMRA),IBIP(2)=2 G:IBIP(1)=1 INPTQ < ; < I $S($G(IBINMRA):1,1:IBXX'="") S ^TMP($J,"IBTUB-INPT" | S ^TMP($J,"IBTUB-INPT",IBNAME_"@@"_DFN,IBDT,IBX)=IBNC I IBMRA'="",$G(IBINMRA) S ^TMP($J,"IBTUB-INPT_MRA",IB < ; ^TMP($J,"IBTUB-RX_MRA",NAME@@DFN,DATE@RX#,IBX)=1 < ; < N IBDATA,IBDAY,IBDRX,IBFL,IBFLG,IBOFD,IBNAME,IBND,IBN | N IBDATA,IBDAY,IBDRX,IBFL,IBFLG,IBOFD,IBNAME,IBND,IBN S (IBFL,X)="",(IBFLG,IBNCF,IBNCF(0),IBMRA)=0 | S (IBFL,X)="",(IBFLG,IBNCF)=0 . S IBNCF=IBNCF+1 ; Increment the number of bills on | . S IBNCF=IBNCF+1 ; Increment the number of bills on . ; If Compile/Store & Not authorized before reportin < . I $G(IBCOMP),$S($P(IBDATA,U,2)'=2:$P(IBDATA,U,3),1: < . S:$P(IBDATA,U,2)'=2 IBFL=1,IBMRA=0 ; at least 1 non < . S:$P(IBDATA,U,2)=2 IBMRA=1 ; at least 1 MRA bill ex < > . ; If Compile/Store & Not authorized before reportin > . I $G(IBCOMP),$P(IBDATA,U,3)>IBEDT Q > . S IBFL=1 ; Refill has been billed S:'IBMRA IBUNB("PRESCRP")=IBUNB("PRESCRP")+1 | S IBUNB("PRESCRP")=IBUNB("PRESCRP")+1 I IBMRA S IBUNB("PRESCRP-MRA")=IBUNB("PRESCRP-MRA")+1 | S IBUNB("UNBILRX")=IBUNB("UNBILRX")+$$BICOST^IBCRCI(I S IBCO=$$BICOST^IBCRCI(IBRT,3,IBDAY,"PRESCRIPTION FIL < S:'IBMRA IBUNB("UNBILRX")=IBUNB("UNBILRX")+IBCO < I IBMRA S IBUNB("UNBILRX-MRA")=IBUNB("UNBILRX-MRA")+I < . S IB(18)=IB(18)+IBCO | . S IB(18)=IB(18)+$$BICOST^IBCRCI(IBRT,3,IBDAY,"PRESC I $S($G(IBINMRA):1,1:'IBMRA) S ^TMP($J,"IBTUB-RX",IBN | S ^TMP($J,"IBTUB-RX",IBNAME_"@@"_DFN,IBDRX,IBX)=IBNCF I IBMRA,$G(IBINMRA) S ^TMP($J,"IBTUB-RX_MRA",IBNAME_" < diff -y --suppress-common-lines ./VADemo/r1/IBTUBO3.m ./VADemo/r2/r/IBTUBO3.m IBTUBO3 ;ALB/RB - UNBILLED AMOUNTS - GENERATE UNBILLED REPORT | IBTUBO3 ;ALB/RB - UNBILLED AMOUNTS - GENERATE UNBILLED REPORT ;;2.0;INTEGRATED BILLING;**123,159,192,155**;21-MAR-9 | ;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94 I X0=1 W ?52,"Admission CF Insurance Carrier(s)",?98, | I X0=1 W ?52,"Admission CF Insurance Carrier(s)",?102 I X0=2 W ?52,"Care Dt. CF Insurance Carrier(s)",?98, | I X0=2 W ?52,"Care Dt. CF Insurance Carrier(s)",?102 I X0=3 W ?52,"Date CF Ins. Carrier(s) MRA Dru | I X0=3 W ?52,"Date CF Insurance Carrier(s) Dr I '$O(^TMP($J,X1,PT,DTE,IBX,0)) W ?98,"I",?103,$S('$G | I '$O(^TMP($J,X1,PT,DTE,IBX,0)) W ?102,"I",! Q . W ?98,$P(IBN1,U,3),?103,$S('$G(IBINMRA):"",$G(^TMP( | . W ?102,$P(IBN1,U,3),?107,CPT,?114,$J(+IBN1,8,2) . W ?62,$J($P(IBN,U),2),?65,$$INS(DFN,+DTE,34) | . W ?62,$J($P(IBN,U),2),?65,$$INS(DFN,+DTE,36) . I X1["INPT" D | . I X1["INPT" W ?102,$P(IBN,U,2),! .. I $P(IBN,U,2)'="" W ?98,$E($P(IBN,U,2),1,3),! < .. I '$G(^TMP($J,X1_"_MRA",PT,DTE,IBX))!'$G(IBINMRA) < .. W ?98,$E($P(^TMP($J,X1_"_MRA",PT,DTE,IBX),U,2),1,3 < . W ?52,$$DTE(+DTE),?61,$J($P(IBN,U),2),?64,$$INS(DFN | . W ?52,$$DTE(+DTE),?61,$J($P(IBN,U),2),?64,$$INS(DFN . W ?88,$E($P(IBN,U,6),1,15),?105,$E($P(IBN,U,2),1,14 | . W ?89,$E($P(IBN,U,6),1,15),?106,$E($P(IBN,U,2),1,16 D DEM^VADPT S SSN=$P(VADM(2),"^"),SSN=$E(SSN,6,9) D K | D DEM^VADPT S SSN=$P(VADM(2),"^"),SSN=$E(SSN,6,9) D ELIG^VADPT S ELIG=$E($P(VAEL(1),"^",2),1,10) D KVAR | D ELIG^VADPT S ELIG=$E($P(VAEL(1),"^",2),1,10) diff -y --suppress-common-lines ./VADemo/r1/IBTUBOA.m ./VADemo/r2/r/IBTUBOA.m ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,15 | ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159**;21-M ; IBUNB("EPISM-I-MRA")=number of MRA req inpat inst | ; IBUNB("EPISM-A")=number of inpatient admissions m ; IBUNB("EPISM-P-MRA")=number of MRA req inpat prof < ; IBUNB("EPISM-A")=number of inpatient admissions m < ; (any type: Prof,Inst or both) < ; IBUNB("EPISM-A-MRA")=number inpt MRA req admissio < ; (any type: Prof,Inst or both) < ; IBUNB("CPTMS-I-MRA")=number of MRA req CPT codes < ; IBUNB("CPTMS-P-MRA")=number of MRA req CPT codes < ; IBUNB("PRESCRP-MRA")=number of MRA req prescripti < ; IBUNB("UNBILIP-MRA")=MRA req inpatient amount < ; IBUNB("UNBILOP-MRA")=MRA req outpatient amount < ; IBUNB("UNBILRX-MRA")=MRA req prescription amount < ; IBUNB("UNBILTL-MRA")=total MRA req amount < N IB,IBAMTI,IBAMTP,IBIAV,IBIA,IBNODE,IBOE,IBPA,IBQUER | N IB,IBAMTI,IBAMTP,IBIAV,IBDT,IBIA,IBNODE,IBOE,IBPA,I N IBAMTIM,IBAMTPM,IBTYP,IBX,IBY,DFN,DGPM,I,J | N IBSAV,IBT,IBTYP,IBUNB,IBX,IBY,DFN,DGPM,I,J K ^TMP($J,"IBTUB-INPT_MRA"),^TMP($J,"IBTUB-OPT_MRA"), < S (IBUNB("ENCNTRS"),IBUNB("PRESCRP"),IBUNB("PRESCRP-M | S (IBUNB("ENCNTRS"),IBUNB("PRESCRP"))=0 F IBX="IP","OP","RX" S IBUNB("UNBIL"_IBX)=0,IBUNB("UN | F IBX="IP","OP","RX" S IBUNB("UNBIL"_IBX)=0 F IBX="I","P" S (IBUNB("EPISM-"_IBX),IBUNB("EPISM-"_I | F IBX="I","P" S (IBUNB("EPISM-"_IBX),IBUNB("CPTMS-"_I S (IBUNB("EPISM-A"),IBUNB("EPISM-A-MRA"))=0 | S IBUNB("EPISM-A")=0 ; < S IBAMTI=$P(IBIAV,"^")*IBUNB("EPISM-I") ; Inst | S IBAMTI=$P(IBIAV,"^")*IBUNB("EPISM-I") ; Institution S IBAMTIM=$P(IBIAV,"^")*IBUNB("EPISM-I-MRA") ; Inst | S IBAMTP=$P(IBIAV,"^",2)*IBUNB("EPISM-P") ; Professio S IBAMTP=$P(IBIAV,"^",2)*IBUNB("EPISM-P") ; Prof < S IBAMTPM=$P(IBIAV,"^",2)*IBUNB("EPISM-P-MRA") ; Prof < S IBUNB("UNBILIP-MRA")=$J(IBAMTIM+IBAMTPM,0,2) < S IBUNB("UNBILOP-MRA")=$J(IBUNB("UNBILOP-MRA"),0,2) < S IBUNB("UNBILRX-MRA")=$J(IBUNB("UNBILRX-MRA"),0,2) < S IBUNB("UNBILTL-MRA")=$J(IBUNB("UNBILIP-MRA")+IBUNB( < K IBDT,IBRT,IBUNB < diff -y --suppress-common-lines ./VADemo/r1/IBTUBO.m ./VADemo/r2/r/IBTUBO.m ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,23 | ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159**;21-M . W ! D DT2("Unbilled Amounts") Q:IBTIMON="^" | . W ! D DT2^IBTUBOU("Unbilled Amounts") Q:IBTIMON="^" . I IBTIMON<3030900 N X S X=$$M2^IBJDE(IBTIMON,11,11) | . N X S X=$$M2^IBJDE(IBTIMON,23,23) .. S IBBDT=+X,IBEDT=$P(X,U,2)+.9,IBSEL="1,2,3" | . S IBBDT=$P(X,"^"),IBEDT=$P(X,"^",2)+.9,IBSEL="1,2,3 . I IBTIMON'<3030900 S IBBDT=$$M3^IBJDE($$LDATE^IBJDE < ; Ask to include REQUEST MRA Status < S DIR(0)="YA",DIR("A")="Do you want to include MRA cl < S IBINMRA=+Y < ; < DT2(STR) ; - Select re-compile date (returns variable < ; Input: STR - String that describe the type of data < ; re-compiled: "Unbilled Amounts", "Average Bi < ; < ; This code is very the same code as is in DT2^IBTUBO < ; a utility routine, so code was copied and altered t < ; EOAM changes. < N DIRUT,DT0,DT1,DT2,Y < ; - AUG 1993 is the first month on file with Unbilled < S DT0=2930800,DT1=$$DAT2^IBOUTL(DT0) < I $E(DT,6,7)'>$E($$LDATE^IBJDE(DT),6,7) S DT2=DT < I $E(DT,6,7)>$E($$LDATE^IBJDE(DT),6,7) S DT2=DT+100 I < S DT2=$$M1^IBJDE(DT2,1),DIR("B")=$$DAT2^IBOUTL(DT2) < S DIR(0)="DA^"_$E(DT0,1,5)_"00:"_DT2_":AE^K:$E(Y,6,7) < S DIR("A")="Re-compile "_$G(STR)_" through MONTH/YEAR < S DIR("?",1)="Enter a past month/year (ex. Oct 2000). < S DIR("?",3)="NOTE: The earliest month/year that can < S DIR("?")=" it is NOT possible to enter the cur < D ^DIR K DIR I $D(DIRUT) S IBTIMON="^" G DT2Q < I $E(Y,6,7)'="00"!($E(Y,4,7)="0000") W " ??" G DT2 < S IBTIMON=Y < ; < DT2Q Q < diff -y --suppress-common-lines ./VADemo/r1/IBTUBOU.m ./VADemo/r2/r/IBTUBOU.m IBTUBOU ;ALB/RB - UNBILLED AMOUNTS (UTILITIES) ;03 Aug 2004 | IBTUBOU ;ALB/RB - UNBILLED AMOUNTS (UTILITIES) ;29-SEP-94 ;;2.0;INTEGRATED BILLING;**123,159,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**123,159**;21-MAR-94 ; event date (if Y=1), or null^req MRA da | ; event date (if Y=1), or null S X2=$P($G(^DGCR(399,X,"S")),U,10) | S X2=$P($G(^DGCR(399,X,"S")),U,10) G:'X2 CKBLQ ; No a I 'X2 G:$P(X1,U,13)'=2 CKBLQ ; No authorization date, | I $P(X1,U,13)<3!($P(X1,U,13)>5) G CKBLQ ; Status not I $P(X1,U,13)<2!($P(X1,U,13)>5) G CKBLQ ; Status not < S:$P(X1,U,13)=2 $P(Z,U,6)=$P($G(^DGCR(399,X,"S")),U,7 < diff -y --suppress-common-lines ./VADemo/r1/IBTUBUL.m ./VADemo/r2/r/IBTUBUL.m ;;2.0;INTEGRATED BILLING;**19,123,159,217,155**;21-MA | ;;2.0;INTEGRATED BILLING;**19,123,159**;21-MAR-94 . S IBT(IDX+3)=" Number of MRA Unbilled Inpt Admiss | . S IBT(IDX+3)=" Number of Inpt. Institutional Case . S IBT(IDX+4)=" Number of Inpt. Institutional Case | . S IBT(IDX+4)=" Average Inpt. Institutional Bill A . S IBT(IDX+5)=" Average Inpt. Institutional Bill A | . S IBT(IDX+5)=" Number of Inpt. Professional Cases . S IBT(IDX+6)=" Number of Inpt. Professional Cases | . S IBT(IDX+6)=" Average Inpt. Professional Bill Am . S IBT(IDX+7)=" Average Inpt. Professional Bill Am | . S IBT(IDX+7)=" Total Unbilled Inpatient Care . S IBT(IDX+8)=" Total Unbilled Inpatient Care | . S IBT(IDX+8)="",IDX=IDX+8 . S IBT(IDX+9)=" Total MRA Unbilled Inpatient Care < . S IBT(IDX+10)="",IDX=IDX+10 < .S IBT(IDX+4)=" Number of MRA Unbilled CPT Codes | .S IBT(IDX+4)=" Total Unbilled Outpatient Care .S IBT(IDX+5)=" Total Unbilled Outpatient Care | .S IBT(IDX+5)="",IDX=IDX+5 .S IBT(IDX+6)=" Total MRA Unbilled Outpatient Care < .S IBT(IDX+7)="",IDX=IDX+7 < .S IBT(IDX+3)=" Number of MRA Unbilled Prescription | .S IBT(IDX+3)=" Total Unbilled Prescriptions .S IBT(IDX+4)=" Total Unbilled Prescriptions | .S IBT(IDX+4)="",IDX=IDX+4 .S IBT(IDX+5)=" Total MRA Unbilled Prescriptions < .S IBT(IDX+6)="",IDX=IDX+6 < .S IBT(IDX+2)="Total MRA Unbilled Amount (all care) | .S IDX(IDX+2)="",IDX=IDX+2 .S IDX(IDX+3)="",IDX=IDX+3 < S IBT(IDX+2)=" not billed (or bill not authoriz | S IBT(IDX+2)=" not billed (or bill not authoriz S IBUNB("EPISM-A")=11111 < diff -y --suppress-common-lines ./VADemo/r1/IBTUBV.m ./VADemo/r2/r/IBTUBV.m IBTUBV ;ALB/AAS - UNBILLED AMOUNTS - VIEW UNBILLED DATA ;29- | IBTUBV ;ALB/AAS - UNBILLED AMOUNTS - VIEW UNBILLED DATA ; 29 ;;2.0;INTEGRATED BILLING;**19,123,155**;21-MAR-94 | ;;2.0;INTEGRATED BILLING;**19,123**;21-MAR-94 N IBAVGI,IBAVGP,IBFL,IBHDT,IBPAG,IBQUIT,IBTMON,DA,ND, | N IBAVGI,IBAVGP,IBFL,IBHDT,IBPAG,IBQUIT,IBTMON,DA,ND, .S ND3=$G(^IBE(356.19,DA,3)) < .W !?10,"Number of Unbilled MRA Admissions: ",$J($P(N < .W !?14,"Total Unbilled Inpatient Care: ",$J($P(ND,U, | .W !?14,"Total Unbilled Inpatient Care: ",$J($P(ND,U, .W !?10,"Total MRA Unbilled Inpatient Care: ",$J($P(N < .W !?11,"Number of MRA Unbilled CPT Codes: ",$J($P(ND | .W !?13,"Total Unbilled Outpatient Care: ",$J($P(ND,U .W !?13,"Total Unbilled Outpatient Care: ",$J($P(ND,U < .W !?9,"Total MRA Unbilled Outpatient Care: ",$J($P(N < .W !?7,"Number of MRA Unbilled Prescriptions: ",$J($P | .W !?15,"Total Unbilled Prescriptions: ",$J($P(ND,U,9 .W !?15,"Total Unbilled Prescriptions: ",$J($P(ND,U,9 < .W !?11,"Total MRA Unbilled Prescriptions: ",$J($P(ND < diff -y --suppress-common-lines ./VADemo/r1/IBTUTL1.m ./VADemo/r2/r/IBTUTL1.m IBTUTL1 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ;21-JUN-93 | IBTUTL1 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ; 21-JUN-9 ;;2.0;INTEGRATED BILLING;**13,223**;21-MAR-94 | ;;Version 2.0 ; INTEGRATED BILLING ;**13**; 21-MAR-94 REFILL(DFN,IBETYP,IBTDT,IBRXN,IBRXN1,IBRMARK,IBEABD) ; -- | REFILL(DFN,IBETYP,IBTDT,IBRXN,IBRXN1,IBRMARK) ; -- add refi ; ibeabd := optional, can specify an earlie < S DR=".02////"_$G(DFN)_";.06////"_+IBTDT_";.08////"_I | S DR=".02////"_$G(DFN)_";.06////"_+IBTDT_";.08////"_I diff -y --suppress-common-lines ./VADemo/r1/IBXA1.m ./VADemo/r2/r/IBXA1.m IBXA1 ; COMPILED XREF FOR FILE #350 ; 10/15/04 | IBXA1 ; COMPILED XREF FOR FILE #350 ; 12/20/02 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IB(D0,1) | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IB(D0,1) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IB(D0,1) | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IB(D0,1) S DIKZ(0)=$G(^IB(DA,0)) < diff -y --suppress-common-lines ./VADemo/r1/IBXA2.m ./VADemo/r2/r/IBXA2.m IBXA2 ; COMPILED XREF FOR FILE #350 ; 10/15/04 | IBXA2 ; COMPILED XREF FOR FILE #350 ; 12/20/02 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IB(D0,1) | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IB(D0,1) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IB(D0,1) | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IB(D0,1) S X=$P(DIKZ(0),U,5) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$P($G(^IB < S DIKZ(0)=$G(^IB(DA,0)) < diff -y --suppress-common-lines ./VADemo/r1/IBXA.m ./VADemo/r2/r/IBXA.m IBXA ; DRIVER FOR COMPILED XREFS FOR FILE #350 ; 10/15/04 | IBXA ; DRIVER FOR COMPILED XREFS FOR FILE #350 ; 12/20/02 diff -y --suppress-common-lines ./VADemo/r1/IBXEXS.m ./VADemo/r2/r/IBXEXS.m IBXEXS ; GENERATED FROM 'IB CURRENT STATUS' INPUT TEMPLATE(# | IBXEXS ; GENERATED FROM 'IB CURRENT STATUS' INPUT TEMPLATE(# N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD | T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")= | SET I X'?.ANP S DDER=1 Q > N DIR S DIR(0)="SMV^"_DU,DIR("V")=1 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=517,U="^" M DIEZAR=^DIE(517,"AR") S DICRREC="TRIG^DIE17" | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=51 < 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 < S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I G RD:X="@",Z | G Z C2 G C2S:$D(DE(2))[0 K DB | C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE S X=DE(2),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IBA(354,D | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IBA(354,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 S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IBA(354,D | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^IBA(354,D C2F1 Q | Q S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I G RD:X="@",Z | G Z C3 G C3S:$D(DE(3))[0 K DB | C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE S X=DE(3),DIC=DIE < C3S S X="" G:DG(DQ)=X C3F1 K DB | C3S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE S X=DG(DQ),DIC=DIE < C3F1 Q | Q S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I G RD:X="@",Z | G Z C4 G C4S:$D(DE(4))[0 K DB | C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE S X=DE(4),DIC=DIE < 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 S X=DG(DQ),DIC=DIE < C4F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/IBXPAR1.m ./VADemo/r2/r/IBXPAR1.m IBXPAR1 ; ;09/24/03 | IBXPAR1 ; ;04/23/02 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,9) S:%]"" DE(3)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,9) S:%]"" DE(2)=% S I $D(^(1)) S %Z=^(1) S %=$P(%Z,U,7) S:%]"" DE(1)=% S | I $D(^(1)) S %Z=^(1) S %=$P(%Z,U,9) S:%]"" DE(1)=% S I $D(^(2)) S %Z=^(2) S %=$P(%Z,U,1) S:%]"" DE(8)=% S | I $D(^(2)) S %Z=^(2) S %=$P(%Z,U,1) S:%]"" DE(7)=% S I S %=$P(%Z,U,12) S:%]"" DE(10)=% | I S %=$P(%Z,U,12) S:%]"" DE(9)=% 1 S DW="1;7",DV="P3.8'",DU="",DLB="BILL CANCELLATION MA | 1 S DW="1;9",DV="P3.8'",DU="",DLB="BILL DISAPPROVED MAI 2 S DW="1;9",DV="P3.8'",DU="",DLB="BILL DISAPPROVED MAI | 2 S DW="0;9",DV="P3.8'",DU="",DLB="COPAY BACKGROUND ERR 3 S DW="0;9",DV="P3.8'",DU="",DLB="COPAY BACKGROUND ERR | 3 S DW="0;11",DV="P3.8'",DU="",DLB="MEANS TEST BILLING 4 S DW="0;11",DV="P3.8'",DU="",DLB="MEANS TEST BILLING | 4 S DQ=5 ;@5 S DU="XMB(3.8," | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 G RE | X5 S:IBDR'["5" Y="@99" X4 Q < 5 S DQ=6 ;@5 < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 S:IBDR'["5" Y="@99" < 7 S DW="1;26",DV="*P353'",DU="",DLB="DEFAULT FORM TYPE" | 6 S DW="1;26",DV="*P353'",DU="",DLB="DEFAULT FORM TYPE" X7 S DIC("S")="I $P(^IBE(353,Y,0),U,1)[""UB""" D ^DIC K | X6 S DIC("S")="I $P(^IBE(353,Y,0),U,1)[""UB""" D ^DIC K 8 S DW="2;1",DV="F",DU="",DLB="AGENT CASHIER MAIL SYMBO | 7 S DW="2;1",DV="F",DU="",DLB="AGENT CASHIER MAIL SYMBO X8 K:$L(X)>25!($L(X)<1) X | X7 K:$L(X)>25!($L(X)<1) X 9 S DW="2;10",DV="RF",DU="",DLB="FACILITY NAME FOR BILL | 8 S DW="2;10",DV="RF",DU="",DLB="FACILITY NAME FOR BILL X9 K:$L(X)>18!($L(X)<1)!'($TR(X," ")?.A) X | X8 K:$L(X)>18!($L(X)<1)!'($TR(X," ")?.A) X 10 S DW="2;12",DV="S",DU="",DLB="BILLING SITE IS OTHER F | 9 S DW="2;12",DV="S",DU="",DLB="BILLING SITE IS OTHER F X10 Q | X9 Q 11 S DW="2;2",DV="F",DU="",DLB="AGENT CASHIER STREET ADD | 10 S DW="2;2",DV="F",DU="",DLB="AGENT CASHIER STREET ADD X11 K:$L(X)>25!($L(X)<3) X | X10 K:$L(X)>25!($L(X)<3) X 12 S DW="2;3",DV="F",DU="",DLB="AGENT CASHIER CITY",DIFL | 11 S DW="2;3",DV="F",DU="",DLB="AGENT CASHIER CITY",DIFL X12 K:$L(X)>15!($L(X)<1) X | X11 K:$L(X)>15!($L(X)<1) X 13 S DW="2;4",DV="P5'",DU="",DLB="AGENT CASHIER STATE",D | 12 S DW="2;4",DV="P5'",DU="",DLB="AGENT CASHIER STATE",D X13 Q | X12 Q 14 S DW="2;5",DV="FX",DU="",DLB="AGENT CASHIER ZIP CODE" | 13 S DW="2;5",DV="FX",DU="",DLB="AGENT CASHIER ZIP CODE" X14 S:$E(X,6)="-" X=$TR(X,"-") K:$L(X)>9!($L(X)<5)!'(X?5N | X13 S:$E(X,6)="-" X=$TR(X,"-") K:$L(X)>9!($L(X)<5)!'(X?5N 15 S DW="2;6",DV="F",DU="",DLB="AGENT CASHIER PHONE NUMB | 14 S DW="2;6",DV="F",DU="",DLB="AGENT CASHIER PHONE NUMB X15 K:$L(X)>25!($L(X)<4) X | X14 K:$L(X)>25!($L(X)<4) X 16 S DQ=17 ;@99 | 15 S DQ=16 ;@99 17 G 0^DIE17 | 16 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXPAR.m ./VADemo/r2/r/IBXPAR.m IBXPAR ; GENERATED FROM 'IB EDIT MCCR PARM' INPUT TEMPLATE(# | IBXPAR ; GENERATED FROM 'IB EDIT MCCR PARM' INPUT TEMPLATE(# I $D(^(1)) S %Z=^(1) S %=$P(%Z,U,1) S:%]"" DE(10)=% S | I $D(^(1)) S %Z=^(1) S %=$P(%Z,U,1) S:%]"" DE(10)=% S I S %=$P(%Z,U,14) S:%]"" DE(6)=% S %=$P(%Z,U,15) S:% | I S %=$P(%Z,U,10) S:%]"" DE(29)=% S %=$P(%Z,U,14) S: I S %=$P(%Z,U,21) S:%]"" DE(5)=% S %=$P(%Z,U,22) S:% | I S %=$P(%Z,U,20) S:%]"" DE(30)=% S %=$P(%Z,U,21) S: I S %=$P(%Z,U,30) S:%]"" DE(26)=% S %=$P(%Z,U,31) S: | I S %=$P(%Z,U,29) S:%]"" DE(25)=% S %=$P(%Z,U,30) S: 25 S DW="1;29",DV="*P80'",DU="",DLB="DEFAULT RX REFILL D | 25 S DW="1;29",DV="P80'",DU="",DLB="DEFAULT RX REFILL DX X25 S DIC("S")="I $$ICD9ACT^IBACSV(+Y)" D ^DIC K DIC S DI | X25 Q Q | 26 S DW="1;30",DV="P81'",DU="",DLB="DEFAULT RX REFILL CP ; < 26 S DW="1;30",DV="*P81'",DU="",DLB="DEFAULT RX REFILL C < X26 S DIC("S")="I $$CPTACT^IBACSV(+Y)" D ^DIC K DIC S DIC | X26 Q Q < ; < 35 D:$D(DG)>9 F^DIE17 G ^IBXPAR1 | 35 S DW="1;7",DV="P3.8'",DU="",DLB="BILL CANCELLATION MA > S DU="XMB(3.8," > G RE > X35 Q > 36 D:$D(DG)>9 F^DIE17 G ^IBXPAR1 diff -y --suppress-common-lines ./VADemo/r1/IBXSC110.m ./VADemo/r2/r/IBXSC110.m IBXSC110 ; ;07/02/04 | IBXSC110 ; ;02/04/03 S X=DE(6),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(6),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(6),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(6),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(6),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(6),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET | I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ diff -y --suppress-common-lines ./VADemo/r1/IBXSC111.m ./VADemo/r2/r/IBXSC111.m IBXSC111 ; ;07/02/04 | IBXSC111 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DE(5),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VA S X=DG(DQ),DIC=DIE | S X=DE(5),DIC=DIE I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/IBXSC112.m ./VADemo/r2/r/IBXSC112.m IBXSC112 ; ;07/02/04 | IBXSC112 ; ;02/04/03 S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 | ; S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(7),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET | I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ diff -y --suppress-common-lines ./VADemo/r1/IBXSC113.m ./VADemo/r2/r/IBXSC113.m IBXSC113 ; ;07/02/04 | IBXSC113 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE ; | D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR < S X=DG(DQ),DIC=DIE < S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V S X=DG(DQ),DIC=DIE | S X=DE(6),DIC=DIE I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/IBXSC114.m ./VADemo/r2/r/IBXSC114.m IBXSC114 ; ;07/02/04 | IBXSC114 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE, < I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,7) S:%]"" DE(2)= < I $D(^(.121)) S %Z=^(.121) S %=$P(%Z,U,7) S:%]"" DE(7 < I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC114",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;12",DV="FXOa",DU < S DQ(1,2)="S Y(0)=Y D ZIPOUT^VAFADDR" < S DE(DW)="C1^IBXSC114",DE(DW,"INDEX")=1 < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) < S X=DE(1),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(1),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DE(1),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(1),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^V < 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 < I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ C1F1 N X,X1,X2 S DIXR=185 D C1X1(U) K X2 M X2=X D C1X1("O" < D < . N DIEXARR M DIEXARR=X S DIEZCOND=1 < . I X1(1)'=X2(1) < . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND < . K EASDO2 < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D < S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X( < S:$D(X)#2 X(2)=X < S X=$G(X(1)) < Q < C1F2 S DIXR=231 D C1X2(U) K X2 M X2=X D C1X2("O") K X1 M X < D < . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1, < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,. < G C1F3 < C1X2(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D < S X=$G(X(1)) < Q < C1F3 Q < X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X < I $D(X),X'?.ANP K X < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".11;7",DV="NJ3,0XOa" < S DQ(2,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11 < S DE(DW)="C2^IBXSC114" < G RE < C2 G C2S:$D(DE(2))[0 K DB < S X=DE(2),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DE(2),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(2),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(2),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA < S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET < C2S S X="" G:DG(DQ)=X C2F1 K DB < S X=DG(DQ),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DG(DQ),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA < I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ < C2F1 Q < X2 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 < Q < ; < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".13;1",DV="Fa",DU="" < S DE(DW)="C3^IBXSC114" < G RE < C3 G C3S:$D(DE(3))[0 K DB < S X=DE(3),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(3),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(3),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VA < 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 < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VA < 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 < C3F1 Q < X3 K:$L(X)>20!($L(X)<4) X < I $D(X),X'?.ANP K X < Q < ; < 4 S DQ=5 ;@155 < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".121;9",DV="RSX",DU= < S DE(DW)="C5^IBXSC114" < S DU="Y:YES;N:NO;" < G RE < C5 G C5S:$D(DE(5))[0 K DB < S X=DE(5),DIC=DIE < X "S DGXRF=.12105 D ^DGDDC Q" < C5S S X="" G:DG(DQ)=X C5F1 K DB < S X=DG(DQ),DIC=DIE < ; < C5F1 Q < X5 S DFN=DA I X="N" D TADD^DGLOCK < Q < ; < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 S:X="N" Y="@915" S:X="Y" DIE("NO^")="" < Q < 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".121;7",DV="DX",DU=" < S DE(DW)="C7^IBXSC114" < G RE < C7 G C7S:$D(DE(7))[0 K DB < S X=DE(7),DIC=DIE < ; < C7S S X="" G:DG(DQ)=X C7F1 K DB < D ^IBXSC115 < C7F1 Q < X7 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD < Q < ; < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 I X']"" W !?4,*7,"But I need a Start Date for this Te < Q < 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".121;8",DV="DX",DU=" < G RE < X9 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD < Q < ; < 10 D:$D(DG)>9 F^DIE17 G ^IBXSC116 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC115.m ./VADemo/r2/r/IBXSC115.m IBXSC115 ; ;07/02/04 | IBXSC115 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(7),DIC=DIE ; | S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(7),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(7),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(7),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA > S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET diff -y --suppress-common-lines ./VADemo/r1/IBXSC116.m ./VADemo/r2/r/IBXSC116.m IBXSC116 ; ;07/02/04 | IBXSC116 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE, < I $D(^(.121)) S %Z=^(.121) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC116",DQ=1 < 1 S DW=".121;1",DV="FX",DU="",DLB="TEMPORARY STREET [LI < S DE(DW)="C1^IBXSC116" < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < X "S DGXRF=.1211 D ^DGDDC Q" < C1S S X="" G:DG(DQ)=X C1F1 K DB < ; | S A1B2TAG="PAT" D ^A1B2XFR C1F1 Q < X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X < I $D(X),X'?.ANP K X < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 I X']"" W !?4,*7,"But I need at least one line of a T < Q < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".121;2",DV="FX",DU=" < S DE(DW)="C3^IBXSC116" < G RE < C3 G C3S:$D(DE(3))[0 K DB < S X=DE(3),DIC=DIE < X "S DGXRF=.1212 D ^DGDDC Q" < C3S S X="" G:DG(DQ)=X C3F1 K DB < ; | D EVENT^IVMPLOG(DA) C3F1 Q < X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X < I $D(X),X'?.ANP K X < Q < ; < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 S:X']"" Y=.1214 < Q < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".121;3",DV="FX",DU=" < G RE < X5 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK < I $D(X),X'?.ANP K X < Q < ; < 6 S DW=".121;4",DV="FX",DU="",DLB="TEMPORARY CITY",DIFL < G RE < X6 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK < I $D(X),X'?.ANP K X < Q < ; < 7 S DW=".121;5",DV="P5'X",DU="",DLB="TEMPORARY STATE",D < S DU="DIC(5," < G RE < X7 S DFN=DA D TAD^DGLOCK Q < Q < ; < 8 S DW=".121;12",DV="FOX",DU="",DLB="TEMPORARY ZIP+4",D < S DQ(8,2)="S Y(0)=Y D ZIPOUT^VAFADDR" < S DE(DW)="C8^IBXSC116" < G RE < C8 G C8S:$D(DE(8))[0 K DB < S X=DE(8),DIC=DIE < D KILL^DGREGDD1(DA,.1216,.121,6,$E(X,1,5)) < C8S S X="" G:DG(DQ)=X C8F1 K DB < D SET^DGREGDD1(DA,.1216,.121,6,$E(X,1,5)) | S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF C8F1 Q | S X=DG(DQ),DIC=DIE X8 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D TAD^DGLOCK I | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VA I $D(X),X'?.ANP K X | I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ Q < ; < 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".121;10",DV="FX",DU= < G RE < X9 K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D TAD^DGLOCK < I $D(X),X'?.ANP K X < Q < ; < 10 S DQ=11 ;@915 < 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) < X11 K DIE("NO^") < Q < 12 S DQ=13 ;@16 < 13 G 1^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC117.m ./VADemo/r2/r/IBXSC117.m IBXSC117 ; ;06/03/03 | IBXSC117 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC118.m ./VADemo/r2/r/IBXSC118.m IBXSC118 ; ;06/03/03 | IBXSC118 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC119.m ./VADemo/r2/r/IBXSC119.m IBXSC119 ; ;06/03/03 | IBXSC119 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC11.m ./VADemo/r2/r/IBXSC11.m IBXSC11 ; ;07/02/04 | IBXSC11 ; ;02/04/03 > I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(16) S DIFLD=1,DGO="^IBXSC12",DC="3^2.01^.01^",DV="2.01MF" | S DIFLD=1,DGO="^IBXSC12",DC="2^2.01^.01^",DV="2.01MF" 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) | 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".11;1",DV="Fa",DU=" X16 S:$$EDADDR^IBCSCE(+$G(DFN)) Y="@155" | S DE(DW)="C16^IBXSC11" > G RE > C16 G C16S:$D(DE(16))[0 K DB > D ^IBXSC17 > C16S S X="" G:DG(DQ)=X C16F1 K DB > D ^IBXSC18 > C16F1 Q > X16 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) > X17 S:X="" Y=.114 17 D:$D(DG)>9 F^DIE17 G ^IBXSC17 | 18 D:$D(DG)>9 F^DIE17 G ^IBXSC19 diff -y --suppress-common-lines ./VADemo/r1/IBXSC120.m ./VADemo/r2/r/IBXSC120.m IBXSC120 ; ;06/03/03 | IBXSC120 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC121.m ./VADemo/r2/r/IBXSC121.m IBXSC121 ; ;06/03/03 | IBXSC121 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC12.m ./VADemo/r2/r/IBXSC12.m IBXSC12 ; ;07/02/04 | IBXSC12 ; ;02/04/03 S DE(DW)="C1^IBXSC12",DE(DW,"INDEX")=1 | S DE(DW)="C1^IBXSC12" C1F1 N X,X1,X2 S DIXR=218 D C1X1(U) K X2 M X2=X D C1X1("O" | C1F1 Q I $G(X(1))]"" D | X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1 D DELCOMP^X < K X M X=X2 I $G(X(1))]"" D < . I '$G(XUNOTRIG) N XUNOTRIG S XUNOTRIG=1,DG20NAME=X < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2.01,DIIENS,.01,DION),$P($G(^ < S X=$G(X(1)) < Q < C1F2 S DIXR=397 D C1X2(U) K X2 M X2=X D C1X2("O") K X1 M X < D < . D FC^DGFCPROT(.DA,2.01,.01,"KILL",$H,$G(DUZ),.X,.X1 < K X M X=X2 D < . D FC^DGFCPROT(.DA,2.01,.01,"SET",$H,$G(DUZ),.X,.X1, < G C1F3 < C1X2(DION) K X < S X(1)=$G(@DIEZTMP@("V",2.01,DIIENS,.01,DION),$P($G(^ < S X=$G(X(1)) < Q < C1F3 Q < X1 K:$L(X)>30!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NA < diff -y --suppress-common-lines ./VADemo/r1/IBXSC13.m ./VADemo/r2/r/IBXSC13.m IBXSC13 ; ;07/02/04 | IBXSC13 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC14.m ./VADemo/r2/r/IBXSC14.m IBXSC14 ; ;07/02/04 | IBXSC14 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC15.m ./VADemo/r2/r/IBXSC15.m IBXSC15 ; ;07/02/04 | IBXSC15 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC16.m ./VADemo/r2/r/IBXSC16.m IBXSC16 ; ;07/02/04 | IBXSC16 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC17.m ./VADemo/r2/r/IBXSC17.m IBXSC17 ; ;07/02/04 | IBXSC17 ; ;02/04/03 D DE G BEGIN | S X=DE(16),DIC=DIE DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE, < I $D(^(.11)) S %Z=^(.11) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC17",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;1",DV="Fa",DU="" < S DE(DW)="C1^IBXSC17",DE(DW,"INDEX")=1 < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < S X=DE(1),DIC=DIE | S X=DE(16),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(16),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(16),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(16),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(16),DIC=DIE S X=DE(1),DIC=DIE | S X=DE(16),DIC=DIE S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET | S X=DE(16),DIIX=2_U_DIFLD D AUDIT^DIET C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < ; < S X=DG(DQ),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DG(DQ),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VA < 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 < C1F1 N X,X1,X2 S DIXR=230 D C1X1(U) K X2 M X2=X D C1X1("O" < D < . D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.111,DION),$P($G(^DP < S X=$G(X(1)) < Q < C1F2 Q < X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S:X="" Y=.114 < Q < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;2",DV="Fa",DU="" < S DE(DW)="C3^IBXSC17",DE(DW,"INDEX")=1 < G RE < C3 G C3S:$D(DE(3))[0 K DB < S X=DE(3),DIC=DIE < X "S DGXRF=.112 D ^DGDDC Q" < S X=DE(3),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DE(3),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DE(3),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DE(3),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DE(3),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VA < 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 < ; < S X=DG(DQ),DIC=DIE < S A1B2TAG="PAT" D ^A1B2XFR < S X=DG(DQ),DIC=DIE < D EVENT^IVMPLOG(DA) < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 < S X=DG(DQ),DIC=DIE < S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF < S X=DG(DQ),DIC=DIE < I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VA < 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 < C3F1 N X,X1,X2 S DIXR=232 D C3X1(U) K X2 M X2=X D C3X1("O" < D < . D FC^DGFCPROT(.DA,2,.112,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.112,"SET",$H,$G(DUZ),.X,.X1,.X < G C3F2 < C3X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.112,DION),$P($G(^DP < S X=$G(X(1)) < Q < C3F2 Q < X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 S:X="" Y=.114 < Q < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;3",DV="Fa",DU="" < S DE(DW)="C5^IBXSC17",DE(DW,"INDEX")=1 < G RE < C5 G C5S:$D(DE(5))[0 K DB < D ^IBXSC18 < C5S S X="" G:DG(DQ)=X C5F1 K DB < D ^IBXSC19 < C5F1 N X,X1,X2 S DIXR=233 D C5X1(U) K X2 M X2=X D C5X1("O" < D < . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X < G C5F2 < C5X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DP < S X=$G(X(1)) < Q < C5F2 Q < X5 K:X[""""!($A(X)=45) X I $D(X) 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 DQ=6,DW=".11;4",DV="Fa",DU="" < S DE(DW)="C6^IBXSC17",DE(DW,"INDEX")=1 < G RE < C6 G C6S:$D(DE(6))[0 K DB < D ^IBXSC110 < C6S S X="" G:DG(DQ)=X C6F1 K DB < D ^IBXSC111 < C6F1 N X,X1,X2 S DIXR=234 D C6X1(U) K X2 M X2=X D C6X1("O" < D < . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X < G C6F2 < C6X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DP < S X=$G(X(1)) < Q < C6F2 Q < X6 K:$L(X)>15!($L(X)<2) X < I $D(X),X'?.ANP K X < Q < ; < 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".11;5",DV="P5'a",DU= < S DE(DW)="C7^IBXSC17",DE(DW,"INDEX")=1 < S DU="DIC(5," < G RE < C7 G C7S:$D(DE(7))[0 K DB < D ^IBXSC112 < C7S S X="" G:DG(DQ)=X C7F1 K DB < D ^IBXSC113 < C7F1 N X,X1,X2 S DIXR=235 D C7X1(U) K X2 M X2=X D C7X1("O" < D < . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,. < K X M X=X2 D < . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X < G C7F2 < C7X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DP < S X=$G(X(1)) < Q < C7F2 Q < X7 Q < 8 D:$D(DG)>9 F^DIE17 G ^IBXSC114 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC18.m ./VADemo/r2/r/IBXSC18.m IBXSC18 ; ;07/02/04 | IBXSC18 ; ;02/04/03 S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE > ; > S X=DG(DQ),DIC=DIE S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VA | I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VA S X=DE(5),DIC=DIE | S X=DG(DQ),DIC=DIE S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET | I $D(DE(16))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(D diff -y --suppress-common-lines ./VADemo/r1/IBXSC19.m ./VADemo/r2/r/IBXSC19.m IBXSC19 ; ;07/02/04 | IBXSC19 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE, > I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,2) S:%]"" DE(1)= > I $D(^(.121)) S %Z=^(.121) S %=$P(%Z,U,9) S:%]"" DE(9 > I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(8)= > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="IBXSC19",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;2",DV="Fa",DU="" > S DE(DW)="C1^IBXSC19" > G RE > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > X "S DGXRF=.112 D ^DGDDC Q" > S X=DE(1),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(1),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(1),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DE(1),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(1),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VA > 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 > ; > S X=DG(DQ),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DG(DQ),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DG(DQ),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DG(DQ),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VA > 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 > C1F1 Q > X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 S:X="" Y=.114 > Q > 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;3",DV="Fa",DU="" > S DE(DW)="C3^IBXSC19" > G RE > C3 G C3S:$D(DE(3))[0 K DB > S X=DE(3),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(3),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(3),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DE(3),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(3),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VA > 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 I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ | I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ > C3F1 Q > X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;4",DV="Fa",DU="" > S DE(DW)="C4^IBXSC19" > G RE > C4 G C4S:$D(DE(4))[0 K DB > S X=DE(4),DIC=DIE > S A1B2TAG="PAT" D ^A1B2XFR > S X=DE(4),DIC=DIE > D EVENT^IVMPLOG(DA) > S X=DE(4),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.1 > S X=DE(4),DIC=DIE > S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXF > S X=DE(4),DIC=DIE > I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VA > 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 > D ^IBXSC110 > C4F1 Q > X4 K:$L(X)>15!($L(X)<2) X > I $D(X),X'?.ANP K X > Q > ; > 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;5",DV="P5'a",DU= > S DE(DW)="C5^IBXSC19" > S DU="DIC(5," > G RE > C5 G C5S:$D(DE(5))[0 K DB > D ^IBXSC111 > C5S S X="" G:DG(DQ)=X C5F1 K DB > D ^IBXSC112 > C5F1 Q > X5 Q > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".11;12",DV="FXOa",DU > S DQ(6,2)="S Y(0)=Y D ZIPOUT^VAFADDR" > S DE(DW)="C6^IBXSC19",DE(DW,"INDEX")=1 > G RE > C6 G C6S:$D(DE(6))[0 K DB > D ^IBXSC113 > C6S S X="" G:DG(DQ)=X C6F1 K DB > D ^IBXSC114 > C6F1 N X,X1,X2 S DIXR=185 D C6X1(U) K X2 M X2=X D C6X1("O" > D > . N DIEXARR M DIEXARR=X S DIEZCOND=1 > . I X1(1)'=X2(1) > . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND > . K EASDO2 > G C6F2 > C6X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^D > S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X( > S:$D(X)#2 X(2)=X > S X=$G(X(1)) > Q > C6F2 Q > X6 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X > I $D(X),X'?.ANP K X > Q > ; > 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".11;7",DV="NJ3,0XOa" > S DQ(7,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11 > S DE(DW)="C7^IBXSC19" > G RE > C7 G C7S:$D(DE(7))[0 K DB > D ^IBXSC115 > C7S S X="" G:DG(DQ)=X C7F1 K DB > D ^IBXSC116 > C7F1 Q > X7 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 > Q > ; > 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".13;1",DV="Fa",DU="" > S DE(DW)="C8^IBXSC19" > G RE > C8 G C8S:$D(DE(8))[0 K DB > D ^IBXSC117 > C8S S X="" G:DG(DQ)=X C8F1 K DB > D ^IBXSC118 > C8F1 Q > X8 K:$L(X)>20!($L(X)<4) X > I $D(X),X'?.ANP K X > Q > ; > 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".121;9",DV="RSX",DU= > S DE(DW)="C9^IBXSC19" > S DU="Y:YES;N:NO;" > G RE > C9 G C9S:$D(DE(9))[0 K DB > D ^IBXSC119 > C9S S X="" G:DG(DQ)=X C9F1 K DB > D ^IBXSC120 > C9F1 Q > X9 S DFN=DA I X="N" D TADD^DGLOCK > Q > ; > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) > X10 S:X="N" Y="@915" S:X="Y" DIE("NO^")="" > Q > 11 D:$D(DG)>9 F^DIE17 G ^IBXSC121 diff -y --suppress-common-lines ./VADemo/r1/IBXSC1.m ./VADemo/r2/r/IBXSC1.m IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), F | IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), F diff -y --suppress-common-lines ./VADemo/r1/IBXSC31.m ./VADemo/r2/r/IBXSC31.m IBXSC31 ; ;02/04/05 | IBXSC31 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC32.m ./VADemo/r2/r/IBXSC32.m IBXSC32 ; ;02/04/05 | IBXSC32 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC33.m ./VADemo/r2/r/IBXSC33.m IBXSC33 ; ;02/04/05 | IBXSC33 ; ;02/04/03 S DQ(1,2)="S Y(0)=Y S Y=$$TRANS^IBCNS2($G(DA,D0),Y)" | S DQ(1,2)="S Y(0)=Y S Y=$$TRANS^IBCNS2(DA,Y)" S DQ(3,2)="S Y(0)=Y S Y=$$TRANS^IBCNS2($G(DA,D0),Y)" | S DQ(3,2)="S Y(0)=Y S Y=$$TRANS^IBCNS2(DA,Y)" S X=DE(11),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA < S X=DE(11),DIC=DIE < ; < D ^IBXSC34 | S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, 20 D:$D(DG)>9 F^DIE17 G ^IBXSC35 | 20 D:$D(DG)>9 F^DIE17 G ^IBXSC34 diff -y --suppress-common-lines ./VADemo/r1/IBXSC34.m ./VADemo/r2/r/IBXSC34.m IBXSC34 ; ;02/04/05 | IBXSC34 ; ;02/04/03 S X=DG(DQ),DIC=DIE | D DE G BEGIN K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, | DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K S X=DG(DQ),DIC=DIE | I $D(^("M")) S %Z=^("M") S %=$P(%Z,U,6) S:%]"" DE(1)= K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA | I $D(^("M1")) S %Z=^("M1") S %=$P(%Z,U,1) S:%]"" DE(3 S X=DG(DQ),DIC=DIE | K %Z Q K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBI | ; > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="IBXSC34",DQ=1 > 1 S DW="M;6",DV="F",DU="",DLB="MAILING ADDRESS STREET2" > G RE > X1 K:$L(X)>35!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 S:X="" Y=107 > Q > 3 S DW="M1;1",DV="F",DU="",DLB="MAILING ADDRESS STREET3 > G RE > X3 K:$L(X)>35!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 4 S DW="M;7",DV="F",DU="",DLB="MAILING ADDRESS CITY",DI > G RE > X4 K:$L(X)>25!($L(X)<2) X > I $D(X),X'?.ANP K X > Q > ; > 5 S DW="M;8",DV="P5'",DU="",DLB="MAILING ADDRESS STATE" > S DU="DIC(5," > G RE > X5 Q > 6 S DW="M;9",DV="FX",DU="",DLB="MAILING ADDRESS ZIP COD > G RE > X6 S:$E(X,6)="-" X=$TR(X,"-") K:$L(X)>9!($L(X)<5)!'(X?5N > I $D(X),X'?.ANP K X > Q > ; > 7 S DQ=8 ;@34 > 8 S DQ=9 ;@999 > 9 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC35.m ./VADemo/r2/r/IBXSC35.m IBXSC35 ; ;02/04/05 | IBXSC35 ; ;02/04/03 D DE G BEGIN | ;; DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K | 1 N X,X1,X2 S DIXR=139 D X1(U) K X2 M X2=X D X1("F") K I $D(^("M")) S %Z=^("M") S %=$P(%Z,U,6) S:%]"" DE(1)= | D I $D(^("M1")) S %Z=^("M1") S %=$P(%Z,U,1) S:%]"" DE(3 | . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1 K %Z Q | . S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0) ; | . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND W W !?DL+DL-2,DLB_": " | . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) DELID^IBCEP3(DA,1) D: > K X M X=X2 D > . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1 > . S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0) > . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND > . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) SETID^IBCEP3(DA,1) D: > Q > X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",399,DIIENS,101,DION),$P($G(^D > S X(2)=$G(@DIEZTMP@("V",399,DIIENS,102,DION),$P($G(^D > S X(3)=$G(@DIEZTMP@("V",399,DIIENS,103,DION),$P($G(^D > S X(4)=$G(@DIEZTMP@("V",399,DIIENS,113,DION),$P($G(^D > S X(5)=$G(@DIEZTMP@("V",399,DIIENS,112,DION),$P($G(^D > S X(6)=$G(@DIEZTMP@("V",399,DIIENS,114,DION),$P($G(^D > S X=$G(X(1)) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC35",DQ=1 < 1 S DW="M;6",DV="F",DU="",DLB="MAILING ADDRESS STREET2" < G RE < X1 K:$L(X)>35!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S:X="" Y=107 < Q < 3 S DW="M1;1",DV="F",DU="",DLB="MAILING ADDRESS STREET3 < G RE < X3 K:$L(X)>35!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 4 S DW="M;7",DV="F",DU="",DLB="MAILING ADDRESS CITY",DI < G RE < X4 K:$L(X)>25!($L(X)<2) X < I $D(X),X'?.ANP K X < Q < ; < 5 S DW="M;8",DV="P5'",DU="",DLB="MAILING ADDRESS STATE" < S DU="DIC(5," < G RE < X5 Q < 6 S DW="M;9",DV="FX",DU="",DLB="MAILING ADDRESS ZIP COD < G RE < X6 S:$E(X,6)="-" X=$TR(X,"-") K:$L(X)>9!($L(X)<5)!'(X?5N < I $D(X),X'?.ANP K X < Q < ; < 7 S DQ=8 ;@34 < 8 S DQ=9 ;@999 < 9 G 0^DIE17 < Only in ./VADemo/r1/: IBXSC36.m diff -y --suppress-common-lines ./VADemo/r1/IBXSC3.m ./VADemo/r2/r/IBXSC3.m IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), F | IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), F K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, S DQ(22,2)="S Y(0)=Y S Y=$$TRANS^IBCNS2($G(DA,D0),Y)" | S DQ(22,2)="S Y(0)=Y S Y=$$TRANS^IBCNS2(DA,Y)" diff -y --suppress-common-lines ./VADemo/r1/IBXSC41.m ./VADemo/r2/r/IBXSC41.m IBXSC41 ; ;10/15/04 | IBXSC41 ; ;03/29/01 DE S DIE="^DGCR(399,D0,""OT"",",DIC=DIE,DP=399.048,DL=2, | DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2, I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S 1 S DW="0;1",DV="M*P399.1'",DU="",DLB="SNF/SA CARE",DIF | 1 S DW="0;1",DV="M*P399.1'",DU="",DLB="OCCURRENCE CODE" K ^DGCR(399,DA(1),"OT","B",$E(X,1,30),DA) | K ^DGCR(399,DA(1),"OC","B",$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 ^DGCR(399,DA(1),"OT","B",$E(X,1,30),DA)="" | S ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA)="" C1F1 Q | Q X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,5),+$P($G(^ | X1 S DIC("S")="I $P(^DGCR(399.1,+Y,0),U,4)=1,$S(+Y'=22:1 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RDX",DU="", | 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RD",DU="",D X2 S %DT="EX" D ^%DT S X=Y K:Y<1 X I $D(X) D OTDAT^IBCU4 | X2 S %DT="EX" D ^%DT S X=Y K:DTX) X 3 S DW="0;3",DV="RDX",DU="",DLB="END DATE",DIFLD=.03 | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 > X3 I $P(^DGCR(399,DA(1),0),U,19)'=2 S Y="@454" > Q > 4 S DW="0;3",DV="P5'",DU="",DLB="STATE",DIFLD=.03 > S DU="DIC(5," X3 S %DT="EX" D ^%DT S X=Y K:Y<1 X I $D(X) D OTDAT^IBCU4 | X4 Q > 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 > X5 S Y="@455" > Q > 6 S DQ=7 ;@454 > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 > X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10 ; | 8 S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 | G RE X4 S DGRVRCAL=1 | X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X 5 G 1^DIE17 | ; > 9 S DQ=10 ;@455 > 10 G 1^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC42.m ./VADemo/r2/r/IBXSC42.m IBXSC42 ; ;10/15/04 | IBXSC42 ; ;03/29/01 DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2, | DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,D I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% 1 S DW="0;1",DV="M*P399.1'",DU="",DLB="OCCURRENCE CODE" | 1 S DW="0;1",DV="M*P399.1'",DU="",DLB="CONDITION CODE", S DE(DW)="C1^IBXSC42" < C1 G C1S:$D(DE(1))[0 K DB | X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,15)" D ^DIC S X=DE(1),DIC=DIE < K ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA) < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA)="" < C1F1 Q < X1 S DIC("S")="I $P(^DGCR(399.1,+Y,0),U,4)=1,$S(+Y'=22:1 < 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RD",DU="",D | 2 G 1^DIE17 G RE < X2 S %DT="EX" D ^%DT S X=Y K:DTX) X < Q < ; < 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 < X3 I $P(^DGCR(399,DA(1),0),U,19)'=2 S Y="@454" < Q < 4 S DW="0;3",DV="P5'",DU="",DLB="STATE",DIFLD=.03 < S DU="DIC(5," < G RE < X4 Q < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 S Y="@455" < Q < 6 S DQ=7 ;@454 < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 < X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10 < Q < 8 S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04 < G RE < X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X < Q < ; < 9 S DQ=10 ;@455 < 10 G 1^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC43.m ./VADemo/r2/r/IBXSC43.m IBXSC43 ; ;10/15/04 | IBXSC43 ; ;03/29/01 DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,D | DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2, I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S 1 S DW="0;1",DV="M*P399.1'",DU="",DLB="CONDITION CODE", | 1 S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFL > S DE(DW)="C1^IBXSC43" X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,15)" D ^DIC | C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > K ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA) > C1S S X="" Q:DG(DQ)=X K DB > S X=DG(DQ),DIC=DIE > S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)="" > Q > X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DL > G RE > X2 K:$L(X)>9!($L(X)<1) X > I $D(X),X'?.ANP K X 2 G 1^DIE17 | 3 G 1^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC44.m ./VADemo/r2/r/IBXSC44.m IBXSC44 ; ;10/15/04 | IBXSC44 ; ;04/03/98 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < C1 G C1S:$D(DE(1))[0 K DB | C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE S X=DE(1),DIC=DIE < 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 X=DG(DQ),DIC=DIE < C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/IBXSC4.m ./VADemo/r2/r/IBXSC4.m IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), F | IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), F I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,9) S:%]"" DE(23)=% | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,9) S:%]"" DE(22)=% I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,8) S:%]"" DE(7)= | I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,8) S:%]"" DE(7)= 8 S D=0 K DE(1) ;48 | 8 S DQ=9 ;@42 S DIFLD=48,DGO="^IBXSC41",DC="3^399.048P^OT^",DV="399 | 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 S DU="DGCR(399.1," | X9 S:IBDR20'["42" Y="@43" G RE:D I $D(DSC(399.048))#2,$P(DSC(399.048),"I $D(^UT < S D=$S($D(^DGCR(399,DA,"OT",0)):$P(^(0),U,3,4),$O(^(0 < M8 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"OT",+D,0)) S DE(8) < G RE < R8 D DE < S D=$S($D(^DGCR(399,DA,"OT",0)):$P(^(0),U,3,4),1:1) G < ; < 9 S DQ=10 ;@42 < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S:IBDR20'["42" Y="@43" < 11 S DW="U;12",DV="*P399.1'",DU="",DLB="DISCHARGE STATUS | 10 S DW="U;12",DV="*P399.1'",DU="",DLB="DISCHARGE STATUS X11 S DIC("S")="I $P(^DGCR(399.1,+Y,0),""^"",6)=1" D ^DIC | X10 S DIC("S")="I $P(^DGCR(399.1,+Y,0),""^"",6)=1" D ^DIC 12 S DQ=13 ;@43 | 11 S DQ=12 ;@43 13 S DQ=14 ;@45 | 12 S DQ=13 ;@45 14 S DQ=15 ;@46 | 13 S DQ=14 ;@46 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) | 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) X15 S:IBDR20'["46" Y="@47" | X14 S:IBDR20'["46" Y="@47" 16 S D=0 K DE(1) ;41 | 15 S D=0 K DE(1) ;41 S DIFLD=41,DGO="^IBXSC42",DC="4^399.041IPA^OC^",DV="3 | S DIFLD=41,DGO="^IBXSC41",DC="4^399.041IPA^OC^",DV="3 G RE:D I $D(DSC(399.041))#2,$P(DSC(399.041),"I $D(^UT | G RE:D I $D(DSC(399.041))#2,$P(DSC(399.041),"I $D(^UT M16 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"OC",+D,0)) S DE(16 | M15 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"OC",+D,0)) S DE(15 R16 D DE | R15 D DE S D=$S($D(^DGCR(399,DA,"OC",0)):$P(^(0),U,3,4),1:1) G | S D=$S($D(^DGCR(399,DA,"OC",0)):$P(^(0),U,3,4),1:1) G 17 S DQ=18 ;@47 | 16 S DQ=17 ;@47 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) | 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) X18 S:IBDR20'["47" Y="@44" | X17 S:IBDR20'["47" Y="@44" 19 S D=0 K DE(1) ;40 | 18 S D=0 K DE(1) ;40 S DIFLD=40,DGO="^IBXSC43",DC="1^399.04PA^CC^",DV="399 | S DIFLD=40,DGO="^IBXSC42",DC="1^399.04PA^CC^",DV="399 G RE:D I $D(DSC(399.04))#2,$P(DSC(399.04),"I $D(^UTIL | G RE:D I $D(DSC(399.04))#2,$P(DSC(399.04),"I $D(^UTIL M19 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"CC",+D,0)) S DE(19 | M18 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"CC",+D,0)) S DE(18 R19 D DE | R18 D DE S D=$S($D(^DGCR(399,DA,"CC",0)):$P(^(0),U,3,4),1:1) G | S D=$S($D(^DGCR(399,DA,"CC",0)):$P(^(0),U,3,4),1:1) G 20 S DQ=21 ;@44 | 19 S DQ=20 ;@44 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) | 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) X21 S:IBDR20'["44" Y="@48" | X20 S:IBDR20'["44" Y="@48" 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) | 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) X22 S IBZ20=$P(^DGCR(399,DA,0),U,9) | X21 S IBZ20=$P(^DGCR(399,DA,0),U,9) 23 S DW="0;9",DV="SX",DU="",DLB="PROCEDURE CODING METHOD | 22 S DW="0;9",DV="SX",DU="",DLB="PROCEDURE CODING METHOD X23 S:X=4 X=5 | X22 S:X=4 X=5 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) | 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) X24 S IBPROT=X | X23 D PRO^IBCSC4B 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) | 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) X25 D PRO^IBCSC4B | X24 S IBASKCOD=1 > 25 S DQ=26 ;@48 X26 S IBASKCOD=1 | X26 S:IBDR20'["48" Y="@49" Q < 27 S DQ=28 ;@48 < 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) < X28 S:IBDR20'["48" Y="@49" < 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE) | 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) X29 I $P(^DGCR(399,DA,0),U,19)=2 S Y="@49" | X27 I $P(^DGCR(399,DA,0),U,19)=2 S Y="@49" 30 S D=0 K DE(1) ;47 | 28 S D=0 K DE(1) ;47 S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="39 | S DIFLD=47,DGO="^IBXSC43",DC="2^399.047PA^CV^",DV="39 G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UT | G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UT M30 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"CV",+D,0)) S DE(30 | M28 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"CV",+D,0)) S DE(28 R30 D DE | R28 D DE S D=$S($D(^DGCR(399,DA,"CV",0)):$P(^(0),U,3,4),1:1) G | S D=$S($D(^DGCR(399,DA,"CV",0)):$P(^(0),U,3,4),1:1) G 31 S DQ=32 ;@49 | 29 S DQ=30 ;@49 32 G 0^DIE17 | 30 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC51.m ./VADemo/r2/r/IBXSC51.m IBXSC51 ; ;10/15/04 | IBXSC51 ; ;03/29/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/IBXSC52.m ./VADemo/r2/r/IBXSC52.m IBXSC52 ; ;10/15/04 | IBXSC52 ; ;03/29/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/IBXSC53.m ./VADemo/r2/r/IBXSC53.m IBXSC53 ; ;10/15/04 | IBXSC53 ; ;03/29/01 diff -y --suppress-common-lines ./VADemo/r1/IBXSC54.m ./VADemo/r2/r/IBXSC54.m IBXSC54 ; ;10/15/04 | IBXSC54 ; ;03/29/01 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/IBXSC5.m ./VADemo/r2/r/IBXSC5.m IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), F | IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), F C8S S X="" G:DG(DQ)=X C8F1 K DB | C8S S X="" Q:DG(DQ)=X K DB C8F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/IBXSC61.m ./VADemo/r2/r/IBXSC61.m IBXSC61 ; ;10/15/04 | IBXSC61 ; ;02/04/03 S X=DE(23),DIC=DIE | S X=DG(DQ),DIC=DIE ; | X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR S X=DE(23),DIC=DIE | S X=DG(DQ),DIC=DIE S DGRVRCAL=2 | S DGRVRCAL=1 S X=DE(23),DIC=DIE | S X=DG(DQ),DIC=DIE D ALLID^IBCEP3(DA,.19,2) | D ALLID^IBCEP3(DA,.19,1) S X=DE(23),DIC=DIE | S X=DG(DQ),DIC=DIE ; | D BILLPNS^IBCU(DA) diff -y --suppress-common-lines ./VADemo/r1/IBXSC62.m ./VADemo/r2/r/IBXSC62.m IBXSC62 ; ;10/15/04 | IBXSC62 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=% > I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,1) S:%]"" DE(15) > I S %=$P(%Z,U,15) S:%]"" DE(20)=% > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="IBXSC62",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;19",DV="RP353'",DU > S DE(DW)="C1^IBXSC62" > S DU="IBE(353," > S X=$G(DIPA("FT1")) > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > ; > S X=DE(1),DIC=DIE > S DGRVRCAL=2 > S X=DE(1),DIC=DIE > D ALLID^IBCEP3(DA,.19,2) > S X=DE(1),DIC=DIE > ; > C1S S X="" G:DG(DQ)=X C1F1 K DB > C1F1 Q > X1 Q > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 S Y="@614" > Q > 3 S DQ=4 ;@615 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 > X4 D FTPRV^IBCEU5(DA) > Q > 5 S DQ=6 ;@62 > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 > X6 S:IBDR20'["62" Y="@63" > Q > 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="U;5",DV="RFOX",DU="" > S DQ(7,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:""" > G RE > X7 I $D(X) D YN^IBCU > I $D(X),X'?.ANP K X > Q > ; > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 > X8 S:X=0 Y=156 > Q > 9 S DW="U;7",DV="FOX",DU="",DLB="R.O.I. FORM(S) COMPLET > S DQ(9,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:""" > G RE > X9 I $D(X) D YN^IBCU > I $D(X),X'?.ANP K X > Q > ; > 10 S DW="U;6",DV="RFOX",DU="",DLB="ASSIGNMENT OF BENEFIT > S DQ(10,2)="S Y(0)=Y S Y=$S(Y="""":"""",""Yy1""[Y:""Y > G RE > X10 I $D(X) D YN^IBCU I $D(X) X:X=0 ^DD(399,156,9.3) K IB > I $D(X),X'?.ANP K X > Q > ; > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 S:'$D(IBOX) Y="@63" > Q > 12 S DW="U;3",DV="RFOX",DU="",DLB="POWER OF ATTORNEY COM > S DQ(12,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"" > G RE > X12 I $D(X) D YN^IBCU > I $D(X),X'?.ANP K X > Q > ; > 13 S DQ=14 ;@63 > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) > X14 S:IBDR20'["63" Y="@64" > Q > 15 S DW="U;1",DV="RDX",DU="",DLB="STATEMENT COVERS FROM" > S DE(DW)="C15^IBXSC62" > G RE > C15 G C15S:$D(DE(15))[0 K DB > S X=DE(15),DIC=DIE > ; > S X=DE(15),DIC=DIE > S DGRVRCAL=2 > S X=DE(15),DIC=DIE > ; > S X=DE(15),DIC=DIE > K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0), > C15S S X="" G:DG(DQ)=X C15F1 K DB > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399 > S X=DG(DQ),DIC=DIE > S DGRVRCAL=1 > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(39 > S X=DG(DQ),DIC=DIE > S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0), > C15F1 Q > X15 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT^IBCU4 > Q > ; > 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="U;2",DV="RDX",DU="" > S DE(DW)="C16^IBXSC62" > G RE > C16 G C16S:$D(DE(16))[0 K DB > S X=DE(16),DIC=DIE > ; > S X=DE(16),DIC=DIE > S DGRVRCAL=2 > C16S S X="" G:DG(DQ)=X C16F1 K DB > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399 > S X=DG(DQ),DIC=DIE > S DGRVRCAL=1 > C16F1 Q > X16 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT1^IBCU > Q > ; > 17 S DQ=18 ;@64 > 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) > X18 S:IBDR20'["64" Y="@65" > Q > 19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW="U;11",DV="*P399.1'" > S DE(DW)="C19^IBXSC62" > S DU="DGCR(399.1," > G RE > C19 G C19S:$D(DE(19))[0 K DB > S X=DE(19),DIC=DIE > ; > C19S S X="" G:DG(DQ)=X C19F1 K DB > D ^IBXSC63 > C19F1 Q > X19 S DIC("S")="I $P(^DGCR(399.1,+Y,0),""^"",5)=1" D ^DIC > Q > ; > 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="U;15",DV="F",DU="", > S DE(DW)="C20^IBXSC62" > G RE > C20 G C20S:$D(DE(20))[0 K DB > S X=DE(20),DIC=DIE > ; > S X=DE(20),DIC=DIE > ; > C20S S X="" G:DG(DQ)=X C20F1 K DB > D ^IBXSC64 > C20F1 Q > X20 K:$L(X)>6!($L(X)<1)!'(X?.N) X > I $D(X),X'?.ANP K X > Q > ; > 21 S DQ=22 ;@65 > 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) > X22 S:IBDR20'["65" Y="@66" > Q > 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) > X23 D RCD^IBCU1 > Q > 24 D:$D(DG)>9 F^DIE17,DE S DQ=24,D=0 K DE(1) ;42 > S DIFLD=42,DGO="^IBXSC65",DC="15^399.042IPA^RC^",DV=" > S DU="DGCR(399.2," > G RE:D I $D(DSC(399.042))#2,$P(DSC(399.042),"I $D(^UT > S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),$O(^(0 > M24 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"RC",+D,0)) S DE(24 > G RE > R24 D DE > S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),1:1) G > ; > 25 D:$D(DG)>9 F^DIE17 G ^IBXSC66 diff -y --suppress-common-lines ./VADemo/r1/IBXSC63.m ./VADemo/r2/r/IBXSC63.m IBXSC63 ; ;10/15/04 | IBXSC63 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K < I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=% < I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,1) S:%]"" DE(15) < I S %=$P(%Z,U,15) S:%]"" DE(20)=% < 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC63",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;19",DV="RP353'",DU < S DE(DW)="C1^IBXSC63" < S DU="IBE(353," < S X=$G(DIPA("FT1")) < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < ; < S X=DE(1),DIC=DIE < S DGRVRCAL=2 < S X=DE(1),DIC=DIE < D ALLID^IBCEP3(DA,.19,2) < S X=DE(1),DIC=DIE < ; < C1S S X="" G:DG(DQ)=X C1F1 K DB < X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR | X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR S X=DG(DQ),DIC=DIE < S DGRVRCAL=1 < S X=DG(DQ),DIC=DIE < D ALLID^IBCEP3(DA,.19,1) < S X=DG(DQ),DIC=DIE < D BILLPNS^IBCU(DA) < C1F1 Q < X1 Q < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S Y="@614" < Q < 3 S DQ=4 ;@615 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 D FTPRV^IBCEU5(DA) < Q < 5 S DQ=6 ;@62 < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 S:IBDR20'["62" Y="@63" < Q < 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="U;5",DV="RFOX",DU="" < S DQ(7,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:""" < G RE < X7 I $D(X) D YN^IBCU < I $D(X),X'?.ANP K X < Q < ; < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 S:X=0 Y=156 < Q < 9 S DW="U;7",DV="FOX",DU="",DLB="R.O.I. FORM(S) COMPLET < S DQ(9,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:""" < G RE < X9 I $D(X) D YN^IBCU < I $D(X),X'?.ANP K X < Q < ; < 10 S DW="U;6",DV="RFOX",DU="",DLB="ASSIGNMENT OF BENEFIT < S DQ(10,2)="S Y(0)=Y S Y=$S(Y="""":"""",""Yy1""[Y:""Y < G RE < X10 I $D(X) D YN^IBCU I $D(X) X:X=0 ^DD(399,156,9.3) K IB < I $D(X),X'?.ANP K X < Q < ; < 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) < X11 S:'$D(IBOX) Y="@63" < Q < 12 S DW="U;3",DV="RFOX",DU="",DLB="POWER OF ATTORNEY COM < S DQ(12,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"" < G RE < X12 I $D(X) D YN^IBCU < I $D(X),X'?.ANP K X < Q < ; < 13 S DQ=14 ;@63 < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 S:IBDR20'["63" Y="@64" < Q < 15 S DW="U;1",DV="RDX",DU="",DLB="STATEMENT COVERS FROM" < S DE(DW)="C15^IBXSC63" < G RE < C15 G C15S:$D(DE(15))[0 K DB < S X=DE(15),DIC=DIE < ; < S X=DE(15),DIC=DIE < S DGRVRCAL=2 < S X=DE(15),DIC=DIE < ; < S X=DE(15),DIC=DIE < K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0), < C15S S X="" G:DG(DQ)=X C15F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399 < S X=DG(DQ),DIC=DIE < S DGRVRCAL=1 < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(39 < S X=DG(DQ),DIC=DIE < S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0), < C15F1 Q < X15 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT^IBCU4 < Q < ; < 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="U;2",DV="RDX",DU="" < S DE(DW)="C16^IBXSC63" < G RE < C16 G C16S:$D(DE(16))[0 K DB < S X=DE(16),DIC=DIE < ; < S X=DE(16),DIC=DIE < S DGRVRCAL=2 < C16S S X="" G:DG(DQ)=X C16F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399 < S X=DG(DQ),DIC=DIE < S DGRVRCAL=1 < C16F1 Q < X16 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT1^IBCU < Q < ; < 17 S DQ=18 ;@64 < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 S:IBDR20'["64" Y="@65" < Q < 19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW="U;11",DV="*P399.1'" < S DE(DW)="C19^IBXSC63" < S DU="DGCR(399.1," < G RE < C19 G C19S:$D(DE(19))[0 K DB < S X=DE(19),DIC=DIE < ; < C19S S X="" G:DG(DQ)=X C19F1 K DB < D ^IBXSC64 < C19F1 Q < X19 S DIC("S")="I $P(^DGCR(399.1,+Y,0),""^"",5)=1" D ^DIC < Q < ; < 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="U;15",DV="F",DU="", < S DE(DW)="C20^IBXSC63" < G RE < C20 G C20S:$D(DE(20))[0 K DB < S X=DE(20),DIC=DIE < ; < S X=DE(20),DIC=DIE < ; < C20S S X="" G:DG(DQ)=X C20F1 K DB < D ^IBXSC65 < C20F1 Q < X20 K:$L(X)>6!($L(X)<1)!'(X?.N) X < I $D(X),X'?.ANP K X < Q < ; < 21 S DQ=22 ;@65 < 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) < X22 S:IBDR20'["65" Y="@66" < Q < 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) < X23 D RCD^IBCU1 < Q < 24 D:$D(DG)>9 F^DIE17,DE S DQ=24,D=0 K DE(1) ;42 < S DIFLD=42,DGO="^IBXSC66",DC="15^399.042IPA^RC^",DV=" < S DU="DGCR(399.2," < G RE:D I $D(DSC(399.042))#2,$P(DSC(399.042),"I $D(^UT < S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),$O(^(0 < M24 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"RC",+D,0)) S DE(24 < G RE < R24 D DE < S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),1:1) G < ; < 25 D:$D(DG)>9 F^DIE17 G ^IBXSC67 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC64.m ./VADemo/r2/r/IBXSC64.m IBXSC64 ; ;10/15/04 | IBXSC64 ; ;02/04/03 X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DG > S X=DG(DQ),DIC=DIE > X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR diff -y --suppress-common-lines ./VADemo/r1/IBXSC65.m ./VADemo/r2/r/IBXSC65.m IBXSC65 ; ;10/15/04 | IBXSC65 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S > I S %=$P(%Z,U,9) S:%]"" DE(6)=% S %=$P(%Z,U,10) S:%] > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="IBXSC65",DQ=1+D G B > 1 S DW="0;1",DV="MR*P399.2'",DU="",DLB="REVENUE CODE",D > S DE(DW)="C1^IBXSC65",DE(DW,"INDEX")=1 > S DU="DGCR(399.2," > G RE:'D S DQ=2 G 2 > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > K ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA) > S X=DE(1),DIC=DIE > I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) K ^DGCR(399,DA(1 > C1S S X="" G:DG(DQ)=X C1F1 K DB K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DG | S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)="" X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR | I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1 > C1F1 N X,X1,X2 S DIXR=53 D C1X1(U) K X2 M X2=X D C1X1("O") > I $G(X(1))]"" D > . I X(2)'=""&'$D(^TMP("IBCRRX",$J)) D DELPR^IBCU1(DA( > G C1F2 > C1X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",399.042,DIIENS,.01,DION),$P($ > S X(2)=$G(@DIEZTMP@("V",399.042,DIIENS,.15,DION),$P($ > S X=$G(X(1)) > Q > C1F2 Q > X1 S DIC("S")="I +$P(^(0),U,3)" D ^DIC K DIC S DIC=DIE,X > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ8,2",DU= > S DE(DW)="C2^IBXSC65" > G RE > C2 G C2S:$D(DE(2))[0 K DB > S X=DE(2),DIC=DIE > D 22^IBCU2 > C2S S X="" G:DG(DQ)=X C2F1 K DB > S X=DG(DQ),DIC=DIE > D 21^IBCU2 > C2F1 Q > X2 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) > Q > ; > 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="RNJ6,0X",DU > S DE(DW)="C3^IBXSC65" > G RE > C3 G C3S:$D(DE(3))[0 K DB > S X=DE(3),DIC=DIE > D 32^IBCU2 > C3S S X="" G:DG(DQ)=X C3F1 K DB > S X=DG(DQ),DIC=DIE > D 31^IBCU2 > C3F1 Q > X3 K:X'?1.N X I $D(X) S:X=0 X=1 > Q > ; > 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;4",DV="RNJ9,2XI",D > S DE(DW)="C4^IBXSC65" > G RE > C4 G C4S:$D(DE(4))[0 K DB > S X=DE(4),DIC=DIE > S DGXRF=2 D TC^IBCU2 K DGXRF > C4S S X="" G:DG(DQ)=X C4F1 K DB > S X=DG(DQ),DIC=DIE > S DGXRF=1 D TC^IBCU2 K DGXRF > C4F1 Q > X4 K:X?1.10N.1".".2N X > Q > ; > 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;5",DV="R*P399.1'", > S DE(DW)="C5^IBXSC65" > S DU="DGCR(399.1," > G RE > C5 G C5S:$D(DE(5))[0 K DB > S X=DE(5),DIC=DIE > K ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA > C5S S X="" G:DG(DQ)=X C5F1 K DB > S X=DG(DQ),DIC=DIE > S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA > C5F1 Q > X5 S DIC("S")="I $P(^(0),U,5)" D ^DIC K DIC S DIC=DIE,X= > Q > ; > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;9",DV="NJ8,2",DU=" > G RE > X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) > Q > ; > 7 S DW="0;6",DV="P81'",DU="",DLB="PROCEDURE",DIFLD=.06 > S DE(DW)="C7^IBXSC65" > S DU="ICPT(" > G RE > C7 G C7S:$D(DE(7))[0 K DB > S X=DE(7),DIC=DIE > K ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA) > S X=DE(7),DIC=DIE > K ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA) > C7S S X="" G:DG(DQ)=X C7F1 K DB > S X=DG(DQ),DIC=DIE > I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,3 > S X=DG(DQ),DIC=DIE > I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E > C7F1 Q > X7 Q > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 > X8 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@658" > Q > 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;7",DV="P40.8'X",DU > S DE(DW)="C9^IBXSC65" > S DU="DG(40.8," > G RE > C9 G C9S:$D(DE(9))[0 K DB > S X=DE(9),DIC=DIE > K ^DGCR(399,"ASC1",+$P(^DGCR(399,DA(1),"RC",DA,0),U,6 > S X=DE(9),DIC=DIE > K ^DGCR(399,"ASC2",DA(1),+$P(^DGCR(399,DA(1),"RC",DA, > C9S S X="" G:DG(DQ)=X C9F1 K DB > S X=DG(DQ),DIC=DIE > I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR > S X=DG(DQ),DIC=DIE > I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P > C9F1 Q > X9 Q > 10 S DQ=11 ;@658 > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) S Y="@659" > Q > 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;10",DV="S",DU="", > S DE(DW)="C12^IBXSC65" > S DU="1:INPT BS;2:OPT VST DT;3:RX;4:CPT;5:PROS;6:DRG; > G RE > C12 G C12S:$D(DE(12))[0 K DB > D ^IBXSC67 > C12S S X="" G:DG(DQ)=X C12F1 K DB > S X=DG(DQ),DIC=DIE > ; > S X=DG(DQ),DIC=DIE > ; > C12F1 Q > X12 Q > 13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="0;12",DV="S",DU="", > S DU="1:INSTITUTIONAL;2:PROFESSIONAL;" > G RE > X13 Q > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) > X14 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)'=4!'$P(^DGC > Q > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) > X15 D LINKCPT^IBCEU5(DA(1),DA) > Q > 16 S DQ=17 ;@659 > 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) > X17 I $$FT^IBCEF(DA(1))'=3 S Y="@6591" > Q > 18 D:$D(DG)>9 F^DIE17 G ^IBXSC68 diff -y --suppress-common-lines ./VADemo/r1/IBXSC66.m ./VADemo/r2/r/IBXSC66.m IBXSC66 ; ;10/15/04 | IBXSC66 ; ;02/04/03 DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2, | DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S | I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,2) S:%]"" DE(1 I S %=$P(%Z,U,9) S:%]"" DE(6)=% S %=$P(%Z,U,10) S:%] | I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,4) S:%]"" DE(1 BEGIN S DNM="IBXSC66",DQ=1+D G B | BEGIN S DNM="IBXSC66",DQ=1 1 S DW="0;1",DV="MR*P399.2'",DU="",DLB="REVENUE CODE",D | 1 S DW="U1;2",DV="NJ8,2",DU="",DLB="OFFSET AMOUNT",DIFL S DE(DW)="C1^IBXSC66",DE(DW,"INDEX")=1 | S DE(DW)="C1^IBXSC66" S DU="DGCR(399.2," | G RE G RE:'D S DQ=2 G 2 < K ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA) | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^ S X=DE(1),DIC=DIE < I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) K ^DGCR(399,DA(1 < S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1 < C1F1 N X,X1,X2 S DIXR=53 D C1X1(U) K X2 M X2=X D C1X1("O") < I $G(X(1))]"" D < . I X(2)'=""&'$D(^TMP("IBCRRX",$J)) D DELPR^IBCU1(DA( < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",399.042,DIIENS,.01,DION),$P($ < S X(2)=$G(@DIEZTMP@("V",399.042,DIIENS,.15,DION),$P($ < S X=$G(X(1)) < Q < C1F2 Q < X1 S DIC("S")="I +$P(^(0),U,3)" D ^DIC K DIC S DIC=DIE,X < Q < 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ8,2",DU= | C1F1 Q S DE(DW)="C2^IBXSC66" | X1 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) G RE < C2 G C2S:$D(DE(2))[0 K DB < S X=DE(2),DIC=DIE < D 22^IBCU2 < C2S S X="" G:DG(DQ)=X C2F1 K DB < S X=DG(DQ),DIC=DIE < D 21^IBCU2 < C2F1 Q < X2 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="RNJ6,0X",DU | 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 S DE(DW)="C3^IBXSC66" | X2 S:'X Y="@657" G RE < C3 G C3S:$D(DE(3))[0 K DB < S X=DE(3),DIC=DIE < D 32^IBCU2 < C3S S X="" G:DG(DQ)=X C3F1 K DB < S X=DG(DQ),DIC=DIE < D 31^IBCU2 < C3F1 Q < X3 K:X'?1.N X I $D(X) S:X=0 X=1 < ; | 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="U1;3",DV="FX",DU="", 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;4",DV="RNJ9,2XI",D < S DE(DW)="C4^IBXSC66" < C4 G C4S:$D(DE(4))[0 K DB | X3 K:$L(X)>24!($L(X)<3) X S X=DE(4),DIC=DIE | I $D(X),X'?.ANP K X S DGXRF=2 D TC^IBCU2 K DGXRF < C4S S X="" G:DG(DQ)=X C4F1 K DB < S X=DG(DQ),DIC=DIE < S DGXRF=1 D TC^IBCU2 K DGXRF < C4F1 Q < X4 K:X?1.10N.1".".2N X < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;5",DV="R*P399.1'", | 4 S DQ=5 ;@657 S DE(DW)="C5^IBXSC66" | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 S DU="DGCR(399.1," | X5 I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@66" G RE < C5 G C5S:$D(DE(5))[0 K DB < S X=DE(5),DIC=DIE < K ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA < C5S S X="" G:DG(DQ)=X C5F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA < C5F1 Q < X5 S DIC("S")="I $P(^(0),U,5)" D ^DIC K DIC S DIC=DIE,X= < ; | 6 S DW="U1;10",DV="RNJ10,2",DU="",DLB="*FY 1 CHARGES",D 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;9",DV="NJ8,2",DU=" < X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) | X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X< 7 S DW="0;6",DV="*P81'",DU="",DLB="PROCEDURE",DIFLD=.06 | 7 S DQ=8 ;@66 S DE(DW)="C7^IBXSC66" | 8 S DQ=9 ;@67 S DU="ICPT(" | 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 > X9 S:IBDR20'["67" Y="@68" > Q > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) > X10 S:'$D(^DGCR(399,DA,"I1")) Y="@672" > Q > 11 S DW="U2;4",DV="NJ11,2",DU="",DLB="PRIMARY PRIOR PAYM > S DE(DW)="C11^IBXSC66" C7 G C7S:$D(DE(7))[0 K DB | C11 G C11S:$D(DE(11))[0 K DB S X=DE(7),DIC=DIE | S X=DE(11),DIC=DIE K ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA) | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, S X=DE(7),DIC=DIE | S X=DE(11),DIC=DIE K ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA) | ; C7S S X="" G:DG(DQ)=X C7F1 K DB | C11S S X="" G:DG(DQ)=X C11F1 K DB I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,3 | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, C7F1 Q | C11F1 Q X7 S ICPTVDT=$$BDATE^IBACSV($G(DA(1))),DIC("S")="I $$CPT | X11 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 | 12 S DQ=13 ;@672 X8 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@658" | 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 S:'$D(^DGCR(399,DA,"I2")) Y="@673" 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;7",DV="P40.8'X",DU | 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW="U2;5",DV="NJ11,2",D S DE(DW)="C9^IBXSC66" | S DE(DW)="C14^IBXSC66" S DU="DG(40.8," < C9 G C9S:$D(DE(9))[0 K DB | C14 G C14S:$D(DE(14))[0 K DB S X=DE(9),DIC=DIE | S X=DE(14),DIC=DIE K ^DGCR(399,"ASC1",+$P(^DGCR(399,DA(1),"RC",DA,0),U,6 | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, S X=DE(9),DIC=DIE | S X=DE(14),DIC=DIE K ^DGCR(399,"ASC2",DA(1),+$P(^DGCR(399,DA(1),"RC",DA, | ; C9S S X="" G:DG(DQ)=X C9F1 K DB | C14S S X="" G:DG(DQ)=X C14F1 K DB I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, C9F1 Q | C14F1 Q X9 Q | X14 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X 10 S DQ=11 ;@658 | Q 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) | ; X11 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) S Y="@659" | 15 S DQ=16 ;@673 > 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) > X16 S:'$D(^DGCR(399,DA,"I3")) Y="@68" 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;10",DV="S",DU="", | 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="U2;6",DV="NJ11,2",D S DE(DW)="C12^IBXSC66" | S DE(DW)="C17^IBXSC66" S DU="1:INPT BS;2:OPT VST DT;3:RX;4:CPT;5:PROS;6:DRG; < C12 G C12S:$D(DE(12))[0 K DB | C17 G C17S:$D(DE(17))[0 K DB D ^IBXSC68 | S X=DE(17),DIC=DIE C12S S X="" G:DG(DQ)=X C12F1 K DB | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, S X=DG(DQ),DIC=DIE | S X=DE(17),DIC=DIE > C17S S X="" G:DG(DQ)=X C17F1 K DB ; | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, C12F1 Q | S X=DG(DQ),DIC=DIE X12 Q | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, 13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="0;12",DV="S",DU="", | C17F1 Q S DU="1:INSTITUTIONAL;2:PROFESSIONAL;" | X17 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X G RE < X13 Q < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)'=4!'$P(^DGC < Q < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 D LINKCPT^IBCEU5(DA(1),DA) < 16 S DQ=17 ;@659 | ; 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) | 18 S DQ=19 ;@68 X17 I $$FT^IBCEF(DA(1))'=3 S Y="@6591" | 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) > X19 K DIE("NO^") 18 D:$D(DG)>9 F^DIE17 G ^IBXSC69 | 20 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC67.m ./VADemo/r2/r/IBXSC67.m IBXSC67 ; ;10/15/04 | IBXSC67 ; ;02/04/03 D DE G BEGIN | S X=DE(12),DIC=DIE DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K | K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y( I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,2) S:%]"" DE(1 | S X=DE(12),DIC=DIE I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,4) S:%]"" DE(1 | X ^DD(399.042,.1,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^D 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC67",DQ=1 < 1 S DW="U1;2",DV="NJ8,2",DU="",DLB="OFFSET AMOUNT",DIFL < S DE(DW)="C1^IBXSC67" < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^ < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < ; < C1F1 Q < X1 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S:'X Y="@657" < Q < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="U1;3",DV="FX",DU="", < G RE < X3 K:$L(X)>24!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 4 S DQ=5 ;@657 < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@66" < Q < 6 S DW="U1;10",DV="RNJ10,2",DU="",DLB="*FY 1 CHARGES",D < G RE < X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X< < Q < ; < 7 S DQ=8 ;@66 < 8 S DQ=9 ;@67 < 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 < X9 S:IBDR20'["67" Y="@68" < Q < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S:'$D(^DGCR(399,DA,"I1")) Y="@672" < Q < 11 S DW="U2;4",DV="NJ11,2",DU="",DLB="PRIMARY PRIOR PAYM < S DE(DW)="C11^IBXSC67" < G RE < C11 G C11S:$D(DE(11))[0 K DB < S X=DE(11),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DE(11),DIC=DIE < ; < C11S S X="" G:DG(DQ)=X C11F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C11F1 Q < X11 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X < Q < ; < 12 S DQ=13 ;@672 < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 S:'$D(^DGCR(399,DA,"I2")) Y="@673" < Q < 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW="U2;5",DV="NJ11,2",D < S DE(DW)="C14^IBXSC67" < G RE < C14 G C14S:$D(DE(14))[0 K DB < S X=DE(14),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DE(14),DIC=DIE < ; < C14S S X="" G:DG(DQ)=X C14F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C14F1 Q < X14 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X < Q < ; < 15 S DQ=16 ;@673 < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 S:'$D(^DGCR(399,DA,"I3")) Y="@68" < Q < 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="U2;6",DV="NJ11,2",D < S DE(DW)="C17^IBXSC67" < G RE < C17 G C17S:$D(DE(17))[0 K DB < S X=DE(17),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DE(17),DIC=DIE < ; < C17S S X="" G:DG(DQ)=X C17F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C17F1 Q < X17 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X < Q < ; < 18 S DQ=19 ;@68 < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 K DIE("NO^") < Q < 20 G 0^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC68.m ./VADemo/r2/r/IBXSC68.m IBXSC68 ; ;10/15/04 | IBXSC68 ; ;02/04/03 S X=DE(12),DIC=DIE | D DE G BEGIN K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y( | DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2, S X=DE(12),DIC=DIE | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,13) S:%]"" DE(1)=% X ^DD(399.042,.1,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^D | 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="IBXSC68",DQ=1 > 1 S DW="0;13",DV="F",DU="",DLB="UB92 FORM LOCATOR 49",D > G RE > X1 K:$L(X)>4!($L(X)<1) X > I $D(X),X'?.ANP K X > Q > ; > 2 S DQ=3 ;@6591 > 3 G 1^DIE17 Only in ./VADemo/r1/: IBXSC69.m diff -y --suppress-common-lines ./VADemo/r1/IBXSC6.m ./VADemo/r2/r/IBXSC6.m IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), F | IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), F S DE(DW)="C17^IBXSC6" < C17 G C17S:$D(DE(17))[0 K DB < S X=DE(17),DIC=DIE < ; < S X=DE(17),DIC=DIE < ; < S X=DE(17),DIC=DIE < ; < C17S S X="" G:DG(DQ)=X C17F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C17F1 Q < 18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="0;27",DV="S",DU="", | 18 S DW="0;27",DV="S",DU="",DLB="BILL CHARGE TYPE",DIFLD D ^IBXSC61 | S X=DE(23),DIC=DIE > ; > S X=DE(23),DIC=DIE > S DGRVRCAL=2 > S X=DE(23),DIC=DIE > D ALLID^IBCEP3(DA,.19,2) > S X=DE(23),DIC=DIE > ; D ^IBXSC62 | D ^IBXSC61 27 D:$D(DG)>9 F^DIE17 G ^IBXSC63 | 27 D:$D(DG)>9 F^DIE17 G ^IBXSC62 Only in ./VADemo/r1/: IBXSC710.m diff -y --suppress-common-lines ./VADemo/r1/IBXSC71.m ./VADemo/r2/r/IBXSC71.m IBXSC71 ; ;10/15/04 | IBXSC71 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC72.m ./VADemo/r2/r/IBXSC72.m IBXSC72 ; ;10/15/04 | IBXSC72 ; ;02/04/03 S X=DG(DQ),DIC=DIE | S X=DE(27),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, | ; S X=DG(DQ),DIC=DIE | S X=DE(27),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, | S DGRVRCAL=2 S X=DG(DQ),DIC=DIE | S X=DE(27),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, | D ALLID^IBCEP3(DA,.19,2) > S X=DE(27),DIC=DIE > ; diff -y --suppress-common-lines ./VADemo/r1/IBXSC73.m ./VADemo/r2/r/IBXSC73.m IBXSC73 ; ;10/15/04 | IBXSC73 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K < I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=%,D < I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,1) S:%]"" DE(19) < 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC73",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;19",DV="RP353'",DU < S DE(DW)="C1^IBXSC73" < S DU="IBE(353," < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < ; < S X=DE(1),DIC=DIE < S DGRVRCAL=2 < S X=DE(1),DIC=DIE < D ALLID^IBCEP3(DA,.19,2) < S X=DE(1),DIC=DIE < ; < C1S S X="" G:DG(DQ)=X C1F1 K DB < C1F1 Q < X1 Q < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S DIPA("FT")=$P($G(^DGCR(399,DA,0)),U,19) < Q < 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 < X3 I $P($G(^IBE(353,+DIPA("FT"),2)),U,2)="P",$P($G(^(2)) < Q < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 W !,*7,"Must be a printable national form type" < Q < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;19",DV="RP353'",DU < S DE(DW)="C5^IBXSC73" < S DU="IBE(353," < S X=$G(DIPA("FT1")) < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C5 G C5S:$D(DE(5))[0 K DB < S X=DE(5),DIC=DIE < ; < S X=DE(5),DIC=DIE < S DGRVRCAL=2 < S X=DE(5),DIC=DIE < D ALLID^IBCEP3(DA,.19,2) < S X=DE(5),DIC=DIE < ; < C5S S X="" G:DG(DQ)=X C5F1 K DB < S X=DG(DQ),DIC=DIE < X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR < S X=DG(DQ),DIC=DIE < S DGRVRCAL=1 < S X=DG(DQ),DIC=DIE < D ALLID^IBCEP3(DA,.19,1) < S X=DG(DQ),DIC=DIE < D BILLPNS^IBCU(DA) < C5F1 Q < X5 Q < 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 < X6 S Y="@714" < Q < 7 S DQ=8 ;@715 < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 D FTPRV^IBCEU5(DA) < Q < 9 S DQ=10 ;@72 < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S:IBDR20'["72" Y="@73" < Q < 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="U;5",DV="RFOX",DU=" < S DQ(11,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"" < G RE < X11 I $D(X) D YN^IBCU < I $D(X),X'?.ANP K X < Q < ; < 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) < X12 S:X=0 Y=156 < Q < 13 S DW="U;7",DV="FOX",DU="",DLB="R.O.I. FORM(S) COMPLET < S DQ(13,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"" < G RE < X13 I $D(X) D YN^IBCU < I $D(X),X'?.ANP K X < Q < ; < 14 S DW="U;6",DV="RFOX",DU="",DLB="ASSIGNMENT OF BENEFIT < S DQ(14,2)="S Y(0)=Y S Y=$S(Y="""":"""",""Yy1""[Y:""Y < G RE < X14 I $D(X) D YN^IBCU I $D(X) X:X=0 ^DD(399,156,9.3) K IB < I $D(X),X'?.ANP K X < Q < ; < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 S:'$D(IBOX) Y="@73" < Q < 16 S DW="U;3",DV="RFOX",DU="",DLB="POWER OF ATTORNEY COM < S DQ(16,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"" < G RE < X16 I $D(X) D YN^IBCU < I $D(X),X'?.ANP K X < Q < ; < 17 S DQ=18 ;@73 < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 S:IBDR20'["73" Y="@75" < Q < 19 S DW="U;1",DV="RDX",DU="",DLB="STATEMENT COVERS FROM" < S DE(DW)="C19^IBXSC73" < G RE < C19 G C19S:$D(DE(19))[0 K DB < S X=DE(19),DIC=DIE < ; < S X=DE(19),DIC=DIE < S DGRVRCAL=2 < S X=DE(19),DIC=DIE < ; < S X=DE(19),DIC=DIE < K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0), < C19S S X="" G:DG(DQ)=X C19F1 K DB < D ^IBXSC74 < C19F1 Q < X19 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT^IBCU4 < Q < ; < 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="U;2",DV="RDX",DU="" < S DE(DW)="C20^IBXSC73" < G RE < C20 G C20S:$D(DE(20))[0 K DB < S X=DE(20),DIC=DIE < ; < S X=DE(20),DIC=DIE < S DGRVRCAL=2 < C20S S X="" G:DG(DQ)=X C20F1 K DB < D ^IBXSC75 < C20F1 Q < X20 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT1^IBCU < Q < ; < 21 S DQ=22 ;@75 < 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) < X22 S:IBDR20'["75" Y="@76" < Q < 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) < X23 D RCD^IBCU1 < Q < 24 D:$D(DG)>9 F^DIE17,DE S DQ=24,D=0 K DE(1) ;42 < S DIFLD=42,DGO="^IBXSC76",DC="15^399.042IPA^RC^",DV=" < S DU="DGCR(399.2," < G RE:D I $D(DSC(399.042))#2,$P(DSC(399.042),"I $D(^UT < S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),$O(^(0 < M24 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"RC",+D,0)) S DE(24 < G RE < R24 D DE < S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),1:1) G < ; < 25 D:$D(DG)>9 F^DIE17 G ^IBXSC77 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC74.m ./VADemo/r2/r/IBXSC74.m IBXSC74 ; ;10/15/04 | IBXSC74 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=% > I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,1) S:%]"" DE(15) > I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,2) 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="IBXSC74",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;19",DV="RP353'",DU > S DE(DW)="C1^IBXSC74" > S DU="IBE(353," > S X=$G(DIPA("FT1")) > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > ; > S X=DE(1),DIC=DIE > S DGRVRCAL=2 > S X=DE(1),DIC=DIE > D ALLID^IBCEP3(DA,.19,2) > S X=DE(1),DIC=DIE > ; > C1S S X="" G:DG(DQ)=X C1F1 K DB > S X=DG(DQ),DIC=DIE > X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR > S X=DG(DQ),DIC=DIE > S DGRVRCAL=1 > S X=DG(DQ),DIC=DIE > D ALLID^IBCEP3(DA,.19,1) > S X=DG(DQ),DIC=DIE > D BILLPNS^IBCU(DA) > C1F1 Q > X1 Q > 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 > X2 S Y="@714" > Q > 3 S DQ=4 ;@715 > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 > X4 D FTPRV^IBCEU5(DA) > Q > 5 S DQ=6 ;@72 > 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 > X6 S:IBDR20'["72" Y="@73" > Q > 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="U;5",DV="RFOX",DU="" > S DQ(7,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:""" > G RE > X7 I $D(X) D YN^IBCU > I $D(X),X'?.ANP K X > Q > ; > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 > X8 S:X=0 Y=156 > Q > 9 S DW="U;7",DV="FOX",DU="",DLB="R.O.I. FORM(S) COMPLET > S DQ(9,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:""" > G RE > X9 I $D(X) D YN^IBCU > I $D(X),X'?.ANP K X > Q > ; > 10 S DW="U;6",DV="RFOX",DU="",DLB="ASSIGNMENT OF BENEFIT > S DQ(10,2)="S Y(0)=Y S Y=$S(Y="""":"""",""Yy1""[Y:""Y > G RE > X10 I $D(X) D YN^IBCU I $D(X) X:X=0 ^DD(399,156,9.3) K IB > I $D(X),X'?.ANP K X > Q > ; > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 S:'$D(IBOX) Y="@73" > Q > 12 S DW="U;3",DV="RFOX",DU="",DLB="POWER OF ATTORNEY COM > S DQ(12,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"" > G RE > X12 I $D(X) D YN^IBCU > I $D(X),X'?.ANP K X > Q > ; > 13 S DQ=14 ;@73 > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) > X14 S:IBDR20'["73" Y="@75" > Q > 15 S DW="U;1",DV="RDX",DU="",DLB="STATEMENT COVERS FROM" > S DE(DW)="C15^IBXSC74" > G RE > C15 G C15S:$D(DE(15))[0 K DB > S X=DE(15),DIC=DIE > ; > S X=DE(15),DIC=DIE > S DGRVRCAL=2 > S X=DE(15),DIC=DIE > ; > S X=DE(15),DIC=DIE > K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0), > C15S S X="" G:DG(DQ)=X C15F1 K DB > C15F1 Q > X15 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT^IBCU4 > Q > ; > 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="U;2",DV="RDX",DU="" > S DE(DW)="C16^IBXSC74" > G RE > C16 G C16S:$D(DE(16))[0 K DB > S X=DE(16),DIC=DIE > ; > S X=DE(16),DIC=DIE > S DGRVRCAL=2 > C16S S X="" G:DG(DQ)=X C16F1 K DB > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399 > S X=DG(DQ),DIC=DIE > S DGRVRCAL=1 > C16F1 Q > X16 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT1^IBCU > Q > ; > 17 S DQ=18 ;@75 > 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) > X18 S:IBDR20'["75" Y="@76" > Q > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) > X19 D RCD^IBCU1 > Q > 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,D=0 K DE(1) ;42 > S DIFLD=42,DGO="^IBXSC75",DC="15^399.042IPA^RC^",DV=" > S DU="DGCR(399.2," > G RE:D I $D(DSC(399.042))#2,$P(DSC(399.042),"I $D(^UT > S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),$O(^(0 > M20 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"RC",+D,0)) S DE(20 > G RE > R20 D DE > S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),1:1) G > ; > 21 S DW="U1;2",DV="NJ8,2",DU="",DLB="OFFSET AMOUNT",DIFL > S DE(DW)="C21^IBXSC74" > G RE > C21 G C21S:$D(DE(21))[0 K DB > D ^IBXSC76 > C21S S X="" G:DG(DQ)=X C21F1 K DB > D ^IBXSC77 > C21F1 Q > X21 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) > Q > ; > 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) > X22 S:'X Y="@757" > Q > 23 D:$D(DG)>9 F^DIE17 G ^IBXSC78 diff -y --suppress-common-lines ./VADemo/r1/IBXSC75.m ./VADemo/r2/r/IBXSC75.m IBXSC75 ; ;10/15/04 | IBXSC75 ; ;02/04/03 > D DE G BEGIN > DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2, > I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S > I S %=$P(%Z,U,10) S:%]"" DE(11)=% S %=$P(%Z,U,12) S: > 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="IBXSC75",DQ=1+D G B > 1 S DW="0;1",DV="MR*P399.2'",DU="",DLB="REVENUE CODE",D > S DE(DW)="C1^IBXSC75",DE(DW,"INDEX")=1 > S DU="DGCR(399.2," > G RE:'D S DQ=2 G 2 > C1 G C1S:$D(DE(1))[0 K DB > S X=DE(1),DIC=DIE > K ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA) > S X=DE(1),DIC=DIE > I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) K ^DGCR(399,DA(1 > C1S S X="" G:DG(DQ)=X C1F1 K DB K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399 | S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)="" S DGRVRCAL=1 | I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1 > C1F1 N X,X1,X2 S DIXR=53 D C1X1(U) K X2 M X2=X D C1X1("O") > I $G(X(1))]"" D > . I X(2)'=""&'$D(^TMP("IBCRRX",$J)) D DELPR^IBCU1(DA( > G C1F2 > C1X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",399.042,DIIENS,.01,DION),$P($ > S X(2)=$G(@DIEZTMP@("V",399.042,DIIENS,.15,DION),$P($ > S X=$G(X(1)) > Q > C1F2 Q > X1 S DIC("S")="I +$P(^(0),U,3)" D ^DIC K DIC S DIC=DIE,X > Q > ; > 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ8,2",DU= > S DE(DW)="C2^IBXSC75" > G RE > C2 G C2S:$D(DE(2))[0 K DB > S X=DE(2),DIC=DIE > D 22^IBCU2 > C2S S X="" G:DG(DQ)=X C2F1 K DB > S X=DG(DQ),DIC=DIE > D 21^IBCU2 > C2F1 Q > X2 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) > Q > ; > 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="RNJ6,0X",DU > S DE(DW)="C3^IBXSC75" > G RE > C3 G C3S:$D(DE(3))[0 K DB > S X=DE(3),DIC=DIE > D 32^IBCU2 > C3S S X="" G:DG(DQ)=X C3F1 K DB > S X=DG(DQ),DIC=DIE > D 31^IBCU2 > C3F1 Q > X3 K:X'?1.N X I $D(X) S:X=0 X=1 > Q > ; > 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;4",DV="RNJ9,2XI",D > S DE(DW)="C4^IBXSC75" > G RE > C4 G C4S:$D(DE(4))[0 K DB > S X=DE(4),DIC=DIE > S DGXRF=2 D TC^IBCU2 K DGXRF > C4S S X="" G:DG(DQ)=X C4F1 K DB > S X=DG(DQ),DIC=DIE > S DGXRF=1 D TC^IBCU2 K DGXRF > C4F1 Q > X4 K:X?1.10N.1".".2N X > Q > ; > 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;5",DV="R*P399.1'", > S DE(DW)="C5^IBXSC75" > S DU="DGCR(399.1," > G RE > C5 G C5S:$D(DE(5))[0 K DB > S X=DE(5),DIC=DIE > K ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA > C5S S X="" G:DG(DQ)=X C5F1 K DB > S X=DG(DQ),DIC=DIE > S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA > C5F1 Q > X5 S DIC("S")="I $P(^(0),U,5)" D ^DIC K DIC S DIC=DIE,X= > Q > ; > 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;6",DV="P81'",DU="" > S DE(DW)="C6^IBXSC75" > S DU="ICPT(" > G RE > C6 G C6S:$D(DE(6))[0 K DB > S X=DE(6),DIC=DIE > K ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA) > S X=DE(6),DIC=DIE > K ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA) > C6S S X="" G:DG(DQ)=X C6F1 K DB > S X=DG(DQ),DIC=DIE > I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,3 > S X=DG(DQ),DIC=DIE > I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E > C6F1 Q > X6 Q > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 > X7 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758" > Q > 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;7",DV="P40.8'X",DU > S DE(DW)="C8^IBXSC75" > S DU="DG(40.8," > S X=$$DEFDIV^IBCU7(DA(1)) > S Y=X > G Y > C8 G C8S:$D(DE(8))[0 K DB > S X=DE(8),DIC=DIE > K ^DGCR(399,"ASC1",+$P(^DGCR(399,DA(1),"RC",DA,0),U,6 > S X=DE(8),DIC=DIE > K ^DGCR(399,"ASC2",DA(1),+$P(^DGCR(399,DA(1),"RC",DA, > C8S S X="" G:DG(DQ)=X C8F1 K DB > S X=DG(DQ),DIC=DIE > I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR > S X=DG(DQ),DIC=DIE > I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P > C8F1 Q > X8 Q > 9 S DQ=10 ;@758 > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) > X10 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDE > Q > 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="0;10",DV="S",DU="", > S DE(DW)="C11^IBXSC75" > S DU="1:INPT BS;2:OPT VST DT;3:RX;4:CPT;5:PROS;6:DRG; > G RE > C11 G C11S:$D(DE(11))[0 K DB > S X=DE(11),DIC=DIE > K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y( > S X=DE(11),DIC=DIE > X ^DD(399.042,.1,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^D > C11S S X="" G:DG(DQ)=X C11F1 K DB > S X=DG(DQ),DIC=DIE > ; > S X=DG(DQ),DIC=DIE > ; > C11F1 Q > X11 Q > 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;12",DV="S",DU="", > S DU="1:INSTITUTIONAL;2:PROFESSIONAL;" > G RE > X12 Q > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P > Q > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) > X14 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@758 > Q > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) > X15 S DGRVRCAL=1 > Q > 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) > X16 D LINKRX^IBCEU5(DA(1),DA) > Q > 17 D:$D(DG)>9 F^DIE17 G ^IBXSC79 diff -y --suppress-common-lines ./VADemo/r1/IBXSC76.m ./VADemo/r2/r/IBXSC76.m IBXSC76 ; ;10/15/04 | IBXSC76 ; ;02/04/03 D DE G BEGIN | S X=DE(21),DIC=DIE DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2, | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S < I S %=$P(%Z,U,10) S:%]"" DE(11)=% S %=$P(%Z,U,12) S: < 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC76",DQ=1+D G B < 1 S DW="0;1",DV="MR*P399.2'",DU="",DLB="REVENUE CODE",D < S DE(DW)="C1^IBXSC76",DE(DW,"INDEX")=1 < S DU="DGCR(399.2," < G RE:'D S DQ=2 G 2 < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < K ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA) < S X=DE(1),DIC=DIE < I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) K ^DGCR(399,DA(1 < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)="" < S X=DG(DQ),DIC=DIE < I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1 < C1F1 N X,X1,X2 S DIXR=53 D C1X1(U) K X2 M X2=X D C1X1("O") < I $G(X(1))]"" D < . I X(2)'=""&'$D(^TMP("IBCRRX",$J)) D DELPR^IBCU1(DA( < G C1F2 < C1X1(DION) K X < S X(1)=$G(@DIEZTMP@("V",399.042,DIIENS,.01,DION),$P($ < S X(2)=$G(@DIEZTMP@("V",399.042,DIIENS,.15,DION),$P($ < S X=$G(X(1)) < Q < C1F2 Q < X1 S DIC("S")="I +$P(^(0),U,3)" D ^DIC K DIC S DIC=DIE,X < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ8,2",DU= < S DE(DW)="C2^IBXSC76" < G RE < C2 G C2S:$D(DE(2))[0 K DB < S X=DE(2),DIC=DIE < D 22^IBCU2 < C2S S X="" G:DG(DQ)=X C2F1 K DB < S X=DG(DQ),DIC=DIE < D 21^IBCU2 < C2F1 Q < X2 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) < Q < ; < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="RNJ6,0X",DU < S DE(DW)="C3^IBXSC76" < G RE < C3 G C3S:$D(DE(3))[0 K DB < S X=DE(3),DIC=DIE < D 32^IBCU2 < C3S S X="" G:DG(DQ)=X C3F1 K DB < S X=DG(DQ),DIC=DIE < D 31^IBCU2 < C3F1 Q < X3 K:X'?1.N X I $D(X) S:X=0 X=1 < Q < ; < 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;4",DV="RNJ9,2XI",D < S DE(DW)="C4^IBXSC76" < G RE < C4 G C4S:$D(DE(4))[0 K DB < S X=DE(4),DIC=DIE < S DGXRF=2 D TC^IBCU2 K DGXRF < C4S S X="" G:DG(DQ)=X C4F1 K DB < S X=DG(DQ),DIC=DIE < S DGXRF=1 D TC^IBCU2 K DGXRF < C4F1 Q < X4 K:X?1.10N.1".".2N X < Q < ; < 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;5",DV="R*P399.1'", < S DE(DW)="C5^IBXSC76" < S DU="DGCR(399.1," < G RE < C5 G C5S:$D(DE(5))[0 K DB < S X=DE(5),DIC=DIE < K ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA < C5S S X="" G:DG(DQ)=X C5F1 K DB < S X=DG(DQ),DIC=DIE < S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA < C5F1 Q < X5 S DIC("S")="I $P(^(0),U,5)" D ^DIC K DIC S DIC=DIE,X= < Q < ; < 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;6",DV="*P81'",DU=" < S DE(DW)="C6^IBXSC76" < S DU="ICPT(" < G RE < C6 G C6S:$D(DE(6))[0 K DB < S X=DE(6),DIC=DIE < K ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA) < S X=DE(6),DIC=DIE < K ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA) < C6S S X="" G:DG(DQ)=X C6F1 K DB < S X=DG(DQ),DIC=DIE < I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,3 < S X=DG(DQ),DIC=DIE < I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E < C6F1 Q < X6 S ICPTVDT=$$BDATE^IBACSV($G(DA(1))),DIC("S")="I $$CPT < Q < ; < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 < X7 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758" < Q < 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;7",DV="P40.8'X",DU < S DE(DW)="C8^IBXSC76" < S DU="DG(40.8," < S X=$$DEFDIV^IBCU7(DA(1)) < S Y=X < G Y < C8 G C8S:$D(DE(8))[0 K DB < S X=DE(8),DIC=DIE < K ^DGCR(399,"ASC1",+$P(^DGCR(399,DA(1),"RC",DA,0),U,6 < S X=DE(8),DIC=DIE < K ^DGCR(399,"ASC2",DA(1),+$P(^DGCR(399,DA(1),"RC",DA, < C8S S X="" G:DG(DQ)=X C8F1 K DB < S X=DG(DQ),DIC=DIE < I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR < S X=DG(DQ),DIC=DIE < I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P < C8F1 Q < X8 Q < 9 S DQ=10 ;@758 < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDE < Q < 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="0;10",DV="S",DU="", < S DE(DW)="C11^IBXSC76" < S DU="1:INPT BS;2:OPT VST DT;3:RX;4:CPT;5:PROS;6:DRG; < G RE < C11 G C11S:$D(DE(11))[0 K DB < D ^IBXSC78 < C11S S X="" G:DG(DQ)=X C11F1 K DB < S X=DG(DQ),DIC=DIE < ; < S X=DG(DQ),DIC=DIE < ; < C11F1 Q < X11 Q < 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;12",DV="S",DU="", < S DU="1:INSTITUTIONAL;2:PROFESSIONAL;" < G RE < X12 Q < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P < Q < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@758 < Q < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 S DGRVRCAL=1 < Q < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 D LINKRX^IBCEU5(DA(1),DA) < Q < 17 D:$D(DG)>9 F^DIE17 G ^IBXSC79 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC77.m ./VADemo/r2/r/IBXSC77.m IBXSC77 ; ;10/15/04 | IBXSC77 ; ;02/04/03 D DE G BEGIN < DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K < I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,2) S:%]"" DE(1 < I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,4) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXSC77",DQ=1 < 1 S DW="U1;2",DV="NJ8,2",DU="",DLB="OFFSET AMOUNT",DIFL < S DE(DW)="C1^IBXSC77" < G RE < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^ < C1S S X="" G:DG(DQ)=X C1F1 K DB < S X=DG(DQ),DIC=DIE < ; < C1F1 Q < X1 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) < Q < ; < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S:'X Y="@757" < Q < 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="U1;3",DV="FX",DU="", < G RE < X3 K:$L(X)>24!($L(X)<3) X < I $D(X),X'?.ANP K X < Q < ; < 4 S DQ=5 ;@757 < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@76" < Q < 6 S DW="U1;10",DV="RNJ10,2",DU="",DLB="*FY 1 CHARGES",D < G RE < X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X< < Q < ; < 7 S DQ=8 ;@76 < 8 S DQ=9 ;@77 < 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 < X9 S:IBDR20'["77" Y="@78" < Q < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 S:'$D(^DGCR(399,DA,"I1")) Y="@772" < Q < 11 S DW="U2;4",DV="NJ11,2",DU="",DLB="PRIMARY PRIOR PAYM < S DE(DW)="C11^IBXSC77" < G RE < C11 G C11S:$D(DE(11))[0 K DB < S X=DE(11),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DE(11),DIC=DIE < ; < C11S S X="" G:DG(DQ)=X C11F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C11F1 Q < X11 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X < Q < ; < 12 S DQ=13 ;@772 < 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) < X13 S:'$D(^DGCR(399,DA,"I2")) Y="@773" < Q < 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW="U2;5",DV="NJ11,2",D < S DE(DW)="C14^IBXSC77" < G RE < C14 G C14S:$D(DE(14))[0 K DB < S X=DE(14),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DE(14),DIC=DIE < ; < C14S S X="" G:DG(DQ)=X C14F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C14F1 Q < X14 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X < Q < ; < 15 S DQ=16 ;@773 < 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) < X16 S:'$D(^DGCR(399,DA,"I3")) Y="@78" < Q < 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="U2;6",DV="NJ11,2",D < S DE(DW)="C17^IBXSC77" < G RE < C17 G C17S:$D(DE(17))[0 K DB < S X=DE(17),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DE(17),DIC=DIE < ; < C17S S X="" G:DG(DQ)=X C17F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C17F1 Q < X17 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X < Q < 18 S DQ=19 ;@78 < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 K DIE("NO^") < Q < 20 G 0^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC78.m ./VADemo/r2/r/IBXSC78.m IBXSC78 ; ;10/15/04 | IBXSC78 ; ;02/04/03 S X=DE(11),DIC=DIE | D DE G BEGIN K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y( | DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K S X=DE(11),DIC=DIE | I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,3) S:%]"" DE(1 X ^DD(399.042,.1,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^D | I $D(^("U2")) S %Z=^("U2") 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 " (N > 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 > 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=^ > T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD > K DDER G X > P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ > 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, > V D @("X"_DQ) K YS > Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S > 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) > Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" > 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 > I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) > X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= > 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 > 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 > KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") > BEGIN S DNM="IBXSC78",DQ=1 > 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="U1;3",DV="FX",DU="", > G RE > X1 K:$L(X)>24!($L(X)<3) X > I $D(X),X'?.ANP K X > Q > ; > 2 S DQ=3 ;@757 > 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 > X3 I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@76" > Q > 4 S DW="U1;10",DV="RNJ10,2",DU="",DLB="*FY 1 CHARGES",D > G RE > X4 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X< > Q > ; > 5 S DQ=6 ;@76 > 6 S DQ=7 ;@77 > 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 > X7 S:IBDR20'["77" Y="@78" > Q > 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 > X8 S:'$D(^DGCR(399,DA,"I1")) Y="@772" > Q > 9 S DW="U2;4",DV="NJ11,2",DU="",DLB="PRIMARY PRIOR PAYM > S DE(DW)="C9^IBXSC78" > G RE > C9 G C9S:$D(DE(9))[0 K DB > S X=DE(9),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > S X=DE(9),DIC=DIE > ; > C9S S X="" G:DG(DQ)=X C9F1 K DB > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > C9F1 Q > X9 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X > Q > ; > 10 S DQ=11 ;@772 > 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 S:'$D(^DGCR(399,DA,"I2")) Y="@773" > Q > 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="U2;5",DV="NJ11,2",D > S DE(DW)="C12^IBXSC78" > G RE > C12 G C12S:$D(DE(12))[0 K DB > S X=DE(12),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > S X=DE(12),DIC=DIE > ; > C12S S X="" G:DG(DQ)=X C12F1 K DB > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > C12F1 Q > X12 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X > Q > ; > 13 S DQ=14 ;@773 > 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) > X14 S:'$D(^DGCR(399,DA,"I3")) Y="@78" > Q > 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="U2;6",DV="NJ11,2",D > S DE(DW)="C15^IBXSC78" > G RE > C15 G C15S:$D(DE(15))[0 K DB > S X=DE(15),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > S X=DE(15),DIC=DIE > ; > C15S S X="" G:DG(DQ)=X C15F1 K DB > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, > C15F1 Q > X15 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X > Q > ; > 16 S DQ=17 ;@78 > 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) > X17 K DIE("NO^") > Q > 18 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC79.m ./VADemo/r2/r/IBXSC79.m IBXSC79 ; ;10/15/04 | IBXSC79 ; ;02/04/03 diff -y --suppress-common-lines ./VADemo/r1/IBXSC7.m ./VADemo/r2/r/IBXSC7.m IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), F | IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), F I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,22) S:%]"" DE(21)=% | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(27)=% S DE(DW)="C21^IBXSC7" < C21 G C21S:$D(DE(21))[0 K DB < S X=DE(21),DIC=DIE < ; < S X=DE(21),DIC=DIE < ; < S X=DE(21),DIC=DIE < ; < C21S S X="" G:DG(DQ)=X C21F1 K DB < D ^IBXSC72 < C21F1 Q < 22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW="0;27",DV="S",DU="", | 22 S DW="0;27",DV="S",DU="",DLB="BILL CHARGE TYPE",DIFLD 27 D:$D(DG)>9 F^DIE17 G ^IBXSC73 | 27 D:$D(DG)>9 F^DIE17,DE S DQ=27,DW="0;19",DV="RP353'",D > S DE(DW)="C27^IBXSC7" > S DU="IBE(353," > G RE > C27 G C27S:$D(DE(27))[0 K DB > D ^IBXSC72 > C27S S X="" G:DG(DQ)=X C27F1 K DB > D ^IBXSC73 > C27F1 Q > X27 Q > 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) > X28 S DIPA("FT")=$P($G(^DGCR(399,DA,0)),U,19) > Q > 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE) > X29 I $P($G(^IBE(353,+DIPA("FT"),2)),U,2)="P",$P($G(^(2)) > Q > 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE) > X30 W !,*7,"Must be a printable national form type" > Q > 31 D:$D(DG)>9 F^DIE17 G ^IBXSC74 diff -y --suppress-common-lines ./VADemo/r1/IBXSC821.m ./VADemo/r2/r/IBXSC821.m IBXSC821 ; ;10/29/04 | IBXSC821 ; ;02/04/03 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S S DU="1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING | S DU="1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING X2 S DIPA("RF")=X S:$D(^XUSEC("IB PROVIDER EDIT",DUZ)) D | X2 I $D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DLAYGO=355.93 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;2",DV="V",DU="",DL | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 S DE(DW)="C3^IBXSC821" | X3 S DIPA("REF")=X > Q > 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;2",DV="V",DU="",DL > S DE(DW)="C4^IBXSC821" C3 G C3S:$D(DE(3))[0 K DB | C4 G C4S:$D(DE(4))[0 K DB S X=DE(3),DIC=DIE | 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 X=DE(4),DIC=DIE S X=DE(3),DIC=DIE | 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 X=DE(4),DIC=DIE C3S S X="" G:DG(DQ)=X C3F1 K DB | C4S S X="" G:DG(DQ)=X C4F1 K DB ; | X ^DD(399.0222,.02,1,4,1.3) I X S X=DIV S Y(1)=$S($D( ; | X ^DD(399.0222,.02,1,5,1.3) I X S X=DIV S Y(1)=$S($D( ; | X ^DD(399.0222,.02,1,6,1.3) I X S X=DIV S Y(1)=$S($D( C3F1 Q | C4F1 Q X3 Q | X4 Q 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 K DLAYGO S DIPA("PRF")=X S:DIPA("PRF")="" Y="@98" < Q < X5 N Z S Z=$$EXPAND^IBTRE(399.0222,.08,$P($G(^DGCR(399,D | X5 K DLAYGO X6 S DIPA("CRD")=$$CRED^IBCEU($P($G(^DGCR(399,DA(1),"PRV | X6 S DIPA("PERF")=X 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="0;3",DV="F",DU="",DL | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 G RE | X7 I DIPA("PERF")="" S Y="@98" X7 K:$L(X)>3!($L(X)<1) X < I $D(X),X'?.ANP K X < ; < X8 K DIPA("W1") S:$G(DIPA("CRD"))'=$P($G(^DGCR(399,DA(1) | X8 S DIPA("SPEC")=$$EXPAND^IBTRE(399.0222,.08,$P($G(^DGC X9 I $G(DIPA("W1")) D WRT1^IBCSC8H($G(DIPA("CRD"))) | X9 W !," Provider Specialty On File: ",$G(DIPA("SPEC" X10 K DIPA("W1") | X10 S DIPA("CUNEED")=$$CUNEED^IBCEP3(DA(1)) I 'DIPA("CUNE X11 I '$G(DIPA("I1")) S Y="@8205" | X11 N Z S Z=$S('$P(DIPA("CUNEED"),U,2):1,'$D(^DGCR(399,DA X12 D PROVID^IBCEP2B(DA(1),DA,1,.DIPA) S Y=$S(DIPA("EDIT" | X12 N Z S Z=$$DISP^IBCEP3($P(DIPA("CUNEED"),U,2),2) S:Z'= Q < 13 S DQ=14 ;@8282 < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 I '$G(DIPA("I2")) S Y="@8205" < Q < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 D PROVID^IBCEP2B(DA(1),DA,2,.DIPA) S Y=$S(DIPA("EDIT" < Q < 16 S DQ=17 ;@8283 < 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) < X17 I '$G(DIPA("I3")) S Y="@8205" < Q < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 D PROVID^IBCEP2B(DA(1),DA,3,.DIPA) S Y=$S(DIPA("EDIT" < Q < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 S Y="@8205" < 20 S DQ=21 ;@8291 | 13 D:$D(DG)>9 F^DIE17 G ^IBXSC822 21 D:$D(DG)>9 F^DIE17 G ^IBXSC824 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC822.m ./VADemo/r2/r/IBXSC822.m IBXSC822 ; ;10/29/04 | IBXSC822 ; ;02/04/03 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K | DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL= I $D(^("TX")) S %Z=^("TX") S %=$P(%Z,U,8) S:%]"" DE(1 | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(12)=% S I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,10) S:%]"" DE( < 1 S DW="TX;8",DV="S",DU="",DLB="FORCE CLAIM TO PRINT",D | 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;9",DV="R*P355.96", S DU="0:NO FORCED PRINT;1:FORCE LOCAL PRINT;2:FORCE C | S DE(DW)="C1^IBXSC822",DE(DW,"INDEX")=1 S Y="NO FORCED PRINT" | S DU="IBA(355.96," G Y | G RE X1 Q | C1 G C1S:$D(DE(1))[0 K DB 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 | C1S S X="" G:DG(DQ)=X C1F1 K DB X2 S Y="@87" | C1F1 N X,X1,X2 S DIXR=140 D C1X1(U) K X2 M X2=X D C1X1("O" Q | D 3 S DQ=4 ;@8611 | . D:X1(1)'=X2(1)&(X(1)'="") DELID^IBCEP3(DA(1),1) 4 S DW="TX;9",DV="S",DU="",DLB="FORCE PRINT MRA SECONDA | K X M X=X2 D S DU="0:NO FORCED PRINT;1:MEDICARE SECONDARY FORCE LO | . D:X1(1)'=X2(1) SETID^IBCEP3(DA(1),1) S Y="NO FORCED PRINT" | G C1F2 G Y | C1X1(DION) K X X4 Q | S X(1)=$G(@DIEZTMP@("V",399.0222,DIIENS,.09,DION),$P( 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 | S X=$G(X(1)) X5 S Y="@87" | Q > C1F2 Q > X1 S DIC("S")="I $$CAREUOK^IBCEP4(DA(1),+Y,1,1)" D ^DIC 6 S DQ=7 ;@861 | ; > 2 S DQ=3 ;@8201 > 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 > X3 N Z S Z=$S('$P(DIPA("CUNEED"),U,3):1,'$D(^DGCR(399,DA > Q > 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 > X4 N Z S Z=$$DISP^IBCEP3($P(DIPA("CUNEED"),U,3),2) S:Z'= > Q > 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;10",DV="R*P355.96" > S DE(DW)="C5^IBXSC822",DE(DW,"INDEX")=1 > S DU="IBA(355.96," > G RE > C5 G C5S:$D(DE(5))[0 K DB > C5S S X="" G:DG(DQ)=X C5F1 K DB > C5F1 N X,X1,X2 S DIXR=141 D C5X1(U) K X2 M X2=X D C5X1("O" > D > . D:X1(1)'=X2(1) DELID^IBCEP3(DA(1),2) > K X M X=X2 D > . D:X1(1)'=X2(1) SETID^IBCEP3(DA(1),2) > G C5F2 > C5X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",399.0222,DIIENS,.1,DION),$P($ > S X=$G(X(1)) > Q > C5F2 Q > X5 S DIC("S")="I $$CAREUOK^IBCEP4(DA(1),+Y,1,2)" D ^DIC > Q > ; > 6 S DQ=7 ;@8202 X7 N X,Y,DIR S DIR(0)="EA",DIR("A",1)="NO FIELDS AVAILAB | X7 I '$P(DIPA("CUNEED"),U,4)!'$D(^DGCR(399,DA(1),"I3")) 8 S DQ=9 ;@87 | 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 | X8 N Z S Z=$$DISP^IBCEP3($P(DIPA("CUNEED"),U,4),2) S:Z'= X9 S:IBDR20'["87" Y="@88" < 10 S DQ=11 ;@88 | 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;11",DV="R*P355.96" 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) | S DE(DW)="C9^IBXSC822",DE(DW,"INDEX")=1 X11 S:IBDR20'["88" Y="@89" | S DU="IBA(355.96," > G RE > C9 G C9S:$D(DE(9))[0 K DB > C9S S X="" G:DG(DQ)=X C9F1 K DB > C9F1 N X,X1,X2 S DIXR=142 D C9X1(U) K X2 M X2=X D C9X1("O" > D > . D:X1(1)'=X2(1) DELID^IBCEP3(DA(1),1) > K X M X=X2 D > . D:X1(1)'=X2(1) SETID^IBCEP3(DA(1),1) > G C9F2 > C9X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",399.0222,DIIENS,.11,DION),$P( > S X=$G(X(1)) > Q > C9F2 Q > X9 S DIC("S")="I $$CAREUOK^IBCEP4(DA(1),+Y,1,3)" D ^DIC 12 S DW="U2;10",DV="*P355.93X",DU="",DLB="NON-VA FACILIT < S DE(DW)="C12^IBXSC822" < S DU="IBA(355.93," < G RE < C12 G C12S:$D(DE(12))[0 K DB < S X=DE(12),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DE(12),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C12S S X="" G:DG(DQ)=X C12F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < S X=DG(DQ),DIC=DIE < C12F1 Q | 10 S DQ=11 ;@830 X12 S DIC("S")="I $P(^(0),U,2)=1,$P(^(0),U)'["",""" D ^DI | 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) > X11 S DIPA("CRED")=$$CRED^IBCEU($P($G(^DGCR(399,DA(1),"PR > Q > 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;3",DV="F",DU="",D > G RE > X12 K:$L(X)>3!($L(X)<1) X > I $D(X),X'?.ANP K X X13 S DIPA("NVA_FC")=X S:DIPA("NVA_FC")="" Y="@882" | X13 K DIPA("W1") I $G(DIPA("CRED"))'=$P($G(^DGCR(399,DA(1 X14 S DIPA("NVA_FC-0")=$G(^IBA(355.93,+DIPA("NVA_FC"),0)) | X14 I $G(DIPA("W1")) W !,*7," **Warning** Credentials ar > Q > 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) > X15 I $G(DIPA("W1")) K DIPA("W1") W $J("",14),"Change wil > Q > 16 S DQ=17 ;@8309 > 17 S DW="0;5",DV="RFX",DU="",DLB="PRIMARY INS CO ID NUMB > S DE(DW)="C17^IBXSC822" > G RE > C17 G C17S:$D(DE(17))[0 K DB > S X=DE(17),DIC=DIE > ; > C17S S X="" G:DG(DQ)=X C17F1 K DB > S X=DG(DQ),DIC=DIE > K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y( > C17F1 Q > X17 I $D(DA) N Z S Z=$G(^DGCR(399,DA(1),"PRV",DA,0)) S:X= > I $D(X),X'?.ANP K X > Q > ; > 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) > X18 S DIPA("INS")=$P($G(^DGCR(399,DA(1),"M")),U,12,14) > Q > 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) > X19 I '$P(DIPA("INS"),U,2) S Y="@821" > Q > 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="0;6",DV="FX",DU="", > G RE > X20 I $D(DA) N Z S Z=$G(^DGCR(399,DA(1),"PRV",DA,0)) S:X= > I $D(X),X'?.ANP K X > Q > ; > 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) > X21 I '$P($G(DIPA("INS")),U,3) S Y="@821" 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 S I(0,0)=D0 S Y(1)= | 22 D:$D(DG)>9 F^DIE17 G ^IBXSC823 S DGO="^IBXSC823",DC="^355.93^IBA(355.93," G DIEZ^DIE < R15 D DE G A < ; < 16 S DQ=17 ;@881 < 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="U2;11",DV="S",DU="" < S DU="1:FEE BASIS, NON-LAB;2:FEE BASIS, LAB;3:NON-FEE < G RE < X17 Q < 18 S DQ=19 ;@882 < 19 S DQ=20 ;@89 < 20 G 0^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC823.m ./VADemo/r2/r/IBXSC823.m IBXSC823 ; ;10/29/04 | IBXSC823 ; ;02/04/03 DE S DIE="^IBA(355.93,",DIC=DIE,DP=355.93,DL=2,DIEL=0,DU | DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL= I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(1)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(4)=% S 1 S DW="0;5",DV="FX",DU="",DLB="STREET ADDRESS",DIFLD=. | 1 S DW="0;7",DV="FX",DU="",DLB="TERTIARY INS CO ID NUMB X1 K:$L(X)>30!($L(X)<1) X I $D(X),$P($G(^IBA(355.93,DA,0 | X1 I $D(DA) N Z S Z=$G(^DGCR(399,DA(1),"PRV",DA,0)) S:X= 2 S DW="0;10",DV="F",DU="",DLB="STREET ADDRESS LINE 2", | 2 S DQ=3 ;@821 G RE | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 X2 K:$L(X)>30!($L(X)<1) X | X3 I $G(DIPA("REF"))'=1 S Y="@98" I $D(X),X'?.ANP K X < ; | 4 S DW="0;4",DV="P5'",DU="",DLB="REFERRING PROVIDER STA 3 S DW="0;6",DV="FX",DU="",DLB="CITY",DIFLD=.06 < G RE < X3 K:$L(X)>20!($L(X)<1) X I $D(X),$P($G(^IBA(355.93,DA,0 < I $D(X),X'?.ANP K X < Q < ; < 4 S DW="0;7",DV="P5'X",DU="",DLB="STATE",DIFLD=.07 < X4 I $D(X),$P($G(^IBA(355.93,DA,0)),U,2)'=1 K X | X4 Q Q | 5 S DQ=6 ;@98 ; < 5 S DW="0;8",DV="FX",DU="",DLB="ZIP CODE",DIFLD=.08 < G RE < X5 K:$L(X)>10!($L(X)<5)!'((X?5N)!(X?5N1"-"4N)) X I $D(X) < I $D(X),X'?.ANP K X < Q < ; < Only in ./VADemo/r1/: IBXSC824.m diff -y --suppress-common-lines ./VADemo/r1/IBXSC82.m ./VADemo/r2/r/IBXSC82.m IBXSC82 ; GENERATED FROM 'IB SCREEN82' INPUT TEMPLATE(#577), | IBXSC82 ; GENERATED FROM 'IB SCREEN82' INPUT TEMPLATE(#577), I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,9) S:%]"" DE(17) | I $D(^("TX")) S %Z=^("TX") S %=$P(%Z,U,8) S:%]"" DE(3 I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,8) S:%]"" DE(3 | I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,9) S:%]"" DE(16) I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,1) S:%]"" DE(1 | I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,8) S:%]"" DE(2 I $D(^("UF3")) S %Z=^("UF3") S %=$P(%Z,U,1) S:%]"" DE | I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,1) S:%]"" DE(1 I $D(^("UF31")) S %Z=^("UF31") S %=$P(%Z,U,2) S:%]"" | I $D(^("UF3")) S %Z=^("UF3") S %=$P(%Z,U,1) S:%]"" DE > I $D(^("UF31")) S %Z=^("UF31") S %=$P(%Z,U,2) S:%]"" X1 K DIPA S DIPA("I1")=$D(^DGCR(399,DA,"I1")),DIPA("I2") | X1 S:IBDR20'["81" Y="@82" 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 | 2 S DW="U1;8",DV="F",DU="",DLB="BILL COMMENT",DIFLD=208 X2 S:IBDR20'["81" Y="@82" < Q < 3 S DW="U1;8",DV="F",DU="",DLB="BILL COMMENT",DIFLD=208 < X3 K:$L(X)>35!($L(X)<2) X | X2 K:$L(X)>35!($L(X)<2) X 4 S DW="UF3;4",DV="F",DU="",DLB="PRIMARY INSURANCE ICN/ | 3 S DW="UF3;4",DV="F",DU="",DLB="PRIMARY INSURANCE ICN/ X4 K:$L(X)>23!($L(X)<3) X | X3 K:$L(X)>23!($L(X)<3) X 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 | 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 X5 S:'DIPA("I2") Y="@8111" | X4 I '$D(^DGCR(399,DA,"I2")) S Y="@8111" 6 S DW="UF3;5",DV="F",DU="",DLB="SECONDARY INSURANCE IC | 5 S DW="UF3;5",DV="F",DU="",DLB="SECONDARY INSURANCE IC X6 K:$L(X)>23!($L(X)<3) X | X5 K:$L(X)>23!($L(X)<3) X 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 | 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 X7 S:'DIPA("I3") Y="@8111" | X6 I '$D(^DGCR(399,DA,"I3")) S Y="@8111" 8 S DW="UF3;6",DV="F",DU="",DLB="TERTIARY INSURANCE ICN | 7 S DW="UF3;6",DV="F",DU="",DLB="TERTIARY INSURANCE ICN X8 K:$L(X)>23!($L(X)<3) X | X7 K:$L(X)>23!($L(X)<3) X 9 S DQ=10 ;@8111 | 8 S DQ=9 ;@8111 10 S DW="U;13",DV="FX",DU="",DLB="PRIMARY AUTHORIZATION | 9 S DW="U;13",DV="FX",DU="",DLB="PRIMARY AUTHORIZATION X10 K:$L(X)>18!($L(X)<1) X | X9 K:$L(X)>18!($L(X)<1) X 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) | 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) X11 S:'DIPA("I2") Y="@811" | X10 I '$D(^DGCR(399,DA,"I2")) S Y="@811" 12 S DW="U2;8",DV="FX",DU="",DLB="SECONDARY AUTHORIZATIO | 11 S DW="U2;8",DV="FX",DU="",DLB="SECONDARY AUTHORIZATIO X12 K:$L(X)>18!($L(X)<1) X | X11 K:$L(X)>18!($L(X)<1) X 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) | 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) X13 S:'DIPA("I3") Y="@811" | X12 I '$D(^DGCR(399,DA,"I3")) S Y="@811" 14 S DW="U2;9",DV="F",DU="",DLB="TERTIARY AUTHORIZATION | 13 S DW="U2;9",DV="F",DU="",DLB="TERTIARY AUTHORIZATION X14 K:$L(X)>18!($L(X)<1) X | X13 K:$L(X)>18!($L(X)<1) X 15 S DQ=16 ;@811 | 14 S DQ=15 ;@811 16 S DW="U2;1",DV="*P80'",DU="",DLB="ADMITTING DIAGNOSIS | 15 S DW="U2;1",DV="P80'",DU="",DLB="ADMITTING DIAGNOSIS" X16 S ICDVDT=$$BDATE^IBACSV(+$G(DA)),DIC("S")="I $$ICD9AC | X15 Q Q | 16 S DW="U;9",DV="S",DU="",DLB="SOURCE OF ADMISSION",DIF ; < 17 S DW="U;9",DV="S",DU="",DLB="SOURCE OF ADMISSION",DIF < X17 Q | X16 Q 18 S DQ=19 ;@82 | 17 S DQ=18 ;@82 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) | 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) X19 S:IBDR20'["82" Y="@83" | X18 S:IBDR20'["82" Y="@83" Q | Q 20 S D=0 K DE(1) ;222 | 19 S D=0 K DE(1) ;222 S DIFLD=222,DGO="^IBXSC821",DC="17^399.0222ISA^PRV^", | S DIFLD=222,DGO="^IBXSC821",DC="14^399.0222ISA^PRV^", S DU="1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING | S DU="1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING G RE:D I $D(DSC(399.0222))#2,$P(DSC(399.0222),"I $D(^ | G RE:D I $D(DSC(399.0222))#2,$P(DSC(399.0222),"I $D(^ M20 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"PRV",+D,0)) S DE(2 | M19 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"PRV",+D,0)) S DE(1 R20 D DE | R19 D DE S D=$S($D(^DGCR(399,DA,"PRV",0)):$P(^(0),U,3,4),1:1) | S D=$S($D(^DGCR(399,DA,"PRV",0)):$P(^(0),U,3,4),1:1) 21 S DQ=22 ;@83 | 20 S DQ=21 ;@83 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) | 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) X22 S:IBDR20'["83" Y="@84" | X21 S:IBDR20'["83" Y="@84" 23 S DW="UF3;1",DV="F",DU="",DLB="UB92 FORM LOCATOR 2",D | 22 S DW="UF3;1",DV="F",DU="",DLB="FORM LOCATOR 2",DIFLD= X23 K:$L(X)>59!($L(X)<3) X | X22 K:$L(X)>59!($L(X)<3) X 24 S DW="UF3;2",DV="F",DU="",DLB="FORM LOCATOR 11",DIFLD | 23 S DW="UF3;2",DV="F",DU="",DLB="FORM LOCATOR 11",DIFLD X24 K:$L(X)>25!($L(X)<3) X | X23 K:$L(X)>25!($L(X)<3) X 25 S DQ=26 ;@84 | 24 S DQ=25 ;@84 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) | 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE) X26 S:IBDR20'["84" Y="@85" | X25 S:IBDR20'["84" Y="@85" 27 S DW="UF3;3",DV="F",DU="",DLB="FORM LOCATOR 31",DIFLD | 26 S DW="UF3;3",DV="F",DU="",DLB="FORM LOCATOR 31",DIFLD X27 K:$L(X)>11!($L(X)<3) X | X26 K:$L(X)>11!($L(X)<3) X 28 S DQ=29 ;@85 | 27 S DQ=28 ;@85 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE) | 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE) X29 S:IBDR20'["85" Y="@86" | X28 S:IBDR20'["85" Y="@86" 30 S DW="UF3;7",DV="F",DU="",DLB="FORM LOCATOR 56",DIFLD | 29 S DW="UF3;7",DV="F",DU="",DLB="FORM LOCATOR 56",DIFLD X30 K:$L(X)>69!($L(X)<3) X | X29 K:$L(X)>69!($L(X)<3) X 31 S DW="UF31;2",DV="F",DU="",DLB="FORM LOCATOR 78",DIFL | 30 S DW="UF31;2",DV="F",DU="",DLB="FORM LOCATOR 78",DIFL X31 K:$L(X)>5!($L(X)<3) X | X30 K:$L(X)>5!($L(X)<3) X 32 S DQ=33 ;@86 | 31 S DQ=32 ;@86 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE) | 32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE) X33 S:IBDR20'["86" Y="@87" | X32 S:IBDR20'["86" Y="@87" Q < 34 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=34 D X34 D:$D(DIEFIRE) < X34 I '$P($G(^DGCR(399,DA,"TX")),U,8),'$$TXMT^IBCEF4(DA) < 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE) | 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE) X35 I $$REQMRA^IBEFUNC(DA) S Y="@8611" | X33 I '$P($G(^DGCR(399,DA,"TX")),U,8),'$$TXMT^IBCEF4(IBIF 36 D:$D(DG)>9 F^DIE17 G ^IBXSC822 | 34 S DW="TX;8",DV="S",DU="",DLB="FORCE CLAIM TO PRINT",D > S DU="0:NO FORCED PRINT;1:FORCE LOCAL PRINT;2:FORCE C > S Y="NO FORCED PRINT" > G Y > X34 Q > 35 S DQ=36 ;@861 > 36 S DQ=37 ;@87 > 37 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC8H1.m ./VADemo/r2/r/IBXSC8H1.m IBXSC8H1 ; ;10/29/04 | IBXSC8H1 ; ;02/04/03 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S S DU="1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING | S DU="1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING X2 S DIPA("RF")=X S:$D(^XUSEC("IB PROVIDER EDIT",DUZ)) D | X2 S DIPA("REF")=X 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;2",DV="V",DU="",DL | 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 S DE(DW)="C3^IBXSC8H1" | X3 I $D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DLAYGO=355.93 > Q > 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;2",DV="V",DU="",DL > S DE(DW)="C4^IBXSC8H1" C3 G C3S:$D(DE(3))[0 K DB | C4 G C4S:$D(DE(4))[0 K DB S X=DE(3),DIC=DIE | 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 X=DE(4),DIC=DIE S X=DE(3),DIC=DIE | 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 X=DE(4),DIC=DIE C3S S X="" G:DG(DQ)=X C3F1 K DB | C4S S X="" G:DG(DQ)=X C4F1 K DB ; | X ^DD(399.0222,.02,1,4,1.3) I X S X=DIV S Y(1)=$S($D( ; | X ^DD(399.0222,.02,1,5,1.3) I X S X=DIV S Y(1)=$S($D( ; | X ^DD(399.0222,.02,1,6,1.3) I X S X=DIV S Y(1)=$S($D( C3F1 Q | C4F1 Q X3 Q | X4 Q 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 < X4 K DLAYGO S DIPA("PRF")=X S:X="" Y="@98" < Q < X5 N Z S Z=$$EXPAND^IBTRE(399.0222,.08,$P($G(^DGCR(399,D | X5 K DLAYGO X6 S DIPA("CRD")=$$CRED^IBCEU($P(^DGCR(399,DA(1),"PRV",D | X6 S DIPA("PERF")=X 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="0;3",DV="F",DU="",DL | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 G RE | X7 I DIPA("PERF")="" S Y="@98" X7 K:$L(X)>3!($L(X)<1) X < I $D(X),X'?.ANP K X < ; < X8 K DIPA("W1") S:$G(DIPA("CRD"))'=$P(^DGCR(399,DA(1),"P | X8 S DIPA("SPEC")=$$EXPAND^IBTRE(399.0222,.08,$P($G(^DGC X9 I $G(DIPA("W1")) D WRT1^IBCSC8H($G(DIPA("CRD"))) | X9 W !," Provider Specialty On File: ",$G(DIPA("SPEC" X10 K DIPA("W1") | X10 S DIPA("CUNEED")=$$CUNEED^IBCEP3(DA(1)) I 'DIPA("CUNE X11 I '$G(DIPA("I1")) S Y="@8305" | X11 N Z S Z=$S('$P(DIPA("CUNEED"),U,2):1,'$D(^DGCR(399,DA X12 D PROVID^IBCEP2B(DA(1),DA,1,.DIPA) S Y=$S(DIPA("EDIT" | X12 N Z S Z=$$DISP^IBCEP3($P(DIPA("CUNEED"),U,2),2) I Z'= Q < 13 S DQ=14 ;@8382 < 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) < X14 I '$G(DIPA("I2")) S Y="@8305" < Q < 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) < X15 D PROVID^IBCEP2B(DA(1),DA,2,.DIPA) S Y=$S(DIPA("EDIT" < Q < 16 S DQ=17 ;@8383 < 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) < X17 I '$G(DIPA("I3")) S Y="@8305" < Q < 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) < X18 D PROVID^IBCEP2B(DA(1),DA,3,.DIPA) S Y=$S(DIPA("EDIT" < Q < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 S Y="@8305" < 20 S DQ=21 ;@8391 | 13 D:$D(DG)>9 F^DIE17 G ^IBXSC8H4 21 D:$D(DG)>9 F^DIE17 G ^IBXSC8H4 < diff -y --suppress-common-lines ./VADemo/r1/IBXSC8H2.m ./VADemo/r2/r/IBXSC8H2.m IBXSC8H2 ; ;10/29/04 | IBXSC8H2 ; ;02/04/03 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(1)=% S | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(1)=% S 2 S DW="0;10",DV="F",DU="",DLB="STREET ADDRESS LINE 2", | 2 S DW="0;6",DV="FX",DU="",DLB="CITY",DIFLD=.06 X2 K:$L(X)>30!($L(X)<1) X | X2 K:$L(X)>20!($L(X)<1) X I $D(X),$P($G(^IBA(355.93,DA,0 3 S DW="0;6",DV="FX",DU="",DLB="CITY",DIFLD=.06 | 3 S DW="0;7",DV="P5'X",DU="",DLB="STATE",DIFLD=.07 G RE < X3 K:$L(X)>20!($L(X)<1) X I $D(X),$P($G(^IBA(355.93,DA,0 < I $D(X),X'?.ANP K X < Q < ; < 4 S DW="0;7",DV="P5'X",DU="",DLB="STATE",DIFLD=.07 < X4 I $D(X),$P($G(^IBA(355.93,DA,0)),U,2)'=1 K X | X3 I $D(X),$P($G(^IBA(355.93,DA,0)),U,2)'=1 K X 5 S DW="0;8",DV="FX",DU="",DLB="ZIP CODE",DIFLD=.08 | 4 S DW="0;8",DV="FX",DU="",DLB="ZIP CODE",DIFLD=.08 X5 K:$L(X)>10!($L(X)<5)!'((X?5N)!(X?5N1"-"4N)) X I $D(X) | X4 K:$L(X)>10!($L(X)<5)!'((X?5N)!(X?5N1"-"4N)) X I $D(X) 6 G 1^DIE17 | 5 G 1^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC8H3.m ./VADemo/r2/r/IBXSC8H3.m IBXSC8H3 ; ;10/29/04 | IBXSC8H3 ; ;02/04/03 I $D(^("TX")) S %Z=^("TX") S %=$P(%Z,U,8) S:%]"" DE(2 | I $D(^("TX")) S %Z=^("TX") S %=$P(%Z,U,8) S:%]"" DE(1 I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,11) S:%]"" DE( | I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,11) S:%]"" DE( I $D(^("UF2")) S %Z=^("UF2") S %=$P(%Z,U,2) S:%]"" DE | I $D(^("UF2")) S %Z=^("UF2") S %=$P(%Z,U,2) S:%]"" DE I $D(^("UF31")) S %Z=^("UF31") S %=$P(%Z,U,3) S:%]"" | I $D(^("UF31")) S %Z=^("UF31") S %=$P(%Z,U,3) S:%]"" 3 S DQ=4 ;@842 | 3 S DQ=4 ;@85 X4 S:"24"'[$P($G(^DGCR(399,DA,"U2")),U,11) Y="@85" | X4 S:IBDR20'["85" Y="@86" 5 S DW="U2;13",DV="F",DU="",DLB="LAB CLIA NUMBER",DIFLD | 5 S DW="UF31;3",DV="F",DU="",DLB="FORM LOC 19-UNSPECIFI S X=$$CLIANVA^IBCEP8(DA) < S Y=X < G Y < X5 K:$L(X)>15!($L(X)<1) X < I $D(X),X'?.ANP K X < Q < ; < 6 S DQ=7 ;@85 < 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 < X7 S:IBDR20'["85" Y="@86" < Q < 8 S DW="UF31;3",DV="F",DU="",DLB="FORM LOC 19-UNSPECIFI < X8 K:$L(X)>80!($L(X)<1) X | X5 K:$L(X)>80!($L(X)<1) X 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 | 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 X9 D ASK19^IBCEU3(DA) | X6 D ASK19^IBCEU3(DA) 10 S DW="U2;14",DV="S",DU="",DLB="HOMEBOUND",DIFLD=236 | 7 S DW="U2;14",DV="S",DU="",DLB="HOMEBOUND",DIFLD=236 X10 Q | X7 Q 11 S DW="U2;15",DV="D",DU="",DLB="DATE LAST SEEN",DIFLD= | 8 S DW="U2;15",DV="D",DU="",DLB="DATE LAST SEEN",DIFLD= X11 S %DT="EX" D ^%DT S X=Y K:Y<1 X | X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X 12 S DW="U2;16",DV="F",DU="",DLB="SPECIAL PROGRAM INDICA | 9 S DW="U2;16",DV="F",DU="",DLB="SPECIAL PROGRAM INDICA S X=$S($$WNRBILL^IBEFUNC(DA):"31",1:"") | S X=$S($$WNRBILL^IBEFUNC(IBIFN):"31",1:"") X12 K:$L(X)>2!($L(X)<1) X | X9 K:$L(X)>2!($L(X)<1) X 13 S DQ=14 ;@86 | 10 S DQ=11 ;@86 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) | 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) X14 S:IBDR20'["86" Y="@99" | X11 S:IBDR20'["86" Y="@99" 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) | 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) X15 I $$NSAME^IBCSC8H(DA) S Y="@861" | X12 I $P($G(^IBE(350.9,1,0)),U,2)'=$P($G(^DG(40.8,+$P(^DG 16 S DW="UF2;2",DV="*S",DU="",DLB="PRINT FACILITY DATA I | 13 S DW="UF2;2",DV="*S",DU="",DLB="PRINT FACILITY DATA I X16 Q | X13 Q 17 S DQ=18 ;@861 | 14 S DQ=15 ;@861 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) | 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) X18 I '$P($G(^DGCR(399,DA,"TX")),U,8),'$$TXMT^IBCEF4(DA) | X15 I '$P($G(^DGCR(399,DA,"TX")),U,8),'$$TXMT^IBCEF4(IBIF Q < 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 I $$REQMRA^IBEFUNC(DA) S Y="@8611" < 20 S DW="TX;8",DV="S",DU="",DLB="FORCE CLAIM TO PRINT",D | 16 S DW="TX;8",DV="S",DU="",DLB="FORCE CLAIM TO PRINT",D S Y="NO FORCED PRINT" | S Y="NO" G Y < X20 Q < 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) < X21 S Y="@862" < Q < 22 S DQ=23 ;@8611 < 23 S DW="TX;9",DV="S",DU="",DLB="FORCE PRINT MRA SECONDA < S DU="0:NO FORCED PRINT;1:MEDICARE SECONDARY FORCE LO < S Y="NO FORCED PRINT" < X23 Q | X16 Q 24 S DQ=25 ;@862 | 17 S DQ=18 ;@862 25 S DQ=26 ;@99 | 18 S DQ=19 ;@99 26 G 0^DIE17 | 19 G 0^DIE17 diff -y --suppress-common-lines ./VADemo/r1/IBXSC8H4.m ./VADemo/r2/r/IBXSC8H4.m IBXSC8H4 ; ;10/29/04 | IBXSC8H4 ; ;02/04/03 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(2)=%,DE | I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(11)=% S I S %=$P(%Z,U,14) S:%]"" DE(9)=%,DE(21)=% < 1 S DW="0;12",DV="*P355.97'R",DU="",DLB="PRIM INS PERF | 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;9",DV="R*P355.96", S DU="IBE(355.97," | S DE(DW)="C1^IBXSC8H4",DE(DW,"INDEX")=1 G RE | S DU="IBA(355.96," X1 S DIC("S")="I '$P($G(^(1)),U,7),$$SECIDCK^IBCEF74(DA( | G RE > C1 G C1S:$D(DE(1))[0 K DB > C1S S X="" G:DG(DQ)=X C1F1 K DB > C1F1 N X,X1,X2 S DIXR=140 D C1X1(U) K X2 M X2=X D C1X1("O" > D > . D:X1(1)'=X2(1)&(X(1)'="") DELID^IBCEP3(DA(1),1) > K X M X=X2 D > . D:X1(1)'=X2(1) SETID^IBCEP3(DA(1),1) > G C1F2 > C1X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",399.0222,DIIENS,.09,DION),$P( > S X=$G(X(1)) ; | C1F2 Q 2 S DW="0;5",DV="FX",DU="",DLB="PRIM INS PERF PROV SECO | X1 S DIC("S")="I $$CAREUOK^IBCEP4(DA(1),+Y,1,1)" D ^DIC S DE(DW)="C2^IBXSC8H4" < G RE < C2 G C2S:$D(DE(2))[0 K DB < S X=DE(2),DIC=DIE < ; < C2S S X="" G:DG(DQ)=X C2F1 K DB < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y( < C2F1 Q < X2 I $D(DA) N Z S Z=$G(^DGCR(399,DA(1),"PRV",DA,0)) S:X= < I $D(X),X'?.ANP K X < > 2 S DQ=3 ;@8301 X3 S Y="@8382" | X3 N Z S Z=$S('$P(DIPA("CUNEED"),U,3):1,'$D(^DGCR(399,DA 4 S DQ=5 ;@8392 | 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;13",DV="*P355.97'R | X4 N Z S Z=$$DISP^IBCEP3($P(DIPA("CUNEED"),U,3),2) I Z'= S DU="IBE(355.97," < G RE < X5 S DIC("S")="I '$P($G(^(1)),U,7),$$SECIDCK^IBCEF74(DA( < ; | 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;10",DV="R*P355.96" 6 S DW="0;6",DV="FX",DU="",DLB="SECOND INS PERF PROV SE | S DE(DW)="C5^IBXSC8H4",DE(DW,"INDEX")=1 G RE | S DU="IBA(355.96," X6 I $D(DA) N Z S Z=$G(^DGCR(399,DA(1),"PRV",DA,0)) S:X= | G RE I $D(X),X'?.ANP K X | C5 G C5S:$D(DE(5))[0 K DB > C5S S X="" G:DG(DQ)=X C5F1 K DB > C5F1 N X,X1,X2 S DIXR=141 D C5X1(U) K X2 M X2=X D C5X1("O" > D > . D:X1(1)'=X2(1) DELID^IBCEP3(DA(1),2) > K X M X=X2 D > . D:X1(1)'=X2(1) SETID^IBCEP3(DA(1),2) > G C5F2 > C5X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",399.0222,DIIENS,.1,DION),$P($ > S X=$G(X(1)) > Q > C5F2 Q > X5 S DIC("S")="I $$CAREUOK^IBCEP4(DA(1),+Y,1,2)" D ^DIC > 6 S DQ=7 ;@8302 X7 S Y="@8383" | X7 I '$P(DIPA("CUNEED"),U,4)!'$D(^DGCR(399,DA(1),"I3")) 8 S DQ=9 ;@8393 | 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;11",DV="R*P355.96" 9 S DW="0;14",DV="*P355.97'R",DU="",DLB="TERTIARY INS P | S DE(DW)="C8^IBXSC8H4",DE(DW,"INDEX")=1 S DU="IBE(355.97," | S DU="IBA(355.96," G RE | G RE X9 S DIC("S")="I '$P($G(^(1)),U,7),$$SECIDCK^IBCEF74(DA( | C8 G C8S:$D(DE(8))[0 K DB > C8S S X="" G:DG(DQ)=X C8F1 K DB > C8F1 N X,X1,X2 S DIXR=142 D C8X1(U) K X2 M X2=X D C8X1("O" > D > . D:X1(1)'=X2(1) DELID^IBCEP3(DA(1),1) > K X M X=X2 D > . D:X1(1)'=X2(1) SETID^IBCEP3(DA(1),1) > G C8F2 > C8X1(DION) K X > S X(1)=$G(@DIEZTMP@("V",399.0222,DIIENS,.11,DION),$P( > S X=$G(X(1)) > Q > C8F2 Q > X8 S DIC("S")="I $$CAREUOK^IBCEP4(DA(1),+Y,1,3)" D ^DIC > Q > ; > 9 S DQ=10 ;@830 > 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) > X10 S DIPA("CRED")=$$CRED^IBCEU($P($G(^DGCR(399,DA(1),"PR ; | 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="0;3",DV="F",DU="",D 10 S DW="0;7",DV="FX",DU="",DLB="TERTIARY INS PERF PROV < X10 I $D(DA) N Z S Z=$G(^DGCR(399,DA(1),"PRV",DA,0)) S:X= | X11 K:$L(X)>3!($L(X)<1) X 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) | 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE) X11 S Y="@8305" | X12 K DIPA("W1") I $G(DIPA("CRED"))'=$P($G(^DGCR(399,DA(1 > Q > 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) > X13 I $G(DIPA("W1")) W !,*7," **Warning** Credentials ar 12 S DQ=13 ;@8371 | 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) 13 S DW="0;12",DV="*P355.97'",DU="",DLB="PRIM INS PROVID | X14 I $G(DIPA("W1")) K DIPA("W1") W $J("",14),"Changes wi S DU="IBE(355.97," | Q S X=DIPA("PRIDT") | 15 S DQ=16 ;@8309 S Y=X | 16 S DW="0;5",DV="RFX",DU="",DLB="PRIMARY INS CO ID NUMB S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | S DE(DW)="C16^IBXSC8H4" G RD:X="@",Z | G RE X13 Q | C16 G C16S:$D(DE(16))[0 K DB 14 S DW="0;5",DV="FX",DU="",DLB="PRIMARY INS CO ID NUMBE | S X=DE(16),DIC=DIE S DE(DW)="C14^IBXSC8H4" < S X=DIPA("PRID") < S Y=X < S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ < G RD:X="@",Z < C14 G C14S:$D(DE(14))[0 K DB < S X=DE(14),DIC=DIE < C14S S X="" G:DG(DQ)=X C14F1 K DB | C16S S X="" G:DG(DQ)=X C16F1 K DB C14F1 Q | C16F1 Q X14 Q | X16 I $D(DA) N Z S Z=$G(^DGCR(399,DA(1),"PRV",DA,0)) S:X= 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) | I $D(X),X'?.ANP K X X15 S Y="@8382" | Q Q | ; 16 S DQ=17 ;@8372 | 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="0;13",DV="*P355.97' | X17 S DIPA("INS")=$P($G(^DGCR(399,DA(1),"M")),U,12,14) S DU="IBE(355.97," | Q S X=DIPA("PRIDT") | 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE) S Y=X | X18 I '$P(DIPA("INS"),U,2) S Y="@831" S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | Q G RD:X="@",Z | 19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW="0;6",DV="FX",DU="", X17 Q | G RE 18 S DW="0;6",DV="FX",DU="",DLB="SECONDARY INS CO ID NUM | X19 I $D(DA) N Z S Z=$G(^DGCR(399,DA(1),"PRV",DA,0)) S:X= S X=DIPA("PRID") | I $D(X),X'?.ANP K X S Y=X | Q S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ | ; G RD:X="@",Z | 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) X18 Q | X20 I '$P($G(DIPA("INS")),U,3) S Y="@831" 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) < X19 S Y="@8383" < Q < 20 S DQ=21 ;@8373 < 21 S DW="0;14",DV="*P355.97'",DU="",DLB="TERT INS PROVID < S DU="IBE(355.97," < S X=DIPA("PRIDT") < S Y=X < S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ < G RD:X="@",Z < X21 Q < 22 S DW="0;7",DV="FX",DU="",DLB="TERTIARY INS CO ID NUMB < S X=DIPA("PRID") < S Y=X < S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $ < G RD:X="@",Z < X22 Q < 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) < X23 S Y="@8305" < Q < 24 S DQ=25 ;@8305 < 25 S DQ=26 ;@98 < 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE) < X26 W @IOF < 27 G 1^DIE17 | 21 D:$D(DG)>9 F^DIE17 G ^IBXSC8H5 diff -y --suppress-common-lines ./VADemo/r1/IBXSC8H.m ./VADemo/r2/r/IBXSC8H.m IBXSC8H ; GENERATED FROM 'IB SCREEN8H' INPUT TEMPLATE(#515), | IBXSC8H ; GENERATED FROM 'IB SCREEN8H' INPUT TEMPLATE(#515), I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,13) S:%]"" DE(14 | I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,13) S:%]"" DE(13 I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,1) S:%]"" DE(7 | I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,1) S:%]"" DE(6 I $D(^("UF3")) S %Z=^("UF3") S %=$P(%Z,U,4) S:%]"" DE | I $D(^("UF3")) S %Z=^("UF3") S %=$P(%Z,U,4) S:%]"" DE X1 K DIPA S DIPA("I1")=$D(^DGCR(399,DA,"I1")),DIPA("I2") | X1 S:IBDR20'["81" Y="@82" 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 | 2 S DW="U;16",DV="D",DU="",DLB="UNABLE TO WORK FROM",DI X2 S:IBDR20'["81" Y="@82" < Q < 3 S DW="U;16",DV="D",DU="",DLB="UNABLE TO WORK FROM",DI < X3 S %DT="EX" D ^%DT S X=Y K:Y<1 X | X2 S %DT="EX" D ^%DT S X=Y K:Y<1 X 4 S DW="U;17",DV="D",DU="",DLB="UNABLE TO WORK TO",DIFL | 3 S DW="U;17",DV="D",DU="",DLB="UNABLE TO WORK TO",DIFL X4 S %DT="EX" D ^%DT S X=Y K:Y<1 X | X3 S %DT="EX" D ^%DT S X=Y K:Y<1 X 5 S DQ=6 ;@82 | 4 S DQ=5 ;@82 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 | 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 X6 S:IBDR20'["82" Y="@83" | X5 S:IBDR20'["82" Y="@83" 7 S DW="U2;1",DV="*P80'",DU="",DLB="ADMITTING DIAGNOSIS | 6 S DW="U2;1",DV="P80'",DU="",DLB="ADMITTING DIAGNOSIS" X7 S ICDVDT=$$BDATE^IBACSV(+$G(DA)),DIC("S")="I $$ICD9AC | X6 Q Q | 7 S DW="UF3;4",DV="F",DU="",DLB="PRIMARY INSURANCE ICN/ ; < 8 S DW="UF3;4",DV="F",DU="",DLB="PRIMARY INSURANCE ICN/ < X8 K:$L(X)>23!($L(X)<3) X | X7 K:$L(X)>23!($L(X)<3) X 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 | 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 X9 S:'DIPA("I2") Y="@825" | X8 I '$D(^DGCR(399,DA,"I2")) S Y="@825" 10 S DW="UF3;5",DV="F",DU="",DLB="SECONDARY INSURANCE IC | 9 S DW="UF3;5",DV="F",DU="",DLB="SECONDARY INSURANCE IC X10 K:$L(X)>23!($L(X)<3) X | X9 K:$L(X)>23!($L(X)<3) X 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE) | 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) X11 S:'DIPA("I3") Y="@825" | X10 I '$D(^DGCR(399,DA,"I3")) S Y="@825" 12 S DW="UF3;6",DV="F",DU="",DLB="FORM LOCATOR 37C",DIFL | 11 S DW="UF3;6",DV="F",DU="",DLB="FORM LOCATOR 37C",DIFL X12 K:$L(X)>23!($L(X)<3) X | X11 K:$L(X)>23!($L(X)<3) X 13 S DQ=14 ;@825 | 12 S DQ=13 ;@825 14 S DW="U;13",DV="FX",DU="",DLB="PRIMARY AUTHORIZATION | 13 S DW="U;13",DV="FX",DU="",DLB="PRIMARY AUTHORIZATION X14 K:$L(X)>18!($L(X)<1) X | X13 K:$L(X)>18!($L(X)<1) X 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE) | 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE) X15 S:'DIPA("I2") Y="@83" | X14 I '$D(^DGCR(399,DA,"I2")) S Y="@83" 16 S DW="U2;8",DV="FX",DU="",DLB="SECONDARY AUTHORIZATIO | 15 S DW="U2;8",DV="FX",DU="",DLB="SECONDARY AUTHORIZATIO X16 K:$L(X)>18!($L(X)<1) X | X15 K:$L(X)>18!($L(X)<1) X 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE) | 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) X17 S:'DIPA("I3") Y="@83" | X16 I '$D(^DGCR(399,DA,"I3")) S Y="@83" 18 S DW="U2;9",DV="F",DU="",DLB="TERTIARY AUTHORIZATION | 17 S DW="U2;9",DV="F",DU="",DLB="TERTIARY AUTHORIZATION X18 K:$L(X)>18!($L(X)<1) X | X17 K:$L(X)>18!($L(X)<1) X 19 S DQ=20 ;@83 | 18 S DQ=19 ;@83 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE) | 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) X20 S:IBDR20'["83" Y="@84" | X19 S:IBDR20'["83" Y="@84" 21 S D=0 K DE(1) ;222 | 20 S D=0 K DE(1) ;222 S DIFLD=222,DGO="^IBXSC8H1",DC="17^399.0222ISA^PRV^", | S DIFLD=222,DGO="^IBXSC8H1",DC="14^399.0222ISA^PRV^", S DU="1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING | S DU="1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING G RE:D I $D(DSC(399.0222))#2,$P(DSC(399.0222),"I $D(^ | G RE:D I $D(DSC(399.0222))#2,$P(DSC(399.0222),"I $D(^ M21 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"PRV",+D,0)) S DE(2 | M20 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"PRV",+D,0)) S DE(2 R21 D DE | R20 D DE S D=$S($D(^DGCR(399,DA,"PRV",0)):$P(^(0),U,3,4),1:1) | S D=$S($D(^DGCR(399,DA,"PRV",0)):$P(^(0),U,3,4),1:1) 22 S DQ=23 ;@84 | 21 S DQ=22 ;@84 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) | 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) X23 S:IBDR20'["84" Y="@85" | X22 S:IBDR20'["84" Y="@85" 24 S DW="U2;10",DV="*P355.93X",DU="",DLB="NON-VA FACILIT | 23 S DW="U2;10",DV="*P355.93X",DU="",DLB="NON-VA FACILIT S DE(DW)="C24^IBXSC8H" | S DE(DW)="C23^IBXSC8H" C24 G C24S:$D(DE(24))[0 K DB | C23 G C23S:$D(DE(23))[0 K DB S X=DE(24),DIC=DIE | S X=DE(23),DIC=DIE S X=DE(24),DIC=DIE | S X=DE(23),DIC=DIE C24S S X="" G:DG(DQ)=X C24F1 K DB | C23S S X="" G:DG(DQ)=X C23F1 K DB C24F1 Q | C23F1 Q X24 S DIC("S")="I $P(^(0),U,2)=1,$P(^(0),U)'["",""" D ^DI | X23 S DIC("S")="I $P(^(0),U,2)=1,$P(^(0),U)'["",""" D ^DI > 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE) > X24 S DIPA("NVA_FAC")=X > Q X25 S DIPA("NVA_FC")=X S:X="" Y="@842" | X25 I DIPA("NVA_FAC")="" S Y="@85" X26 S DIPA("NVA_FC-0")=$G(^IBA(355.93,+DIPA("NVA_FC"),0)) | X26 S DIPA("NVA_FAC-0")=$G(^IBA(355.93,+DIPA("NVA_FAC"),0 > Q > 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE) > X27 I $P(DIPA("NVA_FAC-0"),U,5)'=""&($P(DIPA("NVA_FAC-0") 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 S I(0,0)=D0 S Y(1)= | 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 S I(0,0)=D0 S Y(1)= R27 D DE G A | R28 D DE G A 28 S DQ=29 ;@841 | 29 S DQ=30 ;@841 29 D:$D(DG)>9 F^DIE17 G ^IBXSC8H3 | 30 D:$D(DG)>9 F^DIE17 G ^IBXSC8H3 diff -y --suppress-common-lines ./VADemo/r1/IBXSC8.m ./VADemo/r2/r/IBXSC8.m IBXSC8 ; GENERATED FROM 'IB SCREEN8' INPUT TEMPLATE(#514), F | IBXSC8 ; GENERATED FROM 'IB SCREEN8' INPUT TEMPLATE(#514), F N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X | N I X="" G A:DV'["R",X:'DV,X:D'>0,A T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD | T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ | P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S | Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^D SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")= | SET I X'?.ANP S DDER=1 Q > N DIR S DIR(0)="SMV^"_DU,DIR("V")=1 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBAD | S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=514,U="^" M DIEZAR=^DIE(514,"AR") S DICRREC="TRIG^DIE17" | 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=51 < 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 < 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 | 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 G A:$D(Y)[0,A:Y 5 S DW="U1;4",DV="F",DU="",DLB="UB82 FORM LOCATOR 2",DI | 5 S DW="U1;4",DV="F",DU="",DLB="FORM LOCATOR 2",DIFLD=2 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 | 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 G A:$D(Y)[0,A:Y 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) | 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE) | 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 G A:$D(Y)[0,A 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE) | 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 G A:$D(Y)[0,A 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE) | 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 G A:$D(Y)[0,A 20 S DW="U1;14",DV="F",DU="",DLB="*FORM LOCATOR 93",DIFL | 20 S DW="U1;14",DV="F",DU="",DLB="FORM LOCATOR 93",DIFLD 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE) | 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 G A:$D(Y)[0,A 23 S DW="U;13",DV="FX",DU="",DLB="TREATMENT AUTHORIZATIO | 23 S DW="U;13",DV="F",DU="",DLB="TREATMENT AUTHORIZATION diff -y --suppress-common-lines ./VADemo/r1/IBXST1.m ./VADemo/r2/r/IBXST1.m IBXST1 ; ;10/29/04 | IBXST1 ; ;04/23/02 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/IBXST2.m ./VADemo/r2/r/IBXST2.m IBXST2 ; ;10/29/04 | IBXST2 ; ;04/23/02 X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( | X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( | X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( diff -y --suppress-common-lines ./VADemo/r1/IBXST3.m ./VADemo/r2/r/IBXST3.m IBXST3 ; ;10/29/04 | IBXST3 ; ;04/23/02 S X=DE(19),DIC=DIE | S X=DG(DQ),DIC=DIE K ^DGCR(399,"ALEX",$E(X,1,30),DA) | S ^DGCR(399,"ALEX",$E(X,1,30),DA)="" diff -y --suppress-common-lines ./VADemo/r1/IBXST4.m ./VADemo/r2/r/IBXST4.m IBXST4 ; ;10/29/04 | IBXST4 ; ;04/23/02 S X=DG(DQ),DIC=DIE | S X=DE(22),DIC=DIE S ^DGCR(399,"ALEX",$E(X,1,30),DA)="" | ; > S X=DE(22),DIC=DIE > ; diff -y --suppress-common-lines ./VADemo/r1/IBXST5.m ./VADemo/r2/r/IBXST5.m IBXST5 ; ;10/29/04 | IBXST5 ; ;04/23/02 D DE G BEGIN < DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K < I $D(^("S")) S %Z=^("S") S %=$P(%Z,U,9) S:%]"" DE(7)= < I $D(^("TX")) S %Z=^("TX") S %=$P(%Z,U,5) 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 " (N < 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 < 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=^ < T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD < K DDER G X < P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_ < 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, < V D @("X"_DQ) K YS < Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) S < 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) < Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X=" < 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 < I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) < X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_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")= < 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 < 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 < KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") < BEGIN S DNM="IBXST5",DQ=1 < 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="TX;5",DV="S",DU="",D < S DE(DW)="C1^IBXST5" < S DU="0:NO MRA NEEDED;1N:MRA NEEDED/NOT YET REQUESTED < S X="1R" < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C1 G C1S:$D(DE(1))[0 K DB < S X=DE(1),DIC=DIE < ; < C1S S X="" G:DG(DQ)=X C1F1 K DB < X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, C1F1 Q < X1 Q < 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 < X2 S Y="@99" < Q < 3 S DQ=4 ;@94 < 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="S;14",DV="D",DU="",D < S DE(DW)="C4^IBXST5" < S X=DT < S Y=X < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C4 G C4S:$D(DE(4))[0 K DB < S X=DE(4),DIC=DIE < ; < S X=DE(4),DIC=DIE < ; < C4S S X="" G:DG(DQ)=X C4F1 K DB < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, < C4F1 Q < X4 S %DT="TX" D ^%DT S X=Y K:Y<1 X < Q < ; < 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 < X5 S Y="@99" < Q < 6 S DQ=7 ;@902 < 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="S;9",DV="FOX",DU="", < S DQ(7,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:""" < S DE(DW)="C7^IBXST5" < S Y="Y" < S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I < G RD < C7 G C7S:$D(DE(7))[0 K DB < S X=DE(7),DIC=DIE < ; < S X=DE(7),DIC=DIE < ; < S X=DE(7),DIC=DIE < ; < S X=DE(7),DIC=DIE < ; < C7S S X="" G:DG(DQ)=X C7F1 K DB < S X=DG(DQ),DIC=DIE < X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(3 < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1, < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D( < S X=DG(DQ),DIC=DIE < K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL < C7F1 Q < X7 I $D(X) D YN^IBCU < I $D(X),X'?.ANP K X < Q < ; < 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 < X8 S Y="@99" < Q < 9 S DQ=10 ;@99 < 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE) < X10 K DIE("NO^") < Q < 11 G 0^DIE17 < diff -y --suppress-common-lines ./VADemo/r1/IBXST6.m ./VADemo/r2/r/IBXST6.m IBXST6 ; ;09/17/04 | IBXST6 ; ;04/23/02 C1S S X="" G:DG(DQ)=X C1F1 K DB | C1S S X="" Q:DG(DQ)=X K DB C1F1 Q | Q diff -y --suppress-common-lines ./VADemo/r1/IBXST.m ./VADemo/r2/r/IBXST.m IBXST ; GENERATED FROM 'IB STATUS' INPUT TEMPLATE(#506), FI | IBXST ; GENERATED FROM 'IB STATUS' INPUT TEMPLATE(#506), FI I $D(^("S")) S %Z=^("S") S %=$P(%Z,U,9) S:%]"" DE(4)= | I $D(^("S")) S %Z=^("S") S %=$P(%Z,U,9) S:%]"" DE(4)= S X=DE(4),DIC=DIE | C4S S X="" Q:DG(DQ)=X K DB ; < C4S S X="" G:DG(DQ)=X C4F1 K DB < S X=DG(DQ),DIC=DIE | Q K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL < C4F1 Q < C10S S X="" G:DG(DQ)=X C10F1 K DB | C10S S X="" Q:DG(DQ)=X K DB K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1 | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1 | K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399, C10F1 Q | Q C13S S X="" G:DG(DQ)=X C13F1 K DB | C13S S X="" Q:DG(DQ)=X K DB C13F1 Q | Q C16S S X="" G:DG(DQ)=X C16F1 K DB | C16S S X="" Q:DG(DQ)=X K DB C16F1 Q | Q > S X=DE(19),DIC=DIE > K ^DGCR(399,"ALEX",$E(X,1,30),DA) > C19S S X="" Q:DG(DQ)=X K DB C19S S X="" G:DG(DQ)=X C19F1 K DB | Q D ^IBXST4 < C19F1 Q < X20 I $P($G(^DGCR(399,DA,0)),U,13)'=2 S Y="@99" | X20 S Y="@99" 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE) | 21 S DQ=22 ;@94 X21 I $P($G(^DGCR(399,DA,"TX")),U,5)="C" S Y="@99" | 22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW="S;14",DV="D",DU="", > S DE(DW)="C22^IBXST" > S X=DT > S Y=X > S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I > G RD > C22 G C22S:$D(DE(22))[0 K DB > D ^IBXST4 > C22S S X="" Q:DG(DQ)=X K DB > D ^IBXST5 > Q > X22 S %DT="TX" D ^%DT S X=Y K:Y<1 X > Q > ; > 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE) > X23 S Y="@99" 22 D:$D(DG)>9 F^DIE17 G ^IBXST5 | 24 S DQ=25 ;@902 > 25 D:$D(DG)>9 F^DIE17 G ^IBXST6 diff -y --suppress-common-lines ./VADemo/r1/IBXX10.m ./VADemo/r2/r/IBXX10.m IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 02/04/05 | IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 09/27/02 diff -y --suppress-common-lines ./VADemo/r1/IBXX11.m ./VADemo/r2/r/IBXX11.m IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 02/04/05 | IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 09/27/02 diff -y --suppress-common-lines ./VADemo/r1/IBXX12.m ./VADemo/r2/r/IBXX12.m IBXX12 ; COMPILED XREF FOR FILE #399.048 ; 02/04/05 | IBXX12 ; COMPILED XREF FOR FILE #399.30416 ; 09/27/02 S DA=0 | S DA(2)=DA(1) S DA(1)=0 S DA=0 I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G 0 ; | A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S A S DA=$O(^DGCR(399,DA(1),"OT",DA)) I DA'>0 S DA=0 G EN < S DIKZ(0)=$G(^DGCR(399,DA(1),"OT",DA,0)) | B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 > 2 ; > S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0)) > S X=$P(DIKZ(0),U,2) > I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1 I X'="" K ^DGCR(399,DA(1),"OT","B",$E(X,1,30),DA) | I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1 G:'$D(DIKLM) A Q:$D(DIKILL) | G:'$D(DIKLM) B Q:$D(DIKILL) END G ^IBXX13 | END Q diff -y --suppress-common-lines ./VADemo/r1/IBXX13.m ./VADemo/r2/r/IBXX13.m IBXX13 ; COMPILED XREF FOR FILE #399.30416 ; 02/04/05 | IBXX13 ; COMPILED XREF FOR FILE #399 ; 09/27/02 S DA(2)=DA(1) S DA(1)=0 S DA=0 | S DIKZK=1 A1 ; | S DIKZ(0)=$G(^DGCR(399,DA,0)) I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G | S X=$P(DIKZ(0),U,1) A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S | I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)="" 1 ; | S X=$P(DIKZ(0),U,1) B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 | I X'="" D 2 ; | .N DIK,DIV,DIU,DIN S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0)) | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( S X=$P(DIKZ(0),U,2) | S X=$P(DIKZ(0),U,1) I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1 | I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1 | I X'="" D G:'$D(DIKLM) B Q:$D(DIKILL) | .N DIK,DIV,DIU,DIN END Q | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( > S X=$P(DIKZ(0),U,1) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 > S X=$P(DIKZ(0),U,1) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,2) > I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,2) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( > S X=$P(DIKZ(0),U,3) > I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,3) > I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DG > S X=$P(DIKZ(0),U,3) > I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)="" > S X=$P(DIKZ(0),U,4) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,5) > I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,5) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,6) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,7) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,7) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 > S X=$P(DIKZ(0),U,7) > I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,8) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,8) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,8) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,8) > I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,8) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(39 > S X=$P(DIKZ(0),U,11) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,11) > I X'="" D EN^IBCU5 > S X=$P(DIKZ(0),U,11) > I X'="" S DGRVRCAL=1 > S X=$P(DIKZ(0),U,11) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,13) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 > S X=$P(DIKZ(0),U,13) > I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399 > S X=$P(DIKZ(0),U,13) > I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)="" > S X=$P(DIKZ(0),U,13) > 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=$P(DIKZ(0),U,17) > I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,19) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC > S X=$P(DIKZ(0),U,19) > I X'="" S DGRVRCAL=1 > S X=$P(DIKZ(0),U,19) > I X'="" D ALLID^IBCEP3(DA,.19,1) > S X=$P(DIKZ(0),U,19) > I X'="" D BILLPNS^IBCU(DA) > S X=$P(DIKZ(0),U,20) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR > S X=$P(DIKZ(0),U,21) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 > S X=$P(DIKZ(0),U,25) > I X'="" D ALLID^IBCEP3(DA,.25,1) > S X=$P(DIKZ(0),U,26) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 > S X=$P(DIKZ(0),U,27) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 > S DIKZ("S")=$G(^DGCR(399,DA,"S")) > S X=$P(DIKZ("S"),U,1) > I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)="" > S X=$P(DIKZ("S"),U,3) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( > S X=$P(DIKZ("S"),U,3) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( > S X=$P(DIKZ("S"),U,9) > I X'="" D > .N DIK,DIV,DIU,DIN > .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( > S X=$P(DIKZ("S"),U,9) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1 > S X=$P(DIKZ("S"),U,9) > END G ^IBXX14 diff -y --suppress-common-lines ./VADemo/r1/IBXX14.m ./VADemo/r2/r/IBXX14.m IBXX14 ; COMPILED XREF FOR FILE #399 ; 02/04/05 | IBXX14 ; COMPILED XREF FOR FILE #399.0222 ; 09/27/02 S DIKZK=1 < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S X=$P(DIKZ(0),U,1) < I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)="" < S X=$P(DIKZ(0),U,1) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D S X=$P(DIKZ(0),U,1) | S X=$P(DIKZ("S"),U,10) > I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)="" > S X=$P(DIKZ("S"),U,12) .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( S X=$P(DIKZ(0),U,1) | S X=$P(DIKZ("S"),U,12) .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR S X=$P(DIKZ(0),U,1) | S X=$P(DIKZ("S"),U,12) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR S X=$P(DIKZ(0),U,1) | S X=$P(DIKZ("S"),U,12) > I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)="" > S X=$P(DIKZ("S"),U,14) .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("S"),U,14) S X=$P(DIKZ(0),U,2) < I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)="" < S X=$P(DIKZ(0),U,2) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("S"),U,16) S X=$P(DIKZ(0),U,3) < I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)="" < S X=$P(DIKZ(0),U,3) < I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DG < S X=$P(DIKZ(0),U,3) < I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)="" < S X=$P(DIKZ(0),U,4) < .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("S"),U,16) S X=$P(DIKZ(0),U,5) < I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)="" < S X=$P(DIKZ(0),U,5) < .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("S"),U,17) S X=$P(DIKZ(0),U,6) < .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(39 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S DIKZ("TX")=$G(^DGCR(399,DA,"TX")) S X=$P(DIKZ(0),U,7) | S X=$P(DIKZ("TX"),U,2) > I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)="" > S X=$P(DIKZ("TX"),U,5) .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR S X=$P(DIKZ(0),U,7) | S X=$P(DIKZ("TX"),U,6) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=$P(DIKZ(0),U,7) | S X=$P(DIKZ("TX"),U,6) I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)="" < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S X=$P(DIKZ(0),U,8) < .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ(0),U,8) | S X=$P(DIKZ("TX"),U,6) .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ(0),U,8) | S DIKZ("C")=$G(^DGCR(399,DA,"C")) > S X=$P(DIKZ("C"),U,14) .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(39 S X=$P(DIKZ(0),U,8) | S DIKZ("M")=$G(^DGCR(399,DA,"M")) I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)="" | S X=$P(DIKZ("M"),U,1) S X=$P(DIKZ(0),U,8) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(39 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("M"),U,1) S X=$P(DIKZ(0),U,11) < .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCE S X=$P(DIKZ(0),U,11) | S X=$P(DIKZ("M"),U,2) I X'="" D EN^IBCU5 < S X=$P(DIKZ(0),U,11) < I X'="" S DGRVRCAL=1 < S X=$P(DIKZ(0),U,11) < .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("M"),U,2) S X=$P(DIKZ(0),U,13) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCE S X=$P(DIKZ(0),U,13) | S X=$P(DIKZ("M"),U,3) I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399 < S X=$P(DIKZ(0),U,13) < I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)="" < S X=$P(DIKZ(0),U,13) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("M"),U,11) S X=$P(DIKZ(0),U,14) | I X'="" D MAILIN^IBCU5 I X'="" D BC^IBJVDEQ | S X=$P(DIKZ("M"),U,11) S X=$P(DIKZ(0),U,17) | I X'="" S DGRVRCAL=1 I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)="" | S X=$P(DIKZ("M"),U,12) S X=$P(DIKZ(0),U,19) < .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ(0),U,19) | S X=$P(DIKZ("M"),U,12) I X'="" S DGRVRCAL=1 | I X'="" D IX^IBCNS2(DA,"I1") S X=$P(DIKZ(0),U,19) | S X=$P(DIKZ("M"),U,12) I X'="" D ALLID^IBCEP3(DA,.19,1) < S X=$P(DIKZ(0),U,19) < I X'="" D BILLPNS^IBCU(DA) < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S X=$P(DIKZ(0),U,20) < .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR | .X ^DD(399,112,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGC S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("M"),U,13) S X=$P(DIKZ(0),U,21) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ(0),U,21) | S X=$P(DIKZ("M"),U,13) > I X'="" D IX^IBCNS2(DA,"I2") > S X=$P(DIKZ("M"),U,13) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMR | .X ^DD(399,113,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGC S X=$P(DIKZ(0),U,21) | S X=$P(DIKZ("M"),U,14) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRB | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("M"),U,14) S X=$P(DIKZ(0),U,22) | I X'="" D IX^IBCNS2(DA,"I3") > S X=$P(DIKZ("M"),U,14) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .X ^DD(399,114,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGC S X=$P(DIKZ(0),U,22) | S DIKZ("MP")=$G(^DGCR(399,DA,"MP")) > S X=$P(DIKZ("MP"),U,1) > I X'="" S:$P(^DGCR(399,DA,0),U,2) ^DGCR(399,"AE",$P(^ > S X=$P(DIKZ("MP"),U,1) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ(0),U,22) | S X=$P(DIKZ("MP"),U,1) > I X'="" D MAILA^IBCU5 > S X=$P(DIKZ("MP"),U,1) > I X'="" S DGRVRCAL=1 > S X=$P(DIKZ("MP"),U,2) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBIL > S DIKZ("U")=$G(^DGCR(399,DA,"U")) > S X=$P(DIKZ("U"),U,1) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(39 > S X=$P(DIKZ("U"),U,1) > I X'="" S DGRVRCAL=1 > S X=$P(DIKZ("U"),U,1) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(3 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("U"),U,1) S X=$P(DIKZ(0),U,25) | I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS", > S X=$P(DIKZ("U"),U,2) diff -y --suppress-common-lines ./VADemo/r1/IBXX15.m ./VADemo/r2/r/IBXX15.m IBXX15 ; COMPILED XREF FOR FILE #399 ; 02/04/05 | IBXX15 ; COMPILED XREF FOR FILE #399.0222 ; 09/27/02 I X'="" D ALLID^IBCEP3(DA,.25,1) < S X=$P(DIKZ(0),U,26) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(39 S DIKZ(0)=$G(^DGCR(399,DA,0)) | S X=$P(DIKZ("U"),U,2) S X=$P(DIKZ(0),U,27) | I X'="" S DGRVRCAL=1 > S X=$P(DIKZ("U"),U,11) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC S DIKZ("S")=$G(^DGCR(399,DA,"S")) | S X=$P(DIKZ("U"),U,15) S X=$P(DIKZ("S"),U,1) < I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)="" < S X=$P(DIKZ("S"),U,3) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^D S X=$P(DIKZ("S"),U,3) | S X=$P(DIKZ("U"),U,15) .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( | .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGC S DIKZ("S")=$G(^DGCR(399,DA,"S")) | S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) S X=$P(DIKZ("S"),U,7) | S X=$P(DIKZ("U2"),U,4) I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)="" < S X=$P(DIKZ("S"),U,9) < .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR( | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ("S"),U,9) | S X=$P(DIKZ("U2"),U,4) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ("S"),U,9) | S X=$P(DIKZ("U2"),U,5) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ("S"),U,9) | S X=$P(DIKZ("U2"),U,5) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNA | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ("S")=$G(^DGCR(399,DA,"S")) | S X=$P(DIKZ("U2"),U,6) S X=$P(DIKZ("S"),U,10) < I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)="" < S X=$P(DIKZ("S"),U,12) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ("S"),U,12) | S X=$P(DIKZ("U2"),U,6) .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ("S"),U,12) | S X=$P(DIKZ("U2"),U,10) .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S X=$P(DIKZ("S"),U,12) | CR1 S DIXR=139 I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)="" | K X S DIKZ("S")=$G(^DGCR(399,DA,"S")) | S X(1)=$P(DIKZ("M"),U,1) S X=$P(DIKZ("S"),U,14) | S X(2)=$P(DIKZ("M"),U,2) I X'="" D | S X(3)=$P(DIKZ("M"),U,3) .N DIK,DIV,DIU,DIN | S X(4)=$P(DIKZ("M"),U,13) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | S X(5)=$P(DIKZ("M"),U,12) S X=$P(DIKZ("S"),U,14) | S X(6)=$P(DIKZ("M"),U,14) I X'="" D | S X=$G(X(1)) .N DIK,DIV,DIU,DIN | . K X1,X2 M X1=X,X2=X .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | . N DIKXARR M DIKXARR=X S DIKCOND=1 S DIKZ("S")=$G(^DGCR(399,DA,"S")) | . S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0) S X=$P(DIKZ("S"),U,16) | . S DIKCOND=$G(X) K X M X=DIKXARR I X'="" D | . Q:'DIKCOND .N DIK,DIV,DIU,DIN | . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) SETID^IBCEP3(DA,1) D: .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNA | CR2 K X S X=$P(DIKZ("S"),U,16) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNA < S DIKZ("S")=$G(^DGCR(399,DA,"S")) < S X=$P(DIKZ("S"),U,17) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D( < S DIKZ("TX")=$G(^DGCR(399,DA,"TX")) < S X=$P(DIKZ("TX"),U,2) < I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)="" < S X=$P(DIKZ("TX"),U,5) < I X'="" D < .N DIK,DIV,DIU,DIN < .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR < S DIKZ("TX")=$G(^DGCR(399,DA,"TX")) < S X=$P(DIKZ("TX"),U,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=$P(DIKZ("TX"),U,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(399,25, < S X=$P(DIKZ("TX"),U,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(399,25, < S DIKZ("C")=$G(^DGCR(399,DA,"C")) < S X=$P(DIKZ("C"),U,14) < I X'="" D < .N DIK,DIV,DIU,DIN < .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR < S DIKZ("M")=$G(^DGCR(399,DA,"M")) < S X=$P(DIKZ("M"),U,1) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S X=$P(DIKZ("M"),U,1) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCE < S X=$P(DIKZ("M"),U,1) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRW < S DIKZ("M")=$G(^DGCR(399,DA,"M")) < S X=$P(DIKZ("M"),U,2) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S X=$P(DIKZ("M"),U,2) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCE < S X=$P(DIKZ("M"),U,2) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRW < S DIKZ("M")=$G(^DGCR(399,DA,"M")) < S X=$P(DIKZ("M"),U,3) < diff -y --suppress-common-lines ./VADemo/r1/IBXX16.m ./VADemo/r2/r/IBXX16.m IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 02/04/05 | IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 09/27/02 > S DA(1)=DA S DA=0 > A1 ; > I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 > 0 ; > A S DA=$O(^DGCR(399,DA(1),"PRV",DA)) I DA'>0 S DA=0 G E > 1 ; > S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0)) > S X=$P(DIKZ(0),U,1) > I X'="" S ^DGCR(399,DA(1),"PRV","B",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,1) .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y S DIKZ("M")=$G(^DGCR(399,DA,"M")) | S X=$P(DIKZ(0),U,1) S X=$P(DIKZ("M"),U,11) | I X'="" S ^DGCR(399,DA(1),"PRV","C",$E($$EXTERNAL^DIL I X'="" D MAILIN^IBCU5 | S X=$P(DIKZ(0),U,1) S X=$P(DIKZ("M"),U,11) | I X'="" S ^DGCR(399,DA(1),"PRV","C",$$LOW^XLFSTR($E($ I X'="" S DGRVRCAL=1 | S X=$P(DIKZ(0),U,2) S X=$P(DIKZ("M"),U,12) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .X ^DD(399.0222,.02,1,1,1.3) I X S X=DIV S Y(1)=$S($D S X=$P(DIKZ("M"),U,12) | S X=$P(DIKZ(0),U,2) I X'="" D IX^IBCNS2(DA,"I1") < S X=$P(DIKZ("M"),U,12) < .X ^DD(399,112,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .X ^DD(399.0222,.02,1,2,1.3) I X S X=DIV S Y(1)=$S($D S DIKZ("M")=$G(^DGCR(399,DA,"M")) | S X=$P(DIKZ(0),U,2) S X=$P(DIKZ("M"),U,13) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .X ^DD(399.0222,.02,1,3,1.3) I X S X=DIV S Y(1)=$S($D S X=$P(DIKZ("M"),U,13) | S X=$P(DIKZ(0),U,2) I X'="" D IX^IBCNS2(DA,"I2") < S X=$P(DIKZ("M"),U,13) < .X ^DD(399,113,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .X ^DD(399.0222,.02,1,4,1.3) I X S X=DIV S Y(1)=$S($D S DIKZ("M")=$G(^DGCR(399,DA,"M")) | S X=$P(DIKZ(0),U,2) S X=$P(DIKZ("M"),U,14) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .X ^DD(399.0222,.02,1,5,1.3) I X S X=DIV S Y(1)=$S($D S X=$P(DIKZ("M"),U,14) | S X=$P(DIKZ(0),U,2) I X'="" D IX^IBCNS2(DA,"I3") < S X=$P(DIKZ("M"),U,14) < .X ^DD(399,114,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGC | .X ^DD(399.0222,.02,1,6,1.3) I X S X=DIV S Y(1)=$S($D S DIKZ("MP")=$G(^DGCR(399,DA,"MP")) | S X=$P(DIKZ(0),U,5) S X=$P(DIKZ("MP"),U,1) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y S X=$P(DIKZ("MP"),U,1) | G:'$D(DIKLM) A Q:$D(DISET) I X'="" D MAILA^IBCU5 < S X=$P(DIKZ("MP"),U,1) < I X'="" S DGRVRCAL=1 < S DIKZ("MP")=$G(^DGCR(399,DA,"MP")) < S X=$P(DIKZ("MP"),U,2) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBIL < S DIKZ("U")=$G(^DGCR(399,DA,"U")) < S X=$P(DIKZ("U"),U,1) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(39 < S X=$P(DIKZ("U"),U,1) < I X'="" S DGRVRCAL=1 < S X=$P(DIKZ("U"),U,1) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(3 < S X=$P(DIKZ("U"),U,1) < I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS", < S DIKZ("U")=$G(^DGCR(399,DA,"U")) < S X=$P(DIKZ("U"),U,2) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(39 < S X=$P(DIKZ("U"),U,2) < I X'="" S DGRVRCAL=1 < S DIKZ("U")=$G(^DGCR(399,DA,"U")) < S X=$P(DIKZ("U"),U,11) < I X'="" D < .N DIK,DIV,DIU,DIN < .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGC < S DIKZ("U")=$G(^DGCR(399,DA,"U")) < S X=$P(DIKZ("U"),U,15) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^D < S X=$P(DIKZ("U"),U,15) < I X'="" D < .N DIK,DIV,DIU,DIN < .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGC < S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) < S X=$P(DIKZ("U2"),U,4) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S X=$P(DIKZ("U2"),U,4) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) < S X=$P(DIKZ("U2"),U,5) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S X=$P(DIKZ("U2"),U,5) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) < S X=$P(DIKZ("U2"),U,6) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S X=$P(DIKZ("U2"),U,6) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) < S X=$P(DIKZ("U2"),U,10) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 < S DIKZ("M1")=$G(^DGCR(399,DA,"M1")) < S X=$P(DIKZ("M1"),U,8) < I X'="" S ^DGCR(399,"AG",$E(X,1,30),DA)="" < CR1 S DIXR=139 < K X < S DIKZ("M")=$G(^DGCR(399,DA,"M")) < S X(1)=$P(DIKZ("M"),U,1) < S X(2)=$P(DIKZ("M"),U,2) < S X(3)=$P(DIKZ("M"),U,3) < S X(4)=$P(DIKZ("M"),U,13) < S X(5)=$P(DIKZ("M"),U,12) < S X(6)=$P(DIKZ("M"),U,14) < S X=$G(X(1)) < D < . K X1,X2 M X1=X,X2=X < . N DIKXARR M DIKXARR=X S DIKCOND=1 < . S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0) < . S DIKCOND=$G(X) K X M X=DIKXARR < . Q:'DIKCOND < . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) SETID^IBCEP3(DA,1) D: < CR2 S DIXR=477 < K X < S DIKZ("M")=$G(^DGCR(399,DA,"M")) < S X(1)=$P(DIKZ("M"),U,1) < S X(2)=$P(DIKZ("M"),U,2) < S X(3)=$P(DIKZ("M"),U,3) < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S X(4)=$P(DIKZ(0),U,2) < S X=$G(X(1)) < D < . K X1,X2 M X1=X,X2=X < . N CURR S CURR=+$$COBN^IBCEF(DA) I $G(X(4)),$G(X(CUR < CR3 K X < diff -y --suppress-common-lines ./VADemo/r1/IBXX17.m ./VADemo/r2/r/IBXX17.m IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 02/04/05 | IBXX17 ; COMPILED XREF FOR FILE #399.0304 ; 09/27/02 S DA(1)=DA S DA=0 | S DA=0 A S DA=$O(^DGCR(399,DA(1),"PRV",DA)) I DA'>0 S DA=0 G E | A S DA=$O(^DGCR(399,DA(1),"CP",DA)) I DA'>0 S DA=0 G EN S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0)) | S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0)) I X'="" S ^DGCR(399,DA(1),"PRV","B",$E(X,1,30),DA)="" | I X'="" S ^DGCR(399,DA(1),"CP","B",$E(X,1,30),DA)="" I X'="" D | I X'="" I $P(X,";",2)="ICPT(",$D(^DGCR(399,DA(1),"CP" .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y < S X=$P(DIKZ(0),U,1) < I X'="" S ^DGCR(399,DA(1),"PRV","C",$E($$EXTERNAL^DIL < S X=$P(DIKZ(0),U,1) < I X'="" S ^DGCR(399,DA(1),"PRV","C",$$LOW^XLFSTR($E($ < S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0)) < S X=$P(DIKZ(0),U,2) < I X'="" D < .N DIK,DIV,DIU,DIN < .X ^DD(399.0222,.02,1,1,1.3) I X S X=DIV S Y(1)=$S($D < S X=$P(DIKZ(0),U,2) < I X'="" D < .N DIK,DIV,DIU,DIN < .X ^DD(399.0222,.02,1,2,1.3) I X S X=DIV S Y(1)=$S($D < > I X'="" I $D(^DGCR(399,DA(1),"CP",DA,0)),+^(0),$P($P( > S X=$P(DIKZ(0),U,4) > I X'="" S ^DGCR(399,DA(1),"CP","D",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,5) > I X'="" S DGRVRCAL=1 > S X=$P(DIKZ(0),U,5) > I X'="" S ^DGCR(399,DA(1),"CP","ASC",$E(X,1,30),DA)=" > S X=$P(DIKZ(0),U,7) .X ^DD(399.0222,.02,1,3,1.3) I X S X=DIV S Y(1)=$S($D | .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0)) | S X=$P(DIKZ(0),U,10) S X=$P(DIKZ(0),U,5) < .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y | .X ^DD(399.0304,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^ diff -y --suppress-common-lines ./VADemo/r1/IBXX18.m ./VADemo/r2/r/IBXX18.m IBXX18 ; COMPILED XREF FOR FILE #399.0304 ; 02/04/05 | IBXX18 ; COMPILED XREF FOR FILE #399.041 ; 09/27/02 A S DA=$O(^DGCR(399,DA(1),"CP",DA)) I DA'>0 S DA=0 G EN | A S DA=$O(^DGCR(399,DA(1),"OC",DA)) I DA'>0 S DA=0 G EN S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0)) | S DIKZ(0)=$G(^DGCR(399,DA(1),"OC",DA,0)) I X'="" S ^DGCR(399,DA(1),"CP","B",$E(X,1,30),DA)="" | I X'="" S ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA)="" S X=$P(DIKZ(0),U,1) < I X'="" I $P(X,";",2)="ICPT(",$D(^DGCR(399,DA(1),"CP" < S X=$P(DIKZ(0),U,2) < I X'="" I $D(^DGCR(399,DA(1),"CP",DA,0)),+^(0),$P($P( < S X=$P(DIKZ(0),U,4) < I X'="" S ^DGCR(399,DA(1),"CP","D",$E(X,1,30),DA)="" < S X=$P(DIKZ(0),U,5) < I X'="" S DGRVRCAL=1 < S X=$P(DIKZ(0),U,5) < I X'="" S ^DGCR(399,DA(1),"CP","ASC",$E(X,1,30),DA)=" < S X=$P(DIKZ(0),U,7) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y < S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0)) < S X=$P(DIKZ(0),U,10) < I X'="" D < .N DIK,DIV,DIU,DIN < .X ^DD(399.0304,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^ < diff -y --suppress-common-lines ./VADemo/r1/IBXX19.m ./VADemo/r2/r/IBXX19.m IBXX19 ; COMPILED XREF FOR FILE #399.041 ; 02/04/05 | IBXX19 ; COMPILED XREF FOR FILE #399.042 ; 09/27/02 A S DA=$O(^DGCR(399,DA(1),"OC",DA)) I DA'>0 S DA=0 G EN | A S DA=$O(^DGCR(399,DA(1),"RC",DA)) I DA'>0 S DA=0 G EN S DIKZ(0)=$G(^DGCR(399,DA(1),"OC",DA,0)) | S DIKZ(0)=$G(^DGCR(399,DA(1),"RC",DA,0)) I X'="" S ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA)="" | I X'="" S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,1) > I X'="" I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR( > S X=$P(DIKZ(0),U,2) > I X'="" D 21^IBCU2 > S X=$P(DIKZ(0),U,3) > I X'="" D 31^IBCU2 > S X=$P(DIKZ(0),U,4) > I X'="" S DGXRF=1 D TC^IBCU2 K DGXRF > S X=$P(DIKZ(0),U,5) > I X'="" S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGC > S X=$P(DIKZ(0),U,6) > I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1", > S X=$P(DIKZ(0),U,6) > I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2", > S X=$P(DIKZ(0),U,7) > I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1", > S X=$P(DIKZ(0),U,7) > I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2", > S X=$P(DIKZ(0),U,15) > I X'="" S ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)=" diff -y --suppress-common-lines ./VADemo/r1/IBXX1.m ./VADemo/r2/r/IBXX1.m IBXX1 ; COMPILED XREF FOR FILE #399 ; 02/04/05 | IBXX1 ; COMPILED XREF FOR FILE #399 ; 09/27/02 S DIKZ(0)=$G(^DGCR(399,DA,0)) < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S X=$P(DIKZ(0),U,21) < I X'="" D < .N DIK,DIV,DIU,DIN < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMR < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S X=$P(DIKZ("S"),U,7) < I X'="" K ^DGCR(399,"APM",$E(X,1,30),DA) < .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 | .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ("M")=$G(^DGCR(399,DA,"M")) | S X=$P(DIKZ("M"),U,1) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ("M")=$G(^DGCR(399,DA,"M")) | S X=$P(DIKZ("M"),U,2) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 > S X=$P(DIKZ("M"),U,3) > I X'="" D > .N DIK,DIV,DIU,DIN > .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399 S DIKZ("M")=$G(^DGCR(399,DA,"M")) < S DIKZ("M")=$G(^DGCR(399,DA,"M")) < > I X'="" K:$P(^DGCR(399,DA,0),U,2) ^DGCR(399,"AE",$P(^ > S X=$P(DIKZ("MP"),U,1) S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) < S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) < S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) < S DIKZ("M1")=$G(^DGCR(399,DA,"M1")) | S X=$P(DIKZ(0),U,1) S X=$P(DIKZ("M1"),U,8) | I X'="" K ^DGCR(399,"B",$E(X,1,30),DA) I X'="" K ^DGCR(399,"AG",$E(X,1,30),DA) | CR1 S DIXR=139 > K X diff -y --suppress-common-lines ./VADemo/r1/IBXX20.m ./VADemo/r2/r/IBXX20.m IBXX20 ; COMPILED XREF FOR FILE #399.042 ; 02/04/05 | IBXX20 ; COMPILED XREF FOR FILE #399.043 ; 09/27/02 A S DA=$O(^DGCR(399,DA(1),"RC",DA)) I DA'>0 S DA=0 G EN | A S DA=$O(^DGCR(399,DA(1),"OP",DA)) I DA'>0 S DA=0 G EN S DIKZ(0)=$G(^DGCR(399,DA(1),"RC",DA,0)) | S DIKZ(0)=$G(^DGCR(399,DA(1),"OP",DA,0)) I X'="" S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)="" | I X'="" S ^DGCR(399,"AOPV",$P(^DGCR(399,DA(1),0),U,2) I X'="" I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR( | I X'="" S DGRVRCAL=1 S X=$P(DIKZ(0),U,2) < I X'="" D 21^IBCU2 < S X=$P(DIKZ(0),U,3) < I X'="" D 31^IBCU2 < S X=$P(DIKZ(0),U,4) < I X'="" S DGXRF=1 D TC^IBCU2 K DGXRF < S X=$P(DIKZ(0),U,5) < I X'="" S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGC < S X=$P(DIKZ(0),U,6) < I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1", < S X=$P(DIKZ(0),U,6) < I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2", < S X=$P(DIKZ(0),U,7) < I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1", < S X=$P(DIKZ(0),U,7) < I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2", < S X=$P(DIKZ(0),U,15) < I X'="" S ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)=" < diff -y --suppress-common-lines ./VADemo/r1/IBXX21.m ./VADemo/r2/r/IBXX21.m IBXX21 ; COMPILED XREF FOR FILE #399.043 ; 02/04/05 | IBXX21 ; COMPILED XREF FOR FILE #399.044 ; 09/27/02 A S DA=$O(^DGCR(399,DA(1),"OP",DA)) I DA'>0 S DA=0 G EN | A S DA=$O(^DGCR(399,DA(1),"D1",DA)) I DA'>0 S DA=0 G EN S DIKZ(0)=$G(^DGCR(399,DA(1),"OP",DA,0)) | S DIKZ(0)=$G(^DGCR(399,DA(1),"D1",DA,0)) I X'="" S ^DGCR(399,"AOPV",$P(^DGCR(399,DA(1),0),U,2) | I X'="" S ^DGCR(399,DA(1),"D1","B",$E(X,1,30),DA)="" S X=$P(DIKZ(0),U,1) < I X'="" S DGRVRCAL=1 < diff -y --suppress-common-lines ./VADemo/r1/IBXX22.m ./VADemo/r2/r/IBXX22.m IBXX22 ; COMPILED XREF FOR FILE #399.044 ; 02/04/05 | IBXX22 ; COMPILED XREF FOR FILE #399.045 ; 09/27/02 A S DA=$O(^DGCR(399,DA(1),"D1",DA)) I DA'>0 S DA=0 G EN | A S DA=$O(^DGCR(399,DA(1),"D2",DA)) I DA'>0 S DA=0 G EN S DIKZ(0)=$G(^DGCR(399,DA(1),"D1",DA,0)) | S DIKZ(0)=$G(^DGCR(399,DA(1),"D2",DA,0)) I X'="" S ^DGCR(399,DA(1),"D1","B",$E(X,1,30),DA)="" | I X'="" S ^DGCR(399,DA(1),"D2","B",$E(X,1,30),DA)="" diff -y --suppress-common-lines ./VADemo/r1/IBXX23.m ./VADemo/r2/r/IBXX23.m IBXX23 ; COMPILED XREF FOR FILE #399.045 ; 02/04/05 | IBXX23 ; COMPILED XREF FOR FILE #399.046 ; 09/27/02 A S DA=$O(^DGCR(399,DA(1),"D2",DA)) I DA'>0 S DA=0 G EN | A S DA=$O(^DGCR(399,DA(1),"R",DA)) I DA'>0 S DA=0 G END S DIKZ(0)=$G(^DGCR(399,DA(1),"D2",DA,0)) | S DIKZ(0)=$G(^DGCR(399,DA(1),"R",DA,0)) I X'="" S ^DGCR(399,DA(1),"D2","B",$E(X,1,30),DA)="" | I X'="" S ^DGCR(399,DA(1),"R","B",$E(X,1,30),DA)="" > S X=$P(DIKZ(0),U,4) > I X'="" S ^DGCR(399,DA(1),"R","AC",$E(X,1,30),DA)="" diff -y --suppress-common-lines ./VADemo/r1/IBXX24.m ./VADemo/r2/r/IBXX24.m IBXX24 ; COMPILED XREF FOR FILE #399.046 ; 02/04/05 | IBXX24 ; COMPILED XREF FOR FILE #399.047 ; 09/27/02 A S DA=$O(^DGCR(399,DA(1),"R",DA)) I DA'>0 S DA=0 G END | A S DA=$O(^DGCR(399,DA(1),"CV",DA)) I DA'>0 S DA=0 G EN S DIKZ(0)=$G(^DGCR(399,DA(1),"R",DA,0)) | S DIKZ(0)=$G(^DGCR(399,DA(1),"CV",DA,0)) I X'="" S ^DGCR(399,DA(1),"R","B",$E(X,1,30),DA)="" | I X'="" S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)="" S X=$P(DIKZ(0),U,4) < I X'="" S ^DGCR(399,DA(1),"R","AC",$E(X,1,30),DA)="" < diff -y --suppress-common-lines ./VADemo/r1/IBXX25.m ./VADemo/r2/r/IBXX25.m IBXX25 ; COMPILED XREF FOR FILE #399.047 ; 02/04/05 | IBXX25 ; COMPILED XREF FOR FILE #399.30416 ; 09/27/02 S DA=0 | S DA(2)=DA(1) S DA(1)=0 S DA=0 I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 | I $D(DISET) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G( 0 ; | A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S A S DA=$O(^DGCR(399,DA(1),"CV",DA)) I DA'>0 S DA=0 G EN < S DIKZ(0)=$G(^DGCR(399,DA(1),"CV",DA,0)) | B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 > 2 ; > S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0)) I X'="" S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)="" | I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1 G:'$D(DIKLM) A Q:$D(DISET) | S X=$P(DIKZ(0),U,2) END G ^IBXX26 | I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1 > G:'$D(DIKLM) B Q:$D(DISET) > END Q Only in ./VADemo/r1/: IBXX26.m Only in ./VADemo/r1/: IBXX27.m diff -y --suppress-common-lines ./VADemo/r1/IBXX2.m ./VADemo/r2/r/IBXX2.m IBXX2 ; COMPILED XREF FOR FILE #399 ; 02/04/05 | IBXX2 ; COMPILED XREF FOR FILE #399 ; 09/27/02 S DIKZ(0)=$G(^DGCR(399,DA,0)) < S X=$P(DIKZ(0),U,1) < I X'="" K ^DGCR(399,"B",$E(X,1,30),DA) < CR1 S DIXR=139 < K X < S DIKZ("M")=$G(^DGCR(399,DA,"M")) < D < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5),X2(6) < CR2 S DIXR=477 | CR2 K X K X < S DIKZ("M")=$G(^DGCR(399,DA,"M")) < S X(1)=$P(DIKZ("M"),U,1) < S X(2)=$P(DIKZ("M"),U,2) < S X(3)=$P(DIKZ("M"),U,3) < S DIKZ(0)=$G(^DGCR(399,DA,0)) < S X(4)=$P(DIKZ(0),U,2) < S X=$G(X(1)) < D < . K X1,X2 M X1=X,X2=X < . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))="" < . N G I $G(X(4)) F G=1,2,3 I $G(X(G)) K ^DGCR(399,"AE < CR3 K X < diff -y --suppress-common-lines ./VADemo/r1/IBXX3.m ./VADemo/r2/r/IBXX3.m IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 02/04/05 | IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 09/27/02 S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0)) < diff -y --suppress-common-lines ./VADemo/r1/IBXX4.m ./VADemo/r2/r/IBXX4.m IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 02/04/05 | IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 09/27/02 S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0)) < S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0)) < diff -y --suppress-common-lines ./VADemo/r1/IBXX5.m ./VADemo/r2/r/IBXX5.m IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 02/04/05 | IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 09/27/02 diff -y --suppress-common-lines ./VADemo/r1/IBXX6.m ./VADemo/r2/r/IBXX6.m IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 02/04/05 | IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 09/27/02 S DIKZ(0)=$G(^DGCR(399,DA(1),"RC",DA,0)) < S DIKZ(0)=$G(^DGCR(399,DA(1),"RC",DA,0)) < . S:$D(DIKIL) (X2,X2(1),X2(2))="" < diff -y --suppress-common-lines ./VADemo/r1/IBXX7.m ./VADemo/r2/r/IBXX7.m IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 02/04/05 | IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 09/27/02 diff -y --suppress-common-lines ./VADemo/r1/IBXX8.m ./VADemo/r2/r/IBXX8.m IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 02/04/05 | IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 09/27/02 diff -y --suppress-common-lines ./VADemo/r1/IBXX9.m ./VADemo/r2/r/IBXX9.m IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 02/04/05 | IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 09/27/02 diff -y --suppress-common-lines ./VADemo/r1/IBXX.m ./VADemo/r2/r/IBXX.m IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 02/04/05 | IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 09/27/02 I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=D | I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=D I $D(DIKST) D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET | I $D(DIKST) D:DIKZ1=DH(1) ^IBXX13 D:DIKZ1'=DH(1) SET S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU= | S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU= I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBX | I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBX I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX12 Q | I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX12 Q I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX13 Q < I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX17 Q | I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX16 Q I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX18,A1^IB | I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX17,A1^IB I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX19 Q | I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX18 Q I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX20 Q | I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX19 Q I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q | I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX20 Q I DIKZ1=399.044,DIKUM'<1 S DIKM1=1 D A1^IBXX22 Q | I DIKZ1=399.044,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q I DIKZ1=399.045,DIKUM'<1 S DIKM1=1 D A1^IBXX23 Q | I DIKZ1=399.045,DIKUM'<1 S DIKM1=1 D A1^IBXX22 Q I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX24 Q | I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX23 Q I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX25 Q | I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX24 Q I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX26 Q | I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX25 Q I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX27 Q < Only in ./VADemo/r1/: IBY221P.m Only in ./VADemo/r1/: IBY254PO.m Only in ./VADemo/r1/: IBY280PO.m Only in ./VADemo/r1/: IBY280PR.m Only in ./VADemo/r1/: IBYPSA1.m Only in ./VADemo/r1/: IBYPSA2.m Only in ./VADemo/r1/: IBYPSA.m Only in ./VADemo/r1/: ICD0IDX.m Only in ./VADemo/r2/r/: ICD14ENV.m Only in ./VADemo/r2/r/: ICD1595A.m Only in ./VADemo/r2/r/: ICD1596A.m Only in ./VADemo/r2/r/: ICD15P95.m Only in ./VADemo/r2/r/: ICD15P96.m Only in ./VADemo/r2/r/: ICD15PR.m Only in ./VADemo/r2/r/: ICD15PT.m Only in ./VADemo/r2/r/: ICD1697A.m Only in ./VADemo/r2/r/: ICD16P97.m Only in ./VADemo/r2/r/: ICD16PR.m Only in ./VADemo/r2/r/: ICD16PT.m Only in ./VADemo/r1/: ICD1812.m Only in ./VADemo/r1/: ICD187PT.m Only in ./VADemo/r1/: ICD9IDX.m Only in ./VADemo/r1/: ICDAPIU.m Only in ./VADemo/r1/: ICDCODE.m diff -y --suppress-common-lines ./VADemo/r1/ICDCOD.m ./VADemo/r2/r/ICDCOD.m ICDCOD ;ALB/ABR/ADL - INQUIRE TO ICD CODES ; 10/23/00 11:36a | ICDCOD ;ALB/ABR - INQUIRE TO ICD CODES ; 10/23/00 11:36am ;;18.0;DRG Grouper;**7**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 ;;ADL;Update for CSV project - 03/20/03 < N DIRUT,DTOUT,DUOUT,DIR,DIC,DA,DR,DIQ,X,Y,ICDTMP | N DIRUT,DTOUT,DUOUT,DIR,DIC,DA,DR,DIQ,X,Y DATE D EFFDATE^ICDDRGM G EXIT:$D(DUOUT),EXIT:$D(DTOUT) < G DATE | Q . S DR=".01;3;10;100;102" | .S DIC="^ICD9(",DA=+Y,DR=".01;3;10;100;102",DIQ(0)="E . S DIC="^ICD9(",DA=+Y,DIQ(0)="EN",DIQ="ICDASK" | .D EN^DIQ1 . D EN^DIQ1 | .W !!,ICDASK(80,DA,.01,"E"),?15,ICDASK(80,DA,3,"E"),! . S ICDTMP=$$ICDDX^ICDCODE(+DA,ICDDATE) | .I $D(ICDASK(80,DA,102))!$D(ICDASK(80,DA,100)) W " . W !!,ICDASK(80,DA,.01,"E"),?15,ICDASK(80,DA,3,"E"), < . I '$P(ICDTMP,U,10) W " **CODE INACTIVE" I $P(ICDT < . N ICDASK | .N ICDASK . S DIC="^ICD0(",DA=+Y,DR=".01;4;10;100;102",DIQ(0)=" | .S DIC="^ICD0(",DA=+Y,DR=".01;4;10;100;102",DIQ(0)="E . D EN^DIQ1 | .D EN^DIQ1 . S ICDTMP=$$ICDOP^ICDCODE(+DA,ICDDATE) | .W !!,ICDASK(80.1,DA,.01,"E"),?15,ICDASK(80.1,DA,4,"E . W !!,ICDASK(80.1,DA,.01,"E"),?15,ICDASK(80.1,DA,4," | .I $D(ICDASK(80.1,DA,102))!$D(ICDASK(80.1,DA,100)) W . I '$P(ICDTMP,U,10) W " **CODE INACTIVE" I $P(ICDT < EXIT Q ;Exit subroutine < diff -y --suppress-common-lines ./VADemo/r1/ICDDRG0.m ./VADemo/r2/r/ICDDRG0.m ICDDRG0 ;ALB/GRR/EG/ADL - DRG GROUPER PROCESSING BEGINS ; 12/ | ICDDRG0 ;ALB/GRR/EG - DRG GROUPER PROCESSING BEGINS ; 9/21/01 ;;18.0;DRG Grouper;**1,2,7,10,14**;Oct 20, 2000 | ;;18.0;DRG Grouper;**1,2**;Oct 20, 2000 . I 'ICDRG S ICDRG=470,ICDRTC=8 | . S ICDRG=470,ICDRTC=8 D ^ICDDRG1:ICDMDC=1,^ICDDRG2:ICDMDC=2,^ICDDRG3:ICDMDC | D ^ICDDRG2:ICDMDC=2,^ICDDRG3:ICDMDC=3,^ICDDRG5:ICDMDC DODRG ;Go to DRG file and retrieve table entry to use if de | DODRG I $D(^ICD(ICDRG,"MC1")),^("MC1")'="" S ICDREF="DRG"_I N DRGFY,ICDREF S (DRGFY,ICDREF)="" < I ICDRG S DRGFY=$O(^ICD(ICDRG,2,"B",+$G(ICDDATE)_.01) < I 'DRGFY S DRGFY=3041001 ;default to current fiscal y < S ICDREF=$O(^ICD(+ICDRG,2,"B",+DRGFY,ICDREF)) < I ICDREF'="" D < . S ICDREF=$P($G(^ICD(+ICDRG,2,ICDREF,0)),U,3) < . S ICDREF="DRG"_ICDRG_"^"_ICDREF D @ICDREF K ICDREF < I $D(ICDOP(" 33.6"))!$D(ICDOP(" 37.5"))!(ICDDATE>3030 | I $D(ICDOP(" 33.6"))!$D(ICDOP(" 37.5")) S ICDRG=103,I S ICDTMP=$$DRG^ICDGTDRG(ICDDRG,ICDDATE) I '$P(ICDTMP, < I ICDPD["AI"!(ICDSD["AI") D Q | I ICDPD["AI"!(ICDSD["AI") S ICDRG=$S($S($D(ICDEXP):IC . I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICD < . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):123,ICDPD["V"! < I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP < diff -y --suppress-common-lines ./VADemo/r1/ICDDRG14.m ./VADemo/r2/r/ICDDRG14.m ICDDRG14 ;ALB/GRR - FIX SURGERY HIERARCHY ; 9/29/04 3: | ICDDRG14 ;ALB/GRR - FIX SURGERY HIERARCHY ; 10/23/00 1 ;;18.0;DRG Grouper;**14**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 POST N DRGFY,ICDREF | POST I ICDPD["d" S ICDRG=$S(ICDOR["O":377,1:376) Q S (DRGFY,ICDREF)="" < I ICDPD["d" S ICDRG=$S(ICDOR["O":377,1:376) Q < S DRGFY=$O(^ICD(ICDRG,2,"B",+ICDDATE),-1) | I $D(^ICD(ICDRG,"MC1")),^("MC1")'="" S ICDREF="DRG"_I S ICDREF=$O(^ICD(ICDRG,2,"B",$S($G(DRGFY):DRGFY,1:304 < S ICDREF=$P($G(^ICD(ICDRG,2,+ICDREF,0)),U,3) < I ICDREF'="" S ICDREF="DRG"_ICDRG_"^"_ICDREF D @ICDRE < Only in ./VADemo/r1/: ICDDRG17.m Only in ./VADemo/r1/: ICDDRG1.m diff -y --suppress-common-lines ./VADemo/r1/ICDDRG5.m ./VADemo/r2/r/ICDDRG5.m ICDDRG5 ;ALB/GRR/EG/MRY/ADL - FIX SURGERY HIERARCHY ; 3/20/03 | ICDDRG5 ;ALB/GRR/EG/MRY - FIX SURGERY HIERARCHY ; 10/31/02 10 ;;18.0;DRG Grouper;**2,5,7,10**;Oct 20, 2000 | ;;18.0;DRG Grouper;**2,5**;Oct 20, 2000 I ICDJ=535 S ICDJ(4)=ICDJ Q | I ICDJ=514 S ICDJ(4)=ICDJ Q I ICDJ=536 S ICDJ(5)=ICDJ Q | I ICDJ=515 S ICDJ(5)=ICDJ Q I ICDJ=515 S ICDJ(6)=ICDJ Q | I ICDJ=108 S ICDJ(6)=ICDJ Q I ICDJ=108 S ICDJ(7)=ICDJ Q | I ICDJ=106 S ICDJ(7)=ICDJ Q I ICDJ=106 S ICDJ(8)=ICDJ Q | I ICDJ=110 S ICDJ(8)=ICDJ Q I ICDJ=110 S ICDJ(9)=ICDJ Q | I ICDJ=111 S ICDJ(9)=ICDJ Q I ICDJ=111 S ICDJ(10)=ICDJ Q | I ICDJ=113 S ICDJ(10)=ICDJ Q I ICDJ=113 S ICDJ(11)=ICDJ Q | I ICDJ=115 S ICDJ(11)=ICDJ Q I ICDJ=115 S ICDJ(12)=ICDJ Q | I ICDJ=116 S ICDJ(12)=ICDJ Q I ICDJ=116 S ICDJ(13)=ICDJ Q | I ICDJ=526 S ICDJ(13)=ICDJ Q I ICDJ=526 S ICDJ(14)=ICDJ Q | I ICDJ=527 S ICDJ(14)=ICDJ Q I ICDJ=527 S ICDJ(15)=ICDJ Q | I ICDJ=516 S ICDJ(15)=ICDJ Q I ICDJ=516 S ICDJ(16)=ICDJ Q | I ICDJ=517 S ICDJ(16)=ICDJ Q I ICDJ=517 S ICDJ(17)=ICDJ Q | I ICDJ=518 S ICDJ(17)=ICDJ Q I ICDJ=518 S ICDJ(18)=ICDJ Q | I ICDJ=478 S ICDJ(18)=ICDJ Q I ICDJ=478 S ICDJ(19)=ICDJ Q | I ICDJ=479 S ICDJ(19)=ICDJ Q I ICDJ=479 S ICDJ(20)=ICDJ Q < I ICDJ=114 S ICDJ(21)=ICDJ Q | I ICDJ=114 S ICDJ(20)=ICDJ Q I ICDJ=118 S ICDJ(22)=ICDJ Q | I ICDJ=118 S ICDJ(21)=ICDJ Q I ICDJ=117 S ICDJ(23)=ICDJ Q | I ICDJ=117 S ICDJ(22)=ICDJ Q I ICDJ=119 S ICDJ(24)=ICDJ Q | I ICDJ=119 S ICDJ(23)=ICDJ Q I ICDJ=120 S ICDJ(25)=ICDJ | I ICDJ=120 S ICDJ(24)=ICDJ EN1 S (ICDCC3,ICDCC2)=0 | EN1 S ICDCC3=0 I $D(ICDOP(" 00.50")) S ICDCC3=1 < I $D(ICDOP(" 00.52")) I $D(ICDOP(" 00.53")) S ICDCC3= < I $D(ICDOP(" 00.54"))!$D(ICDOP(" 37.95"))!$D(ICDOP(" < N ICDTMP | S (ICDCATH,ICDAJ)="" F ICDI=1:1 Q:'$D(ICDPRC(ICDI)) S (ICDCATH,ICDAJ)="" F ICDI=1:1 Q:'$D(ICDPRC(ICDI)) < . S ICDOP($P(ICDY(0),"^",1))="",ICDCATH=ICDCATH_$P(IC < diff -y --suppress-common-lines ./VADemo/r1/ICDDRG8.m ./VADemo/r2/r/ICDDRG8.m ;;18.0;DRG Grouper;**1,2,10**;Oct 20, 2000 | ;;18.0;DRG Grouper;**1,2**;Oct 20, 2000 I ICDJ=537 S ICDJ(15)=ICDJ Q | I ICDJ=230 S ICDJ(15)=ICDJ Q I ICDJ=230 S ICDJ(16)=ICDJ Q | I ICDJ=226 S ICDJ(16)=ICDJ Q I ICDJ=226 S ICDJ(17)=ICDJ Q | I ICDJ=227 S ICDJ(17)=ICDJ Q I ICDJ=227 S ICDJ(18)=ICDJ Q | I ICDJ=225 S ICDJ(18)=ICDJ Q I ICDJ=225 S ICDJ(19)=ICDJ Q | I ICDJ=228 S ICDJ(19)=ICDJ Q I ICDJ=228 S ICDJ(20)=ICDJ Q | I ICDJ=223 S ICDJ(20)=ICDJ Q I ICDJ=223 S ICDJ(21)=ICDJ Q | I ICDJ=232 S ICDJ(21)=ICDJ Q I ICDJ=232 S ICDJ(22)=ICDJ Q | I ICDJ=224 S ICDJ(22)=ICDJ Q I ICDJ=224 S ICDJ(23)=ICDJ Q | I ICDJ=229 S ICDJ(23)=ICDJ Q I ICDJ=229 S ICDJ(24)=ICDJ Q | I ICDJ=233 S ICDJ(24)=ICDJ Q I ICDJ=233 S ICDJ(25)=ICDJ Q < diff -y --suppress-common-lines ./VADemo/r1/ICDDRG.m ./VADemo/r2/r/ICDDRG.m ICDDRG ;ALB/GRR/EG/ADL - ASSIGNS DRG CODES ; 11/18/04 10:47a | ICDDRG ;ALB/GRR/EG - ASSIGNS DRG CODES ; 7/20/01 2:34pm ;;18.0;DRG Grouper;**2,7,10,14**;Oct 20, 2000 | ;;18.0;DRG Grouper;**2**;Oct 20, 2000 ;ADL - UPDATED FOR CSV;3/10/03 < I '$D(ICDDATE) S ICDDATE=DT ;default is today's File < S ICDTMP=$$ICDDX^ICDCODE(ICDDX(1),ICDDATE) | I '$D(^ICD9(ICDDX(1),0)) S ICDRTC=1 G ERR I ICDTMP<0 S ICDRTC=1 G ERR | S ICDY(0)=^ICD9(ICDDX(1),0) I $P(ICDY(0),"^",4)=1!($P S ICDY(0)=$P(ICDTMP,U,2,99) I $P(ICDY(0),"^",4)=1!($P < ;I $D(^ICD9(ICDDX(1),"DRG")) S ICDPDRG=^("DRG") F ICD | I $D(^ICD9(ICDDX(1),"DRG")) S ICDPDRG=^("DRG") F ICDI ;Setup DRG arrays ICDPDRG(x) and ICDDRG(x) and SEX ar < S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(1),ICDDATE,9) I ICDT < . F ICDI=1:1 Q:$P(ICDPDRG,"^",ICDI)']"" S ICDPDRG($P < . S ICDTMP=$$ICDDX^ICDCODE(ICDDX(ICDI),ICDDATE) I ICD | . I '$D(^ICD9(ICDDX(ICDI),0)) S ICDRTC=8 Q . S ICDY(0)=$P(ICDTMP,U,2,99),ICDDXT($P(ICDY(0),"^",1 | . S ICDY(0)=^ICD9(ICDDX(ICDI),0),ICDDXT($P(ICDY(0),"^ N ICDOTMP S (ICDMAJ,ICDORNI,ICDOP,ICDOR,ICDOTMP)="",( | S (ICDMAJ,ICDORNI,ICDOP,ICDOR)="",(ICDOCNT,ICDONR,ICD ;Return ICD Operation/Procedure code info check if ac | I $D(ICDPRC) F ICDI=1:1 Q:'$D(ICDPRC(ICDI)) X "I '$D I $D(ICDPRC) F ICDI=1:1 Q:'$D(ICDPRC(ICDI)) X "S ICD < . S ICDY(0)=$P(ICDTMP,U,2,99),ICDNOR=ICDNOR+1,ICDY=IC < ;Group ICD identifiers in one variable < S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(ICDI),ICDDATE,9) | I (($P(ICDY(0),"^",7)=1)!(ICDPD["h")!(ICDPD["J")!(ICD ;If any of the following conditions are met set ICDSD | . S ICDSDRG=^ICD9(ICDDX(ICDI),"DRG") I (($P(ICDY(0),"^",7)=1)!(ICDPD["h")!(ICDPD["J")!(ICD < . S ICDSDRG=$P(ICDTMP,";") < ;Set ICDOTMP with DRGs for doing checks < S ICDOTMP=$P($$GETDRG^ICDGTDRG(ICDY,ICDDATE,0),";",1) < ..I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT("ICD | ..I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT("ICD I +ICDOTMP>0 S ICDF=ICDOTMP F ICDFX=1:1 Q:$P(ICDF,"^" | I $D(^ICD0(ICDY,"MDC",ICDMDC,"DRG")) S ICDF=^("DRG") S ICD104=$S($P(ICDY(0),"^",2)["P":1,1:0),ICDNMDC($S($ | S ICD104=$S($P(ICDY(0),"^",2)["P":1,1:0),ICDNMDC($S($ Q ;ERR < N X,Y,I,N,DRG,MDC,ICDTMP | N X,Y,I,N,DRG,MDC S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(1),ICDDATE,9) Q:'$P( | S Y=$G(^ICD9(ICDDX(1),"DRG")) Q:+Y=0 S Y=$P(ICDTMP,";") < .S MDC=$P($$DRG^ICDGTDRG(DRG,ICDDATE),"^",5) Q:MDC="" | .S MDC=$P(^ICD(DRG,0),"^",5) Q:MDC="" N I,MD,BOOL,DRGFY | N I,MD,BOOL . S DRGFY=$O(^ICD0(CODE,2,"B",+ICDDATE),-1),DADRGFY=$ | .I $D(^ICD0(ICDY,"MDC",MD,PAR)) S BOOL(1)="" .I $D(MDC) S BOOL(1)="" < K ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNS | K ICD,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDOR diff -y --suppress-common-lines ./VADemo/r1/ICDDRGM.m ./VADemo/r2/r/ICDDRGM.m ICDDRGM ;ALB/GRR/EG/ADL - GROUPER DRIVER ; 10/23/00 11:45am | ICDDRGM ;ALB/GRR/EG - GROUPER DRIVER ; 10/23/00 11:45am ;;18.0;DRG Grouper;**7**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 ;;ADL;Add Date prompt and passing of effective date f < ;;ADL;Update DIC("S") code to screen using new functi < ;;ADL;Update to access DRG file using new API for CSV < D EFFDATE G KILL:$D(DUOUT),OUT:$D(DTOUT) < CD K DIC S CC=0,DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A")="En | CD K DIC S CC=0,DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A")="En . S DIC("S")="I '$P($$ICDDX^ICDCODE(+Y,ICDDATE),U,5), | F ICDNSD=2:1 S DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A")=" F ICDNSD=2:1 S DIC="^ICD9(",DIC(0)="AEQMZ",DIC("A")=" < OP S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,ICDDATE,0)" K ICD | OP S DIC("S")="I '$P(^ICD0(+Y,0),U,9)" K ICDPRC D ^ICDDRG S:ICDDRG=470 ICDRTC=470 K ICDEXP,SEX,ICDDX | D ^ICDDRG S:'$D(^ICD(+ICDDRG,0)) (ICDRTC,ICDDRG)=470 WRT S ICDDRG(0)=$$DRG^ICDGTDRG(+ICDDRG,ICDDATE) ; new C | WRT S ICDDRG(0)=^ICD(ICDDRG,0) W !!?9,"Effective Date: "," ",ICDDSP | W !!,"Diagnosis Related Group: ",$J(ICDDRG,6),?40,"Av W !,"Diagnosis Related Group: ",$J(ICDDRG,6),?40,"Avg < K ICDMAJ,ICDS25,ICDSEX,AGE,DOB,CC,HICDRG,ICD,ICDCC3,I | K ICDMAJ,ICDS25,ICDSEX,AGE,DOB,CC,HICDRG,ICD,ICDCC3,I EFFDATE ;prompts for effective date for DRG grouper? < K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="E < S DIR("?")="The effective to be used when calculating < D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q < S ICDDATE=Y,ICDDSP=Y(0) < Q < diff -y --suppress-common-lines ./VADemo/r1/ICDDRGX.m ./VADemo/r2/r/ICDDRGX.m ICDDRGX ;ALB/EG/MRY/ADL - GROUPER PROCESS ; 11/3/04 11:26am | ICDDRGX ;ALB/EG/MRY - GROUPER PROCESS ; 11/6/02 11:59am ;;18.0;DRG Grouper;**1,2,5,7,10,14**;Oct 20, 2000 | ;;18.0;DRG Grouper;**1,2,5**;Oct 20, 2000 ;use FY logic to resolve DRG if no FY defined user cu | S ICDRG=$S($D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!( N ICDDXFY S ICDDXFY="" < I ICDDATE>3040930.01 D Q:ICDRG=541!(ICDRG=542) ;Use < .S ICDRG=$S($D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))! < .I ICDRG=541&(($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE)," < I ICDDATE<3041001.01 D Q:ICDRG=483 ;Use DRG FY 04 l < .S ICDRG=$S($D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))! < S ICDRG=$S(ICDOR["q":103,1:ICDRG) I ICDRG=103 S ICDRT < S ICDRG=$S(ICDOR["t"&($P($$ICDDX^ICDCODE(ICDDX(1),ICD | S ICDRG=$S(ICDOR["t"&($P(^ICD9(ICDDX(1),0),"^",2)["Y" Only in ./VADemo/r1/: ICDGTDRG.m diff -y --suppress-common-lines ./VADemo/r1/ICDHLPD.m ./VADemo/r2/r/ICDHLPD.m ICDHLPD ;ALB/GRR/EG - HELP DISPLAY DIAGNOSIS IDENTIFIERS ; 9/ | ICDHLPD ;ALB/GRR/EG - HELP DISPLAY DIAGNOSIS IDENTIFIERS ; 10 ;;18.0;DRG Grouper;**10,14**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 W !,"A=Cardio",?20,"M=Musculoskeletal",?50,"B=Spine" | W !,"A=Cardio",?20,"M=Musculoskeletal" ;;K=Intracranial Hemorrhage < ;;Q=Acute CNS DX < ;;W=Severe Sepsis < ;;Z=2ndry HF (2ndry dx of heart failure) < diff -y --suppress-common-lines ./VADemo/r1/ICDHLPO.m ./VADemo/r2/r/ICDHLPO.m ICDHLPO ;ALB/GRR/EG-HELP DISPLAY FOR OPERATION IDENTIFIERS ; | ICDHLPO ;ALB/GRR/EG-HELP DISPLAY FOR OPERATION IDENTIFIERS ; ;;18.0;DRG Grouper;**10,14**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 ;;K=Intracranial Vascular < ;;S=Ventricular Shunt < ;;q=Heart Transplant < ;;V=Ventilator < ;;C=Chemo inplant < ;;Q=Craniotomy < ;;I=injectable/infusion (injection or infusion of dru < Only in ./VADemo/r1/: ICDID.m Only in ./VADemo/r2/r/: ICDNTEG.m Only in ./VADemo/r1/: ICDREF.m Only in ./VADemo/r1/: ICDSUPT.m Only in ./VADemo/r1/: ICDTLB1A.m diff -y --suppress-common-lines ./VADemo/r1/ICDTLB1.m ./VADemo/r2/r/ICDTLB1.m ICDTLB1 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/29/03 11:47am | ICDTLB1 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:47a ;;18.0;DRG Grouper;**10**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 DRG1 D DRG528 D:ICDRG'=528 DRG529 | DRG1 S ICDRG=$S(AGE<18:3,ICDPD["T":2,1:1) I AGE="" S ICDRT S ICDRG=$S(AGE<18:3,ICDRG=528:528,ICDRG=529:529,ICDRG < DRG2 D DRG1 | DRG2 S ICDRG=$S(AGE<18:3,ICDPD["T":2,1:1) I AGE="" S ICDRT DRG3 D DRG1 | DRG3 S ICDRG=$S(AGE<18:3,ICDPD["T":2,1:1) I AGE="" S ICDRT DRG528 S ICDRG=$S((ICDPD["K")&(ICDOR["K"):528,1:ICDRG) Q < DRG529 S ICDRG=$S((ICDOR["S")&(ICDCC):529,(ICDOR["S")&('ICDC < DRG530 D DRG529 Q < Only in ./VADemo/r1/: ICDTLB2A.m diff -y --suppress-common-lines ./VADemo/r1/ICDTLB2.m ./VADemo/r2/r/ICDTLB2.m ICDTLB2 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/19/03 1:09pm | ICDTLB2 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/19/01 1:09pm ;;18.0;DRG Grouper;**2,10**;Oct 20, 2000 | ;;18.0;DRG Grouper;**2**;Oct 20, 2000 .;I ICDOR'["b" D DRG516^ICDTLB6 I +ICDRG>0 Q | .I ICDOR'["b" D DRG516^ICDTLB6 I +ICDRG>0 Q D DRG113 I ICDRG=113 Q | I ICDOR["1" D DRG112 I ICDOR["1" D DRG516^ICDTLB6 < DRG113 S ICDRG=$S($D(ICDJJ(113)):113,1:ICDRG) Q | DRG115 D EN1^ICDDRG5 S ICDRG=$S(ICDPD["A"&(ICDCC3=1):115,ICD DRG115 D EN1^ICDDRG5 S ICDRG=$S(ICDPD["A"&(ICDCC3=1):115,ICD < Only in ./VADemo/r1/: ICDTLB3A.m diff -y --suppress-common-lines ./VADemo/r1/ICDTLB3.m ./VADemo/r2/r/ICDTLB3.m ICDTLB3 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/29/04 3:38pm | ICDTLB3 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:48a ;;18.0;DRG Grouper;**14**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 S ICDREF=$$RTABLE^ICDREF(+ICDRG,+ICDDATE) | I ICDRG["^"&($D(^ICD(+ICDRG,"MC1"))) X ("D DRG"_+ICDR I ICDRG["^"&($D(ICDREF)) X "D DRG"_+ICDRG_"^"_^ICDREF < Only in ./VADemo/r1/: ICDTLB4A.m Only in ./VADemo/r1/: ICDTLB5A.m diff -y --suppress-common-lines ./VADemo/r1/ICDTLB5.m ./VADemo/r2/r/ICDTLB5.m ICDTLB5 ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS ; 10/23/00 11 | ICDTLB5 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:49a ;;18.0;DRG Grouper;**7**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003 < .F I=1:1 Q:'$D(ICDDX(I)) S ICDRG=$S($P($$ICDDX^ICDCO | .F I=1:1 Q:'$D(ICDDX(I)) S ICDRG=$S($P(^ICD9(ICDDX(I diff -y --suppress-common-lines ./VADemo/r1/ICDTLB61.m ./VADemo/r2/r/ICDTLB61.m ICDTLB61 ;SSI/ALA-GROUPER UTILITY FUNCTIONS [ 10/9/03 | ICDTLB61 ;SSI/ALA-GROUPER UTILITY FUNCTIONS [ 04/02/97 ;;18.0;DRG Grouper;**10**;Oct 20, 2000 | ;;18.0;DRG Grouper;;Oct 20, 2000 I ICDPD["L" D DRG539^ICDTLB6 Q | I ICDPD["L" D DRG400^ICDTLB5 Q Only in ./VADemo/r1/: ICDTLB6A.m diff -y --suppress-common-lines ./VADemo/r1/ICDTLB6.m ./VADemo/r2/r/ICDTLB6.m ICDTLB6 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 9/29/03 2:4 | ICDTLB6 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 11/12/02 2: ;;18.0;DRG Grouper;**2,5,10**;Oct 20, 2000 | ;;18.0;DRG Grouper;**2,5**;Oct 20, 2000 .S ICDRG=$S((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICD | .S ICDRG=$S(ICDPD["L":400,ICDCC:406,1:407) DRG514 ; Replaced with DRG535 | DRG514 N ICDE1,ICDE2 N ICDE1,ICDE2 < DRG515 D DRG535 Q | DRG515 D DRG514 Q DRG531 S ICDRG=$S(ICDCC:531,1:532) Q < DRG532 D DRG531 Q < DRG533 S ICDRG=$S(ICDCC:533,1:534) Q < DRG534 D DRG533 Q < DRG535 N ICDE1,ICDE2,ICDE3 < S ICDE1=$S($D(ICDOP(" 37.95"))&(($D(ICDOP(" 37.96"))) < S ICDE2=$S($D(ICDOP(" 37.97"))&(($D(ICDOP(" 37.98"))) < S ICDE3=$S($D(ICDOP(" 00.52"))&($D(ICDOP(" 00.54"))): < ;S ICDE4=$S($D(ICDOP(" 00.54"))&($D(ICDOP(" 37.95"))) < S ICDRG=470 < I $D(ICDOP(" 37.94"))!$D(ICDOP(" 00.51")) I ICDE1+ICD < I '$D(ICDOP(" 37.94"))&('$D(ICDOP(" 00.51"))) I ICDE1 < ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, < I ICDRG=515 I ICDOR["HN" S ICDRG=$S(ICDPD["A":535,1:5 < I ICDRG=470 D DRG115^ICDTLB2 < DRG536 D DRG535 Q < DRG537 S ICDRG=$S(ICDCC:537,1:538) Q < DRG538 D DRG537 Q < DRG539 I ICDPD["L"&(ICDMAJ'[3) D DRG401^ICDTLB5 Q:"401^402^4 < S ICDRG=$S((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDC < DRG540 D DRG539 Q < Only in ./VADemo/r1/: ICDUPDT.m Only in ./VADemo/r1/: ICPT619.m diff -y --suppress-common-lines ./VADemo/r1/ICPTAPIU.m ./VADemo/r2/r/ICPTAPIU.m ICPTAPIU ;ALB/DEK/KER - CPT UTILITIES FOR APIS ; 04/1 | ICPTAPIU ;ALB/ABR - CPT UTILITIES FOR APIS ; 1/18/02 4 ;;6.0;CPT/HCPCS;**1,6,12,14,16,19**;May 19, 1997 | ;;6.0;CPT/HCPCS;**1,6,12**;May 19, 1997 ; External References | EFF(FILE,CODE,EDT) ; returns effective date and status f ; DBIA 10011 ^DIWP | ; ; DBIA 10029 ^DIWW | ; Input: FILE = file number REQUIRED ; DBIA 10103 $$DT^XLFDT | ; 81 for CPT file ; | ; 81.3 for CPT MODIFIER file CPTDIST() ; Distribution Date | ; CODE = CPT CODE ien or CPT MODIFIER ien R > ; EDT = date to check for (FileMan format) > ; > ; Output: effective date^status > ; where STATUS = 1 = active > ; 0 = inactive > ; -1^error message > ; > ; Variables: EFILE = indirect file reference for cod > ; EFF = effective date > ; EFFN = sub-entry ien > ; STR = output > ; > N EFILE,EFF,EFFN,STR > I '$G(FILE) S STR="-1^NO FILE SELECTED" G EFFQ > I '(FILE=81!(FILE=81.3)) S STR="-1^INVALID FILE" G EF > I '$G(CODE) S STR="-1^NO "_$S(FILE=81:"CODE",1:"MODIF > S FILE=$S(FILE=81:"^ICPT(",1:"^DIC(81.3,") > I $G(EDT)="" S EDT=DT > S EFILE=FILE_CODE_",60," > S EFF=$O(@(EFILE_"""B"","_(EDT+.001)_")"),-1) I 'EFF > S EFFN=$O(@(EFILE_"""B"","_EFF_",0)")) ; node 60 (eff > S STR=$G(@(EFILE_EFFN_",0)")) S:'STR STR="-1^NO DATA" > EFFQ Q STR > ; > CPTDIST() ; DISTRIBUTION DATE Q $P($G(^DIC(81.2,1,0)),"^",2) | Q $P($G(^DIC(81.2,1,0)),U,2) CAT(CAT,DFN) ; Return CATEGORY NAME given IEN | CAT(CAT,DFN) ; return CATEGORY NAME given ien I $P(STR,"^",2)="" S STR="-1^TYPE OF CATEGORY UNSPECI | I $P(STR,U,2)="" S STR="-1^TYPE OF CATEGORY UNSPECIFI S CATN=$P(STR,"^") | S CATN=$P(STR,U) I $P(STR,"^",2)="m" S MCATNM=CATN,MCATIEN=+CAT | I $P(STR,U,2)="m" S MCATNM=CATN,MCATIEN=+CAT I $P(STR,"^",2)="s" D | I $P(STR,U,2)="s" D . S MCATIEN=$P(STR,"^",3) | . S MCATIEN=$P(STR,U,3) . I MCATIEN S MCATNM=$P($G(^DIC(81.1,MCATIEN,0)),"^") | . I MCATIEN S MCATNM=$P($G(^DIC(81.1,MCATIEN,0)),U) S STR=CATN_"^"_$P(STR,"^",6)_"^"_MCATIEN_"^"_MCATNM | S STR=CATN_U_$P(STR,U,6)_U_MCATIEN_U_MCATNM NUM(Y) ; Convert CPT/HCPCS Code to Numeric | NUM(Y) ; convert cpt/hcpcs code to numeric ; Convert HCPCS to $A() of Alpha _ Numeric Portion | ; convert HCPCS to $A() of alpha _ numeric portion COPY ; API to Print Copyright Information | COPY ; api to print copyright information W !!! S DIWL=1,DIWR=80,DIWF="W" | W !!! S DIWL=1,DIWR=80,DIWF="W" F VARR=0:0 S VARR=$O( F VARR=0:0 S VARR=$O(^DIC(81.2,1,1,VARR)) Q:VARR'>0 < ; < STATCHK(CODE,CDT) ; Check Status of CPT Code or Modifie < ; Input: < ; CODE - CPT Code/Modifier REQUIRED < ; CDT - Date to screen against (FileMan format, de < ; < ; Output: < ; 2-Piece String containing the status of the code < ; and the IEN if the code/modifier exists, else -1 < ; The following are possible outputs: < ; 1 ^ IEN Active Code/Modifier < ; 0 ^ IEN Inactive Code/Modifier < ; 0 ^ -1 Code/Modifier not Found < ; < ; This API requires the ACT Cross-Reference < ; ^ICPT("ACT",,,,) < ; ^DIC(81.3,"ACT",,,,) < ; < N ICPTC,ICPTD,ICPTIEN,ICPTA,ICPTI,X,ICPTG,ICPTR,ICPTD < S ICPTC=$G(CODE) Q:'$L(ICPTC) "0^-1" < ; Case 1: Not Valid 0^- < ; Fails Pattern Match for Code < S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:ICPTG="" "0^-1" < ; Case 2: Never Active 0^I < ; No In/Active Date < S ICPTD=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT($G < S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTD),ICPTA=$O(@(ICPTR_" < I '$L(ICPTA) D Q X < . S ICPTA=$O(@(ICPTR_")")),X="0^-1" Q:'$L(ICPTA) < . S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTA) < . S ICPTIEN=$O(@(ICPTR_",0)")) S:+ICPTIEN<1 ICPTIEN=- < . S X="0^"_ICPTIEN < ; Case 3: Active, Never Inactive 1^I < ; Has an Activation Date < ; No Inactivation Date < S ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTD),ICPTI=$O(@(ICPTR_" < I $L(ICPTA),'$L(ICPTI) D Q X < . S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTA),ICPTIEN=$O(@(ICP < . S X=$S(+ICPTIEN=0:"0^-1",1:"1^"_ICPTIEN) < ; Case 4: Active, but later Inactivated 0^I < ; Has an In/Activation Date < I $L(ICPTA),$L(ICPTI),ICPTI>ICPTA,ICPTIICPTA D Q X < . S ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTI),ICPTIEN=$O(@(ICP < . S X=$S(+$O(@(ICPTR_",0)"))=0:"0^-1",1:"1^"_ICPTIEN) < ; Case 6: Fails Time Test 0^- < Q ("0^"_$S(+($G(ICPTIEN))>0:+($G(ICPTIEN)),1:"-1")) < ; < NEXT(CODE) ; Next CPT Code or Modifier (active or inacti < ; Input: < ; CODE = CPT Code/Modifier REQUIRED < ; < ; Output: < ; The Next CPT Code/Modifier, Null if none < ; < N ICPTC,ICPTG < S ICPTC=$G(CODE) Q:'$L(ICPTC) "" < S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:'$L(ICPTG) "" < S ICPTC=$O(@(ICPTG_"""BA"","""_ICPTC_" "")")) < Q $S(ICPTC="":"",1:$E(ICPTC,1,$L(ICPTC)-1)) < ; < PREV(CODE) ; Previous CPT Code or Modifier (active or in < ; Input: < ; CODE = CPT Code/Modifier REQUIRED < ; < ; Output: < ; The Previous CPT Code/Modifier, Null if none < ; < N ICPTC,ICPTG < S ICPTC=$G(CODE) Q:'$L(ICPTC) "" < S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:'$L(ICPTG) "" < S ICPTC=$O(@(ICPTG_"""BA"","""_ICPTC_" "")"),-1) < Q $S(ICPTC="":"",1:$E(ICPTC,1,$L(ICPTC)-1)) < ; < HIST(CODE,ARY) ; Activation History < ; Input: < ; CODE - CPT Code or Modifier REQUIRED < ; .ARY - Array, passed by Reference REQUIRED < ; < ; Output: Mirrors ARY(0) (or, -1 on error) < ; ARY(0) = Number of Activation History Entries < ; ARY() = status where: 1 is Active < ; ARY("IEN") = < ; < Q:$G(CODE)="" -1 < N ICPTC,ICPTI,ICPTN,ICPTD,ICPTG,ICPTF,ICPTO < S ICPTG=$$GBL^ICPTSUPT(CODE) Q:'$L(ICPTG) -1 < S ICPTI=$O(@(ICPTG_"""BA"","""_CODE_" "",0)")) Q:'$L( < S ARY("IEN")=ICPTI,ICPTO="" M ICPTO=@(ICPTG_ICPTI_",6 < K ICPT0("B") S ARY(0)=+($P($G(ICPTO(0)),"^",4)) < S:+ARY(0)=0 ARY(0)=-1 K:ARY(0)=-1 ARY("IEN") < S (ICPTI,ICPTC)=0 F S ICPTI=$O(ICPTO(ICPTI)) Q:+ICPT < . S ICPTD=$P($G(ICPTO(ICPTI,0)),"^",1) Q:+ICPTD=0 < . S ICPTF=$P($G(ICPTO(ICPTI,0)),"^",2) Q:'$L(ICPTF) < . S ICPTC=ICPTC+1,ARY(0)=ICPTC,ARY(ICPTD)=ICPTF < Q ARY(0) < ; < PERIOD(CODE,ARY) ; return Activation/Inactivation Peri < ; < ; Output: ARY(0) = String: IEN^Selectable < ; < ; Where the pieces are: < ; < ; 1 Internal Entry Number of code in ^ICP < ; 2 0:unselectable; 1:selectable < ; < ; ARY(Activation Date) = Inactivation Date^S < ; Where the Short Name is the Versioned t < ; multiple), and the text is versioned as < ; < ; Period is active - Versioned text fo < ; Period is inactive - Versioned text < ; < ; or < ; < ; -1^0 (no period or error) < ; < I $G(CODE)="" S ARY(0)="-1^0" Q < N ICPTC,ICPTI,ICPTA,ICPTG,ICPTF,ICPTBA,ICPTBI,ICPTST, < S ICPTG=$$GBL^ICPTSUPT(CODE) I ICPTG="" S ARY(0)="-1^ < S ICPTC=$O(@(ICPTG_"""BA"","""_CODE_" "",0)")) I ICPT < S (ARY(0),ICPTC)=+ICPTC,ICPTZ=$G(@(ICPTG_ICPTC_",0)") < S $P(ARY(0),"^",2)=$S(ICPTG="^ICPT(":$P(ICPTZ,"^",6)' < S (ICPTA,ICPTBA)=0,ICPTG=ICPTG_ICPTC_",60," < ; Versioned text for TODAY < S ICPTN=$$VST^ICPTCOD(ICPTC,$$DT^XLFDT,ICPTG) < F Q:ICPTBA D < . S ICPTA=$O(@(ICPTG_"""B"","_ICPTA_")")) < . I ICPTA="" S ICPTBA=1 Q < . S ICPTF=$O(@(ICPTG_"""B"","_ICPTA_",0)")) < . I '+ICPTF S ICPTBA=1 Q < . S ICPTST=$P($G(@(ICPTG_ICPTF_",0)")),"^",2) < . Q:'ICPTST ;outer loop looks for active < . ; Versioned text for activation date < . S ICPTV=$$VST^ICPTCOD(ICPTC,ICPTA,ICPTG),ICPTCA=1 < . S ARY(ICPTA)="^"_ICPTS,ICPTBI=0,ICPTI=ICPTA < . S:$L(ICPTV) $P(ARY(ICPTA),"^",2)=ICPTV < . F Q:ICPTBI D < . . S ICPTI=$O(@(ICPTG_"""B"","_ICPTI_")")) < . . I ICPTI="" S (ICPTBI,ICPTBA)=1 Q < . . S ICPTF=$O(@(ICPTG_"""B"","_ICPTI_",0)")) < . . I '+ICPTF S (ICPTBI,ICPTBA)=1 Q < . . S ICPTST=$P($G(@(ICPTG_ICPTF_",0)")),"^",2) < . . I ICPTST S ICPTBI=1 Q ;inner loop looks for inac < . . ; Versioned text for inactive date < . . S ICPTV=$$VST^ICPTCOD(ICPTC,ICPTI,ICPTG) < . . S $P(ARY(ICPTA),"^")=ICPTI,ICPTBI=1,ICPTA=ICPTI,I < . . S:$L(ICPTV) $P(ARY(ICPTA),"^",2)=ICPTV < . ; if no inactivation date, use TODAY's text < . I +ICPTCA,$L(ICPTN) S ARY(ICPTA)="^"_ICPTN < Q < ; < ACT(ICPTG,ICPTC,ICPTS,ICPTD) ; return "ACT" root < Q ICPTG_"""ACT"","""_ICPTC_" "","_ICPTS_","_ICPTD < Only in ./VADemo/r1/: ICPTAU.m diff -y --suppress-common-lines ./VADemo/r1/ICPTCOD.m ./VADemo/r2/r/ICPTCOD.m ICPTCOD ;ALB/DEK/KER - CPT CODE APIS ; 04/18/2004 | ICPTCOD ;ALB/ABR - CPT CODE APIS ; 3/27/02 3:29pm ;;6.0;CPT/HCPCS;**6,12,13,14,16,19**;May 19, 1997 | ;;6.0;CPT/HCPCS;**6,12,13**;May 19, 1997 ; External References | CPT(CODE,CDT,SRC,DFN) ; returns basic info on CPT/HCPCS co ; DBIA 10103 $$DT^XLFDT | ; Input: CODE - CPT or HCPCS code, ien or .01 forma ; | ; CDT - active as of date, default = today Q | ; SRC - SCREEN SOURCE CPT(CODE,CDT,SRC,DFN) ; returns basic info on CPT/HCPCS cod | ; If '$G(SRC), level 1, Level 2 only. ; | ; If $G(SRC), include level 3. ; Input: CODE CPT/HCPCS or IEN (Required) | ; DFN - not in use but included in anticipa ; CDT Date (default = TODAY) | ; ; SRC Screen source | ; Output: string: ; If '$G(SRC), check Level I and II | ; ien^CPT CODE^SHORT NAME^CATEGORY ien^SOURCE^EF ; If $G(SRC), check Level I, II, an | ; where STATUS = 0 - inactive ; DFN Not in use, future need | ; = 1 - active ; | ; EFFECTIVE DATE = date status became effec ; Output: Returns a 10 piece string delimited ^ | ; -or- ; | ; -1^error description ; 1 IEN of code in ^ICPT | ; ; 2 CPT Code (.01 field) | ; ; 3 Versioned Short Name (from #61 multip | ; Variables: ; 4 Category IEN (#3 field) | ; DATA = 0-node for cpt code ; 5 Source (#6 field) C:CPT; H:HCPCS; L:V | ; EFF = effective date ; 6 Effective Date (from #60 multiple) | ; EFFS = status ; 7 Status (from #60 multiple) | ; STR = output ; 8 Inactivation Date (from #60 multiple) | ; ; 9 Activation Date (from #60 multiple) | N DATA,EFF,EFFS,STR ; 10 Message (CODE TEXT MAY BE INACCURATE) < ; < ; or < ; < ; -1^Error Description < ; < N DATA,EFF,STR,VCPT < S CODE=$G(CODE),CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE | I $G(CDT)="" S CDT=DT ;if no date selected, picks to I CODE<1!'$D(^ICPT(CODE)) S STR="-1^NO SUCH ENTRY" G | S CODE=$G(CODE),CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE I '$G(SRC),$P(^ICPT(CODE,0),"^",6)="L" S STR="-1^VA L | I CODE<1!'$D(^ICPT(CODE)) S STR="-1^NO SUCH ENTRY" G > I '$G(SRC),$P(^ICPT(CODE,0),U,6)="L" S STR="-1^VA LOC > ; > ; move 0-node data into string S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT) | S STR=CODE_U_DATA,$P(STR,U,5)=$P(STR,U,7),STR=$P(STR, S VCPT=$$VSTCP(CODE,CDT) | S EFF=$$EFF^ICPTAPIU(81,CODE,CDT) S STR=CODE_"^"_DATA,$P(STR,"^",5)=$P(STR,"^",7),STR=$ | I EFF'>0 S EFF="^0" S EFF=$$EFF^ICPTSUPT(81,CODE,CDT) S:EFF<1 $P(EFF,"^", | S STR=STR_U_EFF S STR=STR_"^"_EFF_"^"_$$MSG^ICPTSUPT(CDT) S:$L(VCPT) < CPTD(CODE,OUTARR,DFN,CDT) ; Returns CPT description | CPTD(CODE,OUTARR,DFN) ; returns CPT description in array ; Input: CODE CPT/HCPCS code or IEN (Required) | ; Input: CODE - CPT/HCPCS code REQUIRED ; OUTARR Output Array Name for description | ; OUTARR - array to store description ; e.g. "ABC" or "ABC("TEST")" | ; name of array - e.g. "ABC" or "AB > ; or temp array. ; DFN Not in use, future need | ; DFN - not in use but included in anticipat ; CDT Date (default = TODAY) | ; ; | ; Output: # of lines ; Output: # Number of lines in description | ; @OUTARR(1-n) lines of description ; < ; @OUTARR(1:n) - Versioned Description (line < ; @OUTARR(n+1) - blank < ; @OUTARR(n+1) - a message stating: CODE TEX < ; < ; or < ; < ; -1^Error Description < ; ** NOTE - User must initialize ^TMP("ICPTD",$J), if | ; -1^error message N ARR,END,I,N,CTV | ; **NOTE - USER IS RESPONSIBLE FOR INITIALIZING ^TMP( > ; > N ARR,END,I,N > ; > ; check to make sure OUTARR is in proper format > ; > ; If ^TMP("ICPTD",$J, used, clear before using S CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE)),I=0,N=0 | S CODE=$G(CODE),CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE I CODE<1!'$D(^ICPT(CODE)) S N="-1^NO SUCH CODE" G CPT | I CODE<1!'$D(^ICPT(CODE)) S N="-1^NO SUCH CODE" G CPT S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT) | F S I=$O(^ICPT(CODE,"D",I)) Q:'I S N=N+1,ARR=OUTARR D VLTCP(+CODE,CDT,.CTV) S (N,I)=0 F S I=$O(CTV(I)) Q < . S N=N+1,ARR=OUTARR_N_")",@ARR=$$TRIM($G(CTV(I))) < I +N>0 S N=N+1,ARR=OUTARR_N_")",@ARR=" ",N=N+1,ARR=OU < I +N'>0 S N="-1^VERSIONED DESCRIPTION NOT FOUND FOR M < CODM(CODE,OUTARR,SRC,CDT,DFN) ; returns list of modifiers f | CODM(CODE,OUTARR,SRC,CDT,DFN) ; returns list of modifiers ; | ; ; Input: CODE CPT/HCPCS code, Internal or External | ; Input: CODE = CPT/HCPCS code (Internal or exter ; ARY Array Name for list returned | ; OUTARR = array name for list returned ; e.g. "ABC" or "ABC("TEST")" | ; name of array - e.g. "ABC" or "AB ; Default = ^TMP("ICPTM",$J) | ; or temp array. ; SRC Source Screen | ; Default = ^TMP("ICPTM",$J) ; If 0 or Null, check Level I/II cod | ; SRC = Source Screen. ; If >0, check Level I/II/III code/m | ; If 0 or Null, use national(level ; CDT Date (default = TODAY) | ; If SRC>0, use all mods, locals (l ; DFN Not in use, future need | ; CDT = date in Fileman format to check m ; | ; If 0 or Null, return all the modi ; Output: # Number of modifiers that apply | ; Else return only modifiers active ; | ; DFN = not in use. Included in anticipat ; OUTARR Array in the format: | ; ; | ; Output: STR = # of modifiers that apply ; ARY(Mod) = Versioned Name^Mod IEN | ; OUTARR array in the format: ; | ; OUTARR(mod) = name^mod ien ; Where | ; (mod is the .01 field) ; Mod is the .01 field) | ; -1^error description ; Versioned Name is 1 field of the | ; ; | ;**NOTE - USER IS RESPONSIBLE FOR INITIALIZING ^TMP(" ; or | ; ; | N ARR,CODI,CODA,BR,END,ER,MD,MDST,MI,MN,STR,CODEC,ACT ; -1^Error Description < ; < ; ** NOTE - User must initialize ^TMP("ICPTM",$J) a < N ARR,CODI,CODA,BR,END,ER,MD,MDST,MI,MN,STR,CODEC,ACT < S CDT=$G(CDT) < S STR=0,CODI=$S(CODE?1.N:+CODE,1:$$CODEN(CODE)) | S STR=0,CODI=$S(CODE?1.N:+CODE,1:$$CODEN(CODE)),CODEC I CODI<1!'$D(^ICPT(CODI,0)) S STR="-1^NO SUCH CODE" G | I '$D(^ICPT(CODI,0)) S STR="-1^NO SUCH CODE" G CODMQ I '$G(SRC),$P(^ICPT(CODI,0),"^",6)="L" S STR="-1^VA L | I '$G(SRC),$P(^ICPT(CODI,0),U,6)="L" S STR="-1^VA LOC S CODEC=$$CODEC(CODI),CODA=$$NUM^ICPTAPIU(CODEC) | ; > ; check to make sure OUTARR is in proper format > ; > ; If ^TMP("ICPTM",$J, used, clear before using S:$G(CDT)]"" CDT=$$DTBR^ICPTSUPT(CDT) | ;find first begin range S BR="" F S BR=$O(^DIC(81.3,"M",BR)) Q:BR>CODA!'BR | ; BR = Begin Range; ER = End Range > S BR="" F S BR=$O(^DIC(81.3,"M",BR)) Q:BR>CODA!'BR ...S MDST=$G(^DIC(81.3,MI,0)) Q:'$L(MDST) | ...S MDST=$G(^DIC(81.3,MI,0)) Q:'$L(MDST) ; quits if ...I '$G(SRC) Q:$P(MDST,"^",4)="V" | ...I '$G(SRC) Q:$P(MDST,U,4)="V" ; screens out local ...I $G(CDT) S ACTMD="",ACTMD=$$MOD^ICPTMOD(MI,"I",CD | ...I $G(CDT) S ACTMD="",ACTMD=$$MOD^ICPTMOD(MI,"I",CD ...S MD=$P(MDST,"^",1,2),MN=$P(MD,"^") | ...S MD=$P(MDST,U,1,2),MN=$P(MD,U) ...I $L(MN)'=2 Q | ...I $L(MN)'=2 Q ; checks for valid modifier format ...S MVST=$$VSTCM^ICPTMOD(MI,CDT) | ...S ARR=OUTARR_""""_MN_""")",@ARR=$P(MD,U,2)_U_MI,ST ...S ARR=OUTARR_""""_MN_""")",@ARR=MVST_"^"_MI,STR=ST < CODEN(CODE) ; Rreturn the IEN of a CPT/HCPCS code | CODEN(CODE) ;-- This function will return the ien of a CP ; < I $G(CODE)="" Q -1 | Q +$O(^ICPT("B",CODE,0)) N COD < S COD=+$O(^ICPT("B",CODE,0)) < Q $S(COD>0:COD,1:-1) < ; < CODEC(CODE) ; Return the CPT/HCPCS Code < ; Input: IEN of CPT/HCPCS code | CODEC(CODE) ;--This function will return the CPT or HCPCS ; Output: CPT/HCPCS code | ; Input: ien of CPT/HCPCS code > ; Output: CPT/HCPCS code I $G(CODE)="" Q -1 < S Y=$P($G(^ICPT(CODE,0)),"^") | S Y=$P($G(^ICPT(CODE,0)),U,1) Q $S(Y="":-1,1:Y) | Q Y > ; Input: CODE - CPT or HCPCS code, ien or .01 form > ; CDT - active as of date, default = today > ; SRC - SCREEN SOURCE '$G(SRC) level 1, Lev > ; DFN - not in use but included in anticipa ; Input: | ; Output: STR: 1 if valid code for selection ; | ; -1^error message if not selectabl ; CODE - CPT or HCPCS code, ien or .01 format, REQ < ; CTD - Date, default = today < ; SRC - SCREEN SOURCE < ; '$G(SRC) level 1, Level 2 only < ; $G(SRC) include level 3 < ; DFN - not in use, future need < ; < ; Output: STR: 1 if valid code for < ; -1^error message if not selectable < S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT) | I $G(CDT)="" S CDT=DT I '$P(STR,"^",7) S STR="-1^INACTIVE CODE" | I '$P(STR,U,7) S STR="-1^Inactive Code for "_$$FMTE^X ; < ; < Q < VST(IEN,VDATE,TYPE) ; Versioned Short Text < Q:TYPE["ICPT(" $$VSTCP($G(IEN),$G(VDATE)) < Q:TYPE["DIC(81.3" $$VSTCM^ICPTMOD($G(IEN),$G(VDATE)) < Q "" < VSTCP(IEN,VDATE) ; Versioned Short Text (CPT Procedure < N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT < S CPTI=+($G(IEN)) Q:+CPTI'>0 "" Q:'$D(^ICPT(+CPTI)) < S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT= < S CPT0=$G(^ICPT(+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:'$L(C < S CPTSTD=$O(^ICPT("AST",(CPTC_" "),(CPTVDT+.000001)), < I +CPTSTD>0 D Q:$L($G(CPTTXT)) $G(CPTTXT) < . S CPTSTI=$O(^ICPT("AST",(CPTC_" "),CPTSTD,+CPTI," " < S CPTSTD=$O(^ICPT(+CPTI,61,"B",0)) I +CPTSTD>0 D Q:$ < . S CPTSTI=$O(^ICPT(+CPTI,61,"B",CPTSTD,0)),CPTTXT=$$ < Q $$TRIM($P(CPT0,"^",2)) < VLTCP(IEN,VDATE,ARY) ; Versioned Description - Long Text ( < N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT,CPTD,CPT < S CPTI=+($G(IEN)) Q:+CPTI'>0 Q:'$D(^ICPT(+CPTI)) < S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT= < S CPT0=$G(^ICPT(+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:'$L(C < S CPTSTD=$O(^ICPT("ADS",(CPTC_" "),(CPTVDT+.000001)), < I +CPTSTD>0 D Q:+($O(ARY(0)))>0 < . S CPTSTI=$O(^ICPT("ADS",(CPTC_" "),CPTSTD,+CPTI," " < . S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(+CPTI,62,CPTSTI, < . . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(+CPTI,62, < S CPTSTD=$O(^ICPT(+CPTI,62,"B",0)) I +CPTSTD>0 D Q:+ < . S CPTSTI=$O(^ICPT(+CPTI,62,"B",CPTSTD,0)) < . S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(+CPTI,62,CPTSTI, < . . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(+CPTI,62, < K ARY S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(CPTI,"D",CPT < . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(CPTI,"D",CP < Q < TRIM(X) ; Trim Spaces < S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X < F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1)) < F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229) < Q X < Only in ./VADemo/r1/: ICPTID.m Only in ./VADemo/r1/: ICPTIDX.m Only in ./VADemo/r1/: ICPTMIDX.m diff -y --suppress-common-lines ./VADemo/r1/ICPTMOD.m ./VADemo/r2/r/ICPTMOD.m ICPTMOD ;ALB/DEK/KER - CPT MODIFIER APIS ; 04/18/2004 | ICPTMOD ;ALB/ABR - CPT MODIFIER APIS ; 3/27/02 3:28pm ;;6.0;CPT/HCPCS;**6,12,13,14,19**;May 19, 1997 | ;;6.0;CPT/HCPCS;**6,12,13**;May 19, 1997 ; External References | ; APIs for CPT modifiers ; DBIA 10103 $$DT^XLFDT < Q < > ; Input: MOD - modifier REQUIRED > ; MFT - modifier format > ; where: "I" = ien format > ; "E" = .01 format (default) > ; MDT - date to check active for, default = > ; SRC - Modifier Source Screen. > ; If 0 or Null, check national(level > ; DFN - not in use but included in anticipa > ; > ; Output: string: > ; ien^modifier^NAME^CODE^SOURCE^EFFECTIVE DAT > ; where STATUS = 0 - inactive > ; = 1 - active > ; EFFECTIVE DATE = date status became effec > ; -or- > ; -1^error description > ; > ; > ; Variables: > ; DATA = 0-node for cpt modifier code > ; EFF = effective date > ; EFFX = ien of effective date > ; EFFS = status for date > ; STR = output ; Input: MOD Modifier, Internal or External forma | N DATA,EFF,EFFX,EFFS,STR,MODN ; MFT Modifier Format "I" = IEN "E" = .0 < ; MDT Date to check status for, FileMan fo < ; SRC Source Screen < ; If 0 or Null, check Level I and II < ; If >0, check Level I, II, and III < ; DFN Not in use but included in anticipat < ; < ; Output: Returns a 10 piece string delimited by the < ; pieces are: < ; < ; 1 Internal Entry Number < ; 2 Modifier (.01 field) < ; 3 Versioned Name (field 1 of the 61 mul < ; 4 Code (.03 field) Alternate 5-digit Co < ; 5 Source (.04 field) C:CPT; H:HCPCS; V: < ; 6 Effective Date (from multiple field 6 < ; 7 Status (.02 field of multiple field 6 < ; 8 Inactivation Date (from .01 of #60 mu < ; 9 Activation Date (from .01 of #60 mult < ; 10 Message (a message stating: CODE TEXT < ; < ; or < ; < ; -1^Error Description < ; < N DATA,EFF,EFFX,EFFS,STR,MODN,MODST < S MDT=$S($G(MDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(MDT) | I $G(MDT)="" S MDT=DT ;if no date selected, picks tod > ; > ; find ien of modifier > ; if mult mods have same name, return list of iens I MFT="E" S MOD=MODN | I MFT="E" S MOD=MODN ; sets MOD = ien I 'MOD!'$D(^DIC(81.3,MOD)) S STR="-1^NO SUCH MODIFIER | I 'MOD!'$D(^DIC(81.3,MOD)) S STR="-1^NO SUCH MODIFIER > ; > ; move 0-node data into string S MODST=$$VSTCM(MOD,MDT) < S STR=MOD_"^"_$P(DATA,"^",1,4) | S STR=MOD_U_$P(DATA,U,1,4) I '$G(SRC),$P(STR,"^",5)="V" Q "-1^VA LOCAL MODIFIER | S EFF=$$EFF^ICPTAPIU(81.3,MOD,MDT) S EFF=$$EFF^ICPTSUPT(81.3,MOD,MDT) | I EFF'>0 S EFF="^0" I EFF<1 S $P(EFF,"^",2)=0 | S STR=STR_U_EFF S STR=STR_"^"_EFF_"^"_$$MSG^ICPTSUPT(MDT) | I '$G(SRC),$P(STR,U,5)="V" S STR="-1^VA LOCAL MODIFIE S:$L(MODST) $P(STR,"^",3)=MODST < MODD(CODE,OUTARR,DFN,CDT) ; returns CPT descripti < ; < ; Input: CODE CPT Modifier code, internal or exte < ; ARY Output Array Name for description < ; e.g. "ABC" or "ABC("TEST")" < ; Default = ^TMP("ICPTD",$J) < ; DFN Not in use but included in anticipa < ; CDT Date to screen against (default = T < ; If CDT is prior to 1/1/1989, 1/1/ < ; If CDT is year only, the first of < ; If CDT is month/year only, the fi < ; If CDT is later than today, TODAY < ; < ; Output: # Number of lines in description < ; < ; @ARY(1:n) - Versioned Description (lines 1 < ; @ARY(n+1) - blank < ; @ARY(n+1) - a message stating: CODE TEXT M < ; < ; or < ; < ; -1^Error Description < ; < ; ** NOTE - User must initialize ^TMP("ICPTD",$J), i < ; < N ARR,END,CTV,I,N < I $G(CODE)="" S N="-1^NO CODE SELECTED" G MODDQ < I $G(OUTARR)="" S OUTARR="^TMP(""ICPTD"",$J," < I OUTARR'["(" S OUTARR=OUTARR_"(" < I OUTARR[")" S OUTARR=$P(OUTARR,")") < S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S O < I OUTARR="^TMP(""ICPTD"",$J," K ^TMP("ICPTD",$J) < S CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE)),I=0,N=0 < I CODE<1!'$D(^DIC(81.3,CODE)) S N="-1^NO SUCH CODE" G < S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT) < D VLTCM(+CODE,CDT,.CTV) < S (N,I)=0 F S I=$O(CTV(I)) Q:+I=0 D < . S N=N+1,ARR=OUTARR_N_")",@ARR=$$TRIM($G(CTV(I))) < I +N>0 D < . S N=N+1,ARR=OUTARR_N_")",@ARR=" " < . S N=N+1,ARR=OUTARR_N_")",@ARR=$$MSG^ICPTSUPT(CDT,1) < I +N'>0 S N="-1^VERSIONED DESCRIPTION NOT FOUND FOR M < MODDQ Q N < ; < ; Input: CODE CPT/HCPCS Code, Internal or External | ; Input: CODE - CPT/HCPCS code (ien or .01 format ; MOD Modifier, Internal or External Forma | ; MOD - MODIFIER REQUIRED ; MFT Modifier Format "I" = IEN "E" = .01 | ; MFT - modifier format ; MDT Date to check against, FileMan forma | ; "I" = ien format ; If MDT is prior to 1/1/1989, 1/1/1 | ; "E" = .01 format (default) ; If MDT is year only, the first of | ; MDT - date (default = today)(FileMan form ; If MDT is month/year only, the fir | ; SRC - Modifier Source Screen. ; If MDT is later than today, valida | ; If 0 or Null, check national(level ; using the newest activation and in | ; If SRC>0, include VA modifiers ; SRC Source Screen | ; DFN - not in use but included in anticipa ; If 0 or Null, check Level I and II | ; ; If >0, check Level I, II, and III | ; Output: STR = 0 if pair is unacceptable ; DFN Not in use but included in anticipat | ; STR = IEN in 81.3^MODIFIER name (.02 fiel ; | ; or STR = -1^error message ; Output: 0, if pair is unacceptable | ; ; | ; Variables ; or | N CODEA,CODN,PR,PRN,STR,MODN,MODN,MODX,POP,MODCK ; < ; IEN^Versioned Name (field 1 of the 61 mult < ; < ; or < ; < ; -1^error message < ; < N CODEA,CODN,PR,PRN,STR,MODN,MODN,MODX,POP,MODCK,MODS < I $G(MFT)="" S MFT="E" | I $G(MFT)="" S MFT="E" ;if no modifier format select I "E^I"'[MFT S STR="-1^INVALID MODIFIER FORMAT" G MOD | I $G(MDT)="" S MDT=DT ;if no date selected, default S MDT=$S($G(MDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(MDT) | I "E^I"'[MFT S STR="-1^INVALID MODIFIER FORMAT" G MOD > ; > ; check to see if cpt code exists > ;S:'CODE CODN=$$CODEN^ICPTCOD(CODE) > ;I CODE S CODN=+CODE I CODN<1!'$D(^ICPT(CODN,0)) Q "-1^NO SUCH CPT CODE" | S CODE=$P($G(^ICPT(CODN,0)),U) I '$L(CODE) S STR="-1^ S CODE=$P($G(^ICPT(CODN,0)),"^") I '$L(CODE) S STR="- | ; ICPT*6*13 check to see if cpt code active I '$G(SRC),$P(^ICPT(CODN,0),"^",6)="L" S STR="-1^VA L | I MDT=DT,$P($G(^ICPT(CODN,0)),U,4) S STR="-1^CPT CODE S PRN=$$EFF^ICPTSUPT(81,CODN,MDT) | I MDT'=DT,'$P($$EFF^ICPTAPIU(81,CODN,MDT),U,2) S STR= I '$P(PRN,"^",2) Q "-1^CPT CODE INACTIVE" | S CODEA=$$NUM^ICPTAPIU(CODE) ; convert code to numeri S CODEA=$$NUM^ICPTAPIU(CODE),MODCK="" | I '$G(SRC),$P(^ICPT(CODN,0),U,6)="L" S STR="-1^VA LOC > ; > ; find ien for modifier, if .01 sent in > S MODCK="" . D MODC(MODN) S MODST=$$VSTCM(MODN,MDT) | . D MODC(MODN) . I STR>0 S $P(STR,"^",2)=MODST,POP=1 | . I STR>0 S POP=1 I '$G(SRC),$P(^DIC(81.3,MODCK,0),"^",4)="V" S STR="-1 | I '$G(SRC),$P(^DIC(81.3,MODCK,0),U,4)="V" S STR="-1^V MODC(MOD) ; Checks modifier for range including code, a | MODC(MOD) ;subroutine checks modifier for range includi ; | ; for date desired. ; Input: | ; MOD = modifier ien ; MOD - modifier ien | ; ; | N MODNM N MODNM,MODEFF | I MDT=DT,$D(^DIC(81.3,MOD,0)),$P(^DIC(81.3,MOD,0),U,5 S MODEFF=$$EFF^ICPTSUPT(81.3,MOD,MDT) | S PR=CODEA_.0001,PR=$O(^DIC(81.3,MOD,"M",PR),-1) ; fi I '$P(MODEFF,"^",2) S STR="-1^modifier inactive" Q < S PR=CODEA_.0001,PR=$O(^DIC(81.3,MOD,"M",PR),-1) < S PRN=^DIC(81.3,MOD,"M",PR) | S PRN=^DIC(81.3,MOD,"M",PR) ; END RANGE VALUE I PRN S STR=MOD_"^"_MODNM ; code modifier pair okay pending > ; > ; check that modifier is active for given date > I MDT'=DT,'$P($$EFF^ICPTAPIU(81.3,MOD,MDT),U,2) S STR MULT ; Finds iens for all modifiers with same 2-letter cod | MULT ; finds iens for all modifiers with same 2-letter cod ; < CODEN(CODE) ; return the ien of a CPT modifier < ; Input: CPT modifier code < ; Output: ien of code < ; < Q:$G(CODE)="" -1 < N COD S COD=+$O(^DIC(81.3,"BA",(CODE_" "),0)) < Q $S(COD>0:COD,1:-1) < ; < VSTCM(IEN,VDATE) ; Versioned Short Text (CPT Modifier) < N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT < S CPTI=+($G(IEN)) Q:+CPTI'>0 "" Q:'$D(^DIC(81.3,+CPT < S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT= < S CPT0=$G(^DIC(81.3,+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:' < S CPTSTD=$O(^DIC(81.3,"AST",(CPTC_" "),(CPTVDT+.00000 < I +CPTSTD>0 D Q:$L($G(CPTTXT)) $G(CPTTXT) < . S CPTSTI=$O(^DIC(81.3,"AST",(CPTC_" "),CPTSTD,+CPTI < S CPTSTD=$O(^DIC(81.3,+CPTI,61,"B",0)) I +CPTSTD>0 D < . S CPTSTI=$O(^DIC(81.3,+CPTI,61,"B",CPTSTD,0)),CPTTX < Q $$TRIM($P(CPT0,"^",2)) < VLTCM(IEN,VDATE,ARY) ; Versioned Description - Long Text ( < N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT < S CPTI=+($G(IEN)) Q:+CPTI'>0 Q:'$D(^DIC(81.3,+CPTI)) < S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT= < S CPT0=$G(^DIC(81.3,+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:' < S CPTSTD=$O(^DIC(81.3,"ADS",(CPTC_" "),(CPTVDT+.00000 < I +CPTSTD>0 D Q:+($O(ARY(0)))>0 < . S CPTSTI=$O(^DIC(81.3,"ADS",(CPTC_" "),CPTSTD,+CPTI < . S (CPTD,CPTT)=0 F S CPTD=$O(^DIC(81.3,+CPTI,62,CPT < . . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^DIC(81.3,+CPTI < S CPTSTD=$O(^DIC(81.3,+CPTI,62,"B",0)) I +CPTSTD>0 D < . S CPTSTI=$O(^DIC(81.3,+CPTI,62,"B",CPTSTD,0)) < . S (CPTD,CPTT)=0 F S CPTD=$O(^DIC(81.3,+CPTI,62,CPT < . . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^DIC(81.3,+CPTI < K ARY S (CPTD,CPTT)=0 F S CPTD=$O(^DIC(81.3,CPTI,"D" < . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^DIC(81.3,CPTI,"D < Q < TRIM(X) ; Trim Spaces < S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X < F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1)) < F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229) < Q X < Only in ./VADemo/r1/: ICPTSUPT.m diff -y --suppress-common-lines ./VADemo/r1/IMRDAT.m ./VADemo/r2/r/IMRDAT.m IMRDAT ; HCIOFO-FAI/SS - DATA EXTRACTION ; 2/14/03 9:41am | IMRDAT ; HCIOFO-FAI/SS - DATA EXTRACTION ; 1/6/03 8:18am ;;2.1;IMMUNOLOGY CASE REGISTRY;**4,8,9,5,14,13,16,15, | ;;2.1;IMMUNOLOGY CASE REGISTRY;**4,8,9,5,14,13,16,15, . N IMRIV,METHOD,RACE S IMRIV="" | . N I,METHOD,RACE S I="" . F S IMRIV=$O(VADM(12,IMRIV)) Q:IMRIV="" D D LCH | . F S I=$O(VADM(12,I)) Q:I="" D D LCHK . . S RACE=$$PTR2CODE^DGUTL4($P(VADM(12,IMRIV),U),1,2 | . . S RACE=$$PTR2CODE^DGUTL4($P(VADM(12,I),U),1,2) Q . . S METHOD=$$PTR2CODE^DGUTL4($P($G(VADM(12,IMRIV,1) | . . S METHOD=$$PTR2CODE^DGUTL4($P($G(VADM(12,I,1)),U) . N ETHN,IMRIV,METHOD S IMRIV="" | . N ETHN,I,METHOD S I="" . F S IMRIV=$O(VADM(11,IMRIV)) Q:IMRIV="" D D LCH | . F S I=$O(VADM(11,I)) Q:I="" D D LCHK . . S ETHN=$$PTR2CODE^DGUTL4($P(VADM(11,IMRIV),U),2,2 | . . S ETHN=$$PTR2CODE^DGUTL4($P(VADM(11,I),U),2,2) Q . . S METHOD=$$PTR2CODE^DGUTL4($P($G(VADM(11,IMRIV,1) | . . S METHOD=$$PTR2CODE^DGUTL4($P($G(VADM(11,I,1)),U) Only in ./VADemo/r1/: IMRP020.m Only in ./VADemo/r1/: IVM2069P.m Only in ./VADemo/r1/: IVM2069Q.m Only in ./VADemo/r1/: IVM2071A.m Only in ./VADemo/r1/: IVM2071M.m Only in ./VADemo/r1/: IVM2074.m Only in ./VADemo/r1/: IVM2077P.m Only in ./VADemo/r1/: IVM2078P.m Only in ./VADemo/r1/: IVM2096.m Only in ./VADemo/r1/: IVM273A.m Only in ./VADemo/r1/: IVM273M.m Only in ./VADemo/r1/: IVM279P.m Only in ./VADemo/r1/: IVM289A.m Only in ./VADemo/r1/: IVM289M.m Only in ./VADemo/r1/: IVM2A102.m Only in ./VADemo/r1/: IVM2B102.m diff -y --suppress-common-lines ./VADemo/r1/IVMCDD.m ./VADemo/r2/r/IVMCDD.m IVMCDD ;ALB/CJM - DATA DICTIONARY FUNCTIONS ; 01/30/2004 | IVMCDD ;ALB/CJM - DATA DICTIONARY FUNCTIONS ; 20-APR-95 ;;2.0;INCOME VERIFICATION MATCH;**17,89**;21-OCT-94 | ;;2.0;INCOME VERIFICATION MATCH;**17**;21-OCT-94 Q:+$G(^DGMT(408.31,MTIEN,0))'>DT < Q:+$G(^DGMT(408.31,MTIEN,0))'>DT < Q:'(+$G(^IVM(301.5,IVMPAT,0))) < Q:+$G(^DGMT(408.31,MTIEN,0))'>DT | Q:'(+$G(^IVM(301.5,IVMPAT,0))) ;Kill logic for the "AE" x-ref on the IVM Patient fil | ;Kill logic for the "AC" x-ref on the IVM Patient fil Q:+$G(^DGMT(408.31,MTIEN,0))'>DT < diff -y --suppress-common-lines ./VADemo/r1/IVMCM1.m ./VADemo/r2/r/IVMCM1.m IVMCM1 ;ALB/SEK,BRM - DCD INCOME TESTS UPLOAD DRIVER ; 1/24/ | IVMCM1 ;ALB/SEK,BRM - DCD INCOME TESTS UPLOAD DRIVER ; 1/4/0 ;;2.0;INCOME VERIFICATION MATCH;**17,49,71**;21-OCT-9 | ;;2.0;INCOME VERIFICATION MATCH;**17,49**;21-OCT-94 ; or created by upload. IVMAR2 is the array used to c | ; or created by upload. K IVMAR,IVMAR2 | K IVMAR ; New Edit Checks | ; edit checks N IVMERR,OK2UPLD S IVMERR="",OK2UPLD=1 | S IVMX=$$EN^IVMCME() I IVMX]"" D PROB^IVMCMC(IVMX) K D EN^IVMCMF(.IVMERR),PROB^IVMCMFB(,.IVMERR,0) Q:'OK2U < diff -y --suppress-common-lines ./VADemo/r1/IVMCM6.m ./VADemo/r2/r/IVMCM6.m IVMCM6 ;ALB/SEK,JAN,RTK,CKN,TDM,GN - COMPLETE DCD INCOME TES | IVMCM6 ;ALB/SEK,JAN,RTK,CKN,TDM - COMPLETE DCD INCOME TEST ; ;;2.0;INCOME VERIFICATION MATCH;**17,25,39,44,50,53,4 | ;;2.0;INCOME VERIFICATION MATCH;**17,25,39,44,50,53,4 ;IVM*2*84 - insure DGMTP is defined by LTC test prior < ; audit < ; < ..S DGMTP=$G(DGMTP) < diff -y --suppress-common-lines ./VADemo/r1/IVMCMC.m ./VADemo/r2/r/IVMCMC.m IVMCMC ;ALB/SEK,BRM,GN - CHECK INCOME TEST TRANSMISSION SEGM | IVMCMC ;ALB/SEK,BRM - CHECK INCOME TEST TRANSMISSION SEGMENT ;;2.0;INCOME VERIFICATION MATCH;**17,34,49,51,90**;21 | ;;2.0;INCOME VERIFICATION MATCH;**17,34,49,51**;21-OC ; < ;IVM*2*90 - stop upload of LTC type 4 test when staus < ; < ;IVM*2*90 don't allow upload of LTC with a date & a < I SEG="ZMT4",$P(IVMSEG,HLFS,3),$P(IVMSEG,HLFS,4)'=0,$ < ; < Only in ./VADemo/r1/: IVMCMF1.m Only in ./VADemo/r1/: IVMCMF2.m Only in ./VADemo/r1/: IVMCMF3.m Only in ./VADemo/r1/: IVMCMFB.m Only in ./VADemo/r1/: IVMCMF.m diff -y --suppress-common-lines ./VADemo/r1/IVMCM.m ./VADemo/r2/r/IVMCM.m IVMCM ;ALB/SEK,KCL,RTK,AEG,BRM,AEG - PROCESS INCOME TEST (Z | IVMCM ;ALB/SEK,KCL,RTK,AEG,BRM,AEG - PROCESS INCOME TEST (Z ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,3 | ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,3 S IVMTYPE=5,IVMZ10F=1 | S IVMTYPE=5 ; set default to error condition K DGMTMSG,IVMZ10F | K DGMTMSG .I $$Z06MT^EASPTRN1(+IVMLAST) Q < > ; > DOM(DFN) ; Is patient in a DOM? > ; Input: DFN - pointer to pt in file (#2) > ; Output: IVMDOM - Is the patient in a DOM? 0 => NO > ; > N IVMDOM,VAINDT,VADMVT > D ADM^VADPT2 > I VADMVT,$P($G(^DG(43,1,0)),"^",21),$D(^DIC(42,+$P($G > Q +$G(IVMDOM) > ; Only in ./VADemo/r1/: IVMCMZ.m diff -y --suppress-common-lines ./VADemo/r1/IVMCZMT.m ./VADemo/r2/r/IVMCZMT.m IVMCZMT ;ALB/MLI/LD/CKN/TDM - Creation of HL7 ZMT (means tes | IVMCZMT ;ALB/MLI/LD/CKN/TDM - Creation of HL7 ZMT (means tes ;;2.0;INCOME VERIFICATION MATCH;**17,53,49,58,81,89** | ;;2.0;INCOME VERIFICATION MATCH;**17,53,49,58**;21-OC ; an income year other than indicated in th | ; a prior income year than indicated by the ; Income Year requiring transmission from IVM Patient | S X=$$LST^DGMTU(DFN,VAFMTDT,$S($G(VAFTYPE):VAFTYPE,1: S IVMIY=$S($D(IVMIY):IVMIY,1:(VAFMTDT-10000)) | S MTIEN=+X ; | I MTIEN S NODE=$G(^DGMT(408.31,+X,0)),PRIM=$G(^("PRIM ; Check for a future dated Income Test | ; S MTIEN=+$$FUT^DGMTU(DFN,"",$S($G(VAFTYPE):VAFTYPE,1: | ;if $$LST of ^DGMTU returned the wrong income yr, dis I MTIEN S NODE=$G(^DGMT(408.31,MTIEN,0)),PRIM=$G(^("P | I ($G(LIMIT)=1),$E(VAFMTDT,1,3)'=$E(+NODE,1,3) S (NOD > ; > ; Check $$FUT > I 'X D > . N OK2SND,DGMTI,Y > . S OK2SND=0 > . S Y=$$FUT^DGMTU(DFN,"",$S($G(VAFTYPE):VAFTYPE,1:1)) > . I +Y,$P($G(^DG(408.34,+$P(Y,U,5),0)),U)="DCD",$$VER > S MTIEN=+X > I MTIEN S NODE=$G(^DGMT(408.31,+X,0)),PRIM=$G(^("PRIM I ($G(LIMIT)=1),($E(IVMIY,1,3)+1)'=$E(+NODE,1,3) S (N | I ($G(LIMIT)=1),$E(VAFMTDT,1,3)'=$E(+NODE,1,3) S (NOD ; < ; Check for a current Primary Income Test < I 'MTIEN S MTIEN=+$$LST^DGMTU(DFN,VAFMTDT,$S($G(VAFTY < S:(NODE="") NODE=$G(^DGMT(408.31,MTIEN,0)),PRIM=$G(^( < diff -y --suppress-common-lines ./VADemo/r1/IVMLDEM4.m ./VADemo/r2/r/IVMLDEM4.m IVMLDEM4 ;ALB/KCL,PJR - IVM DEMOGRAPHIC UPLOAD/DELETE | IVMLDEM4 ;ALB/KCL - IVM DEMOGRAPHIC UPLOAD/DELETE FIEL ;;2.0;INCOME VERIFICATION MATCH;**5,10,56,102**; 21-O | ;;2.0;INCOME VERIFICATION MATCH;**5,10**; 21-OCT-94 N VALMY,IVMDOD S IVMDOD=0 | N VALMY N IVMPKDOD D CHECKS,CHECKDOD | D CHECKS .; - check to see if selection is a Date of Death fie < .I IVMPKDOD S IVMDOD=$$DOD^IVMLDEMD(+IVMINDEX,$P(IVMI < .; < .Q:IVMDOD < .; < N IVMPKDOD D CHECKS,CHECKDOD | D CHECKS .;if Date of Death is Deleted, send bulletin < .I IVMPKDOD D BULLETIN S IVMPKDOD=0 < CHECKDOD ; check if date of death was selected < ; IVMPKDOD=0 date of death not selected < ; 1 date of death selected < ; < N IVMPPIC1,IVMPPIC2,CKST < S (IVMPKDOD,IVMPPIC2)=0 < Q:IVMWHERE'="UP" < S IVMENT4=0 F S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT < .S CKST=$G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4) < .I CKST["DATE OF DEATH"!(CKST["SOURCE OF NOTIFICATION < Q < BULLETIN ; Non-Acceptance of Date of Death Data Bullet < N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT, < 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 < S XMTEXT="DGBULL(" < S XMSUB="NON-ACCEPTANCE OF DATE OF DEATH DATA" < 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 Enrollment Record contain < D LINE^DGEN("however, you did not upload this informa < D LINE^DGEN("Contact the HEC by phone or by fax with < D LINE^DGEN("non-acceptance. The HEC will delete err < D LINE^DGEN("information and update the veteran's enr < D ^XMD < Q < diff -y --suppress-common-lines ./VADemo/r1/IVMLDEM6.m ./VADemo/r2/r/IVMLDEM6.m IVMLDEM6 ;ALB/KCL/BRM - IVM DEMOGRAPHIC UPLOAD FILE AD | IVMLDEM6 ;ALB/KCL/BRM - IVM DEMOGRAPHIC UPLOAD FILE AD ;;2.0;INCOME VERIFICATION MATCH;**10,58,73,79**; 21-O | ;;2.0;INCOME VERIFICATION MATCH;**10,58**; 21-OCT-94 S:$$PHARM(+$G(DFN)) DIR("A",1)="*** WARNING: This pat < S DIR("A",2)="" < I $$ADRDTCK^IVMLDEM9(+$G(DFN),IVMDA2,IVMDA1) S DIR("A < ; determine correct address change date/time to use < D ADDRDT(DFN,IVMDA2,IVMDA1) < ; < ..; - perform any necessary address field manipulatio | ..; - load addr field rec'd from IVM into DHCP (#2) f ..; load addr field rec'd from IVM into DHCP (#2) f < ; < ; < ; - delete inaccurate Addr Change Site data if Source < ; (trigger x-ref does not fire with 4 slash stuff) < I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12 < ; < Q:'IVMDA1 IVMFLAG < ..; don't auto-update if there is an active Prescript < ..; the Bad Address Indicator is null < ..I ('NOUPDT),$$PHARM(+DFN),'$$BADADR^DGUTL3(+DFN) D < ..; < ..; - if no display or uploadable fields left, then d < ..; segment < ..I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM < ...D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up na < ADDRDT(DFN,IVMDA2,IVMDA1) ; < ; - validate Address Change Dt/Tm before filing < ; if incoming address is accepted and the change da < ; than what's on file, then use today's date for Ad < ; < Q:'$$ADRDTCK^IVMLDEM9(DFN,IVMDA2,IVMDA1) < N FDA,IEN92,IVMDA,IENS,ERR < S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92 < Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92)) < S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IE < S IENS=IVMDA_","_IVMDA1_","_IVMDA2_"," < S FDA(301.511,IENS,.02)=$$NOW^XLFDT < D FILE^DIE("","FDA","ERR") < Q < ; < PHARM(DFN) ;does this patient have active pharmacy presc < ; < ;External reference to $$EN^PSSRXACT supported by IA < ; < Q $S('$G(DFN):0,1:$$EN^PSSRXACT(DFN)) < diff -y --suppress-common-lines ./VADemo/r1/IVMLDEM7.m ./VADemo/r2/r/IVMLDEM7.m IVMLDEM7 ;ALB/KCL - IVM DEMOGRAPHIC UPLOAD - DELETE AD | IVMLDEM7 ;ALB/KCL - IVM DEMOGRAPHIC UPLOAD - DELETE AD ;;2.0;INCOME VERIFICATION MATCH;**10,79**; 21-OCT-94 | ;;2.0;INCOME VERIFICATION MATCH;**10**; 21-OCT-94 S DIR("A",1)="If you delete this address, then the pr < S DIR("A",2)="will be transmitted to HEC and all site < ; < ; file new Address Change Date/Time < N FDA,ERRMSG < S FDA(2,DFN_",",.118)=$$FMTE^XLFDT($$NOW^XLFDT) < D FILE^DIE("E","FDA","ERRMSG") < ; < Only in ./VADemo/r1/: IVMLDEM9.m Only in ./VADemo/r1/: IVMLDEMC.m Only in ./VADemo/r1/: IVMLDEMD.m diff -y --suppress-common-lines ./VADemo/r1/IVMLINS1.m ./VADemo/r2/r/IVMLINS1.m ;;2.0;INCOME VERIFICATION MATCH;**14,94**; 21-OCT-94 | ;;2.0;INCOME VERIFICATION MATCH;**14**; 21-OCT-94 D DISP^DGIBDSP | D DISP^IBCNS diff -y --suppress-common-lines ./VADemo/r1/IVMLINS.m ./VADemo/r2/r/IVMLINS.m IVMLINS ;ALB/KCL,PHH - IVM INSURANCE UPLOAD ; 14-JAN-94 | IVMLINS ;ALB/KCL - IVM INSURANCE UPLOAD ; 14-JAN-94 ;;2.0;INCOME VERIFICATION MATCH;**14,94**; 21-OCT-94 | ;;2.0;INCOME VERIFICATION MATCH;**14**; 21-OCT-94 ..S IVMINS=$$INSUR^IBBAPI(DFN,DT),IVMINS=$S(IVMINS=1: | ..S IVMINS=$$INSURED^IBCNS1(DFN,DT),IVMINS=$S(IVMINS= diff -y --suppress-common-lines ./VADemo/r1/IVMPINS.m ./VADemo/r2/r/IVMPINS.m IVMPINS ;ALB/CPM,PHH - INSURANCE EVENT DRIVER INTERFACE ; 01- | IVMPINS ;ALB/CPM - INSURANCE EVENT DRIVER INTERFACE ; 01-MAY- ;;2.0;INCOME VERIFICATION MATCH;**9,94**; 21-OCT-94 | ;;2.0;INCOME VERIFICATION MATCH;**9**; 21-OCT-94 S IVMINSA=$$INSUR^IBBAPI(DFN) | S IVMINSA=$$INSURED^IBCNS1(DFN) I IVMDA,(IVMINSP&'IVMINSA)!('IVMINSP&IVMINSA=1) I $$S | I IVMDA,(IVMINSP&'IVMINSA)!('IVMINSP&IVMINSA) I $$SET diff -y --suppress-common-lines ./VADemo/r1/IVMPMTE.m ./VADemo/r2/r/IVMPMTE.m ;;2.0;INCOME VERIFICATION MATCH;**1,9,17,39,49,89**;2 | ;;2.0;INCOME VERIFICATION MATCH;**1,9,17,39,49**;21-O ; Quit when uploading Future Means Tests < Q:$G(IVM1)>DT < ; < ; Update cross references when editing Future Dated T < I $D(DGMTI),+$G(DGMT0)>DT,$D(IVMDA) D < .I DGMTYPT=1,$P(^IVM(301.5,IVMDA,0),U,6)'="",+DGMTA'> < .I DGMTYPT=2,$P(^IVM(301.5,IVMDA,0),U,7)'="",+DGMTA'> < ; < diff -y --suppress-common-lines ./VADemo/r1/IVMPREC1.m ./VADemo/r2/r/IVMPREC1.m IVMPREC1 ;ALB/SEK/BRM - PROCESS INCOMING HL7 (ACK) MES | IVMPREC1 ;ALB/SEK/BRM - PROCESS INCOMING HL7 (ACK) MES ;;2.0;INCOME VERIFICATION MATCH;**9,17,26,52,34,72,82 | ;;2.0;INCOME VERIFICATION MATCH;**9,17,26,52,34**; 21 N Z07FLG,Z07RET | S IVMI=1 F S IVMI=$O(^TMP($J,IVMRTN,IVMI)) Q:'IVMI S IVMI=0 F S IVMI=$O(^TMP($J,IVMRTN,IVMI)) Q:'IVMI < .D:$E(IVMSEG,1,3)="MSH" < ..S Z07RET=0 < ..I $P(IVMSEG,HLFS,9)["ORU~Z07" S Z07FLG=1 Q < ..K Z07FLG < .S IVMDA=$O(^IVM(301.6,"ADS",IVMMCI,"")) I 'IVMDA D | .S IVMDA=$O(^IVM(301.6,"ADS",IVMMCI,"")) I 'IVMDA D O ..I $D(Z07FLG) D Q < ...S Z07RET=$$Z07CHK(IVMI,IVMMCI,IVMEM) < ...S:Z07RET IVMDA=$O(^IVM(301.6,"ADS",IVMMCI,"")) < ..D OTH < F IVMDA=0:0 S IVMDA=$O(^IVM(301.6,"AE",+$G(IVMMCI),IV | F IVMDA=0:0 S IVMDA=$O(^IVM(301.6,"AE",+IVMMCI,IVMDA) ; < Z07CHK(CURSEQ,CURMCI,CUREM) ; Function ; < ; INPUT < ; CURSEQ : Current Sequence # reviewing in batch < ; CURMCI : Current Message Control ID reviewing < ; CUREM : Current Error Message reviewing in ba < ; < ; Check for duplicate ACK sequence on the same batch < N SEQ,CHKSEG,CHKSEGN,DUP < S (SEQ,DUP)=0 < F S SEQ=$O(^TMP($J,IVMRTN,SEQ)) Q:SEQ="" D < . S CHKSEG=^TMP($J,IVMRTN,SEQ,0),CHKSEGN=$E(CHKSEG,1, < . Q:CHKSEGN'="MSA" < . Q:SEQ=CURSEQ < . S:$P(CHKSEG,"^",3)=CURMCI DUP=1 < I DUP Q "0^DUPLICATE SEQUENCE ON ACK BATCH" < ; < ; Check to see if ADS x-ref missing in last 1000 entr < N END,IEN,MCI,FND,LOG,RET,TMPCTR < S FND=0,RET="",IEN=" " < F TMPCTR=1:1:1000 S IEN=$O(^IVM(301.6,IEN),-1) Q:+IEN < . S MCI=$P(^IVM(301.6,IEN,0),"^",5) < . I MCI=CURMCI S FND=1 D Q < . . S LOG=^IVM(301.6,IEN,0) < . . I $P(LOG,"^",3)=3&($P(LOG,"^",4)=CUREM) S RET="0^ < . . S ^IVM(301.6,"ADS",CURMCI,IEN)="" S RET="1^ADS X- < Q RET < diff -y --suppress-common-lines ./VADemo/r1/IVMPREC6.m ./VADemo/r2/r/IVMPREC6.m IVMPREC6 ;ALB/KCL/BRM - PROCESS INCOMING (Z05 EVENT TY | IVMPREC6 ;ALB/KCL/BRM - PROCESS INCOMING (Z05 EVENT TY ;;2.0; INCOME VERIFICATION MATCH ;**3,4,12,17,34,58,7 | ;;2.0; INCOME VERIFICATION MATCH ;**3,4,12,17,34,58** .;S IVMFLG=0 | .S IVMFLG=0 .I $$RF1CHK(IVMRTN,IVMDA) D NEXT,COMPARE(IVMSEG) S IV | .I $$RF1CHK(IVMRTN,IVMDA) D Q > ..D NEXT > ..; - get 3 letter HL7 segment name > ..S IVMXREF=$P(IVMSEG,HLFS,1),IVMSTART=IVMXREF > ..; - strip off HL7 segment name > ..S IVMSEG=$P(IVMSEG,HLFS,2,99) > ..; - file address data in file #2 if appropriate > ..D RF1^IVMPREC8(IVMSEG) ; Cleanup variables if no msg necessary < I 'IVMCNTR K IVMTEXT,XMSUB < .I IVMXREF["RF1",(IVMSTART["RF1") D RF1^IVMPREC8 < ; If record is auto uploaded, don't add veteran to bu < I $$CKAUTO Q < ; < ; < CKAUTO() ; < ; Chect if message qualifies for an auto upload. < N AUTO,IVMI,DOD < S AUTO=0,IVMI=$O(^IVM(301.92,"C","ZPD09","")) < I IVMI=IVMDEMDA D < .I +IVMFLD'>0 S AUTO=1 Q < .S DOD=$P($G(^DPT(DFN,.35)),U) < .I DOD=IVMFLD S AUTO=1 Q < ; < Q AUTO < diff -y --suppress-common-lines ./VADemo/r1/IVMPREC7.m ./VADemo/r2/r/IVMPREC7.m ;;2.0;INCOME VERIFICATION MATCH;**1,17,44,34,77**;21- | ;;2.0;INCOME VERIFICATION MATCH;**1,17,44,34**;21-OCT ..I $$Z06MT^EASPTRN1(IVMMTIEN) Q ;EDB Z06 - Don't < diff -y --suppress-common-lines ./VADemo/r1/IVMPREC8.m ./VADemo/r2/r/IVMPREC8.m IVMPREC8 ;ALB/KCL/BRM/PJR - PROCESS INCOMING (Z05 EVEN | IVMPREC8 ;ALB/KCL/BRM - PROCESS INCOMING (Z05 EVENT TY ;;2.0; INCOME VERIFICATION MATCH ;**5,6,12,58,73,79,1 | ;;2.0; INCOME VERIFICATION MATCH ;**5,6,12,58**; 21-O N COMPPH1,COMPPH2 < .; line remove so that the phone number is compared | .I IVMXREF["PID13" S IVMFLD=$P(IVMSEG,HLFS,13) D STOR .; before saving to 301.5. < .;I IVMXREF["PID13" S IVMFLD=$P(IVMSEG,HLFS,13) D STO < .; - special logic for phone number processing < .; - if different, then store the actual value receiv < .I IVMXREF["PID13",IVMFLD]"" D Q < ..S COMPPH1=$$CONVPH(IVMFLD) < ..S COMPPH2=$$CONVPH(IVMDHCP) < ..I COMPPH1'=COMPPH2 D STORE^IVMPREC9 < .; < .I IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32" | .I IVMXREF["ZPD09"!(IVMXREF["ZPD13") S IVMFLD=$$FMDAT .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9 Q | .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9 .I IVMXREF["ZPD09"!(IVMXREF["ZPD31")!(IVMXREF["ZPD32" < I IVMXREF["ZPD32",$$AUTODOD^IVMLDEMD(DFN) < RF1 ; - compare RF1 segment fields with DHCP fields < S IVMPIECE=$E(IVMXREF,4),IVMADFLG=1 < I $P(IVMSEG,HLFS,IVMPIECE)]"" D < .;if RF1 field is SEQ6, then parse subcomponents < .I IVMXREF["RF16" D Q < ..;- get data containing 4 pieces seperated by HLECH < ..S IVMRFDAT=$P(IVMSEG,HLFS,6) < ..S IVMPIECE=$E(IVMXREF,5),IVMFLD=$P(IVMRFDAT,"~",IVM < ..I IVMPIECE=2 S IVMFLD=$$ADDRCNV(IVMFLD) < ..Q:IVMFLD="" < ..D STORE^IVMPREC9 < .I IVMXREF["RF17" D Q < ..;get address change date/tm field < ..S IVMFLD=$$FMDATE^HLFNC($P(IVMSEG,HLFS,7)) < ..Q:IVMFLD="" < ..D STORE^IVMPREC9 < ..; check for auto-upload < ..S NOUPDT=0,IVMDHCP=$P($G(^DPT(DFN,.11)),HLFS,13) < ..I IVMFLD]"",(IVMFLD'>IVMDHCP) S NOUPDT=1 < ..I $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT) < Q < > RF1(IVMSEG) ; - compare RF1 segment fields against DHCP a > ; data into the Patient (#2) file if the address is > ; than the one on file. > ; > Q:$G(IVMSEG)']"" > N ADDR6,ADDRSIT,ADDRSRC,NOUPDT > S IVMADFLG=1 > ; sequences 1-5 in RF1 are not currently used > ; > ; - get address update site and source > ; (4 components) separated by a tilde (~) > S ADDR6=$P(IVMSEG,HLFS,6) > S ADDRSIT=$P(ADDR6,"~",1) > S ADDRSRC=$$ADDRCNV($P(ADDR6,"~",2)) > S:ADDRSRC'="VAMC" ADDRSIT="" > ; components 3 and 4 in RF1 sequence 6 are not curr > ; > ; - get Date/Time of Address change > S ADDR7=$P(IVMSEG,HLFS,7) > S ADDRDT=$$FMDATE^HLFNC(ADDR7) > ; > ; see Address Indexing HL7 Review doc for SEQ 8-10 ap > ; - Invalid Address Date (SEQ 8) - not currently used > ; - Date Checked by NCOA (SEQ 9) - not currently used > ; - Invalid Address Reason (SEQ 10) - not used but ha > ; > ; - get address date/time updated from the Patient (# > S ADDRDT2=$P($G(^DPT(DFN,.11)),"^",13) > ; > ; - quit w/o update if incoming address older than ex > Q:'ADDRDT > I ADDRDT'>ADDRDT2 S NOUPDT=1 > ; > ; - update Patient file address data if necessary > Q:'$$AUTOADDR^IVMLDEM6(DFN,1,+$G(NOUPDT)) > ; > ; - set up FDA array for change date, source, and sit > S FDA(2,DFN_",",.118)=$$FMTE^XLFDT($G(ADDRDT)) > S FDA(2,DFN_",",.119)=$G(ADDRSRC) > S FDA(2,DFN_",",.12)=$G(ADDRSIT) > D FILE^DIE("E","FDA","ERRMSG") > Q CONVPH(PH) ;remove special chars/spaces from Phone numbe < Q $TR(PH," )(/#\-","") < diff -y --suppress-common-lines ./VADemo/r1/IVMPRECA.m ./VADemo/r2/r/IVMPRECA.m IVMPRECA ;ALB/KCL/BRM/PJR/RGL - DEMOGRAPHICS MESSAGE C | IVMPRECA ;ALB/KCL/BRM - DEMOGRAPHICS MESSAGE CONSISTEN ;;2.0; INCOME VERIFICATION MATCH ;**5,6,12,34,58,56** | ;;2.0; INCOME VERIFICATION MATCH ;**5,6,12,34,58**; 2 ; - I X]"" was changed to I X below for IVM*2*56 | S X=$P(IVMSTR("ZPD"),HLFS,9) I X]"",($$FMDATE^HLFNC(X S X=$P(IVMSTR("ZPD"),HLFS,9) I X,($$FMDATE^HLFNC(X)<$ < diff -y --suppress-common-lines ./VADemo/r1/IVMPRECZ.m ./VADemo/r2/r/IVMPRECZ.m IVMPRECZ ;ALB/SEK,RTK - ROUTINE TO PROCESS V1.5 ORF-Z0 | IVMPRECZ ;ALB/SEK,RTK - ROUTINE TO PROCESS V1.5 ORF-Z0 ;;2.0;INCOME VERIFICATION MATCH;**34,64,71**;21-OCT-9 | ;;2.0;INCOME VERIFICATION MATCH;**34,64**;21-OCT-94 S XMSUB="MT SIGNATURE UPLOAD "_$E($P(IVMPAT,"^"),1)_$ | S XMSUB="IVM - MEANS TEST UPLOAD" S IVMTEXT(1)="Unable to upload a MT Signature. A Mea | S IVMTEXT(1)="The following error occured when an Inc S IVMTEXT(2)="matches the Centralized Anniversary Dat | S IVMTEXT(2)="verified Means Test was being uploaded ..S IVMTEXT(6)="Means Test of "_Y_" not found in Vist | ..S IVMTEXT(6)="Means Test of "_Y_" not in DHCP." ..S HLERR="Means test not in VistA" D ACK | ..S HLERR="Means test not in DHCP" D ACK diff -y --suppress-common-lines ./VADemo/r1/IVMPTRN3.m ./VADemo/r2/r/IVMPTRN3.m IVMPTRN3 ;ALB/KCL - SEND INITIAL TRANSMISSION TO IVM C | IVMPTRN3 ;ALB/KCL - SEND INITIAL TRANSMISSION TO IVM C ;;2.0;INCOME VERIFICATION MATCH;**1,9,34,92**; 21-OCT | ;;2.0;INCOME VERIFICATION MATCH;**1,9,34**; 21-OCT-94 ; Check the 301.5 record for Transmission Status | I $$CLEAR^IVMPLOG(IVMPTR,WHEN) ;if successful,IVM PAT N TRSTAT S TRSTAT=+$P(^IVM(301.5,IVMPTR,0),U,3) < ; If this record is not updated, update it only | ; - add TRANSMISSION LOG entry I 'TRSTAT D UPDTLOG(IVMPTR,WHEN,MSGID,.EVENTS,MTSTAT, < ; < ; If this record is already updated, check all other < ; for this patient that should be updated. < I TRSTAT D < .N NXTPTR,NXTYR S NXTPTR=0 < .F S NXTPTR=$O(^IVM(301.5,"B",DFN,NXTPTR)) Q:'NXTPTR < ..Q:NXTPTR=IVMPTR < ..S TRSTAT=+$P(^IVM(301.5,NXTPTR,0),U,3) < ..Q:TRSTAT < ..S NXTYR=$P(^IVM(301.5,NXTPTR,0),U,2) < ..I $$LOG^IVMPLOG(DFN,NXTYR,.EVENTS) < ..D UPDTLOG(NXTPTR,WHEN,MSGID,.EVENTS,MTSTAT,INSSTAT) < ; < Q < ; < UPDTLOG(IVMPTR,WHEN,MSGID,EVENTS,MTSTAT,INSSTAT) ; < ; Update record to TRANSMITTED, and remove duplicates < ; < ; Update the IVM PATIENT (#301.5) record to a TRANSMI < I $$CLEAR^IVMPLOG(IVMPTR,WHEN) < ; < ; Add an entry in the IVM TRANSMISSION LOG (#301.6) F < ; < diff -y --suppress-common-lines ./VADemo/r1/IVMPTRN4.m ./VADemo/r2/r/IVMPTRN4.m IVMPTRN4 ;ALB/SEK - SEND RE-TRANSMISSIONS TO THE IVM C | IVMPTRN4 ;ALB/SEK - SEND RE-TRANSMISSIONS TO THE IVM C ;;2.0;INCOME VERIFICATION MATCH;**9,11,17,34,66,81,86 | ;;2.0;INCOME VERIFICATION MATCH;**9,11,17,34,66**; 21 ENTRY ; Check if message transmission has not been acknowle | ENTRY ; Check if message has not been transmitted in 3 days ; following date range (IVMDMT3 through IVM14) where < ; IVMDMT3 - First Date Checked < ; IVM14 - Last Date Checked < ; < diff -y --suppress-common-lines ./VADemo/r1/IVMPTRN5.m ./VADemo/r2/r/IVMPTRN5.m IVMPTRN5 ;ALB/CPM/GN - NIGHTLY BILLING TRANSMISSION PR | IVMPTRN5 ;ALB/CPM - NIGHTLY BILLING TRANSMISSION PROCE ;;2.0;INCOME VERIFICATION MATCH;**1,9,24,34,69,78,96* | ;;2.0;INCOME VERIFICATION MATCH;**1,9,24,34**; 21-OCT ; < ;IVM*2*96 - break up Z09's by Income year, via new "A < ; < D TRNSMT^EASPTRN5 ;If any EDB Z09's to tra < S ICYR=0 | S DFN=0 F S DFN=$O(^IVM(301.61,"ATR",DFN)) Q:'DFN D F S ICYR=$O(^IVM(301.61,"ATR",ICYR)) Q:'ICYR D < . D BLDZ09(ICYR) < D FILE^IVMPTRN3 < K DFN,IVMPID,IVMTDA,IVMMTDT,IVMN,IVMSTOP,IVMEVENT,IVM < D CLEAN^IVMUFNC < Q < ; < BLDZ09(ICYR) ;create the Z09 per DFN < S DFN=0 < F S DFN=$O(^IVM(301.61,"ATR",ICYR,DFN)) Q:'DFN D < .I $$WHERETO^EASPTRN1(ICYR,DFN) Q ;Do not se < .S IVMTDA=$O(^IVM(301.61,"ATR",ICYR,DFN,0)) | .S IVMTDA=$O(^IVM(301.61,"ATR",DFN,0)) .S IVMTDA=0 F S IVMTDA=$O(^IVM(301.61,"ATR",ICYR,DFN | .S IVMTDA=0 F S IVMTDA=$O(^IVM(301.61,"ATR",DFN,IVMT > D FILE^IVMPTRN3 > K DFN,IVMPID,IVMTDA,IVMMTDT,IVMN,IVMSTOP,IVMEVENT,IVM > D CLEAN^IVMUFNC ; < ;Check DISABLE text in #101 to determine if communica < ; Edb are active or not. Text in this field indicate < ; active < ; < EDB(HLEID) S HLEID=$O(^ORD(101,"B",HLEID,0)) < I 'HLEID Q 0 ;Protoco < I $P(^ORD(101,HLEID,0),"^",3)="" Q 1 ;Edb pro < Q 0 < diff -y --suppress-common-lines ./VADemo/r1/IVMPTRN7.m ./VADemo/r2/r/IVMPTRN7.m IVMPTRN7 ;ALB/KCL/CJM/PHH - HL7 FULL DATA TRANSMISSION | IVMPTRN7 ;ALB/KCL/CJM - HL7 FULL DATA TRANSMISSION (Z0 ;;2.0;INCOME VERIFICATION MATCH;**9,11,24,34,74,88**; | ;;2.0;INCOME VERIFICATION MATCH;**9,11,24,34**;JUL 8, I IVMMTDT="" D < .S IVMMTDT=$P($$LST^DGMTU(DFN,DT),"^",2) < .I IVMMTDT="" S IVMMTDT=DT < ; < ; Don't process records with corrupted nodes | I '$D(^DPT(DFN,0)) Q 0 ; ignore corrupted nodes I '$D(^DPT(DFN,0)) D REM Q 0 < ; < ; < D REM < ; < REM ; Remove Psuedo SSN from Queue < ; Set TRANSMISSION STATUS to transmission not require < S PDATA(.03)=1 I $$UPD^DGENDBS(301.5,IVMDA,.PDATA,.ER < K PDATA,ERR < Q < diff -y --suppress-common-lines ./VADemo/r1/IVMPTRN8.m ./VADemo/r2/r/IVMPTRN8.m IVMPTRN8 ;ALB/RKS/PDJ/BRM/TDM - HL7 FULL DATA TRANSMIS | IVMPTRN8 ;ALB/RKS/PDJ - HL7 FULL DATA TRANSMISSION (Z0 ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,24 | ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,24 N DGINC,DGIR,DGREL,I,IVMNTE,IVMPID,IVMSUB,IVMZRD,VAFP | N DGINC,DGIR,DGREL,I,IVMNTE,IVMPID,IVMSUB,IVMZRD,VAFP N EDBMTZ06,ZMHSQ,SETID < S IVMSEQ="3,5,7,8,11,12,13,14,19" | S IVMPID=$$EN^VAFHLPID(DFN,"1,3,5,7,8,11,12,13,14,19" ; do not transmit seq 11 and 12 if the Bad Address In < ; or other address filters do not pass < S:$$FILTER^IVMPTRN9(DFN) IVMSEQ="3,5,7,8,13,14,19" < S IVMPID=$$EN^VAFHLPID(DFN,"1,"_IVMSEQ) ;add S < .I +$$GETICN^MPIF001(DFN)>0,($$IFLOCAL^MPIF001(DFN)=0 | .I +$$GETICN^MPIF001(DFN)>0,($$IFLOCAL^MPIF001(DFN)=0 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN1^VAFHLZPD(D | S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZPD(DF D EN1^VAFHLZEL(DFN,"1,2,5,6,7,10,11,13,14,15,16,17,18 | S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZEL(DF S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(VAFZEL(1)) ; < F IVMSUB=1:0 S IVMSUB=+$O(VAFZEL(IVMSUB)) Q:'IVMSUB | F IVMSUB=0:0 S IVMSUB=+$O(VAFZEL(IVMSUB)) Q:'IVMSUB ; Optionally create (ZMH) Military History segments | ; Optionally create (ZMH) Military History segment fo D ENTER^VAFHLZMH(DFN,"IVMZMH") | D ENTER^VAFHLZMH(DFN,"IVMZMH","13") S (ZMHSQ,SETID)=0 | I $P(IVMZMH(1,0),HLFS,3)="PH","YN"[$E($P(IVMZMH(1,0), I $D(IVMZMH) F S ZMHSQ=$O(IVMZMH(ZMHSQ)) Q:ZMHSQ="" < .Q:$TR($P(IVMZMH(ZMHSQ,0),HLFS,4,5),"""^~")="" < .S SETID=SETID+1,IVMCT=IVMCT+1 < .S ^TMP("HLS",$J,IVMCT)="ZMH"_HLFS_SETID_HLFS_$P(IVMZ < ; Income Year requiring transmission from IVM Patient < S IVMIY=$S($D(IVMIY):IVMIY,1:(IVMMTDT-10000)) < N MTINFO S MTINFO=$$FUT^DGMTU(DFN) < I ($E(IVMIY,1,3)+1)=$E($P(MTINFO,U,2),1,3) S IVMMTDT= < S EDBMTZ06=0 I $$VERZ06^EASPTRN1(DFN) S EDBMTZ06=1 < I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS < I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^1" < I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HLS < I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HLS < .I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIC^"_$P(^TMP("HL < .I EDBMTZ06 S ^TMP("HLS",$J,IVMCT)="ZIR^"_$P(^TMP("HL < diff -y --suppress-common-lines ./VADemo/r1/IVMPTRN9.m ./VADemo/r2/r/IVMPTRN9.m IVMPTRN9 ;ALB/KCL/CN/BRM/TDM - HL7 FULL DATA TRANSMISS | IVMPTRN9 ;ALB/KCL/CKN/BRM/TDM - HL7 FULL DATA TRANSMIS ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,46 | ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,46 N CPTST,LINK | S SEQS=$S(TESTTYPE=2:"1,2,3,4,9,10,12,15,16,17,18,22, S SEQS="1,17",CPTST=+$$LST^DGMTU(DFN,IVMMTDT,2),LINK= < I LINK=+$$LST^DGMTU(DFN,IVMMTDT,1) S SEQS="1,2,3,4,9, < ; < FILTER(DFN) ; address transmission filter < ; Check Bad Address Indicator for a known bad address < ; Scrutinize the Street Address line 1 field for know < ; strings based on functionality currently in place i < ; < ; Input: DFN - ien of the Patient (#2) file < ; Output: 0 - filter passed (ok to transmit address < ; 1 - filter failed (do not transmit addres < ; < N VAPA < Q:'$G(DFN) 1 ;DFN missing < Q:$$BADADR^DGUTL3(DFN) 1 ;check Bad Address Indicato < D ADD^VADPT ;get patient address < ; Street Address Line 1 or Zip Code is < Q:($G(VAPA(1))="")!($P($G(VAPA(11)),"^")="") 1 < ; St Addr Line 1 contains 'UNKNOWN', 'HOMELESS', or ' < Q:(VAPA(1)["UNKNOWN")!(VAPA(1)["HOMELESS")!(VAPA(1)[" < ; The first two characters of the address is equal to < Q:$E(VAPA(1),1,2)="**" 1 < ; passed all address filters - ok to send < Q 0 < diff -y --suppress-common-lines ./VADemo/r1/IVMPTRNA.m ./VADemo/r2/r/IVMPTRNA.m IVMPTRNA ;ALB/CKN/BRM - HL7 FULL DATA TRANSMISSION (Z0 | IVMPTRNA ;ALB/CKN/BRM - HL7 FULL DATA TRANSMISSION (Z0 ;;2.0;INCOME VERIFICATION MATCH;**46,58,76**; 21-OCT- | ;;2.0;INCOME VERIFICATION MATCH;**46,58**; 21-OCT-94 Q:$$BADADR^DGUTL3(DFN) RETURN < diff -y --suppress-common-lines ./VADemo/r1/IVMPTRN.m ./VADemo/r2/r/IVMPTRN.m IVMPTRN ;ALB/MLI,SEK,RTK,BRM - IVM BACKGROUND JOB/TRANSMISSIO | IVMPTRN ;ALB/MLI,SEK,RTK - IVM BACKGROUND JOB/TRANSMISSIONS T ;;2.0;INCOME VERIFICATION MATCH;**1,9,11,12,17,28,34, | ;;2.0;INCOME VERIFICATION MATCH;**1,9,11,12,17,28,34* ; - auto-upload address changes from #301.5 if >14 da < ; - auto-delete non address changes from #301.5 if >3 < N ADDRDT S ADDRDT(0)=30,ADDRDT(1)=14 D EN^IVMLDEMC(.A < ; < K IVMNODE,IVMPAT,IVMPID,IVMQDT,IVMREC,IVMSTAT,X,%,VAF | K IVMNODE,IVMPAT,IVMPID,IVMQDT,IVMREC,IVMSTAT,X,%,VAF S IVMIY=0 | F IVMDA=0:0 S IVMDA=$O(^IVM(301.5,"ATR",0,IVMDA)) Q:' F S IVMIY=$O(^IVM(301.5,"ATR",0,IVMIY)) Q:'IVMIY D | .; .S IVMDA=0 | .N EVENTS .F S IVMDA=$O(^IVM(301.5,"ATR",0,IVMIY,IVMDA)) Q:'IV | .; - get node, income year, dfn ..; | .S IVMNODE=$G(^IVM(301.5,+IVMDA,0)),IVMDT=+$P(IVMNODE ..N EVENTS | .I 'DFN!'IVMDT Q ..; - get node, income year, dfn | .; ..S IVMNODE=$G(^IVM(301.5,+IVMDA,0)),IVMDT=+$P(IVMNOD | .Q:($$STATUS^IVMPLOG(IVMDA,.EVENTS)=1) ..I 'DFN!'IVMDT Q | .; ..; | .S IVMMTDT=($E(IVMDT,1,3)+1)_"1231.9999" ..Q:($$STATUS^IVMPLOG(IVMDA,.EVENTS)=1) | .; ..; | .; - prepare FULL transmission ..S IVMMTDT=$P($$LST^DGMTU(DFN,($E(IVMDT,1,3)+1)_"123 | .D FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT, ..; < ..; - prepare FULL transmission < ..D FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT < ..S MTIEN=$O(^IVM(301.5,"AC",FDATE,IVMPAT,""),-1) | ..S MTIEN=$O(^IVM(301.5,"AC",FDATE,IVMPAT,0)) ..I '$$FUTURECK("AC",FDATE,IVMPAT,MTIEN) K ^IVM(301.5 | ..Q:'MTIEN ..I DFN S NODE=$$LST^DGMTU(DFN,DT_.9999,1) I $E($P(NO | ..I DFN S NODE=$$LST^DGMTU(DFN,DT_.9999,1) I $E($P(NO ..S MTIEN=$O(^IVM(301.5,"AD",FDATE,IVMPAT,""),-1) | ..S MTIEN=$O(^IVM(301.5,"AD",FDATE,IVMPAT,0)) ..I '$$FUTURECK("AD",FDATE,IVMPAT,MTIEN) K ^IVM(301.5 | ..Q:'MTIEN ..I DFN S NODE=$$LST^DGMTU(DFN,DT_.9999,2) I $E($P(NO | ..I DFN S NODE=$$LST^DGMTU(DFN,DT_.9999,2) I $E($P(NO ; < FUTURECK(TYPE,FDATE,IVMPAT,MTIEN) ; < ; Check the Future MT or CP xref for a valid income t < ; and Delete all invalid xref entries. < N VALID,MTREC S VALID=1,MTREC=0 < ; < ; Remove duplicate entries from cross reference, leav < F S MTREC=$O(^IVM(301.5,TYPE,FDATE,IVMPAT,MTREC)) Q: < ; < I '$D(^IVM(301.5,IVMPAT,0)) S VALID=0 Q VALID < I '$D(^DGMT(408.31,MTIEN,0)) S VALID=0 Q VALID < I FDATE'=+(^DGMT(408.31,MTIEN,0)) S VALID=0 Q VALID < ; < Q VALID < diff -y --suppress-common-lines ./VADemo/r1/IVMUFNC1.m ./VADemo/r2/r/IVMUFNC1.m IVMUFNC1 ;ALB/SEK - INPATIENT/OUTPATIENT CALCULATIONS | IVMUFNC1 ;ALB/SEK - INPATIENT/OUTPATIENT CALCULATIONS ;;2.0;INCOME VERIFICATION MATCH ;**3,11,80**; 21-OCT- | ;;2.0;INCOME VERIFICATION MATCH ;**3,11**; 21-OCT-94 S IVMMTDT=$P($$LST^DGMTU(DFN,IVMMTDT),"^",2) < I '$G(IVMMTDT) G EPQ < diff -y --suppress-common-lines ./VADemo/r1/IVMUFNC.m ./VADemo/r2/r/IVMUFNC.m IVMUFNC ;ALB/MLI/PHH/SCK - IVM GENERIC FUNCTIONS ; 10/15/2004 | IVMUFNC ;ALB/MLI - IVM GENERIC FUNCTIONS ; 12/21/00 3:15pm ;;2.0;INCOME VERIFICATION MATCH;**3,11,17,34,95,94**; | ;;2.0;INCOME VERIFICATION MATCH;**3,11,17,34**;21-OCT Q $S($$INSUR^IBBAPI(DFN,$G(IVMDT))=1:1,1:0) | Q $$INSURED^IBCNS1(DFN,$G(IVMDT)) ; Quit when Outpatient Encounter STATUS is CHECKED OU | Q $S($P(SDOE0,U,12)=2:1,$P(SDOE0,U,12)=14&($P($G(^DPT Q:$P(SDOE0,U,12)=2 1 < ; Quit when Outpatient Encounter STATUS is ACTION REQ < ; Appointment Status is SCHEDULED/KEPT < N DGARRAY,SDCNT,SDSTAT,SDDTTM S DGARRAY("FLDS")=3,DGA < S DGARRAY(1)=$P(SDOE0,U),DGARRAY("SORT")="P",DGARRAY( < S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),SDSTAT="" < I SDCNT>0 D < .S SDDTTM=$O(^TMP($J,"SDAMA301",DGARRAY(4),0)) < .I SDDTTM S SDSTAT=$P($P($G(^TMP($J,"SDAMA301",DGARRA < K ^TMP($J,"SDAMA301") < Q:(($P(SDOE0,U,12)=14)&(SDSTAT="R")) 1 < Q 0 < Only in ./VADemo/r2/r/: JXMRUCX.m diff -y --suppress-common-lines ./VADemo/r1/KMPDBD01.m ./VADemo/r2/r/KMPDBD01.m KMPDBD01 ;OAK/RAK - CM Tools Background Driver ;2/17/0 | KMPDBD01 ;OAK/RAK - CM Tools Background Driver ;3/11/0 ;;2.0;CAPACITY MANAGEMENT TOOLS;**2**;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 N DAILY,STR | N DAILY,ENDT,STDT ; | S STDT=$$NOW^XLFDT,DAILY=$$FMADD^XLFDT(DT,-1) ; update cpu data in file #8973 (CP PARAMETERS) | S ^XTMP("KMPD","BACKGROUND","HL7","DLY","TOTAL","STAR D CPUSET^KMPDUTL6(1) | ; compile and store daily stats in file 8973.1 (CM HL ; < ; hl7 < ;compile and store daily stats in file 8973.1 (CM HL7 < S STR=$$NOW^XLFDT,DAILY=$$FMADD^XLFDT(DT,-1) < D STRSTP^KMPDUTL2(3,1,1,STR) | S ENDT=$$NOW^XLFDT ; | S ^XTMP("KMPD","BACKGROUND","HL7","DLY","TOTAL","END" ; timing | S ^XTMP("KMPD","BACKGROUND","HL7","DLY","TOTAL","DELT ; compile and store timing stats in file 8973.2 (CP T | ; S STR=$$NOW^XLFDT | ; if sunday do weekly compression, transmit data to c D DAILY^KMPDTU02 | ; database, and purge file #8973.1 (cm hl7 data) of o ; store start, stop and delta times for daily backgro | I '$$DOW^XLFDT(DT,1) D D STRSTP^KMPDUTL2(4,1,1,STR) | .S STDT=$$NOW^XLFDT ; | .S ^XTMP("KMPD","BACKGROUND","HL7","WKY","TOTAL","STA ; transmit 'yesterdays' daily stats to national datab | .; weekly compression S STR=$$NOW^XLFDT,DAILY=$$FMADD^XLFDT(DT,-1) | .D WEEKLY^KMPDHU01(DT,1) D DAILY^KMPDTU01(DAILY) | .; store start, stop and delta times for daily backgr ; store start, stop and delta times for daily backgro | .S ENDT=$$NOW^XLFDT D STRSTP^KMPDUTL2(4,2,1,STR) | .S ^XTMP("KMPD","BACKGROUND","HL7","WKY","TOTAL","END ; | .S ^XTMP("KMPD","BACKGROUND","HL7","WKY","TOTAL","DEL ; < ; if sunday < D:'$$DOW^XLFDT(DT,1) SUNDAY < ; < Q < ; < SUNDAY ;-- weekly < ; < N STR < ; < S:'$G(DT) DT=$$DT^XLFDT < ; < ; hl7 - compress & transmit hl7 data to cm national < ; database, and purge file #8973.1 (CM HL7 DATA) of o < S STR=$$NOW^XLFDT < D WEEKLY^KMPDHU01(DT,1) < ; store start, stop and delta times for weekly backgr < D STRSTP^KMPDUTL2(3,2,1,STR) < ; < ; purge entries from file 8973.2 (CP TIMING) < S STR=$$NOW^XLFDT < D PURGE1^KMPDUTL3 < D STRSTP^KMPDUTL2(4,2,2,STR) < Only in ./VADemo/r1/: KMPDENV.m diff -y --suppress-common-lines ./VADemo/r1/KMPDHU01.m ./VADemo/r2/r/KMPDHU01.m KMPDHU01 ;OAK/RAK - CM Tools HL7 Utility ;2/17/04 08: | KMPDHU01 ;OAK/RAK - CM Tools HL7 Utility;1/29/02 09:3 ;;2.0;CAPACITY MANAGEMENT TOOLS;;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 N DATA,DATE,DDLDT,DELDATE,EN,END,HOURS,I,IEN,J,NM,PT, | N DATA,DATE,DELDATE,EN,END,HOURS,I,IEN,J,NM,PT,SITE,S S (START,END)="",STR=$$NOW^XLFDT | S (START,END)="",ST=$$NOW^XLFDT ; days to keep - this is represented by 'weeks to kee < ; so must be converted to days < S DDLDT=$P($G(^KMPD(8973,1,3)),U,11)*7 < S:'DDLDT DDLDT=14 < S DELDATE=$$FMADD^XLFDT(KMPDT,-DDLDT) | S DELDATE=$$FMADD^XLFDT(KMPDT,-14) .S SYNC=0 | .S IEN=0 .F S SYNC=$O(^KMPD(8973.1,"ASYNC",DATE,SYNC)) Q:'SYN | .F S IEN=$O(^KMPD(8973.1,"B",DATE,IEN)) Q:'IEN D ..F S IEN=$O(^KMPD(8973.1,"ASYNC",DATE,SYNC,IEN)) Q: | ..Q:'$D(^KMPD(8973.1,IEN,0)) ...Q:'$D(^KMPD(8973.1,IEN,0)) | ..; data nodes into DATA() array. ...; data nodes into DATA() array. | ..S DATA(0)=^KMPD(8973.1,IEN,0),DATA(1)=$G(^(1)),DATA ...S DATA(0)=^KMPD(8973.1,IEN,0) F I=1,1.1,1.2,2,2.1, | ..; quit if data has already been sent to national da ...; quit if data has already been sent to national d | ..Q:$P(DATA(0),U,2) ...Q:$P(DATA(0),U,2) | ..; quit if no namespace or protocol ...; quit if no namespace or protocol | ..S NM=$P(DATA(0),U,3),PT=$P(DATA(0),U,5) Q:NM=""!(PT ...S NM=$P(DATA(0),U,3),PT=$P(DATA(0),U,5) Q:NM=""!(P | ..; change first piece to start date (this is for nat ...; change first piece to start date (this is for na | ..S $P(DATA(0),U)=START ...S $P(DATA(0),U)=START | ..; second piece not applicable to national database ...; second piece not applicable to national database | ..S $P(DATA(0),U,2)="" ...S $P(DATA(0),U,2)="" | ..; node 99.1 is for national database (end date^faci ...D @$S(SYNC=2:"ASYNC(IEN,NM,PT,.DATA)",1:"SYNC(IEN, | ..S DATA(99.1)=END_"^"_$P(SITE,U,2)_"^"_$P(SITE,U,3) ...; add to processed array. | ..I '$D(ZTQUEUED) W:$X>78 !?16 W "." ...S ^TMP("KMPDHU01",$J,IEN)="" | ..S ^TMP($J,START,NM,PT,0)=DATA(0) > ..F I=0:0 S I=$O(DATA(I)) Q:'I D > ...;W !,$$FMTE^XLFDT(DATE),?15,IEN,",",I,")=",DATA(I) > ...; Add data to get weekly totals. > ...F J=1:1:$S(I=0:4,I=99:6,I=99.1:3,1:9) D > ....S $P(^TMP($J,START,NM,PT,I),U,J)=$P($G(^TMP($J,ST > ..; > ..; Back to IEN level. > ..; Add to processed array. > ..S ^TMP("KMPDHU01",$J,IEN)="" > S ST=$$NOW^XLFDT .K FDA,ERROR W:'$D(ZTQUEUED) "." | .K FDA,ERROR I '$D(ZTQUEUED) W:$X>78 !?16 W "." ; < > S EN=$$NOW^XLFDT > S ^XTMP("KMPD","BACKGROUND","HL7","WKY","UPDT","START > S ^XTMP("KMPD","BACKGROUND","HL7","WKY","UPDT","END") > S ^XTMP("KMPD","BACKGROUND","HL7","WKY","UPDT","DELTA S STR=$$NOW^XLFDT | S ST=$$NOW^XLFDT D STRSTP^KMPDUTL2(3,2,2,STR) | S EN=$$NOW^XLFDT > S ^XTMP("KMPD","BACKGROUND","HL7","WKY","PURGE","STAR > S ^XTMP("KMPD","BACKGROUND","HL7","WKY","PURGE","END" > S ^XTMP("KMPD","BACKGROUND","HL7","WKY","PURGE","DELT Q < ; < ASYNC(IEN,NM,PR,DATA) ; compile asynchronous stats < ;---------------------------------------------------- < ; IEN..... Ien for file #8973.1 (CM HL7 DATA) < ; NM...... Namespace (free text) < ; PR...... Protocol (free text) < ; DATA().. Array containing node data for file #8973. < ;---------------------------------------------------- < Q:'$G(IEN) < Q:$G(NM)="" < Q:$G(PR)="" < Q:'$D(DATA) < N CS,I,J < ; quit if no contact site < S CS=$P(DATA(99.2),U,12) Q:CS="" < S ^TMP($J,START,NM,PR,CS,0)=DATA(0) < ; node 99.1 is for national database (end date^facili < S DATA(99.1)=END_"^"_$P(SITE,U,2)_"^"_$P(SITE,U,3) < ; pieces 6 through 13 of node 99.2 contain text < F I=6:1:13 S $P(^TMP($J,START,NM,PR,CS,99.2),U,I)=$P( < W:'$D(ZTQUEUED) "." < F I=0:0 S I=$O(DATA(I)) Q:'I D < .; 99.1 data not to be totalled < .I I=99.1 F J=1:1:3 S $P(^TMP($J,START,NM,PR,CS,I),U, < .; Add data to get weekly totals. < .E F J=1:1:$S($E(I)=5:24,I=99:6,I=99.2:3,I=99.3:9,99 < ..S $P(^TMP($J,START,NM,PR,CS,I),U,J)=$P($G(^TMP($J,S < SYNC(IEN,NM,PR,DATA) ; compile asynchronous stats < ;---------------------------------------------------- < ; IEN..... Ien for file #8973.1 (CM HL7 DATA) < ; NM...... Namespace (free text) < ; PR...... Protocol (free text) < ; DATA().. Array containing node data for file #8973. < ;---------------------------------------------------- < Q:'$G(IEN) < Q:$G(NM)="" < Q:$G(PR)="" < Q:'$D(DATA) < N I,J < S ^TMP($J,START,NM,PR,0)=DATA(0) < ; node 99.1 is for national database (end date^facili < S DATA(99.1)=END_"^"_$P(SITE,U,2)_"^"_$P(SITE,U,3) < ; pieces 6 through 13 of node 99.2 contain text < F I=6:1:13 S $P(^TMP($J,START,NM,PR,99.2),U,I)=$P(DAT < W:'$D(ZTQUEUED) "." < F I=0:0 S I=$O(DATA(I)) Q:'I D < .; 99.1 data not to be totalled < .I I=99.1 F J=1:1:3 S $P(^TMP($J,START,NM,PR,I),U,J)= < .; Add data to get weekly totals. < .E F J=1:1:$S(I=99:6,1:9) D < ..S $P(^TMP($J,START,NM,PR,I),U,J)=$P($G(^TMP($J,STAR < Q < ; < N C,CPU,HRSDAYS,I,IEN,LN,N,P,S,XMSUB,X,XMTEXT,XMY,XMZ | N HRSDAYS,I,IEN,LN,N,P,S,XMSUB,X,XMTEXT,XMY,XMZ,Y,Z ; version and patch info | ; version and patch info. ; system information < S LN=LN+1,^TMP("KMPDHU01-2",$J,LN)="SYSINFO="_$$SYSIN < ; send cpu data to national database < D CPU^KMPDUTL5(.CPU) I $D(CPU) S I="" F S I=$O(CPU(I < .S LN=LN+1,^TMP("KMPDHU01-2",$J,LN)="CPU="_I_U_CPU(I) < ...; synchronous data | ...F S I=$O(^TMP($J,S,N,P,I)) Q:I="" D ...F S I=$O(^TMP($J,S,N,P,I)) Q:(+I)'=I S LN=LN+1 D | ....S LN=LN+1 ...; asynchronous data < ...S C="-" < ...F S C=$O(^TMP($J,S,N,P,C)) Q:C="" S I="",IEN=IEN < ....F S I=$O(^TMP($J,S,N,P,C,I)) Q:(+I)'=I S LN=LN+ < .....S ^TMP("KMPDHU01-2",$J,LN)=IEN_","_I_")="_^TMP($ < S XMY("S.KMP4-CM-SERVER@FO-ALBANY.MED.VA.GOV")="" | S XMY("S.KMP4-CM-SERVER@ISC-ALBANY.VA.GOV")="" S XMY("CAPACITY,MANAGEMENT@FO-ALBANY.MED.VA.GOV")="" | ;S XMY("CAPACITY,MANAGEMENT@ISC-ALBANY.VA.GOV")="" > S XMY("KAMAROWSKI@ISC-ALBANY.VA.GOV")="" diff -y --suppress-common-lines ./VADemo/r1/KMPDHU02.m ./VADemo/r2/r/KMPDHU02.m KMPDHU02 ;OAK/RAK - CM Tools Compile & File HL7 Daily | KMPDHU02 ;OAK/RAK - CM Tools Compile & File HL7 Daily ;;2.0;CAPACITY MANAGEMENT TOOLS;;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 ;---------------------------------------------------- < ; < Q:'$G(KMPDST) < Q:'$G(KMPDEN) < ; make sure end date has hours < S:'$P(KMPDEN,".",2) $P(KMPDEN,".",2)="99" < S:'$G(DT) DT=$$DT^XLFDT < ; < N ERROR,GBL,GBL1,STR,X < ; < ; get data from hl7 api < W:'$D(ZTQUEUED) !,"Gathering HL7 data..." < ; global with 'raw' hl7 api data < S GBL=$NA(^TMP("KMPDH",$J)) K @GBL < ; set up global to get asynchronous data < K ^TMP($J) < S ^TMP($J,"HLUCM")="DEBUG GLOBAL" < S X=$$CM2^HLUCM(KMPDST,KMPDEN,1,1,"KMPDH","EITHER",.E < I 'X!($D(ERROR))!('$D(^TMP("KMPDH",$J))) D Q < .W:'$D(ZTQUEUED) " no data to report" < ; < ; global for storing compiled data before filing < S GBL1=$NA(^TMP("KMPDH-1",$J)) K @GBL1 < ; < W:'$D(ZTQUEUED) !,"Compiling synchronous HL7 data..." < D SYNC < ; < W:'$D(ZTQUEUED) !,"Compiling asynchronous HL7 data... < D ASYNC < ; < K @GBL,@GBL1,^TMP($J),^TMP("KMPDHERRTIME",$J) < W:'$D(ZTQUEUED) !,"Finished!" < ; < Q < ; < ; < ASYNC ;- asynchronous data < Q:$G(GBL)="" < Q:$G(GBL1)="" < ; < N COUNT,DATA,DATA1,DATA2,HOUR,I,IEN,IEN1,IEN2,J,LOCAL < N OF,PIECE,PR,PTNP,SD,STDT,TIME1,TIME2,UNIT < ; < ; local site name < S LOCAL=$P($$SITE^VASITE,U,2) Q:LOCAL="" < S IEN=0 < F S IEN=$O(^TMP($J,"HLUCMSTORE","U",IEN)) Q:'IEN S < .; data = Protocol~Ien^Namespace < .; message type < .S MSG=$P(DATA,U,6) < .; quit if not 'complete' message < .Q:'$$ASYNCHK(MSG) < .; protocol - check protocol fist, then inferred prot < .S PR=$S($P(DATA,U,7)]"":$P(DATA,U,7),$P(DATA,U,8)]"" < .; namespace - check namespace first, then inferred n < .S NM=$S($P(DATA,U,9)]"":$P(DATA,U,9),$P(DATA,U,10)]" < .; other facility < .S OF=$P(DATA,U,11) S:OF["~" OF=$P(OF,"~",2) Q:OF="" < .; quit if other facility is LOCAL < .Q:OF[LOCAL < .; start date/time < .S STDT=$P(DATA,U,4) Q:'STDT < .; date without time < .S SD=$P(STDT,".") Q:'SD < .S $P(@GBL1@(SD,PR,NM,OF,99.2),U,11)=$P($P(DATA,U,11) < .S $P(@GBL1@(SD,PR,NM,OF,99.2),U,12)=$P($P(DATA,U,11) < .S $P(@GBL1@(SD,PR,NM,OF,99.2),U,13)=$P($P(DATA,U,11) < .; < .S (COUNT,HOUR,IEN1)=0 K UNIT < .F S IEN1=$O(^TMP($J,"HLUCMSTORE","U",IEN,IEN1)) Q:' < ..; data1 = piece 1 - Characters < ..; piece 2 - Messages < ..; piece 3 - Seconds < ..; piece 4 - Begining Time < ..; piece 5 - End Time < ..; piece 6 - Type: msg, ca, aa or ca < ..; piece 7 - Protocol~Ien < ..; piece 8 - Namespace < ..S DATA1=$G(^TMP($J,"HLUCMSTORE","U",IEN,IEN1,"CCC") < ..S COUNT=COUNT+1,UNIT(COUNT)=DATA1 < .; < .; back to IEN level < .; quit if unit() array is not complete < .Q:'$$UNITS(MSG) < .; hour of transaction < .S HOUR=+$E($P(STDT,".",2),1,2),HOUR=HOUR+1 < .; prime time or non-prime time < .S PTNP=$$PTNP^KMPDHU03(STDT) Q:'PTNP < .; node: 5 - prime time < .; 6 - non-prime time < .S NODE=$S(PTNP=2:6,1:5) < .; < .; update msg unit count - prime time or non-prime ti < .S $P(@GBL1@(SD,PR,NM,OF,99.5),U,PTNP)=$P($G(@GBL1@(S < .;update msg unit count - both prime time & non-prime < .S $P(@GBL1@(SD,PR,NM,OF,99.5),U,3)=$P($G(@GBL1@(SD,P < .; totals < .F J=0:0 S J=$O(UNIT(J)) Q:'J F I=1:1:3 D < ..; total < ..S $P(@GBL1@(SD,PR,NM,OF,99.2),U,I)=$P($G(@GBL1@(SD, < ..S $P(@GBL1@(SD,PR,NM,OF,99.3),U,(I+6))=$P($G(@GBL1@ < ..; prime time or non-prime time < ..; ^ piece to set < ..S PIECE=I+$S(PTNP=2:3,1:0) < ..S $P(@GBL1@(SD,PR,NM,OF,99.3),U,PIECE)=$P($G(@GBL1@ < .; < .; msg to ca - originating message to commit ack < .; ^ piece: 1 - characters < .; 2 - count < .; 3 - seconds < .F I=1:1:3 S $P(@GBL1@(SD,PR,NM,OF,NODE+(I*.1)),U,HOU < .; < .; processing time (ca to aa) - commit ack ending tim < .; ack starting time < .S TIME1=+$P(UNIT(3),U,4),TIME2=+$P(UNIT(2),U,5) < .S $P(@GBL1@(SD,PR,NM,OF,(NODE+(.4))),U,HOUR)=$$TIMEA < .; processing time (ca to aa) - count < .S $P(@GBL1@(SD,PR,NM,OF,(NODE+(.5))),U,HOUR)=$P($G(@ < .; < .; aa to ca - application ack to commit ack < .; ^ piece: 1 - characters < .; 2 - count < .; 3 - seconds < .F I=1:1:3 S $P(@GBL1@(SD,PR,NM,OF,NODE+(I+6*.1)),U,H < ; < D:$D(@GBL1) FILE^KMPDHU03(2) < ; < Q < ; < ASYNCHK(KMPDMSG) ;-- extrinsic function - check for 'c < ;---------------------------------------------------- < ; KMPDMGS... message ack designations < ; < ; Return: 0 - not a complete message < ; 1 - complete message < ;---------------------------------------------------- < Q:$G(KMPDMSG)="" 0 < Q:MSG="MSG~CA~AA~CA" 1 < Q:MSG="MSG~CA~AR~CA" 1 < Q:MSG="MSG~AA" 1 < Q 0 < ; < UNITS(MSG) ;-- extrinsic function < ;---------------------------------------------------- < ; MSG.... type of message: 'msg~aa', 'msg~ca~aa~ca', < ; < ; Return: 0 - unit() array not complete < ; 1 - unit() array is complete < ; < ; unit() array must be segmented into the following f < ; unit(1) = msg < ; unit(2) = ca < ; unit(3) = aa < ; unit(4) = ca < ; this data is then used to calculate characters, mes < ;---------------------------------------------------- < Q:$G(MSG)="" 0 < ; all messages must have unit(2) < Q:'$D(UNIT(2)) 0 < ; "msg~ca~aa~ca" & "msg~ca~ar~ca" messages must have < I MSG="MSG~CA~AA~CA"!(MSG="MSG~CA~AR~CA") Q:'$D(UNIT( < I MSG="MSG~CA~AA~CA"!(MSG="MSG~CA~AR~CA") Q:'$D(UNIT( < ; 'msg~aaa' messages contain only 2 unit() entries < ; create 4 unit() entries for processing < I MSG="MSG~AA" D < .S (UNIT(3),UNIT(4))=UNIT(2),UNIT(2)=UNIT(1) < .S $P(UNIT(1),U,1,3)="0^0^0" < .S $P(UNIT(4),U,1,3)="0^0^0" < ; calculate seconds < ; msg to ca < S $P(UNIT(2),U,3)=$$FMDIFF^XLFDT($P(UNIT(2),U,5),$P(U < S:$P(UNIT(2),U,3)<0 $P(UNIT(2),U,3)=0 < ; ca to aa < S $P(UNIT(3),U,3)=$$FMDIFF^XLFDT($P(UNIT(3),U,5),$P(U < S:$P(UNIT(3),U,3)<0 $P(UNIT(3),U,3)=0 < ; aa to ca < S $P(UNIT(4),U,3)=$$FMDIFF^XLFDT($P(UNIT(4),U,5),$P(U < S:$P(UNIT(4),U,3)<0 $P(UNIT(4),U,3)=0 < ; < Q 1 < ; < SYNC ;- synchronous data < ;---------------------------------------------------- < Q:$G(GBL)="" | ; Q:$G(GBL1)="" | Q:'$G(KMPDST) N SS1,SS2,SS3,SS4,SS5,SS6 | Q:'$G(KMPDEN) S SS1="" | ; make sure end date has hours F S SS1=$O(@GBL@(SS1)) Q:SS1="" I SS1'="RFAC" S SS2 | S:'$P(KMPDEN,".",2) $P(KMPDEN,".",2)="99" > S:'$G(DT) DT=$$DT^XLFDT > ; > N END,ERROR,GBL,GBL1,SS1,SS2,SS3,SS4,SS5,SS6,STR,X > ; > ; update ^XTMP("KMPD",0) node to 1 year from today > S ^XTMP("KMPD",0)=DT+10000 > ; get data from hl7 api > W:'$D(ZTQUEUED) !,"Gathering HL7 data..." > ; start time for hl7 api > S STR=$$NOW^XLFDT > S X=$$CM^HLUCM(KMPDST,KMPDEN,1,1,"KMPDH","EITHER",.ER > ; finish time for hl7 api > S END=$$NOW^XLFDT > ; store start time, end time, and delta > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","API","START" > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","API","END")= > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","API","DELTA" > I 'X!($D(ERROR))!('$D(^TMP("KMPDH",$J))) D Q > .W:'$D(ZTQUEUED) " no data to report" > ; > ; start time for compiling data > S STR=$$NOW^XLFDT > W:'$D(ZTQUEUED) !,"Compiling HL7 data into daily stat > ; global for storing compiled data before filing > S GBL1=$NA(^TMP("KMPDH-1",$J)) > K @GBL1 > ; global with 'raw' hl7 api data > S GBL=$NA(^TMP("KMPDH",$J)),SS1="" > F S SS1=$O(@GBL@(SS1)) Q:SS1="" S SS2="" D ......D COMPILE^KMPDHU03 | ......D COMPILE D:$D(@GBL1) FILE^KMPDHU03(1) | ; end compile > S END=$$NOW^XLFDT > ; store start time, end time and delta > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","COMPILE","ST > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","COMPILE","EN > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","COMPILE","DE > ; > ; start time > S STR=$$NOW^XLFDT > D:$D(@GBL1) FILE > ; end time > S END=$$NOW^XLFDT > ; store start time, end time and delta > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","FILE","START > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","FILE","END") > S ^XTMP("KMPD","BACKGROUND","HL7","DLY","FILE","DELTA K @GBL1 | W:'$D(ZTQUEUED) !,"Finished!" > ; > Q > ; > COMPILE ;-compile and store data into GLB1 for filing in file > ;---------------------------------------------------- > ; DATA.... data from GBL array > ; DATE.... date.hr > ; ND...... node where data will be filed in file #897 > ; LC...... up-arrow (^) piece location of data to be > ; NM....... namespace > ; PT...... protocol name~ien > ; PTNP.... prime time - 1 > ; non-prime time 2 > ;---------------------------------------------------- > ; > N DATA,DATE,I,ND,LC,NM,PT,PTNP > ; > Q:'$D(@GBL@(SS1,SS2,SS3,SS4,SS5,SS6)) S DATA=$G(^(SS > ; namespace > S NM=$S(SS1="HR"!(SS1="PROT"):SS5,SS1="NMSP":SS4,1:"" > ; protocol > S PT=$S(SS1="HR"!(SS1="NMSP"):SS6,SS1="PROT":SS4,1:"" > ; prime time - 1, non-prime time - 2 > S DATE=$S(SS1="HR":SS4,SS1="NMSP":SS5,SS1="PROT":SS6, > S PTNP=$$PTNP(DATE) Q:'PTNP > ; > I SS1="HR" D > .S ND=$S(SS2="TM":1,1:""),ND=ND+(PTNP-1) > .S LC=$S(SS3="T":0,SS3="M":3,SS3="U":6,1:"") > I SS1="NMSP" D > .S ND=$S(SS2="IO":1.1,SS2="LR":1.2,1:""),ND=ND+(PTNP- > .S LC=$S(SS3="I"!(SS3="L"):0,SS3="O"!(SS3="R"):3,SS3= > I SS1="PROT" D > .S ND=99,LC=$S(PTNP=1:0,PTNP=2:3,1:"") > ; > ; quit if not node (ND) or location (LC) > Q:'$P(DATE,".")!('ND)!(LC="") > ; > F I=1:1:3 D > .S $P(@GBL1@($P(DATE,"."),PT,NM,ND),U,(I+LC))=$P($G(@ > ;W !,SS1,?6,SS2,?12,SS3,?18,DATE,"-",PTNP,?34,NM,?40, > ; > FILE ;-file data into file 8973.1 (CM HL7 DATA) > ; > Q:'$D(@GBL1) > ; > W:'$D(ZTQUEUED) !,"Filing HL7 stats into file 8973.1 > ; > N DATE,ERROR,FDA,I,IEN,NM,PT,PT1,ZIEN > ; > S DATE=0 > F S DATE=$O(@GBL1@(DATE)) Q:'DATE S PT="" D > .F S PT=$O(@GBL1@(DATE,PT)) Q:PT="" S NM="" D > ..; remove ien (name~123) from protocol > ..S PT1=$P(PT,"~") Q:PT1="" > ..F S NM=$O(@GBL1@(DATE,PT,NM)) Q:NM="" S ND=0 D > ...K ERROR,FDA,IEN,ZIEN > ...; determine if data has already been filed (if ien > ...S IEN=$O(^KMPD(8973.1,"APTDTNM",PT1,DATE,NM,0)) > ...; if filed set IEN="ien," - edit entry > ...; if not filed set IEN="+1," - add entry > ...S IEN=$S(IEN:IEN_",",1:"+1,") > ...S FDA($J,8973.1,IEN,.01)=DATE > ...S FDA($J,8973.1,IEN,.03)=NM > ...S FDA($J,8973.1,IEN,.05)=PT1 > ...F S ND=$O(@GBL1@(DATE,PT,NM,ND)) Q:'ND D > ....S DATA=@GBL1@(DATE,PT,NM,ND) Q:DATA="" > ....F I=1:1:$S(ND=99:6,1:9) S:$P(DATA,U,I)'="" FDA($J > ...; file data > ...D UPDATE^DIE("","FDA($J)","ZIEN","ERROR") > ; > Q > ; > PTNP(DATE) ;-extrinsic function - determine if date.hr i > N DOW,HOUR > ; day of week in numeric format > S DOW=$$DOW^XLFDT(DATE,1) > ; hours > S HOUR=$E($P(DATE,".",2),1,2) > ; prime time - not saturday or sunday or holiday and > ; of 8am (0800) to 5 pm (1700) > Q:DOW'=0&(DOW'=6)&('$G(^HOLIDAY($P(DATE,"."),0)))&(HO > ; non-prime time > Q 2 Only in ./VADemo/r1/: KMPDHU03.m Only in ./VADemo/r1/: KMPDHUA.m diff -y --suppress-common-lines ./VADemo/r1/KMPDPOST.m ./VADemo/r2/r/KMPDPOST.m KMPDPOST ;OAK/RAK - CM Tools Post Install ;4/2/04 08: | KMPDPOST ;OAK/RAK - CM Tools Post Install ;3/11/02 15 ;;2.0;CAPACITY MANAGEMENT TOOLS;**1,2**;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 N ERROR,FDA,ZIEN | D MES^XPDUTL(" Queueing [KMPD BACKGROUND DRIVER] D MES^XPDUTL(" Adding 'Transfer To' data to CP PA | ; make sure option KMPD BACKGROUND DRIVER is queued t ; ad 'transmit to' entries | D QUEBKG^KMPDUTL("KMPD BACKGROUND DRIVER","T+1@0130", ; < ; sagg < K ERROR,FDA,ZIEN < S FDA($J,8973.01,"?+1,1,",.01)="S.KMP1-SAGG-SERVER@FO < ; file data < D UPDATE^DIE("","FDA($J)","ZIEN","ERROR") < ; if error < I $D(ERROR) D MSG^DIALOG("W","",60,10,"ERROR") < ; < ; rum < K ERROR,FDA,ZIEN < S FDA($J,8973.02,"?+1,1,",.01)="S.KMP2-RUM-SERVER@FO- < S FDA($J,8973.02,"?+2,1,",.01)="CAPACITY,MANAGEMENT@F < ; file data < D UPDATE^DIE("","FDA($J)","ZIEN","ERROR") < ; if error < I $D(ERROR) D MSG^DIALOG("W","",60,10,"ERROR") < ; < ; hl7 < K ERROR,FDA,ZIEN < S FDA($J,8973.03,"?+1,1,",.01)="S.KMP4-CM-SERVER@FO-A < S FDA($J,8973.03,"?+2,1,",.01)="CAPACITY,MANAGEMENT@F < ; file data < D UPDATE^DIE("","FDA($J)","ZIEN","ERROR") < ; if error < I $D(ERROR) D MSG^DIALOG("W","",60,10,"ERROR") < ; < ; timing < K ERROR,FDA,ZIEN < S FDA($J,8973.04,"?+1,1,",.01)="S.KMP6-TIMING-SERVER@ < S FDA($J,8973.04,"?+2,1,",.01)="CAPACITY,MANAGEMENT@F < ; file data < D UPDATE^DIE("","FDA($J)","ZIEN","ERROR") < ; if error < I $D(ERROR) D MSG^DIALOG("W","",60,10,"ERROR") < ; < ; < Only in ./VADemo/r1/: KMPDSSA.m diff -y --suppress-common-lines ./VADemo/r1/KMPDSS.m ./VADemo/r2/r/KMPDSS.m KMPDSS ;OAK/RAK - CM Tools Status ;2/17/04 09:04 | KMPDSS ;OAK/RAK - CM Tools Status ;3/11/02 15:17 ;;2.0;CAPACITY MANAGEMENT TOOLS;;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 ; | N DIR,KMPDX,KMPDX1,VERSION,X,Y D DISPLAY^KMPDSSA | S X="KMPDUTL" X ^%ZOSF("TEST") I '$T W !,"The CM Tool ; | S VERSION=$$VERSION^KMPDUTL Q | S X="CM Tools v"_$P(VERSION,U) ; | W @IOF,!?(IOM-$L(X)\2),X VERDSPL(KMPDPKG) ;--display routine version info | ; if patches ;---------------------------------------------------- | I $P(VERSION,U,2)]"" S X=$P(VERSION,U,2) W !?(IOM-$L( ; KMPDPKG... CM Package: | W ! ; "D" - CM Tools | I '$O(^DIC(19,"B","KMPD BACKGROUND DRIVER",0)) D ; "R" - RUM | .W !," The 'CM Tools Background Driver' option [KMPD ; "S" - SAGG < ;---------------------------------------------------- < Q:$G(KMPDPKG)="" < Q:KMPDPKG'="D"&(KMPDPKG'="R")&(KMPDPKG'="S") < N I,X < ; routine check < D VERPTCH^KMPDUTL1(KMPDPKG,.X) < W !?5,$S(KMPDPKG="D":"CM TOOLS",KMPDPKG="R":"RUM",1:" < W " routines",$$REPEAT^XLFSTR(".",28-$X),": " < I '$P($G(X(0)),U,3) W "No Problems" < .W !?20,"Current Version",?55,"Should be" | .S KMPDX=+$O(^DIC(19,"B","KMPD BACKGROUND DRIVER",0)) .S I=0 F S I=$O(X(I)) Q:I="" I $P(X(I),U) D | .S KMPDX=+$O(^DIC(19.2,"B",KMPDX,0)) ..W !?3,I,?20,$P(X(I),U,4) | .; if not scheduled or no task id ..W:$P(X(I),U,5)]"" " - ",$P(X(I),U,5) | .I 'KMPDX!('$G(^DIC(19.2,+KMPDX,1))) D Q:'Y ..W ?55,$P(X(I),U,2) | ..W !?5,"The 'CM Tools Background Driver' [KMPD BACKG ..W:$P(X(I),U,3)]"" " - ",$P(X(I),U,3) | ..K DIR S DIR(0)="YO",DIR("B")="YES" Q | ..S DIR("A")="Do you want to queue this option to run ; | ..W ! D ^DIR Q:'Y PRM ;-- edit parameters file | ..D QUEBKG^KMPDUTL("KMPD BACKGROUND DRIVER","T+1@0130 ; | .S KMPDX=+$O(^DIC(19,"B","KMPD BACKGROUND DRIVER",0)) N DDSFILE,DR,DA | .S KMPDX=+$O(^DIC(19.2,"B",KMPDX,0)) ; | .S KMPDX=$G(^DIC(19.2,KMPDX,0)),KMPDX1=$G(^(1)) S DA=$O(^KMPD(8973,0)) Q:'DA | .S $P(KMPDX,U,2)=$$FMTE^XLFDT($P(KMPDX,U,2)) S DDSFILE=8973,DR="[KMPD PARAMETERS EDIT]" D ^DDS | .W !?5,"CM Tools Background Driver [KMPD BACKGROUND D ; | .W !?5,"QUEUED TO RUN AT.......: ",$P(KMPDX,U,2) Q | .W !?5,"RESCHEDULING FREQUENCY.: ",$P(KMPDX,U,6) ; | .W !?5,"TASK ID................: ",+KMPDX1 SST ;-- start/stop coversheet collection | .; user info. ; check for cprs patch | .S KMPDX1=$G(^%ZTSK(+KMPDX1,0)) I '$$PATCH^XPDUTL("OR*3.0*209") D Q | .W !?5,"QUEUED BY..............: ",$P($G(^VA(200,+$P( .W !! D EN^DDIOL($C(7)_"*** Patch OR*3.0*209 must be | .; quit if no user > .Q:'(+$P(KMPDX1,U,3)) > .; user 'active' or 'terminated' > .S KMPDX1=$$ACTIVE^XUSER(+$P(KMPDX1,U,3)) > .W " (",$S($P(KMPDX1,U,2)["TERMINATED":"Terminated - > W ! > W !?35," # of",?45,"Oldest",?55,"Recent" > W !?5,"File",?35,"Entries",?45," Date",?55," Date" > W !?5,"-------------------------",?35,"-------",?45," > ; file name > W !?5,"8973.1 - CM HL7 DATA" > ; number of entries > W ?35,$J($FN($P($G(^KMPD(8973.1,0)),U,4),",",0),7) > ; oldest date > W ?45,$$FMTE^XLFDT(+$O(^KMPD(8973.1,"B",0)),2) > ; most recent date > W ?55,$$FMTE^XLFDT(+$O(^KMPD(8973.1,"B","A"),-1),2) > ; pause > K DIR S DIR(0)="EO",DIR("A")="Press RETURN to continu > W !! D ^DIR N DIR,STAT,X,Y < S STAT=$G(^KMPTMP("KMPD-CPRS")) < W !!!,"Timing Collection is currently [ ",$S(STAT:"Ru < S DIR(0)="YO",DIR("B")="N" < S DIR("A")="Do you want to '"_$S(STAT:"Stop",1:"Start < D ^DIR Q:'Y < S ^KMPTMP("KMPD-CPRS")=$S(STAT:"",1:1) < W !!,"Timing Collection has been [ ",$S(STAT:"STOPPED < Only in ./VADemo/r1/: KMPDTM.m Only in ./VADemo/r1/: KMPDTP1.m Only in ./VADemo/r1/: KMPDTP2.m Only in ./VADemo/r1/: KMPDTP3.m Only in ./VADemo/r1/: KMPDTP4.m Only in ./VADemo/r1/: KMPDTP5.m Only in ./VADemo/r1/: KMPDTP6.m Only in ./VADemo/r1/: KMPDTP7.m Only in ./VADemo/r1/: KMPDTU01.m Only in ./VADemo/r1/: KMPDTU02.m Only in ./VADemo/r1/: KMPDTU10.m Only in ./VADemo/r1/: KMPDTU11.m Only in ./VADemo/r1/: KMPDU11.m Only in ./VADemo/r1/: KMPDU1.m Only in ./VADemo/r1/: KMPDU2.m Only in ./VADemo/r1/: KMPDU3.m Only in ./VADemo/r1/: KMPDU4.m Only in ./VADemo/r1/: KMPDU5.m Only in ./VADemo/r1/: KMPDUG1.m Only in ./VADemo/r1/: KMPDUG2.m Only in ./VADemo/r1/: KMPDUG.m Only in ./VADemo/r1/: KMPDUGV.m diff -y --suppress-common-lines ./VADemo/r1/KMPDU.m ./VADemo/r2/r/KMPDU.m KMPDU ;OAK/RAK - CM Tools Utility ;2/17/04 09:47 | KMPDU ;OAK/RAK - CM Tools Utility ;3/11/02 15:17 ;;2.0;CAPACITY MANAGEMENT TOOLS;**2**;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 ; < GBLCHECK(GLOBAL) ;-- extrinsic function < ;---------------------------------------------------- < ; GLOBAL.. Global name to be checked. Must be either < ; ^XTMP < ; ^TMP < ; ^UTILITY < ; < ; RESUTL: 0 - Does not pass. < ; 1 - Passes. < ;---------------------------------------------------- < Q:$G(GLOBAL)="" 0 < N GBL,I,RESULT < S RESULT=0 < S GBL=GLOBAL < ;-- remove '^'. < S GBL=$E(GBL,2,$L(GBL)) < ;-- remove '('. < S GBL=$P(GBL,"(") < F I="XTMP","TMP","UTILITY" I GBL=I S RESULT=1 Q < Q RESULT < ; < ; < KILL(RESULT,VARIABLE) ;-- kill variables. < ;---------------------------------------------------- < ; VARIABLE... local or global variable to be killed. < ; < ; This subroutine kills variables (local or global). < ; mostly to kill global variables that have been set < ; have been populated with long lists that were set i < ; globals. If VARIABLE is a global variable, it must < ; ^UTILITY to be killed. < ;---------------------------------------------------- < K RESULT S RESULT="" < I $G(VARIABLE)="" S RESULT="[No variable to kill]" Q < I $E(VARIABLE)="^" D Q:RESULT]"" < .I '$$GBLCHECK(VARIABLE) D < ..S RESULT="[Can only kill globals ^XTMP, ^TMP or ^UT < K @VARIABLE < S RESULT="<"_VARIABLE_" killed>" < Q < ; < TIMEADD(KMPDTM,KMPDADD) ;-- extrinsic function - add time < ;---------------------------------------------------- < ; KMPDTM... Current time in dy hr:mn:sc format < ; KMPDTM... Time to add to current time in dy hr:mn:s < ; < ; RETURN: total in dy hr:mn:sc format < ;---------------------------------------------------- < Q:$G(KMPDTM)="" "" < Q:$G(KMPDADD)="" KMPDTM < N DY,HR,MN,SC < ; current time < S DY(1)=+$P(KMPDTM," ") < S HR(1)=+$P($P(KMPDTM," ",2),":") < S MN(1)=+$P($P(KMPDTM," ",2),":",2) < S SC(1)=+$P($P(KMPDTM," ",2),":",3) < ; time to be added < S DY(2)=+$P(KMPDADD," ") < S HR(2)=+$P($P(KMPDADD," ",2),":") < S MN(2)=+$P($P(KMPDADD," ",2),":",2) < S SC(2)=+$P($P(KMPDADD," ",2),":",3) < ; add seconds < S SC(3)=SC(1)+SC(2) < ; if greater than 59 seconds < I SC(3)>59 S MN(3)=SC(3)\60,SC(3)=SC(3)-60 < ; add minutes < S MN(3)=$G(MN(3))+MN(1)+MN(2) < ; if greater than 59 minutes < I MN(3)>59 S HR(3)=MN(3)\60,MN(3)=MN(3)-60 < ; add hours < S HR(3)=$G(HR(3))+HR(1)+HR(2) < ; if greater than 23 hours < I HR(3)>23 S DY(3)=HR(3)\24,HR(3)=HR(3)-24 < ; days < S DY(3)=$G(DY(3))+DY(1)+DY(2) < ; < Q DY(3)_" "_HR(3)_":"_MN(3)_":"_SC(3) < diff -y --suppress-common-lines ./VADemo/r1/KMPDUT2.m ./VADemo/r2/r/KMPDUT2.m KMPDUT2 ;OAK/RAK - CM Tools Utility ;2/17/04 10:45 | KMPDUT2 ;OAK/RAK - CM Tools Utility ;3/11/02 15:17 ;;2.0;CAPACITY MANAGEMENT TOOLS;;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 S DATA=$G(^KMPD(8973.1,+KMPDIEN,0)),DATA(99.2)=$G(^(9 | S DATA=$G(^KMPD(8973.1,+KMPDIEN,0)) Q:DATA="" S TXT(1)=TXT(1)_$J(" ",52-$L(TXT(1))) < ; synch/asynch < S TXT(1)=TXT(1)_$S($P(DATA,U,6)=1:"sync",1:"async") < ; other site number < I $P(DATA(99.2),U,12)'="" D < .S TXT(2)=$P(DATA(99.2),U,12) < .S TXT(2,"F")="!?41" < ID1(KMPDIEN) ;--called from ^DD(8973.2,0,"ID","W") < ;---------------------------------------------------- < ; KMPDIEN... Ien for file #8973.2 (CM TIMING) < ;---------------------------------------------------- < Q:'$G(KMPDIEN) < Q:'$D(^KMPD(8973.2,+KMPDIEN,0)) < N DATA,TXT < S DATA=$G(^KMPD(8973.2,+KMPDIEN,0)) Q:DATA="" < S TXT(1)="" < ; date/time < S TXT(1)=TXT(1)_$$FMTE^XLFDT($P(DATA,U,3),2) < S TXT(1)=TXT(1)_$J(" ",18-$L(TXT(1))) < ; title < S TXT(1)=TXT(1)_$E($P(DATA,U,8),1,16) < ; client name < S TXT(2)=$E($P(DATA,U,6),1,30) < ; person < S TXT(3)=$P($G(^VA(200,+$P(DATA,U,5),0)),U) < ; sent to national database < S TXT(4)="weekly - "_$S($P(DATA,U,2):"sent",1:"not se < S TXT(5)="daily - "_$S($P(DATA,U,10):"sent",1:"not se < ;S TXT(1)=TXT(1)_$J(" ",11-$L(TXT(1))) < S TXT(1,"F")="?45" < S TXT(2,"F")="!?48" < S TXT(3,"F")="!?48" < S TXT(4,"F")="!?48" < S TXT(5,"F")="!?48" < D EN^DDIOL(.TXT) < Q < ; < ; < XREF1(DA,X,KMPDTYPE) ;-set/kill 'ACSDTPRNM' xref in file # < ;---------------------------------------------------- < ; DA....... Ien for file #8973.1 (CM HL7 DATA) < ; X........ Value of field #99.212 (CONTACTED SITE NA < ; KMPDTYPE. 1 - set xref < ; 2 - kill xref < ; < ; variables used: < ; DATE.. Internal value of field #.01 (DATE) < ; NM.... Internal value of field #.03 (NAMESPACE) < ; PR.... Internal value of field #.05 (PROTOCOL) < ;---------------------------------------------------- < Q:'$G(DA) < Q:$G(X)="" < Q:'$G(KMPDTYPE) < N DATA,DATE,NM,PR < S DATA=$G(^KMPD(8973.1,DA,0)) Q:DATA="" < S DATE=$P(DATA,U) Q:'DATE < S NM=$P(DATA,U,3) Q:NM="" < S PR=$P(DATA,U,5) Q:PR="" < I KMPDTYPE=1 S ^KMPD(8973.1,"ACSDTPRNM",X,DATE,PR,NM, < I KMPDTYPE=2 K ^KMPD(8973.1,"ACSDTPRNM",X,DATE,PR,NM, < Q < ; < XREF2(DA,X,KMPDTYPE) ;-set/kill 'ASYNC' xref in file #8973 < ;---------------------------------------------------- < ; DA....... Ien for file #8973.1 (CM HL7 DATA) < ; X........ Value of field #.06 (SYNC/ASYNC) < ; KMPDTYPE. 1 - set xref < ; 2 - kill xref < ; < ; variables used: < ; DATE.. Internal value of field #.01 (DATE) < ;---------------------------------------------------- < Q:'$G(DA) < Q:$G(X)="" < Q:'$G(KMPDTYPE) < N DATA,DATE < S DATA=$G(^KMPD(8973.1,DA,0)) Q:DATA="" < S DATE=$P(DATA,U) Q:'DATE < I KMPDTYPE=1 S ^KMPD(8973.1,"ASYNC",DATE,X,DA)="" < I KMPDTYPE=2 K ^KMPD(8973.1,"ASYNC",DATE,X,DA) < Q < ; < XREFT1(DA,X,KMPDTYPE) ;-set/kill 'ASVDTSS' xref in file #89 < ;---------------------------------------------------- < ; DA....... Ien for file #8973.2 (CM TIMING) < ; X........ Value of field #.07 (SERVER SUBSCRIPT) < ; KMPDTYPE. 1 - set xref < ; 2 - kill xref < ;---------------------------------------------------- < Q:'$G(DA) < Q:$G(X)="" < Q:'$G(KMPDTYPE) < N DATA,DATE < S DATA=$G(^KMPD(8973.2,DA,0)) Q:DATA="" < ; strip off time < S DATE=$P($P(DATA,U,3),".") Q:'DATE < I KMPDTYPE=1 S ^KMPD(8973.2,"ASVDTSS",X,DATE,DA)="" < I KMPDTYPE=2 K ^KMPD(8973.2,"ASVDTSS",X,DATE,DA) < Q < ; < XREFT2(DA,X,KMPDTYPE) ;-set/kill 'ASSDTPT' xref in file #89 < ;---------------------------------------------------- < ; DA....... Ien for file #8973.2 (CM TIMING) < ; X........ Value of field #.07 (SERVER SUBSCRIPT) < ; KMPDTYPE. 1 - set xref < ; 2 - kill xref < ; < ; ^KMPD(8973.2,"ASSDTPT",ServerSubscript,ServerStartD < ;---------------------------------------------------- < Q:'$G(DA) < Q:$G(X)="" < Q:'$G(KMPDTYPE) < N DATA,DATE,PTNP < S DATA=$G(^KMPD(8973.2,DA,0)) Q:DATA="" < ; server start date/time < S DATE=$P(DATA,U,3) Q:'DATE < ; prime time / non-prime time < S PTNP=$$PTNP^KMPDHU03(DATE) Q:'PTNP < ; strip off time < S DATE=$P(DATE,".") Q:'DATE < I KMPDTYPE=1 S ^KMPD(8973.2,"ASSDTPT",X,DATE,PTNP,DA) < I KMPDTYPE=2 K ^KMPD(8973.2,"ASSDTPT",X,DATE,PTNP,DA) < Q < ; < XREFT3(DA,X,KMPDTYPE) ;-set/kill 'ASSDTTM' xref in file #89 < ;---------------------------------------------------- < ; DA....... Ien for file #8973.2 (CM TIMING) < ; X........ Value of field #.07 (SERVER SUBSCRIPT) < ; KMPDTYPE. 1 - set xref < ; 2 - kill xref < ; < ; ^KMPD(8973.2,"ASSDTTM",ServerSubscript,ServerStartD < ;---------------------------------------------------- < Q:'$G(DA) < Q:$G(X)="" < Q:'$G(KMPDTYPE) < N DATA,DATE < S DATA=$G(^KMPD(8973.2,DA,0)) Q:DATA="" < ; server start date/time < S DATE=$P(DATA,U,3) Q:'DATE < I KMPDTYPE=1 S ^KMPD(8973.2,"ASSDTTM",X,DATE,DA)="" < I KMPDTYPE=2 K ^KMPD(8973.2,"ASSDTTM",X,DATE,DA) < Q < ; < XREFT4(DA,X,KMPDTYPE) ;-set/kill 'ASSCLDTTM' xref in file # < ;---------------------------------------------------- < ; DA....... Ien for file #8973.2 (CM TIMING) < ; X........ Value of field #.07 (KMPTMP SUBSCRIPT) < ; KMPDTYPE. 1 - set xref < ; 2 - kill xref < ; < ; ^KMPD(8973.2,"ASSCLDTTM",KmptmpSubscript,ClientName < ;---------------------------------------------------- < Q:'$G(DA) < Q:$G(X)="" < Q:'$G(KMPDTYPE) < N CLNM,DATA,DATE < S DATA=$G(^KMPD(8973.2,DA,0)) Q:DATA="" < ; server start date/time < S DATE=$P(DATA,U,3) Q:'DATE < ; client name < S CLNM=$P(DATA,U,6) Q:CLNM="" < I KMPDTYPE=1 S ^KMPD(8973.2,"ASSCLDTTM",X,CLNM,DATE,D < I KMPDTYPE=2 K ^KMPD(8973.2,"ASSCLDTTM",X,CLNM,DATE,D < Q < XREFT5(DA,X,KMPDTYPE) ;-set/kill 'ASSNPDTTM' xref in file # < ;---------------------------------------------------- < ; DA....... Ien for file #8973.2 (CM TIMING) < ; X........ Value of field #.07 (KMPTMP SUBSCRIPT) < ; KMPDTYPE. 1 - set xref < ; 2 - kill xref < ; < ; ^KMPD(8973.2,"ASSNPDTTM",KmptmpSubscript,NewPerson, < ;---------------------------------------------------- < Q:'$G(DA) < Q:$G(X)="" < Q:'$G(KMPDTYPE) < N NP,DATA,DATE < S DATA=$G(^KMPD(8973.2,DA,0)) Q:DATA="" < ; server start date/time < S DATE=$P(DATA,U,3) Q:'DATE < ; new person < S NP=$P(DATA,U,5) Q:NP="" < I KMPDTYPE=1 S ^KMPD(8973.2,"ASSNPDTTM",X,NP,DATE,DA) < I KMPDTYPE=2 K ^KMPD(8973.2,"ASSNPDTTM",X,NP,DATE,DA) < Q < ; < XREFT6(DA,X,KMPDTYPE) ;-set/kill 'ASSIPDTTM' xref in file # < ;---------------------------------------------------- < ; DA....... Ien for file #8973.2 (CM TIMING) < ; X........ Value of field #.07 (KMPTMP SUBSCRIPT) < ; KMPDTYPE. 1 - set xref < ; 2 - kill xref < ; < ; ^KMPD(8973.2,"ASSIPDTTM",KmptmpSubscript,IpAddress, < ;---------------------------------------------------- < Q:'$G(DA) < Q:$G(X)="" < Q:'$G(KMPDTYPE) < N IP,DATA,DATE < S DATA=$G(^KMPD(8973.2,DA,0)) Q:DATA="" < ; server start date/time < S DATE=$P(DATA,U,3) Q:'DATE < ; ip address < S IP=$P(DATA,U,9) Q:IP="" < I KMPDTYPE=1 S ^KMPD(8973.2,"ASSIPDTTM",X,IP,DATE,DA) < I KMPDTYPE=2 K ^KMPD(8973.2,"ASSIPDTTM",X,IP,DATE,DA) < Q < Only in ./VADemo/r1/: KMPDUT4A.m Only in ./VADemo/r1/: KMPDUT4B.m Only in ./VADemo/r1/: KMPDUT4C.m Only in ./VADemo/r1/: KMPDUT4.m Only in ./VADemo/r1/: KMPDUT5.m Only in ./VADemo/r1/: KMPDUTL1.m Only in ./VADemo/r1/: KMPDUTL2.m diff -y --suppress-common-lines ./VADemo/r1/KMPDUTL3.m ./VADemo/r2/r/KMPDUTL3.m KMPDUTL3 ;OAK/RAK - CM Tools Utility ;2/17/04 10:53 | KMPDUTL3 ;OAK/RAK - CM Tools Utility ;3/11/02 15:18 ;;2.0;CAPACITY MANAGEMENT TOOLS;;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 ; < PURGE1 ;-- purge data in file #8973.2 < ; < N DA,DATE,DAYS,DIK,IEN,PURGE < ; < ; days to keep data (weeks * 7) < S DAYS=$P($G(^KMPD(8973,1,4)),U,11) < S:'DAYS DAYS=4 S DAYS=DAYS*7 < ; determine date to start purge < S PURGE=$$FMADD^XLFDT(DT,-DAYS) Q:'PURGE < W:'$D(ZTQUEUED) !!,"Purging old records..." < S DATE=PURGE-.1 < F S DATE=$O(^KMPD(8973.2,"C",DATE),-1) Q:'DATE!(DATE < .F IEN=0:0 S IEN=$O(^KMPD(8973.2,"C",DATE,IEN)) Q:'IE < ..Q:'$D(^KMPD(8973.2,IEN,0)) < ..W:'$D(ZTQUEUED)&('(IEN#10)) "." < ..; delete entry. < ..S DA=IEN,DIK="^KMPD(8973.2," D ^DIK < ; < Q < Only in ./VADemo/r1/: KMPDUTL4.m Only in ./VADemo/r1/: KMPDUTL5.m Only in ./VADemo/r1/: KMPDUTL6.m Only in ./VADemo/r1/: KMPDUTL7.m Only in ./VADemo/r1/: KMPDUTL8.m diff -y --suppress-common-lines ./VADemo/r1/KMPDUTL.m ./VADemo/r2/r/KMPDUTL.m KMPDUTL ;OAK/RAK - CM Tools Utility ;2/17/04 10:50 | KMPDUTL ;OAK/RAK - CM Tools Utility ;3/11/02 15:18 ;;2.0;CAPACITY MANAGEMENT TOOLS;**1,2**;Mar 22, 2002 | ;;1.0;CM TOOLS;;Mar 11, 2002 ; < VRSNGET(KMPDAPPL) ;-- extrinsic function - get version^ < ;---------------------------------------------------- < ; KMPDAPPL... application: < ; 0 - CM Tools < ; 1 - SAGG < ; 2 - RUM < ; < ; Return: Version^Patch^VersionInstallDate^PatchInsta < ; null = no application < ;---------------------------------------------------- < ; < Q:$G(KMPDAPPL)="" "" < Q:KMPDAPPL<0!(KMPDAPPL>2) "" < ; < N DATA,VERSION S VERSION="" < ; < ; cm tools < I KMPDAPPL=0 D < .S DATA=$G(^KMPD(8973,1,KMPDAPPL)) < .S VERSION=$P(DATA,U,2)_U_$P(DATA,U,4)_U_$P(DATA,U,3) < ; < ; all other applications < E D < .S DATA=$G(^KMPD(8973,1,KMPDAPPL)) < .S VERSION=$P(DATA,U)_U_$P(DATA,U,3)_U_$P(DATA,U,2)_U < ; < Q VERSION < ; < PTCHINFO ; -- patch information: routine name ^ curren < ;;KMPDBD01^2.0^**2** < ;;KMPDHU01^2.0 < ;;KMPDHU02^2.0 < ;;KMPDHU03^2.0 < ;;KMPDHUA^2.0 < ;;KMPDSS^2.0 < ;;KMPDSSA^2.0^**1,2** < ;;KMPDTM^2.0^**1** < ;;KMPDTP1^2.0 < ;;KMPDTP2^2.0 < ;;KMPDTP3^2.0 < ;;KMPDTP4^2.0 < ;;KMPDTP5^2.0 < ;;KMPDTP6^2.0 < ;;KMPDTP7^2.0 < ;;KMPDTU01^2.0 < ;;KMPDTU02^2.0 < ;;KMPDTU10^2.0 < ;;KMPDTU11^2.0 < ;;KMPDU^2.0^**2** < ;;KMPDU1^2.0 < ;;KMPDU2^2.0^**2** < ;;KMPDU3^2.0^**2** < ;;KMPDU4^2.0 < ;;KMPDU5^2.0^**2** < ;;KMPDU11^2.0 < ;;KMPDUG^2.0 < ;;KMPDUG1^2.0 < ;;KMPDUG2^2.0 < ;;KMPDUGV^2.0 < ;;KMPDUT^2.0 < ;;KMPDUT2^2.0 < ;;KMPDUT4^2.0 < ;;KMPDUT4A^2.0 < ;;KMPDUT4B^2.0 < ;;KMPDUT4C^2.0 < ;;KMPDUT5^2.0 < ;;KMPDUTL^2.0^**1,2** < ;;KMPDUTL1^2.0 < ;;KMPDUTL2^2.0 < ;;KMPDUTL3^2.0 < ;;KMPDUTL4^2.0 < ;;KMPDUTL5^2.0 < ;;KMPDUTL6^2.0 < ;;KMPDUTL7^2.0^**2** < ;;KMPDUTL8^2.0^**2** < Only in ./VADemo/r1/: KMPDUT.m diff -y --suppress-common-lines ./VADemo/r1/KMPRBD01.m ./VADemo/r2/r/KMPRBD01.m KMPRBD01 ;OAK/RAK - RUM Daily/Weekly Compression ;5/28 | KMPRBD01 ;SFISC/RAK - RUM Daily/Weekly Compression ;1/ ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;**1**;Dec 09, 1998 > ; Protect ^XTMP("KMPR") from the XQ82 background clea > S ^XTMP("KMPR",0)=DT+10000 N ENDT,STDT | S:'$G(DT) DT=$$DT^XLFDT S STDT=$$NOW^XLFDT < ; store daily stats in file #8971.1 (RESOURCE USAGE M < S ^KMPTMP("KMPR","BACKGROUND","DAILY","TOTAL","START" < > ; store daily stats in file #8971.1 (RESOURCE USAGE M > S ^XTMP("KMPR","BACKGROUND","START")=$$FMTE^XLFDT($$N > S ^XTMP("KMPR","BACKGROUND","STOP")="" ; | S ^XTMP("KMPR","BACKGROUND","STOP")=$$FMTE^XLFDT($$NO ; store start, stop and delta times for daily backgro < S ENDT=$$NOW^XLFDT S:ENDT="" ENDT="00:00:00" < S ^KMPTMP("KMPR","BACKGROUND","DAILY","TOTAL","STOP") < S ^KMPTMP("KMPR","BACKGROUND","DAILY","TOTAL","DELTA" < .S STDT=$$NOW^XLFDT | .S ^XTMP("KMPR","BACKGROUND","WEEKLY","START")=$$FMTE .S ^KMPTMP("KMPR","BACKGROUND","WEEKLY","TOTAL","STAR | .S ^XTMP("KMPR","BACKGROUND","WEEKLY","STOP")="" .; | .D WEEKLY^KMPRBD02(DT) .D WEEKLY^KMPRBD04(DT) | .S ^XTMP("KMPR","BACKGROUND","WEEKLY","STOP")=$$FMTE^ .; < .; store start, stop and delta times for weekly backg < .S ENDT=$$NOW^XLFDT < .S ^KMPTMP("KMPR","BACKGROUND","WEEKLY","TOTAL","STOP < .S ^KMPTMP("KMPR","BACKGROUND","WEEKLY","TOTAL","DELT < F S NODE=$O(^KMPTMP("KMPR","JOB",NODE)) Q:NODE="" D | F S NODE=$O(^XTMP("KMPR","JOB",NODE)) Q:NODE="" D ..I '$D(^XUTL("XQ",JOB)) K ^KMPTMP("KMPR","JOB",NODE, | ..I '$D(^XUTL("XQ",JOB)) K ^XTMP("KMPR","JOB",NODE,JO K ^KMPTMP("KMPR","ERR") | K ^XTMP("KMPR","ERR") diff -y --suppress-common-lines ./VADemo/r1/KMPRBD02.m ./VADemo/r2/r/KMPRBD02.m KMPRBD02 ;OAK/RAK - RUM Data Compression ;5/28/03 08: | KMPRBD02 ;SF/RAK - RUM Data Compression ;1/20/00 07:3 ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;**1**;Dec 09, 1998 N COUNT,CNT,CNT1,CNT2,DATA,FMHDATE,HDATE,HTIME,I,JOB, | N ARRAY,COUNT,DATA,DOW,HDATE,HTIME,I,JOB,MESSAGE,NODE N NODE,NW,OKAY,OPTION,NP,PT,PTM,X,VAR,USERS,USRDATA,W | N NP,PT,PTM,X,VAR ; < K ^TMP($J) < ; | ; where daily data is located. ; yesterday - this will be the data that is compiled | S ARRAY=$NA(^XTMP("KMPR","DLY")) S YSTRDAY=$$HADD^XLFDT(KMPRTDAY,-1) < ; < F S NODE=$O(^KMPTMP("KMPR","DLY",NODE)) Q:NODE="" D | F S NODE=$O(@ARRAY@(NODE)) Q:NODE="" D .F S HDATE=$O(^KMPTMP("KMPR","DLY",NODE,HDATE)) Q:HD | .F S HDATE=$O(@ARRAY@(NODE,HDATE)) Q:HDATE=""!(HDATE ..; if less than 'yesterday' kill - old data < ..I HDATE ; quit if not sunday. > Q:$$DOW^XLFDT(KMPRDT,1) > ; storage array. > S TMPARRY=$NA(^TMP($J)) > ; processed entries. > S TMPARRY1=$NA(^TMP("KMPR PROC",$J)) > K @TMPARRY,@TMPARRY1 > ; site info. > S SITE=$$SITE^VASITE Q:SITE="" > S DATE=KMPRDT > S (START,END)="" > ; Date to begin deletion. > S DELDATE=$$FMADD^XLFDT(KMPRDT,-14) > ; > W:'$D(ZTQUEUED) !,"Compressing data into weekly forma > ; Reverse $order to get previous dates. > F S DATE=$O(^KMPR(8971.1,"B",DATE),-1) Q:'DATE D > .; If DATE is saturday set START and END dates and ki > .I $$DOW^XLFDT(DATE,1)=6 D > ..S END=DATE,START=$$FMADD^XLFDT(DATE,-6) > ..K @TMPARRY > .Q:'START > .S IEN=0 > .F S IEN=$O(^KMPR(8971.1,"B",DATE,IEN)) Q:'IEN D > ..Q:'$D(^KMPR(8971.1,IEN,0)) > ..; data nodes into DATA() array. > ..S DATA(0)=^KMPR(8971.1,IEN,0),DATA(1)=$G(^(1)),DATA > ..; Quit if data has already been sent to national da > ..Q:$P(DATA(0),U,2) > ..; Cpu node. > ..S NODE=$P(DATA(0),U,3) Q:NODE="" > ..; OPTION = OptionName^ProtocolName. > ..; option. > ..S OPTION=$P(DATA(0),U,4) > ..; rpc. > ..S:OPTION="" OPTION=$P(DATA(0),U,7) > ..; hl7. > ..S:OPTION="" OPTION=$P(DATA(0),U,9) > ..Q:OPTION="" > ..S $P(OPTION,U,2)=$P(DATA(0),U,5) > ..S @TMPARRY@(START,NODE,OPTION,0)=DATA(0) > ..; change first piece to starting date (START) > ..S $P(@TMPARRY@(START,NODE,OPTION,0),U)=START > ..; second piece not applicable to national database > ..S $P(@TMPARRY@(START,NODE,OPTION,0),U,2)="" > ..; EndingDate^SiteName^SiteNumber. > ..S @TMPARRY@(START,NODE,OPTION,99)=END_U_$P(SITE,U,2 > ..; Nodes 1 and 2. > ..F I=1,2 I DATA(I)]"" D > ...; Add data to get weekly totals. > ...F J=1:1:8 S $P(@TMPARRY@(START,NODE,OPTION,I),U,J) ..; file number of users information | ..; Back to IEN level. ..D FILE^KMPRBD03(HDATE,NODE,"#USERS#",.WD,.NW) | ..; Add to processed array. > ..S @TMPARRY1@(IEN)="" > .; > .; Back to DATE level. > .; If START then transmit data. > .I DATE=START I $D(@TMPARRY) D TRANSMIT K @TMPARRY > ; > ; Transmit data to national database. > W:'$D(ZTQUEUED) !,"Transmitting data to national data > D:$D(@TMPARRY) TRANSMIT > K @TMPARRY > ; > ; update field .02 (SENT TO CM NATIONAL DATABASE) to > ; processed entries. > W:'$D(ZTQUEUED) !,"Updating records to reflect transm > S IEN=0 > F S IEN=$O(@TMPARRY1@(IEN)) Q:'IEN D > .K FDA,ERROR > .S FDA($J,8971.1,IEN_",",.02)=1 > .D FILE^DIE("","FDA($J)","ERROR") > K @TMPARRY1 > ; > ; leave two complete weeks of data in file #8971.1 > D PURGE^KMPRUTL3(DELDATE,1) > ; > Q > ; > TRANSMIT ;-- format TMPARRY data, put into e-mail and > ; > Q:$G(TMPARRY)="" > ; > N HRSDAYS,I,IEN,LN,N,O,S,UPLDARRY,XMSUB,X,XMTEXT,XMY, > ; > S UPLDARRY=$NA(^TMP("KMPR UPLOAD",$J)) > K @UPLDARRY K ^TMP($J) | S LN=0 > ; version and patch info. > S LN=LN+1,@UPLDARRY@(LN)="VERSION="_$$VERSION^KMPRUTL > ; > ; get hours/days data > D HRSDAYS^KMPRUTL3(START,END,1,.HRSDAYS) > ; if ^XTMP("KMPR","HOURS","START") exists then this i > ; the "HOURS" subscript is being accessed. chances a > ; partial data, so it should be ignored. > I $G(^XTMP("KMPR","HOURS","START"))&($D(HRSDAYS)) D > .K HRSDAYS,^XTMP("KMPR","HOURS","START") > ; > I $D(HRSDAYS) S S=0 D > .F S S=$O(HRSDAYS(S)) Q:'S S N="" D > ..F S N=$O(HRSDAYS(S,N)) Q:N="" D > ...S LN=LN+1 > ...; StartDate^Node^EndDate^PTDays^PTHours^NPTDays^NP > ...S @UPLDARRY@(LN)="HRSDAYS="_START_"^"_N_"^"_END_"^ > ; > ; reformat so that data is in ^TMP("KMPR UPLOAD",$J,L > S IEN=0,S="" > F S S=$O(@TMPARRY@(S)) Q:S="" S N="" D > .F S N=$O(@TMPARRY@(S,N)) Q:N="" S O="" D > ..F S O=$O(@TMPARRY@(S,N,O)) Q:O="" S I="",IEN=IEN+ > ...F S I=$O(@TMPARRY@(S,N,O,I)) Q:I="" D > ....S LN=LN+1 > ....S @UPLDARRY@(LN)=IEN_","_I_")="_@TMPARRY@(S,N,O,I > ; > ; quit if no data to transmit. > Q:'$D(@UPLDARRY) > ; send packman message. > S XMTEXT="^TMP(""KMPR UPLOAD"","_$J_"," > S XMSUB="RUM DATA - "_$P(SITE,U,2)_" ("_$P(SITE,U,3)_ > S XMY("S.KMP2-RUM-SERVER@ISC-ALBANY.VA.GOV")="" > S XMY("CAPACITY,MANAGEMENT@ISC-ALBANY.VA.GOV")="" > D ^XMD > W:'$D(ZTQUEUED) !,"Message #",$G(XMZ)," sent..." > K @UPLDARRY diff -y --suppress-common-lines ./VADemo/r1/KMPRBD03.m ./VADemo/r2/r/KMPRBD03.m KMPRBD03 ;OAK/RAK - Resource Usage Monitor Data Compre | KMPRBD03 ;SFISC/RAK - Resource Usage Monitor Data Comp ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;;Dec 09, 1998 ; KMPRPT().... Array for Prime Time data - passed by | ; KMPRPT...... Prime Time Data (8 elements) ; (1)... Prime Time Data (8 elements) | ; KMPRNP...... Non Prime Data (8 elements) ; (1.1). Hour count (24 hours) < ; (1.2). User count (24 hours) < ; KMPRNP().... Array fo Non-Prime data - passed by re < ; (1)... Non-Prime Time Data (8 elements) < ; (1.1). Hour count (24 hours) < ; (1.2). User count (24 hours) < ; array (passed by reference) | ; array (passed by reference). ; File data in file #8971.1 (RESOUCE USAGE MONITOR) | ; File data in file #8971.1 (RESOUCE USAGE MONITOR). Q:'$D(KMPRPT)&('$D(KMPRNP)) | S KMPRPT=$G(KMPRPT),KMPRNP=$G(KMPRNP) N FDA,FMDATE,I,J,MESSAGE,OPT,WORKDAY,ZIEN | N FDA,I,J,MESSAGE,OPT,ZIEN S FMDATE=$$HTFM^XLFDT(KMPRDATE),WORKDAY=$$WORKDAY^XUW | ; date. ; | S FDA($J,8971.1,"+1,",.01)=$$HTFM^XLFDT(KMPRDATE) ; date | ; sent to cm national database. S FDA($J,8971.1,"+1,",.01)=FMDATE < ; sent to cm national database < ; cpu node | ; node. ; option | ; option. ; rum designation | ; rum designation. ; if the first character of OPT is '`' then this is a | ; if the first character of OPT is '`' then this is a ; if the first character of OPT is '&' then this is a | ; if the first character of OPT is '&' then this is a ; option | ; option. ; protocol | ; protocol. ;--Populate prime time, non-prime time and non-workda | ; populate prime time and non-prime time fields. .; | .; prime time - node 1. .; subscript 1 - workday prime time (PT) | .I $P(KMPRPT,U,I)'=""&(KMPRPTHR) D .I $P($G(KMPRPT(1)),U,I)'=""&(KMPRPTHR) D | ..S FDA($J,8971.1,"+1,",1+J)=$FN($P(KMPRPT,U,I),"",2) ..S FDA($J,8971.1,"+1,",1+J)=$FN($P(KMPRPT(1),U,I),"" | .; non-prime time - node 2 .; | .I $P(KMPRNP,U,I)'=""&(KMPRNPHR) D .I $P($G(KMPRNP(1)),U,I)'=""&(KMPRNPHR) D | ..S FDA($J,8971.1,"+1,",2+J)=$FN($P(KMPRNP,U,I),"",2) ..; subscript 2 - workday non-prime time (NP) < ..I WORKDAY S FDA($J,8971.1,"+1,",2+J)=$FN($P(KMPRNP( < ..; subscript 3 - entire non-workday time (NW) < ..E S FDA($J,8971.1,"+1,",3+J)=$FN($P(KMPRNP(1),U,I) < ; < ;--Populate workday and non-workday hourly occurrence < ; non-workday is considered non-prime time < F I=1:1:24 S J=I*.001 D < .; < .; subscript 1.1 - workday (WD) hourly occurrence cou < .I $P($G(KMPRPT(1.1)),U,I)'="" D < ..S FDA($J,8971.1,"+1,",1.1+J)=$P(KMPRPT(1.1),U,I) < .; < .; subscript 1.2 - workday (WD) hourly user counts < .I $P($G(KMPRPT(1.2)),U,I)'="" D < ..S FDA($J,8971.1,"+1,",1.2+J)=$P(KMPRPT(1.2),U,I) < .; < .; subscript 2.1 - non-workday (NW) hourly occurrence < .I $P($G(KMPRNP(1.1)),U,I)'="" D < ..S FDA($J,8971.1,"+1,",2.1+J)=$P(KMPRNP(1.1),U,I) < .; < .; subscript 2.2 - non-workday (NW) hourly user count < .I $P($G(KMPRNP(1.2)),U,I)'="" D < ..S FDA($J,8971.1,"+1,",2.2+J)=$P(KMPRNP(1.2),U,I) < ; update file 8971.1 | ; update file 8971.1. ; if error message | ; if error message. RUMDESIG(KMPROPT) ;-- extrinsic function - determine ru | RUMDESIG(KMPROPT) ;-- extrinsic function - determine ru ; KMPROPT... Option name | ; KMPROPT... Option name. ; #8971.1) | ; #8971.1). ; 5 = other | ; 5 = other. ; 3 = broker | ; 3 = broker. ; 4 = users | ; 4 = hl7 Q:$E(KMPROPT)="#" 4 | Q:$E(KMPROPT)="&" 4 ; 2 - option | ; 2 - user. OPTION(KMPROPT) ;-- extrinsic function - option name | OPTION(KMPROPT) ;-- extrinsic function - option name. ; KMPROPT... Option name as it appears from ^KMPTMP(" | ; KMPROPT... Option name (as it appears from ^XTMP("K ; Return: Option name with extraneous characters remo | ; Return: Option name with extraneous characters remo ; rpc | ; rpc. > ; hl7. > Q:$E(KMPROPT)="&" "" Only in ./VADemo/r1/: KMPRBD04.m Only in ./VADemo/r2/r/: KMPRENV.m diff -y --suppress-common-lines ./VADemo/r1/KMPRP1.m ./VADemo/r2/r/KMPRP1.m KMPRP1 ;OAK/RAK - RUM Data by Option/Protocol/RPC ;5/28/03 | KMPRP1 ;SFISC/RAK - RUM Data by Option ;4 Nov 1998 ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;;Dec 09, 1998 N %ZIS,CONT,IORVOFF,IORVON,KMPRDATE,KMPROPR,KMPROPT,O | N %ZIS,CONT,DIC,IORVOFF,IORVON,KMPRDATE,KMPROPT,OUT,P .W @IOF,!,?30,IORVON," RUM Data by Option/Protocol/RP | .W @IOF,!,?30,IORVON," RUM Data by Option ",IORVOFF,! .S KMPROPR=$$OPR I 'KMPROPR S OUT=1 Q | .K DIC S DIC=19,DIC(0)="AEMQZ",DIC("A")="Select Optio .; select option, protocol or rpc entry | .W ! D ^DIC I Y<0 S OUT=1 Q .S KMPROPT=$$OPRSEL(KMPROPR) Q:'KMPROPT | .S KMPROPT=+Y_"^"_Y(0,0) .D RUMDATES^KMPRUTL(.KMPRDATE) Q:'KMPRDATE | .D RUMDATES^KMPRUTL(.KMPRDATE) > .Q:'KMPRDATE ..S ZTSAVE("KMPRDATE")="",ZTSAVE("KMPROPR")="",ZTSAVE | ..S ZTSAVE("KMPRDATE")="",ZTSAVE("KMPROPT")="" Q:'$G(KMPROPR) < Q:'$G(KMPROPR) < ..S OPTION=$$OPRCHK(KMPROPR,KMPROPT,DATA(0)) Q:OPTION | ..S OPTION=$P(DATA(0),U,4) > ..Q:OPTION'=$P(KMPROPT,U,2) ; < OPR() ;-- extrinsic function - select option, protocol or r < ;---------------------------------------------------- < ; Return: 1 - Option < ; 2 - Protocol < ; 3 - RPC < ; "" - No selection made < ;---------------------------------------------------- < N DIR,X,Y < S DIR(0)="SO^1:Option;2:Protocol;3:RPC" < D ^DIR < Q $S(Y:Y_"^"_$G(Y(0)),1:"") < ; < OPRCHK(OPR,OPT,DATA) ;-- extrinsic function - check to see < ;---------------------------------------------------- < ; OPR.... Results from $$OPR above. < ; OPT.... Option, protocol or rpc name to be matched < ; DATA... Zero node of file 8971.1 (RESOURCE USAGE MO < ; < ; Return: OptionName - match < ; "" - no match < ;---------------------------------------------------- < Q:$G(OPR)="" "" < Q:'OPR!($P(OPR,U,2)="") "" < Q:'$D(DATA) "" < Q:(+OPR)<1!((+OPR)>3) "" < N OPTION < ; option - piece 4, protocol - piece 5, rpc - piece7 < S OPTION=$S((+OPR)=1:$P(DATA,U,4),(+OPR)=2:$P(DATA,U, < Q $S(OPTION="":"",OPTION'=$P(OPT,U,2):"",1:OPTION) < ; < OPRSEL(OPR) ;-- extrinsic function - select entry < ;---------------------------------------------------- < ; OPT.... Results from $$OPR above. < ; < ; Return: IEN^Name - this will be from the Option fil < ; or RPC file, depending on the va < ; "" - no selection made < ;---------------------------------------------------- < Q:'$G(OPR) "" < Q:OPR<1!(OPR>3) "" < N DIC,X,Y < ; 1 - option, 2 - protocol, 3 - rpc < S DIC=$S((+OPR)=1:19,(+OPR)=2:101,1:8994) < S DIC(0)="AEMQZ",DIC("A")="Select "_$P(OPR,U,2)_": " < W ! D ^DIC < Q $S(Y<0:"",1:+Y_"^"_Y(0,0)) < Only in ./VADemo/r1/: KMPRP2.m diff -y --suppress-common-lines ./VADemo/r1/KMPRPG01.m ./VADemo/r2/r/KMPRPG01.m KMPRPG01 ;OAK/RAK - RUM Data for All Nodes (Graph) ;5/ | KMPRPG01 ;SFISC/RAK - RUM Data for All Nodes (Graph) ; ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;;Dec 09, 1998 diff -y --suppress-common-lines ./VADemo/r1/KMPRPG02.m ./VADemo/r2/r/KMPRPG02.m KMPRPG02 ;OAK/RAK - RUM Data by Date for Single Node ; | KMPRPG02 ;SFISC/RAK - RUM Data by Date for Single Node ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;;Dec 09, 1998 diff -y --suppress-common-lines ./VADemo/r1/KMPRPN03.m ./VADemo/r2/r/KMPRPN03.m KMPRPN03 ;OAK/RAK - Print Package RUM Stats ;5/28/03 | KMPRPN03 ;SFISC/RAK - Print Package RUM Stats ;29 Oct ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;;Dec 09, 1998 diff -y --suppress-common-lines ./VADemo/r1/KMPRPOST.m ./VADemo/r2/r/KMPRPOST.m KMPRPOST ;OAK/RAK - RUM Post Install Routine ;5/28/03 | KMPRPOST ;SF/RAK - RUM Post Install Routine ;3/27/00 ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;**1,2**;Dec 09, 1998 > ;; EN ;-- entry point. | ; This post install routine is for RUM patch KMPR*1.0 N DATE,IEN | EN ;-- entry point. D BMES^XPDUTL(" Begin Post-Install...") < ; if post install < I $G(XPDNM)]"" D < .D MES^XPDUTL(" Removing data from ^XTMP(""KMPR"")... < .K ^XTMP("KMPR") < .D MES^XPDUTL(" Cleaning up ^KMPTMP(""KMPR"",""BACKGR < .K ^KMPTMP("KMPR","BACKGROUND") < D MES^XPDUTL(" Checking RUM Background Job...") | N IEN S IEN=$O(^DIC(19,"B","KMPR BACKGROUND DRIVER",0)) | S IEN=$O(^DIC(19,"B","KMPR BACKGROUND DRIVER",0)) Q:' S:IEN IEN=$O(^DIC(19.2,"B",+IEN,0)) | S IEN=$O(^DIC(19.2,"B",+IEN,0)) ; if not scheduled then queue background job | ; if scheduled then no further action necessary D:'IEN QUEBKG^KMPRUTL1 | Q:IEN ;D:$P($G(^%ZOSF("OS")),"^")["OpenM" QUEBKG^KMPRUTL1 | D:$P($G(^%ZOSF("OS")),"^")["OpenM" QUEBKG^KMPRUTL1 ; < D MES^XPDUTL(" Cleaning up ""B"" xref in RESOURCE USA < ; begin with dates 3 weeks old < S DATE=$$FMADD^XLFDT(DT,-21) < ; reverse $order < F S DATE=$O(^KMPR(8971.1,"B",DATE),-1) Q:'DATE S IE < .F S IEN=$O(^KMPR(8971.1,"B",DATE,IEN)) Q:'IEN D < ..K:'$D(^KMPR(8971.1,IEN,0)) ^KMPR(8971.1,"B",DATE,IE < ; < D MES^XPDUTL(" Post-Install complete!") < diff -y --suppress-common-lines ./VADemo/r1/KMPRSS.m ./VADemo/r2/r/KMPRSS.m KMPRSS ;OAK/RAK - Resource Usage Monitor Status ;5/28/03 09 | KMPRSS ;SFISC/KAK/RAK - Resource Usage Monitor Status ;3/28/ ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;**1,2**;Dec 09, 1998 N CHECK,DELTA,DIR,ENDT,HDR,KMPRX,KMPRX1,STDT,X,Y | N CHECK,KMPRX,X,Y D HDR(.HDR) | W @IOF,!!,?25,"Resource Usage Monitor Status" W !,?5,"Status......................: " | S X="Version "_$P($$VERSION^KMPRUTL,U) I +$G(^%ZTSCH("LOGRSRC")) W "Running" | W !,?(80-$L(X)\2),X,! E W "STOPPED!" | ; patches > S X=$P($$VERSION^KMPRUTL,U,2) > W:X]"" ?(80-$L(X)\2),X,! > W !,?5,"The Resource Usage Monitor is currently " > I +$G(^%ZTSCH("LOGRSRC")) W "running." > E W "stopped." .S KMPRX=$G(^DIC(19.2,KMPRX,0)),KMPRX1=$G(^(1)) | .S KMPRX=$G(^DIC(19.2,KMPRX,0)) .W !?5,"RUM Background Driver.......: KMPR BACKGROUND | .W !,?5,"The 'RUM Background Driver' [KMPR BACKGROUND .W !?5,"QUEUED TO RUN AT............: ",$P(KMPRX,U,2) | .W !?5,"is QUEUED TO RUN AT ",$P(KMPRX,U,2) .W !?5,"RESCHEDULING FREQUENCY......: ",$P(KMPRX,U,6) | .W !,?5,"with a RESCHEDULING FREQUENCY of '",$P(KMPRX .W !?5,"TASK ID.....................: ",+KMPRX | W !!,?5,"The temporary collection global (i.e., 'XTMP .; user info | W !!,"Press to continue: " R X:DTIME .S KMPRX1=$G(^%ZTSK(+KMPRX1,0)) < .W !?5,"QUEUED BY...................: ",$P($G(^VA(200 < .; if user < .I $P(KMPRX1,U,3) D < ..; user active or terminated < ..S KMPRX1=$$ACTIVE^XUSER(+$P(KMPRX1,U,3)) < ..W " (" < ..I $P(KMPRX1,U,2)["TERMINATED" W "Terminated - ",$$F < ..E W "Active" < ..W ")" < ; daily/weekly background job info < S STDT=$G(^KMPTMP("KMPR","BACKGROUND","DAILY","TOTAL" < S:$E(DELTA)=" " $E(DELTA)="0" < W ! < W !?5,"Daily Background last start.: ",$$FMTE^XLFDT(S < W !?5,"Daily Background last stop..: ",$$FMTE^XLFDT(E < W !?5,"Daily Background total time.: ",DELTA < ; < S STDT=$G(^KMPTMP("KMPR","BACKGROUND","WEEKLY","TOTAL < S:$E(DELTA)=" " $E(DELTA)="0" < W !?5,"Weekly Background last start: ",$$FMTE^XLFDT(S < W !?5,"Weekly Background last stop.: ",$$FMTE^XLFDT(E < W !?5,"Weekly Background total time: ",DELTA < ; < W ! < W !,?5,"Temporary collection global" < W !?5,"^KMPTMP(""KMPR"").............: ",$S('$D(^KMPT < ; < ; page pause < Q:'$$CONT^KMPDUTL1(1) < D HDR(.HDR) < ; < ; file info < W ! < W !?45," # of",?55,"Oldest",?65,"Recent" < W !?5,"File",?45,"Entries",?55," Date",?65," Date" < W !?5,$$REPEAT^XLFSTR("-",36),?45,"-------",?55,"---- < W !?5,"8971.1 - RESOURCE USAGE MONITOR" < ; number of entries < W ?45,$J($FN($P($G(^KMPR(8971.1,0)),U,4),",",0),7) < ; oldest date < W ?55,$$FMTE^XLFDT($O(^KMPR(8971.1,"B",0)),2) < ; most recent date < W ?65,$$FMTE^XLFDT($O(^KMPR(8971.1,"B","A"),-1),2) < ; display routine data < W !! D VERDSPL^KMPDSS("R") < ; < Q:'$$CONT^KMPDUTL1(0) < ; < Q < ; < HDR(KMPRHDR) ;-display header < ;---------------------------------------------------- < ; KMPRHDR.. Array (passed by reference) containing he < ; displayed. < ; * If KMPRHDR() is not defined the array w < ;---------------------------------------------------- < N X < I '$D(KMPRHDR) D < .S KMPRHDR(1)="RUM Environment" < .S KMPRHDR("1","F")="!?32" < .S X="Version "_$P($$VERSION^KMPRUTL,U) < .S KMPRHDR(2)=X < .S KMPRHDR(2,"F")="!?"_(80-$L(X)\2) < .; patches < .S X=$P($$VERSION^KMPRUTL,U,2) < .I X]"" S KMPRHDR(2)=X,KMPRHDR(2,"F")="!?"_(80-$L(X)\ < .S KMPRHDR(3)="",KMPRHDR(3,"F")="!" < W @IOF D EN^DDIOL(.KMPRHDR) < N CHECK,DA,DIE,DIR,DR,X,Y | N CHECK D ^DIR Q:$D(DTOUT)!$D(DUOUT) | D ^DIR G:$D(DTOUT)!$D(DUOUT) END H 1 | H 1 G END Q < N DA,DIE,DIR,DR,DTOUT,DUOUT,X,Y < D ^DIR Q:$D(DTOUT)!$D(DUOUT) | D ^DIR G:$D(DTOUT)!$D(DUOUT) END > ; > END ; > K DA,DIE,DIR,DR,DTOUT,DUOUT,X,Y diff -y --suppress-common-lines ./VADemo/r1/KMPRUTL1.m ./VADemo/r2/r/KMPRUTL1.m KMPRUTL1 ;OAK/KAK/RAK - Resource Usage Monitor Utility | KMPRUTL1 ;SFISC/KAK/RAK - Resource Usage Monitor Utili ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;**1,2**;Dec 09, 1998 diff -y --suppress-common-lines ./VADemo/r1/KMPRUTL2.m ./VADemo/r2/r/KMPRUTL2.m KMPRUTL2 ;OAK/RAK - RUM Data for All Nodes (Graph) ;5/ | KMPRUTL2 ;SFISC/RAK - RUM Data for All Nodes (Graph) ; ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;;Dec 09, 1998 diff -y --suppress-common-lines ./VADemo/r1/KMPRUTL3.m ./VADemo/r2/r/KMPRUTL3.m KMPRUTL3 ;OAK/RAK - Resource Usage Monitor Utilities ; | KMPRUTL3 ;SF/RAK - Resource Usage Monitor Utilities ;1 ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;**1**;Dec 09, 1998 HRSDAYS(KMPRSDT,KMPREDT,KMPRKILL,KMPRRES) ; | HRSDAYS(KMPRSDT,KMPREDT,KMPRKILL,KMPRRES) ;-- hours/day ;-- number of days/hours in the date range < ; KMPRSDT.. Start Date in internal fileman format | ; KMPRSDT.. Stat Date in internal fileman format. ; KMPREDT.. End Date in internal fileman format | ; KMPREDT.. End Date in internal fileman format. ; 0 - do not kill | ; 0 - do not kill. ; Where Data equals for the specified da | ; Where Data equals: ; '^' Piece 5 - Workday Days | ; Example: ; '^' Piece 6 - Workday Hours | ; KMPRRES(2990130,"999A01")=5^9^7^15 ; '^' Piece 7 - Non-Workday Days | ; KMPRRES(2990130,"999A02")=5^4^7^10 ; '^' Piece 8 - Non-Workday Hours | ; KMPRRES(2990130,"999A03")=5^9^7^15 ; Example for the specified date range: | ; KMPRRES(...,...)=... ; KMPRRES(3030418,"999A01")=5^45^7^123^5 < ; KMPRRES(3030418,"999A02")=5^40^7^120^5 < ; KMPRRES(3030418,"999A03")=5^45^7^123^5 < ; KMPRRES( ... , ... )=... < D HOURS(KMPRSDT,KMPREDT,KMPRKILL,.HOURS) | D HOURS(KMPRSDT,KMPREDT,KMPRKILL,.HOURS) Q:'$D(HOURS) Q:'$D(HOURS) < ; < F S NODE=$O(HOURS(NODE)) Q:NODE="" D | F S NODE=$O(HOURS(NODE)) Q:NODE="" D .F S DATE=$O(HOURS(NODE,DATE)) Q:'DATE D | .F S DATE=$O(HOURS(NODE,DATE)) Q:'DATE D ..; < ..; piece 1 - prime time hours per day < ..; piece 2 - non-prime time hours per day < ..; piece 3 - workday hours per day < ..; piece 4 - non-workday hours per day < ..; | ..; piece 1 - prime time. ..F I=1:1:4 D | ..; piece 2 - non-prime time. ...; total hours for the specified date range | ..F I=1,2 D > ...; total hours. ...; if current day has hours then increment total da | ...; if current day has hours then increment total da ...; specified date range < .; | .; back to NODE level. .; back to NODE level | .S KMPRRES(KMPRSDT,NODE)=$P(DAYS,U)_"^"_$P(HOURS,U)_" .S KMPRRES(KMPRSDT,NODE)=$P(DAYS,U)_"^"_$P(HOURS,U)_" < ; < HOURS(KMPRSDT,KMPREDT,KMPRKILL,KMPRRES) ; | HOURS(KMPRSDT,KMPREDT,KMPRKILL,KMPRRES) ;-- determine prime t ;-- determine prime time & non-prime time hours per d < ;-- determine workday & non-workday hours per day < ; KMPRSDT.. Start Date in internal fileman format | ; KMPRSDT.. Stat Date in internal fileman format. ; KMPREDT.. End Date in internal fileman format | ; KMPREDT.. End Date in internal fileman format. ; 0 - do not kill | ; 0 - do not kill. ; KMPRRES.. Array (passed by reference) containing ho | ; KMPRRES.. Array (passed by reference) containing da ; '^' Piece 1 - Prime Time Hours per day | ; '^' Piece 1 - Prime Time Days ; '^' Piece 2 - Non-Prime Time Hours per | ; '^' Piece 2 - Prime Time Hours ; '^' Piece 3 - Workday Hours per day | ; '^' Piece 3 - Non-Prime Time Days ; '^' Piece 4 - Non-Workday Hours per da | ; '^' Piece 4 - Non-Prime Time Hours ; KMPRRES(3030418,"999A01")=9^15^24^0 < | ; KMPRRES(2990130,"999A01")=5^9^7^15 ; KMPRRES(3030418,"999A02")=4^10^14^0 < | ; KMPRRES(2990130,"999A02")=5^4^7^10 ; KMPRRES(3030419,"999A01")=0^24^0^24 < | ; KMPRRES(2990131,"999A01")=5^9^7^15 ; KMPRRES( ... , ... )= ... | ; KMPRRES(...,...)=... N DATA,DATE,DOW,END,HOURS,HRS,I,NODE,PIECE,WORKDAY | N DATA,DATE,DOW,END,HOURS,HRS,I,NODE,PIECE ; | ; end date. ; end date < F S DATE=$O(^KMPTMP("KMPR","HOURS",DATE)) Q:'DATE!(D | F S DATE=$O(^XTMP("KMPR","HOURS",DATE)) Q:'DATE!(DAT .; < .; | .S NODE="",DOW=$$DOW^XLFDT(DATE,1) .S NODE="",DOW=$$DOW^XLFDT(DATE,1),WORKDAY=$$WORKDAY^ | .; prime time (8am to 5pm). .; | .; if not saturday or sunday or holiday then prime ti .; prime time (8am to 5pm) | .; if saturday or sunday then non-prime time (piece 2 .; if not saturday or sunday or holiday then prime ti < .; if saturday or sunday then non-prime time (piece 2 < .; | .F S NODE=$O(^XTMP("KMPR","HOURS",DATE,NODE)) Q:NODE .F S NODE=$O(^KMPTMP("KMPR","HOURS",DATE,NODE)) Q:NO | ..S DATA=$G(^XTMP("KMPR","HOURS",DATE,NODE)) Q:DATA=" ..S DATA=$G(^KMPTMP("KMPR","HOURS",DATE,NODE)) Q:DATA < ..; | ..; prime time. ..; prime time hours < ..; | ..; non-prime time. ..; non-prime time hours < ..; < ..; workday, non-workday hours < ..S HRS=0 < ..F I=1:1:24 S HRS=HRS+$P(DATA,U,I) < ..I WORKDAY S $P(HOURS,U,3)=$P(HOURS,U,3)+HRS < ..E S $P(HOURS,U,4)=$P(HOURS,U,4)+HRS < ..; < ..; | ..K:KMPRKILL ^XTMP("KMPR","HOURS",DATE,NODE) ..K:KMPRKILL ^KMPTMP("KMPR","HOURS",DATE,NODE) < ; KMPRHRS.. Purge Hours/Days data from ^KMPTMP("KMPR" | ; KMPRHRS.. Purge Hours/Days data from ^XTMP("KMPR"," D:'$D(ZTQUEUED) EN^DDIOL("Deleting old records...") | W:'$D(ZTQUEUED) !,"Deleting old records..." ..; delete if no zero node < ..I '$D(^KMPR(8971.1,IEN,0)) K ^KMPR(8971.1,"B",DATE, < ..Q:$P($G(^KMPR(8971.1,IEN,0)),U,2)=0 | ..Q:'$P($G(^KMPR(8971.1,IEN,0)),U,2) D:'$D(ZTQUEUED) EN^DDIOL("Deleting old entries from ^ | W:'$D(ZTQUEUED) !,"Deleting old entries from ^XTMP("" F S DATE=$O(^KMPTMP("KMPR","HOURS",DATE),-1) Q:'DATE | F S DATE=$O(^XTMP("KMPR","HOURS",DATE),-1) Q:'DATE!( .K ^KMPTMP("KMPR","HOURS",DATE) | .K ^XTMP("KMPR","HOURS",DATE) diff -y --suppress-common-lines ./VADemo/r1/KMPRUTL.m ./VADemo/r2/r/KMPRUTL.m KMPRUTL ;OAK/KAK/RAK - Resource Usage Monitor Utilities ;5/28 | KMPRUTL ;SFISC/KAK/RAK - Resource Usage Monitor Utilities ;2/ ;;2.0;CAPACITY MANAGEMENT - RUM;;May 28, 2003 | ;;1.0;CAPACITY MANAGEMENT - RUM;**1,2**;Dec 09, 1998 .S TXT(2,"F")="!?"_$S($G(DDSDIW):40,1:42) | .S TXT(2,"F")="!?"_$S($G(DDSDIW):36,1:45) ;; < PTCHINFO ; -- patch information: routine name ^ curren < ;;KMPRBD01^2.0^ < ;;KMPRBD02^2.0^ < ;;KMPRBD03^2.0^ < ;;KMPRP1^2.0^ < ;;KMPRPG01^2.0^ < ;;KMPRPG02^2.0^ < ;;KMPRPN03^2.0^ < ;;KMPRSS^2.0^ < ;;KMPRUTL^2.0^ < ;;KMPRUTL1^2.0^ < ;;KMPRUTL2^2.0^ < ;;KMPRUTL3^2.0^ < ;;%ZOSVKR^8.0^**90,94,107,122,143,186** < ;; < diff -y --suppress-common-lines ./VADemo/r1/KMPSGE.m ./VADemo/r2/r/KMPSGE.m KMPSGE ;OAK/KAK - Master Routine ;27 AUG 97 1:12 pm | KMPSGE ;SF/KAK - Master Routine ;27 AUG 97 1:12 pm ;;1.8;SAGG PROJECT;**1,2,3**;Jul 26, 2004 | ;;1.8;SAGG PROJECT;**1,2**;July 12, 2002 8:42 am S SESSNUM=+$H,U="^",SITENUM=$P($$SITE^VASITE(),U,3) | S SESSNUM=+$H,SITENUM=^DD("SITE",1),U="^" S ^XTMP("KMPS",0)=$$FMADD^XLFDT($$DT^XLFDT,14)_U_NOWD | S ^XTMP("KMPS",0)=NOWDT+10000 ; session number^M platform^SAGG version_" "_patch^st | ; session number^M platform^SAGG version_" "_patch^st ; -> completed date-time will be set in $$PACK | ; completed date-time set in $$PACK .S UCIDA=0 F S UCIDA=$O(^KMPS(8970.1,1,1,"B",VOL,UCI | .S UCIDA=0 F S UCIDA=$O(^KMPS(8970.1,1,1,"B",VOL,UCI F Q:'$D(^XTMP("KMPS","START"))!+$G(^XTMP("KMPS","STO | F Q:'$D(^XTMP("KMPS","START")) H HANG I (+$H>(SESSN ..S TEXT(I+3)=" Also run "_$S(OS="CVMS":"Integrity",1 | ..S TEXT(I+3)=" Also run INTEGRIT on the listed volum F H HANG S RUN=$$RUN Q:(RUN skip < . . . I LA7CFG,LA7DAT'<$G(LA7DAT(LA7CFG)) Q < ; < ; < PSM ; Purge shipping manifests file (#62.8) < ; < ; Check each manifest to determine if accessions on m < ; been purged from file #68. < ; < ; If over 10000 entries purged from #62.85 then quit < ; session. Avoid performance and journaling issues. < N DA,DIK,LA7628,LA7CNT < S (LA7628,LA7CNT)=0,DIK="^LAHM(62.8," < F S LA7628=$O(^LAHM(62.8,LA7628)) Q:'LA7628 D Q:LA < . I '$$CHK628(LA7628) Q < . D P6285 < . S DA=LA7628 D ^DIK < Q < ; < ; < PLPO ; Purge Lab Pending Orders file (#69.6) < ; < ; Check each order to determine if order can be purge < ; < ; If over 5000 entries purged then quit and pickup ne < ; Avoid performance and journaling issues. < ; < N DA,DIK,LA7696,LA7CNT,LA7COFF,LA7STAT < ; < S DIK="^LRO(69.6,",(LA7696,LA7CNT)=0 < ; Cutoff dates < S LA7COFF(1)=$$FMADD^XLFDT(DT,-365),LA7COFF(2)=$$FMAD < ; Results sent status ien < S LA7STAT=$$FIND1^DIC(64.061,"","OMX","Results/data R < F S LA7696=$O(^LRO(69.6,LA7696)) Q:'LA7696 D Q:LA7 < . I '$$CHK696(LA7696,.LA7COFF,LA7STAT) Q < . S LA7CNT=LA7CNT+1,DA=LA7696 D ^DIK < Q < ; < ; < CHK628(LA7628) ; If all accessions have been purged then saf < ; and associated events (#62.85) < ; < ; Call with LA7628 = ien of manifest in #62.8 < ; < ; Returns OK = 1(yes)/ 0(no) to purge < ; < N LRUID,OK < S OK=1,LRUID="" < F S LRUID=$O(^LAHM(62.8,LA7628,10,"UID",LRUID)) Q:LR < Q OK < ; < ; < P6285 ; Purge related entries in shipping activity log (#62 < ; < N DA,DIK,LA7SM,LRUID < S LA7SM=$P(^LAHM(62.8,LA7628,0),"^"),LRUID="",DIK="^L < ; < ; Purge entries in 62.85 relating to accessions (UID) < F S LRUID=$O(^LAHM(62.8,LA7628,10,"UID",LRUID)) Q:LR < . S DA=0 < . F S DA=$O(^LAHM(62.85,"AM",LRUID,LA7SM,DA)) Q:'DA < ; < ; Purge entries in 62.85 relating to manifest < S DA=0 < F S DA=$O(^LAHM(62.85,"B",LA7SM,DA)) Q:'DA D ^DIK S < Q < ; < ; < CHK696(LA7696,LA7COFF,LA7SPST) ; Check if order safe to purg < ; < ; Call with LA7696 = ien of order in #69.6 < ; LA7COFF = array of cutoff FileMan dates. < ; LA7SPST = ien of specimen status Results/d < ; < ; Returns OK = 1(yes)/ 0(no) to purge < ; < N LAX,OK < S OK=0,LAX=$G(^LRO(69.6,LA7696,1)) < ; < ; Check date order completed < I $P(LAX,"^",7),$P(LAX,"^",7) ; Example: LA7SC="*" > ; or > ; LA7SC(1)="89628.0000^N ; = The "*" (wildcard) for any code | ; LA7SPEC = array of specimen types using H ; Example: LA7SC="*" | ; or "*" (wildcard) for any code ; | ; Currently specimen type only su ; = A list of subscripts (separated < ; where the results will be extra < ; or "SP"). < ; Example: LA7SC="CH,MI" (CH and < ; < ; LA7SPEC = array of specimen types using H < ; 0070 or "*" (wildcard) for any < ; Currently specimen type only su < ; and MI subscripted tests. < ; LA7DEST = closed root global reference to | ; LA7DEST = closed root global reference to ; results (optional). If this par < ; omitted or equals an empty stri < ; ^TMP("HLS",$J) is used. < ; Example: LA7DEST=$NA(^TMP("ZZTM < ; LA7HL7 = HL7 field separator and encodin | ; If this parameter is omitted or ; to use to encode results (optio | ; then node ^TMP("HLS",$J) is use ; If undefined or incomplete (len | ; Example: LA7DEST=$NA(^TMP("ZZTM ; field separator = "|" and encod < ; "^\~&" < ; Returns LA7DEST = contains global reference of s | ; LA7HL7 = HL7 field separator and encodin ; in HL7 message structure, usually ^TMP(" | ; If undefined or incomplete (len > ; Returns LA7DEST = contains global reference of se N DFN,DIQUIET,LA76248,LA7CODE,LA7PTYP,LA7QUIT,LA7SCSR | N DFN,DIQUIET,LA76248,LA7CODE,LA7PTYP,LA7QUIT,LRDFN,L I $D(LA7ERR) Q "" | I $D(LA7ERR) Q "" S LA7SCSRC=$G(LA7SC) | S LA7SC=$G(LA7SC) S TMP=$$SCLIST^LA7QRY2(LA7SCSRC) | I LA7SC'="*" D CHKSC^LA7QRY1 Q:$D(LA7ERR) "" < S LA7SC=TMP D:LA7SC'="*" CHKSC^LA7QRY1 < I LA7SPEC'="*" D SPEC^LA7QRY1 | I LA7SPEC'="*" D SPEC^LA7QRY1 D CLEANUP S LA7SC=LA7SCSRC | D CLEANUP diff -y --suppress-common-lines ./VADemo/r1/LA7SBCR1.m ./VADemo/r2/r/LA7SBCR1.m LA7SBCR1 ;DALOI/JMC - Shipping Barcode Reader Utility | LA7SBCR1 ;DALOI/JMC - Shipping Barcode Reader Utility ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46**;Sep 27, 199 S LA7("SSN")=LA7X < ; < ; Try LAB PENDING ORDERS file < D LPO(.LA7,LA7SCFG("SMID")) < ; < I $G(LA7("ERROR")) D DPT(.LA7,LA7X) | D DPT(.LA7,LA7X) ; < > ; Else try LAB PENDING ORDERS file > I $G(LA7("ERROR")),$L(LA7SCFG("SMID")),$L(LA7("RUID") > . S LA7("SSN")=LA7X > . D LPO(.LA7,LA7SCFG("SMID")) I +$G(LA7("ERROR"))=4 D PD1 | I +$G(LA7("ERROR"))=4 D > . S LA7("SSN")=LA7X > . D PD1 S LA7RUID=LA7("RUID"),LA7696="" | S LA7RUID=LA7("RUID") I LA7SM'="",LA7RUID'="" S LA7696=$O(^LRO(69.6,"AD",LA | S LA7696=$O(^LRO(69.6,"AD",LA7SM,LA7RUID,0)) I 'LA7696 S LA7("ERROR")="4^Unsuccessful SSN lookup" | I 'LA7696 Q N RACE,LA7ERR < D GETS^DIQ(2,LA7Y_",","2*","I","RACE","LA7ERR") < I '$D(LA7ERR) D < . S X=$Q(RACE(2.02)) Q:X="" < . S LA7("RACE")=$P(@X,"^") < N I | S LA7Y(0)=$G(^LRO(69.6,LA7Y,0)) F I=0,.1 S LA7Y(I)=$G(^LRO(69.6,LA7Y,I)) < S LA7("RACE")=$P(LA7Y(.1),U) < S LA7("RIEN")=$O(^LRT(67,"C",LA7("SSN"),0)) < I $G(LA7("RIEN")),$G(^LRT(67,LA7("RIEN"),"LR")) D < . S LA7("LRDFN")=^LRT(67,LA7("RIEN"),"LR") < . S LA7("DFN")=LA7("RIEN") < diff -y --suppress-common-lines ./VADemo/r1/LA7SBCR2.m ./VADemo/r2/r/LA7SBCR2.m LA7SBCR2 ;DALOI/JMC - Shipping Barcode Reader Utility | LA7SBCR2 ;DALOI/JMC - Shipping Barcode Reader Utility ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46**;Sep 27, 199 I LRX,LRY'="" D | I LRX,$L(LRY) D . S LRY(99)=$$RETFACID^LA7VHLU2(LRX,2,1) | . S LRY(99)=$$GET1^DIQ(4,LRX_",",99) I LRX,LRY'="" D | I LRX,$L(LRY) D . S LRY(99)=$$RETFACID^LA7VHLU2(LRX,2,1) | . S LRY(99)=$$GET1^DIQ(4,LRX_",",99) I $P(LA7,"^")'="" D | I $L($P(LA7,"^")) D . S Z=$$FINDSITE^LA7VHLU2($P(LA7,"^"),2,1) | . S Z=$$FIND1^DIC(4,"","OMX",$P(LA7,"^")) I $P(LA7,"^",3)'="" S LA7("SMID")=$P(LA7,"^",3) | I $L($P(LA7,"^",3)) S LA7("SMID")=$P(LA7,"^",3) diff -y --suppress-common-lines ./VADemo/r1/LA7SCE.m ./VADemo/r2/r/LA7SCE.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,61,64**;Sep 2 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,61**;Sep 27, N LA7CHECK,LA7COPY,LA7NVAF,LA7SCFG,LA7SCFR,LA7TYPE,LA | N LA7CHECK,LA7COPY,LA7SCFG,LA7SCFR,LA7TYPE,LA7VAF S DIC("DR")=".02;.03",DLAYGO=62.9 | S DIC("DR")=".02;.03" > S DLAYGO=62.9 S LA7VAF="",LA7NVAF=0 | S LA7VAF="" I $P(LA7SCFG(0),"^",2),$P(LA7SCFG(0),"^",3) D | I $P(LA7SCFG(0),"^",2),$P(LA7SCFG(0),"^",3) S LA7VAF= . S LA7X=$S(LA7TYPE=1:$P(LA7SCFG(0),"^",3),1:$P(LA7SC < . S LA7VAF=$$GET1^DIQ(4,LA7X_",","AGENCY CODE","I") < . S LA7NVAF=$$NVAF^LA7VHLU2(LA7X) < . S LA7MSG=LA7MSG_" missing AGENCY CODE field in INSI | . S LA7MSG=LA7MSG_" missing AGENCY CODE field" . S DR=".01;.02;.06;.03;.031;" | . S DR=".01;.02;.06;.03;.031;"_$S(LA7VAF'="V":".11;.1 . I LA7NVAF>1 S DR=DR_".11;.12;.14;.15;" | . S DR(2,62.9001)=".01;.02;.025;.03;.04;.05;.06;.07;1 . I LA7NVAF=1 S DR=DR_".14////1;.15////1;" < . S DR=DR_".04;.07;.08;.09;.1;.13;60" < . S DR(2,62.9001)=".01;.02;.025;.03;.04;.05;.06;.07" < . S DR=".01;.02;.06;.03;.031;" | . S DR=".01;.02;.06;.03;.031;"_$S(LA7VAF'="V":".11;.1 . I LA7NVAF>1 S DR=DR_".11;.14;.15;" | . S DR(2,62.9001)=".01;.04;.09" . I LA7NVAF=1 S DR=DR_".14////0;.15////1;" < . S DR=DR_".04;.05;60" < . S DR(2,62.9001)=".01;S LRSS=$P(^LAB(60,X,0),U,4);.0 < . S DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,LA7 | . S DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,LA7 . I LA7TYPE=1,LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001) | . I LA7TYPE=2 S DR(2,62.9001)=DR(2,62.9001)_";I $P(^L . S DR(2,62.9001)=DR(2,62.9001)_";@9" < . I LA7TYPE=1 D < . . S DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,L < . . I LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001)_"////99 < . . S DR(2,62.9001)=DR(2,62.9001)_";@10" < . I LA7TYPE=2 D < . . S DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,L < . . I LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001)_"////99 < . . S DR(2,62.9001)=DR(2,62.9001)_";@10" < ; < I LA7TYPE=1 D < . N J,K < . S DR(2,62.9001)=DR(2,62.9001)_";" < . S X="1.1;I 'X S Y=1.2;1.15;1.16;1.2;I 'X S Y=2.1;1. < . I ($L(DR(2,62.9001))+$L(X))<246 S DR(2,62.9001)=DR( < . S K=$L(X,";") < . F J=1:1:K D < . . I ($L(DR(2,62.9001))+$L($P(X,";")))>244 S J=K Q < . . S DR(2,62.9001)=DR(2,62.9001)_$P(X,";")_";",X=$P( < . I X'="" S DR(2,62.9001,1)=X < diff -y --suppress-common-lines ./VADemo/r1/LA7SM2.m ./VADemo/r2/r/LA7SM2.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 199 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 D UNLOCKSM^LA7SM < ; < ; < RCI ; Enter/edit relevant clinical information < N DA,FDA,LA7628,LA762801,LA7DIR,LA7QUIT,LA7TCNT,LA7Y < D INIT^LA7SM < I LA7QUIT D CLEANUP^LA7SM Q < S LA7SM=$$SELSM^LA7SMU(+LA7SCFG,"0,1,3") < I LA7SM<0 D Q < . D EN^DDIOL($P(LA7SM,"^",2),"","!?5") < . D CLEANUP^LA7SM < D LOCKSM^LA7SM < I LA7QUIT D Q < . D EN^DDIOL($P(LA7QUIT,"^",2),"","!?5") < . D UNLOCKSM^LA7SM,CLEANUP^LA7SM < S LA7SM(0)=$G(^LAHM(62.8,+LA7SM,0)) < D SEL^LA7SM < I LA7QUIT D UNLOCKSM^LA7SM,CLEANUP^LA7SM Q < S (LA7I,LA7TCNT)=0 < F S LA7I=$O(^LAHM(62.8,+LA7SM,10,"UID",LA7UID,LA7I)) < . S LA7I(0)=$G(^LAHM(62.8,+LA7SM,10,LA7I,0)) < . I $P(LA7I(0),"^",8)=0 Q ; Previously "removed". < . I $P(LA7I(0),"^",8),$P(LA7I(0),"^",8)'=1 S LA7QUIT= < . S LA7TCNT=LA7TCNT+1,LA760(LA7TCNT)=LA7I_"^"_LA7I(0) < I 'LA7TCNT,'LA7QUIT S LA7QUIT="1^Accession is not on < I LA7QUIT D UNLOCKSM^LA7SM,CLEANUP^LA7SM Q < S LA7I=0 < F S LA7I=$O(LA760(LA7I)) Q:'LA7I D EN^DDIOL(LA7I_" < S DIR(0)="LO^1:"_LA7TCNT,DIR("A")="Select test(s) to < D ^DIR < I $D(DIRUT) S LA7QUIT=1 D UNLOCKSM^LA7SM,CLEANUP^LA7S < M LA7YARRY=Y < K DIR < D FIELD^DID(62.801,.1,,"DESCRIPTION;FIELD LENGTH;HELP < S LA7X=$P($G(^LAHM(62.9,+$P(LA7SM(0),"^",2),0)),"^",3 < I $$NVAF^LA7VHLU2(LA7X)=1 D < . S LA7DIR("FIELD LENGTH")=78 < . S LA7DIR("HELP-PROMPT")="Answer must be 1-78 charac < S DIR(0)="FAO^1:"_LA7DIR("FIELD LENGTH"),DIR("A")="Re < M DIR("?")=LA7DIR("DESCRIPTION"),DIR("?")=LA7DIR("HEL < S LA7Y="",LA7628=+LA7SM,LA7QUIT=0 < F S LA7Y=$O(LA7YARRY(LA7Y)) Q:LA7Y="" D Q:LA7QUIT < . F LA7I=1:1 Q:'$P(LA7YARRY(LA7Y),",",LA7I) D Q:LA7 < . . K DA,DIRUT,DUOUT,DTOUT,FDA,LA7DIE < . . S LA7X=$P(LA7YARRY(LA7Y),",",LA7I),DA=+LA760(LA7X < . . S LA762801=DA_","_LA7628_"," < . . W !,"For test: ",$$GET1^DIQ(62.801,LA762801,.02) < . . S DIR("B")=$$GET1^DIQ(62.801,LA762801,.1) < . . I DIR("B")="" K DIR("B") < . . D ^DIR < . . I $D(DIRUT),X'="@" S LA7QUIT=1 Q < . . I Y="",X="@" S Y="@" < . . S FDA(62.8,62.801,LA762801,.1)=Y < . . D FILE^DIE("","FDA(62.8)","LA7DIE(1)") < ; < D UNLOCKSM^LA7SM,CLEANUP^LA7SM < Q < diff -y --suppress-common-lines ./VADemo/r1/LA7SMB.m ./VADemo/r2/r/LA7SMB.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46**;Sep 27, 199 I $G(LA7SCFG),$G(LA7SM)>0 D EN^DDIOL("Shipping manife | I LA7SM>0 D EN^DDIOL("Shipping manifest# "_$P(LA7SM," D CLEANUP | ;D CLEANUP N FDA,IENS,LA7628,LA768,LA7DATA | N FDA,LA7628,LA768,LA7DATA I LA7UID="" S LA7UID=$$LRUID^LRX(LA7AA,LA7AD,LA7AN) < S LA7628(1)=+LA7SM,IENS="+2,"_LA7628(1)_"," | S LA7628(1)=+LA7SM S FDA(2,62.801,IENS,.01)=LRDFN | S FDA(2,62.801,"+2,"_+LA7SM_",",.01)=LRDFN S FDA(2,62.801,IENS,.02)=LA760 | S FDA(2,62.801,"+2,"_+LA7SM_",",.02)=LA760 I LA76805 S FDA(2,62.801,IENS,.03)=LA76805 | I LA76805 S FDA(2,62.801,"+2,"_+LA7SM_",",.03)=LA7680 S FDA(2,62.801,IENS,.04)=LA76205 | S FDA(2,62.801,"+2,"_+LA7SM_",",.04)=LA76205 S FDA(2,62.801,IENS,.05)=LA7UID | S FDA(2,62.801,"+2,"_+LA7SM_",",.05)=LA7UID S FDA(2,62.801,IENS,.08)=1 | I $P($G(LA7X(LA7I,0)),"^",5) S FDA(2,62.801,"+2,"_+LA I $D(LA7X(LA7I,0)) D | I $P($G(LA7X(LA7I,0)),"^",6) S FDA(2,62.801,"+2,"_+LA . I $P(LA7X(LA7I,0),"^",5) S FDA(2,62.801,IENS,.06)=$ | S FDA(2,62.801,"+2,"_+LA7SM_",",.08)=1 . I $P(LA7X(LA7I,0),"^",6) S FDA(2,62.801,IENS,.07)=$ | I $P($G(LA7X(LA7I,0)),"^",7) S FDA(2,62.801,"+2,"_+LA . I $P(LA7X(LA7I,0),"^",7) S FDA(2,62.801,IENS,.09)=$ | I $L($P($G(LA7X(LA7I,1)),"^",1)) S FDA(2,62.801,"+2," I $D(LA7X(LA7I,1)) D | I $L($P($G(LA7X(LA7I,1)),"^",2)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,1),"^",1)]"" S FDA(2,62.801,IENS,1.1 | I $L($P($G(LA7X(LA7I,1)),"^",5)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,1),"^",2)]"" S FDA(2,62.801,IENS,1.1 | I $L($P($G(LA7X(LA7I,1)),"^",3)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,1),"^",5)]"" S FDA(2,62.801,IENS,1.1 | I $L($P($G(LA7X(LA7I,1)),"^",4)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,1),"^",3)]"" S FDA(2,62.801,IENS,1.2 | I $L($P($G(LA7X(LA7I,1)),"^",6)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,1),"^",4)]"" S FDA(2,62.801,IENS,1.2 | I $L($P($G(LA7X(LA7I,2)),"^",1)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,1),"^",6)]"" S FDA(2,62.801,IENS,1.2 | I $L($P($G(LA7X(LA7I,2)),"^",2)) S FDA(2,62.801,"+2," I $D(LA7X(LA7I,2)) D | I $L($P($G(LA7X(LA7I,2)),"^",7)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",1)]"" S FDA(2,62.801,IENS,2.1 | I $L($P($G(LA7X(LA7I,2)),"^",3)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",2)]"" S FDA(2,62.801,IENS,2.1 | I $L($P($G(LA7X(LA7I,2)),"^",4)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",7)]"" S FDA(2,62.801,IENS,2.1 | I $L($P($G(LA7X(LA7I,2)),"^",8)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",3)]"" S FDA(2,62.801,IENS,2.2 | I $L($P($G(LA7X(LA7I,2)),"^",5)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",4)]"" S FDA(2,62.801,IENS,2.2 | I $L($P($G(LA7X(LA7I,2)),"^",6)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",8)]"" S FDA(2,62.801,IENS,2.2 | I $L($P($G(LA7X(LA7I,2)),"^",9)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",5)]"" S FDA(2,62.801,IENS,2.3 | I $L($P($G(LA7X(LA7I,5)),"^",1)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",6)]"" S FDA(2,62.801,IENS,2.3 | I $L($P($G(LA7X(LA7I,5)),"^",2)) S FDA(2,62.801,"+2," . I $P(LA7X(LA7I,2),"^",9)]"" S FDA(2,62.801,IENS,2.3 | D UPDATE^DIE("","FDA(2)","LA7628","LA7DIE(2)") ; Add I $D(LA7X(LA7I,5)) D < . F I=1:1:9 I $P(LA7X(LA7I,5),"^",I)]"" S FDA(2,62.80 < D UPDATE^DIE("","FDA(2)","LA7628","LA7DIE(2)") < diff -y --suppress-common-lines ./VADemo/r1/LA7SMP0.m ./VADemo/r2/r/LA7SMP0.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 199 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 > ; > ; > ; I IOM>131 W ?86,$P(LA7PROV,"^",2) | I IOM>131 W ?86,LA7DOC I IOM'>131 W !,?11,$E($P(LA7PROV,"^",2),1,28),?41,$S( | I IOM'>131 W !,?11,$E(LA7DOC,1,28),?41,$S(LA7CDT:$$FM I +LA7SMST'=4 D < . D PROV(+LA7PROV) < . I $P($G(LA762801(0)),"^",6) D < . . S X=$$GET1^DIQ(62.91,$P(LA762801(0),"^",6),.01) < . . W !,?11,"Specimen Container: ",X < ; < ; Print collection sample if micro < I $G(LA7AA),$P($G(^LRO(68,LA7AA,0)),"^",2)="MI" W !,? < > ; > ; > ; > ; > ; ; < I $G(LA7SM("BARCODE"))="" D | I '$L($G(LA7SM("BARCODE"))) D > ; > ; CMT ; Print comments on manifest < ; < N LA7I < F LA7I=1:1:LA7CMT D Q:LA7EXIT < . I ($Y+4)>IOSL D Q:LA7EXIT < . . I LA7PAGE W ! D WARN < . . D HED < . W !,?11,LA7CMT(LA7I,0) < Q < ; < ; < PROV(LA7OP) ; Print ordering provider contact on working < ; Call with LA7OP = provider's file #200 ien < ; < N LRERR,X,Y < I LA7OP D GETS^DIQ(200,LA7OP_",",".132;.137;.138","E" < I '$D(LA7OP(LA7OP)) Q < S X="Requestor's " < I LA7OP(LA7OP,200,LA7OP_",",.132,"E")'="" D < . W !,?11,X,"Phone: ",LA7OP(LA7OP,200,LA7OP_",",.132, < . S X="" < I LA7OP(LA7OP,200,LA7OP_",",.137,"E")'="" D < . S Y=0 < . I X="" S Y=$L(LA7OP(LA7OP,200,LA7OP_",",.137,"E"))+ < . I Y>IOM!(X'="") W !,?11 < . E S X=" "_X < . W X,"Voice Pager: ",LA7OP(LA7OP,200,LA7OP_",",.137, < . S X="" < I LA7OP(LA7OP,200,LA7OP_",",.138,"E")'="" D < . S Y=0 < . I X="" S Y=$L(LA7OP(LA7OP,200,LA7OP_",",.138,"E"))+ < . I Y>IOM!(X'="") W !,?11 < . E S X=" "_X < . W X,"Digital Pager: ",LA7OP(LA7OP,200,LA7OP_",",.13 < . S X="" < ; < I X="" W ! < Q < ; < ; < K LA7AA,LA7ACC,LA7AD,LA7AN,LA7CDT,LA7CHK,LA7CMT,LA7DC | K LA7AA,LA7ACC,LA7AD,LA7AN,LA7CDT,LA7CHK,LA7DC,LA7DOC diff -y --suppress-common-lines ./VADemo/r1/LA7SMP.m ./VADemo/r2/r/LA7SMP.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,45,46,64**;Sep 2 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,45,46**;Sep 27, > ; I LA7SBC,$P($G(^LAHM(62.8,+LA7SM,0)),"^",3)=4 D | ; > I $P($G(^LAHM(62.8,+LA7SM,0)),"^",3)=4 D > ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" Q:$QS(LA7ROOT | F S LA7ROOT=$Q(@LA7ROOT) Q:$QS(LA7ROOT,1)'="LA7SM"!( . F I=0,.1,2,5 S LA762801(I)=$G(^LAHM(62.8,+LA7SM,10, | . F I=0,2,5 S LA762801(I)=$G(^LAHM(62.8,+LA7SM,10,LA7 . . S X=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0),"Not a | . . S LA7DOC=$$PRAC^LRX($P($G(^LRO(68,LA7AA,1,LA7AD,1 . . S LA7PROV=$S(X>0:X,1:"")_"^"_$S(X>0:$$PRAC^LRX(X) < . . S LA762=$P(LA7SPEC,"^",2) < . . I LA762 S LA762(0)=$G(^LAB(62,LA762,0)) < . . E S LA762(0)="Collection info not assigned" < . I LA762801(.1)'="" D < . . K ^UTILITY($J),LA7CMT < . . S DIWL=1,DIWR=IOM-13,DIWF="" < . . S X="Relevant clinical information: "_LA762801(.1 < . . M LA7CMT=^UTILITY($J,"W",DIWL) < . . W ! D CMT^LA7SMP0 W ! < S LA7FS(99)=$$RETFACID^LA7VHLU2(LA7X,2,1) | S LA7FS(99)=$$GET1^DIQ(4,LA7X_",",99) S LA7TS(99)=$$RETFACID^LA7VHLU2(LA7X,1,1) | S LA7TS(99)=$$GET1^DIQ(4,LA7Y_",",99) diff -y --suppress-common-lines ./VADemo/r1/LA7SMPXL.m ./VADemo/r2/r/LA7SMPXL.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,42,46,64**;Sep 2 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,42,46**;Sep 27, . I LA7UID'="",LA7UID'=$QS(LA7ROOT,4) W !,LA7LINE | . I $L(LA7UID),LA7UID'=$QS(LA7ROOT,4) W !,LA7LINE . I $D(LA7CMT) D CMT^LA7SMP0 < . . S LA7NLT=$P(LA76964(0),"^",2) | . . S LA7NLT=$P(LA76964(0),"^") . . S LA7NLTN=$P(LA76964(0),"^") | . . S LA7NLTN=$P(LA76964(0),"^",2) . . I LA7NLTN'="" W:($X+$L($P(LA76964(0),"^",2))+3)>I | . . I $L(LA7NLTN) W:($X+$L($P(LA76964(0),"^",2))+3)>I . . I $P(LA76964(0),"^",9)'="" W !,?20,"Host site UID < S (SSN,SSN(2))=$P(LA7696(0),U,9) | S (SSN,SSN(2))=$P(LA7696(0),U,9),LA7DOC="" S I=0,LA7PROV="" | S I=0 F S I=$O(^LRO(69.6,LA7696,2,I)) Q:'I D Q:LA7PROV'= | F S I=$O(^LRO(69.6,LA7696,2,I)) Q:'I D Q:$L(LA7DOC . I X'="" S $P(LA7PROV,"^",2)=$P(X,"[") | . I $L(X) S LA7DOC=$P(X,"[") I LA7PROV="" S LA7PROV="^REF:"_LA7FSITE(99) | I LA7DOC="" S LA7DOC="REF:"_LA7FSITE(99) ; < ; Check for comments < K LA7CMT < I $D(^LRO(69.6,LA7696,99,0)) D < . N DIWF,DIWL,DIWR,LA7ERR,X < . S LA7CMT=$$GET1^DIQ(69.6,LA7696_",",99,"","LA7CMT", < . K ^UTILITY($J,"W") < . S DIWL=1,DIWR=IOM-13,DIWF="" < . I $$GET1^DID(+$$GET1^DID(69.6,99,"","SPECIFIER","LA < . S LA7I=$O(LA7CMT(0)),LA7CMT(LA7I)="COMMENTS: "_LA7C < . F S LA7I=$O(LA7CMT(LA7I)) Q:'LA7I S X=LA7CMT(LA7I < . K LA7CMT < . M LA7CMT=^UTILITY($J,"W",DIWL) < . K ^UTILITY($J,"W") < ; < ; Add local (host) status info < S LA7CMT=$G(LA7CMT)+1 < I LA7CMT>1 S LA7CMT(LA7CMT,0)=" ",LA7CMT=LA7CMT+1 < S LA7CMT(LA7CMT,0)="Host test status: "_$$GET1^DIQ(69 < K LA7696,LA76964,LA7CMT,LA7SMAN | K LA7696,LA76964,LA7SMAN diff -y --suppress-common-lines ./VADemo/r1/LA7SMU1.m ./VADemo/r2/r/LA7SMU1.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,65,64**;Sep 2 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,65**;Sep 27, F S LA7I=$O(^LAHM(62.8,LA7628,10,"UID",LA7UID,LA7I)) | F S LA7I=$O(^LAHM(62.8,LA7628,"UID",LA7UID,LA7I)) Q: diff -y --suppress-common-lines ./VADemo/r1/LA7SMU2.m ./VADemo/r2/r/LA7SMU2.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 199 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 DTTO(LA7SCFG,LA7VNLT,LA7HLSC,LA764NCS,LA761NCS,LA7HLPRI,LA7CS | DTTO(LA7SCFG,LA7VNLT,LA7HLSC,LA764NCS,LA761NCS,LA7HLPRI) ; LA7CSC = collection sample code^name^cod | ; Returns LA7X = 0^0^0^0^ (if unsuccessful) > ; LABORATORY TEST (ien file #60)^TOPOGRAPHY (ien fi ; Returns LA7X = 0^0^0^0^^^ (if unsuccessful) | N LA7V64,LA7X,X,Y ; LABORATORY TEST (ien file #60)^ < N LA760,LA7V64,LA7X,X,Y,Z | S LA7X="0^0^0^0^" > I $G(LA7HLSC)="" Q LA7X > I $G(LA7VNLT)="" Q LA7X S LA7X="0^0^0^0^^^" | S LA7HLPRI=$G(LA7HLPRI),LA7SCFG=+$G(LA7SCFG) I LA7VNLT="" Q LA7X < S LA7SCFG=+$G(LA7SCFG) < I LA7HLPRI="" S LA7HLPRI="R" < I LA7HLSC="" S LA7HLSC="XXX" < I LA761NCS="" S LA761NCS="HL70070" | I $G(LA761NCS)="" S LA761NCS="HL70070" I LA764NCS="" S LA764NCS="99VA64" | I $G(LA764NCS)="" S LA764NCS="99VA64" I LA764NCS="L",$P(^LAHM(62.9,LA7SCFG,0),"^",15)=0 S L < I LA7HLPRI]"" D | I $L(LA7HLPRI) D . I $P(LA7CSC,"^")'="" D Q:LA7X | . N X . . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT,LA7HLSC,LA < . . I X S LA7X=X < . I X S LA7X=X Q | . I +X,$P(X,"^",2),$P(X,"^",3) S LA7X=X . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT,"XXX",LA7HLP < . I X,"MISPCYEM"[$P(^LAB(60,+X,0),"^",4) S LA7X=X < . I $P(LA7CSC,"^")'="" D Q:LA7X | . N X . . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT,LA7HLSC,0, < . . I X S LA7X=X < . I X S LA7X=X Q | . I +X,$P(X,"^",2),$P(X,"^",3) S LA7X=X . S X=$G(^TMP("LA7TC",$J,LA7SCFG,LA7VNLT,"XXX")) < . I X,"MISPCYEM"[$P(^LAB(60,+X,0),"^",4) S LA7X=X < ; Lookup test using NLT code and get first lab test i < ; NLT code that's type (I)nput or (B)oth. < . S LA7V64=$O(^LAM("E",LA7VNLT,0)),Y=0 Q:'LA7V64 | . S LA7V64=$O(^LAM("E",LA7VNLT,0)) ; Lookup NLT code . F S Y=$O(^LAB(60,"AC",LA7V64,Y)) Q:'Y Q:"BI"[$P(^ | . I LA7V64 D . I Y S $P(LA7X,"^")=Y | . . ; Lookup test using this NLT code ; | . . S Y=$O(^LAB(60,"AC",LA7V64,0)) ; Get default topography and collection sample for HL | . . ; Get lab test for this NLT code. ; Check file #60 collection samples first, then check | . . I Y S $P(LA7X,"^")=Y ; If non-table 0070 then look for "XXX" in table 0070 | . ; Get default topography and collection sample for I $P(LA7X,"^"),'$P(LA7X,"^",2),LA761NCS="HL70070" D < . S (X,Y)=0,LA760=$P(LA7X,"^") < . F S X=$O(^LAB(60,LA760,3,"B",X)) Q:'X D Q:Y < . . S Z=$P(^LAB(62,X,0),"^",2) < . . I Z,$D(^LAB(61,"HL7",LA7HLSC,Z)) S Y=Z_"^"_X < . I Y S $P(LA7X,"^",2,3)=Y < I '$P(LA7X,"^",2),LA761NCS="HL70070" D < . S $P(LA7X,"^",2)=X | . S X(0)=$G(^LAB(61,X,0)) . I '$P(LA7X,"^",3) S $P(LA7X,"^",3)=$P(^LAB(61,X,0), | . ; Topography and collection sample I $P(LA7X,"^"),'$P(LA7X,"^",2),LA761NCS'="HL70070","M | . S $P(LA7X,"^",2,3)=X_"^"_(+$P(X(0),"^",6)) . S X=$O(^LAB(61,"HL7","XXX",0)) < . I X S $P(LA7X,"^",2)=X < ; No urgency mapping, get last using this HL7 code or | ; No urgency mapping, get last using this HL7 code or ; Find highest non-workload urgency using this priori < . S X=$O(^LAB(62.05,"HL7",LA7HLPRI,50),-1) | . ; Default urgency from #69.9 . I X S $P(LA7X,"^",4)=X | . N X,LA7DURG . E S $P(LA7X,"^",4)=+$P($G(^LAB(69.9,1,3)),"^",2) | . S LA7DURG=$S($P($G(^LAB(69.9,1,3)),"^",2):$P($G(^LA > . ; If no priority, use site's default. > . I LA7HLPRI="" S $P(LA7X,"^",4)=LA7DURG > . I '$P(LA7X,"^",4) D > . . ; Find highest non-workload urgency > . . S X=$O(^LAB(62.05,"HL7",LA7HLPRI,50),-1) > . . ; Last urgency using this priority code else use > . . I X S $P(LA7X,"^",4)=X > . . E S $P(LA7X,"^",4)=LA7DURG ; Check file #60 forced and highest urgency. | ; Check if test and urgency for forced and highest ur . S X=$G(^LAB(60,$P(LA7X,"^"),0)) | . N LA760 . I $P(X,"^",18) S $P(LA7X,"^",4)=$P(X,"^",18) | . S LA760=$P(LA7X,"^") . I $P(X,"^",16),$P(LA7X,"^",4)<$P(X,"^",16) S $P(LA7 | . ; File #60 forced urgency > . I $P($G(^LAB(60,LA760,0)),"^",18) S $P(LA7X,"^",4)= > . ; File #60 highest urgency > . I $P($G(^LAB(60,LA760,0)),"^",16),$P(LA7X,"^",4)<$P ; | BINDX ; Build index of test for a shipping configuration. BINDX ; Build index of tests for a shipping configuration. < > ; > ; > ; Build index for each test on cofiguration > ; BLD ; Build TMP global for a test | BLD ; Build TMP globlal for a test ; Laboratory test/collection sample. | ; Laboratory test. S LA760=$P(LA7X(0),"^"),LA762=$P(LA7X(0),"^",9) | S LA760=$P(LA7X(0),"^") > ; > ; Collection sample. > S LA762=$P(LA7X(0),"^",9) > ; ; Test urgency/HL7 priority code. | ; Test urgency. S LA76205=$P(LA7X(0),"^",4),LA76205("HL")="" | S LA76205=$P(LA7X(0),"^",4) I LA76205 S LA76205("HL")=$$GET1^DIQ(62.05,LA76205_", | I LA76205 D > . ; File #60 forced urgency > . I $P($G(^LAB(60,LA760,0)),"^",18) S LA76205=$P(^LAB > . ; File #60 highest urgency > . I $P($G(^LAB(60,LA760,0)),"^",16),LA76205<$P(^LAB(6 I 'LA761,"BBCH"[$P(^LAB(60,LA760,0),"^",4) Q ; Incom | I 'LA761 Q ; Incomplete entry. ; Handle MI with no topography associated with collec < I 'LA761,$P(^LAB(60,LA760,0),"^",4)="MI" S LA761=+$P < ; File #64 ien/NLT code/NLT code test name. | ; File #64 ien ; Use NLT code if using VA coding else use non-VA tes < > ; > ; NLT code. > ; > ; NLT code test name. > ; > ; HL7 priority code. > S LA76205("HL")=$S(LA76205:$$GET1^DIQ(62.05,LA76205_" > ; > ; Use NLT code if using VA coding else use non-VA tes I LA7HL'="",LA7TC'="" D | I LA760,LA761,LA762,$L(LA7HL),$L(LA7TC) D . I "MISPCYEM"[$P(^LAB(60,LA760,0),"^",4),$P(LA7X(5), | . S ^TMP("LA7TC",$J,LA7SCFG,LA7TC,LA7HL)=LA760_"^"_LA . . S ^TMP("LA7TC",$J,LA7SCFG,LA7TC,LA7HL,0,$P(LA7X(5 | . I $L(LA76205("HL")) S ^TMP("LA7TC",$J,LA7SCFG,LA7TC . E S ^TMP("LA7TC",$J,LA7SCFG,LA7TC,LA7HL)=LA760_"^" < . I LA76205("HL")'="" D < . . I "MISPCYEM"[$P(^LAB(60,LA760,0),"^",4),$P(LA7X(5 < . . . S ^TMP("LA7TC",$J,LA7SCFG,LA7TC,LA7HL,LA76205(" < . . E S ^TMP("LA7TC",$J,LA7SCFG,LA7TC,LA7HL,LA76205( < ; < ; Set TMP global when collection sample does not have < ; Used for "MISPCYEM" subscripts which can have colle < I LA7TC'="",'LA761,"MISPCYEM"[$P(^LAB(60,LA760,0),"^" < . S ^TMP("LA7TC",$J,LA7SCFG,LA7TC,"XXX")=LA760_"^"_LA < . I LA76205("HL")'="" S ^TMP("LA7TC",$J,LA7SCFG,LA7TC < diff -y --suppress-common-lines ./VADemo/r1/LA7SMU.m ./VADemo/r2/r/LA7SMU.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46**;Sep 27, 199 S DT=$$DT^XLFDT,LA7DT=$E($$FMTHL7^XLFDT(DT),1,8) | S DT=$$DT^XLFDT,LA7DT=$$HLDATE^HLFNC(DT,"DT") S FDA(1,62.8,"+1,",.06)=+$P(LA7SCFG(0),"^",16) < D RECALL^DILFD(62.8,LA7IEN(1)_",",DUZ) < S FDA(3,62.85,"+1,",.02)=$S($G(DUZ)>0:DUZ,1:.5) | S FDA(3,62.85,"+1,",.02)=DUZ N D,DIC,DTOUT,DUOUT,LA7Y,X,Y | N DIC,DTOUT,DUOUT,LA7Y,X,Y S DIC="^LAHM(62.8,",DIC(0)="AEQ",DIC("A")="Select Shi | S DIC="^LAHM(62.8,",DIC(0)="AEMNQ",DIC("A")="Select S I $G(LA7SCR)'="" S DIC("S")=DIC("S")_","""_LA7SCR_""" | I $L($G(LA7SCR)) S DIC("S")=DIC("S")_","""_LA7SCR_""" S D="C" | D ^DIC D MIX^DIC1 < diff -y --suppress-common-lines ./VADemo/r1/LA7SRR.m ./VADemo/r2/r/LA7SRR.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 199 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 . K LA7X | . K LA7X,LA7Y . . K LA7Y < N LA763,LA768,LA7I,LA7X,LA7Y,LR60,LR61,LRDFN,LRIDT,LR | N LA763,LA768,LA7I,LA7X,LA7Y,LRDFN,LRIDT,LRODT,LRSB,L S LRSS=$P(^LRO(68,LRAA,0),"^",2) | F LA7I=0,.3,3 S LA768(LA7I)=$G(^LRO(68,LRAA,1,LRAD,1, F LA7I=0,.2,.3,3 S LA768(LA7I)=$G(^LRO(68,LRAA,1,LRAD < S LA7UID=$P(LA768(.3),"^") < > ; Check accession for results available date. > I '$P(LA768(3),"^",4) Q I '$P(LA768(.3),"^",2),'$P(LA768(.3),"^",3) D Q | I '$P(LA768(.3),"^",2),'$P(LA768(.3),"^",3) Q . N LA7X < . S LA7X="Not a LEDI specimen - Accession "_$P(LA768( < . D EN^DDIOL(LA7X,"","!") < I "CHMICYEMSP"'[LRSS!(LRSS="") D | S LA7UID=$P(LA768(.3),"^"),LRSS=$P(^LRO(68,LRAA,0),"^ > I LRSS'="CH" D . S LA7X(2)="Accession "_$P(LA768(.2),"^")_" ("_LA7UI | . S LA7X(2)="Accession with UID "_LA7UID_" skipped" ; Check file #63 for order codes and results | ; Check file #63 for order codes and results/ ; If no order NLT code found then use default NLT < ; Check if test has been added to order then report r < ; code of the added test. < ; Check for date report completed. | S LRSB=1 I '$P(^LR(LRDFN,LRSS,LRIDT,0),"^",3) D Q | F S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB D . N LA7X | . S X=^LR(LRDFN,LRSS,LRIDT,LRSB) . S LA7X="No date report completed - Accession "_$P(L | . S LA7NLT=$P($P(X,"^",3),"!") . D EN^DDIOL(LA7X,"","!") | . I $L(LA7NLT) S LA7Y(LA7NLT,LRSB)="" ; < I LRSS="CH" D < . S LRSB=1 < . F S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB D < . . S X=^LR(LRDFN,LRSS,LRIDT,LRSB) < . . S LA7NLT=$P($P(X,"^",3),"!") < . . I LA7NLT'="" S LA7Y(LA7NLT,LRSB)="" Q < . . S LR61=+$P(^LR(LRDFN,LRSS,LRIDT,0),"^",5) < . . S LA7NLT=$P($$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(X,"^" < . . I LA7NLT'="" S LA7Y(LA7NLT,LRSB)="" < ; < I LRSS="MI" D < . S LR60=0 < . F S LR60=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR60)) Q: < . . S LA764=$P($G(^LAB(60,LR60,64)),"^") < . . S LA7NLT=$$GET1^DIQ(64,LA764_",",1) < . . I LA7NLT'="" S LA7Y(LA7NLT)="" < ; < I LRSS="SP" S LA7Y("88515.0000")="" < I LRSS="CY" S LA7Y("88593.0000")="" < I LRSS="EM" S LA7Y("88597.0000")="" < I LRSS="AU" S LA7Y("88533.0000")="" < I LA7UID'="",$D(LA7Y) D | I $L(LA7UID),$D(LA7Y) D diff -y --suppress-common-lines ./VADemo/r1/LA7UTILA.m ./VADemo/r2/r/LA7UTILA.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**23,27,46,64**;Sep 2 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**23,27,46**;Sep 27, ; < ; < FMT(LA76249) ; Perform test to determine storage format, e < ; node or segment has continuation nodes separated w < ; Call with LA76249 = ien of entry in file #62.49 < ; Returns LA7Y = 0-old format, 1-new format < ; < N LA7END,LA7Y,LA7ROOT < S (LA7END,LA7Y)=0,LA7ROOT="^LAHM(62.49,LA76249,150,0) < F S LA7ROOT=$Q(@LA7ROOT) Q:LA7END D < . I $QS(LA7ROOT,1)'="62.49"!($QS(LA7ROOT,2)'=LA76249) < . I @LA7ROOT="" S (LA7Y,LA7END)=1 < Q LA7Y < Only in ./VADemo/r1/: LA7UTL02.m Only in ./VADemo/r1/: LA7UTL03.m Only in ./VADemo/r1/: LA7UTL1A.m Only in ./VADemo/r1/: LA7UTL1B.m Only in ./VADemo/r1/: LA7UTL1C.m diff -y --suppress-common-lines ./VADemo/r1/LA7VHL.m ./VADemo/r2/r/LA7VHL.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,62,64**;Sep 2 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,62**;Sep 27, N LA76248,LA76249,LA7AAT,LA7AERR,LA7CS,LA7DT,LA7ECH,L | N LA76248,LA76249,LA7AAT,LA7CS,LA7DT,LA7ECH,LA7FS,LA7 K ^TMP("HLA",$J) < D RSPINIT^HLFNC2(HL("EIDS"),.LA7HLS) | D INIT^HLFNC2(HL("EID"),.LA7HLS) S (LA76248,LA76249,LA7INTYP,LA7SEQ)=0 | S (LA76248,LA76249,LA7SEQ)=0 I $G(LA7AERR)'="",$G(LA7AAT(1))="SU" Q | I $D(HLA("HLA")),$G(LA7AAT(1))="SU" Q I $G(LA7AERR)="",$G(LA7AAT(1))="ER" Q | I '$D(HLA("HLA")),$G(LA7AAT(1))="ER" Q ; < ; If POC interface and no error then quit - send appl < ; processing message. < I $G(LA7AERR)="",LA7INTYP>19,LA7INTYP<30 S X=$$DONTPU < I $G(LA7AERR)="" S HLA("HLA",1)="MSA"_LA7HLS("RFS")_" | I '$D(HLA("HLA")) S HLA("HLA",1)="MSA"_LA7HLS("FS")_" I $D(^TMP("HLA",$J)) D < . S HLP("NAMESPACE")="LA" < . D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1 < ; < I 'LA76248 S LA76248=+$O(^LAHM(62.48,"B",LA7SAP,0)) < I 'LA76248,$E(LA7SAP,1,11)="LA7V REMOTE" S LA76248=+$ < ; Determine interface type < S LA7INTYP=+$P(^LAHM(62.48,LA76248,0),"^",9) < ; < S FDA(1,62.49,LA76249_",",700)=HL("EID")_";"_HLMTIENS < ; < S HLA("HLA",1)="MSA"_LA7HLS("RFS")_"AR"_LA7HLS("RFS") | S HLA("HLA",1)="MSA"_LA7HLS("FS")_"AR"_LA7HLS("FS")_H S LA7AERR=LA7AR < diff -y --suppress-common-lines ./VADemo/r1/LA7VHLU1.m ./VADemo/r2/r/LA7VHLU1.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,64**;Sep 27, | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 199 ; < ; < FAMG(LA76248,LA7TYP) ; Find alert mail group for this aler < ; Call with LA76248 = ien of entry in file #62.48 < ; LA7TYP = type of alert < ; (1-new results) < ; (2-error on message) < ; (3-orders received) < ; < ; Returns LA7MG = name of mail group < ; < N LA7MG,X,Y < S (LA7MG,X)="" < F S X=$O(^LAHM(62.48,+$G(LA76248),20,"B",LA7TYP,X)) < . S Y=$G(^LAHM(62.48,LA76248,20,X,0)) < . I $P(Y,"^",2)'="" S LA7MG=$P(Y,"^",2) ; Send to mai < ; < ; Fail safe mail group when no mail group specified < I LA7MG="" S LA7MG="LAB MESSAGING" < ; < Q LA7MG < ; < ; < ABFLAGS ;; HL7 Table 0078 Abnormal flags < ;;Below low normal;; < ;;Above high normal;; < ;;Below lower panic limits;; < ;;Above upper panic limits;; < ;;Below absolute low-off instrument scale;; < ;;Above absolute high-off instrument scale;; < ;;Normal;; < ;;Abnormal;; < ;;Very abnormal;; < ;;Significant change up;; < ;;Significant change down;; < ;;Better;; < ;;Worse;; < ;;Susceptible;; < ;;Resistant;; < ;;Intermediate;; < ;;Moderately susceptible;; < ;;Very susceptible;; < diff -y --suppress-common-lines ./VADemo/r1/LA7VHLU2.m ./VADemo/r2/r/LA7VHLU2.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,64**;Sep 27, | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 199 S LA7TYPE=$G(LA7TYPE),LA7Z=$G(LA7Z),LA7Y="",LA7SEM=$G | S LA7TYPE=$G(LA7TYPE),LA7Z=$G(LA7Z),LA7Y="",LA7SEM=$G ; If appears to be a VA station number | S LA7Y=$$FIND1^DIC(4,"","OMX",LA7X) I LA7Z?1(3N,3.4N2U,3N1U1N) S LA7Y=$$IDX^XUAF4("VASTAN < ; If appears to be a DoD DMIS number < I LA7Z?4N S LA7Y=$$IDX^XUAF4("DMIS",LA7Z) < ; Else try anything < I 'LA7Y S LA7Y=$$FIND1^DIC(4,"","OMX",LA7X) < ; Check that entry is not a VA facility | I LA7Y'>0,$L(LA7X) D I LA7Y'>0,LA7X]"" D | . N LA7J . N LA7J,LA7K < . F S LA7J=$O(^LAHM(62.9,LA7J)) Q:'LA7J D Q:LA7Y | . F S LA7J=$O(^LAHM(62.9,LA7J)) Q:'LA7J D . . I $P(LA7J(0),"^",12)'=LA7X Q | . . I $P(LA7J(0),"^",12)=LA7X S LA7Y=$S(LA7TYPE=1:$P( . . S LA7K=$S(LA7TYPE=1:$P(LA7J(0),"^",3),LA7TYPE=2:$ < . . I LA7K,$$NVAF(LA7K) S LA7Y=LA7K < . S LA7SITE=$S(LA7TYPE=1:"Host",LA7TYPE=2:"Collection | . S LA7SITE=$S(LA7TYPE=1:"Host",LA7TYPE=2:"Collection . N LA7X,LA7Y,LA7Z | . N LA7X,LA7Y N I,LA7NVAF,LA7X,LA7Y | N LA7Y S LA7Y="",LA7SEM=$G(LA7SEM,1) | S LA7TYPE=$G(LA7TYPE),LA7Z=$G(LA7Z),LA7Y="",LA7SEM=$G ; Check identifiers on file. | S LA7Y=$$GET1^DIQ(4,LA7Z_",",99) ; If DoD use DMIS code since some DoD also have VA st < S LA7NVAF=$$NVAF(LA7Z) < I LA7NVAF=0 S LA7Y=$$ID^XUAF4("VASTANUM",LA7Z) < I LA7NVAF=1 S LA7Y=$$ID^XUAF4("DMIS",LA7Z) < . I LA7Y'="" S LA7Y=$$UP^XLFSTR(LA7Y) < . I LA7X'=LA7Z S LA7Y="-1^Not a valid ICN" | . I LA7X'=LA7Y S LA7Y="-1^Not a valid ICN" ; Call with LA7X = ien of institution in file #4 | ; Call with LA7X = ien of instution in file #4 diff -y --suppress-common-lines ./VADemo/r1/LA7VHLU3.m ./VADemo/r2/r/LA7VHLU3.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 199 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 ; If data does not contain escape encoding then retur | S LA7LEN=$L(LA7CH) S LA7LEN=$L(LA7CH),LA7ESC=$E(LA7CH,LA7LEN-1) | S LA7ESC=$E(LA7CH,LA7LEN-1) I LA7X'[LA7ESC Q LA7X | ; > ; If data does not contain escape encoding > ; then return input string as output > I '$L(LA7X,LA7ESC) Q LA7X ; < ; < UNESCFT(LA7X,LA7CH,LA7Y) ; Unescape formatted text dat < ; Call with LA7X = array to decode (pass by referenc < ; LA7CH = HL7 delimiters (both field separa < ; < ; Returns LA7Y = array of unencoded data. < ; < N J,K,LA7ESC,LA7I,LA7Z,SAVX,SAVY,Z < ; < S J=0,LA7ESC=$E(LA7CH,$L(LA7CH)-1),(LA7I,SAVX,SAVY)=" < F S LA7I=$O(LA7X(LA7I)) Q:LA7I="" D < . S J=J+1 < . I LA7X(LA7I)'[LA7ESC,SAVY="" S LA7Y(J,0)=LA7X(LA7I) < . F K=1:1:$L(LA7X(LA7I)) D < . . S Z=$E(LA7X(LA7I),K) < . . I Z=LA7ESC D Q < . . . I SAVY="" S SAVY=Z Q < . . . S SAVY=SAVY_Z < . . . I $P(SAVY,LA7ESC,2)=".br" S LA7Y(J,0)=$S(SAVX]" < . . . I $E(SAVY,2)'="." S SAVX=SAVX_$$UNESC(SAVY,LA7C < . . . S SAVY="" < . . I SAVY]"" S SAVY=SAVY_Z Q < . . S SAVX=SAVX_Z < . S LA7Y(J,0)=SAVX,SAVX="" < S LA7Y=J < ; < Q < diff -y --suppress-common-lines ./VADemo/r1/LA7VHLU4.m ./VADemo/r2/r/LA7VHLU4.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 199 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 N LA7NVAF,LA7X,LA7Y,LA7Z | N LA7IENS,LA7X,LA7Y,LA7Z I LA74'="",LA74'=+LA74 D | I $L(LA74),LA74'=+LA74 D . S LA7NVAF=$$NVAF^LA7VHLU2(LA74) | . S LA7IENS=LA74_"," . ; Build id - VA station #/DMIS code | . D GETS^DIQ(4,LA7IENS,".01;95;99;100","E","LA7X") . I LA7NVAF<2 S LA7Y=$$ID^XUAF4($S(LA7NVAF=1:"DMIS",1 | . ; Build id - VA station # (VAxxxyy) > . ; Don't use "VA" prefix until changes made to proce > . S LA7Y=$S(LA7X(4,LA7IENS,95,"E")="VA":"",1:"")_LA7X . S LA7Z=$$NAME^XUAF4(LA74) | . S LA7Z=$S($L(LA7X(4,LA7IENS,100,"E")):LA7X(4,LA7IEN . S $P(LA7Y,$E(LA7ECH,1),2)=$$CHKDATA^LA7VHLU3(LA7Z,L | . S LA7Z=$$CHKDATA^LA7VHLU3(LA7Z,LA7FS_LA7ECH) > . S $P(LA7Y,$E(LA7ECH,1),2)=LA7Z > S LA7FN=$G(LA7FN),LA7DA=$G(LA7DA),LA7DT=$G(LA7DT),LA7 > S LA7FN=$G(LA7FN),LA7DA=$G(LA7DA),LA7FS=$G(LA7FS),LA7 > S LA7FN=$G(LA7FN),LA7DA=$G(LA7DA),LA7FS=$G(LA7FS),LA7 . I X,$P(X,"^",2)'="" S LA7DUZ=LA7Z | . I X,$L($P(X,"^",2)) S LA7DUZ=LA7Z S LA7Y=$$TRIM^XLFSTR(LA7Y,"R",",") | S X=$RE(LA7Y) S:$E(X)="," LA7Y=$E(LA7Y,1,$L(LA7Y)-1) I $P(LA7X,$E(LA7ECH))'="",LA7Y'="" S LA7Y=LA7Y_" ["_$ | I $L($P(LA7X,$E(LA7ECH))),$L(LA7Y) S LA7Y=LA7Y_" ["_$ ; < ; < PLTFM(LA7PL,LA7ECH) ; Resolve location from PL (person lo < ; Call with LA7PL = HL7 field containing person locat < ; LA7ECH = HL7 encoding characters < ; < ; Returns LA7Y = file #44 ien^name field (#.01)^di < ; < N LA7X,LA7Y,X,Y < S LA7X=$P(LA7PL,$E(LA7ECH)),(LA7Y,Y)="" < I LA7X?1.N S Y=$$GET1^DIQ(44,LA7X_",",.01) < ; If not ien try as name < I Y="" D < . S X=$$FIND1^DIC(44,"","X",LA7X,"B") < . I X S Y=LA7X,LA7X=X < I Y'="" S LA7Y=LA7X_"^"_Y < E I $P(LA7PL,$E(LA7ECH),2)'="" S LA7Y="^"_$P(LA7PL,$ < ; < ; Process division (institution) < S LA7X=$P(LA7PL,$E(LA7ECH),4),Y="" < I LA7X'="" S Y=$$FINDSITE^LA7VHLU2(LA7X,1,1) < S $P(LA7Y,"^",3)=Y < ; < Q LA7Y < diff -y --suppress-common-lines ./VADemo/r1/LA7VHLU5.m ./VADemo/r2/r/LA7VHLU5.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 199 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 I LA7CODE="" S LA7CODE="!!!" | I '$L(LA7CODE) S LA7CODE="!!!" I LA7MISS'="" D | I $L(LA7MISS) D . I LRSS="CY" D CYSUB Q < . I LRSS="EM" D EMSUB Q < . . I LA7X'="" S $P(LA7CODE,"!")=LA7X,$P(LA7MISS,"^") | . . I $L(LA7X) S $P(LA7CODE,"!")=LA7X,$P(LA7MISS,"^") . . I LA7Y'="" S $P(LA7CODE,"!",2)=LA7Y,$P(LA7MISS,"^ | . . I $L(LA7Y) S $P(LA7CODE,"!",2)=LA7Y,$P(LA7MISS,"^ . I LA7NLT'="" S LA7X=$$LNC^LRVER1(LA7NLT,$P(LA7CODE, | . I $L(LA7NLT) S LA7X=$$LNC^LRVER1(LA7NLT,$P(LA7CODE, . I LA7NLT'="" S LA7X=$$LNC^LRVER1(LA7NLT,$P(LA7CODE, | . I $L(LA7NLT) S LA7X=$$LNC^LRVER1(LA7NLT,$P(LA7CODE, > N LA7NLT,LA7X,LA7Y > ; > ; Default order/result NLT codes > ; Default result LOINC code based on result NLT code > ; I LRSB=1.4 S LA7DFCDE="88515.0000^88571.0000^22637" D | I LRSB=1.4 S LA7DFCDE="88515.0000^88589.0000^22637" D CYSUB ; Determine codes for CY subscript < ; < ; specimens < I LRSB=.012 S LA7DFCDE="88593.0000^88539.0000^22633" < ; < ; brief clinical history < I LRSB=.013 S LA7DFCDE="88593.0000^88542.0000^22636" < ; < ; preoperative diagnosis < I LRSB=.014 S LA7DFCDE="88593.0000^88544.0000^10219" < ; < ; operative findings < I LRSB=.015 S LA7DFCDE="88593.0000^88542.0000^10215" < ; < ; postoperative diagnosis < I LRSB=.016 S LA7DFCDE="88593.0000^88547.0000^10218" < ; < ; gross description < I LRSB=1!(LRSB=20) S LA7DFCDE="88593.0000^88549.0000^ < ; < ; microscopic examination < I LRSB=1.1 S LA7DFCDE="88593.0000^88563.0000^22635" D < ; < ; supplementary report < I LRSB=1.2 S LA7DFCDE="88593.0000^88589.0000^22639" D < ; < ; cytopatholgy diagnosis < I LRSB=1.4 S LA7DFCDE="88593.0000^88571.0000^22637" D < ; < Q < ; < ; < EMSUB ; Determine codes for EM subscript < ; < ; specimens < I LRSB=.012 S LA7DFCDE="88597.0000^88057.0000^22633" < ; < ; brief clinical history < I LRSB=.013 S LA7DFCDE="88597.0000^88542.0000^22636" < ; < ; preoperative diagnosis < I LRSB=.014 S LA7DFCDE="88597.0000^88544.0000^10219" < ; < ; operative findings < I LRSB=.015 S LA7DFCDE="88597.0000^88542.0000^10215" < ; < ; postoperative diagnosis < I LRSB=.016 S LA7DFCDE="88597.0000^88547.0000^10218" < ; < ; gross description < I LRSB=1!(LRSB=20) S LA7DFCDE="88597.0000^88549.0000^ < ; < ; microscopic examination < I LRSB=1.1 S LA7DFCDE="88597.0000^88563.0000^22635" D < ; < ; supplementary report < I LRSB=1.2 S LA7DFCDE="88597.0000^88589.0000^22639" D < ; < ; em diagnosis < I LRSB=1.4 S LA7DFCDE="88597.0000^88571.0000^22637" D < ; < Q < ; < ; < diff -y --suppress-common-lines ./VADemo/r1/LA7VHLU.m ./VADemo/r2/r/LA7VHLU.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,62,64**;Sep 27, | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,62**;Sep 27, 199 N LA7MSH,X | N LA7MSH > ; > K ^TMP("HLS",$J) > K HL,HLCOMP,HLSUB,HLFS,HLERR,HLMID > K LA7PIDSN > ; > ; I $G(HL) D Q | S LA7MSH(0)="MSH"_LA7FS_LA7ECH . N LA7X < . S LA7X(1)=LA76249,LA7X(2)=$TR(HL,"^","-") < . D CREATE^LA7LOG(28) < S X="MSH"_LA7FS_LA7ECH_LA7FS_HL("SAN")_LA7FS_HL("SAF" < S $P(X,LA7FS,9)=HL("MTN")_$E(LA7ECH,1)_HL("ETN") < S $P(X,LA7FS,11)=HL("PID") < S $P(X,LA7FS,12)=HL("VER") < S:$D(HL("ACAT")) $P(X,LA7FS,15)=HL("ACAT") < S:$D(HL("APAT")) $P(X,LA7FS,16)=HL("APAT") < S LA7MSH(0)=X < K ^TMP("HLS",$J) < K HL,HLCOMP,HLSUB,HLFS,HLERR,HLMID < ; < D INIT^HLFNC2(LA7101,.HL,0) | S HL="HL",INT=0 > D INIT^HLFNC2(LA7101,.HL,INT) ; | GEN ;generate HL7 v1.6 message GEN ; Generate HL7 v1.6 message < ; HLARYTYP - array type | ; HLARYTYP - acknowledgement array ; HLMTIEN - IEN in 772 (batch messages) | ; HLMTIEN - IEN in 772 ; | ; N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLRESLT,I | N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLRESLT,HLP K LA7MID M LA7MID=HLRESLT | S HLMID=$P(HLRESLT,"^") I $P(HLRESLT,"^",2)'="" D CREATE^LA7LOG(23) | I $L($P(HLRESLT,"^",2)) D CREATE^LA7LOG(23) I $O(LA7MID(0)) D < . S I=0 < . F S I=$O(LA7MID(I)) Q:'I I $L($P(LA7MID,"^",2)) S < K HLP < ; < F S LA7I=$O(LA7DATA(LA7I)) Q:LA7I="" S @LA7ROOT@(LA | F S LA7I=$O(LA7DATA(LA7I)) Q:LA7I="" D > . S @LA7ROOT@(LA7HLSN,LA7I)=$G(LA7DATA(LA7I)) ; < P(LA7X,LA7P,LA7EC) ; get field LA7P from array (passed b | P(LA7X,LA7P,LA7EC) ; get piece LA7P from array (passed b ; LA7P = field to extract | ; LA7P = piece to extract N I,L,LA7Y,L1,Y | N I,L,L1,L2,LA7Y S L=0,Y=1,LA7Y="" | S (L2,Y)=0,LA7Y="" ;Y=begining piece of each node, L1=number of pieces i | F I=0:1 D Q:$L(LA7Y)!'($D(LA7X(I))) ;L=last piece in each node, quit when last piece is g | . S L1=$L($G(LA7X(I)),LA7EC),L=L1+Y-1 F I=0:1 Q:'$D(LA7X(I)) S L1=$L(LA7X(I),LA7EC),L=L1+Y | . S:L1=1 L=L+1 . ;if LA7P is less than last piece, this node has fie | . S:LA7P'>L LA7Y=$P($G(LA7X(I-1)),LA7EC,LA7P-L2)_$P($ . S:LA7P'>L LA7Y=LA7Y_$P(LA7X(I),LA7EC,(LA7P-Y+1)) | . S L2=Y,Y=L . S Y=L < PA(LA7X,LA7P,LA7EC,LA7Y) ; get field LA7P from array ( < ; Call with LA7X = array to extract data from, pass < ; LA7P = field to extract < ; LA7EC = encoding character separator < ; < ; Returns LA7Y = array value of requested piece (retu < ; < N I,L,L1,X,Y < S (L,LA7Y)=0,Y=1 < ;Y=begining piece of each node, L1=number of pieces i < ;L=last piece in each node, quit when last piece is g < F I=0:1 Q:'$D(LA7X(I)) S L1=$L(LA7X(I),LA7EC),L=L1+Y < . ;if LA7P is less than last piece, this node has fie < . I LA7P'>L S X=$P(LA7X(I),LA7EC,(LA7P-Y+1)) S:X]"" L < . S Y=L < Q < ; < ; < Only in ./VADemo/r1/: LA7VIN1A.m diff -y --suppress-common-lines ./VADemo/r1/LA7VIN1.m ./VADemo/r2/r/LA7VIN1.m ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64**;Sep 27, 199 | ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 S LA7ERR="" | S (LA7ERR)="" . D SETID^LA7VHLU1(LA76249,LA7ID,"UNKNOWN") < F S LA7END=$$GETSEG^LA7VHLU2(LA76249,.LA7INDX,.LA7SE | F S LA7END=$$GETSEG^LA7VHLU2(LA76249,.LA7INDX,.LA7SE > . S LA7ERR=6 > . D CREATE^LA7LOG(LA7ERR) ; Currently only on LEDI (10) type interfaces. < . I LA7INTYP=10,$D(^TMP("LA7-ORU",$J,LA76248)) D XQA^ | . D XQA^LA7UXQA(1,LA76248) ; If amended results received then send bulletins < I $D(^TMP("LA7 AMENDED RESULTS",$J)) D SENDARB^LA7VIN < ; < ; If cancelled orders received then send bulletins < I $D(^TMP("LA7 ORDER STATUS",$J)) D SENDOS