source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPROWL.m@ 1424

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

initial load of FOIAVistA 6/30/08 version

File size: 2.7 KB
Line 
1RMPROWL ;VACO/HNC- CLONE OWL SUSPENSE IN FILE 668 ;5/24/06
2 ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25
3 ;
4 ; Passed parameter DA - Prosthetics Consult Record from ^RMPR(668
5 ;
6 ; Passed parameter RMPRW - Work Order Number, external format
7 ;
8 ; Return RESULT(1)=ERROR STRING, OR Message ALL IS OKAY
9 Q
10 ;
11EN2(DA,RMPRW) ;Create OWL Clone in Suspense
12 G EN3
13EN(RESULT,DA,RMPRW) ;GUI entry point
14 ;
15EN3 ;
16 N RMP9 S RMP9=$P($G(^RMPR(668,DA,0)),U,8)
17 I RMP9="" S RESULT(1)="No Suspense Available to Clone!" G EXIT
18 I (RMP9'=11) S RESULT(1)="Only LAB Can be CLONED" G EXIT
19 S RMPRH=DA
20 S (RMPRFLD,RMPRFI,RMPRFW)=0
21 D GETS^DIQ(668,RMPRH,"**","I","OUT")
22 Q:'$D(OUT)
23 ;create new record
24 D NOW^%DTC S X=%
25 S DIC="^RMPR(668,",DIC(0)="L"
26 K DD,DO D FILE^DICN
27 S RMPRA=+Y
28 M R6681(668,RMPRA_",")=OUT(668,RMPRH_",")
29 F S RMPRFLD=$O(R6681(668,RMPRA_",",RMPRFLD)) Q:RMPRFLD'>0 D
30 . F S RMPRFI=$O(R6681(668,RMPRA_",",RMPRFLD,RMPRFI)) Q:RMPRFI="" D
31 .. I RMPRFI="I" S R668(668,RMPRA_",",RMPRFLD)=R6681(668,RMPRA_",",RMPRFLD,RMPRFI) Q
32 .. S R668(668,RMPRA_",",RMPRFLD,RMPRFI)=R6681(668,RMPRA_",",RMPRFLD,RMPRFI)
33 S RMPRC=RMPRA_","
34 S R668(668,RMPRA_",",4)="R668(668,"_""""_RMPRC_""""_",4)"
35 I $D(R668(668,RMPRA_",",7)) S R668(668,RMPRA_",",7)="R668(668,"_""""_RMPRC_""""_",7)"
36 K OUT
37 ;
38 ;don't set the following fields
39 K R668(668,RMPRA_",",.01)
40 ;urgency
41 K R668(668,RMPRA_",",2.3)
42 ;completion date
43 K R668(668,RMPRA_",",5)
44 ;completed by
45 K R668(668,RMPRA_",",6)
46 ;initial action note
47 K R668(668,RMPRA_",",7)
48 ;suspended by
49 S R668(668,RMPRA_",",8)=DUZ
50 ;patient 2319
51 K R668(668,RMPRA_",",8.1)
52 ;amis grouper
53 K R668(668,RMPRA_",",8.2)
54 ;init action date
55 K R668(668,RMPRA_",",10)
56 ;completion note
57 K R668(668,RMPRA_",",12)
58 ;initial action by
59 K R668(668,RMPRA_",",16)
60 ;cancelled by
61 K R668(668,RMPRA_",",17)
62 ;cancel date
63 K R668(668,RMPRA_",",18)
64 ;CPRS order may be purged, remobe
65 K R668(668,RMPRA_",",19)
66 ;cancel note
67 K R668(668,RMPRA_",",21)
68 ;date rx written, keep same per Karen 9/15/03
69 ;K R668(668,RMPRA_",",22)
70 ;consult service
71 K R668(668,RMPRA_",",23)
72 ;consult needed for display set to orig pointer
73 S R668(668,RMPRA_",",20)=$P(^RMPR(668,RMPRH,0),U,15)
74 ;forwarded by
75 K R668(668,RMPRA_",",24)
76 ;consult visit
77 K R668(668,RMPRA_",",30)
78 ;set status to open
79 S R668(668,RMPRA_",",14)="O"
80 ;set type to clone
81 S R668(668,RMPRA_",",9)=7
82 ;will automatically set the Billing Fields as needed IF NO DUPLICATES!
83 ;32,32.1,32.2,33,33.1,33.2,33.3
84 S DIC="^RMPR(668,",DIC(0)="AEQM"
85 D FILE^DIE("K","R668","ERROR")
86 I $D(ERROR) S RESULT(1)="COULD NOT CLONE DUE TO BAD DATA IN SUSPENSE!" D KILL
87EXIT ;exit
88 K R6681,RMPRA,RMPRC,RMPRFLD,RMPRFI,RMPRFW,RMPRH
89 S RESULT(1)="New Clone Suspense Created."
90 Q
91 K DIC,DIK,ERROR,R668,X,Y
92KILL ;get rid of new clone if error
93 S DA=RMPRA,DIK=668 D ^DIK
94 G EXIT
95 Q
96 ;
Note: See TracBrowser for help on using the repository browser.