- 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 Feb 18, 2025@23:59:12 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