EASECDEL ;ALB/LBD - Delete a LTC Copay Test; 2 JUN 2003
;;1.0;ENROLLMENT APPLICATION SYSTEM;**34**;Mar 15, 2001
;
EN ; Entry point to delete a LTC copay test
I '$D(^XUSEC("DG MTDELETE",+DUZ)) W !!,"ACCESS TO THIS OPTION IS RESTRICTED!!",*7 G EXIT
;
LKP ; Patient lookup
N DIC,DTOUT,DUOUT,DGMTYPT,DGNAM,DGDOB,VA,Y
S DGMTYPT=3
D HOME^%ZIS S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC G:$D(DTOUT)!($D(DUOUT))!(+Y<0) EXIT
I '$O(^DGMT(408.31,"AD",DGMTYPT,+Y,0)) W !?5,$P(Y(0),U)," has no LTC copay (10-10EC) tests on file." G LKP
S DFN=+Y,DGNAM=$P(Y(0),U),DGDOB=$P(Y(0),U,3)
D HD
;
LKT ; LTC Copay Test lookup
N D,DIC,DGMTI,DGMTDT,DIR,X,Y
S DIC("W")="D ID^EASECDEL",DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT"
W ! S DIC="^DGMT(408.31,",DIC(0)="EQZ",X=DFN,D="C" D IX^DIC K DIC
I $D(DTOUT)!($D(DUOUT))!(+Y<0) G LKP
I '$P($G(^DG(408.34,+$P(Y(0),U,23),0)),U,2) W !,?5,"This LTC Copay Test (10-10EC) is uneditable and cannot be deleted." G LKP
S DGMTI=+Y,DGMTDT=$P(Y(0),U)
S DIR(0)="Y",DIR("A")="Display test",DIR("B")="YES"
D ^DIR K DIR I Y D HD,DISPLAY^EASECU23(DGMTI,DGMTYPT)
S DIR(0)="Y",DIR("A")="Are you sure you want to delete the "_$$FMTE^XLFDT(DGMTDT,1)_" test",DIR("B")="NO"
W ! D ^DIR K DIR I Y'=1 W !," <OK, nothing deleted!>" G LKP
D DEL(DGMTI,DFN) W !," <LTC Copay Test deleted.>"
G LKP
EXIT Q
;
DEL(DGMTI,DFN) ; Delete selected LTC Copay Test from Annual Means Test file
; #408.31 and all entries that point to it in the Individual Annual
; Income file #408.21 and the Income Relations file #408.22.
; INPUT - DGMTI IEN of LTC Copay Test to delete from file #408.31
; DFN IEN of Patient file #2
; OUTPUT - none
N DIK,DA,DGX,DGY,LTC4
S LTC4=$P($G(^DGMT(408.31,DGMTI,2)),U,8)
S DA=DGMTI,DIK="^DGMT(408.31," D ^DIK K DIK
S DIK="^DGMT(408.22,",DGY=0
F S DGY=$O(^DGMT(408.22,"AMT",DGMTI,DFN,DGY)) Q:'DGY S DGX=0 F S DGX=$O(^DGMT(408.22,"AMT",DGMTI,DFN,DGY,DGX)) Q:'DGX S DA=DGX D ^DIK
S DGX=0
F S DGX=$O(^DGMT(408.21,"AM",DGMTI,DGX)) Q:'DGX S DIK="^DGMT(408.21,",DA=DGX D ^DIK D
.S DGY=0 F S DGY=$O(^DGMT(408.22,"AIND",DGX,DGY)) Q:'DGY S DIK="^DGMT(408.22,",DA=DGY D ^DIK
; Delete associated LTC Copay Exemption test (type 4) if it's
; not associated with any other LTC Copay test.
Q:'LTC4 Q:$O(^DGMT(408.31,"AT",LTC4,""))
D DEL4(LTC4)
Q
;
DEL4(LTC4) ; Delete LTC Copay Exemption Test (type 4) associated with
; LTC Copay Test. Update IVM Patient file to send deletion to HEC.
; INPUT - LTC4 IEN of LTC Copay Exemption Test to delete from #408.31
N DGMTDT,DGMTI,DGMTP,DGMTA,DGMTINF,DGMTACT,DGMTYPT
S DGMTI=$G(LTC4) Q:'DGMTI
S DGMTDT=$P($G(^DGMT(408.31,DGMTI,0)),U) Q:'DGMTDT
S DGMTP=$G(^DGMT(408.31,DGMTI,0))
D DELETE^IVMPLOG(DFN,DGMTDT,,,,4)
S DA=DGMTI,DIK="^DGMT(408.31," D ^DIK
S DGMTACT="DEL" D AFTER^DGMTEVT
S DGMTYPT=4,DGMTINF=1 D EN^DGMTAUD
D ^IVMPMTE
Q
HD ; Writes patient header to the screen
W @IOF,"Name: ",DGNAM,?40,"DOB: ",$$FMTE^XLFDT(DGDOB),?65,"Pat ID: ",$$PID(DFN),!!!
Q
;
PID(DFN) ; Return PID
; INPUT - DFN
; OUTPUT - PID or 'UNKNOWN'
D PID^VADPT6
Q $S(VA("PID")]"":VA("PID"),1:"UNKNOWN")
;
ID ; Write identifiers for test lookup
N DGI,DGN
S DGI=Y,DGN=$G(^DGMT(408.31,DGI,0))
W " LTC Copay Test Date Status: ",$$S^DGMTAUD1($P(^(0),U,3))
W !?36,"Source: ",$$SR^DGMTAUD1(DGN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECDEL 3374 printed Sep 23, 2025@19:29:56 Page 2
EASECDEL ;ALB/LBD - Delete a LTC Copay Test; 2 JUN 2003
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**34**;Mar 15, 2001
+2 ;
EN ; Entry point to delete a LTC copay test
+1 IF '$DATA(^XUSEC("DG MTDELETE",+DUZ))
WRITE !!,"ACCESS TO THIS OPTION IS RESTRICTED!!",*7
GOTO EXIT
+2 ;
LKP ; Patient lookup
+1 NEW DIC,DTOUT,DUOUT,DGMTYPT,DGNAM,DGDOB,VA,Y
+2 SET DGMTYPT=3
+3 DO HOME^%ZIS
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
WRITE !
DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<0)
GOTO EXIT
+4 IF '$ORDER(^DGMT(408.31,"AD",DGMTYPT,+Y,0))
WRITE !?5,$PIECE(Y(0),U)," has no LTC copay (10-10EC) tests on file."
GOTO LKP
+5 SET DFN=+Y
SET DGNAM=$PIECE(Y(0),U)
SET DGDOB=$PIECE(Y(0),U,3)
+6 DO HD
+7 ;
LKT ; LTC Copay Test lookup
+1 NEW D,DIC,DGMTI,DGMTDT,DIR,X,Y
+2 SET DIC("W")="D ID^EASECDEL"
SET DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT"
+3 WRITE !
SET DIC="^DGMT(408.31,"
SET DIC(0)="EQZ"
SET X=DFN
SET D="C"
DO IX^DIC
KILL DIC
+4 IF $DATA(DTOUT)!($DATA(DUOUT))!(+Y<0)
GOTO LKP
+5 IF '$PIECE($GET(^DG(408.34,+$PIECE(Y(0),U,23),0)),U,2)
WRITE !,?5,"This LTC Copay Test (10-10EC) is uneditable and cannot be deleted."
GOTO LKP
+6 SET DGMTI=+Y
SET DGMTDT=$PIECE(Y(0),U)
+7 SET DIR(0)="Y"
SET DIR("A")="Display test"
SET DIR("B")="YES"
+8 DO ^DIR
KILL DIR
IF Y
DO HD
DO DISPLAY^EASECU23(DGMTI,DGMTYPT)
+9 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete the "_$$FMTE^XLFDT(DGMTDT,1)_" test"
SET DIR("B")="NO"
+10 WRITE !
DO ^DIR
KILL DIR
IF Y'=1
WRITE !," <OK, nothing deleted!>"
GOTO LKP
+11 DO DEL(DGMTI,DFN)
WRITE !," <LTC Copay Test deleted.>"
+12 GOTO LKP
EXIT QUIT
+1 ;
DEL(DGMTI,DFN) ; Delete selected LTC Copay Test from Annual Means Test file
+1 ; #408.31 and all entries that point to it in the Individual Annual
+2 ; Income file #408.21 and the Income Relations file #408.22.
+3 ; INPUT - DGMTI IEN of LTC Copay Test to delete from file #408.31
+4 ; DFN IEN of Patient file #2
+5 ; OUTPUT - none
+6 NEW DIK,DA,DGX,DGY,LTC4
+7 SET LTC4=$PIECE($GET(^DGMT(408.31,DGMTI,2)),U,8)
+8 SET DA=DGMTI
SET DIK="^DGMT(408.31,"
DO ^DIK
KILL DIK
+9 SET DIK="^DGMT(408.22,"
SET DGY=0
+10 FOR
SET DGY=$ORDER(^DGMT(408.22,"AMT",DGMTI,DFN,DGY))
if 'DGY
QUIT
SET DGX=0
FOR
SET DGX=$ORDER(^DGMT(408.22,"AMT",DGMTI,DFN,DGY,DGX))
if 'DGX
QUIT
SET DA=DGX
DO ^DIK
+11 SET DGX=0
+12 FOR
SET DGX=$ORDER(^DGMT(408.21,"AM",DGMTI,DGX))
if 'DGX
QUIT
SET DIK="^DGMT(408.21,"
SET DA=DGX
DO ^DIK
Begin DoDot:1
+13 SET DGY=0
FOR
SET DGY=$ORDER(^DGMT(408.22,"AIND",DGX,DGY))
if 'DGY
QUIT
SET DIK="^DGMT(408.22,"
SET DA=DGY
DO ^DIK
End DoDot:1
+14 ; Delete associated LTC Copay Exemption test (type 4) if it's
+15 ; not associated with any other LTC Copay test.
+16 if 'LTC4
QUIT
if $ORDER(^DGMT(408.31,"AT",LTC4,""))
QUIT
+17 DO DEL4(LTC4)
+18 QUIT
+19 ;
DEL4(LTC4) ; Delete LTC Copay Exemption Test (type 4) associated with
+1 ; LTC Copay Test. Update IVM Patient file to send deletion to HEC.
+2 ; INPUT - LTC4 IEN of LTC Copay Exemption Test to delete from #408.31
+3 NEW DGMTDT,DGMTI,DGMTP,DGMTA,DGMTINF,DGMTACT,DGMTYPT
+4 SET DGMTI=$GET(LTC4)
if 'DGMTI
QUIT
+5 SET DGMTDT=$PIECE($GET(^DGMT(408.31,DGMTI,0)),U)
if 'DGMTDT
QUIT
+6 SET DGMTP=$GET(^DGMT(408.31,DGMTI,0))
+7 DO DELETE^IVMPLOG(DFN,DGMTDT,,,,4)
+8 SET DA=DGMTI
SET DIK="^DGMT(408.31,"
DO ^DIK
+9 SET DGMTACT="DEL"
DO AFTER^DGMTEVT
+10 SET DGMTYPT=4
SET DGMTINF=1
DO EN^DGMTAUD
+11 DO ^IVMPMTE
+12 QUIT
HD ; Writes patient header to the screen
+1 WRITE @IOF,"Name: ",DGNAM,?40,"DOB: ",$$FMTE^XLFDT(DGDOB),?65,"Pat ID: ",$$PID(DFN),!!!
+2 QUIT
+3 ;
PID(DFN) ; Return PID
+1 ; INPUT - DFN
+2 ; OUTPUT - PID or 'UNKNOWN'
+3 DO PID^VADPT6
+4 QUIT $SELECT(VA("PID")]"":VA("PID"),1:"UNKNOWN")
+5 ;
ID ; Write identifiers for test lookup
+1 NEW DGI,DGN
+2 SET DGI=Y
SET DGN=$GET(^DGMT(408.31,DGI,0))
+3 WRITE " LTC Copay Test Date Status: ",$$S^DGMTAUD1($PIECE(^(0),U,3))
+4 WRITE !?36,"Source: ",$$SR^DGMTAUD1(DGN)
+5 QUIT
