DGMTAUD2 ;ALB/CAW,BRM - Means test audit delete ; 12/20/01 9:22am
;;5.3;Registration;**45,166,182,300,433**;Aug 13, 1993
;
DIS ;Display changes pertaining to a means test for a vet
;
LKP ;Vet lookup
S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G:$D(DTOUT)!($D(DUOUT))!(+Y<0) KIL
I '$O(^DGMT(408.31,"AD",DGMTYPT,+Y,0)) W !?5,$P(Y(0),U)," has no "_$P("means^copay^^LTC exemption","^",DGMTYPT)_" test on file." K DIC,Y G LKP
S DFN=+Y,DGNAM=$P(Y(0),U) K DIC,Y
;
LKM ;Means test lookup
S DIC("W")="W ?27,$P(""MEANS^COPAY^^LTC EXEMPTION"",""^"",DGMTYPT)_"" TEST "",?42,$S($G(^DGMT(408.31,+Y,""PRIM""))=1:"" **PRIMARY** "",1:""""),?60,$$SR^DGMTAUD1($G(^DGMT(408.31,+Y,0)),+Y)",DIC("S")="I $P(^(0),U,2)=DFN&($P(^(0),U,19)=DGMTYPT)"
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
I $D(DTOUT)!($D(DUOUT)) D KIL Q
I +Y<0 G LKP
S DGMTI=+Y,DGMTD=$P(Y(0),U) K DIC,Y
S DGDASH="",$P(DGDASH,"=",79)="" D HDR^DGMTAUD1 I '$O(^DGMT(408.41,"AM",DGMTYPT,DFN,DGMTI,0)) W !?5,"There are no changes to the "_$P("means^copay^^LTC exemption","^",DGMTYPT)_" test.",! G KIL
;
;Loop thru xref;write data
S DGMTAI=0 F S DGMTAI=$O(^DGMT(408.41,"AM",DGMTYPT,DFN,DGMTI,DGMTAI)) Q:'DGMTAI S DGMTAIZ=$G(^DGMT(408.41,DGMTAI,0)) I DGMTAIZ]"" D:IOSL'>($Y+4) CR G:$D(DTOUT)!($D(DUOUT)) KIL D
.W !?2,$$D^DGMTAUD1($P(DGMTAIZ,U)),?23,$$C^DGMTAUD1($P(DGMTAIZ,U,2)),?57,$E($$U^DGMTAUD1($P(DGMTAIZ,U,7)),1,20)
.I $P(DGMTAIZ,U,5,6)'="^" W !?23,"OLD STATUS VALUE: ",$S($P(DGMTAIZ,U,5)']"":"<Nothing>",1:$P(DGMTAIZ,U,5)),!?23,"NEW STATUS VALUE: ",$S($P(DGMTAIZ,U,6)']"":"<Nothing>",1:$P(DGMTAIZ,U,6))
.I $P(DGMTAIZ,U,8,9)'="^" W !?23,"OLD SOURCE OF TEST: ",$S($P(DGMTAIZ,U,8)']"":"<Nothing>",1:$P(DGMTAIZ,U,8)),!?23,"NEW SOURCE OF TEST: ",$S($P(DGMTAIZ,U,9)']"":"<Nothing>",1:$P(DGMTAIZ,U,9))
G LKP
;
KIL K D,DGDASH,DGMTAI,DGMTAIZ,DGMTD,DGMTI,DGMTYPT,DGNAM,DFN,DIC,DTOUT,DUOUT,X,Y
Q
CR I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR W:'Y @IOF D:Y HDR^DGMTAUD1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTAUD2 2036 printed Oct 16, 2024@18:45:16 Page 2
DGMTAUD2 ;ALB/CAW,BRM - Means test audit delete ; 12/20/01 9:22am
+1 ;;5.3;Registration;**45,166,182,300,433**;Aug 13, 1993
+2 ;
DIS ;Display changes pertaining to a means test for a vet
+1 ;
LKP ;Vet lookup
+1 SET DIC="^DPT("
SET DIC(0)="AEQMZ"
DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(+Y<0)
GOTO KIL
+2 IF '$ORDER(^DGMT(408.31,"AD",DGMTYPT,+Y,0))
WRITE !?5,$PIECE(Y(0),U)," has no "_$PIECE("means^copay^^LTC exemption","^",DGMTYPT)_" test on file."
KILL DIC,Y
GOTO LKP
+3 SET DFN=+Y
SET DGNAM=$PIECE(Y(0),U)
KILL DIC,Y
+4 ;
LKM ;Means test lookup
+1 SET DIC("W")="W ?27,$P(""MEANS^COPAY^^LTC EXEMPTION"",""^"",DGMTYPT)_"" TEST "",?42,$S($G(^DGMT(408.31,+Y,""PRIM""))=1:"" **PRIMARY** "",1:""""),?60,$$SR^DGMTAUD1($G(^DGMT(408.31,+Y,0)),+Y)"
SET DIC("S")="I $P(^(0),U,2)=DFN&($P(^(0),U,19)=DGMTYPT)"
+2 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))
DO KIL
QUIT
+4 IF +Y<0
GOTO LKP
+5 SET DGMTI=+Y
SET DGMTD=$PIECE(Y(0),U)
KILL DIC,Y
+6 SET DGDASH=""
SET $PIECE(DGDASH,"=",79)=""
DO HDR^DGMTAUD1
IF '$ORDER(^DGMT(408.41,"AM",DGMTYPT,DFN,DGMTI,0))
WRITE !?5,"There are no changes to the "_$PIECE("means^copay^^LTC exemption","^",DGMTYPT)_" test.",!
GOTO KIL
+7 ;
+8 ;Loop thru xref;write data
+9 SET DGMTAI=0
FOR
SET DGMTAI=$ORDER(^DGMT(408.41,"AM",DGMTYPT,DFN,DGMTI,DGMTAI))
if 'DGMTAI
QUIT
SET DGMTAIZ=$GET(^DGMT(408.41,DGMTAI,0))
IF DGMTAIZ]""
if IOSL'>($Y+4)
DO CR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO KIL
Begin DoDot:1
+10 WRITE !?2,$$D^DGMTAUD1($PIECE(DGMTAIZ,U)),?23,$$C^DGMTAUD1($PIECE(DGMTAIZ,U,2)),?57,$EXTRACT($$U^DGMTAUD1($PIECE(DGMTAIZ,U,7)),1,20)
+11 IF $PIECE(DGMTAIZ,U,5,6)'="^"
WRITE !?23,"OLD STATUS VALUE: ",$SELECT($PIECE(DGMTAIZ,U,5)']"":"<Nothing>",1:$PIECE(DGMTAIZ,U,5)),!?23,"NEW STATUS VALUE: ",$SELECT($PIECE(DGMTAIZ,U,6)']"":"<Nothing>",1:$PIECE(DGMTAIZ,U,6))
+12 IF $PIECE(DGMTAIZ,U,8,9)'="^"
WRITE !?23,"OLD SOURCE OF TEST: ",$SELECT($PIECE(DGMTAIZ,U,8)']"":"<Nothing>",1:$PIECE(DGMTAIZ,U,8)),!?23,"NEW SOURCE OF TEST: ",$SELECT($PIECE(DGMTAIZ,U,9)']"":"<Nothing>",1:$PIECE(DGMTAIZ,U,9))
End DoDot:1
+13 GOTO LKP
+14 ;
KIL KILL D,DGDASH,DGMTAI,DGMTAIZ,DGMTD,DGMTI,DGMTYPT,DGNAM,DFN,DIC,DTOUT,DUOUT,X,Y
+1 QUIT
CR IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
WRITE @IOF
if Y
DO HDR^DGMTAUD1
+1 QUIT
