Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORPR02

ORPR02.m

Go to the documentation of this file.
  1. 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
  1. PRINT(ORVP,ARAY,SARAY,LOC,SELECT,ALTPRAM,NOQUE,ORTIMES) ;Decisions
  1. ;ORVP=DFN;DPT(
  1. ;ARAY=Name of global storing list of orders or just the local aray
  1. ;@ARAY@(#)=ORIFN;DA of action - Array of orders to print
  1. ;SARAY(PKG,ORIFN)=Device ptr^# of copies (used by Consults service copies)
  1. ;LOC=Location (ORL)
  1. ;SELECT=Set for desired reports (chart^label^req^service^work)
  1. ;ALTPRAM=Alternate for PARAM variable (overrides internal parameters):
  1. ; PROMPT CC^CC DEVICE^L DEVICE^R DEVICE^PROMPT L^PROMPT R^PROMPT W^W DEVICE
  1. ;NOQUE=1 to force interactive device selection; used for service copies
  1. ;ORTIMES=# of copies
  1. N PARAM,IFN,ORPARAY,VAR
  1. S ORPARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. 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
  1. 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
  1. I $S('$O(@ORPARAY@(0)):1,+$G(LOC)'>0:1,1:0),'$D(SARAY) G END
  1. N ORAL,ORIFN
  1. K ^TMP("ORAL",$J)
  1. S PARAM=$S($L($G(ALTPRAM)):ALTPRAM,1:""),ORAL="^TMP(""ORAL"",$J)"
  1. D:'$L($G(ALTPRAM)) PARAM($G(LOC))
  1. D ARAY(.ARAY)
  1. 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
  1. 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)
  1. G END
  1. CHART(ARAY,PARAM) ;Chart copies
  1. ;ARAY=Array of orders to print
  1. ;PARAM=Print parameters based on location
  1. S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. I $L($P(PARAM,"^"))!($L($P(PARAM,"^",2))) S X=$$DEVICE($P(PARAM,"^")_"^CHART COPY",$P(PARAM,"^",2),"C1^ORPR03")
  1. Q
  1. WORK(ARAY,PARAM) ;Work Copy
  1. S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. I $L($P(PARAM,"^",7))!($L($P(PARAM,"^",8))) S X=$$DEVICE($P(PARAM,"^",7)_"^WORK COPY",$P(PARAM,"^",8),"W1^ORPR03")
  1. Q
  1. LABEL(ARAY,PARAM,ORTIMES) ;Labels
  1. N ORPLF,ORTKG,ORPRMT
  1. S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. I $L($P(PARAM,"^",3))!$L($P(PARAM,"^",5)) D
  1. . S (ORPLF,ORTKG)=0
  1. . I $O(@ARAY@(0)) F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG'>0!(ORPLF) D
  1. .. S ORPLF=$S($$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",ORTKG,"I"):1,1:0)
  1. . S ORPRMT=$S(ORPLF:$P(PARAM,"^",5),1:"*")_"^LABELS"
  1. . S X=$$DEVICE(ORPRMT,$P(PARAM,"^",3),"L1^ORPR03",$G(ORTIMES))
  1. Q
  1. REQ(ARAY,PARAM) ;Requisitions
  1. N ORPLF,ORTKG,ORPRMT,ORIFN,ORDLG
  1. S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. I $L($P(PARAM,"^",4))!$L($P(PARAM,"^",6)) D
  1. . S (ORPLF,ORTKG)=0
  1. . I $O(@ARAY@(0)) F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG'>0!(ORPLF) D
  1. .. S ORPLF=$S($$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORTKG,"I"):1,1:0)
  1. .. I ORTKG=$O(^DIC(9.4,"B","DIETETICS",0)) D
  1. ... S ORIFN=0 F S ORIFN=$O(@ARAY@(ORTKG,ORIFN)) Q:'ORIFN D
  1. .... S ORDLG=+$P(^OR(100,+ORIFN,0),U,5)
  1. .... I ORDLG'=$O(^ORD(101.41,"B","FHW SPECIAL MEAL",0)) S ORPLF=0
  1. . S ORPRMT=$S(ORPLF:$P(PARAM,"^",6),1:"*")_"^REQUISITIONS"
  1. . S X=$$DEVICE(ORPRMT,$P(PARAM,"^",4),"R1^ORPR03")
  1. Q
  1. SERV(ARAY,PARAM,SARAY,NOQUE) ;Service copies
  1. N ZTRTN,ZTSAVE,ZTIO,ZTDTH,ZTSK,GLOB
  1. S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. S GLOB=$S($E(ARAY)="^":$E(ARAY,1,$L(ARAY)-1)_",",1:ARAY_"(")
  1. I $O(@ARAY@(0)) D
  1. . I $G(NOQUE)'=1 D Q
  1. .. 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
  1. .. S ZTDESC="Service copy root task" D ^%ZTLOAD
  1. . D SVCOPY^ORPR03(1)
  1. Q
  1. END ;Leave
  1. D HOME^%ZIS
  1. Q
  1. DEVICE(PRMT,DEF,ZTRTN,ORTIMES) ; Gets device for output
  1. ;PRMT=Prompt?^Report name
  1. ;DEF=Print device
  1. ;ZTRTN=Routine
  1. ;ORTIMES=# of copies
  1. N %ZIS,DIC,DIR,IOP,FORCEQUE,X,Y,ZTIO,ZTDESC,ZTDTH,OREND,GLOB,ORIOPTR,ORION
  1. I $P(PRMT,"^")="*" Q 1
  1. I $P(PRMT,"^")=0,'$G(DEF) Q 1
  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
  1. I +$G(DEF)>0 D
  1. . N X,DIC
  1. . S X="`"_+DEF,DIC(0)="NX",DIC=3.5
  1. . D ^DIC
  1. . I Y<1 S %ZIS("A")=$P(PRMT,"^",2)_"Print DEVICE: " Q
  1. . S:+PRMT=1 %ZIS("B")=$P(Y,"^",2)
  1. . S ORION=$P(Y,"^",2)
  1. . S:+PRMT=0!(+PRMT=2) ORIOPTR="`"_+Y,%ZIS="QN"
  1. I $L($G(ARAY)) S GLOB=$S($E(ARAY)="^":$E(ARAY,1,$L(ARAY)-1)_",",1:ARAY_"("),ZTSAVE(GLOB)="",ZTSAVE("ARAY")=""
  1. S (ZTSAVE("ORTIMES"),ZTSAVE("ORTKG"),ZTSAVE("ORVP"),ZTSAVE("ORPRES"),ZTSAVE("ORSEQ"),ZTSAVE("ORCUM("),ZTSAVE("LOC"),ZTSAVE("LOC("),ZTSAVE("ORRACT"))="",ZTDESC=$P(PRMT,"^",2)
  1. S:+PRMT'=1 FORCEQUE=1,ZTDTH=$H
  1. D QUE^ORUTL1(ZTRTN,ZTDESC,.ZTSAVE,$G(ORIOPTR),$G(ZTDTH),.%ZIS,$G(FORCEQUE),1,$G(ORION))
  1. Q ""
  1. PAT(ARAY) ;Get patient if not passed
  1. S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. Q:'$O(@ARAY@(0)) ""
  1. S X=$O(@ARAY@(0)),X=$P($G(^OR(100,+@ARAY@(X),0)),"^",2)
  1. Q X
  1. LOC(ARAY) ;Get location if not passed
  1. S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. Q:'$O(@ARAY@(0)) ""
  1. S X=$O(@ARAY@(0)),X=$P($G(^OR(100,+@ARAY@(X),0)),"^",10)
  1. Q X
  1. TEST ;Test call
  1. N DALE,OREND S OREND=0
  1. K ^TMP("ORPARAY",$J)
  1. F ORI=6752:0 S ORI=$O(^OR(100,ORI)) Q:ORI<1!(ORI>8000) S ^TMP("ORPARAY",$J,ORI)=ORI_";1"
  1. W @IOF
  1. D PRINT("","^TMP(""ORPARAY"",$J)","","","1^1^1^1^1")
  1. ;D GUI("^TMP(""ORPARAY"",$J)",63,"C",,1)
  1. K ^TMP("ORPARAY",$J)
  1. Q
  1. PARAM(LOC) ;Get Print parameters
  1. ;LOC=Ptr to location SC(42,LOC,
  1. ;Returns Parameters in PARAM
  1. ;PARAM=Prompt for CC^CC device^L Device^R Device^Prompt for L^Prompt for R^Prompt for W^WC device
  1. Q:'$G(LOC)
  1. 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
  1. . S PARAM=PARAM_$$GET^XPAR("ALL^"_+LOC_";SC(",I,1,"I")_"^"
  1. Q
  1. ARAY(ARAY) ;Set aray up by package in ^TMP("ORAL",$J,package,orifn;action)
  1. S ARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY")
  1. N X,IFN S IFN=0
  1. 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))=""
  1. Q
  1. 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
  1. ;@ARAY@(#)=ORIFN;DA of action - Array of orders to print
  1. ;DEVICE=printer (internal ptr value)
  1. ;FMT=C:Chart copy, L:Labels, R:Requisitions, S:Service copies W:Work copies
  1. ;LOC=Location (ORL)
  1. ;TASK=1 to not task, 0 or undefined to task (default)
  1. ; this affects the closing of devices in ^ORPR03
  1. ;ORTIMES=# of copies
  1. N ORPARAY,VAR
  1. S ORPARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY"),ARAY=ORPARAY
  1. Q:'$O(@ORPARAY@(0)) Q:'$D(IO) Q:'$D(FMT) Q:FMT="" Q:"CLRSW"'[FMT
  1. N ORAL,ORVP,X,ZTRTN
  1. K ^TMP("ORAL",$J)
  1. S ORVP=$$PAT(.ARAY),ORAL="^TMP(""ORAL"",$J)"
  1. I 'ORVP S VAR("ARAY")="" D EN^ORERR("GUI~ORPR02 called with invalid ORVP",,.VAR) Q
  1. I '$G(LOC) S LOC=$$LOC(.ARAY)
  1. D ARAY(.ARAY)
  1. I "WC"'[FMT K ARAY S ARAY=ORAL
  1. S X=0_"^"_$S(FMT="L":"Labels",FMT="R":"Requisitions",FMT="S":"Service Copies",FMT="C":"Chart Copies",FMT="W":"Work Copies",1:"")
  1. S ZTRTN=$S(FMT="S":"SVCOPY^ORPR03()",1:FMT_"1^ORPR03")
  1. S:FMT="S" TASK=1
  1. I $G(TASK) D @ZTRTN Q
  1. I '$G(TASK) S X=$$DEVICE(X,DEVICE,ZTRTN)
  1. Q