- BEHORXPS ;IHS/MSC/PLS - Prescription Print Support ;27-May-2010 07:04;PLS
- ;;1.1;BEH COMPONENTS;**009004**;Mar 20, 2007
- Q
- ; Called by BEHORXPS PSCRIPT
- ; Returns prescription text
- ; Input: ORIFN: IEN to Order File
- ; RXNUM: Prescription number (external)
- ; Output: Array of text
- PSCRIPT(DATA,ORIFN,RXNUM) ;EP
- N RX,RX1,ARAY,BEHOLOC,ORVP,CRXPR
- S DATA=$$TMPGBL^CIAVMRPC
- I '$G(ORIFN)!('$L(RXNUM)) S @DATA@(1)="Insufficient information to generate prescription printout!" Q
- S RX=$G(^OR(100,ORIFN,4))
- S RX1=$O(^PSRX("B",RXNUM,0))
- S ARAY(1)=ORIFN
- S BEHOLOC=+$P($G(^OR(100,ORIFN,0)),U,10)
- S CRXPR=$TR($$GET^XPAR("ALL","BEHORX SCRIPT CUSTOM FORMAT"),"~",U)
- I $L(CRXPR) D
- .D CAPTURE^CIAUHFS(CRXPR,DATA,80)
- E D
- .D CAPTURE^CIAUHFS("D GUI^BEHORXPS(.ARAY,BEHOLOC,""C"",1,1)",DATA,80)
- Q
- GUI(ARAY,DEVICE,FMT,LOC,TASK,ORTIMES) ;Silence of the Prints
- ;ARAY=Name of global storing list of orders or just the local aray
- ;@ARAY@(#)=ORIFN;DA of action - Array of orders to print
- ;DEVICE=printer (internal ptr value)
- ;FMT=C:Chart copy, L:Labels, R:Requisitions, S:Service copies W:Work copies
- ;LOC=Location (ORL)
- ;TASK=1 to not task, 0 or undefined to task (default)
- ; this affects the closing of devices in ^ORPR03
- ;ORTIMES=# of copies
- N ORPARAY,VAR
- S ORPARAY=$S($L($G(ARAY))&('$G(ARAY)):ARAY,1:"ARAY"),ARAY=ORPARAY
- Q:'$O(@ORPARAY@(0)) Q:'$D(IO) Q:'$D(FMT) Q:FMT="" Q:"CLRSW"'[FMT
- N ORAL,ORVP,X,ZTRTN
- K ^TMP("ORAL",$J)
- S ORVP=$$PAT^ORPR02(.ARAY),ORAL="^TMP(""ORAL"",$J)"
- I 'ORVP S VAR("ARAY")="" D EN^ORERR("GUI~ORPR02 called with invalid ORVP",,.VAR) Q
- I '$G(LOC) S LOC=$$LOC^ORPR02(.ARAY)
- D ARAY^ORPR02(.ARAY)
- I "WC"'[FMT K ARAY S ARAY=ORAL
- S X=0_"^"_$S(FMT="L":"Labels",FMT="R":"Requisitions",FMT="S":"Service Copies",FMT="C":"Chart Copies",FMT="W":"Work Copies",1:"")
- S ZTRTN="C1^BEHORXPS"
- D @ZTRTN
- Q
- 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
- ;S IOSL=56,IOM=80
- U IO
- D PAT^ORPR02(+ORVP)
- S ORHEAD=$$GET^XPAR("ALL","BEHORX SCRIPT HEADER",1,"I")
- S ORFOOT=$$GET^XPAR("ALL","BEHORX SCRIPT FOOTER",1,"I")
- S OROFMT=$$GET^XPAR("ALL","BEHORX SCRIPT 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
- S IOF="!!"
- S 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("PRESCRIPTION PRINT WITH INVALID ORIFN:"_ORIFN) Q
- . D CHT1^ORPR04
- . I 'OACTION D EN^ORERR("NO ACTION DEFINED FOR PRESCRIPTION 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) D
- .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
- Q
- BEHORXPS ;IHS/MSC/PLS - Prescription Print Support ;27-May-2010 07:04;PLS
- +1 ;;1.1;BEH COMPONENTS;**009004**;Mar 20, 2007
- +2 QUIT
- +3 ; Called by BEHORXPS PSCRIPT
- +4 ; Returns prescription text
- +5 ; Input: ORIFN: IEN to Order File
- +6 ; RXNUM: Prescription number (external)
- +7 ; Output: Array of text
- PSCRIPT(DATA,ORIFN,RXNUM) ;EP
- +1 NEW RX,RX1,ARAY,BEHOLOC,ORVP,CRXPR
- +2 SET DATA=$$TMPGBL^CIAVMRPC
- +3 IF '$GET(ORIFN)!('$LENGTH(RXNUM))
- SET @DATA@(1)="Insufficient information to generate prescription printout!"
- QUIT
- +4 SET RX=$GET(^OR(100,ORIFN,4))
- +5 SET RX1=$ORDER(^PSRX("B",RXNUM,0))
- +6 SET ARAY(1)=ORIFN
- +7 SET BEHOLOC=+$PIECE($GET(^OR(100,ORIFN,0)),U,10)
- +8 SET CRXPR=$TRANSLATE($$GET^XPAR("ALL","BEHORX SCRIPT CUSTOM FORMAT"),"~",U)
- +9 IF $LENGTH(CRXPR)
- Begin DoDot:1
- +10 DO CAPTURE^CIAUHFS(CRXPR,DATA,80)
- End DoDot:1
- +11 IF '$TEST
- Begin DoDot:1
- +12 DO CAPTURE^CIAUHFS("D GUI^BEHORXPS(.ARAY,BEHOLOC,""C"",1,1)",DATA,80)
- End DoDot:1
- +13 QUIT
- GUI(ARAY,DEVICE,FMT,LOC,TASK,ORTIMES) ;Silence of the Prints
- +1 ;ARAY=Name of global storing list of orders or just the local aray
- +2 ;@ARAY@(#)=ORIFN;DA of action - Array of orders to print
- +3 ;DEVICE=printer (internal ptr value)
- +4 ;FMT=C:Chart copy, L:Labels, R:Requisitions, S:Service copies W:Work copies
- +5 ;LOC=Location (ORL)
- +6 ;TASK=1 to not task, 0 or undefined to task (default)
- +7 ; this affects the closing of devices in ^ORPR03
- +8 ;ORTIMES=# of copies
- +9 NEW ORPARAY,VAR
- +10 SET ORPARAY=$SELECT($LENGTH($GET(ARAY))&('$GET(ARAY)):ARAY,1:"ARAY")
- SET ARAY=ORPARAY
- +11 IF '$ORDER(@ORPARAY@(0))
- QUIT
- IF '$DATA(IO)
- QUIT
- IF '$DATA(FMT)
- QUIT
- IF FMT=""
- QUIT
- IF "CLRSW"'[FMT
- QUIT
- +12 NEW ORAL,ORVP,X,ZTRTN
- +13 KILL ^TMP("ORAL",$JOB)
- +14 SET ORVP=$$PAT^ORPR02(.ARAY)
- SET ORAL="^TMP(""ORAL"",$J)"
- +15 IF 'ORVP
- SET VAR("ARAY")=""
- DO EN^ORERR("GUI~ORPR02 called with invalid ORVP",,.VAR)
- QUIT
- +16 IF '$GET(LOC)
- SET LOC=$$LOC^ORPR02(.ARAY)
- +17 DO ARAY^ORPR02(.ARAY)
- +18 IF "WC"'[FMT
- KILL ARAY
- SET ARAY=ORAL
- +19 SET X=0_"^"_$SELECT(FMT="L":"Labels",FMT="R":"Requisitions",FMT="S":"Service Copies",FMT="C":"Chart Copies",FMT="W":"Work Copies",1:"")
- +20 SET ZTRTN="C1^BEHORXPS"
- +21 DO @ZTRTN
- +22 QUIT
- 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 ;S IOSL=56,IOM=80
- +4 USE IO
- +5 DO PAT^ORPR02(+ORVP)
- +6 SET ORHEAD=$$GET^XPAR("ALL","BEHORX SCRIPT HEADER",1,"I")
- +7 SET ORFOOT=$$GET^XPAR("ALL","BEHORX SCRIPT FOOTER",1,"I")
- +8 SET OROFMT=$$GET^XPAR("ALL","BEHORX SCRIPT 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
- +13 SET IOF="!!"
- +14 SET ORFIRST1=1
- +15 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
- +16 IF '$LENGTH($GET(^OR(100,ORIFN,0)))
- DO EN^ORERR("PRESCRIPTION PRINT WITH INVALID ORIFN:"_ORIFN)
- QUIT
- +17 DO CHT1^ORPR04
- +18 IF 'OACTION
- DO EN^ORERR("NO ACTION DEFINED FOR PRESCRIPTION PRINT ORIFN:"_ORIFN)
- QUIT
- +19 IF '$DATA(^OR(100,ORIFN,8,OACTION))
- DO EN^ORERR("ACTION NODE ^(8) NOT SET FOR ORIFN:DA:"_ORIFN_":"_OACTION)
- QUIT
- +20 ;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
- +21 IF ORFOOT
- IF '$GET(OREND)
- Begin DoDot:1
- +22 IF IOF?1"!"."!"
- SET $PIECE(IOF,"!",$SELECT(ORIOSL>200:200,ORIOSL-$Y>1:ORIOSL-$Y,1:2))=""
- +23 DO PRINT^ORPR00(ORFOOT,1)
- End DoDot:1
- +24 SET IOF=ORIOF
- +25 WRITE @IOF
- +26 QUIT
