source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMCMC.m@ 1328

Last change on this file since 1328 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1IVMCMC ;ALB/SEK,BRM,GN - CHECK INCOME TEST TRANSMISSION SEGMENTS ; 9/17/03 12:54pm
2 ;;2.0;INCOME VERIFICATION MATCH;**17,34,49,51,90**;21-OCT-94
3 ;
4 ;IVM*2*90 - stop upload of LTC type 4 test when staus code not valid
5 ;
6EN ; Check segment structure of Income Test (Z10) transmission.
7 ; Variable input:
8 ; IVMDA -- pointer to an incoming message line in file #772
9 ; IVMORF -- [optional]: set to 1 if Z10 is an ORF message
10 ; IVMSEG -- the MSH segment string
11 ;
12 ; plus the usual HL7 variables: HLDA, HLFS, HLQ, HLECH
13 ;
14 ; Variable output:
15 ; DFN -- pointer to the patient in file #2
16 ; DGLY -- Income Year
17 ; IVMFLGC -- Number of Dependent Children
18 ; IVMMCI -- HL7 message control id of query sent to IVM Center
19 ;
20 ; and the global array ^TMP($J,"IVMCM" which holds the message.
21 ;
22 N ERRMSG,DOBP,SEXP,X,Y
23 ;
24 ; - message control id from MSH segment
25 S MSGID=$P(IVMSEG,HLFS,10)
26 ;
27 ; - if query response (ORF), do additional edit checks
28 I $G(IVMORF) D ADDL I $D(HLERR) G ENQ
29 ;
30 ; - check the PID segment and get a match on patient
31 D GET("PIDV") I IVMSEG1'="PID" D PROB("Missing PID segment") G ENQ
32 S DOBP=$P(IVMSEG,HLFS,8),SEXP=$P(IVMSEG,HLFS,9)
33 I SEXP'="F"&(SEXP'="M") D PROB("Incorrect value for Sex") G ENQ
34 S X=$$FMDATE^HLFNC(DOBP),%DT=X D ^%DT I Y<0 D PROB("Invalid Date of Birth") G ENQ
35 S DFN=$$LOOKUP^IVMUFNC($P(IVMSEG,HLFS,20),Y,SEXP,.ERRMSG)
36 I 'DFN D PROB(ERRMSG) G ENQ
37 ;
38 ; - check for veteran's ZIC and ZIR segments
39 D GET("ZICV") I IVMSEG1'="ZIC" D PROB("Missing veteran's ZIC segment") G ENQ
40 S DGLY=$$FMDATE^HLFNC($P(IVMSEG,"^",3)) ; income year
41 I 'DGLY D PROB("Missing veteran's Income Year") G ENQ
42 D GET("ZIRV") I IVMSEG1'="ZIR" D PROB("Missing veteran's ZIR segment") G ENQ
43 ;
44 ; - check for spouse's ZDP, ZIC, ZIR segments
45 D GET("ZDPS") I IVMSEG1'="ZDP" D PROB("Missing spouse's ZDP segment") G ENQ
46 D GET("ZICS") I IVMSEG1'="ZIC" D PROB("Missing spouse's ZIC segment") G ENQ
47 D GET("ZIRS") I IVMSEG1'="ZIR" D PROB("Missing spouse's ZIR segment") G ENQ
48 ;
49 ; - check for dependent children's ZDP, ZIC, ZIR segments and ZMT segment
50 S IVMFLGC=0
51 F IVMNBR=1:1 D I $D(HLERR)!(IVMSEG1="ZMT") Q
52 .D GET("ZDPC",IVMNBR) I IVMSEG1'="ZDP",IVMSEG1'="ZMT" D PROB("Missing child's ZDP segment or ZMT segment") Q
53 .I IVMSEG1="ZMT" Q
54 .I $P(IVMSEG,"^",2)=""!($P(IVMSEG,"^",3)="")!($P(IVMSEG,"^",4)="") D PROB("Missing child data from ZDP segment") Q
55 .D GET("ZICC",IVMNBR) I IVMSEG1'="ZIC" D PROB("Missing child's ZIC segment") Q
56 .D GET("ZIRC",IVMNBR) I IVMSEG1'="ZIR" D PROB("Missing child's ZIR segment") Q
57 .S IVMFLGC=IVMFLGC+1 ; # of children
58 ;
59 I $D(HLERR) G ENQ
60 ;
61 ; - check for remaining ZMT and ZBT segments
62 D GET("ZMT2") I IVMSEG1'="ZMT" D PROB("Missing Copay Test ZMT segment") G ENQ
63 ;
64 ; ** added ZMT4 lines for LTC phase II (IVM*2*49)
65 ; uncomment after all sites have installed to enable consistency chk
66 D GET("ZMT4") I IVMSEG1'="ZMT" D PROB("Missing LTC Test ZMT segment") G ENQ
67 ;
68 ; remove next line after all sites have installed
69 ;D GET("ZMT4") I IVMSEG1'="ZMT" K ^TMP($J,"IVMCM","ZMT4") S IVMDA=IVMDA-1
70 ;
71 D GET("ZBT") I IVMSEG1'="ZBT" D PROB("Missing Beneficiary Travel ZBT segment") G ENQ
72 ;
73ENQ I IVMSEG1="MSH" S IVMDA=IVMDA-1,HLERR="",IVMTYPE=5
74 K IVMSEG1,IVMNBR
75 Q
76 ;
77 ;
78GET(SEG,NUM) ; Get the next HL7 segment.
79 ; Formal input:
80 ; SEG -- String with which to build ^TMP($J,"IVMCM"
81 ; NUM -- Number to index child dependent strings [optional]
82 ; Required variable input:
83 ; HLDA -- Pointer to the incoming message in file #772
84 ; IVMDA -- Pointer to the next message line within file #772
85 S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA)),IVMSEG=$G(^(+IVMDA,0))
86 S IVMSEG1=$E(IVMSEG,1,3)
87 I $G(SEG)="" G GETQ
88 I $G(NUM),IVMSEG1'="ZMT" S ^TMP($J,"IVMCM",SEG,NUM)=$P(IVMSEG,HLFS,2,99) G GETQ
89 I IVMSEG1="ZMT",$E(SEG,1,3)'="ZMT" S SEG="ZMT1"
90 ;
91 ;IVM*2*90 don't allow upload of LTC with a date & a bad status code
92 I SEG="ZMT4",$P(IVMSEG,HLFS,3),$P(IVMSEG,HLFS,4)'=0,$P(IVMSEG,HLFS,4)'=1,$P(IVMSEG,HLFS,4)'="""""" Q
93 ;
94 S ^TMP($J,"IVMCM",SEG)=$P(IVMSEG,HLFS,2,99)
95GETQ Q
96 ;
97PROB(ERR) ; Process encountered errors.
98 ; Input: ERR -- Error text
99 S HLERR=ERR
100 D ACK^IVMPREC
101 Q
102 ;
103ADDL ; Perform additional segment checks for ORF messages.
104 ;
105 N DOB,ERRMSG,IVMMSA,IVMPAT,IVMQRD,IVMQRF,QARRAY,QRYIEN,SEX,SSN
106 ;
107 ; edit checks for MSA, QRD, and QRF segments
108 D GET("") I IVMSEG1'="MSA" D PROB("Missing required MSA segment") G ADDLQ
109 S IVMMCI=$P(IVMSEG,"^",3) ; msg control id of msg being acknowledged
110 S IVMMSA=IVMSEG
111 ; trace reply back to the original query msg
112 S QRYIEN=$$FINDMSG^IVMCQ2(IVMMCI)
113 I 'QRYIEN D PROB("Query not found") G ADDLQ
114 I QRYIEN,'$$GET^IVMCQ2(QRYIEN,.QARRAY) D PROB("Query not found") G ADDLQ
115 S DFN=QARRAY("DFN")
116 ;
117 D GET("") I IVMSEG1'="QRD" D PROB("Missing required QRD segment") G ADDLQ
118 S IVMQRD=IVMSEG
119 S SSN=$P(IVMQRD,HLFS,9)
120 ;
121 D GET("") I IVMSEG1'="QRF" D PROB("Missing required QRF segment") G ADDLQ
122 S IVMQRF=IVMSEG
123 S DOB=$$FMDATE^HLFNC($P(IVMQRF,HLFS,5))
124 S SEX=$P(IVMQRF,HLFS,6)
125 ;
126 ;
127 ; if application reject rec'd from HEC (i.e. No income data on file)
128 I $P(IVMMSA,HLFS,2)="AR" D
129 .S HLERR=""
130 .S IVMTYPE=7 ;type 4 is now used for LTC test (IVM*2*49)
131 .; - if patient identifiers rec'd from HEC incorrect,
132 .; queue off job to send a new query
133 .I $$GETPAT^IVMUFNC(DFN,.IVMPAT),((SSN'=IVMPAT("SSN"))!(DOB'=IVMPAT("DOB"))!(SEX'=IVMPAT("SEX"))) D QRYQUE^IVMCQ2(DFN)
134 ;
135ADDLQ Q
Note: See TracBrowser for help on using the repository browser.