- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- Location:
- WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG
- Files:
-
- 24 edited
-
A1CKC.m (modified) (8 diffs)
-
A1CKC1.m (modified) (1 diff)
-
A1CKC10.m (modified) (1 diff)
-
A1CKC11.m (modified) (1 diff)
-
A1CKC12.m (modified) (1 diff)
-
A1CKC13.m (modified) (1 diff)
-
A1CKC14.m (modified) (1 diff)
-
A1CKC15.m (modified) (2 diffs)
-
A1CKC2.m (modified) (1 diff)
-
A1CKC3.m (modified) (1 diff)
-
A1CKC4.m (modified) (1 diff)
-
A1CKC5.m (modified) (1 diff)
-
A1CKC6.m (modified) (1 diff)
-
A1CKC7.m (modified) (1 diff)
-
A1CKC8.m (modified) (1 diff)
-
A1CKC9.m (modified) (1 diff)
-
RGADTP2.m (modified) (1 diff)
-
RGHLLOG.m (modified) (1 diff)
-
RGMTETOT.m (modified) (1 diff)
-
RGPVMPI.m (modified) (1 diff)
-
RGPVREJ.m (modified) (1 diff)
-
RGRSBUL1.m (modified) (1 diff)
-
RGRSPT.m (modified) (1 diff)
-
RGSYSTAT.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC.m
r613 r623 1 A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#1505), FILE 2; 12/13/081 A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#1505), FILE 2;04/21/06 2 2 D DE G BEGIN 3 3 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" 4 I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(4)=% ,DE(11)=%S %=$P(%Z,U,2) S:%]"" DE(5)=%4 I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(4)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% 5 5 I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(6)=% 6 I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(13)=% S %=$P(%Z,U,14) S:%]"" DE(12)=%7 6 I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(7)=% 8 I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(3)=% ,DE(10)=%7 I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(3)=% 9 8 K %Z Q 10 9 ; … … 61 60 Q 62 61 2 S DQ=3 ;@10 63 3 S DW="VET;1",DV=" SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=190162 3 S DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 64 63 S DE(DW)="C3^A1CKC" 65 64 S DU="Y:YES;N:NO;" … … 71 70 S DFN=DA D EN^DGMTCOR K DGMTCOR 72 71 S X=DE(3),DIC=DIE 73 S DFN=DA D EN^DGRP7CC74 S X=DE(3),DIC=DIE75 72 ; 76 73 S X=DE(3),DIC=DIE … … 84 81 S X=DG(DQ),DIC=DIE 85 82 S DFN=DA D EN^DGMTCOR K DGMTCOR 86 S X=DG(DQ),DIC=DIE87 S DFN=DA D EN^DGRP7CC88 83 S X=DG(DQ),DIC=DIE 89 84 X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) … … 99 94 Q 100 95 ; 101 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".3;1",DV=" SXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.30196 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 102 97 S DE(DW)="C4^A1CKC" 103 98 S DU="Y:YES;N:NO;" … … 187 182 S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET 188 183 C6S S X="" G:DG(DQ)=X C6F1 K DB 189 S X=DG(DQ),DIC=DIE 190 X "S DFN=DA D EN^DGMTR K DGREQF" 191 S X=DG(DQ),DIC=DIE 192 K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) 193 S X=DG(DQ),DIC=DIE 194 ; 195 S X=DG(DQ),DIC=DIE 196 S ^DPT("AEL",DA,+X)="" 197 S X=DG(DQ),DIC=DIE 198 D AUTOUPD^DGENA2(DA) 199 I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET 184 D ^A1CKC1 200 185 C6F1 Q 201 186 X6 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 202 187 Q 203 188 ; 204 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="TYPE;1",DV=" P391'a",DU="",DLB="TYPE",DIFLD=391189 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391 205 190 S DE(DW)="C7^A1CKC",DE(DW,"INDEX")=1 206 191 S DU="DG(391," … … 214 199 S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET 215 200 C7S S X="" G:DG(DQ)=X C7F1 K DB 216 S X=DG(DQ),DIC=DIE 217 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) 218 I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET 201 D ^A1CKC2 219 202 C7F1 N X,X1,X2 S DIXR=664 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X 220 203 I $G(X(1))]"" D … … 233 216 Q 234 217 9 S DQ=10 ;@20 235 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 236 S DE(DW)="C10^A1CKC" 237 S DU="Y:YES;N:NO;" 238 S Y="Y" 239 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 240 G RD 241 C10 G C10S:$D(DE(10))[0 K DB 242 D ^A1CKC1 243 C10S S X="" G:DG(DQ)=X C10F1 K DB 244 D ^A1CKC2 245 C10F1 Q 246 X10 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK 247 Q 248 ; 249 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".3;1",DV="SXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 250 S DE(DW)="C11^A1CKC" 251 S DU="Y:YES;N:NO;" 252 S Y="N" 253 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 254 G RD 255 C11 G C11S:$D(DE(11))[0 K DB 256 D ^A1CKC3 257 C11S S X="" G:DG(DQ)=X C11F1 K DB 258 D ^A1CKC4 259 C11F1 Q 260 X11 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK 261 Q 262 ; 263 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 264 S DE(DW)="C12^A1CKC" 265 S DU="Y:YES;N:NO;U:UNKNOWN;" 266 S X=$S(PE="Y":"Y",1:"N") 267 S Y=X 268 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 269 G RD 270 C12 G C12S:$D(DE(12))[0 K DB 271 D ^A1CKC5 272 C12S S X="" G:DG(DQ)=X C12F1 K DB 273 D ^A1CKC6 274 C12F1 Q 275 X12 S DFN=DA D MV^DGLOCK 276 Q 277 ; 278 13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 279 S DE(DW)="C13^A1CKC" 280 S DU="Y:YES;N:NO;U:UNKNOWN;" 281 S X=$S(AA="Y":"Y",1:"N") 282 S Y=X 283 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 284 G RD 285 C13 G C13S:$D(DE(13))[0 K DB 286 D ^A1CKC7 287 C13S S X="" G:DG(DQ)=X C13F1 K DB 288 D ^A1CKC8 289 C13F1 Q 290 X13 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK 291 Q 292 ; 293 14 D:$D(DG)>9 F^DIE17 G ^A1CKC9 218 10 D:$D(DG)>9 F^DIE17 G ^A1CKC3 -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC1.m
r613 r623 1 A1CKC1 ; ; 12/13/082 S X=D E(10),DIC=DIE3 S DFN=DA D EN^DGMTCOR K DGMTCOR4 S X=D E(10),DIC=DIE5 S DFN=DA D EN^DGRP7CC6 S X=D E(10),DIC=DIE1 A1CKC1 ; ;04/21/06 2 S X=DG(DQ),DIC=DIE 3 X "S DFN=DA D EN^DGMTR K DGREQF" 4 S X=DG(DQ),DIC=DIE 5 K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) 6 S X=DG(DQ),DIC=DIE 7 7 ; 8 S X=DE(10),DIC=DIE 8 S X=DG(DQ),DIC=DIE 9 S ^DPT("AEL",DA,+X)="" 10 S X=DG(DQ),DIC=DIE 9 11 D AUTOUPD^DGENA2(DA) 10 S X=DE(10),DIC=DIE 11 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) 12 S X=DE(10),DIC=DIE 13 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) 14 S X=DE(10),DIIX=2_U_DIFLD D AUDIT^DIET 12 I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC10.m
r613 r623 1 A1CKC10 ; ;12/13/08 2 D DE G BEGIN 3 DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% 5 K %Z Q 6 ; 7 W W !?DL+DL-2,DLB_": " 8 Q 9 O D W W Y W:$X>45 !?9 10 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 11 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 12 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 13 Q 14 A K DQ(DQ) S DQ=DQ+1 15 B G @DQ 16 RE G PR:$D(DE(DQ)) D W,TR 17 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 18 RD G QS:X?."?" I X["^" D D G ^DIE17 19 I X="@" D D G Z^DIE2 20 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 21 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 22 K DDER G X 23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 24 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 25 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 26 V D @("X"_DQ) K YS 27 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 28 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 29 S X="?BAD" 30 QS S DZ=X D D,QQ^DIEQ G B 31 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 32 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 33 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 34 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 35 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 36 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 37 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 38 I I DV'["I",DV'["#" G RD 39 D E^DIE0 G RD:$D(X),PR 40 Q 41 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 42 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 43 D ^DIR I 'DDER S %=Y(0),X=Y 44 Q 45 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 46 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 47 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 48 Q 49 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 BEGIN S DNM="A1CKC10",DQ=1+D G B 52 1 S DW="0;1",DV="MP31'X",DU="",DLB="RATED DISABILITIES (VA)",DIFLD=.01 53 S DE(DW)="C1^A1CKC10",DE(DW,"INDEX")=1 54 S DU="DIC(31," 55 S X="`"_ISC 56 S Y=X 57 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 G RD 59 C1 G C1S:$D(DE(1))[0 K DB 60 S X=DE(1),DIC=DIE 61 D EVENT^IVMPLOG($G(DA(1))) 62 C1S S X="" G:DG(DQ)=X C1F1 K DB 1 A1CKC10 ; ;04/21/06 63 2 S X=DG(DQ),DIC=DIE 64 D EVENT^IVMPLOG($G(DA(1))) 65 C1F1 N X,X1,X2 S DIXR=411 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X 66 D 67 . N DIEXARR M DIEXARR=X S DIEZCOND=1 68 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 69 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 70 . S DGRDCHG=1 71 K X M X=X2 D 72 . N DIEXARR M DIEXARR=X S DIEZCOND=1 73 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 74 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 75 . S DGRDCHG=1 76 G C1F2 77 C1X1(DION) K X 78 S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) 79 S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) 80 S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) 81 S X=$G(X(1)) 82 Q 83 C1F2 Q 84 X1 I $D(X) D EK^DGLOCK Q 85 Q 86 ; 87 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFLD=2 88 S DE(DW)="C2^A1CKC10",DE(DW,"INDEX")=1 89 S X=+SCI(ISC) 90 S Y=X 91 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 92 G RD 93 C2 G C2S:$D(DE(2))[0 K DB 94 S X=DE(2),DIC=DIE 95 D EVENT^IVMPLOG($G(DA(1))) 96 C2S S X="" G:DG(DQ)=X C2F1 K DB 97 S X=DG(DQ),DIC=DIE 98 D EVENT^IVMPLOG($G(DA(1))) 99 C2F1 N X,X1,X2 S DIXR=411 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X 100 D 101 . N DIEXARR M DIEXARR=X S DIEZCOND=1 102 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 103 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 104 . S DGRDCHG=1 105 K X M X=X2 D 106 . N DIEXARR M DIEXARR=X S DIEZCOND=1 107 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 108 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 109 . S DGRDCHG=1 110 G C2F2 111 C2X1(DION) K X 112 S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) 113 S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) 114 S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) 115 S X=$G(X(1)) 116 Q 117 C2F2 Q 118 X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^DGLOCK 119 Q 120 ; 121 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFLD=3 122 S DE(DW)="C3^A1CKC10",DE(DW,"INDEX")=1 123 S DU="0:NO;1:YES;" 124 S Y="1" 125 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 126 G RD 127 C3 G C3S:$D(DE(3))[0 K DB 128 S X=DE(3),DIC=DIE 129 D EVENT^IVMPLOG($G(DA(1))) 130 C3S S X="" G:DG(DQ)=X C3F1 K DB 131 S X=DG(DQ),DIC=DIE 132 D EVENT^IVMPLOG($G(DA(1))) 133 C3F1 N X,X1,X2 S DIXR=411 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X 134 D 135 . N DIEXARR M DIEXARR=X S DIEZCOND=1 136 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 137 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 138 . S DGRDCHG=1 139 K X M X=X2 D 140 . N DIEXARR M DIEXARR=X S DIEZCOND=1 141 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 142 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 143 . S DGRDCHG=1 144 G C3F2 145 C3X1(DION) K X 146 S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) 147 S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) 148 S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) 149 S X=$G(X(1)) 150 Q 151 C3F2 Q 152 X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK 153 Q 154 ; 155 4 G 1^DIE17 3 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) 4 I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC11.m
r613 r623 1 A1CKC11 ; ;12/13/08 2 S X=DE(19),DIC=DIE 1 A1CKC11 ; ;04/21/06 2 D DE G BEGIN 3 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" 4 I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(6)=% 5 I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(12)=% S %=$P(%Z,U,13) S:%]"" DE(15)=% S %=$P(%Z,U,14) S:%]"" DE(9)=% 6 K %Z Q 7 ; 8 W W !?DL+DL-2,DLB_": " 9 Q 10 O D W W Y W:$X>45 !?9 11 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 12 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 13 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 14 Q 15 A K DQ(DQ) S DQ=DQ+1 16 B G @DQ 17 RE G PR:$D(DE(DQ)) D W,TR 18 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 19 RD G QS:X?."?" I X["^" D D G ^DIE17 20 I X="@" D D G Z^DIE2 21 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 22 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 23 K DDER G X 24 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 25 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 26 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 27 V D @("X"_DQ) K YS 28 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 29 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 30 S X="?BAD" 31 QS S DZ=X D D,QQ^DIEQ G B 32 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 33 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 34 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 35 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 36 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 37 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 38 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 39 I I DV'["I",DV'["#" G RD 40 D E^DIE0 G RD:$D(X),PR 41 Q 42 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 43 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 44 D ^DIR I 'DDER S %=Y(0),X=Y 45 Q 46 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 47 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 48 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 49 Q 50 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 51 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 52 BEGIN S DNM="A1CKC11",DQ=1 53 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,D=0 K DE(1) ;.3721 54 S DIFLD=.3721,DGO="^A1CKC12",DC="6^2.04P^.372^",DV="2.04MP31'X",DW="0;1",DOW="RATED DISABILITIES (VA)",DLB="Select "_DOW S:D DC=DC_D 55 S DU="DIC(31," 56 G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY(",1)="" X DSC(2.04) S D=$O(^(0)) S:D="" D=-1 G M1 57 S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 58 M1 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(1)=$P(^(0),U,1) 59 S X="`"_ISC 60 S Y=X 61 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 62 G RD 63 R1 D DE 64 G A 65 ; 66 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 67 X2 S Y="@31" 68 Q 69 3 S DQ=4 ;@39 70 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 71 X4 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 72 Q 73 5 S DQ=6 ;@100 74 6 S DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025 75 S DE(DW)="C6^A1CKC11" 76 S DU="Y:YES;N:NO;U:UNKNOWN;" 77 S X=CP 78 S Y=X 79 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 80 G RD 81 C6 G C6S:$D(DE(6))[0 K DB 82 S X=DE(6),DIC=DIE 83 X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4) 84 S X=DE(6),DIC=DIE 85 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4) 86 C6S S X="" G:DG(DQ)=X C6F1 K DB 87 S X=DG(DQ),DIC=DIE 88 X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4) 89 S X=DG(DQ),DIC=DIE 90 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4) 91 C6F1 Q 92 X6 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1 93 Q 94 ; 95 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 96 X7 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 97 Q 98 8 S DQ=9 ;@200 99 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 100 S DE(DW)="C9^A1CKC11" 101 S DU="Y:YES;N:NO;U:UNKNOWN;" 102 S X=PE 103 S Y=X 104 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 105 G RD 106 C9 G C9S:$D(DE(9))[0 K DB 107 S X=DE(9),DIC=DIE 3 108 X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) 4 S X=DE( 19),DIC=DIE109 S X=DE(9),DIC=DIE 5 110 S DFN=DA D EN^DGMTCOR K DGMTCOR 6 S X=DE( 19),DIC=DIE111 S X=DE(9),DIC=DIE 7 112 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) 8 S X=DE( 19),DIC=DIE113 S X=DE(9),DIC=DIE 9 114 D AUTOUPD^DGENA2(DA) 115 C9S S X="" G:DG(DQ)=X C9F1 K DB 116 S X=DG(DQ),DIC=DIE 117 X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) 118 S X=DG(DQ),DIC=DIE 119 S DFN=DA D EN^DGMTCOR K DGMTCOR 120 S X=DG(DQ),DIC=DIE 121 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) 122 S X=DG(DQ),DIC=DIE 123 D AUTOUPD^DGENA2(DA) 124 C9F1 Q 125 X9 S DFN=DA D MV^DGLOCK 126 Q 127 ; 128 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 129 X10 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 130 Q 131 11 S DQ=12 ;@300 132 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 133 S DE(DW)="C12^A1CKC11" 134 S DU="Y:YES;N:NO;U:UNKNOWN;" 135 S X=AA 136 S Y=X 137 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 138 G RD 139 C12 G C12S:$D(DE(12))[0 K DB 140 S X=DE(12),DIC=DIE 141 X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) 142 S X=DE(12),DIC=DIE 143 S DFN=DA D EN^DGMTCOR K DGMTCOR 144 S X=DE(12),DIC=DIE 145 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) 146 S X=DE(12),DIC=DIE 147 D AUTOUPD^DGENA2(DA) 148 C12S S X="" G:DG(DQ)=X C12F1 K DB 149 D ^A1CKC13 150 C12F1 Q 151 X12 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK 152 Q 153 ; 154 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 155 X13 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 156 Q 157 14 S DQ=15 ;@400 158 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 159 S DE(DW)="C15^A1CKC11" 160 S DU="Y:YES;N:NO;U:UNKNOWN;" 161 S X=HB 162 S Y=X 163 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 164 G RD 165 C15 G C15S:$D(DE(15))[0 K DB 166 D ^A1CKC14 167 C15S S X="" G:DG(DQ)=X C15F1 K DB 168 D ^A1CKC15 169 C15F1 Q 170 X15 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK 171 Q 172 ; 173 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 174 X16 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 175 Q 176 17 S DQ=18 ;@999 177 18 G 0^DIE17 -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC12.m
r613 r623 1 A1CKC12 ; ;12/13/08 2 S X=DG(DQ),DIC=DIE 3 X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) 4 S X=DG(DQ),DIC=DIE 5 S DFN=DA D EN^DGMTCOR K DGMTCOR 6 S X=DG(DQ),DIC=DIE 7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) 8 S X=DG(DQ),DIC=DIE 9 D AUTOUPD^DGENA2(DA) 1 A1CKC12 ; ;04/21/06 2 D DE G BEGIN 3 DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% 5 K %Z Q 6 ; 7 W W !?DL+DL-2,DLB_": " 8 Q 9 O D W W Y W:$X>45 !?9 10 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 11 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 12 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 13 Q 14 A K DQ(DQ) S DQ=DQ+1 15 B G @DQ 16 RE G PR:$D(DE(DQ)) D W,TR 17 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 18 RD G QS:X?."?" I X["^" D D G ^DIE17 19 I X="@" D D G Z^DIE2 20 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 21 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 22 K DDER G X 23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 24 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 25 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 26 V D @("X"_DQ) K YS 27 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 28 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 29 S X="?BAD" 30 QS S DZ=X D D,QQ^DIEQ G B 31 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 32 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 33 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 34 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 35 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 36 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 37 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 38 I I DV'["I",DV'["#" G RD 39 D E^DIE0 G RD:$D(X),PR 40 Q 41 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 42 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 43 D ^DIR I 'DDER S %=Y(0),X=Y 44 Q 45 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 46 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 47 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 48 Q 49 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 BEGIN S DNM="A1CKC12",DQ=1+D G B 52 1 S DW="0;1",DV="MP31'X",DU="",DLB="RATED DISABILITIES (VA)",DIFLD=.01 53 S DE(DW)="C1^A1CKC12",DE(DW,"INDEX")=1 54 S DU="DIC(31," 55 S X="`"_ISC 56 S Y=X 57 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 G RD 59 C1 G C1S:$D(DE(1))[0 K DB 60 C1S S X="" G:DG(DQ)=X C1F1 K DB 61 C1F1 N X,X1,X2 S DIXR=411 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X 62 D 63 . N DIEXARR M DIEXARR=X S DIEZCOND=1 64 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 65 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 66 . S DGRDCHG=1 67 K X M X=X2 D 68 . N DIEXARR M DIEXARR=X S DIEZCOND=1 69 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 70 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 71 . S DGRDCHG=1 72 G C1F2 73 C1X1(DION) K X 74 S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) 75 S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) 76 S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) 77 S X=$G(X(1)) 78 Q 79 C1F2 Q 80 X1 I $D(X) D EK^DGLOCK Q 81 Q 82 ; 83 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFLD=2 84 S DE(DW)="C2^A1CKC12",DE(DW,"INDEX")=1 85 S X=+SCI(ISC) 86 S Y=X 87 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 88 G RD 89 C2 G C2S:$D(DE(2))[0 K DB 90 C2S S X="" G:DG(DQ)=X C2F1 K DB 91 C2F1 N X,X1,X2 S DIXR=411 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X 92 D 93 . N DIEXARR M DIEXARR=X S DIEZCOND=1 94 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 95 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 96 . S DGRDCHG=1 97 K X M X=X2 D 98 . N DIEXARR M DIEXARR=X S DIEZCOND=1 99 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 100 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 101 . S DGRDCHG=1 102 G C2F2 103 C2X1(DION) K X 104 S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) 105 S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) 106 S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) 107 S X=$G(X(1)) 108 Q 109 C2F2 Q 110 X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^DGLOCK 111 Q 112 ; 113 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFLD=3 114 S DE(DW)="C3^A1CKC12",DE(DW,"INDEX")=1 115 S DU="0:NO;1:YES;" 116 S Y="1" 117 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 118 G RD 119 C3 G C3S:$D(DE(3))[0 K DB 120 C3S S X="" G:DG(DQ)=X C3F1 K DB 121 C3F1 N X,X1,X2 S DIXR=411 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X 122 D 123 . N DIEXARR M DIEXARR=X S DIEZCOND=1 124 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 125 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 126 . S DGRDCHG=1 127 K X M X=X2 D 128 . N DIEXARR M DIEXARR=X S DIEZCOND=1 129 . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) 130 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND 131 . S DGRDCHG=1 132 G C3F2 133 C3X1(DION) K X 134 S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) 135 S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) 136 S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) 137 S X=$G(X(1)) 138 Q 139 C3F2 Q 140 X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK 141 Q 142 ; 143 4 G 1^DIE17 -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC13.m
r613 r623 1 A1CKC13 ; ; 12/13/082 S X=D E(22),DIC=DIE3 X ^DD(2,.36205,1,1, 2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4)4 S X=D E(22),DIC=DIE1 A1CKC13 ; ;04/21/06 2 S X=DG(DQ),DIC=DIE 3 X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) 4 S X=DG(DQ),DIC=DIE 5 5 S DFN=DA D EN^DGMTCOR K DGMTCOR 6 S X=D E(22),DIC=DIE7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3, 2.4)8 S X=D E(22),DIC=DIE6 S X=DG(DQ),DIC=DIE 7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) 8 S X=DG(DQ),DIC=DIE 9 9 D AUTOUPD^DGENA2(DA) -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC14.m
r613 r623 1 A1CKC14 ; ; 12/13/082 S X=D G(DQ),DIC=DIE3 X ^DD(2,.362 05,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)4 S X=D G(DQ),DIC=DIE1 A1CKC14 ; ;04/21/06 2 S X=DE(15),DIC=DIE 3 X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) 4 S X=DE(15),DIC=DIE 5 5 S DFN=DA D EN^DGMTCOR K DGMTCOR 6 S X=D G(DQ),DIC=DIE7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.362 05,1,3,1.4)8 S X=D G(DQ),DIC=DIE6 S X=DE(15),DIC=DIE 7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) 8 S X=DE(15),DIC=DIE 9 9 D AUTOUPD^DGENA2(DA) -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC15.m
r613 r623 1 A1CKC15 ; ;12/13/08 2 D DE G BEGIN 3 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" 4 I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,13) S:%]"" DE(1)=% 5 K %Z Q 6 ; 7 W W !?DL+DL-2,DLB_": " 8 Q 9 O D W W Y W:$X>45 !?9 10 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 11 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 12 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 13 Q 14 A K DQ(DQ) S DQ=DQ+1 15 B G @DQ 16 RE G PR:$D(DE(DQ)) D W,TR 17 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 18 RD G QS:X?."?" I X["^" D D G ^DIE17 19 I X="@" D D G Z^DIE2 20 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 21 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 22 K DDER G X 23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 24 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 25 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 26 V D @("X"_DQ) K YS 27 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 28 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 29 S X="?BAD" 30 QS S DZ=X D D,QQ^DIEQ G B 31 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 32 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 33 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 34 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 35 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 36 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 37 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 38 I I DV'["I",DV'["#" G RD 39 D E^DIE0 G RD:$D(X),PR 40 Q 41 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 42 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 43 D ^DIR I 'DDER S %=Y(0),X=Y 44 Q 45 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 46 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 47 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 48 Q 49 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 BEGIN S DNM="A1CKC15",DQ=1 52 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 53 S DE(DW)="C1^A1CKC15" 54 S DU="Y:YES;N:NO;U:UNKNOWN;" 55 S X=HB 56 S Y=X 57 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 G RD 59 C1 G C1S:$D(DE(1))[0 K DB 60 S X=DE(1),DIC=DIE 61 X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) 62 S X=DE(1),DIC=DIE 63 S DFN=DA D EN^DGMTCOR K DGMTCOR 64 S X=DE(1),DIC=DIE 65 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) 66 S X=DE(1),DIC=DIE 67 D AUTOUPD^DGENA2(DA) 68 C1S S X="" G:DG(DQ)=X C1F1 K DB 1 A1CKC15 ; ;04/21/06 69 2 S X=DG(DQ),DIC=DIE 70 3 X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) … … 75 8 S X=DG(DQ),DIC=DIE 76 9 D AUTOUPD^DGENA2(DA) 77 C1F1 Q78 X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK79 Q80 ;81 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1782 X2 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99)83 Q84 3 S DQ=4 ;@99985 4 G 0^DIE17 -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC2.m
r613 r623 1 A1CKC2 ; ; 12/13/081 A1CKC2 ; ;04/21/06 2 2 S X=DG(DQ),DIC=DIE 3 S DFN=DA D EN^DGMTCOR K DGMTCOR 4 S X=DG(DQ),DIC=DIE 5 S DFN=DA D EN^DGRP7CC 6 S X=DG(DQ),DIC=DIE 7 X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) 8 S X=DG(DQ),DIC=DIE 9 D AUTOUPD^DGENA2(DA) 10 S X=DG(DQ),DIC=DIE 11 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) 12 S X=DG(DQ),DIC=DIE 13 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) 14 I $D(DE(10))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET 3 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) 4 I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC3.m
r613 r623 1 A1CKC3 ; ;12/13/08 2 S X=DE(11),DIC=DIE 3 ; 4 S X=DE(11),DIC=DIE 5 ; 6 S X=DE(11),DIC=DIE 7 D AUTOUPD^DGENA2(DA) 8 S X=DE(11),DIC=DIE 1 A1CKC3 ; ;04/21/06 2 D DE G BEGIN 3 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" 4 I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(2)=% 5 I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(6)=% 6 I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(4)=% S %=$P(%Z,U,13) S:%]"" DE(5)=% S %=$P(%Z,U,14) S:%]"" DE(3)=% 7 I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(7)=% 8 I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(1)=% 9 K %Z Q 10 ; 11 W W !?DL+DL-2,DLB_": " 12 Q 13 O D W W Y W:$X>45 !?9 14 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 15 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 16 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 17 Q 18 A K DQ(DQ) S DQ=DQ+1 19 B G @DQ 20 RE G PR:$D(DE(DQ)) D W,TR 21 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 22 RD G QS:X?."?" I X["^" D D G ^DIE17 23 I X="@" D D G Z^DIE2 24 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 25 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 26 K DDER G X 27 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 28 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 29 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 30 V D @("X"_DQ) K YS 31 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 32 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 33 S X="?BAD" 34 QS S DZ=X D D,QQ^DIEQ G B 35 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 36 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 37 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 38 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 39 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 40 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 41 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 42 I I DV'["I",DV'["#" G RD 43 D E^DIE0 G RD:$D(X),PR 44 Q 45 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 46 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 47 D ^DIR I 'DDER S %=Y(0),X=Y 48 Q 49 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 50 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 51 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 52 Q 53 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 54 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 55 BEGIN S DNM="A1CKC3",DQ=1 56 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 57 S DE(DW)="C1^A1CKC3" 58 S DU="Y:YES;N:NO;" 59 S Y="Y" 60 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 61 G RD 62 C1 G C1S:$D(DE(1))[0 K DB 63 S X=DE(1),DIC=DIE 64 S DFN=DA D EN^DGMTCOR K DGMTCOR 65 S X=DE(1),DIC=DIE 66 ; 67 S X=DE(1),DIC=DIE 68 D AUTOUPD^DGENA2(DA) 69 S X=DE(1),DIC=DIE 70 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) 71 S X=DE(1),DIC=DIE 72 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) 73 S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET 74 C1S S X="" G:DG(DQ)=X C1F1 K DB 75 S X=DG(DQ),DIC=DIE 76 S DFN=DA D EN^DGMTCOR K DGMTCOR 77 S X=DG(DQ),DIC=DIE 78 X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) 79 S X=DG(DQ),DIC=DIE 80 D AUTOUPD^DGENA2(DA) 81 S X=DG(DQ),DIC=DIE 82 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) 83 S X=DG(DQ),DIC=DIE 84 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) 85 I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET 86 C1F1 Q 87 X1 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK 88 Q 89 ; 90 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 91 S DE(DW)="C2^A1CKC3" 92 S DU="Y:YES;N:NO;" 93 S Y="N" 94 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 95 G RD 96 C2 G C2S:$D(DE(2))[0 K DB 97 S X=DE(2),DIC=DIE 98 ; 99 S X=DE(2),DIC=DIE 100 ; 101 S X=DE(2),DIC=DIE 102 D AUTOUPD^DGENA2(DA) 103 S X=DE(2),DIC=DIE 9 104 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) 10 S X=DE(11),DIC=DIE 11 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) 12 S X=DE(11),DIIX=2_U_DIFLD D AUDIT^DIET 105 S X=DE(2),DIC=DIE 106 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) 107 S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET 108 C2S S X="" G:DG(DQ)=X C2F1 K DB 109 S X=DG(DQ),DIC=DIE 110 X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4) 111 S X=DG(DQ),DIC=DIE 112 X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) 113 S X=DG(DQ),DIC=DIE 114 D AUTOUPD^DGENA2(DA) 115 S X=DG(DQ),DIC=DIE 116 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) 117 S X=DG(DQ),DIC=DIE 118 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) 119 I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET 120 C2F1 Q 121 X2 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK 122 Q 123 ; 124 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 125 S DE(DW)="C3^A1CKC3" 126 S DU="Y:YES;N:NO;U:UNKNOWN;" 127 S X=$S(PE="Y":"Y",1:"N") 128 S Y=X 129 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 130 G RD 131 C3 G C3S:$D(DE(3))[0 K DB 132 S X=DE(3),DIC=DIE 133 X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) 134 S X=DE(3),DIC=DIE 135 S DFN=DA D EN^DGMTCOR K DGMTCOR 136 S X=DE(3),DIC=DIE 137 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) 138 S X=DE(3),DIC=DIE 139 D AUTOUPD^DGENA2(DA) 140 C3S S X="" G:DG(DQ)=X C3F1 K DB 141 S X=DG(DQ),DIC=DIE 142 X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) 143 S X=DG(DQ),DIC=DIE 144 S DFN=DA D EN^DGMTCOR K DGMTCOR 145 S X=DG(DQ),DIC=DIE 146 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) 147 S X=DG(DQ),DIC=DIE 148 D AUTOUPD^DGENA2(DA) 149 C3F1 Q 150 X3 S DFN=DA D MV^DGLOCK 151 Q 152 ; 153 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 154 S DE(DW)="C4^A1CKC3" 155 S DU="Y:YES;N:NO;U:UNKNOWN;" 156 S X=$S(AA="Y":"Y",1:"N") 157 S Y=X 158 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 159 G RD 160 C4 G C4S:$D(DE(4))[0 K DB 161 S X=DE(4),DIC=DIE 162 X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) 163 S X=DE(4),DIC=DIE 164 S DFN=DA D EN^DGMTCOR K DGMTCOR 165 S X=DE(4),DIC=DIE 166 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) 167 S X=DE(4),DIC=DIE 168 D AUTOUPD^DGENA2(DA) 169 C4S S X="" G:DG(DQ)=X C4F1 K DB 170 D ^A1CKC4 171 C4F1 Q 172 X4 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK 173 Q 174 ; 175 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 176 S DE(DW)="C5^A1CKC3" 177 S DU="Y:YES;N:NO;U:UNKNOWN;" 178 S X=$S(HB="Y":"Y",1:"N") 179 S Y=X 180 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 181 G RD 182 C5 G C5S:$D(DE(5))[0 K DB 183 D ^A1CKC5 184 C5S S X="" G:DG(DQ)=X C5F1 K DB 185 D ^A1CKC6 186 C5F1 Q 187 X5 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK 188 Q 189 ; 190 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361 191 S DE(DW)="C6^A1CKC3" 192 S DU="DIC(8," 193 S X=ELIG 194 S Y=X 195 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 196 G RD 197 C6 G C6S:$D(DE(6))[0 K DB 198 D ^A1CKC7 199 C6S S X="" G:DG(DQ)=X C6F1 K DB 200 D ^A1CKC8 201 C6F1 Q 202 X6 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 203 Q 204 ; 205 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391 206 S DE(DW)="C7^A1CKC3",DE(DW,"INDEX")=1 207 S DU="DG(391," 208 S X=DZT2 209 S Y=X 210 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 211 G RD 212 C7 G C7S:$D(DE(7))[0 K DB 213 D ^A1CKC9 214 C7S S X="" G:DG(DQ)=X C7F1 K DB 215 D ^A1CKC10 216 C7F1 N X,X1,X2 S DIXR=664 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X 217 I $G(X(1))]"" D 218 . K ^DPT("APTYPE",X,DA) 219 K X M X=X2 I $G(X(1))]"" D 220 . S ^DPT("APTYPE",X,DA)="" 221 G C7F2 222 C7X1(DION) K X 223 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,391,DION),$P($G(^DPT(DA,"TYPE")),U,1)) 224 S X=$G(X(1)) 225 Q 226 C7F2 Q 227 X7 Q 228 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 229 X8 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 230 Q 231 9 S DQ=10 ;@30 232 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 233 X10 I 'SCI S Y="@39" 234 Q 235 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 236 X11 S ISC=0 237 Q 238 12 S DQ=13 ;@31 239 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 240 X13 S ISC=$O(SCI(ISC)) 241 Q 242 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 243 X14 I 'ISC S Y="@39" 244 Q 245 15 D:$D(DG)>9 F^DIE17 G ^A1CKC11 -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC4.m
r613 r623 1 A1CKC4 ; ; 12/13/081 A1CKC4 ; ;04/21/06 2 2 S X=DG(DQ),DIC=DIE 3 X ^DD(2,.3 01,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4)3 X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) 4 4 S X=DG(DQ),DIC=DIE 5 X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) 5 S DFN=DA D EN^DGMTCOR K DGMTCOR 6 S X=DG(DQ),DIC=DIE 7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) 6 8 S X=DG(DQ),DIC=DIE 7 9 D AUTOUPD^DGENA2(DA) 8 S X=DG(DQ),DIC=DIE9 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA)10 S X=DG(DQ),DIC=DIE11 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)12 I $D(DE(11))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC5.m
r613 r623 1 A1CKC5 ; ; 12/13/082 S X=DE( 12),DIC=DIE3 X ^DD(2,.362 35,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4)4 S X=DE( 12),DIC=DIE1 A1CKC5 ; ;04/21/06 2 S X=DE(5),DIC=DIE 3 X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) 4 S X=DE(5),DIC=DIE 5 5 S DFN=DA D EN^DGMTCOR K DGMTCOR 6 S X=DE( 12),DIC=DIE7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.362 35,1,3,2.4)8 S X=DE( 12),DIC=DIE6 S X=DE(5),DIC=DIE 7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) 8 S X=DE(5),DIC=DIE 9 9 D AUTOUPD^DGENA2(DA) -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC6.m
r613 r623 1 A1CKC6 ; ; 12/13/081 A1CKC6 ; ;04/21/06 2 2 S X=DG(DQ),DIC=DIE 3 X ^DD(2,.362 35,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4)3 X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) 4 4 S X=DG(DQ),DIC=DIE 5 5 S DFN=DA D EN^DGMTCOR K DGMTCOR 6 6 S X=DG(DQ),DIC=DIE 7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.362 35,1,3,1.4)7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) 8 8 S X=DG(DQ),DIC=DIE 9 9 D AUTOUPD^DGENA2(DA) -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC7.m
r613 r623 1 A1CKC7 ; ;12/13/08 2 S X=DE(13),DIC=DIE 3 X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) 4 S X=DE(13),DIC=DIE 5 S DFN=DA D EN^DGMTCOR K DGMTCOR 6 S X=DE(13),DIC=DIE 7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) 8 S X=DE(13),DIC=DIE 1 A1CKC7 ; ;04/21/06 2 S X=DE(6),DIC=DIE 3 ; 4 S X=DE(6),DIC=DIE 5 K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK 6 S X=DE(6),DIC=DIE 7 X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" 8 S X=DE(6),DIC=DIE 9 K ^DPT("AEL",DA,+X) 10 S X=DE(6),DIC=DIE 9 11 D AUTOUPD^DGENA2(DA) 12 S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC8.m
r613 r623 1 A1CKC8 ; ; 12/13/081 A1CKC8 ; ;04/21/06 2 2 S X=DG(DQ),DIC=DIE 3 X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)3 X "S DFN=DA D EN^DGMTR K DGREQF" 4 4 S X=DG(DQ),DIC=DIE 5 S DFN=DA D EN^DGMTCOR K DGMTCOR5 K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) 6 6 S X=DG(DQ),DIC=DIE 7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) 7 ; 8 S X=DG(DQ),DIC=DIE 9 S ^DPT("AEL",DA,+X)="" 8 10 S X=DG(DQ),DIC=DIE 9 11 D AUTOUPD^DGENA2(DA) 12 I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC9.m
r613 r623 1 A1CKC9 ; ;12/13/08 2 D DE G BEGIN 3 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" 4 I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(16)=% 5 I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(2)=% 6 I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(22)=% S %=$P(%Z,U,13) S:%]"" DE(1)=% S %=$P(%Z,U,14) S:%]"" DE(19)=% 7 I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(3)=% 8 K %Z Q 9 ; 10 W W !?DL+DL-2,DLB_": " 11 Q 12 O D W W Y W:$X>45 !?9 13 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 14 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 15 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 16 Q 17 A K DQ(DQ) S DQ=DQ+1 18 B G @DQ 19 RE G PR:$D(DE(DQ)) D W,TR 20 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 21 RD G QS:X?."?" I X["^" D D G ^DIE17 22 I X="@" D D G Z^DIE2 23 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 24 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 25 K DDER G X 26 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 27 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 28 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 29 V D @("X"_DQ) K YS 30 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 31 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 32 S X="?BAD" 33 QS S DZ=X D D,QQ^DIEQ G B 34 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 35 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 36 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 37 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 38 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 39 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 40 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 41 I I DV'["I",DV'["#" G RD 42 D E^DIE0 G RD:$D(X),PR 43 Q 44 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 45 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 46 D ^DIR I 'DDER S %=Y(0),X=Y 47 Q 48 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 49 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 50 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 51 Q 52 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 53 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 54 BEGIN S DNM="A1CKC9",DQ=1 55 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 56 S DE(DW)="C1^A1CKC9" 57 S DU="Y:YES;N:NO;U:UNKNOWN;" 58 S X=$S(HB="Y":"Y",1:"N") 59 S Y=X 60 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 61 G RD 62 C1 G C1S:$D(DE(1))[0 K DB 63 S X=DE(1),DIC=DIE 64 X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) 65 S X=DE(1),DIC=DIE 66 S DFN=DA D EN^DGMTCOR K DGMTCOR 67 S X=DE(1),DIC=DIE 68 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) 69 S X=DE(1),DIC=DIE 70 D AUTOUPD^DGENA2(DA) 71 C1S S X="" G:DG(DQ)=X C1F1 K DB 72 S X=DG(DQ),DIC=DIE 73 X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) 74 S X=DG(DQ),DIC=DIE 75 S DFN=DA D EN^DGMTCOR K DGMTCOR 76 S X=DG(DQ),DIC=DIE 77 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) 78 S X=DG(DQ),DIC=DIE 79 D AUTOUPD^DGENA2(DA) 80 C1F1 Q 81 X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK 82 Q 83 ; 84 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361 85 S DE(DW)="C2^A1CKC9" 86 S DU="DIC(8," 87 S X=ELIG 88 S Y=X 89 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 90 G RD 91 C2 G C2S:$D(DE(2))[0 K DB 92 S X=DE(2),DIC=DIE 93 ; 94 S X=DE(2),DIC=DIE 95 K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK 96 S X=DE(2),DIC=DIE 97 X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" 98 S X=DE(2),DIC=DIE 99 K ^DPT("AEL",DA,+X) 100 S X=DE(2),DIC=DIE 101 D AUTOUPD^DGENA2(DA) 102 S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET 103 C2S S X="" G:DG(DQ)=X C2F1 K DB 104 S X=DG(DQ),DIC=DIE 105 X "S DFN=DA D EN^DGMTR K DGREQF" 106 S X=DG(DQ),DIC=DIE 107 K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) 108 S X=DG(DQ),DIC=DIE 109 ; 110 S X=DG(DQ),DIC=DIE 111 S ^DPT("AEL",DA,+X)="" 112 S X=DG(DQ),DIC=DIE 113 D AUTOUPD^DGENA2(DA) 114 I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET 115 C2F1 Q 116 X2 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 117 Q 118 ; 119 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="TYPE;1",DV="P391'a",DU="",DLB="TYPE",DIFLD=391 120 S DE(DW)="C3^A1CKC9",DE(DW,"INDEX")=1 121 S DU="DG(391," 122 S X=DZT2 123 S Y=X 124 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 125 G RD 126 C3 G C3S:$D(DE(3))[0 K DB 127 S X=DE(3),DIC=DIE 1 A1CKC9 ; ;04/21/06 2 S X=DE(7),DIC=DIE 128 3 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) 129 S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET 130 C3S S X="" G:DG(DQ)=X C3F1 K DB 131 S X=DG(DQ),DIC=DIE 132 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) 133 I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET 134 C3F1 N X,X1,X2 S DIXR=664 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X 135 I $G(X(1))]"" D 136 . K ^DPT("APTYPE",X,DA) 137 K X M X=X2 I $G(X(1))]"" D 138 . S ^DPT("APTYPE",X,DA)="" 139 G C3F2 140 C3X1(DION) K X 141 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,391,DION),$P($G(^DPT(DA,"TYPE")),U,1)) 142 S X=$G(X(1)) 143 Q 144 C3F2 Q 145 X3 Q 146 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 147 X4 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 148 Q 149 5 S DQ=6 ;@30 150 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 151 X6 I 'SCI S Y="@39" 152 Q 153 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 154 X7 S ISC=0 155 Q 156 8 S DQ=9 ;@31 157 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 158 X9 S ISC=$O(SCI(ISC)) 159 Q 160 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 161 X10 I 'ISC S Y="@39" 162 Q 163 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,D=0 K DE(1) ;.3721 164 S DIFLD=.3721,DGO="^A1CKC10",DC="6^2.04P^.372^",DV="2.04MP31'X",DW="0;1",DOW="RATED DISABILITIES (VA)",DLB="Select "_DOW S:D DC=DC_D 165 S DU="DIC(31," 166 G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY(",1)="" X DSC(2.04) S D=$O(^(0)) S:D="" D=-1 G M11 167 S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 168 M11 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(11)=$P(^(0),U,1) 169 S X="`"_ISC 170 S Y=X 171 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 172 G RD 173 R11 D DE 174 G A 175 ; 176 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 177 X12 S Y="@31" 178 Q 179 13 S DQ=14 ;@39 180 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 181 X14 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 182 Q 183 15 S DQ=16 ;@100 184 16 S DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025 185 S DE(DW)="C16^A1CKC9" 186 S DU="Y:YES;N:NO;U:UNKNOWN;" 187 S X=CP 188 S Y=X 189 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 190 G RD 191 C16 G C16S:$D(DE(16))[0 K DB 192 S X=DE(16),DIC=DIE 193 X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4) 194 S X=DE(16),DIC=DIE 195 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4) 196 S X=DE(16),DIC=DIE 197 D EVENT^IVMPLOG(DA) 198 C16S S X="" G:DG(DQ)=X C16F1 K DB 199 S X=DG(DQ),DIC=DIE 200 X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4) 201 S X=DG(DQ),DIC=DIE 202 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4) 203 S X=DG(DQ),DIC=DIE 204 D EVENT^IVMPLOG(DA) 205 C16F1 Q 206 X16 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1 207 Q 208 ; 209 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 210 X17 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 211 Q 212 18 S DQ=19 ;@200 213 19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 214 S DE(DW)="C19^A1CKC9" 215 S DU="Y:YES;N:NO;U:UNKNOWN;" 216 S X=PE 217 S Y=X 218 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 219 G RD 220 C19 G C19S:$D(DE(19))[0 K DB 221 D ^A1CKC11 222 C19S S X="" G:DG(DQ)=X C19F1 K DB 223 D ^A1CKC12 224 C19F1 Q 225 X19 S DFN=DA D MV^DGLOCK 226 Q 227 ; 228 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 229 X20 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 230 Q 231 21 S DQ=22 ;@300 232 22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 233 S DE(DW)="C22^A1CKC9" 234 S DU="Y:YES;N:NO;U:UNKNOWN;" 235 S X=AA 236 S Y=X 237 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 238 G RD 239 C22 G C22S:$D(DE(22))[0 K DB 240 D ^A1CKC13 241 C22S S X="" G:DG(DQ)=X C22F1 K DB 242 D ^A1CKC14 243 C22F1 Q 244 X22 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK 245 Q 246 ; 247 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 248 X23 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) 249 Q 250 24 S DQ=25 ;@400 251 25 D:$D(DG)>9 F^DIE17 G ^A1CKC15 4 S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP2.m
r613 r623 1 RGADTP2 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;10/30/02 10:04 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**27,20,45,44,47,48,49,52**;30 Apr 99;Build 2 3 DBIA ; 4 ;Reference to $$ADD^VAFCEHU1 supported by IA #2753 5 ;Reference to EDIT^VAFCPTED supported by IA #2784 6 Q 7 PROCIN(ARRAY,RGLOCAL,RGER,DFN,HL) ; 8 N RGRSDFN,OTHSITE,NODE,ICN,CMORIEN,CMOR,CMORDISP,SENSTVTY,RMTDOD,LOCDOD,VAFCA,VAFCA08,HERE,BOGUS,ARAY,REP 9 S REP=$E(HL("ECH"),2) 10 S HERE=$P($$SITE^VASITE,"^",3) 11 ;if sending site is your site quit 12 Q:$G(ARRAY("MPISSITE"))=$G(HERE) 13 S ARRAY(.097)=$P($$NOW^XLFDT,".") 14 I $G(ARRAY("ICN"))'="" D 15 .S RGRSDFN=$$GETDFN^MPIF001(+ARRAY("ICN")) I +RGRSDFN<1 S RGER=RGRSDFN_" ICN#"_$G(ARRAY("ICN")) Q ;quit and return error msg 16 .S OTHSITE=ARRAY("SENDING SITE") ;**40 REMOVED THE PLUS TO KEEP SUFFIX ON STATION# & CHANGED THE SITE TO BE SENDING SITE INSTEAD OF AUTHORITATIVE SOURCE 17 I $G(RGRSDFN)="" S RGRSDFN=$G(DFN) 18 I $G(RGRSDFN)="" S RGER="-1^DFN not defined" 19 Q:$G(RGER) 20 I $G(OTHSITE)="" S OTHSITE="" 21 S NODE=$$MPINODE^MPIFAPI(RGRSDFN) 22 S ICN=$P(NODE,"^") 23 S CMORIEN=$P(NODE,"^",3) 24 S CMOR=$$NS^XUAF4(CMORIEN) 25 S CMORDISP=$P(CMOR,"^",1) 26 S CMOR=$P(CMOR,"^",2) 27 ; 28 ;If patient is Sensitive at other site but not here send bulletin 29 I $G(ARRAY("SENSITIVITY"))'="" S SENSTVTY=$G(ARRAY("SENSITIVITY")) D 30 .N NAME S NAME=ARRAY("NAME") 31 .I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D 32 ..S ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") 33 ..S ARAY("SENSITIVITY USER")=ARRAY("SENSITIVITY USER"),ARAY("SENSITIVITY DATE")=ARRAY("SENSITIVITY DATE") 34 ..D SENSTIVE^RGRSBUL1(RGRSDFN,"ARAY",NAME) 35 ; 36 ;MPIC_772 - **52; Commented out Remote Date of Death Indicated section. 37 ;If patient has DATE OF DEATH (DOD) at remote site send bulletin 38 ;Ignore time if present with date. 39 ;S RMTDOD=$G(ARRAY("MPIDOD")),RMTDOD=$P(RMTDOD,".") 40 ;S DFN=RGRSDFN D DEM^VADPT 41 ;S LOCDOD=$P($P(VADM(6),"^"),".") 42 ;If there is a remote DOD but no local DOD OR if remote DOD is different from local DOD, send bulletin 43 ;I RMTDOD D 44 ;.N NAME S NAME=ARRAY("NAME"),ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") 45 ;.D RMTDOD^RGRSBUL1(RGRSDFN,"ARAY",NAME,RMTDOD,LOCDOD) 46 ;K VADM 47 ; 48 NOTLOC I 'RGLOCAL D 49 .;if sending site is not the CMOR AND NOT THE MPI - log update into PDR if differences exist **45 ADDED MPI 50 .I (OTHSITE)'=(CMOR)&(OTHSITE'="200M") D Q 51 ..S VAFCA=$P($$NOW^XLFDT,".")_"^"_$$NOW^XLFDT_"^"_$G(ARRAY("SENDING SITE"))_"^"_RGRSDFN 52 ..S ARRAY(.01)=$$FREE^RGRSPARS(ARRAY("NAME")),ARRAY(.03)=$$FREE^RGRSPARS($G(ARRAY("MPIDOB"))) 53 ..S ARRAY(.09)=$$FREE^RGRSPARS($G(ARRAY("SSN"))),ARRAY(.02)=$$SEX^RGRSPARS($G(ARRAY("SEX"))) 54 ..S ARRAY(.2403)=$$FREE^RGRSPARS($G(ARRAY("MMN"))),ARRAY(991.01)=$P($G(ARRAY("ICN")),"V") 55 ..N ARAY M ARAY(2)=ARRAY 56 ..S VAFCA08=1 ;S BOGUS=$$ADD^VAFCEHU1(VAFCA,"ARAY") comment out by RG*1*49 57 .;if sending site is the CMOR OR MPI - synchronize data **45 ADDED MPI AND SSNV TO UPDATED FIELDS 58 .I (OTHSITE)=(CMOR)!(OTHSITE="200M") D 59 ..;**44 is there an outstanding edit in the ADT/HL7 PIVOT file for this patient for an identity element 60 ..S RGER=$$CHKPVT^RGADTP3(.ARRAY) Q:+RGER<0 61 ..N DR,ARAY2 S RGER="" 62 ..D DIFF^RGADTP3(.ARRAY,RGRSDFN,.DR,.ARRAY) ;**47 63 ..I DR'="" D 64 ...S VAFCA08=1,ARAY(2,.01)=ARRAY("NAME"),ARAY(2,.03)=$G(ARRAY("MPIDOB")) 65 ...I ARRAY("SSN")'="" S ARAY(2,.09)=$G(ARRAY("SSN")) ;**45 only set SSN to update if it isn't null 66 ...S ARAY(2,.02)=$G(ARRAY("SEX")),ARAY(2,.2403)=$G(ARRAY("MMN")),ARAY(2,994)=$G(ARRAY("MBI")) 67 ...;**48 ONLY SET SSN VERIFICATION STATUS AND PSEUDO SSN REASON IF SSN UPDATE WAS SUCCESSFUL 68 ...I $D(ARRAY("ALIAS")) M ARAY(2,1)=ARRAY("ALIAS") ;**48 ADD ALIAS TO MIX 69 ...D EDIT^VAFCPTED(RGRSDFN,"ARAY(2)",DR) 70 ...;check to see if edits were successful, if not set RGER="why it failed" 71 ...N NAME,SSN,PDOB,SEX,MMN,OLDNAME,OLDHLNAM,OLDMMN,OLDHLMMN,HLNAME,HLMMN,SSNV,MBI 72 ...S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01,"I"),PDOB=$$GET1^DIQ(2,+RGRSDFN_",",.03,"I") 73 ...S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09,"I"),SEX=$$GET1^DIQ(2,+RGRSDFN_",",.02,"I") 74 ...S MMN=$$GET1^DIQ(2,+RGRSDFN_",",.2403,"I"),MBI=$$GET1^DIQ(2,+RGRSDFN_",",994,"I") 75 ...D STDNAME^XLFNAME(.NAME,"F",.OLDNAME) S HLNAME=ARRAY("NAME") D STDNAME^XLFNAME(.HLNAME,"F",.OLDHLNAM) 76 ...I NAME'=$G(HLNAME) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Name field failure" 77 ...I PDOB'=$G(ARRAY("MPIDOB")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"DOB field failure" 78 ...;**48 79 ...I SSN["P" D 80 ....;if pseudo SSN reason field has been added to the DD then attempt to set it 81 ....N PS,ERROR,LABEL D FIELD^DID(2,.0906,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D 82 .....S ARAY2(2,.0906)=$G(ARRAY(.0906)),DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) 83 .....S PS=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") 84 .....I PS=""&(ARAY2(2,.0906)="@") Q 85 .....I PS'=ARAY2(2,.0906) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" 86 .....I PS=ARAY2(2,.0906) D 87 ......K ARAY2 N ERROR,LABEL D FIELD^DID(2,.0907,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D 88 ......S ARAY2(2,.0907)=$G(ARRAY(.0907)),DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) 89 ......S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") 90 ......S:$G(ARRAY(.0907))="@" ARRAY(.0907)="" I SSNV'=$G(ARRAY(.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" 91 ...I $G(ARRAY("SSN"))'="",SSN'=$G(ARRAY("SSN")) D 92 ....I $G(ARRAY("SSN"))="P",SSN["P" Q ;**47 NEEDED TO CREATE PSEUDO AND DID 93 ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN field failure" ;**45 only check if SSN is sent isn't null 94 ...I SSN=$G(ARRAY("SSN")) D 95 ....;if SSN VERIFICATION STATUS field has been added to the DD then attempt to set it 96 ....K ARAY2 N ERROR,LABEL D FIELD^DID(2,.0907,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D 97 .....S ARAY2(2,.0907)=$G(ARRAY(.0907)) S DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) 98 .....S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") 99 .....S:$G(ARRAY(.0907))="@" ARRAY(.0907)="" I SSNV'=$G(ARRAY(.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" 100 .....I SSNV'="" D 101 ......N PS,ERROR,LABEL D FIELD^DID(2,.0906,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D 102 ......S ARAY2(2,.0906)=$G(ARRAY(.0906)) S DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) 103 ......S PS=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") 104 ......I PS=""&(ARAY2(2,.0906)="@") Q 105 ......S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" 106 ...I SEX'=$G(ARRAY("SEX")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SEX field failure" 107 ...D STDNAME^XLFNAME(.MMN,"F",.OLDMMN) S HLMMN=ARRAY("MMN") D STDNAME^XLFNAME(.HLMMN,"F",.OLDHLMMN) 108 ...I MMN'=$G(HLMMN) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MOTHER'S MAIDEN NAME field failure" 109 ...;**REMOVED MBI FROM PATCH 45 PUT BACK IN **47 110 ...I MBI'=$G(ARRAY("MBI")) D 111 ....Q:MBI=""&($G(ARRAY("MBI"))="@") ;**47 "" AND @ ARE THE SAME 112 ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MULTIPLE BIRTH INDICATOR field failure" 113 ...;send the updated fields to the MPI to synch site with MPI 114 ...I HL("ETN")'="A31" S ZTSAVE("DFN")="",ZTRTN="MPISYN^RGADTPC",ZTDESC="Sending Synchronized Patient Data to MPI...",ZTIO="RG QUEUE",ZTDTH=$H D ^%ZTLOAD 115 ...;**45 ^ don't trigger A31 sync message if A31 was being processed-- ack to a31 will sync id elements on MPI 116 Q 1 RGADTP2 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;10/30/02 10:04 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**27,20,45,44,47,48**;30 Apr 99;Build 3 3 DBIA ; 4 ;Reference to $$ADD^VAFCEHU1 supported by IA #2753 5 ;Reference to EDIT^VAFCPTED supported by IA #2784 6 Q 7 PROCIN(ARRAY,RGLOCAL,RGER,DFN,HL) ; 8 N RGRSDFN,OTHSITE,NODE,ICN,CMORIEN,CMOR,CMORDISP,SENSTVTY,RMTDOD,LOCDOD,VAFCA,VAFCA08,HERE,BOGUS,ARAY,REP 9 S REP=$E(HL("ECH"),2) 10 S HERE=$P($$SITE^VASITE,"^",3) 11 ;if sending site is your site quit 12 Q:$G(ARRAY("MPISSITE"))=$G(HERE) 13 S ARRAY(.097)=$P($$NOW^XLFDT,".") 14 I $G(ARRAY("ICN"))'="" D 15 .S RGRSDFN=$$GETDFN^MPIF001(+ARRAY("ICN")) I +RGRSDFN<1 S RGER=RGRSDFN_" ICN#"_$G(ARRAY("ICN")) Q ;quit and return error msg 16 .S OTHSITE=ARRAY("SENDING SITE") ;**40 REMOVED THE PLUS TO KEEP SUFFIX ON STATION# & CHANGED THE SITE TO BE SENDING SITE INSTEAD OF AUTHORITATIVE SOURCE 17 I $G(RGRSDFN)="" S RGRSDFN=$G(DFN) 18 I $G(RGRSDFN)="" S RGER="-1^DFN not defined" 19 Q:$G(RGER) 20 I $G(OTHSITE)="" S OTHSITE="" 21 S NODE=$$MPINODE^MPIFAPI(RGRSDFN) 22 S ICN=$P(NODE,"^") 23 S CMORIEN=$P(NODE,"^",3) 24 S CMOR=$$NS^XUAF4(CMORIEN) 25 S CMORDISP=$P(CMOR,"^",1) 26 S CMOR=$P(CMOR,"^",2) 27 ; 28 ;If patient is Sensitive at other site but not here send bulletin 29 I $G(ARRAY("SENSITIVITY"))'="" S SENSTVTY=$G(ARRAY("SENSITIVITY")) D 30 .N NAME S NAME=ARRAY("NAME") 31 .I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D 32 ..S ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") 33 ..S ARAY("SENSITIVITY USER")=ARRAY("SENSITIVITY USER"),ARAY("SENSITIVITY DATE")=ARRAY("SENSITIVITY DATE") 34 ..D SENSTIVE^RGRSBUL1(RGRSDFN,"ARAY",NAME) 35 ; 36 ;If patient has DATE OF DEATH (DOD) at remote site send bulletin 37 ;Ignore time if present with date. 38 S RMTDOD=$G(ARRAY("MPIDOD")),RMTDOD=$P(RMTDOD,".") 39 S DFN=RGRSDFN D DEM^VADPT 40 S LOCDOD=$P($P(VADM(6),"^"),".") 41 ;If there is a remote DOD but no local DOD OR if remote DOD is different from local DOD, send bulletin 42 I RMTDOD D 43 .N NAME S NAME=ARRAY("NAME"),ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") 44 .D RMTDOD^RGRSBUL1(RGRSDFN,"ARAY",NAME,RMTDOD,LOCDOD) 45 K VADM 46 ; 47 NOTLOC I 'RGLOCAL D 48 .;if sending site is not the CMOR AND NOT THE MPI - log update into PDR if differences exist **45 ADDED MPI 49 .I (OTHSITE)'=(CMOR)&(OTHSITE'="200M") D Q 50 ..S VAFCA=$P($$NOW^XLFDT,".")_"^"_$$NOW^XLFDT_"^"_$G(ARRAY("SENDING SITE"))_"^"_RGRSDFN 51 ..S ARRAY(.01)=$$FREE^RGRSPARS(ARRAY("NAME")),ARRAY(.03)=$$FREE^RGRSPARS($G(ARRAY("MPIDOB"))) 52 ..S ARRAY(.09)=$$FREE^RGRSPARS($G(ARRAY("SSN"))),ARRAY(.02)=$$SEX^RGRSPARS($G(ARRAY("SEX"))) 53 ..S ARRAY(.2403)=$$FREE^RGRSPARS($G(ARRAY("MMN"))),ARRAY(991.01)=$P($G(ARRAY("ICN")),"V") 54 ..N ARAY M ARAY(2)=ARRAY 55 ..S VAFCA08=1 S BOGUS=$$ADD^VAFCEHU1(VAFCA,"ARAY") 56 .;if sending site is the CMOR OR MPI - synchronize data **45 ADDED MPI AND SSNV TO UPDATED FIELDS 57 .I (OTHSITE)=(CMOR)!(OTHSITE="200M") D 58 ..;**44 is there an outstanding edit in the ADT/HL7 PIVOT file for this patient for an identity element 59 ..S RGER=$$CHKPVT^RGADTP3(.ARRAY) Q:+RGER<0 60 ..N DR,ARAY2 S RGER="" 61 ..D DIFF^RGADTP3(.ARRAY,RGRSDFN,.DR,.ARRAY) ;**47 62 ..I DR'="" D 63 ...S VAFCA08=1,ARAY(2,.01)=ARRAY("NAME"),ARAY(2,.03)=$G(ARRAY("MPIDOB")) 64 ...I ARRAY("SSN")'="" S ARAY(2,.09)=$G(ARRAY("SSN")) ;**45 only set SSN to update if it isn't null 65 ...S ARAY(2,.02)=$G(ARRAY("SEX")),ARAY(2,.2403)=$G(ARRAY("MMN")),ARAY(2,994)=$G(ARRAY("MBI")) 66 ...;**48 ONLY SET SSN VERIFICATION STATUS AND PSEUDO SSN REASON IF SSN UPDATE WAS SUCCESSFUL 67 ...I $D(ARRAY("ALIAS")) M ARAY(2,1)=ARRAY("ALIAS") ;**48 ADD ALIAS TO MIX 68 ...D EDIT^VAFCPTED(RGRSDFN,"ARAY(2)",DR) 69 ...;check to see if edits were successful, if not set RGER="why it failed" 70 ...N NAME,SSN,PDOB,SEX,MMN,OLDNAME,OLDHLNAM,OLDMMN,OLDHLMMN,HLNAME,HLMMN,SSNV,MBI 71 ...S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01,"I"),PDOB=$$GET1^DIQ(2,+RGRSDFN_",",.03,"I") 72 ...S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09,"I"),SEX=$$GET1^DIQ(2,+RGRSDFN_",",.02,"I") 73 ...S MMN=$$GET1^DIQ(2,+RGRSDFN_",",.2403,"I"),MBI=$$GET1^DIQ(2,+RGRSDFN_",",994,"I") 74 ...D STDNAME^XLFNAME(.NAME,"F",.OLDNAME) S HLNAME=ARRAY("NAME") D STDNAME^XLFNAME(.HLNAME,"F",.OLDHLNAM) 75 ...I NAME'=$G(HLNAME) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Name field failure" 76 ...I PDOB'=$G(ARRAY("MPIDOB")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"DOB field failure" 77 ...;**48 78 ...I SSN["P" D 79 ....;if pseudo SSN reason field has been added to the DD then attempt to set it 80 ....N PS,ERROR,LABEL D FIELD^DID(2,.0906,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D 81 .....S ARAY2(2,.0906)=$G(ARRAY(.0906)),DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) 82 .....S PS=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") 83 .....I PS=""&(ARAY2(2,.0906)="@") Q 84 .....I PS'=ARAY2(2,.0906) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" 85 .....I PS=ARAY2(2,.0906) D 86 ......K ARAY2 N ERROR,LABEL D FIELD^DID(2,.0907,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D 87 ......S ARAY2(2,.0907)=$G(ARRAY(.0907)),DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) 88 ......S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") 89 ......S:$G(ARRAY(.0907))="@" ARRAY(.0907)="" I SSNV'=$G(ARRAY(.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" 90 ...I $G(ARRAY("SSN"))'="",SSN'=$G(ARRAY("SSN")) D 91 ....I $G(ARRAY("SSN"))="P",SSN["P" Q ;**47 NEEDED TO CREATE PSEUDO AND DID 92 ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN field failure" ;**45 only check if SSN is sent isn't null 93 ...I SSN=$G(ARRAY("SSN")) D 94 ....;if SSN VERIFICATION STATUS field has been added to the DD then attempt to set it 95 ....K ARAY2 N ERROR,LABEL D FIELD^DID(2,.0907,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D 96 .....S ARAY2(2,.0907)=$G(ARRAY(.0907)) S DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) 97 .....S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") 98 .....S:$G(ARRAY(.0907))="@" ARRAY(.0907)="" I SSNV'=$G(ARRAY(.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" 99 .....I SSNV'="" D 100 ......N PS,ERROR,LABEL D FIELD^DID(2,.0906,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D 101 ......S ARAY2(2,.0906)=$G(ARRAY(.0906)) S DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) 102 ......S PS=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") 103 ......I PS=""&(ARAY2(2,.0906)="@") Q 104 ......S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" 105 ...I SEX'=$G(ARRAY("SEX")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SEX field failure" 106 ...D STDNAME^XLFNAME(.MMN,"F",.OLDMMN) S HLMMN=ARRAY("MMN") D STDNAME^XLFNAME(.HLMMN,"F",.OLDHLMMN) 107 ...I MMN'=$G(HLMMN) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MOTHER'S MAIDEN NAME field failure" 108 ...;**REMOVED MBI FROM PATCH 45 PUT BACK IN **47 109 ...I MBI'=$G(ARRAY("MBI")) D 110 ....Q:MBI=""&($G(ARRAY("MBI"))="@") ;**47 "" AND @ ARE THE SAME 111 ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MULTIPLE BIRTH INDICATOR field failure" 112 ...;send the updated fields to the MPI to synch site with MPI 113 ...I HL("ETN")'="A31" S ZTSAVE("DFN")="",ZTRTN="MPISYN^RGADTPC",ZTDESC="Sending Synchronized Patient Data to MPI...",ZTIO="RG QUEUE",ZTDTH=$H D ^%ZTLOAD 114 ...;**45 ^ don't trigger A31 sync message if A31 was being processed-- ack to a31 will sync id elements on MPI 115 Q -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGHLLOG.m
r613 r623 1 RGHLLOG ;CAIRO/DKM-LOG MESSAGE PROCESSING INFO ;09/04/98 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,11,13,18,19,25,45,52**;30 Apr 99;Build 2 3 ; 4 ;Reference to ^HLMA("C" supported by IA #3244 5 ;================================================================= 6 ; Log information about message processing and exceptions 7 ; in CIRN HL7 Exception Log file. 8 ;================================================================= 9 ; Start time for run log 10 START(RGMSG,RGDC,RGPARAM) ; 11 ;This entry point starts the log process in the CIRN HL7 EXCEPTION LOG 12 ;file (#991.1), if the (#6) MINIMAL EXCEPTION LOGGING? field in 13 ;File #990.8 is set to 0. 14 ; Input: Required 15 ; RGMSG - IEN of message entry in File #773, usually HLMTIEN 16 ; Optional 17 ; RGDC - Event Class, associated with an entry in File # 18 ; RGPARAM - reprocessing routine 19 S U="^" 20 K RGLOG 21 S RGLOG(3)=$G(RGMSG),RGLOG(5)=$G(RGDC),RGLOG(4)=$G(RGPARAM),RGLOG(1)=$$NOW^XLFDT 22 I '$P(^RGSITE("COR",1,0),U,8) S RGLOG=$$CREATE 23 Q 24 ; Create a log entry 25 CREATE() Q:$G(RGLOG) RGLOG 26 L +^RGHL7(991.1,0):10 27 S RGLOG=$O(^RGHL7(991.1,$C(32)),-1)+1 28 S:$G(RGLOG(1))="" RGLOG(1)=$$NOW^XLFDT 29 S RGLOG(3)=$S($G(RGLOG(3))=0:0,$G(HL("MID"))="":"",1:$$IEN773($G(HL("MID")))) 30 S (DA,X)=RGLOG,DIC="^RGHL7(991.1,",DIC(0)="L",DLAYGO=991.1,DIC("DR")="1///"_$G(RGLOG(1))_";3////"_$G(RGLOG(3))_";5///"_$G(RGLOG(5))_";4////"_$G(RGLOG(4)) K DD,DO D FILE^DICN K DIC,DA,X,DLAYGO 31 L -^RGHL7(991.1,0) 32 Q RGLOG 33 ; Log time run completed 34 STOP(RGQUIT) ; 35 ;This entry point completes the logging process 36 ; Input: required 37 ; RGQUIT - 0 for success and 1 for failure 38 ; 39 Q:'$G(RGLOG) 40 L +^RGHL7(991.1,RGLOG):10 41 S DIE="^RGHL7(991.1,",DR="1.5///NOW;1.6///^S X=$G(RGQUIT)",DA=RGLOG D ^DIE K DIE,DA,DR 42 L -^RGHL7(991.1,RGLOG) 43 K RGLOG,RGQUIT,X,Y,DIC,DIE 44 Q 45 ; Log unclassified exception (old entry point) 46 ERR(RGERR,RGSEV) ; 47 D EXC(18,RGERR) 48 S RGQUIT=$G(RGQUIT)!$G(RGSEV) 49 Q 50 ; Log an exception 51 EXC(RGEXC,RGERR,RGDFN,MSGID,STATNUM) ; 52 ;This entry point logs exceptions in the CIRN HL7 EXCEPTION LOG 53 ;file (#991.1) 54 ; Input: Required 55 ; RGEXC - Exception type in File #991.11 56 ; RGERR - Supplemental text 57 ; Optional 58 ; RGDFN - IEN in the PATIENT file (#2) 59 ; MSGID - message id of the HL7 message where the exception was encountered (optional) 60 ; STATNUM - station # of site that encountered the error (optional) - if not defined then the local site is assumed, using $$SITE^VASITE 61 ; 62 I (RGEXC=215)!(RGEXC=216)!(RGEXC=217) Q ;**52 until MPIFBT3 call eliminates these exception types 63 I $L($G(HL("MID"))) Q:$$INVEXC(HL("MID")) ; is the exception valid? 64 N RGI,RGZ 65 S U="^" 66 S:RGEXC[U RGERR=$P(RGEXC,U,2,999),RGEXC=+RGEXC 67 S:RGEXC'=+RGEXC RGERR=RGEXC,RGEXC=18 68 S:'$D(^RGHL7(991.11,RGEXC)) RGEXC=18 69 L +^RGHL7(991.11,RGEXC):10 70 S RGZ=$G(^RGHL7(991.11,RGEXC,0)) 71 S:$L(RGZ) $P(^RGHL7(991.11,RGEXC,0),U,5)=$P(RGZ,U,5)+1 72 S:$P(RGZ,U,2)>1 RGQUIT=1 73 L -^RGHL7(991.11,RGEXC) 74 S RGLOG=$$CREATE 75 L +^RGHL7(991.1,RGLOG):10 76 S RGI=$O(^RGHL7(991.1,RGLOG,1,$C(32)),-1)+1 77 S RGERR=$E($G(RGERR),1,250) 78 S DIC="^RGHL7(991.1,"_RGLOG_",1," 79 S X=RGI,DA(1)=RGLOG,DIC(0)="FL",DLAYGO=991.12,DIC("P")=$P(^DD(991.1,2,0),"^",2) 80 D ^DIC 81 S DIE=DIC 82 K DIC,DA,DR,DLAYGO 83 S STAT=0 84 S DIC="3.8",DIC(0)="Z",X="MPIF EXCEPTIONS" D ^DIC K DIC 85 S RGMG=$P($G(Y),"^",1) 86 I $P(^RGHL7(991.11,RGEXC,0),U,4)=RGMG S STAT=1 87 S DA(1)=RGLOG,DA=RGI,DR="2///"_$G(RGEXC)_";3///"_$S($G(RGDFN):"`"_RGDFN,1:"")_";6///"_$G(STAT)_";10///"_$G(RGERR) 88 D ^DIE K DIE,DA,DR 89 L -^RGHL7(991.1,RGLOG) 90 S RGI=$P(RGZ,U,3),RGZ=$P(RGZ,U,4) 91 ; 92 ;If the action type is for the MPI Exception Handler, send exception to the handler and quit 93 I (RGI=3) D SENDMPI^RGHLLOG1($G(RGEXC),$G(RGERR),$G(RGDFN),$G(MSGID),$G(STATNUM)) Q 94 ; 95 Q:'RGI!'RGZ 96 ;quit and don't send messages for exception types that are now being 97 ;handled through the MPI/PD Exception Handling option. 98 Q:RGEXC=234!(RGEXC=218) ;MPIC_772; **52 remove 215, 216, and 217 99 S DIC="^XMB(3.8,",DIC(0)="NZ",X="`"_RGZ D ^DIC K DIC Q:+Y<1 S RGZ=$P(Y,U,2) K Y 100 Q:RGZ=""!$P($G(^RGSITE("COR",1,0)),U,7) 101 S RGERR=$$SHORT(RGEXC,RGERR),RGZ="G."_RGZ 102 I RGI=2 D ALERT^RGRSUTL2(RGERR,RGZ) Q 103 D MAIL^RGRSUTL2(RGERR,RGZ,"MPI/PD Exception: "_$$SHORT(RGEXC),"MPI/PD exception notification") 104 Q 105 ; 106 INVEXC(RGMID) ; determine if this exception needs to be sent to MPI/PD 107 ; personnel via FORUM. Return 1 to avoid messaging to FORUM, else 0. 108 ; IA#:3244 is applied in this functionality 109 N RGFLG,RGIEN S RGFLG=1 110 S RGIEN=$$IEN773(RGMID) Q:'RGIEN RGFLG 111 S RGIEN("SND")=$$GET1^DIQ(773,RGIEN_",",13) 112 S RGIEN("REC")=$$GET1^DIQ(773,RGIEN_",",14) 113 ; check the sending application (fld:13, 0;11) & the receiving 114 ; application (fld:14, 0;12) to see if they are related to the MPI/PD 115 ; project. 116 I RGIEN("SND")]""!(RGIEN("REC")]"") D Q RGFLG 117 .S RGFLG=$$APP(RGIEN("SND")) Q:'RGFLG 118 .S RGFLG=$$APP(RGIEN("REC")) 119 .Q 120 ; Only if the sending/receiving applications cannot be determined from 121 ; the data in their respective fields, do I check the MSH multiple for 122 ; the MSH segment. I identify the sending/receiving application from 123 ; this segment. 124 E D 125 .N RG,RG1,RGMSH,RGFS 126 .D GETS^DIQ(773,RGIEN_",",200,,"RGMSH") ;check MSH mult for snd/rec app 127 .Q:'($D(RGMSH)\10) ; no data in "MSH" multiple for file 773 128 .S RGIEN=RGIEN_",",RG="RGMSH(773,"""_RGIEN_""","_200_")" 129 .S RG1=0 F S RG1=$O(@RG@(RG1)) Q:RG1'>0 D Q:$E($G(@RG@(RG1)),1,3)="MSH" 130 ..I $E($G(@RG@(RG1)),1,3)="MSH" D 131 ...S RG(0)=$G(@RG@(RG1)),RGFS=$E(RG(0),4) 132 ...S:$P(RG(0),RGFS,3)]"" RGFLG=$$APP($P(RG(0),RGFS,3)) Q:'RGFLG 133 ...S:$P(RG(0),RGFS,5)]"" RGFLG=$$APP($P(RG(0),RGFS,5)) 134 ...Q 135 ..Q 136 .Q 137 Q RGFLG 138 APP(X) ; check if the sending/receiving application is relevant to the 139 ; MPI/PD team. Returns 1 if a non-relevant namespace, else 0 140 I $E(X,1,2)="RG"!($E(X,1,2)="VA")!($E(X,1,3)="MPI") Q 0 141 Q 1 142 ; 143 IEN773(RGMID) ; find the ien of the record in the HL7 MESSAGE ADMINISTRATION 144 ; (#773) file based on the Message ID. Input: Message ID 145 ; Output: null, no record in 773, else 773 record ien. IA#: 3244 146 Q:$G(RGMID)="" "" 147 Q $O(^HLMA("C",RGMID,0)) 148 ; 149 SHORT(RGEXC,RGTXT) ; 150 ; Retrieve short text description of exception 151 Q $G(^RGHL7(991.11,+RGEXC,10))_$S($G(RGTXT)="":"",1:": "_RGTXT) 152 ; 1 RGHLLOG ;CAIRO/DKM-LOG MESSAGE PROCESSING INFO ;09/04/98 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,11,13,18,19,25,45**;30 Apr 99;Build 9 3 ;Reference to ^HLMA("C" supported by IA #3244 4 ;================================================================= 5 ; Log information about message processing and exceptions 6 ; in CIRN HL7 Exception Log file. 7 ;================================================================= 8 ; Start time for run log 9 START(RGMSG,RGDC,RGPARAM) ; 10 ;This entry point starts the log process in the CIRN HL7 EXCEPTION LOG 11 ;file (#991.1), if the (#6) MINIMAL EXCEPTION LOGGING? field in 12 ;File #990.8 is set to 0. 13 ; Input: Required 14 ; RGMSG - IEN of message entry in File #773, usually HLMTIEN 15 ; Optional 16 ; RGDC - Event Class, associated with an entry in File # 17 ; RGPARAM - reprocessing routine 18 S U="^" 19 K RGLOG 20 S RGLOG(3)=$G(RGMSG),RGLOG(5)=$G(RGDC),RGLOG(4)=$G(RGPARAM),RGLOG(1)=$$NOW^XLFDT 21 I '$P(^RGSITE("COR",1,0),U,8) S RGLOG=$$CREATE 22 Q 23 ; Create a log entry 24 CREATE() Q:$G(RGLOG) RGLOG 25 L +^RGHL7(991.1,0):10 26 S RGLOG=$O(^RGHL7(991.1,$C(32)),-1)+1 27 S:$G(RGLOG(1))="" RGLOG(1)=$$NOW^XLFDT 28 S RGLOG(3)=$S($G(RGLOG(3))=0:0,$G(HL("MID"))="":"",1:$$IEN773($G(HL("MID")))) 29 S (DA,X)=RGLOG,DIC="^RGHL7(991.1,",DIC(0)="L",DLAYGO=991.1,DIC("DR")="1///"_$G(RGLOG(1))_";3////"_$G(RGLOG(3))_";5///"_$G(RGLOG(5))_";4////"_$G(RGLOG(4)) K DD,DO D FILE^DICN K DIC,DA,X,DLAYGO 30 L -^RGHL7(991.1,0) 31 Q RGLOG 32 ; Log time run completed 33 STOP(RGQUIT) ; 34 ;This entry point completes the logging process 35 ; Input: required 36 ; RGQUIT - 0 for success and 1 for failure 37 ; 38 Q:'$G(RGLOG) 39 L +^RGHL7(991.1,RGLOG):10 40 S DIE="^RGHL7(991.1,",DR="1.5///NOW;1.6///^S X=$G(RGQUIT)",DA=RGLOG D ^DIE K DIE,DA,DR 41 L -^RGHL7(991.1,RGLOG) 42 K RGLOG,RGQUIT,X,Y,DIC,DIE 43 Q 44 ; Log unclassified exception (old entry point) 45 ERR(RGERR,RGSEV) ; 46 D EXC(18,RGERR) 47 S RGQUIT=$G(RGQUIT)!$G(RGSEV) 48 Q 49 ; Log an exception 50 EXC(RGEXC,RGERR,RGDFN,MSGID,STATNUM) ; 51 ;This entry point logs exceptions in the CIRN HL7 EXCEPTION LOG 52 ;file (#991.1) 53 ; Input: Required 54 ; RGEXC - Exception type in File #991.11 55 ; RGERR - Supplemental text 56 ; Optional 57 ; RGDFN - IEN in the PATIENT file (#2) 58 ; MSGID - message id of the HL7 message where the exception was encountered (optional) 59 ; STATNUM - station # of site that encountered the error (optional) - if not defined then the local site is assumed, using $$SITE^VASITE 60 ; 61 I $L($G(HL("MID"))) Q:$$INVEXC(HL("MID")) ; is the exception valid? 62 N RGI,RGZ 63 S U="^" 64 S:RGEXC[U RGERR=$P(RGEXC,U,2,999),RGEXC=+RGEXC 65 S:RGEXC'=+RGEXC RGERR=RGEXC,RGEXC=18 66 S:'$D(^RGHL7(991.11,RGEXC)) RGEXC=18 67 L +^RGHL7(991.11,RGEXC):10 68 S RGZ=$G(^RGHL7(991.11,RGEXC,0)) 69 S:$L(RGZ) $P(^RGHL7(991.11,RGEXC,0),U,5)=$P(RGZ,U,5)+1 70 S:$P(RGZ,U,2)>1 RGQUIT=1 71 L -^RGHL7(991.11,RGEXC) 72 S RGLOG=$$CREATE 73 L +^RGHL7(991.1,RGLOG):10 74 S RGI=$O(^RGHL7(991.1,RGLOG,1,$C(32)),-1)+1 75 S RGERR=$E($G(RGERR),1,250) 76 S DIC="^RGHL7(991.1,"_RGLOG_",1," 77 S X=RGI,DA(1)=RGLOG,DIC(0)="FL",DLAYGO=991.12,DIC("P")=$P(^DD(991.1,2,0),"^",2) 78 D ^DIC 79 S DIE=DIC 80 K DIC,DA,DR,DLAYGO 81 S STAT=0 82 S DIC="3.8",DIC(0)="Z",X="MPIF EXCEPTIONS" D ^DIC K DIC 83 S RGMG=$P($G(Y),"^",1) 84 I $P(^RGHL7(991.11,RGEXC,0),U,4)=RGMG S STAT=1 85 S DA(1)=RGLOG,DA=RGI,DR="2///"_$G(RGEXC)_";3///"_$S($G(RGDFN):"`"_RGDFN,1:"")_";6///"_$G(STAT)_";10///"_$G(RGERR) 86 D ^DIE K DIE,DA,DR 87 L -^RGHL7(991.1,RGLOG) 88 S RGI=$P(RGZ,U,3),RGZ=$P(RGZ,U,4) 89 ; 90 ;If the action type is for the MPI Exception Handler, send exception to the handler and quit 91 I (RGI=3) D SENDMPI^RGHLLOG1($G(RGEXC),$G(RGERR),$G(RGDFN),$G(MSGID),$G(STATNUM)) Q 92 ; 93 Q:'RGI!'RGZ 94 ;quit and don't send messages for exception types that are now being 95 ;handled through the MPI/PD Exception Handling option. 96 Q:RGEXC=234!((RGEXC>214)&(RGEXC<219)) 97 S DIC="^XMB(3.8,",DIC(0)="NZ",X="`"_RGZ D ^DIC K DIC Q:+Y<1 S RGZ=$P(Y,U,2) K Y 98 Q:RGZ=""!$P($G(^RGSITE("COR",1,0)),U,7) 99 S RGERR=$$SHORT(RGEXC,RGERR),RGZ="G."_RGZ 100 I RGI=2 D ALERT^RGRSUTL2(RGERR,RGZ) Q 101 D MAIL^RGRSUTL2(RGERR,RGZ,"MPI/PD Exception: "_$$SHORT(RGEXC),"MPI/PD exception notification") 102 Q 103 ; 104 INVEXC(RGMID) ; determine if this exception needs to be sent to MPI/PD 105 ; personnel via FORUM. Return 1 to avoid messaging to FORUM, else 0. 106 ; IA#:3244 is applied in this functionality 107 N RGFLG,RGIEN S RGFLG=1 108 S RGIEN=$$IEN773(RGMID) Q:'RGIEN RGFLG 109 S RGIEN("SND")=$$GET1^DIQ(773,RGIEN_",",13) 110 S RGIEN("REC")=$$GET1^DIQ(773,RGIEN_",",14) 111 ; check the sending application (fld:13, 0;11) & the receiving 112 ; application (fld:14, 0;12) to see if they are related to the MPI/PD 113 ; project. 114 I RGIEN("SND")]""!(RGIEN("REC")]"") D Q RGFLG 115 .S RGFLG=$$APP(RGIEN("SND")) Q:'RGFLG 116 .S RGFLG=$$APP(RGIEN("REC")) 117 .Q 118 ; Only if the sending/receiving applications cannot be determined from 119 ; the data in their respective fields, do I check the MSH multiple for 120 ; the MSH segment. I identify the sending/receiving application from 121 ; this segment. 122 E D 123 .N RG,RG1,RGMSH,RGFS 124 .D GETS^DIQ(773,RGIEN_",",200,,"RGMSH") ;check MSH mult for snd/rec app 125 .Q:'($D(RGMSH)\10) ; no data in "MSH" multiple for file 773 126 .S RGIEN=RGIEN_",",RG="RGMSH(773,"""_RGIEN_""","_200_")" 127 .S RG1=0 F S RG1=$O(@RG@(RG1)) Q:RG1'>0 D Q:$E($G(@RG@(RG1)),1,3)="MSH" 128 ..I $E($G(@RG@(RG1)),1,3)="MSH" D 129 ...S RG(0)=$G(@RG@(RG1)),RGFS=$E(RG(0),4) 130 ...S:$P(RG(0),RGFS,3)]"" RGFLG=$$APP($P(RG(0),RGFS,3)) Q:'RGFLG 131 ...S:$P(RG(0),RGFS,5)]"" RGFLG=$$APP($P(RG(0),RGFS,5)) 132 ...Q 133 ..Q 134 .Q 135 Q RGFLG 136 APP(X) ; check if the sending/receiving application is relevant to the 137 ; MPI/PD team. Returns 1 if a non-relevant namespace, else 0 138 I $E(X,1,2)="RG"!($E(X,1,2)="VA")!($E(X,1,3)="MPI") Q 0 139 Q 1 140 ; 141 IEN773(RGMID) ; find the ien of the record in the HL7 MESSAGE ADMINISTRATION 142 ; (#773) file based on the Message ID. Input: Message ID 143 ; Output: null, no record in 773, else 773 record ien. IA#: 3244 144 Q:$G(RGMID)="" "" 145 Q $O(^HLMA("C",RGMID,0)) 146 ; 147 SHORT(RGEXC,RGTXT) ; 148 ; Retrieve short text description of exception 149 Q $G(^RGHL7(991.11,+RGEXC,10))_$S($G(RGTXT)="":"",1:": "_RGTXT) 150 ; -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGMTETOT.m
r613 r623 1 RGMTETOT ;BIR/CML-Compile Totals for Site Exceptions ;11/15/01 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**20,30,43,45,52**;30 Apr 99;Build 2 3 ; 4 ;Reference to ^DPT("AICNL" supported by IA #2070 5 ; 6 ;Variable RGHLMQ cannot be killed in this routine, it is needed for the remote query 7 ; 8 ;Use this routine to compile totals of a site's exceptions in file #991.1 9 S DUMP=0 G START 10 ; 11 DUMP1 ;Use this call to dump all data in ascii format for table 12 S DUMP=1 G START 13 ; 14 DUMP2 ;Use this call to dump data in ascii format for table - just for exceptions sites have to deal with 15 S DUMP=2 16 ; 17 START ; 18 ;do purge of any dups for POTENTIAL MATCH Exceptions 19 K TYPEARR,^XTMP("RGMT","HLMQETOT") 20 S ^XTMP("RGMT",0)=$$FMADD^XLFDT(DT,30)_"^"_$$NOW^XLFDT_"^MPI/PD Maintenance Data" 21 D PURGE 22 ;create type array from file 991.11 23 S TYPE=233 F S TYPE=$O(^RGHL7(991.11,TYPE)) Q:'TYPE I TYPE'=218 S TYPEARR(TYPE)=0 ;MPIC_772; **52 remove 215, 216, and 217 24 ; 25 ;start loop 26 S TYPE=233 F S TYPE=$O(^RGHL7(991.1,"AC",TYPE)) Q:'TYPE D ;MPIC_772; **52 remove 215, 216, and 217 27 .Q:TYPE=218 28 .S IEN1=0 F S IEN1=$O(^RGHL7(991.1,"AC",TYPE,IEN1)) Q:'IEN1 D 29 ..S IEN2=0 F S IEN2=$O(^RGHL7(991.1,"AC",TYPE,IEN1,IEN2)) Q:'IEN2 D 30 ...I '$D(^RGHL7(991.1,IEN1,1,IEN2,0)) Q 31 ...S STAT=$P(^RGHL7(991.1,IEN1,1,IEN2,0),"^",5) I STAT<1 S TYPEARR(TYPE)=TYPEARR(TYPE)+1 32 ; 33 PRT ; 34 S GRAND=0 35 S SITENM=$P($$SITE^VASITE(),"^",2),$P(LN,"-",81)="" 36 D NOW^%DTC S RUNDT=$$FMTE^XLFDT($E(%,1,12)) 37 ; 38 PRT0 I 'DUMP D 39 .W !!,"Exception Totals for ",SITENM 40 .W !,"Printed ",RUNDT,!,LN 41 .S TYPE=0 F S TYPE=$O(TYPEARR(TYPE)) Q:'TYPE I +TYPEARR(TYPE) D 42 ..S GRAND=GRAND+TYPEARR(TYPE) 43 ..W !!,"TYPE: ",TYPE,?12,$P($T(@TYPE),";;",2),?67,"TOTAL = ",$J(TYPEARR(TYPE),4) 44 ..W !,"DESCRIPTION:" 45 ..S TXT=0 F S TXT=$O(^RGHL7(991.11,TYPE,99,TXT)) Q:'TXT W !,^RGHL7(991.11,TYPE,99,TXT,0) 46 .W !!?56,"TOTAL EXCEPTIONS: ",$J(GRAND,5) 47 ; 48 PRT1 I DUMP=1 D 49 .W !!,"At this point it is necessary for you to increase the right margin." 50 .W !,"At the DEVICE prompt enter=> ;255" 51 .W ! D ^%ZIS I POP W !,"DOWNLOAD ABORTED!" Q 52 .W !!,"Data string=Site;Run Date;Date CIRN Installed;Exceptions 218 & 234" ;MPIC_772; **52 remove 215, 216, and 217 53 .S STR=SITENM_";"_RUNDT_";" 54 .S TYPE=0 F S TYPE=$O(TYPEARR(TYPE)) Q:'TYPE D 55 ..S STR=STR_";"_TYPEARR(TYPE) 56 .W !!,STR 57 ; 58 PRT2 I DUMP=2 D 59 .S ICN=0,LOCCNT=0 F S ICN=$O(^DPT("AICNL",1,ICN)) Q:'ICN S LOCCNT=LOCCNT+1 60 .S SITEIEN=+$$SITE^VASITE(),STANUM=$P($$SITE^VASITE(),"^",3) 61 .I '$D(RGHLMQ) W !!,"Data string:" 62 .I '$D(RGHLMQ) W !,"Site;Sta#;;;LocICNs,218,234" ;MPIC_772; **52 remove 215, 216, and 217 63 .S STR=SITENM_";"_STANUM_";;;"_LOCCNT 64 .F TYPE=218,234 S STR=STR_";"_TYPEARR(TYPE) ;MPIC_772; **52 remove 215, 216, and 217 65 .I '$D(RGHLMQ) W !!,STR 66 .I $D(RGHLMQ) S ^XTMP("RGMT","HLMQETOT",STANUM,1)=STR 67 ; 68 QUIT ; 69 K %,CIRNIEN,CNT,DA,DIK,DUMP,DUPCNT,EXCDT,GRAND,ICN,IEN,IEN1,IEN2,LN,LOCCNT,OLDDT,OLDNODE,PTNM 70 K RGDFN,RUNDT,SITEIEN,SITENM,STANUM,STAT,STR,TXT,TYPE,XCNT,HOME,DFN,RCNT,VADM 71 K ^XTMP("RGMT","ETOT") 72 Q 73 ; 74 PURGE ; 75 I '$D(RGHLMQ) W !!,"...purging duplicate Potential Match Exceptions",! 76 K ^XTMP("RGMT","ETOT") 77 S (RGDFN,CNT,XCNT,DUPCNT)=0,HOME=$$SITE^VASITE() 78 F S RGDFN=$O(^RGHL7(991.1,"ADFN",218,RGDFN)) Q:'RGDFN D 79 .S IEN=0 80 .F S IEN=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN)) Q:'IEN D 81 ..S IEN2=0 82 ..F S IEN2=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN,IEN2)) Q:'IEN2 D 83 ...I '$D(^RGHL7(991.1,IEN,0)) Q 84 ...S CNT=CNT+1 85 ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) 86 ...I '$D(^XTMP("RGMT","ETOT",RGDFN)) D Q 87 ....S XCNT=XCNT+1 88 ....D SETTMP 89 ...I $D(^XTMP("RGMT","ETOT",RGDFN)) D 90 ....S OLDNODE=^XTMP("RGMT","ETOT",RGDFN) 91 ....S OLDDT=$P(OLDNODE,"^") 92 ....I EXCDT>OLDDT D Q 93 .....S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3) 94 .....D DELDUP 95 .....D SETTMP 96 ....I OLDDT>EXCDT!(OLDDT=EXCDT) D 97 .....S DA(1)=IEN,DA=IEN2 98 .....D DELDUP 99 I '$D(RGHLMQ) W !,DUPCNT," duplicate patient entries for POTENTIAL MATCH exceptions were identified" 100 I '$D(RGHLMQ) W !,"and deleted from the CIRN HL7 EXCEPTION LOG file (#991.1)." 101 ; 102 K ^XTMP("RGMT","ETOT") 103 S (RCNT,RGDFN)=0 N IEN,SUB 104 F S RGDFN=$O(^RGHL7(991.1,"ADFN",218,RGDFN)) Q:'RGDFN D 105 .;S ICN=+$$GETICN^MPIF001(RGDFN) 106 .;I $E(ICN,1,3)=$P(HOME,"^",3)!(ICN<0) D 107 .;**43 shouldn't check for locals or no ICN, check for processed/not processed 108 .S IEN=0 F S IEN=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN)) Q:IEN="" D 109 ..S SUB=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN,"")) 110 ..I $P($G(^RGHL7(991.1,IEN,1,SUB,0)),"^",5)=0 D 111 ...S DFN=RGDFN D DEM^VADPT 112 ...I VADM(1)=""!(VADM(2)="") Q 113 ...S RCNT=RCNT+1 114 ...S ^XTMP("RGMT","ETOT",VADM(1),RGDFN)=$P(VADM(2),"^")_"^"_$P(VADM(3),"^",2) 115 ; 116 ;count the number of patients who need to be resolved 117 S PTNM="",CNT=0 118 F S PTNM=$O(^XTMP("RGMT","ETOT",PTNM)) Q:PTNM="" D 119 .S RGDFN=0 120 .F S RGDFN=$O(^XTMP("RGMT","ETOT",PTNM,RGDFN)) Q:'RGDFN S CNT=CNT+1 121 S TYPEARR(218)=CNT 122 Q 123 ; 124 SETTMP ;set TMP global for patient check 125 S ^XTMP("RGMT","ETOT",RGDFN)=EXCDT_"^"_IEN_"^"_IEN2 126 Q 127 ; 128 DELDUP ;delete patient dups from file 129 S DUPCNT=DUPCNT+1 130 S DIK="^RGHL7(991.1,"_DA(1)_",1," 131 D ^DIK K DIK,DA 132 Q 133 ; 134 218 ;;(Potential Matches Returned) 135 234 ;;(Primary View Reject) 1 RGMTETOT ;BIR/CML-Compile Totals for Site Exceptions ;11/15/01 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**20,30,43,45**;30 Apr 99;Build 9 3 ; 4 ;Reference to ^DPT("AICNL" supported by IA #2070 5 ; 6 ;Variable RGHLMQ cannot be killed in this routine, it is needed for the remote query 7 ; 8 ;Use this routine to compile totals of a site's exceptions in file #991.1 9 S DUMP=0 G START 10 ; 11 DUMP1 ;Use this call to dump all data in ascii format for table 12 S DUMP=1 G START 13 ; 14 DUMP2 ;Use this call to dump data in ascii format for table - just for exceptions sites have to deal with 15 S DUMP=2 16 ; 17 START ; 18 ;do purge of any dups for POTENTIAL MATCH Exceptions 19 K TYPEARR,^XTMP("RGMT","HLMQETOT") 20 S ^XTMP("RGMT",0)=$$FMADD^XLFDT(DT,30)_"^"_$$NOW^XLFDT_"^MPI/PD Maintenance Data" 21 D PURGE 22 ;create type array from file 991.11 23 S TYPE=214 F S TYPE=$O(^RGHL7(991.11,TYPE)) Q:'TYPE I TYPE'=218 S TYPEARR(TYPE)=0 24 ; 25 ;start loop 26 S TYPE=214 F S TYPE=$O(^RGHL7(991.1,"AC",TYPE)) Q:'TYPE D 27 .Q:TYPE=218 28 .S IEN1=0 F S IEN1=$O(^RGHL7(991.1,"AC",TYPE,IEN1)) Q:'IEN1 D 29 ..S IEN2=0 F S IEN2=$O(^RGHL7(991.1,"AC",TYPE,IEN1,IEN2)) Q:'IEN2 D 30 ...I '$D(^RGHL7(991.1,IEN1,1,IEN2,0)) Q 31 ...S STAT=$P(^RGHL7(991.1,IEN1,1,IEN2,0),"^",5) I STAT<1 S TYPEARR(TYPE)=TYPEARR(TYPE)+1 32 ; 33 PRT ; 34 S GRAND=0 35 S SITENM=$P($$SITE^VASITE(),"^",2),$P(LN,"-",81)="" 36 D NOW^%DTC S RUNDT=$$FMTE^XLFDT($E(%,1,12)) 37 ; 38 PRT0 I 'DUMP D 39 .W !!,"Exception Totals for ",SITENM 40 .W !,"Printed ",RUNDT,!,LN 41 .S TYPE=0 F S TYPE=$O(TYPEARR(TYPE)) Q:'TYPE I +TYPEARR(TYPE) D 42 ..S GRAND=GRAND+TYPEARR(TYPE) 43 ..W !!,"TYPE: ",TYPE,?12,$P($T(@TYPE),";;",2),?67,"TOTAL = ",$J(TYPEARR(TYPE),4) 44 ..W !,"DESCRIPTION:" 45 ..S TXT=0 F S TXT=$O(^RGHL7(991.11,TYPE,99,TXT)) Q:'TXT W !,^RGHL7(991.11,TYPE,99,TXT,0) 46 .W !!?56,"TOTAL EXCEPTIONS: ",$J(GRAND,5) 47 ; 48 PRT1 I DUMP=1 D 49 .W !!,"At this point it is necessary for you to increase the right margin." 50 .W !,"At the DEVICE prompt enter=> ;255" 51 .W ! D ^%ZIS I POP W !,"DOWNLOAD ABORTED!" Q 52 .W !!,"Data string=Site;Run Date;Date CIRN Installed;Exceptions 215-234" 53 .S STR=SITENM_";"_RUNDT_";" 54 .S TYPE=0 F S TYPE=$O(TYPEARR(TYPE)) Q:'TYPE D 55 ..S STR=STR_";"_TYPEARR(TYPE) 56 .W !!,STR 57 ; 58 PRT2 I DUMP=2 D 59 .S ICN=0,LOCCNT=0 F S ICN=$O(^DPT("AICNL",1,ICN)) Q:'ICN S LOCCNT=LOCCNT+1 60 .S SITEIEN=+$$SITE^VASITE(),STANUM=$P($$SITE^VASITE(),"^",3) 61 .I '$D(RGHLMQ) W !!,"Data string:" 62 .I '$D(RGHLMQ) W !,"Site;Sta#;;;LocICNs,215,216,217,218,227,234" 63 .S STR=SITENM_";"_STANUM_";;;"_LOCCNT 64 .F TYPE=215,216,217,218,227,234 S STR=STR_";"_TYPEARR(TYPE) 65 .I '$D(RGHLMQ) W !!,STR 66 .I $D(RGHLMQ) S ^XTMP("RGMT","HLMQETOT",STANUM,1)=STR 67 ; 68 QUIT ; 69 K %,CIRNIEN,CNT,DA,DIK,DUMP,DUPCNT,EXCDT,GRAND,ICN,IEN,IEN1,IEN2,LN,LOCCNT,OLDDT,OLDNODE,PTNM 70 K RGDFN,RUNDT,SITEIEN,SITENM,STANUM,STAT,STR,TXT,TYPE,XCNT,HOME,DFN,RCNT,VADM 71 K ^XTMP("RGMT","ETOT") 72 Q 73 ; 74 PURGE ; 75 I '$D(RGHLMQ) W !!,"...purging duplicate Potential Match Exceptions",! 76 K ^XTMP("RGMT","ETOT") 77 S (RGDFN,CNT,XCNT,DUPCNT)=0,HOME=$$SITE^VASITE() 78 F S RGDFN=$O(^RGHL7(991.1,"ADFN",218,RGDFN)) Q:'RGDFN D 79 .S IEN=0 80 .F S IEN=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN)) Q:'IEN D 81 ..S IEN2=0 82 ..F S IEN2=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN,IEN2)) Q:'IEN2 D 83 ...I '$D(^RGHL7(991.1,IEN,0)) Q 84 ...S CNT=CNT+1 85 ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) 86 ...I '$D(^XTMP("RGMT","ETOT",RGDFN)) D Q 87 ....S XCNT=XCNT+1 88 ....D SETTMP 89 ...I $D(^XTMP("RGMT","ETOT",RGDFN)) D 90 ....S OLDNODE=^XTMP("RGMT","ETOT",RGDFN) 91 ....S OLDDT=$P(OLDNODE,"^") 92 ....I EXCDT>OLDDT D Q 93 .....S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3) 94 .....D DELDUP 95 .....D SETTMP 96 ....I OLDDT>EXCDT!(OLDDT=EXCDT) D 97 .....S DA(1)=IEN,DA=IEN2 98 .....D DELDUP 99 I '$D(RGHLMQ) W !,DUPCNT," duplicate patient entries for POTENTIAL MATCH exceptions were identified" 100 I '$D(RGHLMQ) W !,"and deleted from the CIRN HL7 EXCEPTION LOG file (#991.1)." 101 ; 102 K ^XTMP("RGMT","ETOT") 103 S (RCNT,RGDFN)=0 N IEN,SUB 104 F S RGDFN=$O(^RGHL7(991.1,"ADFN",218,RGDFN)) Q:'RGDFN D 105 .;S ICN=+$$GETICN^MPIF001(RGDFN) 106 .;I $E(ICN,1,3)=$P(HOME,"^",3)!(ICN<0) D 107 .;**43 shouldn't check for locals or no ICN, check for processed/not processed 108 .S IEN=0 F S IEN=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN)) Q:IEN="" D 109 ..S SUB=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN,"")) 110 ..I $P($G(^RGHL7(991.1,IEN,1,SUB,0)),"^",5)=0 D 111 ...S DFN=RGDFN D DEM^VADPT 112 ...I VADM(1)=""!(VADM(2)="") Q 113 ...S RCNT=RCNT+1 114 ...S ^XTMP("RGMT","ETOT",VADM(1),RGDFN)=$P(VADM(2),"^")_"^"_$P(VADM(3),"^",2) 115 ; 116 ;count the number of patients who need to be resolved 117 S PTNM="",CNT=0 118 F S PTNM=$O(^XTMP("RGMT","ETOT",PTNM)) Q:PTNM="" D 119 .S RGDFN=0 120 .F S RGDFN=$O(^XTMP("RGMT","ETOT",PTNM,RGDFN)) Q:'RGDFN S CNT=CNT+1 121 S TYPEARR(218)=CNT 122 Q 123 ; 124 SETTMP ;set TMP global for patient check 125 S ^XTMP("RGMT","ETOT",RGDFN)=EXCDT_"^"_IEN_"^"_IEN2 126 Q 127 ; 128 DELDUP ;delete patient dups from file 129 S DUPCNT=DUPCNT+1 130 S DIK="^RGHL7(991.1,"_DA(1)_",1," 131 D ^DIK K DIK,DA 132 Q 133 ; 134 215 ;;(Death Entry on MPI not in VISTA) 135 216 ;;(Death Entry on Vista not in MPI) 136 217 ;;(Death Entries Mismatch) 137 218 ;;(Potential Matches Returned) 138 227 ;;(Multiple ICNs) 139 234 ;;(Primary View Reject) -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVMPI.m
r613 r623 1 RGPVMPI ;BIR/PTD-REMOTE PRIMARY VIEW DISPLAY FROM MPI ;5/17/07 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,53**;30 Apr 99;Build 2 3 ; 4 ;Reference to EN1^XWB2HL7 supported by IA #3144 5 ;Reference to RPCCHK^XWB2HL7 supported by IA #3144 6 ; 7 INTRO ;Display purpose of option 8 W @IOF S SAPV=1 ;from stand alone option, not EH 9 W !,"This option sends a remote request for data to the Master Patient" 10 W !,"Index, using a Remote Procedure Call (RPC). When the RPC returns" 11 W !,"the information, you can review Primary View data as it currently" 12 W !,"exists on the MPI Patient Data Inquiry (PDAT) report." 13 ; 14 W !!,"Choose the patient for whom Primary View data is to be requested." 15 W !,"The selected patient must have an Integration Control Number (ICN)." 16 W !,"You can select by Patient Name, Social Security Number, or ICN.",! 17 ; 18 ASK ;Ask For Patient 19 S DFN="",RGICN="" K DTOUT,DUOUT 20 S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5" 21 D MIX^DIC1 K DIC,D 22 I Y<0 G EXIT 23 S DFN=+Y 24 S RGICN=+$$GETICN^MPIF001(DFN) I RGICN<1 W !,"There is no Integration Control Number for this patient." G ASK 25 ; 26 SEND ;Send a remote query to the MPI for Primary View PDAT 27 ;Entry point from Exception Handler; DATA should be defined. 28 S (QFLG,QUIT)=0 N RETURN,RESULT,SNTDT 29 I SAPV=0 D I QUIT=1 G EXIT 30 .I DATA="" W !,"No Exception Data available." S QUIT=1 Q 31 .S RGICN=$P(DATA,"^",6) I RGICN="" W !,"No ICN defined." S QUIT=1 Q 32 .S VALMBCK="" 33 .D FULL^VALM1 34 NOQ ;No previous query exists for this ICN 35 I '$D(^XTMP("RGPVMPI"_RGICN)) D RPC G DISP 36 ; 37 OLDQ ;Query previously sent for this ICN 38 I $D(^XTMP("RGPVMPI"_RGICN)) D 39 .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVMPI"_RGICN,"DATA"),"^",2)) 40 .W !,"A query was last sent for this ICN on "_SNTDT 41 .;Has data returned for query? 42 .S RETURN(0)=$P(^XTMP("RGPVMPI"_RGICN,"DATA"),"^") 43 .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) 44 .;Data has NOT returned 45 .I +RESULT(0)'=1 D FAIL Q ;**53 46 .I +RESULT(0)=1 D ;Data has returned 47 ..S DIR("A")="Do you wish to view the existing query data now? ",DIR(0)="YA" 48 ..S DIR("?")="Enter YES to review the existing data; enter NO to send a new query" 49 ..S DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q ;up-arrowed out 50 ..I Y>0 K DIR Q ;yes, use existing query 51 ..I Y=0 D Q ;no, don't use existing, send new query 52 ...K ^XTMP("RGPVMPI"_RGICN) 53 ...D RPC 54 ...K DIR 55 ; 56 DISP ;Display Primary View Data 57 I QUIT'=1 D I QFLG G EXIT 58 .I SAPV=1 D Q:QFLG ;Stand alone PV display 59 ..W !,"(Be sure HISTORY is enabled to capture data!)" 60 ..S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 61 ..W !,@IOF D SAPV^RGEX06(RGICN) 62 .I SAPV=0 D EN^RGEX06(RGICN) ;Exception Handler PV display 63 ; 64 EXIT ;Kill variables and quit 65 K CNT,D,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,QFLG,QUIT,RGICN,SAPV,X,Y 66 Q 67 ; 68 RPC ;Send the Remote Query 69 W !!,"Sending a Remote Query to the Master Patient Index." 70 W !,"This will take some time; please be patient." 71 D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW FROM MPI",1,RGICN) I RETURN(0)'="" D Q 72 .S ^XTMP("RGPVMPI"_RGICN,0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW MPI PDAT" 73 .S ^XTMP("RGPVMPI"_RGICN,"DATA")=RETURN(0)_"^"_$$NOW^XLFDT 74 .;Has data returned for this query? 75 .S CNT=0 F S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0) H 2 I CNT>15 Q ;result(0)=status of handle 76 .I +RESULT(0)=1 W !,"Query data has returned from the MPI and is available for review." 77 .I +RESULT(0)'=1 D FAIL ;**53 78 W !!,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1)) 79 S QUIT=1 80 I SAPV=0 D PAUSE^VALM1 81 Q 82 ; 83 FAIL ;Status of RPC call - unsuccessful after 30 seconds ;**53 84 W !,"Your query request has NOT returned data from the MPI after trying for" 85 W !,"30 seconds. This could be due to network issues. Please try again later." 86 K ^XTMP("RGPVMPI"_RGICN) 87 S QUIT=1 88 I SAPV=0 D PAUSE^VALM1 89 Q 90 ; 1 RGPVMPI ;BIR/PTD-REMOTE PRIMARY VIEW DISPLAY FROM MPI ;5/17/07 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48**;30 Apr 99;Build 3 3 ; 4 ;Reference to EN1^XWB2HL7 supported by IA #3144 5 ;Reference to RPCCHK^XWB2HL7 supported by IA #3144 6 ; 7 INTRO ;Display purpose of option 8 W @IOF S SAPV=1 ;from stand alone option, not EH 9 W !,"This option sends a remote request for data to the Master Patient" 10 W !,"Index, using a Remote Procedure Call (RPC). When the RPC returns" 11 W !,"the information, you can review Primary View data as it currently" 12 W !,"exists on the MPI Patient Data Inquiry (PDAT) report." 13 ; 14 W !!,"Choose the patient for whom Primary View data is to be requested." 15 W !,"The selected patient must have an Integration Control Number (ICN)." 16 W !,"You can select by Patient Name, Social Security Number, or ICN.",! 17 ; 18 ASK ;Ask For Patient 19 S DFN="",RGICN="" K DTOUT,DUOUT 20 S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5" 21 D MIX^DIC1 K DIC,D 22 I Y<0 G EXIT 23 S DFN=+Y 24 S RGICN=+$$GETICN^MPIF001(DFN) I RGICN<1 W !,"There is no Integration Control Number for this patient." G ASK 25 ; 26 SEND ;Send a remote query to the MPI for Primary View PDAT 27 ;Entry point from Exception Handler; DATA should be defined. 28 S (QFLG,QUIT)=0 N RETURN,RESULT,SNTDT 29 I SAPV=0 D I QUIT=1 G EXIT 30 .I DATA="" W !,"No Exception Data available." S QUIT=1 Q 31 .S RGICN=$P(DATA,"^",6) I RGICN="" W !,"No ICN defined." S QUIT=1 Q 32 .S VALMBCK="" 33 .D FULL^VALM1 34 NOQ ;No previous query exists for this ICN 35 I '$D(^XTMP("RGPVMPI",RGICN)) D RPC G DISP 36 ; 37 OLDQ ;Query previously sent for this ICN 38 I $D(^XTMP("RGPVMPI",RGICN)) D 39 .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVMPI",RGICN),"^",2)) 40 .W !,"A query was last sent for this ICN on "_SNTDT 41 .;Has data returned for query? 42 .S RETURN(0)=$P(^XTMP("RGPVMPI",RGICN),"^") 43 .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) 44 .;Data has NOT returned 45 .I +RESULT(0)'=1 S QUIT=1 W !,"Query data has NOT returned from the MPI; please check back later." Q 46 .I +RESULT(0)=1 D ;Data has returned 47 ..S DIR("A")="Do you wish to view the existing query data now? ",DIR(0)="YA" 48 ..S DIR("?")="Enter YES to review the existing data; enter NO to send a new query" 49 ..S DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q ;up-arrowed out 50 ..I Y>0 K DIR Q ;yes, use existing query 51 ..I Y=0 D Q ;no, don't use existing, send new query 52 ...K ^XTMP("RGPVMPI",RGICN) 53 ...D RPC 54 ...K DIR 55 ; 56 DISP ;Display Primary View Data 57 I QUIT'=1 D I QFLG G EXIT 58 .I SAPV=1 D Q:QFLG ;Stand alone PV display 59 ..W !,"(Be sure HISTORY is enabled to capture data!)" 60 ..S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 61 ..W !,@IOF D SAPV^RGEX06(RGICN) 62 .I SAPV=0 D EN^RGEX06(RGICN) ;Exception Handler PV display 63 ; 64 EXIT ;Kill variables and quit 65 K CNT,D,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,QFLG,QUIT,RGICN,SAPV,X,Y 66 Q 67 ; 68 RPC ;Send the Remote Query 69 W !!,"Sending a Remote Query to the Master Patient Index." 70 W !,"This will take some time; please be patient." 71 D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW FROM MPI",1,RGICN) I RETURN(0)'="" D Q 72 .S ^XTMP("RGPVMPI",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW MPI PDAT" 73 .S ^XTMP("RGPVMPI",RGICN)=RETURN(0)_"^"_$$NOW^XLFDT 74 .;Has data returned for this query? 75 .S CNT=0 F S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0) H 2 I CNT>15 Q ;result(0)=status of handle 76 .I +RESULT(0)=1 W !,"Query data has returned from the MPI and is available for review." 77 .I +RESULT(0)'=1 D ;quit, info not back after 30 seconds 78 ..W !,"Query data has NOT returned from the MPI; please check back later." 79 ..S QUIT=1 80 ..I SAPV=0 D PAUSE^VALM1 81 W !!,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1)) 82 S QUIT=1 83 I SAPV=0 D PAUSE^VALM1 84 Q 85 ; -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVREJ.m
r613 r623 1 RGPVREJ ;BIR/PTD-REMOTE PRIMARY VIEW REJECT (PATIENT) ;10/8/06 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,47,53**;30 Apr 99;Build 2 3 ; 4 ;Reference to ^XWB2HL7 supported by IA #3144 5 ;Reference to ^XWBDRPC supported by IA #3149 6 ; 7 REJ ;Option only available for Primary View Reject exceptions 8 ;From within the Exception Handler, for selection, DATA should be defined. 9 N RGBDT,RGICN,RGSITE,PTEN,PELV 10 I DATA="" W !,"No Exception Data available." Q 11 S PTEN=$P(DATA,"^",10) ;IEN IN 991.1 12 S PELV=$P(DATA,"^",11) ;IEN IN 991.12 13 I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",3)'=234 S VALMSG="Action is ONLY for PRIMARY VIEW REJECT exceptions!" Q 14 I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",5)=1 S VALMSG="Exception has been PROCESSED; no longer active." Q 15 S RGSITE=$P($$SITE^VASITE(),"^",3) I RGSITE="" W !,"No Site Data defined." Q 16 S RGICN=$P(DATA,"^",6) I RGICN="" W !,"No ICN defined." Q 17 S RGBDT=$P(DATA,"^",3) I RGBDT="" W !,"No Exception Date defined." Q 18 S X=RGBDT D ^%DT S RGBDT=Y ;convert Exception Date from external format to internal 19 ; 20 S VALMBCK="",QUIT=0 21 D FULL^VALM1 22 SEND ;Send a remote query to the MPI for Primary View Reject report 23 N RETURN,RESULT,RGEDT,SNTDT 24 S RGEDT=$$DT^XLFDT ;End date for report internal format 25 NOQ ;No previous query exists for this ICN/exception date 26 I '$D(^XTMP("RGPVREJ"_RGICN,RGBDT)) D RPC G DISP 27 ; 28 OLDQ ;Query already sent for this ICN/ exception date 29 I $D(^XTMP("RGPVREJ"_RGICN,RGBDT)) D 30 .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVREJ"_RGICN,RGBDT),"^",2)) 31 .W !?3,"A query was last sent for this ICN/Exception Date on "_SNTDT 32 .S X=$P(SNTDT,"@") D ^%DT S SNTDT=Y ;convert to internal, strip time 33 .;Has data returned for existing query? 34 .S RETURN(0)=$P(^XTMP("RGPVREJ"_RGICN,RGBDT),"^") 35 .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D Q ;Data has returned 36 ..I RGEDT=SNTDT D ;query was sent 'today', want to use that one? 37 ...S DIR("A")=" Do you wish to review that existing query data now? ",DIR(0)="YA" 38 ...S DIR("?")=" Enter YES to review the existing query; NO to send a new query" 39 ...S DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q ;up-arrowed out 40 ...I Y>0 K DIR Q ;yes, use existing query 41 ...I Y=0 D Q ;no, don't use existing, send new query 42 ....K ^XTMP("RGPVREJ"_RGICN,RGBDT) 43 ....D RPC 44 ....K DIR 45 ....; 46 ..I RGEDT'=SNTDT D ;query was NOT sent 'today', data may be old, send new query 47 ...W !?3,"Previous Query data may be obsolete." 48 ...K ^XTMP("RGPVREJ"_RGICN,RGBDT) 49 ...D RPC 50 .;Data for existing query has NOT returned **47 51 .I +RESULT(0)'=1 D FAIL ;**53 52 ; 53 DISP ;Display Primary View Reject Data 54 I QUIT'=1 D EN^RGEX07(RGICN,RGBDT) 55 EXIT ;Kill variables and quit 56 K CNT,DIR,DIRUT,QUIT,X,Y 57 Q 58 ; 59 RPC ;Send the Remote Query 60 W !?3,"Sending a Remote Query to the Master Patient Index." 61 W !?3,"This will take some time; please be patient." 62 D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW REJECT",1,RGSITE,RGICN,RGBDT,RGEDT) I RETURN(0)'="" D Q 63 .S ^XTMP("RGPVREJ"_RGICN,0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW REJECT" 64 .S ^XTMP("RGPVREJ"_RGICN,RGBDT)=RETURN(0)_"^"_$$NOW^XLFDT 65 .;Has data returned for this query? 66 .S CNT=0 F S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0) H 2 I CNT>15 Q ;result(0)=status of handle 67 .I +RESULT(0)=1 W !?3,"Query data has returned from the MPI and is available for review." 68 .I +RESULT(0)'=1 D FAIL ;**53 69 W !!?3,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1)) 70 S QUIT=1 71 D PAUSE^VALM1 72 Q 73 ; 74 FAIL ;Status of RPC call - unsuccessful after 30 seconds ;**53 75 W !?3,"Your query request has NOT returned data from the MPI after trying for" 76 W !?3,"30 seconds. This could be due to network issues. Please try again later." 77 K ^XTMP("RGPVREJ"_RGICN,RGBDT) 78 S QUIT=1 79 D PAUSE^VALM1 80 Q 81 ; 1 RGPVREJ ;BIR/PTD-REMOTE PRIMARY VIEW REJECT (PATIENT) ;10/8/06 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,47**;30 Apr 99;Build 10 3 ; 4 ;Reference to ^XWB2HL7 supported by IA #3144 5 ;Reference to ^XWBDRPC supported by IA #3149 6 ; 7 REJ ;Option only available for Primary View Reject exceptions 8 ;From within the Exception Handler, for selection, DATA should be defined. 9 N RGBDT,RGICN,RGSITE,PTEN,PELV 10 I DATA="" W !,"No Exception Data available." Q 11 S PTEN=$P(DATA,"^",10) ;IEN IN 991.1 12 S PELV=$P(DATA,"^",11) ;IEN IN 991.12 13 I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",3)'=234 S VALMSG="Action is ONLY for PRIMARY VIEW REJECT exceptions!" Q 14 I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",5)=1 S VALMSG="Exception has been PROCESSED; no longer active." Q 15 S RGSITE=$P($$SITE^VASITE(),"^",3) I RGSITE="" W !,"No Site Data defined." Q 16 S RGICN=$P(DATA,"^",6) I RGICN="" W !,"No ICN defined." Q 17 S RGBDT=$P(DATA,"^",3) I RGBDT="" W !,"No Exception Date defined." Q 18 S X=RGBDT D ^%DT S RGBDT=Y ;convert Exception Date from external format to internal 19 ; 20 S VALMBCK="",QUIT=0 21 D FULL^VALM1 22 SEND ;Send a remote query to the MPI for Primary View Reject report 23 N RETURN,RESULT,RGEDT,SNTDT 24 S RGEDT=$$DT^XLFDT ;End date for report internal format 25 NOQ ;No previous query exists for this ICN/exception date 26 I '$D(^XTMP("RGPVREJ",RGICN,RGBDT)) D RPC G DISP 27 ; 28 OLDQ ;Query already sent for this ICN/ exception date 29 I $D(^XTMP("RGPVREJ",RGICN,RGBDT)) D 30 .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVREJ",RGICN,RGBDT),"^",2)) 31 .W !?3,"A query was last sent for this ICN/Exception Date on "_SNTDT 32 .S X=$P(SNTDT,"@") D ^%DT S SNTDT=Y ;convert to internal, strip time 33 .;Has data returned for existing query? 34 .S RETURN(0)=$P(^XTMP("RGPVREJ",RGICN,RGBDT),"^") 35 .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D Q ;Data has returned 36 ..I RGEDT=SNTDT D ;query was sent 'today', want to use that one? 37 ...S DIR("A")=" Do you wish to review that existing query data now? ",DIR(0)="YA" 38 ...S DIR("?")=" Enter YES to review the existing query; NO to send a new query" 39 ...S DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q ;up-arrowed out 40 ...I Y>0 K DIR Q ;yes, use existing query 41 ...I Y=0 D Q ;no, don't use existing, send new query 42 ....K ^XTMP("RGPVREJ",RGICN,RGBDT) 43 ....D RPC 44 ....K DIR 45 ....; 46 ..I RGEDT'=SNTDT D ;query was NOT sent 'today', data may be old, send new query 47 ...W !?3,"Previous Query data may be obsolete." 48 ...K ^XTMP("RGPVREJ",RGICN,RGBDT) 49 ...D RPC 50 .;Data for existing query has NOT returned **47 51 .I +RESULT(0)'=1 S QUIT=1 W !?3,"Query data has NOT returned from the MPI; please check back later." D PAUSE^VALM1 52 ; 53 DISP ;Display Primary View Reject Data 54 I QUIT'=1 D EN^RGEX07(RGICN,RGBDT) 55 EXIT ;Kill variables and quit 56 K CNT,DIR,DIRUT,QUIT,X,Y 57 Q 58 ; 59 RPC ;Send the Remote Query 60 W !?3,"Sending a Remote Query to the Master Patient Index." 61 W !?3,"This will take some time; please be patient." 62 D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW REJECT",1,RGSITE,RGICN,RGBDT,RGEDT) I RETURN(0)'="" D Q 63 .S ^XTMP("RGPVREJ",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW REJECT" 64 .S ^XTMP("RGPVREJ",RGICN,RGBDT)=RETURN(0)_"^"_$$NOW^XLFDT 65 .;Has data returned for this query? 66 .S CNT=0 F S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0) H 2 I CNT>15 Q ;result(0)=status of handle 67 .I +RESULT(0)=1 W !?3,"Query data has returned from the MPI and is available for review." 68 .I +RESULT(0)'=1 D ;quit, info not back after 30 seconds 69 ..W !?3,"Query data has NOT returned from the MPI; please check back later." 70 ..S QUIT=1 71 ..D PAUSE^VALM1 72 W !!?3,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1)) 73 S QUIT=1 74 D PAUSE^VALM1 75 Q 76 ; -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSBUL1.m
r613 r623 1 RGRSBUL1 ;ALB/RJS,CML-RGRSTEXT BULLETIN ROUTINE (PART 2) ;07/24/98 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,19,52**;30 Apr 99;Build 2 3 ; 4 SSNBULL(DFN,ARRAY,NAME,SSN,ICN,CMOR) ; 5 ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC 6 ;ISSUES mail group about an SSN change for a given patient. 7 ; 8 ;Input: Required Variables 9 ; 10 ; DFN - IEN in the PATIENT file (#2) 11 ; ARRAY - Array of data containing sending sites station number 12 ; NAME - Patient's Name 13 ; SSN - Patient's SSN 14 ; ICN - Patient's ICN (Integration Control Number) 15 ; CMOR - Patient's CMOR (Coordinating Master of Record) 16 ; 17 Q:$G(DFN)=""!($G(ARRAY)="") 18 N LOCDATA,RGRSTEXT,INDEX,COUNTER 19 S RGRSTEXT(1)="The MPI/PD Package has received an SSN change from:" 20 S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) 21 S RGRSTEXT(3)=" " 22 S RGRSTEXT(4)="This change has been made in your local data base for:" 23 S RGRSTEXT(5)=NAME 24 S RGRSTEXT(6)=" " 25 S RGRSTEXT(7)="=> Local "_$P($$SITE^VASITE(),"^",2)_" data PRIOR to update:" 26 S RGRSTEXT(8)="NAME: "_NAME 27 S RGRSTEXT(9)="SSN: "_SSN 28 S RGRSTEXT(10)="ICN: "_ICN 29 S RGRSTEXT(11)="CMOR: "_CMOR 30 S RGRSTEXT(12)="--------------------------------------------------------" 31 S RGRSTEXT(13)="=> Update received from "_$P($$INST(@ARRAY@("SENDING SITE"))," -->")_":" 32 S RGRSTEXT(14)="SSN: "_@ARRAY@("SSN") 33 D BULL2^RGRSBULL("MPI/PD SSN CHANGE - "_NAME,"RGRSTEXT(") 34 Q 35 ; 36 NOT2(ARRAY) ; 37 ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC 38 ;ISSUES mail group about invalid subscription information for a given 39 ;patient. 40 ; 41 ;Input: Required Variables 42 ; 43 ; ARRAY - Array of information regarding the invalid subscription 44 ; 45 Q:($G(ARRAY)="") 46 N RGRSTEXT,INDEX,COUNTER 47 S RGRSTEXT(1)="The MPI/PD Package has received a message from:" 48 S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) 49 S RGRSTEXT(3)="This patient has your station as a subscriber, however" 50 S RGRSTEXT(4)="the patient was not found in your database." 51 S RGRSTEXT(5)="--------------------------------------------------------" 52 S RGRSTEXT(6)="Remote Data" 53 S RGRSTEXT(7)=" " 54 S INDEX=0,COUNTER=8 55 F S INDEX=$O(@ARRAY@("MESSAGE",INDEX)) Q:INDEX']"" D 56 . S RGRSTEXT(COUNTER)=@ARRAY@("MESSAGE",INDEX) 57 . S COUNTER=COUNTER+1 58 D BULL2^RGRSBULL("MPI/PD - PATIENT NOT FOUND","RGRSTEXT(") 59 Q 60 ; 61 SENSTIVE(DFN,ARRAY,NAME) ;FIRES WHEN PT. IS FLAGGED AS SENSITIVE AT ANOTHER SITE 62 ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC 63 ;ISSUES mail group when a given patient is flagged as sensitive at 64 ;another site. 65 ; 66 ;Input: Required Variables 67 ; 68 ; DFN - IEN in the PATIENT file (#2) 69 ; ARRAY - Array of data containing sending sites station number and SSN 70 ; NAME - Patient's name 71 ; CMOR - Coordinating Master of Record 72 ; 73 Q:($G(ARRAY)="")!($G(DFN)="") 74 N RGRSTEXT,INDEX,COUNTER,CMOR 75 S CMOR=$$CMOR2^MPIF001(DFN) I $P(CMOR,"^")<0 S CMOR="not assigned" 76 S RGRSTEXT(1)="The MPI/PD Package has received a message from:" 77 S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) 78 S RGRSTEXT(3)=" " 79 S RGRSTEXT(4)="This message indicates that patient "_NAME_" is flagged" 80 S RGRSTEXT(5)="as Sensitive at the other facility but is not flagged as" 81 S RGRSTEXT(6)="Sensitive at your facility." 82 S RGRSTEXT(7)=" " 83 S RGRSTEXT(8)="Remote Patient SSN: "_$S(@ARRAY@("SSN")="":"Not Available",1:@ARRAY@("SSN")) 84 S RGRSTEXT(9)="Remote User who Flagged the Patient as Sensitive: "_@ARRAY@("SENSITIVITY USER") 85 S RGRSTEXT(10)="Date/Time Remote User Flagged Patient Sensitive: "_$$FMTE^XLFDT(@ARRAY@("SENSITIVITY DATE")) 86 S RGRSTEXT(11)=" " 87 S RGRSTEXT(12)="CMOR Site: "_CMOR 88 D BULL2^RGRSBULL("Remote Sensitivity Indicated","RGRSTEXT(") 89 Q 90 ; 91 ;MPIC_772 - **52; Commented out Remote Date of Death Indicated module. 92 ;Only RGADTP2 and RGRSPT called this module; and both have been commented out. 93 RMTDOD(DFN,ARRAY,NAME,RDOD,LDOD) ;Fires when patient has a Date of Death at another site 94 ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC 95 ;ISSUES mail group when a given patient has a Date of Death at 96 ;another site. 97 ; 98 ;Input: Required Variables 99 ; 100 ; DFN - IEN in the PATIENT file (#2) 101 ; ARRAY - Array of data containing sending sites station number and SSN 102 ; NAME - Patient's name 103 ; RDOD - Date of Death at remote site 104 ; LDOD - Date of Death at local site 105 ; CMOR - Coordinating Master of Record 106 ; 107 ;Q:($G(ARRAY)="")!($G(DFN)="") 108 ;Q:(RDOD=LDOD) ;If remote DOD and local DOD same, QUIT 109 ;N CMOR 110 ;S CMOR=$$CMOR2^MPIF001(DFN) I $P(CMOR,"^")<0 S CMOR="not assigned" 111 ;N RGRSTEXT 112 ;S RGRSTEXT(1)="The MPI/PD Package has received a message from:" 113 ;S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) 114 ;S RGRSTEXT(3)=" " 115 ;S RGRSTEXT(4)="This message indicates that patient "_NAME 116 ;I 'LDOD S RGRSTEXT(5)="has a date of death at the other facility but not at your facility." G RMTMSG 117 ;I LDOD,(LDOD'=RDOD) S RGRSTEXT(5)="has a different date of death at the other facility than at your facility." 118 RMTMSG ;S RGRSTEXT(6)=" " 119 ;S RGRSTEXT(7)="Remote Patient SSN: "_$S(@ARRAY@("SSN")="":"Not Available",1:@ARRAY@("SSN")) 120 ;S RGRSTEXT(8)="Date of Death from other facility: "_$$FMTE^XLFDT(RDOD) 121 ;I LDOD,(LDOD'=RDOD) S RGRSTEXT(9)="Date of Death at your facility: "_$$FMTE^XLFDT(LDOD) 122 ;S RGRSTEXT(10)=" " 123 ;S RGRSTEXT(11)="CMOR site: "_CMOR 124 ;D BULL2^RGRSBULL("Remote Date of Death Indicated","RGRSTEXT(") 125 Q 126 ; 127 INST(SITENUM) ; 128 N RETURN,IEN,DATA,NAME,NUMBER 129 S RETURN="" 130 Q:$G(SITENUM)="" RETURN 131 S IEN=$$LKUP^XUAF4(SITENUM) 132 I IEN>0 S DATA=$$NS^XUAF4(IEN) 133 I $G(DATA)]"" D 134 . S NAME=$P(DATA,"^",1),NUMBER=$P(DATA,"^",2) 135 . S RETURN=NAME_" --> Site Number: "_NUMBER 136 Q RETURN 137 ; 138 FORMAT(DATA1,DATA2) ; 139 N SPACES,SPACENUM,LENGTH1,LENGTH2,RETURN 140 S SPACES=" " 141 S LENGTH1=$L(DATA1),LENGTH2=$L(DATA2) 142 I LENGTH1>23 S DATA1=$E(DATA1,1,23) S LENGTH1=23 143 I LENGTH2>22 S DATA2=$E(DATA2,1,22) 144 S SPACENUM=23-LENGTH1 145 S SPACES=$E(SPACES,1,SPACENUM) 146 S RETURN=DATA1_SPACES_" "_DATA2 147 Q $G(RETURN) 148 ; 149 FREE(DATA) ; 150 Q:$G(DATA)="" "" 151 Q:$G(DATA)["@" "" 152 Q:$G(DATA)=HL("Q") "" 153 Q $G(DATA) 1 RGRSBUL1 ;ALB/RJS,CML-RGRSTEXT BULLETIN ROUTINE (PART 2) ;07/24/98 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,19**;30 Apr 99 3 SSNBULL(DFN,ARRAY,NAME,SSN,ICN,CMOR) ; 4 ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC 5 ;ISSUES mail group about an SSN change for a given patient. 6 ; 7 ;Input: Required Variables 8 ; 9 ; DFN - IEN in the PATIENT file (#2) 10 ; ARRAY - Array of data containing sending sites station number 11 ; NAME - Patient's Name 12 ; SSN - Patient's SSN 13 ; ICN - Patient's ICN (Integration Control Number) 14 ; CMOR - Patient's CMOR (Coordinating Master of Record) 15 ; 16 Q:$G(DFN)=""!($G(ARRAY)="") 17 N LOCDATA,RGRSTEXT,INDEX,COUNTER 18 S RGRSTEXT(1)="The MPI/PD Package has received an SSN change from:" 19 S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) 20 S RGRSTEXT(3)=" " 21 S RGRSTEXT(4)="This change has been made in your local data base for:" 22 S RGRSTEXT(5)=NAME 23 S RGRSTEXT(6)=" " 24 S RGRSTEXT(7)="=> Local "_$P($$SITE^VASITE(),"^",2)_" data PRIOR to update:" 25 S RGRSTEXT(8)="NAME: "_NAME 26 S RGRSTEXT(9)="SSN: "_SSN 27 S RGRSTEXT(10)="ICN: "_ICN 28 S RGRSTEXT(11)="CMOR: "_CMOR 29 S RGRSTEXT(12)="--------------------------------------------------------" 30 S RGRSTEXT(13)="=> Update received from "_$P($$INST(@ARRAY@("SENDING SITE"))," -->")_":" 31 S RGRSTEXT(14)="SSN: "_@ARRAY@("SSN") 32 D BULL2^RGRSBULL("MPI/PD SSN CHANGE - "_NAME,"RGRSTEXT(") 33 Q 34 ; 35 NOT2(ARRAY) ; 36 ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC 37 ;ISSUES mail group about invalid subscription information for a given 38 ;patient. 39 ; 40 ;Input: Required Variables 41 ; 42 ; ARRAY - Array of information regarding the invalid subscription 43 ; 44 Q:($G(ARRAY)="") 45 N RGRSTEXT,INDEX,COUNTER 46 S RGRSTEXT(1)="The MPI/PD Package has received a message from:" 47 S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) 48 S RGRSTEXT(3)="This patient has your station as a subscriber, however" 49 S RGRSTEXT(4)="the patient was not found in your database." 50 S RGRSTEXT(5)="--------------------------------------------------------" 51 S RGRSTEXT(6)="Remote Data" 52 S RGRSTEXT(7)=" " 53 S INDEX=0,COUNTER=8 54 F S INDEX=$O(@ARRAY@("MESSAGE",INDEX)) Q:INDEX']"" D 55 . S RGRSTEXT(COUNTER)=@ARRAY@("MESSAGE",INDEX) 56 . S COUNTER=COUNTER+1 57 D BULL2^RGRSBULL("MPI/PD - PATIENT NOT FOUND","RGRSTEXT(") 58 Q 59 ; 60 SENSTIVE(DFN,ARRAY,NAME) ;FIRES WHEN PT. IS FLAGGED AS SENSITIVE AT ANOTHER SITE 61 ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC 62 ;ISSUES mail group when a given patient is flagged as sensitive at 63 ;another site. 64 ; 65 ;Input: Required Variables 66 ; 67 ; DFN - IEN in the PATIENT file (#2) 68 ; ARRAY - Array of data containing sending sites station number and SSN 69 ; NAME - Patient's name 70 ; CMOR - Coordinating Master of Record 71 ; 72 Q:($G(ARRAY)="")!($G(DFN)="") 73 N RGRSTEXT,INDEX,COUNTER,CMOR 74 S CMOR=$$CMOR2^MPIF001(DFN) I $P(CMOR,"^")<0 S CMOR="not assigned" 75 S RGRSTEXT(1)="The MPI/PD Package has received a message from:" 76 S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) 77 S RGRSTEXT(3)=" " 78 S RGRSTEXT(4)="This message indicates that patient "_NAME_" is flagged" 79 S RGRSTEXT(5)="as Sensitive at the other facility but is not flagged as" 80 S RGRSTEXT(6)="Sensitive at your facility." 81 S RGRSTEXT(7)=" " 82 S RGRSTEXT(8)="Remote Patient SSN: "_$S(@ARRAY@("SSN")="":"Not Available",1:@ARRAY@("SSN")) 83 S RGRSTEXT(9)="Remote User who Flagged the Patient as Sensitive: "_@ARRAY@("SENSITIVITY USER") 84 S RGRSTEXT(10)="Date/Time Remote User Flagged Patient Sensitive: "_$$FMTE^XLFDT(@ARRAY@("SENSITIVITY DATE")) 85 S RGRSTEXT(11)=" " 86 S RGRSTEXT(12)="CMOR Site: "_CMOR 87 D BULL2^RGRSBULL("Remote Sensitivity Indicated","RGRSTEXT(") 88 Q 89 ; 90 RMTDOD(DFN,ARRAY,NAME,RDOD,LDOD) ;Fires when patient has a Date of Death at another site 91 ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC 92 ;ISSUES mail group when a given patient has a Date of Death at 93 ;another site. 94 ; 95 ;Input: Required Variables 96 ; 97 ; DFN - IEN in the PATIENT file (#2) 98 ; ARRAY - Array of data containing sending sites station number and SSN 99 ; NAME - Patient's name 100 ; RDOD - Date of Death at remote site 101 ; LDOD - Date of Death at local site 102 ; CMOR - Coordinating Master of Record 103 ; 104 Q:($G(ARRAY)="")!($G(DFN)="") 105 Q:(RDOD=LDOD) ;If remote DOD and local DOD same, QUIT 106 N CMOR 107 S CMOR=$$CMOR2^MPIF001(DFN) I $P(CMOR,"^")<0 S CMOR="not assigned" 108 N RGRSTEXT 109 S RGRSTEXT(1)="The MPI/PD Package has received a message from:" 110 S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) 111 S RGRSTEXT(3)=" " 112 S RGRSTEXT(4)="This message indicates that patient "_NAME 113 I 'LDOD S RGRSTEXT(5)="has a date of death at the other facility but not at your facility." G RMTMSG 114 I LDOD,(LDOD'=RDOD) S RGRSTEXT(5)="has a different date of death at the other facility than at your facility." 115 RMTMSG S RGRSTEXT(6)=" " 116 S RGRSTEXT(7)="Remote Patient SSN: "_$S(@ARRAY@("SSN")="":"Not Available",1:@ARRAY@("SSN")) 117 S RGRSTEXT(8)="Date of Death from other facility: "_$$FMTE^XLFDT(RDOD) 118 I LDOD,(LDOD'=RDOD) S RGRSTEXT(9)="Date of Death at your facility: "_$$FMTE^XLFDT(LDOD) 119 S RGRSTEXT(10)=" " 120 S RGRSTEXT(11)="CMOR site: "_CMOR 121 D BULL2^RGRSBULL("Remote Date of Death Indicated","RGRSTEXT(") 122 Q 123 ; 124 INST(SITENUM) ; 125 N RETURN,IEN,DATA,NAME,NUMBER 126 S RETURN="" 127 Q:$G(SITENUM)="" RETURN 128 S IEN=$$LKUP^XUAF4(SITENUM) 129 I IEN>0 S DATA=$$NS^XUAF4(IEN) 130 I $G(DATA)]"" D 131 . S NAME=$P(DATA,"^",1),NUMBER=$P(DATA,"^",2) 132 . S RETURN=NAME_" --> Site Number: "_NUMBER 133 Q RETURN 134 ; 135 FORMAT(DATA1,DATA2) ; 136 N SPACES,SPACENUM,LENGTH1,LENGTH2,RETURN 137 S SPACES=" " 138 S LENGTH1=$L(DATA1),LENGTH2=$L(DATA2) 139 I LENGTH1>23 S DATA1=$E(DATA1,1,23) S LENGTH1=23 140 I LENGTH2>22 S DATA2=$E(DATA2,1,22) 141 S SPACENUM=23-LENGTH1 142 S SPACES=$E(SPACES,1,SPACENUM) 143 S RETURN=DATA1_SPACES_" "_DATA2 144 Q $G(RETURN) 145 ; 146 FREE(DATA) ; 147 Q:$G(DATA)="" "" 148 Q:$G(DATA)["@" "" 149 Q:$G(DATA)=HL("Q") "" 150 Q $G(DATA) -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSPT.m
r613 r623 1 RGRSPT ;ALB/RJS,CML-HIGH LEVEL ROUTINE FOR PARSING AND FILING ;06/25/98 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,7,8,52**;30 Apr 99;Build 2 3 ; 4 ;Parse Incoming Message, and file. 5 ; 6 ; 7 Q:($G(HL("MTN"))'="ADT") 8 N RGRSDFN,VAFCA,RGRS,VAFCA08,RGRSARAY,BOGUS,RGDC,SENSTVTY,CMORDISP 9 N NAME,LASTNAME,SSN,ICN,CMOR,CMORIEN,OTHSITE,RGRSDATA,HERE,BULSUB,NODE 10 S RGRSARAY="RGRS(2)" 11 D INITIZE^RGRSUTIL ;copy HL7 message into local RGDC array 12 S VAFCA=$$EN^RGRSMSH() ;parse MSH for filer 13 D EN^RGRSPARS(RGRSARAY) ;parse HL7 message into local array RGRS 14 I $$SKIP^RGRSZZPT(1,RGRSARAY) D G EXIT ;skip if certain data is not there 15 . D SKIPBULL^RGRSBULL(RGRSARAY) 16 S RGRSDFN=$$GETDFN^MPIF001(@RGRSARAY@(991.01)) ;Get DFN from ICN 17 Q:+$$SEND2^VAFCUTL1(RGRSDFN,"T") ;safeguard to prevent the processing of test patients 18 S OTHSITE=@RGRSARAY@("SITENUM")\1 19 S HERE=$P($$SITE^VASITE,"^",3)\1 20 ; 21 ;If patient not known in site, send bulletin, go exit 22 ; 23 I +RGRSDFN=-1 D EXC^RGHLLOG(210,"Msg#"_$G(HL("MID"))_" Bad DFN#"_$G(RGRSDFN)_" for "_$G(@RGRSARAY@(.01))_" (ICN#"_$G(@RGRSARAY@(991.01))_")") D STOP^RGHLLOG(1) Q 24 ; 25 S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01) 26 S LASTNAME=$P(NAME,",",1) 27 S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09) 28 S NODE=$$MPINODE^MPIFAPI(RGRSDFN) 29 S ICN=$P(NODE,"^") 30 S CMORIEN=$P(NODE,"^",3) 31 S CMOR=$$NS^XUAF4(CMORIEN) 32 S CMORDISP=$P(CMOR,"^",1) 33 S CMOR=$P(CMOR,"^",2) 34 ; 35 S @RGRSARAY@("NAME")=@RGRSARAY@(.01) 36 S @RGRSARAY@("SSN")=@RGRSARAY@(.09) 37 S @RGRSARAY@("ICN")=@RGRSARAY@(991.01) 38 S @RGRSARAY@("CMOR")=$P($$NS^XUAF4($$LKUP^XUAF4(OTHSITE)),"^") 39 ; 40 ;If ICN or CMOR don't match, send bulletin and go exit 41 I '$$MATCH(RGRSDFN,RGRSARAY,,,ICN,CMOR,.BULSUB) D G EXIT 42 . D MTCHBULL^RGRSBULL(RGRSDFN,RGRSARAY,NAME,SSN,ICN,CMORDISP,BULSUB) 43 ; 44 ;if ICN and CMOR match, check for SSN edit from CMOR 45 I @RGRSARAY@("SENDING SITE")=CMOR,(SSN'=@RGRSARAY@(.09)) D 46 .D SSNBULL^RGRSBUL1(RGRSDFN,RGRSARAY,NAME,SSN,ICN,CMORDISP) 47 ; 48 ;If patient is Sensitive at other site but not here send bulletin 49 S SENSTVTY=$G(@RGRSARAY@("SENSITIVITY")) 50 I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D SENSTIVE^RGRSBUL1(RGRSDFN,RGRSARAY,NAME) 51 ; 52 ;MPIC_772 - **52; Commented out Remote Date of Death Indicated section. 53 ;If patient has DATE OF DEATH (DOD) at remote site send bulletin 54 ;Ignore time if present with date. 55 ;S RMTDOD=@RGRSARAY@(.351),RMTDOD=$P(RMTDOD,".") 56 ;S DFN=RGRSDFN D DEM^VADPT 57 ;S LOCDOD=$P($P(VADM(6),"^"),".") 58 ;If there is a remote DOD but no local DOD OR 59 ;if remote DOD is different from local DOD, send bulletin 60 ;I RMTDOD D RMTDOD^RGRSBUL1(RGRSDFN,RGRSARAY,NAME,RMTDOD,LOCDOD) 61 ;K LOCDOD,RMTDOD,VADM 62 ; 63 D G EXIT ;**7 64 . ; 65 . ;IF it's the CMOR - review file 66 . ; 67 . I (OTHSITE)=(HERE) D Q 68 . . S VAFCA=VAFCA_"^"_RGRSDFN 69 . . S VAFCA08=1 S BOGUS=$$ADD^VAFCEHU1(VAFCA,"RGRS") 70 . ; 71 . ;IF it's not the CMOR - Don't Rebroadcast 72 . ; 73 . I (OTHSITE)'=(HERE) D Q 74 . . S VAFCA08=1 75 . . D EDIT^VAFCPTED(RGRSDFN,RGRSARAY,".01;.03;.09;.02;.2403") ;**7 broadcasted fields - removed .05,.08,.111;.112;.113;.114;.115;.1112;.117;.131;.132;.211;.219;.31115 76 EXIT ; 77 Q 78 ; 79 MATCH(DFN,RGRSARAY,LASTNAME,SSN,ICN,CMOR,BULSUB) ; 80 Q:$G(DFN)=""!($G(RGRSARAY)="") 0 81 N COUNT,TRUE S (COUNT,TRUE)=0 82 S BULSUB="" 83 I $D(LASTNAME) D 84 . S COUNT=COUNT+1 85 . I (LASTNAME'=""),(LASTNAME=$P(@RGRSARAY@(.01),",",1)) S TRUE=TRUE+1 86 I $D(SSN) D 87 . S COUNT=COUNT+1 88 . I (SSN'=""),(SSN=$G(@RGRSARAY@(.09))) S TRUE=TRUE+1 89 I $D(ICN) D 90 . S COUNT=COUNT+1 91 . I (ICN'=""),(ICN=$G(@RGRSARAY@(991.01))) S TRUE=TRUE+1 Q 92 . S BULSUB=BULSUB_"ICN" 93 I $D(CMOR) D 94 . S COUNT=COUNT+1 95 . I (CMOR'=""),(CMOR=$G(@RGRSARAY@("SITENUM"))) S TRUE=TRUE+1 Q 96 . I BULSUB]"" S BULSUB=BULSUB_" & " 97 . S BULSUB=BULSUB_"CMOR" 98 I COUNT=TRUE Q 1 99 Q 0 1 RGRSPT ;ALB/RJS,CML-HIGH LEVEL ROUTINE FOR PARSING AND FILING ;06/25/98 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,7,8**;30 Apr 99 3 ; 4 ;Parse Incoming Message, and file. 5 ; 6 ; 7 Q:($G(HL("MTN"))'="ADT") 8 N RGRSDFN,VAFCA,RGRS,VAFCA08,RGRSARAY,BOGUS,RGDC,SENSTVTY,CMORDISP 9 N NAME,LASTNAME,SSN,ICN,CMOR,CMORIEN,OTHSITE,RGRSDATA,HERE,BULSUB,NODE 10 S RGRSARAY="RGRS(2)" 11 D INITIZE^RGRSUTIL ;copy HL7 message into local RGDC array 12 S VAFCA=$$EN^RGRSMSH() ;parse MSH for filer 13 D EN^RGRSPARS(RGRSARAY) ;parse HL7 message into local array RGRS 14 I $$SKIP^RGRSZZPT(1,RGRSARAY) D G EXIT ;skip if certain data is not there 15 . D SKIPBULL^RGRSBULL(RGRSARAY) 16 S RGRSDFN=$$GETDFN^MPIF001(@RGRSARAY@(991.01)) ;Get DFN from ICN 17 Q:+$$SEND2^VAFCUTL1(RGRSDFN,"T") ;safeguard to prevent the processing of test patients 18 S OTHSITE=@RGRSARAY@("SITENUM")\1 19 S HERE=$P($$SITE^VASITE,"^",3)\1 20 ; 21 ;If patient not known in site, send bulletin, go exit 22 ; 23 I +RGRSDFN=-1 D EXC^RGHLLOG(210,"Msg#"_$G(HL("MID"))_" Bad DFN#"_$G(RGRSDFN)_" for "_$G(@RGRSARAY@(.01))_" (ICN#"_$G(@RGRSARAY@(991.01))_")") D STOP^RGHLLOG(1) Q 24 ; 25 S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01) 26 S LASTNAME=$P(NAME,",",1) 27 S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09) 28 S NODE=$$MPINODE^MPIFAPI(RGRSDFN) 29 S ICN=$P(NODE,"^") 30 S CMORIEN=$P(NODE,"^",3) 31 S CMOR=$$NS^XUAF4(CMORIEN) 32 S CMORDISP=$P(CMOR,"^",1) 33 S CMOR=$P(CMOR,"^",2) 34 ; 35 S @RGRSARAY@("NAME")=@RGRSARAY@(.01) 36 S @RGRSARAY@("SSN")=@RGRSARAY@(.09) 37 S @RGRSARAY@("ICN")=@RGRSARAY@(991.01) 38 S @RGRSARAY@("CMOR")=$P($$NS^XUAF4($$LKUP^XUAF4(OTHSITE)),"^") 39 ; 40 ;If ICN or CMOR don't match, send bulletin and go exit 41 I '$$MATCH(RGRSDFN,RGRSARAY,,,ICN,CMOR,.BULSUB) D G EXIT 42 . D MTCHBULL^RGRSBULL(RGRSDFN,RGRSARAY,NAME,SSN,ICN,CMORDISP,BULSUB) 43 ; 44 ;if ICN and CMOR match, check for SSN edit from CMOR 45 I @RGRSARAY@("SENDING SITE")=CMOR,(SSN'=@RGRSARAY@(.09)) D 46 .D SSNBULL^RGRSBUL1(RGRSDFN,RGRSARAY,NAME,SSN,ICN,CMORDISP) 47 ; 48 ;If patient is Sensitive at other site but not here send bulletin 49 S SENSTVTY=$G(@RGRSARAY@("SENSITIVITY")) 50 I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D SENSTIVE^RGRSBUL1(RGRSDFN,RGRSARAY,NAME) 51 ; 52 ;If patient has DATE OF DEATH (DOD) at remote site send bulletin 53 ;Ignore time if present with date. 54 S RMTDOD=@RGRSARAY@(.351),RMTDOD=$P(RMTDOD,".") 55 S DFN=RGRSDFN D DEM^VADPT 56 S LOCDOD=$P($P(VADM(6),"^"),".") 57 ;If there is a remote DOD but no local DOD OR 58 ;if remote DOD is different from local DOD, send bulletin 59 I RMTDOD D RMTDOD^RGRSBUL1(RGRSDFN,RGRSARAY,NAME,RMTDOD,LOCDOD) 60 K LOCDOD,RMTDOD,VADM 61 ; 62 D G EXIT ;**7 63 . ; 64 . ;IF it's the CMOR - review file 65 . ; 66 . I (OTHSITE)=(HERE) D Q 67 . . S VAFCA=VAFCA_"^"_RGRSDFN 68 . . S VAFCA08=1 S BOGUS=$$ADD^VAFCEHU1(VAFCA,"RGRS") 69 . ; 70 . ;IF it's not the CMOR - Don't Rebroadcast 71 . ; 72 . I (OTHSITE)'=(HERE) D Q 73 . . S VAFCA08=1 74 . . D EDIT^VAFCPTED(RGRSDFN,RGRSARAY,".01;.03;.09;.02;.2403") ;**7 broadcasted fields - removed .05,.08,.111;.112;.113;.114;.115;.1112;.117;.131;.132;.211;.219;.31115 75 EXIT ; 76 Q 77 ; 78 MATCH(DFN,RGRSARAY,LASTNAME,SSN,ICN,CMOR,BULSUB) ; 79 Q:$G(DFN)=""!($G(RGRSARAY)="") 0 80 N COUNT,TRUE S (COUNT,TRUE)=0 81 S BULSUB="" 82 I $D(LASTNAME) D 83 . S COUNT=COUNT+1 84 . I (LASTNAME'=""),(LASTNAME=$P(@RGRSARAY@(.01),",",1)) S TRUE=TRUE+1 85 I $D(SSN) D 86 . S COUNT=COUNT+1 87 . I (SSN'=""),(SSN=$G(@RGRSARAY@(.09))) S TRUE=TRUE+1 88 I $D(ICN) D 89 . S COUNT=COUNT+1 90 . I (ICN'=""),(ICN=$G(@RGRSARAY@(991.01))) S TRUE=TRUE+1 Q 91 . S BULSUB=BULSUB_"ICN" 92 I $D(CMOR) D 93 . S COUNT=COUNT+1 94 . I (CMOR'=""),(CMOR=$G(@RGRSARAY@("SITENUM"))) S TRUE=TRUE+1 Q 95 . I BULSUB]"" S BULSUB=BULSUB_" & " 96 . S BULSUB=BULSUB_"CMOR" 97 I COUNT=TRUE Q 1 98 Q 0 -
WorldVistAEHR/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGSYSTAT.m
r613 r623 1 RGSYSTAT ;BAY/ALS-MPI/PD STATUS DISPLAY ;01/05/01 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**16,19,23,25,20,43,45,52**;30 Apr 99;Build 2 3 ; 4 ;Reference to ^DGCN(391.98,"AST" supported by IA #3303 5 ;Reference to ^DGCN(391.984 supported by IA #3304 6 ;Reference to ^MPIF(984.9 supported by IA #3298 7 ;Reference to OPTSTAT^XUTMOPT supported by IA #1472 8 ;Reference to ^DPT("ACMORS", ^DPT("AICN", and ^DPT("AICNL" supported by IA #2070 9 ;Reference to ^VAT(391.71 supported by IA #3422 10 EN ; 11 ; Count exceptions on hand 12 EXC ; 13 W @IOF,"Exception Handler Entries:",!,"--------------------------" 14 S CNT=0,EXCTYP="",NTYP="",TOTL=0,PCNT=0 15 N STAT,DFN,ICN 16 S HOME=$$SITE^VASITE() 17 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D 18 . I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, 217, & 227 19 .. I (EXCTYP'=NTYP)&(CNT>0) D 20 ... S ETEXT=$P($G(^RGHL7(991.11,NTYP,10)),"^",1) 21 ... W !,$E(ETEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 22 .. S IEN=0,NTYP=EXCTYP 23 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 24 ... S IEN2=0 25 ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 26 .... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5) I STAT<1 D 27 ..... S DFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'DFN 28 ..... S ^XTMP("RGEXC",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"MPI/PD Status Display" 29 ..... S ^XTMP("RGEXC",DFN)=DFN 30 ..... S ICN=+$$GETICN^MPIF001(DFN) 31 ..... I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!(EXCTYP=218) D ;**43;**45;MPIC_772; **52 remove 215, 216, and 217 32 ...... S CNT=CNT+1 33 I CNT>0 D 34 .S ETEXT=$P($G(^RGHL7(991.11,NTYP,10)),"^",1) 35 .W !,$E(ETEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT 36 I TOTL=0 W !,"There are no entries in the Exception Handler." 37 I TOTL>0 D 38 . W !!,"Total number of exceptions: ",?55,$J(TOTL,6) 39 . S PDFN="" 40 . F S PDFN=$O(^XTMP("RGEXC",PDFN)) Q:'PDFN D 41 .. S PCNT=PCNT+1 42 . W !,"Total unique patient exceptions: ",?55,$J(PCNT,6) 43 S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1) 44 I $D(^RGSITE(991.8,1,"EXCPRG")) D 45 . S STDT=$$FMTE^XLFDT(STDT,1) 46 . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"." 47 K CNT,EXCTYP,NTYP,ETEXT,TOTL,IEN,IEN2,HOME,PCNT,^XTMP("RGEXC"),PDFN,STDT 48 I $Y>21 D QUIT Q:X="^" 49 PDR ;Count entries in Patient Data Review ;**52 Obsolete data removed from report. 50 ;W !!,"Patient Data Review Entries:",!,"----------------------------" 51 ;S CNT=0,PDRTYP="",NTYP="",TOTL=0 52 ;F S PDRTYP=$O(^DGCN(391.98,"AST",PDRTYP)) Q:'PDRTYP D 53 ;. I (PDRTYP'=NTYP)&(CNT>0) D 54 ;.. S DIC="^DGCN(391.984,",DR=".01",DA=NTYP,DIQ(0)="E",DIQ="RGPDR" 55 ;.. D EN^DIQ1 K DIC,DA,DR,DIQ 56 ;.. S PTEXT=$G(RGPDR(391.984,NTYP,.01,"E")) 57 ;.. W !,$E(PTEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 58 ;. I (PDRTYP=1)!(PDRTYP=2)!(PDRTYP=5) D 59 ;.. S IEN=0,NTYP=PDRTYP 60 ;.. F S IEN=$O(^DGCN(391.98,"AST",PDRTYP,IEN)) Q:'IEN D 61 ;... S CNT=CNT+1 62 ;I CNT>0 D 63 ;. S DIC="^DGCN(391.984,",DR=".01",DA=NTYP,DIQ(0)="E",DIQ="RGPDR" 64 ;. D EN^DIQ1 K DIC,DA,DR,DIQ 65 ;. S PTEXT=$G(RGPDR(391.984,NTYP,.01,"E")) 66 ;.W !,$E(PTEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT 67 ;I TOTL=0 W !,"There are no entries in Patient Data Review." 68 ;K CNT,PDRTYP,NTYP,TOTL,IEN,PTEXT,RGPDR 69 ;Q 70 ;I $Y>20 D QUIT Q:X="^" 71 ; 72 CMOR ;CMOR Requests Status ;**52 Obsolete data removed from report. 73 ;W !!,"CMOR Requests Status:",!,"---------------------" 74 ;S CNT=0,STAT="",NSTAT="",TOTL=0 75 ;F S STAT=$O(^MPIF(984.9,"AC",STAT)) Q:'STAT D 76 ;. I (STAT'=NSTAT)&(CNT>0) D 77 ;.. S TEXT=$$EXTERNAL^DILFD(984.9,.06,,NSTAT) 78 ;.. W !,$E(TEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 79 ;. S IEN=0,NSTAT=STAT 80 ;. F S IEN=$O(^MPIF(984.9,"AC",STAT,IEN)) Q:'IEN D 81 ;.. S CNT=CNT+1 S TOTL=TOTL+CNT 82 ;I CNT>0 S TEXT=$$EXTERNAL^DILFD(984.9,.06,,NSTAT) W !,$E(TEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 83 ;I TOTL=0 W !,"There are no outstanding CMOR Requests." 84 ;K CNT,STAT,NSTAT,TEXT,TOTL,IEN 85 ;I $Y>20 D QUIT Q:X="^" 86 ; 87 S HOME=$P($$SITE^VASITE(),"^",3) 88 S ICN=0,CNT=0 89 F S ICN=$O(^DPT("AICN",ICN)) Q:'ICN D 90 .Q:$E(ICN,1,3)=HOME 91 .S CNT=CNT+1 92 W !!,"Current total number of National ICNs = ",CNT 93 S ICN=0,CNT=0 94 F S ICN=$O(^DPT("AICNL",1,ICN)) Q:'ICN S CNT=CNT+1 95 W !,"Current total number of Local ICNs = ",CNT 96 K CNT,DFN,ICN 97 Q 98 QUIT S DIR(0)="E" D D ^DIR K DIR 99 .S SS=21-$Y F JJ=1:1:SS W ! 100 S $Y=0 101 K JJ,SS 102 Q 1 RGSYSTAT ;BAY/ALS-MPI/PD STATUS DISPLAY ;01/05/01 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**16,19,23,25,20,43,45**;30 Apr 99;Build 9 3 ;Reference to ^DGCN(391.98,"AST" supported by IA #3303 4 ;Reference to ^DGCN(391.984 supported by IA #3304 5 ;Reference to ^MPIF(984.9 supported by IA #3298 6 ;Reference to OPTSTAT^XUTMOPT supported by IA #1472 7 ;Reference to ^DPT("ACMORS", ^DPT("AICN", and ^DPT("AICNL" supported by IA #2070 8 ;Reference to ^VAT(391.71 supported by IA #3422 9 EN ; 10 ; Count exceptions on hand 11 EXC ; 12 W @IOF,"Exception Handler Entries:",!,"--------------------------" 13 S CNT=0,EXCTYP="",NTYP="",TOTL=0,PCNT=0 14 N STAT,DFN,ICN 15 S HOME=$$SITE^VASITE() 16 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D 17 . I (EXCTYP=234)!(EXCTYP=227)!((EXCTYP>214)&(EXCTYP<219)) D ;**45 18 .. I (EXCTYP'=NTYP)&(CNT>0) D 19 ... S ETEXT=$P($G(^RGHL7(991.11,NTYP,10)),"^",1) 20 ... W !,$E(ETEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 21 .. S IEN=0,NTYP=EXCTYP 22 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 23 ... S IEN2=0 24 ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 25 .... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5) I STAT<1 D 26 ..... S DFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'DFN 27 ..... S ^XTMP("RGEXC",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"MPI/PD Status Display" 28 ..... S ^XTMP("RGEXC",DFN)=DFN 29 ..... S ICN=+$$GETICN^MPIF001(DFN) 30 ..... I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**43,45 31 ...... S CNT=CNT+1 32 I CNT>0 D 33 .S ETEXT=$P($G(^RGHL7(991.11,NTYP,10)),"^",1) 34 .W !,$E(ETEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT 35 I TOTL=0 W !,"There are no entries in the Exception Handler." 36 I TOTL>0 D 37 . W !!,"Total number of exceptions: ",?55,$J(TOTL,6) 38 . S PDFN="" 39 . F S PDFN=$O(^XTMP("RGEXC",PDFN)) Q:'PDFN D 40 .. S PCNT=PCNT+1 41 . W !,"Total unique patient exceptions: ",?55,$J(PCNT,6) 42 S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1) 43 I $D(^RGSITE(991.8,1,"EXCPRG")) D 44 . S STDT=$$FMTE^XLFDT(STDT,1) 45 . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"." 46 K CNT,EXCTYP,NTYP,ETEXT,TOTL,IEN,IEN2,HOME,PCNT,^XTMP("RGEXC"),PDFN,STDT 47 I $Y>21 D QUIT Q:X="^" 48 PDR ;Count entries in Patient Data Review 49 W !!,"Patient Data Review Entries:",!,"----------------------------" 50 S CNT=0,PDRTYP="",NTYP="",TOTL=0 51 F S PDRTYP=$O(^DGCN(391.98,"AST",PDRTYP)) Q:'PDRTYP D 52 . I (PDRTYP'=NTYP)&(CNT>0) D 53 .. S DIC="^DGCN(391.984,",DR=".01",DA=NTYP,DIQ(0)="E",DIQ="RGPDR" 54 .. D EN^DIQ1 K DIC,DA,DR,DIQ 55 .. S PTEXT=$G(RGPDR(391.984,NTYP,.01,"E")) 56 .. W !,$E(PTEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 57 . I (PDRTYP=1)!(PDRTYP=2)!(PDRTYP=5) D 58 .. S IEN=0,NTYP=PDRTYP 59 .. F S IEN=$O(^DGCN(391.98,"AST",PDRTYP,IEN)) Q:'IEN D 60 ... S CNT=CNT+1 61 I CNT>0 D 62 . S DIC="^DGCN(391.984,",DR=".01",DA=NTYP,DIQ(0)="E",DIQ="RGPDR" 63 . D EN^DIQ1 K DIC,DA,DR,DIQ 64 . S PTEXT=$G(RGPDR(391.984,NTYP,.01,"E")) 65 .W !,$E(PTEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT 66 I TOTL=0 W !,"There are no entries in Patient Data Review." 67 K CNT,PDRTYP,NTYP,TOTL,IEN,PTEXT,RGPDR 68 ;Q 69 I $Y>20 D QUIT Q:X="^" 70 ; 71 CMOR ;CMOR Requests Status 72 W !!,"CMOR Requests Status:",!,"---------------------" 73 S CNT=0,STAT="",NSTAT="",TOTL=0 74 F S STAT=$O(^MPIF(984.9,"AC",STAT)) Q:'STAT D 75 . I (STAT'=NSTAT)&(CNT>0) D 76 .. S TEXT=$$EXTERNAL^DILFD(984.9,.06,,NSTAT) 77 .. W !,$E(TEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 78 . S IEN=0,NSTAT=STAT 79 . F S IEN=$O(^MPIF(984.9,"AC",STAT,IEN)) Q:'IEN D 80 .. S CNT=CNT+1 S TOTL=TOTL+CNT 81 I CNT>0 S TEXT=$$EXTERNAL^DILFD(984.9,.06,,NSTAT) W !,$E(TEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 82 I TOTL=0 W !,"There are no outstanding CMOR Requests." 83 K CNT,STAT,NSTAT,TEXT,TOTL,IEN 84 I $Y>20 D QUIT Q:X="^" 85 ; 86 S HOME=$P($$SITE^VASITE(),"^",3) 87 S ICN=0,CNT=0 88 F S ICN=$O(^DPT("AICN",ICN)) Q:'ICN D 89 .Q:$E(ICN,1,3)=HOME 90 .S CNT=CNT+1 91 W !,"Current total number of National ICNs = ",CNT 92 S ICN=0,CNT=0 93 F S ICN=$O(^DPT("AICNL",1,ICN)) Q:'ICN S CNT=CNT+1 94 W !,"Current total number of Local ICNs = ",CNT 95 K CNT,DFN,ICN 96 Q 97 QUIT S DIR(0)="E" D D ^DIR K DIR 98 .S SS=21-$Y F JJ=1:1:SS W ! 99 S $Y=0 100 K JJ,SS 101 Q
Note:
See TracChangeset
for help on using the changeset viewer.
