BMCFPRNC ; IHS/OIT/FCJ - PRINT REFERRAL CALL IN FORM ; [ 09/26/2006 4:18 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**2,4**;JAN 09, 2006;Build 101
;BMC*4.0*2 IHS/OIT/FCJ ADDED CONSULT PRINT TEST
;4.0*3 9.15.08 IHS.OIT.FCJ FX FOR UNDEF VAR WHEN QUEUED
;
PRINT ;Ref Form: Heading,pat demo, ref to, apt date, purpose, pert med
S BMCFTYP="CI"
D PRINT^BMCFUTL
Q:BMCQUIT
REFFROM ;
D REFFROM^BMCFUTL ;BMC*4.0*2 9/21/06 IHS/OIT/FCJ CALL TO WRONG UTL RTN
Q:BMCQUIT
TEXT ;
D TEXT^BMCFUTL
Q:BMCQUIT
LINE ;CHS No Sig
G:$P(BMCR0,U,4)'="C" ROUT
W !!!!!!
ROUT ;Prt Rt slp
I BMCPROUT=1 W # D PRINT^BMCFDRS
CONSULT ;PRNT CONSULT LETTER ;BMC*4.0*2 IHS/OIT/FCJ
I $G(BMCPCON)=1 W # D PRINT^BMCFDRP ;BMC*4.0*4 IHS/OIT/FCJ ADDED $G
Q
W ;
Q:X=""
NEW %
S %=$L(X)
I $Y>(IOSL-4) D HEAD Q:BMCQUIT
I N F I=1:1:N W !
I $G(C) W ?(IOM-$L(X)/2),X Q
S %=$S($G(T):T,1:0) W ?%,X
Q
C ; CHS REFERRAL
D C^BMCFUTL
Q
I ; IHS REFERRAL
D I^BMCFUTL
Q
N ; IN-HOUSE REFERRAL
D N^BMCFUTL
Q
O ; OTHER REFERRAL
D O^BMCFUTL
Q
L ;
S T=0,X=$TR($J(" ",IOM)," ","_"),N=1,C=0 D W Q:BMCQUIT
Q
D ;
S T=0,X=$TR($J(" ",IOM)," ","-"),N=1,C=0 D W Q:BMCQUIT
Q
S ;
S T=0,X=$TR($J(" ",IOM)," ","*"),N=1,C=0 D W Q:BMCQUIT
Q
WPTXT ;
; site-specific txt
D WPTXT^BMCFUTL
Q
WP ;
D WP^BMCFDR
Q
HEAD ;
NEW N,T,C,X,Y
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT=1 Q
HEAD1 ;
W:$D(IOF) @IOF
HEAD2 ;
I 'BMCPG S BMCPG=BMCPG+1 Q
S BMCPG=BMCPG+1 W:$D(IOF) @IOF W !,?(IOM-20),"Page ",BMCPG
Q
BMCFPRNC ; IHS/OIT/FCJ - PRINT REFERRAL CALL IN FORM ; [ 09/26/2006 4:18 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**2,4**;JAN 09, 2006;Build 101
+2 ;BMC*4.0*2 IHS/OIT/FCJ ADDED CONSULT PRINT TEST
+3 ;4.0*3 9.15.08 IHS.OIT.FCJ FX FOR UNDEF VAR WHEN QUEUED
+4 ;
PRINT ;Ref Form: Heading,pat demo, ref to, apt date, purpose, pert med
+1 SET BMCFTYP="CI"
+2 DO PRINT^BMCFUTL
+3 IF BMCQUIT
QUIT
REFFROM ;
+1 ;BMC*4.0*2 9/21/06 IHS/OIT/FCJ CALL TO WRONG UTL RTN
DO REFFROM^BMCFUTL
+2 IF BMCQUIT
QUIT
TEXT ;
+1 DO TEXT^BMCFUTL
+2 IF BMCQUIT
QUIT
LINE ;CHS No Sig
+1 IF $PIECE(BMCR0,U,4)'="C"
GOTO ROUT
+2 WRITE !!!!!!
ROUT ;Prt Rt slp
+1 IF BMCPROUT=1
WRITE #
DO PRINT^BMCFDRS
CONSULT ;PRNT CONSULT LETTER ;BMC*4.0*2 IHS/OIT/FCJ
+1 ;BMC*4.0*4 IHS/OIT/FCJ ADDED $G
IF $GET(BMCPCON)=1
WRITE #
DO PRINT^BMCFDRP
+2 QUIT
W ;
+1 IF X=""
QUIT
+2 NEW %
+3 SET %=$LENGTH(X)
+4 IF $Y>(IOSL-4)
DO HEAD
IF BMCQUIT
QUIT
+5 IF N
FOR I=1:1:N
WRITE !
+6 IF $GET(C)
WRITE ?(IOM-$LENGTH(X)/2),X
QUIT
+7 SET %=$SELECT($GET(T):T,1:0)
WRITE ?%,X
+8 QUIT
C ; CHS REFERRAL
+1 DO C^BMCFUTL
+2 QUIT
I ; IHS REFERRAL
+1 DO I^BMCFUTL
+2 QUIT
N ; IN-HOUSE REFERRAL
+1 DO N^BMCFUTL
+2 QUIT
O ; OTHER REFERRAL
+1 DO O^BMCFUTL
+2 QUIT
L ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","_")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 QUIT
D ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 QUIT
S ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","*")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 QUIT
WPTXT ;
+1 ; site-specific txt
+2 DO WPTXT^BMCFUTL
+3 QUIT
WP ;
+1 DO WP^BMCFDR
+2 QUIT
HEAD ;
+1 NEW N,T,C,X,Y
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BMCQUIT=1
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
HEAD2 ;
+1 IF 'BMCPG
SET BMCPG=BMCPG+1
QUIT
+2 SET BMCPG=BMCPG+1
IF $DATA(IOF)
WRITE @IOF
WRITE !,?(IOM-20),"Page ",BMCPG
+3 QUIT
