- DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD,BDB,HM - COPAY UTILITIES;8/13/04 8:31am
- ;;5.3;Registration;**33,45,54,335,358,401,436,445,564,840,858,972**;Aug 13, 1993;Build 80
- AUTO(DFN,AUTOEX) ;
- ; Returns 1 if Exempt from CP w/o needing MT/CP information
- ; INPUT: DFN [Required]
- ; AUTOEX [Optional]
- ; RETURNS 1=Exempt 0=Not Exempt
- ;
- ; Hold the Auto exclusion information for later use
- S AUTOEX=$$AUTOINFO(DFN)
- ;
- Q AUTOEX["1"
- AUTOINFO(DFN) ;
- ; This returns info needed to IB to see if MT information needs to be
- ; looked at to determine Copay Exemption Status
- ;
- ; INPUT: DFN - IEN of Patient File (Required)
- ; OUTPUT:(SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PT^NON.VET^INPT^POW^UNEMP^CD^MOH)
- ; Piece: ( 1 ^ 2 ^ 3 ^ 4 ^ 5 ^ 6 ^ 7 ^ 8 ^ 9 ^10 ^ 11)
- ; PIECES =1 IF TRUE
- ;
- ; Supported ICR #423: Supports use of AUTOINFO^DGMTCOU1(DFN) to check if a veteran
- ; is MOH recipient
- ;
- N DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT,DGI
- S DGX=""
- I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S $P(DGX,U,6)=1 G QTAUTO ;NON-VET
- S DGEL=0,DGALLEL=U
- F S DGEL=$O(^DPT("AEL",DFN,DGEL)) Q:'DGEL S DGALLEL=DGALLEL_$P($G(^DIC(8,DGEL,0)),U,9)_U
- F DGI=.3,.362,.39,.52,.54 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) ;DG*5.3*840 ;added MOH indicator field on loop DG*5.3*972 HM
- I (DGALLEL["^1^") S $P(DGX,U,1)=1 G QTAUTO ;SC>50
- I $P(DGNODE(.362),U,12)["Y"!(DGALLEL["^2^") S $P(DGX,U,2)=1 G QTAUTO ;A&A
- I $P(DGNODE(.362),U,13)["Y"!(DGALLEL["^15^") S $P(DGX,U,3)=1 G QTAUTO ;HB
- I $P(DGNODE(.362),U,14)["Y"!(DGALLEL["^4^") S $P(DGX,U,4)=1 G QTAUTO ;PENSION
- I $P(DGNODE(.52),U,5)["Y"!(DGALLEL["^18^") S $P(DGX,U,8)=1 G QTAUTO ;POW
- I $P(DGNODE(.39),U,6)["Y"!(DGALLEL["^21^") S $P(DGX,U,10)=1 G QTAUTO ;CD DG*5.3*840
- I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S $P(DGX,U,9)=1 G QTAUTO ;UNEMPLOYABLE
- I $P(DGNODE(.54),U,1)["Y" S $P(DGX,U,11)=1 G QTAUTO ; MOH DG*5.3*972 HM
- N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
- D DOM^DGMTR I $G(DGDOM) S $P(DGX,U,5)=1 G QTAUTO ;DOM
- D IN5^VADPT I $G(VAIP(1))'="" S $P(DGX,U,7)=1 G QTAUTO ;INPAT
- QTAUTO Q DGX
- ;
- LST(DFN,DGDT,DGMTYPT1) ;Last Copay Exemption or Means Test for a patient
- ; Input -- DFN Patient IEN
- ; DGDT Date/Time (Optional- default today@2359)
- ; DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
- ; Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
- ; Piece: 1 ^ 2 3 4 5
- ;
- N DGCPDT,DGIDT,DGIDT,DGMTDT,DGMTI,Y
- S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
- I '$D(DGMTYPT1) S DGMTYPT1=3
- I DGMTYPT1=3 D ;EITHER
- .S DGMTDT=+$O(^DGMT(408.31,"AID",1,DFN,DGIDT))
- .S DGCPDT=+$O(^DGMT(408.31,"AID",2,DFN,DGIDT))
- .S DGMTYPT1=$S(DGCPDT<DGMTDT:2,(DGCPDT>DGMTDT):1,$D(^DGMT(408.31,"AS",1,3,+DGMTDT,DFN)):2,1:1)
- S DGMTI=+$$LST^DGMTU(DFN,$P(DGIDT,"-",2),DGMTYPT1)
- I $D(^DGMT(408.31,DGMTI,0)) S Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS^DGMTU(DFN,+$P(^(0),"^",3))_"^"_DGMTYPT1
- Q $G(Y)
- THRESH(DGDT) ;PRINTS THE YEAR'S COPAY THRESHOLDS
- ;UPDATE 11/15/00 TO REFLECT YEAR'S COPAY THRESHOLDS PER VHA DIRECTIVE
- ;99-064
- N DGCPLEV,DGDEP,DGNODE,DGTYPE,Y
- I '$D(DGDT) S DGDT=DT
- S DGDT=DGDT\1
- S Y=DGDT X ^DD("DD") W !,?2,"Net Annual Income Thresholds on ",Y,":"
- S DGTYPE=$S(DGDT<2961201:2,1:1)
- S DGCPLEV=$$THRES^IBARXEU1(DGDT,DGTYPE,0)
- I DGCPLEV']"" W !,"None for this date..." G THRESHQT
- W !,?5,"Num. Dependents: ",?25,"0 (Self)",?42,1,?52,2,?62,3,?72,4
- W !,?5,"Net Income:"
- F DGDEP=0:1:4 W ?(23+(DGDEP*10)),$J(+$$THRES^IBARXEU1(DGDT,DGTYPE,DGDEP),10)
- THRESHQT Q
- DISPMAS(DFN) ; Displays Co
- N DGCPS,DGEX,Y,AUTOEX
- S DGEX=$$AUTO(DFN,.AUTOEX)
- I $P($G(AUTOEX),U,5)!($P($G(AUTOEX),U,7)) Q
- I DGEX W !,"Patient is exempt from Copay."
- I 'DGEX D
- .S DGCPS=$$LST365(DFN,DT,2),Y=$P(DGCPS,U,2)
- .I DGCPS]"" D
- ..X ^DD("DD")
- ..W !,"Patient's Copay Status is ",$P(DGCPS,U,3)
- ..W ". Last Test Date: ",Y,"."
- Q
- LST365(DFN,DGDT,DGMTYPT1) ;RETURNS CURRENT MT/CP (WITHIN 1 YEAR OF VFA START DATE)
- ; Input: DGDT - IB DATE
- ; DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
- ; Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
- ; Piece: 1 ^ 2 3 4 5
- N DGLST
- S DGDT=$G(DGDT)
- I '$D(DGMTYPT1) S DGMTYPT1=3
- S DGLST=$$LST(DFN,DGDT,DGMTYPT1)
- S:$P(DGLST,U,4)="N" DGLST=$$LST(DFN,DGDT,2)
- ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- S:$$OLDMTPF^DGMTU4($P(DGLST,U,2)) DGLST=""
- Q DGLST
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTCOU1 4632 printed Jan 18, 2025@03:45:23 Page 2
- DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD,BDB,HM - COPAY UTILITIES;8/13/04 8:31am
- +1 ;;5.3;Registration;**33,45,54,335,358,401,436,445,564,840,858,972**;Aug 13, 1993;Build 80
- AUTO(DFN,AUTOEX) ;
- +1 ; Returns 1 if Exempt from CP w/o needing MT/CP information
- +2 ; INPUT: DFN [Required]
- +3 ; AUTOEX [Optional]
- +4 ; RETURNS 1=Exempt 0=Not Exempt
- +5 ;
- +6 ; Hold the Auto exclusion information for later use
- +7 SET AUTOEX=$$AUTOINFO(DFN)
- +8 ;
- +9 QUIT AUTOEX["1"
- AUTOINFO(DFN) ;
- +1 ; This returns info needed to IB to see if MT information needs to be
- +2 ; looked at to determine Copay Exemption Status
- +3 ;
- +4 ; INPUT: DFN - IEN of Patient File (Required)
- +5 ; OUTPUT:(SC>50%^REC.A&A^REC.HB^REC.PEN^DOM PT^NON.VET^INPT^POW^UNEMP^CD^MOH)
- +6 ; Piece: ( 1 ^ 2 ^ 3 ^ 4 ^ 5 ^ 6 ^ 7 ^ 8 ^ 9 ^10 ^ 11)
- +7 ; PIECES =1 IF TRUE
- +8 ;
- +9 ; Supported ICR #423: Supports use of AUTOINFO^DGMTCOU1(DFN) to check if a veteran
- +10 ; is MOH recipient
- +11 ;
- +12 NEW DGALLEL,DGDOM,DGEL,DGNODE,DGX,DGYR,VADMVT,DGI
- +13 SET DGX=""
- +14 ;NON-VET
- IF $PIECE($GET(^DPT(DFN,"VET")),U,1)'="Y"
- SET $PIECE(DGX,U,6)=1
- GOTO QTAUTO
- +15 SET DGEL=0
- SET DGALLEL=U
- +16 FOR
- SET DGEL=$ORDER(^DPT("AEL",DFN,DGEL))
- if 'DGEL
- QUIT
- SET DGALLEL=DGALLEL_$PIECE($GET(^DIC(8,DGEL,0)),U,9)_U
- +17 ;DG*5.3*840 ;added MOH indicator field on loop DG*5.3*972 HM
- FOR DGI=.3,.362,.39,.52,.54
- SET DGNODE(DGI)=$GET(^DPT(DFN,DGI))
- +18 ;SC>50
- IF (DGALLEL["^1^")
- SET $PIECE(DGX,U,1)=1
- GOTO QTAUTO
- +19 ;A&A
- IF $PIECE(DGNODE(.362),U,12)["Y"!(DGALLEL["^2^")
- SET $PIECE(DGX,U,2)=1
- GOTO QTAUTO
- +20 ;HB
- IF $PIECE(DGNODE(.362),U,13)["Y"!(DGALLEL["^15^")
- SET $PIECE(DGX,U,3)=1
- GOTO QTAUTO
- +21 ;PENSION
- IF $PIECE(DGNODE(.362),U,14)["Y"!(DGALLEL["^4^")
- SET $PIECE(DGX,U,4)=1
- GOTO QTAUTO
- +22 ;POW
- IF $PIECE(DGNODE(.52),U,5)["Y"!(DGALLEL["^18^")
- SET $PIECE(DGX,U,8)=1
- GOTO QTAUTO
- +23 ;CD DG*5.3*840
- IF $PIECE(DGNODE(.39),U,6)["Y"!(DGALLEL["^21^")
- SET $PIECE(DGX,U,10)=1
- GOTO QTAUTO
- +24 ;UNEMPLOYABLE
- IF $PIECE(DGNODE(.3),U,5)["Y"&($PIECE(DGNODE(.3),U,2)>0)&($PIECE(DGNODE(.362),U,20)>0)
- SET $PIECE(DGX,U,9)=1
- GOTO QTAUTO
- +25 ; MOH DG*5.3*972 HM
- IF $PIECE(DGNODE(.54),U,1)["Y"
- SET $PIECE(DGX,U,11)=1
- GOTO QTAUTO
- +26 NEW DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
- +27 ;DOM
- DO DOM^DGMTR
- IF $GET(DGDOM)
- SET $PIECE(DGX,U,5)=1
- GOTO QTAUTO
- +28 ;INPAT
- DO IN5^VADPT
- IF $GET(VAIP(1))'=""
- SET $PIECE(DGX,U,7)=1
- GOTO QTAUTO
- QTAUTO QUIT DGX
- +1 ;
- LST(DFN,DGDT,DGMTYPT1) ;Last Copay Exemption or Means Test for a patient
- +1 ; Input -- DFN Patient IEN
- +2 ; DGDT Date/Time (Optional- default today@2359)
- +3 ; DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
- +4 ; Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
- +5 ; Piece: 1 ^ 2 3 4 5
- +6 ;
- +7 NEW DGCPDT,DGIDT,DGIDT,DGMTDT,DGMTI,Y
- +8 SET DGIDT=$SELECT($GET(DGDT)>0:-DGDT,1:-DT)
- if '$PIECE(DGIDT,".",2)
- SET DGIDT=DGIDT_.2359
- +9 IF '$DATA(DGMTYPT1)
- SET DGMTYPT1=3
- +10 ;EITHER
- IF DGMTYPT1=3
- Begin DoDot:1
- +11 SET DGMTDT=+$ORDER(^DGMT(408.31,"AID",1,DFN,DGIDT))
- +12 SET DGCPDT=+$ORDER(^DGMT(408.31,"AID",2,DFN,DGIDT))
- +13 SET DGMTYPT1=$SELECT(DGCPDT<DGMTDT:2,(DGCPDT>DGMTDT):1,$DATA(^DGMT(408.31,"AS",1,3,+DGMTDT,DFN)):2,1:1)
- End DoDot:1
- +14 SET DGMTI=+$$LST^DGMTU(DFN,$PIECE(DGIDT,"-",2),DGMTYPT1)
- +15 IF $DATA(^DGMT(408.31,DGMTI,0))
- SET Y=DGMTI_"^"_$PIECE(^(0),"^")_"^"_$$MTS^DGMTU(DFN,+$PIECE(^(0),"^",3))_"^"_DGMTYPT1
- +16 QUIT $GET(Y)
- THRESH(DGDT) ;PRINTS THE YEAR'S COPAY THRESHOLDS
- +1 ;UPDATE 11/15/00 TO REFLECT YEAR'S COPAY THRESHOLDS PER VHA DIRECTIVE
- +2 ;99-064
- +3 NEW DGCPLEV,DGDEP,DGNODE,DGTYPE,Y
- +4 IF '$DATA(DGDT)
- SET DGDT=DT
- +5 SET DGDT=DGDT\1
- +6 SET Y=DGDT
- XECUTE ^DD("DD")
- WRITE !,?2,"Net Annual Income Thresholds on ",Y,":"
- +7 SET DGTYPE=$SELECT(DGDT<2961201:2,1:1)
- +8 SET DGCPLEV=$$THRES^IBARXEU1(DGDT,DGTYPE,0)
- +9 IF DGCPLEV']""
- WRITE !,"None for this date..."
- GOTO THRESHQT
- +10 WRITE !,?5,"Num. Dependents: ",?25,"0 (Self)",?42,1,?52,2,?62,3,?72,4
- +11 WRITE !,?5,"Net Income:"
- +12 FOR DGDEP=0:1:4
- WRITE ?(23+(DGDEP*10)),$JUSTIFY(+$$THRES^IBARXEU1(DGDT,DGTYPE,DGDEP),10)
- THRESHQT QUIT
- DISPMAS(DFN) ; Displays Co
- +1 NEW DGCPS,DGEX,Y,AUTOEX
- +2 SET DGEX=$$AUTO(DFN,.AUTOEX)
- +3 IF $PIECE($GET(AUTOEX),U,5)!($PIECE($GET(AUTOEX),U,7))
- QUIT
- +4 IF DGEX
- WRITE !,"Patient is exempt from Copay."
- +5 IF 'DGEX
- Begin DoDot:1
- +6 SET DGCPS=$$LST365(DFN,DT,2)
- SET Y=$PIECE(DGCPS,U,2)
- +7 IF DGCPS]""
- Begin DoDot:2
- +8 XECUTE ^DD("DD")
- +9 WRITE !,"Patient's Copay Status is ",$PIECE(DGCPS,U,3)
- +10 WRITE ". Last Test Date: ",Y,"."
- End DoDot:2
- End DoDot:1
- +11 QUIT
- LST365(DFN,DGDT,DGMTYPT1) ;RETURNS CURRENT MT/CP (WITHIN 1 YEAR OF VFA START DATE)
- +1 ; Input: DGDT - IB DATE
- +2 ; DGMTYPT1 (Optional (1:MT, 2:CP, Null/Default or 3:Either)
- +3 ; Output -- MT IEN^Date of Test ^Status Name^Status Code^Type of Test
- +4 ; Piece: 1 ^ 2 3 4 5
- +5 NEW DGLST
- +6 SET DGDT=$GET(DGDT)
- +7 IF '$DATA(DGMTYPT1)
- SET DGMTYPT1=3
- +8 SET DGLST=$$LST(DFN,DGDT,DGMTYPT1)
- +9 if $PIECE(DGLST,U,4)="N"
- SET DGLST=$$LST(DFN,DGDT,2)
- +10 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
- +11 if $$OLDMTPF^DGMTU4($PIECE(DGLST,U,2))
- SET DGLST=""
- +12 QUIT DGLST