source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRDIS.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1RMPRDIS ;PHX/JLT-DISPLAY/EDIT DISABILITY CODES
2 ;;3.0;PROSTHETICS;;Feb 09, 1996
3 D GETPAT^RMPRUTIL Q:'$D(RMPRDFN)
4EN ;ADD DISABILITY CODE, CALLED FROM RMPRAP
5 N DIC,DIR
6 I $D(RMPRDIR7) S DIR(0)="Y",DIR("A")="Would you like to ADD/EDIT a Disability Code to the Patient's 2319",DIR("B")="YES",DIR("?")="Enter 'Y' to Edit a Disability Code, 'N' or '^' to continue."
7 I D ^DIR G:$D(DIRUT)!($D(DUOUT)) END G:+Y=0 DEA
8 I $G(RMPRDA) S DFN=$P($G(^RMPR(660.5,RMPRDA,0)),U,2) I +DFN,'$D(^RMPR(665,+DFN)) S ^RMPR(665,DFN,0)=DFN_U_RMPR("STA") S DA=DFN,DIK="^RMPR(665," D IX1^DIK
9 I '$D(^RMPR(665,RMPRDFN,1)) S ^RMPR(665,RMPRDFN,1,0)="^665.01PI^0^0"
10 D:'$D(RMPRBACK) LP L +^RMPR(665,RMPRDFN,1):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry" G END
11AMP W ! S DA(1)=RMPRDFN,DIC="^RMPR(665,"_DA(1)_",1,",DIC(0)="AEQMZL",DLAYGO=665,DIC("W")="S RA=^(0) D DSP^RMPRDIS" D ^DIC K DLAYGO G:+Y'>0 DEND S RMPRY=Y,RMPRX=$P(Y,U,2)
12 I $P(^RMPR(665,RMPRDFN,1,+Y,0),U,10) S DIR(0)="Y",DIR("A",1)="DISABILITY CODE HAS BEEN MARKED AS DELETED.",DIR("A")="WOULD YOU LIKE TO RE-ACTIVATED THIS CODE",DIR("B")="NO",DIR("?")="Enter 'Y' to re-activate code."
13 I D ^DIR G:$D(DIRUT)!($D(DUOUT)) DEND K DIR I +Y=1 S DA=+RMPRY,DIE=DIC,DR="10///@" D ^DIE
14 S RC=0 F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,"B",RMPRX,RI)) Q:RI'>0 S RC=RC+1
15 I RC'>1 K DIRUT D DIR G:$D(DIRUT) AMP
16EDIT K DIR S DIE="^RMPR(665,RMPRDFN,1,",DA(1)=RMPRDFN,DA=+RMPRY D SDR
17 D ^DIE I $D(DA),$P(^RMPR(665,DA(1),1,DA,0),U,4)'=4 S $P(^(0),U,5)=""
18 I $D(DA) I '$P(^RMPR(665,RMPRDFN,1,DA,0),U,3)!'$P(^(0),U,4) S DA(1)=RMPRDFN,DIK="^RMPR(665,RMPRDFN,1,",DA(1)=RMPRDFN D ^DIK W !,?5,$C(7),"Deleted..."
19 G AMP
20DEND L -^RMPR(665,RMPRDFN,1) K RMPRX,RMPRY,RT,RI,RA,RMPRT,RCC
21 I '$D(RMPRBACK) K DIC,Y,RMPRD,DIE,DR Q
22DEA ;DEACTIVATE PATIENT PROSTHETICS DISABILITY CODES
23 ;I $G(RMPRDFN)'>0 Q
24 Q:$D(RMPRDIR3) I '$D(RMPRBACK) K RMPRDFN D GETPAT^RMPRUTIL G:'$D(RMPRDFN) END
25 Q:$G(RMPRDFN)'>0
26 I '$D(^RMPR(665,RMPRDFN,1))!($O(^RMPR(665,RMPRDFN,1,0))'>0) W !!,"Patient has no Prosthetics Disability codes",$C(7) G END
27 W !,$P(^DPT(RMPRDFN,0),U,1)," HAS THE FOLLOWING DISABILITY CODES:",! F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,RI)) Q:RI'>0 S RA=^(RI,0) W !,?5,$P(^RMPR(662,$P(RA,U,1),0),U,1) D DSP
28 I $D(RMPRDIR7) W !! S DIR(0)="Y",DIR("A")="Would you like to Mark a Disability Code as Deleted",DIR("B")="NO",DIR("?")="Enter 'Y' to Mark a Disability Code as Deleted" D ^DIR G:$D(DIRUT)!($D(DUOUT))!(+Y=0) END
29 S RA=0 F RI=0:1 S RA=$O(^RMPR(665,RMPRDFN,1,RA)) Q:RA'>0
30 I RI'>1 G SEL
31 K DIR W !! S DIR(0)="Y"
32 S DIR("A")="Would you like to Mark all of the Patient's Disability Codes as Deleted",DIR("B")="NO",DIR("?")="Enter 'Y' to Mark all of the Patients Disability Codes as Deleted, 'N' to select a Disability Code."
33 D ^DIR G:$D(DIRUT)!($D(DUOUT)) END I +Y=0 G SEL
34 L +^RMPR(665,RMPRDFN,1):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry!" G END
35 F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,RI)) Q:RI'>0 I $D(^(RI,0)) S DA=RI,DIE="^RMPR(665,"_RMPRDFN_",1,",DR="5///^S X=2;10///^S X=DT",DA(1)=RMPRDFN D ^DIE
36 L -^RMPR(665,RMPRDFN,1)
37END K RMPRX,RMPRY,RA,RI,RT,RC,RMPRT I $D(RMPRDIR3) Q
38 I $D(RMPRDIR7) K RMPRDIR7 G ASK1^RMPRPAT
39 Q:$D(RMPRBACK) K RMPRDFN,RMPRSSN,RMPRNAM,RMPRDOB,RMPRD,DIE,DIR,DR,DIRUT,DIC,DIK,DA Q
40SEL W ! S DIC="^RMPR(665,"_RMPRDFN_",1,"
41 S DIC(0)="AEQMZ",DIC("W")="S RA=^(0) D DSP^RMPRDIS"
42 D ^DIC G:+Y'>0&('$D(RMPRBACK)) DEA G:+Y'>0 END
43 L +^RMPR(665,RMPRDFN,1):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry!" G END
44 S DA=+Y,DA(1)=RMPRDFN,DIE=DIC,DR="5///^S X=2;10///^S X=DT" D ^DIE L -^RMPR(665,RMPRDFN,1) W !,?5,"**CODE MARKED AS DELETED**" W ! G SEL
45LP ;DISPLAY DISABILITY CODES
46 K RMPRD F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,RI)) Q:RI'>0 I $D(^(RI,0)) S RMPRD(RI)=^(0)
47 W ! I $D(RMPRD) W !,$P(^DPT(RMPRDFN,0),U)," HAS THE FOLLOWING CODES:",! F RI=0:0 S RI=$O(RMPRD(RI)) Q:RI'>0 S RA=RMPRD(RI) W !,?5,$P(^RMPR(662,$P(RA,U),0),U) D DSP
48 Q
49DIR K DIR I '$P(RMPRY,U,3) S DIR(0)="S^E:EDIT DISABILITY CODE;A:ADD DUPLICATE DISABILITY CODE",DIR("B")="EDIT" D ^DIR Q:$D(DIRUT) I Y["A" D FILE
50 Q
51FILE K DD,DO,D0 S DIC="^RMPR(665,"_RMPRDFN_",1,",DIC(0)="EQML",DLAYGO=665 S X=RMPRX D FILE^DICN K DLAYGO S DA(1)=RMPRDFN,RMPRY=+Y Q
52DSP I +$P(RA,U,3) W ?15 W $S($P(RA,U,3)=1:"SC ",1:"NSC ")
53 I +$P(RA,U,4) S RT=$P(^DD(665.01,3,0),U,3) W ?21,$P($P(RT,":",$P(RA,U,4)+1),";",1)_" "
54 I +$P(RA,U,5) S RT=$P(^DD(665.01,4,0),U,3) W ?41,$P($P(RT,":",$P(RA,U,5)+1),";",1)
55 I +$P(RA,U,10) W ?65,"Deleted..."
56 Q
57SDR S DR=".01;5///1;2;3;S $P(^RMPR(665,DA(1),1,DA,0),U,8)=DUZ;1///^S X=DT;10///@;I $P(^RMPR(665,DA(1),1,DA,0),U,4)'=4 S Y="""";4" Q
58CHK S RDA=$P(^RMPR(665,DA(1),1,DA,0),U) D K RDA
59 .F RI=0:0 S RI=$O(^RMPR(665,DA(1),1,"B",RDA,RI)) Q:RI'>0 S RV=$P(^RMPR(665,DA(1),1,RI,0),U,3) I (X=RV),(DA'=RI) K X Q
Note: See TracBrowser for help on using the repository browser.