DGENUPL3 ;ALB/CJM,ISA/KWP,AEG,BRM,ERC,CKN,BAJ,PHH,TDM,LBD - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 6/4/09 4:09pm
;;5.3;PIMS;**147,230,232,377,404,451,653,688,1015,1016**;JUN 30, 2012;Build 20
;
;
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
;
;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)=""
;
; 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
;PROCESS PH, OEF/OIF & POW FROM ZMH
;Process Military Service Episodes (SL,SNL,SNNL,MSD) - DG*5.3*797
I "^SL^SNL^SNNL^MSD^"[("^"_SEG(2)_"^") D Q
. N BOS,SN,DIS,SED,SSD,COM
. 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
. . 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
. S DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1
;
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)
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
;
DGENUPL3 ;ALB/CJM,ISA/KWP,AEG,BRM,ERC,CKN,BAJ,PHH,TDM,LBD - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 6/4/09 4:09pm
+1 ;;5.3;PIMS;**147,230,232,377,404,451,653,688,1015,1016**;JUN 30, 2012;Build 20
+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
+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 ; if flag is set, send msg to remote mail group specified in
+58 ; the IVM SITE PARAMETER file
+59 IF $GET(MSGS("HEC"))=1
Begin DoDot:1
+60 SET MAILGRP=$PIECE($GET(^IVM(301.9,1,0)),"^",10)
+61 SET MAILGRP=$$EXTERNAL^DILFD(301.9,.10,"F",MAILGRP)
+62 IF MAILGRP]""
SET XMY("G."_MAILGRP)=""
End DoDot:1
+63 ;
+64 ;
+65 SET XMTEXT="TEXT("
+66 SET TEXT(1)="The enrollment/eligibility upload produced the following alerts:"
+67 SET TEXT(2)=" "
+68 SET TEXT(3)="Patient Name : "_DGPAT("NAME")
+69 SET TEXT(4)="SSN : "_DGPAT("SSN")
+70 SET TEXT(5)="DOB : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("DOB"),"F",DGPAT("DOB"))
+71 SET TEXT(6)="SEX : "_$$EXTERNAL^DILFD(2,$$FIELD^DGENPTA1("SEX"),"F",DGPAT("SEX"))
+72 SET TEXT(7)=" "
+73 ;
+74 SET TEXT(8)=" ** Alerts **"
+75 SET TEXT(9)=" "
+76 SET COUNT=0
FOR
SET COUNT=$ORDER(MSGS(COUNT))
IF 'COUNT
QUIT
SET TEXT(10+COUNT)=COUNT_") "_MSGS(COUNT)
+77 ;
+78 DO ^XMD
+79 QUIT
+80 ;
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
+1 ;PROCESS PH, OEF/OIF & POW FROM ZMH
+2 ;Process Military Service Episodes (SL,SNL,SNNL,MSD) - DG*5.3*797
+3 IF "^SL^SNL^SNNL^MSD^"[("^"_SEG(2)_"^")
Begin DoDot:1
+4 NEW BOS,SN,DIS,SED,SSD,COM
+5 ;Service Branch
SET BOS=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+6 IF BOS]""
SET BOS=$ORDER(^DIC(23,"B",BOS,""))
+7 ;Service Number
SET SN=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),2))
+8 ;Discharge Type
SET DIS=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),3))
+9 IF DIS]""
SET DIS=$ORDER(^DIC(25,"B",DIS,""))
+10 ;Entry Date
SET SED=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH)),"DATE")
+11 IF 'SED!ERROR
Begin DoDot:2
+12 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, SERVICE ENTRY DATE",.ERRCOUNT)
End DoDot:2
QUIT
+13 ;Sep. Date
SET SSD=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),2),"DATE")
+14 ;Service Component
SET COM=$$CONVERT^DGENUPL1($PIECE(SEG(5),$EXTRACT(HLECH)))
+15 SET DGNMSE(-SED)=SED_U_SSD_U_BOS_U_COM_U_SN_U_DIS_U_1
End DoDot:1
QUIT
+16 ;
+17 ;Process Purple Heart from ZMH
IF SEG(2)="PH"
Begin DoDot:1
+18 SET DGPAT("PHI")=$PIECE(SEG(3),$EXTRACT(HLECH))
+19 SET DGELG("PH")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+20 SET DGPAT("PHST")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),2))
+21 SET DGPAT("PHRR")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),3))
End DoDot:1
QUIT
+22 ;
+23 IF SEG(2)="OEIF"
Begin DoDot:1
+24 NEW OEIFLOC
+25 SET OEIFLOC=$PIECE(SEG(3),$EXTRACT(HLECH))
+26 ;Ignore these entries
IF OEIFLOC="Conflict Unspecified"
QUIT
+27 IF OEIFLOC="Unknown OEF/OIF"
SET OEIFLOC="UNK"
+28 SET OEIFLOC=$EXTRACT(OEIFLOC,1,3)
+29 IF ((OEIFLOC'="OIF")&(OEIFLOC'="OEF")&(OEIFLOC'="UNK"))
QUIT
+30 SET DGOEIF("COUNT")=$GET(DGOEIF("COUNT"))+1
+31 SET DGOEIF("LOC",DGOEIF("COUNT"))=OEIFLOC
+32 SET DGOEIF("SITE",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),2),"INSTITUTION")
+33 SET DGOEIF("FR",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH)),"DATE")
+34 SET DGOEIF("TO",DGOEIF("COUNT"))=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),2),"DATE")
+35 SET DGOEIF("LOCK",DGOEIF("COUNT"))=1
End DoDot:1
QUIT
+36 ;
+37 ;Process POW from ZMH
IF SEG(2)="POW"
Begin DoDot:1
+38 ;POW STATUS INDICATED
SET DGPAT("POWI")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+39 SET DGELG("POW")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH)))
+40 SET DGPAT("POWLOC")=$$CONVERT^DGENUPL1($PIECE(SEG(3),$EXTRACT(HLECH),2))
+41 ;POW CONFINEMENT LOCATION
IF DGPAT("POWLOC")'="@"
SET DGPAT("POWLOC")=$$POWLOC(DGPAT("POWLOC"),.ERROR)
+42 IF ERROR
Begin DoDot:2
+43 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 3, POW CONFINEMENT LOCATION",.ERRCOUNT)
End DoDot:2
QUIT
+44 ;POW FROM DATE
SET DGPAT("POWFDT")=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH)),"DATE",.ERROR)
+45 IF ERROR
Begin DoDot:2
+46 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW FROM DATE",.ERRCOUNT)
End DoDot:2
QUIT
+47 ;POW TO DATE
SET DGPAT("POWTDT")=$$CONVERT^DGENUPL1($PIECE(SEG(4),$EXTRACT(HLECH),2),"DATE",.ERROR)
+48 IF ERROR
Begin DoDot:2
+49 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMH SEGMENT, SEQ 4, POW TO DATE",.ERRCOUNT)
End DoDot:2
QUIT
End DoDot:1
+50 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 ;
