- 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
