Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m =================================================================== --- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m (revision 613) +++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m (revision 623) @@ -1,264 +1,262 @@ -IVMCM ;ALB/SEK,KCL,RTK,AEG,BRM,AEG - PROCESS INCOME TEST (Z10) TRANSMISSIONS ; 04/23/03 1:43pm - ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,34,49,59,55,63,77,74,123**;21-OCT-94;Build 6 - ; - ; -ORF ; Handler for ORF type HL7 messages received from HEC - ; - ; Make sure POSTMASTER DUZ instead of DUZ of Person who - ; started Incoming Logical Link. - S DUZ=.5 - N CNT,IVMRTN,SEGCNT - S IVMRTN="IVMCMX" ;USE "IVMCMX" BECAUSE "IVMCM" ALREADY USED - K ^TMP($J,IVMRTN),DIC - S (DGMSGF,DGMTMSG)=1 ; HL7 rtn. Don't need DG interative messages. - S HLECH=HL("ECH"),HLQ=HL("Q"),HLMID=HL("MID") - K %,%H,%I D NOW^%DTC S HLDT=% - F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D - . S CNT=0 - . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE - . F S CNT=$O(HLNODE(CNT)) Q:'CNT D - . . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) - S HLDA=HLMTIEN - ; - N SEG,EVENT,MSGID - S:'$D(HLEVN) HLEVN=0 - D NXTSEG^DGENUPL(HLDA,0,.SEG) - Q:(SEG("TYPE")'="MSH") ;would not have reached here if this happened! - S EVENT=$P(SEG(9),$E(HLECH),2) - ; - ; INITIALIZE HL7 VARIABLES - S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORF-"_EVENT_" SERVER" - S HLEID=$O(^ORD(101,"B",HLEID,0)) - D INIT^HLFNC2(HLEID,.HL) - S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) - ; - ; Handle means test signature ORF (Z06) event - I EVENT="Z06" D ORF^IVMPREC7 - ; - ; Handle income test ORF (Z10) event - I EVENT="Z10" D Z10 - ; - ; Handle enrollment/elig. ORF (Z11) event - I EVENT="Z11" D - .S MSGID=SEG(10) - .D ORFZ11^DGENUPL(HLDA,MSGID) - ; - K ^TMP($J,IVMRTN) - Q - ; - ; -Z10 ; Entry point for receipt of ORF~Z10 transmission - ; The Income Test (Z10) transmission has the following format: - ; - ; BHS ORF msgs do not include batch header or trailer. - ; {MSH - ; PID They will include the sequence: MSA - ; ZIC QRD - ; ZIR QRF - ; {ZDP These segments will follow the MSH segment. - ; ZIC - ; ZIR - ; } - ; {ZMT - ; } - ; ZBT - ; } - ; BTS - ; - S IVMORF=1 ; set ORF msg flag - S (HLEVN,IVMCT,IVMERROR,IVMCNTR)=0 ; init vars - ; -ORU ; Entry point for receipt of ORU~Z10 trans (called by IVMPREC2) - S IVMTYPE=5,IVMZ10F=1 - ; - ; - loop through the msg in (#772 file), and process (PROC) msgs - S IVMDA=0 F S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D PROC Q:'IVMDA - ; - ; - if ORF msg flag, update the Query Tran Log and send ACK - I $G(IVMORF) D - .I $G(DFN),$D(IVMMCI) D - ..N IVMCR - ..S IVMCR=$P("1^2^3^7^5^6^4","^",IVMTYPE) ;map reason to test type - ..D FIND^IVMCQ2(DFN,IVMMCI,HLDT,$S($D(HLERR):5,1:IVMCR),1) - .;D ACK^IVMPREC:'$D(HLERR) - .;N HLRESLTA,HLP - .;D GENACK^HLMA1(HLEID,HLMTIEN,HLEIDS,"LM",1,.HLRESLTA,"",.HLP) - ; - ; - if tests are uploaded, generate notification msg - I $D(^TMP($J,"IVMBULL")) D ^IVMCMB - ; -ENQ ; - K IVMDA,IVMORF,IVMSEG,IVMFLGC,IVMTYPE,IVMMTIEN,IVMMTDT,IVMDGBT,IVMMCI - K ^TMP($J,"IVMCM"),^("IVMBULL"),DGMSGF,DGADDF,IVMCPAY,IVMBULL,DFN - K DGMTMSG,IVMZ10F - Q - ; -PROC ; Process each HL7 message from (#772) file - ; - N IVMFUTR,TMSTAMP,SOURCE,NODE,HSDATE,IVMZ10,DGMTP,DGMTACT,DGMTI,DGMTA - S DGMTACT="ADD" - D PRIOR^DGMTEVT - S IVMZ10="UPLOAD IN PROGRESS" - S IVMFUTR=0 ;this flag will indicate whether or not a test with a future date is being uploaded - S IVMMTIEN=0 - ; - S MSGID=$P(IVMSEG,HLFS,10) ; msg control id for ACK's - ; - check if DCD messaging is enabled - I '$$DCDON^IVMUPAR1() D PROB^IVMCMC("Facility has DCD messaging disabled") Q - ; - ; - check HL7 msg structure for errors - K HLERR,^TMP($J,"IVMCM") - D ^IVMCMC I $D(HLERR) K:HLERR="" HLERR Q - ; - ; Determine type of test/transmission - S IVMTYPE=0 - ; - ; - was a means test sent? - I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2) S IVMTYPE=1 ; MT trans - ; - ; - if MT and CT transmitted, error - pt can't have both unless - ; one is a deletion, but HEC not currently handling that situation - I IVMTYPE,$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) D PROB^IVMCMC("Patient can not have both a Means Test and Copay Test") Q - I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) S IVMTYPE=2 ; CT trans - ; - ; - if no MT or CT or LTC then Income Screening - I 'IVMTYPE,'$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) S IVMTYPE=3 ; IS trans - ; - ;send an eligibility query if no eligibility code - I '$$ELIG^IVMCUF1(DFN),'$$PENDING^DGENQRY(DFN) I $$SEND^DGENQRY1(DFN) - ; - ; obtain locks used to sychronize upload with local income test options - D GETLOCKS^IVMCUPL(DFN) - ; - ; -MT ; If transmission is a Means Test - N NODE0,RET,CODE,DATA - S HLQ=$G(HL("Q")) - S:HLQ="" HLQ="""""" - I IVMTYPE=1 D I $D(HLERR) G PROCQ - .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2)) - .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,25)) - .S HSDATE=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,24)) - .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,22) - .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,1) - .; Check that test is for same year - .I $P(IVMLAST,U,2),$E($P(IVMLAST,U,2),1,3)'=$E(IVMMTDT,1,3) S IVMLAST="" - .I $$Z06MT^EASPTRN1(+IVMLAST) D PROB^IVMCMC("IVM Means Test already on file for this year") Q - .I '$$ELIG^IVMUFNC5(DFN) S ERRMSG="Means Test upload not appropriate for current patient" - .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D - ..N CATCZMT S CATCZMT=$G(^TMP($J,"IVMCM","ZMT1")) - ..S CATC=$$CATC^IVMUFNC5(CATCZMT) - ..I '+$G(CATC) S ERRMSG="Only Means Tests in current/previous income years are valid (not effective)" - .I $G(ERRMSG)'="" D PROB^IVMCMC(ERRMSG) K ERRMSG,CATC Q - .; - .; - perform edit checks and file MT - .D CHKDT - .;deletion indicator sent? - .I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,3)=HLQ D Q - ..D - ...;if there is a future test for that income year, delete that - ...N IEN,DATA,IVMPAT - ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1,.IVMPAT) - ...I IEN S DATA(.06)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) - ...I IEN,$D(^DGMT(408.31,IEN,0)) D - ....S IVMMTIEN=IEN - ....S IVMFUTR=1 - ...E D - ....S IVMFUTR=0 - ..Q:('IVMMTIEN) - ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - ..I $$EN^IVMCMD(IVMMTIEN) D - ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) - ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") - ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) - .; - .;check timestamp - if matches current primary test and hardship matches, then this is a duplicate and does not need to be uploaded - .I TMSTAMP D - ..S NODE="" - ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1) - ..Q:'IVMMTIEN - ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) - .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5),(HSDATE=$P(NODE,"^")) Q - .; - .D DELTYPE^IVMCMD(DFN,IVMMTDT,2) - .D EN^IVMCM1 - ; - ; -CT ; If transmission is a Copay Test - N NODE0,RET,CODE,DATA - I IVMTYPE=2 D I $D(HLERR) G PROCQ - .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2)) - .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,25)) - .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,22) - .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,2) - .S IVMCPAY=$$RXST^IBARXEU(DFN) - .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D PROB^IVMCMC("Only Copay Tests in the current/previous income years are valid. (Not effective)") Q - .; - perform edit checks and file CT - .D CHKDT - .;deletion indicator sent? - .I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,3)=HLQ D Q - ..D - ...;if there is a future test for that income year, delete that - ...N IEN,DATA,IVMPAT - ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2,.IVMPAT) - ...I IEN S DATA(.07)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) - ...I IEN,$D(^DGMT(408.31,IEN,0)) D - ....S IVMMTIEN=IEN - ....S IVMFUTR=1 - ...E D - ....S IVMFUTR=0 - ..Q:('IVMMTIEN) - ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - ..I $$EN^IVMCMD(IVMMTIEN) D - ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) - ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") - ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) - .; - .;check timestamp - if matches current primary test, then this is a duplicate and does not need to be uploaded - .I TMSTAMP D - ..S NODE="" - ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2) - ..Q:'IVMMTIEN - ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) - .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5) Q - .; - .D DELTYPE^IVMCMD(DFN,IVMMTDT,1) - .D EN^IVMCM1 - ; -IS ; - If transmission is income screening info only then do not process - ; - outside of the scope of MTS - ;I IVMTYPE=3 S IVMMTDT=0 D EN^IVMCM1 I $D(HLERR) G PROCQ - I IVMTYPE=3 S IVMMTDT=0 - ; -LTC ; If transmission contains a Long Term Care Test (TYPE 4 TEST) - I $P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) D LTC^IVMCM1 - ; -PROCQ ; - ; release locks used to sychronize upload with local income test options - D RELLOCKS^IVMCUPL(DFN) - Q - ; -CHKDT ; check date of income test being uploaded - ; Is it a future date? If so, set IVMFUTR=1 - ; - ; IVMMTIEN is the IEN of current primary test for the year - ; - I $E($P(IVMLAST,"^",2),1,3)=$E(IVMMTDT,1,3) S IVMMTIEN=+IVMLAST - I IVMMTDT>DT S IVMFUTR=1 - Q -FUTURE(DFN,YEAR,TYPE,IVMPAT) ; - ;Returns the ien of the future test, if there is one - ;Inputs: DFN - ; YEAR - income year - ; TYPE - type of test - ;Output: - ; function value - ien of future means test, if there is one, "" otherwise - ; IVMPAT - Pointer to the IVM Patient file for the income year if there is an entry (pass by reference) - ; - N RET - S RET="" - S IVMPAT=$$FIND^IVMPLOG(DFN,YEAR) - I IVMPAT S RET=$P($G(^IVM(301.5,IVMPAT,0)),"^",$S(TYPE=1:6,1:7)) - Q RET +IVMCM ;ALB/SEK,KCL,RTK,AEG,BRM,AEG - PROCESS INCOME TEST (Z10) TRANSMISSIONS ; 04/23/03 1:43pm + ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,34,49,59,55,63,77,74**;21-OCT-94 + ; + ; +ORF ; Handler for ORF type HL7 messages received from HEC + ; + ; Make sure POSTMASTER DUZ instead of DUZ of Person who + ; started Incoming Logical Link. + S DUZ=.5 + N CNT,IVMRTN,SEGCNT + S IVMRTN="IVMCMX" ;USE "IVMCMX" BECAUSE "IVMCM" ALREADY USED + K ^TMP($J,IVMRTN),DIC + S (DGMSGF,DGMTMSG)=1 ; HL7 rtn. Don't need DG interative messages. + S HLECH=HL("ECH"),HLQ=HL("Q"),HLMID=HL("MID") + K %,%H,%I D NOW^%DTC S HLDT=% + F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D + . S CNT=0 + . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE + . F S CNT=$O(HLNODE(CNT)) Q:'CNT D + . . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) + S HLDA=HLMTIEN + ; + N SEG,EVENT,MSGID + S:'$D(HLEVN) HLEVN=0 + D NXTSEG^DGENUPL(HLDA,0,.SEG) + Q:(SEG("TYPE")'="MSH") ;would not have reached here if this happened! + S EVENT=$P(SEG(9),$E(HLECH),2) + ; + ; INITIALIZE HL7 VARIABLES + S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORF-"_EVENT_" SERVER" + S HLEID=$O(^ORD(101,"B",HLEID,0)) + D INIT^HLFNC2(HLEID,.HL) + S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) + ; + ; Handle means test signature ORF (Z06) event + I EVENT="Z06" D ORF^IVMPREC7 + ; + ; Handle income test ORF (Z10) event + I EVENT="Z10" D Z10 + ; + ; Handle enrollment/elig. ORF (Z11) event + I EVENT="Z11" D + .S MSGID=SEG(10) + .D ORFZ11^DGENUPL(HLDA,MSGID) + ; + K ^TMP($J,IVMRTN) + Q + ; + ; +Z10 ; Entry point for receipt of ORF~Z10 transmission + ; The Income Test (Z10) transmission has the following format: + ; + ; BHS ORF msgs do not include batch header or trailer. + ; {MSH + ; PID They will include the sequence: MSA + ; ZIC QRD + ; ZIR QRF + ; {ZDP These segments will follow the MSH segment. + ; ZIC + ; ZIR + ; } + ; {ZMT + ; } + ; ZBT + ; } + ; BTS + ; + S IVMORF=1 ; set ORF msg flag + S (HLEVN,IVMCT,IVMERROR,IVMCNTR)=0 ; init vars + ; +ORU ; Entry point for receipt of ORU~Z10 trans (called by IVMPREC2) + S IVMTYPE=5,IVMZ10F=1 + ; + ; - loop through the msg in (#772 file), and process (PROC) msgs + S IVMDA=0 F S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D PROC Q:'IVMDA + ; + ; - if ORF msg flag, update the Query Tran Log and send ACK + I $G(IVMORF) D + .I $G(DFN),$D(IVMMCI) D + ..N IVMCR + ..S IVMCR=$P("1^2^3^7^5^6^4","^",IVMTYPE) ;map reason to test type + ..D FIND^IVMCQ2(DFN,IVMMCI,HLDT,$S($D(HLERR):5,1:IVMCR),1) + .;D ACK^IVMPREC:'$D(HLERR) + .;N HLRESLTA,HLP + .;D GENACK^HLMA1(HLEID,HLMTIEN,HLEIDS,"LM",1,.HLRESLTA,"",.HLP) + ; + ; - if tests are uploaded, generate notification msg + I $D(^TMP($J,"IVMBULL")) D ^IVMCMB + ; +ENQ ; + K IVMDA,IVMORF,IVMSEG,IVMFLGC,IVMTYPE,IVMMTIEN,IVMMTDT,IVMDGBT,IVMMCI + K ^TMP($J,"IVMCM"),^("IVMBULL"),DGMSGF,DGADDF,IVMCPAY,IVMBULL,DFN + K DGMTMSG,IVMZ10F + Q + ; +PROC ; Process each HL7 message from (#772) file + ; + N IVMFUTR,TMSTAMP,SOURCE,NODE,HSDATE,IVMZ10,DGMTP,DGMTACT,DGMTI,DGMTA + S DGMTACT="ADD" + D PRIOR^DGMTEVT + S IVMZ10="UPLOAD IN PROGRESS" + S IVMFUTR=0 ;this flag will indicate whether or not a test with a future date is being uploaded + S IVMMTIEN=0 + ; + S MSGID=$P(IVMSEG,HLFS,10) ; msg control id for ACK's + ; - check if DCD messaging is enabled + I '$$DCDON^IVMUPAR1() D PROB^IVMCMC("Facility has DCD messaging disabled") Q + ; + ; - check HL7 msg structure for errors + K HLERR,^TMP($J,"IVMCM") + D ^IVMCMC I $D(HLERR) K:HLERR="" HLERR Q + ; + ; Determine type of test/transmission + S IVMTYPE=0 + ; + ; - was a means test sent? + I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2) S IVMTYPE=1 ; MT trans + ; + ; - if MT and CT transmitted, error - pt can't have both unless + ; one is a deletion, but HEC not currently handling that situation + I IVMTYPE,$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) D PROB^IVMCMC("Patient can not have both a Means Test and Copay Test") Q + I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) S IVMTYPE=2 ; CT trans + ; + ; - if no MT or CT or LTC then Income Screening + I 'IVMTYPE,'$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) S IVMTYPE=3 ; IS trans + ; + ;send an eligibility query if no eligibility code + I '$$ELIG^IVMCUF1(DFN),'$$PENDING^DGENQRY(DFN) I $$SEND^DGENQRY1(DFN) + ; + ; obtain locks used to sychronize upload with local income test options + D GETLOCKS^IVMCUPL(DFN) + ; + ; +MT ; If transmission is a Means Test + N NODE0,RET,CODE,DATA + S HLQ=$G(HL("Q")) + S:HLQ="" HLQ="""""" + I IVMTYPE=1 D I $D(HLERR) G PROCQ + .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2)) + .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,25)) + .S HSDATE=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,24)) + .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,22) + .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,1) + .I $$Z06MT^EASPTRN1(+IVMLAST) Q + .I '$$ELIG^IVMUFNC5(DFN) S ERRMSG="Means Test upload not appropriate for current patient" + .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D + ..N CATCZMT S CATCZMT=$G(^TMP($J,"IVMCM","ZMT1")) + ..S CATC=$$CATC^IVMUFNC5(CATCZMT) + ..I '+$G(CATC) S ERRMSG="Only Means Tests in current/previous income years are valid (not effective)" + .I $G(ERRMSG)'="" D PROB^IVMCMC(ERRMSG) K ERRMSG,CATC Q + .; + .; - perform edit checks and file MT + .D CHKDT + .;deletion indicator sent? + .I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,3)=HLQ D Q + ..D + ...;if there is a future test for that income year, delete that + ...N IEN,DATA,IVMPAT + ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1,.IVMPAT) + ...I IEN S DATA(.06)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) + ...I IEN,$D(^DGMT(408.31,IEN,0)) D + ....S IVMMTIEN=IEN + ....S IVMFUTR=1 + ...E D + ....S IVMFUTR=0 + ..Q:('IVMMTIEN) + ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) + ..I $$EN^IVMCMD(IVMMTIEN) D + ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) + ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") + ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) + .; + .;check timestamp - if matches current primary test and hardship matches, then this is a duplicate and does not need to be uploaded + .I TMSTAMP D + ..S NODE="" + ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1) + ..Q:'IVMMTIEN + ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) + .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) + .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5),(HSDATE=$P(NODE,"^")) Q + .; + .D DELTYPE^IVMCMD(DFN,IVMMTDT,2) + .D EN^IVMCM1 + ; + ; +CT ; If transmission is a Copay Test + N NODE0,RET,CODE,DATA + I IVMTYPE=2 D I $D(HLERR) G PROCQ + .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2)) + .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,25)) + .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,22) + .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,2) + .S IVMCPAY=$$RXST^IBARXEU(DFN) + .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D PROB^IVMCMC("Only Copay Tests in the current/previous income years are valid. (Not effective)") Q + .; - perform edit checks and file CT + .D CHKDT + .;deletion indicator sent? + .I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,3)=HLQ D Q + ..D + ...;if there is a future test for that income year, delete that + ...N IEN,DATA,IVMPAT + ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2,.IVMPAT) + ...I IEN S DATA(.07)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) + ...I IEN,$D(^DGMT(408.31,IEN,0)) D + ....S IVMMTIEN=IEN + ....S IVMFUTR=1 + ...E D + ....S IVMFUTR=0 + ..Q:('IVMMTIEN) + ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) + ..I $$EN^IVMCMD(IVMMTIEN) D + ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) + ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") + ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) + .; + .;check timestamp - if matches current primary test, then this is a duplicate and does not need to be uploaded + .I TMSTAMP D + ..S NODE="" + ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2) + ..Q:'IVMMTIEN + ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) + .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) + .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5) Q + .; + .D DELTYPE^IVMCMD(DFN,IVMMTDT,1) + .D EN^IVMCM1 + ; +IS ; - If transmission is income screening info only then do not process + ; - outside of the scope of MTS + ;I IVMTYPE=3 S IVMMTDT=0 D EN^IVMCM1 I $D(HLERR) G PROCQ + I IVMTYPE=3 S IVMMTDT=0 + ; +LTC ; If transmission contains a Long Term Care Test (TYPE 4 TEST) + I $P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) D LTC^IVMCM1 + ; +PROCQ ; + ; release locks used to sychronize upload with local income test options + D RELLOCKS^IVMCUPL(DFN) + Q + ; +CHKDT ; check date of income test being uploaded + ; Is it a future date? If so, set IVMFUTR=1 + ; + ; IVMMTIEN is the IEN of current primary test for the year + ; + I $E($P(IVMLAST,"^",2),1,3)=$E(IVMMTDT,1,3) S IVMMTIEN=+IVMLAST + I IVMMTDT>DT S IVMFUTR=1 + Q +FUTURE(DFN,YEAR,TYPE,IVMPAT) ; + ;Returns the ien of the future test, if there is one + ;Inputs: DFN + ; YEAR - income year + ; TYPE - type of test + ;Output: + ; function value - ien of future means test, if there is one, "" otherwise + ; IVMPAT - Pointer to the IVM Patient file for the income year if there is an entry (pass by reference) + ; + N RET + S RET="" + S IVMPAT=$$FIND^IVMPLOG(DFN,YEAR) + I IVMPAT S RET=$P($G(^IVM(301.5,IVMPAT,0)),"^",$S(TYPE=1:6,1:7)) + Q RET Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM9.m =================================================================== --- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM9.m (revision 613) +++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM9.m (revision 623) @@ -1,206 +1,205 @@ -IVMLDEM9 ;ALB/BRM/PHH - IVM ADDRESS UPDATES PENDING REVIEW RPT ; 04/09/08 13:35pm - ;;2.0;INCOME VERIFICATION MATCH;**79,93,119,126**; 21-OCT-94;Build 1 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - Q - ; -EN2 ;entry point for IVM ADDR UPDT PENDING REVIEW menu option - K ^TMP("IVMLDEM9",$J) - K ^TMP($J,"IVMLDEM9") - ;If mail group has no member or remote-member - I '$$MEMBER() D Q - . I '$D(ZTQUEUED) W !!,"IVM ADDR UPDT REPORT does not have a member. Report not sent." K DIR S DIR(0)="E" D ^DIR K DIR - I +$G(ZTSK) D PRINT,EXIT Q ;started by Taskman job - ;User runs the option - I '$D(ZTQUEUED) D - . W !!,"The report will be sent to mail group IVM ADDR UPDT REPORT" - . D QUE - . D EXIT - . K DIR S DIR(0)="E" D ^DIR K DIR - Q - ; -LOOP(DTPARAM,FILDAT) ;main loop - N DFN,IVMDT,IVMDA,IVMDA1,IVMDA2,RF171,TODAY,AUTODT,DTDIFF,NAME,UPLDT - N X1,X2,Y,SSN,DFN - D DT^DILF("X","T"_$G(DTPARAM),.AUTODT) - S TODAY=$$DT^XLFDT S:'$G(FILDAT) FILDAT=0 - Q:'$G(AUTODT) ;this should never occur, but just in case - S RF171=$O(^IVM(301.92,"C","RF171","")),IVMDA2="" - Q:'RF171 - F S IVMDA2=$O(^IVM(301.5,IVMDA2)) Q:IVMDA2="" D - .S DFN=$P($G(^IVM(301.5,IVMDA2,0)),"^"),IVMDA1="" - .Q:('DFN)!('$D(^DPT(+DFN)))!('$D(^IVM(301.5,IVMDA2,"IN"))) - .F S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1)) Q:IVMDA1="" D - ..Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171)) - ..S IVMDA="" - ..F S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171,IVMDA)) Q:'IVMDA D - ...S IVMDT=$P($G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)),"^",3) - ...Q:('IVMDT)!(IVMDT>AUTODT) - ...; report addresses that will be auto-uploaded in DTDIFF days - ...S X1=TODAY,X2=IVMDT D ^%DTC S DTDIFF=+$G(X) - ...S NAME=$P($G(^DPT(DFN,0)),"^"),SSN=$P($G(^DPT(DFN,0)),"^",9) - ...S X1=IVMDT,X2=14 D C^%DTC S UPLDT=$G(X) - ...I '$D(^IVM(301.5,"ASEG","PID",IVMDA2)) Q - ...S ^TMP("IVMLDEM9",$J,DTDIFF,SSN,IVMDA)=$G(NAME)_"^"_$P(IVMDT,".")_"^"_$P(UPLDT,".")_"^"_DFN_"^"_IVMDA2_"^"_IVMDA1 - Q - ; -AUTOLOAD(DFN,IVMDA2,IVMDA1) ;auto-upload records that not been reviewed - ; this tag is called from ^IVMLDEMC - ; - Q:('$G(DFN))!('$G(IVMDA2))!('$G(IVMDA1)) - N IVMI,IVMJ,IVMFIELD,IVMVALUE,IVMNODE,IVMFLAG,DUZ - S DUZ="IVM AUTO ADDR JOB" - ; - ; determine appropriate address change dt/tm to be used - D ADDRDT^IVMLDEM6(DFN,IVMDA2,IVMDA1) - ; - N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR) - ; - ; loop through the record to be uploaded - S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D - .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D - ..; - ..; check for data node in (#301.511) sub-file - ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) - ..Q:('+IVMNODE)!($P(IVMNODE,"^",2)']"") - ..; - ..; check for residence phone number -> do not auto-upload - ..Q:(+IVMNODE=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0))) - ..; - ..; do not auto-upload if there is an active prescription - ..I $$PHARM^IVMLDEM6(+DFN) D REJTADD Q - ..; - ..; set upload parameters - ..S IVMFIELD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5) - ..S IVMVALUE=$P(IVMNODE,"^",2) - ..; - ..; load addr field into the Patient (#2) file - ..D UPLOAD^IVMLDEM6(DFN,IVMFIELD,IVMVALUE) S IVMFLAG=1 - ..; - ..; remove entry from (#301.511) sub-file - ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ) - ..; - ..; if no display or uploadable fields, delete PID segment - ..I ('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0))&('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)) D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") - ; - I +$G(IVMFLAG) D - .N DGCURR - .D GETUPDTS^DGADDUTL(DFN,.DGCURR) - .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR) - Q -REJTADD ;Reject the address - ; update the ADDRESS CHANGE DT/TM field #.118 in PATIENT file #2 - D UPDDTTM^DGADDUTL(DFN,"PERM") - ; - ; trigger the record to transmit the existing address on file to HEC - N DGENUPLD ; Used in SETSTAT^IVMPLOG to prevent filing. - N DA,X,IVMX - S (DA,X)=DFN - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX - Q -PRINT ;report output - N DAYS,SSN,DATA,EX,PAGE,IVMDA,DATA,IVMLN,XMY,XMSUB,XMDUZ,XMTEXT - D LOOP("",0) - D HDR - D DISPLAY - D EMAIL - Q -DISPLAY ;Display the report - S DAYS="" - I '$D(^TMP("IVMLDEM9",$J)) Q - F S DAYS=$O(^TMP("IVMLDEM9",$J,DAYS),-1) Q:DAYS=""!($G(EX)) D - .S SSN="" - .F S SSN=$O(^TMP("IVMLDEM9",$J,DAYS,SSN)) Q:SSN=""!($G(EX)) D - ..S IVMDA="" - ..F S IVMDA=$O(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) Q:(IVMDA="")!($G(EX)) D - ...S DATA=$G(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) - ... D LNPLUS - ... S ^TMP($J,"IVMLDEM9",IVMLN)=" "_$$FMTE^XLFDT($P(DATA,"^",3))_" "_$$FMTE^XLFDT($P(DATA,"^",2))_" "_SSN_" "_$P(DATA,"^") - ... S ^TMP($J,"IVMLDEM9","TOTAL")=$G(^TMP($J,"IVMLDEM9","TOTAL"))+1 - D TOTAL - D - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)=" <>" - I $E(IOST)="C" W ! K DIR S DIR(0)="E" D ^DIR K DIR - Q -HDR ;print header - N IVMDT,Y,DLINE - I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,EX)=1 Q - S Y=DT X ^DD("DD") S IVMDT=Y - D - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)=" IVM ADDRESS UPDATES PENDING REVIEW "_IVMDT - . D LNPLUS - . S $P(^TMP($J,"IVMLDEM9",IVMLN),"=",78)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)=" Auto-Upload Date Date Received SSN Patient Name" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)=" ---------------- ------------- --------- ------------" - Q -EXIT D ^%ZISC,HOME^%ZIS Q - K ^TMP($J,"IVMLDEM9") - K ^TMP("IVMLDEM9",$J) - ; -ADRDTCK(DFN,IVMDA2,IVMDA1) ;is the incoming address older than #2 address? - Q:'$G(DFN)!('$G(IVMDA2))!('$G(IVMDA1)) "0^MISSING INPUT PARAMETER" - N OADDRDT,NADDRDT,ERR,IVMDA,IEN92,IENS - S OADDRDT=$$GET1^DIQ(2,DFN_",",.118,"I","","ERR") Q:$D(ERR) "0^OLD ADDR ERROR" - S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92 "0^BAD #301.92 ENTRY FOR RF171" - I '$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92)) Q "0^ADDR DT NOT PRESENT" - S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA "0^MISSING ADDR DT IN 301.5" - S IENS=IVMDA_","_IVMDA1_","_IVMDA2_"," - S NADDRDT=$$GET1^DIQ(301.511,IENS,.02,"I","","ERR") Q:$D(ERR) "0^NEW ADDR ERROR" - Q:(OADDRDT="")&(NADDRDT="") 0 - Q:(NADDRDT="")!(OADDRDT'0),('$$GOTLOCAL^XMXAPIG("IVM ADDR UPDT REPORT")) S RESULT=0 - Q RESULT -EMAIL ;Set up parameters to email the report - ;If called within a task, protect variables - I $D(ZTQUEUED) N %,DIFROM - N RDT - D NOW^%DTC S Y=% X ^DD("DD") - S RDT=$P(Y,"@",1)_"@"_$P($P(Y,"@",2),":",1,2) - S XMSUB="IVM Address Pending Review ("_RDT_")" - S XMY("G.IVM ADDR UPDT REPORT")="" - I $G(^TMP($J,"IVMLDEM9","TOTAL"))<1 D - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="*** NO RECORDS TO PRINT ***" - S XMTEXT="^TMP($J,""IVMLDEM9""," - D ^XMD - Q -QUE ;Que the task if user invokes option - N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR,IOP - W ! - S ZTIO="" - S ZTRTN="PRINT^IVMLDEM9" - S ZTDESC="IVM AUTO ADDRESS UPLOAD RPT" - D ^%ZTLOAD - D ^%ZISC,HOME^%ZIS - W !,$S($D(ZTSK):"REQUEST QUEUED AS TASK#"_ZTSK,1:"REQUEST CANCELLED!") - Q -TOTAL ;Display record total on the report - N IVMTOTAL - S IVMTOTAL=$G(^TMP($J,"IVMLDEM9","TOTAL")) - D - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="TOTAL RECORD(S): "_$G(IVMTOTAL) - Q -LNPLUS ;Increase line number for the email text - S IVMLN=$G(IVMLN)+1 - Q +IVMLDEM9 ;ALB/BRM/PHH - IVM ADDRESS UPDATES PENDING REVIEW RPT ; 10/18/06 12:47pm + ;;2.0;INCOME VERIFICATION MATCH;**79,93,119**; 21-OCT-94;Build 1 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + Q + ; +EN2 ;entry point for IVM ADDR UPDT PENDING REVIEW menu option + K ^TMP("IVMLDEM9",$J) + K ^TMP($J,"IVMLDEM9") + ;If mail group has no member or remote-member + I '$$MEMBER() D Q + . I '$D(ZTQUEUED) W !!,"IVM ADDR UPDT REPORT does not have a member. Report not sent." K DIR S DIR(0)="E" D ^DIR K DIR + I +$G(ZTSK) D PRINT,EXIT Q ;started by Taskman job + ;User runs the option + I '$D(ZTQUEUED) D + . W !!,"The report will be sent to mail group IVM ADDR UPDT REPORT" + . D QUE + . D EXIT + . K DIR S DIR(0)="E" D ^DIR K DIR + Q + ; +LOOP(DTPARAM,FILDAT) ;main loop + N DFN,IVMDT,IVMDA,IVMDA1,IVMDA2,RF171,TODAY,AUTODT,DTDIFF,NAME,UPLDT + N X1,X2,Y,SSN,DFN + D DT^DILF("X","T"_$G(DTPARAM),.AUTODT) + S TODAY=$$DT^XLFDT S:'$G(FILDAT) FILDAT=0 + Q:'$G(AUTODT) ;this should never occur, but just in case + S RF171=$O(^IVM(301.92,"C","RF171","")),IVMDA2="" + Q:'RF171 + F S IVMDA2=$O(^IVM(301.5,IVMDA2)) Q:IVMDA2="" D + .S DFN=$P($G(^IVM(301.5,IVMDA2,0)),"^"),IVMDA1="" + .Q:('DFN)!('$D(^DPT(+DFN)))!('$D(^IVM(301.5,IVMDA2,"IN"))) + .F S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1)) Q:IVMDA1="" D + ..Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171)) + ..S IVMDA="" + ..F S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171,IVMDA)) Q:'IVMDA D + ...S IVMDT=$P($G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)),"^",3) + ...Q:('IVMDT)!(IVMDT>AUTODT) + ...; report addresses that will be auto-uploaded in DTDIFF days + ...S X1=TODAY,X2=IVMDT D ^%DTC S DTDIFF=+$G(X) + ...S NAME=$P($G(^DPT(DFN,0)),"^"),SSN=$P($G(^DPT(DFN,0)),"^",9) + ...S X1=IVMDT,X2=14 D C^%DTC S UPLDT=$G(X) + ...S ^TMP("IVMLDEM9",$J,DTDIFF,SSN,IVMDA)=$G(NAME)_"^"_$P(IVMDT,".")_"^"_$P(UPLDT,".")_"^"_DFN_"^"_IVMDA2_"^"_IVMDA1 + Q + ; +AUTOLOAD(DFN,IVMDA2,IVMDA1) ;auto-upload records that not been reviewed + ; this tag is called from ^IVMLDEMC + ; + Q:('$G(DFN))!('$G(IVMDA2))!('$G(IVMDA1)) + N IVMI,IVMJ,IVMFIELD,IVMVALUE,IVMNODE,IVMFLAG,DUZ + S DUZ="IVM AUTO ADDR JOB" + ; + ; determine appropriate address change dt/tm to be used + D ADDRDT^IVMLDEM6(DFN,IVMDA2,IVMDA1) + ; + N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR) + ; + ; loop through the record to be uploaded + S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D + .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D + ..; + ..; check for data node in (#301.511) sub-file + ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) + ..Q:('+IVMNODE)!($P(IVMNODE,"^",2)']"") + ..; + ..; check for residence phone number -> do not auto-upload + ..Q:(+IVMNODE=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0))) + ..; + ..; do not auto-upload if there is an active prescription + ..I $$PHARM^IVMLDEM6(+DFN) D REJTADD Q + ..; + ..; set upload parameters + ..S IVMFIELD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5) + ..S IVMVALUE=$P(IVMNODE,"^",2) + ..; + ..; load addr field into the Patient (#2) file + ..D UPLOAD^IVMLDEM6(DFN,IVMFIELD,IVMVALUE) S IVMFLAG=1 + ..; + ..; remove entry from (#301.511) sub-file + ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ) + ..; + ..; if no display or uploadable fields, delete PID segment + ..I ('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0))&('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)) D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") + ; + I +$G(IVMFLAG) D + .N DGCURR + .D GETUPDTS^DGADDUTL(DFN,.DGCURR) + .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR) + Q +REJTADD ;Reject the address + ; update the ADDRESS CHANGE DT/TM field #.118 in PATIENT file #2 + D UPDDTTM^DGADDUTL(DFN,"PERM") + ; + ; trigger the record to transmit the existing address on file to HEC + N DGENUPLD ; Used in SETSTAT^IVMPLOG to prevent filing. + N DA,X,IVMX + S (DA,X)=DFN + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX + Q +PRINT ;report output + N DAYS,SSN,DATA,EX,PAGE,IVMDA,DATA,IVMLN,XMY,XMSUB,XMDUZ,XMTEXT + D LOOP("",0) + D HDR + D DISPLAY + D EMAIL + Q +DISPLAY ;Display the report + S DAYS="" + I '$D(^TMP("IVMLDEM9",$J)) Q + F S DAYS=$O(^TMP("IVMLDEM9",$J,DAYS),-1) Q:DAYS=""!($G(EX)) D + .S SSN="" + .F S SSN=$O(^TMP("IVMLDEM9",$J,DAYS,SSN)) Q:SSN=""!($G(EX)) D + ..S IVMDA="" + ..F S IVMDA=$O(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) Q:(IVMDA="")!($G(EX)) D + ...S DATA=$G(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) + ... D LNPLUS + ... S ^TMP($J,"IVMLDEM9",IVMLN)=" "_$$FMTE^XLFDT($P(DATA,"^",3))_" "_$$FMTE^XLFDT($P(DATA,"^",2))_" "_SSN_" "_$P(DATA,"^") + ... S ^TMP($J,"IVMLDEM9","TOTAL")=$G(^TMP($J,"IVMLDEM9","TOTAL"))+1 + D TOTAL + D + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)=" <>" + I $E(IOST)="C" W ! K DIR S DIR(0)="E" D ^DIR K DIR + Q +HDR ;print header + N IVMDT,Y,DLINE + I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,EX)=1 Q + S Y=DT X ^DD("DD") S IVMDT=Y + D + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)=" IVM ADDRESS UPDATES PENDING REVIEW "_IVMDT + . D LNPLUS + . S $P(^TMP($J,"IVMLDEM9",IVMLN),"=",78)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)=" Auto-Upload Date Date Received SSN Patient Name" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)=" ---------------- ------------- --------- ------------" + Q +EXIT D ^%ZISC,HOME^%ZIS Q + K ^TMP($J,"IVMLDEM9") + K ^TMP("IVMLDEM9",$J) + ; +ADRDTCK(DFN,IVMDA2,IVMDA1) ;is the incoming address older than #2 address? + Q:'$G(DFN)!('$G(IVMDA2))!('$G(IVMDA1)) "0^MISSING INPUT PARAMETER" + N OADDRDT,NADDRDT,ERR,IVMDA,IEN92,IENS + S OADDRDT=$$GET1^DIQ(2,DFN_",",.118,"I","","ERR") Q:$D(ERR) "0^OLD ADDR ERROR" + S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92 "0^BAD #301.92 ENTRY FOR RF171" + I '$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92)) Q "0^ADDR DT NOT PRESENT" + S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA "0^MISSING ADDR DT IN 301.5" + S IENS=IVMDA_","_IVMDA1_","_IVMDA2_"," + S NADDRDT=$$GET1^DIQ(301.511,IENS,.02,"I","","ERR") Q:$D(ERR) "0^NEW ADDR ERROR" + Q:(OADDRDT="")&(NADDRDT="") 0 + Q:(NADDRDT="")!(OADDRDT'0),('$$GOTLOCAL^XMXAPIG("IVM ADDR UPDT REPORT")) S RESULT=0 + Q RESULT +EMAIL ;Set up parameters to email the report + ;If called within a task, protect variables + I $D(ZTQUEUED) N %,DIFROM + N RDT + D NOW^%DTC S Y=% X ^DD("DD") + S RDT=$P(Y,"@",1)_"@"_$P($P(Y,"@",2),":",1,2) + S XMSUB="IVM Address Pending Review ("_RDT_")" + S XMY("G.IVM ADDR UPDT REPORT")="" + I $G(^TMP($J,"IVMLDEM9","TOTAL"))<1 D + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="*** NO RECORDS TO PRINT ***" + S XMTEXT="^TMP($J,""IVMLDEM9""," + D ^XMD + Q +QUE ;Que the task if user invokes option + N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR,IOP + W ! + S ZTIO="" + S ZTRTN="PRINT^IVMLDEM9" + S ZTDESC="IVM AUTO ADDRESS UPLOAD RPT" + D ^%ZTLOAD + D ^%ZISC,HOME^%ZIS + W !,$S($D(ZTSK):"REQUEST QUEUED AS TASK#"_ZTSK,1:"REQUEST CANCELLED!") + Q +TOTAL ;Display record total on the report + N IVMTOTAL + S IVMTOTAL=$G(^TMP($J,"IVMLDEM9","TOTAL")) + D + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="TOTAL RECORD(S): "_$G(IVMTOTAL) + Q +LNPLUS ;Increase line number for the email text + S IVMLN=$G(IVMLN)+1 + Q Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ072.m =================================================================== --- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ072.m (revision 613) +++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ072.m (revision 623) @@ -1,69 +1,68 @@ -IVMZ072 ;BAJ/PHH - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE II ; 05/22/08 - ;;2.0;INCOME VERIFICATION MATCH;**105,130**;JUL 8,1996;Build 2 - ; - ; - ; This routine supports the IVMZ07C consistency checker routines. -LOADSD(DFN,DGSD) ; Load spouse & dependent data into array - ; We will need to look at the Patient Relationship file to determine the spouse(s) and dependents for the patient - ; from the Patient Relation file ^DGPR(408.12) This file will point to an IEN in the Income Person file. - ; Next, we will load all of the spouse(s) and dependents from the Income Person file into the array. - N NIEN,IEN,RIEN,NODE,I,ENODE - ; look into Patient Relation file #408.12. Here we will find a pointer to each relation. And the record itself will - ; contain a pointer into the INCOME PERSON file (#408.13) - ; - ;Global ^DGPR(408.12,,DFN - ;^DGPR(408.12,"B",9999955601,3206)= - ; 3210)= <<------| - ; 3211)= | - ; 3212)= | - ; ] - ;Global ^DGPR(408.12,3210 <<------------ - ;^DGPR(408.12,3210,0)=9999955601^2^7170758;DGPR(408.13, - ;^DGPR(408.12,3210,"E",0)=^408.1275D^1^1 | - ;^DGPR(408.12,3210,"E",1,0)=2560406^1 | - ;^DGPR(408.12,3210,"E","AID",-2560406,1)= | - ;^DGPR(408.12,3210,"E","B",2560406,1)= | - ; | - ; | - ;Global ^DGPR(408.13,7170758 <<-------------- - ;^DGPR(408.13,7170758,0)=XXXXXX,XXXX SPOUSE^F^2560406^^^^^^174040656P^N - ; 1)=XXXXX,XXXX^^^^^^^ - ; - I '$D(^DGPR(408.12,"B",DFN)) Q - S NIEN="" F S NIEN=$O(^DGPR(408.12,"B",DFN,NIEN)) Q:NIEN="" D - . Q:'$D(^DGPR(408.12,NIEN,0)) - . S IEN=$P(^DGPR(408.12,NIEN,0),U,3) - . ; an entry in DPT is the patient. we only need relations - . Q:$P(IEN,";",2)["DPT"!'IEN - . Q:'$$ACTIF(NIEN,.ENODE) ;include only Active dependents - . S RIEN=$P(IEN,";",1),NODE=$P(IEN,";",2) - . S NODE=U_NODE,NODE=NODE_RIEN_")" - . Q:'$D(@NODE) - . S DGSD("DEP",RIEN,"EFF")=ENODE - . S DGSD("DEP",RIEN)=$P(^DGPR(408.12,NIEN,0),U,2) - . M DGSD("DEP",RIEN)=@NODE - Q - ; -ACTIF(NIEN,ENODE) ;determine if record in ^DGPR(408.12) is currently active. If active, populate variable ENODE with Effective Date. - ; This API should be called something like this I $$ACTIF^IVMZ072(NIEN,.ENODE)... - ; Input: - ; NIEN = IEN of ^DGPR(408.12) reference - ; ENODE = Variable to contain Effective Date - ; - ; Populates: - ; ENODE = With the most recent effective date of changes - ; - ; Returns: - ; ACTIVE flag - ; 1 = Active - ; 0 = Inactive - ; - N ROOT,ACTDAT,INDEX,ACTIVE,EFF - S ACTIVE=0 - D Q ACTIVE - . S ROOT=$O(^DGPR(408.12,NIEN,"E","AID","")) Q:ROOT="" - . S INDEX=$O(^DGPR(408.12,NIEN,"E","AID",ROOT,"")) Q:INDEX="" - . S ACTDAT=^DGPR(408.12,NIEN,"E",INDEX,0) - . S ACTIVE=$P(ACTDAT,"^",2),ENODE=$P(ACTDAT,"^",1) - Q ACTIVE - ; +IVMZ072 ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE II ; 09/27/06 + ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 + ; + ; + ; This routine supports the IVMZ07C consistency checker routines. +LOADSD(DFN,DGSD) ; Load spouse & dependent data into array + ; We will need to look at the Patient Relationship file to determine the spouse(s) and dependents for the patient + ; from the Patient Relation file ^DGPR(408.12) This file will point to an IEN in the Income Person file. + ; Next, we will load all of the spouse(s) and dependents from the Income Person file into the array. + N NIEN,IEN,RIEN,NODE,I,ENODE + ; look into Patient Relation file #408.12. Here we will find a pointer to each relation. And the record itself will + ; contain a pointer into the INCOME PERSON file (#408.13) + ; + ;Global ^DGPR(408.12,,DFN + ;^DGPR(408.12,"B",9999955601,3206)= + ; 3210)= <<------| + ; 3211)= | + ; 3212)= | + ; ] + ;Global ^DGPR(408.12,3210 <<------------ + ;^DGPR(408.12,3210,0)=9999955601^2^7170758;DGPR(408.13, + ;^DGPR(408.12,3210,"E",0)=^408.1275D^1^1 | + ;^DGPR(408.12,3210,"E",1,0)=2560406^1 | + ;^DGPR(408.12,3210,"E","AID",-2560406,1)= | + ;^DGPR(408.12,3210,"E","B",2560406,1)= | + ; | + ; | + ;Global ^DGPR(408.13,7170758 <<-------------- + ;^DGPR(408.13,7170758,0)=XXXXXX,XXXX SPOUSE^F^2560406^^^^^^174040656P^N + ; 1)=XXXXX,XXXX^^^^^^^ + ; + I '$D(^DGPR(408.12,"B",DFN)) Q + S NIEN="" F S NIEN=$O(^DGPR(408.12,"B",DFN,NIEN)) Q:NIEN="" D + . S IEN=$P(^DGPR(408.12,NIEN,0),U,3) + . ; an entry in DPT is the patient. we only need relations + . Q:$P(IEN,";",2)["DPT" + . Q:'$$ACTIF(NIEN,.ENODE) ;include only Active dependents + . S RIEN=$P(IEN,";",1),NODE=$P(IEN,";",2) + . S NODE=U_NODE,NODE=NODE_RIEN_")" + . Q:'$D(@NODE) + . S DGSD("DEP",RIEN,"EFF")=ENODE + . S DGSD("DEP",RIEN)=$P(^DGPR(408.12,NIEN,0),U,2) + . M DGSD("DEP",RIEN)=@NODE + Q + ; +ACTIF(NIEN,ENODE) ;determine if record in ^DGPR(408.12) is currently active. If active, populate variable ENODE with Effective Date. + ; This API should be called something like this I $$ACTIF^IVMZ072(NIEN,.ENODE)... + ; Input: + ; NIEN = IEN of ^DGPR(408.12) reference + ; ENODE = Variable to contain Effective Date + ; + ; Populates: + ; ENODE = With the most recent effective date of changes + ; + ; Returns: + ; ACTIVE flag + ; 1 = Active + ; 0 = Inactive + ; + N ROOT,ACTDAT,INDEX,ACTIVE,EFF + S ACTIVE=0 + D Q ACTIVE + . S ROOT=$O(^DGPR(408.12,NIEN,"E","AID","")) Q:ROOT="" + . S INDEX=$O(^DGPR(408.12,NIEN,"E","AID",ROOT,"")) Q:INDEX="" + . S ACTDAT=^DGPR(408.12,NIEN,"E",INDEX,0) + . S ACTIVE=$P(ACTDAT,"^",2),ENODE=$P(ACTDAT,"^",1) + Q ACTIVE + ; Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m =================================================================== --- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m (revision 613) +++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m (revision 623) @@ -1,181 +1,182 @@ -IVMZ07C ;BAJ/PHH - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE ; 1/17/2008 - ;;2.0;INCOME VERIFICATION MATCH;**105,128**;JUL 8,1996;Build 2 - ; - ; - ; This routine calls various checking subroutines and manages arrays and data filing - ; for inconsistency checking prior to building a Z07 HL7 record. This routine returns - ; a value and must be called as an API: - ; - ; I '$$EN^IVMZ07C(DFN) Q - ; - ; Values returned: - ; 0 = Fail: inconsistencies found, do not build Z07 record - ; 1 = Pass: No inconsistencies found, Ok to build Z07 record - ; - ; Must be called from entry point - Q - ; -EN(DFN) ; entry point. Patient DFN is sent from calling routine. - ; initialize working variables - N PASS,DGP,DGSD,U - S U="^" - ; - ; Input: DFN = ^DPT(DFN) of record to check - ; BATCH = 1 batch/background job records should be counted - ; = 0 single job, do not count records - ; structure: - ; 1. delete existing Z07 inconsistencies - ; 2. load data arrays - ; 3. call subroutines - ; 4. check for Pass/Fail - ; 5. update file 38.5 if necessary - ; 6. return Pass/Fail - ; - ; Set flag - S PASS=0 - I '$D(^DPT(DFN)) Q PASS - S PASS=1 - ; - ; Load Patient and Spouse/dependent data - D LOADPT(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD) - ; - ; Do checks and file inconsistencies - D WORK(DFN,.DGP,.DGSD) - ; - ; Delete old Inconsistency info - D DELETE(DFN) - ; - ; File new inconsistencies if necessary - I $$FILE(DFN) S PASS=0 - ; - ; update counters - D COUNT(PASS) - ; - ; return pass/fail flag - Q PASS - ; -COUNT(PASS) ; counter for batch run - N I - ; Set it up the first time through - I '$D(^TMP($J,"CC")) D - . F I=0,1 S ^TMP($J,"CC",I)=0 - ; - ; Increment Batch counter - S ^TMP($J,"CC",PASS)=^TMP($J,"CC",PASS)+1 - Q - ; -LOADPT(DFN,DGP) ; load patient data into arrays - N NIEN,IEN,I,DTTM,NAMCOM,NAME - ; we need to load data from the following files - ; Patient File 2 - ; Name Components 20 - ; Patient Enrollment 27.11 - ; Means test file 408.31 - ; MST History file 29.11 - ; Note: we also need Catastrophic data info, but that subroutine loads its own data array. - ; - ; *************************** - ; DGP("PAT") Patient file - F I=0,.3,.15,.29,.31,.32,.321,.322,.35,.36,.361,.38,.52,"SSN","TYPE","VET" S DGP("PAT",I)=$G(^DPT(DFN,I)) - S NAME=$P($G(^DPT(DFN,0)),"^",1),NAMCOM=$P($G(^DPT(DFN,"NAME")),"^",1)'="" - ; - ; *************************** - ; DGP("NAME") Name Components - I NAMCOM S NIEN=$P(^DPT(DFN,"NAME"),U,1) I '$D(^VA(20,NIEN,1)) S NAMCOM=0 - S DGP("NAME",1)=$S(NAMCOM:$G(^VA(20,NIEN,1)),1:$P(NAME,",")_"^"_$P($P(NAME,",",2)," ",1)_"^"_$P($P(NAME,",",2)," ",2)) - ; - ; *************************** - ; - ; DGP("ENR") Patient Enrollment - S NIEN="",NIEN=$P($G(^DPT(DFN,"ENR")),U,1) - I NIEN]"",$D(^DGEN(27.11,NIEN)) M DGP("ENR")=^DGEN(27.11,NIEN) - ; - ; *************************** - ; DGP("MEANS") Means Test - S NIEN=+$$LST^DGMTU(DFN) I NIEN,$D(^DGMT(408.31,NIEN,0)) S DGP("MEANS",0)=^DGMT(408.31,NIEN,0) - ; - ; *************************** - ; DGP("MST") MST History - S (DTTM,NIEN)="" - S DTTM=$O(^DGMS(29.11,"APDT",DFN,""),-1) - I DTTM'="" D - . S NIEN=$O(^DGMS(29.11,"APDT",DFN,DTTM,""),-1) - . I $D(^DGMS(29.11,NIEN,0)) S DGP("MST",0)=^DGMS(29.11,NIEN,0) - ; - ; *************************** - Q - ; -WORK(DFN,DGP,DGSD) ; - ; call subroutines to run rules and file any inconsistencies - ; - ; Demographics rules - D EN^IVMZ7CD(DFN,.DGP,.DGSD) - ; - ; Enrollment/Eligibility rules - D EN^IVMZ7CE(DFN,.DGP) - ; - ; Service rules - D EN^IVMZ7CS(DFN,.DGP) - ; - ; Catastrophic Disability rules - D EN^IVMZ7CCD(DFN) - ; - ; Registration Inconsistencies - D EN^IVMZ7CR(DFN,.DGP,.DGSD) - ; - Q - ; -DELETE(DFN) ; delete all Z07 inconsistencies from INCONSISTENT DATA file (#38.5). Since we're not sure which rules - ; will block a Z07 record, we need to loop through the INCONSISTENT DATA ELEMENTS file (#38.6) and grab only - ; those rules which are marked to prevent building a Z07 record: - ; - ; - N DELARRY,RULE,DIK,DA - ; - ; create an array of rules which prevent Z07 records - S RULE=0 F S RULE=$O(^DGIN(38.6,RULE)) Q:RULE="" Q:$A(RULE)>$A(9) D - . I '$P(^DGIN(38.6,RULE,0),U,5),$P(^DGIN(38.6,RULE,0),U,6) S DELARRY(RULE)="" - ; - ; Now we have to check the patient INCONSISTENT DATA file (#38.5) and delete any records which have to be rechecked. - ; - S DIK="^DGIN(38.5,"_DFN_","_"""I"""_"," - ; - S DA="" F S DA=$O(DELARRY(DA)) Q:DA="" D ^DIK - Q - ; -FILE(DFN) ; - N FILE,SUCCESS,CCS,I,DGENDA,DATA,SUBFILE,DIK,DA - S FILE=38.5,CCS=0 - ; if no inconsistencies, return 0 - I '$D(^TMP($J,DFN)) D Q CCS - . ; clean up INCONSISTENT DATA file if no inconsistencies exist - . I '$P($G(^DGIN(38.5,DFN,"I",0)),"^",4) D - . . S DIK="^DGIN(38.5,",DA=DFN - . . D ^DIK - ; - ; else process inconsistencies and return PASS=0 - S CCS=1 - ; if a new entry, create a stub - S DATA(.01)=DFN - I '$D(^DGIN(FILE,"B",DFN)) D - . S DATA(2)=$$DT^XLFDT,DATA(3)=.5 - . S SUCCESS=$$ADD^DGENDBS(FILE,,.DATA,,DFN) - ; - ; update file header with data and user info. - ; Last Updated field (#4) = Today's date - ; Last Updated by field (#5) = Postmaster - S DGENDA=DFN,DATA(4)=$$DT^XLFDT,DATA(5)=.5 - S SUCCESS=$$UPD^DGENDBS(FILE,.DGENDA,.DATA) - ; - ; add inconsistencies to file - K DATA - S SUBFILE=38.51,DGENDA(1)=DFN - S I="" F S I=$O(^TMP($J,DFN,I)) Q:I="" D - . S (DATA(.01),DATA(.001),DGENDA)=I - . S SUCCESS=$$ADD^DGENDBS(SUBFILE,.DGENDA,.DATA) - ; - ; kill temp file before exit - K ^TMP($J,DFN) - ; - Q CCS - ; +IVMZ07C ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE ; 9/27/2006 + ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 + ; + ; + ; This routine calls various checking subroutines and manages arrays and data filing + ; for inconsistency checking prior to building a Z07 HL7 record. This routine returns + ; a value and must be called as an API: + ; + ; I '$$EN^IVMZ07C(DFN) Q + ; + ; Values returned: + ; 0 = Fail: inconsistencies found, do not build Z07 record + ; 1 = Pass: No inconsistencies found, Ok to build Z07 record + ; + ; Must be called from entry point + Q + ; +EN(DFN) ; entry point. Patient DFN is sent from calling routine. + ; initialize working variables + N PASS,DGP,DGSD,U + S U="^" + ; + ; Input: DFN = ^DPT(DFN) of record to check + ; BATCH = 1 batch/background job records should be counted + ; = 0 single job, do not count records + ; structure: + ; 1. delete existing Z07 inconsistencies + ; 2. load data arrays + ; 3. call subroutines + ; 4. check for Pass/Fail + ; 5. update file 38.5 if necessary + ; 6. return Pass/Fail + ; + ; Set flag + S PASS=0 + I '$D(^DPT(DFN)) Q PASS + S PASS=1 + ; + ; Load Patient and Spouse/dependent data + D LOADPT(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD) + ; + ; Do checks and file inconsistencies + D WORK(DFN,.DGP,.DGSD) + ; + ; Delete old Inconsistency info + D DELETE(DFN) + ; + ; File new inconsistencies if necessary + I $$FILE(DFN) S PASS=0 + ; + ; update counters + D COUNT(PASS) + ; + ; return pass/fail flag + Q PASS + ; +COUNT(PASS) ; counter for batch run + N I + ; Set it up the first time through + I '$D(^TMP($J,"CC")) D + . F I=0,1 S ^TMP($J,"CC",I)=0 + ; + ; Increment Batch counter + S ^TMP($J,"CC",PASS)=^TMP($J,"CC",PASS)+1 + Q + ; +LOADPT(DFN,DGP) ; load patient data into arrays + N NIEN,IEN,I,DTTM,NAMCOM,NAME + ; we need to load data from the following files + ; Patient File 2 + ; Name Components 20 + ; Patient Enrollment 27.11 + ; Means test file 408.31 + ; MST History file 29.11 + ; Note: we also need Catastrophic data info, but that subroutine loads its own data array. + ; + ; *************************** + ; DGP("PAT") Patient file + F I=0,.3,.15,.29,.31,.32,.321,.322,.35,.36,.361,.38,.52,"SSN","TYPE","VET" S DGP("PAT",I)=$G(^DPT(DFN,I)) + S NAME=$P($G(^DPT(DFN,0)),"^",1),NAMCOM=$P($G(^DPT(DFN,"NAME")),"^",1)'="" + ; + ; *************************** + ; DGP("NAME") Name Components + I NAMCOM S NIEN=$P(^DPT(DFN,"NAME"),U,1) I '$D(^VA(20,NIEN,1)) S NAMCOM=0 + S DGP("NAME",1)=$S(NAMCOM:$G(^VA(20,NIEN,1)),1:$P(NAME,",")_"^"_$P($P(NAME,",",2)," ",1)_"^"_$P($P(NAME,",",2)," ",2)) + ; + ; *************************** + ; + ; DGP("ENR") Patient Enrollment + S NIEN="",NIEN=$P($G(^DPT(DFN,"ENR")),U,1) + I NIEN]"",$D(^DGEN(27.11,NIEN)) M DGP("ENR")=^DGEN(27.11,NIEN) + ; + ; *************************** + ; DGP("MEANS") Means Test + S NIEN=+$$LST^DGMTU(DFN) I NIEN,$D(^DGMT(408.31,NIEN,0)) S DGP("MEANS",0)=^DGMT(408.31,NIEN,0) + ; + ; *************************** + ; DGP("MST") MST History + S (DTTM,NIEN)="" + S DTTM=$O(^DGMS(29.11,"APDT",DFN,""),-1) + I DTTM'="" D + . S DTTM=$O(^DGMS(29.11,"APDT",DFN,"")) + . S NIEN=$O(^DGMS(29.11,"APDT",DFN,DTTM,"")) + . I $D(^DGMS(29.11,NIEN,0)) S DGP("MST",0)=^DGMS(29.11,NIEN,0) + ; + ; *************************** + Q + ; +WORK(DFN,DGP,DGSD) ; + ; call subroutines to run rules and file any inconsistencies + ; + ; Demographics rules + D EN^IVMZ7CD(DFN,.DGP,.DGSD) + ; + ; Enrollment/Eligibility rules + D EN^IVMZ7CE(DFN,.DGP) + ; + ; Service rules + D EN^IVMZ7CS(DFN,.DGP) + ; + ; Catastrophic Disability rules + D EN^IVMZ7CCD(DFN) + ; + ; Registration Inconsistencies + D EN^IVMZ7CR(DFN,.DGP,.DGSD) + ; + Q + ; +DELETE(DFN) ; delete all Z07 inconsistencies from INCONSISTENT DATA file (#38.5). Since we're not sure which rules + ; will block a Z07 record, we need to loop through the INCONSISTENT DATA ELEMENTS file (#38.6) and grab only + ; those rules which are marked to prevent building a Z07 record: + ; + ; + N DELARRY,RULE,DIK,DA + ; + ; create an array of rules which prevent Z07 records + S RULE=0 F S RULE=$O(^DGIN(38.6,RULE)) Q:RULE="" Q:$A(RULE)>$A(9) D + . I '$P(^DGIN(38.6,RULE,0),U,5),$P(^DGIN(38.6,RULE,0),U,6) S DELARRY(RULE)="" + ; + ; Now we have to check the patient INCONSISTENT DATA file (#38.5) and delete any records which have to be rechecked. + ; + S DIK="^DGIN(38.5,"_DFN_","_"""I"""_"," + ; + S DA="" F S DA=$O(DELARRY(DA)) Q:DA="" D ^DIK + Q + ; +FILE(DFN) ; + N FILE,SUCCESS,CCS,I,DGENDA,DATA,SUBFILE,DIK,DA + S FILE=38.5,CCS=0 + ; if no inconsistencies, return 0 + I '$D(^TMP($J,DFN)) D Q CCS + . ; clean up INCONSISTENT DATA file if no inconsistencies exist + . I '$P($G(^DGIN(38.5,DFN,"I",0)),"^",4) D + . . S DIK="^DGIN(38.5,",DA=DFN + . . D ^DIK + ; + ; else process inconsistencies and return PASS=0 + S CCS=1 + ; if a new entry, create a stub + S DATA(.01)=DFN + I '$D(^DGIN(FILE,"B",DFN)) D + . S DATA(2)=$$DT^XLFDT,DATA(3)=.5 + . S SUCCESS=$$ADD^DGENDBS(FILE,,.DATA,,DFN) + ; + ; update file header with data and user info. + ; Last Updated field (#4) = Today's date + ; Last Updated by field (#5) = Postmaster + S DGENDA=DFN,DATA(4)=$$DT^XLFDT,DATA(5)=.5 + S SUCCESS=$$UPD^DGENDBS(FILE,.DGENDA,.DATA) + ; + ; add inconsistencies to file + K DATA + S SUBFILE=38.51,DGENDA(1)=DFN + S I="" F S I=$O(^TMP($J,DFN,I)) Q:I="" D + . S (DATA(.01),DATA(.001),DGENDA)=I + . S SUCCESS=$$ADD^DGENDBS(SUBFILE,.DGENDA,.DATA) + ; + ; kill temp file before exit + K ^TMP($J,DFN) + ; + Q CCS + ; Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m =================================================================== --- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m (revision 613) +++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m (revision 623) @@ -1,128 +1,128 @@ -IVMZ7CD ;CKN,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006 - ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6 - ; - ; Demographic Consistency Checks - ; This routine will be called from driver routine and it checks the - ; various elements of Person demographic information prior to - ; building a Z07 record. Any test which fails consistency check will - ; be saved in file 38.6 INCONSISTENT DATA ELEMENT record for Person. - ; - ;It is all facade - Q - ; -EN(DFN,DGP,DGSD) ;Entry point - ; input: DFN - Patient IEN - ; DGP - Patient data array - ; DGSD - Spouse and Dependent data array - ; output: ^TMP($J,DFN,RULE) global - ; DFN - Patient IEN - ; RULE - Consistency rule # - ;initializing variables - N RULE,Y,X,FILERR - ; - ; loop through rules in INCONSISTENT DATA ELEMENTS file. - ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 - ; CHECKS fields are turned ON. - ; - ; ***NOTE loop boundary (301-311) must be changed if rule numbers - ; are added *** - F RULE=301:1:312 I $D(^DGIN(38.6,RULE)) D - . S Y=^DGIN(38.6,RULE,0) - . I '$P(Y,"^",5),$P(Y,"^",6) D @RULE - I $D(FILERR) M ^TMP($J,DFN)=FILERR - Q - ; -301 ; PERSON LASTNAME REQUIRED - S X=$P($G(DGP("NAME",1)),U) I X="" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U) - . S X=$P(X,",") I X="" S FILERR(RULE)="" - Q - ; -302 ; DATE OF BIRTH REQUIRED - Duplicate with #4 - Q ;This tag needs to be removed after its placement in IVMZ7CR - S X=$P($G(DGP("PAT",0)),U,3) I X="" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U,3) I X="" S FILERR(RULE)="" - Q - ; -303 ; GENDER REQUIRED - S X=$P($G(DGP("PAT",0)),U,2) I X="" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U,2) I X="" S FILERR(RULE)="" - Q - ; -304 ; GENDER INVALID - S X=$P($G(DGP("PAT",0)),U,2) I X]"",X'="M",X'="F" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U,2) - . I X]"",X'="M",X'="F" S FILERR(RULE)="" - Q - ; -305 ; VETERAN SSN MISSING - Duplicate with #7 - Q ;This tag needs to be removed after its placement in IVMZ7CR - S X=$P($G(DGP("PAT",0)),U,9) I X="" S FILERR(RULE)="" - Q - ; -306 ; VALID SSN/PSEUDO SSN REQUIRED, turned off with DG*5.3*771 - N Z - S X=$P($G(DGP("PAT",0)),U,9) - Q:X="" ;quit if no SSN - Q:$E(X,$L(X))="P" ;quit if SSN is a Pseudo - I $E(X,1,5)="00000" S FILERR(RULE)="" ;First 5 number are zero - S $P(Z,$E(X),9)=$E(X) I X=Z S FILERR(RULE)="" ;all numbers are same - I $E(X,1,3)="000" S FILERR(RULE)="" ;First 3 digits are zeros - I $E(X,4,5)="00" S FILERR(RULE)="" ;4th & 5th are zeros - I $E(X,6,9)="0000" S FILERR(RULE)="" ;Last 4 digits are zeros - I X=123456789 S FILERR(RULE)="" ;SSN is 123456789 - I X>728999999 S FILERR(RULE)="" ;SSN is greater than 728999999 - Q - ; -307 ; PSEUDO SSN REASON REQUIRED, turned off with DG*5.3*771 - S X=$P($G(DGP("PAT",0)),U,9) - I X]"",X["P",$P($G(DGP("PAT","SSN")),U)="" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U,9) - . I X]"",X["P",$P(DGSD("DEP",RIEN,0),U,10)="" S FILERR(RULE)="" - Q - ; -308 ; DATE OF DEATH BEFORE DOB - S X=$P($G(DGP("PAT",.35)),U) I X']"" Q - I X<$P($G(DGP("PAT",0)),U,3) S FILERR(RULE)="" - Q - ; -309 ; PATIENT RELATIONSHIP INVALID - N DEPSEX,RELSEX,DEPREL - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S DEPREL=$G(DGSD("DEP",RIEN)) - . I DEPREL="" S FILERR(RULE)="" Q - . I '$D(^DG(408.11,DEPREL)) S FILERR(RULE)="" Q - . S DEPSEX=$P(DGSD("DEP",RIEN,0),U,2) - . S RELSEX=$P(^DG(408.11,DEPREL,0),U,3) - . I RELSEX="E" Q ;Gender for relation can be either - . I DEPSEX'=RELSEX S FILERR(RULE)="" - Q - ; -310 ; DEPENDENT EFF. DATE REQUIRED - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$G(DGSD("DEP",RIEN,"EFF")) I 'X S FILERR(RULE)="" - Q - ; -311 ; DATE OF DEATH IS FUTURE DATE - Duplicate with #16 - Q ;This tag needs to be removed after its placement in IVMZ7CR - S X=$P($G(DGP("PAT",.35)),U) - I X]"",X>$$NOW^XLFDT() S FILERR(RULE)="" - Q - ; -312 ; PERSON MUST HAVE NATIONAL ICN - I $$GETICN^MPIF001(DFN)<0 S FILERR(RULE)="" Q ;No ICN - I $$IFLOCAL^MPIF001(DFN)=1 S FILERR(RULE)="" ;Not National ICN - Q - ; +IVMZ7CD ;CKN,BAJ - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006 + ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 + ; + ; Demographic Consistency Checks + ; This routine will be called from driver routine and it checks the + ; various elements of Person demographic information prior to + ; building a Z07 record. Any test which fails consistency check will + ; be saved in file 38.6 INCONSISTENT DATA ELEMENT record for Person. + ; + ;It is all facade + Q + ; +EN(DFN,DGP,DGSD) ;Entry point + ; input: DFN - Patient IEN + ; DGP - Patient data array + ; DGSD - Spouse and Dependent data array + ; output: ^TMP($J,DFN,RULE) global + ; DFN - Patient IEN + ; RULE - Consistency rule # + ;initializing variables + N RULE,Y,X,FILERR + ; + ; loop through rules in INCONSISTENT DATA ELEMENTS file. + ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 + ; CHECKS fields are turned ON. + ; + ; ***NOTE loop boundary (301-311) must be changed if rule numbers + ; are added *** + F RULE=301:1:312 I $D(^DGIN(38.6,RULE)) D + . S Y=^DGIN(38.6,RULE,0) + . I '$P(Y,"^",5),$P(Y,"^",6) D @RULE + I $D(FILERR) M ^TMP($J,DFN)=FILERR + Q + ; +301 ; PERSON LASTNAME REQUIRED + S X=$P($G(DGP("NAME",1)),U) I X="" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U) + . S X=$P(X,",") I X="" S FILERR(RULE)="" + Q + ; +302 ; DATE OF BIRTH REQUIRED - Duplicate with #4 + Q ;This tag needs to be removed after its placement in IVMZ7CR + S X=$P($G(DGP("PAT",0)),U,3) I X="" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U,3) I X="" S FILERR(RULE)="" + Q + ; +303 ; GENDER REQUIRED + S X=$P($G(DGP("PAT",0)),U,2) I X="" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U,2) I X="" S FILERR(RULE)="" + Q + ; +304 ; GENDER INVALID + S X=$P($G(DGP("PAT",0)),U,2) I X]"",X'="M",X'="F" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U,2) + . I X]"",X'="M",X'="F" S FILERR(RULE)="" + Q + ; +305 ; VETERAN SSN MISSING - Duplicate with #7 + Q ;This tag needs to be removed after its placement in IVMZ7CR + S X=$P($G(DGP("PAT",0)),U,9) I X="" S FILERR(RULE)="" + Q + ; +306 ; VALID SSN/PSEUDO SSN REQUIRED + N Z + S X=$P($G(DGP("PAT",0)),U,9) + Q:X="" ;quit if no SSN + Q:$E(X,$L(X))="P" ;quit if SSN is a Pseudo + I $E(X,1,5)="00000" S FILERR(RULE)="" ;First 5 number are zero + S $P(Z,$E(X),9)=$E(X) I X=Z S FILERR(RULE)="" ;all numbers are same + I $E(X,1,3)="000" S FILERR(RULE)="" ;First 3 digits are zeros + I $E(X,4,5)="00" S FILERR(RULE)="" ;4th & 5th are zeros + I $E(X,6,9)="0000" S FILERR(RULE)="" ;Last 4 digits are zeros + I X=123456789 S FILERR(RULE)="" ;SSN is 123456789 + I X>728999999 S FILERR(RULE)="" ;SSN is greater than 728999999 + Q + ; +307 ; PSEUDO SSN REASON REQUIRED + S X=$P($G(DGP("PAT",0)),U,9) + I X]"",X["P",$P($G(DGP("PAT","SSN")),U)="" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U,9) + . I X]"",X["P",$P(DGSD("DEP",RIEN,0),U,10)="" S FILERR(RULE)="" + Q + ; +308 ; DATE OF DEATH BEFORE DOB + S X=$P($G(DGP("PAT",.35)),U) I X']"" Q + I X<$P($G(DGP("PAT",0)),U,3) S FILERR(RULE)="" + Q + ; +309 ; PATIENT RELATIONSHIP INVALID + N DEPSEX,RELSEX,DEPREL + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S DEPREL=$G(DGSD("DEP",RIEN)) + . I DEPREL="" S FILERR(RULE)="" Q + . I '$D(^DG(408.11,DEPREL)) S FILERR(RULE)="" Q + . S DEPSEX=$P(DGSD("DEP",RIEN,0),U,2) + . S RELSEX=$P(^DG(408.11,DEPREL,0),U,3) + . I RELSEX="E" Q ;Gender for relation can be either + . I DEPSEX'=RELSEX S FILERR(RULE)="" + Q + ; +310 ; DEPENDENT EFF. DATE REQUIRED + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$G(DGSD("DEP",RIEN,"EFF")) I 'X S FILERR(RULE)="" + Q + ; +311 ; DATE OF DEATH IS FUTURE DATE - Duplicate with #16 + Q ;This tag needs to be removed after its placement in IVMZ7CR + S X=$P($G(DGP("PAT",.35)),U) + I X]"",X>$$NOW^XLFDT() S FILERR(RULE)="" + Q + ; +312 ; PERSON MUST HAVE NATIONAL ICN + I $$GETICN^MPIF001(DFN)<0 S FILERR(RULE)="" Q ;No ICN + I $$IFLOCAL^MPIF001(DFN)=1 S FILERR(RULE)="" ;Not National ICN + Q + ; Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m =================================================================== --- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m (revision 613) +++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m (revision 623) @@ -1,86 +1,85 @@ -IVMZ7CE ;TDM,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 12/4/07 2:56pm - ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6 - ; - ; Eligibility Consistency Checks - ; This routine checks the various elements of service information - ; prior to building a Z07 record. Any tests which fail consistency - ; check will be saved to the ^DGIN(38.6 record for the patient. - ; - ; Must be called from entry point - Q - ; -EN(DFN,DGP) ; entry point. Patient DFN is sent from calling routine. - ; initialize working variables - N RULE,Y,X,FILERR - ; - ; loop through rules in INCONSISTENT DATA ELEMENTS file. - ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 - ; CHECKS fields are turned ON. - ; - ; ***NOTE loop boundary (401-413) must be changed if rule numbers - ; are added *** - F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D - . S Y=^DGIN(38.6,RULE,0) - . I '$P(Y,U,5),$P(Y,U,6) D @RULE - I $D(FILERR) M ^TMP($J,DFN)=FILERR - Q - ; -401 ; RATED INCOMPETENT INVALID - S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" - Q - ; -402 ; ELIGIBLE FOR MEDICAID INVALID - S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" - Q - ; -403 ; DT MEDICAID LAST ASKED INVALID - I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)="" - Q - ; -404 ; INELIGIBLE REASON INVALID - ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule - Q - ; -405 ; NON VETERAN ELIG CODE INVALID - ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule - Q - ; -406 ; CLAIM FOLDER NUMBER INVALID - S X=$P(DGP("PAT",.31),U,3) - I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)="" - Q - ; -407 ; ELIGIBILITY STATUS INVALID - S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)="" - Q - ; -408 ; DECLINE TO GIVE INCOME INVALID - ; This CC removed per customer 05/08/2006 -- BAJ - ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)="" - Q - ; -409 ; AGREE TO PAY DEDUCT INVALID - ; this CC inactivated by DG*5.3*771 - ; 2 PENDING ADJUDICATION MEANS TEST - ; 6 MT COPAY REQUIRED MEANS TEST - ;16 GMT COPAY REQUIRED MEANS TEST - I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D - . S X=$P(DGP("MEANS",0),U,3) - . I (X=2)!(X=6) S FILERR(RULE)="" Q - . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)="" - Q - ; -410 ; Note: RULE #404 above is a duplicate of this rule - Q - ; -411 ; ENROLLMENT APP DATE INVALID - I $D(DGP("ENR",0)) S X=$P(DGP("ENR","0"),U) I ($E(X,1,3)<1)!($E(X,4,5)<1)!($E(X,6,7)<1) S FILERR(RULE)="" - Q - ; -412 ; POS/ELIG CODE INVALID - ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule - Q - ; -413 ; POS INVALID - ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule - Q +IVMZ7CE ;TDM,BAJ - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 01/23/07 + ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 + ; + ; Eligibility Consistency Checks + ; This routine checks the various elements of service information + ; prior to building a Z07 record. Any tests which fail consistency + ; check will be saved to the ^DGIN(38.6 record for the patient. + ; + ; Must be called from entry point + Q + ; +EN(DFN,DGP) ; entry point. Patient DFN is sent from calling routine. + ; initialize working variables + N RULE,Y,X,FILERR + ; + ; loop through rules in INCONSISTENT DATA ELEMENTS file. + ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 + ; CHECKS fields are turned ON. + ; + ; ***NOTE loop boundary (401-413) must be changed if rule numbers + ; are added *** + F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D + . S Y=^DGIN(38.6,RULE,0) + . I '$P(Y,U,5),$P(Y,U,6) D @RULE + I $D(FILERR) M ^TMP($J,DFN)=FILERR + Q + ; +401 ; RATED INCOMPETENT INVALID + S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" + Q + ; +402 ; ELIGIBLE FOR MEDICAID INVALID + S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" + Q + ; +403 ; DT MEDICAID LAST ASKED INVALID + I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)="" + Q + ; +404 ; INELIGIBLE REASON INVALID + ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule + Q + ; +405 ; NON VETERAN ELIG CODE INVALID + ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule + Q + ; +406 ; CLAIM FOLDER NUMBER INVALID + S X=$P(DGP("PAT",.31),U,3) + I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)="" + Q + ; +407 ; ELIGIBILITY STATUS INVALID + S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)="" + Q + ; +408 ; DECLINE TO GIVE INCOME INVALID + ; This CC removed per customer 05/08/2006 -- BAJ + ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)="" + Q + ; +409 ; AGREE TO PAY DEDUCT INVALID + ; 2 PENDING ADJUDICATION MEANS TEST + ; 6 MT COPAY REQUIRED MEANS TEST + ;16 GMT COPAY REQUIRED MEANS TEST + I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D + . S X=$P(DGP("MEANS",0),U,3) + . I (X=2)!(X=6) S FILERR(RULE)="" Q + . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)="" + Q + ; +410 ; Note: RULE #404 above is a duplicate of this rule + Q + ; +411 ; ENROLLMENT APP DATE INVALID + I $D(DGP("ENR",0)) S X=$P(DGP("ENR","0"),U) I ($E(X,1,3)<1)!($E(X,4,5)<1)!($E(X,6,7)<1) S FILERR(RULE)="" + Q + ; +412 ; POS/ELIG CODE INVALID + ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule + Q + ; +413 ; POS INVALID + ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule + Q Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m =================================================================== --- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m (revision 613) +++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m (revision 623) @@ -1,249 +1,250 @@ -IVMZ7CR ;BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/6/07 8:51am - ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6 - ; - ; Registration Consistency Checks - Q ; Entry point must be specified -EN(DFN,DGP,DGSD) ;Entry point - ; input: DFN - Patient IEN - ; DGP - Patient data array - ; DGSD - Spouse and Dependent data array - ; output: ^TMP($J,DFN,RULE) global - ; DFN - Patient IEN - ; RULE - Consistency rule # - ;initialize variables - N RULE,Y,X,FILERR,SPDEP - S SPDEP=$D(DGSD("DEP")) - ; we do not count through all numbers to save routine space - F RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,75,76,78,81,83,85,86 I $D(^DGIN(38.6,RULE)) D - . I $$ON(RULE) D @RULE - I $D(FILERR) M ^TMP($J,DFN)=FILERR - Q -4 ; DOB UNSPECIFIED - ; Note: RULE #302 in IVMZ7CD is a duplicate of this rule - N RIEN - I $P($G(DGP("PAT",0)),U,3)="" S FILERR(RULE)="" - I 'SPDEP Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . I $P(DGSD("DEP",RIEN,0),U,3)="" S FILERR(RULE)="" - Q -7 ; SSN UNSPECIFIED - ; Note: RULE #305 in IVMZ7CD is a duplicate of this rule - I $P($G(DGP("PAT",0)),U,9)="" S FILERR(RULE)="" - Q -9 ; VETERAN STATUS UNSPECIFIED - I $P($G(DGP("PAT","VET")),U)="" S FILERR(RULE)="" - Q -11 ; SC PROMPT INCONSISTENT - N VET,SC,PTYPE - ; If VET Status is not specified (RULE 9) no need for this test - Q:$P($G(DGP("PAT","VET")),U)="" - S VET=$P(DGP("PAT","VET"),U,1)="Y",SC=$P(DGP("PAT",.3),U,1)="Y" - I 'VET,SC S FILERR(RULE)="" - Q -13 ; POS UNSPECIFIED - ; Note: Rule #413 IN IVMZ7CE is a duplicate of this rule - Q:$P($G(DGP("PAT","VET")),U,1)'="Y" - ; Make sure that the value in the field is valid -- DGRPC does this as well - I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),0)) S FILERR(RULE)="" - Q -15 ; INEL REASON UNSPECIFIED - ; Note: Rule #404 IN IVMZ7CE is a duplicate of this rule - I $P(DGP("PAT",.15),U,2),$P($G(DGP("PAT",.3)),U,7)="" S FILERR(RULE)="" - Q -16 ; DATE OF DEATH IN FUTURE - ; Note: Rule #308 IN IVMZ7CD is a duplicate of this rule - S X=$P($G(DGP("PAT",.35)),U) I X']"" Q - ; Compare DOD to right now - I X>$$DT^XLFDT S FILERR(RULE)="" - Q -19 ; ELIG/NONVET STAT INCONSISTENT - ; Note: Rule #405 in IVMZ7CE is a duplicate of this rule - N VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE - ; Patient's VET status - S VET=$P($G(DGP("PAT","VET")),U,1) I VET="" S FILERR(RULE)="" Q - ; do this check for NON-VET status only - Q:VET="Y" - ; Check PT type to see if we skip VET checks - S PTYPE=$P($G(DGP("PAT","TYPE")),U,1) - I PTYPE]"",$P(^DG(391,PTYPE,0),U,2) Q - ; Eligibility Code - S ELIG=$P($G(DGP("PAT",.36)),U,1) I ELIG="" S FILERR(RULE)="" Q - ;start in File #8 - S FILE8=$G(^DIC(8,ELIG,0)) I FILE8="" S FILERR(RULE)="" Q - ;using the pointer value in field #8 (node 0; piece 9) - S MPTR=$P(FILE8,U,9) - ;find the record in File #8.1 - S FILE81=$G(^DIC(8.1,MPTR,0)) I FILE81="" S FILERR(RULE)="" Q - ;check the Type field #4 (node 0; piece 5). - S MTYPE=$P(FILE81,U,5) - ; Pt's VET status must match NON-VET Status of Eligibility Code - I VET'=MTYPE S FILERR(RULE)="" - Q -24 ; POS/ELIG CODE INCONSISTENT - ; Note: Rule #412 in IVMZ7CE is a duplicate of this rule - I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),"E",+$P(DGP("PAT",.36),U,1))) S FILERR(RULE)="" - Q -29 ; A&A CLAIMED, NONVET - I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)="" - Q -30 ; HOUSEBOUND CLAIMED, NONVET - I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)="" - Q -31 ; VA PENSION CLAIMED, NONVET - I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)="" - Q -34 ; POW CLAIMED, NONVET - I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)="" - Q -60 ; AGENT ORANGE EXP LOC MISSING - ; Note: Rule #512 in IVMZ7CS is a duplicate of this rule. - I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)="" - Q -72 ; MSE DATA MISSING/INCOMPLETE, turned off with DG*5.3*765 - ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule. - N I,X - S X=DGP("PAT",.32) - F I=4,5,8 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,6)) S FILERR(RULE)="" Q ;LAST - F I=9,10,13 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" Q ;NTL - F I=14,15,18 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" ;NNTL - Q - ; -74 ; CONFLICT DT MISSING/INCOMPLETE, turned off with DG*5.3*765 - ; Note:#515 IVMZ7CS is a duplicate, turned off with DG*5.3*771 -75 ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT -76 ; # 76 INACCURATE CONFLICT DATE, turned off with DG*5.3*771 - ; - N I,T,FROM,TO,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON74,ON75,ON76 - S ON74=$$ON(74),ON75=$$ON(75),ON76=$$ON(76) - S I=$$RANGE^DGMSCK() ; load range table - F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT" D - . ;we have to have a flag ERR because we don't want multiple - . ;inconsistencies on a single conflict but we do want to - . ;flag a single inconsistency on multiple conflicts - . S ERR=0 - . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4) - . S RNGE=$P(CONFL,U,5) - . Q:$P(DGP("PAT",NODE),U,PCE)'="Y" - . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO) - . ; check rule 74 CONFLICT DT MISSING/INCOMPLETE - . I ON74,(RULE=74) F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1 - . Q:ERR - . ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT - . I ON75,(RULE=75),(FROM>TO) S FILERR(RULE)="",ERR=1 - . Q:ERR - . ; check rule 76 INACCURATE CONFLICT DATE - . Q:ERR - . Q:'$D(RANGE(RNGE)) ; can't calculate if range table is missing - . ; determine whether dates are withing conflict range - . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2) - . I ON76,(RULE=76) D - . . I '((RFR'>FROM)&((RTO'FROM&((FROM'>RTO)&((RTO'$$DT^XLFDT S FILERR(RULE)="" + Q +19 ; ELIG/NONVET STAT INCONSISTENT + ; Note: Rule #405 in IVMZ7CE is a duplicate of this rule + N VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE + ; Patient's VET status + S VET=$P($G(DGP("PAT","VET")),U,1) I VET="" S FILERR(RULE)="" Q + ; do this check for NON-VET status only + Q:VET="Y" + ; Check PT type to see if we skip VET checks + S PTYPE=$P($G(DGP("PAT","TYPE")),U,1) + I PTYPE]"",$P(^DG(391,PTYPE,0),U,2) Q + ; Eligibility Code + S ELIG=$P($G(DGP("PAT",.36)),U,1) I ELIG="" S FILERR(RULE)="" Q + ;start in File #8 + S FILE8=$G(^DIC(8,ELIG,0)) I FILE8="" S FILERR(RULE)="" Q + ;using the pointer value in field #8 (node 0; piece 9) + S MPTR=$P(FILE8,U,9) + ;find the record in File #8.1 + S FILE81=$G(^DIC(8.1,MPTR,0)) I FILE81="" S FILERR(RULE)="" Q + ;check the Type field #4 (node 0; piece 5). + S MTYPE=$P(FILE81,U,5) + ; Pt's VET status must match NON-VET Status of Eligibility Code + I VET'=MTYPE S FILERR(RULE)="" + Q +24 ; POS/ELIG CODE INCONSISTENT + ; Note: Rule #412 in IVMZ7CE is a duplicate of this rule + I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),"E",+$P(DGP("PAT",.36),U,1))) S FILERR(RULE)="" + Q +29 ; A&A CLAIMED, NONVET + I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)="" + Q +30 ; HOUSEBOUND CLAIMED, NONVET + I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)="" + Q +31 ; VA PENSION CLAIMED, NONVET + I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)="" + Q +34 ; POW CLAIMED, NONVET + I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)="" + Q +60 ; AGENT ORANGE EXP LOC MISSING + ; Note: Rule #512 in IVMZ7CS is a duplicate of this rule. + I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)="" + Q +72 ; MSE DATA MISSING/INCOMPLETE + ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule. + N I,X + S X=DGP("PAT",.32) + F I=4,5,8 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,6)) S FILERR(RULE)="" Q ;LAST + F I=9,10,13 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" Q ;NTL + F I=14,15,18 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" ;NNTL + Q + ; +74 ; CONFLICT DT MISSING/INCOMPLETE + ; Note: Rule #515 in IVMZ7CS is a duplicate of this rule. + ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT + ; # 76 INACCURATE CONFLICT DATE + ; + N I,T,FROM,TO,RULE1,RULE2,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON75,ON76 + S RULE1=75,RULE2=76 + S ON75=$$ON(75),ON76=$$ON(76) + S I=$$RANGE^DGMSCK() ; load range table + F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT" D + . ;we have to have a flag ERR because we don't want multiple + . ;inconsistencies on a single conflict but we do want to + . ;flag a single inconsistency on multiple conflicts + . S ERR=0 + . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4) + . S RNGE=$P(CONFL,U,5) + . Q:$P(DGP("PAT",NODE),U,PCE)'="Y" + . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO) + . ; check rule 74 CONFLICT DT MISSING/INCOMPLETE + . F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1 + . Q:ERR + . ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT + . I ON75,FROM>TO S FILERR(RULE1)="",ERR=1 + . Q:ERR + . ; check rule 76 INACCURATE CONFLICT DATE + . Q:ERR + . Q:'$D(RANGE(RNGE)) ; can't calculate if range table is missing + . ; determine whether dates are withing conflict range + . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2) + . I ON76 D + . . I '((RFR'>FROM)&((RTO'FROM&((FROM'>RTO)&((RTO'