source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOSA.m@ 1604

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1RMPREOSA ;HINES-IOFO/HNC - Clone, Auto Adaptive, Clothing Allowance ;10/31/03 14:17
2 ;;3.0;PROSTHETICS;**80,75**;Feb 09, 1996;Build 25
3EN ;Add Auto Adaptive Suspense
4 ;
5 D NOW^%DTC S X=%
6 S DIC="^RMPR(668,",DIC(0)="AEQLM",DLAYGO=668
7 S DIC("DR")="1////^S X=RMPRDFN;22R;14////^S X=""O"";8////^S X=DUZ;9////^S X=8;3////^S X=9;2////^S X=RMPR(""STA"")"
8 K DINUM,D0,DD,DO D FILE^DICN K DLAYGO G:Y'>0 EX S (RDA,DA)=+Y
9 S DIE="^RMPR(668,",DR="13;4"
10 L +^RMPR(668,RDA,0):1 I $T=0 W $C(7),?5,!,"Someone else is editing this record" G EX
11 D ^DIE L -^RMPR(668,RDA,0)
12 I '$P(^RMPR(668,RDA,0),U,3) S DA=RDA,DIK="^RMPR(668," D ^DIK W !,$C(7),?5,"Deleted..."
13EX K X,DIC,DIE,DR,Y
14 Q
15 ;
16EN1 ;Add Clothing Allowance Suspense
17 ;
18 D NOW^%DTC S X=%
19 S DIC="^RMPR(668,",DIC(0)="AEQLM",DLAYGO=668
20 S DIC("DR")="1////^S X=RMPRDFN;22R;14////^S X=""O"";8////^S X=DUZ;9////^ S X=6;3////^S X=9;2////^S X=RMPR(""STA"")"
21 K DINUM,D0,DD,DO D FILE^DICN K DLAYGO G:Y'>0 EX S (RDA,DA)=+Y
22 S DIE="^RMPR(668,",DR="13;4"
23 L +^RMPR(668,RDA,0):1 I $T=0 W $C(7),?5,!,"Someone else is editing this record" G EX
24 D ^DIE L -^RMPR(668,RDA,0)
25 I '$P(^RMPR(668,RDA,0),U,3) S DA=RDA,DIK="^RMPR(668," D ^DIK W !,$C(7),?5,"Deleted..."
26 K X,DIC,DIE,DR,Y
27 Q
28EN2 ;Create Clone CPRS Suspense
29 ;
30 N RMPR9
31 S RMPR9=$P(^RMPR(668,DA,0),U,8)
32 I $P(^RMPR(668,DA,0),U,8)>4&(RMPR9'=9)&(RMPR9'=11) W !!!,"Only CPRS Suspense Can Be Cloned!",!! H 2 Q
33 I $P(^RMPR(668,DA,0),U,8)=11&($P($G(^RMPR(668,DA,0)),U,15)'>0) W !!!,"This was a Manual Request, not a CPRS Suspense. Please create another Manual.",!! H 2 Q
34ST2 S RMPRH=DA
35 S (RMPRFLD,RMPRFI,RMPRFW)=0
36 D GETS^DIQ(668,RMPRH,"**","I","OUT")
37 Q:'$D(OUT)
38 ;create new record
39 D NOW^%DTC S X=%
40 S DIC="^RMPR(668,",DIC(0)="L"
41 K DD,DO D FILE^DICN
42 S RMPRA=+Y
43 M R6681(668,RMPRA_",")=OUT(668,RMPRH_",")
44 F S RMPRFLD=$O(R6681(668,RMPRA_",",RMPRFLD)) Q:RMPRFLD'>0 D
45 . F S RMPRFI=$O(R6681(668,RMPRA_",",RMPRFLD,RMPRFI)) Q:RMPRFI="" D
46 .. I RMPRFI="I" S R668(668,RMPRA_",",RMPRFLD)=R6681(668,RMPRA_",",RMPRFLD,RMPRFI) Q
47 .. S R668(668,RMPRA_",",RMPRFLD,RMPRFI)=R6681(668,RMPRA_",",RMPRFLD,RMPRFI)
48 S RMPRC=RMPRA_","
49 S R668(668,RMPRA_",",4)="R668(668,"_""""_RMPRC_""""_",4)"
50 I $D(R668(668,RMPRA_",",7)) S R668(668,RMPRA_",",7)="R668(668,"_""""_RMPRC_""""_",7)"
51 K OUT
52 ;
53 ;don't set the following fields
54 K R668(668,RMPRA_",",.01)
55 ;urgency
56 K R668(668,RMPRA_",",2.3)
57 ;completion date
58 K R668(668,RMPRA_",",5)
59 ;completed by
60 K R668(668,RMPRA_",",6)
61 ;initial action note
62 K R668(668,RMPRA_",",7)
63 ;suspended by
64 S R668(668,RMPRA_",",8)=DUZ
65 ;patient 2319
66 K R668(668,RMPRA_",",8.1)
67 ;amis grouper
68 K R668(668,RMPRA_",",8.2)
69 ;init action date
70 K R668(668,RMPRA_",",10)
71 ;completion note
72 K R668(668,RMPRA_",",12)
73 ;initial action by
74 K R668(668,RMPRA_",",16)
75 ;cancelled by
76 K R668(668,RMPRA_",",17)
77 ;cancel date
78 K R668(668,RMPRA_",",18)
79 ;CPRS order may be purged, remobe
80 K R668(668,RMPRA_",",19)
81 ;cancel note
82 K R668(668,RMPRA_",",21)
83 ;date rx written, keep same per Karen 9/15/03
84 ;K R668(668,RMPRA_",",22)
85 ;consult service
86 K R668(668,RMPRA_",",23)
87 ;consult needed for display set to orig pointer
88 S R668(668,RMPRA_",",20)=$P(^RMPR(668,RMPRH,0),U,15)
89 ;forwarded by
90 K R668(668,RMPRA_",",24)
91 ;consult visit
92 K R668(668,RMPRA_",",30)
93 ;set status to open
94 S R668(668,RMPRA_",",14)="O"
95 ;set type to clone
96 S R668(668,RMPRA_",",9)=7
97 ;will automatically set the Billing Fields as needed IF NO DUPLICATES!
98 ;32,32.1,32.2,33,33.1,33.2,33.3
99 S DIC="^RMPR(668,",DIC(0)="AEQM"
100 D FILE^DIE("K","R668","ERROR")
101 I $D(ERROR) W !,ERROR("DIERR",1,"TEXT",1),!,"Could NOT CLONE DUE TO BAD DATA!" H 2 K ERROR,R668 G KILL
102 ;file field #1 Veteran
103 ;S DA=RMPRA
104 ;S DIE="^RMPR(668,"
105 ;S DR="1////^S X=RMPRDFN"
106 ;L +^RMPR(668,RMPRA,0):1 I $T=0 W $C(7),?5,!,"Someone else is editing this record" G EX
107 ;D ^DIE L -^RMPR(668,RMPRA,0)
108 ;print view request, ask for device
109 W !!,"Done... Please select a device to print the new SUSPENSE Record."
110 S DA=RMPRA
111 S L=0
112 S DIC="^RMPR(668,",FLDS="[RMPR VIEW REQUEST]"
113 S BY="@NUMBER",(FR,TO)=DA
114 D EN1^DIP
115 N DIR S DIR(0)="E" D ^DIR
116 W @IOF
117 S DA=^TMP($J,"RMPREOEE",XDA,0)
118 D VALL^RMPREO24(DA,.L) Q:L="^"
119 K RMPRA,RMPRC,DFN,DA,DIC,X,Y
120 Q
121KILL ;get rid of new clone if error
122 S DA=RMPRA,DIK=668 D ^DIK
123 Q
124 ;END
Note: See TracBrowser for help on using the repository browser.