ORPR02 ; slc/dcm/rv - Dances with Prints ;09/13/06 13:30
;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,260**;Dec 17, 1997;Build 26
PRINT(ORVP,ARAY,SARAY,LOC,SELECT,ALTPRAM,NOQUE,ORTIMES) ;Decisions
;ORVP=DFN;DPT(
;ARAY=Name of global storing list of orders or just the local aray
;@ARAY@(#)=ORIFN;DA of action - Array of orders to print
;SARAY(PKG,ORIFN)=Device ptr^# of copies (used by Consults service copies)
;LOC=Location (ORL)
;SELECT=Set for desired reports (chart^label^req^service^work)
;ALTPRAM=Alternate for PARAM variable (overrides internal parameters):
; PROMPT CC^CC DEVICE^L DEVICE^R DEVICE^PROMPT L^PROMPT R^PROMPT W^W DEVICE
;NOQUE=1 to force interactive device selection; used for service copies
;ORTIMES=# of copies
N PARAM,IFN,ORPARAY,VAR
S ORPARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
I '$G(ORVP) S ORVP=$$PAT(.ARAY) I '$G(ORVP) S VAR("ARAY")="" D EN^ORERR("PRINT~ORPR02 called with invalid ORVP",,.VAR) G END
I '$L($G(LOC)) S LOC=$$LOC(.ARAY) I 'LOC S VAR("ARAY")="" D EN^ORERR("PRINT~ORPR02 called with invalid LOC",,.VAR) G END
I $S('$O(@ORPARAY@(0)):1,+$G(LOC)'>0:1,1:0),'$D(SARAY) G END
N ORAL,ORIFN
K ^TMP("ORAL",$J)
S PARAM=$S($L($G(ALTPRAM)):ALTPRAM,1:""),ORAL="^TMP(""ORAL"",$J)"
D:'$L($G(ALTPRAM)) PARAM($G(LOC))
D ARAY(.ARAY)
I '$D(SELECT) D CHART(.ARAY,PARAM),LABEL(.ORAL,PARAM,$G(ORTIMES)),REQ(.ORAL,PARAM),SERV(.ORAL,PARAM,.SARAY,$G(NOQUE)),WORK(.ARAY,PARAM) G END
I $D(SELECT) D CHART(.ARAY,PARAM):$P(SELECT,"^"),LABEL(.ORAL,PARAM,$G(ORTIMES)):$P(SELECT,"^",2),REQ(.ORAL,PARAM):$P(SELECT,"^",3),SERV(.ORAL,PARAM,.SARAY,$G(NOQUE)):$P(SELECT,"^",4),WORK(.ARAY,PARAM):$P(SELECT,"^",5)
G END
CHART(ARAY,PARAM) ;Chart copies
;ARAY=Array of orders to print
;PARAM=Print parameters based on location
S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
I $L($P(PARAM,"^"))!($L($P(PARAM,"^",2))) S X=$$DEVICE($P(PARAM,"^")_"^CHART COPY",$P(PARAM,"^",2),"C1^ORPR03")
Q
WORK(ARAY,PARAM) ;Work Copy
S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
I $L($P(PARAM,"^",7))!($L($P(PARAM,"^",8))) S X=$$DEVICE($P(PARAM,"^",7)_"^WORK COPY",$P(PARAM,"^",8),"W1^ORPR03")
Q
LABEL(ARAY,PARAM,ORTIMES) ;Labels
N ORPLF,ORTKG,ORPRMT
S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
I $L($P(PARAM,"^",3))!$L($P(PARAM,"^",5)) D
. S (ORPLF,ORTKG)=0
. I $O(@ARAY@(0)) F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG'>0!(ORPLF) D
.. S ORPLF=$S($$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",ORTKG,"I"):1,1:0)
. S ORPRMT=$S(ORPLF:$P(PARAM,"^",5),1:"*")_"^LABELS"
. S X=$$DEVICE(ORPRMT,$P(PARAM,"^",3),"L1^ORPR03",$G(ORTIMES))
Q
REQ(ARAY,PARAM) ;Requisitions
N ORPLF,ORTKG,ORPRMT,ORIFN,ORDLG
S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
I $L($P(PARAM,"^",4))!$L($P(PARAM,"^",6)) D
. S (ORPLF,ORTKG)=0
. I $O(@ARAY@(0)) F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG'>0!(ORPLF) D
.. S ORPLF=$S($$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORTKG,"I"):1,1:0)
.. I ORTKG=$O(^DIC(9.4,"B","DIETETICS",0)) D
... S ORIFN=0 F S ORIFN=$O(@ARAY@(ORTKG,ORIFN)) Q:'ORIFN D
.... S ORDLG=+$P(^OR(100,+ORIFN,0),U,5)
.... I ORDLG'=$O(^ORD(101.41,"B","FHW SPECIAL MEAL",0)) S ORPLF=0
. S ORPRMT=$S(ORPLF:$P(PARAM,"^",6),1:"*")_"^REQUISITIONS"
. S X=$$DEVICE(ORPRMT,$P(PARAM,"^",4),"R1^ORPR03")
Q
SERV(ARAY,PARAM,SARAY,NOQUE) ;Service copies
N ZTRTN,ZTSAVE,ZTIO,ZTDTH,ZTSK,GLOB
S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
S GLOB=$S($E(ARAY)="^":$E(ARAY,1,$L(ARAY)-1)_",",1:ARAY_"(")
I $O(@ARAY@(0)) D
. I $G(NOQUE)'=1 D Q
.. S ZTRTN="SVCOPY^ORPR03()",(ZTSAVE("CHART"),ZTSAVE("ORVP"),ZTSAVE("ARAY"),ZTSAVE(GLOB),ZTSAVE("PARAM"),ZTSAVE("SARAY("),ZTSAVE("ORPRES"),ZTSAVE("LOC"),ZTSAVE("LOC("),ZTIO)="",ZTDTH=$H
.. S ZTDESC="Service copy root task" D ^%ZTLOAD
. D SVCOPY^ORPR03(1)
Q
END ;Leave
D HOME^%ZIS
Q
DEVICE(PRMT,DEF,ZTRTN,ORTIMES) ; Gets device for output
;PRMT=Prompt?^Report name
;DEF=Print device
;ZTRTN=Routine
;ORTIMES=# of copies
N %ZIS,DIC,DIR,IOP,FORCEQUE,X,Y,ZTIO,ZTDESC,ZTDTH,OREND,GLOB,ORIOPTR,ORION
I $P(PRMT,"^")="*" Q 1
I $P(PRMT,"^")=0,'$G(DEF) Q 1
I +PRMT S DIR("A")="Print "_$P(PRMT,"^",2)_" for the orders: ",DIR("B")="YES",DIR("?")="Answer YES to have "_$P(PRMT,"^",2)_" printed for the orders.",DIR(0)="YA" D ^DIR I 'Y Q 1
I +$G(DEF)>0 D
. N X,DIC
. S X="`"_+DEF,DIC(0)="NX",DIC=3.5
. D ^DIC
. I Y<1 S %ZIS("A")=$P(PRMT,"^",2)_"Print DEVICE: " Q
. S:+PRMT=1 %ZIS("B")=$P(Y,"^",2)
. S ORION=$P(Y,"^",2)
. S:+PRMT=0!(+PRMT=2) ORIOPTR="`"_+Y,%ZIS="QN"
I $L($G(ARAY)) S GLOB=$S($E(ARAY)="^":$E(ARAY,1,$L(ARAY)-1)_",",1:ARAY_"("),ZTSAVE(GLOB)="",ZTSAVE("ARAY")=""
S (ZTSAVE("ORTIMES"),ZTSAVE("ORTKG"),ZTSAVE("ORVP"),ZTSAVE("ORPRES"),ZTSAVE("ORSEQ"),ZTSAVE("ORCUM("),ZTSAVE("LOC"),ZTSAVE("LOC("),ZTSAVE("ORRACT"))="",ZTDESC=$P(PRMT,"^",2)
S:+PRMT'=1 FORCEQUE=1,ZTDTH=$H
D QUE^ORUTL1(ZTRTN,ZTDESC,.ZTSAVE,$G(ORIOPTR),$G(ZTDTH),.%ZIS,$G(FORCEQUE),1,$G(ORION))
Q ""
PAT(ARAY) ;Get patient if not passed
S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
Q:'$O(@ARAY@(0)) ""
S X=$O(@ARAY@(0)),X=$P($G(^OR(100,+@ARAY@(X),0)),"^",2)
Q X
LOC(ARAY) ;Get location if not passed
S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
Q:'$O(@ARAY@(0)) ""
S X=$O(@ARAY@(0)),X=$P($G(^OR(100,+@ARAY@(X),0)),"^",10)
Q X
TEST ;Test call
N DALE,OREND S OREND=0
K ^TMP("ORPARAY",$J)
F ORI=6752:0 S ORI=$O(^OR(100,ORI)) Q:ORI<1!(ORI>8000) S ^TMP("ORPARAY",$J,ORI)=ORI_";1"
W @IOF
D PRINT("","^TMP(""ORPARAY"",$J)","","","1^1^1^1^1")
;D GUI("^TMP(""ORPARAY"",$J)",63,"C",,1)
K ^TMP("ORPARAY",$J)
Q
PARAM(LOC) ;Get Print parameters
;LOC=Ptr to location SC(42,LOC,
;Returns Parameters in PARAM
;PARAM=Prompt for CC^CC device^L Device^R Device^Prompt for L^Prompt for R^Prompt for W^WC device
Q:'$G(LOC)
F I="ORPF PROMPT FOR CHART COPY","ORPF CHART COPY PRINT DEVICE","ORPF LABEL PRINT DEVICE","ORPF REQUISITION PRINT DEVICE","ORPF PROMPT FOR LABELS","ORPF PROMPT FOR REQUISITIONS","ORPF PROMPT FOR WORK COPY","ORPF WORK COPY PRINT DEVICE" D
. S PARAM=PARAM_$$GET^XPAR("ALL^"_+LOC_";SC(",I,1,"I")_"^"
Q
ARAY(ARAY) ;Set aray up by package in ^TMP("ORAL",$J,package,orifn;action)
S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
N X,IFN S IFN=0
F S IFN=$O(@ARAY@(IFN)) Q:IFN<1 S X=$G(^OR(100,+@ARAY@(IFN),0)) K:$P(X,"^",2)'=ORVP @ARAY@(IFN) I +X,$P(X,"^",2)=ORVP,$P(X,"^",14) S ^TMP("ORAL",$J,$P(X,"^",14),@ARAY@(IFN))=""
Q
GUI(ARAY,DEVICE,FMT,LOC,TASK,ORTIMES) ;Silence of the Prints
;ARAY=Name of global storing list of orders or just the local aray
;@ARAY@(#)=ORIFN;DA of action - Array of orders to print
;DEVICE=printer (internal ptr value)
;FMT=C:Chart copy, L:Labels, R:Requisitions, S:Service copies W:Work copies
;LOC=Location (ORL)
;TASK=1 to not task, 0 or undefined to task (default)
; this affects the closing of devices in ^ORPR03
;ORTIMES=# of copies
N ORPARAY,VAR
S ORPARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY"),ARAY=ORPARAY
Q:'$O(@ORPARAY@(0)) Q:'$D(IO) Q:'$D(FMT) Q:FMT="" Q:"CLRSW"'[FMT
N ORAL,ORVP,X,ZTRTN
K ^TMP("ORAL",$J)
S ORVP=$$PAT(.ARAY),ORAL="^TMP(""ORAL"",$J)"
I 'ORVP S VAR("ARAY")="" D EN^ORERR("GUI~ORPR02 called with invalid ORVP",,.VAR) Q
I '$G(LOC) S LOC=$$LOC(.ARAY)
D ARAY(.ARAY)
I "WC"'[FMT K ARAY S ARAY=ORAL
S X=0_"^"_$S(FMT="L":"Labels",FMT="R":"Requisitions",FMT="S":"Service Copies",FMT="C":"Chart Copies",FMT="W":"Work Copies",1:"")
S ZTRTN=$S(FMT="S":"SVCOPY^ORPR03()",1:FMT_"1^ORPR03")
S:FMT="S" TASK=1
I $G(TASK) D @ZTRTN Q
I '$G(TASK) S X=$$DEVICE(X,DEVICE,ZTRTN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPR02 7606 printed Sep 23, 2025@20:08:55 Page 2
ORPR02 ; slc/dcm/rv - Dances with Prints ;09/13/06 13:30
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,260**;Dec 17, 1997;Build 26
PRINT(ORVP,ARAY,SARAY,LOC,SELECT,ALTPRAM,NOQUE,ORTIMES) ;Decisions
+1 ;ORVP=DFN;DPT(
+2 ;ARAY=Name of global storing list of orders or just the local aray
+3 ;@ARAY@(#)=ORIFN;DA of action - Array of orders to print
+4 ;SARAY(PKG,ORIFN)=Device ptr^# of copies (used by Consults service copies)
+5 ;LOC=Location (ORL)
+6 ;SELECT=Set for desired reports (chart^label^req^service^work)
+7 ;ALTPRAM=Alternate for PARAM variable (overrides internal parameters):
+8 ; PROMPT CC^CC DEVICE^L DEVICE^R DEVICE^PROMPT L^PROMPT R^PROMPT W^W DEVICE
+9 ;NOQUE=1 to force interactive device selection; used for service copies
+10 ;ORTIMES=# of copies
+11 NEW PARAM,IFN,ORPARAY,VAR
+12 SET ORPARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+13 IF '$GET(ORVP)
SET ORVP=$$PAT(.ARAY)
IF '$GET(ORVP)
SET VAR("ARAY")=""
DO EN^ORERR("PRINT~ORPR02 called with invalid ORVP",,.VAR)
GOTO END
+14 IF '$LENGTH($GET(LOC))
SET LOC=$$LOC(.ARAY)
IF 'LOC
SET VAR("ARAY")=""
DO EN^ORERR("PRINT~ORPR02 called with invalid LOC",,.VAR)
GOTO END
+15 IF $SELECT('$ORDER(@ORPARAY@(0)):1,+$GET(LOC)'>0:1,1:0)
IF '$DATA(SARAY)
GOTO END
+16 NEW ORAL,ORIFN
+17 KILL ^TMP("ORAL",$JOB)
+18 SET PARAM=$SELECT($LENGTH($GET(ALTPRAM)):ALTPRAM,1:"")
SET ORAL="^TMP(""ORAL"",$J)"
+19 if '$LENGTH($GET(ALTPRAM))
DO PARAM($GET(LOC))
+20 DO ARAY(.ARAY)
+21 IF '$DATA(SELECT)
DO CHART(.ARAY,PARAM)
DO LABEL(.ORAL,PARAM,$GET(ORTIMES))
DO REQ(.ORAL,PARAM)
DO SERV(.ORAL,PARAM,.SARAY,$GET(NOQUE))
DO WORK(.ARAY,PARAM)
GOTO END
+22 IF $DATA(SELECT)
if $PIECE(SELECT,"^")
DO CHART(.ARAY,PARAM)
if $PIECE(SELECT,"^",2)
DO LABEL(.ORAL,PARAM,$GET(ORTIMES))
if $PIECE(SELECT,"^",3)
DO REQ(.ORAL,PARAM)
if $PIECE(SELECT,"^",4)
DO SERV(.ORAL,PARAM,.SARAY,$GET(NOQUE))
if $PIECE(SELECT,"^",5)
DO WORK(.ARAY,PARAM)
+23 GOTO END
CHART(ARAY,PARAM) ;Chart copies
+1 ;ARAY=Array of orders to print
+2 ;PARAM=Print parameters based on location
+3 SET ARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+4 IF $LENGTH($PIECE(PARAM,"^"))!($LENGTH($PIECE(PARAM,"^",2)))
SET X=$$DEVICE($PIECE(PARAM,"^")_"^CHART COPY",$PIECE(PARAM,"^",2),"C1^ORPR03")
+5 QUIT
WORK(ARAY,PARAM) ;Work Copy
+1 SET ARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+2 IF $LENGTH($PIECE(PARAM,"^",7))!($LENGTH($PIECE(PARAM,"^",8)))
SET X=$$DEVICE($PIECE(PARAM,"^",7)_"^WORK COPY",$PIECE(PARAM,"^",8),"W1^ORPR03")
+3 QUIT
LABEL(ARAY,PARAM,ORTIMES) ;Labels
+1 NEW ORPLF,ORTKG,ORPRMT
+2 SET ARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+3 IF $LENGTH($PIECE(PARAM,"^",3))!$LENGTH($PIECE(PARAM,"^",5))
Begin DoDot:1
+4 SET (ORPLF,ORTKG)=0
+5 IF $ORDER(@ARAY@(0))
FOR
SET ORTKG=$ORDER(@ARAY@(ORTKG))
if ORTKG'>0!(ORPLF)
QUIT
Begin DoDot:2
+6 SET ORPLF=$SELECT($$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",ORTKG,"I"):1,1:0)
End DoDot:2
+7 SET ORPRMT=$SELECT(ORPLF:$PIECE(PARAM,"^",5),1:"*")_"^LABELS"
+8 SET X=$$DEVICE(ORPRMT,$PIECE(PARAM,"^",3),"L1^ORPR03",$GET(ORTIMES))
End DoDot:1
+9 QUIT
REQ(ARAY,PARAM) ;Requisitions
+1 NEW ORPLF,ORTKG,ORPRMT,ORIFN,ORDLG
+2 SET ARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+3 IF $LENGTH($PIECE(PARAM,"^",4))!$LENGTH($PIECE(PARAM,"^",6))
Begin DoDot:1
+4 SET (ORPLF,ORTKG)=0
+5 IF $ORDER(@ARAY@(0))
FOR
SET ORTKG=$ORDER(@ARAY@(ORTKG))
if ORTKG'>0!(ORPLF)
QUIT
Begin DoDot:2
+6 SET ORPLF=$SELECT($$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORTKG,"I"):1,1:0)
+7 IF ORTKG=$ORDER(^DIC(9.4,"B","DIETETICS",0))
Begin DoDot:3
+8 SET ORIFN=0
FOR
SET ORIFN=$ORDER(@ARAY@(ORTKG,ORIFN))
if 'ORIFN
QUIT
Begin DoDot:4
+9 SET ORDLG=+$PIECE(^OR(100,+ORIFN,0),U,5)
+10 IF ORDLG'=$ORDER(^ORD(101.41,"B","FHW SPECIAL MEAL",0))
SET ORPLF=0
End DoDot:4
End DoDot:3
End DoDot:2
+11 SET ORPRMT=$SELECT(ORPLF:$PIECE(PARAM,"^",6),1:"*")_"^REQUISITIONS"
+12 SET X=$$DEVICE(ORPRMT,$PIECE(PARAM,"^",4),"R1^ORPR03")
End DoDot:1
+13 QUIT
SERV(ARAY,PARAM,SARAY,NOQUE) ;Service copies
+1 NEW ZTRTN,ZTSAVE,ZTIO,ZTDTH,ZTSK,GLOB
+2 SET ARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+3 SET GLOB=$SELECT($EXTRACT(ARAY)="^":$EXTRACT(ARAY,1,$LENGTH(ARAY)-1)_",",1:ARAY_"(")
+4 IF $ORDER(@ARAY@(0))
Begin DoDot:1
+5 IF $GET(NOQUE)'=1
Begin DoDot:2
+6 SET ZTRTN="SVCOPY^ORPR03()"
SET (ZTSAVE("CHART"),ZTSAVE("ORVP"),ZTSAVE("ARAY"),ZTSAVE(GLOB),ZTSAVE("PARAM"),ZTSAVE("SARAY("),ZTSAVE("ORPRES"),ZTSAVE("LOC"),ZTSAVE("LOC("),ZTIO)=""
SET ZTDTH=$HOROLOG
+7 SET ZTDESC="Service copy root task"
DO ^%ZTLOAD
End DoDot:2
QUIT
+8 DO SVCOPY^ORPR03(1)
End DoDot:1
+9 QUIT
END ;Leave
+1 DO HOME^%ZIS
+2 QUIT
DEVICE(PRMT,DEF,ZTRTN,ORTIMES) ; Gets device for output
+1 ;PRMT=Prompt?^Report name
+2 ;DEF=Print device
+3 ;ZTRTN=Routine
+4 ;ORTIMES=# of copies
+5 NEW %ZIS,DIC,DIR,IOP,FORCEQUE,X,Y,ZTIO,ZTDESC,ZTDTH,OREND,GLOB,ORIOPTR,ORION
+6 IF $PIECE(PRMT,"^")="*"
QUIT 1
+7 IF $PIECE(PRMT,"^")=0
IF '$GET(DEF)
QUIT 1
+8 IF +PRMT
SET DIR("A")="Print "_$PIECE(PRMT,"^",2)_" for the orders: "
SET DIR("B")="YES"
SET DIR("?")="Answer YES to have "_$PIECE(PRMT,"^",2)_" printed for the orders."
SET DIR(0)="YA"
DO ^DIR
IF 'Y
QUIT 1
+9 IF +$GET(DEF)>0
Begin DoDot:1
+10 NEW X,DIC
+11 SET X="`"_+DEF
SET DIC(0)="NX"
SET DIC=3.5
+12 DO ^DIC
+13 IF Y<1
SET %ZIS("A")=$PIECE(PRMT,"^",2)_"Print DEVICE: "
QUIT
+14 if +PRMT=1
SET %ZIS("B")=$PIECE(Y,"^",2)
+15 SET ORION=$PIECE(Y,"^",2)
+16 if +PRMT=0!(+PRMT=2)
SET ORIOPTR="`"_+Y
SET %ZIS="QN"
End DoDot:1
+17 IF $LENGTH($GET(ARAY))
SET GLOB=$SELECT($EXTRACT(ARAY)="^":$EXTRACT(ARAY,1,$LENGTH(ARAY)-1)_",",1:ARAY_"(")
SET ZTSAVE(GLOB)=""
SET ZTSAVE("ARAY")=""
+18 SET (ZTSAVE("ORTIMES"),ZTSAVE("ORTKG"),ZTSAVE("ORVP"),ZTSAVE("ORPRES"),ZTSAVE("ORSEQ"),ZTSAVE("ORCUM("),ZTSAVE("LOC"),ZTSAVE("LOC("),ZTSAVE("ORRACT"))=""
SET ZTDESC=$PIECE(PRMT,"^",2)
+19 if +PRMT'=1
SET FORCEQUE=1
SET ZTDTH=$HOROLOG
+20 DO QUE^ORUTL1(ZTRTN,ZTDESC,.ZTSAVE,$GET(ORIOPTR),$GET(ZTDTH),.%ZIS,$GET(FORCEQUE),1,$GET(ORION))
+21 QUIT ""
PAT(ARAY) ;Get patient if not passed
+1 SET ARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+2 if '$ORDER(@ARAY@(0))
QUIT ""
+3 SET X=$ORDER(@ARAY@(0))
SET X=$PIECE($GET(^OR(100,+@ARAY@(X),0)),"^",2)
+4 QUIT X
LOC(ARAY) ;Get location if not passed
+1 SET ARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+2 if '$ORDER(@ARAY@(0))
QUIT ""
+3 SET X=$ORDER(@ARAY@(0))
SET X=$PIECE($GET(^OR(100,+@ARAY@(X),0)),"^",10)
+4 QUIT X
TEST ;Test call
+1 NEW DALE,OREND
SET OREND=0
+2 KILL ^TMP("ORPARAY",$JOB)
+3 FOR ORI=6752:0
SET ORI=$ORDER(^OR(100,ORI))
if ORI<1!(ORI>8000)
QUIT
SET ^TMP("ORPARAY",$JOB,ORI)=ORI_";1"
+4 WRITE @IOF
+5 DO PRINT("","^TMP(""ORPARAY"",$J)","","","1^1^1^1^1")
+6 ;D GUI("^TMP(""ORPARAY"",$J)",63,"C",,1)
+7 KILL ^TMP("ORPARAY",$JOB)
+8 QUIT
PARAM(LOC) ;Get Print parameters
+1 ;LOC=Ptr to location SC(42,LOC,
+2 ;Returns Parameters in PARAM
+3 ;PARAM=Prompt for CC^CC device^L Device^R Device^Prompt for L^Prompt for R^Prompt for W^WC device
+4 if '$GET(LOC)
QUIT
+5 FOR I="ORPF PROMPT FOR CHART COPY","ORPF CHART COPY PRINT DEVICE","ORPF LABEL PRINT DEVICE","ORPF REQUISITION PRINT DEVICE","ORPF PROMPT FOR LABELS","ORPF PROMPT FOR REQUISITIONS","ORPF PROMPT FOR WORK COPY","ORPF WORK COPY PRINT DEVICE"
Begin DoDot:1
+6 SET PARAM=PARAM_$$GET^XPAR("ALL^"_+LOC_";SC(",I,1,"I")_"^"
End DoDot:1
+7 QUIT
ARAY(ARAY) ;Set aray up by package in ^TMP("ORAL",$J,package,orifn;action)
+1 SET ARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
+2 NEW X,IFN
SET IFN=0
+3 FOR
SET IFN=$ORDER(@ARAY@(IFN))
if IFN<1
QUIT
SET X=$GET(^OR(100,+@ARAY@(IFN),0))
if $PIECE(X,"^",2)'=ORVP
KILL @ARAY@(IFN)
IF +X
IF $PIECE(X,"^",2)=ORVP
IF $PIECE(X,"^",14)
SET ^TMP("ORAL",$JOB,$PIECE(X,"^",14),@ARAY@(IFN))=""
+4 QUIT
GUI(ARAY,DEVICE,FMT,LOC,TASK,ORTIMES) ;Silence of the Prints
+1 ;ARAY=Name of global storing list of orders or just the local aray
+2 ;@ARAY@(#)=ORIFN;DA of action - Array of orders to print
+3 ;DEVICE=printer (internal ptr value)
+4 ;FMT=C:Chart copy, L:Labels, R:Requisitions, S:Service copies W:Work copies
+5 ;LOC=Location (ORL)
+6 ;TASK=1 to not task, 0 or undefined to task (default)
+7 ; this affects the closing of devices in ^ORPR03
+8 ;ORTIMES=# of copies
+9 NEW ORPARAY,VAR
+10 SET ORPARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
SET ARAY=ORPARAY
+11 if '$ORDER(@ORPARAY@(0))
QUIT
if '$DATA(IO)
QUIT
if '$DATA(FMT)
QUIT
if FMT=""
QUIT
if "CLRSW"'[FMT
QUIT
+12 NEW ORAL,ORVP,X,ZTRTN
+13 KILL ^TMP("ORAL",$JOB)
+14 SET ORVP=$$PAT(.ARAY)
SET ORAL="^TMP(""ORAL"",$J)"
+15 IF 'ORVP
SET VAR("ARAY")=""
DO EN^ORERR("GUI~ORPR02 called with invalid ORVP",,.VAR)
QUIT
+16 IF '$GET(LOC)
SET LOC=$$LOC(.ARAY)
+17 DO ARAY(.ARAY)
+18 IF "WC"'[FMT
KILL ARAY
SET ARAY=ORAL
+19 SET X=0_"^"_$SELECT(FMT="L":"Labels",FMT="R":"Requisitions",FMT="S":"Service Copies",FMT="C":"Chart Copies",FMT="W":"Work Copies",1:"")
+20 SET ZTRTN=$SELECT(FMT="S":"SVCOPY^ORPR03()",1:FMT_"1^ORPR03")
+21 if FMT="S"
SET TASK=1
+22 IF $GET(TASK)
DO @ZTRTN
QUIT
+23 IF '$GET(TASK)
SET X=$$DEVICE(X,DEVICE,ZTRTN)
+24 QUIT
