- EASECU ;ALB/PHH,LBD,AMA,HM - LTC Co-Pay Test Utilities ; 22 AUG 2001
- ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40,79,174**;Mar 15, 2001;Build 26
- ;
- LST(DFN,DGDT,DGMTYPT) ;Last LTC Co-Pay test for a patient
- ; Input -- DFN Patient IEN
- ; DGDT Date/Time (Optional- default today@2359)
- ; DGMTYPT Type of Test (Optional - if not defined
- ; LTC Co-Pay will be assumed)
- ; Output -- LTC Co-Pay Test IEN^Date of Test
- ; ^Status Name^Status Code^Source of Test
- N DGIDT,DGMTFL1,DGMTI,DGNOD,Y I '$D(DGMTYPT) S DGMTYPT=3
- S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
- F S DGIDT=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT)) Q:'DGIDT!$G(DGMTFL1) D
- . F DGMTI=0:0 S DGMTI=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT,DGMTI)) Q:'DGMTI!$G(DGMTFL1) D
- . . S DGNOD=$G(^DGMT(408.31,DGMTI,0)) I DGNOD S DGMTFL1=1,Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS(+$P(^(0),"^",3))_"^"_$P(DGNOD,"^",23)
- Q $G(Y)
- ;
- MTS(DGMTS) ;LTC Co-Pay test status -- default current
- ; Input -- DGMTS LTC Co-Pay Test Status IEN
- ; Output -- Status Name^Status Code
- N Y
- I $G(DGMTS) S Y=$P($G(^DG(408.32,DGMTS,0)),"^",1,2)
- Q $G(Y)
- ;
- EXMPT(DFN) ;Check if veteran is exempt from LTC co-payments:
- ; If the veteran has a compensable SC disability, OR
- ; If the veteran is a single, NSC pensioner not in receipt of A&A
- ; If the veteran is a Medal of Honor recipient - EAS*1.0*174 HM
- ; and HB benefits
- ; Input -- DFN Patient IEN
- ; Output -- 0 = veteran not exempt
- ; 1 = veteran has compensable SC disability
- ; 2 = veteran is single NSC pensioner (no A&A, HB)
- ; 14 = veteran is Medal of Honor recipient - EAS*1.0*174 HM
- N X,Y,ELG
- S Y=0
- ; if service connected percentage is greater than 10% OR service
- ; connected percentage is less than 10% and annual VA
- ; check amount is greater than 0, then exempt type 1
- S X=$G(^DPT(DFN,.36)),ELG=$P($G(^DIC(8,+X,0)),U,9)
- I ELG=1!($P($G(^DPT(DFN,.3)),U,2)'<10) S Y=1 G EXMPTQ
- I ELG=3,$P($G(^DPT(DFN,.3)),U,2)<10,$P($G(^DPT(DFN,.362)),U,20)>0 S Y=1 G EXMPTQ
- ;if MOH = "Y" quit
- I $P($G(^DPT(DFN,.54)),U,1)="Y" S Y=14 G EXMPTQ ;IF MEDAL OF HONOR = "Y" SET OUTPUT TO BE 14 EAS*1*174 HM
- ; if Service Connected quit
- I $P($G(^DPT(DFN,.3)),U)="Y" G EXMPTQ
- ; if Marital Status = 'Married' or 'Separated' quit
- S X=$P($G(^DIC(11,+$P($G(^DPT(DFN,0)),U,5),0)),U,3)
- I "^M^S^"[("^"_X_"^") G EXMPTQ
- ; if not receiving VA pension quit
- S X=$G(^DPT(DFN,.362)) I $P(X,U,14)'="Y" G EXMPTQ
- ; if receiving A&A or HP benefits quit
- I $P(X,U,12)="Y"!($P(X,U,13)="Y") G EXMPTQ
- S Y=2
- EXMPTQ Q Y
- ;
- DIS(DFN) ;Display patient's current LTC Copay Test status and test date
- ; Input -- DFN IEN of Patient file
- ; Output -- None
- N DGX,DGMTI,DGMTDT,DGMTS
- Q:'$G(DFN)
- S DGX=$$LST(DFN) Q:'DGX
- S DGMTI=+DGX,DGMTDT=$P(DGX,U,2),DGMTS=$P(DGX,U,3) S:DGMTS="" DGMTS="UNKNOWN"
- W !,"LTC Copayment Status: ",DGMTS," Last Test: " S Y=DGMTDT X ^DD("DD") W Y
- ; If last test is over a year old and patient is not deceased or not
- ; exempt due to eligibility (compensable SC) or LTC before 11/30/99
- ; display message that a new test is required
- I $$FMDIFF^XLFDT(DT,DGMTDT)>364 D
- . I $P($G(^DPT(DFN,.35)),U) Q
- . I "^1^4^"[(U_$P($G(^DGMT(408.31,DGMTI,2)),U,7)_U) Q
- . W " **NEW TEST REQUIRED**"
- I $P($G(^DGMT(408.31,DGMTI,0)),U,11)=0 W !,"Patient INELIGIBLE to Receive LTC Services -- Did Not Agree to Pay Copayments"
- Q
- ;
- FORM(DGMTI) ; Return the version of the 10-10EC form used to complete
- ; the LTC Copay Test passed in DGMTI
- ; Input: DGMTI - LTC Copay Test (IEN file #408.31)
- ; Output: 0 = Original format
- ; 1 = Revised format
- I '$G(DGMTI) Q 0
- Q $P($G(^DGMT(408.31,DGMTI,2)),U,10)
- ;
- ;EAS*1.0*79 - Instead of changing DIS (in case another routine
- ; calls it), copied it but also used LTC Admission Date
- DISDT(DFN,EASADM) ;Display patient's LTC Copay Test status for a given LTC Admission Date
- ; Input -- DFN - IEN of Patient file
- ; EASADM - LTC Admission Date
- ; Output -- None
- N DGX,DGMTI,DGMTDT,DGMTS
- Q:'$G(DFN) Q:'$G(EASADM)
- S DGX=$$LST(DFN,EASADM) Q:'DGX
- S DGMTI=+DGX,DGMTDT=$P(DGX,U,2),DGMTS=$P(DGX,U,3) S:DGMTS="" DGMTS="UNKNOWN"
- W !,"LTC Copayment Status: ",DGMTS," Last Test: " S Y=DGMTDT X ^DD("DD") W Y
- ; If last test is over a year old and patient is not deceased or not
- ; exempt due to eligibility (compensable SC) or LTC before 11/30/99
- ; display message that a new test is required
- I $$FMDIFF^XLFDT(DT,DGMTDT)>364 D
- . I $P($G(^DPT(DFN,.35)),U) Q
- . I "^1^4^"[(U_$P($G(^DGMT(408.31,DGMTI,2)),U,7)_U) Q
- . W " **NEW TEST REQUIRED**"
- I $P($G(^DGMT(408.31,DGMTI,0)),U,11)=0 W !,"Patient INELIGIBLE to Receive LTC Services -- Did Not Agree to Pay Copayments"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECU 4924 printed Jan 18, 2025@02:55:33 Page 2
- EASECU ;ALB/PHH,LBD,AMA,HM - LTC Co-Pay Test Utilities ; 22 AUG 2001
- +1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40,79,174**;Mar 15, 2001;Build 26
- +2 ;
- LST(DFN,DGDT,DGMTYPT) ;Last LTC Co-Pay test for a patient
- +1 ; Input -- DFN Patient IEN
- +2 ; DGDT Date/Time (Optional- default today@2359)
- +3 ; DGMTYPT Type of Test (Optional - if not defined
- +4 ; LTC Co-Pay will be assumed)
- +5 ; Output -- LTC Co-Pay Test IEN^Date of Test
- +6 ; ^Status Name^Status Code^Source of Test
- +7 NEW DGIDT,DGMTFL1,DGMTI,DGNOD,Y
- IF '$DATA(DGMTYPT)
- SET DGMTYPT=3
- +8 SET DGIDT=$SELECT($GET(DGDT)>0:-DGDT,1:-DT)
- if '$PIECE(DGIDT,".",2)
- SET DGIDT=DGIDT_.2359
- +9 FOR
- SET DGIDT=+$ORDER(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT))
- if 'DGIDT!$GET(DGMTFL1)
- QUIT
- Begin DoDot:1
- +10 FOR DGMTI=0:0
- SET DGMTI=+$ORDER(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT,DGMTI))
- if 'DGMTI!$GET(DGMTFL1)
- QUIT
- Begin DoDot:2
- +11 SET DGNOD=$GET(^DGMT(408.31,DGMTI,0))
- IF DGNOD
- SET DGMTFL1=1
- SET Y=DGMTI_"^"_$PIECE(^(0),"^")_"^"_$$MTS(+$PIECE(^(0),"^",3))_"^"_$PIECE(DGNOD,"^",23)
- End DoDot:2
- End DoDot:1
- +12 QUIT $GET(Y)
- +13 ;
- MTS(DGMTS) ;LTC Co-Pay test status -- default current
- +1 ; Input -- DGMTS LTC Co-Pay Test Status IEN
- +2 ; Output -- Status Name^Status Code
- +3 NEW Y
- +4 IF $GET(DGMTS)
- SET Y=$PIECE($GET(^DG(408.32,DGMTS,0)),"^",1,2)
- +5 QUIT $GET(Y)
- +6 ;
- EXMPT(DFN) ;Check if veteran is exempt from LTC co-payments:
- +1 ; If the veteran has a compensable SC disability, OR
- +2 ; If the veteran is a single, NSC pensioner not in receipt of A&A
- +3 ; If the veteran is a Medal of Honor recipient - EAS*1.0*174 HM
- +4 ; and HB benefits
- +5 ; Input -- DFN Patient IEN
- +6 ; Output -- 0 = veteran not exempt
- +7 ; 1 = veteran has compensable SC disability
- +8 ; 2 = veteran is single NSC pensioner (no A&A, HB)
- +9 ; 14 = veteran is Medal of Honor recipient - EAS*1.0*174 HM
- +10 NEW X,Y,ELG
- +11 SET Y=0
- +12 ; if service connected percentage is greater than 10% OR service
- +13 ; connected percentage is less than 10% and annual VA
- +14 ; check amount is greater than 0, then exempt type 1
- +15 SET X=$GET(^DPT(DFN,.36))
- SET ELG=$PIECE($GET(^DIC(8,+X,0)),U,9)
- +16 IF ELG=1!($PIECE($GET(^DPT(DFN,.3)),U,2)'<10)
- SET Y=1
- GOTO EXMPTQ
- +17 IF ELG=3
- IF $PIECE($GET(^DPT(DFN,.3)),U,2)<10
- IF $PIECE($GET(^DPT(DFN,.362)),U,20)>0
- SET Y=1
- GOTO EXMPTQ
- +18 ;if MOH = "Y" quit
- +19 ;IF MEDAL OF HONOR = "Y" SET OUTPUT TO BE 14 EAS*1*174 HM
- IF $PIECE($GET(^DPT(DFN,.54)),U,1)="Y"
- SET Y=14
- GOTO EXMPTQ
- +20 ; if Service Connected quit
- +21 IF $PIECE($GET(^DPT(DFN,.3)),U)="Y"
- GOTO EXMPTQ
- +22 ; if Marital Status = 'Married' or 'Separated' quit
- +23 SET X=$PIECE($GET(^DIC(11,+$PIECE($GET(^DPT(DFN,0)),U,5),0)),U,3)
- +24 IF "^M^S^"[("^"_X_"^")
- GOTO EXMPTQ
- +25 ; if not receiving VA pension quit
- +26 SET X=$GET(^DPT(DFN,.362))
- IF $PIECE(X,U,14)'="Y"
- GOTO EXMPTQ
- +27 ; if receiving A&A or HP benefits quit
- +28 IF $PIECE(X,U,12)="Y"!($PIECE(X,U,13)="Y")
- GOTO EXMPTQ
- +29 SET Y=2
- EXMPTQ QUIT Y
- +1 ;
- DIS(DFN) ;Display patient's current LTC Copay Test status and test date
- +1 ; Input -- DFN IEN of Patient file
- +2 ; Output -- None
- +3 NEW DGX,DGMTI,DGMTDT,DGMTS
- +4 if '$GET(DFN)
- QUIT
- +5 SET DGX=$$LST(DFN)
- if 'DGX
- QUIT
- +6 SET DGMTI=+DGX
- SET DGMTDT=$PIECE(DGX,U,2)
- SET DGMTS=$PIECE(DGX,U,3)
- if DGMTS=""
- SET DGMTS="UNKNOWN"
- +7 WRITE !,"LTC Copayment Status: ",DGMTS," Last Test: "
- SET Y=DGMTDT
- XECUTE ^DD("DD")
- WRITE Y
- +8 ; If last test is over a year old and patient is not deceased or not
- +9 ; exempt due to eligibility (compensable SC) or LTC before 11/30/99
- +10 ; display message that a new test is required
- +11 IF $$FMDIFF^XLFDT(DT,DGMTDT)>364
- Begin DoDot:1
- +12 IF $PIECE($GET(^DPT(DFN,.35)),U)
- QUIT
- +13 IF "^1^4^"[(U_$PIECE($GET(^DGMT(408.31,DGMTI,2)),U,7)_U)
- QUIT
- +14 WRITE " **NEW TEST REQUIRED**"
- End DoDot:1
- +15 IF $PIECE($GET(^DGMT(408.31,DGMTI,0)),U,11)=0
- WRITE !,"Patient INELIGIBLE to Receive LTC Services -- Did Not Agree to Pay Copayments"
- +16 QUIT
- +17 ;
- FORM(DGMTI) ; Return the version of the 10-10EC form used to complete
- +1 ; the LTC Copay Test passed in DGMTI
- +2 ; Input: DGMTI - LTC Copay Test (IEN file #408.31)
- +3 ; Output: 0 = Original format
- +4 ; 1 = Revised format
- +5 IF '$GET(DGMTI)
- QUIT 0
- +6 QUIT $PIECE($GET(^DGMT(408.31,DGMTI,2)),U,10)
- +7 ;
- +8 ;EAS*1.0*79 - Instead of changing DIS (in case another routine
- +9 ; calls it), copied it but also used LTC Admission Date
- DISDT(DFN,EASADM) ;Display patient's LTC Copay Test status for a given LTC Admission Date
- +1 ; Input -- DFN - IEN of Patient file
- +2 ; EASADM - LTC Admission Date
- +3 ; Output -- None
- +4 NEW DGX,DGMTI,DGMTDT,DGMTS
- +5 if '$GET(DFN)
- QUIT
- if '$GET(EASADM)
- QUIT
- +6 SET DGX=$$LST(DFN,EASADM)
- if 'DGX
- QUIT
- +7 SET DGMTI=+DGX
- SET DGMTDT=$PIECE(DGX,U,2)
- SET DGMTS=$PIECE(DGX,U,3)
- if DGMTS=""
- SET DGMTS="UNKNOWN"
- +8 WRITE !,"LTC Copayment Status: ",DGMTS," Last Test: "
- SET Y=DGMTDT
- XECUTE ^DD("DD")
- WRITE Y
- +9 ; If last test is over a year old and patient is not deceased or not
- +10 ; exempt due to eligibility (compensable SC) or LTC before 11/30/99
- +11 ; display message that a new test is required
- +12 IF $$FMDIFF^XLFDT(DT,DGMTDT)>364
- Begin DoDot:1
- +13 IF $PIECE($GET(^DPT(DFN,.35)),U)
- QUIT
- +14 IF "^1^4^"[(U_$PIECE($GET(^DGMT(408.31,DGMTI,2)),U,7)_U)
- QUIT
- +15 WRITE " **NEW TEST REQUIRED**"
- End DoDot:1
- +16 IF $PIECE($GET(^DGMT(408.31,DGMTI,0)),U,11)=0
- WRITE !,"Patient INELIGIBLE to Receive LTC Services -- Did Not Agree to Pay Copayments"
- +17 QUIT