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

IVMCMC.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;IVM*2*90 - stop upload of LTC type 4 test when staus code not valid
  1. ;
  1. EN ; Check segment structure of Income Test (Z10) transmission.
  1. ; Variable input:
  1. ; IVMDA -- pointer to an incoming message line in file #772
  1. ; IVMORF -- [optional]: set to 1 if Z10 is an ORF message
  1. ; IVMSEG -- the MSH segment string
  1. ;
  1. ; plus the usual HL7 variables: HLDA, HLFS, HLQ, HLECH
  1. ;
  1. ; Variable output:
  1. ; DFN -- pointer to the patient in file #2
  1. ; DGLY -- Income Year
  1. ; IVMFLGC -- Number of Dependent Children
  1. ; IVMMCI -- HL7 message control id of query sent to IVM Center
  1. ;
  1. ; and the global array ^TMP($J,"IVMCM" which holds the message.
  1. ;
  1. N ERRMSG,DOBP,SEXP,X,Y,ZDPIFLG,TMPARY,PID3ARY,ICN
  1. ;
  1. ; - message control id from MSH segment
  1. S MSGID=$P(IVMSEG,HLFS,10)
  1. ;
  1. ; - if query response (ORF), do additional edit checks
  1. I $G(IVMORF) D ADDL I $D(HLERR) G ENQ
  1. ;
  1. ; - check the PID segment and get a match on patient
  1. D GET("PIDV") I IVMSEG1'="PID" D PROB("Missing PID segment") G ENQ
  1. ;S DOBP=$P(IVMSEG,HLFS,8),SEXP=$P(IVMSEG,HLFS,9)
  1. S DOBP=$G(^TMP($J,"IVMCM","PIDV",7)),SEXP=$G(^TMP($J,"IVMCM","PIDV",8))
  1. ;S SSNP=$G(^TMP($J,"IVMCM","PIDV",19))
  1. I SEXP'="F"&(SEXP'="M") D PROB("Incorrect value for Sex") G ENQ
  1. S X=$$FMDATE^HLFNC(DOBP),%DT=X D ^%DT I Y<0 D PROB("Invalid Date of Birth") G ENQ
  1. ;S DFN=$$LOOKUP^IVMUFNC(SSNP,Y,SEXP,.ERRMSG)
  1. ;I 'DFN D PROB(ERRMSG) G ENQ
  1. M TMPARY(3)=^TMP($J,"IVMCM","PIDV",3) D PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
  1. S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
  1. I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) D PROB(ERRMSG) G ENQ
  1. K TMPARY,PID3ARY
  1. ;
  1. ; - check for veteran's ZIC and ZIR segments
  1. D GET("ZICV") I IVMSEG1'="ZIC" D PROB("Missing veteran's ZIC segment") G ENQ
  1. S DGLY=$$FMDATE^HLFNC($P(IVMSEG,"^",3)) ; income year
  1. I 'DGLY D PROB("Missing veteran's Income Year") G ENQ
  1. D GET("ZIRV") I IVMSEG1'="ZIR" D PROB("Missing veteran's ZIR segment") G ENQ
  1. ;
  1. ; - check for spouse's ZDP, ZIC, ZIR segments
  1. D GET("ZDPS") I IVMSEG1'="ZDP" D PROB("Missing spouse's ZDP segment") G ENQ
  1. D GET("ZICS") I IVMSEG1'="ZIC" D PROB("Missing spouse's ZIC segment") G ENQ
  1. D GET("ZIRS") I IVMSEG1'="ZIR" D PROB("Missing spouse's ZIR segment") G ENQ
  1. I $E($G(^TMP($J,IVMRTN,IVMDA+1,0)),1,3)="NTE" D GET("NTE") ;NTE segment is optional IVM*2.0*190
  1. ;
  1. ; - check for dependent children's ZDP, ZIC, ZIR segments and ZMT segment
  1. S (IVMFLGC,ZDPIFLG)=0
  1. F IVMNBR=1:1 D I $D(HLERR)!(IVMSEG1="ZMT") Q
  1. .D GET("ZDPC",IVMNBR) I IVMSEG1'="ZDP",IVMSEG1'="ZMT" D PROB("Missing child's ZDP segment or ZMT segment") Q
  1. .I IVMSEG1="ZMT" Q
  1. .I $P(IVMSEG,"^",2)=""!($P(IVMSEG,"^",3)="")!($P(IVMSEG,"^",4)="") D PROB("Missing child data from ZDP segment") Q
  1. .Q:ZDPIFLG ;No ZIC,ZIR segs or # of children for inactive dependents
  1. .D GET("ZICC",IVMNBR) I IVMSEG1'="ZIC" D PROB("Missing child's ZIC segment") Q
  1. .D GET("ZIRC",IVMNBR) I IVMSEG1'="ZIR" D PROB("Missing child's ZIR segment") Q
  1. .S IVMFLGC=IVMFLGC+1 ; # of children
  1. ;
  1. I $D(HLERR) G ENQ
  1. ;
  1. ; Patch IVM*2.0*174 - jam - For ORU-Z10, process SSN for IENs in ^XTMP("DG53970P")
  1. ; -----------------
  1. ; Do this for ORU message only
  1. ; The caller routine ^EASCM sets IVMSSNFLAG=0, quit if this var gets set to 1
  1. I $G(IVMORF)'=1 D I $G(IVMSSNFLAG)=1 G ENQ
  1. . ; Check if there is a job number in ^XTMP("DG53970P")
  1. . N IVMJOB
  1. . S IVMJOB=0
  1. . S IVMJOB=$O(^XTMP("DG53970P",IVMJOB))
  1. . I 'IVMJOB Q
  1. . ; If this DFN is in the ^XTMP global, process the SSNs in the ZDP, and set IVMSSNFLAG=1 to have caller quit further processing
  1. . I $D(^XTMP("DG53970P",IVMJOB,"DFN",DFN)) D IVMFSSN^IVM2174F(DFN,IVMJOB) S IVMSSNFLAG=1
  1. ; ------------------
  1. ; - check for remaining ZMT and ZBT segments
  1. D GET("ZMT2") I IVMSEG1'="ZMT" D PROB("Missing Copay Test ZMT segment") G ENQ
  1. ;
  1. ; ** added ZMT4 lines for LTC phase II (IVM*2*49)
  1. ; uncomment after all sites have installed to enable consistency chk
  1. D GET("ZMT4") I IVMSEG1'="ZMT" D PROB("Missing LTC Test ZMT segment") G ENQ
  1. ;
  1. ; remove next line after all sites have installed
  1. ;D GET("ZMT4") I IVMSEG1'="ZMT" K ^TMP($J,"IVMCM","ZMT4") S IVMDA=IVMDA-1
  1. ;
  1. D GET("ZBT") I IVMSEG1'="ZBT" D PROB("Missing Beneficiary Travel ZBT segment") G ENQ
  1. ;
  1. ENQ I IVMSEG1="MSH" S IVMDA=IVMDA-1,HLERR="",IVMTYPE=5
  1. K IVMSEG1,IVMNBR
  1. Q
  1. ;
  1. ;
  1. GET(SEG,NUM) ; Get the next HL7 segment.
  1. ; Formal input:
  1. ; SEG -- String with which to build ^TMP($J,"IVMCM"
  1. ; NUM -- Number to index child dependent strings [optional]
  1. ; Required variable input:
  1. ; HLDA -- Pointer to the incoming message in file #772
  1. ; IVMDA -- Pointer to the next message line within file #772
  1. N NEXTSEG,NOPID,PIDCNTR,PIDSTR,SEQ
  1. S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA)),IVMSEG=$G(^(+IVMDA,0))
  1. S NEXTSEG=$E($G(^TMP($J,IVMRTN,IVMDA+1,0)),1,3)
  1. S IVMSEG1=$E(IVMSEG,1,3)
  1. I $G(SEG)="" G GETQ
  1. I IVMSEG1="ZIR" S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,15) ;Strip ""
  1. I IVMSEG1="ZDP" S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS) ;Strip ""
  1. I $G(NUM),IVMSEG1'="ZMT" D G GETQ
  1. .I IVMSEG1="ZDP",$P(IVMSEG,HLFS,12)="",NEXTSEG'="ZIC" D PROB("Missing Child ZIC segment OR Inactive ZDP missing Inactivation Date") Q
  1. .I IVMSEG1="ZDP",$P(IVMSEG,HLFS,12)'="" D
  1. ..I NEXTSEG="ZIC" D PROB("ZIC segment following Inactive ZDP segment") Q
  1. ..S ZDPIFLG=1
  1. ..S SEG=$S($P(IVMSEG,HLFS,7)=2:"ZDPIS",1:"ZDPIC")
  1. ..S NUM=$O(^TMP($J,"IVMCM",SEG,""),-1)+1
  1. .Q:$D(HLERR)
  1. .S ^TMP($J,"IVMCM",SEG,NUM)=$P(IVMSEG,HLFS,2,99)
  1. I IVMSEG1="ZMT",$E(SEG,1,3)'="ZMT" S SEG="ZMT1"
  1. ;
  1. ;IVM*2*90 don't allow upload of LTC with a date & a bad status code
  1. I SEG="ZMT4",$P(IVMSEG,HLFS,3),$P(IVMSEG,HLFS,4)'=0,$P(IVMSEG,HLFS,4)'=1,$P(IVMSEG,HLFS,4)'="""""" Q
  1. ;
  1. I IVMSEG1="PID" D Q
  1. .K ^TMP($J,"IVMCM",SEG)
  1. .S (NOPID,PIDCNTR)=1
  1. .S PIDSTR(PIDCNTR)=$P(IVMSEG,HLFS,2,99)
  1. .F I=1:1 D Q:NOPID
  1. ..I $E($G(^TMP($J,IVMRTN,IVMDA+1,0)),1,4)="ZIC^" S NOPID=1 Q
  1. ..S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA))
  1. ..S IVMSEG=$G(^TMP($J,IVMRTN,+IVMDA,0))
  1. ..S PIDCNTR=PIDCNTR+1,PIDSTR(PIDCNTR)=IVMSEG
  1. .D BLDPID^IVMPREC6(.PIDSTR,.IVMPID)
  1. .M ^TMP($J,"IVMCM","PIDV")=IVMPID
  1. ;
  1. ;IVM*2.0*190
  1. I IVMSEG1="NTE" D Q
  1. .N NONTE
  1. .S NONTE=0
  1. .K ^TMP($J,"IVMCM",SEG)
  1. .F I=1:1 D Q:NONTE
  1. ..S IVMSEG=$G(^TMP($J,IVMRTN,IVMDA,0))
  1. ..I $P(IVMSEG,HLFS)'="NTE" S NONTE=1,IVMDA=IVMDA-1 Q
  1. ..S ^TMP($J,"IVMCM",SEG,I)=$P(IVMSEG,HLFS,4),IVMDA=IVMDA+1
  1. S ^TMP($J,"IVMCM",SEG)=$P(IVMSEG,HLFS,2,99)
  1. GETQ Q
  1. ;
  1. PROB(ERR) ; Process encountered errors.
  1. ; Input: ERR -- Error text
  1. S HLERR=ERR
  1. D ACK^IVMPREC
  1. Q
  1. ;
  1. ADDL ; Perform additional segment checks for ORF messages.
  1. ;
  1. N DOB,ERRMSG,IVMMSA,IVMPAT,IVMQRD,IVMQRF,QARRAY,QRYIEN,SEX,SSN
  1. ;
  1. ; edit checks for MSA, QRD, and QRF segments
  1. D GET("") I IVMSEG1'="MSA" D PROB("Missing required MSA segment") G ADDLQ
  1. S IVMMCI=$P(IVMSEG,"^",3) ; msg control id of msg being acknowledged
  1. S IVMMSA=IVMSEG
  1. ; trace reply back to the original query msg
  1. S QRYIEN=$$FINDMSG^IVMCQ2(IVMMCI)
  1. I 'QRYIEN D PROB("Query not found") G ADDLQ
  1. I QRYIEN,'$$GET^IVMCQ2(QRYIEN,.QARRAY) D PROB("Query not found") G ADDLQ
  1. S DFN=QARRAY("DFN")
  1. ;
  1. D GET("") I IVMSEG1'="QRD" D PROB("Missing required QRD segment") G ADDLQ
  1. S IVMQRD=IVMSEG
  1. S SSN=$P(IVMQRD,HLFS,9)
  1. ;
  1. D GET("") I IVMSEG1'="QRF" D PROB("Missing required QRF segment") G ADDLQ
  1. S IVMQRF=IVMSEG
  1. S DOB=$$FMDATE^HLFNC($P(IVMQRF,HLFS,5))
  1. S SEX=$P(IVMQRF,HLFS,6)
  1. ;
  1. ;
  1. ; if application reject rec'd from HEC (i.e. No income data on file)
  1. I $P(IVMMSA,HLFS,2)="AR" D
  1. .S HLERR=""
  1. .S IVMTYPE=7 ;type 4 is now used for LTC test (IVM*2*49)
  1. .; - if patient identifiers rec'd from HEC incorrect,
  1. .; queue off job to send a new query
  1. .I $$GETPAT^IVMUFNC(DFN,.IVMPAT),((SSN'=IVMPAT("SSN"))!(DOB'=IVMPAT("DOB"))!(SEX'=IVMPAT("SEX"))) D QRYQUE^IVMCQ2(DFN)
  1. ;
  1. ADDLQ Q