Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGENUPL2

DGENUPL2.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;**************************************************************
  1. ;The following procedures parse particular segment types.
  1. ;Input:SEG(),MSGID
  1. ;Output:DGPAT(),DGELG(),DGENR(),DGCDIS(),DGNTR(),DGOEIF(),ERROR
  1. ;**************************************************************
  1. ;
  1. PID ;
  1. S DGPAT("SSN")=SEG(19)
  1. Q
  1. ;
  1. ZPD ;
  1. D ZPD^DGENUPLA ;code removed due to size of DGENUPLA - DG*5.3*688
  1. Q
  1. ;
  1. ZIE ;
  1. S DGPAT("INELDATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIE SEGMENT, SEQ 2",.ERRCOUNT)
  1. S DGPAT("INELREA")=$$CONVERT^DGENUPL1(SEG(3))
  1. S DGPAT("INELDEC")=$$CONVERT^DGENUPL1(SEG(4))
  1. Q
  1. ;
  1. ZIO ;New segment - DG*5.3*653
  1. D ZIO^DGENUPLA ;Code for ZIO has moved to DGENUPLA
  1. Q
  1. ;
  1. ZEL(COUNT) ;
  1. D ZEL^DGENUPLA(COUNT) ;code for ZEL segment has moved to DGENUPLA
  1. Q
  1. ;
  1. ZEN ;
  1. N SUB,DGRES
  1. S DGENR("DATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 2",.ERRCOUNT)
  1. S DGENR("SOURCE")=$$CONVERT^DGENUPL1(SEG(3))
  1. S DGENR("STATUS")=$$CONVERT^DGENUPL1(SEG(4))
  1. ;S ERROR=$$PEND(DFN,DGENR("STATUS")) ;DG*5.3*934
  1. S ERROR=0 ;DG*5.3*934
  1. ;I ERROR D Q ;DG*5.3*934
  1. ;.D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ENROLLMENT STATUS PENDING-ELIGIBILITY IS VERIFIED",.ERRCOUNT)
  1. S DGENR("REASON")=$$CONVERT^DGENUPL1(SEG(5))
  1. S DGENR("REMARKS")=$$CONVERT^DGENUPL1(SEG(6))
  1. S DGENR("FACREC")=$$CONVERT^DGENUPL1(SEG(7),"INSTITUTION",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY RECEIVED "_SEG(7)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
  1. S DGPAT("PREFAC")=$$CONVERT^DGENUPL1(SEG(8),"INSTITUTION",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"PREFERRED FACILITY "_SEG(8)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
  1. ;
  1. S DGENR("PRIORITY")=$$CONVERT^DGENUPL1(SEG(9))
  1. S DGENR("EFFDATE")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 10",.ERRCOUNT)
  1. S DGOAPP=""
  1. S DGENR("APP")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 11",.ERRCOUNT)
  1. ;DG*5.3*1027 - Capture Application Date tranmitted by ES for checking later
  1. S DGOAPP=DGENR("APP")
  1. I DGOAPP="@" S DGOAPP=""
  1. ;
  1. ;!!!!!! take next line out when HEC begins transmitting application dt
  1. I DGENR("APP")=""!(DGENR("APP")="@") S DGENR("APP")=DGENR("DATE")
  1. I DGENR("APP")=""!(DGENR("APP")="@") S DGENR("APP")=DGENR("EFFDATE")
  1. ;
  1. S DGENR("END")=$$CONVERT^DGENUPL1(SEG(12),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 12",.ERRCOUNT)
  1. ;Phase II Parse out Sub-Group (SRS 6[B.4)
  1. S DGENR("SUBGRP")=$$CONVERT^DGENUPL1(SEG(13))
  1. S DGPAT("PFSRC")=$$CONVERT^DGENUPL1(SEG(14)) N PFSRC S PFSRC=DGPAT("PFSRC")
  1. 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
  1. ;
  1. S DGENR("RCODE")=$$CONVERT^DGENUPL1(SEG(15)) ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
  1. S DGENR("PTAPPLIED")=$$CONVERT^DGENUPL1(SEG(16)) ;KUM field added with DG*5.3*993
  1. S DGENR("REGREA")=$$CONVERT^DGENUPL1(SEG(17)) ;KUM field added with DG*5.3*993
  1. S DGENR("REGREA")=$$FIND1^DIC(408.43,"","X",$G(DGENR("REGREA")),"C","","ERROR")
  1. I DGENR("REGREA")=0 S DGENR("REGREA")=""
  1. S DGENR("REGDATE")=$$CONVERT^DGENUPL1(SEG(18),"DATE",.ERROR) ;KUM field added with DG*5.3*993
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 18",.ERRCOUNT)
  1. S DGENR("REGSRC")=$$CONVERT^DGENUPL1(SEG(19)) ;KUM field added with DG*5.3*993
  1. I ((DGENR("REGSRC")'="")!(DGENR("REGSRC")'="@")) D
  1. . S DGRES=0
  1. . D CHK^DIE(27.11,.17,"",DGENR("REGSRC"),.DGRES)
  1. . I +DGRES>0 S DGENR("REGSRC")=DGRES
  1. ;DG*5.3*933
  1. ;Make Enrollment Application Date, Effective Date and Enrollment End Date as Registration date if it is blank for REGISTRAITON ONLY status
  1. I $G(DGENR("STATUS"))=25 D
  1. .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)
  1. .I (($G(DGENR("APP"))="")!($G(DGENR("APP"))="@")) S DGENR("APP")=DGENR("REGDATE")
  1. .I (($G(DGENR("EFFDATE"))="")!($G(DGENR("EFFDATE"))="@")) S DGENR("EFFDATE")=DGENR("REGDATE")
  1. .I (($G(DGENR("SOURCE"))="")!($G(DGENR("SOURCE"))="@")) S DGENR("SOURCE")=2
  1. ;want to ignore double quotes sent for enrollment fields
  1. S SUB=""
  1. F S SUB=$O(DGENR(SUB)) Q:SUB="" I DGENR(SUB)="@"!(DGENR(SUB)="""""") S DGENR(SUB)=""
  1. ;
  1. Q
  1. ;
  1. ZMT ;
  1. I SEG(1)>1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ZMT SEGMENT, SEQ 1, SHOULD SPECIFY MEANS TEST",.ERRCOUNT) S ERROR=1 Q
  1. S DGELG("MTSTA")=$$CONVERT^DGENUPL1(SEG(3),"MT",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMT SEGMENT, SEQ 3",.ERRCOUNT)
  1. Q
  1. ;
  1. ZCD ;
  1. ;Phase II for multiple ZCD's
  1. I SEG(1)>1 G SKIP
  1. S DGCDIS("BY")=$$CONVERT^DGENUPL1(SEG(3))
  1. S DGCDIS("DATE")=$$CONVERT^DGENUPL1(SEG(5),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 5",.ERRCOUNT)
  1. S DGCDIS("FACDET")=$$CONVERT^DGENUPL1(SEG(4),"INSTITUTION",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY "_SEG(4)_" MAKING CATASTROPHIC DISABILITY DETERMINATION NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
  1. S DGCDIS("REVDTE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 2",.ERRCOUNT)
  1. S DGCDIS("METDET")=$$CONVERT^DGENUPL1($P(SEG(6),$E(HLECH)))
  1. S DGCDIS("VCD")=$$CONVERT^DGENUPL1(SEG(12))
  1. ;SEQ 14 - DATE VETERAN REQUESTED CD EVALUATION
  1. S DGCDIS("VETREQDT")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 14",.ERRCOUNT)
  1. ;SEQ 15 - DATE FACILITY INITIATED REVIEW
  1. S DGCDIS("DTFACIRV")=$$CONVERT^DGENUPL1(SEG(15),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 15",.ERRCOUNT)
  1. ;SEQ 16 - DATE VETERAN WAS NOTIFIED
  1. S DGCDIS("DTVETNOT")=$$CONVERT^DGENUPL1(SEG(16),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 16",.ERRCOUNT)
  1. SKIP ;
  1. ;Phase II Parse out additional fields. CONVERT type of RSN converts the code to IEN for diagnosis,procedure and condition (HL7TORSN^DGENA5).
  1. ; * check the new DESCRIPTOR sequences - DG*5.3*894
  1. N I,D3 ; DG*5.3*894
  1. S D3="|" ; DG*5.3*894
  1. F I=1:1 Q:$P(SEG(17),D3,I)="" D
  1. . S DGCDIS("DESCR",I)=$$CONVERT^DGENUPL1($P(SEG(17),D3,I),"CDDSCR")
  1. ;
  1. I '$D(DGCDIS("DESCR")) D
  1. .S DGCDIS("DIAG",SEG(1))=$$CONVERT^DGENUPL1(SEG(7),"CDRSN")
  1. .S DGCDIS("PROC",SEG(1))=$$CONVERT^DGENUPL1(SEG(8),"CDRSN")
  1. .S DGCDIS("COND",SEG(1))=$$CONVERT^DGENUPL1(SEG(10),"CDRSN")
  1. ;
  1. S DGCDIS("EXT",SEG(1),1)=$$CONVERT^DGENUPL1($P(SEG(9),$E(HLECH)),"EXT")
  1. S DGCDIS("SCORE",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(11),$E(HLECH)))
  1. S DGCDIS("PERM",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(13),$E(HLECH)))
  1. I DGCDIS("VCD")="Y",'$D(DGCDIS("DIAG")),'$D(DGCDIS("PROC")),'$D(DGCDIS("COND")),'$D(DGCDIS("DESCR")) D Q
  1. .S ERROR=1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"NO VALID DIAGNOSIS,PROCEDURE,CONDITION, OR DESCRIPTOR IN THE ZCD SEGMENT",.ERRCOUNT)
  1. Q
  1. ;
  1. ZSP ;
  1. S DGELG("SC")=$$CONVERT^DGENUPL1(SEG(2),"Y/N",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 2",.ERRCOUNT)
  1. S DGELG("SCPER")=$$CONVERT^DGENUPL1(SEG(3))
  1. S DGELG("POS")=$$CONVERT^DGENUPL1(SEG(4),"POS",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 4",.ERRCOUNT)
  1. S DGELG("EFFDT")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
  1. I ERROR D Q
  1. . D ADDERROR^DGENUPL(MSGID,$G(DGELG("EFFDT")),"BAD VALUE, ZSP SEGMENT, SEQ 11",.ERRCOUNT)
  1. ;if effective date is null, set update value to "@" (delete)
  1. I DGELG("EFFDT")="" S DGELG("EFFDT")="@"
  1. ;
  1. ;added 8/3/98 to reduce #rejects
  1. ;if HEC sends SC=NO, SC% not sent, and site has value for SC% then delete it
  1. I DGELG("SC")="N",DGELG("SCPER")="" S DGELG("SCPER")="@"
  1. ;
  1. S DGELG("P&T")=$$CONVERT^DGENUPL1(SEG(6),"Y/N",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 6",.ERRCOUNT)
  1. S DGELG("UNEMPLOY")=$$CONVERT^DGENUPL1(SEG(7),"Y/N",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 7",.ERRCOUNT)
  1. S DGELG("SCAWDATE")=$$CONVERT^DGENUPL1(SEG(8),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 8",.ERRCOUNT)
  1. S DGELG("P&TDT")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
  1. I ERROR D
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 10 - P&T EFFECTIVE DATE",.ERRCOUNT)
  1. S DGPAT("DENTC2IN")=$$CONVERT^DGENUPL1(SEG(12),"Y/N",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 12",.ERRCOUNT)
  1. S DGPAT("DENTC2DT")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
  1. I ERROR D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 13",.ERRCOUNT)
  1. Q
  1. ;
  1. ZMH ;Purple Heart, OEFOIE, POW
  1. D ZMH^DGENUPL3 ;Moved to DGENUPL3 - DG*5.3*653
  1. Q
  1. ;
  1. ZRD ;
  1. N COUNT,DXCODE,NAME,COND
  1. S DXCODE=$P(SEG(2),$E(HLECH))
  1. I DXCODE="""""" S DXCODE=""
  1. S NAME=$P(SEG(2),$E(HLECH),2)
  1. Q:DXCODE="" ;segment does not contain a disability condition
  1. ;
  1. S COUNT=1+(+$G(DGELG("RATEDIS")))
  1. S (COND,DGELG("RATEDIS",COUNT,"RD"))=$$DCLOOKUP(DXCODE,NAME)
  1. S DGELG("RATEDIS",COUNT,"PER")=$$CONVERT^DGENUPL1(SEG(3)),DGELG("RATEDIS")=COUNT
  1. S DGELG("RATEDIS",COUNT,"RDEXT")=$$CONVERT^DGENUPL1(SEG(12))
  1. S DGELG("RATEDIS",COUNT,"RDORIG")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
  1. I ERROR D Q
  1. . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 13",.ERRCOUNT)
  1. S DGELG("RATEDIS",COUNT,"RDCURR")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
  1. I ERROR D Q
  1. . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 14",.ERRCOUNT)
  1. I 'COND D Q
  1. .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, SEQ 2 - DISABILTY CONDITION LOOKUP FAILED",.ERRCOUNT)
  1. .S ERROR=1
  1. Q
  1. OBX ;
  1. D OBX^DGENUPLA ;code for OBX segment moved to DGENUPLA
  1. Q
  1. ;
  1. ;*********** end of segment parsers ****
  1. ;
  1. DCLOOKUP(DGCODE,DGNAME) ;
  1. ; Description: Returns the ien of a Disability Condition (file #31) based on the DGCODE and DGNAME
  1. ;
  1. ;Input:
  1. ; DGCODE - DX Code of the Disability Condition
  1. ; DGNAME - name of the Disability Condition
  1. ;Output:
  1. ; Function Value: ien of the entry found, or 0 otherwise
  1. ;
  1. Q:(DGCODE="") 0
  1. N NODE,IEN,FOUND
  1. S (FOUND,IEN)=0
  1. F S IEN=$O(^DIC(31,"C",DGCODE,IEN)) Q:'IEN D Q:FOUND
  1. .S NODE=$G(^DIC(31,IEN,0))
  1. .I DGNAME=$P(NODE,"^"),DGCODE=$P(NODE,"^",3) S FOUND=1
  1. I 'FOUND S IEN=$O(^DIC(31,"C",DGCODE,0))
  1. Q +IEN
  1. ;
  1. REGCHECK(DFN) ;
  1. ; Description: passes patient through the registration consistency checker
  1. ;Input -
  1. ; DFN - is a pointer to the Patient File
  1. ;
  1. N DGCD,DGCHK,DGDAY,DGEDCN,DGER,DGLST,DGNCK,DGRPCOLD,DGSC,DGTYPE,DGVT,VA,X
  1. ;
  1. S DGEDCN=0
  1. D ^DGRPC
  1. Q
  1. PEND(DFN,DGSTAT) ;
  1. N DGARR,DGEC,DGERR,DGX
  1. I $P($G(^DPT(DFN,.361)),U)'="V" Q 0
  1. I $G(DGSTAT)="@" Q 0
  1. I $G(DGSTAT)']"" Q 0
  1. S DGSTAT="^"_DGSTAT_"^"
  1. Q:"^15^17^"'[DGSTAT 0
  1. D GETS^DIQ(2,DFN_",",".301;.302;.361;.36295","IE","DGARR","DGERR")
  1. I $D(DGERR) Q 0
  1. S DGEC=$G(DGARR(2,DFN_",",.361,"I"))
  1. I $G(DGEC)']"" Q 0
  1. S DGEC=$P($G(^DIC(8,DGEC,0)),U,9)
  1. I $G(DGEC)']"" Q 0
  1. I DGEC=5 Q 1
  1. I DGEC=3 D Q DGX
  1. . S DGX=1
  1. . I $G(DGARR(2,DFN_",",.301,"I"))'="Y" S DGX=0 Q
  1. . I +$G(DGARR(2,DFN_",",.302,"I"))>0 S DGX=0 Q
  1. . I +$G(DGARR(2,DFN_",",.36295,"I"))>0 S DGX=0 Q
  1. Q 0