source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCEL.m@ 949

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1RMPRPCEL ;HCIOFO/RVD - LINK SUSPENSE UTILITY; 08/14/01
2 ;;3.0;PROSTHETICS;**62,69**;Feb 09, 1996
3 ;
4 ;RVD patch #69 4/17/02 - prevent error if record in 668 is not complete
5 ; for 2319 linking.
6 ;This routine contains the code for linking file #660 and #668.
7 ;Link the selected suspense to a corresponding 2319 record(s).
8 ;And call routine for updating #660 and #668
9 ;
10 ;Variables need for this subroutine:
11 ; ^TMP($J,"RMPRPCE",660
12 ; ^TMP($J,"RMPRPCE",668
13LINK60 ;link suspense to 2319 records
14SEL60 ;
15 K RMSUS60
16 S RMSULINK=DA
17 D NEWVAR
18 W !!,"List of 2319 Records:"
19 S (RM60CNT,RMSERR)=0
20 F RMSI=0:0 S RMSI=$O(^TMP($J,"RMPRPCE",660,RMSI)) Q:RMSI'>0 D
21 .I $D(^RMPR(660,RMSI,0)) S RM60CNT=RM60CNT+1,RMSUS60(RM60CNT)=RMSI
22 ;
23RES60 K DIR
24 S (RMQUIT,RMSCNT,RMNT)=0
25 F RMSI=0:0 S RMSI=$O(RMSUS60(RMSI)) Q:(RMSI'>0)!(RMQUIT=1) D
26 .S DIR(0)="E"
27 .S RMSCNT=RMSCNT+1,RMNT=RMNT+1,(RM60IT,RM60VEN0,RMPRPRC)=""
28 .S RM60DATA=$G(^RMPR(660,RMSUS60(RMSI),0))
29 .S RM60DATE=$P(RM60DATA,U,1),RM60ITEM=$P(RM60DATA,U,6)
30 .S RM60TYPT=$P(RM60DATA,U,4),RM60VEN=$P(RM60DATA,U,9)
31 .S RM60D=$E(RM60DATE,4,5)_"/"_$E(RM60DATE,6,7)_"/"_$E(RM60DATE,2,3)
32 .I RM60ITEM,$D(^RMPR(661,RM60ITEM,0)) S RM60IT=$P(^RMPR(661,RM60ITEM,0),U,1)
33 .I RM60VEN,$D(^PRC(440,RM60VEN,0)) S RM60VEN0=$E($P(^PRC(440,RM60VEN,0),U,1),1,15)
34 .I RM60VEN,'$D(^PRC(440,RM60VEN,0)) S RM60VEN0=""
35 .I RM60ITEM,'$D(^RMPR(661,RM60ITEM,0)) S RM60IT=""
36 .I RM60IT,$D(^PRC(441,RM60IT,0)) S RMPRPRC=$E($P(^PRC(441,RM60IT,0),U,2),1,15)
37 .W !,?5,RMSI_".",?9,RM60D,?21,RMPRPRC,?39,RM60VEN0
38 .I RMNT>14 D ^DIR S RMNT=0 I Y'=1 S RMQUIT=1
39 Q:RMQUIT
40 S DIR(0)="LO^1:"_RMSCNT
41 S DIR("A")="Enter 2319 Record to be LINKED "
42 D ^DIR
43 I $D(DUOUT)!$D(DTOUT)!$D(DIRUT)!(Y="") W !!,"***NO Link to Suspense!!",!! Q
44 S RM60L=Y
45 S RC=0 F S RC=RC+1 S RMD=$P(RM60L,",",RC) Q:RMD="" D
46 .Q:'$D(RMSUS60(RMD))
47 .S RMSEL(RMD)=""
48 .S $P(^TMP($J,"RMPRPCE",660,RMSUS60(RMD)),U,3)=1
49 .S $P(^TMP($J,"RMPRPCE",660,RMSUS60(RMD)),U,4)=RMSULINK
50 .K RMSUS60(RMD)
51 .;S RNT=0 F RMSI=0:0 S RMSI=$O(RMSUS60(RMSI)) Q:RMSI'>0 S RNT=RNT+1 I (RMSI>1),(RNT'=RMSI) S RMSUS60(RNT)=RMSUS60(RMSI) K RMSUS60(RMSI)
52 ;
53UPFILE ;call update 660 & 668
54 ;process link to suspense, update field in file #660.
55 S RMSCHECK=0
56 F I=0:0 S I=$O(^TMP($J,"RMPRPCE",660,I)) Q:I'>0 D
57 .S RM60DAT=$G(^TMP($J,"RMPRPCE",660,I))
58 .S RMSAMIS=$P(RM60DAT,U,1)
59 .S RMSTATUS=$P(RM60DAT,U,3)
60 .S RM668=$P(RM60DAT,U,4)
61 .Q:'$G(RM668)
62 .Q:'$G(RMSAMIS)
63 .S RMSCHECK=$$UP60^RMPRPCE1(I,RM668,RMSTATUS)
64 .S RMSERR=$$UP68^RMPRPCE1(I,RM668,RMSAMIS)
65 .K ^TMP($J,"RMPRPCE",660,I)
66 K ^TMP($J,"RMPRPCE",668)
67 S:$G(RMSULINK) DA=RMSULINK
68 Q
69 ;
70SMESS8 ;print/display message for mandatory suspense entry.
71 W !!,"*********************************************************"
72 W !,"** No suspense record has been selected for this trans-**"
73 W !,"** action. You must select an entry from the list to **"
74 W !,"** complete this transaction, otherwise transaction **"
75 W !,"** will not be linked to SUSPENSE.................... **"
76 W !,"*********************************************************"
77 W !!
78 Q
79 ;
80SMESS0 ;print/display message for 2319 entry.
81 W !!,"*********************************************************"
82 W !,"** Patient record(s) still exist...................... **"
83 W !,"** You must select an entry from the list to complete **"
84 W !,"** all transactions, otherwise some transactions will **"
85 W !,"** not be linked to SUSPENSE!!! **"
86 W !,"*********************************************************"
87 W !!
88 Q
89 ;
90CDIR K DIR
91 S DIR(0)="SBO^L:LINK Suspense to Patient Record;E:EXIT without linking to Suspense"
92 S DIR("A")="Would you like to LINK Suspense or EXIT without linking"
93 S DIR("B")="L"
94 S DIR("?")="Answer `L` to Link to suspense, 'E' to exit without linking to suspense"
95 D ^DIR S RMENTSUS=Y
96 I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) S RMENTSUS="E"
97 W !! K DIR
98 Q
99 ;
100AUTO ;auto-link a suspense record.
101 ;added by #62
102 ;input rm60link(),rm68link, rgrp1 and rmprdfn
103 F R6I=0:0 S R6I=$O(RM60LINK(R6I)) Q:R6I'>0 D
104 .;do auto-link if only one suspense
105 .Q:'$D(RM68LINK)
106 .I $D(RM68LINK) S RM668I=$O(RM68LINK(0))
107 .S ^TMP($J,"RMPRPCE",660,R6I)=$G(RGRP1)_"^"_RMPRDFN_"^"_1_"^"_RM668I
108 .S ^TMP($J,"RMPRPCE",668,RM668I)=""
109 .D UPFILE^RMPRPCEL
110 G KILL
111 ;
112MAN ;link record.
113 ;input rm60link(), rgrp1 and rmprdfn
114 ;call suspense listmanager screen for multiple suspense and items.
115 S RMSUCLFG=1
116 F R6I=0:0 S R6I=$O(RM60LINK(R6I)) Q:R6I'>0 D
117 .S ^TMP($J,"RMPRPCE",660,R6I)=$G(RGRP1)_"^"_RMPRDFN
118 D LINK^RMPRS
119 G KILL
120 ;
121KILL ;kill link variables
122 K RM60LINK,RM68LINK,R6I,RM668I,RMSUCLFG
123 Q
124 ;
125COL ;collect PREVIOUS items for CO & CPO options only.
126 ;input variable RMPRA
127 ;return variable RM68FG = a flag if previous item is linked.
128 ;if linked, variables RM60LINK & RM68LINK are sets.
129 S RM68FG=0
130 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 S RM664DAT=$G(^RMPR(664,RMPRA,1,RI,0)) I $P(RM664DAT,U,13) D
131 .S RM660I=$P(RM664DAT,U,13)
132 .S:$D(^RMPR(660,RM660I,"AMS")) RGRP1=$P(^RMPR(660,RM660I,"AMS"),U,1)
133 .I $P($G(^RMPR(660,RM660I,10)),U,14) S RM668D10=$O(^RMPR(668,"F",RM660I,0)) D
134 ..I $G(RM668D10),'$D(RM68LINK(RM668D10)) S RM68FG=RM68FG+1,RM68LINK(RM668D10)=""
135 .I '$D(^RMPR(660,RM660I,10)) S RM60LINK(RM660I)=""
136 .I $D(^RMPR(660,RM660I,10)),$P(^RMPR(660,RM660I,10),U,1)="" S RM60LINK(RM660I)=""
137 Q
138 ;
139ICDT(R68) ;update the initial and completion date in #660
140 ;input variable R68 = FILE 668 ien
141 N RMDAT,RM660,RI,RMINDT,RMCODT,RMERROR,DA
142 Q:'$D(^RMPR(668,R68,10))
143 F RI=0:0 S RI=$O(^RMPR(668,R68,10,RI)) Q:RI'>0 I $P(^RMPR(668,R68,10,RI,0),U,1) D
144 .S RM660=$P(^RMPR(668,R68,10,RI,0),U,1)
145 .I $G(RM660),$D(^RMPR(660,RM660,10)) D
146 ..S RMINDT=$P(^RMPR(668,R68,0),U,9)
147 ..S RMCODT=$P(^RMPR(668,R68,0),U,5)
148 ..S RMDAT(660,RM660_",",8.3)=RMINDT
149 ..S RMDAT(660,RM660_",",8.4)=RMCODT
150 ..D FILE^DIE("","RMDAT","RMERROR")
151 ..I $D(RMERROR) W !!,"*** Error in 2319 Record = ",RM660," !!!",!! Q
152 Q
153 ;
154NEWVAR N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC
155 N RMERR,RMCHK,RMAMIS,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS
156 N RM68CNT,RM60CNT,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD
157 N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT
158 Q
Note: See TracBrowser for help on using the repository browser.