DGMTDEL ;ALB/TET,RMO,CAW,LD,SCG - DELETE MEANS TEST for a Patient ;5/11/92 09:40
;;5.3;Registration;**33,45,182,344,407,433**;Aug 13, 1993
;
EN ;Entry point to delete means test
I '$D(^XUSEC("DG MTDELETE",+DUZ)) W !!,"ACCESS TO THIS OPTION IS RESTRICTED!!",*7 G EXIT
F I=1:1 S J=$P($T(TXT+I),";;",2) Q:J="END" W !,J
; - if type of test = means test, diplay MT text
I DGMTYPT=1 F I=1:1 S J=$P($T(MTTXT+I),";;",2) Q:J="END" W !,J
; - if type of test = copay test, display CT text
I DGMTYPT=2 F I=1:1 S J=$P($T(CTTXT+I),";;",2) Q:J="END" W !,J
; - if type of test = LTC copay exemption test, display LTC text
I DGMTYPT=4 F I=1:1 S J=$P($T(LTCTXT+I),";;",2) Q:J="END" W !,J
;
LKP ;Patient lookup
N DGMDOD,DGFLG
D HOME^%ZIS S DIC="^DPT(",DIC(0)="AEQMZ" 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 "_$S(DGMTYPT=1:"means",DGMTYPT=2:"copay",DGMTYPT=4:"LTC copay exemption",1:"")_" tests on file." K DIC,Y G LKP
S DFN=+Y,DGNAM=$P(Y(0),U),DG0=Y(0) K DIC,Y
I $P($G(^DPT(DFN,.35)),U)'="" S DGMDOD=$P(^DPT(DFN,.35),U)
I $G(DGMDOD) W !,*7,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D") G EXIT
W @IOF,"Name: ",$P(DGNAM,U),?40,"DOB: ",$$DATE^DGMTDEL1($P(DG0,U,3)),?60,"PT ID: ",$$PID^DGMTDEL1(DFN),!!!
D DIS^DGMTU(DFN) W !!
VET ;determine if patient is a vet; set dgnvet flag (1=nonvet,0=vet)
S DGNVET=0 ;,DGNVET=+$P($G(^DPT(DFN,.36)),U),DGNVET=$P($G(^DIC(8,DGNVET,0)),U,5),DGNVET=$S(DGNVET="N":1,1:0)
S DGNVET=$S($P($G(^DIC(8,+$P($G(^DPT(DFN,.36)),U),0)),U,5)="N":1,1:0)
I 'DGNVET S:$G(^DPT(DFN,"VET"))="N" DGNVET=1
G:'DGNVET LKM ;Q
S DIR("A")="Do you wish to delete all "_$S(DGMTYPT=1:"means",DGMTYPT=2:"copay",DGMTYPT=4:"LTC copay exemption",1:"")_" tests on file for this patient",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR G LKP:$D(DIRUT),LOOP^DGMTDEL1:Y
LKM ;Means test lookup
S DIC("W")="D ID^DGMTDEL1",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 X["?" W !,"Enter appropriate corresponding number." G LKM
G LKP:$D(DTOUT)!($D(DUOUT))!(+Y<0)
I DGMTYPT=1!(DGMTYPT=2) D G:$G(DGFLG) LKP
.I ('$P($G(^DG(408.34,+$P(Y(0),"^",23),0)),U,2))!('$P($G(^DGMT(408.31,+Y,"PRIM")),"^")) W !?5,*7,"This "_$S(DGMTYPT=1:"means",DGMTYPT=2:"copay")_" test is uneditable and cannot be deleted." S DGFLG=1
I DGMTYPT=4 D G:$G(DGFLG) LKP
. I '$P($G(^DG(408.34,+$P(Y(0),"^",23),0)),U,2) W !,?5,*7,"This LTC Copay Exemption Test is uneditable and cannot be deleted." S DGFLG=1
S DGMTI=+Y,DGMT0=Y(0) D VAR^DGMTDEL1 K DIC,Y
S DIR("A")="Are you sure you want to delete the "_$$DATE^DGMTDEL1(DGMTD)_" test date",DIR(0)="Y",DIR("B")="NO"
D ^DIR K DIR G LKP:$D(DIRUT)!('Y) D DEL^DGMTDEL1 W !,$S(DGMTYPT=1:"Means",DGMTYPT=2:"Copay",DGMTYPT=4:"LTC copay exemption",1:"")_" test deleted."
S DGMT=$$LST^DGMTU(DFN,"",DGMTYPT) I DGMTYPT=1,DGMT]"",$P(DGMT,U,2)<DGMTD D
.Q:$P(DGMT,U,4)=$P(DGCAT,U,2)
.W !,"Previous Means Test Category of '",$P(DGCAT,U),"'",!," has been changed to '",$P(DGMT,U,3),"'"
.S DGMTACT="CAT",DGMTP=DGP,DGMTI=+DGMT D AFTER^DGMTEVT
.S DGMTINF=0 D EN^DGMTEVT
EXIT K DFN,DGCAT,DGCT,DGI,DGN,DGNAM,DGNVET,DGP,DG0,DGMT,DGMTA,DGMTACT,DGMTD,DGMTI,DGMTINF,DGMTSRC,DGMTY,DGMT0,DGMTYPT,DGMTATYP
K D,DA,DIC,DIE,DIK,DIR,DIRUT,DTOUT,DUOUT,DGMTA,DGMTP,I,J,VA,VADAT,VADATE,X,Y
Q
;
TXT ;informational text displayed to user
;;
;;This option is used to delete financial test data which may have been
;;inadvertantly entered. Under normal circumstances only individual
;;dates of test may be deleted using this option. The exception is
;;non-veterans. All financial tests found for a non-veteran may be
;;deleted.
;;END
MTTXT ;informational text displayed to user if type of test = means test
;;
;;A means test may not be deleted under the following conditions:
;; 1) The means test is an uploaded test from the IVM Center.
;; 2) The means test is a test that was done at the VAMC but has
;; an associated uploaded means test from the IVM Center.
;;END
CTTXT ;informational text displayed to user if type of test = copay test
;;
;;A copay test may not be deleted under the following conditions:
;; 1) The copay test is an uploaded test from the IVM Center.
;; 2) The copay test is a test that was done at the VAMC but has
;; an associated uploaded copay test from the IVM Center.
;;END
LTCTXT ;informational text displayed to user if type of test = LTC copay test
;;
;;A LTC copay exemption test may not be deleted under the following conditions:
;; 1) The LTC copay exemption test is an uploaded test from the IVM Center.
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTDEL 4683 printed Sep 23, 2025@20:20:41 Page 2
DGMTDEL ;ALB/TET,RMO,CAW,LD,SCG - DELETE MEANS TEST for a Patient ;5/11/92 09:40
+1 ;;5.3;Registration;**33,45,182,344,407,433**;Aug 13, 1993
+2 ;
EN ;Entry point to delete means test
+1 IF '$DATA(^XUSEC("DG MTDELETE",+DUZ))
WRITE !!,"ACCESS TO THIS OPTION IS RESTRICTED!!",*7
GOTO EXIT
+2 FOR I=1:1
SET J=$PIECE($TEXT(TXT+I),";;",2)
if J="END"
QUIT
WRITE !,J
+3 ; - if type of test = means test, diplay MT text
+4 IF DGMTYPT=1
FOR I=1:1
SET J=$PIECE($TEXT(MTTXT+I),";;",2)
if J="END"
QUIT
WRITE !,J
+5 ; - if type of test = copay test, display CT text
+6 IF DGMTYPT=2
FOR I=1:1
SET J=$PIECE($TEXT(CTTXT+I),";;",2)
if J="END"
QUIT
WRITE !,J
+7 ; - if type of test = LTC copay exemption test, display LTC text
+8 IF DGMTYPT=4
FOR I=1:1
SET J=$PIECE($TEXT(LTCTXT+I),";;",2)
if J="END"
QUIT
WRITE !,J
+9 ;
LKP ;Patient lookup
+1 NEW DGMDOD,DGFLG
+2 DO HOME^%ZIS
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<0)
GOTO EXIT
+3 IF '$ORDER(^DGMT(408.31,"AD",DGMTYPT,+Y,0))
WRITE !?5,$PIECE(Y(0),U)," has no "_$SELECT(DGMTYPT=1:"means",DGMTYPT=2:"copay",DGMTYPT=4:"LTC copay exemption",1:"")_" tests on file."
KILL DIC,Y
GOTO LKP
+4 SET DFN=+Y
SET DGNAM=$PIECE(Y(0),U)
SET DG0=Y(0)
KILL DIC,Y
+5 IF $PIECE($GET(^DPT(DFN,.35)),U)'=""
SET DGMDOD=$PIECE(^DPT(DFN,.35),U)
+6 IF $GET(DGMDOD)
WRITE !,*7,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D")
GOTO EXIT
+7 WRITE @IOF,"Name: ",$PIECE(DGNAM,U),?40,"DOB: ",$$DATE^DGMTDEL1($PIECE(DG0,U,3)),?60,"PT ID: ",$$PID^DGMTDEL1(DFN),!!!
+8 DO DIS^DGMTU(DFN)
WRITE !!
VET ;determine if patient is a vet; set dgnvet flag (1=nonvet,0=vet)
+1 ;,DGNVET=+$P($G(^DPT(DFN,.36)),U),DGNVET=$P($G(^DIC(8,DGNVET,0)),U,5),DGNVET=$S(DGNVET="N":1,1:0)
SET DGNVET=0
+2 SET DGNVET=$SELECT($PIECE($GET(^DIC(8,+$PIECE($GET(^DPT(DFN,.36)),U),0)),U,5)="N":1,1:0)
+3 IF 'DGNVET
if $GET(^DPT(DFN,"VET"))="N"
SET DGNVET=1
+4 ;Q
if 'DGNVET
GOTO LKM
+5 SET DIR("A")="Do you wish to delete all "_$SELECT(DGMTYPT=1:"means",DGMTYPT=2:"copay",DGMTYPT=4:"LTC copay exemption",1:"")_" tests on file for this patient"
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO LKP
if Y
GOTO LOOP^DGMTDEL1
LKM ;Means test lookup
+1 SET DIC("W")="D ID^DGMTDEL1"
SET DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,19)=DGMTYPT"
+2 WRITE !
SET DIC="^DGMT(408.31,"
SET DIC(0)="EQZ"
SET X=DFN
SET D="C"
DO IX^DIC
KILL DIC
IF X["?"
WRITE !,"Enter appropriate corresponding number."
GOTO LKM
+3 if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<0)
GOTO LKP
+4 IF DGMTYPT=1!(DGMTYPT=2)
Begin DoDot:1
+5 IF ('$PIECE($GET(^DG(408.34,+$PIECE(Y(0),"^",23),0)),U,2))!('$PIECE($GET(^DGMT(408.31,+Y,"PRIM")),"^"))
WRITE !?5,*7,"This "_$SELECT(DGMTYPT=1:"means",DGMTYPT=2:"copay")_" test is uneditable and cannot be deleted."
SET DGFLG=1
End DoDot:1
if $GET(DGFLG)
GOTO LKP
+6 IF DGMTYPT=4
Begin DoDot:1
+7 IF '$PIECE($GET(^DG(408.34,+$PIECE(Y(0),"^",23),0)),U,2)
WRITE !,?5,*7,"This LTC Copay Exemption Test is uneditable and cannot be deleted."
SET DGFLG=1
End DoDot:1
if $GET(DGFLG)
GOTO LKP
+8 SET DGMTI=+Y
SET DGMT0=Y(0)
DO VAR^DGMTDEL1
KILL DIC,Y
+9 SET DIR("A")="Are you sure you want to delete the "_$$DATE^DGMTDEL1(DGMTD)_" test date"
SET DIR(0)="Y"
SET DIR("B")="NO"
+10 DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO LKP
DO DEL^DGMTDEL1
WRITE !,$SELECT(DGMTYPT=1:"Means",DGMTYPT=2:"Copay",DGMTYPT=4:"LTC copay exemption",1:"")_" test deleted."
+11 SET DGMT=$$LST^DGMTU(DFN,"",DGMTYPT)
IF DGMTYPT=1
IF DGMT]""
IF $PIECE(DGMT,U,2)<DGMTD
Begin DoDot:1
+12 if $PIECE(DGMT,U,4)=$PIECE(DGCAT,U,2)
QUIT
+13 WRITE !,"Previous Means Test Category of '",$PIECE(DGCAT,U),"'",!," has been changed to '",$PIECE(DGMT,U,3),"'"
+14 SET DGMTACT="CAT"
SET DGMTP=DGP
SET DGMTI=+DGMT
DO AFTER^DGMTEVT
+15 SET DGMTINF=0
DO EN^DGMTEVT
End DoDot:1
EXIT KILL DFN,DGCAT,DGCT,DGI,DGN,DGNAM,DGNVET,DGP,DG0,DGMT,DGMTA,DGMTACT,DGMTD,DGMTI,DGMTINF,DGMTSRC,DGMTY,DGMT0,DGMTYPT,DGMTATYP
+1 KILL D,DA,DIC,DIE,DIK,DIR,DIRUT,DTOUT,DUOUT,DGMTA,DGMTP,I,J,VA,VADAT,VADATE,X,Y
+2 QUIT
+3 ;
TXT ;informational text displayed to user
+1 ;;
+2 ;;This option is used to delete financial test data which may have been
+3 ;;inadvertantly entered. Under normal circumstances only individual
+4 ;;dates of test may be deleted using this option. The exception is
+5 ;;non-veterans. All financial tests found for a non-veteran may be
+6 ;;deleted.
+7 ;;END
MTTXT ;informational text displayed to user if type of test = means test
+1 ;;
+2 ;;A means test may not be deleted under the following conditions:
+3 ;; 1) The means test is an uploaded test from the IVM Center.
+4 ;; 2) The means test is a test that was done at the VAMC but has
+5 ;; an associated uploaded means test from the IVM Center.
+6 ;;END
CTTXT ;informational text displayed to user if type of test = copay test
+1 ;;
+2 ;;A copay test may not be deleted under the following conditions:
+3 ;; 1) The copay test is an uploaded test from the IVM Center.
+4 ;; 2) The copay test is a test that was done at the VAMC but has
+5 ;; an associated uploaded copay test from the IVM Center.
+6 ;;END
LTCTXT ;informational text displayed to user if type of test = LTC copay test
+1 ;;
+2 ;;A LTC copay exemption test may not be deleted under the following conditions:
+3 ;; 1) The LTC copay exemption test is an uploaded test from the IVM Center.
+4 ;;END
