BMCFPRNP ; IHS/OIT/FCJ - PRINT PHYSICIAN CONSULT LETTER ; [ 10/31/2006 2:40 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**2,9**;JAN 09, 2006;Build 101
;Consultation Letter to recieve information back from the consult visit
;letter to be sent with patient
;BMC*4.0*9 ;IHS.OIT.FCJ ICD-10 CHANGES
;
PRINT ;print consult letter
S BMCR0=^BMCREF(BMCREF,0),BMCPG=0,BMCDFN=$P(BMCR0,U,3)
D @("HEAD"_(2-($E(IOST,1,2)="C-")))
S BMCQUIT=0
S X="CONSULT REQUEST" S N=1,C=1 D W
S BMCFTYP=$S($E($P(^BMCTFORM(BMCFTYPE,0),U),1,4)="CALL":"CI",1:"S")
S Y=DT X ^DD("DD")
S X="DATE: "_Y S N=1,C=0,T=0 D W
PHY ;PHYSICIAN INFORMATION; REFERRED TO AND REFERRED FROM
D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
;
PURPOSE ;
S X="REASON FOR REQUEST: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
I $L(X)>IOM D I 1
.S BMCX=X S X=$E(BMCX,1,IOM),N=2,C=0,T=0 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=0 D W Q:BMCQUIT
PERTMED ;
S BMCCMT=0
F S BMCCMT=$O(^BMCCOM("AD",BMCREF,BMCCMT)) Q:BMCCMT'?1N.N D
.Q:$P(^BMCCOM(BMCCMT,0),U,5)'="M"
.S BMCNODE=1,BMCIOM=70,BMCFILE=90001.03,BMCDA=BMCCMT,BMCNODE=1
.D WP 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)
DX ;BMC*4.1*9 REWROTE SECTION, WAS PRINTING DRG NOT DX
;S X="PROVISIONAL DIAGNOSIS: "_$$VAL^XBDIQ1(90001,BMCREF,.21),C=0,T=0,N=2 D W Q:BMCQUIT
I $D(^BMCDX("AD",BMCREF)) S (CT,DX)=0 F S DX=$O(^BMCDX("AD",BMCREF,DX)) Q:DX'=+DX S BMCD=+^BMCDX(DX,0) D Q:BMCQUIT
.Q:$P($G(^BMCDX(DX,0)),U,4)'="P"
.S CT=CT+1,BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
.I CT=1 S X="PROVISIONAL DIAGNOSIS: "_$P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2)_" - "_$E($P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,50),C=0,T=0,N=2 D W Q
.E S X=$P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2)_"-"_$E($P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,50),C=0,T=23,N=2 D W Q
I BMCFTYP'="CI" S X="PHYSICIAN'S SIGNATURE (ELECTONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=2,T=0,C=0 D W Q:BMCQUIT
CONSULT ;CONSULT INFORMATION
S X="CONSULTATION REPORT:" S N=2,C=1,T=0 D W
S X="CONSULTING PHYSICIAN SIGNATURE: "
S X=X_" DATE:" S N=10,C=0,T=0 D W Q:BMCQUIT
REFFROM ;
S BMCV=$P(BMCR0,U,5)
S Y=$P(BMCR0,U,4)
S X="Return To: "_$$VAL^XBDIQ1(90001,BMCV,.05),N=2,C=0,T=0 D W
I $$VAL^XBDIQ1(90001.31,BMCV,201)'="" D
.S X=$$VAL^XBDIQ1(90001.31,BMCV,201)
.I BMCV,X]"" S N=1,C=0,T=11 D W Q:BMCQUIT
.S X=$$VAL^XBDIQ1(90001.31,BMCV,202)
.I BMCV,X]"" D
..S X=X_", "_$$VAL^XBDIQ1(90001.31,BMCV,203)
..S X=X_" "_$$VAL^XBDIQ1(90001.31,BMCV,204),N=1,C=0,T=11 D W Q:BMCQUIT
E I $$VAL^XBDIQ1(9999999.06,BMCV,.14)'="" D
.S X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
.I BMCV,X]"" S N=1,C=0,T=11 D W Q:BMCQUIT
.S X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
.I BMCV,X]"" D
..S X=X_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)
..S X=X_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17),N=1,C=0,T=11 D W Q:BMCQUIT
S X=$$VAL^XBDIQ1(90001.31,BMCV,.17)
S X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")",N=1,C=0,T=11 D W Q:BMCQUIT
;
DEMO ;Demographic Data
S X="Patient Name: "_$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,T=0,N=2 D W Q:BMCQUIT
S X="DOB: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.03),N=0,T=54,C=0 D W Q:BMCQUIT
S X="IHS ID Number: "_$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2),2),N=1,T=0,C=0 D W Q:BMCQUIT
S X="Referral #: "_$$VAL^XBDIQ1(90001,BMCREF,.02),N=0,C=0,T=25 D W Q:BMCQUIT
S X="Date of Service: "_$$AVDOS^BMCRLU(BMCREF,"E"),N=0,C=0,T=54 D W Q:BMCQUIT
Q
TEXT ;
W ! D S
K BMCWP
S BMCCHSAS=$P($G(^BMCREF(BMCREF,11)),U,12)
I $P(BMCR0,U,4)="C" S BMCNODE=$S(BMCCHSAS="A":1,BMCCHSAS="D":2,BMCCHSAS="P":3,1:3) S BMCFILE=90001.33,BMCDA=BMCFTYPE D WPTXT
I $P(BMCR0,U,4)="O" S BMCNODE=2,BMCFILE=90001.33,BMCDA=BMCFTYPE D WPTXT
I $P(BMCR0,U,4)="I"!($P(BMCR0,U,4)="N") W ! S BMCWP(1)=""
;
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 ;
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
S ;
S T=0,X=$TR($J(" ",IOM)," ","*"),N=1,C=0 D W
Q
C ;
S BMCV=$P(BMCR0,U,7)
Q:'BMCV
S X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$S($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:""),N=2,C=0,T=0 D W Q:BMCQUIT
S X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=0,T=40,C=0 D W Q:BMCQUIT
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")",N=1,C=0,T=5 D W Q:BMCQUIT
S X=$$VAL^XBDIQ1(9999999.11,BMCV,1301),N=1,C=0,T=5 D W Q:BMCQUIT
I $G(^AUTTVNDR(BMCV,13))'="" D Q:BMCQUIT
.S BMCVIEN=$P(^AUTTVNDR(BMCV,13),U,3)
.S X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "
.I BMCVIEN'="" S X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
.S N=1,C=0,T=5 D W
W !
Q
I ;
S BMCV=$P(BMCR0,U,8)
Q:'BMCV
S X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.08)_$S($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":" ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"") S N=2,C=0,T=0 D W Q:BMCQUIT
S X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=0,T=40,C=0 D W Q:BMCQUIT
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=5 D W Q:BMCQUIT
I $$VAL^XBDIQ1(9999999.06,BMCV,.14)]"" S X=$$VAL^XBDIQ1(9999999.06,BMCV,.14) S N=1,C=0,T=5 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=5 D W Q:BMCQUIT
Q
N ;
S X="IN HOUSE REFERRAL",N=1,C=0,T=0 D W Q:BMCQUIT
S X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic",N=1,C=0,T=0 D W Q:BMCQUIT
S X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=0,T=40,C=0 D W Q:BMCQUIT
Q
O ;
S BMCV=$P(BMCR0,U,7)
I BMCV D I 1
.S X="To: "_$$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=0 D W Q:BMCQUIT
.S X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=0,T=40,C=0 D W Q:BMCQUIT
.I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=5 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=5 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=5 D W Q:BMCQUIT
E S X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.09),N=1,C=0,T=0 D W Q:BMCQUIT
Q
WPTXT ;
; get site-specific text (if any)
I $P(BMCR0,U,4)="C" D
.I BMCCHSAS="A",$D(^BMCPARM(DUZ(2),31)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=31
.I BMCCHSAS="D",$D(^BMCPARM(DUZ(2),32)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=32
.I BMCCHSAS="P"!(BMCCHSAS=""),$D(^BMCPARM(DUZ(2),33)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=33
I $P(BMCR0,U,4)="O",$D(^BMCPARM(DUZ(2),33)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=34
; fall through to WP to get the text
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
BMCFPRNP ; IHS/OIT/FCJ - PRINT PHYSICIAN CONSULT LETTER ; [ 10/31/2006 2:40 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**2,9**;JAN 09, 2006;Build 101
+2 ;Consultation Letter to recieve information back from the consult visit
+3 ;letter to be sent with patient
+4 ;BMC*4.0*9 ;IHS.OIT.FCJ ICD-10 CHANGES
+5 ;
PRINT ;print consult letter
+1 SET BMCR0=^BMCREF(BMCREF,0)
SET BMCPG=0
SET BMCDFN=$PIECE(BMCR0,U,3)
+2 DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+3 SET BMCQUIT=0
+4 SET X="CONSULT REQUEST"
SET N=1
SET C=1
DO W
+5 SET BMCFTYP=$SELECT($EXTRACT($PIECE(^BMCTFORM(BMCFTYPE,0),U),1,4)="CALL":"CI",1:"S")
+6 SET Y=DT
XECUTE ^DD("DD")
+7 SET X="DATE: "_Y
SET N=1
SET C=0
SET T=0
DO W
PHY ;PHYSICIAN INFORMATION; REFERRED TO AND REFERRED FROM
+1 DO @$$VALI^XBDIQ1(90001,BMCREF,.04)
IF BMCQUIT
QUIT
+2 ;
PURPOSE ;
+1 SET X="REASON FOR REQUEST: "_$$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=2
SET C=0
SET T=0
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=0
DO W
IF BMCQUIT
QUIT
PERTMED ;
+1 SET BMCCMT=0
+2 FOR
SET BMCCMT=$ORDER(^BMCCOM("AD",BMCREF,BMCCMT))
IF BMCCMT'?1N.N
QUIT
Begin DoDot:1
+3 IF $PIECE(^BMCCOM(BMCCMT,0),U,5)'="M"
QUIT
+4 SET BMCNODE=1
SET BMCIOM=70
SET BMCFILE=90001.03
SET BMCDA=BMCCMT
SET BMCNODE=1
+5 DO WP
KILL BMCIOM
+6 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:2
+7 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+8 WRITE !?5,BMCWP(Y)
End DoDot:2
End DoDot:1
DX ;BMC*4.1*9 REWROTE SECTION, WAS PRINTING DRG NOT DX
+1 ;S X="PROVISIONAL DIAGNOSIS: "_$$VAL^XBDIQ1(90001,BMCREF,.21),C=0,T=0,N=2 D W Q:BMCQUIT
+2 IF $DATA(^BMCDX("AD",BMCREF))
SET (CT,DX)=0
FOR
SET DX=$ORDER(^BMCDX("AD",BMCREF,DX))
IF DX'=+DX
QUIT
SET BMCD=+^BMCDX(DX,0)
Begin DoDot:1
+3 IF $PIECE($GET(^BMCDX(DX,0)),U,4)'="P"
QUIT
+4 SET CT=CT+1
SET BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
+5 IF CT=1
S">SET X="PROVIS">SIONAL DIAGNOS">SIS">S: "_$PIECE($$ICDDX^ICDEX(BMCD,BMCDOS">S,,"I"),U,2)_" - "_$EXTRACT($PIECE($$ICDDX^ICDEX(BMCD,BMCDOS">S,,"I"),U,4),1,50)
SET C=0
SET T=0
SET N=2
DO W
QUIT
+6 IF '$TEST
S">SET X=$PIECE($$ICDDX^ICDEX(BMCD,BMCDOS">S,,"I"),U,2)_"-"_$EXTRACT($PIECE($$ICDDX^ICDEX(BMCD,BMCDOS">S,,"I"),U,4),1,50)
SET C=0
SET T=23
SET N=2
DO W
QUIT
End DoDot:1
IF BMCQUIT
QUIT
+7 IF BMCFTYP'="CI"
SET X="PHYSICIAN'S SIGNATURE (ELECTONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=2
SET T=0
SET C=0
DO W
IF BMCQUIT
QUIT
CONSULT ;CONSULT INFORMATION
+1 SET X="CONSULTATION REPORT:"
SET N=2
SET C=1
SET T=0
DO W
+2 SET X="CONSULTING PHYSICIAN SIGNATURE: "
+3 SET X=X_" DATE:"
SET N=10
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
REFFROM ;
+1 SET BMCV=$PIECE(BMCR0,U,5)
+2 SET Y=$PIECE(BMCR0,U,4)
+3 SET X="Return To: "_$$VAL^XBDIQ1(90001,BMCV,.05)
SET N=2
SET C=0
SET T=0
DO W
+4 IF $$VAL^XBDIQ1(90001.31,BMCV,201)'=""
Begin DoDot:1
+5 SET X=$$VAL^XBDIQ1(90001.31,BMCV,201)
+6 IF BMCV
IF X]""
SET N=1
SET C=0
SET T=11
DO W
IF BMCQUIT
QUIT
+7 SET X=$$VAL^XBDIQ1(90001.31,BMCV,202)
+8 IF BMCV
IF X]""
Begin DoDot:2
+9 SET X=X_", "_$$VAL^XBDIQ1(90001.31,BMCV,203)
+10 SET X=X_" "_$$VAL^XBDIQ1(90001.31,BMCV,204)
SET N=1
SET C=0
SET T=11
DO W
IF BMCQUIT
QUIT
End DoDot:2
End DoDot:1
+11 IF '$TEST
IF $$VAL^XBDIQ1(9999999.06,BMCV,.14)'=""
Begin DoDot:1
+12 SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
+13 IF BMCV
IF X]""
SET N=1
SET C=0
SET T=11
DO W
IF BMCQUIT
QUIT
+14 SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
+15 IF BMCV
IF X]""
Begin DoDot:2
+16 SET X=X_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)
+17 SET X=X_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)
SET N=1
SET C=0
SET T=11
DO W
IF BMCQUIT
QUIT
End DoDot:2
End DoDot:1
+18 SET X=$$VAL^XBDIQ1(90001.31,BMCV,.17)
+19 SET X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")"
SET N=1
SET C=0
SET T=11
DO W
IF BMCQUIT
QUIT
+20 ;
DEMO ;Demographic Data
+1 SET X="Patient Name: "_$$VAL^XBDIQ1(90001,BMCREF,.03)
SET C=0
SET T=0
SET N=2
DO W
IF BMCQUIT
QUIT
+2 SET X="DOB: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.03)
SET N=0
SET T=54
SET C=0
DO W
IF BMCQUIT
QUIT
+3 SET X="IHS ID Number: "_$$HRN^AUPNPAT($PIECE(BMCR0,U,3),DUZ(2),2)
SET N=1
SET T=0
SET C=0
DO W
IF BMCQUIT
QUIT
+4 SET X="Referral #: "_$$VAL^XBDIQ1(90001,BMCREF,.02)
SET N=0
SET C=0
SET T=25
DO W
IF BMCQUIT
QUIT
+5 SET X="Date of Service: "_$$AVDOS^BMCRLU(BMCREF,"E")
SET N=0
SET C=0
SET T=54
DO W
IF BMCQUIT
QUIT
+6 QUIT
TEXT ;
+1 WRITE !
DO S
+2 KILL BMCWP
+3 SET BMCCHSAS=$PIECE($GET(^BMCREF(BMCREF,11)),U,12)
+4 IF $PIECE(BMCR0,U,4)="C"
SET BMCNODE=$SELECT(BMCCHSAS="A":1,BMCCHSAS="D":2,BMCCHSAS="P":3,1:3)
SET BMCFILE=90001.33
SET BMCDA=BMCFTYPE
DO WPTXT
+5 IF $PIECE(BMCR0,U,4)="O"
SET BMCNODE=2
SET BMCFILE=90001.33
SET BMCDA=BMCFTYPE
DO WPTXT
+6 IF $PIECE(BMCR0,U,4)="I"!($PIECE(BMCR0,U,4)="N")
WRITE !
SET BMCWP(1)=""
+7 ;
+8 SET BMCY=0
FOR
SET BMCY=$ORDER(BMCWP(BMCY))
IF BMCY'=+BMCY!(BMCQUIT)
QUIT
Begin DoDot:1
+9 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+10 WRITE !,BMCWP(BMCY)
End DoDot:1
+11 ;
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
S ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","*")
SET N=1
SET C=0
DO W
+2 QUIT
C ;
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF 'BMCV
QUIT
+3 SET X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:"")
SET N=2
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+4 SET X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=0
SET T=40
SET C=0
DO W
IF BMCQUIT
QUIT
+5 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+6 SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1301)
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+7 IF $GET(^AUTTVNDR(BMCV,13))'=""
Begin DoDot:1
+8 SET BMCVIEN=$PIECE(^AUTTVNDR(BMCV,13),U,3)
+9 SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "
+10 IF BMCVIEN'=""
SET X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
+11 SET N=1
SET C=0
SET T=5
DO W
End DoDot:1
IF BMCQUIT
QUIT
+12 WRITE !
+13 QUIT
I ;
+1 SET BMCV=$PIECE(BMCR0,U,8)
+2 IF 'BMCV
QUIT
+3 SET X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.08)_$SELECT($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":" ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"")
SET N=2
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+4 SET X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=0
SET T=40
SET C=0
DO W
IF BMCQUIT
QUIT
+5 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+6 IF $$VAL^XBDIQ1(9999999.06,BMCV,.14)]""
SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+7 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=5
DO W
IF BMCQUIT
QUIT
+8 QUIT
N ;
+1 SET X="IN HOUSE REFERRAL"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+2 SET X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+3 SET X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=0
SET T=40
SET C=0
DO W
IF BMCQUIT
QUIT
+4 QUIT
O ;
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF BMCV
Begin DoDot:1
+3 SET X="To: "_$$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=0
DO W
IF BMCQUIT
QUIT
+4 SET X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=0
SET T=40
SET C=0
DO W
IF BMCQUIT
QUIT
+5 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+6 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=5
DO W
IF BMCQUIT
QUIT
+7 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=5
DO W
IF BMCQUIT
QUIT
End DoDot:1
IF 1
+8 IF '$TEST
SET X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.09)
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+9 QUIT
WPTXT ;
+1 ; get site-specific text (if any)
+2 IF $PIECE(BMCR0,U,4)="C"
Begin DoDot:1
+3 IF BMCCHSAS="A"
IF $DATA(^BMCPARM(DUZ(2),31))
SET BMCFILE=90001.31
SET BMCDA=DUZ(2)
SET BMCNODE=31
+4 IF BMCCHSAS="D"
IF $DATA(^BMCPARM(DUZ(2),32))
SET BMCFILE=90001.31
SET BMCDA=DUZ(2)
SET BMCNODE=32
+5 IF BMCCHSAS="P"!(BMCCHSAS="")
IF $DATA(^BMCPARM(DUZ(2),33))
SET BMCFILE=90001.31
SET BMCDA=DUZ(2)
SET BMCNODE=33
End DoDot:1
+6 IF $PIECE(BMCR0,U,4)="O"
IF $DATA(^BMCPARM(DUZ(2),33))
SET BMCFILE=90001.31
SET BMCDA=DUZ(2)
SET BMCNODE=34
+7 ; fall through to WP to get the text
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
