KIDS Distribution saved on Jan 07, 2021@12:36:46 DG*5.3*1018 **KIDS**:DG*5.3*1018^ **INSTALL NAME** DG*5.3*1018 "BLD",11541,0) DG*5.3*1018^REGISTRATION^0^3210107^y "BLD",11541,1,0) ^^2^2^3201215^ "BLD",11541,1,1,0) Please see the DG*5.3*1018 patch description for detailed information "BLD",11541,1,2,0) regarding this patch. "BLD",11541,4,0) ^9.64PA^43^3 "BLD",11541,4,2,0) 2 "BLD",11541,4,2,2,0) ^9.641^2^1 "BLD",11541,4,2,2,2,0) PATIENT (File-top level) "BLD",11541,4,2,2,2,1,0) ^9.6411^.32102^2 "BLD",11541,4,2,2,2,1,.32102,0) AGENT ORANGE EXPOS. INDICATED? "BLD",11541,4,2,2,2,1,.3213,0) AGENT ORANGE EXPOSURE LOCATION "BLD",11541,4,2,222) y^n^p^^^^n^^n "BLD",11541,4,2,224) "BLD",11541,4,27.11,0) 27.11 "BLD",11541,4,27.11,2,0) ^9.641^27.11^1 "BLD",11541,4,27.11,2,27.11,0) PATIENT ENROLLMENT (File-top level) "BLD",11541,4,27.11,2,27.11,1,0) ^9.6411^50.22^1 "BLD",11541,4,27.11,2,27.11,1,50.22,0) AGENT ORANGE EXPOSURE LOCATION "BLD",11541,4,27.11,222) y^n^p^^^^n^^n "BLD",11541,4,27.11,224) "BLD",11541,4,43,0) 43 "BLD",11541,4,43,2,0) ^9.641^43^1 "BLD",11541,4,43,2,43,0) MAS PARAMETERS (File-top level) "BLD",11541,4,43,2,43,1,0) ^9.6411^1402^1 "BLD",11541,4,43,2,43,1,1402,0) BWN ACTIVE DATE "BLD",11541,4,43,222) y^n^p^^^^n^^n "BLD",11541,4,43,224) "BLD",11541,4,"APDD",2,2) "BLD",11541,4,"APDD",2,2,.32102) "BLD",11541,4,"APDD",2,2,.3213) "BLD",11541,4,"APDD",27.11,27.11) "BLD",11541,4,"APDD",27.11,27.11,50.22) "BLD",11541,4,"APDD",43,43) "BLD",11541,4,"APDD",43,43,1402) "BLD",11541,4,"B",2,2) "BLD",11541,4,"B",27.11,27.11) "BLD",11541,4,"B",43,43) "BLD",11541,6) 2 "BLD",11541,6.3) 5 "BLD",11541,"ABPKG") n "BLD",11541,"INID") ^y "BLD",11541,"INIT") EN^DG531018P "BLD",11541,"KRN",0) ^9.67PA^1.5^25 "BLD",11541,"KRN",.4,0) .4 "BLD",11541,"KRN",.401,0) .401 "BLD",11541,"KRN",.402,0) .402 "BLD",11541,"KRN",.403,0) .403 "BLD",11541,"KRN",.5,0) .5 "BLD",11541,"KRN",.84,0) .84 "BLD",11541,"KRN",1.5,0) 1.5 "BLD",11541,"KRN",1.6,0) 1.6 "BLD",11541,"KRN",1.61,0) 1.61 "BLD",11541,"KRN",1.62,0) 1.62 "BLD",11541,"KRN",3.6,0) 3.6 "BLD",11541,"KRN",3.8,0) 3.8 "BLD",11541,"KRN",9.2,0) 9.2 "BLD",11541,"KRN",9.8,0) 9.8 "BLD",11541,"KRN",9.8,"NM",0) ^9.68A^6^6 "BLD",11541,"KRN",9.8,"NM",1,0) DGENEGT1^^0^B70366781 "BLD",11541,"KRN",9.8,"NM",2,0) DGENELA4^^0^B86716569 "BLD",11541,"KRN",9.8,"NM",3,0) DGENUPL9^^0^B8131378 "BLD",11541,"KRN",9.8,"NM",4,0) DGRP6EF^^0^B33525270 "BLD",11541,"KRN",9.8,"NM",5,0) VAFHLZE1^^0^B33057349 "BLD",11541,"KRN",9.8,"NM",6,0) VADPT4^^0^B45245158 "BLD",11541,"KRN",9.8,"NM","B","DGENEGT1",1) "BLD",11541,"KRN",9.8,"NM","B","DGENELA4",2) "BLD",11541,"KRN",9.8,"NM","B","DGENUPL9",3) "BLD",11541,"KRN",9.8,"NM","B","DGRP6EF",4) "BLD",11541,"KRN",9.8,"NM","B","VADPT4",6) "BLD",11541,"KRN",9.8,"NM","B","VAFHLZE1",5) "BLD",11541,"KRN",19,0) 19 "BLD",11541,"KRN",19.1,0) 19.1 "BLD",11541,"KRN",101,0) 101 "BLD",11541,"KRN",409.61,0) 409.61 "BLD",11541,"KRN",771,0) 771 "BLD",11541,"KRN",779.2,0) 779.2 "BLD",11541,"KRN",870,0) 870 "BLD",11541,"KRN",8989.51,0) 8989.51 "BLD",11541,"KRN",8989.52,0) 8989.52 "BLD",11541,"KRN",8993,0) 8993 "BLD",11541,"KRN",8994,0) 8994 "BLD",11541,"KRN","B",.4,.4) "BLD",11541,"KRN","B",.401,.401) "BLD",11541,"KRN","B",.402,.402) "BLD",11541,"KRN","B",.403,.403) "BLD",11541,"KRN","B",.5,.5) "BLD",11541,"KRN","B",.84,.84) "BLD",11541,"KRN","B",1.5,1.5) "BLD",11541,"KRN","B",1.6,1.6) "BLD",11541,"KRN","B",1.61,1.61) "BLD",11541,"KRN","B",1.62,1.62) "BLD",11541,"KRN","B",3.6,3.6) "BLD",11541,"KRN","B",3.8,3.8) "BLD",11541,"KRN","B",9.2,9.2) "BLD",11541,"KRN","B",9.8,9.8) "BLD",11541,"KRN","B",19,19) "BLD",11541,"KRN","B",19.1,19.1) "BLD",11541,"KRN","B",101,101) "BLD",11541,"KRN","B",409.61,409.61) "BLD",11541,"KRN","B",771,771) "BLD",11541,"KRN","B",779.2,779.2) "BLD",11541,"KRN","B",870,870) "BLD",11541,"KRN","B",8989.51,8989.51) "BLD",11541,"KRN","B",8989.52,8989.52) "BLD",11541,"KRN","B",8993,8993) "BLD",11541,"KRN","B",8994,8994) "BLD",11541,"QDEF") ^^^^NO^^^^NO^^YES "BLD",11541,"QUES",0) ^9.62^^ "BLD",11541,"REQB",0) ^9.611^3^3 "BLD",11541,"REQB",1,0) DG*5.3*993^1 "BLD",11541,"REQB",2,0) DG*5.3*1014^1 "BLD",11541,"REQB",3,0) DG*5.3*1007^1 "BLD",11541,"REQB","B","DG*5.3*1007",3) "BLD",11541,"REQB","B","DG*5.3*1014",2) "BLD",11541,"REQB","B","DG*5.3*993",1) "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^n^p^^^^n^^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,.32102) "FIA",2,2,.3213) "FIA",27.11) PATIENT ENROLLMENT "FIA",27.11,0) ^DGEN(27.11, "FIA",27.11,0,0) 27.11OID "FIA",27.11,0,1) y^n^p^^^^n^^n "FIA",27.11,0,10) "FIA",27.11,0,11) "FIA",27.11,0,"RLRO") "FIA",27.11,0,"VR") 5.3^DG "FIA",27.11,27.11) 1 "FIA",27.11,27.11,50.22) "FIA",43) MAS PARAMETERS "FIA",43,0) ^DG(43, "FIA",43,0,0) 43 "FIA",43,0,1) y^n^p^^^^n^^n "FIA",43,0,10) "FIA",43,0,11) "FIA",43,0,"RLRO") "FIA",43,0,"VR") 5.3^DG "FIA",43,43) 1 "FIA",43,43,1402) "INIT") EN^DG531018P "MBREQ") 0 "PKG",47,-1) 1^1 "PKG",47,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",47,22,0) ^9.49I^1^1 "PKG",47,22,1,0) 5.3^2930813^2960613 "PKG",47,22,1,"PAH",1,0) 1018^3210107 "PKG",47,22,1,"PAH",1,1,0) ^^2^2^3210107 "PKG",47,22,1,"PAH",1,1,1,0) Please see the DG*5.3*1018 patch description for detailed information "PKG",47,22,1,"PAH",1,1,2,0) regarding this patch. "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") NO "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") NO "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") 7 "RTN","DG531018P") 0^^B3117216 "RTN","DG531018P",1,0) DG531018P ;ALB/JAM - DG*5.3*1018 POST-INSTALL ROUTINE ;12/03/20 9:49am "RTN","DG531018P",2,0) ;;5.3;Registration;**1018**;Aug 13, 1993;Build 5 "RTN","DG531018P",3,0) ; "RTN","DG531018P",4,0) ; Integration Agreements: "RTN","DG531018P",5,0) ; 10141 : BMES^XPDUTL "RTN","DG531018P",6,0) ; : MES^XPDUTL "RTN","DG531018P",7,0) ; 3352 : Provides the use of DIEZ^DIKCUTL3 to recompile all compiled input templates that contain specific fields. "RTN","DG531018P",8,0) ; "RTN","DG531018P",9,0) ; This post-install does the following: "RTN","DG531018P",10,0) ; - Set the BWN ACTIVE DATE field #1402 in the MAS PARAMETERS file #43 "RTN","DG531018P",11,0) ; - Compiles all input templates that include the AGENT ORANGE EXPOSURE LOCATION field #.3213 (in the PATIENT file #2) "RTN","DG531018P",12,0) Q "RTN","DG531018P",13,0) ; "RTN","DG531018P",14,0) EN ; Entry point for post-install "RTN","DG531018P",15,0) D BMES^XPDUTL(">>> Patch DG*5.3*1018 - Post-install begin...") "RTN","DG531018P",16,0) N DGFDA,DGERR,X,Y "RTN","DG531018P",17,0) ; "RTN","DG531018P",18,0) D BMES^XPDUTL(" o Set BWN ACTIVE DATE (#1402) field in MAS PARAMETERS (#43) file") "RTN","DG531018P",19,0) ; Set the active date (For readability, get internal date from external) "RTN","DG531018P",20,0) S X="05/10/2021" "RTN","DG531018P",21,0) D ^%DT "RTN","DG531018P",22,0) S DGFDA(43,"1,",1402)=Y "RTN","DG531018P",23,0) D FILE^DIE("","DGFDA","DGERR") "RTN","DG531018P",24,0) I '$D(DGERR) D MES^XPDUTL(" o BWN ACTIVE DATE (#1402) field set to "_$$GET1^DIQ(43,1,1402)) "RTN","DG531018P",25,0) I $D(DGERR) D "RTN","DG531018P",26,0) . D BMES^XPDUTL(" *** ERROR: "_DGERR("DIERR",1,"TEXT",1)) "RTN","DG531018P",27,0) . D MES^XPDUTL(" Please log YOUR IT Services ticket. ***") "RTN","DG531018P",28,0) ; "RTN","DG531018P",29,0) N DGFLD "RTN","DG531018P",30,0) D BMES^XPDUTL(" o Recompile all compiled input templates that contain field:") "RTN","DG531018P",31,0) D MES^XPDUTL(" - AGENT ORANGE EXPOSURE LOCATION (#.3213) field in PATIENT (#2) file") "RTN","DG531018P",32,0) ;build array of file and field numbers for top-level (#2) file fields being exported "RTN","DG531018P",33,0) ;array format: DGFLD(file#,field)="" "RTN","DG531018P",34,0) S DGFLD(2,.3213)="" "RTN","DG531018P",35,0) ;recompile all compiled input templates that contain the fields in the DGLFD array passed by reference "RTN","DG531018P",36,0) D DIEZ^DIKCUTL3(2,.DGFLD) "RTN","DG531018P",37,0) ; "RTN","DG531018P",38,0) D BMES^XPDUTL(">>> Patch DG*5.3*1018 - Post-install complete.") "RTN","DG531018P",39,0) Q "RTN","DGENEGT1") 0^1^B70366781 "RTN","DGENEGT1",1,0) DGENEGT1 ;ALB/KCL,ISA/KWP,LBD,RGL,BRM,DLF,TDM,KUM - Enrollment Group Threshold API's ; 6/17/09 11:05am "RTN","DGENEGT1",2,0) ;;5.3;Registration;**232,417,454,491,513,451,564,672,717,688,803,754,1018**;Aug 13, 1993;Build 5 "RTN","DGENEGT1",3,0) ; "RTN","DGENEGT1",4,0) ; "RTN","DGENEGT1",5,0) NOTIFY(DGEGT,OLDEGT) ; "RTN","DGENEGT1",6,0) ; Description: This is used to send a message to local mail group. "RTN","DGENEGT1",7,0) ; The notification is used to communicate changes in the Enrollment "RTN","DGENEGT1",8,0) ; Group Threshold (EGT) setting to users at the local site. "RTN","DGENEGT1",9,0) ; "RTN","DGENEGT1",10,0) ; Input: "RTN","DGENEGT1",11,0) ; DGEGT - the new Enrollment Group Threshold array, passed by reference "RTN","DGENEGT1",12,0) ; OLDEGT - the previous Enrollment Group Threshold array, passed by reference "RTN","DGENEGT1",13,0) ; "RTN","DGENEGT1",14,0) ; Output: None "RTN","DGENEGT1",15,0) ; "RTN","DGENEGT1",16,0) N TEXT,XMDUN,XMDUZ,XMTEXT,XMROU,XMSTRIP,XMSUB,XMY,XMZ,OLDPRI "RTN","DGENEGT1",17,0) ; "RTN","DGENEGT1",18,0) ; init subject and sender "RTN","DGENEGT1",19,0) S XMSUB="Enrollment Group Threshold (EGT) Changed" "RTN","DGENEGT1",20,0) S (XMDUN,XMDUZ)="Registration Enrollment Module" "RTN","DGENEGT1",21,0) ; "RTN","DGENEGT1",22,0) ; recipient "RTN","DGENEGT1",23,0) S XMY("G.DGEN EGT UPDATES")="" "RTN","DGENEGT1",24,0) ; "RTN","DGENEGT1",25,0) ; get old EGT priority "RTN","DGENEGT1",26,0) S OLDPRI=$G(OLDEGT("PRIORITY")) "RTN","DGENEGT1",27,0) ; "RTN","DGENEGT1",28,0) S XMTEXT="TEXT(" "RTN","DGENEGT1",29,0) S TEXT(1)="The Secretary of the VA has officially changed the enrollment priority" "RTN","DGENEGT1",30,0) S TEXT(2)="grouping of veterans who shall receive care. This change may place" "RTN","DGENEGT1",31,0) S TEXT(3)="veterans under your facilities care into a 'Not Enrolled' category." "RTN","DGENEGT1",32,0) S TEXT(4)="" "RTN","DGENEGT1",33,0) S TEXT(5)="" "RTN","DGENEGT1",34,0) S TEXT(6)=" Prior EGT Priority: "_$S($G(OLDPRI):$$EXTERNAL^DILFD(27.16,.02,"F",OLDPRI),1:"N/A")_$S($G(OLDEGT("SUBGRP")):$$EXTERNAL^DILFD(27.16,.03,"F",OLDEGT("SUBGRP")),1:"") "RTN","DGENEGT1",35,0) S TEXT(7)="" "RTN","DGENEGT1",36,0) S TEXT(8)="" "RTN","DGENEGT1",37,0) S TEXT(9)=" New Enrollment Group Threshold (EGT) Settings:" "RTN","DGENEGT1",38,0) S TEXT(10)="" "RTN","DGENEGT1",39,0) S TEXT(11)=" EGT Priority: "_$$EXTERNAL^DILFD(27.16,.02,"F",DGEGT("PRIORITY"))_$S($G(DGEGT("SUBGRP")):$$EXTERNAL^DILFD(27.16,.03,"F",DGEGT("SUBGRP")),1:"") "RTN","DGENEGT1",40,0) S TEXT(12)=" EGT Type: "_$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE")) "RTN","DGENEGT1",41,0) S TEXT(13)=" EGT Effective Date: "_$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("EFFDATE")) "RTN","DGENEGT1",42,0) ; "RTN","DGENEGT1",43,0) ; mailman deliverey "RTN","DGENEGT1",44,0) D ^XMD "RTN","DGENEGT1",45,0) ; "RTN","DGENEGT1",46,0) Q "RTN","DGENEGT1",47,0) ; "RTN","DGENEGT1",48,0) ; "RTN","DGENEGT1",49,0) DISPLAY() ; "RTN","DGENEGT1",50,0) ; Description: Display Enrollment Group Threshold (EGT) settings. "RTN","DGENEGT1",51,0) ; "RTN","DGENEGT1",52,0) N DGEGT "RTN","DGENEGT1",53,0) ; "RTN","DGENEGT1",54,0) W ! "RTN","DGENEGT1",55,0) I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.DGEGT) W !,"Enrollment Group Threshold (EGT) settings not found." "RTN","DGENEGT1",56,0) E D "RTN","DGENEGT1",57,0) .W !,?3,"Enrollment Group Threshold (EGT) Settings" "RTN","DGENEGT1",58,0) .W !,?3,"=========================================" "RTN","DGENEGT1",59,0) .W ! "RTN","DGENEGT1",60,0) .W !?5,"Date Entered",?25,": ",$S('$G(DGEGT("ENTERED")):"-none-",1:$$EXTERNAL^DILFD(27.16,.01,"F",DGEGT("ENTERED"))) "RTN","DGENEGT1",61,0) .W !?5,"EGT Priority",?25,": ",$S('$G(DGEGT("PRIORITY")):"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"F",DGEGT("PRIORITY")))_$S($G(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"F",DGEGT("SUBGRP"))) "RTN","DGENEGT1",62,0) .W !?5,"EGT Type",?25,": ",$S($G(DGEGT("TYPE"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.04,"F",DGEGT("TYPE"))) "RTN","DGENEGT1",63,0) .W !?5,"EGT Effective Date",?25,": ",$S('$G(DGEGT("EFFDATE")):"-none-",1:$$EXTERNAL^DILFD(27.16,.05,"F",DGEGT("EFFDATE"))) "RTN","DGENEGT1",64,0) ; "RTN","DGENEGT1",65,0) Q "RTN","DGENEGT1",66,0) ; "RTN","DGENEGT1",67,0) ABOVE(DPTDFN,ENRPRI,ENRGRP,EGTPRI,EGTGRP,EGTFLG) ; "RTN","DGENEGT1",68,0) ; Description: This function will determine if the enrollment is above "RTN","DGENEGT1",69,0) ; the threshold. "RTN","DGENEGT1",70,0) ; "RTN","DGENEGT1",71,0) ;Input: "RTN","DGENEGT1",72,0) ; DPTDFN - Patient File IEN "RTN","DGENEGT1",73,0) ; ENRPRI - Enrollment Priority "RTN","DGENEGT1",74,0) ; ENRGRP - Enrollment Sub-Group "RTN","DGENEGT1",75,0) ; EGTPRI - EGT Priority (optional) - not used "RTN","DGENEGT1",76,0) ; EGTGRP - EGT Sub-Group (optional) - not used "RTN","DGENEGT1",77,0) ; EGTFLG - Flag to bypass additional EGT type 2 check (optional) "RTN","DGENEGT1",78,0) ; It is used by $$ABOVE2 to prevent re-entering the "RTN","DGENEGT1",79,0) ; sub-priority API ($$SUBPRI^DGENELA4) "RTN","DGENEGT1",80,0) ; Output: "RTN","DGENEGT1",81,0) ; Returns 1 if above 0 below. "RTN","DGENEGT1",82,0) ; "RTN","DGENEGT1",83,0) I $G(ENRGRP)="" S ENRGRP="" "RTN","DGENEGT1",84,0) I $G(ENRPRI)="" S ENRPRI="" "RTN","DGENEGT1",85,0) N ABOVE,EGT,TODAY,X "RTN","DGENEGT1",86,0) I '$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) Q 1 "RTN","DGENEGT1",87,0) D NOW^%DTC S TODAY=X "RTN","DGENEGT1",88,0) I TODAYEGT("PRIORITY") S ABOVE=1 Q "RTN","DGENEGT1",96,0) .;do check for priorities 7 and 8 "RTN","DGENEGT1",97,0) .I ENRPRIEGT("SUBGRP") S ABOVE=1 Q "RTN","DGENEGT1",99,0) .I $$OVRRIDE(.DPTDFN,.EGT) S ABOVE=1 "RTN","DGENEGT1",100,0) ; "RTN","DGENEGT1",101,0) ;EGT types 1 & 3 "RTN","DGENEGT1",102,0) ;do check for priorities 7 and 8 "RTN","DGENEGT1",103,0) I ENRPRI>6&(ENRPRI=EGT("PRIORITY")) S ABOVE=0 D Q ABOVE "RTN","DGENEGT1",104,0) .I ENRGRP'>(EGT("SUBGRP")) S ABOVE=1 "RTN","DGENEGT1",105,0) I ENRPRI'>(EGT("PRIORITY")) Q 1 "RTN","DGENEGT1",106,0) Q 0 "RTN","DGENEGT1",107,0) ; "RTN","DGENEGT1",108,0) ABOVE2(DPTDFN,ENRDT,PRIORITY,SUBGRP) ; "RTN","DGENEGT1",109,0) ; "RTN","DGENEGT1",110,0) ; Input: DPTDFN - Patient File IEN "RTN","DGENEGT1",111,0) ; ENRDT - enrollment effective date "RTN","DGENEGT1",112,0) ; PRIORITY - enrollment priority "RTN","DGENEGT1",113,0) ; SUBGRP - enrollment sub-priority (internal numeric value) "RTN","DGENEGT1",114,0) ; "RTN","DGENEGT1",115,0) ; Output: 1 or 0 for above or below EGT threshold "RTN","DGENEGT1",116,0) ; "RTN","DGENEGT1",117,0) N ABOVE,TODAY,X,EGT "RTN","DGENEGT1",118,0) S ABOVE=1 "RTN","DGENEGT1",119,0) S:'$G(SUBGRP) SUBGRP="" "RTN","DGENEGT1",120,0) S:'$G(PRIORITY) PRIORITY="" "RTN","DGENEGT1",121,0) S:'$G(ENRDT) ENRDT="" "RTN","DGENEGT1",122,0) D NOW^%DTC S TODAY=X "RTN","DGENEGT1",123,0) Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(ENRDT),.EGT) 1 "RTN","DGENEGT1",124,0) Q:'$G(EGT("EFFDATE")) 1 "RTN","DGENEGT1",125,0) Q:TODAY0 "RTN","DGENEGT1",157,0) ; Check previous enrollment records for Application Date/Effective "RTN","DGENEGT1",158,0) ; Date and special CE rules "RTN","DGENEGT1",159,0) S (STOP,CE)=0 "RTN","DGENEGT1",160,0) F Q:STOP D "RTN","DGENEGT1",161,0) .I 'ENRIEN S STOP=1 Q ;cannot check if no current enrollment "RTN","DGENEGT1",162,0) .I '$$GET^DGENA(ENRIEN,.EGTENR) S STOP=1 Q ;need enr info to proceed "RTN","DGENEGT1",163,0) .S ENRIEN=$$FINDPRI^DGENA(ENRIEN) "RTN","DGENEGT1",164,0) .; If status is Pending, Deceased, Not Eligible; Ineligible Date, "RTN","DGENEGT1",165,0) .; or Not Applicable ignore record and get previous "RTN","DGENEGT1",166,0) .I "^6^15^16^17^18^19^20^21^23^"[(U_EGTENR("STATUS")_U) Q "RTN","DGENEGT1",167,0) .S ENRDT=$$EDATE($G(EGTENR("APP")),$G(EGTENR("EFFDATE"))) S:'ENRDT ENRDT=DT "RTN","DGENEGT1",168,0) .S ENRCAT=$P($G(^DGEN(27.15,+EGTENR("STATUS"),0)),"^",2) "RTN","DGENEGT1",169,0) .; If Application Date or Effective Date of Change are prior to the "RTN","DGENEGT1",170,0) .; EGT Effective Date then cont. enroll. "RTN","DGENEGT1",171,0) .I ENRDT0 Q "RTN","DGENEGT1",175,0) Q CE "RTN","DGENEGT1",176,0) ; "RTN","DGENEGT1",177,0) RULES(DPTDFN,EGTENR,EGT,DGPAT) ;check for new cont enrollment rules (DG*5.3*672) "RTN","DGENEGT1",178,0) N RTN,STAEXP "RTN","DGENEGT1",179,0) ; If veteran ever had a verified enrollment with SC 10%+ and is now "RTN","DGENEGT1",180,0) ; SC 0% non-compensable then cont. enroll "RTN","DGENEGT1",181,0) I EGTENR("ELIG","VACKAMT")&(EGTENR("ELIG","SCPER")>9)&(DGPAT("SCPER")=0)&(DGPAT("VACKAMT")'>0) Q 1 "RTN","DGENEGT1",182,0) ; If veteran ever had a verified enrollment with one of these "RTN","DGENEGT1",183,0) ; eligibilities then cont. enroll: AA, HB, VA Pension "RTN","DGENEGT1",184,0) I EGTENR("ELIG","VACKAMT")&((EGTENR("ELIG","A&A")="Y")!(EGTENR("ELIG","HB")="Y")!(EGTENR("ELIG","VAPEN")="Y")) Q 1 "RTN","DGENEGT1",185,0) ; If AO Exposure Location = Korean DMZ prior to ESR implementation, "RTN","DGENEGT1",186,0) ; or AO Exposure Location = Vietnam prior to Special Treatment "RTN","DGENEGT1",187,0) ; Authority (STA) termination "RTN","DGENEGT1",188,0) ; then cont. enroll. "RTN","DGENEGT1",189,0) ; **** NOTE: For patch DG*5.3*672 the ESR implementation date will "RTN","DGENEGT1",190,0) ; be set to 12/29/2040. This will be changed to the actual ESR "RTN","DGENEGT1",191,0) ; implementation date in a later patch. "RTN","DGENEGT1",192,0) ; DG*5.3*688 - Date changed to 3/21/2009 "RTN","DGENEGT1",193,0) I DGPAT("AO")="Y" D I $G(RTN) Q RTN "RTN","DGENEGT1",194,0) .I $S($D(EGTENR("ELIG","AOEXPLOC")):EGTENR("ELIG","AOEXPLOC"),1:DGPAT("AOEXPLOC"))="K",EGTENR("EFFDATE"),EGTENR("EFFDATE")<3090321 S RTN=1 "RTN","DGENEGT1",195,0) .;I (EGTENR("ELIG","AOEXPLOC")="V" D ;Added with DG*5.3*754 "RTN","DGENEGT1",196,0) .; DG*5.3*1018;KUM - Added Blue Water Navy check "RTN","DGENEGT1",197,0) .I ((EGTENR("ELIG","AOEXPLOC")="V")!(EGTENR("ELIG","AOEXPLOC")="B")) D ;Added with DG*5.3*754 "RTN","DGENEGT1",198,0) ..S STAEXP=$$STAEXP^DGENELA4("AO") Q:STAEXP<1 "RTN","DGENEGT1",199,0) ..I EGTENR("EFFDATE"),EGTENR("EFFDATE")0)&((PRI0)&(SUB49))!(CODENAME="SERVICE CONNECTED 50% to 100%") S PRIORITY=1 Q "RTN","DGENELA4",143,0) .I (DGELG("SC")="Y")&(DGELG("SCPER")>0)&(DGELG("UNEMPLOY")="Y")&(DGELG("VACKAMT")>0)&(DGELG("VAPEN")'="Y")&(DGELG("A&A")'="Y")&(DGELG("HB")'="Y") S PRIORITY=1 Q "RTN","DGENELA4",144,0) .I (DGELG("MOH")="Y")&(DGPAT("VETERAN")="Y") S PRIORITY=1 Q ;Added for DG*5.3*841 added I DGELG("MOH")="Y" S PRIORITY=1 DG*5.3*972 HM "RTN","DGENELA4",145,0) .I ((DGELG("SC")="Y")&(DGELG("SCPER")>29)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=2 Q "RTN","DGENELA4",146,0) .I ((DGELG("SC")="Y")&(DGELG("SCPER")>9)&(CODENAME="SC LESS THAN 50%"))!(DGELG("POW")="Y")!(CODENAME="PRISONER OF WAR")!(DGELG("DISRET")=1)!(DGELG("DISLOD")=1)!(CODENAME="PURPLE HEART RECIPIENT")!(DGELG("PH")="Y") S PRIORITY=3 Q "RTN","DGENELA4",147,0) .I (DGELG("A&A")="Y")!(CODENAME="AID & ATTENDANCE")!(DGELG("HB")="Y")!(CODENAME="HOUSEBOUND")!(DGELG("VCD")="Y") S PRIORITY=4 Q "RTN","DGENELA4",148,0) .I (MTSTA="A")!(DGELG("MEDICAID")=1)!(DGELG("VAPEN")="Y")!(CODENAME="NSC, VA PENSION") S PRIORITY=5 Q "RTN","DGENELA4",149,0) .I (CODENAME="WORLD WAR I")!(CODENAME="MEXICAN BORDER WAR")!(DGELG("VACKAMT")>0)!((DGELG("CVELEDT"))&(DGELG("CVELEDT")'MTTHR)) S PRIORITY=7 D Q "RTN","DGENELA4",157,0) ..I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q "RTN","DGENELA4",158,0) ..S SUBGRP=$$SUBPRI(DFN,.PRIORITY,3) "RTN","DGENELA4",159,0) .S MTTEST1=MTTHR "RTN","DGENELA4",160,0) .I GMTTHR>MTTHR S MTTEST1=GMTTHR "RTN","DGENELA4",161,0) .S MTTEST2=MTTEST1+(MTTEST1*0.10)+0.01 ; Add 10% to the test threshold "RTN","DGENELA4",162,0) .I $$SC^DGMTR(DFN),DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q "RTN","DGENELA4",163,0) .I $$SC^DGMTR(DFN),DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,2) Q "RTN","DGENELA4",164,0) .I DGELG("SC")="N",DGMTYR>2007,DGNCM>MTTEST1,MTTEST2>DGNCM,ENRDATE>3090614 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q "RTN","DGENELA4",165,0) .I DGELG("SC")="N",DGMTYR>2007,(DGNCM-DGMEDEX-DGEDEX)79999.99 S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,4) Q "RTN","DGENELA4",166,0) .I ((DGELG("SC")="Y")&(DGELG("SCPER")=0)&(DGELG("VACKAMT")<1)&(CODENAME="SC LESS THAN 50%")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,.PRIORITY,1) Q "RTN","DGENELA4",167,0) .I ((MTSTA="C")!(MTSTA="P")) S PRIORITY=8,SUBGRP=$$SUBPRI(DFN,PRIORITY,3) Q "RTN","DGENELA4",168,0) ; "RTN","DGENELA4",169,0) Q PRIORITY_$S(PRIORITY:"^"_SUBGRP,1:"") "RTN","DGENELA4",170,0) ; "RTN","DGENELA4",171,0) SUBPRI(DFN,PRIORITY,SUBGRP) ;calculate sub-priority if under EGT "RTN","DGENELA4",172,0) ; "RTN","DGENELA4",173,0) N PRVPRI,DONE,PRVENST,ENRDT,DGENRIEN,EGT,DGENRC,TODAY,X "RTN","DGENELA4",174,0) Q:'$G(DFN) "RTN","DGENELA4",175,0) S U="^" "RTN","DGENELA4",176,0) S:$G(PRIORITY)="" PRIORITY="" "RTN","DGENELA4",177,0) S:$G(SUBGRP)="" SUBGRP="" "RTN","DGENELA4",178,0) D NOW^%DTC S TODAY=X "RTN","DGENELA4",179,0) Q:'$$GET^DGENEGT($$FINDCUR^DGENEGT(),.EGT) SUBGRP ;EGT isn't set "RTN","DGENELA4",180,0) Q:TODAYEGT("PRIORITY")) $$SUBCNV(SUBGRP) "RTN","DGENELA4",184,0) ;I $G(ENRDATE) Q:$$ABOVE2^DGENEGT1(ENRDATE,PRIORITY,SUBGRP) SUBGRP "RTN","DGENELA4",185,0) S DGENRIEN=$$FINDCUR^DGENA(DFN) "RTN","DGENELA4",186,0) I 'DGENRIEN,$G(ENRDATE),ENRDATE> this function has been removed based on a customer request "RTN","DGENUPL9",42,0) ; >> the code is being left for reactivation if desired w/ ESR "RTN","DGENUPL9",43,0) Q "RTN","DGENUPL9",44,0) N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ "RTN","DGENUPL9",45,0) S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT","")) "RTN","DGENUPL9",46,0) Q:'DGMGRP "RTN","DGENUPL9",47,0) D XMY^DGMTUTL(DGMGRP,0,1) "RTN","DGENUPL9",48,0) S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9) "RTN","DGENUPL9",49,0) S XMTEXT="DGBULL(" "RTN","DGENUPL9",50,0) S XMSUB="AGENT ORANGE EXPOSURE LOCATION CHANGE" "RTN","DGENUPL9",51,0) S DGLINE=0 "RTN","DGENUPL9",52,0) D LINE^DGEN("Patient: "_DGNAME,.DGLINE) "RTN","DGENUPL9",53,0) D LINE^DGEN("SSN: "_DGSSN,.DGLINE) "RTN","DGENUPL9",54,0) D LINE^DGEN("",.DGLINE) "RTN","DGENUPL9",55,0) D LINE^DGEN("This veteran's Agent Orange Exposure Location has been changed.",.DGLINE) "RTN","DGENUPL9",56,0) D LINE^DGEN("Contact the HEC by phone if you have questions or believe",.DGLINE) "RTN","DGENUPL9",57,0) D LINE^DGEN("this information to be incorrect.",.DGLINE) "RTN","DGENUPL9",58,0) D ^XMD "RTN","DGENUPL9",59,0) Q "RTN","DGRP6EF") 0^4^B33525270 "RTN","DGRP6EF",1,0) DGRP6EF ;ALB/TMK,EG,BAJ,JLS,ARF,JAM - REGISTRATION SCREEN 6 FIELDS FOR EXPOSURE FACTORS ;05 Feb 2015 11:06 AM "RTN","DGRP6EF",2,0) ;;5.3;Registration;**689,659,737,688,909,1014,1018**;Aug 13,1993;Build 5 "RTN","DGRP6EF",3,0) ; "RTN","DGRP6EF",4,0) EN(DFN,QUIT) ; Display Environmental exposure factors/allow to edit "RTN","DGRP6EF",5,0) N I,IND,DG321,DG322,DGCT,DIR,Z,X,Y,DIE,DR,DA,DGNONT "RTN","DGRP6EF",6,0) ; Returns QUIT=1 if ^ entered "RTN","DGRP6EF",7,0) ; "RTN","DGRP6EF",8,0) EN1 D CLEAR^VALM1 "RTN","DGRP6EF",9,0) N DTOUT,DUOUT,TYPE,SEL,L,S,L1,L2,L3 "RTN","DGRP6EF",10,0) S DG321=$G(^DPT(DFN,.321)),DG322=$G(^DPT(DFN,.322)) "RTN","DGRP6EF",11,0) ; "RTN","DGRP6EF",12,0) S DIR(0)="SA^",DGCT=0 "RTN","DGRP6EF",13,0) N DGSSNSTR,DGPTYPE,DGSSN,DGDOB ;ARF-DG*5.3*1014 begin - add standardize patient data to the screen banner "RTN","DGRP6EF",14,0) S DGSSNSTR=$$SSNNM^DGRPU(DFN) "RTN","DGRP6EF",15,0) S DGSSN=$P($P(DGSSNSTR,";",2)," ",3) "RTN","DGRP6EF",16,0) S DGDOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","DGRP6EF",17,0) S DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($E(DGDOB,1,12),1)) "RTN","DGRP6EF",18,0) S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01) "RTN","DGRP6EF",19,0) S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN" "RTN","DGRP6EF",20,0) S DGCT=DGCT+1,DIR("A",DGCT)=$P(DGSSNSTR,";",1)_$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB "RTN","DGRP6EF",21,0) S DGCT=DGCT+1,DIR("A",DGCT)=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE "RTN","DGRP6EF",22,0) ;S DGCT=DGCT+1,DIR("A",DGCT)=$$SSNNM^DGRPU(DFN) ;ARF-DG*5.3*1014 end "RTN","DGRP6EF",23,0) S DGCT=DGCT+1,DIR("A",DGCT)="",$P(DIR("A",DGCT),"=",81)="" "RTN","DGRP6EF",24,0) S DGCT=DGCT+1,DIR("A",DGCT)=$J("",23)_"**** ENVIRONMENTAL FACTORS ****",DGCT=DGCT+1,DIR("A",DGCT)=" " "RTN","DGRP6EF",25,0) S IND=$S('$G(DGRPV):"[]",1:"<>") "RTN","DGRP6EF",26,0) S DGCT=DGCT+1 "RTN","DGRP6EF",27,0) S Z=$E(IND)_"1"_$E(IND,2) "RTN","DGRP6EF",28,0) ; "OTHER" choice added DG*5.3*688 "RTN","DGRP6EF",29,0) ; variables S,L1,L2, & L3 used for dynamic spacing "RTN","DGRP6EF",30,0) S SEL=$P(DG321,U,13),S=$C(32),($P(L1,S,6),$P(L2,S,$S(SEL="O":3,1:2)),$P(L3,S,3))="" "RTN","DGRP6EF",31,0) ; DG*5.3*1018 - Add Blue Water Navy Value "B" "RTN","DGRP6EF",32,0) S TYPE=$S(SEL="B":" (BWN) ",SEL="K":" (DMZ) ",SEL="V":" (VIET)",SEL="O":" (OTH)",1:$J("",7)) "RTN","DGRP6EF",33,0) S DIR("A",DGCT)=Z_L1_"A/O Exp.: "_$$YN^DGRP6CL(DG321,2)_TYPE_L2_"Reg: "_$$DAT^DGRP6CL(DG321,7,12)_L3_"Exam: "_$$DAT^DGRP6CL(DG321,9,12)_"A/O#: "_$P(DG321,U,10) "RTN","DGRP6EF",34,0) S Z=$E(IND)_"2"_$E(IND,2) "RTN","DGRP6EF",35,0) S DGCT=DGCT+1,DIR("A",DGCT)=Z_" ION Rad.: "_$$YN^DGRP6CL(DG321,3)_$J("",8)_"Reg: "_$$DAT^DGRP6CL(DG321,11,12)_"Method: " "RTN","DGRP6EF",36,0) S:$P(DG321,U,12)>7 $P(DG321,U,12)="" S DIR("A",DGCT)=DIR("A",DGCT)_$P($T(SELTBL+$P(DG321,U,12)),";;",2) "RTN","DGRP6EF",37,0) S Z=$E(IND)_"3"_$E(IND,2) "RTN","DGRP6EF",38,0) ;Env Contam name changed to SW Asia Conditions, DG*5.3*688 "RTN","DGRP6EF",39,0) S DGCT=DGCT+1,DIR("A",DGCT)=Z_" SW Asia Cond: "_$$YN^DGRP6CL(DG322,13)_$J("",8)_"Reg: "_$$DAT^DGRP6CL(DG322,14,12)_" Exam: "_$$DAT^DGRP6CL(DG322,15,11) "RTN","DGRP6EF",40,0) S DGNONT=0 I $$GETSTAT^DGNTAPI1(DFN)>2,'$D(^XUSEC("DGNT VERIFY",DUZ)) S DGNONT=1 "RTN","DGRP6EF",41,0) I $G(DGRPV) S DGNONT=1 "RTN","DGRP6EF",42,0) S DGCT=DGCT+1,DIR("A",DGCT)=$S(DGNONT:"<",1:"[")_"4"_$S(DGNONT:">",1:"]")_" N/T Radium: " N DGNT S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT") S DIR("A",DGCT)=DIR("A",DGCT)_$G(DGNT("INTRP")) "RTN","DGRP6EF",43,0) ; "RTN","DGRP6EF",44,0) ; DG*5.3*909 Display Camp Lejeune info in entirety "RTN","DGRP6EF",45,0) N DG3217CL S DG3217CL=$G(^DPT(DFN,.3217)) "RTN","DGRP6EF",46,0) N DGCLE S DGCLE=$$CLE^DGENCLEA(DFN) "RTN","DGRP6EF",47,0) I DGCLE=1,$G(^DPT(DFN,.32171))=1 S DGCLE=0 "RTN","DGRP6EF",48,0) S IND=$S('DGCLE:"<>",1:IND) "RTN","DGRP6EF",49,0) S Z=$E(IND)_"5"_$E(IND,2) "RTN","DGRP6EF",50,0) S DGCT=DGCT+1,DIR("A",DGCT)=Z_" Camp Lejeune: " "RTN","DGRP6EF",51,0) S DIR("A",DGCT)=DIR("A",DGCT)_$$YN^DGRP6CL(DG3217CL,1) "RTN","DGRP6EF",52,0) ; "RTN","DGRP6EF",53,0) S DGCT=DGCT+1,DIR("A",DGCT)=" " "RTN","DGRP6EF",54,0) N DGENDTXT S DGENDTXT=$S(DGNONT&DGCLE:"3,5",DGNONT&'DGCLE:"3",'DGNONT&DGCLE:"5",1:"4") ; DG*5.3*909 Determine available choices based also on Camp Lejeune eligibility "RTN","DGRP6EF",55,0) S DIR("A")=$S('$G(DGRPV):"SELECT AN ENVIRONMENTAL FACTOR (1-"_DGENDTXT_") OR (Q)UIT: ",1:"PRESS RETURN TO CONTINUE ") ;DG*5.3*909 Camp Lejeune choice added "RTN","DGRP6EF",56,0) ;Env Contam name changed to SW Asia Conditions, DG*5.3*688 "RTN","DGRP6EF",57,0) S DIR(0)=$S('$G(DGRPV):"SA^1:A/O Exp;2:ION Rad;3:SW Asia Cond;"_$S(DGNONT:"",1:"4:N/T Radium;")_$S(DGCLE:"5:Camp Lejeune;",1:"")_"Q:QUIT",1:"EA") ; DG*5.3*909 Camp Lejeune choice added "RTN","DGRP6EF",58,0) I '$G(DGRPV) S DIR("B")="QUIT" "RTN","DGRP6EF",59,0) I 'DGCLE,$G(^DPT(DFN,.32171))=1,$P($G(XQY0),U)'="DG REGISTRATION VIEW" D "RTN","DGRP6EF",60,0) . S DGHECMSG(1)="Camp Lejeune data has been verified by HEC, please " "RTN","DGRP6EF",61,0) . S DGHECMSG(1)=DGHECMSG(1)_"notify the HEC via" "RTN","DGRP6EF",62,0) . S DGHECMSG(2)="the HEC Alert process if changes are required." "RTN","DGRP6EF",63,0) . S DGHECMSG(3)="Press Return key to continue" "RTN","DGRP6EF",64,0) . S DIR("PRE")="I X=5 W !!,DGHECMSG(1),!,DGHECMSG(2),!!,DGHECMSG(3)" "RTN","DGRP6EF",65,0) . S DIR("PRE")=DIR("PRE")_" R *DGANSWER S X=""""" "RTN","DGRP6EF",66,0) D ^DIR K DIR,DGANSWER,DGHECMSG "RTN","DGRP6EF",67,0) I $G(DGRPV)!$D(DUOUT)!$D(DTOUT)!(Y="Q") S:Y'="Q" QUIT=1 G QUIT "RTN","DGRP6EF",68,0) S Z="603"_$E("0",2-$L(+Y))_+Y "RTN","DGRP6EF",69,0) S DIE=2,DA=DFN,DR=$P($T(@Z),";;",2) "RTN","DGRP6EF",70,0) ; "RTN","DGRP6EF",71,0) ; DG*5.3*909 Camp Lejeune logic added "RTN","DGRP6EF",72,0) I Y'=5 D:DR'="" ^DIE "RTN","DGRP6EF",73,0) E X DR D AUTOUPD^DGENA2(DFN) "RTN","DGRP6EF",74,0) K DIE,DA,DR "RTN","DGRP6EF",75,0) G EN1 "RTN","DGRP6EF",76,0) ; "RTN","DGRP6EF",77,0) QUIT Q "RTN","DGRP6EF",78,0) ; "RTN","DGRP6EF",79,0) EF(DFN,LIN) ; "RTN","DGRP6EF",80,0) N DG321,DG322,LENGTH,Z,SEQ "RTN","DGRP6EF",81,0) K LIN S (LENGTH,LIN)=0 "RTN","DGRP6EF",82,0) S DG321=$G(^DPT(DFN,.321)),DG322=$G(^(.322)) "RTN","DGRP6EF",83,0) I $P(DG321,U,2)="Y" D "RTN","DGRP6EF",84,0) . S Z="A/O Exp.",SEQ=1 "RTN","DGRP6EF",85,0) . ;S:'$P(DG321,U,7)!'$P(DG321,U,9)!($P(DG321,U,10)="") Z=Z_"(Incomplete)" "RTN","DGRP6EF",86,0) . S:'$P(DG321,U,7)!('$P(DG321,U,9))="" Z=Z_"(Incomplete)" "RTN","DGRP6EF",87,0) . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",88,0) ; "RTN","DGRP6EF",89,0) I $P(DG321,U,3)="Y" D "RTN","DGRP6EF",90,0) . S Z="Ion Rad.",SEQ=2 "RTN","DGRP6EF",91,0) . S:'$P(DG321,U,11)!($P(DG321,U,12)="") Z=Z_"(Incomplete)" "RTN","DGRP6EF",92,0) . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",93,0) ; "RTN","DGRP6EF",94,0) I $P(DG322,U,13)="Y" D "RTN","DGRP6EF",95,0) . I 'LIN S LIN=LIN+1,LIN(LIN)="" "RTN","DGRP6EF",96,0) . ;Env Contam name changed to SW Asia Conditions, DG*5.3*688 "RTN","DGRP6EF",97,0) . S Z="SW Asia Cond.",SEQ=3 "RTN","DGRP6EF",98,0) . S:'$P(DG322,U,14)!'$P(DG322,U,15) Z=Z_"(Incomplete)" "RTN","DGRP6EF",99,0) . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",100,0) ; N/T Radium Exposure "RTN","DGRP6EF",101,0) N DGNT,DGRPX S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT") "RTN","DGRP6EF",102,0) I "NO"'[$G(DGNT("INTRP")) D "RTN","DGRP6EF",103,0) . I 'LIN S LIN=LIN+1,LIN(LIN)="" "RTN","DGRP6EF",104,0) . S SEQ=4 D SETLNEX^DGRP6("N/T Radium ("_$P(DGNT("INTRP"),"YES,",2)_")",SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",105,0) ; DG*5.3*909 Get latest Camp Lejeune information from PATIENT file "RTN","DGRP6EF",106,0) N DG3217CL "RTN","DGRP6EF",107,0) S DG3217CL=$G(^DPT(DFN,.3217)) "RTN","DGRP6EF",108,0) I $P(DG3217CL,U,1)="Y" D "RTN","DGRP6EF",109,0) . I 'LIN S LIN=LIN+1,LIN(LIN)="" "RTN","DGRP6EF",110,0) . S Z="Camp Lejeune",SEQ=5 "RTN","DGRP6EF",111,0) . D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH) "RTN","DGRP6EF",112,0) Q "RTN","DGRP6EF",113,0) ; "RTN","DGRP6EF",114,0) CHKAOEL(DGY) ;DG*5.3*1018;jam; - Screen logic for .3213 (AGENT ORANGE EXPOSURE LOCATION) field in PATIENT file "RTN","DGRP6EF",115,0) ; Returns: TRUE if the entry DGY is valid "RTN","DGRP6EF",116,0) ; "RTN","DGRP6EF",117,0) ; Only checking B (BLUE WATER NAVY) entry - All other entries are allowed "RTN","DGRP6EF",118,0) I DGY'="B" Q 1 "RTN","DGRP6EF",119,0) N DGBWNDT "RTN","DGRP6EF",120,0) ; Allow B to be displayed when BWN ACTIVE DATE (#1402) in MAS PARAMETER file #43 is reached "RTN","DGRP6EF",121,0) ; - Get the BWN ACTIVE DATE "RTN","DGRP6EF",122,0) S DGBWNDT=$$GET1^DIQ(43,1,1402,"I") "RTN","DGRP6EF",123,0) ; - If active date not defined, return FALSE "RTN","DGRP6EF",124,0) I 'DGBWNDT Q 0 "RTN","DGRP6EF",125,0) ; - If active date is in the future, return FALSE "RTN","DGRP6EF",126,0) I DGBWNDT>$$DT^XLFDT Q 0 "RTN","DGRP6EF",127,0) Q 1 "RTN","DGRP6EF",128,0) ; "RTN","DGRP6EF",129,0) ; The following tag is a table of values. Do not change location of values including null at SELTBL+0 "RTN","DGRP6EF",130,0) SELTBL ;; "RTN","DGRP6EF",131,0) ;;NO VALUE "RTN","DGRP6EF",132,0) ;;HIROSHIMA/NAGASAKI "RTN","DGRP6EF",133,0) ;;ATMOSPHERIC NUCLEAR TEST "RTN","DGRP6EF",134,0) ;;H/N AND ATMOSPHERIC TEST "RTN","DGRP6EF",135,0) ;;UNDERGROUND NUCLEAR TEST "RTN","DGRP6EF",136,0) ;;EXP. AT NUCLEAR FACILITY "RTN","DGRP6EF",137,0) ;;OTHER "RTN","DGRP6EF",138,0) 60301 ;;.32102//NO;S:X'="Y" Y="@65";.3213;.32107;.32109;.3211;@65; "RTN","DGRP6EF",139,0) 60302 ;;.32103//NO;S:X'="Y" Y="@66";.3212;.32111;@66; "RTN","DGRP6EF",140,0) 60303 ;;.322013//NO;S:X'="Y" Y="@612";.322014;Q;.322015;@612; "RTN","DGRP6EF",141,0) 60304 ;;D REG^DGNTQ(DFN) "RTN","DGRP6EF",142,0) 60305 ;;D ADDEDTCL^DGENCLEA(DFN) "RTN","DGRP6EF",143,0) ;; "RTN","VADPT4") 0^6^B45245158 "RTN","VADPT4",1,0) VADPT4 ;ALB/MRL,MJK,ERC,DIC,PWC,ARF - PATIENT VARIABLES ;12 DEC 1988 ;10/13/10 4:43pm "RTN","VADPT4",2,0) ;;5.3;Registration;**343,342,528,689,688,790,797,935,952,1007,1018**;Aug 13, 1993;Build 5 "RTN","VADPT4",3,0) 7 ;Eligibility [ELIG] "RTN","VADPT4",4,0) F I=.15,.3,.31,.32,.36,.361,"INE","TYPE","VET" S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","VADPT4",5,0) S VAZ=$P(VAX(.36),"^",1) S:$D(^DIC(8,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",1))=VAZ "RTN","VADPT4",6,0) S VAX=0 F I=0:0 S VAX=$O(^DPT(DFN,"E",VAX)) Q:VAX'>0 S VAZ=VAX I $D(^DIC(8,+VAZ,0)),+@VAV@($P(VAS,"^"))'=VAZ S VAZ=VAZ_"^"_$P(^DIC(8,+VAZ,0),"^") S @VAV@($P(VAS,"^",1),VAX)=VAZ "RTN","VADPT4",7,0) S VAZ=$P(VAX(.32),"^",3) S:$D(^DIC(21,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",2))=VAZ "RTN","VADPT4",8,0) S VAZ=$S($P(VAX(.3),"^",1)="Y":1,1:0) S:VAZ VAZ=VAZ_"^"_$P(VAX(.3),"^",2) S @VAV@($P(VAS,"^",3))=VAZ "RTN","VADPT4",9,0) S @VAV@($P(VAS,"^",4))=$S(VAX("VET")="Y":1,1:0),VAZ=$S(+$P(VAX(.15),"^",2):0,1:1),@VAV@($P(VAS,"^",5))=VAZ "RTN","VADPT4",10,0) I VAZ F I=1:1:6 S @VAV@($P(VAS,"^",5),I)="" G 71 "RTN","VADPT4",11,0) S VAZ=$P(VAX(.15),"^",2),Y=VAZ X ^DD("DD") S @VAV@($P(VAS,"^",5),1)=VAZ_"^"_Y,VAZ=$P(VAX("INE"),"^",1) S:VAZ]"" VAZ=VAZ_"^"_$P("VAMC^REGIONAL OFFICE^RPC","^",VAZ) S @VAV@($P(VAS,"^",5),2)=VAZ "RTN","VADPT4",12,0) S @VAV@($P(VAS,"^",5),3)=$P(VAX("INE"),"^",3),VAZ=$P(VAX("INE"),"^",4) S:$D(^DIC(5,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",5),4)=VAZ "RTN","VADPT4",13,0) S @VAV@($P(VAS,"^",5),5)=$P(VAX("INE"),"^",6),@VAV@($P(VAS,"^",5),6)=$P(VAX(.3),"^",7) "RTN","VADPT4",14,0) 71 S VAZ=VAX("TYPE") S:$D(^DG(391,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",6))=VAZ "RTN","VADPT4",15,0) S @VAV@($P(VAS,"^",7))=$P(VAX(.31),"^",3),VAZ=$P(VAX(.361),"^",1) S:VAZ]"" VAZ=VAZ_"^"_$S(VAZ="V":"VERIFIED",VAZ="P":"PENDING VERIFICATION",VAZ="R":"PENDING RE-VERIFICATION",1:"") S @VAV@($P(VAS,"^",8))=VAZ "RTN","VADPT4",16,0) I $D(^DPT(DFN,0)) S VAX=$P(^(0),"^",14),VAX=$G(^DG(408.32,+VAX,0)) I VAX]"" S @VAV@($P(VAS,"^",9))=$P(VAX,"^",2)_"^"_$P(VAX,"^",1) "RTN","VADPT4",17,0) S VAX=$G(^DPT(DFN,.55)) S @VAV@($P(VAS,"^",10))=VAX_$S(VAX]"":"^",1:"")_$$GET1^DIQ(2,DFN_",",.5501,"E") "RTN","VADPT4",18,0) Q "RTN","VADPT4",19,0) ; "RTN","VADPT4",20,0) 8 ;Monetary Benefits [MB] "RTN","VADPT4",21,0) N DGTOTVA "RTN","VADPT4",22,0) S @VAV@($P(VAS,"^",6))=0 ; SSI no longer supported "RTN","VADPT4",23,0) D ALL^DGMTU21(DFN,"V",DT,"I") "RTN","VADPT4",24,0) S VAX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) F I=8,11,13 S @VAV@($S(I=8:$P(VAS,"^",3),I=11:$P(VAS,"^",5),1:$P(VAS,"^",8)))=$S($P(VAX,"^",I)'="":"1^"_$P(VAX,"^",I),1:0) "RTN","VADPT4",25,0) S VAX=$G(^DPT(DFN,.362)) "RTN","VADPT4",26,0) S DGTOTVA=$P(VAX,U,20) "RTN","VADPT4",27,0) F I=12,13,14 S @VAV@($S(I=12:$P(VAS,"^",1),(I=13):$P(VAS,"^",2),1:$P(VAS,"^",4)))=$S($P(VAX,"^",I)="Y":1_U_DGTOTVA,1:0) "RTN","VADPT4",28,0) S I=17 S @VAV@($P(VAS,"^",9))=$S($P(VAX,"^",17)="Y":1_U_$P(VAX,U,6),1:0) "RTN","VADPT4",29,0) S VAX=$G(^DPT(DFN,.3)) S @VAV@($P(VAS,"^",7))=$S($P(VAX,"^",11)="Y":1_U_DGTOTVA,1:0) "RTN","VADPT4",30,0) K DGDEP,DGREL,DGINC,DGINR Q "RTN","VADPT4",31,0) ; "RTN","VADPT4",32,0) 9 ;Service information "RTN","VADPT4",33,0) F I=.32,.321,.3291,.52,.53 S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","VADPT4",34,0) D:$D(^DPT(DFN,.3216)) MSDS "RTN","VADPT4",35,0) S VAX("N")=.321 F I=1,2,3 S VAX(3)=I,VAZ=$S($P(VAX(.321),"^",I)="Y":1,1:0),@VAV@($P(VAS,"^",VAX(3)))=VAZ I VAZ S VAX(1)=$S(I=1:"4^5",I=2:"7^9^8",1:11),VAX(4)=0 D 91 "RTN","VADPT4",36,0) S VAX("N")=.52 F I=5,11 S VAX(3)=$S(I=5:4,1:5),VAX(1)=$S(I=5:"7^8",1:"13^14"),VAZ=$S($P(VAX(.52),"^",I)="Y":1,1:0),@VAV@($P(VAS,"^",VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91 "RTN","VADPT4",37,0) ;Combat Vet "RTN","VADPT4",38,0) S VAX(3)=10,VAX(1)="15",VAZ=$S($P(VAX(.52),U,15)]"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91 "RTN","VADPT4",39,0) F I=6,7,8 S @VAV@($P(VAS,"^",I))="" F VAX(1)=1:1:6 S @VAV@($P(VAS,"^",I),VAX(1))="" "RTN","VADPT4",40,0) S VAX("N")=.32,VAZ=$S($P(VAX(.32),"^",5)]"":1,1:0),@VAV@($P(VAS,"^",6))=VAZ I VAZ,$P(VAX(.32),"^",19)="Y" S VAZ=1,@VAV@($P(VAS,"^",7))=VAZ I VAZ,$P(VAX(.32),"^",20)="Y" S @VAV@($P(VAS,"^",8))=1 "RTN","VADPT4",41,0) F I=6,7,8 I @VAV@($P(VAS,"^",I)) S VAX(3)=I,VAX(1)=$S(I=6:"6^7",I=7:"11^12",1:"16^17"),VAX(4)=3 D 91 "RTN","VADPT4",42,0) S VAX("N")=.3291 "RTN","VADPT4",43,0) F I=6,7,8 I @VAV@($P(VAS,"^",I)) S VAX(3)=I,VAX(1)=I-5,VAX(4)=6 D 94 "RTN","VADPT4",44,0) S VAX("N")=.53,VAX(3)=9,VAX(1)="2^3",VAZ=$S($P(VAX(.53),U)="Y":1,$P(VAX(.53),U)="N":1,1:0),@VAV@($P(VAS,U,VAX(3)))=$S($P(VAX(.53),U)="Y":1,$P(VAX(.53),U)="N":0,1:"") I VAZ S VAX(4)=0 D 93 "RTN","VADPT4",45,0) S VAX("N")=.3215,VAZ=$$GET^DGENOEIF(DFN,.VAZ,1) "RTN","VADPT4",46,0) ;OEF/OIF "RTN","VADPT4",47,0) F I=11,12,13 S @VAV@(I)=+$G(VAZ($P("OIF^OEF^UNK",U,I-10),"COUNT")) "RTN","VADPT4",48,0) S VAX(2)=11 "RTN","VADPT4",49,0) F I="OIF","OEF","UNK" S VAX=0 F S VAX=$O(VAZ(I,VAX)) S:'VAX VAX(2)=VAX(2)+1 Q:'VAX S VAX(3)=0 D "RTN","VADPT4",50,0) . N Z "RTN","VADPT4",51,0) . F VAX(1)="LOC","FR","TO" S VAX(3)=VAX(3)+1,Z=$G(VAZ(I,VAX,VAX(1))),@VAV@(VAX(2),VAX,VAX(3))=Z D 95 "RTN","VADPT4",52,0) ;SHAD - added with DG*5.3*688 "RTN","VADPT4",53,0) S VAX(3)=14,VAZ=$S($P(VAX(.321),U,15)]"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S @VAV@($P(VAS,U,VAX(3)),1)=$S($P(VAX(.321),U,15)=1:"1^YES",1:"0^NO") "RTN","VADPT4",54,0) Q "RTN","VADPT4",55,0) ; "RTN","VADPT4",56,0) 91 ;date fields "RTN","VADPT4",57,0) F VAX(2)=1:1 S VAX(4)=VAX(4)+1,X=+$P(VAX(1),"^",VAX(2)) Q:'X S X=$P(VAX(VAX("N")),"^",X),VAZ=X,Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$S(VAZ]"":VAZ_"^"_Y,1:"") "RTN","VADPT4",58,0) Q:VAX(3)=1!(VAX(3)=9)!(VAX(3)=10) "RTN","VADPT4",59,0) ;some sets of codes ;DG*5.3*1018 corrected the external code stored in the array for the AGENT ORANGE EXPOSURE LOCATION field (#.3213) "RTN","VADPT4",60,0) I VAX(3)=2 S @VAV@($P(VAS,"^",2),4)=$P(VAX(.321),"^",10) S (X,VAZ)=$P(VAX(.321),"^",13) S:X]"" VAZ=VAZ_"^"_$$GET1^DIQ(2,DFN,.3213,"E") S @VAV@($P(VAS,"^",2),5)=VAZ Q "RTN","VADPT4",61,0) I VAX(3)<4 S X=$P(VAX(.321),"^",12),VAZ=X D "RTN","VADPT4",62,0) .S:X]"" VAZ=VAZ_"^"_$S(X="2":"HIROSHIMA/NAGASAKI",X="3":"ATMOSPHERIC NUCLEAR TESTING",X="4":"H/N AND ATMOSPHERIC TESTING",X="5":"UNDERGROUND NUCLEAR TESTING",X="6":"EXPOSURE AT NUCLEAR FACILITY",1:"OTHER") "RTN","VADPT4",63,0) .S @VAV@($P(VAS,"^",3),2)=VAZ Q "RTN","VADPT4",64,0) ;POW, combat locations "RTN","VADPT4",65,0) I VAX(3)<6 S X=$P(VAX(VAX("N")),"^",$S(VAX(3)=4:6,1:12)),VAZ=X S:$D(^DIC(22,+X,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",VAX(3)),3)=VAZ Q "RTN","VADPT4",66,0) ;service episodes "RTN","VADPT4",67,0) S X=$S(VAX(3)=6:5,VAX(3)=7:10,1:15),VAX(2)=0 F VAX(5)=X,X+3,X-1 S VAX(2)=VAX(2)+1,VAZ=$P(VAX(VAX("N")),"^",VAX(5)),@VAV@($P(VAS,"^",VAX(3)),VAX(2))=VAZ I "^4^5^9^10^14^15^"[("^"_VAX(5)_"^"),+VAZ D 92 "RTN","VADPT4",68,0) Q "RTN","VADPT4",69,0) 92 ;pointers to Branch of Service (23) and Type Discharge (25) "RTN","VADPT4",70,0) S VAX(6)="^DIC("_$S('(VAX(5)#5):23,1:25)_","_+VAZ_",0)" I $D(@(VAX(6))) S VAZ=$P(^(0),"^",1),@VAV@($P(VAS,"^",VAX(3)),VAX(2))=@VAV@($P(VAS,"^",VAX(3)),VAX(2))_"^"_VAZ "RTN","VADPT4",71,0) Q "RTN","VADPT4",72,0) 93 ;Purple Heart "RTN","VADPT4",73,0) NEW VAFILE,VAIENS,VAFLDS,VAARR,VAI "RTN","VADPT4",74,0) S VAFILE=2,VAIENS=DFN_",",VAFLDS=".532;.533" "RTN","VADPT4",75,0) D GETS^DIQ(VAFILE,VAIENS,VAFLDS,"IEN","VAARR") "RTN","VADPT4",76,0) F VAI=1:1 S VAFLDS(VAI)=$P(VAFLDS,";",VAI) Q:VAFLDS(VAI)="" D "RTN","VADPT4",77,0) . I '$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I")),'$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E")) S @VAV@($P(VAS,"^",VAX(3)),VAI)="" "RTN","VADPT4",78,0) . E S @VAV@($P(VAS,U,VAX(3)),VAI)=$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"I"))_"^"_$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),"E")) "RTN","VADPT4",79,0) Q "RTN","VADPT4",80,0) 94 ;more military service "RTN","VADPT4",81,0) N VASVCI,VASVCE "RTN","VADPT4",82,0) ;DG*5.3*1007 No longer using Fileman lookup to get Military Service Component "RTN","VADPT4",83,0) ;S VAIENS=DFN_",",VAFLDS=".3291"_VAX(1) "RTN","VADPT4",84,0) ;D GETS^DIQ(2,VAIENS,VAFLDS,"IEN","VAARR") "RTN","VADPT4",85,0) ;I $G(VAARR(2,VAIENS,VAFLDS,"I"))'="" D "RTN","VADPT4",86,0) ;. S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=$G(VAARR(2,VAIENS,VAFLDS,"I"))_"^"_$G(VAARR(2,VAIENS,VAFLDS,"E")) "RTN","VADPT4",87,0) ;DG*5.3*1007 Using Military Service Component data extracted from the .3291 field or .3216 sub-file "RTN","VADPT4",88,0) I $G(VAX(.3291))'="" D "RTN","VADPT4",89,0) . S VASVCI=$S(VAX(3)=6:$P(VAX(.3291),"^",1),VAX(3)=7:$P(VAX(.3291),"^",2),VAX(3)=8:$P(VAX(.3291),"^",3),1:0) "RTN","VADPT4",90,0) . S VASVCE=$S(VASVCI="R":"REGULAR",VASVCI="V":"ACTIVATED RESERVE",VASVCI="G":"ACTIVATED NG",1:0) "RTN","VADPT4",91,0) . S @VAV@($P(VAS,"^",VAX(3)),VAX(4))=VASVCI_"^"_VASVCE "RTN","VADPT4",92,0) Q "RTN","VADPT4",93,0) ; "RTN","VADPT4",94,0) 95 ;OEF/OIF "RTN","VADPT4",95,0) N X,Y "RTN","VADPT4",96,0) I VAX(3)=1 S $P(@VAV@(VAX(2),VAX,VAX(3)),U,2)=$$EXTERNAL^DILFD(2.3215,.01,"",Z) "RTN","VADPT4",97,0) I VAX(3)=2!(VAX(3)=3) S Y=Z X ^DD("DD") S:Y'="" $P(@VAV@(VAX(2),VAX,VAX(3)),U,2)=Y "RTN","VADPT4",98,0) Q "RTN","VADPT4",99,0) ; "RTN","VADPT4",100,0) MSDS ;Returns latest service episodes from ESR sourced data "RTN","VADPT4",101,0) N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB "RTN","VADPT4",102,0) S COUNT=0,EDATE="" "RTN","VADPT4",103,0) ;Clear military service discharge, branch, start, end and number info "RTN","VADPT4",104,0) F I=4:1:20 S $P(VAX(.32),U,I)="" "RTN","VADPT4",105,0) ;Clear military service component info "RTN","VADPT4",106,0) F I=1:1:3 S $P(VAX(.3291),U,I)="" "RTN","VADPT4",107,0) ;Scan back for three most recent service episodes "RTN","VADPT4",108,0) F S EDATE=$O(^DPT(DFN,.3216,"B",EDATE),-1) Q:'EDATE D Q:COUNT'<3 "RTN","VADPT4",109,0) .S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA "RTN","VADPT4",110,0) .;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935 "RTN","VADPT4",111,0) .S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""!($P(EDATA,U,8)'="") "RTN","VADPT4",112,0) .S COUNT=COUNT+1,SDATE=$P(EDATA,U,2) "RTN","VADPT4",113,0) .S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4) "RTN","VADPT4",114,0) .S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6) "RTN","VADPT4",115,0) .;SL = 4, SNL = 9 or SNNL = 14 "RTN","VADPT4",116,0) .S SUB=(COUNT*5)-1 "RTN","VADPT4",117,0) .S $P(VAX(.32),U,SUB)=DTYP "RTN","VADPT4",118,0) .S $P(VAX(.32),U,SUB+1)=BRANCH "RTN","VADPT4",119,0) .S $P(VAX(.32),U,SUB+2)=EDATE "RTN","VADPT4",120,0) .S $P(VAX(.32),U,SUB+3)=SDATE "RTN","VADPT4",121,0) .S $P(VAX(.32),U,SUB+4)=SERVNO "RTN","VADPT4",122,0) .S $P(VAX(.3291),U,COUNT)=COMP "RTN","VADPT4",123,0) .S:SUB=9 $P(VAX(.32),U,19)="Y" "RTN","VADPT4",124,0) .S:SUB=14 $P(VAX(.32),U,20)="Y" "RTN","VADPT4",125,0) Q "RTN","VAFHLZE1") 0^5^B33057349 "RTN","VAFHLZE1",1,0) VAFHLZE1 ;BPFO/JRP,TDM,JLS,KUM - Data extractor for ZEL segment ;5/24/06 3:43pm "RTN","VAFHLZE1",2,0) ;;5.3;Registration;**342,497,602,672,653,909,952,1018**;Aug 13,1993;Build 5 "RTN","VAFHLZE1",3,0) ; "RTN","VAFHLZE1",4,0) GETDATA ;Get information needed to build ZEL segment "RTN","VAFHLZE1",5,0) ;Input: Existence of the following variables is assumed "RTN","VAFHLZE1",6,0) ; DFN - Pointer to Patient (#2) file "RTN","VAFHLZE1",7,0) ; VAFPELIG - Primary Eligibility string (.36 node) "RTN","VAFHLZE1",8,0) ; VAFSTR - Fields to extract (padded with commas) "RTN","VAFHLZE1",9,0) ; VAFNODE - Eligibility Node (node from Elig. ["E"] mult) "RTN","VAFHLZE1",10,0) ; VAFMSTDT - Date to use when getting MST status (optional) "RTN","VAFHLZE1",11,0) ; VAFSETID - Value to use for Set ID (optional) "RTN","VAFHLZE1",12,0) ; HL7 encoding characters (HLFS, HLENC, HLQ) "RTN","VAFHLZE1",13,0) ; "RTN","VAFHLZE1",14,0) ;Output: VAFHLZEL(SeqNum) = Value "RTN","VAFHLZE1",15,0) ; "RTN","VAFHLZE1",16,0) ;Notes: VAFHLZEL is initialized (KILLed) on entry "RTN","VAFHLZE1",17,0) ; : If not passed, sequence 1 (Set ID) will have a value of '1' "RTN","VAFHLZE1",18,0) ; if getting data for the primary eligibility and '2' if getting "RTN","VAFHLZE1",19,0) ; data for other eligibility "RTN","VAFHLZE1",20,0) ; : All requested fields will be returned with the primary "RTN","VAFHLZE1",21,0) ; eligibility. The Set ID (seq 1), eligibility code (seq 2) "RTN","VAFHLZE1",22,0) ; long ID (seq 3), and short ID (seq 4) will be the only fields "RTN","VAFHLZE1",23,0) ; returned for all other eligibilities. "RTN","VAFHLZE1",24,0) ; "RTN","VAFHLZE1",25,0) N IEN33,ISOTH,J,PRIME,VAF,VAFMST,X "RTN","VAFHLZE1",26,0) K VAFHLZEL "RTN","VAFHLZE1",27,0) ;If true, primary eligibility (return all fields) "RTN","VAFHLZE1",28,0) S PRIME=+VAFNODE=+VAFPELIG "RTN","VAFHLZE1",29,0) ;Set ID "RTN","VAFHLZE1",30,0) I VAFSTR[",1," S VAFHLZEL(1)=$S($G(VAFSETID):VAFSETID,PRIME:1,1:2) "RTN","VAFHLZE1",31,0) ;Eligibility Code "RTN","VAFHLZE1",32,0) I VAFSTR[",2," S X=$P($G(^DIC(8,+VAFNODE,0)),"^",9),VAFHLZEL(2)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",33,0) ;Long ID "RTN","VAFHLZE1",34,0) I VAFSTR[",3," S X=$P(VAFNODE,"^",3),VAFHLZEL(3)=$S(X]"":$$M10^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",35,0) ;Short ID "RTN","VAFHLZE1",36,0) I VAFSTR[",4," S X=$P(VAFNODE,"^",4),VAFHLZEL(4)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",37,0) ;Done if not getting primary eligibility information "RTN","VAFHLZE1",38,0) I 'PRIME D Q "RTN","VAFHLZE1",39,0) .N Y,Z "RTN","VAFHLZE1",40,0) .S Y=$L(VAFSTR,",") "RTN","VAFHLZE1",41,0) .F X=1:1:Y S Z=$P(VAFSTR,",",X) I Z S:(Z>4) VAFHLZEL(Z)=HLQ "RTN","VAFHLZE1",42,0) ;Get needed nodes in Patient file (#2) "RTN","VAFHLZE1",43,0) N VAF "RTN","VAFHLZE1",44,0) F X=.3,.31,.321,.3217,.322,.362,.361 S VAF(X)=$G(^DPT(DFN,X)) "RTN","VAFHLZE1",45,0) ;Military Disability Retirement "RTN","VAFHLZE1",46,0) I VAFSTR[",5," S X=$P(VAFPELIG,"^",12),VAFHLZEL(5)=$S(X=0:"N",X=1:"Y",1:HLQ) "RTN","VAFHLZE1",47,0) ;Claim Number "RTN","VAFHLZE1",48,0) I VAFSTR[",6," S X=$P(VAF(.31),"^",3),VAFHLZEL(6)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",49,0) ;Claim Folder Loc "RTN","VAFHLZE1",50,0) I VAFSTR[",7," S X=$P(VAF(.31),"^",2),VAFHLZEL(7)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",51,0) ;Veteran? "RTN","VAFHLZE1",52,0) I VAFSTR[",8," S X=$P($G(^DPT(DFN,"VET")),"^"),VAFHLZEL(8)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",53,0) ;Type "RTN","VAFHLZE1",54,0) I VAFSTR[",9," S X=$P($G(^DG(391,+$P($G(^DPT(DFN,"TYPE")),"^"),0)),"^"),VAFHLZEL(9)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",55,0) ;Elig Status "RTN","VAFHLZE1",56,0) I VAFSTR[10 S X=$P(VAF(.361),"^",1),VAFHLZEL(10)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",57,0) ;Elig Status Date "RTN","VAFHLZE1",58,0) I VAFSTR[11 S X=$P(VAF(.361),"^",2),VAFHLZEL(11)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",59,0) ;Elig Interim Response "RTN","VAFHLZE1",60,0) I VAFSTR[12 S X=$P(VAF(.361),"^",4),VAFHLZEL(12)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",61,0) ;Elig Verif. Method "RTN","VAFHLZE1",62,0) I VAFSTR[13 S X=$P(VAF(.361),"^",5),VAFHLZEL(13)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",63,0) ;Rec A&A Benefits? "RTN","VAFHLZE1",64,0) I VAFSTR[14 S X=$P(VAF(.362),"^",12),VAFHLZEL(14)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",65,0) ;Rec Housebound Benefits? "RTN","VAFHLZE1",66,0) I VAFSTR[15 S X=$P(VAF(.362),"^",13),VAFHLZEL(15)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",67,0) ;Rec VA Pension? "RTN","VAFHLZE1",68,0) I VAFSTR[16 S X=$P(VAF(.362),"^",14),VAFHLZEL(16)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",69,0) ;Rec VA Disability? "RTN","VAFHLZE1",70,0) I VAFSTR[17 S X=$P(VAF(.3),"^",11),VAFHLZEL(17)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",71,0) ;Agent Orange Expos. Indicated? "RTN","VAFHLZE1",72,0) I VAFSTR[18 S X=$P(VAF(.321),"^",2),VAFHLZEL(18)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",73,0) ;Radiation Expos. Indicated? "RTN","VAFHLZE1",74,0) I VAFSTR[19 S X=$P(VAF(.321),"^",3),VAFHLZEL(19)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",75,0) ;Environmental Contaminants? "RTN","VAFHLZE1",76,0) I VAFSTR[20 S X=$P(VAF(.322),"^",13),VAFHLZEL(20)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",77,0) ;Total Annual VA Check Amount "RTN","VAFHLZE1",78,0) I VAFSTR[21 S X=$P(VAF(.362),"^",20),VAFHLZEL(21)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",79,0) ;Radiation Exposure Method "RTN","VAFHLZE1",80,0) I (VAFSTR[22) D "RTN","VAFHLZE1",81,0) .S X=$P(VAF(.321),"^",12) "RTN","VAFHLZE1",82,0) .S:(X="")!($L(X)>1) X=HLQ "RTN","VAFHLZE1",83,0) .S:(X'=HLQ) X=$TR(X,"NTB","234") "RTN","VAFHLZE1",84,0) .S VAFHLZEL(22)=X "RTN","VAFHLZE1",85,0) ;Call MST status API "RTN","VAFHLZE1",86,0) S VAFMST=$$GETSTAT^DGMSTAPI(DFN,$G(VAFMSTDT)) "RTN","VAFHLZE1",87,0) I $P(VAFMST,"^",1)<0 D I 1 "RTN","VAFHLZE1",88,0) .F J=23,24,25 I VAFSTR[J S VAFHLZEL(J)=HLQ "RTN","VAFHLZE1",89,0) E D "RTN","VAFHLZE1",90,0) .;Current MST status "RTN","VAFHLZE1",91,0) .I VAFSTR[23 S X=$P(VAFMST,"^",2),VAFHLZEL(23)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",92,0) .;MST status change date "RTN","VAFHLZE1",93,0) .I VAFSTR[24 S X=$P(VAFMST,"^",3),VAFHLZEL(24)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",94,0) .;Site determining MST status "RTN","VAFHLZE1",95,0) .I VAFSTR[25 S X=$P(VAFMST,"^",7) S X=$$GET1^DIQ(4,(+X)_",",99) S VAFHLZEL(25)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",96,0) ;Agent Orange Registration Date "RTN","VAFHLZE1",97,0) I VAFSTR[26 S X=$P(VAF(.321),"^",7),VAFHLZEL(26)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",98,0) ;Agent Orange Exam Date "RTN","VAFHLZE1",99,0) I VAFSTR[27 S X=$P(VAF(.321),"^",9),VAFHLZEL(27)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",100,0) ;Agent Orange Registration # "RTN","VAFHLZE1",101,0) I VAFSTR[28 S X=$P(VAF(.321),"^",10),VAFHLZEL(28)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",102,0) ;Agent Orange Exposure Location "RTN","VAFHLZE1",103,0) ;I VAFSTR[29 S X=$P(VAF(.321),"^",13),VAFHLZEL(29)=$S(X]"":X,$P(VAF(.321),U,2)="Y":"U",1:HLQ) "RTN","VAFHLZE1",104,0) ;DG*5.3*1018 - Add Blue Water Navy value "RTN","VAFHLZE1",105,0) ;I VAFSTR[29 S X=$P(VAF(.321),"^",13),VAFHLZEL(29)=$S(",K,V,O,"[(","_X_","):X,1:HLQ) "RTN","VAFHLZE1",106,0) I VAFSTR[29 S X=$P(VAF(.321),"^",13),VAFHLZEL(29)=$S(",K,V,O,B,"[(","_X_","):X,1:HLQ) "RTN","VAFHLZE1",107,0) ;Radiation Registration Date "RTN","VAFHLZE1",108,0) I VAFSTR[30 S X=$P(VAF(.321),"^",11),VAFHLZEL(30)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",109,0) ;Envir. Cont. Exam Date "RTN","VAFHLZE1",110,0) I VAFSTR[31 S X=$P(VAF(.322),"^",15),VAFHLZEL(31)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",111,0) ;Envir. Cont. Registration date "RTN","VAFHLZE1",112,0) I VAFSTR[32 S X=$P(VAF(.322),"^",14),VAFHLZEL(32)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",113,0) ;Monetary Ben. Verify Date "RTN","VAFHLZE1",114,0) I VAFSTR[33 S X=$P(VAF(.3),"^",6),VAFHLZEL(33)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",115,0) ;User Enrollee Valid Through "RTN","VAFHLZE1",116,0) I VAFSTR[34 S X=$P(VAF(.361),"^",7),VAFHLZEL(34)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",117,0) ;User Enrollee Site "RTN","VAFHLZE1",118,0) I VAFSTR[35 S X=$P(VAF(.361),"^",8),X=$$GET1^DIQ(4,+X,99),VAFHLZEL(35)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",119,0) ;Combat Vet "RTN","VAFHLZE1",120,0) I (VAFSTR[37)!(VAFSTR[38) D "RTN","VAFHLZE1",121,0) .N CVET "RTN","VAFHLZE1",122,0) .S CVET=$$CVEDT^DGCV(DFN) "RTN","VAFHLZE1",123,0) .;Eligible "RTN","VAFHLZE1",124,0) .I VAFSTR[37 D "RTN","VAFHLZE1",125,0) ..S X=+CVET "RTN","VAFHLZE1",126,0) ..S:X<0 X="" "RTN","VAFHLZE1",127,0) ..S VAFHLZEL(37)=$S(X]"":$$YN^VAFHLFNC(X),1:HLQ) "RTN","VAFHLZE1",128,0) .;End Date "RTN","VAFHLZE1",129,0) .I VAFSTR[38 D "RTN","VAFHLZE1",130,0) ..S X=+$P(CVET,"^",2) "RTN","VAFHLZE1",131,0) ..S VAFHLZEL(38)=$S(X:$$HLDATE^HLFNC(X),1:HLQ) "RTN","VAFHLZE1",132,0) ;Discharge Due To Disability "RTN","VAFHLZE1",133,0) I VAFSTR[39 S X=$P(VAFPELIG,"^",13),VAFHLZEL(39)=$S(X=0:"N",X=1:"Y",1:HLQ) "RTN","VAFHLZE1",134,0) ;SHAD Indicator "RTN","VAFHLZE1",135,0) I VAFSTR[40 S X=$P(VAF(.321),"^",15),VAFHLZEL(40)=$S(X=0:"N",X=1:"Y",1:HLQ) "RTN","VAFHLZE1",136,0) ;CAMP LEJEUNE ELIGIBILITY INDICATOR DG*5.3*909 "RTN","VAFHLZE1",137,0) S X=$P(VAF(.3217),"^",1),VAFHLZEL(41)=$S(X="Y":1,X="N":0,1:HLQ) "RTN","VAFHLZE1",138,0) ;CAMP LEJEUNE ELIGIBILITY DATE REGISTERED "RTN","VAFHLZE1",139,0) I VAFSTR[42 S X=$P(VAF(.3217),"^",2),VAFHLZEL(42)=$S(X]"":$P($$HLDATE^HLFNC(X,"DT"),"^",1),1:HLQ) "RTN","VAFHLZE1",140,0) ;CAMP LEJEUNE ELIGIBILITY CHANGE SITE "RTN","VAFHLZE1",141,0) I VAFSTR[43 S X=$P(VAF(.3217),"^",3),VAFHLZEL(43)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",142,0) ;CAMP LEJEUNE ELIGIBILITY SOURCE OF CHANGE "RTN","VAFHLZE1",143,0) I VAFSTR[44 S X=$P(VAF(.3217),"^",4),VAFHLZEL(44)=$S(X]"":X,1:HLQ) "RTN","VAFHLZE1",144,0) S ISOTH="",IEN33=+$O(^DGOTH(33,"B",DFN,"")) I IEN33 S ISOTH=$$GET1^DIQ(33,IEN33_",",.02,"I") "RTN","VAFHLZE1",145,0) ;OTH Eligibility Indicator "RTN","VAFHLZE1",146,0) I VAFSTR[45 S VAFHLZEL(45)=$S(IEN33:ISOTH,1:"") "RTN","VAFHLZE1",147,0) ;OTH Eligibility Factor Code "RTN","VAFHLZE1",148,0) I VAFSTR[46 S VAFHLZEL(46)="" S:IEN33 X=$$GET1^DIQ(2,DFN_",",.5501,"I"),VAFHLZEL(46)=$S(X="OTH-90":1,X="OTH-EXT":2,1:"") "RTN","VAFHLZE1",149,0) ;OTH Eligibility Update Date "RTN","VAFHLZE1",150,0) I VAFSTR[47 S VAFHLZEL(47)=$S(IEN33:$$HLDATE^HLFNC($$GETTIMST^DGOTHEL(DFN)),1:"") "RTN","VAFHLZE1",151,0) ;Done "RTN","VAFHLZE1",152,0) Q "VER") 8.0^22.2 "^DD",2,2,.32102,0) AGENT ORANGE EXPOS. INDICATED?^RSX^Y:YES;N:NO;U:UNKNOWN;^.321;2^S DFN=DA D SV^DGLOCK "^DD",2,2,.32102,.1) EXPOSED TO AGENT ORANGE "^DD",2,2,.32102,1,0) ^.1^^-1 "^DD",2,2,.32102,1,1,0) ^^TRIGGER^2^.32107 "^DD",2,2,.32102,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.32102,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="NO" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X="" X ^DD(2,.32102,1,1,1.4) "^DD",2,2,.32102,1,1,1.4) S DIH=$G(^DPT(DIV(0),.321)),DIV=X S $P(^(.321),U,7)=DIV,DIH=2,DIG=.32107 D ^DICR "^DD",2,2,.32102,1,1,2) Q "^DD",2,2,.32102,1,1,"CREATE CONDITION") #.32102="NO" "^DD",2,2,.32102,1,1,"CREATE VALUE") @ "^DD",2,2,.32102,1,1,"DELETE VALUE") NO EFFECT "^DD",2,2,.32102,1,1,"DT") 3080507 "^DD",2,2,.32102,1,1,"FIELD") #.32107 "^DD",2,2,.32102,1,2,0) ^^TRIGGER^2^.3211 "^DD",2,2,.32102,1,2,1) X ^DD(2,.32102,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.321)),DIV=X S $P(^(.321),U,10)=DIV,DIH=2,DIG=.3211 D ^DICR "^DD",2,2,.32102,1,2,1.3) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.32102,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="NO" "^DD",2,2,.32102,1,2,2) Q "^DD",2,2,.32102,1,2,"CREATE CONDITION") #.32102="NO" "^DD",2,2,.32102,1,2,"CREATE VALUE") @ "^DD",2,2,.32102,1,2,"DELETE VALUE") NO EFFECT "^DD",2,2,.32102,1,2,"DT") 3080507 "^DD",2,2,.32102,1,2,"FIELD") #.3211 "^DD",2,2,.32102,1,3,0) ^^TRIGGER^2^.32109 "^DD",2,2,.32102,1,3,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.32102,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))="NO" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X="" X ^DD(2,.32102,1,3,1.4) "^DD",2,2,.32102,1,3,1.4) S DIH=$G(^DPT(DIV(0),.321)),DIV=X S $P(^(.321),U,9)=DIV,DIH=2,DIG=.32109 D ^DICR "^DD",2,2,.32102,1,3,2) Q "^DD",2,2,.32102,1,3,"CREATE CONDITION") #.32102="NO" "^DD",2,2,.32102,1,3,"CREATE VALUE") @ "^DD",2,2,.32102,1,3,"DELETE VALUE") NO EFFECT "^DD",2,2,.32102,1,3,"DT") 3080507 "^DD",2,2,.32102,1,3,"FIELD") #.32109 "^DD",2,2,.32102,1,4,0) 2^AENR32102^MUMPS "^DD",2,2,.32102,1,4,1) D AUTOUPD^DGENA2(DA) "^DD",2,2,.32102,1,4,2) D AUTOUPD^DGENA2(DA) "^DD",2,2,.32102,1,4,3) DO NOT DELETE "^DD",2,2,.32102,1,4,"%D",0) ^.101^2^2^3140623^^^^ "^DD",2,2,.32102,1,4,"%D",1,0) This cross-reference is used to update the patient's current Patient Enrollment "^DD",2,2,.32102,1,4,"%D",2,0) record. "^DD",2,2,.32102,1,4,"DT") 2970630 "^DD",2,2,.32102,1,5,0) ^^TRIGGER^2^.3213 "^DD",2,2,.32102,1,5,1) X ^DD(2,.32102,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.321)),DIV=X S $P(^(.321),U,13)=DIV,DIH=2,DIG=.3213 D ^DICR "^DD",2,2,.32102,1,5,1.3) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.32102,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59),1)="NO" "^DD",2,2,.32102,1,5,2) Q "^DD",2,2,.32102,1,5,"CREATE CONDITION") #.32102="NO" "^DD",2,2,.32102,1,5,"CREATE VALUE") @ "^DD",2,2,.32102,1,5,"DELETE VALUE") NO EFFECT "^DD",2,2,.32102,1,5,"DT") 3010314 "^DD",2,2,.32102,1,5,"FIELD") #.3213 "^DD",2,2,.32102,3) Enter 'Y' if this patient claims exposure to agent orange, 'N' if not, 'U' if unknown. "^DD",2,2,.32102,20,0) ^.3LA^1^1 "^DD",2,2,.32102,20,1,0) AO "^DD",2,2,.32102,21,0) ^^16^16^3201217^ "^DD",2,2,.32102,21,1,0) For this veteran applicant enter 'Y' if s/he was exposed to the chemical "^DD",2,2,.32102,21,2,0) agent orange, 'N' if not, or 'U' if unknown. "^DD",2,2,.32102,21,3,0) "^DD",2,2,.32102,21,4,0) Exposure can be claimed by those serving in the KOREAN DMZ between "^DD",2,2,.32102,21,5,0) January 1, 1968 and December 31, 1969; or served in country in Vietnam or "^DD",2,2,.32102,21,6,0) the offshore waters of Vietnam during Jan 9, 1962 to May 7, 1975. "^DD",2,2,.32102,21,7,0) "^DD",2,2,.32102,21,8,0) When Consistency Check # 25 is active (AGENT ORANGE EXPOSURE INDICATED "^DD",2,2,.32102,21,9,0) WITHOUT VIETNAM ERA PERIOD OF SERVICE), exposure cannot be claimed unless "^DD",2,2,.32102,21,10,0) the Period of Service (#.323) field in the Patient (#2) file is answered "^DD",2,2,.32102,21,11,0) VIETNAM ERA, which entails those serving in the Korean DMZ between "^DD",2,2,.32102,21,12,0) January 1, 1968 and December 31, 1969 or served in country in Vietnam or "^DD",2,2,.32102,21,13,0) the offshore waters of Vietnam during Jan 9, 1962 to May 7, 1975. "^DD",2,2,.32102,21,14,0) "^DD",2,2,.32102,21,15,0) Once the service record has been verified only users who hold the "^DD",2,2,.32102,21,16,0) designated security key may enter/edit this field. "^DD",2,2,.32102,"DT") 3201209 "^DD",2,2,.3213) "^DD",2,2,.3213,0) AGENT ORANGE EXPOSURE LOCATION^RSX^B:BLUE WATER NAVY;K:KOREAN DMZ;V:VIETNAM;O:OTHER;^.321;13^Q "^DD",2,2,.3213,.1) Agent Orange Exposure Location "^DD",2,2,.3213,1,0) ^.1 "^DD",2,2,.3213,1,1,0) 2^AENR3213^MUMPS "^DD",2,2,.3213,1,1,1) D AUTOUPD^DGENA2(DA) "^DD",2,2,.3213,1,1,2) D AUTOUPD^DGENA2(DA) "^DD",2,2,.3213,1,1,3) DO NOT DELETE "^DD",2,2,.3213,1,1,"%D",0) ^.101^2^2^3201023^^^^ "^DD",2,2,.3213,1,1,"%D",1,0) This MUMPS cross-reference is used to update the patient's current "^DD",2,2,.3213,1,1,"%D",2,0) Patient Enrollment record. "^DD",2,2,.3213,1,1,"DT") 3060218 "^DD",2,2,.3213,3) Enter where the patient was exposed to agent orange. "^DD",2,2,.3213,5,1,0) 2^.32102^5 "^DD",2,2,.3213,12) Available locations are shown. "^DD",2,2,.3213,12.1) S DIC("S")="I $$CHKAOEL^DGRP6EF(Y)" "^DD",2,2,.3213,21,0) ^^5^5^3201208^ "^DD",2,2,.3213,21,1,0) For this veteran applicant who was exposed to agent orange (EXPOSED TO "^DD",2,2,.3213,21,2,0) AGENT ORANGE prompt must be answered YES) enter the location where the "^DD",2,2,.3213,21,3,0) exposure occurred. Once the service record has been verified only users "^DD",2,2,.3213,21,4,0) who hold the designated security key may enter/edit this field. This "^DD",2,2,.3213,21,5,0) field cannot be deleted as long as agent orange exposure is indicated. "^DD",2,2,.3213,"DEL",1,0) S DFN=DA D AOD^DGLOCK1 I '$D(X) "^DD",2,2,.3213,"DT") 3201229 "^DD",27.11,27.11,50.22,0) AGENT ORANGE EXPOSURE LOCATION^S^B:BLUE WATER NAVY;K:KOREAN DMZ;V:VIETNAM;O:OTHER;^E;22^Q "^DD",27.11,27.11,50.22,.1) "^DD",27.11,27.11,50.22,3) Enter where the patient was exposed to agent orange. "^DD",27.11,27.11,50.22,21,0) ^.001^3^3^3201023^^^^ "^DD",27.11,27.11,50.22,21,1,0) For this veteran applicant who was exposed to agent orange (EXPOSED TO "^DD",27.11,27.11,50.22,21,2,0) AGENT ORANGE prompt must be answered YES) enter the location where the "^DD",27.11,27.11,50.22,21,3,0) exposure occurred. "^DD",27.11,27.11,50.22,"DT") 3201209 "^DD",43,43,1402,0) BWN ACTIVE DATE^DI^^BWN;1^S %DT="EX" D ^%DT S X=Y K:Y<1 X "^DD",43,43,1402,3) Enter the date on which "BLUE WATER NAVY" is a valid Agent Orange Exposure Location and can be entered by the user. "^DD",43,43,1402,21,0) ^.001^2^2^3201207^^ "^DD",43,43,1402,21,1,0) The date on which "BLUE WATER NAVY" is a valid Agent Orange Exposure "^DD",43,43,1402,21,2,0) Location and can be entered by the user. "^DD",43,43,1402,"DT") 3201207 **END** **END**