DGMTU4 ;ALB/CJM,SCG,LBD,EG,PHH MEANS TEST UTILITES ; 06/07/2005
;;5.3;Registration;**182,267,285,347,454,456,476,610,658,1015**;Aug 13, 1993;Build 21
;
GETSITE(DUZ) ;
;Descripition: Gets the users station number. If not found, it will
;return the station number of the primary facility.
;
;Input:
; DUZ array, pass by reference
;Output:
; Function Value - station number with suffix
N FACILITY,STATION,CURSTN,CHILD,CIEN
S FACILITY=""
S:($G(DUZ)'=.5) FACILITY=$G(DUZ(2))
I 'FACILITY S FACILITY=+$$SITE^VASITE()
S:FACILITY STATION=$$STA^XUAF4(FACILITY)
S CURSTN=$P($$SITE^VASITE,"^",3)
I $D(STATION) D
.I STATION']"" D
..D CHILDREN^XUAF4("CHILD","`"_FACILITY,"PARENT FACILITY")
..S CIEN=0 F S CIEN=$O(CHILD("C",CIEN)) Q:'CIEN I CIEN=CURSTN S STATION=$$STA^XUAF4(CIEN) Q
..I STATION']"" D
...D CHILDREN^XUAF4("CHILD","`"_FACILITY,"VISN")
...S CIEN=0 F S CIEN=$O(CHILD("C",CIEN)) Q:'CIEN I CIEN=CURSTN S STATION=$$STA^XUAF4(CIEN) Q
Q $G(STATION)
;
DATETIME(MTIEN) ;
;Writes date/time stamp to means test record
N DATA
Q:$G(IVMZ10)="UPLOAD IN PROGRESS"
S DATA(2.02)=$$NOW^XLFDT
I $G(MTIEN),$D(^DGMT(408.31,MTIEN,0)) I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
Q
SAVESTAT(MTIEN,DGERR) ;
;Save the Test Determined Status (#2.03) in the ANNUAL MEANS TEST file
;(#408.31)
;
;Input:
; MTIEN - IEN of 408.31
; DGERR - (optional) 1 - Means or Copay Test is incomplete
; 0 - Means or Copay Test is complete
;
;only current statuses of P, A, or C for Means Tests and
;current status of M, or E for Copay Tests will be stored.
;
;if test is incomplete the Test Determined Status will be deleted.
;
Q:('$G(MTIEN))
;
N CODE,DATA,NODE0,TYPE
I $G(DGERR) S DATA(2.03)="" G SET
S NODE0=$G(^DGMT(408.31,MTIEN,0))
S TYPE=$P(NODE0,"^",19)
S CODE=$$GETCODE^DGMTH($P(NODE0,"^",3))
S:CODE="A" (DATA(.11),DATA(.14))=""
S DATA(2.03)=""
I TYPE=1,(CODE="N") Q
I TYPE=2,(CODE="L") Q
I TYPE=1,(CODE'=""),"CPAG"[CODE D
.S DATA(2.03)=$P(NODE0,"^",3)
.I $P(NODE0,"^",20) D
..S DATA(2.03)=$$GETSTAT^DGMTH($S(CODE="P":"P",CODE="A"&(($P(NODE0,U,4)-$P(NODE0,U,15))'>$P(NODE0,U,27)):"G",1:"C"),1)
I TYPE=2,(CODE'=""),"ME"[CODE S DATA(2.03)=$P(NODE0,"^",3)
SET I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
Q
MTPRIME(MTIEN) ;
;Makes the means test MTIEN primary
;
N DGREQF,DGDOM1,DGADDF,DGMSGF,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTA,TRIES,DATA,NODE,DFN,MTDATE,YREND,DGMTDC,IBPRIOR,MTPRIME,LSTNODE
Q:('$G(MTIEN))
S MTPRIME="DGMTU4"
S NODE=$G(^DGMT(408.31,MTIEN,0))
Q:(NODE="")
S DFN=$P($G(^DGMT(408.31,MTIEN,0)),"^",2)
Q:'DFN
Q:+$G(^DGMT(408.31,MTIEN,"PRIM")) ;already marked as primary!
S MTDATE=+NODE
Q:'MTDATE
Q:($P(NODE,"^",19)'=1)
;
S DGMTACT="ADD"
D PRIOR^DGMTEVT
;
;marks any existing tests as non-primary - shouldn't be more than
;one such test, but give it two tries
I '$$OLD(MTDATE) D
.S YREND=DT_.2359
E D
.S YREND=$E(MTDATE,1,3)_1231.9999
F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,1) Q:'(+NODE) Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3)) D
.N DATA
.;set up for the event driver - should be treated as an edit
.S:(TRIES=1) DGMTACT="EDT",DGMTI=+NODE D PRIOR^DGMTEVT
.;set the old test to non-primary
.S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
;
;don't want any old RX copay tests as primary either - if needed, they can be auto-created based on the means test
F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,2) Q:'(+NODE) Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3)) D
.N DATA
.;set the old test to non-primary
.S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
;
;mark this test as primary
K DATA S DATA(2)=1 I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
;
; Get Last Primary Means Test irrespective of income year
S LSTNODE=$$LST^DGMTU(DFN)
;if STATUS is REQUIRED & test is PRIMARY, then set it to NOT PRIMARY
;if the uploaded test is MT COPAY REQUIRED
; MT COPAY (CAT C) doesn't expire, which is why you have to
; flip the test to Not Primary eg 02/01/2005
I $P(LSTNODE,U,4)="R",+$G(^DGMT(408.31,+LSTNODE,"PRIM")),$P(^DGMT(408.31,MTIEN,0),U,3)=6 D
. N DATA S DATA(2)=0 I $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
;if means test is required and test is primary and not a CAT C,
;and it hasn't expired, flip the test to Not Primary eg 02/23/2005
I $P(LSTNODE,U,4)="R",+$G(^DGMT(408.31,+LSTNODE,"PRIM")),$P(^DGMT(408.31,MTIEN,0),U,3)'=6,'$$OLD(MTDATE) D
. N DATA S DATA(2)=0 I $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
;
;If this is a Z10 upload, call the means test event driver and quit.
;
I $G(IVMZ10)="UPLOAD IN PROGRESS" D Q
.S DGMTI=MTIEN
.S DGMTINF=1
.D QUE^DGMTR
;
;If the test is still in effect, need to do additional checks
;and call event driver
;
I '$$OLD(MTDATE) D
.;Mark this test as NO LONGER REQUIRED - calling EN^DGMTR will
.;change it back to its old status if required and will que the event
.;driver
.K DATA
.S DATA(.03)=$$GETSTAT^DGMTH("N",1)
.I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
.S (DGADDF,DGMSGF)=1 ;don't want new test added or messages
.S DGMTI=MTIEN
.S DGMTINF=1
.;
.D EN^DGMTR
.;if the test wasn't required, maybe a Rx copay test is needed
.I '$G(DGREQF),'$G(DGDOM1) D COPYRX^DGMTR1(DFN,MTIEN)
Q
;
RXPRIME(RXIEN) ;
;Makes phramacy copay test =RXIEN the primary test
;
N DGREQF,DGDOM1,DGADDF,DGMSGF,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTA,TRIES,DATA,NODE,DFN,MTIEN,DGRAUTO,DGADDF,DGMTE,DGMTCOR,DGMT,YREND,RXPRIME,QUIT
;
Q:('$G(RXIEN))
S RXPRIME="DGMTU4"
S QUIT=0
S NODE=$G(^DGMT(408.31,RXIEN,0))
Q:(NODE="")
S DFN=$P($G(^DGMT(408.31,RXIEN,0)),"^",2)
Q:'DFN
Q:+$G(^DGMT(408.31,RXIEN,"PRIM")) ;already marked as primary!
S MTDATE=+NODE
Q:'MTDATE
Q:($P(NODE,"^",19)'=2)
;
S DGMTINF=1
;
;marks any existing tests as non-primary - shouldn't be more than
;one such test, but give it two tries
;
I '$$OLD(MTDATE) D
.S YREND=DT_.2359
E D
.S YREND=$E(MTDATE,1,3)_1231.9999
F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,2) Q:'(+NODE) Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3)) D
.N DATA
.;set up for the event driver - should be treated as an edit
.S:(TRIES=1) DGMTACT="EDT",DGMTI=+NODE D PRIOR^DGMTEVT
.;set the old test to non-primary
.S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
;
;don't want any old means tests marked as primary - unless they are actually needed! In which case, do not make this Rx test primary.
F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,1) Q:'(+NODE) Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3)) D
.N DATA
.I '$$OLD($P(NODE,"^",2)),$P(NODE,"^",4)'="","ACGP"[$P(NODE,"^",4) S QUIT=1 Q
.;set the old test to non-primary
.S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
;
I QUIT G QRXPRIME
;mark this test as primary - calling
;EN^DGMTCOR will change it to NO LONGER APPLICABLE if appropriate
;
K DATA
S DATA(2)=1 I $$UPD^DGENDBS(408.31,RXIEN,.DATA)
;
;If the test is still in effect, need to do additional checks
;and call event driver
;
I '$$OLD(MTDATE) D
.S DGMSGF=1,DGADDF=0 ;don't want new test added or messages
.;
.;EN^DGMTR will first create a stub for a required MT if needed, then
.;call ^DGMTCOR to set the status of the copay test
.D EN^DGMTR
.;
.;if the pharmacy copay test was determined to be required, than
.;que the event driver
.I DGMTCOR D
..S DGMTACT="ADD"
..D PRIOR^DGMTEVT
..S DGMTI=RXIEN
..D QUE^DGMTR
QRXPRIME ;
Q
;
OLD(TESTDATE) ;
;Checks if the date is older than 365 days. Returns 0 for no, 1 for yes
;if the test is exactly 365 days,
;it is considered expired eg 03/09/2005
I ($$FMDIFF^XLFDT(DT,TESTDATE)'<365) Q 1
Q 0
;
TRANSFER(DFN,FROM,TO) ;
;transfers the Income Relations from the test=FROM to test=TO
;
N DGINI,DGINR,DATA,ERROR
Q:'$G(DFN)
Q:'$G(FROM)
Q:'$G(TO)
Q:(FROM=TO)
S DGINI=0 F S DGINI=$O(^DGMT(408.22,"AMT",FROM,DFN,DGINI)) Q:'DGINI S DGINR=$O(^DGMT(408.22,"AMT",FROM,DFN,DGINI,"")) I $P($G(^DGMT(408.22,+DGINR,"MT")),"^")]"" D
.K DATA
.S DATA(31)=TO
.I $$UPD^DGENDBS(408.22,+DGINR,.DATA,.ERROR)
Q
;
GETINCOM(DFN,TDATE) ;
;Makes sure Income Relations point to the right test
;
;Input:
; DFN
; TDATE -income year of test (uses $E(IVMMTDT,1,3))
;Output: none. Repoints Income Relations if necessary
;
N MTNODE,RXNODE,IVMMTDT,CODE,ACTVIEN
Q:'$G(TDATE)
Q:'$G(DFN)
;
S IVMMTDT=$E(TDATE,1,3)_"1231.9"
S (CODE,ACTVIEN)=""
S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
;
D
.;determine which test has the associated income relations
.;
.I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q
.I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q
.I +MTNODE S ACTVIEN=+MTNODE Q
.I +RXNODE S ACTVIEN=+RXNODE Q
I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
Q
;
CHKPT(DFN) ;
; Cross check the CURRENT MEANS TEST STATUS in the PATIENT File (#2) with the
; primary means test in the ANNUAL MEANS TEST File (#408.31). Update the
; CURRENT MEANS TEST STATUS if the fields are out of synch.
;
N PATMT,DGMTI,DATA
;
Q:$G(DFN)'>0
Q:'$D(^DPT(DFN))
S PATMT=$$GET1^DIQ(2,DFN,.14,"I")
S DGMTI=+$$LST^DGMTU(DFN)
S DATA(.14)=$P($G(^DGMT(408.31,DGMTI,0)),U,3)
Q:DATA(.14)=PATMT
;
I $$UPD^DGENDBS(2,DFN,.DATA)
Q
DGMTU4 ;ALB/CJM,SCG,LBD,EG,PHH MEANS TEST UTILITES ; 06/07/2005
+1 ;;5.3;Registration;**182,267,285,347,454,456,476,610,658,1015**;Aug 13, 1993;Build 21
+2 ;
GETSITE(DUZ) ;
+1 ;Descripition: Gets the users station number. If not found, it will
+2 ;return the station number of the primary facility.
+3 ;
+4 ;Input:
+5 ; DUZ array, pass by reference
+6 ;Output:
+7 ; Function Value - station number with suffix
+8 NEW FACILITY,STATION,CURSTN,CHILD,CIEN
+9 SET FACILITY=""
+10 IF ($GET(DUZ)'=.5)
SET FACILITY=$GET(DUZ(2))
+11 IF 'FACILITY
SET FACILITY=+$$SITE^VASITE()
+12 IF FACILITY
SET STATION=$$STA^XUAF4(FACILITY)
+13 SET CURSTN=$PIECE($$SITE^VASITE,"^",3)
+14 IF $DATA(STATION)
Begin DoDot:1
+15 IF STATION']""
Begin DoDot:2
+16 DO CHILDREN^XUAF4("CHILD","`"_FACILITY,"PARENT FACILITY")
+17 SET CIEN=0
FOR
SET CIEN=$ORDER(CHILD("C",CIEN))
IF 'CIEN
QUIT
IF CIEN=CURSTN
SET STATION=$$STA^XUAF4(CIEN)
QUIT
+18 IF STATION']""
Begin DoDot:3
+19 DO CHILDREN^XUAF4("CHILD","`"_FACILITY,"VISN")
+20 SET CIEN=0
FOR
SET CIEN=$ORDER(CHILD("C",CIEN))
IF 'CIEN
QUIT
IF CIEN=CURSTN
SET STATION=$$STA^XUAF4(CIEN)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT $GET(STATION)
+22 ;
DATETIME(MTIEN) ;
+1 ;Writes date/time stamp to means test record
+2 NEW DATA
+3 IF $GET(IVMZ10)="UPLOAD IN PROGRESS"
QUIT
+4 SET DATA(2.02)=$$NOW^XLFDT
+5 IF $GET(MTIEN)
IF $DATA(^DGMT(408.31,MTIEN,0))
IF $$UPD^DGENDBS(408.31,MTIEN,.DATA)
+6 QUIT
SAVESTAT(MTIEN,DGERR) ;
+1 ;Save the Test Determined Status (#2.03) in the ANNUAL MEANS TEST file
+2 ;(#408.31)
+3 ;
+4 ;Input:
+5 ; MTIEN - IEN of 408.31
+6 ; DGERR - (optional) 1 - Means or Copay Test is incomplete
+7 ; 0 - Means or Copay Test is complete
+8 ;
+9 ;only current statuses of P, A, or C for Means Tests and
+10 ;current status of M, or E for Copay Tests will be stored.
+11 ;
+12 ;if test is incomplete the Test Determined Status will be deleted.
+13 ;
+14 IF ('$GET(MTIEN))
QUIT
+15 ;
+16 NEW CODE,DATA,NODE0,TYPE
+17 IF $GET(DGERR)
SET DATA(2.03)=""
GOTO SET
+18 SET NODE0=$GET(^DGMT(408.31,MTIEN,0))
+19 SET TYPE=$PIECE(NODE0,"^",19)
+20 SET CODE=$$GETCODE^DGMTH($PIECE(NODE0,"^",3))
+21 IF CODE="A"
SET (DATA(.11),DATA(.14))=""
+22 SET DATA(2.03)=""
+23 IF TYPE=1
IF (CODE="N")
QUIT
+24 IF TYPE=2
IF (CODE="L")
QUIT
+25 IF TYPE=1
IF (CODE'="")
IF "CPAG"[CODE
Begin DoDot:1
+26 SET DATA(2.03)=$PIECE(NODE0,"^",3)
+27 IF $PIECE(NODE0,"^",20)
Begin DoDot:2
+28 SET DATA(2.03)=$$GETSTAT^DGMTH($SELECT(CODE="P":"P",CODE="A"&(($PIECE(NODE0,U,4)-$PIECE(NODE0,U,15))'>$PIECE(NODE0,U,27)):"G",1:"C"),1)
End DoDot:2
End DoDot:1
+29 IF TYPE=2
IF (CODE'="")
IF "ME"[CODE
SET DATA(2.03)=$PIECE(NODE0,"^",3)
SET IF $$UPD^DGENDBS(408.31,MTIEN,.DATA)
+1 QUIT
MTPRIME(MTIEN) ;
+1 ;Makes the means test MTIEN primary
+2 ;
+3 NEW DGREQF,DGDOM1,DGADDF,DGMSGF,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTA,TRIES,DATA,NODE,DFN,MTDATE,YREND,DGMTDC,IBPRIOR,MTPRIME,LSTNODE
+4 IF ('$GET(MTIEN))
QUIT
+5 SET MTPRIME="DGMTU4"
+6 SET NODE=$GET(^DGMT(408.31,MTIEN,0))
+7 IF (NODE="")
QUIT
+8 SET DFN=$PIECE($GET(^DGMT(408.31,MTIEN,0)),"^",2)
+9 IF 'DFN
QUIT
+10 ;already marked as primary!
IF +$GET(^DGMT(408.31,MTIEN,"PRIM"))
QUIT
+11 SET MTDATE=+NODE
+12 IF 'MTDATE
QUIT
+13 IF ($PIECE(NODE,"^",19)'=1)
QUIT
+14 ;
+15 SET DGMTACT="ADD"
+16 DO PRIOR^DGMTEVT
+17 ;
+18 ;marks any existing tests as non-primary - shouldn't be more than
+19 ;one such test, but give it two tries
+20 IF '$$OLD(MTDATE)
Begin DoDot:1
+21 SET YREND=DT_.2359
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 SET YREND=$EXTRACT(MTDATE,1,3)_1231.9999
End DoDot:1
+24 FOR TRIES=1,2
SET NODE=$$LST^DGMTU(DFN,YREND,1)
IF '(+NODE)
QUIT
IF ($EXTRACT($PIECE(NODE,"^",2),1,3)'=$EXTRACT(MTDATE,1,3))
QUIT
Begin DoDot:1
+25 NEW DATA
+26 ;set up for the event driver - should be treated as an edit
+27 IF (TRIES=1)
SET DGMTACT="EDT"
SET DGMTI=+NODE
DO PRIOR^DGMTEVT
+28 ;set the old test to non-primary
+29 SET DATA(2)=0
IF $$UPD^DGENDBS(408.31,+NODE,.DATA)
End DoDot:1
+30 ;
+31 ;don't want any old RX copay tests as primary either - if needed, they can be auto-created based on the means test
+32 FOR TRIES=1,2
SET NODE=$$LST^DGMTU(DFN,YREND,2)
IF '(+NODE)
QUIT
IF ($EXTRACT($PIECE(NODE,"^",2),1,3)'=$EXTRACT(MTDATE,1,3))
QUIT
Begin DoDot:1
+33 NEW DATA
+34 ;set the old test to non-primary
+35 SET DATA(2)=0
IF $$UPD^DGENDBS(408.31,+NODE,.DATA)
End DoDot:1
+36 ;
+37 ;mark this test as primary
+38 KILL DATA
SET DATA(2)=1
IF $$UPD^DGENDBS(408.31,MTIEN,.DATA)
+39 ;
+40 ; Get Last Primary Means Test irrespective of income year
+41 SET LSTNODE=$$LST^DGMTU(DFN)
+42 ;if STATUS is REQUIRED & test is PRIMARY, then set it to NOT PRIMARY
+43 ;if the uploaded test is MT COPAY REQUIRED
+44 ; MT COPAY (CAT C) doesn't expire, which is why you have to
+45 ; flip the test to Not Primary eg 02/01/2005
+46 IF $PIECE(LSTNODE,U,4)="R"
IF +$GET(^DGMT(408.31,+LSTNODE,"PRIM"))
IF $PIECE(^DGMT(408.31,MTIEN,0),U,3)=6
Begin DoDot:1
+47 NEW DATA
SET DATA(2)=0
IF $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
End DoDot:1
+48 ;if means test is required and test is primary and not a CAT C,
+49 ;and it hasn't expired, flip the test to Not Primary eg 02/23/2005
+50 IF $PIECE(LSTNODE,U,4)="R"
IF +$GET(^DGMT(408.31,+LSTNODE,"PRIM"))
IF $PIECE(^DGMT(408.31,MTIEN,0),U,3)'=6
IF '$$OLD(MTDATE)
Begin DoDot:1
+51 NEW DATA
SET DATA(2)=0
IF $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
End DoDot:1
+52 ;
+53 ;If this is a Z10 upload, call the means test event driver and quit.
+54 ;
+55 IF $GET(IVMZ10)="UPLOAD IN PROGRESS"
Begin DoDot:1
+56 SET DGMTI=MTIEN
+57 SET DGMTINF=1
+58 DO QUE^DGMTR
End DoDot:1
QUIT
+59 ;
+60 ;If the test is still in effect, need to do additional checks
+61 ;and call event driver
+62 ;
+63 IF '$$OLD(MTDATE)
Begin DoDot:1
+64 ;Mark this test as NO LONGER REQUIRED - calling EN^DGMTR will
+65 ;change it back to its old status if required and will que the event
+66 ;driver
+67 KILL DATA
+68 SET DATA(.03)=$$GETSTAT^DGMTH("N",1)
+69 IF $$UPD^DGENDBS(408.31,MTIEN,.DATA)
+70 ;don't want new test added or messages
SET (DGADDF,DGMSGF)=1
+71 SET DGMTI=MTIEN
+72 SET DGMTINF=1
+73 ;
+74 DO EN^DGMTR
+75 ;if the test wasn't required, maybe a Rx copay test is needed
+76 IF '$GET(DGREQF)
IF '$GET(DGDOM1)
DO COPYRX^DGMTR1(DFN,MTIEN)
End DoDot:1
+77 QUIT
+78 ;
RXPRIME(RXIEN) ;
+1 ;Makes phramacy copay test =RXIEN the primary test
+2 ;
+3 NEW DGREQF,DGDOM1,DGADDF,DGMSGF,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTA,TRIES,DATA,NODE,DFN,MTIEN,DGRAUTO,DGADDF,DGMTE,DGMTCOR,DGMT,YREND,RXPRIME,QUIT
+4 ;
+5 IF ('$GET(RXIEN))
QUIT
+6 SET RXPRIME="DGMTU4"
+7 SET QUIT=0
+8 SET NODE=$GET(^DGMT(408.31,RXIEN,0))
+9 IF (NODE="")
QUIT
+10 SET DFN=$PIECE($GET(^DGMT(408.31,RXIEN,0)),"^",2)
+11 IF 'DFN
QUIT
+12 ;already marked as primary!
IF +$GET(^DGMT(408.31,RXIEN,"PRIM"))
QUIT
+13 SET MTDATE=+NODE
+14 IF 'MTDATE
QUIT
+15 IF ($PIECE(NODE,"^",19)'=2)
QUIT
+16 ;
+17 SET DGMTINF=1
+18 ;
+19 ;marks any existing tests as non-primary - shouldn't be more than
+20 ;one such test, but give it two tries
+21 ;
+22 IF '$$OLD(MTDATE)
Begin DoDot:1
+23 SET YREND=DT_.2359
End DoDot:1
+24 IF '$TEST
Begin DoDot:1
+25 SET YREND=$EXTRACT(MTDATE,1,3)_1231.9999
End DoDot:1
+26 FOR TRIES=1,2
SET NODE=$$LST^DGMTU(DFN,YREND,2)
IF '(+NODE)
QUIT
IF ($EXTRACT($PIECE(NODE,"^",2),1,3)'=$EXTRACT(MTDATE,1,3))
QUIT
Begin DoDot:1
+27 NEW DATA
+28 ;set up for the event driver - should be treated as an edit
+29 IF (TRIES=1)
SET DGMTACT="EDT"
SET DGMTI=+NODE
DO PRIOR^DGMTEVT
+30 ;set the old test to non-primary
+31 SET DATA(2)=0
IF $$UPD^DGENDBS(408.31,+NODE,.DATA)
End DoDot:1
+32 ;
+33 ;don't want any old means tests marked as primary - unless they are actually needed! In which case, do not make this Rx test primary.
+34 FOR TRIES=1,2
SET NODE=$$LST^DGMTU(DFN,YREND,1)
IF '(+NODE)
QUIT
IF ($EXTRACT($PIECE(NODE,"^",2),1,3)'=$EXTRACT(MTDATE,1,3))
QUIT
Begin DoDot:1
+35 NEW DATA
+36 IF '$$OLD($PIECE(NODE,"^",2))
IF $PIECE(NODE,"^",4)'=""
IF "ACGP"[$PIECE(NODE,"^",4)
SET QUIT=1
QUIT
+37 ;set the old test to non-primary
+38 SET DATA(2)=0
IF $$UPD^DGENDBS(408.31,+NODE,.DATA)
End DoDot:1
+39 ;
+40 IF QUIT
GOTO QRXPRIME
+41 ;mark this test as primary - calling
+42 ;EN^DGMTCOR will change it to NO LONGER APPLICABLE if appropriate
+43 ;
+44 KILL DATA
+45 SET DATA(2)=1
IF $$UPD^DGENDBS(408.31,RXIEN,.DATA)
+46 ;
+47 ;If the test is still in effect, need to do additional checks
+48 ;and call event driver
+49 ;
+50 IF '$$OLD(MTDATE)
Begin DoDot:1
+51 ;don't want new test added or messages
SET DGMSGF=1
SET DGADDF=0
+52 ;
+53 ;EN^DGMTR will first create a stub for a required MT if needed, then
+54 ;call ^DGMTCOR to set the status of the copay test
+55 DO EN^DGMTR
+56 ;
+57 ;if the pharmacy copay test was determined to be required, than
+58 ;que the event driver
+59 IF DGMTCOR
Begin DoDot:2
+60 SET DGMTACT="ADD"
+61 DO PRIOR^DGMTEVT
+62 SET DGMTI=RXIEN
+63 DO QUE^DGMTR
End DoDot:2
End DoDot:1
QRXPRIME ;
+1 QUIT
+2 ;
OLD(TESTDATE) ;
+1 ;Checks if the date is older than 365 days. Returns 0 for no, 1 for yes
+2 ;if the test is exactly 365 days,
+3 ;it is considered expired eg 03/09/2005
+4 IF ($$FMDIFF^XLFDT(DT,TESTDATE)'<365)
QUIT 1
+5 QUIT 0
+6 ;
TRANSFER(DFN,FROM,TO) ;
+1 ;transfers the Income Relations from the test=FROM to test=TO
+2 ;
+3 NEW DGINI,DGINR,DATA,ERROR
+4 IF '$GET(DFN)
QUIT
+5 IF '$GET(FROM)
QUIT
+6 IF '$GET(TO)
QUIT
+7 IF (FROM=TO)
QUIT
+8 SET DGINI=0
FOR
SET DGINI=$ORDER(^DGMT(408.22,"AMT",FROM,DFN,DGINI))
IF 'DGINI
QUIT
SET DGINR=$ORDER(^DGMT(408.22,"AMT",FROM,DFN,DGINI,""))
IF $PIECE($GET(^DGMT(408.22,+DGINR,"MT")),"^")]""
Begin DoDot:1
+9 KILL DATA
+10 SET DATA(31)=TO
+11 IF $$UPD^DGENDBS(408.22,+DGINR,.DATA,.ERROR)
End DoDot:1
+12 QUIT
+13 ;
GETINCOM(DFN,TDATE) ;
+1 ;Makes sure Income Relations point to the right test
+2 ;
+3 ;Input:
+4 ; DFN
+5 ; TDATE -income year of test (uses $E(IVMMTDT,1,3))
+6 ;Output: none. Repoints Income Relations if necessary
+7 ;
+8 NEW MTNODE,RXNODE,IVMMTDT,CODE,ACTVIEN
+9 IF '$GET(TDATE)
QUIT
+10 IF '$GET(DFN)
QUIT
+11 ;
+12 SET IVMMTDT=$EXTRACT(TDATE,1,3)_"1231.9"
+13 SET (CODE,ACTVIEN)=""
+14 SET MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1)
IF $EXTRACT($PIECE(MTNODE,"^",2),1,3)'=$EXTRACT(IVMMTDT,1,3)
SET MTNODE=""
+15 SET RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2)
IF $EXTRACT($PIECE(RXNODE,"^",2),1,3)'=$EXTRACT(IVMMTDT,1,3)
SET RXNODE=""
+16 ;
+17 Begin DoDot:1
+18 ;determine which test has the associated income relations
+19 ;
+20 IF +MTNODE
SET CODE=$PIECE(MTNODE,"^",4)
IF CODE'=""
IF ("ACGPR"[CODE)
SET ACTVIEN=+MTNODE
QUIT
+21 IF +RXNODE
SET CODE=$PIECE(RXNODE,"^",4)
IF CODE'=""
IF ("EMI"[CODE)
SET ACTVIEN=+RXNODE
QUIT
+22 IF +MTNODE
SET ACTVIEN=+MTNODE
QUIT
+23 IF +RXNODE
SET ACTVIEN=+RXNODE
QUIT
End DoDot:1
+24 IF ACTVIEN
IF +MTNODE
IF +RXNODE
DO TRANSFER^DGMTU4(DFN,$SELECT((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
+25 QUIT
+26 ;
CHKPT(DFN) ;
+1 ; Cross check the CURRENT MEANS TEST STATUS in the PATIENT File (#2) with the
+2 ; primary means test in the ANNUAL MEANS TEST File (#408.31). Update the
+3 ; CURRENT MEANS TEST STATUS if the fields are out of synch.
+4 ;
+5 NEW PATMT,DGMTI,DATA
+6 ;
+7 IF $GET(DFN)'>0
QUIT
+8 IF '$DATA(^DPT(DFN))
QUIT
+9 SET PATMT=$$GET1^DIQ(2,DFN,.14,"I")
+10 SET DGMTI=+$$LST^DGMTU(DFN)
+11 SET DATA(.14)=$PIECE($GET(^DGMT(408.31,DGMTI,0)),U,3)
+12 IF DATA(.14)=PATMT
QUIT
+13 ;
+14 IF $$UPD^DGENDBS(2,DFN,.DATA)
+15 QUIT
