BMCFPRNA ; IHS/PHXAO/TMJ - PRINT ALT RESOURCE LETTER ; [ 09/27/2006 2:01 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1,4**;JAN 09, 2006;Build 101
;4.0*1 2.15.06 IHS/OIT/FCJ ADDED TEST TO PRNT FRM SITE PARM
;4.0*4 9.12.08 IHS/OIT/FCJ ADDED SIR NAME TO PRINT
;
PRINT ;
;print referral form
S BMCR0=^BMCREF(BMCREF,0),BMCPG=0,BMCDFN=$P(BMCR0,U,3)
D @("HEAD"_(2-($E(IOST,1,2)="C-")))
S BMCQUIT=0
W !!,?50,"PUBLIC HEALTH SERVICE",!,?50,"PHS INDIAN HEALTH SERVICE"
W !!!!!!!
S Y=DT D DD^%DT W Y
I BMCLTYP="M" S X="Mail Certified #: "_$$VAL^XBDIQ1(90001,BMCREF,1403),C=0,T=0,N=1 D W Q:BMCQUIT
W !
DEMO ;Demographic Data
;Age - If under 19 Print "To Parents of"
S BMCAGE=$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.033)
W:BMCAGE<20 !,"**TO THE PARENTS OF "_$$VAL^XBDIQ1(90001,BMCREF,.03),":",!
S X=$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,T=0,N=1 D W Q:BMCQUIT
;BMC*4.0*4 IHS/OIT/FCJ ADDED SIR TO NEXT 2 LINES
S BMCFIRST=$P(X,",",2),BMCLAST=$P(X,",",1),BMCSIR=$P(X,",",3)
S X=BMCFIRST_" "_BMCLAST_" "_BMCSIR,C=0,T=0,N=1 D W Q:BMCQUIT
S:$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1602.2)]"" X=$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1602.2) S C=0,T=0,N=1 D W Q:BMCQUIT
S T=0,C=0,N=1,X=$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1603.2)_", "_$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1604.2)_" "_$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1605.2) D W Q:BMCQUIT
;
REFTO ;
W !
D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
DATE ;
S X=$S($P(BMCR0,U,14)="I":" Admit Date",1:"Service Date")_": "_$$AVDOS^BMCRLU(BMCREF,"E"),N=1,C=0,T=26 D W Q:BMCQUIT
S X=" #"_$$VAL^XBDIQ1(90001,BMCREF,.02)_" "_$P($G(^BMCREF(BMCREF,1)),U),N=0,C=0,T=30 D W Q:BMCQUIT
;
PURPOSE ;Comment Out Per Rebecca Hicks 1/11/01
S X="Services: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
I $L(X)>IOM D I 1
.S BMCX=X S X=$E(BMCX,1,IOM),N=1,C=0,T=30 D W Q:BMCQUIT
.S X=$E(BMCX,(IOM+1),IOM),N=1,C=0,T=22 D W Q:BMCQUIT
E S C=0,N=1,T=30 D W Q:BMCQUIT
;
AMOUNT ;Estimated Amount of Service
W !
S X=$$AVICOST^BMCRLU(BMCREF),X2="2$" D COMMA^%DTC S X=" Est. Amount: "_X,N=0,C=0,T=26 D W Q:BMCQUIT
;
W !,"Dear Patient:"
TEXT ;
W !
K BMCWP
S BMCPHONE=$P($G(^BMCPARM(DUZ(2),0)),U,18) ;Contact Phone #
S BMCNODE=1,BMCFILE=90001.33,BMCDA=BMCFTYPE D WP^BMCFDRA
;
S BMCY=0 F S BMCY=$O(BMCWP(BMCY)) Q:BMCY'=+BMCY!(BMCQUIT) D
.I $Y>(IOSL-3) D HEAD Q:BMCQUIT
.W !,BMCWP(BMCY)
;
LINE ;CHS Supervisor Signature (if Type=CHS)
W !!,"___A. You must contact "_BMCCPRVP_" to schedule an appointment",!
;
W "to complete an application. It is very important that you keep your scheduled",!,"appointment.",!
W !,"___B. You will need to bring the following documentation with you to your",!,"appointment: ",!
;
DOC ;Appointment Documentation Code
;
I '$D(^BMCREF(BMCREF,15)) G TEXT2
S BMCNODE=15,BMCIOM=70,BMCFILE=90001,BMCDA=BMCREF D WP^BMCFDRA K BMCIOM
S Y=0 F S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT) D
.I $Y>(IOSL-3) D HEAD Q:BMCQUIT
.W !?5,BMCWP(Y)
W !
TEXT2 ;
;Determine which text to print - CHS or PBC
S BMCTEXT=""
S BMCTEXT=$P($G(^BMCPARM(DUZ(2),0)),U,29) ;Is there a Benefits Coordinator
K BMCWP
S BMCNODE=$S(BMCTEXT'="":3,1:2),BMCFILE=90001.33,BMCDA=BMCFTYPE D WP^BMCFDRA
S BMCY=0 F S BMCY=$O(BMCWP(BMCY)) Q:BMCY'=+BMCY!(BMCQUIT) D
. I $Y>(IOSL-3) D HEAD Q:BMCQUIT
. W !,BMCWP(BMCY)
W BMCPHONE W ".",!
W !,?50,"Sincerely,"
W !!!!
W ?50,$S(BMCTEXT'="":$$VAL^XBDIQ1(90001.31,DUZ(2),.29),1:$P($G(^BMCPARM(DUZ(2),0)),U,28))
W !!
W "cc: file",!
S X="______________________________",C=0,T=50,N=1 D W Q:BMCQUIT
S X="PATIENT SIGNATURE DATE",C=0,T=50,N=1 D W Q:BMCQUIT
STUFF ;Stuff Date of Print/User
S DR=""
S DIE="^BMCREF(" S DA=BMCREF,DR="1401///"_DT D ^DIE K DIE,DR,DA,DIC
;
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 ;
S BMCV=$P(BMCR0,U,7)
Q:'BMCV
S X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$S($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:"") S N=1,C=0,T=30 D W Q:BMCQUIT
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=42 D W Q:BMCQUIT
I $$VAL^XBDIQ1(9999999.11,BMCV,1301)]"" S X=$$VAL^XBDIQ1(9999999.11,BMCV,1301)_$S($$VAL^XBDIQ1(9999999.11,BMCV,1310)]"":", "_$$VAL^XBDIQ1(9999999.11,BMCV,1310),1:"") S N=1,C=0,T=42 D W Q:BMCQUIT
I $$VAL^XBDIQ1(9999999.11,BMCV,1302)]"" S X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(9999999.11,BMCV,1303)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304),N=1,C=0,T=42 D W Q:BMCQUIT
Q
I ;
S BMCV=$P(BMCR0,U,8)
Q:'BMCV
S X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.08)_$S($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":" ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"") S N=1,C=0,T=30 D W Q:BMCQUIT
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=19 D W Q:BMCQUIT
;4.0*1 2.15.06 IHS/OIT/FCJ ADDED TEST TO PRNT FRM SITE PARM
I $$VAL^XBDIQ1(90001.31,BMCV,201)]"" D
.S X=$$VAL^XBDIQ1(90001.31,BMCV,201) S N=1,C=0,T=19 D W Q:BMCQUIT
.I $$VAL^XBDIQ1(90001.31,BMCV,202)]"" S X=$$VAL^XBDIQ1(90001.31,BMCV,202)_", "_$$VAL^XBDIQ1(90001.31,BMCV,203)_" "_$$VAL^XBDIQ1(90001.31,BMCV,204),N=1,C=0,T=19 D W Q:BMCQUIT
E D
.I $$VAL^XBDIQ1(9999999.06,BMCV,.14)]"" S X=$$VAL^XBDIQ1(9999999.06,BMCV,.14) S N=1,C=0,T=19 D W Q:BMCQUIT
.I $$VAL^XBDIQ1(9999999.06,BMCV,.15)]"" S X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17),N=1,C=0,T=19 D W Q:BMCQUIT
Q
N ;
S X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic",N=1,C=0,T=30 D W Q:BMCQUIT
Q
O ;
S BMCV=$P(BMCR0,U,7)
I BMCV D I 1
.S X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$S($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:"") S N=1,C=0,T=30 D W Q:BMCQUIT
.I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=19 D W Q:BMCQUIT
.I $$VAL^XBDIQ1(9999999.11,BMCV,1301)]"" S X=$$VAL^XBDIQ1(9999999.11,BMCV,1301)_$S($$VAL^XBDIQ1(9999999.11,BMCV,1310)]"":", "_$$VAL^XBDIQ1(9999999.11,BMCV,1310),1:"") S N=1,C=0,T=19 D W Q:BMCQUIT
.I $$VAL^XBDIQ1(9999999.11,BMCV,1302)]"" S X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(9999999.11,BMCV,1303)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304),N=1,C=0,T=19 D W Q:BMCQUIT
E S X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.09),N=1,C=0,T=30 D W Q:BMCQUIT
Q
L ;
S T=0,X=$TR($J(" ",IOM)," ","_") S N=1,C=0 D W Q:BMCQUIT
Q
D ;
S T=0,X=$TR($J(" ",IOM)," ","-") S N=1,C=0 D W Q:BMCQUIT
Q
S ;
S T=0,X=$TR($J(" ",IOM)," ","*") S N=1,C=0 D W Q:BMCQUIT
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
BMCFPRNA ; IHS/PHXAO/TMJ - PRINT ALT RESOURCE LETTER ; [ 09/27/2006 2:01 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1,4**;JAN 09, 2006;Build 101
+2 ;4.0*1 2.15.06 IHS/OIT/FCJ ADDED TEST TO PRNT FRM SITE PARM
+3 ;4.0*4 9.12.08 IHS/OIT/FCJ ADDED SIR NAME TO PRINT
+4 ;
PRINT ;
+1 ;print referral form
+2 SET BMCR0=^BMCREF(BMCREF,0)
SET BMCPG=0
SET BMCDFN=$PIECE(BMCR0,U,3)
+3 DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+4 SET BMCQUIT=0
+5 WRITE !!,?50,"PUBLIC HEALTH SERVICE",!,?50,"PHS INDIAN HEALTH SERVICE"
+6 WRITE !!!!!!!
+7 SET Y=DT
DO DD^%DT
WRITE Y
+8 IF BMCLTYP="M"
SET X="Mail Certified #: "_$$VAL^XBDIQ1(90001,BMCREF,1403)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+9 WRITE !
DEMO ;Demographic Data
+1 ;Age - If under 19 Print "To Parents of"
+2 SET BMCAGE=$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.033)
+3 IF BMCAGE<20
WRITE !,"**TO THE PARENTS OF "_$$VAL^XBDIQ1(90001,BMCREF,.03),":",!
+4 SET X=$$VAL^XBDIQ1(90001,BMCREF,.03)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+5 ;BMC*4.0*4 IHS/OIT/FCJ ADDED SIR TO NEXT 2 LINES
+6 SET BMCFIRST=$PIECE(X,",",2)
SET BMCLAST=$PIECE(X,",",1)
SET BMCSIR=$PIECE(X,",",3)
+7 SET X=BMCFIRST_" "_BMCLAST_" "_BMCSIR
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+8 IF $$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1602.2)]""
SET X=$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1602.2)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+9 SET T=0
SET C=0
SET N=1
SET X=$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1603.2)_", "_$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1604.2)_" "_$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1605.2)
DO W
IF BMCQUIT
QUIT
+10 ;
REFTO ;
+1 WRITE !
+2 DO @$$VALI^XBDIQ1(90001,BMCREF,.04)
IF BMCQUIT
QUIT
DATE ;
+1 SET X=$SELECT($PIECE(BMCR0,U,14)="I":" Admit Date",1:"Service Date")_": "_$$AVDOS^BMCRLU(BMCREF,"E")
SET N=1
SET C=0
SET T=26
DO W
IF BMCQUIT
QUIT
+2 SET X=" #"_$$VAL^XBDIQ1(90001,BMCREF,.02)_" "_$PIECE($GET(^BMCREF(BMCREF,1)),U)
SET N=0
SET C=0
SET T=30
DO W
IF BMCQUIT
QUIT
+3 ;
PURPOSE ;Comment Out Per Rebecca Hicks 1/11/01
+1 SET X="Services: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
+2 IF $LENGTH(X)>IOM
Begin DoDot:1
+3 SET BMCX=X
SET X=$EXTRACT(BMCX,1,IOM)
SET N=1
SET C=0
SET T=30
DO W
IF BMCQUIT
QUIT
+4 SET X=$EXTRACT(BMCX,(IOM+1),IOM)
SET N=1
SET C=0
SET T=22
DO W
IF BMCQUIT
QUIT
End DoDot:1
IF 1
+5 IF '$TEST
SET C=0
SET N=1
SET T=30
DO W
IF BMCQUIT
QUIT
+6 ;
AMOUNT ;Estimated Amount of Service
+1 WRITE !
+2 SET X=$$AVICOST^BMCRLU(BMCREF)
SET X2="2$"
DO COMMA^%DTC
SET X=" Est. Amount: "_X
SET N=0
SET C=0
SET T=26
DO W
IF BMCQUIT
QUIT
+3 ;
+4 WRITE !,"Dear Patient:"
TEXT ;
+1 WRITE !
+2 KILL BMCWP
+3 ;Contact Phone #
SET BMCPHONE=$PIECE($GET(^BMCPARM(DUZ(2),0)),U,18)
+4 SET BMCNODE=1
SET BMCFILE=90001.33
SET BMCDA=BMCFTYPE
DO WP^BMCFDRA
+5 ;
+6 SET BMCY=0
FOR
SET BMCY=$ORDER(BMCWP(BMCY))
IF BMCY'=+BMCY!(BMCQUIT)
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+8 WRITE !,BMCWP(BMCY)
End DoDot:1
+9 ;
LINE ;CHS Supervisor Signature (if Type=CHS)
+1 WRITE !!,"___A. You must contact "_BMCCPRVP_" to schedule an appointment",!
+2 ;
+3 WRITE "to complete an application. It is very important that you keep your scheduled",!,"appointment.",!
+4 WRITE !,"___B. You will need to bring the following documentation with you to your",!,"appointment: ",!
+5 ;
DOC ;Appointment Documentation Code
+1 ;
+2 IF '$DATA(^BMCREF(BMCREF,15))
GOTO TEXT2
+3 SET BMCNODE=15
SET BMCIOM=70
SET BMCFILE=90001
SET BMCDA=BMCREF
DO WP^BMCFDRA
KILL BMCIOM
+4 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+6 WRITE !?5,BMCWP(Y)
End DoDot:1
+7 WRITE !
TEXT2 ;
+1 ;Determine which text to print - CHS or PBC
+2 SET BMCTEXT=""
+3 ;Is there a Benefits Coordinator
SET BMCTEXT=$PIECE($GET(^BMCPARM(DUZ(2),0)),U,29)
+4 KILL BMCWP
+5 SET BMCNODE=$SELECT(BMCTEXT'="":3,1:2)
SET BMCFILE=90001.33
SET BMCDA=BMCFTYPE
DO WP^BMCFDRA
+6 SET BMCY=0
FOR
SET BMCY=$ORDER(BMCWP(BMCY))
IF BMCY'=+BMCY!(BMCQUIT)
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+8 WRITE !,BMCWP(BMCY)
End DoDot:1
+9 WRITE BMCPHONE
WRITE ".",!
+10 WRITE !,?50,"Sincerely,"
+11 WRITE !!!!
+12 WRITE ?50,$SELECT(BMCTEXT'="":$$VAL^XBDIQ1(90001.31,DUZ(2),.29),1:$PIECE($GET(^BMCPARM(DUZ(2),0)),U,28))
+13 WRITE !!
+14 WRITE "cc: file",!
+15 SET X="______________________________"
SET C=0
SET T=50
SET N=1
DO W
IF BMCQUIT
QUIT
+16 SET X="PATIENT SIGNATURE DATE"
SET C=0
SET T=50
SET N=1
DO W
IF BMCQUIT
QUIT
STUFF ;Stuff Date of Print/User
+1 SET DR=""
+2 SET DIE="^BMCREF("
SET DA=BMCREF
SET DR="1401///"_DT
DO ^DIE
KILL DIE,DR,DA,DIC
+3 ;
+4 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 ;
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF 'BMCV
QUIT
+3 SET X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:"")
SET N=1
SET C=0
SET T=30
DO W
IF BMCQUIT
QUIT
+4 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=42
DO W
IF BMCQUIT
QUIT
+5 IF $$VAL^XBDIQ1(9999999.11,BMCV,1301)]""
SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1301)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1310)]"":", "_$$VAL^XBDIQ1(9999999.11,BMCV,1310),1:"")
SET N=1
SET C=0
SET T=42
DO W
IF BMCQUIT
QUIT
+6 IF $$VAL^XBDIQ1(9999999.11,BMCV,1302)]""
SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(9999999.11,BMCV,1303)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
SET N=1
SET C=0
SET T=42
DO W
IF BMCQUIT
QUIT
+7 QUIT
I ;
+1 SET BMCV=$PIECE(BMCR0,U,8)
+2 IF 'BMCV
QUIT
+3 SET X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.08)_$SELECT($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":" ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"")
SET N=1
SET C=0
SET T=30
DO W
IF BMCQUIT
QUIT
+4 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=19
DO W
IF BMCQUIT
QUIT
+5 ;4.0*1 2.15.06 IHS/OIT/FCJ ADDED TEST TO PRNT FRM SITE PARM
+6 IF $$VAL^XBDIQ1(90001.31,BMCV,201)]""
Begin DoDot:1
+7 SET X=$$VAL^XBDIQ1(90001.31,BMCV,201)
SET N=1
SET C=0
SET T=19
DO W
IF BMCQUIT
QUIT
+8 IF $$VAL^XBDIQ1(90001.31,BMCV,202)]""
SET X=$$VAL^XBDIQ1(90001.31,BMCV,202)_", "_$$VAL^XBDIQ1(90001.31,BMCV,203)_" "_$$VAL^XBDIQ1(90001.31,BMCV,204)
SET N=1
SET C=0
SET T=19
DO W
IF BMCQUIT
QUIT
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 IF $$VAL^XBDIQ1(9999999.06,BMCV,.14)]""
SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
SET N=1
SET C=0
SET T=19
DO W
IF BMCQUIT
QUIT
+11 IF $$VAL^XBDIQ1(9999999.06,BMCV,.15)]""
SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)
SET N=1
SET C=0
SET T=19
DO W
IF BMCQUIT
QUIT
End DoDot:1
+12 QUIT
N ;
+1 SET X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic"
SET N=1
SET C=0
SET T=30
DO W
IF BMCQUIT
QUIT
+2 QUIT
O ;
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF BMCV
Begin DoDot:1
+3 SET X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:"")
SET N=1
SET C=0
SET T=30
DO W
IF BMCQUIT
QUIT
+4 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=19
DO W
IF BMCQUIT
QUIT
+5 IF $$VAL^XBDIQ1(9999999.11,BMCV,1301)]""
SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1301)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1310)]"":", "_$$VAL^XBDIQ1(9999999.11,BMCV,1310),1:"")
SET N=1
SET C=0
SET T=19
DO W
IF BMCQUIT
QUIT
+6 IF $$VAL^XBDIQ1(9999999.11,BMCV,1302)]""
SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(9999999.11,BMCV,1303)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
SET N=1
SET C=0
SET T=19
DO W
IF BMCQUIT
QUIT
End DoDot:1
IF 1
+7 IF '$TEST
SET X="Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.09)
SET N=1
SET C=0
SET T=30
DO W
IF BMCQUIT
QUIT
+8 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
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
