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

ORWD2.m

Go to the documentation of this file. 
  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,286,477**;Dec 17, 1997;Build 8
  1.  ;
  1.  ; DBIA 10061 IN5^VADPT
  1.  ; PUBLIC CALLS
  1.  ;
  1. DEVINFO(LST,LOC,NATR,ORDERS)       ; Return device info when signing/releasing orders
  1.  ; Y(0)=Prompt Chart ^ Prompt Label ^ Prompt Requisition ^ Prompt Work
  1.  ;      ^ Chart Device ^ Label Device ^ Requisition Device ^ Work Device
  1.  ; for Prompt X: *=no print, 0=autoprint, 1=prompt&dev 2=prompt only 
  1.  ; Y(n)=ORIFN;ACT ^ Chart ^ Label ^ Requisition ^ Service ^ Work
  1.  ; LOC=location (ptr 44), NATR=nature of order (ptr 100.02)
  1.  ; ORDERS=ORIFN;ACT ^ R | S | E (released, signed, error)
  1.  N NATCHT,NATWRK,WHENCHT,PRMTCHT,PRMTLBL,PRMTREQ,PRMTWRK
  1.  N DOCHT,DOLBL,DOREQ,DOWRK,RELEASE,ORDERID,I,J,X
  1.  N NDCR,NODE,NPCC,NPWC
  1.  S (DOCHT,DOLBL,DOREQ,DOWRK,I,J)=0,LOC=+LOC_";SC("
  1.  S NATR=$O(^ORD(100.02,"C",NATR,0))
  1.  S NATCHT=+$P($G(^ORD(100.02,NATR,1)),U,2),NATWRK=+$P($G(^(1)),U,5)
  1.  S WHENCHT=$$GET^XPAR("ALL^"_LOC,"ORPF PRINT CHART COPY WHEN",1,"I")
  1.  I '$L(WHENCHT) S WHENCHT="R"
  1.  S PRMTCHT=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR CHART COPY",1,"I")
  1.  S PRMTLBL=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR LABELS",1,"I")
  1.  S PRMTREQ=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR REQUISITIONS",1,"I")
  1.  S PRMTWRK=$$GET^XPAR("ALL^"_LOC,"ORPF PROMPT FOR WORK COPY",1,"I")
  1.  N BBPKG S BBPKG=+$O(^DIC(9.4,"B","VBECS",0))
  1.  D INSRTBB(.ORDERS) ; insert any blood bank child lab orders into ORDERS array
  1.  F  S I=$O(ORDERS(I)) Q:'I  I $P(ORDERS(I),U,2)'["E" D
  1.  . S ORDERID=$P(ORDERS(I),U),RELEASE=($P(ORDERS(I),U,2)["R")
  1.  . S J=J+1,LST(J)=ORDERID_"^^^^"
  1.  . ;AGP this section check the order for DC Reason and grabs the print requirement
  1.  . ;from the Nature of Order file.
  1.  . S NPCC=1,NPWC=1
  1.  . S NDCR=$P($G(^OR(100,+ORDERID,6)),U) I NDCR>0 D
  1.  . .S NODE=$G(^ORD(100.02,NDCR,1))
  1.  . .S NPCC=+$P(NODE,U,2)
  1.  . .S NPWC=+$P(NODE,U,5)
  1.  . ; skip chart copy if nature doesn't print, no match to 'print when',
  1.  . ; prompt parameter says don't print, or is lab child of blood bank 
  1.  . I NPCC,NATCHT,($P(ORDERS(I),U,2)[WHENCHT),(PRMTCHT'="*"),$$HASFMTC,$$NOTBB(+ORDERS(I)) S $P(LST(J),U,2)=1,DOCHT=1
  1.  . ; skip label if not released, no label format, or prompt parameter
  1.  . ; says don't print
  1.  . I RELEASE,(PRMTLBL'="*"),$$HASFMTL S $P(LST(J),U,3)=1,DOLBL=1
  1.  . ; skip requisition if not released, no requistion format, or the
  1.  . ; prompt parameter says don't print
  1.  . I RELEASE,(PRMTREQ'="*"),$$HASFMTR S $P(LST(J),U,4)=1,DOREQ=1
  1.  . ; skip service copy if not releasing
  1.  . I RELEASE S $P(LST(J),U,5)=1
  1.  . ; skip work copy if nature doesn't print, not released, no work
  1.  . ; copy format, or prompt parameter says don't print
  1.  . I NPWC,NATWRK,RELEASE,(PRMTWRK'="*"),$$HASFMTW,$$NOTBB(+ORDERS(I)) S $P(LST(J),U,6)=1,DOWRK=1
  1.  S LST(0)=$$DEFDEV
  1.  Q
  1. MANUAL(REC,LOC,ORDERS)   ; return device info for manual prints
  1.  N DOCHT,DOLBL,DOREQ,DOWRK,ORDERID,I
  1.  N PRMTCHT,PRMTLBL,PRMTREQ,PRMTWRK  ; (so undefined for DEFDEV call)
  1.  S (DOCHT,DOLBL,DOREQ,DOWRK,I,J)=0,LOC=+LOC_";SC("
  1.  N BBPKG S BBPKG=+$O(^DIC(9.4,"B","VBECS",0))
  1.  D INSRTBB(.ORDERS) ; insert any blood bank child lab orders into ORDERS array
  1.  F  S I=$O(ORDERS(I)) Q:'I  D  Q:DOCHT&DOLBL&DOREQ&DOWRK
  1.  . S ORDERID=$P(ORDERS(I),U)
  1.  . I $$HASFMTC,$$NOTBB(+ORDERS(I)) S DOCHT=1
  1.  . I $$HASFMTL S DOLBL=1
  1.  . I $$HASFMTR S DOREQ=1
  1.  . I $$HASFMTW,$$NOTBB(+ORDERS(I)) S DOWRK=1
  1.  S REC=$$DEFDEV
  1.  Q
  1.  ;
  1.  ; PRIVATE CALLS
  1.  ;
  1. DEFDEV()        ; returns string of prompt flags & default devices
  1.  ; called from DEVINFO & MANUAL
  1.  ; expects LOC,DOCHT,DOLBL,DOREQ,DOWRK to be defined
  1.  ; optionally expects PRMTCHT, PRMTLBL, PRMTREQ, PRMTWRK
  1.  N X,DFN,VAIP,ROOMBED,PRINTDEV
  1.  S (PRINTDEV,ROOMBED)=""
  1.  I $G(ORDERID)]"" D
  1.  . S DFN=+$P(^OR(100,+ORDERID,0),"^",2)
  1.  . D IN5^VADPT
  1.  . S ROOMBED=$P($G(VAIP(6)),"^")
  1.  I DOCHT D
  1.  . S $P(X,U,1)=$G(PRMTCHT,1)
  1.  . S $P(X,U,5)=$TR($$GET^XPAR("ALL^"_LOC,"ORPF CHART COPY PRINT DEVICE",1,"B"),U,";")
  1.  . I ROOMBED]"" D
  1.  . . S PRINTDEV=$TR($$GET^XPAR("ALL^"_ROOMBED_";DG(405.4,","ORPF CHART COPY PRINT DEVICE",1,"B"),U,";")
  1.  . . I PRINTDEV]"" S $P(X,U,5)=PRINTDEV
  1.  E  S $P(X,U,1)="*"
  1.  I DOLBL D
  1.  . S $P(X,U,2)=$G(PRMTLBL,1)
  1.  . S $P(X,U,6)=$TR($$GET^XPAR("ALL^"_LOC,"ORPF LABEL PRINT DEVICE",1,"B"),U,";")
  1.  . I ROOMBED]"" D
  1.  . . S PRINTDEV=$TR($$GET^XPAR("ALL^"_ROOMBED_";DG(405.4,","ORPF LABEL PRINT DEVICE",1,"B"),U,";")
  1.  . . I PRINTDEV]"" S $P(X,U,6)=PRINTDEV
  1.  E  S $P(X,U,2)="*"
  1.  I DOREQ D
  1.  . S $P(X,U,3)=$G(PRMTREQ,1)
  1.  . S $P(X,U,7)=$TR($$GET^XPAR("ALL^"_LOC,"ORPF REQUISITION PRINT DEVICE",1,"B"),U,";")
  1.  . I ROOMBED]"" D
  1.  . . S PRINTDEV=$TR($$GET^XPAR("ALL^"_ROOMBED_";DG(405.4,","ORPF REQUISITION PRINT DEVICE",1,"B"),U,";")
  1.  . . I PRINTDEV]"" S $P(X,U,7)=PRINTDEV
  1.  E  S $P(X,U,3)="*"
  1.  I DOWRK D
  1.  . S $P(X,U,4)=$G(PRMTWRK,1)
  1.  . S $P(X,U,8)=$TR($$GET^XPAR("ALL^"_LOC,"ORPF WORK COPY PRINT DEVICE",1,"B"),U,";")
  1.  . I ROOMBED]"" D
  1.  . . S PRINTDEV=$TR($$GET^XPAR("ALL^"_ROOMBED_";DG(405.4,","ORPF WORK COPY PRINT DEVICE",1,"B"),U,";")
  1.  . . I PRINTDEV]"" S $P(X,U,8)=PRINTDEV
  1.  E  S $P(X,U,4)="*"
  1.  Q X
  1.  ;
  1. HASFMTC()       ; returns 1 if a chart copy format is available
  1.  ; called from DEVINFO & MANUAL, expects ORDERID & DOLBL to be defined
  1.  I DOCHT=1 Q 1  ; already know we're doing at least 1 label
  1.  Q ''$$GET^XPAR("SYS","ORPF CHART COPY FORMAT",1,"I")
  1.  ;
  1. HASFMTL()       ; returns 1 if a label format is available
  1.  ; called from DEVINFO & MANUAL, expects ORDERID & DOLBL to be defined
  1.  I DOLBL=1 Q 1  ; already know we're doing at least 1 label
  1.  N PKG S PKG=+$P($G(^OR(100,+ORDERID,0)),U,14)
  1.  Q ''$$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",PKG,"I")
  1.  ;
  1. HASFMTR()       ; returns 1 if a requisition format is available
  1.  ; called from DEVINFO & MANUAL, expects ORDERID & DOREQ to be defined
  1.  ;I DOREQ=1 Q 1  ; already know we're doing at least 1 requisition
  1.  N PKG,DLG S PKG=+$P($G(^OR(100,+ORDERID,0)),U,14),DLG=+$P($G(^OR(100,+ORDERID,0)),U,5)
  1.  I PKG=$O(^DIC(9.4,"B","DIETETICS",0)),DLG'=$O(^ORD(101.41,"B","FHW SPECIAL MEAL",0)) Q 0 ;no requisitions
  1.  I DOREQ=1 Q 1  ; already know we're doing at least 1 requisition
  1.  Q ''$$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",PKG,"I")
  1.  ;
  1. HASFMTW()       ; returns 1 if a work copy format is available
  1.  ; called from DEVINFO & MANUAL, expects ORDERID & DOWRK to be defined
  1.  I DOWRK=1 Q 1  ; already know we're doing at least 1 work copy
  1.  Q ''$$GET^XPAR("SYS","ORPF WORK COPY FORMAT",1,"I") ; not at pkg level
  1.  ;
  1. INSRTBB(ORDRLST) ; Insert child lab orders for any orders going to VBECS
  1.  ; called from DEVINFO, MANUAL
  1.  ; expects BBPKG to be defined
  1.  Q:'BBPKG
  1.  N I,LABPKG,SUBID,CHILD,ACT,KIND
  1.  S LABPKG=+$O(^DIC(9.4,"B","LAB SERVICE",0)) Q:'LABPKG
  1.  S I=0 F  S I=$O(ORDRLST(I)) Q:'I  I $P(ORDRLST(I),U,2)'["E" D
  1.  . I $P($G(^OR(100,+ORDRLST(I),0)),U,14)'=BBPKG Q
  1.  . S SUBID=.0001
  1.  . S CHILD=0 F  S CHILD=$O(^OR(100,+ORDRLST(I),2,CHILD)) Q:'CHILD  D
  1.  . . I $P($G(^OR(100,CHILD,0)),U,14)'=LABPKG Q
  1.  . . S SUBID=SUBID+.0001,ACT=+$P(^OR(100,CHILD,3),U,7),KIND=$P(ORDRLST(I),U,2)
  1.  . . S ORDRLST(I+SUBID)=CHILD_";"_ACT_U_KIND
  1.  . S I=I+SUBID
  1.  Q
  1. NOTBB(CHILD) ; returns 1 if the order is not a blood bank child lab order
  1.  ; called from DEVINFO, MANUAL
  1.  ; expects BBPKG to be defined
  1.  N PARENT S PARENT=$P(^OR(100,CHILD,3),U,9)
  1.  I PARENT,$P(^OR(100,PARENT,0),U,14)=BBPKG Q 0
  1.  Q 1