- 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 Feb 19, 2025@00:01:42 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