Released DG*5.3*1007 SEQ #887 Extracted from mail message **KIDS**:DG*5.3*1007^ **INSTALL NAME** DG*5.3*1007 "BLD",11852,0) DG*5.3*1007^REGISTRATION^0^3200707^y "BLD",11852,1,0) ^^8^8^3200621^ "BLD",11852,1,1,0) Patch DG*5.3*1007 address two issues "BLD",11852,1,2,0) "BLD",11852,1,3,0) 1. The Service Component (.04) field of the Military Service Episode "BLD",11852,1,4,0) (.3216) sub-file is not being extracted with the corresponding Military "BLD",11852,1,5,0) Service Episode data "BLD",11852,1,6,0) "BLD",11852,1,7,0) 2. Incorrect Help Text Displays on Registration Screen for Multiple Birth "BLD",11852,1,8,0) Indicator "BLD",11852,4,0) ^9.64PA^^ "BLD",11852,6.3) 3 "BLD",11852,"KRN",0) ^9.67PA^1.5^25 "BLD",11852,"KRN",.4,0) .4 "BLD",11852,"KRN",.401,0) .401 "BLD",11852,"KRN",.402,0) .402 "BLD",11852,"KRN",.403,0) .403 "BLD",11852,"KRN",.5,0) .5 "BLD",11852,"KRN",.84,0) .84 "BLD",11852,"KRN",1.5,0) 1.5 "BLD",11852,"KRN",1.6,0) 1.6 "BLD",11852,"KRN",1.61,0) 1.61 "BLD",11852,"KRN",1.62,0) 1.62 "BLD",11852,"KRN",3.6,0) 3.6 "BLD",11852,"KRN",3.8,0) 3.8 "BLD",11852,"KRN",9.2,0) 9.2 "BLD",11852,"KRN",9.8,0) 9.8 "BLD",11852,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",11852,"KRN",9.8,"NM",1,0) DGRPECE^^0^B92896470 "BLD",11852,"KRN",9.8,"NM",2,0) VADPT4^^0^B45368870 "BLD",11852,"KRN",9.8,"NM","B","DGRPECE",1) "BLD",11852,"KRN",9.8,"NM","B","VADPT4",2) "BLD",11852,"KRN",19,0) 19 "BLD",11852,"KRN",19.1,0) 19.1 "BLD",11852,"KRN",101,0) 101 "BLD",11852,"KRN",409.61,0) 409.61 "BLD",11852,"KRN",771,0) 771 "BLD",11852,"KRN",779.2,0) 779.2 "BLD",11852,"KRN",870,0) 870 "BLD",11852,"KRN",8989.51,0) 8989.51 "BLD",11852,"KRN",8989.52,0) 8989.52 "BLD",11852,"KRN",8993,0) 8993 "BLD",11852,"KRN",8994,0) 8994 "BLD",11852,"KRN","B",.4,.4) "BLD",11852,"KRN","B",.401,.401) "BLD",11852,"KRN","B",.402,.402) "BLD",11852,"KRN","B",.403,.403) "BLD",11852,"KRN","B",.5,.5) "BLD",11852,"KRN","B",.84,.84) "BLD",11852,"KRN","B",1.5,1.5) "BLD",11852,"KRN","B",1.6,1.6) "BLD",11852,"KRN","B",1.61,1.61) "BLD",11852,"KRN","B",1.62,1.62) "BLD",11852,"KRN","B",3.6,3.6) "BLD",11852,"KRN","B",3.8,3.8) "BLD",11852,"KRN","B",9.2,9.2) "BLD",11852,"KRN","B",9.8,9.8) "BLD",11852,"KRN","B",19,19) "BLD",11852,"KRN","B",19.1,19.1) "BLD",11852,"KRN","B",101,101) "BLD",11852,"KRN","B",409.61,409.61) "BLD",11852,"KRN","B",771,771) "BLD",11852,"KRN","B",779.2,779.2) "BLD",11852,"KRN","B",870,870) "BLD",11852,"KRN","B",8989.51,8989.51) "BLD",11852,"KRN","B",8989.52,8989.52) "BLD",11852,"KRN","B",8993,8993) "BLD",11852,"KRN","B",8994,8994) "BLD",11852,"QDEF") ^^^^^^^^^^YES "BLD",11852,"QUES",0) ^9.62^^ "BLD",11852,"REQB",0) ^9.611^2^2 "BLD",11852,"REQB",1,0) DG*5.3*965^1 "BLD",11852,"REQB",2,0) DG*5.3*952^1 "BLD",11852,"REQB","B","DG*5.3*952",2) "BLD",11852,"REQB","B","DG*5.3*965",1) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 1007^3200707 "PKG",5,22,1,"PAH",1,1,0) ^^8^8^3200707 "PKG",5,22,1,"PAH",1,1,1,0) Patch DG*5.3*1007 address two issues "PKG",5,22,1,"PAH",1,1,2,0) "PKG",5,22,1,"PAH",1,1,3,0) 1. The Service Component (.04) field of the Military Service Episode "PKG",5,22,1,"PAH",1,1,4,0) (.3216) sub-file is not being extracted with the corresponding Military "PKG",5,22,1,"PAH",1,1,5,0) Service Episode data "PKG",5,22,1,"PAH",1,1,6,0) "PKG",5,22,1,"PAH",1,1,7,0) 2. Incorrect Help Text Displays on Registration Screen for Multiple Birth "PKG",5,22,1,"PAH",1,1,8,0) Indicator "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") 2 "RTN","DGRPECE") 0^1^B92896470^B92843483 "RTN","DGRPECE",1,0) DGRPECE ;ALB/MRY,ERC,BAJ,NCA - REGISTRATION CATASTROPHIC EDITS ; 10/4/06 3:27pm "RTN","DGRPECE",2,0) ;;5.3;Registration;**638,682,700,720,653,688,750,831,907,965,1007**;Aug 13, 1993;Build 3 "RTN","DGRPECE",3,0) ; "RTN","DGRPECE",4,0) CEDITS(DFN) ;catastrophic edits - buffer values, save after check "RTN","DGRPECE",5,0) ;Input; "RTN","DGRPECE",6,0) ; DFN := patient ien "RTN","DGRPECE",7,0) ;Catastrophic edits will prompt for name, ssn, dob, and sex. Placing "RTN","DGRPECE",8,0) ;responses into a buffer space. User will be alerted on catastrophic "RTN","DGRPECE",9,0) ;edits on the following conditions: "RTN","DGRPECE",10,0) ; 1. Two or more catastrophic edits will generate a warning message. "RTN","DGRPECE",11,0) ; 2. Acceptance of two or more catastrophic edits will generate an alert "RTN","DGRPECE",12,0) ; to appropriate supervising staff holding the DG CATASTROPHIC EDIT key. "RTN","DGRPECE",13,0) ; 3. Acceptance of <2 catastrophic edits will process normally. "RTN","DGRPECE",14,0) ; "RTN","DGRPECE",15,0) ; Arrays: BEFORE - Holds patient values before the edit process "RTN","DGRPECE",16,0) ; (before snapshot). "RTN","DGRPECE",17,0) ; BUFFER - initialized with BEFORE array, holds edited changes "RTN","DGRPECE",18,0) ; (after snapshot). "RTN","DGRPECE",19,0) ; SAVE - holds only edited changes for filing into file #2. "RTN","DGRPECE",20,0) ; "RTN","DGRPECE",21,0) N DA,DIR,DIRUT,Y,BUFFER,BEFORE,SAVE,DG20IEN,XUNOTRIG "RTN","DGRPECE",22,0) D BEFORE(DFN,.BEFORE,.BUFFER) ;retrieve before patient values "RTN","DGRPECE",23,0) ;buffer - get name "RTN","DGRPECE",24,0) K DG20NAME "RTN","DGRPECE",25,0) S BUFFER("NAME")=$$NCEDIT^DPTNAME(DFN,,.DG20NAME) "RTN","DGRPECE",26,0) I BUFFER("NAME")="" S BUFFER("NAME")=BEFORE("NAME") "RTN","DGRPECE",27,0) I $D(DG20NAME("FAMILY")) S BUFFER("FAMILY")=DG20NAME("FAMILY") "RTN","DGRPECE",28,0) I $D(DG20NAME("GIVEN")) S BUFFER("GIVEN")=DG20NAME("GIVEN") "RTN","DGRPECE",29,0) I $D(DG20NAME("MIDDLE")) S BUFFER("MIDDLE")=DG20NAME("MIDDLE") "RTN","DGRPECE",30,0) I $D(DG20NAME("SUFFIX")) S BUFFER("SUFFIX")=DG20NAME("SUFFIX") "RTN","DGRPECE",31,0) ; the formal name is last name, first name, middle name and suffix "RTN","DGRPECE",32,0) ; the prefix and degree are only stored in file 20 "RTN","DGRPECE",33,0) I $D(DG20NAME("PREFIX")) S BUFFER("PREFIX")=DG20NAME("PREFIX") "RTN","DGRPECE",34,0) I $D(DG20NAME("DEGREE")) S BUFFER("DEGREE")=DG20NAME("DEGREE") "RTN","DGRPECE",35,0) K DG20NAME "RTN","DGRPECE",36,0) ;DG*5.3*688 BAJ if SSN is verified, do not allow edits "RTN","DGRPECE",37,0) I BEFORE("SSNV")="VERIFIED" D G DOB "RTN","DGRPECE",38,0) . S BUFFER("SSN")=BEFORE("SSN") "RTN","DGRPECE",39,0) . W !,"SSN: "_BUFFER("SSN") "RTN","DGRPECE",40,0) . W !,"SOCIAL SECURITY NUMBER "_BUFFER("SSN")_" has been verified by SSA --NO EDITING" "RTN","DGRPECE",41,0) ;buffer - get ssn "RTN","DGRPECE",42,0) S DIR(0)="2,.09^^" "RTN","DGRPECE",43,0) S DA=DFN D ^DIR "RTN","DGRPECE",44,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",45,0) S BUFFER("SSN")=Y "RTN","DGRPECE",46,0) ;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC "RTN","DGRPECE",47,0) I $G(BUFFER("SSN"))["P" D I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",48,0) REAS . ; "RTN","DGRPECE",49,0) . N DGREA,DGQSSN,DIR "RTN","DGRPECE",50,0) . S DGQSSN=0 "RTN","DGRPECE",51,0) . S DGREA=$P($G(^DPT(DFN,"SSN")),U) "RTN","DGRPECE",52,0) . S DIR(0)="2,.0906^^" "RTN","DGRPECE",53,0) . S DA=DFN "RTN","DGRPECE",54,0) . D ^DIR "RTN","DGRPECE",55,0) . I ($D(DUOUT)!($D(DTOUT))!($D(DIRUT))),($G(BUFFER("SSNREAS"))']"") D "RTN","DGRPECE",56,0) . . W !?10,"PSSN Reason Required if SSN is a Pseudo." "RTN","DGRPECE",57,0) . . I $G(BEFORE("SSN"))["P" G REAS "RTN","DGRPECE",58,0) . . I $G(BEFORE("SSN"))']"" G REAS "RTN","DGRPECE",59,0) . . S DIR(0)="YA",DIR("A")=" Delete Pseudo SSN?: ",DIR("?")="If the SSN is a Pseudo SSN there must be a Pseudo SSN Reason.",DIR("B")="YES" "RTN","DGRPECE",60,0) . . D ^DIR "RTN","DGRPECE",61,0) . . I Y=1 S BUFFER("SSN")=BEFORE("SSN"),DGQSSN=1,Y="" Q "RTN","DGRPECE",62,0) . . G REAS "RTN","DGRPECE",63,0) . I DGQSSN=1 Q "RTN","DGRPECE",64,0) . S BUFFER("SSNREAS")=Y "RTN","DGRPECE",65,0) . I $D(DIRUT)!('$D(BUFFER("SSN"))) D CECHECK Q "RTN","DGRPECE",66,0) DOB ;buffer - get dob "RTN","DGRPECE",67,0) S DIR(0)="2,.03^^" "RTN","DGRPECE",68,0) S DA=DFN D ^DIR "RTN","DGRPECE",69,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",70,0) S BUFFER("DOB")=Y "RTN","DGRPECE",71,0) SEX ;buffer - get sex "RTN","DGRPECE",72,0) S DIR(0)="2,.02^^" "RTN","DGRPECE",73,0) S DIR("A")="BIRTH SEX" ; DG*5.3*907 "RTN","DGRPECE",74,0) S DA=DFN D ^DIR "RTN","DGRPECE",75,0) K DIR("A") ; DG*5.3*907 "RTN","DGRPECE",76,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",77,0) S BUFFER("SEX")=Y "RTN","DGRPECE",78,0) ; DG*5.3*907 - begin of SIGI change in this section "RTN","DGRPECE",79,0) SIGI ;buffer - get Self-Identified Gender Identity ; DG*5.3*907 "RTN","DGRPECE",80,0) S DIR(0)="SAB^M:Male;F:Female;TM:Transmale/Transman/Female-to-Male;TF:Transfemale/Transwoman/Male-to-Female;O:Other;N:individual chooses not to answer" "RTN","DGRPECE",81,0) S DIR("?",1)="Select the code that specifies the patient's preferred gender." "RTN","DGRPECE",82,0) S DIR("?",2)="This SELF IDENTIFIED GENDER value indicates the patient's view of" "RTN","DGRPECE",83,0) S DIR("?")="their gender identity, if they choose to provide it." "RTN","DGRPECE",84,0) S DIR("A")="SELF-IDENTIFIED GENDER IDENTITY: " S:$G(BEFORE("SIGI"))'="" DIR("B")=$$GET1^DIQ(2,+DFN_",",.024) "RTN","DGRPECE",85,0) D ^DIR "RTN","DGRPECE",86,0) K DIR("A"),DIR("B"),DIR("?") "RTN","DGRPECE",87,0) I $D(DIRUT) S BUFFER("SIGI")=BEFORE("SIGI") D CECHECK Q "RTN","DGRPECE",88,0) S BUFFER("SIGI")=Y "RTN","DGRPECE",89,0) ; DG*5.3*907 - end-section of SIGI "RTN","DGRPECE",90,0) MBI ; buffer - get MBI (multiple birth indicator) "RTN","DGRPECE",91,0) S DIR(0)="2,994^^" "RTN","DGRPECE",92,0) S DA=DFN D ^DIR "RTN","DGRPECE",93,0) S BUFFER("MBI")=Y "RTN","DGRPECE",94,0) I $D(DIRUT) D CECHECK Q "RTN","DGRPECE",95,0) CECHECK ;do catastrophic edit checks, alert, and save "RTN","DGRPECE",96,0) N DGCNT,DGCEFLG "RTN","DGRPECE",97,0) ;Compare before/buffer arrays, putting edits into save array.S DIR("A")="SELF IDENTIFIED GENDER IDENTITY" "RTN","DGRPECE",98,0) S DGCNT=$$AFTER(.BEFORE,.BUFFER,.SAVE) "RTN","DGRPECE",99,0) ; DGCNT: 0 = no changes "RTN","DGRPECE",100,0) ; 1 = only one edit change, ok to save w/o CE message "RTN","DGRPECE",101,0) ; >1 = more then 1 edit, give CE message "RTN","DGRPECE",102,0) I DGCNT>1 D ;give CE message "RTN","DGRPECE",103,0) . S DGCEFLG=$$WARNING() "RTN","DGRPECE",104,0) . ; DGCEFLG: 0 = exit without saving changes "RTN","DGRPECE",105,0) . ; 1 = send alert and save "RTN","DGRPECE",106,0) . I DGCEFLG=0 S DGCNT=0 "RTN","DGRPECE",107,0) I DGCNT>0 D SAVE(DFN) I $D(DGCEFLG),DGCEFLG D ALERT "RTN","DGRPECE",108,0) Q "RTN","DGRPECE",109,0) ; "RTN","DGRPECE",110,0) SAVE(DFN) ;store accepted/edited values into patient file "RTN","DGRPECE",111,0) N FDATA,DIERR "RTN","DGRPECE",112,0) I $D(SAVE("NAME")) S FDATA(2,+DFN_",",.01)=SAVE("NAME") "RTN","DGRPECE",113,0) I $D(SAVE("DOB")) S FDATA(2,+DFN_",",.03)=SAVE("DOB") "RTN","DGRPECE",114,0) I $D(SAVE("SEX")) S FDATA(2,+DFN_",",.02)=SAVE("SEX") "RTN","DGRPECE",115,0) I $D(SAVE("SSN")) S FDATA(2,+DFN_",",.09)=SAVE("SSN") "RTN","DGRPECE",116,0) I $D(SAVE("SSNREAS")) S FDATA(2,+DFN_",",.0906)=SAVE("SSNREAS") "RTN","DGRPECE",117,0) I $D(SAVE("MBI")) S FDATA(2,+DFN_",",994)=SAVE("MBI") "RTN","DGRPECE",118,0) I $D(SAVE("SIGI")) S FDATA(2,+DFN_",",.024)=SAVE("SIGI") ; DG*5.3*907 "RTN","DGRPECE",119,0) D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",120,0) K FDATA,DIERR "RTN","DGRPECE",121,0) ;I '$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I") Q:DG20IEN="" ;DG*5.3*965 commented out this line "RTN","DGRPECE",122,0) I $G(DG20IEN),'$D(^VA(20,DG20IEN)) S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I") ;DG*5.3*965 "RTN","DGRPECE",123,0) I '$G(DG20IEN) D Q ;DG*5.3*965 "RTN","DGRPECE",124,0) .N DA,DIK "RTN","DGRPECE",125,0) .S DA=+DFN,DIK="^DPT(",DIK(1)=".01^ANAM01" D EN1^DIK "RTN","DGRPECE",126,0) .S DG20IEN=$$GET1^DIQ(2,+DFN_",",1.01,"I") "RTN","DGRPECE",127,0) Q:'$G(DG20IEN) "RTN","DGRPECE",128,0) I $D(SAVE("NAME")) D "RTN","DGRPECE",129,0) .S FDATA(20,+DG20IEN_",",1)=BUFFER("FAMILY") "RTN","DGRPECE",130,0) .S FDATA(20,+DG20IEN_",",2)=BUFFER("GIVEN") "RTN","DGRPECE",131,0) .S FDATA(20,+DG20IEN_",",3)=BUFFER("MIDDLE") "RTN","DGRPECE",132,0) .S FDATA(20,+DG20IEN_",",5)=BUFFER("SUFFIX") "RTN","DGRPECE",133,0) .S XUNOTRIG=1 "RTN","DGRPECE",134,0) .D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",135,0) .K FDATA,DIERR "RTN","DGRPECE",136,0) I $D(BUFFER("PREFIX")) S FDATA(20,+DG20IEN_",",4)=BUFFER("PREFIX") "RTN","DGRPECE",137,0) I $D(BUFFER("DEGREE")) S FDATA(20,+DG20IEN_",",6)=BUFFER("DEGREE") "RTN","DGRPECE",138,0) I $D(SAVE("PREFIX")) S FDATA(20,+DG20IEN_",",4)=SAVE("PREFIX") "RTN","DGRPECE",139,0) I $D(SAVE("DEGREE")) S FDATA(20,+DG20IEN_",",6)=SAVE("DEGREE") "RTN","DGRPECE",140,0) D FILE^DIE("","FDATA","DIERR") "RTN","DGRPECE",141,0) K FDATA,DIERR "RTN","DGRPECE",142,0) Q "RTN","DGRPECE",143,0) ; "RTN","DGRPECE",144,0) BEFORE(IEN,BEF,BUF) ;save original name, ssn, dob, sex, mbi, prefix, degree "RTN","DGRPECE",145,0) N DG20 "RTN","DGRPECE",146,0) S BEF("NAME")=$$GET1^DIQ(2,+IEN_",",.01),BUF("NAME")=BEF("NAME") "RTN","DGRPECE",147,0) S BEF("SSN")=$$GET1^DIQ(2,+IEN_",",.09),BUF("SSN")=BEF("SSN") "RTN","DGRPECE",148,0) ;Get SSN Verification flag DG*5.3*688 BAJ 11/22/2005 "RTN","DGRPECE",149,0) S BEF("SSNV")=$$GET1^DIQ(2,+IEN_",",.0907),BUF("SSNV")=BEF("SSNV") "RTN","DGRPECE",150,0) S BEF("SSNREAS")=$$GET1^DIQ(2,+IEN_",",.0906),BUF("SSNREAS")=BEF("SSNREAS") "RTN","DGRPECE",151,0) S BEF("DOB")=$$GET1^DIQ(2,+IEN_",",.03,"I"),BUF("DOB")=BEF("DOB") "RTN","DGRPECE",152,0) S BEF("SEX")=$$GET1^DIQ(2,+IEN_",",.02,"I"),BUF("SEX")=BEF("SEX") "RTN","DGRPECE",153,0) S BEF("MBI")=$$GET1^DIQ(2,+IEN_",",994,"I"),BUF("MBI")=BEF("MBI") "RTN","DGRPECE",154,0) S BEF("SIGI")=$$GET1^DIQ(2,+IEN_",",.024,"I"),BUF("SIGI")=BEF("SIGI") ; DG*5.3*907 "RTN","DGRPECE",155,0) D GETS^DIQ(2,+IEN_",",1.01,"I","DG20") "RTN","DGRPECE",156,0) S BEF("FAMILY")="",BEF("GIVEN")="",BUF("FAMILY")="",BUF("GIVEN")="" "RTN","DGRPECE",157,0) S BEF("MIDDLE")="",BEF("SUFFIX")="",BUF("MIDDLE")="",BUF("SUFFIX")="" "RTN","DGRPECE",158,0) S BEF("PREFIX")="",BEF("DEGREE")="",BUF("PREFIX")="",BUF("DEGREE")="" "RTN","DGRPECE",159,0) S DG20IEN=DG20(2,+IEN_",",1.01,"I") "RTN","DGRPECE",160,0) I $$GET1^DIQ(20,+DG20IEN_",",.03)[+IEN D "RTN","DGRPECE",161,0) . S BEF("FAMILY")=$$GET1^DIQ(20,+DG20IEN_",",1),BUF("FAMILY")=BEF("FAMILY") "RTN","DGRPECE",162,0) . S BEF("GIVEN")=$$GET1^DIQ(20,+DG20IEN_",",2),BUF("GIVEN")=BEF("GIVEN") "RTN","DGRPECE",163,0) . S BEF("MIDDLE")=$$GET1^DIQ(20,+DG20IEN_",",3),BUF("MIDDLE")=BEF("MIDDLE") "RTN","DGRPECE",164,0) . S BEF("SUFFIX")=$$GET1^DIQ(20,+DG20IEN_",",5),BUF("SUFFIX")=BEF("SUFFIX") "RTN","DGRPECE",165,0) . S BEF("PREFIX")=$$GET1^DIQ(20,+DG20IEN_",",4),BUF("PREFIX")=BEF("PREFIX") "RTN","DGRPECE",166,0) . S BEF("DEGREE")=$$GET1^DIQ(20,+DG20IEN_",",6),BUF("DEGREE")=BEF("DEGREE") "RTN","DGRPECE",167,0) ;add some demographic information (before snapshot) "RTN","DGRPECE",168,0) S BEF("MAIDEN")=$E($$GET1^DIQ(2,+IEN_",",.2403),1,17) "RTN","DGRPECE",169,0) S BEF("POBCITY")=$E($$GET1^DIQ(2,+IEN_",",.092),1,15) "RTN","DGRPECE",170,0) S BEF("POBSTATE")=$$GET1^DIQ(2,+IEN_",",.093,"I") "RTN","DGRPECE",171,0) Q "RTN","DGRPECE",172,0) ; "RTN","DGRPECE",173,0) AFTER(BEF,BUF,SAV) ;prevent catastrophic edit checks "RTN","DGRPECE",174,0) N DGCNT,DG20CNT S (DGCNT,DG20CNT)=0 "RTN","DGRPECE",175,0) I $D(BUF("FAMILY")),BUF("FAMILY")'="",BUF("FAMILY")'=BEF("FAMILY") D "RTN","DGRPECE",176,0) . S DG20CNT=DG20CNT+1 "RTN","DGRPECE",177,0) . S SAV("NAME")=BUF("NAME") "RTN","DGRPECE",178,0) I $D(BUF("GIVEN")),BUF("GIVEN")'="",BUF("GIVEN")'=BEF("GIVEN") D "RTN","DGRPECE",179,0) . S DG20CNT=DG20CNT+1 "RTN","DGRPECE",180,0) . S SAV("NAME")=BUF("NAME") "RTN","DGRPECE",181,0) I $D(BUF("MIDDLE")),BUF("MIDDLE")'=BEF("MIDDLE") D "RTN","DGRPECE",182,0) . S SAV("NAME")=BUF("NAME") ; minor change doesn't count "RTN","DGRPECE",183,0) I $D(BUF("SUFFIX")),BUF("SUFFIX")'=BEF("SUFFIX") D "RTN","DGRPECE",184,0) . S SAV("NAME")=BUF("NAME") ; minor change doesn't count "RTN","DGRPECE",185,0) I DG20CNT>0 S DGCNT=1 "RTN","DGRPECE",186,0) I $D(BUF("PREFIX")),BUF("PREFIX")'=BEF("PREFIX") D "RTN","DGRPECE",187,0) . S SAV("PREFIX")=BUF("PREFIX") "RTN","DGRPECE",188,0) I $D(BUF("DEGREE")),BUF("DEGREE")'=BEF("DEGREE") D "RTN","DGRPECE",189,0) . S SAV("DEGREE")=BUF("DEGREE") "RTN","DGRPECE",190,0) I $D(BUF("SIGI")),BUF("SIGI")'="",BUF("SIGI")'=BEF("SIGI") D ; DG*5.3*907 "RTN","DGRPECE",191,0) . S SAV("SIGI")=BUF("SIGI") ; DG*5.3*907 "RTN","DGRPECE",192,0) I $D(BUF("DOB")),BUF("DOB")'="",BUF("DOB")'=BEF("DOB") D "RTN","DGRPECE",193,0) . S SAV("DOB")=BUF("DOB"),DGCNT=DGCNT+1 "RTN","DGRPECE",194,0) I $D(BUF("SEX")),BUF("SEX")'="",BUF("SEX")'=BEF("SEX") D "RTN","DGRPECE",195,0) . S SAV("SEX")=BUF("SEX"),DGCNT=DGCNT+1 "RTN","DGRPECE",196,0) I $D(BUF("SSN")),BUF("SSN")'="",BUF("SSN")'=BEF("SSN") D "RTN","DGRPECE",197,0) . S SAV("SSN")=BUF("SSN"),DGCNT=DGCNT+1 "RTN","DGRPECE",198,0) I $D(BUF("SSNREAS")),BUF("SSNREAS")'="",BUF("SSNREAS")'=BEF("SSNREAS") D "RTN","DGRPECE",199,0) . S SAV("SSNREAS")=BUF("SSNREAS") "RTN","DGRPECE",200,0) I $D(BUF("MBI")),BUF("MBI")'=BEF("MBI") D "RTN","DGRPECE",201,0) . S SAV("MBI")=BUF("MBI") "RTN","DGRPECE",202,0) I DGCNT=0,$D(SAV("NAME")) Q 1 ;minor name change (i.e. middle name or suffix) "RTN","DGRPECE",203,0) I DGCNT=0,$D(SAV("PREFIX"))!($D(SAV("DEGREE"))) Q 1 ; prefix or degree change "RTN","DGRPECE",204,0) I DGCNT=0,$D(SAV("MBI")) Q 1 ; multiple birth indicator change "RTN","DGRPECE",205,0) I DGCNT=0,$D(SAV("SIGI")) Q 1 ; DG*5.3*907 - Add SIGI indicator change "RTN","DGRPECE",206,0) I DGCNT=0 Q 0 ;no changes "RTN","DGRPECE",207,0) ;DG*750 check audit file for previous changes made during the current day "RTN","DGRPECE",208,0) I DGCNT=1 D DGAUD^DGRPAUD(DFN,.DGCNT) "RTN","DGRPECE",209,0) ;Use temp file created in DGRPAUD to get information for other changes "RTN","DGRPECE",210,0) ;that were made during the day to print on the alert. "RTN","DGRPECE",211,0) N DGAUDIEN,DGFLD,DGTYP "RTN","DGRPECE",212,0) S DGAUDIEN=0 "RTN","DGRPECE",213,0) F S DGAUDIEN=$O(^TMP("DGRPAUD",$J,DFN,DGAUDIEN)) Q:'DGAUDIEN D "RTN","DGRPECE",214,0) .S DGFLD=$P(^TMP("DGRPAUD",$J,DFN,DGAUDIEN),U,2),DGTYP=$P(^TMP("DGRPAUD",$J,DFN,DGAUDIEN),U,5) "RTN","DGRPECE",215,0) .I DGFLD=.01 S BEF("NAME")=DGTYP "RTN","DGRPECE",216,0) .I DGFLD=.09 S BEF("SSN")=DGTYP "RTN","DGRPECE",217,0) .I DGFLD=.02 S BEF("SEX")=DGTYP "RTN","DGRPECE",218,0) .I DGFLD=.03 S BEF("DOB")=DGTYP "RTN","DGRPECE",219,0) .I DGFLD=.024 S BEF("SIGI")=DGTYP ; DG*5.3*907 "RTN","DGRPECE",220,0) I DGCNT<2 Q 1 ;make one change w/o CE message "RTN","DGRPECE",221,0) I DGCNT>1 Q 2 ;more than 1 change, send CE message "RTN","DGRPECE",222,0) K ^TMP("DGRPAUD") "RTN","DGRPECE",223,0) ; "RTN","DGRPECE",224,0) WARNING() ;CE warning message "RTN","DGRPECE",225,0) ;Output 0 = exit without saving changes "RTN","DGRPECE",226,0) ; 1 = send alert and save "RTN","DGRPECE",227,0) W !!,?25,"**WARNING!!**" "RTN","DGRPECE",228,0) W !!,"The edits you are about to make, may potentially change the identity of" "RTN","DGRPECE",229,0) W !,"this patient. Please verify that you have selected the correct patient" "RTN","DGRPECE",230,0) W !,"and ensure that supporting documentation exists for these changes. If" "RTN","DGRPECE",231,0) W !,"you continue with these edits, an alert will be generated and sent to" "RTN","DGRPECE",232,0) W !,"your Supervisor and ADPAC, notifying them of the changes." "RTN","DGRPECE",233,0) N DIR,DGANS,Y "RTN","DGRPECE",234,0) S DIR(0)="Y",DIR("A")="Do you wish to continue and save your edits:" "RTN","DGRPECE",235,0) S DIR("B")="NO" D ^DIR K DIR S DGANS=Y "RTN","DGRPECE",236,0) S DGANS=$S(Y=1:1,1:0) ;0=don't save, 1=save with CE alert "RTN","DGRPECE",237,0) Q DGANS "RTN","DGRPECE",238,0) ; "RTN","DGRPECE",239,0) ALERT ;Queue alert "RTN","DGRPECE",240,0) X ^%ZOSF("UCI") S ZTUCI=Y,ZTRTN="ALERT^DGRPECE1",ZTDTH=$H,ZTIO="",IEN=DFN "RTN","DGRPECE",241,0) F V="IEN","BEFORE(","BUFFER(","SAVE(","XQY" S ZTSAVE(V)="" "RTN","DGRPECE",242,0) S ZTDESC="Patient Catastrophic Edits alert" K V,ZTSK N X D ^%ZTLOAD Q "RTN","DGRPECE",243,0) ;D ALERT^DGRPECE1(DFN,.BEFORE,.BUFFER,.SAVE) "RTN","DGRPECE",244,0) Q "RTN","VADPT4") 0^2^B45368870^B44418572 "RTN","VADPT4",1,0) VADPT4 ;ALB/MRL,MJK,ERC,DIC,PWC - 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**;Aug 13, 1993;Build 3 "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 "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_"^"_$S(X="K":"KOREAN DMZ",1:"VIETNAM") 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 "VER") 8.0^22.2 "BLD",11852,6) ^887 **END** **END**