- 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 Feb 18, 2025@23:26:56 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