DGENUPL2 ;ALB/CJM,RTK,TMK,ISA/KWP/RMM/CKN,EG,ERC,PWC,TDM,TEJ,KUM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 23 Nov 2019 1:07 PM
;;5.3;REGISTRATION;**147,222,232,310,314,367,397,677,631,675,672,673,716,653,688,838,842,894,934,940,993,1027**;Aug 13,1993;Build 70
;Per VHA Directive 2004-038, this routine should not be modified.
;
;**************************************************************
;The following procedures parse particular segment types.
;Input:SEG(),MSGID
;Output:DGPAT(),DGELG(),DGENR(),DGCDIS(),DGNTR(),DGOEIF(),ERROR
;**************************************************************
;
PID ;
S DGPAT("SSN")=SEG(19)
Q
;
ZPD ;
D ZPD^DGENUPLA ;code removed due to size of DGENUPLA - DG*5.3*688
Q
;
ZIE ;
S DGPAT("INELDATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIE SEGMENT, SEQ 2",.ERRCOUNT)
S DGPAT("INELREA")=$$CONVERT^DGENUPL1(SEG(3))
S DGPAT("INELDEC")=$$CONVERT^DGENUPL1(SEG(4))
Q
;
ZIO ;New segment - DG*5.3*653
D ZIO^DGENUPLA ;Code for ZIO has moved to DGENUPLA
Q
;
ZEL(COUNT) ;
D ZEL^DGENUPLA(COUNT) ;code for ZEL segment has moved to DGENUPLA
Q
;
ZEN ;
N SUB,DGRES
S DGENR("DATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 2",.ERRCOUNT)
S DGENR("SOURCE")=$$CONVERT^DGENUPL1(SEG(3))
S DGENR("STATUS")=$$CONVERT^DGENUPL1(SEG(4))
;S ERROR=$$PEND(DFN,DGENR("STATUS")) ;DG*5.3*934
S ERROR=0 ;DG*5.3*934
;I ERROR D Q ;DG*5.3*934
;.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ENROLLMENT STATUS PENDING-ELIGIBILITY IS VERIFIED",.ERRCOUNT)
S DGENR("REASON")=$$CONVERT^DGENUPL1(SEG(5))
S DGENR("REMARKS")=$$CONVERT^DGENUPL1(SEG(6))
S DGENR("FACREC")=$$CONVERT^DGENUPL1(SEG(7),"INSTITUTION",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY RECEIVED "_SEG(7)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
S DGPAT("PREFAC")=$$CONVERT^DGENUPL1(SEG(8),"INSTITUTION",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"PREFERRED FACILITY "_SEG(8)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
;
S DGENR("PRIORITY")=$$CONVERT^DGENUPL1(SEG(9))
S DGENR("EFFDATE")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 10",.ERRCOUNT)
S DGOAPP=""
S DGENR("APP")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 11",.ERRCOUNT)
;DG*5.3*1027 - Capture Application Date tranmitted by ES for checking later
S DGOAPP=DGENR("APP")
I DGOAPP="@" S DGOAPP=""
;
;!!!!!! take next line out when HEC begins transmitting application dt
I DGENR("APP")=""!(DGENR("APP")="@") S DGENR("APP")=DGENR("DATE")
I DGENR("APP")=""!(DGENR("APP")="@") S DGENR("APP")=DGENR("EFFDATE")
;
S DGENR("END")=$$CONVERT^DGENUPL1(SEG(12),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 12",.ERRCOUNT)
;Phase II Parse out Sub-Group (SRS 6[B.4)
S DGENR("SUBGRP")=$$CONVERT^DGENUPL1(SEG(13))
S DGPAT("PFSRC")=$$CONVERT^DGENUPL1(SEG(14)) N PFSRC S PFSRC=DGPAT("PFSRC")
I PFSRC'="V"&(PFSRC'="E")&(PFSRC'="PA")&(PFSRC'="PI")&(PFSRC'="@")&(PFSRC'="") D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 14",.ERRCOUNT) Q
;
S DGENR("RCODE")=$$CONVERT^DGENUPL1(SEG(15)) ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
S DGENR("PTAPPLIED")=$$CONVERT^DGENUPL1(SEG(16)) ;KUM field added with DG*5.3*993
S DGENR("REGREA")=$$CONVERT^DGENUPL1(SEG(17)) ;KUM field added with DG*5.3*993
S DGENR("REGREA")=$$FIND1^DIC(408.43,"","X",$G(DGENR("REGREA")),"C","","ERROR")
I DGENR("REGREA")=0 S DGENR("REGREA")=""
S DGENR("REGDATE")=$$CONVERT^DGENUPL1(SEG(18),"DATE",.ERROR) ;KUM field added with DG*5.3*993
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 18",.ERRCOUNT)
S DGENR("REGSRC")=$$CONVERT^DGENUPL1(SEG(19)) ;KUM field added with DG*5.3*993
I ((DGENR("REGSRC")'="")!(DGENR("REGSRC")'="@")) D
. S DGRES=0
. D CHK^DIE(27.11,.17,"",DGENR("REGSRC"),.DGRES)
. I +DGRES>0 S DGENR("REGSRC")=DGRES
;DG*5.3*933
;Make Enrollment Application Date, Effective Date and Enrollment End Date as Registration date if it is blank for REGISTRAITON ONLY status
I $G(DGENR("STATUS"))=25 D
.I (($G(DGENR("REGDATE"))="")!($G(DGENR("REGDATE"))="@")) D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"REGISTRATION DATE IS MISSING AND ENROLLMENT STATUS IS REGISTRAITON ONLY",.ERRCOUNT)
.I (($G(DGENR("APP"))="")!($G(DGENR("APP"))="@")) S DGENR("APP")=DGENR("REGDATE")
.I (($G(DGENR("EFFDATE"))="")!($G(DGENR("EFFDATE"))="@")) S DGENR("EFFDATE")=DGENR("REGDATE")
.I (($G(DGENR("SOURCE"))="")!($G(DGENR("SOURCE"))="@")) S DGENR("SOURCE")=2
;want to ignore double quotes sent for enrollment fields
S SUB=""
F S SUB=$O(DGENR(SUB)) Q:SUB="" I DGENR(SUB)="@"!(DGENR(SUB)="""""") S DGENR(SUB)=""
;
Q
;
ZMT ;
I SEG(1)>1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ZMT SEGMENT, SEQ 1, SHOULD SPECIFY MEANS TEST",.ERRCOUNT) S ERROR=1 Q
S DGELG("MTSTA")=$$CONVERT^DGENUPL1(SEG(3),"MT",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMT SEGMENT, SEQ 3",.ERRCOUNT)
Q
;
ZCD ;
;Phase II for multiple ZCD's
I SEG(1)>1 G SKIP
S DGCDIS("BY")=$$CONVERT^DGENUPL1(SEG(3))
S DGCDIS("DATE")=$$CONVERT^DGENUPL1(SEG(5),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 5",.ERRCOUNT)
S DGCDIS("FACDET")=$$CONVERT^DGENUPL1(SEG(4),"INSTITUTION",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY "_SEG(4)_" MAKING CATASTROPHIC DISABILITY DETERMINATION NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
S DGCDIS("REVDTE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 2",.ERRCOUNT)
S DGCDIS("METDET")=$$CONVERT^DGENUPL1($P(SEG(6),$E(HLECH)))
S DGCDIS("VCD")=$$CONVERT^DGENUPL1(SEG(12))
;SEQ 14 - DATE VETERAN REQUESTED CD EVALUATION
S DGCDIS("VETREQDT")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 14",.ERRCOUNT)
;SEQ 15 - DATE FACILITY INITIATED REVIEW
S DGCDIS("DTFACIRV")=$$CONVERT^DGENUPL1(SEG(15),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 15",.ERRCOUNT)
;SEQ 16 - DATE VETERAN WAS NOTIFIED
S DGCDIS("DTVETNOT")=$$CONVERT^DGENUPL1(SEG(16),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 16",.ERRCOUNT)
SKIP ;
;Phase II Parse out additional fields. CONVERT type of RSN converts the code to IEN for diagnosis,procedure and condition (HL7TORSN^DGENA5).
; * check the new DESCRIPTOR sequences - DG*5.3*894
N I,D3 ; DG*5.3*894
S D3="|" ; DG*5.3*894
F I=1:1 Q:$P(SEG(17),D3,I)="" D
. S DGCDIS("DESCR",I)=$$CONVERT^DGENUPL1($P(SEG(17),D3,I),"CDDSCR")
;
I '$D(DGCDIS("DESCR")) D
.S DGCDIS("DIAG",SEG(1))=$$CONVERT^DGENUPL1(SEG(7),"CDRSN")
.S DGCDIS("PROC",SEG(1))=$$CONVERT^DGENUPL1(SEG(8),"CDRSN")
.S DGCDIS("COND",SEG(1))=$$CONVERT^DGENUPL1(SEG(10),"CDRSN")
;
S DGCDIS("EXT",SEG(1),1)=$$CONVERT^DGENUPL1($P(SEG(9),$E(HLECH)),"EXT")
S DGCDIS("SCORE",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(11),$E(HLECH)))
S DGCDIS("PERM",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(13),$E(HLECH)))
I DGCDIS("VCD")="Y",'$D(DGCDIS("DIAG")),'$D(DGCDIS("PROC")),'$D(DGCDIS("COND")),'$D(DGCDIS("DESCR")) D Q
.S ERROR=1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"NO VALID DIAGNOSIS,PROCEDURE,CONDITION, OR DESCRIPTOR IN THE ZCD SEGMENT",.ERRCOUNT)
Q
;
ZSP ;
S DGELG("SC")=$$CONVERT^DGENUPL1(SEG(2),"Y/N",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 2",.ERRCOUNT)
S DGELG("SCPER")=$$CONVERT^DGENUPL1(SEG(3))
S DGELG("POS")=$$CONVERT^DGENUPL1(SEG(4),"POS",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 4",.ERRCOUNT)
S DGELG("EFFDT")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
I ERROR D Q
. D ADDERROR^DGENUPL(MSGID,$G(DGELG("EFFDT")),"BAD VALUE, ZSP SEGMENT, SEQ 11",.ERRCOUNT)
;if effective date is null, set update value to "@" (delete)
I DGELG("EFFDT")="" S DGELG("EFFDT")="@"
;
;added 8/3/98 to reduce #rejects
;if HEC sends SC=NO, SC% not sent, and site has value for SC% then delete it
I DGELG("SC")="N",DGELG("SCPER")="" S DGELG("SCPER")="@"
;
S DGELG("P&T")=$$CONVERT^DGENUPL1(SEG(6),"Y/N",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 6",.ERRCOUNT)
S DGELG("UNEMPLOY")=$$CONVERT^DGENUPL1(SEG(7),"Y/N",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 7",.ERRCOUNT)
S DGELG("SCAWDATE")=$$CONVERT^DGENUPL1(SEG(8),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 8",.ERRCOUNT)
S DGELG("P&TDT")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
I ERROR D
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 10 - P&T EFFECTIVE DATE",.ERRCOUNT)
S DGPAT("DENTC2IN")=$$CONVERT^DGENUPL1(SEG(12),"Y/N",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 12",.ERRCOUNT)
S DGPAT("DENTC2DT")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
I ERROR D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 13",.ERRCOUNT)
Q
;
ZMH ;Purple Heart, OEFOIE, POW
D ZMH^DGENUPL3 ;Moved to DGENUPL3 - DG*5.3*653
Q
;
ZRD ;
N COUNT,DXCODE,NAME,COND
S DXCODE=$P(SEG(2),$E(HLECH))
I DXCODE="""""" S DXCODE=""
S NAME=$P(SEG(2),$E(HLECH),2)
Q:DXCODE="" ;segment does not contain a disability condition
;
S COUNT=1+(+$G(DGELG("RATEDIS")))
S (COND,DGELG("RATEDIS",COUNT,"RD"))=$$DCLOOKUP(DXCODE,NAME)
S DGELG("RATEDIS",COUNT,"PER")=$$CONVERT^DGENUPL1(SEG(3)),DGELG("RATEDIS")=COUNT
S DGELG("RATEDIS",COUNT,"RDEXT")=$$CONVERT^DGENUPL1(SEG(12))
S DGELG("RATEDIS",COUNT,"RDORIG")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
I ERROR D Q
. D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 13",.ERRCOUNT)
S DGELG("RATEDIS",COUNT,"RDCURR")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
I ERROR D Q
. D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 14",.ERRCOUNT)
I 'COND D Q
.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, SEQ 2 - DISABILTY CONDITION LOOKUP FAILED",.ERRCOUNT)
.S ERROR=1
Q
OBX ;
D OBX^DGENUPLA ;code for OBX segment moved to DGENUPLA
Q
;
;*********** end of segment parsers ****
;
DCLOOKUP(DGCODE,DGNAME) ;
; Description: Returns the ien of a Disability Condition (file #31) based on the DGCODE and DGNAME
;
;Input:
; DGCODE - DX Code of the Disability Condition
; DGNAME - name of the Disability Condition
;Output:
; Function Value: ien of the entry found, or 0 otherwise
;
Q:(DGCODE="") 0
N NODE,IEN,FOUND
S (FOUND,IEN)=0
F S IEN=$O(^DIC(31,"C",DGCODE,IEN)) Q:'IEN D Q:FOUND
.S NODE=$G(^DIC(31,IEN,0))
.I DGNAME=$P(NODE,"^"),DGCODE=$P(NODE,"^",3) S FOUND=1
I 'FOUND S IEN=$O(^DIC(31,"C",DGCODE,0))
Q +IEN
;
REGCHECK(DFN) ;
; Description: passes patient through the registration consistency checker
;Input -
; DFN - is a pointer to the Patient File
;
N DGCD,DGCHK,DGDAY,DGEDCN,DGER,DGLST,DGNCK,DGRPCOLD,DGSC,DGTYPE,DGVT,VA,X
;
S DGEDCN=0
D ^DGRPC
Q
PEND(DFN,DGSTAT) ;
N DGARR,DGEC,DGERR,DGX
I $P($G(^DPT(DFN,.361)),U)'="V" Q 0
I $G(DGSTAT)="@" Q 0
I $G(DGSTAT)']"" Q 0
S DGSTAT="^"_DGSTAT_"^"
Q:"^15^17^"'[DGSTAT 0
D GETS^DIQ(2,DFN_",",".301;.302;.361;.36295","IE","DGARR","DGERR")
I $D(DGERR) Q 0
S DGEC=$G(DGARR(2,DFN_",",.361,"I"))
I $G(DGEC)']"" Q 0
S DGEC=$P($G(^DIC(8,DGEC,0)),U,9)
I $G(DGEC)']"" Q 0
I DGEC=5 Q 1
I DGEC=3 D Q DGX
. S DGX=1
. I $G(DGARR(2,DFN_",",.301,"I"))'="Y" S DGX=0 Q
. I +$G(DGARR(2,DFN_",",.302,"I"))>0 S DGX=0 Q
. I +$G(DGARR(2,DFN_",",.36295,"I"))>0 S DGX=0 Q
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENUPL2 12310 printed Apr 09, 2024@21:51:06 Page 2
DGENUPL2 ;ALB/CJM,RTK,TMK,ISA/KWP/RMM/CKN,EG,ERC,PWC,TDM,TEJ,KUM - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 23 Nov 2019 1:07 PM
+1 ;;5.3;REGISTRATION;**147,222,232,310,314,367,397,677,631,675,672,673,716,653,688,838,842,894,934,940,993,1027**;Aug 13,1993;Build 70
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;**************************************************************
+5 ;The following procedures parse particular segment types.
+6 ;Input:SEG(),MSGID
+7 ;Output:DGPAT(),DGELG(),DGENR(),DGCDIS(),DGNTR(),DGOEIF(),ERROR
+8 ;**************************************************************
+9 ;
PID ;
+1 SET DGPAT("SSN")=SEG(19)
+2 QUIT
+3 ;
ZPD ;
+1 ;code removed due to size of DGENUPLA - DG*5.3*688
DO ZPD^DGENUPLA
+2 QUIT
+3 ;
ZIE ;
+1 SET DGPAT("INELDATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
+2 IF ERROR
Begin DoDot:1
+3 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZIE SEGMENT, SEQ 2",.ERRCOUNT)
End DoDot:1
QUIT
+4 SET DGPAT("INELREA")=$$CONVERT^DGENUPL1(SEG(3))
+5 SET DGPAT("INELDEC")=$$CONVERT^DGENUPL1(SEG(4))
+6 QUIT
+7 ;
ZIO ;New segment - DG*5.3*653
+1 ;Code for ZIO has moved to DGENUPLA
DO ZIO^DGENUPLA
+2 QUIT
+3 ;
ZEL(COUNT) ;
+1 ;code for ZEL segment has moved to DGENUPLA
DO ZEL^DGENUPLA(COUNT)
+2 QUIT
+3 ;
ZEN ;
+1 NEW SUB,DGRES
+2 SET DGENR("DATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
+3 IF ERROR
Begin DoDot:1
+4 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 2",.ERRCOUNT)
End DoDot:1
QUIT
+5 SET DGENR("SOURCE")=$$CONVERT^DGENUPL1(SEG(3))
+6 SET DGENR("STATUS")=$$CONVERT^DGENUPL1(SEG(4))
+7 ;S ERROR=$$PEND(DFN,DGENR("STATUS")) ;DG*5.3*934
+8 ;DG*5.3*934
SET ERROR=0
+9 ;I ERROR D Q ;DG*5.3*934
+10 ;.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ENROLLMENT STATUS PENDING-ELIGIBILITY IS VERIFIED",.ERRCOUNT)
+11 SET DGENR("REASON")=$$CONVERT^DGENUPL1(SEG(5))
+12 SET DGENR("REMARKS")=$$CONVERT^DGENUPL1(SEG(6))
+13 SET DGENR("FACREC")=$$CONVERT^DGENUPL1(SEG(7),"INSTITUTION",.ERROR)
+14 IF ERROR
Begin DoDot:1
+15 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"FACILITY RECEIVED "_SEG(7)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
End DoDot:1
QUIT
+16 SET DGPAT("PREFAC")=$$CONVERT^DGENUPL1(SEG(8),"INSTITUTION",.ERROR)
+17 IF ERROR
Begin DoDot:1
+18 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"PREFERRED FACILITY "_SEG(8)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
End DoDot:1
QUIT
+19 ;
+20 SET DGENR("PRIORITY")=$$CONVERT^DGENUPL1(SEG(9))
+21 SET DGENR("EFFDATE")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
+22 IF ERROR
Begin DoDot:1
+23 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 10",.ERRCOUNT)
End DoDot:1
QUIT
+24 SET DGOAPP=""
+25 SET DGENR("APP")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
+26 IF ERROR
Begin DoDot:1
+27 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 11",.ERRCOUNT)
End DoDot:1
QUIT
+28 ;DG*5.3*1027 - Capture Application Date tranmitted by ES for checking later
+29 SET DGOAPP=DGENR("APP")
+30 IF DGOAPP="@"
SET DGOAPP=""
+31 ;
+32 ;!!!!!! take next line out when HEC begins transmitting application dt
+33 IF DGENR("APP")=""!(DGENR("APP")="@")
SET DGENR("APP")=DGENR("DATE")
+34 IF DGENR("APP")=""!(DGENR("APP")="@")
SET DGENR("APP")=DGENR("EFFDATE")
+35 ;
+36 SET DGENR("END")=$$CONVERT^DGENUPL1(SEG(12),"DATE",.ERROR)
+37 IF ERROR
Begin DoDot:1
+38 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 12",.ERRCOUNT)
End DoDot:1
QUIT
+39 ;Phase II Parse out Sub-Group (SRS 6[B.4)
+40 SET DGENR("SUBGRP")=$$CONVERT^DGENUPL1(SEG(13))
+41 SET DGPAT("PFSRC")=$$CONVERT^DGENUPL1(SEG(14))
NEW PFSRC
SET PFSRC=DGPAT("PFSRC")
+42 IF PFSRC'="V"&(PFSRC'="E")&(PFSRC'="PA")&(PFSRC'="PI")&(PFSRC'="@")&(PFSRC'="")
DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 14",.ERRCOUNT)
QUIT
+43 ;
+44 ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
SET DGENR("RCODE")=$$CONVERT^DGENUPL1(SEG(15))
+45 ;KUM field added with DG*5.3*993
SET DGENR("PTAPPLIED")=$$CONVERT^DGENUPL1(SEG(16))
+46 ;KUM field added with DG*5.3*993
SET DGENR("REGREA")=$$CONVERT^DGENUPL1(SEG(17))
+47 SET DGENR("REGREA")=$$FIND1^DIC(408.43,"","X",$GET(DGENR("REGREA")),"C","","ERROR")
+48 IF DGENR("REGREA")=0
SET DGENR("REGREA")=""
+49 ;KUM field added with DG*5.3*993
SET DGENR("REGDATE")=$$CONVERT^DGENUPL1(SEG(18),"DATE",.ERROR)
+50 IF ERROR
Begin DoDot:1
+51 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 18",.ERRCOUNT)
End DoDot:1
QUIT
+52 ;KUM field added with DG*5.3*993
SET DGENR("REGSRC")=$$CONVERT^DGENUPL1(SEG(19))
+53 IF ((DGENR("REGSRC")'="")!(DGENR("REGSRC")'="@"))
Begin DoDot:1
+54 SET DGRES=0
+55 DO CHK^DIE(27.11,.17,"",DGENR("REGSRC"),.DGRES)
+56 IF +DGRES>0
SET DGENR("REGSRC")=DGRES
End DoDot:1
+57 ;DG*5.3*933
+58 ;Make Enrollment Application Date, Effective Date and Enrollment End Date as Registration date if it is blank for REGISTRAITON ONLY status
+59 IF $GET(DGENR("STATUS"))=25
Begin DoDot:1
+60 IF (($GET(DGENR("REGDATE"))="")!($GET(DGENR("REGDATE"))="@"))
DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"REGISTRATION DATE IS MISSING AND ENROLLMENT STATUS IS REGISTRAITON ONLY",.ERRCOUNT)
+61 IF (($GET(DGENR("APP"))="")!($GET(DGENR("APP"))="@"))
SET DGENR("APP")=DGENR("REGDATE")
+62 IF (($GET(DGENR("EFFDATE"))="")!($GET(DGENR("EFFDATE"))="@"))
SET DGENR("EFFDATE")=DGENR("REGDATE")
+63 IF (($GET(DGENR("SOURCE"))="")!($GET(DGENR("SOURCE"))="@"))
SET DGENR("SOURCE")=2
End DoDot:1
+64 ;want to ignore double quotes sent for enrollment fields
+65 SET SUB=""
+66 FOR
SET SUB=$ORDER(DGENR(SUB))
if SUB=""
QUIT
IF DGENR(SUB)="@"!(DGENR(SUB)="""""")
SET DGENR(SUB)=""
+67 ;
+68 QUIT
+69 ;
ZMT ;
+1 IF SEG(1)>1
DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"ZMT SEGMENT, SEQ 1, SHOULD SPECIFY MEANS TEST",.ERRCOUNT)
SET ERROR=1
QUIT
+2 SET DGELG("MTSTA")=$$CONVERT^DGENUPL1(SEG(3),"MT",.ERROR)
+3 IF ERROR
Begin DoDot:1
+4 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZMT SEGMENT, SEQ 3",.ERRCOUNT)
End DoDot:1
QUIT
+5 QUIT
+6 ;
ZCD ;
+1 ;Phase II for multiple ZCD's
+2 IF SEG(1)>1
GOTO SKIP
+3 SET DGCDIS("BY")=$$CONVERT^DGENUPL1(SEG(3))
+4 SET DGCDIS("DATE")=$$CONVERT^DGENUPL1(SEG(5),"DATE",.ERROR)
+5 IF ERROR
Begin DoDot:1
+6 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 5",.ERRCOUNT)
End DoDot:1
QUIT
+7 SET DGCDIS("FACDET")=$$CONVERT^DGENUPL1(SEG(4),"INSTITUTION",.ERROR)
+8 IF ERROR
Begin DoDot:1
+9 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"FACILITY "_SEG(4)_" MAKING CATASTROPHIC DISABILITY DETERMINATION NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
End DoDot:1
QUIT
+10 SET DGCDIS("REVDTE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
+11 IF ERROR
Begin DoDot:1
+12 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 2",.ERRCOUNT)
End DoDot:1
QUIT
+13 SET DGCDIS("METDET")=$$CONVERT^DGENUPL1($PIECE(SEG(6),$EXTRACT(HLECH)))
+14 SET DGCDIS("VCD")=$$CONVERT^DGENUPL1(SEG(12))
+15 ;SEQ 14 - DATE VETERAN REQUESTED CD EVALUATION
+16 SET DGCDIS("VETREQDT")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
+17 IF ERROR
Begin DoDot:1
+18 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 14",.ERRCOUNT)
End DoDot:1
QUIT
+19 ;SEQ 15 - DATE FACILITY INITIATED REVIEW
+20 SET DGCDIS("DTFACIRV")=$$CONVERT^DGENUPL1(SEG(15),"DATE",.ERROR)
+21 IF ERROR
Begin DoDot:1
+22 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 15",.ERRCOUNT)
End DoDot:1
QUIT
+23 ;SEQ 16 - DATE VETERAN WAS NOTIFIED
+24 SET DGCDIS("DTVETNOT")=$$CONVERT^DGENUPL1(SEG(16),"DATE",.ERROR)
+25 IF ERROR
Begin DoDot:1
+26 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 16",.ERRCOUNT)
End DoDot:1
QUIT
SKIP ;
+1 ;Phase II Parse out additional fields. CONVERT type of RSN converts the code to IEN for diagnosis,procedure and condition (HL7TORSN^DGENA5).
+2 ; * check the new DESCRIPTOR sequences - DG*5.3*894
+3 ; DG*5.3*894
NEW I,D3
+4 ; DG*5.3*894
SET D3="|"
+5 FOR I=1:1
if $PIECE(SEG(17),D3,I)=""
QUIT
Begin DoDot:1
+6 SET DGCDIS("DESCR",I)=$$CONVERT^DGENUPL1($PIECE(SEG(17),D3,I),"CDDSCR")
End DoDot:1
+7 ;
+8 IF '$DATA(DGCDIS("DESCR"))
Begin DoDot:1
+9 SET DGCDIS("DIAG",SEG(1))=$$CONVERT^DGENUPL1(SEG(7),"CDRSN")
+10 SET DGCDIS("PROC",SEG(1))=$$CONVERT^DGENUPL1(SEG(8),"CDRSN")
+11 SET DGCDIS("COND",SEG(1))=$$CONVERT^DGENUPL1(SEG(10),"CDRSN")
End DoDot:1
+12 ;
+13 SET DGCDIS("EXT",SEG(1),1)=$$CONVERT^DGENUPL1($PIECE(SEG(9),$EXTRACT(HLECH)),"EXT")
+14 SET DGCDIS("SCORE",SEG(1))=$$CONVERT^DGENUPL1($PIECE(SEG(11),$EXTRACT(HLECH)))
+15 SET DGCDIS("PERM",SEG(1))=$$CONVERT^DGENUPL1($PIECE(SEG(13),$EXTRACT(HLECH)))
+16 IF DGCDIS("VCD")="Y"
IF '$DATA(DGCDIS("DIAG"))
IF '$DATA(DGCDIS("PROC"))
IF '$DATA(DGCDIS("COND"))
IF '$DATA(DGCDIS("DESCR"))
Begin DoDot:1
+17 SET ERROR=1
DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"NO VALID DIAGNOSIS,PROCEDURE,CONDITION, OR DESCRIPTOR IN THE ZCD SEGMENT",.ERRCOUNT)
End DoDot:1
QUIT
+18 QUIT
+19 ;
ZSP ;
+1 SET DGELG("SC")=$$CONVERT^DGENUPL1(SEG(2),"Y/N",.ERROR)
+2 IF ERROR
Begin DoDot:1
+3 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 2",.ERRCOUNT)
End DoDot:1
QUIT
+4 SET DGELG("SCPER")=$$CONVERT^DGENUPL1(SEG(3))
+5 SET DGELG("POS")=$$CONVERT^DGENUPL1(SEG(4),"POS",.ERROR)
+6 IF ERROR
Begin DoDot:1
+7 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 4",.ERRCOUNT)
End DoDot:1
QUIT
+8 SET DGELG("EFFDT")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
+9 IF ERROR
Begin DoDot:1
+10 DO ADDERROR^DGENUPL(MSGID,$GET(DGELG("EFFDT")),"BAD VALUE, ZSP SEGMENT, SEQ 11",.ERRCOUNT)
End DoDot:1
QUIT
+11 ;if effective date is null, set update value to "@" (delete)
+12 IF DGELG("EFFDT")=""
SET DGELG("EFFDT")="@"
+13 ;
+14 ;added 8/3/98 to reduce #rejects
+15 ;if HEC sends SC=NO, SC% not sent, and site has value for SC% then delete it
+16 IF DGELG("SC")="N"
IF DGELG("SCPER")=""
SET DGELG("SCPER")="@"
+17 ;
+18 SET DGELG("P&T")=$$CONVERT^DGENUPL1(SEG(6),"Y/N",.ERROR)
+19 IF ERROR
Begin DoDot:1
+20 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 6",.ERRCOUNT)
End DoDot:1
QUIT
+21 SET DGELG("UNEMPLOY")=$$CONVERT^DGENUPL1(SEG(7),"Y/N",.ERROR)
+22 IF ERROR
Begin DoDot:1
+23 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 7",.ERRCOUNT)
End DoDot:1
QUIT
+24 SET DGELG("SCAWDATE")=$$CONVERT^DGENUPL1(SEG(8),"DATE",.ERROR)
+25 IF ERROR
Begin DoDot:1
+26 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 8",.ERRCOUNT)
End DoDot:1
QUIT
+27 SET DGELG("P&TDT")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
+28 IF ERROR
Begin DoDot:1
+29 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 10 - P&T EFFECTIVE DATE",.ERRCOUNT)
End DoDot:1
+30 SET DGPAT("DENTC2IN")=$$CONVERT^DGENUPL1(SEG(12),"Y/N",.ERROR)
+31 IF ERROR
Begin DoDot:1
+32 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 12",.ERRCOUNT)
End DoDot:1
QUIT
+33 SET DGPAT("DENTC2DT")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
+34 IF ERROR
Begin DoDot:1
+35 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 13",.ERRCOUNT)
End DoDot:1
QUIT
+36 QUIT
+37 ;
ZMH ;Purple Heart, OEFOIE, POW
+1 ;Moved to DGENUPL3 - DG*5.3*653
DO ZMH^DGENUPL3
+2 QUIT
+3 ;
ZRD ;
+1 NEW COUNT,DXCODE,NAME,COND
+2 SET DXCODE=$PIECE(SEG(2),$EXTRACT(HLECH))
+3 IF DXCODE=""""""
SET DXCODE=""
+4 SET NAME=$PIECE(SEG(2),$EXTRACT(HLECH),2)
+5 ;segment does not contain a disability condition
if DXCODE=""
QUIT
+6 ;
+7 SET COUNT=1+(+$GET(DGELG("RATEDIS")))
+8 SET (COND,DGELG("RATEDIS",COUNT,"RD"))=$$DCLOOKUP(DXCODE,NAME)
+9 SET DGELG("RATEDIS",COUNT,"PER")=$$CONVERT^DGENUPL1(SEG(3))
SET DGELG("RATEDIS")=COUNT
+10 SET DGELG("RATEDIS",COUNT,"RDEXT")=$$CONVERT^DGENUPL1(SEG(12))
+11 SET DGELG("RATEDIS",COUNT,"RDORIG")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
+12 IF ERROR
Begin DoDot:1
+13 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 13",.ERRCOUNT)
End DoDot:1
QUIT
+14 SET DGELG("RATEDIS",COUNT,"RDCURR")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
+15 IF ERROR
Begin DoDot:1
+16 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 14",.ERRCOUNT)
End DoDot:1
QUIT
+17 IF 'COND
Begin DoDot:1
+18 DO ADDERROR^DGENUPL(MSGID,$GET(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, SEQ 2 - DISABILTY CONDITION LOOKUP FAILED",.ERRCOUNT)
+19 SET ERROR=1
End DoDot:1
QUIT
+20 QUIT
OBX ;
+1 ;code for OBX segment moved to DGENUPLA
DO OBX^DGENUPLA
+2 QUIT
+3 ;
+4 ;*********** end of segment parsers ****
+5 ;
DCLOOKUP(DGCODE,DGNAME) ;
+1 ; Description: Returns the ien of a Disability Condition (file #31) based on the DGCODE and DGNAME
+2 ;
+3 ;Input:
+4 ; DGCODE - DX Code of the Disability Condition
+5 ; DGNAME - name of the Disability Condition
+6 ;Output:
+7 ; Function Value: ien of the entry found, or 0 otherwise
+8 ;
+9 if (DGCODE="")
QUIT 0
+10 NEW NODE,IEN,FOUND
+11 SET (FOUND,IEN)=0
+12 FOR
SET IEN=$ORDER(^DIC(31,"C",DGCODE,IEN))
if 'IEN
QUIT
Begin DoDot:1
+13 SET NODE=$GET(^DIC(31,IEN,0))
+14 IF DGNAME=$PIECE(NODE,"^")
IF DGCODE=$PIECE(NODE,"^",3)
SET FOUND=1
End DoDot:1
if FOUND
QUIT
+15 IF 'FOUND
SET IEN=$ORDER(^DIC(31,"C",DGCODE,0))
+16 QUIT +IEN
+17 ;
REGCHECK(DFN) ;
+1 ; Description: passes patient through the registration consistency checker
+2 ;Input -
+3 ; DFN - is a pointer to the Patient File
+4 ;
+5 NEW DGCD,DGCHK,DGDAY,DGEDCN,DGER,DGLST,DGNCK,DGRPCOLD,DGSC,DGTYPE,DGVT,VA,X
+6 ;
+7 SET DGEDCN=0
+8 DO ^DGRPC
+9 QUIT
PEND(DFN,DGSTAT) ;
+1 NEW DGARR,DGEC,DGERR,DGX
+2 IF $PIECE($GET(^DPT(DFN,.361)),U)'="V"
QUIT 0
+3 IF $GET(DGSTAT)="@"
QUIT 0
+4 IF $GET(DGSTAT)']""
QUIT 0
+5 SET DGSTAT="^"_DGSTAT_"^"
+6 if "^15^17^"'[DGSTAT
QUIT 0
+7 DO GETS^DIQ(2,DFN_",",".301;.302;.361;.36295","IE","DGARR","DGERR")
+8 IF $DATA(DGERR)
QUIT 0
+9 SET DGEC=$GET(DGARR(2,DFN_",",.361,"I"))
+10 IF $GET(DGEC)']""
QUIT 0
+11 SET DGEC=$PIECE($GET(^DIC(8,DGEC,0)),U,9)
+12 IF $GET(DGEC)']""
QUIT 0
+13 IF DGEC=5
QUIT 1
+14 IF DGEC=3
Begin DoDot:1
+15 SET DGX=1
+16 IF $GET(DGARR(2,DFN_",",.301,"I"))'="Y"
SET DGX=0
QUIT
+17 IF +$GET(DGARR(2,DFN_",",.302,"I"))>0
SET DGX=0
QUIT
+18 IF +$GET(DGARR(2,DFN_",",.36295,"I"))>0
SET DGX=0
QUIT
End DoDot:1
QUIT DGX
+19 QUIT 0
