DGENUPL3 ;ALB/CJM,ISA,KWP,AEG,BRM,ERC,CKN,BAJ,PHH,TDM,LBD,DJS,KUM,JAM,HM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;12 June 2018 5:35PM
;;5.3;REGISTRATION;**147,230,232,377,404,451,653,688,793,797,841,928,935,947,966,972**;Aug 13,1993;Build 80
;
;
ADDMSG(MSGS,MESSAGE,TOHEC) ;
;Description: Used to add a message to an array of messages to be sent.
;
;Input:
; MSGS - the array to store the message (pass by reference)
; MESSAGE - the message to store
; TOHEC - a flag, if set to 1 it means that HEC should also receive notification
;
;Output: none
;
I MESSAGE["DATE OF DEATH" Q
S MSGS(0)=($G(MSGS(0))+1)
S MSGS(MSGS(0))=MESSAGE
I ($G(TOHEC)=1) S MSGS("HEC")=1
Q
;
;
NOTIFY(DGPAT,MSGS) ;
;Description: This is used to send a message to the local mail group
;defined by the MAS Parameter ELIGIBILITY UPLOAD MAIL GROUP.The
;notification is to be used when specific problems or conditions
;regarding the upload of the enrollment or eligibility data.
;
;Input:
; OLDPAT -used if the DGPAT elements have not been built
; DGPAT - patient array (pass by reference)
; MSGS - the an array of messages that should be included in the
; notification (pass by reference). If MSGS("HEC")=1
; it means that HEC should also receive notification.
;
;Output: none
;
N TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT
N HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG,CD,DGFDD
;
;if there are no alerts, then quit
Q:'$G(MSGS(0))
;
;Get reason for alert. If there is more than one reason decide which
;reason to display. 'NON-SERVICE' alerts have a higher priority than
;other alerts and are therefore displayed before other alerts in the
;subject line, followed by 'POW' alerts in priority.
S (ELIG,NSC,POW,CD)=0
S COUNT=0 F S COUNT=$O(MSGS(COUNT)) Q:'COUNT!NSC D
.I MSGS(COUNT)["PREVIOUSLY ELIGIBLE" S ELIG=1 Q
.I MSGS(COUNT)["NON-SERVICE" S NSC=1 Q
.I MSGS(COUNT)["POW" S POW=1 Q
.I MSGS(COUNT)["CD EVALUATION" S CD=1 Q
.S HEADER=MSGS(COUNT)
.Q
D
.I ELIG S HEADER="Ineligibility Alert: " Q
.I NSC S HEADER="NSC Alert: " Q
.I POW&'NSC S HEADER="POW Alert: " Q
.I CD S HEADER="CD Alert: " Q
.Q
;
S XMDF=""
S (XMDUN,XMDUZ)="Registration Enrollment Module"
;Phase II Re-Enrollment
;DGPAT("SSN") is built by the parser. DGPAT("NAME"),DGPAT("SEX"),DGPAT("DOB")(are merged into DGPAT from OLDPAT.
;The checks below are to setup the DGPAT elements from OLDPAT if NOTIFY is called before the merge.
I '$D(DGPAT("NAME")) S DGPAT("NAME")=$G(OLDPAT("NAME"))
I '$D(DGPAT("SEX")) S DGPAT("SEX")=$G(OLDPAT("SEX"))
I '$D(DGPAT("DOB")) S DGPAT("DOB")=$G(OLDPAT("DOB"))
S TMPSTR=" ("_$E(DGPAT("NAME"),1,1)
S TMPSTR=TMPSTR_$E(DGPAT("SSN"),$L(DGPAT("SSN"))-3,1000)_")"
S XMSUB=$E(HEADER,1,30)_$E(DGPAT("NAME"),1,25)_TMPSTR
;
; send msg to local mail group specified in IVM SITE PARAMETER file
S MAILGRP=+$P($G(^IVM(301.9,1,0)),"^",9)
S MAILGRP=$$EXTERNAL^DILFD(301.9,.09,"F",MAILGRP)
I MAILGRP]"" S XMY("G."_MAILGRP)=""
;
;Patch DG*5.3*928 is removing ability to send emails to remote email group. Emails have been decommissioned and no longer required.
;if flag is set, send msg to remote mail group specified in
;the IVM SITE PARAMETER file
;I $G(MSGS("HEC"))=1 D
;.S MAILGRP=$P($G(^IVM(301.9,1,0)),"^",10)
;.S MAILGRP=$$EXTERNAL^DILFD(301.9,.10,"F",MAILGRP)
;.I MAILGRP]"" S XMY("G."_MAILGRP)=""
;
;
S XMTEXT="TEXT("
S TEXT(1)="The enrollment/eligibility upload produced the following alerts:"
S TEXT(2)=" "
S TEXT(3)="Patient Name : "_DGPAT("NAME")
S TEXT(4)="SSN : "_DGPAT("SSN")
S TEXT(5)="DOB : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB"))
S TEXT(6)="SEX : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX"))
S TEXT(7)=" "
;
S TEXT(8)=" ** Alerts **"
S TEXT(9)=" "
S COUNT=0 F S COUNT=$O(MSGS(COUNT)) Q:'COUNT S TEXT(10+COUNT)=COUNT_") "_MSGS(COUNT)
;
D ^XMD
Q
;
BEGUPLD(DFN) ;
;Description: Sets a lock used to determine if an eligibility/enrollment
;upload is in progress.
;
;Input:
; DFN - ien, Patient record
;
;Output:
; Function value - returns 1 if the lock was obtained, 0 otherwise.
;
Q:'$G(DFN) 1
L +^DGEN("ELIGIBILITY UPLOAD",DFN):3
Q $T
;
ENDUPLD(DFN) ;
;Description: Releases the lock obtained by calling $$BEGUPLD(DFN)
;
Q:'$G(DFN)
L -^DGEN("ELIGIBILITY UPLOAD",DFN)
Q
;
CKUPLOAD(DFN) ;
;Description: Checks if an upload is in progress. If so, it pauses
;until it is completed.
;The enrollment/eligibility upload can take a while to accomplish.
;If the lock is not obtained initially, it is assumed that the upload
;is in progress, and a message is displayed to the user.
;
;Input: DFN
;Output: none
;
N I
I '$$BEGUPLD(DFN) D
.W !!,"Upload of patient enrollment/eligibility data is in progress ..."
.D UNLOCK^DGENPTA1(DFN)
.F I=1:1:50 Q:$$BEGUPLD(DFN) W "."
.W !,"Upload of patient enrollment/eligibility data is completed.",!
D ENDUPLD(DFN)
Q
SCVET ;moved from DGENUPL4 - DG*5.3*688
I DGPAT3("VETERAN")'="N" D
. I DGELG3("SC")="N" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","NSC VETERAN",0))
. I DGELG3("SC")="Y" S DGPAT3("VETERAN")="Y",DGPAT3("PATYPE")=$O(^DG(391,"B","SC VETERAN",0))
I DGPAT3("VETERAN")="N" S DGPAT3("PATYPE")=$$NONVET(DGELG("ELIG","CODE"))
Q
;
NONVET(DGCODE) ;map Patient Type from Primary Elig (and POS)
;added with DG*5.3*688 - ERC
; input: DGCODE is the Primary Eligibility code
; output: DGTPYE is returned as the value for Patient Type
N PTELG,DGTYPE
S (PTELG,DGTYPE)=""
Q:$G(DGCODE)']"" ""
S PTELG=$$NATNAME^DGENELA(DGCODE)
Q:$G(PTELG)']"" ""
I "CHAMPVA^OTHER FEDERAL AGENCY^REIMBURSABLE INSURANCE^SHARING AGREEMENT"[PTELG S DGTYPE=$$POS(.DGTYPE) Q:DGTYPE DGTYPE
S DGTYPE=$S(PTELG["ALLIED":"ALLIED VETERAN",PTELG["COLLATERAL":"COLLATERAL",PTELG["EMPLOYEE":"EMPLOYEE",PTELG["TRICARE":"TRICARE",1:"")
I DGTYPE']"" S DGTYPE="NON-VETERAN (OTHER)" ;default Pat Type
S DGTYPE=$O(^DG(391,"B",DGTYPE,""))
Q DGTYPE
POS(DGTYPE) ;for these Elig Codes, check POS to determine Patient Type
S DGPOS=DGELG("POS")
I $G(DGPOS)']"" Q ""
I '$D(^DIC(21,DGPOS,0)) Q ""
S DGPOS=$P(^DIC(21,DGPOS,0),U)
S DGTYPE=$S(DGPOS["ACTIVE":"ACTIVE DUTY",DGPOS["OPERAT":"ACTIVE DUTY",DGPOS["RETIR":"MILITARY RETIREE",1:"")
I $G(DGTYPE)]"" S DGTYPE=$O(^DG(391,"B",DGTYPE,""))
Q DGTYPE
;
;ZMH code moved here from DGENUPL2 - DG*5.3*653
ZMH ;Purple Heart, POW, OEF/OIF Conflict Loc, Military Service Episodes, Medal of Honor
;PROCESS PH, OEF/OIF, MH & POW FROM ZMH
;Process Military Service Episodes (SL,SNL,SNNL,MSD) - DG*5.3*797
;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Future Discharge Date Added DG*5.3*935
;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Reason for Early Separation Added DG*5.3*947
;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Separation Reason Code added DG*5.3*966
;DJS, Indicate if the ZMH segment exists in this message; DG*5.3*935
N DGNEW
S ^TMP($J,"DGENUPL","ZMH",0)=1
I "^SL^SNL^SNNL^MSD^FDD^"[("^"_SEG(2)_"^") D Q
. ;DJS, Store the Future Discharge Date (FDD); DG*5.3*935
. I SEG(2)="FDD"&($L(SEG(8))<5) S SEG(8)="",I=0 D Q
. . ;JAM, FDD is NONEDITABLE in FileMan so this code is modified to directly delete the field; DG*5.3*972
. . ;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
. . S DGNEW=0 F S I=$O(^DPT(DFN,.3216,I)) Q:I'?.N!($G(I)="") S $P(^DPT(DFN,.3216,I,0),"^",8)="" D ID1^DGNOZMH(DFN,I,DGNEW) ;Delete an incomplete MSE ;DG*5.3*935
. . K DGNEW Q
. N BOS,SN,DIS,SED,SSD,COM,DGFDD,DIE,DA,DR,RES,RESCODE S ERROR=""
. S BOS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;Service Branch
. S:BOS]"" BOS=$O(^DIC(23,"B",BOS,""))
. S SN=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2)) ;Service Number
. S DIS=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3)) ;Discharge Type
. S:DIS]"" DIS=$O(^DIC(25,"B",DIS,""))
. S SED=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE") ;Entry Date
. I 'SED!ERROR D Q
. . Q:SEG(2)="FDD"&(SEG(8)="") D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, SERVICE ENTRY DATE",.ERRCOUNT)
. S SSD=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE") ;Sep. Date
. S COM=$$CONVERT^DGENUPL1($P(SEG(5),$E(HLECH))) ;Service Component
. ;Add Reason for Early Separation - DG*5.3*947
. S RES=$$CONVERT^DGENUPL1($P(SEG(9),$E(HLECH))) ;Reason for Early Separation (free text)
. ;Add Separation Reason Code (variable is NEW'd above and set into the DGNMSE array below) - DG*5.3*966
. S RESCODE=$$CONVERT^DGENUPL1($P(SEG(10),$E(HLECH))) ;Separation Reason Code (3 digit)
. ;DJS, Create variable DGFDD for storage in Military Service Episode (MSE); DG*5.3*935
. ;DJS, Create MSE whether or not FDD exists & is a valid date; DG*5.3*935
. I SEG(2)="FDD" D
. . S DGFDD=$$CONVERT^DGENUPL1($P(SEG(8),$E(HLECH)),"DATE")
. . I $$VALID^DGRPDT(.DGFDD)=1 D
. . .S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1_U_DGFDD
. ;E S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1
. E S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1_U_U_RES_U_RESCODE
;
I SEG(2)="PH" D Q ;Process Purple Heart from ZMH
. S DGPAT("PHI")=$P(SEG(3),$E(HLECH))
. S DGELG("PH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
. S DGPAT("PHST")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))
. S DGPAT("PHRR")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),3))
;
I SEG(2)="OEIF" D Q
. N OEIFLOC
. S OEIFLOC=$P(SEG(3),$E(HLECH))
. I OEIFLOC="Conflict Unspecified" Q ;Ignore these entries
. I OEIFLOC="Unknown OEF/OIF" S OEIFLOC="UNK"
. S OEIFLOC=$E(OEIFLOC,1,3)
. Q:((OEIFLOC'="OIF")&(OEIFLOC'="OEF")&(OEIFLOC'="UNK"))
. S DGOEIF("COUNT")=$G(DGOEIF("COUNT"))+1
. S DGOEIF("LOC",DGOEIF("COUNT"))=OEIFLOC
. S DGOEIF("SITE",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2),"INSTITUTION")
. S DGOEIF("FR",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE")
. S DGOEIF("TO",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE")
. S DGOEIF("LOCK",DGOEIF("COUNT"))=1
;
I SEG(2)="POW" D ;Process POW from ZMH
. S DGPAT("POWI")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;POW STATUS INDICATED
. S DGELG("POW")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
. S DGPAT("POWLOC")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH),2))
. I DGPAT("POWLOC")'="@" S DGPAT("POWLOC")=$$POWLOC(DGPAT("POWLOC"),.ERROR) ;POW CONFINEMENT LOCATION
. I ERROR D Q
. . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, POW CONFINEMENT LOCATION",.ERRCOUNT)
. S DGPAT("POWFDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH)),"DATE",.ERROR) ;POW FROM DATE
. I ERROR D Q
. . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW FROM DATE",.ERRCOUNT)
. S DGPAT("POWTDT")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE",.ERROR) ;POW TO DATE
. I ERROR D Q
. . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW TO DATE",.ERRCOUNT)
;
I SEG(2)="MH" D ;Process Medal of Honor from ZMH
. N TODAY,Y,DGVDOB,DGLEGDT,DGERRMSG,VAEL
. S DGPAT("MOH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH))) ;MH STATUS INDICATED
. ;MOH DG*5.3*972 HM changes start here
. S DGELG("MOH")=$$CONVERT^DGENUPL1($P(SEG(3),$E(HLECH)))
. I DGELG("MOH")="Y" D
. . I $G(DGPAT("VETERAN"))="Y" Q ;CHECK IF VETERAN FROM ZEL SEGMENT
. . I $G(DGPAT("VETERAN"))="N" S ERROR=1 Q ;IF NOT VETERAN SET ERROR
. . D ELIG^VADPT I $G(VAEL(4))'=1 S ERROR=1 ;IF CANNOT DETERMINE VETERAN STATUS CALL ELIG^VADPT TO GET STATUS FROM DB, IF NON VETERAN SET ERROR
. I ERROR D Q
. . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, NON VETERAN INELIGIBLE FOR MEDAL OF HONOR",.ERRCOUNT)
. S DGPAT("MOHAWRDDATE")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),1),"DATE",.ERROR)
. S DGELG("MOHAWRDDATE")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),1),"DATE",.ERROR)
. I DGPAT("MOH")="N",DGPAT("MOHAWRDDATE")="""" S ERROR=0 ;NO ERROR IF AWARD DATE IS EMPTY STRING
. I DGPAT("MOH")="N" S DGPAT("MOHAWRDDATE")="",DGELG("MOHAWRDDATE")="" ;IF MOH = 'N' SET AWARD DATE TO NULL
. S DGLEGDT=3161216 ;MOH LEGISLATION DATE 2016/12/16
. I $G(DGPAT("MOHAWRDDATE")) D ;MH AWARD DATE
. . I DGPAT("MOHAWRDDATE")>DT S ERROR=1
. . S DGERRMSG="BAD VALUE, ZMH SEGMENT, SEQ 4, MH AWARD DATE IS IN THE FUTURE" ;IF AWARD DATE IS IN FUTURE
. . S DGVDOB=$P(^DPT(+DFN,0),"^",3)
. . I DGPAT("MOHAWRDDATE")-DGVDOB<150000 S ERROR=1,DGERRMSG="BAD VALUE, ZMH SEGMENT, SEQ 4, MH AWARD DATE BEFORE BIRTH DATE" ;IF AWARD DATE IS LESS THE DOB + 15 YEARS ;MH AWARD DATE
. I ERROR D Q
. . S DGPAT("MOHAWRDDATE")="" ;IF AWARD FAILS VALIDATION SE TO "" ;MH AWARD DATE
. . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),DGERRMSG,.ERRCOUNT) ;MH AWARD DATE
. S DGPAT("MOHSTATDATE")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE",.ERROR) ;MH STATUS DATE
. S DGELG("MOHSTATDATE")=$$CONVERT^DGENUPL1($P(SEG(4),$E(HLECH),2),"DATE",.ERROR) ;MH STATUS DATE
. I DGPAT("MOH")="N",DGPAT("MOHSTATDATE")="""" S ERROR=0,DGPAT("MOHSTATDATE")="" ;NO ERROR IF AWARD DATE IS EMPTY STRING
. I DGPAT("MOH")="N",DGPAT("MOHSTATDATE")="" S DGPAT("MOHSTATDATE")=DT,DGELG("MOHSTATDATE")=DT ;IF MOH IS "N' AND STATUS IS NULL SET STATUS DATE TO TODAY
. I ERROR D Q
. . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, MH STATUS DATE MISSING",.ERRCOUNT)
. I DGPAT("MOH")="N" S DGPAT("MOHEXEMPDATE")="",DGELG("MOHEXEMPDATE")=""
. I $G(DGPAT("MOHAWRDDATE")) D
. . I DGPAT("MOHAWRDDATE")<DGLEGDT S DGPAT("MOHEXEMPDATE")=DGLEGDT,DGELG("MOHEXEMPDATE")=DGLEGDT
. . I DGPAT("MOHAWRDDATE")=DGLEGDT S DGPAT("MOHEXEMPDATE")=DGPAT("MOHAWRDDATE"),DGELG("MOHEXEMPDATE")=DGPAT("MOHAWRDDATE")
. . I DGPAT("MOHAWRDDATE")>DGLEGDT S DGPAT("MOHEXEMPDATE")=DGPAT("MOHAWRDDATE"),DGELG("MOHEXEMPDATE")=DGPAT("MOHAWRDDATE")
. ;MOH DG*5.3*972 HM changes end here
Q
POWLOC(LOC,ERROR) ;POW Confinement Location mapping with HL7 table VA023
; Input: LOC - HL7 code for location
; Output: ERROR - Return error 1 on failure
; IEN22 - IEN of file 22
N TBL023
S ERROR=0
I LOC="" S ERROR=1 Q ""
S TBL023(4)="WWI",TBL023(5)="WWII-EUROPE",TBL023(6)="WWII-PACIFIC"
S TBL023(7)="KOREAN",TBL023(8)="VIETNAM",TBL023(9)="OTHER"
S TBL023("A")="PERSIAN GULF",TBL023("B")="YUGOSLAVIA"
S IEN22=$O(^DIC(22,"C",TBL023(LOC),""))
I IEN22="" S ERROR=1
Q IEN22
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENUPL3 14728 printed Apr 09, 2024@21:58:49 Page 2
DGENUPL3 ;ALB/CJM,ISA,KWP,AEG,BRM,ERC,CKN,BAJ,PHH,TDM,LBD,DJS,KUM,JAM,HM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ;12 June 2018 5:35PM
+1 ;;5.3;REGISTRATION;**147,230,232,377,404,451,653,688,793,797,841,928,935,947,966,972**;Aug 13,1993;Build 80
+2 ;
+3 ;
ADDMSG(MSGS,MESSAGE,TOHEC) ;
+1 ;Description: Used to add a message to an array of messages to be sent.
+2 ;
+3 ;Input:
+4 ; MSGS - the array to store the message (pass by reference)
+5 ; MESSAGE - the message to store
+6 ; TOHEC - a flag, if set to 1 it means that HEC should also receive notification
+7 ;
+8 ;Output: none
+9 ;
+10 IF MESSAGE["DATE OF DEATH"
QUIT
+11 SET MSGS(0)=($GET(MSGS(0))+1)
+12 SET MSGS(MSGS(0))=MESSAGE
+13 IF ($GET(TOHEC)=1)
SET MSGS("HEC")=1
+14 QUIT
+15 ;
+16 ;
NOTIFY(DGPAT,MSGS) ;
+1 ;Description: This is used to send a message to the local mail group
+2 ;defined by the MAS Parameter ELIGIBILITY UPLOAD MAIL GROUP.The
+3 ;notification is to be used when specific problems or conditions
+4 ;regarding the upload of the enrollment or eligibility data.
+5 ;
+6 ;Input:
+7 ; OLDPAT -used if the DGPAT elements have not been built
+8 ; DGPAT - patient array (pass by reference)
+9 ; MSGS - the an array of messages that should be included in the
+10 ; notification (pass by reference). If MSGS("HEC")=1
+11 ; it means that HEC should also receive notification.
+12 ;
+13 ;Output: none
+14 ;
+15 NEW TEXT,XMDUZ,XMTEXT,XMSUB,XMSTRIP,XMROU,XMY,XMZ,XMDF,COUNT
+16 NEW HEADER,NSC,POW,TMPSTR,MAILGRP,ELIG,CD,DGFDD
+17 ;
+18 ;if there are no alerts, then quit
+19 if '$GET(MSGS(0))
QUIT
+20 ;
+21 ;Get reason for alert. If there is more than one reason decide which
+22 ;reason to display. 'NON-SERVICE' alerts have a higher priority than
+23 ;other alerts and are therefore displayed before other alerts in the
+24 ;subject line, followed by 'POW' alerts in priority.
+25 SET (ELIG,NSC,POW,CD)=0
+26 SET COUNT=0
FOR
SET COUNT=$ORDER(MSGS(COUNT))
if 'COUNT!NSC
QUIT
Begin DoDot:1
+27 IF MSGS(COUNT)["PREVIOUSLY ELIGIBLE"
SET ELIG=1
QUIT
+28 IF MSGS(COUNT)["NON-SERVICE"
SET NSC=1
QUIT
+29 IF MSGS(COUNT)["POW"
SET POW=1
QUIT
+30 IF MSGS(COUNT)["CD EVALUATION"
SET CD=1
QUIT
+31 SET HEADER=MSGS(COUNT)
+32 QUIT
End DoDot:1
+33 Begin DoDot:1
+34 IF ELIG
SET HEADER="Ineligibility Alert: "
QUIT
+35 IF NSC
SET HEADER="NSC Alert: "
QUIT
+36 IF POW&'NSC
SET HEADER="POW Alert: "
QUIT
+37 IF CD
SET HEADER="CD Alert: "
QUIT
+38 QUIT
End DoDot:1
+39 ;
+40 SET XMDF=""
+41 SET (XMDUN,XMDUZ)="Registration Enrollment Module"
+42 ;Phase II Re-Enrollment
+43 ;DGPAT("SSN") is built by the parser. DGPAT("NAME"),DGPAT("SEX"),DGPAT("DOB")(are merged into DGPAT from OLDPAT.
+44 ;The checks below are to setup the DGPAT elements from OLDPAT if NOTIFY is called before the merge.
+45 IF '$DATA(DGPAT("NAME"))
SET DGPAT("NAME")=$GET(OLDPAT("NAME"))
+46 IF '$DATA(DGPAT("SEX"))
SET DGPAT("SEX")=$GET(OLDPAT("SEX"))
+47 IF '$DATA(DGPAT("DOB"))
SET DGPAT("DOB")=$GET(OLDPAT("DOB"))
+48 SET TMPSTR=" ("_$EXTRACT(DGPAT("NAME"),1,1)
+49 SET TMPSTR=TMPSTR_$EXTRACT(DGPAT("SSN"),$LENGTH(DGPAT("SSN"))-3,1000)_")"
+50 SET XMSUB=$EXTRACT(HEADER,1,30)_$EXTRACT(DGPAT("NAME"),1,25)_TMPSTR
+51 ;
+52 ; send msg to local mail group specified in IVM SITE PARAMETER file
+53 SET MAILGRP=+$PIECE($GET(^IVM(301.9,1,0)),"^",9)
+54 SET MAILGRP=$$EXTERNAL^DILFD(301.9,.09,"F",MAILGRP)
+55 IF MAILGRP]""
SET XMY("G."_MAILGRP)=""
+56 ;
+57 ;Patch DG*5.3*928 is removing ability to send emails to remote email group. Emails have been decommissioned and no longer required.
+58 ;if flag is set, send msg to remote mail group specified in
+59 ;the IVM SITE PARAMETER file
+60 ;I $G(MSGS("HEC"))=1 D
+61 ;.S MAILGRP=$P($G(^IVM(301.9,1,0)),"^",10)
+62 ;.S MAILGRP=$$EXTERNAL^DILFD(301.9,.10,"F",MAILGRP)
+63 ;.I MAILGRP]"" S XMY("G."_MAILGRP)=""
+64 ;
+65 ;
+66 SET XMTEXT="TEXT("
+67 SET TEXT(1)="The enrollment/eligibility upload produced the following alerts:"
+68 SET TEXT(2)=" "
+69 SET TEXT(3)="Patient Name : "_DGPAT("NAME")
+70 SET TEXT(4)="SSN : "_DGPAT("SSN")
+71 SET TEXT(5)="DOB : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB"))
+72 SET TEXT(6)="SEX : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX"))
+73 SET TEXT(7)=" "
+74 ;
+75 SET TEXT(8)=" ** Alerts **"
+76 SET TEXT(9)=" "
+77 SET COUNT=0
FOR
SET COUNT=$ORDER(MSGS(COUNT))
if 'COUNT
QUIT
SET TEXT(10+COUNT)=COUNT_") "_MSGS(COUNT)
+78 ;
+79 DO ^XMD
+80 QUIT
+81 ;
BEGUPLD(DFN) ;
+1 ;Description: Sets a lock used to determine if an eligibility/enrollment
+2 ;upload is in progress.
+3 ;
+4 ;Input:
+5 ; DFN - ien, Patient record
+6 ;
+7 ;Output:
+8 ; Function value - returns 1 if the lock was obtained, 0 otherwise.
+9 ;
+10 if '$GET(DFN)
QUIT 1
+11 LOCK +^DGEN("ELIGIBILITY UPLOAD",DFN):3
+12 QUIT $TEST
+13 ;
ENDUPLD(DFN) ;
+1 ;Description: Releases the lock obtained by calling $$BEGUPLD(DFN)
+2 ;
+3 if '$GET(DFN)
QUIT
+4 LOCK -^DGEN("ELIGIBILITY UPLOAD",DFN)
+5 QUIT
+6 ;
CKUPLOAD(DFN) ;
+1 ;Description: Checks if an upload is in progress. If so, it pauses
+2 ;until it is completed.
+3 ;The enrollment/eligibility upload can take a while to accomplish.
+4 ;If the lock is not obtained initially, it is assumed that the upload
+5 ;is in progress, and a message is displayed to the user.
+6 ;
+7 ;Input: DFN
+8 ;Output: none
+9 ;
+10 NEW I
+11 IF '$$BEGUPLD(DFN)
Begin DoDot:1
+12 WRITE !!,"Upload of patient enrollment/eligibility data is in progress ..."
+13 DO UNLOCK^DGENPTA1(DFN)
+14 FOR I=1:1:50
if $$BEGUPLD(DFN)
QUIT
WRITE "."
+15 WRITE !,"Upload of patient enrollment/eligibility data is completed.",!
End DoDot:1
+16 DO ENDUPLD(DFN)
+17 QUIT
SCVET ;moved from DGENUPL4 - DG*5.3*688
+1 IF DGPAT3("VETERAN")'="N"
Begin DoDot:1
+2 IF DGELG3("SC")="N"
SET DGPAT3("VETERAN")="Y"
SET DGPAT3("PATYPE")=$ORDER(^DG(391,"B","NSC VETERAN",0))
+3 IF DGELG3("SC")="Y"
SET DGPAT3("VETERAN")="Y"
SET DGPAT3("PATYPE")=$ORDER(^DG(391,"B","SC VETERAN",0))
End DoDot:1
+4 IF DGPAT3("VETERAN")="N"
SET DGPAT3("PATYPE")=$$NONVET(DGELG("ELIG","CODE"))
+5 QUIT
+6 ;
NONVET(DGCODE) ;map Patient Type from Primary Elig (and POS)
+1 ;added with DG*5.3*688 - ERC
+2 ; input: DGCODE is the Primary Eligibility code
+3 ; output: DGTPYE is returned as the value for Patient Type
+4 NEW PTELG,DGTYPE
+5 SET (PTELG,DGTYPE)=""
+6 if $GET(DGCODE)']""
QUIT ""
+7 SET PTELG=$$NATNAME^DGENELA(DGCODE)
+8 if $GET(PTELG)']""
QUIT ""
+9 IF "CHAMPVA^OTHER FEDERAL AGENCY^REIMBURSABLE INSURANCE^SHARING AGREEMENT"[PTELG
SET DGTYPE=$$POS(.DGTYPE)
if DGTYPE
QUIT DGTYPE
+10 SET DGTYPE=$SELECT(PTELG["ALLIED":"ALLIED VETERAN",PTELG["COLLATERAL":"COLLATERAL",PTELG["EMPLOYEE":"EMPLOYEE",PTELG["TRICARE":"TRICARE",1:"")
+11 ;default Pat Type
IF DGTYPE']""
SET DGTYPE="NON-VETERAN (OTHER)"
+12 SET DGTYPE=$ORDER(^DG(391,"B",DGTYPE,""))
+13 QUIT DGTYPE
POS(DGTYPE) ;for these Elig Codes, check POS to determine Patient Type
+1 SET DGPOS=DGELG("POS")
+2 IF $GET(DGPOS)']""
QUIT ""
+3 IF '$DATA(^DIC(21,DGPOS,0))
QUIT ""
+4 SET DGPOS=$PIECE(^DIC(21,DGPOS,0),U)
+5 SET DGTYPE=$SELECT(DGPOS["ACTIVE":"ACTIVE DUTY",DGPOS["OPERAT":"ACTIVE DUTY",DGPOS["RETIR":"MILITARY RETIREE",1:"")
+6 IF $GET(DGTYPE)]""
SET DGTYPE=$ORDER(^DG(391,"B",DGTYPE,""))
+7 QUIT DGTYPE
+8 ;
+9 ;ZMH code moved here from DGENUPL2 - DG*5.3*653
ZMH ;Purple Heart, POW, OEF/OIF Conflict Loc, Military Service Episodes, Medal of Honor
+1 ;PROCESS PH, OEF/OIF, MH & POW FROM ZMH
+2 ;Process Military Service Episodes (SL,SNL,SNNL,MSD) - DG*5.3*797
+3 ;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Future Discharge Date Added DG*5.3*935
+4 ;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Reason for Early Separation Added DG*5.3*947
+5 ;Process Military Service Episodes (SL,SNL,SNNL,MSD,FDD) - Separation Reason Code added DG*5.3*966
+6 ;DJS, Indicate if the ZMH segment exists in this message; DG*5.3*935
+7 NEW DGNEW
+8 SET ^TMP($JOB,"DGENUPL","ZMH",0)=1
+9 IF "^SL^SNL^SNNL^MSD^FDD^"[("^"_SEG(2)_"^")
Begin DoDot:1
+10 ;DJS, Store the Future Discharge Date (FDD); DG*5.3*935
+11 IF SEG(2)="FDD"&($LENGTH(SEG(8))<5)
SET SEG(8)=""
SET I=0
Begin DoDot:2
+12 ;JAM, FDD is NONEDITABLE in FileMan so this code is modified to directly delete the field; DG*5.3*972
+13 ;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
+14 ;Delete an incomplete MSE ;DG*5.3*935
SET DGNEW=0
FOR
SET I=$ORDER(^DPT(DFN,.3216,I))
if I'?.N!($GET(I)="")
QUIT
SET $PIECE(^DPT(DFN,.3216,I,0),"^",8)=""
DO ID1^DGNOZMH(DFN,I,DGNEW)
+15 KILL DGNEW
QUIT
End DoDot:2
QUIT
+16 NEW BOS,SN,DIS,SED,SSD,COM,DGFDD,DIE,DA,DR,RES,RESCODE
SET ERROR=""
+17 ;Service Branch
SET BOS=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+18 if BOS]""
SET BOS=$ORDER(^DIC(23,"B",BOS,""))
+19 ;Service Number
SET SN=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),2))
+20 ;Discharge Type
SET DIS=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),3))
+21 if DIS]""
SET DIS=$ORDER(^DIC(25,"B",DIS,""))
+22 ;Entry Date
SET SED=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH)),"DATE")
+23 IF 'SED!ERROR
Begin DoDot:2
+24 if SEG(2)="FDD"&(SEG(8)="")
QUIT
DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, SERVICE ENTRY DATE",.ERRCOUNT)
End DoDot:2
QUIT
+25 ;Sep. Date
SET SSD=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),2),"DATE")
+26 ;Service Component
SET COM=$$CONVERT^DGENUPL1($PIECE(SEG(5),$EXTRACT(HLECH)))
+27 ;Add Reason for Early Separation - DG*5.3*947
+28 ;Reason for Early Separation (free text)
SET RES=$$CONVERT^DGENUPL1($PIECE(SEG(9),$EXTRACT(HLECH)))
+29 ;Add Separation Reason Code (variable is NEW'd above and set into the DGNMSE array below) - DG*5.3*966
+30 ;Separation Reason Code (3 digit)
SET RESCODE=$$CONVERT^DGENUPL1($PIECE(SEG(10),$EXTRACT(HLECH)))
+31 ;DJS, Create variable DGFDD for storage in Military Service Episode (MSE); DG*5.3*935
+32 ;DJS, Create MSE whether or not FDD exists & is a valid date; DG*5.3*935
+33 IF SEG(2)="FDD"
Begin DoDot:2
+34 SET DGFDD=$$CONVERT^DGENUPL1($PIECE(SEG(8),$EXTRACT(HLECH)),"DATE")
+35 IF $$VALID^DGRPDT(.DGFDD)=1
Begin DoDot:3
+36 SET DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1_U_DGFDD
End DoDot:3
End DoDot:2
+37 ;E S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1
+38 IF '$TEST
SET DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1_U_U_RES_U_RESCODE
End DoDot:1
QUIT
+39 ;
+40 ;Process Purple Heart from ZMH
IF SEG(2)="PH"
Begin DoDot:1
+41 SET DGPAT("PHI")=$PIECE(SEG(3),$EXTRACT(HLECH))
+42 SET DGELG("PH")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+43 SET DGPAT("PHST")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),2))
+44 SET DGPAT("PHRR")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),3))
End DoDot:1
QUIT
+45 ;
+46 IF SEG(2)="OEIF"
Begin DoDot:1
+47 NEW OEIFLOC
+48 SET OEIFLOC=$PIECE(SEG(3),$EXTRACT(HLECH))
+49 ;Ignore these entries
IF OEIFLOC="Conflict Unspecified"
QUIT
+50 IF OEIFLOC="Unknown OEF/OIF"
SET OEIFLOC="UNK"
+51 SET OEIFLOC=$EXTRACT(OEIFLOC,1,3)
+52 if ((OEIFLOC'="OIF")&(OEIFLOC'="OEF")&(OEIFLOC'="UNK"))
QUIT
+53 SET DGOEIF("COUNT")=$GET(DGOEIF("COUNT"))+1
+54 SET DGOEIF("LOC",DGOEIF("COUNT"))=OEIFLOC
+55 SET DGOEIF("SITE",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),2),"INSTITUTION")
+56 SET DGOEIF("FR",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH)),"DATE")
+57 SET DGOEIF("TO",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),2),"DATE")
+58 SET DGOEIF("LOCK",DGOEIF("COUNT"))=1
End DoDot:1
QUIT
+59 ;
+60 ;Process POW from ZMH
IF SEG(2)="POW"
Begin DoDot:1
+61 ;POW STATUS INDICATED
SET DGPAT("POWI")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+62 SET DGELG("POW")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+63 SET DGPAT("POWLOC")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),2))
+64 ;POW CONFINEMENT LOCATION
IF DGPAT("POWLOC")'="@"
SET DGPAT("POWLOC")=$$POWLOC(DGPAT("POWLOC"),.ERROR)
+65 IF ERROR
Begin DoDot:2
+66 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, POW CONFINEMENT LOCATION",.ERRCOUNT)
End DoDot:2
QUIT
+67 ;POW FROM DATE
SET DGPAT("POWFDT")=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH)),"DATE",.ERROR)
+68 IF ERROR
Begin DoDot:2
+69 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW FROM DATE",.ERRCOUNT)
End DoDot:2
QUIT
+70 ;POW TO DATE
SET DGPAT("POWTDT")=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),2),"DATE",.ERROR)
+71 IF ERROR
Begin DoDot:2
+72 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW TO DATE",.ERRCOUNT)
End DoDot:2
QUIT
End DoDot:1
+73 ;
+74 ;Process Medal of Honor from ZMH
IF SEG(2)="MH"
Begin DoDot:1
+75 NEW TODAY,Y,DGVDOB,DGLEGDT,DGERRMSG,VAEL
+76 ;MH STATUS INDICATED
SET DGPAT("MOH")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+77 ;MOH DG*5.3*972 HM changes start here
+78 SET DGELG("MOH")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+79 IF DGELG("MOH")="Y"
Begin DoDot:2
+80 ;CHECK IF VETERAN FROM ZEL SEGMENT
IF $GET(DGPAT("VETERAN"))="Y"
QUIT
+81 ;IF NOT VETERAN SET ERROR
IF $GET(DGPAT("VETERAN"))="N"
SET ERROR=1
QUIT
+82 ;IF CANNOT DETERMINE VETERAN STATUS CALL ELIG^VADPT TO GET STATUS FROM DB, IF NON VETERAN SET ERROR
DO ELIG^VADPT
IF $GET(VAEL(4))'=1
SET ERROR=1
End DoDot:2
+83 IF ERROR
Begin DoDot:2
+84 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, NON VETERAN INELIGIBLE FOR MEDAL OF HONOR",.ERRCOUNT)
End DoDot:2
QUIT
+85 SET DGPAT("MOHAWRDDATE")=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),1),"DATE",.ERROR)
+86 SET DGELG("MOHAWRDDATE")=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),1),"DATE",.ERROR)
+87 ;NO ERROR IF AWARD DATE IS EMPTY STRING
IF DGPAT("MOH")="N"
IF DGPAT("MOHAWRDDATE")=""""
SET ERROR=0
+88 ;IF MOH = 'N' SET AWARD DATE TO NULL
IF DGPAT("MOH")="N"
SET DGPAT("MOHAWRDDATE")=""
SET DGELG("MOHAWRDDATE")=""
+89 ;MOH LEGISLATION DATE 2016/12/16
SET DGLEGDT=3161216
+90 ;MH AWARD DATE
IF $GET(DGPAT("MOHAWRDDATE"))
Begin DoDot:2
+91 IF DGPAT("MOHAWRDDATE")>DT
SET ERROR=1
+92 ;IF AWARD DATE IS IN FUTURE
SET DGERRMSG="BAD VALUE, ZMH SEGMENT, SEQ 4, MH AWARD DATE IS IN THE FUTURE"
+93 SET DGVDOB=$PIECE(^DPT(+DFN,0),"^",3)
+94 ;IF AWARD DATE IS LESS THE DOB + 15 YEARS ;MH AWARD DATE
IF DGPAT("MOHAWRDDATE")-DGVDOB<150000
SET ERROR=1
SET DGERRMSG="BAD VALUE, ZMH SEGMENT, SEQ 4, MH AWARD DATE BEFORE BIRTH DATE"
End DoDot:2
+95 IF ERROR
Begin DoDot:2
+96 ;IF AWARD FAILS VALIDATION SE TO "" ;MH AWARD DATE
SET DGPAT("MOHAWRDDATE")=""
+97 ;MH AWARD DATE
DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),DGERRMSG,.ERRCOUNT)
End DoDot:2
QUIT
+98 ;MH STATUS DATE
SET DGPAT("MOHSTATDATE")=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),2),"DATE",.ERROR)
+99 ;MH STATUS DATE
SET DGELG("MOHSTATDATE")=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),2),"DATE",.ERROR)
+100 ;NO ERROR IF AWARD DATE IS EMPTY STRING
IF DGPAT("MOH")="N"
IF DGPAT("MOHSTATDATE")=""""
SET ERROR=0
SET DGPAT("MOHSTATDATE")=""
+101 ;IF MOH IS "N' AND STATUS IS NULL SET STATUS DATE TO TODAY
IF DGPAT("MOH")="N"
IF DGPAT("MOHSTATDATE")=""
SET DGPAT("MOHSTATDATE")=DT
SET DGELG("MOHSTATDATE")=DT
+102 IF ERROR
Begin DoDot:2
+103 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, MH STATUS DATE MISSING",.ERRCOUNT)
End DoDot:2
QUIT
+104 IF DGPAT("MOH")="N"
SET DGPAT("MOHEXEMPDATE")=""
SET DGELG("MOHEXEMPDATE")=""
+105 IF $GET(DGPAT("MOHAWRDDATE"))
Begin DoDot:2
+106 IF DGPAT("MOHAWRDDATE")<DGLEGDT
SET DGPAT("MOHEXEMPDATE")=DGLEGDT
SET DGELG("MOHEXEMPDATE")=DGLEGDT
+107 IF DGPAT("MOHAWRDDATE")=DGLEGDT
SET DGPAT("MOHEXEMPDATE")=DGPAT("MOHAWRDDATE")
SET DGELG("MOHEXEMPDATE")=DGPAT("MOHAWRDDATE")
+108 IF DGPAT("MOHAWRDDATE")>DGLEGDT
SET DGPAT("MOHEXEMPDATE")=DGPAT("MOHAWRDDATE")
SET DGELG("MOHEXEMPDATE")=DGPAT("MOHAWRDDATE")
End DoDot:2
+109 ;MOH DG*5.3*972 HM changes end here
End DoDot:1
+110 QUIT
POWLOC(LOC,ERROR) ;POW Confinement Location mapping with HL7 table VA023
+1 ; Input: LOC - HL7 code for location
+2 ; Output: ERROR - Return error 1 on failure
+3 ; IEN22 - IEN of file 22
+4 NEW TBL023
+5 SET ERROR=0
+6 IF LOC=""
SET ERROR=1
QUIT ""
+7 SET TBL023(4)="WWI"
SET TBL023(5)="WWII-EUROPE"
SET TBL023(6)="WWII-PACIFIC"
+8 SET TBL023(7)="KOREAN"
SET TBL023(8)="VIETNAM"
SET TBL023(9)="OTHER"
+9 SET TBL023("A")="PERSIAN GULF"
SET TBL023("B")="YUGOSLAVIA"
+10 SET IEN22=$ORDER(^DIC(22,"C",TBL023(LOC),""))
+11 IF IEN22=""
SET ERROR=1
+12 QUIT IEN22
+13 ;
