Released DG*5.3*947 SEQ #846 Extracted from mail message **KIDS**:DG*5.3*947^ **INSTALL NAME** DG*5.3*947 "BLD",10211,0) DG*5.3*947^REGISTRATION^0^3180703^y "BLD",10211,1,0) ^^2^2^3180703^^^ "BLD",10211,1,1,0) Please see the DG*5.3*947 patch description for detailed information "BLD",10211,1,2,0) regarding this patch. "BLD",10211,4,0) ^9.64PA^2^1 "BLD",10211,4,2,0) 2 "BLD",10211,4,2,2,0) ^9.641^2.3216^1 "BLD",10211,4,2,2,2.3216,0) MILITARY SERVICE EPISODE (sub-file) "BLD",10211,4,2,2,2.3216,1,0) ^9.6411^.08^2 "BLD",10211,4,2,2,2.3216,1,.08,0) FUTURE DISCHARGE DATE "BLD",10211,4,2,2,2.3216,1,.09,0) REASON FOR EARLY SEPARATION "BLD",10211,4,2,222) y^y^p^^^^n^^n "BLD",10211,4,2,224) "BLD",10211,4,"APDD",2,2.3216) "BLD",10211,4,"APDD",2,2.3216,.08) "BLD",10211,4,"APDD",2,2.3216,.09) "BLD",10211,4,"B",2,2) "BLD",10211,6.3) 13 "BLD",10211,"ABPKG") n "BLD",10211,"KRN",0) ^9.67PA^779.2^20 "BLD",10211,"KRN",.4,0) .4 "BLD",10211,"KRN",.4,"NM",0) ^9.68A^^ "BLD",10211,"KRN",.401,0) .401 "BLD",10211,"KRN",.402,0) .402 "BLD",10211,"KRN",.403,0) .403 "BLD",10211,"KRN",.5,0) .5 "BLD",10211,"KRN",.84,0) .84 "BLD",10211,"KRN",3.6,0) 3.6 "BLD",10211,"KRN",3.8,0) 3.8 "BLD",10211,"KRN",9.2,0) 9.2 "BLD",10211,"KRN",9.8,0) 9.8 "BLD",10211,"KRN",9.8,"NM",0) ^9.68A^5^4 "BLD",10211,"KRN",9.8,"NM",1,0) DGRP6^^0^B20074399 "BLD",10211,"KRN",9.8,"NM",2,0) DGRP61^^0^B64590268 "BLD",10211,"KRN",9.8,"NM",4,0) DGMSEUTL^^0^B18882941 "BLD",10211,"KRN",9.8,"NM",5,0) DGENUPL3^^0^B94088270 "BLD",10211,"KRN",9.8,"NM","B","DGENUPL3",5) "BLD",10211,"KRN",9.8,"NM","B","DGMSEUTL",4) "BLD",10211,"KRN",9.8,"NM","B","DGRP6",1) "BLD",10211,"KRN",9.8,"NM","B","DGRP61",2) "BLD",10211,"KRN",19,0) 19 "BLD",10211,"KRN",19,"NM",0) ^9.68A^^ "BLD",10211,"KRN",19.1,0) 19.1 "BLD",10211,"KRN",101,0) 101 "BLD",10211,"KRN",409.61,0) 409.61 "BLD",10211,"KRN",771,0) 771 "BLD",10211,"KRN",779.2,0) 779.2 "BLD",10211,"KRN",870,0) 870 "BLD",10211,"KRN",8989.51,0) 8989.51 "BLD",10211,"KRN",8989.52,0) 8989.52 "BLD",10211,"KRN",8994,0) 8994 "BLD",10211,"KRN","B",.4,.4) "BLD",10211,"KRN","B",.401,.401) "BLD",10211,"KRN","B",.402,.402) "BLD",10211,"KRN","B",.403,.403) "BLD",10211,"KRN","B",.5,.5) "BLD",10211,"KRN","B",.84,.84) "BLD",10211,"KRN","B",3.6,3.6) "BLD",10211,"KRN","B",3.8,3.8) "BLD",10211,"KRN","B",9.2,9.2) "BLD",10211,"KRN","B",9.8,9.8) "BLD",10211,"KRN","B",19,19) "BLD",10211,"KRN","B",19.1,19.1) "BLD",10211,"KRN","B",101,101) "BLD",10211,"KRN","B",409.61,409.61) "BLD",10211,"KRN","B",771,771) "BLD",10211,"KRN","B",779.2,779.2) "BLD",10211,"KRN","B",870,870) "BLD",10211,"KRN","B",8989.51,8989.51) "BLD",10211,"KRN","B",8989.52,8989.52) "BLD",10211,"KRN","B",8994,8994) "BLD",10211,"QDEF") ^^^^NO^^^^NO^^YES "BLD",10211,"QUES",0) ^9.62^^ "BLD",10211,"REQB",0) ^9.611^2^2 "BLD",10211,"REQB",1,0) DG*5.3*935^1 "BLD",10211,"REQB",2,0) DG*5.3*842^1 "BLD",10211,"REQB","B","DG*5.3*842",2) "BLD",10211,"REQB","B","DG*5.3*935",1) "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^y^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.3216) 1 "FIA",2,2.3216,.08) "FIA",2,2.3216,.09) "MBREQ") 0 "PKG",47,-1) 1^1 "PKG",47,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",47,20,0) ^9.402P^^ "PKG",47,22,0) ^9.49I^1^1 "PKG",47,22,1,0) 5.3^2930813^2960613 "PKG",47,22,1,"PAH",1,0) 947^3180703 "PKG",47,22,1,"PAH",1,1,0) ^^2^2^3180703 "PKG",47,22,1,"PAH",1,1,1,0) Please see the DG*5.3*947 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") 4 "RTN","DGENUPL3") 0^5^B94088270^B89567535 "RTN","DGENUPL3",1,0) DGENUPL3 ;ALB/CJM,ISA,KWP,AEG,BRM,ERC,CKN,BAJ,PHH,TDM,LBD,DJS,KUM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;12 June 2018 5:35PM "RTN","DGENUPL3",2,0) ;;5.3;REGISTRATION;**147,230,232,377,404,451,653,688,793,797,841,928,935,947**;Aug 13,1993;Build 13 "RTN","DGENUPL3",3,0) ; "RTN","DGENUPL3",4,0) ; "RTN","DGENUPL3",5,0) ADDMSG(MSGS,MESSAGE,TOHEC) ; "RTN","DGENUPL3",6,0) ;Description: Used to add a message to an array of messages to be sent. "RTN","DGENUPL3",7,0) ; "RTN","DGENUPL3",8,0) ;Input: "RTN","DGENUPL3",9,0) ; MSGS - the array to store the message (pass by reference) "RTN","DGENUPL3",10,0) ; MESSAGE - the message to store "RTN","DGENUPL3",11,0) ; TOHEC - a flag, if set to 1 it means that HEC should also receive notification "RTN","DGENUPL3",12,0) ; "RTN","DGENUPL3",13,0) ;Output: none "RTN","DGENUPL3",14,0) ; "RTN","DGENUPL3",15,0) I MESSAGE["DATE OF DEATH" Q "RTN","DGENUPL3",16,0) S MSGS(0)=($G(MSGS(0))+1) "RTN","DGENUPL3",17,0) S MSGS(MSGS(0))=MESSAGE "RTN","DGENUPL3",18,0) I ($G(TOHEC)=1) S MSGS("HEC")=1 "RTN","DGENUPL3",19,0) Q "RTN","DGENUPL3",20,0) ; "RTN","DGENUPL3",21,0) ; "RTN","DGENUPL3",22,0) NOTIFY(DGPAT,MSGS) ; "RTN","DGENUPL3",23,0) ;Description: This is used to send a message to the local mail group "RTN","DGENUPL3",24,0) ;defined by the MAS Parameter ELIGIBILITY UPLOAD MAIL GROUP.The "RTN","DGENUPL3",25,0) ;notification is to be used when specific problems or conditions "RTN","DGENUPL3",26,0) ;regarding the upload of the enrollment or eligibility data. "RTN","DGENUPL3",27,0) ; "RTN","DGENUPL3",28,0) ;Input: "RTN","DGENUPL3",29,0) ; OLDPAT -used if the DGPAT elements have not been built "RTN","DGENUPL3",30,0) ; DGPAT - patient array (pass by reference) "RTN","DGENUPL3",31,0) ; MSGS - the an array of messages that should be included in the "RTN","DGENUPL3",32,0) ; notification (pass by reference). If MSGS("HEC")=1 "RTN","DGENUPL3",33,0) ; it means that HEC should also receive notification. "RTN","DGENUPL3",34,0) ; "RTN","DGENUPL3",35,0) ;Output: none "RTN","DGENUPL3",36,0) ; "RTN","DGENUPL3",37,0) N TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT "RTN","DGENUPL3",38,0) N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG,CD,DGFDD "RTN","DGENUPL3",39,0) ; "RTN","DGENUPL3",40,0) ;if there are no alerts, then quit "RTN","DGENUPL3",41,0) Q:'$G(MSGS(0)) "RTN","DGENUPL3",42,0) ; "RTN","DGENUPL3",43,0) ;Get reason for alert. If there is more than one reason decide which "RTN","DGENUPL3",44,0) ;reason to display. 'NON-SERVICE' alerts have a higher priority than "RTN","DGENUPL3",45,0) ;other alerts and are therefore displayed before other alerts in the "RTN","DGENUPL3",46,0) ;subject line, followed by 'POW' alerts in priority. "RTN","DGENUPL3",47,0) S (ELIG,NSC,POW,CD)=0 "RTN","DGENUPL3",48,0) S COUNT=0 F S COUNT=$O(MSGS(COUNT)) Q:'COUNT!NSC D "RTN","DGENUPL3",49,0) .I MSGS(COUNT)["PREVIOUSLY ELIGIBLE" S ELIG=1 Q "RTN","DGENUPL3",50,0) .I MSGS(COUNT)["NON-SERVICE" S NSC=1 Q "RTN","DGENUPL3",51,0) .I MSGS(COUNT)["POW" S POW=1 Q "RTN","DGENUPL3",52,0) .I MSGS(COUNT)["CD EVALUATION" S CD=1 Q "RTN","DGENUPL3",53,0) .S HEADER=MSGS(COUNT) "RTN","DGENUPL3",54,0) .Q "RTN","DGENUPL3",55,0) D "RTN","DGENUPL3",56,0) .I ELIG S HEADER="Ineligibility Alert: " Q "RTN","DGENUPL3",57,0) .I NSC S HEADER="NSC Alert: " Q "RTN","DGENUPL3",58,0) .I POW&'NSC S HEADER="POW Alert: " Q "RTN","DGENUPL3",59,0) .I CD S HEADER="CD Alert: " Q "RTN","DGENUPL3",60,0) .Q "RTN","DGENUPL3",61,0) ; "RTN","DGENUPL3",62,0) S XMDF="" "RTN","DGENUPL3",63,0) S (XMDUN,XMDUZ)="Registration Enrollment Module" "RTN","DGENUPL3",64,0) ;Phase II Re-Enrollment "RTN","DGENUPL3",65,0) ;DGPAT("SSN") is built by the parser. DGPAT("NAME"),DGPAT("SEX"),DGPAT("DOB")(are merged into DGPAT from OLDPAT. "RTN","DGENUPL3",66,0) ;The checks below are to setup the DGPAT elements from OLDPAT if NOTIFY is called before the merge. "RTN","DGENUPL3",67,0) I '$D(DGPAT("NAME")) S DGPAT("NAME")=$G(OLDPAT("NAME")) "RTN","DGENUPL3",68,0) I '$D(DGPAT("SEX")) S DGPAT("SEX")=$G(OLDPAT("SEX")) "RTN","DGENUPL3",69,0) I '$D(DGPAT("DOB")) S DGPAT("DOB")=$G(OLDPAT("DOB")) "RTN","DGENUPL3",70,0) S TMPSTR=" ("_$E(DGPAT("NAME"),1,1) "RTN","DGENUPL3",71,0) S TMPSTR=TMPSTR_$E(DGPAT("SSN"),$L(DGPAT("SSN"))-3,1000)_")" "RTN","DGENUPL3",72,0) S XMSUB=$E(HEADER,1,30)_$E(DGPAT("NAME"),1,25)_TMPSTR "RTN","DGENUPL3",73,0) ; "RTN","DGENUPL3",74,0) ; send msg to local mail group specified in IVM SITE PARAMETER file "RTN","DGENUPL3",75,0) S MAILGRP=+$P($G(^IVM(301.9,1,0)),"^",9) "RTN","DGENUPL3",76,0) S MAILGRP=$$EXTERNAL^DILFD(301.9,.09,"F",MAILGRP) "RTN","DGENUPL3",77,0) I MAILGRP]"" S XMY("G."_MAILGRP)="" "RTN","DGENUPL3",78,0) ; "RTN","DGENUPL3",79,0) ;Patch DG*5.3*928 is removing ability to send emails to remote email group. Emails have been decommissioned and no longer required. "RTN","DGENUPL3",80,0) ;if flag is set, send msg to remote mail group specified in "RTN","DGENUPL3",81,0) ;the IVM SITE PARAMETER file "RTN","DGENUPL3",82,0) ;I $G(MSGS("HEC"))=1 D "RTN","DGENUPL3",83,0) ;.S MAILGRP=$P($G(^IVM(301.9,1,0)),"^",10) "RTN","DGENUPL3",84,0) ;.S MAILGRP=$$EXTERNAL^DILFD(301.9,.10,"F",MAILGRP) "RTN","DGENUPL3",85,0) ;.I MAILGRP]"" S XMY("G."_MAILGRP)="" "RTN","DGENUPL3",86,0) ; "RTN","DGENUPL3",87,0) ; "RTN","DGENUPL3",88,0) S XMTEXT="TEXT(" "RTN","DGENUPL3",89,0) S TEXT(1)="The enrollment/eligibility upload produced the following alerts:" "RTN","DGENUPL3",90,0) S TEXT(2)=" " "RTN","DGENUPL3",91,0) S TEXT(3)="Patient Name : "_DGPAT("NAME") "RTN","DGENUPL3",92,0) S TEXT(4)="SSN : "_DGPAT("SSN") "RTN","DGENUPL3",93,0) S TEXT(5)="DOB : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB")) "RTN","DGENUPL3",94,0) S TEXT(6)="SEX : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX")) "RTN","DGENUPL3",95,0) S TEXT(7)=" " "RTN","DGENUPL3",96,0) ; "RTN","DGENUPL3",97,0) S TEXT(8)=" ** Alerts **" "RTN","DGENUPL3",98,0) S TEXT(9)=" " "RTN","DGENUPL3",99,0) S COUNT=0 F S COUNT=$O(MSGS(COUNT)) Q:'COUNT S TEXT(10+COUNT)=COUNT_") "_MSGS(COUNT) "RTN","DGENUPL3",100,0) ; "RTN","DGENUPL3",101,0) D ^XMD "RTN","DGENUPL3",102,0) Q "RTN","DGENUPL3",103,0) ; "RTN","DGENUPL3",104,0) BEGUPLD(DFN) ; "RTN","DGENUPL3",105,0) ;Description: Sets a lock used to determine if an eligibility/enrollment "RTN","DGENUPL3",106,0) ;upload is in progress. "RTN","DGENUPL3",107,0) ; "RTN","DGENUPL3",108,0) ;Input: "RTN","DGENUPL3",109,0) ; DFN - ien, Patient record "RTN","DGENUPL3",110,0) ; "RTN","DGENUPL3",111,0) ;Output: "RTN","DGENUPL3",112,0) ; Function value - returns 1 if the lock was obtained, 0 otherwise. "RTN","DGENUPL3",113,0) ; "RTN","DGENUPL3",114,0) Q:'$G(DFN) 1 "RTN","DGENUPL3",115,0) L +^DGEN("ELIGIBILITY UPLOAD",DFN):3 "RTN","DGENUPL3",116,0) Q $T "RTN","DGENUPL3",117,0) ; "RTN","DGENUPL3",118,0) ENDUPLD(DFN) ; "RTN","DGENUPL3",119,0) ;Description: Releases the lock obtained by calling $$BEGUPLD(DFN) "RTN","DGENUPL3",120,0) ; "RTN","DGENUPL3",121,0) Q:'$G(DFN) "RTN","DGENUPL3",122,0) L -^DGEN("ELIGIBILITY UPLOAD",DFN) "RTN","DGENUPL3",123,0) Q "RTN","DGENUPL3",124,0) ; "RTN","DGENUPL3",125,0) CKUPLOAD(DFN) ; "RTN","DGENUPL3",126,0) ;Description: Checks if an upload is in progress. If so, it pauses "RTN","DGENUPL3",127,0) ;until it is completed. "RTN","DGENUPL3",128,0) ;The enrollment/eligibility upload can take a while to accomplish. "RTN","DGENUPL3",129,0) ;If the lock is not obtained initially, it is assumed that the upload "RTN","DGENUPL3",130,0) ;is in progress, and a message is displayed to the user. "RTN","DGENUPL3",131,0) ; "RTN","DGENUPL3",132,0) ;Input: DFN "RTN","DGENUPL3",133,0) ;Output: none "RTN","DGENUPL3",134,0) ; "RTN","DGENUPL3",135,0) N I "RTN","DGENUPL3",136,0) I '$$BEGUPLD(DFN) D "RTN","DGENUPL3",137,0) .W !!,"Upload of patient enrollment/eligibility data is in progress ..." "RTN","DGENUPL3",138,0) .D UNLOCK^DGENPTA1(DFN) "RTN","DGENUPL3",139,0) .F I=1:1:50 Q:$$BEGUPLD(DFN) W "." "RTN","DGENUPL3",140,0) .W !,"Upload of patient enrollment/eligibility data is completed.",! "RTN","DGENUPL3",141,0) D ENDUPLD(DFN) "RTN","DGENUPL3",142,0) Q "RTN","DGENUPL3",143,0) SCVET ;moved from DGENUPL4 - DG*5.3*688 "RTN","DGENUPL3",144,0) I DGPAT3("VETERAN")'="N" D "RTN","DGENUPL3",145,0) . I DGELG3("SC")="N" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","NSC VETERAN",0)) "RTN","DGENUPL3",146,0) . I DGELG3("SC")="Y" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","SC VETERAN",0)) "RTN","DGENUPL3",147,0) I DGPAT3("VETERAN")="N" S DGPAT3("PATYPE")=$$NONVET(DGELG("ELIG","CODE")) "RTN","DGENUPL3",148,0) Q "RTN","DGENUPL3",149,0) ; "RTN","DGENUPL3",150,0) NONVET(DGCODE) ;map Patient Type from Primary Elig (and POS) "RTN","DGENUPL3",151,0) ;added with DG*5.3*688 - ERC "RTN","DGENUPL3",152,0) ; input: DGCODE is the Primary Eligibility code "RTN","DGENUPL3",153,0) ; output: DGTPYE is returned as the value for Patient Type "RTN","DGENUPL3",154,0) N PTELG,DGTYPE "RTN","DGENUPL3",155,0) S (PTELG,DGTYPE)="" "RTN","DGENUPL3",156,0) Q:$G(DGCODE)']"" "" "RTN","DGENUPL3",157,0) S PTELG=$$NATNAME^DGENELA(DGCODE) "RTN","DGENUPL3",158,0) Q:$G(PTELG)']"" "" "RTN","DGENUPL3",159,0) I "CHAMPVA^OTHER FEDERAL AGENCY^REIMBURSABLE INSURANCE^SHARING AGREEMENT"[PTELG S DGTYPE=$$POS(.DGTYPE) Q:DGTYPE DGTYPE "RTN","DGENUPL3",160,0) S DGTYPE=$S(PTELG["ALLIED":"ALLIED VETERAN",PTELG["COLLATERAL":"COLLATERAL",PTELG["EMPLOYEE":"EMPLOYEE",PTELG["TRICARE":"TRICARE",1:"") "RTN","DGENUPL3",161,0) I DGTYPE']"" S DGTYPE="NON-VETERAN (OTHER)" ;default Pat Type "RTN","DGENUPL3",162,0) S DGTYPE=$O(^DG(391,"B",DGTYPE,"")) "RTN","DGENUPL3",163,0) Q DGTYPE "RTN","DGENUPL3",164,0) POS(DGTYPE) ;for these Elig Codes, check POS to determine Patient Type "RTN","DGENUPL3",165,0) S DGPOS=DGELG("POS") "RTN","DGENUPL3",166,0) I $G(DGPOS)']"" Q "" "RTN","DGENUPL3",167,0) I '$D(^DIC(21,DGPOS,0)) Q "" "RTN","DGENUPL3",168,0) S DGPOS=$P(^DIC(21,DGPOS,0),U) "RTN","DGENUPL3",169,0) S DGTYPE=$S(DGPOS["ACTIVE":"ACTIVE DUTY",DGPOS["OPERAT":"ACTIVE DUTY",DGPOS["RETIR":"MILITARY RETIREE",1:"") "RTN","DGENUPL3",170,0) I $G(DGTYPE)]"" S DGTYPE=$O(^DG(391,"B",DGTYPE,"")) "RTN","DGENUPL3",171,0) Q DGTYPE "RTN","DGENUPL3",172,0) ; "RTN","DGENUPL3",173,0) ;ZMH code moved here from DGENUPL2 - DG*5.3*653 "RTN","DGENUPL3",174,0) ZMH ;Purple Heart, POW, OEF/OIF Conflict Loc, Military Service Episodes, Medal of Honor "RTN","DGENUPL3",175,0) ;PROCESS PH, OEF/OIF, MH & POW FROM ZMH "RTN","DGENUPL3",176,0) ;Process Military Service Episodes (SL,SNL,SNNL,MSD) - DG*5.3*797 "RTN","DGENUPL3",177,0) ;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Future Discharge Date Added DG*5.3*935 "RTN","DGENUPL3",178,0) ;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Reason for Early Separation Added DG*5.3*947 "RTN","DGENUPL3",179,0) ;DJS, Indicate if the ZMH segment exists in this message; DG*5.3*935 "RTN","DGENUPL3",180,0) N DGNEW "RTN","DGENUPL3",181,0) S ^TMP($J,"DGENUPL","ZMH",0)=1 "RTN","DGENUPL3",182,0) I "^SL^SNL^SNNL^MSD^FDD^"[("^"_SEG(2)_"^") D Q "RTN","DGENUPL3",183,0) . ;DJS, Store the Future Discharge Date (FDD); DG*5.3*935 "RTN","DGENUPL3",184,0) . I SEG(2)="FDD"&($L(SEG(8))<5) S SEG(8)="",I=0 D Q "RTN","DGENUPL3",185,0) . . S DGNEW=0 F S I=$O(^DPT(DFN,.3216,I)) Q:I'?.N!($G(I)="") S DA(1)=DFN,DA=I,DIE="^DPT("_DA(1)_","_.3216_",",DIE(0)="",DR=".08///@" D ^DIE D ID1^DGNOZMH(DFN,I,DGNEW) S I=DA ;Delete an incomplete MSE ;DG*5.3*935 "RTN","DGENUPL3",186,0) . . K DGNEW Q "RTN","DGENUPL3",187,0) . N BOS,SN,DIS,SED,SSD,COM,DGFDD,DIE,DA,DR,RES S ERROR="" "RTN","DGENUPL3",188,0) . S BOS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;Service Branch "RTN","DGENUPL3",189,0) . S:BOS]"" BOS=$O(^DIC(23,"B",BOS,"")) "RTN","DGENUPL3",190,0) . S SN=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2)) ;Service Number "RTN","DGENUPL3",191,0) . S DIS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3)) ;Discharge Type "RTN","DGENUPL3",192,0) . S:DIS]"" DIS=$O(^DIC(25,"B",DIS,"")) "RTN","DGENUPL3",193,0) . S SED=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE") ;Entry Date "RTN","DGENUPL3",194,0) . I 'SED!ERROR D Q "RTN","DGENUPL3",195,0) . . Q:SEG(2)="FDD"&(SEG(8)="") D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, SERVICE ENTRY DATE",.ERRCOUNT) "RTN","DGENUPL3",196,0) . S SSD=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE") ;Sep. Date "RTN","DGENUPL3",197,0) . S COM=$$CONVERT^DGENUPL1($P(SEG(5),$E(HLECH))) ;Service Component "RTN","DGENUPL3",198,0) . ;Add Reason for Early Separation - DG*5.3*947 "RTN","DGENUPL3",199,0) . S RES=$$CONVERT^DGENUPL1($P(SEG(9),$E(HLECH))) ;Reason for Early Separation (free text) "RTN","DGENUPL3",200,0) . ;DJS, Create variable DGFDD for storage in Military Service Episode (MSE); DG*5.3*935 "RTN","DGENUPL3",201,0) . ;DJS, Create MSE whether or not FDD exists & is a valid date; DG*5.3*935 "RTN","DGENUPL3",202,0) . I SEG(2)="FDD" D "RTN","DGENUPL3",203,0) . . S DGFDD=$$CONVERT^DGENUPL1($P(SEG(8),$E(HLECH)),"DATE") "RTN","DGENUPL3",204,0) . . I $$VALID^DGRPDT(.DGFDD)=1 D "RTN","DGENUPL3",205,0) . . .S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1_U_DGFDD "RTN","DGENUPL3",206,0) . ;E S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1 "RTN","DGENUPL3",207,0) . E S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1_U_U_RES "RTN","DGENUPL3",208,0) ; "RTN","DGENUPL3",209,0) I SEG(2)="PH" D Q ;Process Purple Heart from ZMH "RTN","DGENUPL3",210,0) . S DGPAT("PHI")=$P(SEG(3),$E(HLECH)) "RTN","DGENUPL3",211,0) . S DGELG("PH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) "RTN","DGENUPL3",212,0) . S DGPAT("PHST")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2)) "RTN","DGENUPL3",213,0) . S DGPAT("PHRR")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3)) "RTN","DGENUPL3",214,0) ; "RTN","DGENUPL3",215,0) I SEG(2)="OEIF" D Q "RTN","DGENUPL3",216,0) . N OEIFLOC "RTN","DGENUPL3",217,0) . S OEIFLOC=$P(SEG(3),$E(HLECH)) "RTN","DGENUPL3",218,0) . I OEIFLOC="Conflict Unspecified" Q ;Ignore these entries "RTN","DGENUPL3",219,0) . I OEIFLOC="Unknown OEF/OIF" S OEIFLOC="UNK" "RTN","DGENUPL3",220,0) . S OEIFLOC=$E(OEIFLOC,1,3) "RTN","DGENUPL3",221,0) . Q:((OEIFLOC'="OIF")&(OEIFLOC'="OEF")&(OEIFLOC'="UNK")) "RTN","DGENUPL3",222,0) . S DGOEIF("COUNT")=$G(DGOEIF("COUNT"))+1 "RTN","DGENUPL3",223,0) . S DGOEIF("LOC",DGOEIF("COUNT"))=OEIFLOC "RTN","DGENUPL3",224,0) . S DGOEIF("SITE",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2),"INSTITUTION") "RTN","DGENUPL3",225,0) . S DGOEIF("FR",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE") "RTN","DGENUPL3",226,0) . S DGOEIF("TO",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE") "RTN","DGENUPL3",227,0) . S DGOEIF("LOCK",DGOEIF("COUNT"))=1 "RTN","DGENUPL3",228,0) ; "RTN","DGENUPL3",229,0) I SEG(2)="POW" D ;Process POW from ZMH "RTN","DGENUPL3",230,0) . S DGPAT("POWI")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;POW STATUS INDICATED "RTN","DGENUPL3",231,0) . S DGELG("POW")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) "RTN","DGENUPL3",232,0) . S DGPAT("POWLOC")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2)) "RTN","DGENUPL3",233,0) . I DGPAT("POWLOC")'="@" S DGPAT("POWLOC")=$$POWLOC(DGPAT("POWLOC"),.ERROR) ;POW CONFINEMENT LOCATION "RTN","DGENUPL3",234,0) . I ERROR D Q "RTN","DGENUPL3",235,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, POW CONFINEMENT LOCATION",.ERRCOUNT) "RTN","DGENUPL3",236,0) . S DGPAT("POWFDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE",.ERROR) ;POW FROM DATE "RTN","DGENUPL3",237,0) . I ERROR D Q "RTN","DGENUPL3",238,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW FROM DATE",.ERRCOUNT) "RTN","DGENUPL3",239,0) . S DGPAT("POWTDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE",.ERROR) ;POW TO DATE "RTN","DGENUPL3",240,0) . I ERROR D Q "RTN","DGENUPL3",241,0) . . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW TO DATE",.ERRCOUNT) "RTN","DGENUPL3",242,0) ; "RTN","DGENUPL3",243,0) I SEG(2)="MH" D ;Process Medal of Honor from ZMH "RTN","DGENUPL3",244,0) . S DGPAT("MOH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;MH STATUS INDICATED "RTN","DGENUPL3",245,0) . S DGELG("MOH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) "RTN","DGENUPL3",246,0) Q "RTN","DGENUPL3",247,0) POWLOC(LOC,ERROR) ;POW Confinement Location mapping with HL7 table VA023 "RTN","DGENUPL3",248,0) ; Input: LOC - HL7 code for location "RTN","DGENUPL3",249,0) ; Output: ERROR - Return error 1 on failure "RTN","DGENUPL3",250,0) ; IEN22 - IEN of file 22 "RTN","DGENUPL3",251,0) N TBL023 "RTN","DGENUPL3",252,0) S ERROR=0 "RTN","DGENUPL3",253,0) I LOC="" S ERROR=1 Q "" "RTN","DGENUPL3",254,0) S TBL023(4)="WWI",TBL023(5)="WWII-EUROPE",TBL023(6)="WWII-PACIFIC" "RTN","DGENUPL3",255,0) S TBL023(7)="KOREAN",TBL023(8)="VIETNAM",TBL023(9)="OTHER" "RTN","DGENUPL3",256,0) S TBL023("A")="PERSIAN GULF",TBL023("B")="YUGOSLAVIA" "RTN","DGENUPL3",257,0) S IEN22=$O(^DIC(22,"C",TBL023(LOC),"")) "RTN","DGENUPL3",258,0) I IEN22="" S ERROR=1 "RTN","DGENUPL3",259,0) Q IEN22 "RTN","DGENUPL3",260,0) ; "RTN","DGMSEUTL") 0^4^B18882941^B17883475 "RTN","DGMSEUTL",1,0) DGMSEUTL ;ALB/PJH,LBD,DJS,KUM - MSDS Utility Routine ;12 June 2018 5:36PM "RTN","DGMSEUTL",2,0) ;;5.3;Registration;**797,935,947**;08/13/93;Build 13 "RTN","DGMSEUTL",3,0) ; "RTN","DGMSEUTL",4,0) ; "RTN","DGMSEUTL",5,0) MOVMSE(DFN) ;Move MSE data from .32 node to .3216 multiple in Patient file #2 "RTN","DGMSEUTL",6,0) Q:'$G(DFN) Q:$O(^DPT(DFN,.3216,0)) "RTN","DGMSEUTL",7,0) N ARRAY "RTN","DGMSEUTL",8,0) D ARRAY(DFN,.ARRAY) "RTN","DGMSEUTL",9,0) I $D(ARRAY) D MSE(DFN,.ARRAY) "RTN","DGMSEUTL",10,0) Q "RTN","DGMSEUTL",11,0) ; "RTN","DGMSEUTL",12,0) ARRAY(DFN,ARRAY) ;Get old format VistA data "RTN","DGMSEUTL",13,0) N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI "RTN","DGMSEUTL",14,0) S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291)) "RTN","DGMSEUTL",15,0) ;Last service episode (SL) "RTN","DGMSEUTL",16,0) D EPISODE(1,4,8) "RTN","DGMSEUTL",17,0) ;Next to last service episode (SNL) "RTN","DGMSEUTL",18,0) Q:$P(DGRP(.32),"^",19)'="Y" D EPISODE(2,9,13) "RTN","DGMSEUTL",19,0) ;Prior episode (SNNL) "RTN","DGMSEUTL",20,0) I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18) "RTN","DGMSEUTL",21,0) Q "RTN","DGMSEUTL",22,0) ; "RTN","DGMSEUTL",23,0) EPISODE(SUB,P1,P2) ;Get old VistA data and save "RTN","DGMSEUTL",24,0) S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB) "RTN","DGMSEUTL",25,0) S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3) "RTN","DGMSEUTL",26,0) S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5) "RTN","DGMSEUTL",27,0) ;DJS, Save Future Discharge Date; DG*5.3*935 "RTN","DGMSEUTL",28,0) ;Save in format of new .3216 multiple (no lock flag) "RTN","DGMSEUTL",29,0) S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U_U_$G(DGFDD) ; DG*5.3*935 "RTN","DGMSEUTL",30,0) Q "RTN","DGMSEUTL",31,0) ; "RTN","DGMSEUTL",32,0) MSE(DFN,ARRAY,DEL) ;Copy old VistA data to new .3216 multiple "RTN","DGMSEUTL",33,0) N ECNT,DA,DIK,SUB,X,Y,DIC,DLAYGO,FLDS,DGFDD,DGNEW "RTN","DGMSEUTL",34,0) S ECNT=0 "RTN","DGMSEUTL",35,0) ;Delete existing entries "RTN","DGMSEUTL",36,0) I $G(DEL) F S ECNT=$O(^DPT(DFN,.3216,ECNT)) Q:+ECNT'>0 D "RTN","DGMSEUTL",37,0) .S DA(1)=DFN,DA=ECNT,DIK="^DPT("_DA(1)_",.3216," D ^DIK "RTN","DGMSEUTL",38,0) ;Add service episodes "RTN","DGMSEUTL",39,0) S SUB="" "RTN","DGMSEUTL",40,0) F S SUB=$O(ARRAY(SUB)) Q:'SUB D "RTN","DGMSEUTL",41,0) .;Ignore if Service Entry Date is null "RTN","DGMSEUTL",42,0) .Q:'+ARRAY(SUB) "RTN","DGMSEUTL",43,0) .N DA,DIC,DD,DO,DLAYGO,FLDS,X "RTN","DGMSEUTL",44,0) .S FLDS=ARRAY(SUB) "RTN","DGMSEUTL",45,0) .S DIC="^DPT(DFN,.3216," "RTN","DGMSEUTL",46,0) .S DIC(0)="L",DLAYGO=2 "RTN","DGMSEUTL",47,0) .S DA(1)=DFN "RTN","DGMSEUTL",48,0) .S X=$P(FLDS,U) ;Entry Date "RTN","DGMSEUTL",49,0) .S DIC("DR")=".02////"_$P(FLDS,U,2) ;Separation Date "RTN","DGMSEUTL",50,0) .S DIC("DR")=DIC("DR")_";.03////"_$P(FLDS,U,3) ;Service Branch "RTN","DGMSEUTL",51,0) .S DIC("DR")=DIC("DR")_";.04////"_$P(FLDS,U,4) ;Service Component "RTN","DGMSEUTL",52,0) .S DIC("DR")=DIC("DR")_";.05////"_$P(FLDS,U,5) ;Service Number "RTN","DGMSEUTL",53,0) .S DIC("DR")=DIC("DR")_";.06////"_$P(FLDS,U,6) ;Discharge type "RTN","DGMSEUTL",54,0) .S DIC("DR")=DIC("DR")_";.07////"_$P(FLDS,U,7) ;Locked "RTN","DGMSEUTL",55,0) . ;DJS, Store FUTURE DISCHARGE DATE; DG*5.3*935 "RTN","DGMSEUTL",56,0) .S DIC("DR")=DIC("DR")_";.08///"_$P(FLDS,U,8) ;Future Discharge Date "RTN","DGMSEUTL",57,0) .;Store REASON FOR EARLY SEPARATION - DG*5.3*947 "RTN","DGMSEUTL",58,0) .S DIC("DR")=DIC("DR")_";.09///"_$P(FLDS,U,9) ;Reason for Early Separation "RTN","DGMSEUTL",59,0) .D FILE^DICN "RTN","DGMSEUTL",60,0) Q "RTN","DGMSEUTL",61,0) ; "RTN","DGMSEUTL",62,0) GETMSE(DFN,MSE) ;Return all records in MSE sub-file #2.3216 in MSE array "RTN","DGMSEUTL",63,0) ;Records are sorted in reverse chronological order and the second "RTN","DGMSEUTL",64,0) ;subscript is the MSE IEN in the multiple e.g. MSE(1,4)=last "RTN","DGMSEUTL",65,0) I '$G(DFN) Q "RTN","DGMSEUTL",66,0) N I,SDT,IEN "RTN","DGMSEUTL",67,0) S SDT="" "RTN","DGMSEUTL",68,0) F I=1:1 S SDT=$O(^DPT(DFN,.3216,"B",SDT),-1) Q:'SDT D "RTN","DGMSEUTL",69,0) .S IEN=0 F S IEN=$O(^DPT(DFN,.3216,"B",SDT,IEN)) Q:'IEN D "RTN","DGMSEUTL",70,0) ..I '$D(^DPT(DFN,.3216,IEN,0)) Q "RTN","DGMSEUTL",71,0) ..S MSE(I)=^DPT(DFN,.3216,IEN,0) "RTN","DGMSEUTL",72,0) ..S MSE(I,IEN)="" "RTN","DGMSEUTL",73,0) Q "RTN","DGMSEUTL",74,0) ; "RTN","DGMSEUTL",75,0) LAST(DFN) ;Return last (most recent) MSE "RTN","DGMSEUTL",76,0) I '$G(DFN) Q "" "RTN","DGMSEUTL",77,0) N MSE "RTN","DGMSEUTL",78,0) D GETMSE(DFN,.MSE) "RTN","DGMSEUTL",79,0) S MSE=$O(MSE(0)) "RTN","DGMSEUTL",80,0) Q $G(MSE(+MSE)) "RTN","DGMSEUTL",81,0) ; "RTN","DGMSEUTL",82,0) UPDMSE(DFN,DGNMSE) ;File MSE data from the HEC Z11 message "RTN","DGMSEUTL",83,0) Q:'$G(DFN) Q:'$D(DGNMSE) "RTN","DGMSEUTL",84,0) N DGOMSE,DGTOT,DGCHG,DGN,DGO,I "RTN","DGMSEUTL",85,0) S DGTOT=0,DGN="" F S DGN=$O(DGNMSE(DGN)) Q:'DGN S DGTOT=DGTOT+1 "RTN","DGMSEUTL",86,0) ;Get current MSE data for patient from MSE sub-file #2.3216 "RTN","DGMSEUTL",87,0) D GETMSE(DFN,.DGOMSE) "RTN","DGMSEUTL",88,0) I $D(DGOMSE) D Q:'DGCHG "RTN","DGMSEUTL",89,0) .;Compare the old and new data. If they match, no update is needed. "RTN","DGMSEUTL",90,0) .S DGCHG=0 "RTN","DGMSEUTL",91,0) .I DGTOT'=$O(DGOMSE(""),-1) S DGCHG=1 Q "RTN","DGMSEUTL",92,0) .S (DGO,DGN)="" "RTN","DGMSEUTL",93,0) .F I=1:1:DGTOT S DGO=$O(DGOMSE(DGO)),DGN=$O(DGNMSE(DGN)) D Q:DGCHG "RTN","DGMSEUTL",94,0) ..I DGOMSE(DGO)'=DGNMSE(DGN) S DGCHG=1 Q "RTN","DGMSEUTL",95,0) ;File the new MSE data from HEC, delete old data first if it exists "RTN","DGMSEUTL",96,0) D MSE(DFN,.DGNMSE,$D(DGOMSE)) "RTN","DGMSEUTL",97,0) Q "RTN","DGMSEUTL",98,0) ; "RTN","DGMSEUTL",99,0) ESRDATA(DFN) ;Check if any records in .3216 are from ESR "RTN","DGMSEUTL",100,0) N IEN,LOCKED "RTN","DGMSEUTL",101,0) S IEN=0,LOCKED=0 "RTN","DGMSEUTL",102,0) F S IEN=$O(^DPT(DFN,.3216,IEN)) Q:'IEN D Q:LOCKED "RTN","DGMSEUTL",103,0) .;Check if record is locked "RTN","DGMSEUTL",104,0) .S LOCKED=$P($G(^DPT(DFN,.3216,IEN,0)),U,7) "RTN","DGMSEUTL",105,0) ;Return LOCKED indicating ESR data found "RTN","DGMSEUTL",106,0) Q LOCKED "RTN","DGMSEUTL",107,0) ; "RTN","DGMSEUTL",108,0) WARNMSG(DFN) ;Warning Message if some episodes did not copy "RTN","DGMSEUTL",109,0) N DATA32,OLDMSE,NEWMSE,DATA "RTN","DGMSEUTL",110,0) ;If ESR data exists quit "RTN","DGMSEUTL",111,0) Q:$$ESRDATA(DFN) 0 "RTN","DGMSEUTL",112,0) ;Count number of old episodes "RTN","DGMSEUTL",113,0) N LBRANCH,LDATE,SDAT,NODT "RTN","DGMSEUTL",114,0) S DATA32=$G(^DPT(DFN,.32)) "RTN","DGMSEUTL",115,0) S LDATE=$P(DATA32,U,6),LBRANCH=$P(DATA32,U,5),OLDMSE=0,NODT=0 "RTN","DGMSEUTL",116,0) ;If entry date or branch assume last episode exists "RTN","DGMSEUTL",117,0) I LDATE!LBRANCH S OLDMSE=OLDMSE+1 S:'LDATE NODT=1 "RTN","DGMSEUTL",118,0) ;Check for second episode "RTN","DGMSEUTL",119,0) I $P(DATA32,U,19)="Y" D "RTN","DGMSEUTL",120,0) .S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,11) NODT=1 "RTN","DGMSEUTL",121,0) .;and third episode "RTN","DGMSEUTL",122,0) .I $P(DATA32,U,20)="Y" S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,16) NODT=1 "RTN","DGMSEUTL",123,0) ; "RTN","DGMSEUTL",124,0) ;If no old episodes no message is necessary "RTN","DGMSEUTL",125,0) Q:'OLDMSE 0 "RTN","DGMSEUTL",126,0) ; "RTN","DGMSEUTL",127,0) ;Count number of new episodes "RTN","DGMSEUTL",128,0) S NEWMSE=0,SDAT="" "RTN","DGMSEUTL",129,0) F S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT D "RTN","DGMSEUTL",130,0) .S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN "RTN","DGMSEUTL",131,0) .S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA="" "RTN","DGMSEUTL",132,0) .S NEWMSE=NEWMSE+1 "RTN","DGMSEUTL",133,0) ; "RTN","DGMSEUTL",134,0) ;If number old MSEs greater than new MSEs, and service entry date "RTN","DGMSEUTL",135,0) ;is missing, return 1 "RTN","DGMSEUTL",136,0) I OLDMSE>NEWMSE,NODT Q 1 "RTN","DGMSEUTL",137,0) ;Otherwise, return 0 "RTN","DGMSEUTL",138,0) Q 0 "RTN","DGRP6") 0^1^B20074399^B18281969 "RTN","DGRP6",1,0) DGRP6 ;ALB/MRL,LBD,TMK,JAM - REGISTRATION SCREEN 6/SERVICE INFORMATION ;5/12/11 10:49am "RTN","DGRP6",2,0) ;;5.3;Registration;**161,247,343,397,342,451,672,689,797,841,842,947**;Aug 13, 1993;Build 13 "RTN","DGRP6",3,0) N DIPA,LIN,XX,Z1,GLBL "RTN","DGRP6",4,0) S DGRPS=6 D H^DGRPU F I=.32,.321,.322,.36,.385,.52,.53,.54 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP6",5,0) S (DGRPW,Z)=1 D WW2^DGRPV S Z=" Service Branch/Component",Z1=27 D WW1^DGRPV S Z="Service #",Z1=16 D WW1^DGRPV S Z=" Entered",Z1=12 D WW1^DGRPV S Z="Separated",Z1=12 D WW1^DGRPV W "Discharge" "RTN","DGRP6",6,0) W !?4,"------------------------",?30,"---------",?47,"-------",?58,"---------",?70,"---------" "RTN","DGRP6",7,0) ;Get MSEs from Military Service Episode sub-file #2.3216 (DG*5.3*797) "RTN","DGRP6",8,0) K ^TMP("DGRP6",$J) "RTN","DGRP6",9,0) S GLBL=$NA(^TMP("DGRP6",$J)) "RTN","DGRP6",10,0) D GETMSE^DGRP61(DFN,GLBL,0) "RTN","DGRP6",11,0) D S "RTN","DGRP6",12,0) W ! "RTN","DGRP6",13,0) D CL^DGRP6CL2(DFN,.LIN) "RTN","DGRP6",14,0) S Z=2 D WW2^DGRPV S Z=" Conflict Locations: ",Z1=20 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1) "RTN","DGRP6",15,0) S Z=1 F S Z=$O(LIN(Z)) Q:'Z W !,?25,LIN(Z) "RTN","DGRP6",16,0) D EF^DGRP6EF(DFN,.LIN) "RTN","DGRP6",17,0) S Z=3 D WW2^DGRPV S Z=" Environment Factors: ",Z1=21 D WW1^DGRPV W:'$D(LIN(1)) "< None Specified >" W:$D(LIN(1)) LIN(1) "RTN","DGRP6",18,0) S Z=1 F S Z=$O(LIN(Z)) Q:'Z W !,?4,"+ ",LIN(Z) "RTN","DGRP6",19,0) S Z=4,DGRPX=DGRP(.52) D WW^DGRPV W " POW: " S X=5,Z1=6 D YN W "From: " S X=7,Z1=13 D DAT W "To: " S X=8,Z1=12 D DAT W "War: ",$S($D(^DIC(22,+$P(DGRPX,"^",6),0)):$P(^(0),"^",2),1:"") "RTN","DGRP6",20,0) S Z=5 D WW^DGRPV W " Combat: " S X=11,Z1=6 D YN W "From: " S X=13,Z1=13 D DAT W "To: " S X=14,Z1=12 D DAT W "Loc: ",$S($D(^DIC(22,+$P(DGRPX,"^",12),0)):$P(^(0),"^",2),1:"") "RTN","DGRP6",21,0) S Z=6 D WW^DGRPV S X=$P(DGRP(.36),"^",12),XX=$P(DGRP(.36),"^",13) "RTN","DGRP6",22,0) N DGSPACE "RTN","DGRP6",23,0) S DGSPACE=$S($G(X)="0":" ",$G(X)="1":"",1:" ") "RTN","DGRP6",24,0) W " Mil Disab Retirement: ",$S(X=0:"NO",X=1:"YES",1:"") W DGSPACE_" Dischrg Due to Disab: ",$S(XX=0:"NO",XX=1:"YES",1:"") "RTN","DGRP6",25,0) ;W ! "RTN","DGRP6",26,0) S Z=7 D WW^DGRPV W " Dent Inj: " S DGRPX=DGRP(.36),X=8,Z1=28 D YN W "Teeth Extracted: " S X=9,Z1=9 D YN S DGRPD=0 I $P(DGRPX,"^",8)="Y",$P(DGRPX,"^",9)="Y" S DGRPD=1 "RTN","DGRP6",27,0) I DGRPD S I1="" F I=0:0 S I=$O(^DPT(DFN,.37,I)) Q:'I S I1=1,DGRPX=^(I,0) D DEN "RTN","DGRP6",28,0) S Z=8 D WW^DGRPV W " Purple Heart: " S DGRPX=DGRP(.53),X=1 D YN D "RTN","DGRP6",29,0) . I $P($G(DGRPX),U)="Y",($P($G(DGRPX),U,2)]"") W ?26,"PH Status: "_$S($P($G(DGRPX),U,2)="1":"Pending",$P($G(DGRPX),U,2)="2":"In Process",$P($G(DGRPX),U,2)="3":"Confirmed",1:"") "RTN","DGRP6",30,0) I $P($G(DGRPX),U)="N" D "RTN","DGRP6",31,0) . S DGX=$P(DGRPX,U,3) "RTN","DGRP6",32,0) . S DGX=$S($G(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$G(DGX)=2:"NO DOCUMENTATION REC'D",$G(DGX)=3:"ENTERED IN ERROR",$G(DGX)=4:"UNSUPPORTED PURPLE HEART",$G(DGX)=5:"VAMC",$G(DGX)=6:"UNDELIVERABLE MAIL",1:"") "RTN","DGRP6",33,0) . I $G(DGX)]"" W ?26,"PH Remarks: "_$S($G(DGX)]"":$G(DGX),1:"") "RTN","DGRP6",34,0) ;DG*5.3*841 "RTN","DGRP6",35,0) I $P(DGRP(.54),"^")="Y" W !,"<9> Medal of Honor: YES" "RTN","DGRP6",36,0) ;DG*5.3*842 "RTN","DGRP6",37,0) I ($P(DGRP(.385),U,8)["Y")!($P(DGRP(.385),U,8)["N") D EN^DDIOL("<10> Class II Dental Indicator: ","","!?0") S DGRPX=DGRP(.385),X=8,Z1=6 D YN I $P(DGRP(.385),U,8)["Y" D EN^DDIOL("Dental Appl Due Before Date: ","","?0") S X=9 D DAT "RTN","DGRP6",38,0) Q K DGRPD,DGRPSV "RTN","DGRP6",39,0) G ^DGRPP "RTN","DGRP6",40,0) YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNK",1:"") D WW1^DGRPV Q "RTN","DGRP6",41,0) DAT S Z=$P(DGRPX,"^",X) I Z']"" S Z="" "RTN","DGRP6",42,0) E S Z=$$FMTE^XLFDT(Z,"5DZ") "RTN","DGRP6",43,0) D WW1^DGRPV Q "RTN","DGRP6",44,0) DEN W !?3," Trt Date: " S X=1,Z1=10 D DAT W "Cond.: ",$E($P(DGRPX,"^",2),1,45) Q "RTN","DGRP6",45,0) S ;Write Military Service Episodes (DG*5.3*797) "RTN","DGRP6",46,0) N DGL,MSECNT "RTN","DGRP6",47,0) Q:$G(GLBL)="" "RTN","DGRP6",48,0) ; JAM; DG*5.3*947 - Reason for Early Separation displayed with MSE data. "RTN","DGRP6",49,0) ; This screen displays up to 3 MSE's and must include RES or Final Discharge Date if present "RTN","DGRP6",50,0) ; Array lines (built in ^DGRP61) may contain an MSE or a RES or FDD, so we need to track the number of MSEs "RTN","DGRP6",51,0) ; being displayed (MSECNT) - not the number of lines "RTN","DGRP6",52,0) S MSECNT=0 "RTN","DGRP6",53,0) S DGL=0 F S DGL=$O(@GLBL@(DGL)) Q:'DGL D "RTN","DGRP6",54,0) .; JAM; DG*5.3*947 - if this array entry is MSE data (node 1 is present), increment the count and only display 3 episodes "RTN","DGRP6",55,0) .I $D(@GLBL@(DGL,1)) S MSECNT=MSECNT+1 "RTN","DGRP6",56,0) .Q:MSECNT>3 "RTN","DGRP6",57,0) .I $G(@GLBL@(DGL,0))]"" W !,@GLBL@(DGL,0) "RTN","DGRP6",58,0) ; "RTN","DGRP6",59,0) ; JAM; DG*5.3*947 - indicate more episodes are available using the MSECNT - not the line count "RTN","DGRP6",60,0) ;I DGL>3 W !," " Q "RTN","DGRP6",61,0) I MSECNT>3 W !," " Q "RTN","DGRP6",62,0) ; end DG*5.3*947 changes "RTN","DGRP6",63,0) Q "RTN","DGRP6",64,0) MR W !?19,"Receiving Military retirement in lieu of VA Compensation." Q "RTN","DGRP6",65,0) ; "RTN","DGRP6",66,0) SETLNEX(Z,SEQ,LIN,LENGTH) ; "RTN","DGRP6",67,0) I 'LIN S LIN=1,LIN(1)="" "RTN","DGRP6",68,0) S Z=$E("("_SEQ_") "_Z,1,75) "RTN","DGRP6",69,0) I LENGTH+$L(Z)>$S(LIN<2:49,1:70) S LIN=LIN+1,LIN(LIN)="",LENGTH=0 "RTN","DGRP6",70,0) S LIN(LIN)=LIN(LIN)_$S(LENGTH:" ",1:"")_Z,LENGTH=$L(LIN(LIN)) "RTN","DGRP6",71,0) Q "RTN","DGRP6",72,0) ; "RTN","DGRP61") 0^2^B64590268^B57864374 "RTN","DGRP61",1,0) DGRP61 ;ALB/PJH,LBD,DJS,JAM - Patient MSDS History - List Manager Screen ;16 Oct 2017 16:04:16 "RTN","DGRP61",2,0) ;;5.3;Registration;**797,909,935,947**;Aug 13,1993;Build 13 "RTN","DGRP61",3,0) ; "RTN","DGRP61",4,0) EN(DFN) ;Main entry point to invoke the DGEN MSDS PATIENT list "RTN","DGRP61",5,0) ; Input -- DFN Patient IEN "RTN","DGRP61",6,0) ; "RTN","DGRP61",7,0) D WAIT^DICD "RTN","DGRP61",8,0) D EN^VALM("DGEN MSDS PATIENT") "RTN","DGRP61",9,0) Q "RTN","DGRP61",10,0) ; "RTN","DGRP61",11,0) HDR ;Header code "RTN","DGRP61",12,0) N DGPREFNM,X,VA,VAERR "RTN","DGRP61",13,0) S VALMHDR(1)=$J("",25)_"MILITARY SERVICE DATA, SCREEN <6.1>" "RTN","DGRP61",14,0) D PID^VADPT "RTN","DGRP61",15,0) S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30) "RTN","DGRP61",16,0) S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")" "RTN","DGRP61",17,0) S X="PATIENT TYPE UNKNOWN" "RTN","DGRP61",18,0) I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1) "RTN","DGRP61",19,0) S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80) "RTN","DGRP61",20,0) S VALMHDR(3)=$J("",4)_"Service Branch/Component Service #" "RTN","DGRP61",21,0) S VALMHDR(3)=VALMHDR(3)_" Entered Separated Discharge" "RTN","DGRP61",22,0) Q "RTN","DGRP61",23,0) ; "RTN","DGRP61",24,0) INIT ;Build patient MSDS screen "RTN","DGRP61",25,0) D CLEAN^VALM10 "RTN","DGRP61",26,0) K ^TMP("DGRP61",$J),DGSEL "RTN","DGRP61",27,0) ; "RTN","DGRP61",28,0) N GLBL "RTN","DGRP61",29,0) S GLBL=$NA(^TMP("DGRP61",$J)) "RTN","DGRP61",30,0) D GETMSE(DFN,GLBL,1) "RTN","DGRP61",31,0) ;Check if any old MSEs didn't copy and display warning message "RTN","DGRP61",32,0) I $$WARNMSG^DGMSEUTL(DFN) D "RTN","DGRP61",33,0) .S VALMSG="**More MSEs available to view on History Screen**" "RTN","DGRP61",34,0) .D MSG^VALM10(VALMSG) "RTN","DGRP61",35,0) Q "RTN","DGRP61",36,0) ; "RTN","DGRP61",37,0) GETMSE(DFN,GLBL,NUM) ;Load service episodes from .3216 array "RTN","DGRP61",38,0) ; INPUT: DFN = Patient IEN "RTN","DGRP61",39,0) ; GLBL = ^TMP global ref "RTN","DGRP61",40,0) ; NUM = 1 - display line numbers "RTN","DGRP61",41,0) N DGDATA,DGDATE,DGSUB,X1,X2,X "RTN","DGRP61",42,0) ; DGSEL - selectable items, DGSEL("episode count") - episode count for DGSEL "RTN","DGRP61",43,0) ; not all items may be selectable "RTN","DGRP61",44,0) K DGSEL S VALMCNT=0,DGDATE="",DGSEL("episode count")=0 "RTN","DGRP61",45,0) F S DGDATE=$O(^DPT(DFN,.3216,"B",DGDATE),-1) Q:'DGDATE D "RTN","DGRP61",46,0) . S DGSUB=$O(^DPT(DFN,.3216,"B",DGDATE,"")) Q:'DGSUB "RTN","DGRP61",47,0) . S DGDATA=$G(^DPT(DFN,.3216,DGSUB,0)) Q:DGDATA="" "RTN","DGRP61",48,0) . D EPISODE(DGDATA,GLBL,NUM) "RTN","DGRP61",49,0) Q "RTN","DGRP61",50,0) ; "RTN","DGRP61",51,0) EPISODE(DGDATA,GLBL,NUM) ;Format individual service episode "RTN","DGRP61",52,0) N DGFDD,DGRPSB,DGRPSC,DGRPSD,DGRPSE,DGRPSN,DGRPSS,Z "RTN","DGRP61",53,0) ; increment episode count "RTN","DGRP61",54,0) S DGSEL("episode count")=DGSEL("episode count")+1 "RTN","DGRP61",55,0) S DGRPSB=+$P(DGDATA,U,3),DGRPSC=$P(DGDATA,U,4),DGRPSN=$P(DGDATA,U,5) "RTN","DGRP61",56,0) ;Service Branch/Component "RTN","DGRP61",57,0) S Z=$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15),1:"UNKNOWN") "RTN","DGRP61",58,0) I DGRPSC'="" D "RTN","DGRP61",59,0) . N Z0 "RTN","DGRP61",60,0) . S Z0=$$SVCCOMP^DGRP6CL(DGRPSC) Q:Z0="" "RTN","DGRP61",61,0) . S Z=Z_"/"_Z0 "RTN","DGRP61",62,0) ;Filipino vet proof "RTN","DGRP61",63,0) I $$FV^DGRPMS(DGRPSB)=1 S Z=$E(Z_$J("",21),1,21)_"("_$P($G(^DPT(DFN,.321)),U,14)_")" "RTN","DGRP61",64,0) ;Service Number "RTN","DGRP61",65,0) S Z=Z_$J("",26-$L(Z))_$S(DGRPSN]"":DGRPSN,1:"UNKNOWN") "RTN","DGRP61",66,0) S Z=Z_$J("",42-$L(Z)) "RTN","DGRP61",67,0) ;Entry and separation dates "RTN","DGRP61",68,0) S DGRPSE=$P(DGDATA,U,1),DGRPSS=$P(DGDATA,U,2) "RTN","DGRP61",69,0) S X=$S(DGRPSE]"":$$FMTE^XLFDT(DGRPSE,"5DZ"),1:"UNKNOWN ") "RTN","DGRP61",70,0) S Z=Z_$E(X,1,10)_" " "RTN","DGRP61",71,0) S X=$S(DGRPSS]"":$$FMTE^XLFDT(DGRPSS,"5DZ"),1:"UNKNOWN ") "RTN","DGRP61",72,0) S Z=Z_$E(X,1,10)_" " "RTN","DGRP61",73,0) ;DJS, Add FUTURE DISCHARGE DATE; DG*5.3*935 "RTN","DGRP61",74,0) ;DGFDD = FUTURE DISCHARGE DATE (internal) "RTN","DGRP61",75,0) ;DGFDD("DISP") = FUTURE DISCHARGE DATE (display) "RTN","DGRP61",76,0) S DGFDD=$P(DGDATA,U,8),DGFDD("DISP")=$S(DGFDD]"":$$FMTE^XLFDT(DGFDD,"5DZ"),1:"") "RTN","DGRP61",77,0) ;Discharge type "RTN","DGRP61",78,0) S DGRPSD=+$P(DGDATA,U,6) "RTN","DGRP61",79,0) I 'DGRPSD S Z=Z_"UNKNOWN" "RTN","DGRP61",80,0) E S Z=Z_$S($D(^DIC(25,+DGRPSD)):$E($P(^DIC(25,DGRPSD,0),"^",1),1,9),1:"UNKNOWN") "RTN","DGRP61",81,0) ; "RTN","DGRP61",82,0) S VALMCNT=VALMCNT+1 "RTN","DGRP61",83,0) ; Add line numbers if NUM true "RTN","DGRP61",84,0) I $G(NUM) D "RTN","DGRP61",85,0) . ;DJS, Indicate MSE episode with FDD not editable or deletable; DG*5.3*935 "RTN","DGRP61",86,0) . ; not selectable, put < > around number, stop "RTN","DGRP61",87,0) . I $G(DGRPV)!($P(DGDATA,U,7)]"")!($P(DGDATA,U,8)]"") S Z="<"_DGSEL("episode count")_"> "_Z Q "RTN","DGRP61",88,0) . ; item is selectable, put into DGSEL, [ ] around number "RTN","DGRP61",89,0) . S Z="["_DGSEL("episode count")_"] "_Z,DGSEL(DGSEL("episode count"))=DGRPSE "RTN","DGRP61",90,0) ; "RTN","DGRP61",91,0) ; Save to List Manager array for display "RTN","DGRP61",92,0) S @GLBL@(VALMCNT,0)=$S($G(NUM):Z,1:$J("",4)_Z) "RTN","DGRP61",93,0) ; JAM; DG*5.3*947 - Track the array entries that are MSE data in the "1" subscript "RTN","DGRP61",94,0) S @GLBL@(VALMCNT,1)="" "RTN","DGRP61",95,0) ; JAM; DG*5.3*947 - if Reason for Early Separation is present, include it in output "RTN","DGRP61",96,0) I $P(DGDATA,U,9)]"" D "RTN","DGRP61",97,0) . ;use the DIWP api to format the text which can be longer than 80 chars "RTN","DGRP61",98,0) . N X,I,DIWL,DIWR,DIWF,RESDESC,RESLINE "RTN","DGRP61",99,0) . K ^UTILITY($J,"W") "RTN","DGRP61",100,0) . S X="Early Separation Reason: "_$P(DGDATA,U,9),DIWL=0,DIWR=80,DIWF="" "RTN","DGRP61",101,0) . D ^DIWP "RTN","DGRP61",102,0) . M RESDESC=^UTILITY($J,"W",0) "RTN","DGRP61",103,0) . F I=1:1:RESDESC D "RTN","DGRP61",104,0) . . S RESLINE=RESDESC(I,0) "RTN","DGRP61",105,0) . . S VALMCNT=VALMCNT+1,@GLBL@(VALMCNT,0)=RESLINE "RTN","DGRP61",106,0) ; end patch DG*5.3*947 changes "RTN","DGRP61",107,0) ; "RTN","DGRP61",108,0) D:DGFDD ; if FDD found, add to display "RTN","DGRP61",109,0) . S VALMCNT=VALMCNT+1,@GLBL@(VALMCNT,0)=" Future Discharge Date: "_DGFDD("DISP") "RTN","DGRP61",110,0) Q "RTN","DGRP61",111,0) ; "RTN","DGRP61",112,0) HELP ;Help code "RTN","DGRP61",113,0) S X="?" D DISP^XQORM1 W !! "RTN","DGRP61",114,0) Q "RTN","DGRP61",115,0) ; "RTN","DGRP61",116,0) EXIT ;Exit code "RTN","DGRP61",117,0) D CLEAN^VALM10 "RTN","DGRP61",118,0) D CLEAR^VALM1 "RTN","DGRP61",119,0) K ^TMP("DGRP61",$J) "RTN","DGRP61",120,0) Q "RTN","DGRP61",121,0) ; "RTN","DGRP61",122,0) PEXIT ;DGEN MSDS MENU protocol exit code "RTN","DGRP61",123,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGRP61",124,0) ;Reset after page up or down "RTN","DGRP61",125,0) ;D XQORM "RTN","DGRP61",126,0) Q "RTN","DGRP61",127,0) ; "RTN","DGRP61",128,0) ACT(DGACT) ; Entry point for menu action selection "RTN","DGRP61",129,0) ; INPUT: DGACT = "A" - Add - DGEN MSDS ADD protocol "RTN","DGRP61",130,0) ; = "E" - Edit - DGEN MSDS EDIT protocol "RTN","DGRP61",131,0) ; = "D" - Delete - DGEN MSDS DELETE protocol "RTN","DGRP61",132,0) N DGX,DA,DIE,DIC,DIK,DIPA,DR,X,Y "RTN","DGRP61",133,0) I $G(DGACT)="" G ACTQ "RTN","DGRP61",134,0) I $G(DGRPV) W !,"View only. This action cannot be selected." D PAUSE^VALM1 G ACTQ "RTN","DGRP61",135,0) D FULL^VALM1 "RTN","DGRP61",136,0) I DGACT="A" D ADD G ACTQ "RTN","DGRP61",137,0) I '$O(DGSEL(0)) D G ACTQ "RTN","DGRP61",138,0) . W !,"There are no episodes to "_$S(DGACT="E":"edit.",1:"delete.") "RTN","DGRP61",139,0) . I $G(VALMCNT) D HECHLP "RTN","DGRP61",140,0) . D PAUSE^VALM1 "RTN","DGRP61",141,0) S DGX=$$SEL(DGACT) I 'DGX G ACTQ "RTN","DGRP61",142,0) S DGX=$G(DGSEL(DGX)) I 'DGX G ACTQ "RTN","DGRP61",143,0) S DA(1)=DFN,DIC="^DPT("_DA(1)_",.3216,",DIC(0)="BX",X=DGX "RTN","DGRP61",144,0) D ^DIC I Y<0 W !,"This episode is not in the patient's record." D PAUSE^VALM1 G ACTQ "RTN","DGRP61",145,0) S DIPA("DA")=+Y "RTN","DGRP61",146,0) I DGACT="E" K DA,DIC,DGFRDT S DIE="^DPT(",DA=DFN D SETDR1 D ^DIE G ACTQ "RTN","DGRP61",147,0) ; deletion, ask user first "RTN","DGRP61",148,0) I DGACT="D",$$RUSURE S DIK=DIC,DA(1)=DFN,DA=DIPA("DA") D ^DIK K DA,DIK "RTN","DGRP61",149,0) ; "RTN","DGRP61",150,0) ; DG*5.3*909 Potentially change Camp Lejeune to No with MSE changes "RTN","DGRP61",151,0) ACTQ ; menu action exit point "RTN","DGRP61",152,0) D INIT S VALMBCK="R" D SETCLNO^DGENCLEA Q "RTN","DGRP61",153,0) ; "RTN","DGRP61",154,0) ADD ; Add new MSE to #2.3216 sub-file "RTN","DGRP61",155,0) N X,Y,DIK,DA,DR,DIE,NEXT,DGFRDT "RTN","DGRP61",156,0) ; Get next record number in sub-file "RTN","DGRP61",157,0) S NEXT=$O(^DPT(DFN,.3216,"A"),-1),NEXT=NEXT+1 "RTN","DGRP61",158,0) D ZNODE(1) "RTN","DGRP61",159,0) ; Prompt for MSE fields "RTN","DGRP61",160,0) S DIE="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D SETDR2 D ^DIE "RTN","DGRP61",161,0) I X["BAD" S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK "RTN","DGRP61",162,0) ; Check if new record is missing or incomplete "RTN","DGRP61",163,0) I '$D(^DPT(DFN,.3216,NEXT)) D ZNODE(-1) Q "RTN","DGRP61",164,0) I '$P(^DPT(DFN,.3216,NEXT,0),U) D Q "RTN","DGRP61",165,0) .S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK D ZNODE(-1) "RTN","DGRP61",166,0) ; "RTN","DGRP61",167,0) ; File FILIPINO VET PROOF, if set "RTN","DGRP61",168,0) I $G(DIPA("FVP"))]"" D "RTN","DGRP61",169,0) .K DA,DR S DIE="^DPT(",DA=DFN,DR=".3214///^S X=DIPA(""FVP"")" "RTN","DGRP61",170,0) .D ^DIE "RTN","DGRP61",171,0) Q "RTN","DGRP61",172,0) ; "RTN","DGRP61",173,0) SEL(ACT) ; function, prompt for episode to edit/delete "RTN","DGRP61",174,0) N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y "RTN","DGRP61",175,0) ; range is 1 to episode count, must be in DGSEL to be selectable "RTN","DGRP61",176,0) S DIR(0)="NAO^1:"_DGSEL("episode count")_"^K:'$D(DGSEL(X)) X" "RTN","DGRP61",177,0) S DIR("A")="Select Episode: " "RTN","DGRP61",178,0) S DIR("?")="^D SELHLP^DGRP61(ACT)" "RTN","DGRP61",179,0) D ^DIR I 'Y Q 0 "RTN","DGRP61",180,0) Q Y "RTN","DGRP61",181,0) ; "RTN","DGRP61",182,0) SELHLP(ACT) ; Help message for episode prompt "RTN","DGRP61",183,0) W !,"Select an episode to ",$S(ACT="E":"edit.",1:"delete.") "RTN","DGRP61",184,0) W !,"Only numbers in square brackets [ ] are selectable." "RTN","DGRP61",185,0) D HECHLP "RTN","DGRP61",186,0) N DIR D PAUSE^VALM1 "RTN","DGRP61",187,0) Q "RTN","DGRP61",188,0) HECHLP ; Help message for episodes that can only be changed by HEC "RTN","DGRP61",189,0) W !,"Angled brackets < > indicate episodes that cannot be changed in VistA." "RTN","DGRP61",190,0) W !,"Please contact the HECAlert mail group or the HEC if you need to update" "RTN","DGRP61",191,0) W !,"this information." "RTN","DGRP61",192,0) Q "RTN","DGRP61",193,0) ; "RTN","DGRP61",194,0) ZNODE(VAL) ; Update zero node of MSE multiple .3216 "RTN","DGRP61",195,0) Q:'$G(VAL) Q:'$G(DFN) "RTN","DGRP61",196,0) N ZNODE "RTN","DGRP61",197,0) S ZNODE=$G(^DPT(DFN,.3216,0)) "RTN","DGRP61",198,0) S ^DPT(DFN,.3216,0)="^2.3216D^"_($P(ZNODE,U,3)+VAL)_U_($P(ZNODE,U,4)+VAL) "RTN","DGRP61",199,0) Q "RTN","DGRP61",200,0) SETDR1 ; Set DR array to edit MSE fields "RTN","DGRP61",201,0) S DR="I '$G(DIPA(""DA"")) S Y=0;.3216////^S X=""`""_DIPA(""DA"");.3214///^S X=$G(DIPA(""FVP""))" "RTN","DGRP61",202,0) S DR(2,2.3216)="D SET0^DGRP61(.DA,.DIPA);@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61" "RTN","DGRP61",203,0) S DR(2,2.3216,1)="I DIPA(""FVP"")=""^"" K DIPA(""FVP"") S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";S Y=""@63""" "RTN","DGRP61",204,0) S DR(2,2.3216,2)="@62;D:DIPA(""X"")]"""" WARN^DGRP61(.DIPA,.Y);.04;@63;.05;.01;.02;.06" "RTN","DGRP61",205,0) Q "RTN","DGRP61",206,0) SETDR2 ; Set DR array to add MSE fields "RTN","DGRP61",207,0) S DR="@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61;I DIPA(""FVP"")=""^"" S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";@62;S:'$$CMP^DGRP61(DIPA(""X"")) Y=""@63"";.04;@63;.05;.01;.02;.06" "RTN","DGRP61",208,0) Q "RTN","DGRP61",209,0) FVP() ; Prompt for FILIPINO VET PROOF "RTN","DGRP61",210,0) N DA,X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT "RTN","DGRP61",211,0) S DIR(0)="2,.3214",DA=DFN "RTN","DGRP61",212,0) D ^DIR I Y=""!(Y="^") Q Y "RTN","DGRP61",213,0) Q Y "RTN","DGRP61",214,0) ; "RTN","DGRP61",215,0) SET0(DA,DIPA) ; Set DIPA(0) to values of Service Branch and Service Component "RTN","DGRP61",216,0) K DIPA(0) "RTN","DGRP61",217,0) S DIPA(0)=$P($G(^DPT(DA(1),.3216,DA,0)),U,3,4) "RTN","DGRP61",218,0) Q "RTN","DGRP61",219,0) ; "RTN","DGRP61",220,0) WARN(DIPA,Y) ;Warns that the Service Branch was changed so the "RTN","DGRP61",221,0) ; Service Component was deleted "RTN","DGRP61",222,0) ; Returns Y to skip component if the component should not be asked "RTN","DGRP61",223,0) ; for this branch of service "RTN","DGRP61",224,0) I '$$CMP($G(DIPA("X"))) S Y="@63" "RTN","DGRP61",225,0) I $P($G(DIPA(0)),U,2)=""!($P($G(DIPA(0)),U)="") Q "RTN","DGRP61",226,0) I $P(DIPA(0),U)=DIPA("X") Q ;Service Branch didn't change "RTN","DGRP61",227,0) ; "RTN","DGRP61",228,0) I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",! "RTN","DGRP61",229,0) Q "RTN","DGRP61",230,0) ; "RTN","DGRP61",231,0) CMP(X) ; Function to determine if service component is valid for "RTN","DGRP61",232,0) ; branch of service ien in X 0 = invalid 1 = valid "RTN","DGRP61",233,0) ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS "RTN","DGRP61",234,0) Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0) "RTN","DGRP61",235,0) ; "RTN","DGRP61",236,0) RUSURE() ; Confirmation prompt for deleting episode "RTN","DGRP61",237,0) N DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT "RTN","DGRP61",238,0) S DIR(0)="YA",DIR("B")="NO" "RTN","DGRP61",239,0) S DIR("A")="Are you sure you want to delete this military service episode? " "RTN","DGRP61",240,0) D ^DIR I 'Y W !,"<< NOTHING DELETED >>" Q 0 "RTN","DGRP61",241,0) Q 1 "RTN","DGRP61",242,0) ; "UP",2,2.3216,-1) 2^.3216 "UP",2,2.3216,0) 2.3216 "VER") 8.0^22.2 "^DD",2,2.3216,.08,0) FUTURE DISCHARGE DATE^DXI^^0;8^S %DT="EX" D ^%DT S X=Y K:Y<1 X "^DD",2,2.3216,.08,3) Enter the date that an active duty service member is expected to be discharged. "^DD",2,2.3216,.08,21,0) ^^3^3^3171013^ "^DD",2,2.3216,.08,21,1,0) The Future Discharge Date (FDD) is the date that an active duty service "^DD",2,2.3216,.08,21,2,0) member is expected to be discharged. This date is controlled in VistA by "^DD",2,2.3216,.08,21,3,0) the Enrollment Service (ES) and cannot be edited within VistA. "^DD",2,2.3216,.08,"DT") 3180629 "^DD",2,2.3216,.09,0) REASON FOR EARLY SEPARATION^FJ128I^^0;9^K:$L(X)>128!($L(X)<3) X "^DD",2,2.3216,.09,3) Enter the Reason For Early Separation when a service member is discharged early for example due to disability, hardship or early out. 3 to 128 characters. "^DD",2,2.3216,.09,21,0) ^.001^7^7^3180629^^^^ "^DD",2,2.3216,.09,21,1,0) The Reason For Early Separation explains why a service member was "^DD",2,2.3216,.09,21,2,0) discharged early, and displays if it was due to disability, hardship or "^DD",2,2.3216,.09,21,3,0) early out reason. Reason for Early Separation for the patient is updated "^DD",2,2.3216,.09,21,4,0) from the Health Eligibility Center (HEC) Enrollment System; the data will "^DD",2,2.3216,.09,21,5,0) be locked and cannot be edited or deleted. Only Military Service "^DD",2,2.3216,.09,21,6,0) Episodes that are sent from the HEC can have a Reason for Early "^DD",2,2.3216,.09,21,7,0) Separation. "^DD",2,2.3216,.09,"DT") 3180629 "BLD",10211,6) ^846 **END** **END**