- 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 Jan 18, 2025@03:02:48 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