- 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 Mar 13, 2025@21:52:34 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
