ORWD2 ; SLC/KCM/REV - GUI Prints; 28-JAN-1999 12:51 ;1/9/06 00:35
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,215**;Dec 17, 1997
;
; PUBLIC CALLS
;
DEVINFO(LST,LOC,NATR,ORDERS) ; Return device info when signing/releasing orders
; Y(0)=Prompt Chart ^ Prompt Label ^ Prompt Requisition ^ Prompt Work
; ^ Chart Device ^ Label Device ^ Requisition Device ^ Work Device
; for Prompt X: *=no print, 0=autoprint, 1=prompt&dev 2=prompt only
; Y(n)=ORIFN;ACT ^ Chart ^ Label ^ Requisition ^ Service ^ Work
; LOC=location (ptr 44), NATR=nature of order (ptr 100.02)
; ORDERS=ORIFN;ACT ^ R | S | E (released, signed, error)
N NATCHT,NATWRK,WHENCHT,PRMTCHT,PRMTLBL,PRMTREQ,PRMTWRK
N DOCHT,DOLBL,DOREQ,DOWRK,RELEASE,ORDERID,I,J,X
N NDCR,NODE,NPCC,NPWC
S (DOCHT,DOLBL,DOREQ,DOWRK,I,J)=0,LOC=+LOC_";SC("
S NATR=$O(^ORD(100.02,"C",NATR,0))
S NATCHT=+$P($G(^ORD(100.02,NATR,1)),U,2),NATWRK=+$P($G(^(1)),U,5)
S WHENCHT=$$GET^XPAR("ALL^"_LOC,"ORPF PRINT CHART COPY WHEN",1,"I")
I '$L(WHENCHT) S WHENCHT="R"
S PRMTCHT=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR CHART COPY",1,"I")
S PRMTLBL=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR LABELS",1,"I")
S PRMTREQ=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR REQUISITIONS",1,"I")
S PRMTWRK=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR WORK COPY",1,"I")
N BBPKG S BBPKG=+$O(^DIC(9.4,"B","VBECS",0))
D INSRTBB(.ORDERS) ; insert any blood bank child lab orders into ORDERS array
F S I=$O(ORDERS(I)) Q:'I I $P(ORDERS(I),U,2)'["E" D
. S ORDERID=$P(ORDERS(I),U),RELEASE=($P(ORDERS(I),U,2)["R")
. S J=J+1,LST(J)=ORDERID_"^^^^"
. ;AGP this section check the order for DC Reason and grabs the print requirement
. ;from the Nature of Order file.
. S NPCC=1,NPWC=1
. S NDCR=$P($G(^OR(100,+ORDERID,6)),U) I NDCR>0 D
. .S NODE=$G(^ORD(100.02,NDCR,1))
. .S NPCC=+$P(NODE,U,2)
. .S NPWC=+$P(NODE,U,5)
. ; skip chart copy if nature doesn't print, no match to 'print when',
. ; prompt parameter says don't print, or is lab child of blood bank
. I NPCC,NATCHT,($P(ORDERS(I),U,2)[WHENCHT),(PRMTCHT'="*"),$$NOTBB(+ORDERS(I)) S $P(LST(J),U,2)=1,DOCHT=1
. ; skip label if not released, no label format, or prompt parameter
. ; says don't print
. I RELEASE,(PRMTLBL'="*"),$$HASFMTL S $P(LST(J),U,3)=1,DOLBL=1
. ; skip requisition if not released, no requistion format, or the
. ; prompt parameter says don't print
. I RELEASE,(PRMTREQ'="*"),$$HASFMTR S $P(LST(J),U,4)=1,DOREQ=1
. ; skip service copy if not releasing
. I RELEASE S $P(LST(J),U,5)=1
. ; skip work copy if nature doesn't print, not released, no work
. ; copy format, or prompt parameter says don't print
. I NPWC,NATWRK,RELEASE,(PRMTWRK'="*"),$$HASFMTW,$$NOTBB(+ORDERS(I)) S $P(LST(J),U,6)=1,DOWRK=1
S LST(0)=$$DEFDEV
Q
MANUAL(REC,LOC,ORDERS) ; return device info for manual prints
N DOCHT,DOLBL,DOREQ,DOWRK,ORDERID,I
N PRMTCHT,PRMTLBL,PRMTREQ,PRMTWRK ; (so undefined for DEFDEV call)
S (DOLBL,DOREQ,DOWRK,I,J)=0,DOCHT=1,LOC=+LOC_";SC("
N BBPKG S BBPKG=+$O(^DIC(9.4,"B","VBECS",0))
D INSRTBB(.ORDERS) ; insert any blood bank child lab orders into ORDERS array
F S I=$O(ORDERS(I)) Q:'I D Q:DOCHT&DOLBL&DOREQ&DOWRK
. S ORDERID=$P(ORDERS(I),U)
. I $$HASFMTL S DOLBL=1
. I $$HASFMTR S DOREQ=1
. I $$HASFMTW,$$NOTBB(+ORDERS(I)) S DOWRK=1
S REC=$$DEFDEV
Q
;
; PRIVATE CALLS
;
DEFDEV() ; returns string of prompt flags & default devices
; called from DEVINFO & MANUAL
; expects LOC,DOCHT,DOLBL,DOREQ,DOWRK to be defined
; optionally expects PRMTCHT, PRMTLBL, PRMTREQ, PRMTWRK
N X
I DOCHT D
. S $P(X,U,1)=$G(PRMTCHT,1)
. S $P(X,U,5)=$TR($$GET^XPAR("ALL^"_LOC,"ORPF CHART COPY PRINT DEVICE",1,"B"),U,";")
E S $P(X,U,1)="*"
I DOLBL D
. S $P(X,U,2)=$G(PRMTLBL,1)
. S $P(X,U,6)=$TR($$GET^XPAR("ALL^"_LOC,"ORPF LABEL PRINT DEVICE",1,"B"),U,";")
E S $P(X,U,2)="*"
I DOREQ D
. S $P(X,U,3)=$G(PRMTREQ,1)
. S $P(X,U,7)=$TR($$GET^XPAR("ALL^"_LOC,"ORPF REQUISITION PRINT DEVICE",1,"B"),U,";")
E S $P(X,U,3)="*"
I DOWRK D
. S $P(X,U,4)=$G(PRMTWRK,1)
. S $P(X,U,8)=$TR($$GET^XPAR("ALL^"_LOC,"ORPF WORK COPY PRINT DEVICE",1,"B"),U,";")
E S $P(X,U,4)="*"
Q X
HASFMTL() ; returns 1 if a label format is available
; called from DEVINFO & MANUAL, expects ORDERID & DOLBL to be defined
I DOLBL=1 Q 1 ; already know we're doing at least 1 label
N PKG S PKG=+$P($G(^OR(100,+ORDERID,0)),U,14)
Q ''$$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",PKG,"I")
;
HASFMTR() ; returns 1 if a requisition format is available
; called from DEVINFO & MANUAL, expects ORDERID & DOREQ to be defined
;I DOREQ=1 Q 1 ; already know we're doing at least 1 requisition
N PKG,DLG S PKG=+$P($G(^OR(100,+ORDERID,0)),U,14),DLG=+$P($G(^OR(100,+ORDERID,0)),U,5)
I PKG=$O(^DIC(9.4,"B","DIETETICS",0)),DLG'=$O(^ORD(101.41,"B","FHW SPECIAL MEAL",0)) Q 0 ;no requisitions
I DOREQ=1 Q 1 ; already know we're doing at least 1 requisition
Q ''$$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",PKG,"I")
;
HASFMTW() ; returns 1 if a work copy format is available
; called from DEVINFO & MANUAL, expects ORDERID & DOWRK to be defined
I DOWRK=1 Q 1 ; already know we're doing at least 1 work copy
Q ''$$GET^XPAR("SYS","ORPF WORK COPY FORMAT",1,"I") ; not at pkg level
;
INSRTBB(ORDRLST) ; Insert child lab orders for any orders going to VBECS
; called from DEVINFO, MANUAL
; expects BBPKG to be defined
Q:'BBPKG
N I,LABPKG,SUBID,CHILD,ACT,KIND
S LABPKG=+$O(^DIC(9.4,"B","LAB SERVICE",0)) Q:'LABPKG
S I=0 F S I=$O(ORDRLST(I)) Q:'I I $P(ORDRLST(I),U,2)'["E" D
. I $P($G(^OR(100,+ORDRLST(I),0)),U,14)'=BBPKG Q
. S SUBID=.0001
. S CHILD=0 F S CHILD=$O(^OR(100,+ORDRLST(I),2,CHILD)) Q:'CHILD D
. . I $P($G(^OR(100,CHILD,0)),U,14)'=LABPKG Q
. . S SUBID=SUBID+.0001,ACT=+$P(^OR(100,CHILD,3),U,7),KIND=$P(ORDRLST(I),U,2)
. . S ORDRLST(I+SUBID)=CHILD_";"_ACT_U_KIND
. S I=I+SUBID
Q
NOTBB(CHILD) ; returns 1 if the order is not a blood bank child lab order
; called from DEVINFO, MANUAL
; expects BBPKG to be defined
N PARENT S PARENT=$P(^OR(100,CHILD,3),U,9)
I PARENT,$P(^OR(100,PARENT,0),U,14)=BBPKG Q 0
Q 1
ORWD2 ; SLC/KCM/REV - GUI Prints; 28-JAN-1999 12:51 ;1/9/06 00:35
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,215**;Dec 17, 1997
+2 ;
+3 ; PUBLIC CALLS
+4 ;
DEVINFO(LST,LOC,NATR,ORDERS) ; Return device info when signing/releasing orders
+1 ; Y(0)=Prompt Chart ^ Prompt Label ^ Prompt Requisition ^ Prompt Work
+2 ; ^ Chart Device ^ Label Device ^ Requisition Device ^ Work Device
+3 ; for Prompt X: *=no print, 0=autoprint, 1=prompt&dev 2=prompt only
+4 ; Y(n)=ORIFN;ACT ^ Chart ^ Label ^ Requisition ^ Service ^ Work
+5 ; LOC=location (ptr 44), NATR=nature of order (ptr 100.02)
+6 ; ORDERS=ORIFN;ACT ^ R | S | E (released, signed, error)
+7 NEW NATCHT,NATWRK,WHENCHT,PRMTCHT,PRMTLBL,PRMTREQ,PRMTWRK
+8 NEW DOCHT,DOLBL,DOREQ,DOWRK,RELEASE,ORDERID,I,J,X
+9 NEW NDCR,NODE,NPCC,NPWC
+10 SET (DOCHT,DOLBL,DOREQ,DOWRK,I,J)=0
SET LOC=+LOC_";SC("
+11 SET NATR=$ORDER(^ORD(100.02,"C",NATR,0))
+12 SET NATCHT=+$PIECE($GET(^ORD(100.02,NATR,1)),U,2)
SET NATWRK=+$PIECE($GET(^(1)),U,5)
+13 SET WHENCHT=$$GET^XPAR("ALL^"_LOC,"ORPF PRINT CHART COPY WHEN",1,"I")
+14 IF '$LENGTH(WHENCHT)
SET WHENCHT="R"
+15 SET PRMTCHT=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR CHART COPY",1,"I")
+16 SET PRMTLBL=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR LABELS",1,"I")
+17 SET PRMTREQ=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR REQUISITIONS",1,"I")
+18 SET PRMTWRK=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR WORK COPY",1,"I")
+19 NEW BBPKG
SET BBPKG=+$ORDER(^DIC(9.4,"B","VBECS",0))
+20 ; insert any blood bank child lab orders into ORDERS array
DO INSRTBB(.ORDERS)
+21 FOR
SET I=$ORDER(ORDERS(I))
IF 'I
QUIT
IF $PIECE(ORDERS(I),U,2)'["E"
Begin DoDot:1
+22 SET ORDERID=$PIECE(ORDERS(I),U)
SET RELEASE=($PIECE(ORDERS(I),U,2)["R")
+23 SET J=J+1
SET LST(J)=ORDERID_"^^^^"
+24 ;AGP this section check the order for DC Reason and grabs the print requirement
+25 ;from the Nature of Order file.
+26 SET NPCC=1
SET NPWC=1
+27 SET NDCR=$PIECE($GET(^OR(100,+ORDERID,6)),U)
IF NDCR>0
Begin DoDot:2
+28 SET NODE=$GET(^ORD(100.02,NDCR,1))
+29 SET NPCC=+$PIECE(NODE,U,2)
+30 SET NPWC=+$PIECE(NODE,U,5)
End DoDot:2
+31 ; skip chart copy if nature doesn't print, no match to 'print when',
+32 ; prompt parameter says don't print, or is lab child of blood bank
+33 IF NPCC
IF NATCHT
IF ($PIECE(ORDERS(I),U,2)[WHENCHT)
IF (PRMTCHT'="*")
IF $$NOTBB(+ORDERS(I))
SET $PIECE(LST(J),U,2)=1
SET DOCHT=1
+34 ; skip label if not released, no label format, or prompt parameter
+35 ; says don't print
+36 IF RELEASE
IF (PRMTLBL'="*")
IF $$HASFMTL
SET $PIECE(LST(J),U,3)=1
SET DOLBL=1
+37 ; skip requisition if not released, no requistion format, or the
+38 ; prompt parameter says don't print
+39 IF RELEASE
IF (PRMTREQ'="*")
IF $$HASFMTR
SET $PIECE(LST(J),U,4)=1
SET DOREQ=1
+40 ; skip service copy if not releasing
+41 IF RELEASE
SET $PIECE(LST(J),U,5)=1
+42 ; skip work copy if nature doesn't print, not released, no work
+43 ; copy format, or prompt parameter says don't print
+44 IF NPWC
IF NATWRK
IF RELEASE
IF (PRMTWRK'="*")
IF $$HASFMTW
IF $$NOTBB(+ORDERS(I))
SET $PIECE(LST(J),U,6)=1
SET DOWRK=1
End DoDot:1
+45 SET LST(0)=$$DEFDEV
+46 QUIT
MANUAL(REC,LOC,ORDERS) ; return device info for manual prints
+1 NEW DOCHT,DOLBL,DOREQ,DOWRK,ORDERID,I
+2 ; (so undefined for DEFDEV call)
NEW PRMTCHT,PRMTLBL,PRMTREQ,PRMTWRK
+3 SET (DOLBL,DOREQ,DOWRK,I,J)=0
SET DOCHT=1
SET LOC=+LOC_";SC("
+4 NEW BBPKG
SET BBPKG=+$ORDER(^DIC(9.4,"B","VBECS",0))
+5 ; insert any blood bank child lab orders into ORDERS array
DO INSRTBB(.ORDERS)
+6 FOR
SET I=$ORDER(ORDERS(I))
IF 'I
QUIT
Begin DoDot:1
+7 SET ORDERID=$PIECE(ORDERS(I),U)
+8 IF $$HASFMTL
SET DOLBL=1
+9 IF $$HASFMTR
SET DOREQ=1
+10 IF $$HASFMTW
IF $$NOTBB(+ORDERS(I))
SET DOWRK=1
End DoDot:1
IF DOCHT&DOLBL&DOREQ&DOWRK
QUIT
+11 SET REC=$$DEFDEV
+12 QUIT
+13 ;
+14 ; PRIVATE CALLS
+15 ;
DEFDEV() ; returns string of prompt flags & default devices
+1 ; called from DEVINFO & MANUAL
+2 ; expects LOC,DOCHT,DOLBL,DOREQ,DOWRK to be defined
+3 ; optionally expects PRMTCHT, PRMTLBL, PRMTREQ, PRMTWRK
+4 NEW X
+5 IF DOCHT
Begin DoDot:1
+6 SET $PIECE(X,U,1)=$GET(PRMTCHT,1)
+7 SET $PIECE(X,U,5)=$TRANSLATE($$GET^XPAR("ALL^"_LOC,"ORPF CHART COPY PRINT DEVICE",1,"B"),U,";")
End DoDot:1
+8 IF '$TEST
SET $PIECE(X,U,1)="*"
+9 IF DOLBL
Begin DoDot:1
+10 SET $PIECE(X,U,2)=$GET(PRMTLBL,1)
+11 SET $PIECE(X,U,6)=$TRANSLATE($$GET^XPAR("ALL^"_LOC,"ORPF LABEL PRINT DEVICE",1,"B"),U,";")
End DoDot:1
+12 IF '$TEST
SET $PIECE(X,U,2)="*"
+13 IF DOREQ
Begin DoDot:1
+14 SET $PIECE(X,U,3)=$GET(PRMTREQ,1)
+15 SET $PIECE(X,U,7)=$TRANSLATE($$GET^XPAR("ALL^"_LOC,"ORPF REQUISITION PRINT DEVICE",1,"B"),U,";")
End DoDot:1
+16 IF '$TEST
SET $PIECE(X,U,3)="*"
+17 IF DOWRK
Begin DoDot:1
+18 SET $PIECE(X,U,4)=$GET(PRMTWRK,1)
+19 SET $PIECE(X,U,8)=$TRANSLATE($$GET^XPAR("ALL^"_LOC,"ORPF WORK COPY PRINT DEVICE",1,"B"),U,";")
End DoDot:1
+20 IF '$TEST
SET $PIECE(X,U,4)="*"
+21 QUIT X
HASFMTL() ; returns 1 if a label format is available
+1 ; called from DEVINFO & MANUAL, expects ORDERID & DOLBL to be defined
+2 ; already know we're doing at least 1 label
IF DOLBL=1
QUIT 1
+3 NEW PKG
SET PKG=+$PIECE($GET(^OR(100,+ORDERID,0)),U,14)
+4 QUIT ''$$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",PKG,"I")
+5 ;
HASFMTR() ; returns 1 if a requisition format is available
+1 ; called from DEVINFO & MANUAL, expects ORDERID & DOREQ to be defined
+2 ;I DOREQ=1 Q 1 ; already know we're doing at least 1 requisition
+3 NEW PKG,DLG
SET PKG=+$PIECE($GET(^OR(100,+ORDERID,0)),U,14)
SET DLG=+$PIECE($GET(^OR(100,+ORDERID,0)),U,5)
+4 ;no requisitions
IF PKG=$ORDER(^DIC(9.4,"B","DIETETICS",0))
IF DLG'=$ORDER(^ORD(101.41,"B","FHW SPECIAL MEAL",0))
QUIT 0
+5 ; already know we're doing at least 1 requisition
IF DOREQ=1
QUIT 1
+6 QUIT ''$$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",PKG,"I")
+7 ;
HASFMTW() ; returns 1 if a work copy format is available
+1 ; called from DEVINFO & MANUAL, expects ORDERID & DOWRK to be defined
+2 ; already know we're doing at least 1 work copy
IF DOWRK=1
QUIT 1
+3 ; not at pkg level
QUIT ''$$GET^XPAR("SYS","ORPF WORK COPY FORMAT",1,"I")
+4 ;
INSRTBB(ORDRLST) ; Insert child lab orders for any orders going to VBECS
+1 ; called from DEVINFO, MANUAL
+2 ; expects BBPKG to be defined
+3 IF 'BBPKG
QUIT
+4 NEW I,LABPKG,SUBID,CHILD,ACT,KIND
+5 SET LABPKG=+$ORDER(^DIC(9.4,"B","LAB SERVICE",0))
IF 'LABPKG
QUIT
+6 SET I=0
FOR
SET I=$ORDER(ORDRLST(I))
IF 'I
QUIT
IF $PIECE(ORDRLST(I),U,2)'["E"
Begin DoDot:1
+7 IF $PIECE($GET(^OR(100,+ORDRLST(I),0)),U,14)'=BBPKG
QUIT
+8 SET SUBID=.0001
+9 SET CHILD=0
FOR
SET CHILD=$ORDER(^OR(100,+ORDRLST(I),2,CHILD))
IF 'CHILD
QUIT
Begin DoDot:2
+10 IF $PIECE($GET(^OR(100,CHILD,0)),U,14)'=LABPKG
QUIT
+11 SET SUBID=SUBID+.0001
SET ACT=+$PIECE(^OR(100,CHILD,3),U,7)
SET KIND=$PIECE(ORDRLST(I),U,2)
+12 SET ORDRLST(I+SUBID)=CHILD_";"_ACT_U_KIND
End DoDot:2
+13 SET I=I+SUBID
End DoDot:1
+14 QUIT
NOTBB(CHILD) ; returns 1 if the order is not a blood bank child lab order
+1 ; called from DEVINFO, MANUAL
+2 ; expects BBPKG to be defined
+3 NEW PARENT
SET PARENT=$PIECE(^OR(100,CHILD,3),U,9)
+4 IF PARENT
IF $PIECE(^OR(100,PARENT,0),U,14)=BBPKG
QUIT 0
+5 QUIT 1
