- 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 Feb 18, 2025@23:59:09 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