source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPCRPL.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: 6.6 KB
Line 
1PRCPCRPL ;WISC/RFJ/DWA-cc and ik preparation list ;01 Sep 93
2 ;;5.1;IFCAP;**27,49**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7DQ ; called from prcpopt to print preparation list on picking ticket
8 ; print cc from ^tmp($j,"prcpcrpl-cc",itemda)
9 ; print ik from ^tmp($j,"prcpcrpl-ik",itemda)
10 N %,CCIKITEM,COMMENTS,DESCR,DFN,ITEMDATA,LOCATION,OPCODE,OPDATE,ORROOM,PATNAME,PATSSN,PRCPDATA,PRCPSDAT,PRCPFILE,PRCPINPT,PRCPPAT,PRCPSURG,SEQ,SURGEON,VADM,VAERR,X,Y
11 D PAT
12 D SURG
13 D CART
14 D IK
15 D Q
16 Q
17 ;
18Q ; clean up ^TMP
19 K ^TMP("PRCPCRPL-CC"),^TMP("PRCPCRPL-IK"),^TMP("PRCPCRPL-KIT"),^TMP("PRCPCRPLSEQ"),^TMP("PRCPCRPLSEQ2")
20 Q
21 ;
22PAT ; get patient data
23 S PRCPPAT=+$P($G(^PRCP(445.3,ORDERDA,2)),"^"),PRCPSURG=+$P($G(^(2)),"^",2)
24 S DFN=PRCPPAT I $$VERSION^XPDUTL("DG") D DEM^VADPT
25 S PATNAME=$G(VADM(1)),PATSSN=$P($G(VADM(2)),"^")
26 Q
27 ;
28SURG ; get surgery data
29 D SURGDATA(PRCPSURG,".02;.09;.14;.28;27")
30 S ORROOM=$G(PRCPSDAT(130,PRCPSURG,.02,"E")),OPDATE=$G(PRCPSDAT(130,PRCPSURG,.09,"E")),SURGEON=$G(PRCPSDAT(130,PRCPSURG,.14,"E")),OPCODE=$G(PRCPSDAT(130,PRCPSURG,27,"I")),OPCODE=OPCODE_" "_$P($$ICPT^PRCPCUT1(+OPCODE),"^",2)
31 ;
32 Q
33 ;
34CART ; process case carts
35 I $D(^TMP($J,"PRCPCRPL-CC")) D
36 . S CCIKITEM=0,PRCPFILE=445.7
37 . K ^TMP($J,"PRCPCRPL-KIT")
38 . F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-CC",CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D
39 . . D H
40 . . S PRCPFILE=445.7
41 . . D CCIKNAME Q:$G(PRCPFLAG)
42 . . D CART2,CART3 Q:$G(PRCPFLAG)
43 . . D COMMENTS Q:$G(PRCPFLAG)
44 . . K ^TMP($J,"PRCPCRPLSEQ")
45 . . D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG)
46 . . I $D(^TMP($J,"PRCPCRPL-KIT")) D KIT K ^TMP($J,"PRCPCRPL-KIT")
47 I $G(PRCPFLAG) Q
48 Q
49CART2 ; set up ^TMP($J,"PRCPCRPLSEQ", for print of carts
50 Q:$G(PRCPFLAG)
51 S ITEMDA=0
52 F S ITEMDA=$O(^PRCP(445.7,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
53 . S SEQ=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
54 . I SEQ="" S SEQ="?"
55 . S ^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)=""
56 . I $D(^PRCP(445.8,ITEMDA)) S ^TMP($J,"PRCPCRPL-KIT",CCIKITEM,ITEMDA)=""
57 Q
58 ;
59CART3 ; print out carts
60 Q:$G(PRCPFLAG)
61 S SEQ=""
62 F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ",SEQ)) Q:SEQ=""!($G(PRCPFLAG)) D
63 . S ITEMDA=""
64 . F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
65 . . S ITEMDATA=$G(^PRCP(445.7,CCIKITEM,1,ITEMDA,0))
66 . . D WRITE
67 . . Q:$G(PRCPFLAG)
68 Q
69 ;
70IK ; process freestanding instrument kits
71 Q:$G(PRCPFLAG)
72 I $D(^TMP($J,"PRCPCRPL-IK")) D
73 . S CCIKITEM=0,PRCPFILE=445.8
74 . F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-IK",CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D
75 . . D H
76 . . D CCIKNAME Q:$G(PRCPFLAG)
77 . . D IK2,IK3 Q:$G(PRCPFLAG)
78 . . D COMMENTS Q:$G(PRCPFLAG)
79 . . K ^TMP($J,"PRCPCRPLSEQ")
80 . . D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG)
81 I $G(PRCPFLAG) Q
82 Q
83IK2 ; set up ^TMP($J,"PRCPCRPLSEQ", for print of kits
84 Q:$G(PRCPFLAG)
85 K ^TMP($J,"PRCPCRPLSEQ")
86 S ITEMDA=0
87 F S ITEMDA=$O(^PRCP(445.8,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
88 . S SEQ=$P(^PRCP(445.8,CCIKITEM,1,ITEMDA,0),"^",3)
89 . I SEQ="" S SEQ=99.99
90 . S ^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)=""
91 Q
92 ;
93IK3 ; print out kits
94 Q:$G(PRCPFLAG)
95 S SEQ=0
96 F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ",SEQ)) Q:'SEQ!($G(PRCPFLAG)) D
97 . S ITEMDA=0
98 . F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
99 . . S ITEMDATA=$G(^PRCP(445.8,CCIKITEM,1,ITEMDA,0))
100 . . D WRITE
101 . . Q:$G(PRCPFLAG)
102 Q
103 ;
104KIT ; process kits associated with cart
105 Q:$G(PRCPFLAG)
106 N CCITEM,CCIKITEM
107 S PRCPFILE=445.8
108 S CCITEM=0
109 F S CCITEM=$O(^TMP($J,"PRCPCRPL-KIT",CCITEM)) Q:'CCITEM!($G(PRCPFLAG)) D
110 . S CCIKITEM=0
111 . F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-KIT",CCITEM,CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D
112 . . D H,CCIKNAME
113 . . Q:$G(PRCPFLAG)
114 . . D KIT2,KIT3 Q:$G(PRCPFLAG)
115 . . D COMMENTS Q:$G(PRCPFLAG)
116 . . K ^TMP($J,"PRCPCRPLSEQ2")
117 . D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG)
118 Q
119KIT2 ; set up ^TMP($J,"PRCPCRPLSEQ2", for print of kits
120 Q:$G(PRCPFLAG)
121 K ^TMP($J,"PRCPCRPLSEQ2")
122 S ITEMDA=0
123 F S ITEMDA=$O(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
124 . S ITEMDATA=$G(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA,0))
125 . S SEQ=$P(ITEMDATA,"^",3)
126 . I SEQ="" S SEQ=99.99
127 . S ^TMP($J,"PRCPCRPLSEQ2",SEQ,CCIKITEM,ITEMDA)=""
128 Q
129KIT3 ; print out kits
130 Q:$G(PRCPFLAG)
131 S SEQ=0
132 F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ2",SEQ)) Q:'SEQ!($G(PRCPFLAG)) D
133 . S ITEMDA=0
134 . F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ2",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
135 . . S ITEMDATA=$G(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA,0))
136 . . D WRITE
137 . . Q:$G(PRCPFLAG)
138 Q
139 ;
140WRITE ; write data
141 I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
142 S LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
143 S DESCR=$E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,33)_" (#"_ITEMDA_")"
144 W !?2,DESCR,?45,$J(+$P(ITEMDATA,"^",2),5),$J($P($$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"^"),"^",2),4)," ",$E(LOCATION,1,15),?72,"__ __ __"
145 Q
146 ;
147 ;
148CCIKNAME ; write cc or ik name
149 I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
150 S PRCPDATA=$G(^PRCP(PRCPFILE,CCIKITEM,0))
151 S PRCPINPT=$P(PRCPDATA,"^",2)
152 S LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,CCIKITEM)
153 S DESCR=$E($$DESCR^PRCPUX1(PRCPINPT,CCIKITEM),1,40)_" (#"_CCIKITEM_") .............................................................."
154 W !!?22,"* * * * * ",$S(PRCPFILE=445.7:" CASE CART ",1:"INSTRUMENT KIT")," * * * * *"
155 W !,$E(DESCR,1,55),?56,$E(LOCATION,1,15),?72,"__ __ __"
156 W !?10,"from: ",$$INVNAME^PRCPUX1(PRCPINPT)
157 Q
158 ;
159 ;
160COMMENTS ; print comments
161 I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
162 I PRCPFILE=445.8 D
163 . W !,"METHOD OF STERILIZATION : ",$$STERILE^PRCPCRDK(CCIKITEM)
164 . W !,"METHOD OF WRAPPING/PACKAGING: ",$$WRAPPING^PRCPCRDK(CCIKITEM)
165 W !,$S(PRCPFILE=445.7:"CASE CART",1:"INSTRUMENT KIT")," SPECIAL INSTRUCTIONS/REMARKS:"
166 S X=0 F S X=$O(^PRCP(PRCPFILE,CCIKITEM,2,X)) Q:'X!($G(PRCPFLAG)) S DATA=$G(^(X,0)) D
167 . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
168 . W !,DATA
169 Q
170 ;
171 ;
172H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
173 W $C(13),"CASE CART OR INSTRUMENT KIT PREPARATION LIST ",?(80-$L(%)),%
174 S %="",$P(%,"-",81)=""
175 W !?1,"PATIENT: ",$E(PATNAME,1,28),?40,"SSN: ",PATSSN,?63,"RETURNED BY ____."
176 W !?1,"DATE OF OPERATION: ",OPDATE,?32,"OR ROOM: ",$E(ORROOM,1,18),?60,"RECEIVED BY ____. |"
177 W !?1,"PRINCIPAL OPERATION CODE: ",OPCODE,?59,"PICKED BY ____. | |"
178 W !?1,"SURGEON: ",SURGEON,?73,"| | |"
179 W !?73,"V V V"
180 W !,"DESCRIPTION (#MI)",?45,$J("QTY",5),$J("UI",4),?56,"LOCATION",?72,"CK CK CK",!,%
181 W !?1,"COMMENTS:"
182 S %=0 F S %=$O(COMMENTS(%)) Q:'% W !,COMMENTS(%)
183 W !
184 Q
185 ;
186 ;
187SURGDATA(DA,DR) ; get surgery data
188 N D0,DIC,DIQ,QPQPQ
189 K PRCPSDAT
190 S QPQPQ=1 ; to prevent executing field 27 opcode transform
191 S DIC="^SRF(",DIQ="PRCPSDAT",DIQ(0)="IEN" D EN^DIQ1
192 Q
Note: See TracBrowser for help on using the repository browser.