source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCE1.m@ 1700

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

initial load of FOIAVistA 6/30/08 version
File size: 5.4 KB
Line 
1RMPRPCE1 ;HCIOFO/RVD - Prosthetics/PCE UPDATE UTILITY ;5/7/03 09:12
2 ;;3.0;PROSTHETICS;**62,69,77,78**;Feb 09, 1996
3 ;
4 ;patch #69
5 ;RVD 4/10/02 - validate the length (16 c) of provisional diagnosis
6 ; before filing. Change Routine Prosthetic to ROUTINE
7 ; Type of Request field in 660.
8 ;RVD 5/6/03 patch #77 - SET Consult Request Service field in #660.
9 ; - POST init for setting Consult Request Service.
10 ;TH 9/29/03 Patch #78 - Add Billing Aware related fields.
11 ;
12 ;DBIA # 10060, Fileman read of file #200.
13 ;
14 ;This routine contains the code for updating file #660 and #668.
15 ;
16 ;RMIE60 - ien of file #660
17UP60(RMIE60,RMIE68,RMSUSTAT) ; update file #660.
18 D NEWVAR
19 S RMERR=0
20 S:RMSUSTAT="" RMSUSTAT=0
21 L +^RMPR(660,RMIE60):2
22 I $T=0 W !,"Someone else is Editing this entry!!!",! H 3 S RMERR=1 G UP60X
23 S RM680=$G(^RMPR(668,RMIE68,0))
24 S RM688=$G(^RMPR(668,RMIE68,8))
25 S RM6810=$G(^RMPR(668,RMIE68,10))
26 ;code here for 668 fields
27 S RMDATE=$P(RM680,U,1) ;Suspense Date
28 S RMCODT=$P(RM680,U,5) ;Completion Date
29 S RMINDT=$P(RM680,U,9) ;Initial Action Date
30 S RMPRCO=$P(RM680,U,15) ;Consult
31 S RMDWRT=$P(RM680,U,16) ;Date RX Written
32 S RMSTAT=$P(RM680,U,7) ;Station
33 S RMTRES=$P(RM680,U,8) ;Type of Request
34 S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",1:"")
35 S RMREQU=$P(RM680,U,11) ;Requestor (Ordering Provider)
36 S RMSERV=""
37 ;I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E")
38 S RMPRDI=$E($P(RM688,U,2),1,16) ;Provisional Diagnosis
39 S RMICD9=$P(RM688,U,3) ;ICD9
40 ;
41 S RMDAT(660,RMIE60_",",8.1)=RMDATE ;Suspense Date
42 S RMDAT(660,RMIE60_",",8.2)=RMDWRT ;Date RX Written
43 S RMDAT(660,RMIE60_",",8.3)=RMINDT ;Initial Action Date
44 S RMDAT(660,RMIE60_",",8.4)=RMCODT ;Completion Date
45 S RMDAT(660,RMIE60_",",8.5)=RMTYRE ;Type of Request
46 S RMDAT(660,RMIE60_",",8.6)=RMREQU ;Ordering Provider
47 S RMDAT(660,RMIE60_",",8.61)=RMSERV ;Consult Request Service
48 S RMDAT(660,RMIE60_",",8.7)=RMPRDI ;Provisional Diagnosis
49 S RMDAT(660,RMIE60_",",8.8)=RMICD9 ;Suspense ICD9
50 S RMDAT(660,RMIE60_",",8.9)=RMPRCO ;Pointer to Request/Consultation
51 S RMDAT(660,RMIE60_",",8.11)=RMSTAT ;Suspense Station
52 S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT ;Suspense Status
53 ;
54 ; Patch #78
55 ; #668,BA nodes
56 F RMPRL=1:1:99 S RM68BA=$G(^RMPR(668,RMIE68,"BA"_RMPRL)) Q:RM68BA="" D
57 . N RMICD,RMAO,RMIR,RMSC,RMEC,RMMST,RMHNC,RMCBV
58 . S RMICD=$P(RM68BA,U,1)
59 . S RMAO=$P(RM68BA,U,2)
60 . S RMIR=$P(RM68BA,U,3)
61 . S RMSC=$P(RM68BA,U,4)
62 . S RMEC=$P(RM68BA,U,5)
63 . S RMMST=$P(RM68BA,U,6)
64 . S RMHNC=$P(RM68BA,U,7)
65 . S RMCBV=$P(RM68BA,U,8)
66 . N RMPTR
67 . S RMPTR=29+RMPRL
68 . S RMDAT(660,RMIE60_",",RMPTR)=RMICD
69 . S RMDAT(660,RMIE60_",",RMPTR_".1")=RMAO
70 . S RMDAT(660,RMIE60_",",RMPTR_".2")=RMIR
71 . S RMDAT(660,RMIE60_",",RMPTR_".3")=RMSC
72 . S RMDAT(660,RMIE60_",",RMPTR_".4")=RMEC
73 . S RMDAT(660,RMIE60_",",RMPTR_".5")=RMMST
74 . S RMDAT(660,RMIE60_",",RMPTR_".6")=RMHNC
75 . S RMDAT(660,RMIE60_",",RMPTR_".7")=RMCBV
76 ;
77 D UPDATE^DIE("","RMDAT",,"RMERROR")
78 I $D(RMERROR) S RMERR=1 D ERR0
79 ;
80 L -^RMPR(660,RMIE60)
81UP60X ; exit point
82 Q RMERR
83 ;
84 ;RMIE60 = IEN of file #660.
85 ;RMIE68 = IEN of file #668.
86UP68(RMIE60,RMIE68,RMAMIS) ; update file #668.
87 D NEWVAR
88 S (RMI,RMERR)=0
89 ;S RMAMIS=$G(^RMPR(660,RMIE60,"AMS"))
90 I '$G(RMAMIS) D ERR8 S RMERR=1 G UP68X
91 ;L +^RMPR(668,RMIE68):2
92 ;I $T=0 W !,"Someone else is Editing this entry!!!",! H 3 S RMERR=1 G UP68X
93 I $D(^RMPR(668,RMIE68,10,"B",RMIE60)) G UP68X
94 S DA(1)=RMIE68 K DD,DO
95 S DIC="^RMPR(668,"_DA(1)_","_"10,",DIC(0)="L",DLAYGO=668,X=RMIE60
96 D FILE^DICN K DIC,X,DLAYGO,DD,DO
97 I Y=-1 S RMERR=1 D ERR8 G UNL68
98 I $D(^RMPR(668,RMIE68,11,"B",RMAMIS)) G UP68X
99 S DA(1)=RMIE68
100 S DIC="^RMPR(668,"_DA(1)_","_"11,",DIC(0)="L",DLAYGO=668,X=RMAMIS
101 D FILE^DICN K DIC
102 I Y=-1 S RMERR=1 D ERR8 G UNL68
103 ;
104UNL68 ;L -^RMPR(668,RMIE68)
105UP68X ; exit point
106 Q RMERR
107 ;
108ERR0 ;error updating file #660
109 W !,"*** Error updating file #660 in PCE module!!!",!
110 Q
111ERR8 ;error updating file #668
112 W !,"*** Error updating file #668 in PCE module!!!",!
113 Q
114LINK ;link 2319 to suspense
115 D DIV4^RMPRSIT Q:$D(X)
116 K ^TMP($J)
117 W ! S DIC="^RMPR(660,",DIC(0)="AEMQZ",DIC("A")="Select PATIENT: "
118 S DIC("S")="S RMZ=$G(^RMPR(660,+Y,10)) I $P(RMZ,U,14)'=1,$D(^(""AMS"")),RMPR(""STA"")=$P(^(0),U,10)"
119 S DIC("W")="D EN^RMPRD1"
120 W !
121 D ^DIC G:Y'>0 EXIT
122 L +^RMPR(660,+Y):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT
123 S RMPRDA=+Y
124 S RMPRDFN=$P(^RMPR(660,+Y,0),U,2)
125 I $D(^RMPR(660,+Y,"AMS")) N RMPRAMIS S RMPRAMIS=$P(^RMPR(660,+Y,"AMS"),U,1)
126 S ^TMP($J,"RMPRPCE",660,+Y)=RMPRAMIS_"^"_RMPRDFN
127 D LINK^RMPRS
128 L -^RMPR(660,RMPRDA)
129EXIT ;quit
130 K ^TMP($J)
131 K RMPR,RMPRSTE
132 K RMCODT
133 D KILL^XUSCLEAN
134 Q
135 ;
136SCRS ;set consult request service.
137 ;start conversion on 1/1/2002, the date of PCE/Link to suspense patch.
138 W !!,"Setting Consult Request Service in file #660....."
139 N RI,RJ F RI=3020100:0 S RI=$O(^RMPR(660,"B",RI)) Q:RI'>0 F RJ=0:0 S RJ=$O(^RMPR(660,"B",RI,RJ)) Q:RJ'>0 I $D(^RMPR(660,RJ,10)) D
140 .K RMAA
141 .S RMREQU=$P(^RMPR(660,RJ,10),U,6)
142 .S RMSERV=""
143 .I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E")
144 .S:RMSERV'="" $P(^RMPR(660,RJ,4),U,3)=RMSERV
145 W !!,"Done setting Consult Request Service!!",!
146 Q
147 ;
148NEWVAR N DA,DIE,DIC,I,J,RMDFN,RMI,RMDATE,RM680,RM688,RM6810,RMERROR
149 N RMERR,RMCHK,RMAMIS,DLAYGO,X,DR,RMAA,RMSERV,RMREQU,RMDAT
150 N RMPRL,RM68BA,RMDWRT,RMICD9,RMINDT,RMPRCO,RMPRDI,RMSTAT,RMTRES,RMTYRE
151 Q
Note: See TracBrowser for help on using the repository browser.