- ORPR03 ; slc/dcm - While you were printing ; 07 Dec 99 01:43PM
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
- C1 ; Chart Copy Print
- N ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
- N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- U IO
- D PAT(+ORVP)
- S ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
- S ORHEAD=$$GET^XPAR("ALL","ORPF CHART COPY HEADER",1,"I")
- S ORFOOT=$$GET^XPAR("ALL","ORPF CHART COPY FOOTER",1,"I")
- S OROFMT=$$GET^XPAR("ALL","ORPF CHART COPY FORMAT",1,"I")
- S ORIOSL=IOSL
- I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
- I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
- S ORIOF=IOF,IOF="!!",ORFIRST1=1
- I OROFMT S ORFMT=OROFMT,ORCI=0 F S ORCI=$O(@ARAY@(ORCI)) Q:ORCI<1 S ORIFN=+@ARAY@(ORCI),OACTION=$P(@ARAY@(ORCI),";",2) D S ORFIRST1=0 Q:$G(OREND)
- . I '$L($G(^OR(100,ORIFN,0))) D EN^ORERR("CHARTCOPY PRINT WITH INVALID ORIFN:"_ORIFN) Q
- . D CHT1^ORPR04
- . I 'OACTION D EN^ORERR("NO ACTION DEFINED FOR CHARTCOPY PRINT ORIFN:"_ORIFN) Q
- . I '$D(^OR(100,ORIFN,8,OACTION)) D EN^ORERR("ACTION NODE ^(8) NOT SET FOR ORIFN:DA:"_ORIFN_":"_OACTION) Q
- . I '$D(ORRACT) S:'$P($G(^OR(100,ORIFN,8,OACTION,7)),"^") $P(^(7),"^",1,4)=1_"^"_$$NOW^XLFDT_"^"_DUZ_"^"_IO ;ORRACT is around if this is a reprint.
- I ORFOOT,'$G(OREND) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))="" D PRINT^ORPR00(ORFOOT,1)
- S IOF=ORIOF
- W @IOF
- I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
- Q
- W1 ;Work Copy Print
- N ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
- N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- U IO
- D PAT(+ORVP)
- S ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
- S ORHEAD=$$GET^XPAR("ALL","ORPF WORK COPY HEADER",1,"I")
- S ORFOOT=$$GET^XPAR("ALL","ORPF WORK COPY FOOTER",1,"I")
- S OROFMT=$$GET^XPAR("ALL","ORPF WORK COPY FORMAT",1,"I")
- S ORIOSL=IOSL
- I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
- I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
- S ORIOF=IOF,IOF="!!",ORFIRST1=1
- I OROFMT S ORFMT=OROFMT,ORCI=0 F S ORCI=$O(@ARAY@(ORCI)) Q:ORCI<1 D Q:$G(OREND)
- . S ORIFN=+@ARAY@(ORCI),OACTION=$P(@ARAY@(ORCI),";",2)
- . D WRK^ORPR08
- . S ORFIRST1=0
- I ORFOOT,'$G(OREND) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))="" D PRINT^ORPR00(ORFOOT,1)
- S IOF=ORIOF
- I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
- Q
- L1 ; Label Print
- N ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORPK,SORT,SORT1,ORCI,X3,SFIELD,ORFIRST1
- N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- U IO
- S ORTKG=0,ORIOF=IOF,ORIOSL=IOSL,ORFIRST1=1
- D PAT(+ORVP)
- F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG<1 I $$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",ORTKG,"I") S ORCI="" D
- . S SFIELD=$$GET^XPAR("SYS","ORPF LABEL SORT FIELD",ORTKG,"I")
- . K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
- . M ^TMP("ORBEFORE",$J)=@ARAY@(ORTKG)
- . D ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
- . S SORT=""
- . F S SORT=$O(^TMP("ORAFTER",$J,SORT)) Q:SORT="" D
- .. S SORT1=""
- .. F S SORT1=$O(^TMP("ORAFTER",$J,SORT,SORT1)) Q:SORT1="" D
- ... S ORCI=""
- ... F S ORCI=$O(^TMP("ORAFTER",$J,SORT,SORT1,ORCI)) Q:ORCI="" D Q:$G(OREND)
- .... S ORIFN=+ORCI,OACTION=$P(ORCI,";",2),X3=$P($G(^OR(100,ORIFN,3)),"^",3)
- .... I X3,X3'=11 D LBL1^ORPR01(1,$G(ORTIMES))
- I $D(ZTSK),'$G(TASK) D ^%ZISC,KILL^%ZTLOAD K ZTSK
- K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
- Q
- R1 ; Requisition Print
- N ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORTKG,ORXPND,ORPK,SORT,SORT1,ORGE,ORCI,X3,SFIELD,ORFIRST1
- N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- U IO
- S ORTKG=0,ORIOF=IOF,ORIOSL=IOSL
- D PAT(+ORVP)
- F S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG<1 I $$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORTKG,"I") S ORCI="",IOF=ORIOF D
- . S SFIELD=$$GET^XPAR("SYS","ORPF REQUISITION SORT FIELD",ORTKG,"I")
- . S ORHEAD=$$GET^XPAR("SYS","ORPF WARD REQUISITION HEADER",ORTKG,"I")
- . S ORFOOT=$$GET^XPAR("SYS","ORPF WARD REQUISITION FOOTER",ORTKG,"I")
- . K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
- . M ^TMP("ORBEFORE",$J)=@ARAY@(ORTKG)
- . D ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
- . S SORT="",ORGE=0 F S SORT=$O(^TMP("ORAFTER",$J,SORT)) Q:SORT="" D
- .. S ORGE=1 ;ORGE used to control form feeds and indicate screened transactions
- .. I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
- .. I +ORHEAD D PRINT^ORPR00(ORHEAD,1)
- .. S ORIOF=IOF,IOF="!!",ORFIRST1=1
- .. S SORT1="" F S SORT1=$O(^TMP("ORAFTER",$J,SORT,SORT1)) Q:SORT1="" D
- ... I 'ORGE W @ORIOF S ORGE=1 I +ORHEAD D PRINT^ORPR00(ORHEAD,1)
- ... S ORCI=""
- ... F S ORCI=$O(^TMP("ORAFTER",$J,SORT,SORT1,ORCI)) Q:ORCI="" D Q:$G(OREND)
- .... S ORFIRST1=0,ORGE=0,ORIFN=+ORCI,OACTION=$P(ORCI,";",2),X3=$P($G(^OR(100,ORIFN,3)),"^",3)
- .... I X3,X3'=11 D REQ1^ORPR01(1,"S ORGE=1")
- ... I ORFOOT,'$G(OREND) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))="" D PRINT^ORPR00(ORFOOT,1)
- ... S IOF=ORIOF
- .. I 'ORFOOT,'ORGE,$O(^TMP("ORAFTER",$J,SORT)) W @ORIOF
- I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
- S IOF=ORIOF
- K ^TMP("ORBEFORE",$J),^TMP("ORAFTER",$J)
- Q
- SVCOPY(ORDEFIO,SARAY) ; Print Service Copies
- ;SARAY(PKG,ORIFN)=Device ptr^# of copies (used by Consults service copies)
- N ORDEF,ORSCI,ORSCPY,ORIC,ORNM,ZTREQ
- I $D(ZTQUEUED) S ZTREQ="@"
- I $D(ARAY) F ORTKG=0:0 S ORTKG=$O(@ARAY@(ORTKG)) Q:ORTKG<1 S ORNM=$P($G(^DIC(9.4,ORTKG,0)),"^") D
- . I $D(SARAY(ORTKG))>9 S ORSCI=0 D
- .. F S ORSCI=$O(SARAY(ORTKG,ORSCI)) Q:ORSCI'>0 D
- ... N ARAY
- ... S ORDEF=$S($G(ORDEFIO):"",1:$P($G(SARAY(ORTKG,ORSCI)),U)),ARAY(ORTKG,ORSCI)=""
- ... S ORSCPY=$S(+$P($G(SARAY(ORTKG,ORSCI)),U,2):+$P($G(SARAY(ORTKG,ORSCI)),U,2),1:1)
- ... F ORIC=1:1:ORSCPY S X=$$DEVICE^ORPR02(+$G(ORDEFIO)_"^"_ORNM_" SERVICE COPIES",ORDEF,"S1^ORPR03")
- . Q:'$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
- . I $D(SARAY(ORTKG))'>9 D
- .. S X=$S($G(ORDEFIO):"",1:$$GET^XPAR(+LOC_";SC("_"^DIV^SYS","ORPF SERVICE COPY DEFLT DEVICE",ORTKG,"I"))
- .. I $L(X) S X=$$DEVICE^ORPR02("0^"_ORNM_" SERVICE COPIES",X,"S1^ORPR03") Q
- .. E I $G(ORDEFIO) S X=$$DEVICE^ORPR02("1^"_ORNM_" SERVICE COPIES",,"S1^ORPR03") Q
- Q
- S1 ; Service Copy Print Routine
- N ORIFN,OACTION,ORX,ORNUM,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORSNUM,ORFIRST1
- N ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- U IO
- D PAT(+ORVP)
- S OROFMT=$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
- S ORHEAD=$$GET^XPAR("SYS","ORPF SERVICE COPY HEADER",ORTKG,"I")
- S ORFOOT=$$GET^XPAR("SYS","ORPF SERVICE COPY FOOTER",ORTKG,"I")
- S ORIOSL=IOSL
- I ORFOOT,$D(^ORD(100.23,ORFOOT,0)) S ORBOT=$P(^(0),"^",2),ORIOSL=IOSL-ORBOT
- I ORHEAD D PRINT^ORPR00(ORHEAD,1,0,1)
- S ORIOF=IOF,IOF="!",ORFIRST1=1
- I OROFMT S ORFMT=OROFMT,ORCI="" F S ORCI=$O(@ARAY@(ORTKG,ORCI)) Q:ORCI="" S ORIFN=+ORCI,OACTION=$P(ORCI,";",2) D CHT1^ORPR04 S ORFIRST1=0 Q:$G(OREND)
- I ORFOOT,'$G(OREND) S:IOF?1"!"."!" $P(IOF,"!",$S(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:1))="" S:IOF="" IOF=ORIOF D PRINT^ORPR00(ORFOOT,1,0)
- S IOF=ORIOF
- I '$G(TASK) D ^%ZISC I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
- Q
- PAT(Y) ;Get patient variables
- ;Y=DFN or ORVP
- N VA,VA200,VAIN,VADM,VAROOT,VAERR,VAINDT
- Q:'$G(Y)
- S DFN=+Y,VA200=1
- D OERR^VADPT
- S ORPNM=VADM(1),ORSSN=VA("PID"),ORDOB=$P(VADM(3),"^",2),ORAGE=VADM(4),ORSEX=$P(VADM(5),"^"),ORTS=+VAIN(3),ORTS=$S($G(ORTS):ORTS,1:""),ORNP=+VAIN(2),ORWARD=VAIN(4),ORPV=""
- I '$D(ORL),$P(ORWARD,"^")?1N.N S ORL(1)=VAIN(5),(ORL,ORL(0),ORL(2))="",X=+ORWARD I $D(^DIC(42,+X,44)) S X=$P(^(44),"^") I X,$D(^SC(X,0)) S ORL=X_";SC(",ORL(0)=$S($L($P(^(0),"^",2)):$P(^(0),"^",2),1:$E($P(^(0),"^"),1,4)),ORL(2)=ORL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPR03 7825 printed Feb 18, 2025@23:59:10 Page 2
- ORPR03 ; slc/dcm - While you were printing ; 07 Dec 99 01:43PM
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69**;Dec 17, 1997
- C1 ; Chart Copy Print
- +1 NEW ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
- +2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- +3 USE IO
- +4 DO PAT(+ORVP)
- +5 SET ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
- +6 SET ORHEAD=$$GET^XPAR("ALL","ORPF CHART COPY HEADER",1,"I")
- +7 SET ORFOOT=$$GET^XPAR("ALL","ORPF CHART COPY FOOTER",1,"I")
- +8 SET OROFMT=$$GET^XPAR("ALL","ORPF CHART COPY FORMAT",1,"I")
- +9 SET ORIOSL=IOSL
- +10 IF ORFOOT
- IF $DATA(^ORD(100.23,ORFOOT,0))
- SET ORBOT=$PIECE(^(0),"^",2)
- SET ORIOSL=IOSL-ORBOT
- +11 IF ORHEAD
- DO PRINT^ORPR00(ORHEAD,1,0,1)
- +12 SET ORIOF=IOF
- SET IOF="!!"
- SET ORFIRST1=1
- +13 IF OROFMT
- SET ORFMT=OROFMT
- SET ORCI=0
- FOR
- SET ORCI=$ORDER(@ARAY@(ORCI))
- if ORCI<1
- QUIT
- SET ORIFN=+@ARAY@(ORCI)
- SET OACTION=$PIECE(@ARAY@(ORCI),";",2)
- Begin DoDot:1
- +14 IF '$LENGTH($GET(^OR(100,ORIFN,0)))
- DO EN^ORERR("CHARTCOPY PRINT WITH INVALID ORIFN:"_ORIFN)
- QUIT
- +15 DO CHT1^ORPR04
- +16 IF 'OACTION
- DO EN^ORERR("NO ACTION DEFINED FOR CHARTCOPY PRINT ORIFN:"_ORIFN)
- QUIT
- +17 IF '$DATA(^OR(100,ORIFN,8,OACTION))
- DO EN^ORERR("ACTION NODE ^(8) NOT SET FOR ORIFN:DA:"_ORIFN_":"_OACTION)
- QUIT
- +18 ;ORRACT is around if this is a reprint.
- IF '$DATA(ORRACT)
- if '$PIECE($GET(^OR(100,ORIFN,8,OACTION,7)),"^")
- SET $PIECE(^(7),"^",1,4)=1_"^"_$$NOW^XLFDT_"^"_DUZ_"^"_IO
- End DoDot:1
- SET ORFIRST1=0
- if $GET(OREND)
- QUIT
- +19 IF ORFOOT
- IF '$GET(OREND)
- if IOF?1"!"."!"
- SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))=""
- DO PRINT^ORPR00(ORFOOT,1)
- +20 SET IOF=ORIOF
- +21 WRITE @IOF
- +22 IF '$GET(TASK)
- DO ^%ZISC
- IF $DATA(ZTSK)
- DO KILL^%ZTLOAD
- KILL ZTSK
- +23 QUIT
- W1 ;Work Copy Print
- +1 NEW ORIFN,OACTION,ORX,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORFIRST1
- +2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- +3 USE IO
- +4 DO PAT(+ORVP)
- +5 SET ORXPND=$$GET^XPAR("ALL","ORPF EXPAND CONTINUOUS ORDERS",1,"I")
- +6 SET ORHEAD=$$GET^XPAR("ALL","ORPF WORK COPY HEADER",1,"I")
- +7 SET ORFOOT=$$GET^XPAR("ALL","ORPF WORK COPY FOOTER",1,"I")
- +8 SET OROFMT=$$GET^XPAR("ALL","ORPF WORK COPY FORMAT",1,"I")
- +9 SET ORIOSL=IOSL
- +10 IF ORFOOT
- IF $DATA(^ORD(100.23,ORFOOT,0))
- SET ORBOT=$PIECE(^(0),"^",2)
- SET ORIOSL=IOSL-ORBOT
- +11 IF ORHEAD
- DO PRINT^ORPR00(ORHEAD,1,0,1)
- +12 SET ORIOF=IOF
- SET IOF="!!"
- SET ORFIRST1=1
- +13 IF OROFMT
- SET ORFMT=OROFMT
- SET ORCI=0
- FOR
- SET ORCI=$ORDER(@ARAY@(ORCI))
- if ORCI<1
- QUIT
- Begin DoDot:1
- +14 SET ORIFN=+@ARAY@(ORCI)
- SET OACTION=$PIECE(@ARAY@(ORCI),";",2)
- +15 DO WRK^ORPR08
- +16 SET ORFIRST1=0
- End DoDot:1
- if $GET(OREND)
- QUIT
- +17 IF ORFOOT
- IF '$GET(OREND)
- if IOF?1"!"."!"
- SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))=""
- DO PRINT^ORPR00(ORFOOT,1)
- +18 SET IOF=ORIOF
- +19 IF '$GET(TASK)
- DO ^%ZISC
- IF $DATA(ZTSK)
- DO KILL^%ZTLOAD
- KILL ZTSK
- +20 QUIT
- L1 ; Label Print
- +1 NEW ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORXPND,ORPK,SORT,SORT1,ORCI,X3,SFIELD,ORFIRST1
- +2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- +3 USE IO
- +4 SET ORTKG=0
- SET ORIOF=IOF
- SET ORIOSL=IOSL
- SET ORFIRST1=1
- +5 DO PAT(+ORVP)
- +6 FOR
- SET ORTKG=$ORDER(@ARAY@(ORTKG))
- if ORTKG<1
- QUIT
- IF $$GET^XPAR("SYS","ORPF WARD LABEL FORMAT",ORTKG,"I")
- SET ORCI=""
- Begin DoDot:1
- +7 SET SFIELD=$$GET^XPAR("SYS","ORPF LABEL SORT FIELD",ORTKG,"I")
- +8 KILL ^TMP("ORBEFORE",$JOB),^TMP("ORAFTER",$JOB)
- +9 MERGE ^TMP("ORBEFORE",$JOB)=@ARAY@(ORTKG)
- +10 DO ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
- +11 SET SORT=""
- +12 FOR
- SET SORT=$ORDER(^TMP("ORAFTER",$JOB,SORT))
- if SORT=""
- QUIT
- Begin DoDot:2
- +13 SET SORT1=""
- +14 FOR
- SET SORT1=$ORDER(^TMP("ORAFTER",$JOB,SORT,SORT1))
- if SORT1=""
- QUIT
- Begin DoDot:3
- +15 SET ORCI=""
- +16 FOR
- SET ORCI=$ORDER(^TMP("ORAFTER",$JOB,SORT,SORT1,ORCI))
- if ORCI=""
- QUIT
- Begin DoDot:4
- +17 SET ORIFN=+ORCI
- SET OACTION=$PIECE(ORCI,";",2)
- SET X3=$PIECE($GET(^OR(100,ORIFN,3)),"^",3)
- +18 IF X3
- IF X3'=11
- DO LBL1^ORPR01(1,$GET(ORTIMES))
- End DoDot:4
- if $GET(OREND)
- QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 IF $DATA(ZTSK)
- IF '$GET(TASK)
- DO ^%ZISC
- DO KILL^%ZTLOAD
- KILL ZTSK
- +20 KILL ^TMP("ORBEFORE",$JOB),^TMP("ORAFTER",$JOB)
- +21 QUIT
- R1 ; Requisition Print
- +1 NEW ORIFN,OACTION,ORX,ORX5,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORTKG,ORXPND,ORPK,SORT,SORT1,ORGE,ORCI,X3,SFIELD,ORFIRST1
- +2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- +3 USE IO
- +4 SET ORTKG=0
- SET ORIOF=IOF
- SET ORIOSL=IOSL
- +5 DO PAT(+ORVP)
- +6 FOR
- SET ORTKG=$ORDER(@ARAY@(ORTKG))
- if ORTKG<1
- QUIT
- IF $$GET^XPAR("SYS","ORPF WARD REQUISITION FORMAT",ORTKG,"I")
- SET ORCI=""
- SET IOF=ORIOF
- Begin DoDot:1
- +7 SET SFIELD=$$GET^XPAR("SYS","ORPF REQUISITION SORT FIELD",ORTKG,"I")
- +8 SET ORHEAD=$$GET^XPAR("SYS","ORPF WARD REQUISITION HEADER",ORTKG,"I")
- +9 SET ORFOOT=$$GET^XPAR("SYS","ORPF WARD REQUISITION FOOTER",ORTKG,"I")
- +10 KILL ^TMP("ORBEFORE",$JOB),^TMP("ORAFTER",$JOB)
- +11 MERGE ^TMP("ORBEFORE",$JOB)=@ARAY@(ORTKG)
- +12 DO ARAY^ORPR06(ORVP,ORTKG,"START",SFIELD)
- +13 SET SORT=""
- SET ORGE=0
- FOR
- SET SORT=$ORDER(^TMP("ORAFTER",$JOB,SORT))
- if SORT=""
- QUIT
- Begin DoDot:2
- +14 ;ORGE used to control form feeds and indicate screened transactions
- SET ORGE=1
- +15 IF ORFOOT
- IF $DATA(^ORD(100.23,ORFOOT,0))
- SET ORBOT=$PIECE(^(0),"^",2)
- SET ORIOSL=IOSL-ORBOT
- +16 IF +ORHEAD
- DO PRINT^ORPR00(ORHEAD,1)
- +17 SET ORIOF=IOF
- SET IOF="!!"
- SET ORFIRST1=1
- +18 SET SORT1=""
- FOR
- SET SORT1=$ORDER(^TMP("ORAFTER",$JOB,SORT,SORT1))
- if SORT1=""
- QUIT
- Begin DoDot:3
- +19 IF 'ORGE
- WRITE @ORIOF
- SET ORGE=1
- IF +ORHEAD
- DO PRINT^ORPR00(ORHEAD,1)
- +20 SET ORCI=""
- +21 FOR
- SET ORCI=$ORDER(^TMP("ORAFTER",$JOB,SORT,SORT1,ORCI))
- if ORCI=""
- QUIT
- Begin DoDot:4
- +22 SET ORFIRST1=0
- SET ORGE=0
- SET ORIFN=+ORCI
- SET OACTION=$PIECE(ORCI,";",2)
- SET X3=$PIECE($GET(^OR(100,ORIFN,3)),"^",3)
- +23 IF X3
- IF X3'=11
- DO REQ1^ORPR01(1,"S ORGE=1")
- End DoDot:4
- if $GET(OREND)
- QUIT
- +24 IF ORFOOT
- IF '$GET(OREND)
- if IOF?1"!"."!"
- SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))=""
- DO PRINT^ORPR00(ORFOOT,1)
- +25 SET IOF=ORIOF
- End DoDot:3
- +26 IF 'ORFOOT
- IF 'ORGE
- IF $ORDER(^TMP("ORAFTER",$JOB,SORT))
- WRITE @ORIOF
- End DoDot:2
- End DoDot:1
- +27 IF '$GET(TASK)
- DO ^%ZISC
- IF $DATA(ZTSK)
- DO KILL^%ZTLOAD
- KILL ZTSK
- +28 SET IOF=ORIOF
- +29 KILL ^TMP("ORBEFORE",$JOB),^TMP("ORAFTER",$JOB)
- +30 QUIT
- SVCOPY(ORDEFIO,SARAY) ; Print Service Copies
- +1 ;SARAY(PKG,ORIFN)=Device ptr^# of copies (used by Consults service copies)
- +2 NEW ORDEF,ORSCI,ORSCPY,ORIC,ORNM,ZTREQ
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 IF $DATA(ARAY)
- FOR ORTKG=0:0
- SET ORTKG=$ORDER(@ARAY@(ORTKG))
- if ORTKG<1
- QUIT
- SET ORNM=$PIECE($GET(^DIC(9.4,ORTKG,0)),"^")
- Begin DoDot:1
- +5 IF $DATA(SARAY(ORTKG))>9
- SET ORSCI=0
- Begin DoDot:2
- +6 FOR
- SET ORSCI=$ORDER(SARAY(ORTKG,ORSCI))
- if ORSCI'>0
- QUIT
- Begin DoDot:3
- +7 NEW ARAY
- +8 SET ORDEF=$SELECT($GET(ORDEFIO):"",1:$PIECE($GET(SARAY(ORTKG,ORSCI)),U))
- SET ARAY(ORTKG,ORSCI)=""
- +9 SET ORSCPY=$SELECT(+$PIECE($GET(SARAY(ORTKG,ORSCI)),U,2):+$PIECE($GET(SARAY(ORTKG,ORSCI)),U,2),1:1)
- +10 FOR ORIC=1:1:ORSCPY
- SET X=$$DEVICE^ORPR02(+$GET(ORDEFIO)_"^"_ORNM_" SERVICE COPIES",ORDEF,"S1^ORPR03")
- End DoDot:3
- End DoDot:2
- +11 if '$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
- QUIT
- +12 IF $DATA(SARAY(ORTKG))'>9
- Begin DoDot:2
- +13 SET X=$SELECT($GET(ORDEFIO):"",1:$$GET^XPAR(+LOC_";SC("_"^DIV^SYS","ORPF SERVICE COPY DEFLT DEVICE",ORTKG,"I"))
- +14 IF $LENGTH(X)
- SET X=$$DEVICE^ORPR02("0^"_ORNM_" SERVICE COPIES",X,"S1^ORPR03")
- QUIT
- +15 IF '$TEST
- IF $GET(ORDEFIO)
- SET X=$$DEVICE^ORPR02("1^"_ORNM_" SERVICE COPIES",,"S1^ORPR03")
- QUIT
- End DoDot:2
- End DoDot:1
- +16 QUIT
- S1 ; Service Copy Print Routine
- +1 NEW ORIFN,OACTION,ORX,ORNUM,ORHEAD,ORFOOT,OROFMT,ORFMT,ORIOF,ORBOT,ORIOSL,ORSNUM,ORFIRST1
- +2 NEW ORAGE,ORDOB,ORL,ORNP,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD
- +3 USE IO
- +4 DO PAT(+ORVP)
- +5 SET OROFMT=$$GET^XPAR("SYS","ORPF SERVICE COPY FORMAT",ORTKG,"I")
- +6 SET ORHEAD=$$GET^XPAR("SYS","ORPF SERVICE COPY HEADER",ORTKG,"I")
- +7 SET ORFOOT=$$GET^XPAR("SYS","ORPF SERVICE COPY FOOTER",ORTKG,"I")
- +8 SET ORIOSL=IOSL
- +9 IF ORFOOT
- IF $DATA(^ORD(100.23,ORFOOT,0))
- SET ORBOT=$PIECE(^(0),"^",2)
- SET ORIOSL=IOSL-ORBOT
- +10 IF ORHEAD
- DO PRINT^ORPR00(ORHEAD,1,0,1)
- +11 SET ORIOF=IOF
- SET IOF="!"
- SET ORFIRST1=1
- +12 IF OROFMT
- SET ORFMT=OROFMT
- SET ORCI=""
- FOR
- SET ORCI=$ORDER(@ARAY@(ORTKG,ORCI))
- if ORCI=""
- QUIT
- SET ORIFN=+ORCI
- SET OACTION=$PIECE(ORCI,";",2)
- DO CHT1^ORPR04
- SET ORFIRST1=0
- if $GET(OREND)
- QUIT
- +13 IF ORFOOT
- IF '$GET(OREND)
- if IOF?1"!"."!"
- SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:1))=""
- if IOF=""
- SET IOF=ORIOF
- DO PRINT^ORPR00(ORFOOT,1,0)
- +14 SET IOF=ORIOF
- +15 IF '$GET(TASK)
- DO ^%ZISC
- IF $DATA(ZTSK)
- DO KILL^%ZTLOAD
- KILL ZTSK
- +16 QUIT
- PAT(Y) ;Get patient variables
- +1 ;Y=DFN or ORVP
- +2 NEW VA,VA200,VAIN,VADM,VAROOT,VAERR,VAINDT
- +3 if '$GET(Y)
- QUIT
- +4 SET DFN=+Y
- SET VA200=1
- +5 DO OERR^VADPT
- +6 SET ORPNM=VADM(1)
- SET ORSSN=VA("PID")
- SET ORDOB=$PIECE(VADM(3),"^",2)
- SET ORAGE=VADM(4)
- SET ORSEX=$PIECE(VADM(5),"^")
- SET ORTS=+VAIN(3)
- SET ORTS=$SELECT($GET(ORTS):ORTS,1:"")
- SET ORNP=+VAIN(2)
- SET ORWARD=VAIN(4)
- SET ORPV=""
- +7 IF '$DATA(ORL)
- IF $PIECE(ORWARD,"^")?1N.N
- SET ORL(1)=VAIN(5)
- SET (ORL,ORL(0),ORL(2))=""
- SET X=+ORWARD
- IF $DATA(^DIC(42,+X,44))
- SET X=$PIECE(^(44),"^")
- IF X
- IF $DATA(^SC(X,0))
- SET ORL=X_";SC("
- SET ORL(0)=$SELECT($LENGTH($PIECE(^(0),"^",2)):$PIECE(^(0),"^",2),1:$EXTRACT($PIECE(^(0),"^"),1,4))
- SET ORL(2)=ORL
- +8 QUIT