ORPR03 ; slc/dcm - While you were printing ; 07 Dec 99 01:43PM
;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
C1 ; Chart Copy Print
N ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
U IO
D PAT(+ORVP)
S ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
S ORHEAD=$$GET^XPAR("ALL","ORPF CHART COPY HEADER",1,"I")
S ORFOOT=$$GET^XPAR("ALL","ORPF CHART COPY FOOTER",1,"I")
S OROFMT=$$GET^XPAR("ALL","ORPF CHART COPY FORMAT",1,"I")
S ORIOSL=IOSL
I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
S ORIOF=IOF,IOF="!!",ORFIRST1=1
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)
. I '$L($G(^OR(100,ORIFN,0))) D EN^ORERR("CHARTCOPY PRINT WITH INVALID ORIFN:"_ORIFN) Q
. D CHT1^ORPR04
. I 'OACTION D EN^ORERR("NO ACTION DEFINED FOR CHARTCOPY PRINT ORIFN:"_ORIFN) Q
. I '$D(^OR(100,ORIFN,8,OACTION)) D EN^ORERR("ACTION NODE ^(8) NOT SET FOR ORIFN:DA:"_ORIFN_":"_OACTION) Q
. 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.
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)
S IOF=ORIOF
W @IOF
I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
Q
W1 ;Work Copy Print
N ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
U IO
D PAT(+ORVP)
S ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
S ORHEAD=$$GET^XPAR("ALL","ORPF WORK COPY HEADER",1,"I")
S ORFOOT=$$GET^XPAR("ALL","ORPF WORK COPY FOOTER",1,"I")
S OROFMT=$$GET^XPAR("ALL","ORPF WORK COPY FORMAT",1,"I")
S ORIOSL=IOSL
I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
S ORIOF=IOF,IOF="!!",ORFIRST1=1
I OROFMT S ORFMT=OROFMT,ORCI=0 F S ORCI=$O(@ARAY@(ORCI)) Q:ORCI<1 D Q:$G(OREND)
. S ORIFN=+@ARAY@(ORCI),OACTION=$P(@ARAY@(ORCI),";",2)
. D WRK^ORPR08
. S ORFIRST1=0
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)
S IOF=ORIOF
I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
Q
L1 ; Label Print
N ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORPK,SORT,SORT1,ORCI,X3,SFIELD,ORFIRST1
N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
U IO
S ORTKG=0,ORIOF=IOF,ORIOSL=IOSL,ORFIRST1=1
D PAT(+ORVP)
F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG<1 I $$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",ORTKG,"I") S ORCI="" D
. S SFIELD=$$GET^XPAR("SYS","ORPF LABEL SORT FIELD",ORTKG,"I")
. K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
. M ^TMP("ORBEFORE",$J)=@ARAY@(ORTKG)
. D ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
. S SORT=""
. F S SORT=$O(^TMP("ORAFTER",$J,SORT)) Q:SORT="" D
.. S SORT1=""
.. F S SORT1=$O(^TMP("ORAFTER",$J,SORT,SORT1)) Q:SORT1="" D
... S ORCI=""
... F S ORCI=$O(^TMP("ORAFTER",$J,SORT,SORT1,ORCI)) Q:ORCI="" D Q:$G(OREND)
.... S ORIFN=+ORCI,OACTION=$P(ORCI,";",2),X3=$P($G(^OR(100,ORIFN,3)),"^",3)
.... I X3,X3'=11 D LBL1^ORPR01(1,$G(ORTIMES))
I $D(ZTSK),'$G(TASK) D ^%ZISC,KILL^%ZTLOAD K ZTSK
K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
Q
R1 ; Requisition Print
N ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORTKG,ORXPND,ORPK,SORT,SORT1,ORGE,ORCI,X3,SFIELD,ORFIRST1
N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
U IO
S ORTKG=0,ORIOF=IOF,ORIOSL=IOSL
D PAT(+ORVP)
F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG<1 I $$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORTKG,"I") S ORCI="",IOF=ORIOF D
. S SFIELD=$$GET^XPAR("SYS","ORPF REQUISITION SORT FIELD",ORTKG,"I")
. S ORHEAD=$$GET^XPAR("SYS","ORPF WARD REQUISITION HEADER",ORTKG,"I")
. S ORFOOT=$$GET^XPAR("SYS","ORPF WARD REQUISITION FOOTER",ORTKG,"I")
. K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
. M ^TMP("ORBEFORE",$J)=@ARAY@(ORTKG)
. D ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
. S SORT="",ORGE=0 F S SORT=$O(^TMP("ORAFTER",$J,SORT)) Q:SORT="" D
.. S ORGE=1 ;ORGE used to control form feeds and indicate screened transactions
.. I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
.. I +ORHEAD D PRINT^ORPR00(ORHEAD,1)
.. S ORIOF=IOF,IOF="!!",ORFIRST1=1
.. S SORT1="" F S SORT1=$O(^TMP("ORAFTER",$J,SORT,SORT1)) Q:SORT1="" D
... I 'ORGE W @ORIOF S ORGE=1 I +ORHEAD D PRINT^ORPR00(ORHEAD,1)
... S ORCI=""
... F S ORCI=$O(^TMP("ORAFTER",$J,SORT,SORT1,ORCI)) Q:ORCI="" D Q:$G(OREND)
.... S ORFIRST1=0,ORGE=0,ORIFN=+ORCI,OACTION=$P(ORCI,";",2),X3=$P($G(^OR(100,ORIFN,3)),"^",3)
.... I X3,X3'=11 D REQ1^ORPR01(1,"S ORGE=1")
... 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)
... S IOF=ORIOF
.. I 'ORFOOT,'ORGE,$O(^TMP("ORAFTER",$J,SORT)) W @ORIOF
I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
S IOF=ORIOF
K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
Q
SVCOPY(ORDEFIO,SARAY) ; Print Service Copies
;SARAY(PKG,ORIFN)=Device ptr^# of copies (used by Consults service copies)
N ORDEF,ORSCI,ORSCPY,ORIC,ORNM,ZTREQ
I $D(ZTQUEUED) S ZTREQ="@"
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
. I $D(SARAY(ORTKG))>9 S ORSCI=0 D
.. F S ORSCI=$O(SARAY(ORTKG,ORSCI)) Q:ORSCI'>0 D
... N ARAY
... S ORDEF=$S($G(ORDEFIO):"",1:$P($G(SARAY(ORTKG,ORSCI)),U)),ARAY(ORTKG,ORSCI)=""
... S ORSCPY=$S(+$P($G(SARAY(ORTKG,ORSCI)),U,2):+$P($G(SARAY(ORTKG,ORSCI)),U,2),1:1)
... F ORIC=1:1:ORSCPY S X=$$DEVICE^ORPR02(+$G(ORDEFIO)_"^"_ORNM_" SERVICE COPIES",ORDEF,"S1^ORPR03")
. Q:'$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
. I $D(SARAY(ORTKG))'>9 D
.. S X=$S($G(ORDEFIO):"",1:$$GET^XPAR(+LOC_";SC("_"^DIV^SYS","ORPF SERVICE COPY DEFLT DEVICE",ORTKG,"I"))
.. I $L(X) S X=$$DEVICE^ORPR02("0^"_ORNM_" SERVICE COPIES",X,"S1^ORPR03") Q
.. E I $G(ORDEFIO) S X=$$DEVICE^ORPR02("1^"_ORNM_" SERVICE COPIES",,"S1^ORPR03") Q
Q
S1 ; Service Copy Print Routine
N ORIFN,OACTION,ORX,ORNUM,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORSNUM,ORFIRST1
N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
U IO
D PAT(+ORVP)
S OROFMT=$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
S ORHEAD=$$GET^XPAR("SYS","ORPF SERVICE COPY HEADER",ORTKG,"I")
S ORFOOT=$$GET^XPAR("SYS","ORPF SERVICE COPY FOOTER",ORTKG,"I")
S ORIOSL=IOSL
I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
S ORIOF=IOF,IOF="!",ORFIRST1=1
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)
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)
S IOF=ORIOF
I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
Q
PAT(Y) ;Get patient variables
;Y=DFN or ORVP
N VA,VA200,VAIN,VADM,VAROOT,VAERR,VAINDT
Q:'$G(Y)
S DFN=+Y,VA200=1
D OERR^VADPT
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=""
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPR03 7825 printed Dec 13, 2024@02:32:37 Page 2
ORPR03 ; slc/dcm - While you were printing ; 07 Dec 99 01:43PM
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
C1 ; Chart Copy Print
+1 NEW ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
+2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
+3 USE IO
+4 DO PAT(+ORVP)
+5 SET ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
+6 SET ORHEAD=$$GET^XPAR("ALL","ORPF CHART COPY HEADER",1,"I")
+7 SET ORFOOT=$$GET^XPAR("ALL","ORPF CHART COPY FOOTER",1,"I")
+8 SET OROFMT=$$GET^XPAR("ALL","ORPF CHART COPY FORMAT",1,"I")
+9 SET ORIOSL=IOSL
+10 IF ORFOOT
IF $DATA(^ORD(100.23,ORFOOT,0))
SET ORBOT=$PIECE(^(0),"^",2)
SET ORIOSL=IOSL-ORBOT
+11 IF ORHEAD
DO PRINT^ORPR00(ORHEAD,1,0,1)
+12 SET ORIOF=IOF
SET IOF="!!"
SET ORFIRST1=1
+13 IF OROFMT
SET ORFMT=OROFMT
SET ORCI=0
FOR
SET ORCI=$ORDER(@ARAY@(ORCI))
if ORCI<1
QUIT
SET ORIFN=+@ARAY@(ORCI)
SET OACTION=$PIECE(@ARAY@(ORCI),";",2)
Begin DoDot:1
+14 IF '$LENGTH($GET(^OR(100,ORIFN,0)))
DO EN^ORERR("CHARTCOPY PRINT WITH INVALID ORIFN:"_ORIFN)
QUIT
+15 DO CHT1^ORPR04
+16 IF 'OACTION
DO EN^ORERR("NO ACTION DEFINED FOR CHARTCOPY PRINT ORIFN:"_ORIFN)
QUIT
+17 IF '$DATA(^OR(100,ORIFN,8,OACTION))
DO EN^ORERR("ACTION NODE ^(8) NOT SET FOR ORIFN:DA:"_ORIFN_":"_OACTION)
QUIT
+18 ;ORRACT is around if this is a reprint.
IF '$DATA(ORRACT)
if '$PIECE($GET(^OR(100,ORIFN,8,OACTION,7)),"^")
SET $PIECE(^(7),"^",1,4)=1_"^"_$$NOW^XLFDT_"^"_DUZ_"^"_IO
End DoDot:1
SET ORFIRST1=0
if $GET(OREND)
QUIT
+19 IF ORFOOT
IF '$GET(OREND)
if IOF?1"!"."!"
SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))=""
DO PRINT^ORPR00(ORFOOT,1)
+20 SET IOF=ORIOF
+21 WRITE @IOF
+22 IF '$GET(TASK)
DO ^%ZISC
IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+23 QUIT
W1 ;Work Copy Print
+1 NEW ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
+2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
+3 USE IO
+4 DO PAT(+ORVP)
+5 SET ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
+6 SET ORHEAD=$$GET^XPAR("ALL","ORPF WORK COPY HEADER",1,"I")
+7 SET ORFOOT=$$GET^XPAR("ALL","ORPF WORK COPY FOOTER",1,"I")
+8 SET OROFMT=$$GET^XPAR("ALL","ORPF WORK COPY FORMAT",1,"I")
+9 SET ORIOSL=IOSL
+10 IF ORFOOT
IF $DATA(^ORD(100.23,ORFOOT,0))
SET ORBOT=$PIECE(^(0),"^",2)
SET ORIOSL=IOSL-ORBOT
+11 IF ORHEAD
DO PRINT^ORPR00(ORHEAD,1,0,1)
+12 SET ORIOF=IOF
SET IOF="!!"
SET ORFIRST1=1
+13 IF OROFMT
SET ORFMT=OROFMT
SET ORCI=0
FOR
SET ORCI=$ORDER(@ARAY@(ORCI))
if ORCI<1
QUIT
Begin DoDot:1
+14 SET ORIFN=+@ARAY@(ORCI)
SET OACTION=$PIECE(@ARAY@(ORCI),";",2)
+15 DO WRK^ORPR08
+16 SET ORFIRST1=0
End DoDot:1
if $GET(OREND)
QUIT
+17 IF ORFOOT
IF '$GET(OREND)
if IOF?1"!"."!"
SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))=""
DO PRINT^ORPR00(ORFOOT,1)
+18 SET IOF=ORIOF
+19 IF '$GET(TASK)
DO ^%ZISC
IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+20 QUIT
L1 ; Label Print
+1 NEW ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORPK,SORT,SORT1,ORCI,X3,SFIELD,ORFIRST1
+2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
+3 USE IO
+4 SET ORTKG=0
SET ORIOF=IOF
SET ORIOSL=IOSL
SET ORFIRST1=1
+5 DO PAT(+ORVP)
+6 FOR
SET ORTKG=$ORDER(@ARAY@(ORTKG))
if ORTKG<1
QUIT
IF $$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",ORTKG,"I")
SET ORCI=""
Begin DoDot:1
+7 SET SFIELD=$$GET^XPAR("SYS","ORPF LABEL SORT FIELD",ORTKG,"I")
+8 KILL ^TMP("ORBEFORE",$JOB),^TMP("ORAFTER",$JOB)
+9 MERGE ^TMP("ORBEFORE",$JOB)=@ARAY@(ORTKG)
+10 DO ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
+11 SET SORT=""
+12 FOR
SET SORT=$ORDER(^TMP("ORAFTER",$JOB,SORT))
if SORT=""
QUIT
Begin DoDot:2
+13 SET SORT1=""
+14 FOR
SET SORT1=$ORDER(^TMP("ORAFTER",$JOB,SORT,SORT1))
if SORT1=""
QUIT
Begin DoDot:3
+15 SET ORCI=""
+16 FOR
SET ORCI=$ORDER(^TMP("ORAFTER",$JOB,SORT,SORT1,ORCI))
if ORCI=""
QUIT
Begin DoDot:4
+17 SET ORIFN=+ORCI
SET OACTION=$PIECE(ORCI,";",2)
SET X3=$PIECE($GET(^OR(100,ORIFN,3)),"^",3)
+18 IF X3
IF X3'=11
DO LBL1^ORPR01(1,$GET(ORTIMES))
End DoDot:4
if $GET(OREND)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF $DATA(ZTSK)
IF '$GET(TASK)
DO ^%ZISC
DO KILL^%ZTLOAD
KILL ZTSK
+20 KILL ^TMP("ORBEFORE",$JOB),^TMP("ORAFTER",$JOB)
+21 QUIT
R1 ; Requisition Print
+1 NEW ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORTKG,ORXPND,ORPK,SORT,SORT1,ORGE,ORCI,X3,SFIELD,ORFIRST1
+2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
+3 USE IO
+4 SET ORTKG=0
SET ORIOF=IOF
SET ORIOSL=IOSL
+5 DO PAT(+ORVP)
+6 FOR
SET ORTKG=$ORDER(@ARAY@(ORTKG))
if ORTKG<1
QUIT
IF $$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORTKG,"I")
SET ORCI=""
SET IOF=ORIOF
Begin DoDot:1
+7 SET SFIELD=$$GET^XPAR("SYS","ORPF REQUISITION SORT FIELD",ORTKG,"I")
+8 SET ORHEAD=$$GET^XPAR("SYS","ORPF WARD REQUISITION HEADER",ORTKG,"I")
+9 SET ORFOOT=$$GET^XPAR("SYS","ORPF WARD REQUISITION FOOTER",ORTKG,"I")
+10 KILL ^TMP("ORBEFORE",$JOB),^TMP("ORAFTER",$JOB)
+11 MERGE ^TMP("ORBEFORE",$JOB)=@ARAY@(ORTKG)
+12 DO ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
+13 SET SORT=""
SET ORGE=0
FOR
SET SORT=$ORDER(^TMP("ORAFTER",$JOB,SORT))
if SORT=""
QUIT
Begin DoDot:2
+14 ;ORGE used to control form feeds and indicate screened transactions
SET ORGE=1
+15 IF ORFOOT
IF $DATA(^ORD(100.23,ORFOOT,0))
SET ORBOT=$PIECE(^(0),"^",2)
SET ORIOSL=IOSL-ORBOT
+16 IF +ORHEAD
DO PRINT^ORPR00(ORHEAD,1)
+17 SET ORIOF=IOF
SET IOF="!!"
SET ORFIRST1=1
+18 SET SORT1=""
FOR
SET SORT1=$ORDER(^TMP("ORAFTER",$JOB,SORT,SORT1))
if SORT1=""
QUIT
Begin DoDot:3
+19 IF 'ORGE
WRITE @ORIOF
SET ORGE=1
IF +ORHEAD
DO PRINT^ORPR00(ORHEAD,1)
+20 SET ORCI=""
+21 FOR
SET ORCI=$ORDER(^TMP("ORAFTER",$JOB,SORT,SORT1,ORCI))
if ORCI=""
QUIT
Begin DoDot:4
+22 SET ORFIRST1=0
SET ORGE=0
SET ORIFN=+ORCI
SET OACTION=$PIECE(ORCI,";",2)
SET X3=$PIECE($GET(^OR(100,ORIFN,3)),"^",3)
+23 IF X3
IF X3'=11
DO REQ1^ORPR01(1,"S ORGE=1")
End DoDot:4
if $GET(OREND)
QUIT
+24 IF ORFOOT
IF '$GET(OREND)
if IOF?1"!"."!"
SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))=""
DO PRINT^ORPR00(ORFOOT,1)
+25 SET IOF=ORIOF
End DoDot:3
+26 IF 'ORFOOT
IF 'ORGE
IF $ORDER(^TMP("ORAFTER",$JOB,SORT))
WRITE @ORIOF
End DoDot:2
End DoDot:1
+27 IF '$GET(TASK)
DO ^%ZISC
IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+28 SET IOF=ORIOF
+29 KILL ^TMP("ORBEFORE",$JOB),^TMP("ORAFTER",$JOB)
+30 QUIT
SVCOPY(ORDEFIO,SARAY) ; Print Service Copies
+1 ;SARAY(PKG,ORIFN)=Device ptr^# of copies (used by Consults service copies)
+2 NEW ORDEF,ORSCI,ORSCPY,ORIC,ORNM,ZTREQ
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 IF $DATA(ARAY)
FOR ORTKG=0:0
SET ORTKG=$ORDER(@ARAY@(ORTKG))
if ORTKG<1
QUIT
SET ORNM=$PIECE($GET(^DIC(9.4,ORTKG,0)),"^")
Begin DoDot:1
+5 IF $DATA(SARAY(ORTKG))>9
SET ORSCI=0
Begin DoDot:2
+6 FOR
SET ORSCI=$ORDER(SARAY(ORTKG,ORSCI))
if ORSCI'>0
QUIT
Begin DoDot:3
+7 NEW ARAY
+8 SET ORDEF=$SELECT($GET(ORDEFIO):"",1:$PIECE($GET(SARAY(ORTKG,ORSCI)),U))
SET ARAY(ORTKG,ORSCI)=""
+9 SET ORSCPY=$SELECT(+$PIECE($GET(SARAY(ORTKG,ORSCI)),U,2):+$PIECE($GET(SARAY(ORTKG,ORSCI)),U,2),1:1)
+10 FOR ORIC=1:1:ORSCPY
SET X=$$DEVICE^ORPR02(+$GET(ORDEFIO)_"^"_ORNM_" SERVICE COPIES",ORDEF,"S1^ORPR03")
End DoDot:3
End DoDot:2
+11 if '$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
QUIT
+12 IF $DATA(SARAY(ORTKG))'>9
Begin DoDot:2
+13 SET X=$SELECT($GET(ORDEFIO):"",1:$$GET^XPAR(+LOC_";SC("_"^DIV^SYS","ORPF SERVICE COPY DEFLT DEVICE",ORTKG,"I"))
+14 IF $LENGTH(X)
SET X=$$DEVICE^ORPR02("0^"_ORNM_" SERVICE COPIES",X,"S1^ORPR03")
QUIT
+15 IF '$TEST
IF $GET(ORDEFIO)
SET X=$$DEVICE^ORPR02("1^"_ORNM_" SERVICE COPIES",,"S1^ORPR03")
QUIT
End DoDot:2
End DoDot:1
+16 QUIT
S1 ; Service Copy Print Routine
+1 NEW ORIFN,OACTION,ORX,ORNUM,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORSNUM,ORFIRST1
+2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
+3 USE IO
+4 DO PAT(+ORVP)
+5 SET OROFMT=$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
+6 SET ORHEAD=$$GET^XPAR("SYS","ORPF SERVICE COPY HEADER",ORTKG,"I")
+7 SET ORFOOT=$$GET^XPAR("SYS","ORPF SERVICE COPY FOOTER",ORTKG,"I")
+8 SET ORIOSL=IOSL
+9 IF ORFOOT
IF $DATA(^ORD(100.23,ORFOOT,0))
SET ORBOT=$PIECE(^(0),"^",2)
SET ORIOSL=IOSL-ORBOT
+10 IF ORHEAD
DO PRINT^ORPR00(ORHEAD,1,0,1)
+11 SET ORIOF=IOF
SET IOF="!"
SET ORFIRST1=1
+12 IF OROFMT
SET ORFMT=OROFMT
SET ORCI=""
FOR
SET ORCI=$ORDER(@ARAY@(ORTKG,ORCI))
if ORCI=""
QUIT
SET ORIFN=+ORCI
SET OACTION=$PIECE(ORCI,";",2)
DO CHT1^ORPR04
SET ORFIRST1=0
if $GET(OREND)
QUIT
+13 IF ORFOOT
IF '$GET(OREND)
if IOF?1"!"."!"
SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:1))=""
if IOF=""
SET IOF=ORIOF
DO PRINT^ORPR00(ORFOOT,1,0)
+14 SET IOF=ORIOF
+15 IF '$GET(TASK)
DO ^%ZISC
IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+16 QUIT
PAT(Y) ;Get patient variables
+1 ;Y=DFN or ORVP
+2 NEW VA,VA200,VAIN,VADM,VAROOT,VAERR,VAINDT
+3 if '$GET(Y)
QUIT
+4 SET DFN=+Y
SET VA200=1
+5 DO OERR^VADPT
+6 SET ORPNM=VADM(1)
SET ORSSN=VA("PID")
SET ORDOB=$PIECE(VADM(3),"^",2)
SET ORAGE=VADM(4)
SET ORSEX=$PIECE(VADM(5),"^")
SET ORTS=+VAIN(3)
SET ORTS=$SELECT($GET(ORTS):ORTS,1:"")
SET ORNP=+VAIN(2)
SET ORWARD=VAIN(4)
SET ORPV=""
+7 IF '$DATA(ORL)
IF $PIECE(ORWARD,"^")?1N.N
SET ORL(1)=VAIN(5)
SET (ORL,ORL(0),ORL(2))=""
SET X=+ORWARD
IF $DATA(^DIC(42,+X,44))
SET X=$PIECE(^(44),"^")
IF X
IF $DATA(^SC(X,0))
SET ORL=X_";SC("
SET ORL(0)=$SELECT($LENGTH($PIECE(^(0),"^",2)):$PIECE(^(0),"^",2),1:$EXTRACT($PIECE(^(0),"^"),1,4))
SET ORL(2)=ORL
+8 QUIT
