ORPR06 ; slc/dcm - Rent a Requisition ; 07 Dec 99 01:43PM
;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
REQ1 ;
I '$S($P($G(^OR(100,+ORIFN,3)),"^",3)'=11:1,1:0) Q
N ORTCNT,ORX,OR3,ORPK,ORPKG
D GET^ORPR01(ORIFN)
S ORPKG=$P(ORX,"^",14)
I $D(OROPKG),(OROPKG'=ORPKG) S ORSNUM=1 D FOOT^ORPR01(ORFOOT) W @ORIOF
D REQSET
I +ORFMT'>0,'+$G(OREND) W:$E(IOST)="C" $C(7),!!,"Requisition copy format is not defined for this package.",!! H 1 Q
Q:+$P(OR3,"^",9)>0!'$L(ORX)
D CPRINT^ORPR01(ORIFN)
Q
REQSET ;Setup
I $S('$G(ORPKG):1,ORPKG=$G(OROPKG):1,1:0) Q
S ORHEAD=$$GET^XPAR("SYS","ORPF WARD REQUISITION HEADER",ORPKG,"I")
S ORFOOT=$$GET^XPAR("SYS","ORPF WARD REQUISITION FOOTER",ORPKG,"I")
S (OROFMT,ORFMT)=$$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORPKG,"I")
S ORIOSL=IOSL
I +ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
S ORIOF=IOF
I +ORHEAD D PRINT^ORPR00(ORHEAD,1)
S IOF="!"
I +OROFMT S ORFMT=OROFMT
Q
REQCLN ;Cleanup
G:+$G(OREND) REQX
I +$G(ORFOOT) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))="" D PRINT^ORPR00(ORFOOT,1)
I $E(IOST)="C" D
. N DIR S DIR(0)="FO^1:1",DIR("A")="Press RETURN to continue or '^' to exit"
. D ^DIR I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) S OREND=1
REQX ;
S:$D(ORIOF) IOF=ORIOF
K ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL
Q
ARAY(ORVP,PKG,FIELD1,FIELD2) ;Sort by field in ^TMP("ORAFTER",$J,field,ORIFN;ACTION)
;This entry point takes an array of orders and sorts them by field
;PKG=ptr to package file
;FIELD1=Name of field for 1st sort (e.g. START DATE)
;FIELD2=Name of field for 2nd sort (e.g. SAMPLE)
;^TMP("ORBEFORE",$J)=Input array
;^TMP("ORAFTER",$J,FIELD1,FIELD2,ORIFN;ACTION)=Output array
Q:'$G(PKG) Q:'$G(ORVP)
N X,IFN,ACT,CIFN
S IFN=""
F S IFN=$O(^TMP("ORBEFORE",$J,IFN)) Q:IFN="" S ACT=$P(IFN,";",2) D
. I $O(^OR(100,+IFN,2,0)) S CIFN=0 D Q
.. F S CIFN=$O(^OR(100,+IFN,2,CIFN)) Q:CIFN<1 I $D(^OR(100,CIFN,0)) D SET(^(0),ACT)
. S X=$G(^OR(100,+IFN,0)) D SET(X,ACT)
Q
SET(X,ACT) ;
I $P(X,"^",2)'=ORVP K ^TMP("ORBEFORE",$J,IFN) Q
I +X,PKG=$P(X,"^",14) D
. N VAL1,VAL2
. S VAL1=$S($L($G(FIELD1)):$$VALUE^ORCSAVE2(+X,FIELD1),1:1)
. S:'$L(VAL1) VAL1=0
. I $G(FIELD1)="START",'VAL1 S VAL1=+$P($G(^OR(100,+IFN,0)),"^",8)
. S VAL2=$S($L($G(FIELD2)):$$VALUE^ORCSAVE2(+X,FIELD2),1:1)
. S:'$L(VAL2) VAL2=0
. S ^TMP("ORAFTER",$J,VAL1,VAL2,+X_$S(ACT:";"_ACT,1:""))=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPR06 2491 printed Sep 23, 2025@20:08:59 Page 2
ORPR06 ; slc/dcm - Rent a Requisition ; 07 Dec 99 01:43PM
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
REQ1 ;
+1 IF '$SELECT($PIECE($GET(^OR(100,+ORIFN,3)),"^",3)'=11:1,1:0)
QUIT
+2 NEW ORTCNT,ORX,OR3,ORPK,ORPKG
+3 DO GET^ORPR01(ORIFN)
+4 SET ORPKG=$PIECE(ORX,"^",14)
+5 IF $DATA(OROPKG)
IF (OROPKG'=ORPKG)
SET ORSNUM=1
DO FOOT^ORPR01(ORFOOT)
WRITE @ORIOF
+6 DO REQSET
+7 IF +ORFMT'>0
IF '+$GET(OREND)
if $EXTRACT(IOST)="C"
WRITE $CHAR(7),!!,"Requisition copy format is not defined for this package.",!!
HANG 1
QUIT
+8 if +$PIECE(OR3,"^",9)>0!'$LENGTH(ORX)
QUIT
+9 DO CPRINT^ORPR01(ORIFN)
+10 QUIT
REQSET ;Setup
+1 IF $SELECT('$GET(ORPKG):1,ORPKG=$GET(OROPKG):1,1:0)
QUIT
+2 SET ORHEAD=$$GET^XPAR("SYS","ORPF WARD REQUISITION HEADER",ORPKG,"I")
+3 SET ORFOOT=$$GET^XPAR("SYS","ORPF WARD REQUISITION FOOTER",ORPKG,"I")
+4 SET (OROFMT,ORFMT)=$$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORPKG,"I")
+5 SET ORIOSL=IOSL
+6 IF +ORFOOT
IF $DATA(^ORD(100.23,ORFOOT,0))
SET ORBOT=$PIECE(^(0),"^",2)
SET ORIOSL=IOSL-ORBOT
+7 SET ORIOF=IOF
+8 IF +ORHEAD
DO PRINT^ORPR00(ORHEAD,1)
+9 SET IOF="!"
+10 IF +OROFMT
SET ORFMT=OROFMT
+11 QUIT
REQCLN ;Cleanup
+1 if +$GET(OREND)
GOTO REQX
+2 IF +$GET(ORFOOT)
if IOF?1"!"."!"
SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))=""
DO PRINT^ORPR00(ORFOOT,1)
+3 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+4 NEW DIR
SET DIR(0)="FO^1:1"
SET DIR("A")="Press RETURN to continue or '^' to exit"
+5 DO ^DIR
IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
SET OREND=1
End DoDot:1
REQX ;
+1 if $DATA(ORIOF)
SET IOF=ORIOF
+2 KILL ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL
+3 QUIT
ARAY(ORVP,PKG,FIELD1,FIELD2) ;Sort by field in ^TMP("ORAFTER",$J,field,ORIFN;ACTION)
+1 ;This entry point takes an array of orders and sorts them by field
+2 ;PKG=ptr to package file
+3 ;FIELD1=Name of field for 1st sort (e.g. START DATE)
+4 ;FIELD2=Name of field for 2nd sort (e.g. SAMPLE)
+5 ;^TMP("ORBEFORE",$J)=Input array
+6 ;^TMP("ORAFTER",$J,FIELD1,FIELD2,ORIFN;ACTION)=Output array
+7 if '$GET(PKG)
QUIT
if '$GET(ORVP)
QUIT
+8 NEW X,IFN,ACT,CIFN
+9 SET IFN=""
+10 FOR
SET IFN=$ORDER(^TMP("ORBEFORE",$JOB,IFN))
if IFN=""
QUIT
SET ACT=$PIECE(IFN,";",2)
Begin DoDot:1
+11 IF $ORDER(^OR(100,+IFN,2,0))
SET CIFN=0
Begin DoDot:2
+12 FOR
SET CIFN=$ORDER(^OR(100,+IFN,2,CIFN))
if CIFN<1
QUIT
IF $DATA(^OR(100,CIFN,0))
DO SET(^(0),ACT)
End DoDot:2
QUIT
+13 SET X=$GET(^OR(100,+IFN,0))
DO SET(X,ACT)
End DoDot:1
+14 QUIT
SET(X,ACT) ;
+1 IF $PIECE(X,"^",2)'=ORVP
KILL ^TMP("ORBEFORE",$JOB,IFN)
QUIT
+2 IF +X
IF PKG=$PIECE(X,"^",14)
Begin DoDot:1
+3 NEW VAL1,VAL2
+4 SET VAL1=$SELECT($LENGTH($GET(FIELD1)):$$VALUE^ORCSAVE2(+X,FIELD1),1:1)
+5 if '$LENGTH(VAL1)
SET VAL1=0
+6 IF $GET(FIELD1)="START"
IF 'VAL1
SET VAL1=+$PIECE($GET(^OR(100,+IFN,0)),"^",8)
+7 SET VAL2=$SELECT($LENGTH($GET(FIELD2)):$$VALUE^ORCSAVE2(+X,FIELD2),1:1)
+8 if '$LENGTH(VAL2)
SET VAL2=0
+9 SET ^TMP("ORAFTER",$JOB,VAL1,VAL2,+X_$SELECT(ACT:";"_ACT,1:""))=""
End DoDot:1
+10 QUIT
