- DGMTU4 ;ALB/CJM,SCG,LBD,EG,PHH,BDB MEANS TEST UTILITES ; 06/07/2005
- ;;5.3;Registration;**182,267,285,347,454,456,476,610,658,858**;Aug 13, 1993;Build 30
- ;
- 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
- ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- I $P(LSTNODE,U,4)="R",+$G(^DGMT(408.31,+LSTNODE,"PRIM")),$P(^DGMT(408.31,MTIEN,0),U,3)'=6,'$$OLDMTPF(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
- ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- I '$$OLDMTPF(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
- .;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- .I '$$OLDMTPF($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
- ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- I '$$OLDMTPF(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
- I TESTDATE<(DT-10000) Q 1
- Q 0
- ;
- OLDMTPF(TESTDATE) ;
- ;For the Discontinue Annual Means Test Renewal project DG*5.3*858
- ;Checks if the date is more than 1 year older than the Discontinue
- ; Annual Means Test Renewal Point Forward Date.
- ;Discontinue Annual Means Test Renewal Point Forward Date
- ;Input TESTDATE - Means Test Date
- ;
- ;Output 0 for No
- ; 1 for Yes
- ;
- N DGMTPFD
- S DGMTPFD=$P(^DG(43,1,"VFA"),"^",1)
- I TESTDATE<(DGMTPFD-10000) 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTU4 10398 printed Jan 18, 2025@03:46:20 Page 2
- DGMTU4 ;ALB/CJM,SCG,LBD,EG,PHH,BDB MEANS TEST UTILITES ; 06/07/2005
- +1 ;;5.3;Registration;**182,267,285,347,454,456,476,610,658,858**;Aug 13, 1993;Build 30
- +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 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- +51 IF $PIECE(LSTNODE,U,4)="R"
- IF +$GET(^DGMT(408.31,+LSTNODE,"PRIM"))
- IF $PIECE(^DGMT(408.31,MTIEN,0),U,3)'=6
- IF '$$OLDMTPF(MTDATE)
- Begin DoDot:1
- +52 NEW DATA
- SET DATA(2)=0
- IF $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
- End DoDot:1
- +53 ;
- +54 ;If this is a Z10 upload, call the means test event driver and quit.
- +55 ;
- +56 IF $GET(IVMZ10)="UPLOAD IN PROGRESS"
- Begin DoDot:1
- +57 SET DGMTI=MTIEN
- +58 SET DGMTINF=1
- +59 DO QUE^DGMTR
- End DoDot:1
- QUIT
- +60 ;
- +61 ;If the test is still in effect, need to do additional checks
- +62 ;and call event driver
- +63 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- +64 IF '$$OLDMTPF(MTDATE)
- Begin DoDot:1
- +65 ;Mark this test as NO LONGER REQUIRED - calling EN^DGMTR will
- +66 ;change it back to its old status if required and will que the event
- +67 ;driver
- +68 KILL DATA
- +69 SET DATA(.03)=$$GETSTAT^DGMTH("N",1)
- +70 IF $$UPD^DGENDBS(408.31,MTIEN,.DATA)
- +71 ;don't want new test added or messages
- SET (DGADDF,DGMSGF)=1
- +72 SET DGMTI=MTIEN
- +73 SET DGMTINF=1
- +74 ;
- +75 DO EN^DGMTR
- +76 ;if the test wasn't required, maybe a Rx copay test is needed
- +77 IF '$GET(DGREQF)
- IF '$GET(DGDOM1)
- DO COPYRX^DGMTR1(DFN,MTIEN)
- End DoDot:1
- +78 QUIT
- +79 ;
- 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 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- +37 IF '$$OLDMTPF($PIECE(NODE,"^",2))
- IF $PIECE(NODE,"^",4)'=""
- IF "ACGP"[$PIECE(NODE,"^",4)
- SET QUIT=1
- QUIT
- +38 ;set the old test to non-primary
- +39 SET DATA(2)=0
- IF $$UPD^DGENDBS(408.31,+NODE,.DATA)
- End DoDot:1
- +40 ;
- +41 IF QUIT
- GOTO QRXPRIME
- +42 ;mark this test as primary - calling
- +43 ;EN^DGMTCOR will change it to NO LONGER APPLICABLE if appropriate
- +44 ;
- +45 KILL DATA
- +46 SET DATA(2)=1
- IF $$UPD^DGENDBS(408.31,RXIEN,.DATA)
- +47 ;
- +48 ;If the test is still in effect, need to do additional checks
- +49 ;and call event driver
- +50 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- +51 IF '$$OLDMTPF(MTDATE)
- Begin DoDot:1
- +52 ;don't want new test added or messages
- SET DGMSGF=1
- SET DGADDF=0
- +53 ;
- +54 ;EN^DGMTR will first create a stub for a required MT if needed, then
- +55 ;call ^DGMTCOR to set the status of the copay test
- +56 DO EN^DGMTR
- +57 ;
- +58 ;if the pharmacy copay test was determined to be required, than
- +59 ;que the event driver
- +60 IF DGMTCOR
- Begin DoDot:2
- +61 SET DGMTACT="ADD"
- +62 DO PRIOR^DGMTEVT
- +63 SET DGMTI=RXIEN
- +64 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 ;I ($$FMDIFF^XLFDT(DT,TESTDATE)'<365) Q 1
- +5 IF TESTDATE<(DT-10000)
- QUIT 1
- +6 QUIT 0
- +7 ;
- OLDMTPF(TESTDATE) ;
- +1 ;For the Discontinue Annual Means Test Renewal project DG*5.3*858
- +2 ;Checks if the date is more than 1 year older than the Discontinue
- +3 ; Annual Means Test Renewal Point Forward Date.
- +4 ;Discontinue Annual Means Test Renewal Point Forward Date
- +5 ;Input TESTDATE - Means Test Date
- +6 ;
- +7 ;Output 0 for No
- +8 ; 1 for Yes
- +9 ;
- +10 NEW DGMTPFD
- +11 SET DGMTPFD=$PIECE(^DG(43,1,"VFA"),"^",1)
- +12 IF TESTDATE<(DGMTPFD-10000)
- QUIT 1
- +13 QUIT 0
- +14 ;
- 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