IVMCMC ;ALB/SEK,BRM,GN,TDM,JAM,HM - CHECK INCOME TEST TRANSMISSION SEGMENTS;1/6/20 8:25am
;;2.0;INCOME VERIFICATION MATCH;**17,34,49,51,90,115,174,190**;21-OCT-94;Build 47
;
;IVM*2*90 - stop upload of LTC type 4 test when staus code not valid
;
EN ; Check segment structure of Income Test (Z10) transmission.
; Variable input:
; IVMDA -- pointer to an incoming message line in file #772
; IVMORF -- [optional]: set to 1 if Z10 is an ORF message
; IVMSEG -- the MSH segment string
;
; plus the usual HL7 variables: HLDA, HLFS, HLQ, HLECH
;
; Variable output:
; DFN -- pointer to the patient in file #2
; DGLY -- Income Year
; IVMFLGC -- Number of Dependent Children
; IVMMCI -- HL7 message control id of query sent to IVM Center
;
; and the global array ^TMP($J,"IVMCM" which holds the message.
;
N ERRMSG,DOBP,SEXP,X,Y,ZDPIFLG,TMPARY,PID3ARY,ICN
;
; - message control id from MSH segment
S MSGID=$P(IVMSEG,HLFS,10)
;
; - if query response (ORF), do additional edit checks
I $G(IVMORF) D ADDL I $D(HLERR) G ENQ
;
; - check the PID segment and get a match on patient
D GET("PIDV") I IVMSEG1'="PID" D PROB("Missing PID segment") G ENQ
;S DOBP=$P(IVMSEG,HLFS,8),SEXP=$P(IVMSEG,HLFS,9)
S DOBP=$G(^TMP($J,"IVMCM","PIDV",7)),SEXP=$G(^TMP($J,"IVMCM","PIDV",8))
;S SSNP=$G(^TMP($J,"IVMCM","PIDV",19))
I SEXP'="F"&(SEXP'="M") D PROB("Incorrect value for Sex") G ENQ
S X=$$FMDATE^HLFNC(DOBP),%DT=X D ^%DT I Y<0 D PROB("Invalid Date of Birth") G ENQ
;S DFN=$$LOOKUP^IVMUFNC(SSNP,Y,SEXP,.ERRMSG)
;I 'DFN D PROB(ERRMSG) G ENQ
M TMPARY(3)=^TMP($J,"IVMCM","PIDV",3) D PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) D PROB(ERRMSG) G ENQ
K TMPARY,PID3ARY
;
; - check for veteran's ZIC and ZIR segments
D GET("ZICV") I IVMSEG1'="ZIC" D PROB("Missing veteran's ZIC segment") G ENQ
S DGLY=$$FMDATE^HLFNC($P(IVMSEG,"^",3)) ; income year
I 'DGLY D PROB("Missing veteran's Income Year") G ENQ
D GET("ZIRV") I IVMSEG1'="ZIR" D PROB("Missing veteran's ZIR segment") G ENQ
;
; - check for spouse's ZDP, ZIC, ZIR segments
D GET("ZDPS") I IVMSEG1'="ZDP" D PROB("Missing spouse's ZDP segment") G ENQ
D GET("ZICS") I IVMSEG1'="ZIC" D PROB("Missing spouse's ZIC segment") G ENQ
D GET("ZIRS") I IVMSEG1'="ZIR" D PROB("Missing spouse's ZIR segment") G ENQ
I $E($G(^TMP($J,IVMRTN,IVMDA+1,0)),1,3)="NTE" D GET("NTE") ;NTE segment is optional IVM*2.0*190
;
; - check for dependent children's ZDP, ZIC, ZIR segments and ZMT segment
S (IVMFLGC,ZDPIFLG)=0
F IVMNBR=1:1 D I $D(HLERR)!(IVMSEG1="ZMT") Q
.D GET("ZDPC",IVMNBR) I IVMSEG1'="ZDP",IVMSEG1'="ZMT" D PROB("Missing child's ZDP segment or ZMT segment") Q
.I IVMSEG1="ZMT" Q
.I $P(IVMSEG,"^",2)=""!($P(IVMSEG,"^",3)="")!($P(IVMSEG,"^",4)="") D PROB("Missing child data from ZDP segment") Q
.Q:ZDPIFLG ;No ZIC,ZIR segs or # of children for inactive dependents
.D GET("ZICC",IVMNBR) I IVMSEG1'="ZIC" D PROB("Missing child's ZIC segment") Q
.D GET("ZIRC",IVMNBR) I IVMSEG1'="ZIR" D PROB("Missing child's ZIR segment") Q
.S IVMFLGC=IVMFLGC+1 ; # of children
;
I $D(HLERR) G ENQ
;
; Patch IVM*2.0*174 - jam - For ORU-Z10, process SSN for IENs in ^XTMP("DG53970P")
; -----------------
; Do this for ORU message only
; The caller routine ^EASCM sets IVMSSNFLAG=0, quit if this var gets set to 1
I $G(IVMORF)'=1 D I $G(IVMSSNFLAG)=1 G ENQ
. ; Check if there is a job number in ^XTMP("DG53970P")
. N IVMJOB
. S IVMJOB=0
. S IVMJOB=$O(^XTMP("DG53970P",IVMJOB))
. I 'IVMJOB Q
. ; If this DFN is in the ^XTMP global, process the SSNs in the ZDP, and set IVMSSNFLAG=1 to have caller quit further processing
. I $D(^XTMP("DG53970P",IVMJOB,"DFN",DFN)) D IVMFSSN^IVM2174F(DFN,IVMJOB) S IVMSSNFLAG=1
; ------------------
; - check for remaining ZMT and ZBT segments
D GET("ZMT2") I IVMSEG1'="ZMT" D PROB("Missing Copay Test ZMT segment") G ENQ
;
; ** added ZMT4 lines for LTC phase II (IVM*2*49)
; uncomment after all sites have installed to enable consistency chk
D GET("ZMT4") I IVMSEG1'="ZMT" D PROB("Missing LTC Test ZMT segment") G ENQ
;
; remove next line after all sites have installed
;D GET("ZMT4") I IVMSEG1'="ZMT" K ^TMP($J,"IVMCM","ZMT4") S IVMDA=IVMDA-1
;
D GET("ZBT") I IVMSEG1'="ZBT" D PROB("Missing Beneficiary Travel ZBT segment") G ENQ
;
ENQ I IVMSEG1="MSH" S IVMDA=IVMDA-1,HLERR="",IVMTYPE=5
K IVMSEG1,IVMNBR
Q
;
;
GET(SEG,NUM) ; Get the next HL7 segment.
; Formal input:
; SEG -- String with which to build ^TMP($J,"IVMCM"
; NUM -- Number to index child dependent strings [optional]
; Required variable input:
; HLDA -- Pointer to the incoming message in file #772
; IVMDA -- Pointer to the next message line within file #772
N NEXTSEG,NOPID,PIDCNTR,PIDSTR,SEQ
S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA)),IVMSEG=$G(^(+IVMDA,0))
S NEXTSEG=$E($G(^TMP($J,IVMRTN,IVMDA+1,0)),1,3)
S IVMSEG1=$E(IVMSEG,1,3)
I $G(SEG)="" G GETQ
I IVMSEG1="ZIR" S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,15) ;Strip ""
I IVMSEG1="ZDP" S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS) ;Strip ""
I $G(NUM),IVMSEG1'="ZMT" D G GETQ
.I IVMSEG1="ZDP",$P(IVMSEG,HLFS,12)="",NEXTSEG'="ZIC" D PROB("Missing Child ZIC segment OR Inactive ZDP missing Inactivation Date") Q
.I IVMSEG1="ZDP",$P(IVMSEG,HLFS,12)'="" D
..I NEXTSEG="ZIC" D PROB("ZIC segment following Inactive ZDP segment") Q
..S ZDPIFLG=1
..S SEG=$S($P(IVMSEG,HLFS,7)=2:"ZDPIS",1:"ZDPIC")
..S NUM=$O(^TMP($J,"IVMCM",SEG,""),-1)+1
.Q:$D(HLERR)
.S ^TMP($J,"IVMCM",SEG,NUM)=$P(IVMSEG,HLFS,2,99)
I IVMSEG1="ZMT",$E(SEG,1,3)'="ZMT" S SEG="ZMT1"
;
;IVM*2*90 don't allow upload of LTC with a date & a bad status code
I SEG="ZMT4",$P(IVMSEG,HLFS,3),$P(IVMSEG,HLFS,4)'=0,$P(IVMSEG,HLFS,4)'=1,$P(IVMSEG,HLFS,4)'="""""" Q
;
I IVMSEG1="PID" D Q
.K ^TMP($J,"IVMCM",SEG)
.S (NOPID,PIDCNTR)=1
.S PIDSTR(PIDCNTR)=$P(IVMSEG,HLFS,2,99)
.F I=1:1 D Q:NOPID
..I $E($G(^TMP($J,IVMRTN,IVMDA+1,0)),1,4)="ZIC^" S NOPID=1 Q
..S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA))
..S IVMSEG=$G(^TMP($J,IVMRTN,+IVMDA,0))
..S PIDCNTR=PIDCNTR+1,PIDSTR(PIDCNTR)=IVMSEG
.D BLDPID^IVMPREC6(.PIDSTR,.IVMPID)
.M ^TMP($J,"IVMCM","PIDV")=IVMPID
;
;IVM*2.0*190
I IVMSEG1="NTE" D Q
.N NONTE
.S NONTE=0
.K ^TMP($J,"IVMCM",SEG)
.F I=1:1 D Q:NONTE
..S IVMSEG=$G(^TMP($J,IVMRTN,IVMDA,0))
..I $P(IVMSEG,HLFS)'="NTE" S NONTE=1,IVMDA=IVMDA-1 Q
..S ^TMP($J,"IVMCM",SEG,I)=$P(IVMSEG,HLFS,4),IVMDA=IVMDA+1
S ^TMP($J,"IVMCM",SEG)=$P(IVMSEG,HLFS,2,99)
GETQ Q
;
PROB(ERR) ; Process encountered errors.
; Input: ERR -- Error text
S HLERR=ERR
D ACK^IVMPREC
Q
;
ADDL ; Perform additional segment checks for ORF messages.
;
N DOB,ERRMSG,IVMMSA,IVMPAT,IVMQRD,IVMQRF,QARRAY,QRYIEN,SEX,SSN
;
; edit checks for MSA, QRD, and QRF segments
D GET("") I IVMSEG1'="MSA" D PROB("Missing required MSA segment") G ADDLQ
S IVMMCI=$P(IVMSEG,"^",3) ; msg control id of msg being acknowledged
S IVMMSA=IVMSEG
; trace reply back to the original query msg
S QRYIEN=$$FINDMSG^IVMCQ2(IVMMCI)
I 'QRYIEN D PROB("Query not found") G ADDLQ
I QRYIEN,'$$GET^IVMCQ2(QRYIEN,.QARRAY) D PROB("Query not found") G ADDLQ
S DFN=QARRAY("DFN")
;
D GET("") I IVMSEG1'="QRD" D PROB("Missing required QRD segment") G ADDLQ
S IVMQRD=IVMSEG
S SSN=$P(IVMQRD,HLFS,9)
;
D GET("") I IVMSEG1'="QRF" D PROB("Missing required QRF segment") G ADDLQ
S IVMQRF=IVMSEG
S DOB=$$FMDATE^HLFNC($P(IVMQRF,HLFS,5))
S SEX=$P(IVMQRF,HLFS,6)
;
;
; if application reject rec'd from HEC (i.e. No income data on file)
I $P(IVMMSA,HLFS,2)="AR" D
.S HLERR=""
.S IVMTYPE=7 ;type 4 is now used for LTC test (IVM*2*49)
.; - if patient identifiers rec'd from HEC incorrect,
.; queue off job to send a new query
.I $$GETPAT^IVMUFNC(DFN,.IVMPAT),((SSN'=IVMPAT("SSN"))!(DOB'=IVMPAT("DOB"))!(SEX'=IVMPAT("SEX"))) D QRYQUE^IVMCQ2(DFN)
;
ADDLQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMCMC 8087 printed Apr 09, 2024@21:03:53 Page 2
IVMCMC ;ALB/SEK,BRM,GN,TDM,JAM,HM - CHECK INCOME TEST TRANSMISSION SEGMENTS;1/6/20 8:25am
+1 ;;2.0;INCOME VERIFICATION MATCH;**17,34,49,51,90,115,174,190**;21-OCT-94;Build 47
+2 ;
+3 ;IVM*2*90 - stop upload of LTC type 4 test when staus code not valid
+4 ;
EN ; Check segment structure of Income Test (Z10) transmission.
+1 ; Variable input:
+2 ; IVMDA -- pointer to an incoming message line in file #772
+3 ; IVMORF -- [optional]: set to 1 if Z10 is an ORF message
+4 ; IVMSEG -- the MSH segment string
+5 ;
+6 ; plus the usual HL7 variables: HLDA, HLFS, HLQ, HLECH
+7 ;
+8 ; Variable output:
+9 ; DFN -- pointer to the patient in file #2
+10 ; DGLY -- Income Year
+11 ; IVMFLGC -- Number of Dependent Children
+12 ; IVMMCI -- HL7 message control id of query sent to IVM Center
+13 ;
+14 ; and the global array ^TMP($J,"IVMCM" which holds the message.
+15 ;
+16 NEW ERRMSG,DOBP,SEXP,X,Y,ZDPIFLG,TMPARY,PID3ARY,ICN
+17 ;
+18 ; - message control id from MSH segment
+19 SET MSGID=$PIECE(IVMSEG,HLFS,10)
+20 ;
+21 ; - if query response (ORF), do additional edit checks
+22 IF $GET(IVMORF)
DO ADDL
IF $DATA(HLERR)
GOTO ENQ
+23 ;
+24 ; - check the PID segment and get a match on patient
+25 DO GET("PIDV")
IF IVMSEG1'="PID"
DO PROB("Missing PID segment")
GOTO ENQ
+26 ;S DOBP=$P(IVMSEG,HLFS,8),SEXP=$P(IVMSEG,HLFS,9)
+27 SET DOBP=$GET(^TMP($JOB,"IVMCM","PIDV",7))
SET SEXP=$GET(^TMP($JOB,"IVMCM","PIDV",8))
+28 ;S SSNP=$G(^TMP($J,"IVMCM","PIDV",19))
+29 IF SEXP'="F"&(SEXP'="M")
DO PROB("Incorrect value for Sex")
GOTO ENQ
+30 SET X=$$FMDATE^HLFNC(DOBP)
SET %DT=X
DO ^%DT
IF Y<0
DO PROB("Invalid Date of Birth")
GOTO ENQ
+31 ;S DFN=$$LOOKUP^IVMUFNC(SSNP,Y,SEXP,.ERRMSG)
+32 ;I 'DFN D PROB(ERRMSG) G ENQ
+33 MERGE TMPARY(3)=^TMP($JOB,"IVMCM","PIDV",3)
DO PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
+34 SET DFN=$GET(PID3ARY("PI"))
SET ICN=$GET(PID3ARY("NI"))
+35 IF '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG)
DO PROB(ERRMSG)
GOTO ENQ
+36 KILL TMPARY,PID3ARY
+37 ;
+38 ; - check for veteran's ZIC and ZIR segments
+39 DO GET("ZICV")
IF IVMSEG1'="ZIC"
DO PROB("Missing veteran's ZIC segment")
GOTO ENQ
+40 ; income year
SET DGLY=$$FMDATE^HLFNC($PIECE(IVMSEG,"^",3))
+41 IF 'DGLY
DO PROB("Missing veteran's Income Year")
GOTO ENQ
+42 DO GET("ZIRV")
IF IVMSEG1'="ZIR"
DO PROB("Missing veteran's ZIR segment")
GOTO ENQ
+43 ;
+44 ; - check for spouse's ZDP, ZIC, ZIR segments
+45 DO GET("ZDPS")
IF IVMSEG1'="ZDP"
DO PROB("Missing spouse's ZDP segment")
GOTO ENQ
+46 DO GET("ZICS")
IF IVMSEG1'="ZIC"
DO PROB("Missing spouse's ZIC segment")
GOTO ENQ
+47 DO GET("ZIRS")
IF IVMSEG1'="ZIR"
DO PROB("Missing spouse's ZIR segment")
GOTO ENQ
+48 ;NTE segment is optional IVM*2.0*190
IF $EXTRACT($GET(^TMP($JOB,IVMRTN,IVMDA+1,0)),1,3)="NTE"
DO GET("NTE")
+49 ;
+50 ; - check for dependent children's ZDP, ZIC, ZIR segments and ZMT segment
+51 SET (IVMFLGC,ZDPIFLG)=0
+52 FOR IVMNBR=1:1
Begin DoDot:1
+53 DO GET("ZDPC",IVMNBR)
IF IVMSEG1'="ZDP"
IF IVMSEG1'="ZMT"
DO PROB("Missing child's ZDP segment or ZMT segment")
QUIT
+54 IF IVMSEG1="ZMT"
QUIT
+55 IF $PIECE(IVMSEG,"^",2)=""!($PIECE(IVMSEG,"^",3)="")!($PIECE(IVMSEG,"^",4)="")
DO PROB("Missing child data from ZDP segment")
QUIT
+56 ;No ZIC,ZIR segs or # of children for inactive dependents
if ZDPIFLG
QUIT
+57 DO GET("ZICC",IVMNBR)
IF IVMSEG1'="ZIC"
DO PROB("Missing child's ZIC segment")
QUIT
+58 DO GET("ZIRC",IVMNBR)
IF IVMSEG1'="ZIR"
DO PROB("Missing child's ZIR segment")
QUIT
+59 ; # of children
SET IVMFLGC=IVMFLGC+1
End DoDot:1
IF $DATA(HLERR)!(IVMSEG1="ZMT")
QUIT
+60 ;
+61 IF $DATA(HLERR)
GOTO ENQ
+62 ;
+63 ; Patch IVM*2.0*174 - jam - For ORU-Z10, process SSN for IENs in ^XTMP("DG53970P")
+64 ; -----------------
+65 ; Do this for ORU message only
+66 ; The caller routine ^EASCM sets IVMSSNFLAG=0, quit if this var gets set to 1
+67 IF $GET(IVMORF)'=1
Begin DoDot:1
+68 ; Check if there is a job number in ^XTMP("DG53970P")
+69 NEW IVMJOB
+70 SET IVMJOB=0
+71 SET IVMJOB=$ORDER(^XTMP("DG53970P",IVMJOB))
+72 IF 'IVMJOB
QUIT
+73 ; If this DFN is in the ^XTMP global, process the SSNs in the ZDP, and set IVMSSNFLAG=1 to have caller quit further processing
+74 IF $DATA(^XTMP("DG53970P",IVMJOB,"DFN",DFN))
DO IVMFSSN^IVM2174F(DFN,IVMJOB)
SET IVMSSNFLAG=1
End DoDot:1
IF $GET(IVMSSNFLAG)=1
GOTO ENQ
+75 ; ------------------
+76 ; - check for remaining ZMT and ZBT segments
+77 DO GET("ZMT2")
IF IVMSEG1'="ZMT"
DO PROB("Missing Copay Test ZMT segment")
GOTO ENQ
+78 ;
+79 ; ** added ZMT4 lines for LTC phase II (IVM*2*49)
+80 ; uncomment after all sites have installed to enable consistency chk
+81 DO GET("ZMT4")
IF IVMSEG1'="ZMT"
DO PROB("Missing LTC Test ZMT segment")
GOTO ENQ
+82 ;
+83 ; remove next line after all sites have installed
+84 ;D GET("ZMT4") I IVMSEG1'="ZMT" K ^TMP($J,"IVMCM","ZMT4") S IVMDA=IVMDA-1
+85 ;
+86 DO GET("ZBT")
IF IVMSEG1'="ZBT"
DO PROB("Missing Beneficiary Travel ZBT segment")
GOTO ENQ
+87 ;
ENQ IF IVMSEG1="MSH"
SET IVMDA=IVMDA-1
SET HLERR=""
SET IVMTYPE=5
+1 KILL IVMSEG1,IVMNBR
+2 QUIT
+3 ;
+4 ;
GET(SEG,NUM) ; Get the next HL7 segment.
+1 ; Formal input:
+2 ; SEG -- String with which to build ^TMP($J,"IVMCM"
+3 ; NUM -- Number to index child dependent strings [optional]
+4 ; Required variable input:
+5 ; HLDA -- Pointer to the incoming message in file #772
+6 ; IVMDA -- Pointer to the next message line within file #772
+7 NEW NEXTSEG,NOPID,PIDCNTR,PIDSTR,SEQ
+8 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,+IVMDA))
SET IVMSEG=$GET(^(+IVMDA,0))
+9 SET NEXTSEG=$EXTRACT($GET(^TMP($JOB,IVMRTN,IVMDA+1,0)),1,3)
+10 SET IVMSEG1=$EXTRACT(IVMSEG,1,3)
+11 IF $GET(SEG)=""
GOTO GETQ
+12 ;Strip ""
IF IVMSEG1="ZIR"
SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,15)
+13 ;Strip ""
IF IVMSEG1="ZDP"
SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
+14 IF $GET(NUM)
IF IVMSEG1'="ZMT"
Begin DoDot:1
+15 IF IVMSEG1="ZDP"
IF $PIECE(IVMSEG,HLFS,12)=""
IF NEXTSEG'="ZIC"
DO PROB("Missing Child ZIC segment OR Inactive ZDP missing Inactivation Date")
QUIT
+16 IF IVMSEG1="ZDP"
IF $PIECE(IVMSEG,HLFS,12)'=""
Begin DoDot:2
+17 IF NEXTSEG="ZIC"
DO PROB("ZIC segment following Inactive ZDP segment")
QUIT
+18 SET ZDPIFLG=1
+19 SET SEG=$SELECT($PIECE(IVMSEG,HLFS,7)=2:"ZDPIS",1:"ZDPIC")
+20 SET NUM=$ORDER(^TMP($JOB,"IVMCM",SEG,""),-1)+1
End DoDot:2
+21 if $DATA(HLERR)
QUIT
+22 SET ^TMP($JOB,"IVMCM",SEG,NUM)=$PIECE(IVMSEG,HLFS,2,99)
End DoDot:1
GOTO GETQ
+23 IF IVMSEG1="ZMT"
IF $EXTRACT(SEG,1,3)'="ZMT"
SET SEG="ZMT1"
+24 ;
+25 ;IVM*2*90 don't allow upload of LTC with a date & a bad status code
+26 IF SEG="ZMT4"
IF $PIECE(IVMSEG,HLFS,3)
IF $PIECE(IVMSEG,HLFS,4)'=0
IF $PIECE(IVMSEG,HLFS,4)'=1
IF $PIECE(IVMSEG,HLFS,4)'=""""""
QUIT
+27 ;
+28 IF IVMSEG1="PID"
Begin DoDot:1
+29 KILL ^TMP($JOB,"IVMCM",SEG)
+30 SET (NOPID,PIDCNTR)=1
+31 SET PIDSTR(PIDCNTR)=$PIECE(IVMSEG,HLFS,2,99)
+32 FOR I=1:1
Begin DoDot:2
+33 IF $EXTRACT($GET(^TMP($JOB,IVMRTN,IVMDA+1,0)),1,4)="ZIC^"
SET NOPID=1
QUIT
+34 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,+IVMDA))
+35 SET IVMSEG=$GET(^TMP($JOB,IVMRTN,+IVMDA,0))
+36 SET PIDCNTR=PIDCNTR+1
SET PIDSTR(PIDCNTR)=IVMSEG
End DoDot:2
if NOPID
QUIT
+37 DO BLDPID^IVMPREC6(.PIDSTR,.IVMPID)
+38 MERGE ^TMP($JOB,"IVMCM","PIDV")=IVMPID
End DoDot:1
QUIT
+39 ;
+40 ;IVM*2.0*190
+41 IF IVMSEG1="NTE"
Begin DoDot:1
+42 NEW NONTE
+43 SET NONTE=0
+44 KILL ^TMP($JOB,"IVMCM",SEG)
+45 FOR I=1:1
Begin DoDot:2
+46 SET IVMSEG=$GET(^TMP($JOB,IVMRTN,IVMDA,0))
+47 IF $PIECE(IVMSEG,HLFS)'="NTE"
SET NONTE=1
SET IVMDA=IVMDA-1
QUIT
+48 SET ^TMP($JOB,"IVMCM",SEG,I)=$PIECE(IVMSEG,HLFS,4)
SET IVMDA=IVMDA+1
End DoDot:2
if NONTE
QUIT
End DoDot:1
QUIT
+49 SET ^TMP($JOB,"IVMCM",SEG)=$PIECE(IVMSEG,HLFS,2,99)
GETQ QUIT
+1 ;
PROB(ERR) ; Process encountered errors.
+1 ; Input: ERR -- Error text
+2 SET HLERR=ERR
+3 DO ACK^IVMPREC
+4 QUIT
+5 ;
ADDL ; Perform additional segment checks for ORF messages.
+1 ;
+2 NEW DOB,ERRMSG,IVMMSA,IVMPAT,IVMQRD,IVMQRF,QARRAY,QRYIEN,SEX,SSN
+3 ;
+4 ; edit checks for MSA, QRD, and QRF segments
+5 DO GET("")
IF IVMSEG1'="MSA"
DO PROB("Missing required MSA segment")
GOTO ADDLQ
+6 ; msg control id of msg being acknowledged
SET IVMMCI=$PIECE(IVMSEG,"^",3)
+7 SET IVMMSA=IVMSEG
+8 ; trace reply back to the original query msg
+9 SET QRYIEN=$$FINDMSG^IVMCQ2(IVMMCI)
+10 IF 'QRYIEN
DO PROB("Query not found")
GOTO ADDLQ
+11 IF QRYIEN
IF '$$GET^IVMCQ2(QRYIEN,.QARRAY)
DO PROB("Query not found")
GOTO ADDLQ
+12 SET DFN=QARRAY("DFN")
+13 ;
+14 DO GET("")
IF IVMSEG1'="QRD"
DO PROB("Missing required QRD segment")
GOTO ADDLQ
+15 SET IVMQRD=IVMSEG
+16 SET SSN=$PIECE(IVMQRD,HLFS,9)
+17 ;
+18 DO GET("")
IF IVMSEG1'="QRF"
DO PROB("Missing required QRF segment")
GOTO ADDLQ
+19 SET IVMQRF=IVMSEG
+20 SET DOB=$$FMDATE^HLFNC($PIECE(IVMQRF,HLFS,5))
+21 SET SEX=$PIECE(IVMQRF,HLFS,6)
+22 ;
+23 ;
+24 ; if application reject rec'd from HEC (i.e. No income data on file)
+25 IF $PIECE(IVMMSA,HLFS,2)="AR"
Begin DoDot:1
+26 SET HLERR=""
+27 ;type 4 is now used for LTC test (IVM*2*49)
SET IVMTYPE=7
+28 ; - if patient identifiers rec'd from HEC incorrect,
+29 ; queue off job to send a new query
+30 IF $$GETPAT^IVMUFNC(DFN,.IVMPAT)
IF ((SSN'=IVMPAT("SSN"))!(DOB'=IVMPAT("DOB"))!(SEX'=IVMPAT("SEX")))
DO QRYQUE^IVMCQ2(DFN)
End DoDot:1
+31 ;
ADDLQ QUIT
