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