WVREFUSE ;HCIOFO/JWR - Add/Enter/Manipulate procedure refusals ;12/9/98 15:56
;;1.0;WOMEN'S HEALTH;**3**;Sep 30, 1998
EDREF ;EDIT AN EXISTING REFUSAL
D EXIT,SETVARS^WVUTL5
D TITLE^WVUTL5("EDIT A REFUSED TREATMENT") W !!
K DIC S DIC("A")=" Select DATE REFUSED: ",WVPOP=0
S DIC="^WV(790.3,",DIC(0)="QEMALZ" D ^DIC
I Y'>0!($D(DUOUT))!($D(DTOUT)) D EXIT Q
S WVDFN=$P($G(^WV(790.3,+Y,0)),U,2),DIDEL=790.3
D DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
G EDREF
Q
ADDREF ;ADD A NEW REFUSAL (not used now, use UNIV for adding a refusal)
D SETVARS^WVUTL5
D TITLE^WVUTL5("ADD A REFUSED PROCEDURE")
K DIR S DIR("A")=" Select DATE REFUSED: ",WVDFN=""
S DIR(0)="DAO",DIR("B")="TODAY"
D ^DIR K DIR I Y'>0 D EXIT Q
S DIC("DR")="1;2"
S DIC="^WV(790.3,",DIC(0)="QEMAL",X=Y
K DD,DO D FILE^DICN
Q:Y'>0
S WVDFN=$P($G(^WV(790.3,+Y,0)),U,2)
D DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
D EXIT Q
CHECK ;Checks for existing refusals for this patient within 30 day period
; for this procedure.
Q:'$D(^WV(790.3,"C",WVDFN))
N A,B,C,D,E,F K WVJR,WVJR1,DR,DIC,DA
S X1=DT,X2=-30 D C^%DTC S A=X
S X1=DT,X2=+30 D C^%DTC S B=X
S G=0 F S G=$O(^WV(790.3,"C",WVDFN,G)) Q:G'>0 S H=$G(^WV(790.3,G,0)) D
.Q:$P(H,U)'>A!($P(H,U))'<B
.Q:$P(H,U,3)'=WVJPR
.S E=$P(H,U,3),D=$P(H,U)
.S E=$S(E>0:$P($G(^WV(790.2,E,0)),U),1:"")
.S Y=D D DD^%DT S F=Y
.S WVJR(D,G)=F_" "_E
S C=1,A=0 F S A=$O(WVJR(A)) Q:A'>0 S B=0 F S B=$O(WVJR(A,B)) Q:B'>0 D
.S WVJR1(C)=B_"^"_WVJR(A,B),C=C+1
S WVC=C-1 I $D(WVJR1) D
.W !!,"The following Entries for this patient and procedure already exist in the"
.W !,"Procedure Refusal file.",!
.D LOOP W !!
.K DIR S DIR("A")="Is this a NEW Refusal? ",DIR(0)="YAO"
.S DIR("B")="Yes" D ^DIR K DIR Q:Y=1!($D(DIRUT))
.S DIR("A")="Select a Number to edit a refusal from the list. "
.S DIR(0)="NAO^1:"_WVC
.D ^DIR K DIR S WVEDREF=$S(+Y>0:+Y,1:"NS") Q:Y'>0
Q
UNIV ;Add new Refusal & check other recent (within 30 days) Refusals
D SETVARS^WVUTL5
D TITLE^WVUTL5("ADD/EDIT A REFUSED TREATMENT")
W !! K DIC S DIC("A")=" Select PATIENT: "
S DIC(0)="AEMQZ",DIC="^WV(790,",DIC("W")="D LOOKL^WVUTL1A(+Y)"
D ^DIC K DIC I Y'>0 D EXIT Q
S WVDFN=+Y
S DIR("A")=" DATE REFUSED: "
S DIR(0)="DAO"
D ^DIR K DIR I Y'>0 D EXIT Q
S WVJDAY=+Y
S DIR(0)="PAO^790.2:AEMNQZ",DIR("A")=" PROCEDURE: "
D ^DIR K DIR I Y'>0 D EXIT Q
S WVJPR=+Y
K WVEDREF D CHECK I $D(DIRUT) K DIRUT D EXIT G UNIV
I $G(WVEDREF)>0 D G UNIV
.S DIDEL=790.3
.D DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+WVJR1(WVEDREF))
I $G(WVEDREF)="NS" D EXIT G UNIV
L +^WV(790.3)
S DIC="^WV(790.3,",DIC(0)="QEMAL",X=WVJDAY
S DIC("DR")="1////^S X=WVDFN;2////^S X=WVJPR"
K DD,DO D FILE^DICN
L -^WV(790.3)
Q:Y'>0
S WVDFN=$P($G(^WV(790.3,+Y,0)),U,2)
D DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
G UNIV
Q
EXIT ;kill variables
D KILLALL^WVUTL8 K WVEDREF,WVJPR,WVJDAY
Q
LOOP ;Loop though the array of refuals for this patient & write them out
S D=0 F S D=$O(WVJR1(D)) Q:D'>0 D
.W !,$J(D,6),". ",$P($G(WVJR1(D)),U,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVREFUSE 3133 printed Apr 09, 2024@21:48:43 Page 2
WVREFUSE ;HCIOFO/JWR - Add/Enter/Manipulate procedure refusals ;12/9/98 15:56
+1 ;;1.0;WOMEN'S HEALTH;**3**;Sep 30, 1998
EDREF ;EDIT AN EXISTING REFUSAL
+1 DO EXIT
DO SETVARS^WVUTL5
+2 DO TITLE^WVUTL5("EDIT A REFUSED TREATMENT")
WRITE !!
+3 KILL DIC
SET DIC("A")=" Select DATE REFUSED: "
SET WVPOP=0
+4 SET DIC="^WV(790.3,"
SET DIC(0)="QEMALZ"
DO ^DIC
+5 IF Y'>0!($DATA(DUOUT))!($DATA(DTOUT))
DO EXIT
QUIT
+6 SET WVDFN=$PIECE($GET(^WV(790.3,+Y,0)),U,2)
SET DIDEL=790.3
+7 DO DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
+8 GOTO EDREF
+9 QUIT
ADDREF ;ADD A NEW REFUSAL (not used now, use UNIV for adding a refusal)
+1 DO SETVARS^WVUTL5
+2 DO TITLE^WVUTL5("ADD A REFUSED PROCEDURE")
+3 KILL DIR
SET DIR("A")=" Select DATE REFUSED: "
SET WVDFN=""
+4 SET DIR(0)="DAO"
SET DIR("B")="TODAY"
+5 DO ^DIR
KILL DIR
IF Y'>0
DO EXIT
QUIT
+6 SET DIC("DR")="1;2"
+7 SET DIC="^WV(790.3,"
SET DIC(0)="QEMAL"
SET X=Y
+8 KILL DD,DO
DO FILE^DICN
+9 if Y'>0
QUIT
+10 SET WVDFN=$PIECE($GET(^WV(790.3,+Y,0)),U,2)
+11 DO DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
+12 DO EXIT
QUIT
CHECK ;Checks for existing refusals for this patient within 30 day period
+1 ; for this procedure.
+2 if '$DATA(^WV(790.3,"C",WVDFN))
QUIT
+3 NEW A,B,C,D,E,F
KILL WVJR,WVJR1,DR,DIC,DA
+4 SET X1=DT
SET X2=-30
DO C^%DTC
SET A=X
+5 SET X1=DT
SET X2=+30
DO C^%DTC
SET B=X
+6 SET G=0
FOR
SET G=$ORDER(^WV(790.3,"C",WVDFN,G))
if G'>0
QUIT
SET H=$GET(^WV(790.3,G,0))
Begin DoDot:1
+7 if $PIECE(H,U)'>A!($PIECE(H,U))'<B
QUIT
+8 if $PIECE(H,U,3)'=WVJPR
QUIT
+9 SET E=$PIECE(H,U,3)
SET D=$PIECE(H,U)
+10 SET E=$SELECT(E>0:$PIECE($GET(^WV(790.2,E,0)),U),1:"")
+11 SET Y=D
DO DD^%DT
SET F=Y
+12 SET WVJR(D,G)=F_" "_E
End DoDot:1
+13 SET C=1
SET A=0
FOR
SET A=$ORDER(WVJR(A))
if A'>0
QUIT
SET B=0
FOR
SET B=$ORDER(WVJR(A,B))
if B'>0
QUIT
Begin DoDot:1
+14 SET WVJR1(C)=B_"^"_WVJR(A,B)
SET C=C+1
End DoDot:1
+15 SET WVC=C-1
IF $DATA(WVJR1)
Begin DoDot:1
+16 WRITE !!,"The following Entries for this patient and procedure already exist in the"
+17 WRITE !,"Procedure Refusal file.",!
+18 DO LOOP
WRITE !!
+19 KILL DIR
SET DIR("A")="Is this a NEW Refusal? "
SET DIR(0)="YAO"
+20 SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if Y=1!($DATA(DIRUT))
QUIT
+21 SET DIR("A")="Select a Number to edit a refusal from the list. "
+22 SET DIR(0)="NAO^1:"_WVC
+23 DO ^DIR
KILL DIR
SET WVEDREF=$SELECT(+Y>0:+Y,1:"NS")
if Y'>0
QUIT
End DoDot:1
+24 QUIT
UNIV ;Add new Refusal & check other recent (within 30 days) Refusals
+1 DO SETVARS^WVUTL5
+2 DO TITLE^WVUTL5("ADD/EDIT A REFUSED TREATMENT")
+3 WRITE !!
KILL DIC
SET DIC("A")=" Select PATIENT: "
+4 SET DIC(0)="AEMQZ"
SET DIC="^WV(790,"
SET DIC("W")="D LOOKL^WVUTL1A(+Y)"
+5 DO ^DIC
KILL DIC
IF Y'>0
DO EXIT
QUIT
+6 SET WVDFN=+Y
+7 SET DIR("A")=" DATE REFUSED: "
+8 SET DIR(0)="DAO"
+9 DO ^DIR
KILL DIR
IF Y'>0
DO EXIT
QUIT
+10 SET WVJDAY=+Y
+11 SET DIR(0)="PAO^790.2:AEMNQZ"
SET DIR("A")=" PROCEDURE: "
+12 DO ^DIR
KILL DIR
IF Y'>0
DO EXIT
QUIT
+13 SET WVJPR=+Y
+14 KILL WVEDREF
DO CHECK
IF $DATA(DIRUT)
KILL DIRUT
DO EXIT
GOTO UNIV
+15 IF $GET(WVEDREF)>0
Begin DoDot:1
+16 SET DIDEL=790.3
+17 DO DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+WVJR1(WVEDREF))
End DoDot:1
GOTO UNIV
+18 IF $GET(WVEDREF)="NS"
DO EXIT
GOTO UNIV
+19 LOCK +^WV(790.3)
+20 SET DIC="^WV(790.3,"
SET DIC(0)="QEMAL"
SET X=WVJDAY
+21 SET DIC("DR")="1////^S X=WVDFN;2////^S X=WVJPR"
+22 KILL DD,DO
DO FILE^DICN
+23 LOCK -^WV(790.3)
+24 if Y'>0
QUIT
+25 SET WVDFN=$PIECE($GET(^WV(790.3,+Y,0)),U,2)
+26 DO DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
+27 GOTO UNIV
+28 QUIT
EXIT ;kill variables
+1 DO KILLALL^WVUTL8
KILL WVEDREF,WVJPR,WVJDAY
+2 QUIT
LOOP ;Loop though the array of refuals for this patient & write them out
+1 SET D=0
FOR
SET D=$ORDER(WVJR1(D))
if D'>0
QUIT
Begin DoDot:1
+2 WRITE !,$JUSTIFY(D,6),". ",$PIECE($GET(WVJR1(D)),U,2)
End DoDot:1
+3 QUIT
