IVMPTRN ;ALB/MLI,SEK,RTK,BRM,BAJ,LBD,KUM - IVM BACKGROUND JOB/TRANSMISSIONS TO IVM CENTER; 10/28/2005 ; 7/13/10 4:11pm
;;2.0;INCOME VERIFICATION MATCH;**1,9,11,12,17,28,34,74,79,89,105,143,147,196**;JUL 8,1996;Build 37
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Supported ICRs
; #2701 - $$GETICN^MPIF001
; #7208 - $$EN^DGREGEEWS
;
; This routine is run nightly to send HL7 messages to the IVM Center for
; processing.
;
BGJ ; - IVM Nightly Background Job
;
;for tests being held for the future, make them primary if now effective
D FUTUREMT,FUTURERX
;
; - retransmit enrollment/eligibility queries with no reply
D BATCH^DGENQRY1
;
; - retransmit income test (financial) queries with no reply
D MONITOR^IVMCQ2
;
; - current year and previous year
S IVMCURYR=$$LYR^DGMTSCU1(DT),IVMPREYR=$$LYR^DGMTSCU1(IVMCURYR)
;
;
; - Master Query Processing
;
; - respond to Master Query for previous year, if necessary
S IVMREC=$$QRY(IVMPREYR) I IVMREC D RESP(IVMPREYR,+IVMREC),END
;
; - respond to Master Query for current year, if necessary
S IVMREC=$$QRY(IVMCURYR) I IVMREC D RESP(IVMCURYR,+IVMREC),END
;
; - send regular 'nightly' transmissions
D REG,END
;
; - perform retransmission processing
D ENTRY^IVMPTRN4,END
;
; - process billing activity
D EN^IVMPTRN5
;
; - auto-upload address changes from #301.5 if >14 days old
; - auto-delete non address changes from #301.5 if >30 days old
N ADDRDT S ADDRDT(0)=30,ADDRDT(1)=14 D EN^IVMLDEMC(.ADDRDT)
;
END ; - cleanup
I $D(ZTQUEUED) S ZTREQ="@"
K DA,DFN,DIE,DIK,DR,IVMCT,IVMDA,IVMDT,IVMGTOT,IVMINCYR,IVMINS,IVMMTDT
K IVMNODE,IVMPAT,IVMPID,IVMQDT,IVMREC,IVMSTAT,X,%,VAFPID,IVMPREYR,IVMIY
D CLEAN^IVMUFNC
K ^TMP($J,"CC")
Q
;
REG ; Creates FULL query transmission for patient's
; that exist in file (#301.5) "ATR" x-ref
;
;
; - initialize variables for HL7/IVM
S HLMTN="ORU"
S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" "_HLMTN_"-Z07 SERVER"
S HLEID=$O(^ORD(101,"B",HLEID,0))
K ^TMP($J,"CC") ;refresh Consistency Check counter
D INIT^IVMUFNC(HLEID,.HL)
;
; - roll thru ATR x-ref for patients that require transmission
K IVMQUERY("LTD"),IVMQUERY("OVIS") ;Variables needed to open/close last visit date and outpt visit QUERIES
S IVMIY=0
F S IVMIY=$O(^IVM(301.5,"ATR",0,IVMIY)) Q:'IVMIY D
.S IVMDA=0
.F S IVMDA=$O(^IVM(301.5,"ATR",0,IVMIY,IVMDA)) Q:'IVMDA D
..;
..N EVENTS
..; - get node, income year, dfn
..S IVMNODE=$G(^IVM(301.5,+IVMDA,0)),IVMDT=+$P(IVMNODE,"^",2),DFN=+IVMNODE
..I 'DFN!'IVMDT Q
..;
..Q:($$STATUS^IVMPLOG(IVMDA,.EVENTS)=1)
..;
..; - if merged patient record, then update Transmission Status to
..; remove from "ATR" x-ref and do not create Z07 (IVM*2*147)
..I $D(^DPT(DFN,-9)) S X=$$CLEAR^IVMPLOG(IVMDA) K X Q
..;
..; IVM*2.0*196 - Do not send Z07
..; If DO YOU WISH TO ENROLL field in PATIENT (#2) file is YES AND
..; there is no current Enrollment record
..I $$GET1^DIQ(2,DFN_",",27.04,"I"),$$FINDCUR^DGENA(DFN)="" Q
..;
..S IVMMTDT=$$GETMTDT(DFN,IVMDT) ;IVM*2*143
..;
..; - prepare FULL transmission
..D FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT,,,,.IVMQUERY)
;
; After all transmissions send Bulletin of inconsistency check totals
D EN^IVMPBUL
;
F Z="LTD","OVIS" I $G(IVMQUERY(Z)) D CLOSE^SDQ(IVMQUERY(Z)) K IVMQUERY(Z)
; - transmit remaining records
D
.N IVMEVENT
.; event code for Full Data Transmission
.S IVMEVENT="Z07"
.D FILE^IVMPTRN3
Q
;
RESP(IVMINCYR,IVMREC) ; Response to the Master Query.
;
; Input: IVMINCYR - The income year for which the query was sent
; IVMREC - Internal entry number of query to be updated
;
N DFN,IVMDA,IVMMTDT,DA,DR,DIE,EVENTS
;
; - initialize variables for HL7/IVM
S HLMTN="ORF"
S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" "_HLMTN_"-Z07 SERVER"
S HLEID=$O(^ORD(101,"B",HLEID,0))
D INIT^IVMUFNC(HLEID,.HL)
;
; - roll thru AYR x-ref
F DFN=0:0 S DFN=$O(^IVM(301.5,"AYR",IVMINCYR,DFN)) Q:'DFN D
.F IVMDA=0:0 S IVMDA=$O(^IVM(301.5,"AYR",IVMINCYR,DFN,IVMDA)) Q:'IVMDA D
..;
..; - check for STOP FLAG in file #301.5.
..I '$$CLOSED^IVMPLOG(IVMDA) D
...;
...; if means test was deleted, -10000 could be entered as income year
...; in ^IVM(301.5. close case if deleted.
...S IVMMTDT=$P($$LST^DGMTU(DFN,($E(IVMINCYR,1,3)+1)_"1231.9999"),"^",2)
...I IVMMTDT="" D CLOSE^IVMPTRN1(IVMINCYR,DFN,1,3) Q
...;
...;get EVENTS() array
...I $$STATUS^IVMPLOG(+IVMDA,.EVENTS)
...;
...; - prepare FULL transmission
...; note: 6th parameter is IVMFLL (=1 to include MSA segment)
...D FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT,1,,$G(IVMREC),.IVMQUERY)
;
; - transmit remaining records
D
.N IVMEVENT
.; event code for Full Data Transmission
.S IVMEVENT="Z07"
.D FILE1^IVMPTRN3 ; added for v1.6 because of MSA segment (note: the original call was to FILE^IVMPTRN3)
;
;
; - update multiple in file #301.9. Stuff (.03) field with date/time
; of FULL query transmission.
S DIE="^IVM(301.9,1,10,",DA=+IVMREC,DA(1)=1,DR=".03////"_$$NOW^XLFDT D ^DIE
Q
;
QRY(YEAR) ; See if Master Query has been satisfied for YEAR.
; Input: YEAR - The income year being checked
;
; Output: 1^2, where 1 = 0, if query does not need a response
; >0, if query needs a response (value
; equal to ien of sub-file entry
; in #301.9
; 2 = 0, if the request has not been received
; 1, if the request has been received
N IVM,X,Y,Z
I '$G(YEAR) S X="0^0" G QRYQ
S Y=$O(^IVM(301.9,1,10,"AB",YEAR,"")) I 'Y S X="0^0" G QRYQ
S IVM=$O(^IVM(301.9,1,10,"AB",YEAR,Y,0)) I 'IVM S X="0^0" G QRYQ
S Z=$P($G(^IVM(301.9,1,10,+IVM,0)),"^",3)
S X=$S(Z:0,1:IVM)_"^1"
QRYQ Q X
;
FUTUREMT ;
;Find future tests, and if now effective then make them primary. Will
;call the MT event driver unless NOT required, in which case the status
;will have the status will be changed to NO LONGER REQUIRED
;and may auto-create a Rx copay test
;
N FDATE,IVMPAT,MTIEN,NODE,DFN,DATA
;
S FDATE=0
F S FDATE=$O(^IVM(301.5,"AC",FDATE)) Q:('FDATE) Q:(FDATE>DT) D
.S IVMPAT=0
.F S IVMPAT=$O(^IVM(301.5,"AC",FDATE,IVMPAT)) Q:'IVMPAT D
..S MTIEN=$O(^IVM(301.5,"AC",FDATE,IVMPAT,""),-1)
..I '$$FUTURECK("AC",FDATE,IVMPAT,MTIEN) K ^IVM(301.5,"AC",FDATE,IVMPAT,MTIEN)
..K DATA S DATA(.06)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA)
..S DFN=+$G(^IVM(301.5,IVMPAT,0))
..I DFN S NODE=$$LST^DGMTU(DFN,DT_.9999,1) I $E($P(NODE,"^",2),1,3)=$E(DT,1,3),$P(NODE,"^",4)'="","R"'=$P(NODE,"^",4) K ^IVM(301.5,"AC",FDATE,IVMPAT,MTIEN) Q
..D MTPRIME^DGMTU4(MTIEN)
Q
;
FUTURERX ;
;Find future COPAY tests, and if now effective then make it primary.
;Will change the status to NO LONGER APPLICABLE if the vet is not
;subject to pharmacy copayments
;
N FDATE,IVMPAT,MTIEN,NODE,DFN,DATA
;
S FDATE=0
F S FDATE=$O(^IVM(301.5,"AD",FDATE)) Q:('FDATE) Q:(FDATE>DT) D
.S IVMPAT=0
.F S IVMPAT=$O(^IVM(301.5,"AD",FDATE,IVMPAT)) Q:'IVMPAT D
..S MTIEN=$O(^IVM(301.5,"AD",FDATE,IVMPAT,""),-1)
..I '$$FUTURECK("AD",FDATE,IVMPAT,MTIEN) K ^IVM(301.5,"AD",FDATE,IVMPAT,MTIEN)
..K DATA S DATA(.07)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA)
..S DFN=+$G(^IVM(301.5,IVMPAT,0))
..I DFN S NODE=$$LST^DGMTU(DFN,DT_.9999,2) I $E($P(NODE,"^",2),1,3)=$E(DT,1,3),$P(NODE,"^",4)'="" K ^IVM(301.5,"AD",FDATE,IVMPAT,MTIEN) Q
..D RXPRIME^DGMTU4(MTIEN)
Q
;
FUTURECK(TYPE,FDATE,IVMPAT,MTIEN) ;
; Check the Future MT or CP xref for a valid income test entry,
; and Delete all invalid xref entries.
N VALID,MTREC S VALID=1,MTREC=0
;
; Remove duplicate entries from cross reference, leaving last entry
F S MTREC=$O(^IVM(301.5,TYPE,FDATE,IVMPAT,MTREC)) Q:(MTREC=MTIEN!('MTREC)) K ^IVM(301.5,TYPE,FDATE,IVMPAT,MTREC)
;
I '$D(^IVM(301.5,IVMPAT,0)) S VALID=0 Q VALID
I '$D(^DGMT(408.31,MTIEN,0)) S VALID=0 Q VALID
I FDATE'=+(^DGMT(408.31,MTIEN,0)) S VALID=0 Q VALID
;
Q VALID
;
GETMTDT(DFN,IVMDT) ;Get date of primary Means Test or RX Copay Test (IVM*2*143)
N IDT,MT,MTDT,MTSTA,RX,RXDT,RXSTA
I '$G(DFN)!('$G(IVMDT)) Q ""
S IDT=($E(IVMDT,1,3)+1)_"1231.9999"
;Get most recent primary MT
S MT=$$LST^DGMTU(DFN,IDT,1),MTDT=$P(MT,"^",2),MTSTA=$P(MT,"^",4)
;Get most recent primary RX Copay Test
S RX=$$LST^DGMTU(DFN,IDT,2),RXDT=$P(RX,"^",2),RXSTA=$P(RX,"^",4)
;If there's no RX Copay Test, then return the Means Test date.
I 'RXDT Q MTDT
;If the RX Copay Test date is greater than or equal to the Means
;Test date, and the RX Copay Test status is Exempt, Non-Exempt,
;or Pending Adjudication, then return the RX Copay Test date.
I RXDT'<MTDT,("^E^M^P^"[("^"_RXSTA_"^")) Q RXDT
;Otherwise, return the Means Test date.
Q MTDT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMPTRN 8922 printed Apr 09, 2024@21:01:37 Page 2
IVMPTRN ;ALB/MLI,SEK,RTK,BRM,BAJ,LBD,KUM - IVM BACKGROUND JOB/TRANSMISSIONS TO IVM CENTER; 10/28/2005 ; 7/13/10 4:11pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**1,9,11,12,17,28,34,74,79,89,105,143,147,196**;JUL 8,1996;Build 37
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Supported ICRs
+5 ; #2701 - $$GETICN^MPIF001
+6 ; #7208 - $$EN^DGREGEEWS
+7 ;
+8 ; This routine is run nightly to send HL7 messages to the IVM Center for
+9 ; processing.
+10 ;
BGJ ; - IVM Nightly Background Job
+1 ;
+2 ;for tests being held for the future, make them primary if now effective
+3 DO FUTUREMT
DO FUTURERX
+4 ;
+5 ; - retransmit enrollment/eligibility queries with no reply
+6 DO BATCH^DGENQRY1
+7 ;
+8 ; - retransmit income test (financial) queries with no reply
+9 DO MONITOR^IVMCQ2
+10 ;
+11 ; - current year and previous year
+12 SET IVMCURYR=$$LYR^DGMTSCU1(DT)
SET IVMPREYR=$$LYR^DGMTSCU1(IVMCURYR)
+13 ;
+14 ;
+15 ; - Master Query Processing
+16 ;
+17 ; - respond to Master Query for previous year, if necessary
+18 SET IVMREC=$$QRY(IVMPREYR)
IF IVMREC
DO RESP(IVMPREYR,+IVMREC)
DO END
+19 ;
+20 ; - respond to Master Query for current year, if necessary
+21 SET IVMREC=$$QRY(IVMCURYR)
IF IVMREC
DO RESP(IVMCURYR,+IVMREC)
DO END
+22 ;
+23 ; - send regular 'nightly' transmissions
+24 DO REG
DO END
+25 ;
+26 ; - perform retransmission processing
+27 DO ENTRY^IVMPTRN4
DO END
+28 ;
+29 ; - process billing activity
+30 DO EN^IVMPTRN5
+31 ;
+32 ; - auto-upload address changes from #301.5 if >14 days old
+33 ; - auto-delete non address changes from #301.5 if >30 days old
+34 NEW ADDRDT
SET ADDRDT(0)=30
SET ADDRDT(1)=14
DO EN^IVMLDEMC(.ADDRDT)
+35 ;
END ; - cleanup
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL DA,DFN,DIE,DIK,DR,IVMCT,IVMDA,IVMDT,IVMGTOT,IVMINCYR,IVMINS,IVMMTDT
+3 KILL IVMNODE,IVMPAT,IVMPID,IVMQDT,IVMREC,IVMSTAT,X,%,VAFPID,IVMPREYR,IVMIY
+4 DO CLEAN^IVMUFNC
+5 KILL ^TMP($JOB,"CC")
+6 QUIT
+7 ;
REG ; Creates FULL query transmission for patient's
+1 ; that exist in file (#301.5) "ATR" x-ref
+2 ;
+3 ;
+4 ; - initialize variables for HL7/IVM
+5 SET HLMTN="ORU"
+6 SET HLEID="VAMC "_$PIECE($$SITE^VASITE,"^",3)_" "_HLMTN_"-Z07 SERVER"
+7 SET HLEID=$ORDER(^ORD(101,"B",HLEID,0))
+8 ;refresh Consistency Check counter
KILL ^TMP($JOB,"CC")
+9 DO INIT^IVMUFNC(HLEID,.HL)
+10 ;
+11 ; - roll thru ATR x-ref for patients that require transmission
+12 ;Variables needed to open/close last visit date and outpt visit QUERIES
KILL IVMQUERY("LTD"),IVMQUERY("OVIS")
+13 SET IVMIY=0
+14 FOR
SET IVMIY=$ORDER(^IVM(301.5,"ATR",0,IVMIY))
if 'IVMIY
QUIT
Begin DoDot:1
+15 SET IVMDA=0
+16 FOR
SET IVMDA=$ORDER(^IVM(301.5,"ATR",0,IVMIY,IVMDA))
if 'IVMDA
QUIT
Begin DoDot:2
+17 ;
+18 NEW EVENTS
+19 ; - get node, income year, dfn
+20 SET IVMNODE=$GET(^IVM(301.5,+IVMDA,0))
SET IVMDT=+$PIECE(IVMNODE,"^",2)
SET DFN=+IVMNODE
+21 IF 'DFN!'IVMDT
QUIT
+22 ;
+23 if ($$STATUS^IVMPLOG(IVMDA,.EVENTS)=1)
QUIT
+24 ;
+25 ; - if merged patient record, then update Transmission Status to
+26 ; remove from "ATR" x-ref and do not create Z07 (IVM*2*147)
+27 IF $DATA(^DPT(DFN,-9))
SET X=$$CLEAR^IVMPLOG(IVMDA)
KILL X
QUIT
+28 ;
+29 ; IVM*2.0*196 - Do not send Z07
+30 ; If DO YOU WISH TO ENROLL field in PATIENT (#2) file is YES AND
+31 ; there is no current Enrollment record
+32 IF $$GET1^DIQ(2,DFN_",",27.04,"I")
IF $$FINDCUR^DGENA(DFN)=""
QUIT
+33 ;
+34 ;IVM*2*143
SET IVMMTDT=$$GETMTDT(DFN,IVMDT)
+35 ;
+36 ; - prepare FULL transmission
+37 DO FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT,,,,.IVMQUERY)
End DoDot:2
End DoDot:1
+38 ;
+39 ; After all transmissions send Bulletin of inconsistency check totals
+40 DO EN^IVMPBUL
+41 ;
+42 FOR Z="LTD","OVIS"
IF $GET(IVMQUERY(Z))
DO CLOSE^SDQ(IVMQUERY(Z))
KILL IVMQUERY(Z)
+43 ; - transmit remaining records
+44 Begin DoDot:1
+45 NEW IVMEVENT
+46 ; event code for Full Data Transmission
+47 SET IVMEVENT="Z07"
+48 DO FILE^IVMPTRN3
End DoDot:1
+49 QUIT
+50 ;
RESP(IVMINCYR,IVMREC) ; Response to the Master Query.
+1 ;
+2 ; Input: IVMINCYR - The income year for which the query was sent
+3 ; IVMREC - Internal entry number of query to be updated
+4 ;
+5 NEW DFN,IVMDA,IVMMTDT,DA,DR,DIE,EVENTS
+6 ;
+7 ; - initialize variables for HL7/IVM
+8 SET HLMTN="ORF"
+9 SET HLEID="VAMC "_$PIECE($$SITE^VASITE,"^",3)_" "_HLMTN_"-Z07 SERVER"
+10 SET HLEID=$ORDER(^ORD(101,"B",HLEID,0))
+11 DO INIT^IVMUFNC(HLEID,.HL)
+12 ;
+13 ; - roll thru AYR x-ref
+14 FOR DFN=0:0
SET DFN=$ORDER(^IVM(301.5,"AYR",IVMINCYR,DFN))
if 'DFN
QUIT
Begin DoDot:1
+15 FOR IVMDA=0:0
SET IVMDA=$ORDER(^IVM(301.5,"AYR",IVMINCYR,DFN,IVMDA))
if 'IVMDA
QUIT
Begin DoDot:2
+16 ;
+17 ; - check for STOP FLAG in file #301.5.
+18 IF '$$CLOSED^IVMPLOG(IVMDA)
Begin DoDot:3
+19 ;
+20 ; if means test was deleted, -10000 could be entered as income year
+21 ; in ^IVM(301.5. close case if deleted.
+22 SET IVMMTDT=$PIECE($$LST^DGMTU(DFN,($EXTRACT(IVMINCYR,1,3)+1)_"1231.9999"),"^",2)
+23 IF IVMMTDT=""
DO CLOSE^IVMPTRN1(IVMINCYR,DFN,1,3)
QUIT
+24 ;
+25 ;get EVENTS() array
+26 IF $$STATUS^IVMPLOG(+IVMDA,.EVENTS)
+27 ;
+28 ; - prepare FULL transmission
+29 ; note: 6th parameter is IVMFLL (=1 to include MSA segment)
+30 DO FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT,1,,$GET(IVMREC),.IVMQUERY)
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
+32 ; - transmit remaining records
+33 Begin DoDot:1
+34 NEW IVMEVENT
+35 ; event code for Full Data Transmission
+36 SET IVMEVENT="Z07"
+37 ; added for v1.6 because of MSA segment (note: the original call was to FILE^IVMPTRN3)
DO FILE1^IVMPTRN3
End DoDot:1
+38 ;
+39 ;
+40 ; - update multiple in file #301.9. Stuff (.03) field with date/time
+41 ; of FULL query transmission.
+42 SET DIE="^IVM(301.9,1,10,"
SET DA=+IVMREC
SET DA(1)=1
SET DR=".03////"_$$NOW^XLFDT
DO ^DIE
+43 QUIT
+44 ;
QRY(YEAR) ; See if Master Query has been satisfied for YEAR.
+1 ; Input: YEAR - The income year being checked
+2 ;
+3 ; Output: 1^2, where 1 = 0, if query does not need a response
+4 ; >0, if query needs a response (value
+5 ; equal to ien of sub-file entry
+6 ; in #301.9
+7 ; 2 = 0, if the request has not been received
+8 ; 1, if the request has been received
+9 NEW IVM,X,Y,Z
+10 IF '$GET(YEAR)
SET X="0^0"
GOTO QRYQ
+11 SET Y=$ORDER(^IVM(301.9,1,10,"AB",YEAR,""))
IF 'Y
SET X="0^0"
GOTO QRYQ
+12 SET IVM=$ORDER(^IVM(301.9,1,10,"AB",YEAR,Y,0))
IF 'IVM
SET X="0^0"
GOTO QRYQ
+13 SET Z=$PIECE($GET(^IVM(301.9,1,10,+IVM,0)),"^",3)
+14 SET X=$SELECT(Z:0,1:IVM)_"^1"
QRYQ QUIT X
+1 ;
FUTUREMT ;
+1 ;Find future tests, and if now effective then make them primary. Will
+2 ;call the MT event driver unless NOT required, in which case the status
+3 ;will have the status will be changed to NO LONGER REQUIRED
+4 ;and may auto-create a Rx copay test
+5 ;
+6 NEW FDATE,IVMPAT,MTIEN,NODE,DFN,DATA
+7 ;
+8 SET FDATE=0
+9 FOR
SET FDATE=$ORDER(^IVM(301.5,"AC",FDATE))
if ('FDATE)
QUIT
if (FDATE>DT)
QUIT
Begin DoDot:1
+10 SET IVMPAT=0
+11 FOR
SET IVMPAT=$ORDER(^IVM(301.5,"AC",FDATE,IVMPAT))
if 'IVMPAT
QUIT
Begin DoDot:2
+12 SET MTIEN=$ORDER(^IVM(301.5,"AC",FDATE,IVMPAT,""),-1)
+13 IF '$$FUTURECK("AC",FDATE,IVMPAT,MTIEN)
KILL ^IVM(301.5,"AC",FDATE,IVMPAT,MTIEN)
+14 KILL DATA
SET DATA(.06)=""
IF $$UPD^DGENDBS(301.5,IVMPAT,.DATA)
+15 SET DFN=+$GET(^IVM(301.5,IVMPAT,0))
+16 IF DFN
SET NODE=$$LST^DGMTU(DFN,DT_.9999,1)
IF $EXTRACT($PIECE(NODE,"^",2),1,3)=$EXTRACT(DT,1,3)
IF $PIECE(NODE,"^",4)'=""
IF "R"'=$PIECE(NODE,"^",4)
KILL ^IVM(301.5,"AC",FDATE,IVMPAT,MTIEN)
QUIT
+17 DO MTPRIME^DGMTU4(MTIEN)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
FUTURERX ;
+1 ;Find future COPAY tests, and if now effective then make it primary.
+2 ;Will change the status to NO LONGER APPLICABLE if the vet is not
+3 ;subject to pharmacy copayments
+4 ;
+5 NEW FDATE,IVMPAT,MTIEN,NODE,DFN,DATA
+6 ;
+7 SET FDATE=0
+8 FOR
SET FDATE=$ORDER(^IVM(301.5,"AD",FDATE))
if ('FDATE)
QUIT
if (FDATE>DT)
QUIT
Begin DoDot:1
+9 SET IVMPAT=0
+10 FOR
SET IVMPAT=$ORDER(^IVM(301.5,"AD",FDATE,IVMPAT))
if 'IVMPAT
QUIT
Begin DoDot:2
+11 SET MTIEN=$ORDER(^IVM(301.5,"AD",FDATE,IVMPAT,""),-1)
+12 IF '$$FUTURECK("AD",FDATE,IVMPAT,MTIEN)
KILL ^IVM(301.5,"AD",FDATE,IVMPAT,MTIEN)
+13 KILL DATA
SET DATA(.07)=""
IF $$UPD^DGENDBS(301.5,IVMPAT,.DATA)
+14 SET DFN=+$GET(^IVM(301.5,IVMPAT,0))
+15 IF DFN
SET NODE=$$LST^DGMTU(DFN,DT_.9999,2)
IF $EXTRACT($PIECE(NODE,"^",2),1,3)=$EXTRACT(DT,1,3)
IF $PIECE(NODE,"^",4)'=""
KILL ^IVM(301.5,"AD",FDATE,IVMPAT,MTIEN)
QUIT
+16 DO RXPRIME^DGMTU4(MTIEN)
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
FUTURECK(TYPE,FDATE,IVMPAT,MTIEN) ;
+1 ; Check the Future MT or CP xref for a valid income test entry,
+2 ; and Delete all invalid xref entries.
+3 NEW VALID,MTREC
SET VALID=1
SET MTREC=0
+4 ;
+5 ; Remove duplicate entries from cross reference, leaving last entry
+6 FOR
SET MTREC=$ORDER(^IVM(301.5,TYPE,FDATE,IVMPAT,MTREC))
if (MTREC=MTIEN!('MTREC))
QUIT
KILL ^IVM(301.5,TYPE,FDATE,IVMPAT,MTREC)
+7 ;
+8 IF '$DATA(^IVM(301.5,IVMPAT,0))
SET VALID=0
QUIT VALID
+9 IF '$DATA(^DGMT(408.31,MTIEN,0))
SET VALID=0
QUIT VALID
+10 IF FDATE'=+(^DGMT(408.31,MTIEN,0))
SET VALID=0
QUIT VALID
+11 ;
+12 QUIT VALID
+13 ;
GETMTDT(DFN,IVMDT) ;Get date of primary Means Test or RX Copay Test (IVM*2*143)
+1 NEW IDT,MT,MTDT,MTSTA,RX,RXDT,RXSTA
+2 IF '$GET(DFN)!('$GET(IVMDT))
QUIT ""
+3 SET IDT=($EXTRACT(IVMDT,1,3)+1)_"1231.9999"
+4 ;Get most recent primary MT
+5 SET MT=$$LST^DGMTU(DFN,IDT,1)
SET MTDT=$PIECE(MT,"^",2)
SET MTSTA=$PIECE(MT,"^",4)
+6 ;Get most recent primary RX Copay Test
+7 SET RX=$$LST^DGMTU(DFN,IDT,2)
SET RXDT=$PIECE(RX,"^",2)
SET RXSTA=$PIECE(RX,"^",4)
+8 ;If there's no RX Copay Test, then return the Means Test date.
+9 IF 'RXDT
QUIT MTDT
+10 ;If the RX Copay Test date is greater than or equal to the Means
+11 ;Test date, and the RX Copay Test status is Exempt, Non-Exempt,
+12 ;or Pending Adjudication, then return the RX Copay Test date.
+13 IF RXDT'<MTDT
IF ("^E^M^P^"[("^"_RXSTA_"^"))
QUIT RXDT
+14 ;Otherwise, return the Means Test date.
+15 QUIT MTDT
