Released DG*5.3*489 SEQ #436 Extracted from mail message **KIDS**:DG*5.3*489^ **INSTALL NAME** DG*5.3*489 "BLD",3739,0) DG*5.3*489^REGISTRATION^0^3030326^y "BLD",3739,1,0) ^^5^5^3030204^ "BLD",3739,1,1,0) "BLD",3739,1,2,0) "BLD",3739,1,3,0) "BLD",3739,1,4,0) "BLD",3739,1,5,0) HIPAA CONFIDENTIAL ADDRESS. "BLD",3739,4,0) ^9.64PA^2^1 "BLD",3739,4,2,0) 2 "BLD",3739,4,2,2,0) ^9.641^2.141^2 "BLD",3739,4,2,2,2,0) PATIENT (File-top level) "BLD",3739,4,2,2,2,1,0) ^9.6411^.14105^10 "BLD",3739,4,2,2,2,1,.14105,0) CONFIDENTIAL ADDRESS ACTIVE? "BLD",3739,4,2,2,2,1,.1411,0) CONFIDENTIAL STREET [LINE 1] "BLD",3739,4,2,2,2,1,.14111,0) CONFIDENTIAL ADDRESS COUNTY "BLD",3739,4,2,2,2,1,.1412,0) CONFIDENTIAL STREET [LINE 2] "BLD",3739,4,2,2,2,1,.1413,0) CONFIDENTIAL STREET [LINE 3] "BLD",3739,4,2,2,2,1,.1414,0) CONFIDENTIAL ADDRESS CITY "BLD",3739,4,2,2,2,1,.1415,0) CONFIDENTIAL ADDRESS STATE "BLD",3739,4,2,2,2,1,.1416,0) CONFIDENTIAL ADDRESS ZIP CODE "BLD",3739,4,2,2,2,1,.1417,0) CONFIDENTIAL START DATE "BLD",3739,4,2,2,2,1,.1418,0) CONFIDENTIAL ADDRESS END DATE "BLD",3739,4,2,2,2.141,0) CONFIDENTIAL ADDRESS CATEGORY (sub-file) "BLD",3739,4,2,2,2.141,1,0) ^9.6411^^0 "BLD",3739,4,2,222) y^n^p^^^^n "BLD",3739,4,"APDD",2,2) "BLD",3739,4,"APDD",2,2,.14105) "BLD",3739,4,"APDD",2,2,.1411) "BLD",3739,4,"APDD",2,2,.14111) "BLD",3739,4,"APDD",2,2,.1412) "BLD",3739,4,"APDD",2,2,.1413) "BLD",3739,4,"APDD",2,2,.1414) "BLD",3739,4,"APDD",2,2,.1415) "BLD",3739,4,"APDD",2,2,.1416) "BLD",3739,4,"APDD",2,2,.1417) "BLD",3739,4,"APDD",2,2,.1418) "BLD",3739,4,"APDD",2,2.141) "BLD",3739,4,"B",2,2) "BLD",3739,"ABPKG") n "BLD",3739,"INIT") POST^DG53489P "BLD",3739,"KRN",0) ^9.67PA^8989.52^19 "BLD",3739,"KRN",.4,0) .4 "BLD",3739,"KRN",.4,"NM",0) ^9.68A^^ "BLD",3739,"KRN",.401,0) .401 "BLD",3739,"KRN",.402,0) .402 "BLD",3739,"KRN",.403,0) .403 "BLD",3739,"KRN",.5,0) .5 "BLD",3739,"KRN",.84,0) .84 "BLD",3739,"KRN",3.6,0) 3.6 "BLD",3739,"KRN",3.8,0) 3.8 "BLD",3739,"KRN",3.8,"NM",0) ^9.68A^^ "BLD",3739,"KRN",9.2,0) 9.2 "BLD",3739,"KRN",9.8,0) 9.8 "BLD",3739,"KRN",9.8,"NM",0) ^9.68A^18^18 "BLD",3739,"KRN",9.8,"NM",1,0) VADPT0^^0^B11949293 "BLD",3739,"KRN",9.8,"NM",2,0) VADPT1^^0^B36388475 "BLD",3739,"KRN",9.8,"NM",3,0) VADPT^^0^B16792484 "BLD",3739,"KRN",9.8,"NM",4,0) DGDDC^^0^B6371201 "BLD",3739,"KRN",9.8,"NM",5,0) DGLOCK3^^0^B6152066 "BLD",3739,"KRN",9.8,"NM",6,0) DGRPD^^0^B42572261 "BLD",3739,"KRN",9.8,"NM",7,0) DGRPU^^0^B10561244 "BLD",3739,"KRN",9.8,"NM",8,0) DGRPE^^0^B38867179 "BLD",3739,"KRN",9.8,"NM",9,0) DGRPH^^0^B26718912 "BLD",3739,"KRN",9.8,"NM",10,0) DGRPV^^0^B16336104 "BLD",3739,"KRN",9.8,"NM",11,0) DGRPP^^0^B23085136 "BLD",3739,"KRN",9.8,"NM",12,0) DGRPP1^^0^B5931859 "BLD",3739,"KRN",9.8,"NM",13,0) DGRPCADD^^0^B7617335 "BLD",3739,"KRN",9.8,"NM",14,0) DGRPC^^0^B20161102 "BLD",3739,"KRN",9.8,"NM",15,0) DGRPC2^^0^B17367418 "BLD",3739,"KRN",9.8,"NM",16,0) DGRPCE1^^0^B5514812 "BLD",3739,"KRN",9.8,"NM",17,0) DG1010P1^^0^B26913291 "BLD",3739,"KRN",9.8,"NM",18,0) DGOVBC1^^0^B27025022 "BLD",3739,"KRN",9.8,"NM","B","DG1010P1",17) "BLD",3739,"KRN",9.8,"NM","B","DGDDC",4) "BLD",3739,"KRN",9.8,"NM","B","DGLOCK3",5) "BLD",3739,"KRN",9.8,"NM","B","DGOVBC1",18) "BLD",3739,"KRN",9.8,"NM","B","DGRPC",14) "BLD",3739,"KRN",9.8,"NM","B","DGRPC2",15) "BLD",3739,"KRN",9.8,"NM","B","DGRPCADD",13) "BLD",3739,"KRN",9.8,"NM","B","DGRPCE1",16) "BLD",3739,"KRN",9.8,"NM","B","DGRPD",6) "BLD",3739,"KRN",9.8,"NM","B","DGRPE",8) "BLD",3739,"KRN",9.8,"NM","B","DGRPH",9) "BLD",3739,"KRN",9.8,"NM","B","DGRPP",11) "BLD",3739,"KRN",9.8,"NM","B","DGRPP1",12) "BLD",3739,"KRN",9.8,"NM","B","DGRPU",7) "BLD",3739,"KRN",9.8,"NM","B","DGRPV",10) "BLD",3739,"KRN",9.8,"NM","B","VADPT",3) "BLD",3739,"KRN",9.8,"NM","B","VADPT0",1) "BLD",3739,"KRN",9.8,"NM","B","VADPT1",2) "BLD",3739,"KRN",19,0) 19 "BLD",3739,"KRN",19,"NM",0) ^9.68A^^ "BLD",3739,"KRN",19.1,0) 19.1 "BLD",3739,"KRN",101,0) 101 "BLD",3739,"KRN",409.61,0) 409.61 "BLD",3739,"KRN",771,0) 771 "BLD",3739,"KRN",870,0) 870 "BLD",3739,"KRN",8989.51,0) 8989.51 "BLD",3739,"KRN",8989.52,0) 8989.52 "BLD",3739,"KRN",8994,0) 8994 "BLD",3739,"KRN","B",.4,.4) "BLD",3739,"KRN","B",.401,.401) "BLD",3739,"KRN","B",.402,.402) "BLD",3739,"KRN","B",.403,.403) "BLD",3739,"KRN","B",.5,.5) "BLD",3739,"KRN","B",.84,.84) "BLD",3739,"KRN","B",3.6,3.6) "BLD",3739,"KRN","B",3.8,3.8) "BLD",3739,"KRN","B",9.2,9.2) "BLD",3739,"KRN","B",9.8,9.8) "BLD",3739,"KRN","B",19,19) "BLD",3739,"KRN","B",19.1,19.1) "BLD",3739,"KRN","B",101,101) "BLD",3739,"KRN","B",409.61,409.61) "BLD",3739,"KRN","B",771,771) "BLD",3739,"KRN","B",870,870) "BLD",3739,"KRN","B",8989.51,8989.51) "BLD",3739,"KRN","B",8989.52,8989.52) "BLD",3739,"KRN","B",8994,8994) "BLD",3739,"QUES",0) ^9.62^^ "BLD",3739,"REQB",0) ^9.611^^ "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,.141) "FIA",2,2,.14105) "FIA",2,2,.1411) "FIA",2,2,.14111) "FIA",2,2,.1412) "FIA",2,2,.1413) "FIA",2,2,.1414) "FIA",2,2,.1415) "FIA",2,2,.1416) "FIA",2,2,.1417) "FIA",2,2,.1418) "FIA",2,2.141) 0 "INIT") POST^DG53489P "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 "PKG",5,22,1,"PAH",1,0) 489^3030326 "PKG",5,22,1,"PAH",1,1,0) ^^5^5^3030326 "PKG",5,22,1,"PAH",1,1,1,0) "PKG",5,22,1,"PAH",1,1,2,0) "PKG",5,22,1,"PAH",1,1,3,0) "PKG",5,22,1,"PAH",1,1,4,0) "PKG",5,22,1,"PAH",1,1,5,0) HIPAA CONFIDENTIAL ADDRESS. "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") 19 "RTN","DG1010P1") 0^17^B26913291 "RTN","DG1010P1",1,0) DG1010P1 ;ALB/REW - VA FORM 10-10 (CONT) ; 26 MAY 92 "RTN","DG1010P1",2,0) ;;5.3;Registration;**489**;Aug 13, 1993 "RTN","DG1010P1",3,0) ; DGP(N) = NTH NODE OF PATIENT FILE - ALREADY DEFINED "RTN","DG1010P1",4,0) ST W !?25,"SEE ATTACHMENT FOR PAPERWORK REDUCTION INFORMATION AND PRIVACY ACT INFORMATION",!,DGLDASH "RTN","DG1010P1",5,0) I $G(IOST)["C-" S DGLUND="" "RTN","DG1010P1",6,0) PARTI W !?54,"PART I - PATIENT DATA",!,DGLUND "RTN","DG1010P1",7,0) S DGD=+$P(DGP("DIS",0),U,3) W !,"1. Type of benefit applied for: ",$P("HOSPITAL/OUTPATIENT TREATMENT^DOMICILIARY CARE^HOSPITAL/OUTPATIENT TREATMENT^OUTPATIENT DENTAL^NURSING HOME CARE",U,+DGD) "RTN","DG1010P1",8,0) W !,DGLUND "RTN","DG1010P1",9,0) W !,"2. Applicant's Name ",?48,"|"," 3. Other names used (Alias)",?86,"|"," 4. Social Security Number" "RTN","DG1010P1",10,0) S DGX=$O(^DPT(DFN,.01,0)) S DGA=$P($G(^DPT(DFN,.01,+DGX,0)),U,1) "RTN","DG1010P1",11,0) W !?5,DGNAM,?48,"|",?54,DGA,?86,"|",?92,DGSS "RTN","DG1010P1",12,0) F S DGX=$O(^DPT(DFN,.01,DGX)) Q:DGX'>0 W !?48,"|",?54,$P($G(^DPT(DFN,.01,DGX,0)),U,1),?86,"|" "RTN","DG1010P1",13,0) W ?131,"",$C(13),DGLUND "RTN","DG1010P1",14,0) CLAIM ; "RTN","DG1010P1",15,0) W !,"5. Claim Number",?23,"| 6. LOCATION OF CLAIMS FOLDER",?60,"| 7. DATE OF BIRTH",?86,"| 8. PLACE OF BIRTH" "RTN","DG1010P1",16,0) S DGX=$$DISP^DG1010P0(DGP(.31),3) "RTN","DG1010P1",17,0) W !?5,$S('DGUNK:"C- ",1:""),DGX,?23,"| ",$E($$DISP^DG1010P0(DGP(.31),2),1,30),?60,"| ",$$DATENP^DG1010P0(DGP(0),3) "RTN","DG1010P1",18,0) S DGD=$$DISP^DG1010P0(DGP(0),11,0,1),DGNOCITY=DGUNK,DGD1=$$POINT^DG1010P0(DGP(0),12,5,1,0,1) "RTN","DG1010P1",19,0) W ?86,"| ",$E($S((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$S(($L(DGD)):", ",1:"")_DGD1),1,39),?131,$C(13),DGLUND "RTN","DG1010P1",20,0) HEADADD ; "RTN","DG1010P1",21,0) S DGD1=$$DATENP^DG1010P0(DGP(.121),7,0,1) ;FROM "RTN","DG1010P1",22,0) S DGD2=$$DATENP^DG1010P0(DGP(.121),8,0,1) ;TO "RTN","DG1010P1",23,0) W !,"9. PERMANENT ADDRESS",?66,"|"," 10. TEMPORARY ADDRESS " "RTN","DG1010P1",24,0) S DGDMAX=1 "RTN","DG1010P1",25,0) PRTTMP ; DGTMP=0 IF TEMP ADDRES ENTER NOT=Y OR END DATE IN PAST "RTN","DG1010P1",26,0) K DGD "RTN","DG1010P1",27,0) S DGTMP=1 "RTN","DG1010P1",28,0) I ($P(DGP(.121),U,9)'="Y")!(($P(DGP(.121),U,8)>0)&($P(DGP(.121),U,8)<(9999999-DFN1))) S DGTMP=0 S DGD(.121,1)="NOT APPLICABLE" F DGDPC=2:1:5,12 S DGD(.121,DGDPC)="" "RTN","DG1010P1",29,0) W:(DGTMP=1)&($L(DGD1)!($L(DGD2))) "(FROM ",DGD1," TO ",DGD2,?126,")" "RTN","DG1010P1",30,0) W !,DGL2 "RTN","DG1010P1",31,0) GETADD ; "RTN","DG1010P1",32,0) STR2ZIP F DGI=.11,.121 Q:((DGI=.121)&(DGTMP=0)) D "RTN","DG1010P1",33,0) .;ADDR=1-3,4-5=CITY,STATE,12=ZIP+4 "RTN","DG1010P1",34,0) .F DGDPC=1:1:5,12 D "RTN","DG1010P1",35,0) ..I ("^1^4^12^"[DGDPC) S DGD(DGI,DGDPC)=$$DISP^DG1010P0(DGP(DGI),DGDPC) I DGDPC=12,(DGD(DGI,12)?9N) S DGD(DGI,12)=$E(DGD(DGI,12),1,5)_"-"_$E(DGD(DGI,12),6,9) "RTN","DG1010P1",36,0) ..I ("23"[DGDPC) S DGD(DGI,DGDPC)=$$DISP^DG1010P0(DGP(DGI),DGDPC,0,1) S:(DGDMAX1) !?21,DGD(.11,2),?66,"|",?89,DGD(.121,2) "RTN","DG1010P1",41,0) W:(DGDMAX>2) !?21,DGD(.11,3),?66,"|",?89,DGD(.121,3) "RTN","DG1010P1",42,0) W !,DGL2 "RTN","DG1010P1",43,0) W !,"9B. CITY: ",DGD(.11,4),?33,"| ","9C. STATE: ",DGD(.11,5),?66,"|"," 10B. CITY: ",$E(DGD(.121,4),1,20),?99,"| ","10C. STATE: ",DGD(.121,5),!,DGL2 "RTN","DG1010P1",44,0) W !,"9D. ZIP CODE: ",DGD(.11,12),?33,"| ","9E. COUNTY: ",$$POINT^DG1010P0(DGP(.11),7,("^DIC(5,"_+$P(DGP(.11),U,5)_",1,"),0),?66,"| " "RTN","DG1010P1",45,0) W "10D. ZIP CODE: ",DGD(.121,12),?99,"| ","10E. COUNTY: " "RTN","DG1010P1",46,0) W:(DGTMP=1) $$POINT^DG1010P0(DGP(.121),11,("^DIC(5,"_+$P(DGP(.121),U,5)_",1,"),0) "RTN","DG1010P1",47,0) W !,DGL2 "RTN","DG1010P1",48,0) W !,"9F. HOME TELEPHONE NUMBER: ",$$DISP^DG1010P0(DGP(.13),1),?66,"| ","10F. HOME TELEPHONE NUMBER:",?96 "RTN","DG1010P1",49,0) W:DGTMP $$DISP^DG1010P0(DGP(.121),10) "RTN","DG1010P1",50,0) W !,DGLUND "RTN","DG1010P1",51,0) CA ;Display confidential address information "RTN","DG1010P1",52,0) N DGACT,DGCAT,DGCATN,DGCATS,VAPA "RTN","DG1010P1",53,0) D ADD^VADPT "RTN","DG1010P1",54,0) W !,"11. CONFIDENTIAL ADDRESS",?66,"|" "RTN","DG1010P1",55,0) I VAPA(12)=""!(VAPA(12)=0) D G SEX "RTN","DG1010P1",56,0) .W !?11,"Not Applicable",?66,"|" "RTN","DG1010P1",57,0) .W !,DGLUND "RTN","DG1010P1",58,0) W !,DGL2 "RTN","DG1010P1",59,0) W !,"11A. STREET ADDRESS:",?21,VAPA(13) "RTN","DG1010P1",60,0) W ?66,"| ","11B. CITY: ",$E(VAPA(16),0,19),?99,"| 11C. STATE: ",$P(VAPA(17),"^",2) "RTN","DG1010P1",61,0) W !,?21,VAPA(14) "RTN","DG1010P1",62,0) W ?66,"| ","11D. ZIP CODE: ",$P(VAPA(18),"^",2),?99,"| 11E. COUNTY: ",$P(VAPA(19),"^",2) "RTN","DG1010P1",63,0) W !,?21,VAPA(15),?66,"| 11F. START DATE: ",$P(VAPA(20),"^",2),?99,"| STOP DATE: ",$P(VAPA(21),"^",2) "RTN","DG1010P1",64,0) W !,$E(DGL2,1,99),"|",$E(DGL2,1,32) "RTN","DG1010P1",65,0) W !,"11G. Active Confidential Address Categories",?66,"|" "RTN","DG1010P1",66,0) S DGCATS="" F S DGCATS=$O(VAPA(22,DGCATS)) Q:DGCATS="" D "RTN","DG1010P1",67,0) .S DGCAT=VAPA(22,DGCATS),DGACT=$P(DGCAT,"^",3),DGCATN=$P(DGCAT,"^",2) "RTN","DG1010P1",68,0) .I DGACT="Y" W !?11,DGCATN,?66,"|" "RTN","DG1010P1",69,0) W !,DGLUND "RTN","DG1010P1",70,0) SEX K DGD,DGX "RTN","DG1010P1",71,0) W !,"12. PATIENT'S SEX",?33,"| ","13. MOTHER'S MAIDEN NAME",?66,"| ","14. MOTHER'S NAME",?99,"| ","15. FATHER'S NAME" "RTN","DG1010P1",72,0) S X=$P(DGP(0),U,2) W !?5,$S((X="M"):"MALE",(X="F"):"FEMALE",1:"UNANSWERED") "RTN","DG1010P1",73,0) W ?33,"| ",?40,$E(($$DISP^DG1010P0(DGP(.24),3)),1,25),?66,"| ",?73,$E(($$DISP^DG1010P0(DGP(.24),2)),1,23),?99,"| ",?106,$E(($$DISP^DG1010P0(DGP(.24),1)),1,30),?131,$C(13),DGLUND "RTN","DG1010P1",74,0) RELIG ; "RTN","DG1010P1",75,0) W !,"16. RELIGIOUS PREFERENCE",?33,"| ","17. DATE OF PREVIOUS CARE",?66,"| ","18. LOCATION OF PREVIOUS CARE",?99,"| ","19. SPINAL CORD INJURY" "RTN","DG1010P1",76,0) W !?5,$$POINT^DG1010P0(DGP(0),8,13),?33,"| ",?40,$$DATENP^DG1010P0(DGP(1010.15),1),?66,"| ",?73,$$POINT^DG1010P0(DGP(1010.15),2,4) "RTN","DG1010P1",77,0) S X=$$UNK^DG1010P0($P(DGP(57),U,4)) "RTN","DG1010P1",78,0) W ?99,"| ",?106,$S((DGUNK):X,(X=1):"PARAPLEGIA-TRAUMATIC",(X=2):"QUADRIPLEGIA-TRAUMATIC",(X=3):"PARAPLEGIA-NONTRAUMATIC",(X=4):"QUADRIPLEGIA-NONTRAUMATIC",(X="X"):"NOT APPLICABLE",1:"INVALID"),?131,$C(13),DGLUND,! "RTN","DG1010P1",79,0) CONTD ; "RTN","DG1010P1",80,0) G CONT^DG1010P2 "RTN","DG1010P1",81,0) ; "RTN","DG53489P") 0^^B4047725 "RTN","DG53489P",1,0) DG53489P ;ALB/EW;BPFO/MM -PRE/POST INIT FOR DG*5.3*489 ;3/10/2003 "RTN","DG53489P",2,0) ;;5.3;Registration;**489**;Aug 13, 1993 "RTN","DG53489P",3,0) ; "RTN","DG53489P",4,0) ;The post initialization routine for DG*5.3*489 adds a new "RTN","DG53489P",5,0) ;inconsistent data element to the Inconsistent Data Element "RTN","DG53489P",6,0) ;(#38.6) file with internal entry number 63. "RTN","DG53489P",7,0) ; "RTN","DG53489P",8,0) POST ;Post-Install "RTN","DG53489P",9,0) N MSGROOT,FDAWP,FDAROOT,IENROOT,IEN,X "RTN","DG53489P",10,0) D BMES^XPDUTL("Creating definition for Conf. Address Data Incomplete - entry #63") "RTN","DG53489P",11,0) D MES^XPDUTL("in INCONSISTENT DATA ELEMENT (#38.6) file.") "RTN","DG53489P",12,0) I $D(^DGIN(38.6,63,0)) D Q "RTN","DG53489P",13,0) . D BMES^XPDUTL("Internal entry number 63 already exist in file 38.6.") "RTN","DG53489P",14,0) . D MES^XPDUTL("Cannot add Conf. Address Data Incomplete element.") "RTN","DG53489P",15,0) S IEN="+1," "RTN","DG53489P",16,0) S FDAROOT(38.6,IEN,.01)="CONF. ADDRESS DATA INCOMPLETE" "RTN","DG53489P",17,0) S FDAROOT(38.6,IEN,2)="'CONFIDENTIAL ADDRESS' INFORMATION INCOMPLETE" "RTN","DG53489P",18,0) S FDAROOT(38.6,IEN,50)="FDAWP" "RTN","DG53489P",19,0) S FDAWP(1,0)="Inconsistency results if a record with an active confidential" "RTN","DG53489P",20,0) S FDAWP(2,0)="address does not contain the first line of the street address," "RTN","DG53489P",21,0) S FDAWP(3,0)="city, state, and zip code for the confidential address." "RTN","DG53489P",22,0) S FDAROOT(38.6,IEN,3)="NO KEY REQUIRED" "RTN","DG53489P",23,0) S FDAROOT(38.6,IEN,4)="NO" "RTN","DG53489P",24,0) S FDAROOT(38.6,IEN,5)="CHECK" "RTN","DG53489P",25,0) S IENROOT(1)=63 "RTN","DG53489P",26,0) D UPDATE^DIE("E","FDAROOT","IENROOT","MSGROOT") "RTN","DG53489P",27,0) I $D(MSGROOT("DIERR")) D "RTN","DG53489P",28,0) .N ERR,LN,LN2 "RTN","DG53489P",29,0) .S (ERR,LN2)=0 "RTN","DG53489P",30,0) .F S ERR=+$O(MSGROOT("DIERR",ERR)) Q:'ERR D "RTN","DG53489P",31,0) ..S LN=0 "RTN","DG53489P",32,0) ..F S LN=+$O(MSGROOT("DIERR",ERR,"TEXT",LN)) Q:'LN D "RTN","DG53489P",33,0) ...S LN2=LN2+1 "RTN","DG53489P",34,0) ...S X(LN2)=MSGROOT("DIERR",ERR,"TEXT",LN) "RTN","DG53489P",35,0) ..D BMES^XPDUTL(.X) "RTN","DG53489P",36,0) Q "RTN","DGDDC") 0^4^B6371201 "RTN","DGDDC",1,0) DGDDC ;ALB/MRL - X-ECUTE KILL X-REFERENCES [PATIENT] ;25 JUL 88@1337 "RTN","DGDDC",2,0) ;;5.3;Registration;**489**;Aug 13, 1993 "RTN","DGDDC",3,0) ; "RTN","DGDDC",4,0) Q:'$D(DGXRF) S DGXRFX=X,DGXRF1=+$P(DGXRF,".",2),DGXRF2=$P($T(@DGXRF1),";;",2) G Q:DGXRF2="" "RTN","DGDDC",5,0) I $D(^DD(2,DGXRF,0)) S DGXRFP=$P(^(0),"^",4),DGXRF6=$P(DGXRFP,";",2),DGXRF5=$P(DGXRFP,";",1) I $D(^DPT(DA,DGXRF5)),($P(^(DGXRF5),"^",DGXRF6)=DGXRFX) G Q "RTN","DGDDC",6,0) F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4="" I $D(^DD(2,DGXRF4,0)) S DGXRF5=$P(^(0),"^",4),DGXRF6=$P(DGXRF5,";",2),DGXRF5=$P(DGXRF5,";",1) I $D(^DPT(DA,DGXRF5)),$P(^(DGXRF5),"^",DGXRF6)'="" D KILL "RTN","DGDDC",7,0) Q S X=DGXRFX K DGXRF,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX Q "RTN","DGDDC",8,0) KILL S DGXRF7=$P(^DPT(DA,DGXRF5),"^",DGXRF6),$P(^DPT(DA,DGXRF5),"^",DGXRF6)="" "RTN","DGDDC",9,0) F DGXRF8=0:0 S DGXRF8=$O(^DD(2,DGXRF4,1,DGXRF8)) Q:'DGXRF8 I $D(^DD(2,DGXRF4,1,DGXRF8,2)) S X=DGXRF7 X:^(2)'["DGXRF" ^(2) D SET I $D(^DD(2,DGXRF4,1,DGXRF8,1)) D SET "RTN","DGDDC",10,0) Q "RTN","DGDDC",11,0) SET Q:^DD(2,DGXRF4,1,DGXRF8,1)'["DGXRF" S X="" X ^(1) Q "RTN","DGDDC",12,0) ; "RTN","DGDDC",13,0) 152 ;;.1651^.1653^.1654^.1656^.307^ "RTN","DGDDC",14,0) 153 ;;.1657^.1658^.1659^ "RTN","DGDDC",15,0) 211 ;;.212^.2125^.213^.214^.215^.216^.217^.218^.219^.21011^.2207^ "RTN","DGDDC",16,0) 2191 ;;.2192^.21925^.2193^.2194^.2195^.2196^.2197^.2198^.2199^.211011^.2203^ "RTN","DGDDC",17,0) 251 ;;.252^.253^.254^.255^.256^.257^.258^.2206^ "RTN","DGDDC",18,0) 3111 ;;.3113^.3114^.3115^.3116^.3117^.3118^.3119^.2205^ "RTN","DGDDC",19,0) 331 ;;.332^.3305^.333^.334^.335^.336^.337^.338^.339^.33011^.2201^ "RTN","DGDDC",20,0) 3311 ;;.3312^.3313^.3314^.3315^.3316^.3317^.3318^.3319^.331011^.2204^ "RTN","DGDDC",21,0) 341 ;;.342^.3405^.343^.344^.345^.346^.347^.348^.349^.34011^.2202^ "RTN","DGDDC",22,0) 3285 ;;.329^.3291^.3292^.3293^.3294^ "RTN","DGDDC",23,0) 32945 ;;.3295^.3296^.3297^.3298^.3299^ "RTN","DGDDC",24,0) 111 ;;.112^.113 "RTN","DGDDC",25,0) 112 ;;.113 "RTN","DGDDC",26,0) 12105 ;;.1217^.1218 "RTN","DGDDC",27,0) 1211 ;;.1212^.1213 "RTN","DGDDC",28,0) 1212 ;;.1213 "RTN","DGDDC",29,0) 14105 ;;.1417^.1418 "RTN","DGDDC",30,0) 1411 ;;.1412^.1413 "RTN","DGDDC",31,0) 1412 ;;.1413 "RTN","DGDDC",32,0) 213 ;;.214^.215 "RTN","DGDDC",33,0) 214 ;;.215 "RTN","DGDDC",34,0) 2193 ;;.2194^.2195 "RTN","DGDDC",35,0) 2194 ;;.2195 "RTN","DGDDC",36,0) 252 ;;.253^.254 "RTN","DGDDC",37,0) 253 ;;.254 "RTN","DGDDC",38,0) 3113 ;;.3114^.3115 "RTN","DGDDC",39,0) 3114 ;;.3115 "RTN","DGDDC",40,0) 3313 ;;.3314^.3315 "RTN","DGDDC",41,0) 3314 ;;.3315 "RTN","DGDDC",42,0) 333 ;;.334^.335 "RTN","DGDDC",43,0) 334 ;;.335 "RTN","DGDDC",44,0) 343 ;;.344^.345 "RTN","DGDDC",45,0) 344 ;;.345 "RTN","DGDDC",46,0) 361 ;;.3611 "RTN","DGLOCK3") 0^5^B6152066 "RTN","DGLOCK3",1,0) DGLOCK3 ;ALB/BOK - PATIENT FILE MUMPS TRIGGER/DATA EDIT CHECKS ; 28 NOV 86 "RTN","DGLOCK3",2,0) ;;5.3;Registration;**489**;Aug 13, 1993 "RTN","DGLOCK3",3,0) KILL S DGX=X I $D(^DPT(DFN,.32)) F DGKZ=0:0 S DGKZ=$O(DGBZ(DGKZ)) Q:'DGKZ S X=$P(^DPT(DFN,.32),"^",DGKZ),$P(^(.32),"^",DGKZ)="" I X]"" S DGIZ=$S(DGKZ=20:.32945,1:(DGKZ/10000+.3281)) I $D(^DD(2,DGIZ,1)) D KILL1 "RTN","DGLOCK3",4,0) S X=DGX "RTN","DGLOCK3",5,0) Q "RTN","DGLOCK3",6,0) KILL1 F DGJZ=0:0 S DGJZ=$O(^DD(2,DGIZ,1,DGJZ)) Q:'DGJZ X ^(DGJZ,2) "RTN","DGLOCK3",7,0) Q "RTN","DGLOCK3",8,0) S1 K DGBZ F DGKZ=9:1:13,20 S DGBZ(DGKZ)="" "RTN","DGLOCK3",9,0) D KILL K DGBZ,DGIZ,DGJZ,DGKZ "RTN","DGLOCK3",10,0) Q "RTN","DGLOCK3",11,0) S2 K DGBZ F DGKZ=14:1:18 S DGBZ(DGKZ)="" "RTN","DGLOCK3",12,0) D KILL K DGBZ,DGIZ,DGJZ,DGKZ "RTN","DGLOCK3",13,0) Q "RTN","DGLOCK3",14,0) CAD ;Confidential Address Edit "RTN","DGLOCK3",15,0) I $S('$D(^DPT(DFN,.141)):1,$P(^(.141),U,9)'="Y":1,1:0) D "RTN","DGLOCK3",16,0) .D EN^DDIOL("Requirement for Confidential Address data not indicated...NO EDITING!","","$C(7),!?4") K X "RTN","DGLOCK3",17,0) Q "RTN","DGLOCK3",18,0) CADD ;Confidential Address Delete "RTN","DGLOCK3",19,0) ;Called from input transform on Confidential Address fields "RTN","DGLOCK3",20,0) Q:'$D(^DPT(DFN,.141)) I $P(^(.141),"^",9)="N"!($P(^(.141),"^",1,6)="^^^^^") D CADM Q "RTN","DGLOCK3",21,0) ASK W !,"Do you want to delete all confidential address data" S %=2 D YN^DICN I %Y["?" W !,"Answer 'Y'es to remove confidential address information, 'N'o to leave data in file" G ASK "RTN","DGLOCK3",22,0) ASK1 ; "RTN","DGLOCK3",23,0) Q:%'=1 "RTN","DGLOCK3",24,0) S DGTEMPH=$P(^DPT(DFN,.141),"^",7,8),^(.141)="^^^^^^"_DGTEMPH_"^N^^" K DGTEMPH "RTN","DGLOCK3",25,0) D CADM "RTN","DGLOCK3",26,0) Q "RTN","DGLOCK3",27,0) CADM ;Delete data from Confidential Address Categories "RTN","DGLOCK3",28,0) I $D(^DPT(DFN,.14)) D "RTN","DGLOCK3",29,0) .N DGX "RTN","DGLOCK3",30,0) .S DGX=X "RTN","DGLOCK3",31,0) .N DGIEN "RTN","DGLOCK3",32,0) .S DGIEN=0 "RTN","DGLOCK3",33,0) .F S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN D "RTN","DGLOCK3",34,0) ..N DGFDA,DGERR "RTN","DGLOCK3",35,0) ..S DGFDA(2.141,DGIEN_","_DFN_",",.01)="" "RTN","DGLOCK3",36,0) ..D FILE^DIE("","DGFDA","DGERR") "RTN","DGLOCK3",37,0) .S X=DGX "RTN","DGLOCK3",38,0) Q "RTN","DGLOCK3",39,0) CADD1 ;Confidential Address Delete "RTN","DGLOCK3",40,0) ;Called from Confidential Address "DEL" nodes "RTN","DGLOCK3",41,0) I $D(^DPT(DFN,.141)),$P(^(.141),U,9)="Y" D "RTN","DGLOCK3",42,0) .D EN^DDIOL("Answer NO to the 'CONFIDENTIAL ADDRESS ACTIVE' prompt to delete.","","$C(7),!?4") K X "RTN","DGLOCK3",43,0) Q "RTN","DGOVBC1") 0^18^B27025022 "RTN","DGOVBC1",1,0) DGOVBC1 ;ALB/MRL - VBC OUTPUT ; 12 FEB 87 "RTN","DGOVBC1",2,0) ;;5.3;Registration;**162,489**;Aug 13, 1993 "RTN","DGOVBC1",3,0) N VAPA "RTN","DGOVBC1",4,0) K DGLN S $P(DGLN," ",80)="",DGU="UNKNOWN",DGPP="" "RTN","DGOVBC1",5,0) F DGPP1=0:0 S DGPP=$O(^UTILITY($J,"DGOVBC",DGPP)) Q:(DGPP="")!($G(ZTSTOP)=1) S DFN=^UTILITY($J,"DGOVBC",DGPP) D DIS,ENDREP^DGUTL "RTN","DGOVBC1",6,0) Q K DGCA,I,DGX,X,Y,%DT,DGFR,DGHD,DGHD1,DGHOW,DGIOM,DGLIN,DGLN,DGPP,DGPP1,DGTO,DGU,DGVAR,DIC,DFN,DGCT,DGDFN,DGP,DGPGM,ZTSTOP,^UTILITY($J,"DGOVBC") D CLOSE^DGUTQ Q "RTN","DGOVBC1",7,0) G Q^DGOVBC2 "RTN","DGOVBC1",8,0) DIS I $$FIRST^DGUTL Q "RTN","DGOVBC1",9,0) D NOW^%DTC S Y=$E(%,1,12) W !,"VETERANS ASSISTANCE UNIT RECORD",?53,"PRINTED: ",$$FMTE^XLFDT(Y,1),?DGHD1,DGHD,!,DGLIN,! K Y "RTN","DGOVBC1",10,0) D DEM^VADPT D L W !,"1. Patient Name: ",$S(VADM(1)]"":VADM(1),1:"UNSPECIFIED PATIENT #"_DFN),?55,"| 2. DOB: ",$P(VADM(3),"^",2) "RTN","DGOVBC1",11,0) D PID^VADPT6 W ?80,"| 3. PT ID: ",$S(VA("PID"):VA("PID"),1:DGU),?106,"| 4. Claim #: " S DGMS=$S(VADM(10):$P(VADM(10),"^",2),1:DGU) K VA,VADM D ELIG^VADPT W $S(VAEL(7):VAEL(7),1:DGU),! S DGSC=+VAEL(3),DGMT=$P(VAEL(9),"^",2) K VAEL "RTN","DGOVBC1",12,0) W "_______________________________________________________|________________________|_________________________|_______________________" "RTN","DGOVBC1",13,0) D ADD^VADPT,A W !,"5. Address Information [Street, City, State, Zip Code]:" F I=0:0 S I=$O(DGA(I)) Q:'I W:I>1 ! W ?57,DGA(I),! "RTN","DGOVBC1",14,0) I VAPA(12)=1 D "RTN","DGOVBC1",15,0) .D L "RTN","DGOVBC1",16,0) .D AC W !,"5A. Confidential Address Information [Street, City, State, Zip Code]:" F I=0:0 S I=$O(DGA(I)) Q:'I W:I>1 ! W ?57,DGA(I) "RTN","DGOVBC1",17,0) K DGA W ! D SVC^VADPT,L W !,"6. Service Record",?35,"Service #",?55,"Entry Date",?75,"Separation Date",?108,"Discharge Type" "RTN","DGOVBC1",18,0) W $C(13)," ","______________",$E(DGLN,1,18),"_________",$E(DGLN,1,11),"__________",$E(DGLN,1,10),"_______________",$E(DGLN,1,18),"______________" S DGPOW=VASV(4) "RTN","DGOVBC1",19,0) F I=6:1:8 I VASV(I) W !?3,$S(VASV(I,1):$P(VASV(I,1),"^",2),1:DGU),?35,$S($L(VASV(I,2)):VASV(I,2),1:DGU),?55,$S('VASV(I,4):DGU,1:$P(VASV(I,4),"^",2)),?75,$S('VASV(I,5):DGU,1:$P(VASV(I,5),"^",2)),?108,$S(VASV(I,3):$P(VASV(I,3),"^",2),1:DGU) "RTN","DGOVBC1",20,0) K VASV W ! D L S DGCT=0 F I=0:0 S I=$O(^DGPM("ATID1",DFN,I)) Q:'I!(DGCT=2) F DGCA=0:0 S DGCA=$O(^DGPM("ATID1",DFN,I,DGCA)) Q:'DGCA!(DGCT=2) I $D(^DGPM(DGCA,0)) S DGCT=DGCT+1,DGADM(DGCT)=^(0),DGADM(DGCT,4)=$P(^(0),"^",12) "RTN","DGOVBC1",21,0) S DGSCOND=0 W !,"7. Admission Date" I 'DGCT W ": NO ADMISSIONS ON FILE FOR THIS APPLICANT." G ^DGOVBC2 "RTN","DGOVBC1",22,0) W ?20,"Admission Type",?55,"Ward",?70,"Admitting Diagnosis",?105,"Admission Authority" "RTN","DGOVBC1",23,0) W $C(13)," ","______________"," ","______________",$E(DGLN,1,21),"____",$E(DGLN,1,11),"___________________",$E(DGLN,1,16),"___________________" "RTN","DGOVBC1",24,0) F I=1:1:DGCT S DGD=DGADM(I),DGD1=DGADM(I,4) D AS W !?3,DGD(1),?20,DGD(2),?55,$E(DGD(3),1,10),?70,DGD(4),?105,$E(DGD(5),1,25) "RTN","DGOVBC1",25,0) D H^DGUTL S DGT=DGTIME K DGTIME D ^DGINPW W !?4,"NOTE: ",$S('DG1:"NOT CURRENTLY AN INPATIENT.",1:$S($D(^DIC(42,+DG1,0)):"CURRENTLY AN INPATIENT ON WARD '"_$P(^(0),"^",1)_"'."),1:"INPATIENT ON UNKNOWN WARD.") "RTN","DGOVBC1",26,0) I DGSCOND W !?4,"NOTE: Asterisk [*] indicates admission for Service Connected Condition." "RTN","DGOVBC1",27,0) K DGSCOND G ^DGOVBC2 "RTN","DGOVBC1",28,0) L F DGL=1:1:$S($D(IOM):(IOM-2),1:130) W "_" "RTN","DGOVBC1",29,0) Q "RTN","DGOVBC1",30,0) PT F I=0,.11,.15,.3,.31,.32,.36,.361,.362,.52,"VET" S DGP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGOVBC1",31,0) S DGSC=$S($P(DGP(.3),"^",1)="Y":1,1:0) Q "RTN","DGOVBC1",32,0) A S DGA=1 F I=1:1:3 Q:'$L(VAPA(I)) S:I=3 DGA(2)=DGA(2)_", "_VAPA(I) S:DGA<3 DGA(I)=VAPA(I),DGA=DGA+1 "RTN","DGOVBC1",33,0) I VAPA(1)']"" S DGA(1)="STREET ADDRESS UNKNOWN",DGA=2 "RTN","DGOVBC1",34,0) S DGA(DGA)=$S($L(VAPA(4))&(VAPA(5)):VAPA(4)_", "_$P(VAPA(5),"^",2),$L(VAPA(4)):VAPA(4),VAPA(5):$P(VAPA(5),"^",2),1:"CITY STATE UNKNOWN") "RTN","DGOVBC1",35,0) S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_VAPA(6) "RTN","DGOVBC1",36,0) I VAPA(12)=0 K I,J "RTN","DGOVBC1",37,0) Q "RTN","DGOVBC1",38,0) AC ;Formatting Confidential Address Information "RTN","DGOVBC1",39,0) K DGA "RTN","DGOVBC1",40,0) I VAPA(12)=1 D "RTN","DGOVBC1",41,0) .N DGASEQ,SEQ "RTN","DGOVBC1",42,0) .S DGA=13 F I=13:1:15 Q:'$L(VAPA(I)) S:I=15 DGA(14)=DGA(14)_", "_VAPA(I) S:DGA<15 DGA(I)=VAPA(I),DGA=DGA+1 "RTN","DGOVBC1",43,0) .S DGA(19)="______________________________________________" "RTN","DGOVBC1",44,0) .S DGA(20)="Confidential Start Date: "_$P(VAPA(20),"^",2) "RTN","DGOVBC1",45,0) .S DGA(21)="Confidential End Date: "_$P(VAPA(21),"^",2) "RTN","DGOVBC1",46,0) .S DGA(22)="Confidential Address Categories:" "RTN","DGOVBC1",47,0) .S SEQ="",DGASEQ=23 F S SEQ=$O(VAPA(22,SEQ)) Q:SEQ="" D "RTN","DGOVBC1",48,0) ..I $P(VAPA(22,SEQ),"^",3)="Y" S DGA(DGASEQ)=$P(VAPA(22,SEQ),"^",2),DGASEQ=DGASEQ+1 "RTN","DGOVBC1",49,0) .I VAPA(13)']"" S DGA(1)="STREET ADDRESS UNKNOWN",DGA=2 "RTN","DGOVBC1",50,0) .S DGA(DGA)=$S($L(VAPA(16))&(VAPA(17)):VAPA(16)_", "_$P(VAPA(17),"^",2),$L(VAPA(16)):VAPA(16),VAPA(17):$P(VAPA(17),"^",2),1:"CITY STATE UNKNOWN") "RTN","DGOVBC1",51,0) .S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_$P(VAPA(18),"^",2) "RTN","DGOVBC1",52,0) K I,VAPA Q "RTN","DGOVBC1",53,0) Q "RTN","DGOVBC1",54,0) AS S Y=$P(DGD,"^",1),Y=$P(Y,".",1) X ^DD("DD") S:$P(DGD,"^",11) DGSCOND=1 S DGD(1)=$S($P(DGD,"^",11):"*",1:" ")_Y,DGD(2)=$S($D(^DG(405.2,+$P(DGD,"^",18),0)):$P(^(0),"^",1),1:DGU) "RTN","DGOVBC1",55,0) S DGD(3)=$S($D(^DIC(42,+$P(DGD,"^",6),0)):$P(^(0),"^",1),1:DGU) "RTN","DGOVBC1",56,0) S DGD(4)=$S($P(DGD,"^",10)]"":$E($P(DGD,"^",10),1,30),1:"ADMITTING DIAGNOSIS UNSPECIFIED"),DGD(5)=$S($D(^DIC(43.4,+$P(DGADM(I,4),"^",1),0)):$P(^(0),"^",1),1:DGU) Q "RTN","DGRPC") 0^14^B20161102 "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**;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,.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!!",*7 Q "RTN","DGRPC2") 0^15^B17367418 "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**;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",95,0) I I,I<99 S DGLST=I G @(DGLST_$S(DGLST>42:"",DGLST>17:"^DGRPC1",1:"^DGRPC")) "RTN","DGRPC2",96,0) G END "RTN","DGRPC2",97,0) ; "RTN","DGRPCADD") 0^13^B7617335 "RTN","DGRPCADD",1,0) DGRPCADD ;ALB/MRL - REGISTRATION SCREEN 1.1/CONFIDENTIAL ADDRESS INFORMATION ;FEB 2003@2300 "RTN","DGRPCADD",2,0) ;;5.3;Registration;**489**;Aug 13, 1993 "RTN","DGRPCADD",3,0) CADD ;Confidential Address "RTN","DGRPCADD",4,0) N CNT,DGA1,DGA2,DGA3,DGACT,DGBEG,DGCAN,DGCAT,DGCC,DGEND,DGTYP,DGTYPNAM,DGX,DGXX,DGZ,DGZIP,DGI,Y,Z,DGERR "RTN","DGRPCADD",5,0) S DGRPS=1.1 D H^DGRPU "RTN","DGRPCADD",6,0) S DGRP(.141)=$G(^DPT(DFN,.141)) "RTN","DGRPCADD",7,0) S Z=1,DGRPW=1.1 D WW^DGRPV W "Confidential Address" "RTN","DGRPCADD",8,0) I DGRP(.141)=""!($P(DGRP(.141),U)="")!('$P($$CAACT(DFN),U)) D G END "RTN","DGRPCADD",9,0) .W !?5,"NO CONFIDENTIAL ADDRESS" "RTN","DGRPCADD",10,0) .W !!?42,"From/To: NOT APPLICABLE" "RTN","DGRPCADD",11,0) S DGXX=DGRP(.141),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3) "RTN","DGRPCADD",12,0) W !?3,DGA1,?43,"County: " "RTN","DGRPCADD",13,0) I $D(^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0)) D "RTN","DGRPCADD",14,0) .S DGCC=^DIC(5,+$P(DGRP(.141),"^",5),1,+$P(DGRP(.141),"^",11),0) W $P(DGCC,"^",1),"(",$P(DGCC,"^",3),")" "RTN","DGRPCADD",15,0) W:DGA2'="" !?3,DGA2 "RTN","DGRPCADD",16,0) W:DGA3'="" !?3,DGA3 "RTN","DGRPCADD",17,0) W !?3,$P(DGRP(.141),"^",4) I $D(^DIC(5,+$P(DGRP(.141),"^",5),0)) W ",",$P(^DIC(5,+$P(DGRP(.141),"^",5),0),"^",2) "RTN","DGRPCADD",18,0) S DGZIP=$P(DGRP(.141),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12) "RTN","DGRPCADD",19,0) W " ",DGZIP "RTN","DGRPCADD",20,0) W ?42,"From/To: " S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D "RTN","DGRPCADD",21,0) .I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y "RTN","DGRPCADD",22,0) .I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED") "RTN","DGRPCADD",23,0) W DGX "RTN","DGRPCADD",24,0) W !!,"Categories: " I $D(^DPT(DFN,.14)) D "RTN","DGRPCADD",25,0) .S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR") "RTN","DGRPCADD",26,0) .S DGX="",DGCAN="" F S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN="" D "RTN","DGRPCADD",27,0) ..Q:'$D(^DPT(DFN,.14,DGCAN,0)) "RTN","DGRPCADD",28,0) ..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2) "RTN","DGRPCADD",29,0) ..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered") "RTN","DGRPCADD",30,0) ..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM="" D "RTN","DGRPCADD",31,0) ...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX "RTN","DGRPCADD",32,0) S DGXX="",CNT=0 F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX="" D "RTN","DGRPCADD",33,0) .W:CNT>0 ! "RTN","DGRPCADD",34,0) .W ?13,DGXX "RTN","DGRPCADD",35,0) .S CNT=CNT+1 "RTN","DGRPCADD",36,0) END ; "RTN","DGRPCADD",37,0) G ^DGRPP "RTN","DGRPCADD",38,0) CAACT(DFN,ACTDT) ;Determines if the Confidential Address is active "RTN","DGRPCADD",39,0) ;Input: DFN - Patient (#2) file internal entry number (Required) "RTN","DGRPCADD",40,0) ; ACTDT - Date used to determine if address is active "RTN","DGRPCADD",41,0) ; (Optional) Defaults to DT if not defined. "RTN","DGRPCADD",42,0) ; "RTN","DGRPCADD",43,0) ;Output: "RTN","DGRPCADD",44,0) ; 1st piece 0 inactive based on start/stop dates "RTN","DGRPCADD",45,0) ; 1 active based on start/stop dates "RTN","DGRPCADD",46,0) ; 2nd piece 0 - no active correspondence types "RTN","DGRPCADD",47,0) ; 1 - at least one active correspondence type "RTN","DGRPCADD",48,0) ; "RTN","DGRPCADD",49,0) N DGCA,DGCABEG,DGCAEND,DGSTAT,DGIEN,DGTYP,DGFLG "RTN","DGRPCADD",50,0) S DGSTAT="0^0" "RTN","DGRPCADD",51,0) I '$D(DFN) Q DGSTAT "RTN","DGRPCADD",52,0) I '$D(ACTDT) S ACTDT=DT "RTN","DGRPCADD",53,0) S DGCA=$G(^DPT(DFN,.141)) D "RTN","DGRPCADD",54,0) .I DGCA="" Q "RTN","DGRPCADD",55,0) .S DGCABEG=$P(DGCA,U,7) "RTN","DGRPCADD",56,0) .S DGCAEND=$P(DGCA,U,8) "RTN","DGRPCADD",57,0) .I 'DGCABEG!(DGCABEG>ACTDT)!(DGCAEND&(DGCAEND0 S DFN=+Y D EN G SEL "RTN","DGRPD",10,0) ; "RTN","DGRPD",11,0) EN ;call to display patient inquiry - input DFN "RTN","DGRPD",12,0) ;MPI/PD CHANGE "RTN","DGRPD",13,0) S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI")) "RTN","DGRPD",14,0) S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGMPI,U,3)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED") "RTN","DGRPD",15,0) I $D(DGMPI),$D(DGLOCATN) S DGCMOR=$P(DGLOCATN,"^") "RTN","DGRPD",16,0) ;END MPI/PD CHANGE "RTN","DGRPD",17,0) K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR F I=0,.11,.13,.121,.31,.32,.36,.361,.141 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPD",18,0) S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU S DGTMPAD=0 I $P(DGRP(.121),"^",9)="Y" S DGTMPAD=$S('$P(DGRP(.121),"^",8):1,$P(DGRP(.121),"^",8)'50) !?9 W:'(I#2) ?51 W DGA(I) "RTN","DGRPD",21,0) S DGCC=+$P(DGRP(.11),U,7),DGST=+$P(DGRP(.11),U,5),DGCC=$S($D(^DIC(5,DGST,1,DGCC,0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?1,"County: ",DGCC "RTN","DGRPD",22,0) S X="NOT APPLICABLE" I DGTMPAD S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU) "RTN","DGRPD",23,0) W ?42,"From/To: ",X,!?2,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S('DGTMPAD:X,$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU) K DGTMPAD "RTN","DGRPD",24,0) W !?1,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU) "RTN","DGRPD",25,0) D CA "RTN","DGRPD",26,0) I 'DGABBRV W !?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED") "RTN","DGRPD",27,0) I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46,"Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED") "RTN","DGRPD",28,0) S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !!,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU) "RTN","DGRPD",29,0) I '$$OKLINE(16) G Q "RTN","DGRPD",30,0) W !,"Other Eligibilities: " F I=0:0 S I=$O(^DIC(8,I)) Q:'I I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^(0),"^",1)_", " I $D(^DPT("AEL",DFN,I)) W:$X+$L(X)>79 !?21 W X "RTN","DGRPD",31,0) ;I '$$OKLINE(16) G Q "RTN","DGRPD",32,0) ; "RTN","DGRPD",33,0) ;display the catastrophic disability review date if there is one "RTN","DGRPD",34,0) D CATDIS "RTN","DGRPD",35,0) ; "RTN","DGRPD",36,0) I $G(DGPRFLG)=1 D "RTN","DGRPD",37,0) . N DGPDT,DGPTM "RTN","DGRPD",38,0) . W !,$$REPEAT^XLFSTR("-",78) "RTN","DGRPD",39,0) . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1) "RTN","DGRPD",40,0) . W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE") "RTN","DGRPD",41,0) . S DGPTM=$$OUTPTTM^SDUTL3(DFN) "RTN","DGRPD",42,0) . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2) "RTN","DGRPD",43,0) . W !,$$REPEAT^XLFSTR("-",78) "RTN","DGRPD",44,0) ; Check if patient is an inpatient and on a DOM ward "RTN","DGRPD",45,0) ; If inpatient is on a DOM ward, don't display MT or CP messages "RTN","DGRPD",46,0) ; If inpatient is NOT on a DOM ward, don't display CP message "RTN","DGRPD",47,0) N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR "RTN","DGRPD",48,0) D DOM^DGMTR "RTN","DGRPD",49,0) I '$G(DGDOM) D "RTN","DGRPD",50,0) .D DIS^DGMTU(DFN) "RTN","DGRPD",51,0) .D IN5^VADPT "RTN","DGRPD",52,0) .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1) "RTN","DGRPD",53,0) I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W ! "RTN","DGRPD",54,0) S VAIP("L")="" "RTN","DGRPD",55,0) I $$OKLINE(14) D INP "RTN","DGRPD",56,0) I '$G(DGRPOUT),($$OKLINE(17)) D SA "RTN","DGRPD",57,0) ;MPI/PD CHANGE "RTN","DGRPD",58,0) Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q "RTN","DGRPD",59,0) CA ;Confidential Address "RTN","DGRPD",60,0) W !!?1,"Confidential Address: ",?44,"Confidential Address Categories:" "RTN","DGRPD",61,0) N DGCABEG,DGCAEND,DGA,DGARRAY,DGERROR "RTN","DGRPD",62,0) S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8) "RTN","DGRPD",63,0) I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND43) !?9 W:'(I#2) ?44 W DGA(I) "RTN","DGRPD",79,0) W !?1,"From/To: ",$$FMTE^XLFDT(DGCABEG)_"-"_$S(DGCAEND'="":$$FMTE^XLFDT(DGCAEND),1:"UNANSWERED") "RTN","DGRPD",80,0) Q "RTN","DGRPD",81,0) HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP "RTN","DGRPD",82,0) ;MPI/PD CHANGE "RTN","DGRPD",83,0) W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q "RTN","DGRPD",84,0) ;END MPI/PD CHANGE "RTN","DGRPD",85,0) INP S VAIP("D")="L" D INP^DGPMV10 "RTN","DGRPD",86,0) S DGPMT=0 "RTN","DGRPD",87,0) D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q "RTN","DGRPD",88,0) SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE(17) SAA Q:$G(DGRPOUT) "RTN","DGRPD",89,0) Q "RTN","DGRPD",90,0) SAA ;Scheduled Admit Data "RTN","DGRPD",91,0) W !!?14,"Scheduled Admit" "RTN","DGRPD",92,0) W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U) "RTN","DGRPD",93,0) W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U) "RTN","DGRPD",94,0) W " on "_$$FMTE^XLFDT(L,"5DZ") "RTN","DGRPD",95,0) Q ;SAA "RTN","DGRPD",96,0) ; "RTN","DGRPD",97,0) CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"") "RTN","DGRPD",98,0) ; "RTN","DGRPD",99,0) FA G:'$$OKLINE(20) RMK "RTN","DGRPD",100,0) S CT=0 W !!,"Future Appointments: " I $O(^DPT(DFN,"S",DT))'>0 W "NONE" G RMK "RTN","DGRPD",101,0) W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "=" "RTN","DGRPD",102,0) F FA=DT:0 S FA=$O(^DPT(DFN,"S",FA)) G RMK:'FA S L=^(FA,0),C=+L I $P(L,"^",2)'["C" D COV D Q:CT>5 "RTN","DGRPD",103,0) .N DGAPPT "RTN","DGRPD",104,0) .S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z") "RTN","DGRPD",105,0) .W !?22,$P(DGAPPT,"@") "RTN","DGRPD",106,0) .W ?33,$P(DGAPPT,"@",2) "RTN","DGRPD",107,0) .W ?39,$P($S($D(^SC(C,0)):^(0),1:""),"^")," ",COV "RTN","DGRPD",108,0) .Q "RTN","DGRPD",109,0) I $O(^DPT(DFN,"S",FA))>0 W !,"See Scheduling options for additional appointments." "RTN","DGRPD",110,0) RMK I '$G(DGRPOUT),($$OKLINE(21)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) "RTN","DGRPD",111,0) K ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky "RTN","DGRPD",112,0) Q "RTN","DGRPD",113,0) COV S COV=$S($P(L,"^",7)=7:" (Collateral) ",1:""),COV=COV_$S($P(L,"^",2)["NT":" * NO ACTION TAKEN *",$P(L,"^",2)["N":" * NO-SHOW *",1:""),CT=CT+1 Q "RTN","DGRPD",114,0) Q "RTN","DGRPD",115,0) ; "RTN","DGRPD",116,0) OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME "RTN","DGRPD",117,0) Q "RTN","DGRPD",118,0) OKLINE(DGLINE) ;DOES PAUSE/HEADER IF $Y EXCEEDS DGLINE "RTN","DGRPD",119,0) ; "RTN","DGRPD",120,0) ;IN: DGLINE --MAX LINE COUNT W/O PAUSE "RTN","DGRPD",121,0) ;OUT: DGLINE[RETURNED] -- 0 IF TIMEOUT/UP ARROW "RTN","DGRPD",122,0) ; DGRPOUT[SET] -- 1 IF " "RTN","DGRPD",123,0) N X,Y ;**286** MLR 09/25/00 Newing X & Y variables prior to ^DIR "RTN","DGRPD",124,0) I $G(IOST)["P-" Q DGLINE ; if printer, quit "RTN","DGRPD",125,0) I $Y>DGLINE N DIR S DIR(0)="E" D ^DIR D:Y HDR I 'Y S DGRPOUT=1,DGLINE=0 "RTN","DGRPD",126,0) Q DGLINE "RTN","DGRPD",127,0) ; "RTN","DGRPD",128,0) CATDIS ; "RTN","DGRPD",129,0) ;displays catastrophic disabity review date if there is one "RTN","DGRPD",130,0) N DGCDIS "RTN","DGRPD",131,0) I $$GET^DGENCDA(DFN,.DGCDIS) D "RTN","DGRPD",132,0) .Q:'DGCDIS("REVDTE") "RTN","DGRPD",133,0) .W !!,"Catastrophically Disabled Review Date: ",$$FMTE^XLFDT(DGCDIS("REVDTE"),1) "RTN","DGRPD",134,0) Q "RTN","DGRPD",135,0) ; "RTN","DGRPE") 0^8^B38867179 "RTN","DGRPE",1,0) DGRPE ;ALB/MRL - REGISTRATIONS EDITS ; 10/27/00 12:40pm "RTN","DGRPE",2,0) ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489**;Aug 13, 1993 "RTN","DGRPE",3,0) ; "RTN","DGRPE",4,0) ;DGDR contains a string of edits; edit=screen*10+item # "RTN","DGRPE",5,0) ; "RTN","DGRPE",6,0) ;line tag screen*10+item*1000 = continuation line "RTN","DGRPE",7,0) ; "RTN","DGRPE",8,0) I DGRPS=8 D ^DGRPEIS,Q Q ; family demographic edit...not conventional!! :) "RTN","DGRPE",9,0) I DGRPS=9 D EDIT9^DGRPEIS2,Q Q ; income screening data ($$$) "RTN","DGRPE",10,0) I DGRPS=5,DGDR["501," D "RTN","DGRPE",11,0) .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q "RTN","DGRPE",12,0) .D REG^IBCNBME(DFN) "RTN","DGRPE",13,0) .Q "RTN","DGRPE",14,0) ;-- Tricare screen #15 "RTN","DGRPE",15,0) I DGRPS=15 D EDIT^DGRP15,Q Q "RTN","DGRPE",16,0) ; "RTN","DGRPE",17,0) N DGPH,DGPHFLG "RTN","DGRPE",18,0) K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0 G ^DGRPE1:DGRPS>6 F I=1:1 S J=$P(DGDR,",",I) Q:J="" F J1=J,J*1000 Q:'$T(@J1) S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE",19,0) D ^DIE "RTN","DGRPE",20,0) I $G(DGPHFLG)>0 D EDITPH1^DGRPLE() "RTN","DGRPE",21,0) Q K DA,DIE,DR,DGCT,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1 "RTN","DGRPE",22,0) Q "RTN","DGRPE",23,0) S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q "RTN","DGRPE",24,0) S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q "RTN","DGRPE",25,0) Q "RTN","DGRPE",26,0) 101 ;;.01;.09;.03; "RTN","DGRPE",27,0) 102 ;;1; "RTN","DGRPE",28,0) 103 ;;.091; "RTN","DGRPE",29,0) 104 ;;S DIE("NO^")="OUTOK";.111;S:X="" Y="@1112";.112;S:X="" Y="@1112";.113;@1112;S EASZIPLK=1;.1112;K EASDO2;.114;S:'$$KEY^DGREGDD1(DUZ,DA) Y=.131;.115;.117;.131;.132;K DIE("NO^"); "RTN","DGRPE",30,0) 105 ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;.1211;I X']"" W !?4,$C(7),"But I need at least one line of a Temporary address." S Y=.12105; "RTN","DGRPE",31,0) 111 ;;.14105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105; "RTN","DGRPE",32,0) 111000 ;;K DR(2,2.141);.1411;I X']"" W !?4,$C(7),"I need at least one line of Address." S Y=.14105;.1412;S:X']"" Y=.1414;.1413;.1414;.1415;.1416;Q;.14111;@15;K DIE("NO^"); "RTN","DGRPE",33,0) 109 ;;S DIE("NO^")="OUTOK";.111;S:X="" Y="@1112";.112;S:X="" Y="@1112";.113;@1112;S EASZIPLK=1;.1112;K EASDO2;.114;S:'$$KEY^DGREGDD1(DUZ,DA) Y=.131;.115;.117;.131;.132;.02;D 109DR^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^"); "RTN","DGRPE",34,0) 105000 ;;.1212;S:X']"" Y=.1214;.1213:.1215;.12112;Q;.12111;.1219;@15;K DIE("NO^"); "RTN","DGRPE",35,0) 201 ;;.02;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE; "RTN","DGRPE",36,0) 202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^"); "RTN","DGRPE",37,0) 203 ;;D 203DR^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06); "RTN","DGRPE",38,0) 301 ;;.211;S:X']"" Y="@31";.212;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31; "RTN","DGRPE",39,0) 302 ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011; "RTN","DGRPE",40,0) 302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32; "RTN","DGRPE",41,0) 303 ;;N DGX1;I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),"^",1)']"":1,1:0) S Y=.331;.3305//NO;I X="Y" S DGX1=1 S X=$S($D(^DPT(DA,.21)):^(.21),1:"") S:X]"" ^(.33)=$P(X_"^^^^^^^^^^^","^",1,9)_"^"_$P(^(.33),"^",10)_"^"_$P(X,"^",11); "RTN","DGRPE",42,0) 303000 ;;I $G(DGX1) S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);S:$G(DGX1) Y=.33011;.331;S:X']"" Y="@33";.332;.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=0;@33; "RTN","DGRPE",43,0) 304 ;;.3311;S:X']"" Y="@34";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@34; "RTN","DGRPE",44,0) 305 ;;N DGX1;I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),"^",1)']"":1,1:0) S Y=.341;.3405//NO;I X="Y" S DGX1=1 S X=$S($D(^DPT(DA,.21)):^(.21),1:"") S:X]"" ^(.34)=$P(X_"^^^^^^^^^^^","^",1,9)_"^"_$P(^(.34),"^",10)_"^"_$P(X,"^",11); "RTN","DGRPE",45,0) 305000 ;;I $G(DGX1)&($D(^DPT(DFN,.22))) S $P(^(.22),U,2)=$P(^(.22),U,7);S:$G(DGX1) Y="@35";.341;S:X']"" Y="@35";.342;.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=0;@35; "RTN","DGRPE",46,0) 401 ;;.07;.31115;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@41";.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41; "RTN","DGRPE",47,0) 402 ;;.2514;.2515;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@42";.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42; "RTN","DGRPE",48,0) 501 ;; "RTN","DGRPE",49,0) 502 ;;.381;.382///NOW; "RTN","DGRPE",50,0) 503 ;;.383; "RTN","DGRPE",51,0) 601 ;;.325;S:X']"" Y="@61";.328;.326;.327;.324;.3285//NO;S:X'="Y" Y="@61";.3291;S:X']"" Y="@61";.3294;.3292;.3293;.329;.32945//NO;S:X'="Y" Y="@61";.3296;S:X']"" Y="@61";.3299;.3297;.3298;.3295;@61; "RTN","DGRPE",52,0) 602 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62; "RTN","DGRPE",53,0) 603 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63; "RTN","DGRPE",54,0) 604 ;;.32101//NO;S:X'="Y" Y="@64";.32104;.32105;@64; "RTN","DGRPE",55,0) 605 ;;.32102//NO;S:X'="Y" Y="@65";.32107;.32109;.3211;.3213;@65; "RTN","DGRPE",56,0) 606 ;;.32103//NO;S:X'="Y" Y="@66";.3212;.32111;@66; "RTN","DGRPE",57,0) 607 ;;.3221//NO;S:X'="Y" Y="@67";.3222;Q;.3223;@67; "RTN","DGRPE",58,0) 608 ;;.3224//NO;S:X'="Y" Y="@68";.3225;Q;.3226;@68; "RTN","DGRPE",59,0) 609 ;;.3227//NO;S:X'="Y" Y="@69";.3228;Q;.3229;@69; "RTN","DGRPE",60,0) 610 ;;.32201//NO;S:X'="Y" Y="@610";.322011;Q;.322012;@610; "RTN","DGRPE",61,0) 611 ;;.322016//NO;S:X'="Y" Y="@611";.322017;Q;.322018;@611; "RTN","DGRPE",62,0) 612 ;;.322013//NO;S:X'="Y" Y="@612";.322014;Q;.322015;@612; "RTN","DGRPE",63,0) 613 ;;.362; "RTN","DGRPE",64,0) 614 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614; "RTN","DGRPE",65,0) 615 ;;.322019//NO;S:X'="Y" Y="@615";.32202;Q;.322021;@615; "RTN","DGRPE",66,0) 616 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162; "RTN","DGRPE",67,0) 617 ;;D REG^DGNTQ(DFN); "RTN","DGRPE",68,0) AD N DGZ4,DGPC "RTN","DGRPE",69,0) S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10) "RTN","DGRPE",70,0) I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4 "RTN","DGRPE",71,0) K DGADD,DGPHONE Q "RTN","DGRPE",72,0) 109DR ;Drop through (use same logic as 203DR) "RTN","DGRPE",73,0) 203DR S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;" "RTN","DGRPE",74,0) S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;" "RTN","DGRPE",75,0) Q "RTN","DGRPE",76,0) DR111 ;Set DR string for Confidential Address categories "RTN","DGRPE",77,0) S DR(2,2.141)=".01;1//YES;" "RTN","DGRPE",78,0) Q "RTN","DGRPH") 0^9^B26718912 "RTN","DGRPH",1,0) DGRPH ;ALB/MRL - REGISTRATION HELP ROUTINE ;06 JUN 88@2300 "RTN","DGRPH",2,0) ;;5.3;Registration;**114,343,397,415,489**;Aug 13, 1993 "RTN","DGRPH",3,0) S DGRPH="" D H^DGRPU K DGRPH W !,"Enter '^' to stop the display ",$S(DGRPV:"",1:"and edit "),"of data, '^N' to jump to screen #N (see",!,"listing below), to continue on to the next available screen" I DGRPV W "." G M "RTN","DGRPH",4,0) W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters. Those groups enclosed in brackets ""[]"" are editable while those",!,"enclosed in arrows ""<>"" are not." "RTN","DGRPH",5,0) W " Enter 'ALL' to edit all editable data",!,"elements on the screen." "RTN","DGRPH",6,0) M I DGRPS=9,DGRPSEL="V" W !!,"You may precede your selection with 'V' to denote veteran." "RTN","DGRPH",7,0) I DGRPS=9,DGRPSEL]"V" W !!,"To edit a specific column, enter 'V'",$S($D(DGREL("S")):", 'S'",1:""),$S($D(DGREL("D")):", 'D'",1:"")," in front of the selected items." "RTN","DGRPH",8,0) S Z="DATA GROUPS ON SCREEN "_DGRPS,DGRPCM=1 W ! D WW^DGRPV S DGRPCM=0 D:DGRPS=1.1 A1 D:DGRPS'=1.1 @DGRPS D:$S(DGRPS<11:1,DGRPS=14:1,1:0) W D S W ! F I=$Y:1:20 W ! "RTN","DGRPH",9,0) ;S Z="Press RETURN key",DGRPCM=1 D WW^DGRPV S DGRPCM=0 W " to EXIT Screen ",DGRPS," HELP " R X:DTIME S X="" Q "RTN","DGRPH",10,0) S DGRPW=0 W "Press " S Z="",DGRPCM=1 D WW^DGRPV W " KEY " S Z="TO EXIT" D WW^DGRPV W " SCREEN ",DGRPS," " S Z="HELP" D WW^DGRPV W " " R X:DTIME S (DGRPCM,DGRPW)=0 Q "RTN","DGRPH",11,0) 1 S X="Name, SSN, DOB^Alias Name & SSN (if applicable)^Remarks concerning this patient^Home Address, Phone & Work Phone^Temporary Address, Dates, Phone" Q "RTN","DGRPH",12,0) A1 S X="Confidential Address,Dates and Types" Q "RTN","DGRPH",13,0) 2 S X="Sex, POB, Parents, etc.^Dates/Locations of Previous Care^Race and Ethnicity" Q "RTN","DGRPH",14,0) 3 S X="Primary Next-of-Kin^Secondary Next-of-Kin^Primary Emergency Contact^Secondary Emergency Contact^Designee to receive personal effects" Q "RTN","DGRPH",15,0) 4 S X="Applicant Employer, Address^Spouses Employer, Address" Q "RTN","DGRPH",16,0) 5 S X="Unexpired Insurance Policies^Eligibile for Medicaid" Q "RTN","DGRPH",17,0) 6 S X="Service History^Prisoner of War^Combat^Vietnam Service^Agent Orange Exposure^IONizing Radiation Exposure^" "RTN","DGRPH",18,0) S X=X_"Lebanon Service^Grenada Service^Panama Service^Persian Gulf Service^Somalia Service^Environmental Contaminants Exposure^Military Retirement/Disability^Dental History^Yugoslavia Service^Purple Heart Recipient^" "RTN","DGRPH",19,0) S X=X_"Nose/Throat Radium Treatment" "RTN","DGRPH",20,0) Q "RTN","DGRPH",21,0) 7 S X="Patient Type, SC Data, Claim Info^VA Monetary Benefits^POS, Eligibility Code(s)^SC Conditions relayed by applicant" Q "RTN","DGRPH",22,0) 8 S X="Spouse's Demographic Info^Dependents' Demographic Info" Q "RTN","DGRPH",23,0) 9 S X="Social Security^U.S. Civil Service^U.S. Railroad Retirement^Military Retirement^Unemployment^Other Retirement^Total Employment Income^Interest,Dividend,Annuity^Workers Comp or Black Lung^Other Income" Q "RTN","DGRPH",24,0) 10 S X="Ineligible Patient Information^Missing Patient Information" Q "RTN","DGRPH",25,0) 11 S X="Eligibility Verification^Monetary Benefits Verification^Service Record Verification^Rated Disabilities (VA)" Q "RTN","DGRPH",26,0) 12 W !,"Four most recent admission episodes on file for this applicant are displayed",!,"in inverse order." Q "RTN","DGRPH",27,0) 13 W !,"Four most recent applications for care (registrations) are displayed in",!,"inverse order." Q "RTN","DGRPH",28,0) 14 S X="Clinics in which actively enrolled^Pending (future) appointments" Q "RTN","DGRPH",29,0) 15 W !,"Sponsor information is displayed for patients." Q "RTN","DGRPH",30,0) S W ! S Z="AVAILABLE SCREENS",DGRPCM=1 D WW^DGRPV S DGRPCM=0 "RTN","DGRPH",31,0) S X="Demographic^Confidential Address^Patient^Contact^Employment^Insurance^Service Record^Eligibility^Family Demographic^Income Screening^Missing/Ineligible^Eligibility Verification^" "RTN","DGRPH",32,0) S X=X_"Admission Info^Application Info^Appointment Info^Sponsor Demograhics" "RTN","DGRPH",33,0) ;S C=0 F I=1:1 S J=$P(X,"^",I) Q:J="" I '$E(DGRPVV,I) S C=C+1,Z="^"_I,DGRPW=(C#2) D WW^DGRPV S Z=$S(I?1N:" ",1:" ")_J_" Data",Z1=$S((C#2)&(I?1N):36,(C#2):35,1:1) D WW1^DGRPV:(C#2) I '(C#2) W Z "RTN","DGRPH",34,0) N DGJ "RTN","DGRPH",35,0) S DGJ="" "RTN","DGRPH",36,0) S C=0 F I=1:1 S DGJ=$O(DGRPVV(DGJ)) Q:DGJ="" I '$E(DGRPVV,DGJ) D "RTN","DGRPH",37,0) .S C=C+1,Z="^"_DGJ,DGRPW=(C#2) "RTN","DGRPH",38,0) .D WW^DGRPV "RTN","DGRPH",39,0) .S Z1=$S((C#2)&(DGJ?1N):36,(C#2):35,1:1) "RTN","DGRPH",40,0) .S Z=$S(DGJ?1N:" ",1:" ")_$P(X,U,I)_" Data" "RTN","DGRPH",41,0) .D WW1^DGRPV:(C#2) "RTN","DGRPH",42,0) .I '(C#2) W Z "RTN","DGRPH",43,0) Q "RTN","DGRPH",44,0) W F I=1:1 S J=$P(X,"^",I) Q:J="" S Z=I,DGRPW=(I#2) D WW^DGRPV S Z=$S(I<10:" ",1:" ")_J,Z1=$S((I#2)&(I>10):36,(I#2):37,1:1) D WW1^DGRPV "RTN","DGRPH",45,0) W:'((I-1)#2) ! Q "RTN","DGRPP") 0^11^B23085136 "RTN","DGRPP",1,0) DGRPP ;ALB/MRL,AEG - REGISTRATION SCREEN PROCESSOR ;06 JUN 88@2300 "RTN","DGRPP",2,0) ;;5.3;Registration;**92,147,343,404,397,489**;Aug 13, 1993 "RTN","DGRPP",3,0) ; "RTN","DGRPP",4,0) ;DGRPS : Screen to edit "RTN","DGRPP",5,0) ;DGRPSEL : If screen 9 (income screening) set to allowable selections "RTN","DGRPP",6,0) ; (V=Veteran, S=Spouse, D=Dependents) "RTN","DGRPP",7,0) ;DGRPSELT : If screen 9, type selected (V, S, or D or all if none specified) "RTN","DGRPP",8,0) ;DGRPAN : Selectable items on screen for edit (user input) "RTN","DGRPP",9,0) ;DGRPANP : Selectable items for print on page footer - i.e. 1-3 "RTN","DGRPP",10,0) ;DGRPANN : Selected item(s) extrapolated (screen_item) "RTN","DGRPP",11,0) ; "RTN","DGRPP",12,0) ; "RTN","DGRPP",13,0) EN ; "RTN","DGRPP",14,0) D:'$$BEGUPLD^DGENUPL3(DFN) "RTN","DGRPP",15,0) .D UNLOCK^DGENPTA1(DFN) "RTN","DGRPP",16,0) .D CKUPLOAD^DGENUPL3(DFN) "RTN","DGRPP",17,0) .I $$LOCK^DGENPTA1(DFN) "RTN","DGRPP",18,0) D ENDUPLD^DGENUPL3(DFN) "RTN","DGRPP",19,0) D Q1,WHICH^DGRPP1 W ! K DGRP S DGRPAN="" F I=1:1:$L(DGRPVV(DGRPS)) I 'DGRPV S:'$E(DGRPVV(DGRPS),I) DGRPAN=DGRPAN_I_"," "RTN","DGRPP",20,0) D STR^DGRPP1 F I=$Y:1:20 W ! "RTN","DGRPP",21,0) I ("8^9"[DGRPS),$G(DGNOBUCK) S Z="C" D W W "=COPY," "RTN","DGRPP",22,0) I ("8^9"[DGRPS),($G(DGEFDT)'=DT) S Z="E" D W W "=ENTER new "_(DGISYR+1)_" data," "RTN","DGRPP",23,0) S Z="" D W W " to ",$S(DGRPS0 D "RTN","DGRPP",39,0) ..W !," ...FAMILY DEMOGRAPHIC DATA COPIED" "RTN","DGRPP",40,0) ..W !," ...............INCOME DATA COPIED" "RTN","DGRPP",41,0) ..H 2 "RTN","DGRPP",42,0) ..S DGRPVV(9)="0000000000",DGRPVV(8)="00",DA=$$GETIN^DGMTU2(DFN,+DGREL("V"),DT) S DIE=408.21,DR=".18///^S X=""YES""" D ^DIE K DA,DIE,DR "RTN","DGRPP",43,0) JUMP G JUMP^DGRPP1:DGRPANN?1"^"1N.".".1N I DGRPOUT!(DGRPANN?1"^".E) G Q "RTN","DGRPP",44,0) S (DGRPANN,X)=$$UPPER^DGUTL(DGRPANN) "RTN","DGRPP",45,0) I $E(DGRPANN)="A" S X=DGRPANN,Z="^ALL" D IN^DGHELP I %'=-1 S DGRPANN=DGRPANP "RTN","DGRPP",46,0) I DGRPANN]"",(DGRPSEL[$E(DGRPANN)) S DGRPSELT=$E(DGRPANN),DGRPANN=$P(DGRPANN,DGRPSELT,2) ; save off type, run through all other checks "RTN","DGRPP",47,0) I DGRPANN'?1N.E D ^DGRPH G:DGRPS'=1.1 @("^DGRP"_DGRPS) G:DGRPS=1.1 ^DGRPCADD "RTN","DGRPP",48,0) S DGDR="" F I=1:1 S DGCH=$P(DGRPANN,",",I) Q:DGCH']""!($L(DGCH)>5) D CHOICE "RTN","DGRPP",49,0) I DGDR']"" D ^DGRPH S X=DGRPS G SCRX "RTN","DGRPP",50,0) D ^DGRPE G QQ:'$D(^DPT(DFN,0)) S X=DGRPS G SCRX "RTN","DGRPP",51,0) Q I 'DGELVER D:$S(DGRPOUT:0,'$D(DGRPV):0,'DGRPV:1,1:0) LT^DGRPP1 "RTN","DGRPP",52,0) K DGDEP,DGINC,DGINR,DGMTC,DGMTED,DGREL,DGTOT,DGSP "RTN","DGRPP",53,0) K DGCH,DGGTOT,DGIRI,DGPRI,DGRPSE1,DGNOCOPY "RTN","DGRPP",54,0) D SENSCHK "RTN","DGRPP",55,0) I 'DGRPV S DGEDCN=1 D ^DGRPC K DGEDCN "RTN","DGRPP",56,0) QQ K DGRPNA,DGRPS,DGRPTYPE,DGRPU,DGRPV,DGRPVV,DGRPW,DGVI,DGVO,DGRPCM,DGELVER,DGRPLAST "RTN","DGRPP",57,0) Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGDR,DGRP,DGRPAG,DGRPAN,DGRPANN,DGRPANP,DGRPD,DGRPSEL,DGRPSELT,DGRPVR,DGRPX,DGAAC "RTN","DGRPP",58,0) K DIRUT,DUOUT,DTOUT "RTN","DGRPP",59,0) K DIC,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1 I $D(DFN)#2,DFN]"" S:$D(^DPT(DFN,0)) DA=DFN "RTN","DGRPP",60,0) Q "RTN","DGRPP",61,0) ; "RTN","DGRPP",62,0) SENSCHK ; check whether patient record should be made sensitive "RTN","DGRPP",63,0) N ELIG,FLAG,X "RTN","DGRPP",64,0) S ELIG=0,FLAG=0 "RTN","DGRPP",65,0) I '$D(^DPT($G(DFN),0)) Q ; patient not defined "RTN","DGRPP",66,0) I $D(^DGSL(38.1,DFN,0)) Q ; patient already in dg security log file "RTN","DGRPP",67,0) S X=$S($D(^DPT(DFN,"TYPE")):+^("TYPE"),1:"") I $D(^DG(391,+X,0)),$P(^(0),"^",4) D SEC Q:FLAG "RTN","DGRPP",68,0) F S ELIG=$O(^DPT(DFN,"E",ELIG)) Q:'ELIG D Q:FLAG "RTN","DGRPP",69,0) . S X=$G(^DIC(8,ELIG,0)) "RTN","DGRPP",70,0) . I $P(X,"^",12) D SEC "RTN","DGRPP",71,0) Q "RTN","DGRPP",72,0) ; "RTN","DGRPP",73,0) SEC ;if patient type says make record sensitive, add to security log file "RTN","DGRPP",74,0) K DD,DO S DIC="^DGSL(38.1,",(X,DINUM)=DFN,DIC(0)="L",DIC("DR")="2///1;3////"_DUZ_";4///NOW;" D FILE^DICN "RTN","DGRPP",75,0) I $D(^DGSL(38.1,DFN,0)) W !!,"===> Record has been classified as sensitive." S FLAG=1 "RTN","DGRPP",76,0) K DIC,X,DINUM,DA,DD,DO,Y "RTN","DGRPP",77,0) Q "RTN","DGRPP",78,0) ; "RTN","DGRPP",79,0) CHOICE ;parse out which items were selected for edit "RTN","DGRPP",80,0) ; "RTN","DGRPP",81,0) ;DGCH=choice to be parsed (either number or number-number) "RTN","DGRPP",82,0) ; "RTN","DGRPP",83,0) N DGFL S DGFL=0 "RTN","DGRPP",84,0) I DGCH["-" Q:DGCH'?1.2N1"-"1.2N!($P(DGCH,"-",2)>17) F J=$P(DGCH,"-",1):1:$P(DGCH,"-",2) I DGRPAN[(J_",") D:(DGRPS=9) SCR9 I 'DGFL S DGDR=DGDR_(DGRPS*100+J)_"," "RTN","DGRPP",85,0) I DGCH'["-",DGCH?1.2N,(DGRPAN[(DGCH_",")) S DGDR=DGDR_(DGRPS*100+DGCH)_"," "RTN","DGRPP",86,0) Q "RTN","DGRPP",87,0) ; "RTN","DGRPP",88,0) NEXT ;find next available screen...goto "RTN","DGRPP",89,0) I DGRPS=DGRPLAST G Q ;last screen and return...quit "RTN","DGRPP",90,0) S X=DGRPLAST "RTN","DGRPP",91,0) F I=DGRPS+1:1 S J=$E(DGRPVV,I) Q:J']"" I 'J S X=I Q "RTN","DGRPP",92,0) I DGRPS=1 S X=1.1 "RTN","DGRPP",93,0) SCRX ;goto screen X "RTN","DGRPP",94,0) ;I DGRPLAST=DGRPS,DGRPLAST=X G Q "RTN","DGRPP",95,0) I X[".",X'=1.1 S X=$P(X,".",1) "RTN","DGRPP",96,0) G:X=1.1 ^DGRPCADD "RTN","DGRPP",97,0) G:X'=1.1 @("^DGRP"_X) ;goto next available screen "RTN","DGRPP",98,0) ; "RTN","DGRPP",99,0) W ;write highlighted text on screen (if parameter on) "RTN","DGRPP",100,0) I IOST="C-QUME",$L(DGVI)'=2 W Z "RTN","DGRPP",101,0) E W @DGVI,Z,@DGVO "RTN","DGRPP",102,0) Q "RTN","DGRPP",103,0) ; "RTN","DGRPP",104,0) SCR9 ; see if MT is completed. Allow only selective editing if so "RTN","DGRPP",105,0) I 'DGMTC Q "RTN","DGRPP",106,0) I '$D(DGRPSELT) S:DGMTC=1 DGFL=1 Q ;if no non-mt dependents "RTN","DGRPP",107,0) I DGRPSELT="S",$D(DGMTC("S")) Q "RTN","DGRPP",108,0) I DGRPSELT="D",$D(DGMTC("D")) Q "RTN","DGRPP",109,0) S DGFL=1 "RTN","DGRPP",110,0) Q "RTN","DGRPP1") 0^12^B5931859 "RTN","DGRPP1",1,0) DGRPP1 ;ALB/MRL - REGISTRATION SCREEN PROCESSOR (CONTINUED) ;06 JUN 88@2300 "RTN","DGRPP1",2,0) ;;5.3;Registration;**489**;Aug 13, 1993 "RTN","DGRPP1",3,0) ; "RTN","DGRPP1",4,0) STR ;write string of selectable items on the bottom of the screen "RTN","DGRPP1",5,0) ; "RTN","DGRPP1",6,0) ;DGRPANP = string to print of selectable items (on bottom of screen) "RTN","DGRPP1",7,0) ;K = 1 if all items are not selectable (DGRPANP=x,y,z,) "RTN","DGRPP1",8,0) ; 0 if whole range is selectable (DGRPANP=x-y) "RTN","DGRPP1",9,0) ;K1 = first item "RTN","DGRPP1",10,0) ;K2 = last item "RTN","DGRPP1",11,0) ; "RTN","DGRPP1",12,0) S (K,K1,K2)="" F I=1:1 S J=+$P(DGRPAN,",",I) Q:'J S K2=+J S:I=1 K1=J I +$P(DGRPAN,",",I+1),+$P(DGRPAN,",",I+1)'=(J+1) S K=1 "RTN","DGRPP1",13,0) S DGRPANP=$S(K:$E(DGRPAN,1,$L(DGRPAN)-1),K1=K2:K1,1:K1_"-"_K2) "RTN","DGRPP1",14,0) K K,K1,K2,I,J,I1 "RTN","DGRPP1",15,0) Q "RTN","DGRPP1",16,0) ; "RTN","DGRPP1",17,0) LT ;local registration template questions "RTN","DGRPP1",18,0) I '$D(^DG(43,1,0)) W !!,*7,"Your MAS PARAMETER file is not properly set up!" Q "RTN","DGRPP1",19,0) S XX=$S($D(^DIE(+$P(^DG(43,1,0),"^",35),0)):$P(^(0),"^",1),1:"") I XX']"" Q "RTN","DGRPP1",20,0) W @IOF S DGRPCM=1,Z="LOCAL REGISTRATION QUESTIONS",X=25 D W^DGRPU "RTN","DGRPP1",21,0) S X1="",$P(X1,"=",81)="" W !,X1,!! "RTN","DGRPP1",22,0) S DR="["_XX_"]",DIE="^DPT(",(DA,Y)=DFN D ^DIE "RTN","DGRPP1",23,0) K XX Q "RTN","DGRPP1",24,0) ; "RTN","DGRPP1",25,0) JUMP ;jump screens (^N) "RTN","DGRPP1",26,0) S X=+$E(DGRPANN,2,99),X1=$E(DGRPVV,X) I X1]"",'X1 G:X'=1.1 @("^DGRP"_X) G:X=1.1 ^DGRPCADD "RTN","DGRPP1",27,0) S Z="INVALID SCREEN NUMBER...VALID SCREENS ARE " F I=1,1.1,2:1:DGRPLAST I '$E(DGRPVV,I) S Z=Z_$S(I=DGRPLAST:" and ",1:"")_I_$S(I"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W "RTN","DGRPU",5,0) I DGRPS=1.1 W @IOF S Z="CONFIDENTIAL ADDRESS DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W "RTN","DGRPU",6,0) S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10) "RTN","DGRPU",7,0) I '$D(DGRPH) W !,$P(X,"^",1),"; ",SSN S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X "RTN","DGRPU",8,0) S X="",$P(X,"=",80)="" W !,X Q "RTN","DGRPU",9,0) Q "RTN","DGRPU",10,0) AL(DGLEN) ;DGLEN= Available length of line "RTN","DGRPU",11,0) A ;Format address(es) "RTN","DGRPU",12,0) I '$D(DGLEN) N DGLEN S DGLEN=29 "RTN","DGRPU",13,0) N DGX "RTN","DGRPU",14,0) F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S DGA(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2 "RTN","DGRPU",15,0) I DGA2=1 S DGA(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2 "RTN","DGRPU",16,0) S J=$S('$D(^DIC(5,+$P(DGRP(DGAD),U,DGA1+4),0)):"",('$L($P(^(0),U,2))):$P(^(0),U,1),1:$P(^(0),U,2)),J(1)=$P(DGRP(DGAD),U,DGA1+3),J(2)=$P(DGRP(DGAD),U,DGA1+5),DGA(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE") "RTN","DGRPU",17,0) I ".33^.34^.211^.331^.311^.25^.21"[DGAD D "RTN","DGRPU",18,0) .F I=1:1:7 I $P(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD S DGX=$P($G(^DPT(DFN,.22)),U,I) "RTN","DGRPU",19,0) E D "RTN","DGRPU",20,0) .I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q "RTN","DGRPU",21,0) .S DGX=$P(DGRP(DGAD),U,DGA1+11) "RTN","DGRPU",22,0) S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9) "RTN","DGRPU",23,0) S DGA(DGA2)=$E($P(DGA(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(DGA(DGA2),",",2)):",",1:"")_$P(DGA(DGA2),",",2)_" "_DGX "RTN","DGRPU",24,0) F I=0:0 S I=$O(DGA(I)) Q:'I S DGA(I)=$E(DGA(I),1,DGLEN) "RTN","DGRPU",25,0) K DGA1,I,J "RTN","DGRPU",26,0) Q "RTN","DGRPU",27,0) ; "RTN","DGRPU",28,0) W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q "RTN","DGRPU",29,0) W ?X,@DGVI,Z,@DGVO "RTN","DGRPU",30,0) Q "RTN","DGRPU",31,0) ; "RTN","DGRPU",32,0) H1 ; "RTN","DGRPU",33,0) ;;PATIENT DEMOGRAPHIC DATA "RTN","DGRPU",34,0) ;;PATIENT DATA "RTN","DGRPU",35,0) ;;EMERGENCY CONTACT DATA "RTN","DGRPU",36,0) ;;APPLICANT/SPOUSE EMPLOYMENT DATA "RTN","DGRPU",37,0) ;;INSURANCE DATA "RTN","DGRPU",38,0) ;;MILITARY SERVICE DATA "RTN","DGRPU",39,0) ;;ELIGIBILITY STATUS DATA "RTN","DGRPU",40,0) ;;FAMILY DEMOGRAPHIC DATA "RTN","DGRPU",41,0) ;;INCOME SCREENING DATA "RTN","DGRPU",42,0) ;;INELIGIBLE/MISSING DATA "RTN","DGRPU",43,0) ;;ELIGIBILITY VERIFICATION DATA "RTN","DGRPU",44,0) ;;ADMISSION INFORMATION "RTN","DGRPU",45,0) ;;APPLICATION INFORMATION "RTN","DGRPU",46,0) ;;APPOINTMENT INFORMATION "RTN","DGRPU",47,0) ;;SPONSOR DEMOGRAPHIC INFORMATION "RTN","DGRPU",48,0) ; "RTN","DGRPU",49,0) ; "RTN","DGRPU",50,0) INCOME(DFN,DGDT) ; compute income for veteran...if not in 408.21, pass back file 2 data "RTN","DGRPU",51,0) ; (called by PTF) "RTN","DGRPU",52,0) ; "RTN","DGRPU",53,0) ; "RTN","DGRPU",54,0) ; Input: DFN as IEN of PATIENT file "RTN","DGRPU",55,0) ; DGDT as date to return income as of "RTN","DGRPU",56,0) ; "RTN","DGRPU",57,0) ; Output: total income (computed function) "RTN","DGRPU",58,0) ; (from 408.21 if available...otherwise from file 2) "RTN","DGRPU",59,0) ; "RTN","DGRPU",60,0) ; "RTN","DGRPU",61,0) N DGDEP,DGINC,DGREL,DGTOT,DGX,I S DGTOT=0 "RTN","DGRPU",62,0) D ALL^DGMTU21(DFN,"V",DGDT,"I") "RTN","DGRPU",63,0) S DGX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I DGX]"" F I=8:1:17 S DGTOT=DGTOT+$P(DGX,"^",I) "RTN","DGRPU",64,0) I DGX']"" S DGTOT=$P($G(^DPT(DFN,.362)),U,20) "RTN","DGRPU",65,0) Q DGTOT "RTN","DGRPU",66,0) ; "RTN","DGRPU",67,0) ; "RTN","DGRPU",68,0) MTCOMP(DFN,DGDT) ; is current means test OR COPAY complete? "RTN","DGRPU",69,0) ; "RTN","DGRPU",70,0) ; Input: DFN as IEN of PATIENT file "RTN","DGRPU",71,0) ; DGDT as 'as of' date "RTN","DGRPU",72,0) ; "RTN","DGRPU",73,0) ; Output: 1 if means test/COPAY for year prior to DT passed is complete "RTN","DGRPU",74,0) ; 0 otherwise "RTN","DGRPU",75,0) ; DGMTYPT 1=MT;2=CP;0=NONE "RTN","DGRPU",76,0) ; "RTN","DGRPU",77,0) N COMP,MT,X,YR "RTN","DGRPU",78,0) S YR=$$LYR^DGMTSCU1(DGDT),MT=$$LST^DGMTCOU1(DFN,DGDT) "RTN","DGRPU",79,0) S DGMTYPT=+$P(MT,U,5) "RTN","DGRPU",80,0) S COMP=1 "RTN","DGRPU",81,0) I DGMTYPT=1 D ;MT "RTN","DGRPU",82,0) .I $P(MT,"^",4)']""!("^R^N^"[("^"_$P(MT,"^",4)_"^")) S COMP=0 "RTN","DGRPU",83,0) I DGMTYPT=2 D ;CP "RTN","DGRPU",84,0) .I $P(MT,"^",4)']""!("^I^L^"[("^"_$P(MT,"^",4)_"^")) S COMP=0 "RTN","DGRPU",85,0) S X=+$P(MT,"^",2) I ($E(X,1,3)-1)*100004 S X=132 X ^%ZOSF("RM") "RTN","DGRPV",20,0) S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1) "RTN","DGRPV",21,0) SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0 "RTN","DGRPV",22,0) S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0 "RTN","DGRPV",23,0) I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10")) "RTN","DGRPV",24,0) ; "RTN","DGRPV",25,0) S DGPH=$P($G(^DPT(DFN,.53)),U) ;Purple Heart Indicator "RTN","DGRPV",26,0) I $G(DGPRFLG)=1 D "RTN","DGRPV",27,0) . S DGRPVV="000001111111111" "RTN","DGRPV",28,0) E D "RTN","DGRPV",29,0) . S DGRPVV="000000000000000" "RTN","DGRPV",30,0) S X="5^3^5^2^3^17^4^2^10^2^4^5^5^2^1" "RTN","DGRPV",31,0) F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J)) "RTN","DGRPV",32,0) S DGRPVV(1.1)=0 "RTN","DGRPV",33,0) I $G(DGPH)]"" S $E(DGRPVV(6),16)=1 "RTN","DGRPV",34,0) I $$GETSTAT^DGNTAPI1(DFN)>2,'$D(^XUSEC("DGNT VERIFY",DUZ)) D "RTN","DGRPV",35,0) . S $E(DGRPVV(6),17)=1 "RTN","DGRPV",36,0) ; "RTN","DGRPV",37,0) F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99) "RTN","DGRPV",38,0) ; "RTN","DGRPV",39,0) ;-- if patient type is TRICARE then turn off screens 2,4 "RTN","DGRPV",40,0) I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99) "RTN","DGRPV",41,0) ; "RTN","DGRPV",42,0) F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99) "RTN","DGRPV",43,0) I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99) "RTN","DGRPV",44,0) K DIRUT,DUOUT,DTOUT "RTN","DGRPV",45,0) ; "RTN","DGRPV",46,0) ;Fields are numbered screen_item and put in that piece position. "RTN","DGRPV",47,0) ;Because FM does not allow more than 100 pieces on a node, it was "RTN","DGRPV",48,0) ;necessary to start a new node E10 for fields on screens 10 or higher. "RTN","DGRPV",49,0) ;In these instances, the piece position will be screen_item-100 so, "RTN","DGRPV",50,0) ;for example, screen 11, item 2 would be field 112, but piece 12. "RTN","DGRPV",51,0) ;Items on screens <10 will be found on node E. "RTN","DGRPV",52,0) ; "RTN","DGRPV",53,0) F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99) "RTN","DGRPV",54,0) ; "RTN","DGRPV",55,0) I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip "RTN","DGRPV",56,0) F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPV",57,0) S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob "RTN","DGRPV",58,0) I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data "RTN","DGRPV",59,0) I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=11111111111111111 ;if service data verified, can't edit service screen "RTN","DGRPV",60,0) ; "RTN","DGRPV",61,0) ELVER ;set up variables for eligibility verification "RTN","DGRPV",62,0) ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10, "RTN","DGRPV",63,0) ; and 11 if they're turned on). "RTN","DGRPV",64,0) ; "RTN","DGRPV",65,0) I $P($G(^DPT(DFN,.361)),U,3)="H" S DGRPVV(10)=10,DGRPVV(11)=1001 "RTN","DGRPV",66,0) S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15) "RTN","DGRPV",67,0) I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I "RTN","DGRPV",68,0) Q K DGRPSC,DGRPSCE "RTN","DGRPV",69,0) Q "RTN","DGRPV",70,0) ; "RTN","DGRPV",71,0) WW ;Write number on screens for display and/or edit (Z=number) "RTN","DGRPV",72,0) W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]") "RTN","DGRPV",73,0) I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO "RTN","DGRPV",74,0) I 'DGRPCM&($E(Z)'="[") W Z "RTN","DGRPV",75,0) Q "RTN","DGRPV",76,0) ; "RTN","DGRPV",77,0) WW1 ;spacing for screen display (Z=item to print) "RTN","DGRPV",78,0) F Z2=1:1:(Z1-$L(Z)) S Z=Z_" " "RTN","DGRPV",79,0) W Z K Z2 "RTN","DGRPV",80,0) Q "RTN","VADPT") 0^3^B16792484 "RTN","VADPT",1,0) VADPT ;ALB/MRL/MJK - RETURN PATIENT VARIABLE ARRAYS [DRIVER];07 DEC 1988 "RTN","VADPT",2,0) ;;5.3;Registration;**193,343,389,415,489**;Aug 13, 1993 "RTN","VADPT",3,0) ;DFN = Patient IFN [if not passed entire array returned as null] "RTN","VADPT",4,0) ; "RTN","VADPT",5,0) DEM ;Demographic Variables "RTN","VADPT",6,0) S VAN=1,VAN(1)=12,VAV="VADM" D ^VADPT0 Q "RTN","VADPT",7,0) ; "RTN","VADPT",8,0) OPD ;Other Patient Data "RTN","VADPT",9,0) S VAN=2,VAN(1)=7,VAV="VAPD" D ^VADPT0 Q "RTN","VADPT",10,0) ; "RTN","VADPT",11,0) ADD ;Current Address "RTN","VADPT",12,0) S VAN=3,VAN(1)=22,VAV="VAPA" D ^VADPT0 Q "RTN","VADPT",13,0) ; "RTN","VADPT",14,0) OAD ;Other Patient Variables "RTN","VADPT",15,0) S VAN=4,VAN(1)=11,VAV="VAOA" D ^VADPT0 Q "RTN","VADPT",16,0) ; "RTN","VADPT",17,0) INP ;Inpatient Data [pre-version 5] "RTN","VADPT",18,0) N VAINDTT S VAN=5,VAN(1)=11,VAV="VAIN",VAINDTT=$G(VAINDT) N VAINDT S:VAINDTT VAINDT=$$DATIM(VAINDTT) D ^VADPT0 Q "RTN","VADPT",19,0) ; "RTN","VADPT",20,0) IN5 ;Inpatient Data [v5.0 and above] "RTN","VADPT",21,0) N VAINDTT S VAN=6,VAN(1)=18,VAV=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")),VAINDTT=$G(VAIP("D")) S:$L(VAINDTT) VAIP("D")=VAINDTT S:VAINDTT VAIP("D")=$$DATIM(VAINDTT) D ^VADPT0 S:$L(VAINDTT) VAIP("D")=VAINDTT Q "RTN","VADPT",22,0) ; "RTN","VADPT",23,0) ELIG ;Eligibility Information "RTN","VADPT",24,0) S VAN=7,VAN(1)=9,VAV="VAEL" D ^VADPT0 Q "RTN","VADPT",25,0) ; "RTN","VADPT",26,0) MB ;Monetary Benefits "RTN","VADPT",27,0) S VAN=8,VAN(1)=9,VAV="VAMB" D ^VADPT0 Q "RTN","VADPT",28,0) ; "RTN","VADPT",29,0) SVC ;Service Information "RTN","VADPT",30,0) S VAN=9,VAN(1)=9,VAV="VASV" D ^VADPT0 Q "RTN","VADPT",31,0) ; "RTN","VADPT",32,0) REG ;Registration data "RTN","VADPT",33,0) S VAN=10,VAV="VARP" D ^VADPT0 Q "RTN","VADPT",34,0) ; "RTN","VADPT",35,0) SDE ;Enrollment Information "RTN","VADPT",36,0) S VAN=11,VAV="VAEN" D ^VADPT0 Q "RTN","VADPT",37,0) ; "RTN","VADPT",38,0) SDA ;Appointment Information "RTN","VADPT",39,0) S VAN=12,VAV="VASD" D ^VADPT0 Q "RTN","VADPT",40,0) ; "RTN","VADPT",41,0) PID ;Patient Id "RTN","VADPT",42,0) S VAN=13,VAV="VA" D ^VADPT0 Q "RTN","VADPT",43,0) ; "RTN","VADPT",44,0) TESTPAT(DFN) ;Test patient ? Returns 0 (No) or 1 (Yes) "RTN","VADPT",45,0) S DFN=+$G(DFN) I 'DFN Q 0 "RTN","VADPT",46,0) I $D(^DPT("ATEST",DFN)) Q 1 "RTN","VADPT",47,0) N NODE S NODE=$G(^DPT(DFN,0)) "RTN","VADPT",48,0) I $P(NODE,"^",21)=1 Q 1 "RTN","VADPT",49,0) I $E($P(NODE,"^",9),1,5)="00000" Q 1 "RTN","VADPT",50,0) Q 0 "RTN","VADPT",51,0) ; "RTN","VADPT",52,0) V5 S X=$S($D(^DG(43,1,"VERSION")):+^("VERSION"),1:""),VADPT("V")=$S(X<5:0,1:1) K X Q "RTN","VADPT",53,0) OERR ; "RTN","VADPT",54,0) 1 S VATAG=1 D MULT Q "RTN","VADPT",55,0) 2 S VATAG=2 D MULT Q "RTN","VADPT",56,0) 3 S VATAG=3 D MULT Q "RTN","VADPT",57,0) 4 S VATAG=4 D MULT Q "RTN","VADPT",58,0) 5 S VATAG=5 D MULT Q "RTN","VADPT",59,0) 6 S VATAG=6 D MULT Q "RTN","VADPT",60,0) 7 S VATAG=7 D MULT Q "RTN","VADPT",61,0) 8 S VATAG=8 D MULT Q "RTN","VADPT",62,0) 9 S VATAG=9 D MULT Q "RTN","VADPT",63,0) 10 S VATAG=10 D MULT Q "RTN","VADPT",64,0) 51 S VATAG=11 D MULT Q "RTN","VADPT",65,0) 52 S VATAG=12 D MULT Q "RTN","VADPT",66,0) 53 S VATAG=13 D MULT Q "RTN","VADPT",67,0) ALL S VATAG=14 D MULT Q "RTN","VADPT",68,0) A5 S VATAG=15 D MULT Q "RTN","VADPT",69,0) SEL Q:$O(VARRAY(0))']"" S VATAG=0,VATAG(2)=$P($T(TAG),";;",2) "RTN","VADPT",70,0) F VATAG(1)=0:0 S VATAG=$O(VARRAY(VATAG)) Q:VATAG="" I VATAG(2)[("^"_VATAG_"^") S VARRAY(VATAG)=1,VAROOT=$S($D(VAROOT(VATAG)):VAROOT(VATAG),1:"") D @VATAG "RTN","VADPT",71,0) G Q "RTN","VADPT",72,0) ; "RTN","VADPT",73,0) MULT S VATAG=$P($T(TG+VATAG),";;",2) "RTN","VADPT",74,0) F VATAG(1)=1:1 S VATAG(2)=$P(VATAG,"^",VATAG(1)) Q:VATAG(2)="" S VAROOT=$S($D(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"") D @(VATAG(2)) "RTN","VADPT",75,0) Q S VAROOT="" K:$D(VAROOT)'=11 VAROOT K VATAG Q "RTN","VADPT",76,0) ; "RTN","VADPT",77,0) KVA K VA "RTN","VADPT",78,0) KVAR D KVAR^VADPT0 K:$D(VAIP("V")) @(VAIP("V")) K I,X,Y,VARRAY,VADM,VAPD,VADPT,VAOA,VASV,VAEL,VAMB,VARP,VAEN,VASD,VAIN,VAIP,VAPA,VAHOW,VAINDT,VAERR,^UTILITY("VADPT",$J),VA200,VATEST Q "RTN","VADPT",79,0) DATIM(DATIM) ;If time not specified see if movement on that date "RTN","VADPT",80,0) Q:DATIM'?7N DATIM "RTN","VADPT",81,0) N A,B S A=$O(^DGPM("ADFN"_DFN,DATIM)),B=+$O(^(+A,0)) "RTN","VADPT",82,0) I 'A Q DATIM "RTN","VADPT",83,0) I $P($G(^DGPM(+B,0)),"^",2)=3 Q DATIM ;Next movement is discharge "RTN","VADPT",84,0) F Q:"^4^5^7^"'[(U_$P($G(^DGPM(+B,0)),"^",2)) S A=$O(^DGPM("ADFN"_DFN,A)),B=+$O(^(+A,0)) I $E(A,1,7)'=DATIM Q "RTN","VADPT",85,0) I 'A Q DATIM "RTN","VADPT",86,0) I $E(A,1,7)'=DATIM Q DATIM "RTN","VADPT",87,0) Q A "RTN","VADPT",88,0) ; "RTN","VADPT",89,0) TG ; "RTN","VADPT",90,0) ;;DEM^INP "RTN","VADPT",91,0) ;;DEM^ELIG "RTN","VADPT",92,0) ;;ELIG^INP "RTN","VADPT",93,0) ;;DEM^ADD "RTN","VADPT",94,0) ;;ADD^INP "RTN","VADPT",95,0) ;;DEM^ELIG^ADD "RTN","VADPT",96,0) ;;ELIG^SVC "RTN","VADPT",97,0) ;;ELIG^SVC^MB "RTN","VADPT",98,0) ;;DEM^REG^SDE^SDA "RTN","VADPT",99,0) ;;SDE^SDA "RTN","VADPT",100,0) ;;DEM^IN5 "RTN","VADPT",101,0) ;;ELIG^IN5 "RTN","VADPT",102,0) ;;ADD^IN5 "RTN","VADPT",103,0) ;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA "RTN","VADPT",104,0) ;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA "RTN","VADPT",105,0) ; "RTN","VADPT",106,0) TAG ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^ "RTN","VADPT0") 0^1^B11949293 "RTN","VADPT0",1,0) VADPT0 ;ALB/MRL/MJK - PATIENT VARIABLE ROUTINE DRIVER, CONT.; 12 DEC 1988 "RTN","VADPT0",2,0) ;;5.3;Registration;**343,342,415,489**;Aug 13, 1993 "RTN","VADPT0",3,0) ; "RTN","VADPT0",4,0) ;Initialize variables "RTN","VADPT0",5,0) N I1 "RTN","VADPT0",6,0) S U="^" D DT^DICRW:'$D(DT) "RTN","VADPT0",7,0) S VAERR=$S('$D(DFN)#2:1,'$D(^DPT(DFN,0)):1,1:0) "RTN","VADPT0",8,0) S Y=VAN'=13 I Y,$D(VAROOT)'[0,VAROOT]"" S Y=0,VAV=VAROOT K @VAV "RTN","VADPT0",9,0) I Y S:$S(VAN>9:1,'$D(VAHOW):0,1:VAHOW[2) VAV="^UTILITY("_""""_VAV_""""_","_$J_")" "RTN","VADPT0",10,0) D @VAN "RTN","VADPT0",11,0) Q K X,Y,VAC,VAS,VAV,VAW,VAN,I,VAX,VAZ Q "RTN","VADPT0",12,0) ; "RTN","VADPT0",13,0) INIT ; -- determine #'s or names then init array "RTN","VADPT0",14,0) ; "RTN","VADPT0",15,0) S VAS="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18^19^20^21^22" "RTN","VADPT0",16,0) I VAN<10,$D(VAHOW),VAHOW[1 S VAS=$P($T(SS+VAN),";;",2) "RTN","VADPT0",17,0) I $D(VAN(1)) F I=1:1:VAN(1) S @VAV@($P(VAS,"^",I))="" "RTN","VADPT0",18,0) Q "RTN","VADPT0",19,0) ; "RTN","VADPT0",20,0) 1 ; -- [DEM] demos "RTN","VADPT0",21,0) D C1,INIT I 'VAERR D 1^VADPT1,13 Q "RTN","VADPT0",22,0) ; "RTN","VADPT0",23,0) 2 ; -- [OPD] other pt vars "RTN","VADPT0",24,0) D C2,INIT,2^VADPT1:'VAERR Q "RTN","VADPT0",25,0) ; "RTN","VADPT0",26,0) 3 ; -- [ADD] current address "RTN","VADPT0",27,0) D C3,INIT,3^VADPT1:'VAERR Q "RTN","VADPT0",28,0) ; "RTN","VADPT0",29,0) 4 ; -- [OAD] other pt vars "RTN","VADPT0",30,0) D C4,INIT,4^VADPT1:'VAERR Q "RTN","VADPT0",31,0) ; "RTN","VADPT0",32,0) 5 ; -- [INP] inpt data -v5 "RTN","VADPT0",33,0) D C5,INIT,5^VADPT2:'VAERR Q "RTN","VADPT0",34,0) ; "RTN","VADPT0",35,0) 6 ; -- [IN5] inpt data v5 "RTN","VADPT0",36,0) D C6,INIT F I=13:1:17 F I1=1:1:7 S @VAV@($P(VAS,"^",I),I1)="" "RTN","VADPT0",37,0) D 6^VADPT3:'VAERR Q "RTN","VADPT0",38,0) ; "RTN","VADPT0",39,0) 7 ; -- [ELIG] elig data "RTN","VADPT0",40,0) D C7,INIT F I=1:1:6 S @VAV@($P(VAS,"^",5),I)="" "RTN","VADPT0",41,0) D 7^VADPT4:'VAERR Q "RTN","VADPT0",42,0) ; "RTN","VADPT0",43,0) 8 ; -- [MB] $ benefits "RTN","VADPT0",44,0) D C8,INIT D 8^VADPT4:'VAERR Q "RTN","VADPT0",45,0) ; "RTN","VADPT0",46,0) 9 ; -- [SVC] service data "RTN","VADPT0",47,0) D C9,INIT F I=1:1:9 S @VAV@($P(VAS,"^",I),1)="",@VAV@($P(VAS,"^",I),2)="" "RTN","VADPT0",48,0) S @VAV@($P(VAS,"^",4),3)="",@VAV@($P(VAS,"^",5),3)="" "RTN","VADPT0",49,0) F I=2,6,7,8 F I1=3,4,5 S @VAV@($P(VAS,"^",I),I1)="" "RTN","VADPT0",50,0) D 9^VADPT4:'VAERR Q "RTN","VADPT0",51,0) ; "RTN","VADPT0",52,0) 10 ; -- [REG] registration data "RTN","VADPT0",53,0) D C10,INIT D 10^VADPT5:'VAERR Q "RTN","VADPT0",54,0) ; "RTN","VADPT0",55,0) 11 ; -- [SDE] clinic enrollment data "RTN","VADPT0",56,0) D C11,INIT D 11^VADPT5:'VAERR Q "RTN","VADPT0",57,0) ; "RTN","VADPT0",58,0) 12 ; -- [SDA] appt data "RTN","VADPT0",59,0) D C12,INIT D 12^VADPT5:'VAERR Q "RTN","VADPT0",60,0) ; "RTN","VADPT0",61,0) 13 ; -- [PID] pt id's "RTN","VADPT0",62,0) S (VA("PID"),VA("BID"))="" D 13^VADPT6:'VAERR Q "RTN","VADPT0",63,0) ; "RTN","VADPT0",64,0) KVAR ; kill all vadpt data "RTN","VADPT0",65,0) K VAN "RTN","VADPT0",66,0) C1 K ^UTILITY("VADM",$J),VADM Q:$D(VAN) "RTN","VADPT0",67,0) C2 K ^UTILITY("VAPD",$J),VAPD Q:$D(VAN) "RTN","VADPT0",68,0) C3 K X S:$D(VAPA("P")) X("P")=VAPA("P") "RTN","VADPT0",69,0) S:$D(VAPA("CD")) X("CD")=VAPA("CD") "RTN","VADPT0",70,0) K ^UTILITY("VAPA",$J),VAPA "RTN","VADPT0",71,0) S:$D(X("P")) VAPA("P")=X("P") K X("P") "RTN","VADPT0",72,0) S:$D(X("CD")) VAPA("CD")=X("CD") K X Q:$D(VAN) "RTN","VADPT0",73,0) C4 K X S:$D(VAOA("A")) X("A")=VAOA("A") "RTN","VADPT0",74,0) K ^UTILITY("VAOA",$J),VAOA "RTN","VADPT0",75,0) S:$D(X("A")) VAOA("A")=X("A") K X Q:$D(VAN) "RTN","VADPT0",76,0) C5 K ^UTILITY("VAIN",$J),VAIN Q:$D(VAN) "RTN","VADPT0",77,0) C6 K X F I="D","E","L","M","V" I $D(VAIP(I)) S X(I)=VAIP(I) "RTN","VADPT0",78,0) S Y=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")) K ^UTILITY(Y,$J),@Y "RTN","VADPT0",79,0) F I="D","E","L","M","V" I $D(X(I)) S VAIP(I)=X(I) "RTN","VADPT0",80,0) K X Q:$D(VAN) "RTN","VADPT0",81,0) C7 K ^UTILITY("VAEL",$J),VAEL Q:$D(VAN) "RTN","VADPT0",82,0) C8 K ^UTILITY("VAMB",$J),VAMB Q:$D(VAN) "RTN","VADPT0",83,0) C9 K ^UTILITY("VASV",$J),VASV Q:$D(VAN) "RTN","VADPT0",84,0) C10 K ^UTILITY("VARP",$J) Q:$D(VAN) "RTN","VADPT0",85,0) C11 K ^UTILITY("VAEN",$J) Q:$D(VAN) "RTN","VADPT0",86,0) C12 K ^UTILITY("VASD",$J) Q "RTN","VADPT0",87,0) C13 Q "RTN","VADPT0",88,0) ; "RTN","VADPT0",89,0) SS ; 1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17^18^19^20^21^22 "RTN","VADPT0",90,0) ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS^ET^RC "RTN","VADPT0",91,0) ;;BC^BS^FN^MN^MM^OC^ES "RTN","VADPT0",92,0) ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE^Z4^CCA^CL1^CL2^CL3^CCI^CST^CZP^CCO^CCS^CCE^CTY "RTN","VADPT0",93,0) ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE^Z4 "RTN","VADPT0",94,0) ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT^AP "RTN","VADPT0",95,0) ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN^AP "RTN","VADPT0",96,0) ;;EL^PS^SC^VT^IN^TY^CN^ES^MT "RTN","VADPT0",97,0) ;;AA^HB^SS^PE^MR^SI^DI^OR^GI "RTN","VADPT0",98,0) ;;VN^AO^IR^PW^CS^S1^S2^S3^PH "RTN","VADPT1") 0^2^B36388475 "RTN","VADPT1",1,0) VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES; 08 DEC 1988 "RTN","VADPT1",2,0) ;;5.3;Registration;**415,489**;Aug 13, 1993 "RTN","VADPT1",3,0) 1 ;Demographic [DEM] "RTN","VADPT1",4,0) N W,Z,NODE "RTN","VADPT1",5,0) ; "RTN","VADPT1",6,0) ; -- name [1 - NM] "RTN","VADPT1",7,0) S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^") "RTN","VADPT1",8,0) ; "RTN","VADPT1",9,0) ; -- ssn [2 - SS] "RTN","VADPT1",10,0) S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"") "RTN","VADPT1",11,0) ; "RTN","VADPT1",12,0) ; -- date of birth [2 - DB] "RTN","VADPT1",13,0) S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y "RTN","VADPT1",14,0) ; "RTN","VADPT1",15,0) ; -- age [4 - AG] "RTN","VADPT1",16,0) S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7)) "RTN","VADPT1",17,0) ; "RTN","VADPT1",18,0) ; -- expired date [6 - EX] "RTN","VADPT1",19,0) S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y "RTN","VADPT1",20,0) ; "RTN","VADPT1",21,0) ; -- sex [5 - SX] "RTN","VADPT1",22,0) S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z "RTN","VADPT1",23,0) ; "RTN","VADPT1",24,0) ; -- remarks [7 - RE] "RTN","VADPT1",25,0) S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10) "RTN","VADPT1",26,0) ; "RTN","VADPT1",27,0) ; -- historic race [8 - RA] "RTN","VADPT1",28,0) S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",29,0) ; "RTN","VADPT1",30,0) ; -- religion [9 - RP] "RTN","VADPT1",31,0) S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",32,0) ; "RTN","VADPT1",33,0) ; -- marital status [10 - MS] "RTN","VADPT1",34,0) S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",35,0) ; "RTN","VADPT1",36,0) ; -- ethnicity [11 - ET] "RTN","VADPT1",37,0) S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X D "RTN","VADPT1",38,0) .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D "RTN","VADPT1",39,0) ..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1) "RTN","VADPT1",40,0) ..; -- collection method "RTN","VADPT1",41,0) ..S Z=$P(NODE,"^",2) "RTN","VADPT1",42,0) ..S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1) "RTN","VADPT1",43,0) S @VAV@($P(VAS,"^",11))=Y-1 "RTN","VADPT1",44,0) ; "RTN","VADPT1",45,0) ; -- race [12 - RC] "RTN","VADPT1",46,0) S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X D "RTN","VADPT1",47,0) .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D "RTN","VADPT1",48,0) ..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1) "RTN","VADPT1",49,0) ..; -- collection method "RTN","VADPT1",50,0) ..S Z=$P(NODE,"^",2) "RTN","VADPT1",51,0) ..S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1) "RTN","VADPT1",52,0) S @VAV@($P(VAS,"^",12))=Y-1 "RTN","VADPT1",53,0) Q "RTN","VADPT1",54,0) ; "RTN","VADPT1",55,0) 2 ;Other Patient Variables [OPD] "RTN","VADPT1",56,0) N W,Z "RTN","VADPT1",57,0) S VAX=^DPT(DFN,0) "RTN","VADPT1",58,0) ; "RTN","VADPT1",59,0) ; -- city of birth [1 - BC] "RTN","VADPT1",60,0) S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11) "RTN","VADPT1",61,0) ; "RTN","VADPT1",62,0) ; -- state of birth [2 - BS] "RTN","VADPT1",63,0) S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"") "RTN","VADPT1",64,0) ; "RTN","VADPT1",65,0) ; -- occupation [6 - OC] "RTN","VADPT1",66,0) S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7) "RTN","VADPT1",67,0) ; "RTN","VADPT1",68,0) ; -- names "RTN","VADPT1",69,0) S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"") "RTN","VADPT1",70,0) S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's [3 - FN] "RTN","VADPT1",71,0) S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's [4 - MN] "RTN","VADPT1",72,0) S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM] "RTN","VADPT1",73,0) ; "RTN","VADPT1",74,0) ; -- employment status [7 - ES] "RTN","VADPT1",75,0) S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN" "RTN","VADPT1",76,0) S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"") "RTN","VADPT1",77,0) Q "RTN","VADPT1",78,0) ; "RTN","VADPT1",79,0) 3 ;Address [ADD] "RTN","VADPT1",80,0) S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT) "RTN","VADPT1",81,0) I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)VAACTDT)!(VAEND&(VAEND6:1,1:0) S VAX=.21,VAOA("A")=7 "RTN","VADPT1",115,0) E S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A")) "RTN","VADPT1",116,0) S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99) "RTN","VADPT1",117,0) S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I) "RTN","VADPT1",118,0) S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8 "RTN","VADPT1",119,0) F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I) "RTN","VADPT1",120,0) I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))="" "RTN","VADPT1",121,0) S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1) "RTN","VADPT1",122,0) S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A")) "RTN","VADPT1",123,0) S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9)) "RTN","VADPT1",124,0) Q "UP",2,2.141,-1) 2^.14 "UP",2,2.141,0) 2.141 "VER") 8.0^22.0 "^DD",2,2,.141,0) CONFIDENTIAL ADDRESS CATEGORY^2.141S^^.14;0 "^DD",2,2,.141,21,0) ^.001^2^2^3030313^^^^ "^DD",2,2,.141,21,1,0) This is a multiple valued field containing the confidential address "^DD",2,2,.141,21,2,0) categories for this applicant. "^DD",2,2,.14105,0) CONFIDENTIAL ADDRESS ACTIVE?^RSX^Y:YES;N:NO;^.141;9^S DFN=DA I X="N" D CADD^DGLOCK3 "^DD",2,2,.14105,1,0) ^.1 "^DD",2,2,.14105,1,1,0) 2^AXR31^MUMPS "^DD",2,2,.14105,1,1,1) Q "^DD",2,2,.14105,1,1,2) S DGXRF=.14105 D ^DGDDC Q "^DD",2,2,.14105,1,1,"DT") 3030113 "^DD",2,2,.14105,3) Enter 'Y' if you want to enter or edit confidential address data. "^DD",2,2,.14105,21,0) ^.001^4^4^3030314^^^ "^DD",2,2,.14105,21,1,0) Enter 'Y' if you wish to enter a confidential address for this applicant "^DD",2,2,.14105,21,2,0) at this time. A 'NO' response will cause the Confidential Start Date "^DD",2,2,.14105,21,3,0) and Confidential End Date fields to be automatically deleted while other "^DD",2,2,.14105,21,4,0) confidential address information will remain on file for future use. "^DD",2,2,.14105,"DT") 3030314 "^DD",2,2,.1411,0) CONFIDENTIAL STREET [LINE 1]^FX^^.141;1^K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1411,1,0) ^.1 "^DD",2,2,.1411,1,1,0) 2^AXR32^MUMPS "^DD",2,2,.1411,1,1,1) Q "^DD",2,2,.1411,1,1,2) S DGXRF=.1411 D ^DGDDC Q "^DD",2,2,.1411,1,1,"DT") 3030113 "^DD",2,2,.1411,3) Enter the first line of the applicant's confidential street address [2-30 characters]. "^DD",2,2,.1411,21,0) ^^4^4^3030311^ "^DD",2,2,.1411,21,1,0) If the 'Confidential Address Active' prompt is answered YES, the "^DD",2,2,.1411,21,2,0) user will be prompted for the first line of the confidential street "^DD",2,2,.1411,21,3,0) address. This field cannot be deleted as long as the need for a "^DD",2,2,.1411,21,4,0) confidential address is indicated. "^DD",2,2,.1411,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1411,"DT") 3030113 "^DD",2,2,.14111,0) CONFIDENTIAL ADDRESS COUNTY^NJ3,0OX^^.141;11^N Z0,DIC S Z0=+$P($G(^DPT(D0,.141)),"^",5) K:'Z0 X Q:'$D(^DIC(5,Z0,1,0)) S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X "^DD",2,2,.14111,2) S Y(0)=Y N Z0 S Z0=+$P($G(^DPT(D0,.141)),"^",5) Q:'Z0 S Y=$P($G(^DIC(5,Z0,1,Y,0)),"^",3) "^DD",2,2,.14111,2.1) N Z0 S Z0=+$P($G(^DPT(D0,.141)),"^",5) Q:'Z0 S Y=$P($G(^DIC(5,Z0,1,Y,0)),"^",3) "^DD",2,2,.14111,3) Enter a valid county for the applicant's confidential address. "^DD",2,2,.14111,4) N Z0,DIC S X="?",Z0=+$P($G(^DPT(D0,.141)),"^",5) Q:'$D(^DIC(5,Z0,1,0)) S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC "^DD",2,2,.14111,21,0) ^.001^2^2^3030313^^ "^DD",2,2,.14111,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.14111,21,2,0) enter the county for the applicant's confidential address. "^DD",2,2,.14111,"DT") 3021212 "^DD",2,2,.1412,0) CONFIDENTIAL STREET [LINE 2]^FX^^.141;2^K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1412,1,0) ^.1 "^DD",2,2,.1412,1,1,0) 2^AXR33^MUMPS "^DD",2,2,.1412,1,1,1) Q "^DD",2,2,.1412,1,1,2) S DGXRF=.1412 D ^DGDDC Q "^DD",2,2,.1412,1,1,"DT") 3030113 "^DD",2,2,.1412,3) If necessary, enter the second line of this applicant's confidential address [2-30 characters]. "^DD",2,2,.1412,21,0) ^^4^4^3030311^ "^DD",2,2,.1412,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1412,21,2,0) the user will be prompted for the second line of the confidential "^DD",2,2,.1412,21,3,0) street address [2-30 characters]. The second line of the street "^DD",2,2,.1412,21,4,0) address is optional and may be left blank. "^DD",2,2,.1412,"DT") 3030113 "^DD",2,2,.1413,0) CONFIDENTIAL STREET [LINE 3]^FX^^.141;3^K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1413,3) If necessary, enter the third line of this applicant's confidential street address [2-30 characters] "^DD",2,2,.1413,21,0) ^^4^4^3030312^ "^DD",2,2,.1413,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1413,21,2,0) the user will be prompted for the third line of the confidential "^DD",2,2,.1413,21,3,0) street address. The third line of the street address is optional "^DD",2,2,.1413,21,4,0) and may be left blank. "^DD",2,2,.1413,"DT") 3030113 "^DD",2,2,.1414,0) CONFIDENTIAL ADDRESS CITY^FX^^.141;4^K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1414,3) Enter the city for the applicant's confidential address [2-30 characters]. "^DD",2,2,.1414,21,0) ^^4^4^3030311^ "^DD",2,2,.1414,21,1,0) If the 'Confidential Address Active' prompt is answered YES, enter "^DD",2,2,.1414,21,2,0) the confidential address city for this applicant [2-30 characters]. "^DD",2,2,.1414,21,3,0) This field may not be deleted as long as the need for a confidential "^DD",2,2,.1414,21,4,0) address is indicated. "^DD",2,2,.1414,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1414,"DT") 3030113 "^DD",2,2,.1415,0) CONFIDENTIAL ADDRESS STATE^P5'X^DIC(5,^.141;5^S DFN=DA D CAD^DGLOCK3 Q "^DD",2,2,.1415,3) Enter the State for the applicant's confidential address. "^DD",2,2,.1415,21,0) ^^4^4^3030311^ "^DD",2,2,.1415,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1415,21,2,0) the user will be asked to select the confidential address state "^DD",2,2,.1415,21,3,0) from the available listing. This field may not be deleted as "^DD",2,2,.1415,21,4,0) long as the need for a confidential address is indicated. "^DD",2,2,.1415,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1415,"DT") 3030113 "^DD",2,2,.1416,0) CONFIDENTIAL ADDRESS ZIP CODE^FXO^^.141;6^K:$L(X)>20!($L(X)<5) X I $D(X) S DFN=DA D CAD^DGLOCK3 I $D(X) D ZIPIN^VAFADDR "^DD",2,2,.1416,2) S Y(0)=Y D ZIPOUT^VAFADDR "^DD",2,2,.1416,2.1) D ZIPOUT^VAFADDR "^DD",2,2,.1416,3) Answer with either the 5 digit or 9 digit zip code. "^DD",2,2,.1416,21,0) ^.001^4^4^3030314^^ "^DD",2,2,.1416,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1416,21,2,0) the user will be asked to enter the zip code assigned to the "^DD",2,2,.1416,21,3,0) city for the confidential address. This field may not be deleted "^DD",2,2,.1416,21,4,0) as long as the need for a confidential address is indicated. "^DD",2,2,.1416,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1416,"DT") 3030113 "^DD",2,2,.1417,0) CONFIDENTIAL START DATE^DX^^.141;7^S %DT="E",%DT(0)=DT D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D CAD^DGLOCK3 "^DD",2,2,.1417,3) Enter the date to begin contacting the applicant at the confidential address. Date cannot be in the past. "^DD",2,2,.1417,21,0) ^.001^3^3^3030314^^ "^DD",2,2,.1417,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2,.1417,21,2,0) enter the date to begin contacting the applicant at the "^DD",2,2,.1417,21,3,0) confidential address. "^DD",2,2,.1417,"DEL",1,0) S DFN=DA D CADD1^DGLOCK3 I '$D(X) "^DD",2,2,.1417,"DT") 3030220 "^DD",2,2,.1418,0) CONFIDENTIAL END DATE^DX^^.141;8^S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D CAD^DGLOCK3 I $D(X),(X<$P(^DPT(DFN,.141),"^",7)) K X "^DD",2,2,.1418,3) Enter the date the applicant will no longer be contacted at the confidential address. End date must be after start date. "^DD",2,2,.1418,21,0) ^.001^2^2^3030314^^ "^DD",2,2,.1418,21,1,0) If the 'Confidential Address Active' prompt is answered YES, enter "^DD",2,2,.1418,21,2,0) the date the applicant will no longer be contacted at this address. "^DD",2,2,.1418,"DT") 3030113 "^DD",2,2.141,0) CONFIDENTIAL ADDRESS CATEGORY SUB-FIELD^^1^2 "^DD",2,2.141,0,"DT") 3030108 "^DD",2,2.141,0,"IX","B",2.141,.01) "^DD",2,2.141,0,"NM","CONFIDENTIAL ADDRESS CATEGORY") "^DD",2,2.141,0,"UP") 2 "^DD",2,2.141,.01,0) CONFIDENTIAL ADDRESS CATEGORY^MS^1:ELIGIBILITY/ENROLLMENT;2:APPOINTMENT/SCHEDULING;3:COPAYMENTS/VETERAN BILLING;4:MEDICAL RECORDS;5:ALL OTHERS;^0;1^Q "^DD",2,2.141,.01,.1) "^DD",2,2.141,.01,1,0) ^.1 "^DD",2,2.141,.01,1,1,0) 2.141^B "^DD",2,2.141,.01,1,1,1) S ^DPT(DA(1),.14,"B",$E(X,1,30),DA)="" "^DD",2,2.141,.01,1,1,2) K ^DPT(DA(1),.14,"B",$E(X,1,30),DA) "^DD",2,2.141,.01,3) Enter the confidential address category for the applicant's confidential communications. "^DD",2,2.141,.01,21,0) ^.001^3^3^3030313^^ "^DD",2,2.141,.01,21,1,0) If the 'Confidential Address Active' prompt is answered YES, "^DD",2,2.141,.01,21,2,0) select the confidential address category for this applicant's "^DD",2,2.141,.01,21,3,0) confidential communications. "^DD",2,2.141,.01,"DT") 3030311 "^DD",2,2.141,1,0) CONFIDENTIAL CATEGORY ACTIVE^S^Y:YES;N:NO;^0;2^Q "^DD",2,2.141,1,3) Enter Yes if the confidential address category for the applicant's confidential communications is active. "^DD",2,2.141,1,21,0) ^.001^3^3^3030313^^ "^DD",2,2.141,1,21,1,0) If the applicant's confidential communications for this category should "^DD",2,2.141,1,21,2,0) be sent to the confidential address, Confidential Category Active field "^DD",2,2.141,1,21,3,0) should be set to yes. If not, select N or No. "^DD",2,2.141,1,"DT") 3021216 **END** **END**