source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVREFUSE.m@ 1766

Last change on this file since 1766 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1WVREFUSE ;HCIOFO/JWR - Add/Enter/Manipulate procedure refusals ;12/9/98 15:56
2 ;;1.0;WOMEN'S HEALTH;**3**;Sep 30, 1998
3EDREF ;EDIT AN EXISTING REFUSAL
4 D EXIT,SETVARS^WVUTL5
5 D TITLE^WVUTL5("EDIT A REFUSED TREATMENT") W !!
6 K DIC S DIC("A")=" Select DATE REFUSED: ",WVPOP=0
7 S DIC="^WV(790.3,",DIC(0)="QEMALZ" D ^DIC
8 I Y'>0!($D(DUOUT))!($D(DTOUT)) D EXIT Q
9 S WVDFN=$P($G(^WV(790.3,+Y,0)),U,2),DIDEL=790.3
10 D DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
11 G EDREF
12 Q
13ADDREF ;ADD A NEW REFUSAL (not used now, use UNIV for adding a refusal)
14 D SETVARS^WVUTL5
15 D TITLE^WVUTL5("ADD A REFUSED PROCEDURE")
16 K DIR S DIR("A")=" Select DATE REFUSED: ",WVDFN=""
17 S DIR(0)="DAO",DIR("B")="TODAY"
18 D ^DIR K DIR I Y'>0 D EXIT Q
19 S DIC("DR")="1;2"
20 S DIC="^WV(790.3,",DIC(0)="QEMAL",X=Y
21 K DD,DO D FILE^DICN
22 Q:Y'>0
23 S WVDFN=$P($G(^WV(790.3,+Y,0)),U,2)
24 D DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
25 D EXIT Q
26CHECK ;Checks for existing refusals for this patient within 30 day period
27 ; for this procedure.
28 Q:'$D(^WV(790.3,"C",WVDFN))
29 N A,B,C,D,E,F K WVJR,WVJR1,DR,DIC,DA
30 S X1=DT,X2=-30 D C^%DTC S A=X
31 S X1=DT,X2=+30 D C^%DTC S B=X
32 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
33 .Q:$P(H,U)'>A!($P(H,U))'<B
34 .Q:$P(H,U,3)'=WVJPR
35 .S E=$P(H,U,3),D=$P(H,U)
36 .S E=$S(E>0:$P($G(^WV(790.2,E,0)),U),1:"")
37 .S Y=D D DD^%DT S F=Y
38 .S WVJR(D,G)=F_" "_E
39 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
40 .S WVJR1(C)=B_"^"_WVJR(A,B),C=C+1
41 S WVC=C-1 I $D(WVJR1) D
42 .W !!,"The following Entries for this patient and procedure already exist in the"
43 .W !,"Procedure Refusal file.",!
44 .D LOOP W !!
45 .K DIR S DIR("A")="Is this a NEW Refusal? ",DIR(0)="YAO"
46 .S DIR("B")="Yes" D ^DIR K DIR Q:Y=1!($D(DIRUT))
47 .S DIR("A")="Select a Number to edit a refusal from the list. "
48 .S DIR(0)="NAO^1:"_WVC
49 .D ^DIR K DIR S WVEDREF=$S(+Y>0:+Y,1:"NS") Q:Y'>0
50 Q
51UNIV ;Add new Refusal & check other recent (within 30 days) Refusals
52 D SETVARS^WVUTL5
53 D TITLE^WVUTL5("ADD/EDIT A REFUSED TREATMENT")
54 W !! K DIC S DIC("A")=" Select PATIENT: "
55 S DIC(0)="AEMQZ",DIC="^WV(790,",DIC("W")="D LOOKL^WVUTL1A(+Y)"
56 D ^DIC K DIC I Y'>0 D EXIT Q
57 S WVDFN=+Y
58 S DIR("A")=" DATE REFUSED: "
59 S DIR(0)="DAO"
60 D ^DIR K DIR I Y'>0 D EXIT Q
61 S WVJDAY=+Y
62 S DIR(0)="PAO^790.2:AEMNQZ",DIR("A")=" PROCEDURE: "
63 D ^DIR K DIR I Y'>0 D EXIT Q
64 S WVJPR=+Y
65 K WVEDREF D CHECK I $D(DIRUT) K DIRUT D EXIT G UNIV
66 I $G(WVEDREF)>0 D G UNIV
67 .S DIDEL=790.3
68 .D DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+WVJR1(WVEDREF))
69 I $G(WVEDREF)="NS" D EXIT G UNIV
70 L +^WV(790.3)
71 S DIC="^WV(790.3,",DIC(0)="QEMAL",X=WVJDAY
72 S DIC("DR")="1////^S X=WVDFN;2////^S X=WVJPR"
73 K DD,DO D FILE^DICN
74 L -^WV(790.3)
75 Q:Y'>0
76 S WVDFN=$P($G(^WV(790.3,+Y,0)),U,2)
77 D DDS^WVFMAN(790.3,"[WV REFUSED PROCEDURE-ENTRY]",+Y)
78 G UNIV
79 Q
80EXIT ;kill variables
81 D KILLALL^WVUTL8 K WVEDREF,WVJPR,WVJDAY
82 Q
83LOOP ;Loop though the array of refuals for this patient & write them out
84 S D=0 F S D=$O(WVJR1(D)) Q:D'>0 D
85 .W !,$J(D,6),". ",$P($G(WVJR1(D)),U,2)
86 Q
Note: See TracBrowser for help on using the repository browser.