ORWD1 ; SLC/KCM/REV - GUI Prints; 28-JAN-1999 12:51 ;7/31/06 11:34
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,140,215,260,492**;Dec 17, 1997;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
;
PRINTS(PRTLST,HLOC,ORWDEV) ; Do the auto-prints after signing orders
; PRTLST(n)=ORIFN;ACT^Chart^Label^Requisition^Service^Work
Q:$G(A7RNDBI) ; per NDBI, to suppress prints during integration
N ADEVICE,TMPLST S HLOC=+HLOC_";SC("
; if there is a print device for chart copies, print chart copies
D MKLST(2) I $D(TMPLST)>1 D ; Print Chart Copies
. ;*492 only print from CPRS when device is passed in otherwise use default
. S ADEVICE=$S($G(ORWDEV)'="":+$P($G(ORWDEV),U,1),1:$$GET^XPAR(HLOC,"ORPF CHART COPY PRINT DEVICE",1,"I"))
. I ADEVICE D GUI^ORPR02(.TMPLST,ADEVICE,"C",HLOC)
D MKLST(3) I $D(TMPLST)>1 D ; Print Labels
. ;*492 only print from CPRS when device is passed in otherwise use default
. S ADEVICE=$S($G(ORWDEV)'="":+$P($G(ORWDEV),U,2),1:$$GET^XPAR(HLOC,"ORPF LABEL PRINT DEVICE",1,"I"))
. I ADEVICE D GUI^ORPR02(.TMPLST,ADEVICE,"L",HLOC)
D MKLST(4) I $D(TMPLST)>1 D ; Print Requisitions
. ;*492 only print from CPRS when device is passed in otherwise use default
. S ADEVICE=$S($G(ORWDEV)'="":+$P($G(ORWDEV),U,3),1:$$GET^XPAR(HLOC,"ORPF REQUISITION PRINT DEVICE",1,"I"))
. I ADEVICE D GUI^ORPR02(.TMPLST,ADEVICE,"R",HLOC)
D MKLST(5) I $D(TMPLST)>1 D ; Print Service Copies
. D GUI^ORPR02(.TMPLST,"","S",HLOC)
D MKLST(6) I $D(TMPLST)>1 D ; Print Work Copies
. ;*492 only print from CPRS when device is passed in otherwise use default
. S ADEVICE=$S($G(ORWDEV)'="":+$P($G(ORWDEV),U,4),1:$$GET^XPAR(HLOC,"ORPF WORK COPY PRINT DEVICE",1,"I"))
. I ADEVICE D GUI^ORPR02(.TMPLST,ADEVICE,"W",HLOC)
Q
MKLST(APIECE) ; Make a list to pass to GUI^ORPR02, called only from PRINTS
; expect PRTLST to be defined, creates new TMPLST
N I,J,ORIFN,ACT,NOA,PKG,DLG K TMPLST
S I="",J=0 F S I=$O(PRTLST(I)) Q:I'>0 D
. I ($L(PRTLST(I),U)>1),'$P(PRTLST(I),"^",APIECE) Q
. S ORIFN=+PRTLST(I),ACT=+$P(PRTLST(I),";",2)
. S NOA=+$P($G(^OR(100,ORIFN,8,ACT,0)),U,12)
. I APIECE=2,'$P($G(^ORD(100.02,NOA,1)),U,2) Q ; no chart copies
. I APIECE=6,'$P($G(^ORD(100.02,NOA,1)),U,5) Q ; no work copies
. S PKG=+$P($G(^OR(100,+ORIFN,0)),U,14),DLG=+$P($G(^OR(100,+ORIFN,0)),U,5)
. I APIECE=4,PKG=$O(^DIC(9.4,"B","DIETETICS",0)),DLG'=$O(^ORD(101.41,"B","FHW SPECIAL MEAL",0)) Q ;no requisitions
. S J=J+1,TMPLST(J)=$P(PRTLST(I),U)
Q
PARAM(Y,LOC) ;Returns in 'Y' the print parameters
;Y=Prompt for CC^Prompt for L ^Prompt for R ^Prompt for W ^CC device ^L Device ^R Device ^WC device
;Device Params returned in internal;external format, the rest are internal
;CC=Chart Copy
;L=Label
;R=Requisitions
;WC=Work Copy
;'Prompt for' values (internal):
;0 for no prompts- chart copy is automatically generated.
;1 to prompt for chart copy and ask which printer should be used.
;2 to prompt for chart copy and automatically print to the
; printer defined in the CHART COPY PRINT DEVICE field.
;* don't print.
;LOC=Ptr to location ^SC(LOC,
Q:'$G(LOC)
S Y=$$BLDIT(LOC)
Q
BLDIT(LOC) ;Get Print parameters
Q:'$G(LOC) ""
N PARAM,I
S PARAM=""
F I="ORPF PROMPT FOR CHART COPY","ORPF PROMPT FOR LABELS","ORPF PROMPT FOR REQUISITIONS","ORPF PROMPT FOR WORK COPY" D
. S PARAM=PARAM_$$XPAR(I,LOC,"Q")_"^"
S PARAM=PARAM_$$XPAR("ORPF CHART COPY PRINT DEVICE",LOC)_"^"
S PARAM=PARAM_$$XPAR("ORPF LABEL PRINT DEVICE",LOC)_"^"
S PARAM=PARAM_$$XPAR("ORPF REQUISITION PRINT DEVICE",LOC)_"^"
S PARAM=PARAM_$$XPAR("ORPF WORK COPY PRINT DEVICE",LOC)_"^"
Q PARAM
COMLOC(LOC,ORDERS) ; Return common location for orders in list, if any
N I
S LOC=0,I=0
; get the location for the first order that was signed or released
F S I=$O(ORDERS(I)) Q:'I D Q:LOC
. I $P(ORDERS(I),U,2)'["R",($P(ORDERS(I),U,2)'["S") Q
. S LOC=+$P($G(^OR(100,+ORDERS(I),0)),U,10)
; compare the location to the following orders
I LOC F S I=$O(ORDERS(I)) Q:'I D Q:'LOC
. I $P(ORDERS(I),U,2)'["R",($P(ORDERS(I),U,2)'["S") Q
. I (+$P($G(^OR(100,+ORDERS(I),0)),U,10)'=LOC) S LOC=0
Q
SIG4ONE(REQ,ANORDER) ; Return 1 if order requires a signature
S REQ=0
I +$P($G(^OR(100,+ANORDER,0)),U,16) S REQ=1
Q
SIG4ANY(REQ,ORDERS) ; Return 1 if any order requires a signature
N I
S I=0,REQ=0
F S I=$O(ORDERS(I)) Q:'I D Q:REQ
. I +$P($G(^OR(100,+ORDERS(I),0)),U,16) S REQ=1
Q
XPAR(NAME,LOC,FMT) ;Get parameter values
Q:'$L(NAME) ""
S:'$D(FMT) FMT="B"
Q $TR($$GET^XPAR("ALL^"_+LOC_";SC(",NAME,1,FMT),"^",";")
;
PRINTGUI(ORESULT,HLOC,ORWDEV,PRTLST) ; File|Print orders from GUI
;ORRACT is set here to identify this as a manual reprint
N ADEVICE,ORRACT,ORPLST,I,PKG,DLG
N BBPKG S BBPKG=+$O(^DIC(9.4,"B","VBECS",0))
S PRTLST="",I=0
K ORPLST M ORPLST=PRTLST
S ORRACT=1,ADEVICE=$P(ORWDEV,U,1),ORESULT=1
I +ADEVICE D GUI^ORPR02(.ORPLST,ADEVICE,"C",HLOC)
S ADEVICE=$P(ORWDEV,U,2)
K ORPLST M ORPLST=PRTLST
D INSRTBB^ORWD2(.ORPLST) ; insert BB child Lab orders into ORPLST for printing labels
I +ADEVICE D GUI^ORPR02(.ORPLST,ADEVICE,"L",HLOC)
;
S ADEVICE=$P(ORWDEV,U,3)
K ORPLST M ORPLST=PRTLST
;no FH order requisitions except special meals
F S I=$O(ORPLST(I)) Q:'I D
. S PKG=+$P($G(^OR(100,+ORPLST(I),0)),U,14),DLG=+$P($G(^OR(100,+ORPLST(I),0)),U,5)
. I PKG=$O(^DIC(9.4,"B","DIETETICS",0)),DLG'=$O(^ORD(101.41,"B","FHW SPECIAL MEAL",0)) K ORPLST(I)
D INSRTBB^ORWD2(.ORPLST) ; insert BB child Lab orders into ORPLST for printing requisitions
I +ADEVICE,$D(ORPLST) D GUI^ORPR02(.ORPLST,ADEVICE,"R",HLOC)
;
S ADEVICE=$P(ORWDEV,U,4)
K ORPLST M ORPLST=PRTLST
I +ADEVICE D GUI^ORPR02(.ORPLST,ADEVICE,"W",HLOC)
; D GUI^ORPR02(.ORPLST,"","S",HLOC) no svc copies from File|Print
Q
RVPRINT(OK,HLOC,ORWDEV,PRTLST) ; print orders from review/sign actions
D PRINTS(.PRTLST,HLOC,ORWDEV) S OK=1
Q
SVONLY(OK,HLOC,PRTLST) ; print service copies only
Q:$G(A7RNDBI) ; per NDBI, to suppress prints during integration
N TMPLST,I,J
S HLOC=+HLOC_";SC(",OK=1
S I="",J=0 F S I=$O(PRTLST(I)) Q:I'>0 D
. I ($L(PRTLST(I),U)>1),'$P(PRTLST(I),U,5) Q
. S J=J+1,TMPLST(J)=$P(PRTLST(I),U)
I $D(TMPLST)>1 D GUI^ORPR02(.TMPLST,"","S",HLOC)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWD1 6309 printed Apr 09, 2024@21:36:04 Page 2
ORWD1 ; SLC/KCM/REV - GUI Prints; 28-JAN-1999 12:51 ;7/31/06 11:34
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,140,215,260,492**;Dec 17, 1997;Build 3
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
PRINTS(PRTLST,HLOC,ORWDEV) ; Do the auto-prints after signing orders
+1 ; PRTLST(n)=ORIFN;ACT^Chart^Label^Requisition^Service^Work
+2 ; per NDBI, to suppress prints during integration
if $GET(A7RNDBI)
QUIT
+3 NEW ADEVICE,TMPLST
SET HLOC=+HLOC_";SC("
+4 ; if there is a print device for chart copies, print chart copies
+5 ; Print Chart Copies
DO MKLST(2)
IF $DATA(TMPLST)>1
Begin DoDot:1
+6 ;*492 only print from CPRS when device is passed in otherwise use default
+7 SET ADEVICE=$SELECT($GET(ORWDEV)'="":+$PIECE($GET(ORWDEV),U,1),1:$$GET^XPAR(HLOC,"ORPF CHART COPY PRINT DEVICE",1,"I"))
+8 IF ADEVICE
DO GUI^ORPR02(.TMPLST,ADEVICE,"C",HLOC)
End DoDot:1
+9 ; Print Labels
DO MKLST(3)
IF $DATA(TMPLST)>1
Begin DoDot:1
+10 ;*492 only print from CPRS when device is passed in otherwise use default
+11 SET ADEVICE=$SELECT($GET(ORWDEV)'="":+$PIECE($GET(ORWDEV),U,2),1:$$GET^XPAR(HLOC,"ORPF LABEL PRINT DEVICE",1,"I"))
+12 IF ADEVICE
DO GUI^ORPR02(.TMPLST,ADEVICE,"L",HLOC)
End DoDot:1
+13 ; Print Requisitions
DO MKLST(4)
IF $DATA(TMPLST)>1
Begin DoDot:1
+14 ;*492 only print from CPRS when device is passed in otherwise use default
+15 SET ADEVICE=$SELECT($GET(ORWDEV)'="":+$PIECE($GET(ORWDEV),U,3),1:$$GET^XPAR(HLOC,"ORPF REQUISITION PRINT DEVICE",1,"I"))
+16 IF ADEVICE
DO GUI^ORPR02(.TMPLST,ADEVICE,"R",HLOC)
End DoDot:1
+17 ; Print Service Copies
DO MKLST(5)
IF $DATA(TMPLST)>1
Begin DoDot:1
+18 DO GUI^ORPR02(.TMPLST,"","S",HLOC)
End DoDot:1
+19 ; Print Work Copies
DO MKLST(6)
IF $DATA(TMPLST)>1
Begin DoDot:1
+20 ;*492 only print from CPRS when device is passed in otherwise use default
+21 SET ADEVICE=$SELECT($GET(ORWDEV)'="":+$PIECE($GET(ORWDEV),U,4),1:$$GET^XPAR(HLOC,"ORPF WORK COPY PRINT DEVICE",1,"I"))
+22 IF ADEVICE
DO GUI^ORPR02(.TMPLST,ADEVICE,"W",HLOC)
End DoDot:1
+23 QUIT
MKLST(APIECE) ; Make a list to pass to GUI^ORPR02, called only from PRINTS
+1 ; expect PRTLST to be defined, creates new TMPLST
+2 NEW I,J,ORIFN,ACT,NOA,PKG,DLG
KILL TMPLST
+3 SET I=""
SET J=0
FOR
SET I=$ORDER(PRTLST(I))
if I'>0
QUIT
Begin DoDot:1
+4 IF ($LENGTH(PRTLST(I),U)>1)
IF '$PIECE(PRTLST(I),"^",APIECE)
QUIT
+5 SET ORIFN=+PRTLST(I)
SET ACT=+$PIECE(PRTLST(I),";",2)
+6 SET NOA=+$PIECE($GET(^OR(100,ORIFN,8,ACT,0)),U,12)
+7 ; no chart copies
IF APIECE=2
IF '$PIECE($GET(^ORD(100.02,NOA,1)),U,2)
QUIT
+8 ; no work copies
IF APIECE=6
IF '$PIECE($GET(^ORD(100.02,NOA,1)),U,5)
QUIT
+9 SET PKG=+$PIECE($GET(^OR(100,+ORIFN,0)),U,14)
SET DLG=+$PIECE($GET(^OR(100,+ORIFN,0)),U,5)
+10 ;no requisitions
IF APIECE=4
IF PKG=$ORDER(^DIC(9.4,"B","DIETETICS",0))
IF DLG'=$ORDER(^ORD(101.41,"B","FHW SPECIAL MEAL",0))
QUIT
+11 SET J=J+1
SET TMPLST(J)=$PIECE(PRTLST(I),U)
End DoDot:1
+12 QUIT
PARAM(Y,LOC) ;Returns in 'Y' the print parameters
+1 ;Y=Prompt for CC^Prompt for L ^Prompt for R ^Prompt for W ^CC device ^L Device ^R Device ^WC device
+2 ;Device Params returned in internal;external format, the rest are internal
+3 ;CC=Chart Copy
+4 ;L=Label
+5 ;R=Requisitions
+6 ;WC=Work Copy
+7 ;'Prompt for' values (internal):
+8 ;0 for no prompts- chart copy is automatically generated.
+9 ;1 to prompt for chart copy and ask which printer should be used.
+10 ;2 to prompt for chart copy and automatically print to the
+11 ; printer defined in the CHART COPY PRINT DEVICE field.
+12 ;* don't print.
+13 ;LOC=Ptr to location ^SC(LOC,
+14 if '$GET(LOC)
QUIT
+15 SET Y=$$BLDIT(LOC)
+16 QUIT
BLDIT(LOC) ;Get Print parameters
+1 if '$GET(LOC)
QUIT ""
+2 NEW PARAM,I
+3 SET PARAM=""
+4 FOR I="ORPF PROMPT FOR CHART COPY","ORPF PROMPT FOR LABELS","ORPF PROMPT FOR REQUISITIONS","ORPF PROMPT FOR WORK COPY"
Begin DoDot:1
+5 SET PARAM=PARAM_$$XPAR(I,LOC,"Q")_"^"
End DoDot:1
+6 SET PARAM=PARAM_$$XPAR("ORPF CHART COPY PRINT DEVICE",LOC)_"^"
+7 SET PARAM=PARAM_$$XPAR("ORPF LABEL PRINT DEVICE",LOC)_"^"
+8 SET PARAM=PARAM_$$XPAR("ORPF REQUISITION PRINT DEVICE",LOC)_"^"
+9 SET PARAM=PARAM_$$XPAR("ORPF WORK COPY PRINT DEVICE",LOC)_"^"
+10 QUIT PARAM
COMLOC(LOC,ORDERS) ; Return common location for orders in list, if any
+1 NEW I
+2 SET LOC=0
SET I=0
+3 ; get the location for the first order that was signed or released
+4 FOR
SET I=$ORDER(ORDERS(I))
if 'I
QUIT
Begin DoDot:1
+5 IF $PIECE(ORDERS(I),U,2)'["R"
IF ($PIECE(ORDERS(I),U,2)'["S")
QUIT
+6 SET LOC=+$PIECE($GET(^OR(100,+ORDERS(I),0)),U,10)
End DoDot:1
if LOC
QUIT
+7 ; compare the location to the following orders
+8 IF LOC
FOR
SET I=$ORDER(ORDERS(I))
if 'I
QUIT
Begin DoDot:1
+9 IF $PIECE(ORDERS(I),U,2)'["R"
IF ($PIECE(ORDERS(I),U,2)'["S")
QUIT
+10 IF (+$PIECE($GET(^OR(100,+ORDERS(I),0)),U,10)'=LOC)
SET LOC=0
End DoDot:1
if 'LOC
QUIT
+11 QUIT
SIG4ONE(REQ,ANORDER) ; Return 1 if order requires a signature
+1 SET REQ=0
+2 IF +$PIECE($GET(^OR(100,+ANORDER,0)),U,16)
SET REQ=1
+3 QUIT
SIG4ANY(REQ,ORDERS) ; Return 1 if any order requires a signature
+1 NEW I
+2 SET I=0
SET REQ=0
+3 FOR
SET I=$ORDER(ORDERS(I))
if 'I
QUIT
Begin DoDot:1
+4 IF +$PIECE($GET(^OR(100,+ORDERS(I),0)),U,16)
SET REQ=1
End DoDot:1
if REQ
QUIT
+5 QUIT
XPAR(NAME,LOC,FMT) ;Get parameter values
+1 if '$LENGTH(NAME)
QUIT ""
+2 if '$DATA(FMT)
SET FMT="B"
+3 QUIT $TRANSLATE($$GET^XPAR("ALL^"_+LOC_";SC(",NAME,1,FMT),"^",";")
+4 ;
PRINTGUI(ORESULT,HLOC,ORWDEV,PRTLST) ; File|Print orders from GUI
+1 ;ORRACT is set here to identify this as a manual reprint
+2 NEW ADEVICE,ORRACT,ORPLST,I,PKG,DLG
+3 NEW BBPKG
SET BBPKG=+$ORDER(^DIC(9.4,"B","VBECS",0))
+4 SET PRTLST=""
SET I=0
+5 KILL ORPLST
MERGE ORPLST=PRTLST
+6 SET ORRACT=1
SET ADEVICE=$PIECE(ORWDEV,U,1)
SET ORESULT=1
+7 IF +ADEVICE
DO GUI^ORPR02(.ORPLST,ADEVICE,"C",HLOC)
+8 SET ADEVICE=$PIECE(ORWDEV,U,2)
+9 KILL ORPLST
MERGE ORPLST=PRTLST
+10 ; insert BB child Lab orders into ORPLST for printing labels
DO INSRTBB^ORWD2(.ORPLST)
+11 IF +ADEVICE
DO GUI^ORPR02(.ORPLST,ADEVICE,"L",HLOC)
+12 ;
+13 SET ADEVICE=$PIECE(ORWDEV,U,3)
+14 KILL ORPLST
MERGE ORPLST=PRTLST
+15 ;no FH order requisitions except special meals
+16 FOR
SET I=$ORDER(ORPLST(I))
if 'I
QUIT
Begin DoDot:1
+17 SET PKG=+$PIECE($GET(^OR(100,+ORPLST(I),0)),U,14)
SET DLG=+$PIECE($GET(^OR(100,+ORPLST(I),0)),U,5)
+18 IF PKG=$ORDER(^DIC(9.4,"B","DIETETICS",0))
IF DLG'=$ORDER(^ORD(101.41,"B","FHW SPECIAL MEAL",0))
KILL ORPLST(I)
End DoDot:1
+19 ; insert BB child Lab orders into ORPLST for printing requisitions
DO INSRTBB^ORWD2(.ORPLST)
+20 IF +ADEVICE
IF $DATA(ORPLST)
DO GUI^ORPR02(.ORPLST,ADEVICE,"R",HLOC)
+21 ;
+22 SET ADEVICE=$PIECE(ORWDEV,U,4)
+23 KILL ORPLST
MERGE ORPLST=PRTLST
+24 IF +ADEVICE
DO GUI^ORPR02(.ORPLST,ADEVICE,"W",HLOC)
+25 ; D GUI^ORPR02(.ORPLST,"","S",HLOC) no svc copies from File|Print
+26 QUIT
RVPRINT(OK,HLOC,ORWDEV,PRTLST) ; print orders from review/sign actions
+1 DO PRINTS(.PRTLST,HLOC,ORWDEV)
SET OK=1
+2 QUIT
SVONLY(OK,HLOC,PRTLST) ; print service copies only
+1 ; per NDBI, to suppress prints during integration
if $GET(A7RNDBI)
QUIT
+2 NEW TMPLST,I,J
+3 SET HLOC=+HLOC_";SC("
SET OK=1
+4 SET I=""
SET J=0
FOR
SET I=$ORDER(PRTLST(I))
if I'>0
QUIT
Begin DoDot:1
+5 IF ($LENGTH(PRTLST(I),U)>1)
IF '$PIECE(PRTLST(I),U,5)
QUIT
+6 SET J=J+1
SET TMPLST(J)=$PIECE(PRTLST(I),U)
End DoDot:1
+7 IF $DATA(TMPLST)>1
DO GUI^ORPR02(.TMPLST,"","S",HLOC)
+8 QUIT
