Released DG*5.3*505 SEQ #454 Extracted from mail message **KIDS**:DG*5.3*505^ **INSTALL NAME** DG*5.3*505 "BLD",1694,0) DG*5.3*505^REGISTRATION^0^3030626^y "BLD",1694,1,0) ^^3^3^3030429^ "BLD",1694,1,1,0) MPI CHANGES - ITERATION 1 "BLD",1694,1,2,0) Refer to patch DG*5.3*505 in the FORUM Patch Module for a complete "BLD",1694,1,3,0) description. "BLD",1694,4,0) ^9.64PA^2^1 "BLD",1694,4,2,0) 2 "BLD",1694,4,2,2,0) ^9.641^2^1 "BLD",1694,4,2,2,2,0) PATIENT (File-top level) "BLD",1694,4,2,2,2,1,0) ^9.6411^994^1 "BLD",1694,4,2,2,2,1,994,0) MULTIPLE BIRTH INDICATOR "BLD",1694,4,2,222) y^n^p^^^^n "BLD",1694,4,"APDD",2,2) "BLD",1694,4,"APDD",2,2,994) "BLD",1694,4,"B",2,2) "BLD",1694,"ABNS",0) ^9.66A^^ "BLD",1694,"ABPKG") ^^ "BLD",1694,"INI") PRE^DG505P "BLD",1694,"INIT") POST^DG505P "BLD",1694,"KRN",0) ^9.67PA^8989.52^19 "BLD",1694,"KRN",.4,0) .4 "BLD",1694,"KRN",.4,"NM",0) ^9.68A^^ "BLD",1694,"KRN",.401,0) .401 "BLD",1694,"KRN",.402,0) .402 "BLD",1694,"KRN",.403,0) .403 "BLD",1694,"KRN",.5,0) .5 "BLD",1694,"KRN",.84,0) .84 "BLD",1694,"KRN",3.6,0) 3.6 "BLD",1694,"KRN",3.8,0) 3.8 "BLD",1694,"KRN",9.2,0) 9.2 "BLD",1694,"KRN",9.8,0) 9.8 "BLD",1694,"KRN",9.8,"NM",0) ^9.68A^7^6 "BLD",1694,"KRN",9.8,"NM",1,0) VAFCPDAT^^0^B37000539 "BLD",1694,"KRN",9.8,"NM",3,0) VAFCPDT2^^0^B20966973 "BLD",1694,"KRN",9.8,"NM",4,0) DGRPC^^0^B20213182 "BLD",1694,"KRN",9.8,"NM",5,0) DGRPC2^^0^B18796060 "BLD",1694,"KRN",9.8,"NM",6,0) DGRPCE1^^0^B5615168 "BLD",1694,"KRN",9.8,"NM",7,0) DG505P^^0^B7978936 "BLD",1694,"KRN",9.8,"NM","B","DG505P",7) "BLD",1694,"KRN",9.8,"NM","B","DGRPC",4) "BLD",1694,"KRN",9.8,"NM","B","DGRPC2",5) "BLD",1694,"KRN",9.8,"NM","B","DGRPCE1",6) "BLD",1694,"KRN",9.8,"NM","B","VAFCPDAT",1) "BLD",1694,"KRN",9.8,"NM","B","VAFCPDT2",3) "BLD",1694,"KRN",19,0) 19 "BLD",1694,"KRN",19.1,0) 19.1 "BLD",1694,"KRN",101,0) 101 "BLD",1694,"KRN",409.61,0) 409.61 "BLD",1694,"KRN",771,0) 771 "BLD",1694,"KRN",870,0) 870 "BLD",1694,"KRN",8989.51,0) 8989.51 "BLD",1694,"KRN",8989.52,0) 8989.52 "BLD",1694,"KRN",8994,0) 8994 "BLD",1694,"KRN","B",.4,.4) "BLD",1694,"KRN","B",.401,.401) "BLD",1694,"KRN","B",.402,.402) "BLD",1694,"KRN","B",.403,.403) "BLD",1694,"KRN","B",.5,.5) "BLD",1694,"KRN","B",.84,.84) "BLD",1694,"KRN","B",3.6,3.6) "BLD",1694,"KRN","B",3.8,3.8) "BLD",1694,"KRN","B",9.2,9.2) "BLD",1694,"KRN","B",9.8,9.8) "BLD",1694,"KRN","B",19,19) "BLD",1694,"KRN","B",19.1,19.1) "BLD",1694,"KRN","B",101,101) "BLD",1694,"KRN","B",409.61,409.61) "BLD",1694,"KRN","B",771,771) "BLD",1694,"KRN","B",870,870) "BLD",1694,"KRN","B",8989.51,8989.51) "BLD",1694,"KRN","B",8989.52,8989.52) "BLD",1694,"KRN","B",8994,8994) "BLD",1694,"QUES",0) ^9.62^^ "BLD",1694,"REQB",0) ^9.611^3^3 "BLD",1694,"REQB",1,0) DG*5.3*415^2 "BLD",1694,"REQB",2,0) DG*5.3*474^2 "BLD",1694,"REQB",3,0) DG*5.3*489^2 "BLD",1694,"REQB","B","DG*5.3*415",1) "BLD",1694,"REQB","B","DG*5.3*474",2) "BLD",1694,"REQB","B","DG*5.3*489",3) "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^n^p^^^^n "FIA",2,0,10) "FIA",2,0,11) "FIA",2,0,"RLRO") "FIA",2,0,"VR") 5.3^DG "FIA",2,2) 1 "FIA",2,2,994) "INI") PRE^DG505P "INIT") POST^DG505P "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813^2970721^12541 "PKG",5,22,1,"PAH",1,0) 505^3030626 "PKG",5,22,1,"PAH",1,1,0) ^^3^3^3030626 "PKG",5,22,1,"PAH",1,1,1,0) MPI CHANGES - ITERATION 1 "PKG",5,22,1,"PAH",1,1,2,0) Refer to patch DG*5.3*505 in the FORUM Patch Module for a complete "PKG",5,22,1,"PAH",1,1,3,0) description. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 6 "RTN","DG505P") 0^7^B7978936 "RTN","DG505P",1,0) DG505P ;BIR/PTD-PATCH DG*5.3*505 PRE/POST INSTALLATION ROUTINE ;4/7/03 "RTN","DG505P",2,0) ;;5.3;Registration;**505**;Aug 13, 1993 "RTN","DG505P",3,0) ; "RTN","DG505P",4,0) ;Reference to ^DD supported by IA #4078 "RTN","DG505P",5,0) ; "RTN","DG505P",6,0) PRE ;pre-install to check consistency checker data elements "RTN","DG505P",7,0) I $$PATCH^XPDUTL("DG*5.3*505") Q ;patch previously installed - don't abort post init "RTN","DG505P",8,0) N I "RTN","DG505P",9,0) F I=64:1:66 I $D(^DGIN(38.6,I,0)) D H 2 "RTN","DG505P",10,0) . D BMES^XPDUTL(" ** Internal entry number "_I_" already exists in file 38.6 - contact NVS **") "RTN","DG505P",11,0) . S XPDABORT=2 "RTN","DG505P",12,0) Q "RTN","DG505P",13,0) ; "RTN","DG505P",14,0) POST ;Post-init entry point "RTN","DG505P",15,0) D POST1,POST2 "RTN","DG505P",16,0) Q "RTN","DG505P",17,0) ; "RTN","DG505P",18,0) POST1 ;Update identifier code for MULTIPLE BIRTH INDICATOR (#994) field in PATIENT (#2) file "RTN","DG505P",19,0) D BMES^XPDUTL(" Updating the identifier code for the MULTIPLE BIRTH INDICATOR (#994) field.") "RTN","DG505P",20,0) S ^DD(2,0,"ID",994)="I $$GET1^DIQ(2,Y_"","",994,""I"")=""Y"" D EN^DDIOL($$GET1^DIQ(2,Y_"","",994),"""",""?$X+2"")" "RTN","DG505P",21,0) Q "RTN","DG505P",22,0) ; "RTN","DG505P",23,0) POST2 ;post-init to add new inconsistent data elements "RTN","DG505P",24,0) N I "RTN","DG505P",25,0) F I=64:1:66 D "RTN","DG505P",26,0) .N MSGROOT,FDAWP,FDAROOT,IENROOT,IEN,X "RTN","DG505P",27,0) .D BMES^XPDUTL("Creating definition for INCONSISTENT DATA ELEMENT #"_I) "RTN","DG505P",28,0) .S IEN="+1," "RTN","DG505P",29,0) .I I=64 D ;POB CITY/STATE MISSING "RTN","DG505P",30,0) ..S FDAROOT(38.6,IEN,.01)="POB CITY/STATE MISSING" "RTN","DG505P",31,0) ..S FDAROOT(38.6,IEN,2)="PLACE OF BIRTH CITY OR STATE IS MISSING" "RTN","DG505P",32,0) ..S FDAROOT(38.6,IEN,50)="FDAWP" "RTN","DG505P",33,0) ..S FDAWP(1,0)="Inconsistency results if the Patient's Place of Birth City or" "RTN","DG505P",34,0) ..S FDAWP(2,0)="State have not been entered." "RTN","DG505P",35,0) .I I=65 D ;MOTHER'S MAIDEN NAME MISSING "RTN","DG505P",36,0) ..S FDAROOT(38.6,IEN,.01)="MOTHER'S MAIDEN NAME MISSING" "RTN","DG505P",37,0) ..S FDAROOT(38.6,IEN,2)="MOTHER'S MAIDEN NAME MISSING" "RTN","DG505P",38,0) ..S FDAROOT(38.6,IEN,50)="FDAWP" "RTN","DG505P",39,0) ..S FDAWP(1,0)="Inconsistency results if the Mother's Maiden Name is not entered." "RTN","DG505P",40,0) .I I=66 D ;PSEUDO SSN IN USE "RTN","DG505P",41,0) ..S FDAROOT(38.6,IEN,.01)="PSEUDO SSN IN USE" "RTN","DG505P",42,0) ..S FDAROOT(38.6,IEN,2)="PSEUDO SSN IN USE" "RTN","DG505P",43,0) ..S FDAROOT(38.6,IEN,50)="FDAWP" "RTN","DG505P",44,0) ..S FDAWP(1,0)="Inconsistency results if a Pseudo SSN has been entered." "RTN","DG505P",45,0) .S FDAROOT(38.6,IEN,3)="NO KEY REQUIRED" "RTN","DG505P",46,0) .S FDAROOT(38.6,IEN,4)="NO" "RTN","DG505P",47,0) .S FDAROOT(38.6,IEN,5)="CHECK" "RTN","DG505P",48,0) .S IENROOT(1)=I "RTN","DG505P",49,0) .D UPDATE^DIE("E","FDAROOT","IENROOT","MSGROOT") "RTN","DG505P",50,0) .I $D(MSGROOT("DIERR")) D "RTN","DG505P",51,0) ..N ERR,LN,LN2 "RTN","DG505P",52,0) ..S (ERR,LN2)=0 "RTN","DG505P",53,0) ..F S ERR=+$O(MSGROOT("DIERR",ERR)) Q:'ERR D "RTN","DG505P",54,0) ...S LN=0 "RTN","DG505P",55,0) ...F S LN=+$O(MSGROOT("DIERR",ERR,"TEXT",LN)) Q:'LN D "RTN","DG505P",56,0) ....S LN2=LN2+1 "RTN","DG505P",57,0) ....S X(LN2)=MSGROOT("DIERR",ERR,"TEXT",LN) "RTN","DG505P",58,0) ..D BMES^XPDUTL(.X) "RTN","DG505P",59,0) Q "RTN","DGRPC") 0^4^B20213182 "RTN","DGRPC",1,0) DGRPC ;ALB/MRL - CHECK CONSISTENCY OF PATIENT DATA ;3/27/01 4:43pm "RTN","DGRPC",2,0) ;;5.3;Registration;**108,121,314,301,470,489,505**;Aug 13, 1993 "RTN","DGRPC",3,0) ; "RTN","DGRPC",4,0) ;linetags in routines correspond to IEN of file 38.6 "RTN","DGRPC",5,0) ; "RTN","DGRPC",6,0) ;variables: DGVT = 1 if VETERAN? = YES, 0 if NO "RTN","DGRPC",7,0) ; DGSC = 1 if SC? = YES, 0 if NO "RTN","DGRPC",8,0) ; DGCD = 0 node of file EC file (#8) "RTN","DGRPC",9,0) ; DGRPCOLD = old inconsistencies for pt (separated by ,s) "RTN","DGRPC",10,0) ; DGCHK = #s to check (separated by ,s) "RTN","DGRPC",11,0) ; DGLST = next # to check "RTN","DGRPC",12,0) ; DGER = inconsistencies found (separated by ,s) "RTN","DGRPC",13,0) ; DGNCK = 1 if missing key elig data...can't process further "RTN","DGRPC",14,0) ; "RTN","DGRPC",15,0) D ON I $S(('$D(DFN)#2):1,'$D(^DPT(DFN,0)):1,DGER:1,1:0) G KVAR^DGRPCE:DGER "RTN","DGRPC",16,0) EN S:'$D(DGEDCN)#2 DGEDCN=0 I DGEDCN W !!,"Checking data for consistency..." "RTN","DGRPC",17,0) D START:DGEDCN "RTN","DGRPC",18,0) F I=0,.13,.141,.22,.24,.3,.31,.311,.32,.321,.322,.33,.35,.36,.362,.38,.39,.52,.53,"TYPE","VET" S DGP(I)=$G(^DPT(DFN,I)) "RTN","DGRPC",19,0) ;get old inconsistencies "RTN","DGRPC",20,0) S DGRPCOLD="," I $D(^DGIN(38.5,DFN)) F I=0:0 S I=$O(^DGIN(38.5,DFN,"I",I)) Q:'I S DGRPCOLD=DGRPCOLD_I_"," "RTN","DGRPC",21,0) ;find consistencies to check/not check "RTN","DGRPC",22,0) S DGCHK="," F I=0:0 S I=$O(^DGIN(38.6,I)) Q:'I I $D(^(I,0)),$S(I=2:0,I=51:0,I=9:1,I=10:1,I=13:1,I=14:1,I=22:1,I=52:1,I=53:1,'$P(^(0),"^",5):1,1:0),I'=99 S DGCHK=DGCHK_I_"," "RTN","DGRPC",23,0) S DGVT=$S(DGP("VET")="Y":1,1:0),DGSC=$S($P(DGP(.3),"^",1)="Y":1,1:0),DGCD=$S($D(^DIC(8,+DGP(.36),0)):^(0),1:""),(DGCT,DGER,DGNCK)="" I 'DGVT,$D(^DG(391,+DGP("TYPE"),0)),$P(^(0),"^",2) S DGVT=2 "RTN","DGRPC",24,0) S DGLST=+$P(DGCHK,",",2) G @DGLST "RTN","DGRPC",25,0) 1 S DGD=$P(DGP(0),"^",1) I DGD?1L.E!(DGD?.E1L.E)!(DGD="") S X=1 D COMB,NEXT I +DGLST'=2 G @DGLST "RTN","DGRPC",26,0) S I1=0 F I=1:1:$L(DGD) Q:I1 S J=$E(DGD,I) I J?1NP,$A(J)>32,J'=",",J'="-",J'=".",J'="'" S I1=1 "RTN","DGRPC",27,0) I I1 S X=1 D COMB "RTN","DGRPC",28,0) D NEXT I +DGLST'=2 G @DGLST "RTN","DGRPC",29,0) 2 S I1=0 F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:'I!(I1) I $P(^(I,0),"^",1)'?1A.E S I1=1 "RTN","DGRPC",30,0) I I1 S X=2 D COMB "RTN","DGRPC",31,0) D NEXT I +DGLST>7!('DGLST) G @DGLST "RTN","DGRPC",32,0) 3 ; "RTN","DGRPC",33,0) 4 ; "RTN","DGRPC",34,0) 5 ; "RTN","DGRPC",35,0) 6 ; "RTN","DGRPC",36,0) 7 F I=2,3,5,8,9 I $P(DGP(0),"^",I)="" S X=$S(I=2:3,I=3:4,I=5:5,I=8:6,1:7) D COMB:DGCHK[(","_X_",") "RTN","DGRPC",37,0) S DGLST=7 G:DGCHK'[",7," FIND^DGRPC2 D NEXT I +DGLST'=8 G @DGLST "RTN","DGRPC",38,0) 8 S I1=0,DGD=$G(^DPT(DFN,.11)) F I=1,4,5,6,7 Q:I1 I $P(DGD,"^",I)="" S I1=1 "RTN","DGRPC",39,0) I I1 S X=8 D COMB "RTN","DGRPC",40,0) D NEXT I +DGLST'=9 G @DGLST "RTN","DGRPC",41,0) 9 I DGP("VET")="" S X=9,DGNCK=1 D COMB "RTN","DGRPC",42,0) D NEXT I +DGLST'=10 G @DGLST "RTN","DGRPC",43,0) 10 I $P(DGP(.3),"^",1)="" S X=10,DGNCK=1 D COMB "RTN","DGRPC",44,0) D NEXT I +DGLST'=11 G @DGLST "RTN","DGRPC",45,0) 11 I 'DGVT,DGSC S X=11 D COMB "RTN","DGRPC",46,0) D NEXT I +DGLST'=12 G @DGLST "RTN","DGRPC",47,0) 12 I DGSC,DGVT,$P(DGP(.3),"^",2)="" S X=12 D COMB "RTN","DGRPC",48,0) D NEXT I +DGLST'=13 G @DGLST "RTN","DGRPC",49,0) 13 I '$D(^DIC(21,+$P(DGP(.32),"^",3),0)) S X=13,DGNCK=1 D COMB "RTN","DGRPC",50,0) D NEXT I +DGLST'=14 G @DGLST "RTN","DGRPC",51,0) 14 I $P(DGCD,"^",1)="" S X=14,DGNCK=1 D COMB "RTN","DGRPC",52,0) ; "RTN","DGRPC",53,0) ;Check Patient Eligibilities multiple if Primary Elig Code defined "RTN","DGRPC",54,0) I DGP(.36),'$D(^DPT(DFN,"E",+DGP(.36),0)) D PRI^VADPT60 ;5.3*301 "RTN","DGRPC",55,0) ; "RTN","DGRPC",56,0) D NEXT I +DGLST'=15 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",57,0) 15 I $P($G(^DPT(DFN,.15)),"^",2)]"",$P(DGP(.3),"^",7)="" S X=15 D COMB "RTN","DGRPC",58,0) D NEXT I +DGLST'=16 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",59,0) 16 D H^DGUTL I +DGP(.35)>DGTIME S X=16 D COMB "RTN","DGRPC",60,0) D NEXT I +DGLST'=17 G FIND^DGRPC2:+DGLST=35,@DGLST "RTN","DGRPC",61,0) 17 K DGDATE,DGTIME S I1=0 I +DGP(.35) S DGD=DT F I=0:0 S DGD=$O(^DPT(DFN,"S",DGD)) Q:DGD=""!(I1) S X=$P(^(DGD,0),"^",2) I X=""!(X="I") S I1=1 "RTN","DGRPC",62,0) I I1 S X=17 D COMB "RTN","DGRPC",63,0) ; "RTN","DGRPC",64,0) END ; end of routine...find next check to execute (or goto end) "RTN","DGRPC",65,0) S:DGNCK DGLST=35 G:DGCHK'[",35,"&(DGNCK) FIND^DGRPC2 D NEXT G @DGLST "RTN","DGRPC",66,0) ; "RTN","DGRPC",67,0) COMB ;record inconsistency "RTN","DGRPC",68,0) S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q "RTN","DGRPC",69,0) Q "RTN","DGRPC",70,0) ; "RTN","DGRPC",71,0) NEXT ; find the next consistency check to check (goto end if can't process further) "RTN","DGRPC",72,0) S I=$F(DGCHK,(","_DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,DGLST<18 Q "RTN","DGRPC",73,0) I +DGLST,DGNCK,+DGLST>17,+DGLST<36 S DGLST=35 Q:DGCHK'[",35," G NEXT "RTN","DGRPC",74,0) S:'+DGLST DGLST="END^DGRPC2" I +DGLST S DGLST=DGLST_"^DGRPC"_$S(+DGLST<43:1,1:2) "RTN","DGRPC",75,0) Q "RTN","DGRPC",76,0) ; "RTN","DGRPC",77,0) PAT ;check inconsistencies for a selected patient "RTN","DGRPC",78,0) D ON G KVAR^DGRPCE:DGER W !! S DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Check consistency for which PATIENT: " D ^DIC K DIC G KVAR^DGRPCE:Y'>0 S DFN=+Y,DGEDCN=1 D DGRPC G PAT "RTN","DGRPC",79,0) ; "RTN","DGRPC",80,0) START ;record start time for checker "RTN","DGRPC",81,0) S DGSTART=$H Q "RTN","DGRPC",82,0) ; "RTN","DGRPC",83,0) TIME ;record end time for checker "RTN","DGRPC",84,0) Q:'$D(DGSTART)#2 S DGEND=$H,X=$P(DGSTART,",",2),X1=$P(DGEND,",",2) "RTN","DGRPC",85,0) I +DGSTART=+DGEND S DGTIME=X1-X "RTN","DGRPC",86,0) E S DGTIME=(5184000-X)+X1 "RTN","DGRPC",87,0) I $S(DGCT:0,DGCON=1:1,1:0) G TIMEQ "RTN","DGRPC",88,0) W !!,"===> ",$S(DGCT:DGCT,DGCON<2:"No",1:"All")," inconsistenc",$S(DGCT=1:"y",1:"ies")," ",$S('DGCON:"found",DGCON=1:"filed",1:"removed")," in ",DGTIME," second",$S(DGTIME=1:"",1:"s"),"..." H 1 "RTN","DGRPC",89,0) TIMEQ K DGSTART,DGEND,DGTIME,X,X1,DGCON Q "RTN","DGRPC",90,0) ; "RTN","DGRPC",91,0) ON ;check if checker is on "RTN","DGRPC",92,0) S DGER=0 I $S('$D(^DG(43,1,0)):1,'$P(^(0),"^",37):1,1:0) S DGER=1 "RTN","DGRPC",93,0) S:'$D(DGEDCN) DGEDCN=0 W:DGER !!,"CONSISTENCY CHECKER TURNED OFF!!",$C(7) Q "RTN","DGRPC2") 0^5^B18796060 "RTN","DGRPC2",1,0) DGRPC2 ;ALB/MRL - CHECK CONSISTENCY OF PATIENT DATA (CONT) ;25 AUG 88@0901 "RTN","DGRPC2",2,0) ;;5.3;Registration;**45,69,108,121,205,218,342,387,470,467,489,505**;Aug 13, 1993 "RTN","DGRPC2",3,0) ; "RTN","DGRPC2",4,0) 43 ; "RTN","DGRPC2",5,0) 44 ; "RTN","DGRPC2",6,0) 45 ; "RTN","DGRPC2",7,0) 46 ; "RTN","DGRPC2",8,0) 47 I DGVT S X=42,DGD=DGP(.362) F I=12:1:14 S X=X+1 I DGCHK[(","_X_","),($P(DGD,"^",I)="Y"),($P(DGD,"^",20)="") D COMB "RTN","DGRPC2",9,0) S DGLST=$S(DGCHK[",47,":47,DGCHK[",46,":46,DGCHK[",45,":45,DGCHK[",44,":44,1:DGLST) "RTN","DGRPC2",10,0) D NEXT G @DGLST "RTN","DGRPC2",11,0) 48 I DGVT S DGD=DGP(.362) I DGCHK[(",48,"),($P(DGD,"^",17)="Y"),($P(DGD,"^",6)="") S X=48 D COMB "RTN","DGRPC2",12,0) D NEXT G @DGLST "RTN","DGRPC2",13,0) 49 ; "RTN","DGRPC2",14,0) 50 ; insurance checks "RTN","DGRPC2",15,0) I DGCHK[",49,"!(DGCHK[",50,") D S DGLST=$S(DGCHK["50":50,1:49) "RTN","DGRPC2",16,0) . N COV,INS,X "RTN","DGRPC2",17,0) . S X=0,COV=$S($P(DGP(.31),"^",11)="Y":1,1:0) "RTN","DGRPC2",18,0) . D ALL^IBCNS1(DFN,"INS",2,DT) "RTN","DGRPC2",19,0) . I COV,'$G(INS(0)) S X=49 ; yes, but none "RTN","DGRPC2",20,0) . I 'COV,$G(INS(0)) S X=50 ; not yes, but some "RTN","DGRPC2",21,0) . I DGCHK[(","_X_",") D COMB "RTN","DGRPC2",22,0) D NEXT G @DGLST "RTN","DGRPC2",23,0) 51 D NEXT G @DGLST ; 51 disabled "RTN","DGRPC2",24,0) S X=$S($D(^DIC(21,+$P(DGP(.32),"^",3),0)):$P(^(0),"^",3),1:"") "RTN","DGRPC2",25,0) I X="Z"&($P(DGP(.32),"^",5)'=7)&($P(DGP(.32),"^",10)'=7)&($P(DGP(.32),"^",15)'=7)!($P(DGP(.32),"^",5)=7&(X'="Z")) S X=51 D COMB "RTN","DGRPC2",26,0) ; "RTN","DGRPC2",27,0) 52 I $P(DGP(.31),"^",11)']"" S X=52 D COMB ;automatically on "RTN","DGRPC2",28,0) D NEXT G @DGLST "RTN","DGRPC2",29,0) 53 I $P(DGP(.311),"^",15)']"" S X=53 D COMB ;automatically on "RTN","DGRPC2",30,0) D NEXT G @DGLST "RTN","DGRPC2",31,0) 54 ; "RTN","DGRPC2",32,0) 55 ;BELOW IS USED BY BOTH 54 & 55 "RTN","DGRPC2",33,0) S DGLST=$S(DGCHK["55":55,1:54) "RTN","DGRPC2",34,0) I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) D NEXT G @DGLST ; patient died before current year "RTN","DGRPC2",35,0) N DGE S DGE=+$O(^DIC(8.1,"B","SERVICE CONNECTED 50% to 100%",0)) "RTN","DGRPC2",36,0) I $P($G(^DPT(DFN,.3)),U,2)'<50!($P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),U,9)=DGE) D NEXT G @DGLST ;50-100% SC "RTN","DGRPC2",37,0) S DGPTYP=$G(^DG(391,+DGP("TYPE"),"S")),DGISYR=$E(DT,1,3)-1_"0000" I '$P(DGPTYP,"^",8)&('$P(DGPTYP,"^",9)) K DGPTYP,DGISYR D NEXT G @DGLST ; screens 8 and 9 off "RTN","DGRPC2",38,0) D ALL^DGMTU21(DFN,"VSD",DT,"IP") "RTN","DGRPC2",39,0) I '$P(DGPTYP,"^",8)!(DGCHK'["54") G JUST55 ; screen 8 off OR JUST 55 IN CHK "RTN","DGRPC2",40,0) S DGFL=0 I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") S DGFL=1 "RTN","DGRPC2",41,0) I 'DGFL F I=0:0 S I=$O(DGREL("D",I)) Q:'I I $$SSN^DGMTU1(+DGREL("D",I))']"" S DGFL=1 Q "RTN","DGRPC2",42,0) I DGFL S X=54 D COMB "RTN","DGRPC2",43,0) JUST55 I DGCHK'["55" D NEXT G @DGLST "RTN","DGRPC2",44,0) S DGLST=55 "RTN","DGRPC2",45,0) I '$P(DGPTYP,"^",9) D NEXT G @DGLST ; screen 9 off "RTN","DGRPC2",46,0) D TOT^DGRP9(.DGINC) S DGFL=0 "RTN","DGRPC2",47,0) F DGD="V","S","D" I $D(DGTOT(DGD)) F I=8:1:17 I $P(DGTOT(DGD),"^",I)]"" S DGFL=1 Q "RTN","DGRPC2",48,0) I 'DGFL N DGAPD D I 'DGAPD S X=55 D COMB "RTN","DGRPC2",49,0) . S DGAPD=+$$LST^DGMTU(DFN),DGAPD=+$P($G(^DGMT(408.31,+DGAPD,0)),U,11) "RTN","DGRPC2",50,0) D NEXT G @DGLST "RTN","DGRPC2",51,0) 56 I DGVT S DGD=DGP(.3) I DGCHK[(",56,"),($P(DGD,"^",11)="Y"),($P(DGP(.362),"^",20)="") S X=56 D COMB "RTN","DGRPC2",52,0) D NEXT G END:$S('+DGLST:1,+DGLST=99:1,1:0) "RTN","DGRPC2",53,0) 57 I $P(DGP(.38),U,1) D "RTN","DGRPC2",54,0) .N X1,X2 "RTN","DGRPC2",55,0) .S X1=$P(DGP(.38),U,2) "RTN","DGRPC2",56,0) .S X=$P($G(^DG(43,1,0)),U,46) S X2=$S(X:X,1:365) D C^%DTC "RTN","DGRPC2",57,0) .I X
17),(I<36) S DGLST=36 G FIND "RTN","DGRPC2",104,0) I I,I<99 S DGLST=I G @(DGLST_$S(DGLST>42:"",DGLST>17:"^DGRPC1",1:"^DGRPC")) "RTN","DGRPC2",105,0) G END "RTN","DGRPC2",106,0) ; "RTN","DGRPCE1") 0^6^B5615168 "RTN","DGRPCE1",1,0) DGRPCE1 ;ALB/MIR/BRM - CONSISTENCY CHECKER EDIT ;10/17/02 1:47pm "RTN","DGRPCE1",2,0) ;;5.3;Registration;**108,226,470,454,489,505**;Aug 13, 1993 "RTN","DGRPCE1",3,0) N I F I=1:1:8,16,53,57,58,61,62,63,64,65,66 D SASK "RTN","DGRPCE1",4,0) ;F I=49,50,52 D SASK ;BELOW REPLACED WITH ^IBCNSP2 CALL "RTN","DGRPCE1",5,0) ;OLDS DR(2,2.312)="S DGRPADI="""";.01;1;2;15;8;7;3;6;S DGRPADI=X;I DGRPADI'=""v"" S Y=""@2312"";17///^S X=""`""_DFN;16///^S X=""01"";S Y=""@23121"";@2312;17;16//^S X=$S(DGRPADI=""s"":""02"",1:"""");@23121;9:14;" "RTN","DGRPCE1",6,0) D SAVE Q "RTN","DGRPCE1",7,0) SASK I DGER[(","_I_","),DGASK'[(","_I_",") S DGD=DGD_$P($T(@I),";;",2,999),DGASK=DGASK_I_"," "RTN","DGRPCE1",8,0) Q "RTN","DGRPCE1",9,0) SAVE I $L(@DGDR)+$L(DGD)<241 S @DGDR=@DGDR_DGD,DGD="" Q "RTN","DGRPCE1",10,0) S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q "RTN","DGRPCE1",11,0) ; "RTN","DGRPCE1",12,0) ; "RTN","DGRPCE1",13,0) ELIG ;eligibility code...if M11+, use compiled template, otherwise DR string "RTN","DGRPCE1",14,0) I ^%ZOSF("OS")'["M/11+" S DGD=$P($T(14),";;",2,999) D SAVE Q "RTN","DGRPCE1",15,0) N DA,DIE,DR S DIE="^DPT(",DA=DFN,DR="[DG CONSISTENCY CHECKER]" D ^DIE "RTN","DGRPCE1",16,0) Q "RTN","DGRPCE1",17,0) ; "RTN","DGRPCE1",18,0) ; "RTN","DGRPCE1",19,0) 1 ;;.01; "RTN","DGRPCE1",20,0) 2 ;;1; "RTN","DGRPCE1",21,0) 3 ;;.02; "RTN","DGRPCE1",22,0) 4 ;;.03; "RTN","DGRPCE1",23,0) 5 ;;.05; "RTN","DGRPCE1",24,0) 6 ;;.08; "RTN","DGRPCE1",25,0) 7 ;;.09; "RTN","DGRPCE1",26,0) 8 ;;.111;S DIE("NO^")="OUTOK";S:X="" Y="@1112";.112;S:X="" Y="@1112";.113;@1112;S EASZIPLK=1;.1112;K EASDO2;.114;S:'$$KEY^DGREGDD1(DUZ,DA) Y="@8";.115;.117;@8; "RTN","DGRPCE1",27,0) 14 ;;.361;S DGECODE=$S($D(^DIC(8,+X,0)):$P(^(0),"^",1),1:"");S:$S(DGECODE["ALLIED":0,DGECODE["FEDERAL":0,1:1) Y=.323;.309;.323;D ^DGYZODS;S:'DGODS Y="";11500.02;11500.03; "RTN","DGRPCE1",28,0) 16 ;;.351; "RTN","DGRPCE1",29,0) 53 ;;.07;.31115;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@53";.3111;S:X']"" Y="@53";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@53; "RTN","DGRPCE1",30,0) 57 ;;.381;.382///NOW; "RTN","DGRPCE1",31,0) 58 ;;.322013;S:X'="Y" Y="@589";.322014;.322015;.32201;S:X'="Y" Y="@581";.322011;.322012;@581;.322016;S:X'="Y" Y="@589";.322017;.322018;@589; "RTN","DGRPCE1",32,0) 61 ;;.131;.132; "RTN","DGRPCE1",33,0) 62 ;;.331; "RTN","DGRPCE1",34,0) 63 ;;.1411;S DIE("NO^")="OUTOK";S:X']"" Y=.1414;.1412;S:X']"" Y=.1414;.1413;.1414;.1415;.1416;Q;.14111;K DIE("NO^"); "RTN","DGRPCE1",35,0) 64 ;;.092;.093; "RTN","DGRPCE1",36,0) 65 ;;.2403; "RTN","DGRPCE1",37,0) 66 ;;.09; "RTN","VAFCPDAT") 0^1^B37000539 "RTN","VAFCPDAT",1,0) VAFCPDAT ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ;10/24/02 13:13 "RTN","VAFCPDAT",2,0) ;;5.3;Registration;**333,414,474,505**;Aug 13, 1993 "RTN","VAFCPDAT",3,0) ;Registration has IA #3299 for MPI/PD to call START^VAFCPDAT "RTN","VAFCPDAT",4,0) ;Reference to CALC^RGVCCMR2 supported by IA #2710 "RTN","VAFCPDAT",5,0) MAIN ; Entry point with device call "RTN","VAFCPDAT",6,0) S NOTRPC=1 "RTN","VAFCPDAT",7,0) K ZTSAVE S ZTSAVE("DFN")="" "RTN","VAFCPDAT",8,0) D EN^XUTMDEVQ("START^VAFCPDAT","Print MPI/PD Patient Data",.ZTSAVE) "RTN","VAFCPDAT",9,0) K NOTRPC "RTN","VAFCPDAT",10,0) Q "RTN","VAFCPDAT",11,0) ; "RTN","VAFCPDAT",12,0) START ;Entry point without device call, used for RPC calls "RTN","VAFCPDAT",13,0) S $P(LN,"=",80)="",$P(LN2,"=",60)="",QFLG=0 "RTN","VAFCPDAT",14,0) D NOW^%DTC S HDT=$$FMTE^XLFDT($E(%,1,12)) "RTN","VAFCPDAT",15,0) S SITE=$$SITE^VASITE(),SITENAM=$P(SITE,"^",2),SITENUM=$P(SITE,"^",3),SITEIEN=$P(SITE,"^") "RTN","VAFCPDAT",16,0) I +DFN<0 D Q "RTN","VAFCPDAT",17,0) .I $D(NOTRPC) W @IOF,!," " "RTN","VAFCPDAT",18,0) .W !,"ICN ",$G(ICN)," does not exist at ",SITENAM,"." "RTN","VAFCPDAT",19,0) .W !,"Search date: ",HDT,!,LN "RTN","VAFCPDAT",20,0) S DIC=2,DR=".01;.02;.03;.09;.111;.112;.113;.114;.115;.1112;.131;.313;.351;994",DA=DFN,DIQ(0)="EI",DIQ="DNODE" "RTN","VAFCPDAT",21,0) N NAME,SSN,DOB,SEX,CLAIM,DOD,ICN,STR1,STR2,STR3,CTY,ST,ZIP,PHN,MBI "RTN","VAFCPDAT",22,0) D EN^DIQ1 K DIC,DR,DA,DIQ "RTN","VAFCPDAT",23,0) S NAME=$G(DNODE(2,DFN,.01,"E")),SSN=$G(DNODE(2,DFN,.09,"E")) "RTN","VAFCPDAT",24,0) S DOB=$$FMTE^XLFDT($G(DNODE(2,DFN,.03,"I"))) "RTN","VAFCPDAT",25,0) S MBI=$G(DNODE(2,DFN,994,"I")) I MBI="Y" S MBI="YES" "RTN","VAFCPDAT",26,0) S SEX=$G(DNODE(2,DFN,.02,"E")),DOD=$G(DNODE(2,DFN,.351,"E")) "RTN","VAFCPDAT",27,0) S CLAIM=$G(DNODE(2,DFN,.313,"E")) S:CLAIM="" CLAIM="None" "RTN","VAFCPDAT",28,0) S STR1=$G(DNODE(2,DFN,.111,"E")),STR2=$G(DNODE(2,DFN,.112,"E")),STR3=$G(DNODE(2,DFN,.113,"E")) "RTN","VAFCPDAT",29,0) S CTY=$G(DNODE(2,DFN,.114,"E")),ST=$G(DNODE(2,DFN,.115,"E")),ZIP=$G(DNODE(2,DFN,.1112,"E")) "RTN","VAFCPDAT",30,0) S PHN=$G(DNODE(2,DFN,.131,"E")) "RTN","VAFCPDAT",31,0) S MNODE=$$MPINODE^MPIFAPI(DFN) I +MNODE=-1 S MNODE="^^^^^" "RTN","VAFCPDAT",32,0) S (ICN,CMOR,SCN,SCORE,SCRDT,DIFF)="" "RTN","VAFCPDAT",33,0) S ICN=$P($G(MNODE),"^") S:ICN="" ICN="None" "RTN","VAFCPDAT",34,0) S CMOR=$$GET1^DIQ(4,+$P($G(MNODE),"^",3)_",",.01) S:CMOR="" CMOR="None" "RTN","VAFCPDAT",35,0) S SCN=$P($G(MNODE),"^",5) S:SCN="" SCN="None" "RTN","VAFCPDAT",36,0) S SCORE=$P($G(MNODE),"^",6) "RTN","VAFCPDAT",37,0) S SCRDT=$P($G(MNODE),"^",7) S:SCRDT'="" DIFF=$$FMDIFF^XLFDT(DT,SCRDT,1) "RTN","VAFCPDAT",38,0) I DIFF>30 S RGDFN=DFN D CALC^RGVCCMR2 S SCORE=$$GET1^DIQ(2,DFN,991.06) "RTN","VAFCPDAT",39,0) S:SCORE="" SCORE="None" "RTN","VAFCPDAT",40,0) I $E(ICN,1,3)=SITENUM S GOT=0 D "RTN","VAFCPDAT",41,0) . I $P($G(MNODE),"^",4)=""!('$D(^DPT("AICNL",1,DFN))) S ICN=ICN_"**" "RTN","VAFCPDAT",42,0) ; "RTN","VAFCPDAT",43,0) I $D(NOTRPC) W @IOF,! "RTN","VAFCPDAT",44,0) W !,"MPI/PD Data for: ",NAME," (DFN #",DFN,")" "RTN","VAFCPDAT",45,0) ; check for patient sensitivity and user security "RTN","VAFCPDAT",46,0) N RESULT,RGSENS,SENSTV,DA,DR,DIC,DIQ,VAFCSEN "RTN","VAFCPDAT",47,0) D PTSEC^DGSEC4(.RESULT,DFN,0,"MPI/PD Patient Inquiry^MPI/PD Patient Inquiry") "RTN","VAFCPDAT",48,0) I RESULT(1)=-1 W !!,"Access denied: Required parameters not defined" G QUIT "RTN","VAFCPDAT",49,0) I RESULT(1)>0 W ?50,"***PATIENT MARKED SENSITIVE***" "RTN","VAFCPDAT",50,0) I RESULT(1)=3 W !!,"Access not allowed on your own PATIENT (#2) file entry" G QUIT "RTN","VAFCPDAT",51,0) I RESULT(1)=4 W !!,"Access denied: Your SSN is not defined" G QUIT "RTN","VAFCPDAT",52,0) I RESULT(1)<3 D "RTN","VAFCPDAT",53,0) . I RESULT(1)=1 D NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",2) ;IA #3027 "RTN","VAFCPDAT",54,0) . I RESULT(1)=2 D NOTICE^DGSEC4(.VAFCSEN,DFN,"RPC - VAFC REMOTE PDAT FROM THE MPI^MPI/PD Patient Inquiry (Remote)",3) ;IA #3027 "RTN","VAFCPDAT",55,0) W !,"Printed ",HDT," at ",SITENAM,!,LN "RTN","VAFCPDAT",56,0) S $Y=$Y+1 "RTN","VAFCPDAT",57,0) ; "RTN","VAFCPDAT",58,0) W !,"SSN : ",SSN,?40,"ICN : ",ICN "RTN","VAFCPDAT",59,0) W !,"Sex : ",SEX,?40,"CMOR: ",CMOR "RTN","VAFCPDAT",60,0) W !,"Claim #: ",CLAIM,?40,"CMOR Activity Score : ",SCORE "RTN","VAFCPDAT",61,0) W !,"Date of Birth: ",DOB,?40,"Subscription Control #: ",SCN "RTN","VAFCPDAT",62,0) I DOD]"" W !,"Date of Death: ",DOD "RTN","VAFCPDAT",63,0) I MBI="YES" W !,"Multiple Birth Indicator: ",MBI "RTN","VAFCPDAT",64,0) W !,"Address: ",STR1 "RTN","VAFCPDAT",65,0) I STR2'="" W !?9,STR2 "RTN","VAFCPDAT",66,0) I STR3'="" W !?9,STR3 "RTN","VAFCPDAT",67,0) I CTY'="" W !?9,$E(CTY,1,20)_", "_$G(ST)_" "_$G(ZIP) "RTN","VAFCPDAT",68,0) I PHN'="" W !,"Phone #: ",PHN "RTN","VAFCPDAT",69,0) I $G(IOSL)<30&($E(IOST,1,2)="C-") D "RTN","VAFCPDAT",70,0) .I $Y>23 D "RTN","VAFCPDAT",71,0) ..S DIR(0)="E" D D ^DIR K DIR I 'Y S QFLG=1 "RTN","VAFCPDAT",72,0) ...S SS=22-$Y F JJ=1:1:SS W ! "RTN","VAFCPDAT",73,0) ..S $Y=0 "RTN","VAFCPDAT",74,0) I QFLG=1 G QUIT "RTN","VAFCPDAT",75,0) ; "RTN","VAFCPDAT",76,0) TF ;List Treating Facilities for this patient "RTN","VAFCPDAT",77,0) D TFHDR "RTN","VAFCPDAT",78,0) K TFARR "RTN","VAFCPDAT",79,0) S TF=0 F S TF=$O(^DGCN(391.91,"APAT",DFN,TF)) Q:'TF D "RTN","VAFCPDAT",80,0) .S TFIEN=$O(^DGCN(391.91,"APAT",DFN,TF,0)) "RTN","VAFCPDAT",81,0) . S DIC="^DGCN(391.91,",DR=".02;.03;.07",DA=TFIEN,DIQ(0)="EI",DIQ="TFDATA" "RTN","VAFCPDAT",82,0) . D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDAT",83,0) . S INST="",STATION="" "RTN","VAFCPDAT",84,0) . S INST=$G(TFDATA(391.91,TFIEN,.02,"I")) "RTN","VAFCPDAT",85,0) . I INST'="" D "RTN","VAFCPDAT",86,0) .. S DIC=4,DR="99",DA=INST,DIQ(0)="E",DIQ="STA" "RTN","VAFCPDAT",87,0) .. D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDAT",88,0) .. S STATION=$G(STA(4,INST,99,"E")) "RTN","VAFCPDAT",89,0) . S TFNM=$G(TFDATA(391.91,TFIEN,.02,"E")) "RTN","VAFCPDAT",90,0) . S LSTDT=$G(TFDATA(391.91,TFIEN,.03,"I")) S:LSTDT="" LSTDT="none found" "RTN","VAFCPDAT",91,0) . S LSTSORT=9999999 "RTN","VAFCPDAT",92,0) . I +LSTDT S LSTSORT=9999999-LSTDT,LSTDT=$$FMTE^XLFDT($E(LSTDT,1,12)) "RTN","VAFCPDAT",93,0) . S REACODE=$G(TFDATA(391.91,TFIEN,.07,"E")) S REASON="none found" "RTN","VAFCPDAT",94,0) . I REACODE'="" D "RTN","VAFCPDAT",95,0) .. S DIC="^VAT(391.72,",DIC(0)="Z",X=REACODE D ^DIC K DIC,X "RTN","VAFCPDAT",96,0) .. S REASON=$P($G(Y(0)),"^",4) "RTN","VAFCPDAT",97,0) . S TFARR(LSTSORT,TFNM)=TFIEN_"^"_REASON_"^"_$G(STATION)_"^"_LSTDT "RTN","VAFCPDAT",98,0) I '$D(TFARR) W !,"No Treating Facilities found." G SUB "RTN","VAFCPDAT",99,0) S LSTSORT=0 F S LSTSORT=$O(TFARR(LSTSORT)) Q:'LSTSORT D G:QFLG QUIT "RTN","VAFCPDAT",100,0) .S TFNM="" F S TFNM=$O(TFARR(LSTSORT,TFNM)) Q:TFNM="" D Q:QFLG "RTN","VAFCPDAT",101,0) ..S REASON=$P(TFARR(LSTSORT,TFNM),"^",2) "RTN","VAFCPDAT",102,0) ..S STATION=$P(TFARR(LSTSORT,TFNM),"^",3) "RTN","VAFCPDAT",103,0) ..S LSTDT=$P(TFARR(LSTSORT,TFNM),"^",4) "RTN","VAFCPDAT",104,0) ..I $Y+3>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDAT",105,0) ...S LNQ=22 D SS Q:QFLG "RTN","VAFCPDAT",106,0) ...W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D TFHDR "RTN","VAFCPDAT",107,0) ..W !,$E(TFNM,1,20),?22,$G(STATION),?32,LSTDT,?54,REASON "RTN","VAFCPDAT",108,0) SUB ;removed listing of subscribers for RG*1.0*23 "RTN","VAFCPDAT",109,0) HIS ;find ICN history "RTN","VAFCPDAT",110,0) I '$O(^DPT(DFN,"MPIFHIS",0)) G CONT "RTN","VAFCPDAT",111,0) ; "RTN","VAFCPDAT",112,0) I $Y+4>IOSL&($E(IOST,1,2)="C-") D G:QFLG QUIT "RTN","VAFCPDAT",113,0) .S LNQ=22 D SS Q:QFLG "RTN","VAFCPDAT",114,0) .W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 "RTN","VAFCPDAT",115,0) D ICNHDR "RTN","VAFCPDAT",116,0) S HIS=0 F S HIS=$O(^DPT(DFN,"MPIFHIS",HIS)) Q:'HIS D G:QFLG QUIT "RTN","VAFCPDAT",117,0) .S DIC=2,DR="992",DR(2.0992)=".01;3",DA=DFN,DA(2.0992)=HIS "RTN","VAFCPDAT",118,0) .S DIQ(0)="E",DIQ="HISNODE" "RTN","VAFCPDAT",119,0) .D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDAT",120,0) .S HISICN=$G(HISNODE(2.0992,HIS,.01,"E")) "RTN","VAFCPDAT",121,0) .S HISDT=$G(HISNODE(2.0992,HIS,3,"E")) "RTN","VAFCPDAT",122,0) .I $Y+3>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDAT",123,0) ..S LNQ=22 D SS Q:QFLG "RTN","VAFCPDAT",124,0) ..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D ICNHDR "RTN","VAFCPDAT",125,0) .W !,HISICN I HISDT]"" W " - changed ",HISDT "RTN","VAFCPDAT",126,0) ; "RTN","VAFCPDAT",127,0) CONT ;Continue to VAFCPDT2 for CMOR data and extended data "RTN","VAFCPDAT",128,0) D CMORHIS^VAFCPDT2 "RTN","VAFCPDAT",129,0) DONE ; "RTN","VAFCPDAT",130,0) I QFLG G QUIT "RTN","VAFCPDAT",131,0) I ($E(IOST,1,2)="C-") S LNQ=24 D SS "RTN","VAFCPDAT",132,0) ; "RTN","VAFCPDAT",133,0) QUIT ; "RTN","VAFCPDAT",134,0) K %,CMOR,DIC,DIR,DIRUT,DNODE,GOT,HDT,HIS,HISDT,HISICN,JJ,LIEN,LINST "RTN","VAFCPDAT",135,0) K LN,LSTDT,MNODE,REACODE,REASON,SCN,SCORE,SITE,SITEIEN,SITENAM,SITENUM "RTN","VAFCPDAT",136,0) K SS,SUBN,SUBARR,TERM,TERMDT,TF,TFARR,TFDATA,TFIEN,TFNM,Y,D,CHG,CHGNODE "RTN","VAFCPDAT",137,0) K HISNODE,DIFF,INST,RGDFN,SCRDT,STATION,STA,LN2,NAME,LSTSORT,LNQ,QFLG,MBI "RTN","VAFCPDAT",138,0) Q "RTN","VAFCPDAT",139,0) TFHDR ; "RTN","VAFCPDAT",140,0) W !!,"Treating Facilities:",?22,"Station:",?32,"DT Last Treated",?54,"Event Reason" "RTN","VAFCPDAT",141,0) W !,"--------------------",?22,"--------",?32,"---------------",?54,"------------" "RTN","VAFCPDAT",142,0) Q "RTN","VAFCPDAT",143,0) ICNHDR W !!,"ICN History:",!,"------------" "RTN","VAFCPDAT",144,0) Q "RTN","VAFCPDAT",145,0) ; "RTN","VAFCPDAT",146,0) SS S DIR(0)="E" D D ^DIR K DIR I 'Y S QFLG=1 "RTN","VAFCPDAT",147,0) .S SS=LNQ-$Y F JJ=1:1:SS W ! "RTN","VAFCPDAT",148,0) Q "RTN","VAFCPDT2") 0^3^B20966973 "RTN","VAFCPDT2",1,0) VAFCPDT2 ;BIR/CML/ALS-DISPLAY MPI/PD INFORMATION FOR SELECTED PATIENT ;08/31/01 "RTN","VAFCPDT2",2,0) ;;5.3;Registration;**414,505**;Aug 13, 1993 "RTN","VAFCPDT2",3,0) ;Reference to ^MPIF(984.9,"C" supported by IA #3298 "RTN","VAFCPDT2",4,0) ; "RTN","VAFCPDT2",5,0) CMORHIS ;Find CMOR History "RTN","VAFCPDT2",6,0) I '$O(^DPT(DFN,"MPICMOR",0)) G CMORCHG "RTN","VAFCPDT2",7,0) I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDT2",8,0) .S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",9,0) .W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 "RTN","VAFCPDT2",10,0) D CHISHDR "RTN","VAFCPDT2",11,0) S HIS=0 F S HIS=$O(^DPT(DFN,"MPICMOR",HIS)) Q:'HIS D Q:QFLG "RTN","VAFCPDT2",12,0) .S DIC=2,DR="993",DR(2.0993)=".01;3",DA=DFN,DA(2.0993)=HIS "RTN","VAFCPDT2",13,0) .S DIQ(0)="E",DIQ="CMORNODE" "RTN","VAFCPDT2",14,0) .D EN^DIQ1 K DIC,DR,DA,DIQ "RTN","VAFCPDT2",15,0) .S HISCMOR=$G(CMORNODE(2.0993,HIS,.01,"E")) "RTN","VAFCPDT2",16,0) .I +HISCMOR S HISCMOR=$$GET1^DIQ(4,HISCMOR,.01) "RTN","VAFCPDT2",17,0) .S CHGDT=$G(CMORNODE(2.0993,HIS,3,"E")) "RTN","VAFCPDT2",18,0) .I $Y+3>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDT2",19,0) ..S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",20,0) ..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D CHISHDR "RTN","VAFCPDT2",21,0) .W !,$P(CHGDT,"@"),?12," - CMOR changed from ",HISCMOR "RTN","VAFCPDT2",22,0) ; "RTN","VAFCPDT2",23,0) CMORCHG ;Find CMOR change request "RTN","VAFCPDT2",24,0) I '$O(^MPIF(984.9,"C",DFN,0)) G EXT "RTN","VAFCPDT2",25,0) I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDT2",26,0) .S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",27,0) .W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 "RTN","VAFCPDT2",28,0) D CCHGHDR "RTN","VAFCPDT2",29,0) S CHG=0 F S CHG=$O(^MPIF(984.9,"C",DFN,CHG)) Q:'CHG D Q:QFLG "RTN","VAFCPDT2",30,0) .S DIC=984.9,DA=CHG,DR=".01;.03;.06;.07;.08;1.03",DIQ="CHGNODE" "RTN","VAFCPDT2",31,0) .S DIQ(0)="EI" D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDT2",32,0) .S CHGNUM=$G(CHGNODE(984.9,CHG,.01,"E")) "RTN","VAFCPDT2",33,0) .S CHGDT=$G(CHGNODE(984.9,CHG,.03,"E")) "RTN","VAFCPDT2",34,0) .S TMSG=$G(CHGNODE(984.9,CHG,.08,"E")) "RTN","VAFCPDT2",35,0) .S TREQ=$G(CHGNODE(984.9,CHG,1.03,"E")) "RTN","VAFCPDT2",36,0) .S SITE=$G(CHGNODE(984.9,CHG,.07,"E")) "RTN","VAFCPDT2",37,0) .S STATUS=$G(CHGNODE(984.9,CHG,.06,"E")) "RTN","VAFCPDT2",38,0) .I $Y+4>IOSL&($E(IOST,1,2)="C-") D Q:QFLG "RTN","VAFCPDT2",39,0) ..S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",40,0) ..W @IOF,!,"MPI/PD data for: ",NAME," (DFN #",DFN,")",!,LN2 D CCHGHDR "RTN","VAFCPDT2",41,0) .W !,"REQUEST #",CHGNUM," - ",TMSG," ",CHGDT "RTN","VAFCPDT2",42,0) .W !?4,"Type of Request: ",TREQ," ",SITE "RTN","VAFCPDT2",43,0) .W !?4,"Status : ",STATUS,! "RTN","VAFCPDT2",44,0) ; "RTN","VAFCPDT2",45,0) EXT ;Extended patient demographic data "RTN","VAFCPDT2",46,0) I $E(IOST,1,2)="C-" D Q:QFLG "RTN","VAFCPDT2",47,0) .S LNQ=22 D SS^VAFCPDAT Q:QFLG "RTN","VAFCPDT2",48,0) .W @IOF "RTN","VAFCPDT2",49,0) I QFLG=1 G QUIT^VAFCPDAT "RTN","VAFCPDT2",50,0) W !!,"Additional DPT Data for: ",NAME," (DFN #",DFN,")",!,LN2 "RTN","VAFCPDT2",51,0) S DA=DFN,DIC=2,DIQ="XDATA",DIQ(0)="EI" "RTN","VAFCPDT2",52,0) S DR=".05;.08;.092;.093;.219;.2401;.2402;.2403;.211;.302;.323;.341;.331;.361;1901;.325;.328;326;.327;.097;.525" "RTN","VAFCPDT2",53,0) N COB,SOB,FNM,MNM,MMNM,NOK,NOKN,DESIG,EMER,ELIG,VET,SRVBR,SRVNUM,SRVEDT,SRVSDT,SRVCPCT,POSRVC,FILEDT,MARS,RELP,POW "RTN","VAFCPDT2",54,0) D EN^DIQ1 K DIC,DA,DR,DIQ "RTN","VAFCPDT2",55,0) S COB=$G(XDATA(2,DFN,.092,"E")),SOB=$G(XDATA(2,DFN,.093,"E")) "RTN","VAFCPDT2",56,0) S FILEDT=$G(XDATA(2,DFN,.097,"E")),FNM=$G(XDATA(2,DFN,.2401,"E")) "RTN","VAFCPDT2",57,0) S MNM=$G(XDATA(2,DFN,.2402,"E")),MMNM=$G(XDATA(2,DFN,.2403,"E")) "RTN","VAFCPDT2",58,0) S NOK=$G(XDATA(2,DFN,.211,"E")),DESIG=$G(XDATA(2,DFN,.341,"E")) "RTN","VAFCPDT2",59,0) S EMER=$G(XDATA(2,DFN,.331,"E")) "RTN","VAFCPDT2",60,0) S ELIG=$G(XDATA(2,DFN,.361,"E")),VET=$G(XDATA(2,DFN,1901,"E")) "RTN","VAFCPDT2",61,0) S SRVBR=$G(XDATA(2,DFN,.325,"E")),SRVNUM=$G(XDATA(2,DFN,.328,"E")) "RTN","VAFCPDT2",62,0) S SRVEDT=$G(XDATA(2,DFN,.326,"E")),SRVSDT=$G(XDATA(2,DFN,.327,"E")) "RTN","VAFCPDT2",63,0) S MARS=$G(XDATA(2,DFN,.05,"E")),RELP=$G(XDATA(2,DFN,.08,"E")) "RTN","VAFCPDT2",64,0) S POSRVC=$G(XDATA(2,DFN,.323,"E")),SRVCPCT=$G(XDATA(2,DFN,.302,"E")) "RTN","VAFCPDT2",65,0) S NOKN=$G(XDATA(2,DFN,.219,"E")),POW=$G(XDATA(2,DFN,.525,"E")) "RTN","VAFCPDT2",66,0) ; "RTN","VAFCPDT2",67,0) W !,"PLACE OF BIRTH [CITY]",?31,": ",COB "RTN","VAFCPDT2",68,0) W !,"PLACE OF BIRTH [STATE]",?31,": ",SOB "RTN","VAFCPDT2",69,0) W !,"FATHER'S NAME",?31,": ",FNM "RTN","VAFCPDT2",70,0) W !,"MOTHER'S NAME",?31,": ",MNM "RTN","VAFCPDT2",71,0) W !,"MOTHER'S MAIDEN NAME",?31,": ",MMNM "RTN","VAFCPDT2",72,0) W !,"NAME OF PRIMARY NEXT OF KIN",?31,": ",NOK "RTN","VAFCPDT2",73,0) W !,"NEXT OF KIN PHONE NUMBER",?31,": ",NOKN "RTN","VAFCPDT2",74,0) W !,"NAME OF DESIGNEE",?31,": ",DESIG "RTN","VAFCPDT2",75,0) W !,"EMERGENCY NAME",?31,": ",EMER "RTN","VAFCPDT2",76,0) W !,"MARITAL STATUS",?31,": ",MARS "RTN","VAFCPDT2",77,0) W !,"RELIGIOUS PREFERENCE",?31,": ",RELP "RTN","VAFCPDT2",78,0) W !,"PRIMARY ELIGIBILITY CODE",?31,": ",ELIG "RTN","VAFCPDT2",79,0) W !,"VETERAN (Y/N)?",?31,": ",VET "RTN","VAFCPDT2",80,0) W !,"SERVICE BRANCH [LAST]",?31,": ",SRVBR "RTN","VAFCPDT2",81,0) W !,"SERVICE NUMBER [LAST]",?31,": ",SRVNUM "RTN","VAFCPDT2",82,0) W !,"SERVICE CONNECTED PERCENT",?31,": ",SRVCPCT "RTN","VAFCPDT2",83,0) W !,"SERVICE ENTRY DATE [LAST]",?31,": ",SRVEDT "RTN","VAFCPDT2",84,0) W !,"SERVICE SEPARATION DATE [LAST]",?31,": ",SRVSDT "RTN","VAFCPDT2",85,0) W !,"PERIOD OF SERVICE",?31,": ",POSRVC "RTN","VAFCPDT2",86,0) W !,"POW STATUS INDICATED?",?31,": ",POW "RTN","VAFCPDT2",87,0) W !,"DATE ENTERED IN PATIENT FILE",?31,": ",FILEDT "RTN","VAFCPDT2",88,0) ; "RTN","VAFCPDT2",89,0) D DEM^VADPT "RTN","VAFCPDT2",90,0) ;ETHNICITY info "RTN","VAFCPDT2",91,0) I $G(VADM(11,1)) W !,"ETHNICITY INFORMATION",?31,": ",$P(VADM(11,1),"^",2) "RTN","VAFCPDT2",92,0) ; "RTN","VAFCPDT2",93,0) ;RACE multiple "RTN","VAFCPDT2",94,0) I $O(VADM(12,0)) D "RTN","VAFCPDT2",95,0) .W !,"RACE INFORMATION (multiple):" "RTN","VAFCPDT2",96,0) .S RACEMUL=0 F S RACEMUL=$O(VADM(12,RACEMUL)) Q:'RACEMUL W !?3,$P(VADM(12,RACEMUL),"^",2) "RTN","VAFCPDT2",97,0) ; "RTN","VAFCPDT2",98,0) ;ALIAS multiple "RTN","VAFCPDT2",99,0) I $O(^DPT(DFN,.01,0)) D "RTN","VAFCPDT2",100,0) .W !,"ALIAS (multiple):" "RTN","VAFCPDT2",101,0) .S ALIAS=0 F S ALIAS=$O(^DPT(DFN,.01,ALIAS)) Q:'ALIAS W !?3,$P(^DPT(DFN,.01,ALIAS,0),"^") "RTN","VAFCPDT2",102,0) ; "RTN","VAFCPDT2",103,0) K ALIAS,XDATA,CHG,CHGNUM,CHGDT,TMSG,TREQ,SITE,STATUS,HIS,HISCMOR,CMORNODE,CHGNODE,RACEMUL,VADM "RTN","VAFCPDT2",104,0) Q "RTN","VAFCPDT2",105,0) ; "RTN","VAFCPDT2",106,0) CHISHDR W !!,"CMOR History:",!,"--------------" "RTN","VAFCPDT2",107,0) Q "RTN","VAFCPDT2",108,0) CCHGHDR W !!,"CMOR Change Request History:",!,"----------------------------" "RTN","VAFCPDT2",109,0) Q "VER") 8.0^22.0 "^DD",2,2,994,0) MULTIPLE BIRTH INDICATOR^S^N:NO;Y:*MULTIPLE BIRTH*;^MPIMB;1^Q "^DD",2,2,994,3) Is the patient part of a multiple birth? "^DD",2,2,994,21,0) ^.001^3^3^3030519^^^^ "^DD",2,2,994,21,1,0) The MULTIPLE BIRTH INDICATOR will designate whether or not "^DD",2,2,994,21,2,0) the patient is part of a multiple birth (i.e. to identify "^DD",2,2,994,21,3,0) twins, etc.). "^DD",2,2,994,"DT") 3030514 **END** **END**