source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPR03.m@ 1195

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

initial load of WorldVistAEHR
File size: 7.5 KB
Line 
1ORPR03 ; slc/dcm - While you were printing ; 07 Dec 99 01:43PM
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
3C1 ; Chart Copy Print
4 N ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
5 N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
6 U IO
7 D PAT(+ORVP)
8 S ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
9 S ORHEAD=$$GET^XPAR("ALL","ORPF CHART COPY HEADER",1,"I")
10 S ORFOOT=$$GET^XPAR("ALL","ORPF CHART COPY FOOTER",1,"I")
11 S OROFMT=$$GET^XPAR("ALL","ORPF CHART COPY FORMAT",1,"I")
12 S ORIOSL=IOSL
13 I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
14 I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
15 S ORIOF=IOF,IOF="!!",ORFIRST1=1
16 I OROFMT S ORFMT=OROFMT,ORCI=0 F S ORCI=$O(@ARAY@(ORCI)) Q:ORCI<1 S ORIFN=+@ARAY@(ORCI),OACTION=$P(@ARAY@(ORCI),";",2) D S ORFIRST1=0 Q:$G(OREND)
17 . I '$L($G(^OR(100,ORIFN,0))) D EN^ORERR("CHARTCOPY PRINT WITH INVALID ORIFN:"_ORIFN) Q
18 . D CHT1^ORPR04
19 . I 'OACTION D EN^ORERR("NO ACTION DEFINED FOR CHARTCOPY PRINT ORIFN:"_ORIFN) Q
20 . I '$D(^OR(100,ORIFN,8,OACTION)) D EN^ORERR("ACTION NODE ^(8) NOT SET FOR ORIFN:DA:"_ORIFN_":"_OACTION) Q
21 . I '$D(ORRACT) S:'$P($G(^OR(100,ORIFN,8,OACTION,7)),"^") $P(^(7),"^",1,4)=1_"^"_$$NOW^XLFDT_"^"_DUZ_"^"_IO ;ORRACT is around if this is a reprint.
22 I ORFOOT,'$G(OREND) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))="" D PRINT^ORPR00(ORFOOT,1)
23 S IOF=ORIOF
24 W @IOF
25 I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
26 Q
27W1 ;Work Copy Print
28 N ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
29 N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
30 U IO
31 D PAT(+ORVP)
32 S ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
33 S ORHEAD=$$GET^XPAR("ALL","ORPF WORK COPY HEADER",1,"I")
34 S ORFOOT=$$GET^XPAR("ALL","ORPF WORK COPY FOOTER",1,"I")
35 S OROFMT=$$GET^XPAR("ALL","ORPF WORK COPY FORMAT",1,"I")
36 S ORIOSL=IOSL
37 I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
38 I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
39 S ORIOF=IOF,IOF="!!",ORFIRST1=1
40 I OROFMT S ORFMT=OROFMT,ORCI=0 F S ORCI=$O(@ARAY@(ORCI)) Q:ORCI<1 D Q:$G(OREND)
41 . S ORIFN=+@ARAY@(ORCI),OACTION=$P(@ARAY@(ORCI),";",2)
42 . D WRK^ORPR08
43 . S ORFIRST1=0
44 I ORFOOT,'$G(OREND) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))="" D PRINT^ORPR00(ORFOOT,1)
45 S IOF=ORIOF
46 I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
47 Q
48L1 ; Label Print
49 N ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORPK,SORT,SORT1,ORCI,X3,SFIELD,ORFIRST1
50 N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
51 U IO
52 S ORTKG=0,ORIOF=IOF,ORIOSL=IOSL,ORFIRST1=1
53 D PAT(+ORVP)
54 F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG<1 I $$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",ORTKG,"I") S ORCI="" D
55 . S SFIELD=$$GET^XPAR("SYS","ORPF LABEL SORT FIELD",ORTKG,"I")
56 . K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
57 . M ^TMP("ORBEFORE",$J)=@ARAY@(ORTKG)
58 . D ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
59 . S SORT=""
60 . F S SORT=$O(^TMP("ORAFTER",$J,SORT)) Q:SORT="" D
61 .. S SORT1=""
62 .. F S SORT1=$O(^TMP("ORAFTER",$J,SORT,SORT1)) Q:SORT1="" D
63 ... S ORCI=""
64 ... F S ORCI=$O(^TMP("ORAFTER",$J,SORT,SORT1,ORCI)) Q:ORCI="" D Q:$G(OREND)
65 .... S ORIFN=+ORCI,OACTION=$P(ORCI,";",2),X3=$P($G(^OR(100,ORIFN,3)),"^",3)
66 .... I X3,X3'=11 D LBL1^ORPR01(1,$G(ORTIMES))
67 I $D(ZTSK),'$G(TASK) D ^%ZISC,KILL^%ZTLOAD K ZTSK
68 K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
69 Q
70R1 ; Requisition Print
71 N ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORTKG,ORXPND,ORPK,SORT,SORT1,ORGE,ORCI,X3,SFIELD,ORFIRST1
72 N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
73 U IO
74 S ORTKG=0,ORIOF=IOF,ORIOSL=IOSL
75 D PAT(+ORVP)
76 F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG<1 I $$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORTKG,"I") S ORCI="",IOF=ORIOF D
77 . S SFIELD=$$GET^XPAR("SYS","ORPF REQUISITION SORT FIELD",ORTKG,"I")
78 . S ORHEAD=$$GET^XPAR("SYS","ORPF WARD REQUISITION HEADER",ORTKG,"I")
79 . S ORFOOT=$$GET^XPAR("SYS","ORPF WARD REQUISITION FOOTER",ORTKG,"I")
80 . K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
81 . M ^TMP("ORBEFORE",$J)=@ARAY@(ORTKG)
82 . D ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
83 . S SORT="",ORGE=0 F S SORT=$O(^TMP("ORAFTER",$J,SORT)) Q:SORT="" D
84 .. S ORGE=1 ;ORGE used to control form feeds and indicate screened transactions
85 .. I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
86 .. I +ORHEAD D PRINT^ORPR00(ORHEAD,1)
87 .. S ORIOF=IOF,IOF="!!",ORFIRST1=1
88 .. S SORT1="" F S SORT1=$O(^TMP("ORAFTER",$J,SORT,SORT1)) Q:SORT1="" D
89 ... I 'ORGE W @ORIOF S ORGE=1 I +ORHEAD D PRINT^ORPR00(ORHEAD,1)
90 ... S ORCI=""
91 ... F S ORCI=$O(^TMP("ORAFTER",$J,SORT,SORT1,ORCI)) Q:ORCI="" D Q:$G(OREND)
92 .... S ORFIRST1=0,ORGE=0,ORIFN=+ORCI,OACTION=$P(ORCI,";",2),X3=$P($G(^OR(100,ORIFN,3)),"^",3)
93 .... I X3,X3'=11 D REQ1^ORPR01(1,"S ORGE=1")
94 ... I ORFOOT,'$G(OREND) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))="" D PRINT^ORPR00(ORFOOT,1)
95 ... S IOF=ORIOF
96 .. I 'ORFOOT,'ORGE,$O(^TMP("ORAFTER",$J,SORT)) W @ORIOF
97 I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
98 S IOF=ORIOF
99 K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
100 Q
101SVCOPY(ORDEFIO,SARAY) ; Print Service Copies
102 ;SARAY(PKG,ORIFN)=Device ptr^# of copies (used by Consults service copies)
103 N ORDEF,ORSCI,ORSCPY,ORIC,ORNM,ZTREQ
104 I $D(ZTQUEUED) S ZTREQ="@"
105 I $D(ARAY) F ORTKG=0:0 S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG<1 S ORNM=$P($G(^DIC(9.4,ORTKG,0)),"^") D
106 . I $D(SARAY(ORTKG))>9 S ORSCI=0 D
107 .. F S ORSCI=$O(SARAY(ORTKG,ORSCI)) Q:ORSCI'>0 D
108 ... N ARAY
109 ... S ORDEF=$S($G(ORDEFIO):"",1:$P($G(SARAY(ORTKG,ORSCI)),U)),ARAY(ORTKG,ORSCI)=""
110 ... S ORSCPY=$S(+$P($G(SARAY(ORTKG,ORSCI)),U,2):+$P($G(SARAY(ORTKG,ORSCI)),U,2),1:1)
111 ... F ORIC=1:1:ORSCPY S X=$$DEVICE^ORPR02(+$G(ORDEFIO)_"^"_ORNM_" SERVICE COPIES",ORDEF,"S1^ORPR03")
112 . Q:'$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
113 . I $D(SARAY(ORTKG))'>9 D
114 .. S X=$S($G(ORDEFIO):"",1:$$GET^XPAR(+LOC_";SC("_"^DIV^SYS","ORPF SERVICE COPY DEFLT DEVICE",ORTKG,"I"))
115 .. I $L(X) S X=$$DEVICE^ORPR02("0^"_ORNM_" SERVICE COPIES",X,"S1^ORPR03") Q
116 .. E I $G(ORDEFIO) S X=$$DEVICE^ORPR02("1^"_ORNM_" SERVICE COPIES",,"S1^ORPR03") Q
117 Q
118S1 ; Service Copy Print Routine
119 N ORIFN,OACTION,ORX,ORNUM,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORSNUM,ORFIRST1
120 N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
121 U IO
122 D PAT(+ORVP)
123 S OROFMT=$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
124 S ORHEAD=$$GET^XPAR("SYS","ORPF SERVICE COPY HEADER",ORTKG,"I")
125 S ORFOOT=$$GET^XPAR("SYS","ORPF SERVICE COPY FOOTER",ORTKG,"I")
126 S ORIOSL=IOSL
127 I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
128 I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
129 S ORIOF=IOF,IOF="!",ORFIRST1=1
130 I OROFMT S ORFMT=OROFMT,ORCI="" F S ORCI=$O(@ARAY@(ORTKG,ORCI)) Q:ORCI="" S ORIFN=+ORCI,OACTION=$P(ORCI,";",2) D CHT1^ORPR04 S ORFIRST1=0 Q:$G(OREND)
131 I ORFOOT,'$G(OREND) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:1))="" S:IOF="" IOF=ORIOF D PRINT^ORPR00(ORFOOT,1,0)
132 S IOF=ORIOF
133 I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
134 Q
135PAT(Y) ;Get patient variables
136 ;Y=DFN or ORVP
137 N VA,VA200,VAIN,VADM,VAROOT,VAERR,VAINDT
138 Q:'$G(Y)
139 S DFN=+Y,VA200=1
140 D OERR^VADPT
141 S ORPNM=VADM(1),ORSSN=VA("PID"),ORDOB=$P(VADM(3),"^",2),ORAGE=VADM(4),ORSEX=$P(VADM(5),"^"),ORTS=+VAIN(3),ORTS=$S($G(ORTS):ORTS,1:""),ORNP=+VAIN(2),ORWARD=VAIN(4),ORPV=""
142 I '$D(ORL),$P(ORWARD,"^")?1N.N S ORL(1)=VAIN(5),(ORL,ORL(0),ORL(2))="",X=+ORWARD I $D(^DIC(42,+X,44)) S X=$P(^(44),"^") I X,$D(^SC(X,0)) S ORL=X_";SC(",ORL(0)=$S($L($P(^(0),"^",2)):$P(^(0),"^",2),1:$E($P(^(0),"^"),1,4)),ORL(2)=ORL
143 Q
Note: See TracBrowser for help on using the repository browser.