BMCFUTL ; IHS/OIT/FCJ - PRINT REFERRAL FORM UTILITY ROUTINE; [ 09/22/2006 4:24 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
;4.0*3 12.10.2007 IHS.OIT.FCJ ADDED EP LABEL TO LINES I, N, O, C, PRINT, REFFROM, TEXT AND WPTXT
;
PRINT ;EP
;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
S X=$P(^BMCTFORM(BMCFTYPE,0),U,2) S N=0,C=1 D W
S X=$$VAL^XBDIQ1(90001,BMCREF,.01),C=0,N=0,T=66 D W
D S Q:BMCQUIT
DEMO ;Demographic Data
Q:BMCQUIT
S X="Patient Identification, Address, Phone",C=1,T=0,N=1 D W Q:BMCQUIT
S X="Patient Name: "_$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,T=0,N=1 D W Q:BMCQUIT
S X="ID Number: "_$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2),2),N=0,T=50,C=0 D W Q:BMCQUIT
I $P($G(^BMCPARM(DUZ(2),4100)),U,2)="" S X="SSN: "_"",C=0,T=9,N=1 D W Q:BMCQUIT
I $P($G(^BMCPARM(DUZ(2),4100)),U,2)="Y" S X="SSN: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.09),C=0,T=9,N=1 D W Q:BMCQUIT
S X="Sex: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.02),N=0,T=56,C=0 D W Q:BMCQUIT
S X="Address: " S:$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1602.2)]"" X=X_$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1602.2) S C=0,T=5,N=1 D W Q:BMCQUIT
S X="DOB: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.03),N=0,T=56,C=0 D W Q:BMCQUIT
S T=15,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
S X="Hm Phone: "_$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1606.2) S C=0,T=51,N=0 D W Q:BMCQUIT
;
REFTO ;
D L
D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
S X=$$VAL^XBDIQ1(90001,BMCREF,.02),N=0,C=0,T=64 D W Q:BMCQUIT
DATE ;
S X=$$VAL^XBDIQ1(90001,BMCREF,.14)_" Services "_$S($P(BMCR0,U,14)="I":"Admission Date",1:"Appointment Date")_": "_$$AVDOS^BMCRLU(BMCREF,"E"),N=1,C=0,T=0 D W Q:BMCQUIT
;
I $P($G(^BMCREF(BMCREF,0)),U,14)="O" S X="# of Outpatient Visits: "_$$VAL^XBDIQ1(90001,BMCREF,1111),C=0,T=0,N=1 D W Q:BMCQUIT
I $P($G(^BMCREF(BMCREF,0)),U,14)="I" W !
S X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCREF,1107),C=0,T=40,N=0 D W Q:BMCQUIT
I $P($G(^BMCREF(BMCREF,0)),U,32)'="" S X="Priority Rating: "_$$VAL^XBDIQ1(90001,BMCREF,.32),C=0,T=0,N=1 D W Q:BMCQUIT
D L
PURPOSE ;
S X="Purpose/Services Requested: "_$$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=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)
ADDMED ;
S X="Additional Medical Information Attached: "_$S($$VAL^XBDIQ1(90001,BMCREF,.34)]"":$$VAL^XBDIQ1(90001,BMCREF,.34),1:" Not Documented by Provider"),C=0,T=0,N=2 D W Q:BMCQUIT
Q:BMCFTYP="CI"
REFFROM ;EP
S T=0,X=$TR($J(" ",IOM)," ","_") S N=1,C=0 D W Q:BMCQUIT
S BMCV=$P(BMCR0,U,5)
S Y=$P(BMCR0,U,4)
I Y="N" S X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=1,T=0,C=0 D W Q:BMCQUIT G PAYOR
;
S X="If you have any questions concerning this referral, please contact:",N=1,C=0,T=0 D W Q:BMCQUIT
S X=" "_$$VAL^XBDIQ1(90001,BMCREF,.05)_$S($$VAL^XBDIQ1(90001.31,DUZ(2),.17)]"":" (contact: "_$$VAL^XBDIQ1(90001.31,DUZ(2),.17)_")",1:"")_")" S N=1,C=0,T=0 D W Q:BMCQUIT
S X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
I BMCV,X]"" S N=1,C=0,T=5 D W Q:BMCQUIT
S X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
I BMCV,X]"" S X=X_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)_" (phone: "_$$VAL^XBDIQ1(90001.31,DUZ(2),.18)_")",N=1,C=0,T=5 D W Q:BMCQUIT
I BMCTYP'="CI" S X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=1,T=6,C=0 D W Q:BMCQUIT
I BMCTYP'="CI" S X="Case Manager: "_$$VAL^XBDIQ1(90001,BMCREF,.19),N=1,T=6,C=0 D W Q:BMCQUIT
S X="Veteran: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),1901),N=0,T=56,C=0 D W Q:BMCQUIT
PAYOR ;OTHER PAYOR INFORMATION
D OTHPAY^BMCFPRN1
Q:BMCQUIT
Q
TEXT ;EP
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)
Q:BMCFTYP="CI"
;
LINE ;CHS Supervisor Signature (if Type=CHS)
G:$P(BMCR0,U,4)'="C" ROUT
W !!!!!
S X="____________________",C=0,T=50,N=1 D W Q:BMCQUIT
W !
S X="Contract Health Service Office",C=0,T=50,N=1 D W Q:BMCQUIT
ROUT ;Print Routing slip
I BMCPROUT=1 W # D PRINT^BMCFDRS
W ;Entry Point
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 ;EP
S BMCV=$P(BMCR0,U,7)
Q:'BMCV
S X="Referred 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
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=19 D W Q:BMCQUIT
S X="Mailing: "_$$VAL^XBDIQ1(9999999.11,BMCV,1301) S N=1,C=0,T=0 D W Q:BMCQUIT
S X="Physical: "_$$VAL^XBDIQ1(9999999.11,BMCV,1306) S N=0,C=0,T=40 D W Q:BMCQUIT
;IHS/ITSC/FCJ MOD TO NOT REQUIRE ADDRESS FOR VENDOR
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=9 D W
.I $$VAL^XBDIQ1(9999999.11,BMCV,1306)'="" D Q:BMCQUIT
..S BMCVIEN=$P(^AUTTVNDR(BMCV,13),U,8)
..S X=$$VAL^XBDIQ1(9999999.11,BMCV,1307)_", "
..I BMCVIEN'="" S X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)
..S X=X_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1309)
..S:X'?1A.E X=""
..S N=0,C=0,T=50 D W
W !
Q
I ;EP
S BMCV=$P(BMCR0,U,8)
Q:'BMCV
S X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.08)_$S($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":" ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:""),N=1,C=0,T=0 D W Q:BMCQUIT
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")",N=1,C=0,T=19 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=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 ;EP
S X="IN HOUSE REFERRAL",N=1,C=0,T=0 D W Q:BMCQUIT
S X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic",N=1,C=0,T=0 D W Q:BMCQUIT
Q
O ;EP
S BMCV=$P(BMCR0,U,7)
I BMCV D I 1
.S X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$S($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:""),N=1,C=0,T=0 D W Q:BMCQUIT
.I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")",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="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.09),N=1,C=0,T=0 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
WPTXT ;EP
; site-specific txt
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
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
BMCFUTL ; IHS/OIT/FCJ - PRINT REFERRAL FORM UTILITY ROUTINE; [ 09/22/2006 4:24 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
+2 ;4.0*3 12.10.2007 IHS.OIT.FCJ ADDED EP LABEL TO LINES I, N, O, C, PRINT, REFFROM, TEXT AND WPTXT
+3 ;
PRINT ;EP
+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 SET X=$PIECE(^BMCTFORM(BMCFTYPE,0),U,2)
SET N=0
SET C=1
DO W
+6 SET X=$$VAL^XBDIQ1(90001,BMCREF,.01)
SET C=0
SET N=0
SET T=66
DO W
+7 DO S
IF BMCQUIT
QUIT
DEMO ;Demographic Data
+1 IF BMCQUIT
QUIT
+2 SET X="Patient Identification, Address, Phone"
SET C=1
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+3 SET X="Patient Name: "_$$VAL^XBDIQ1(90001,BMCREF,.03)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+4 SET X="ID Number: "_$$HRN^AUPNPAT($PIECE(BMCR0,U,3),DUZ(2),2)
SET N=0
SET T=50
SET C=0
DO W
IF BMCQUIT
QUIT
+5 IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,2)=""
SET X="SSN: "_""
SET C=0
SET T=9
SET N=1
DO W
IF BMCQUIT
QUIT
+6 IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,2)="Y"
SET X="SSN: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.09)
SET C=0
SET T=9
SET N=1
DO W
IF BMCQUIT
QUIT
+7 SET X="Sex: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.02)
SET N=0
SET T=56
SET C=0
DO W
IF BMCQUIT
QUIT
+8 SET X="Address: "
IF $$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1602.2)]""
SET X=X_$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1602.2)
SET C=0
SET T=5
SET N=1
DO W
IF BMCQUIT
QUIT
+9 SET X="DOB: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.03)
SET N=0
SET T=56
SET C=0
DO W
IF BMCQUIT
QUIT
+10 SET T=15
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
+11 SET X="Hm Phone: "_$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1606.2)
SET C=0
SET T=51
SET N=0
DO W
IF BMCQUIT
QUIT
+12 ;
REFTO ;
+1 DO L
+2 DO @$$VALI^XBDIQ1(90001,BMCREF,.04)
IF BMCQUIT
QUIT
+3 SET X=$$VAL^XBDIQ1(90001,BMCREF,.02)
SET N=0
SET C=0
SET T=64
DO W
IF BMCQUIT
QUIT
DATE ;
+1 SET X=$$VAL^XBDIQ1(90001,BMCREF,.14)_" Services "_$SELECT($PIECE(BMCR0,U,14)="I":"Admission Date",1:"Appointment Date")_": "_$$AVDOS^BMCRLU(BMCREF,"E")
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+2 ;
+3 IF $PIECE($GET(^BMCREF(BMCREF,0)),U,14)="O"
SET X="# of Outpatient Visits: "_$$VAL^XBDIQ1(90001,BMCREF,1111)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+4 IF $PIECE($GET(^BMCREF(BMCREF,0)),U,14)="I"
WRITE !
+5 SET X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCREF,1107)
SET C=0
SET T=40
SET N=0
DO W
IF BMCQUIT
QUIT
+6 IF $PIECE($GET(^BMCREF(BMCREF,0)),U,32)'=""
SET X="Priority Rating: "_$$VAL^XBDIQ1(90001,BMCREF,.32)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+7 DO L
PURPOSE ;
+1 SET X="Purpose/Services Requested: "_$$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=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
ADDMED ;
+1 SET X="Additional Medical Information Attached: "_$SELECT($$VAL^XBDIQ1(90001,BMCREF,.34)]"":$$VAL^XBDIQ1(90001,BMCREF,.34),1:" Not Documented by Provider")
SET C=0
SET T=0
SET N=2
DO W
IF BMCQUIT
QUIT
+2 IF BMCFTYP="CI"
QUIT
REFFROM ;EP
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","_")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 SET BMCV=$PIECE(BMCR0,U,5)
+3 SET Y=$PIECE(BMCR0,U,4)
+4 IF Y="N"
SET X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=1
SET T=0
SET C=0
DO W
IF BMCQUIT
QUIT
GOTO PAYOR
+5 ;
+6 SET X="If you have any questions concerning this referral, please contact:"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+7 SET X=" "_$$VAL^XBDIQ1(90001,BMCREF,.05)_$SELECT($$VAL^XBDIQ1(90001.31,DUZ(2),.17)]"":" (contact: "_$$VAL^XBDIQ1(90001.31,DUZ(2),.17)_")",1:"")_")"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+8 SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
+9 IF BMCV
IF X]""
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+10 SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
+11 IF BMCV
IF X]""
SET X=X_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)_" (phone: "_$$VAL^XBDIQ1(90001.31,DUZ(2),.18)_")"
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+12 IF BMCTYP'="CI"
SET X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=1
SET T=6
SET C=0
DO W
IF BMCQUIT
QUIT
+13 IF BMCTYP'="CI"
SET X="Case Manager: "_$$VAL^XBDIQ1(90001,BMCREF,.19)
SET N=1
SET T=6
SET C=0
DO W
IF BMCQUIT
QUIT
+14 SET X="Veteran: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),1901)
SET N=0
SET T=56
SET C=0
DO W
IF BMCQUIT
QUIT
PAYOR ;OTHER PAYOR INFORMATION
+1 DO OTHPAY^BMCFPRN1
+2 IF BMCQUIT
QUIT
+3 QUIT
TEXT ;EP
+1 WRITE !
DO S
+2 KILL BMCWP
+3 SET BMCCHSAS=$PIECE($GET(^BMCREF(BMCREF,11)),U,12)
+4 ;
+5 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
+6 IF $PIECE(BMCR0,U,4)="O"
SET BMCNODE=2
SET BMCFILE=90001.33
SET BMCDA=BMCFTYPE
DO WPTXT
+7 IF $PIECE(BMCR0,U,4)="I"!($PIECE(BMCR0,U,4)="N")
WRITE !
SET BMCWP(1)=""
+8 ;
+9 SET BMCY=0
FOR
SET BMCY=$ORDER(BMCWP(BMCY))
IF BMCY'=+BMCY!(BMCQUIT)
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+11 WRITE !,BMCWP(BMCY)
End DoDot:1
+12 IF BMCFTYP="CI"
QUIT
+13 ;
LINE ;CHS Supervisor Signature (if Type=CHS)
+1 IF $PIECE(BMCR0,U,4)'="C"
GOTO ROUT
+2 WRITE !!!!!
+3 SET X="____________________"
SET C=0
SET T=50
SET N=1
DO W
IF BMCQUIT
QUIT
+4 WRITE !
+5 SET X="Contract Health Service Office"
SET C=0
SET T=50
SET N=1
DO W
IF BMCQUIT
QUIT
ROUT ;Print Routing slip
+1 IF BMCPROUT=1
WRITE #
DO PRINT^BMCFDRS
W ;Entry Point
+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 ;EP
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF 'BMCV
QUIT
+3 SET X="Referred 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 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 SET X="Mailing: "_$$VAL^XBDIQ1(9999999.11,BMCV,1301)
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+6 SET X="Physical: "_$$VAL^XBDIQ1(9999999.11,BMCV,1306)
SET N=0
SET C=0
SET T=40
DO W
IF BMCQUIT
QUIT
+7 ;IHS/ITSC/FCJ MOD TO NOT REQUIRE ADDRESS FOR VENDOR
+8 IF $GET(^AUTTVNDR(BMCV,13))'=""
Begin DoDot:1
+9 SET BMCVIEN=$PIECE(^AUTTVNDR(BMCV,13),U,3)
+10 SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "
+11 IF BMCVIEN'=""
SET X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
+12 SET N=1
SET C=0
SET T=9
DO W
+13 IF $$VAL^XBDIQ1(9999999.11,BMCV,1306)'=""
Begin DoDot:2
+14 SET BMCVIEN=$PIECE(^AUTTVNDR(BMCV,13),U,8)
+15 SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1307)_", "
+16 IF BMCVIEN'=""
SET X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)
+17 SET X=X_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1309)
+18 IF X'?1A.E
SET X=""
+19 SET N=0
SET C=0
SET T=50
DO W
End DoDot:2
IF BMCQUIT
QUIT
End DoDot:1
IF BMCQUIT
QUIT
+20 WRITE !
+21 QUIT
I ;EP
+1 SET BMCV=$PIECE(BMCR0,U,8)
+2 IF 'BMCV
QUIT
+3 SET X="Referred to: "_$$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=0
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.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
+6 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
+7 QUIT
N ;EP
+1 SET X="IN HOUSE REFERRAL"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+2 SET X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+3 QUIT
O ;EP
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF BMCV
Begin DoDot:1
+3 SET X="Referred 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 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="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.09)
SET N=1
SET C=0
SET T=0
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
WPTXT ;EP
+1 ; site-specific txt
+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
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
