Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

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
     1IVMCM ;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 ;
     5ORF ; 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 ;
     50Z10 ; 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 ;
     71ORU ; 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 ;
     90ENQ ;
     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 ;
     96PROC ; 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 ;
     134MT ; 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 ;
     186CT ; 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 ;
     228IS ; - 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 ;
     233LTC ; 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 ;
     236PROCQ ;
     237 ; release locks used to sychronize upload with local income test options
     238 D RELLOCKS^IVMCUPL(DFN)
     239 Q
     240 ;
     241CHKDT ; 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
     249FUTURE(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
     1IVMLDEM9 ;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 ;
     7EN2 ;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 ;
     22LOOP(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 ;
     46AUTOLOAD(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
     90REJTADD ;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
     100PRINT ;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
     107DISPLAY ;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
     127HDR ;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
     145EXIT D ^%ZISC,HOME^%ZIS Q
     146 K ^TMP($J,"IVMLDEM9")
     147 K ^TMP("IVMLDEM9",$J)
     148 ;
     149ADRDTCK(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"
     161MEMBER() ;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
     168EMAIL ;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
     184QUE ;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
     194TOTAL ;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
     203LNPLUS ;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         ;
     1IVMZ072 ;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.
     6LOADSD(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 ;
     46ACTIF(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         ;
     1IVMZ07C ;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 ;
     18EN(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 ;
     57COUNT(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 ;
     67LOADPT(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 ;
     109WORK(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 ;
     129DELETE(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 ;
     147FILE(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/2006
    2         ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6
    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, turned off with DG*5.3*771
    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, turned off with DG*5.3*771
    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         ;
     1IVMZ7CD ;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 ;
     13EN(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 ;
     35301 ; 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 ;
     43302 ; 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 ;
     51303 ; 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 ;
     58304 ; 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 ;
     66305 ; 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 ;
     71306 ; 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 ;
     85307 ; 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 ;
     94308 ; 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 ;
     99309 ; 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 ;
     112310 ; 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 ;
     118311 ; 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 ;
     124312 ; 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
     1IVMZ7CE ;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 ;
     12EN(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 ;
     28401 ; RATED INCOMPETENT INVALID
     29 S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
     30 Q
     31 ;
     32402 ; ELIGIBLE FOR MEDICAID INVALID
     33 S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
     34 Q
     35 ;
     36403 ; 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 ;
     40404 ; INELIGIBLE REASON INVALID
     41 ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule
     42 Q
     43 ;
     44405 ; NON VETERAN ELIG CODE INVALID
     45 ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule
     46 Q
     47 ;
     48406 ; 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 ;
     53407 ; 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 ;
     57408 ; 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 ;
     62409 ; 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 ;
     72410 ; Note: RULE #404 above is a duplicate of this rule
     73 Q
     74 ;
     75411 ; 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 ;
     79412 ; POS/ELIG CODE INVALID
     80 ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule
     81 Q
     82 ;
     83413 ; 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
     1IVMZ7CR ;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
     6EN(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
     214 ; 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
     297 ; 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
     339 ; VETERAN STATUS UNSPECIFIED
     34 I $P($G(DGP("PAT","VET")),U)="" S FILERR(RULE)=""
     35 Q
     3611 ; 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
     4313 ; 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
     4915 ; 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
     5316 ; 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
     5919 ; 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
     8224 ; 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
     8629 ; 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
     8930 ; 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
     9231 ; 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
     9534 ; 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
     9860 ; 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
     10272 ; 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 ;
     11174 ; 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
     14378 ; 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
     16081 ; 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 ;
     17983 ; 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
     19585 ; 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
     21986 ; INEL FIL VET SHOULD BE VET='N'
     220 ; This rule is satisfied in #85 above
     221 Q
     222ON(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
     228CONLIST ;;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
     237COMLIST ;;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.