- 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 Feb 19, 2025@00:10:51 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
