- ORPR05 ; slc/dcm - When you are in the Service copies... ; 07 Dec 99 01:43PM
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**69**;Dec 17, 1997
- SRV1 ;
- N ORTCNT,ORX,OR3,ORPK,ORTCNT,ORPKG,ORSNUM
- D GET^ORPR01(ORIFN)
- S ORPKG=$P(ORX,"^",14) I $D(OROPKG),(OROPKG'=ORPKG) S ORSNUM=1 D FOOT^ORPR01(ORFOOT) W @ORIOF
- D SRVSET
- I +ORFMT'>0,'+$G(OREND) W:$E(IOST)="C" $C(7),!!,"SERVICE COPY FORMAT is NOT defined for "_ORPKNM_".",!! H 1 Q
- Q:+$P(OR3,"^",9)>0
- D CPRINT^ORPR01(ORIFN)
- Q
- SCSORT ; Sorts selected orders by package
- N ORPKG,ORI,ORJ,ORIFN,ORSORT
- F ORI=1:1:$L(ORNMBR,",") S ORJ=$P(ORNMBR,",",ORI) I ORJ S ORIFN=$G(^XTMP(ORXTMP,ORJ)) I ORIFN]"" D
- . S ORPKG=$P($G(^OR(100,+ORIFN,0)),U,14),ORSORT(ORPKG,ORJ)=""
- I $O(ORSORT(0)) D
- . S ORPKG=0,ORNMBR="" F S ORPKG=$O(ORSORT(ORPKG)) Q:ORPKG'>0 D
- .. S ORI=0 F S ORI=$O(ORSORT(ORPKG,ORI)) Q:ORI'>0 D
- ... S ORNMBR=ORNMBR_ORI_","
- Q
- SRVSET ;Setup
- ;Input=PACKAGE
- ;Output=ORHEAD,ORFOOT
- I $S('$G(ORPKG):1,ORPKG=$G(OROPKG):1,1:0) Q
- S (OROFMT,ORFMT)=$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORPKG,"I")
- S ORHEAD=$$GET^XPAR("SYS","ORPF SERVICE COPY HEADER",ORPKG,"I")
- S ORFOOT=$$GET^XPAR("SYS","ORPF SERVICE COPY FOOTER",ORPKG,"I")
- S ORPKNM=$P($G(^DIC(9.4,+ORPKG,0)),U),ORIOSL=IOSL
- I +ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT,OROPKG=ORPKG
- S ORIOF=IOF I +ORHEAD D PRINT^ORPR00(ORHEAD,1)
- S IOF="!" I +OROFMT S ORFMT=OROFMT
- Q
- SRVCLN ;Cleanup
- G:+$G(OREND) SCCLEANX
- I $G(ORFOOT) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))="" D PRINT^ORPR00(ORFOOT,1)
- SCCLEANX S:$D(ORIOF) IOF=ORIOF K ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORPKG
- K OROPKG,ORPKNM,ORPKNO
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPR05 1710 printed Mar 13, 2025@21:37:39 Page 2
- ORPR05 ; slc/dcm - When you are in the Service copies... ; 07 Dec 99 01:43PM
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**69**;Dec 17, 1997
- SRV1 ;
- +1 NEW ORTCNT,ORX,OR3,ORPK,ORTCNT,ORPKG,ORSNUM
- +2 DO GET^ORPR01(ORIFN)
- +3 SET ORPKG=$PIECE(ORX,"^",14)
- IF $DATA(OROPKG)
- IF (OROPKG'=ORPKG)
- SET ORSNUM=1
- DO FOOT^ORPR01(ORFOOT)
- WRITE @ORIOF
- +4 DO SRVSET
- +5 IF +ORFMT'>0
- IF '+$GET(OREND)
- if $EXTRACT(IOST)="C"
- WRITE $CHAR(7),!!,"SERVICE COPY FORMAT is NOT defined for "_ORPKNM_".",!!
- HANG 1
- QUIT
- +6 if +$PIECE(OR3,"^",9)>0
- QUIT
- +7 DO CPRINT^ORPR01(ORIFN)
- +8 QUIT
- SCSORT ; Sorts selected orders by package
- +1 NEW ORPKG,ORI,ORJ,ORIFN,ORSORT
- +2 FOR ORI=1:1:$LENGTH(ORNMBR,",")
- SET ORJ=$PIECE(ORNMBR,",",ORI)
- IF ORJ
- SET ORIFN=$GET(^XTMP(ORXTMP,ORJ))
- IF ORIFN]""
- Begin DoDot:1
- +3 SET ORPKG=$PIECE($GET(^OR(100,+ORIFN,0)),U,14)
- SET ORSORT(ORPKG,ORJ)=""
- End DoDot:1
- +4 IF $ORDER(ORSORT(0))
- Begin DoDot:1
- +5 SET ORPKG=0
- SET ORNMBR=""
- FOR
- SET ORPKG=$ORDER(ORSORT(ORPKG))
- if ORPKG'>0
- QUIT
- Begin DoDot:2
- +6 SET ORI=0
- FOR
- SET ORI=$ORDER(ORSORT(ORPKG,ORI))
- if ORI'>0
- QUIT
- Begin DoDot:3
- +7 SET ORNMBR=ORNMBR_ORI_","
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +8 QUIT
- SRVSET ;Setup
- +1 ;Input=PACKAGE
- +2 ;Output=ORHEAD,ORFOOT
- +3 IF $SELECT('$GET(ORPKG):1,ORPKG=$GET(OROPKG):1,1:0)
- QUIT
- +4 SET (OROFMT,ORFMT)=$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORPKG,"I")
- +5 SET ORHEAD=$$GET^XPAR("SYS","ORPF SERVICE COPY HEADER",ORPKG,"I")
- +6 SET ORFOOT=$$GET^XPAR("SYS","ORPF SERVICE COPY FOOTER",ORPKG,"I")
- +7 SET ORPKNM=$PIECE($GET(^DIC(9.4,+ORPKG,0)),U)
- SET ORIOSL=IOSL
- +8 IF +ORFOOT
- IF $DATA(^ORD(100.23,ORFOOT,0))
- SET ORBOT=$PIECE(^(0),"^",2)
- SET ORIOSL=IOSL-ORBOT
- SET OROPKG=ORPKG
- +9 SET ORIOF=IOF
- IF +ORHEAD
- DO PRINT^ORPR00(ORHEAD,1)
- +10 SET IOF="!"
- IF +OROFMT
- SET ORFMT=OROFMT
- +11 QUIT
- SRVCLN ;Cleanup
- +1 if +$GET(OREND)
- GOTO SCCLEANX
- +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)
- SCCLEANX if $DATA(ORIOF)
- SET IOF=ORIOF
- KILL ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORPKG
- +1 KILL OROPKG,ORPKNM,ORPKNO
- +2 QUIT
