- 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 Feb 19, 2025@00:09:22 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 ;