BMCFPRN2 ; IHS/OIT/FCJ - PRINT REFERRAL FORM-SECONDARY PROVIDER ; [ 09/27/2006 2:27 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1,2,12**;JAN 09, 2006;Build 101
;
;This Routine Prints the Actual Data for Secondary Provider Letter
;The Main Driver Routine = BMCFDR2
;The RCIS Output Report Defintion=SECONDARY PROVIDER LETTER-IEN #4
;4.0 IHS/FCJ/ITSC Modified to add dates, in/out pat, correct ref prov,
; priority and print info fr sec ref
;4.0*1 2.15.06 IHS/OIT/FCJ ADDED PRINTING ADDRESS FR PARM
;4.0*1 5.17.06 IHS/OIT/FCJ CALL TO OTH INS ^BMCFPRN1
;4.0*2 9-21-06 IHS/OIT/FCJ ASK TO PRNT CONSULT LETTER
;4.0*3 9.15.08 IHS.OIT.FCJ FX FOR UNDEF VAR WHEN QUEUED
;
PRINT ;
;print referral form
S BMCR0=^BMCREF(BMCREF,0),BMCPG=0,BMCDFN=$P(BMCR0,U,3)
S BMCR1=^BMCREF(BMCSRIEN,0)
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,BMCSRIEN,.01),C=0,N=0,T=67 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
;S X="SSN: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.09),C=0,T=9,N=1 D W Q:BMCQUIT ;BMC*3.1*12
;S X="Sex: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.02),N=0,T=56,C=0 D W Q:BMCQUIT ;BMC*3.1*12
S X="Sex: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.02),N=1,T=56,C=0 D W Q:BMCQUIT ;BMC*3.1*12
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
;
I BMCKIND=1 D I Q:BMCQUIT ;IHS Type Referrals
I BMCKIND=0 D C Q:BMCQUIT ;Contract or Other Type Referrals
;
DATE ;
;Secondary Provider Date Print
S X="Referral: "_$$VAL^XBDIQ1(90001,BMCREF,.02)_" "_$$VAL^XBDIQ1(90001,BMCSRIEN,101) S N=0,C=0,T=40 D W Q:BMCQUIT
S X=$$VAL^XBDIQ1(90001,BMCSRIEN,.14)_" Services "_$S($P(BMCR1,U,14)="I":"Admission Date",1:"Appointment Date")_": "_$$AVDOS^BMCRLU(BMCSRIEN,"E"),N=1,C=0,T=0 D W Q:BMCQUIT
;
I $P($G(^BMCREF(BMCSRIEN,0)),U,14)="O" S X="# of Outpatient Visits: "_$$VAL^XBDIQ1(90001,BMCSRIEN,1111),C=0,T=0,N=1 D W Q:BMCQUIT
I $P(BMCR1,U,14)="I" W !
S X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCSRIEN,1107),C=0,T=40,N=0 D W Q:BMCQUIT
I $P(BMCR1,U,32)'="" S X="Priority Rating: "_$$VAL^XBDIQ1(90001,BMCSRIEN,.32),C=0,T=0,N=1 D W Q:BMCQUIT
D L
PURPOSE ;
S X="Purpose/Services Requested: "_$$VAL^XBDIQ1(90001,BMCSRIEN,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 ; FROM PRIMARY AND SECONDARY REFERAL
I BMCPHX=1 S BMCREF=BMCRIEN D PERTMED1
S BMCREF=BMCSRIEN D PERTMED1
S BMCREF=BMCRIEN
G ADDMED
PERTMED1 ;
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 BMCFILE=90001.03,BMCDA=BMCCMT D PERTMEDW
Q
PERTMEDW ;WRITE PERT MED INFO
S BMCNODE=1,BMCIOM=70,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)
Q
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
REFFROM ;
S T=0,X=$TR($J(" ",IOM)," ","_") S N=1,C=0 D W Q:BMCQUIT
S BMCV=$P(BMCR1,U,5)
S Y=$P(BMCR1,U,4)
I Y="N" S X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCSRIEN,.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:"")_")",N=1,C=0,T=0 D W Q:BMCQUIT
;
;4.0*1 2.15.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRNT ADDRESS FR PARM
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=5 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)
..S X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")",N=1,C=0,T=5 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=5 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)
..S X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")",N=1,C=0,T=5 D W Q:BMCQUIT
;4.0*1 2.15.06 IHS/OIT/FCJ END OF CHANGES
S X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCSRIEN,.06),N=1,T=6,C=0 D W Q:BMCQUIT
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 ;CALL BMCFPRN1 TO PRINT OTHER PAYOR INFORMATION
;4.0*1 5.17.06 IHS/OIT/FCJ REM PAYOR SECTION AND ADDED CALL
D OTHPAY^BMCFPRN1
TEXT ;
W ! D S
K BMCWP
S BMCCHSAS=$P($G(^BMCREF(BMCSRIEN,11)),U,12)
;BMC 4.0*12 IN THE NEXT 3 LINES CHANGED BMCR0 TO BMCR1
I $P(BMCR1,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(BMCR1,U,4)="O" S BMCNODE=2,BMCFILE=90001.33,BMCDA=BMCFTYPE D WPTXT
I $P(BMCR1,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)
;
LINE ;CHS Supervisor Signature (if Type=CHS)
;Q:$P(BMCR1,U,4)'="C" ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ
G:$P(BMCR1,U,4)'="C" CONSULT ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ
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
;D W ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ ADDED LINE
CONSULT ;PRNT CONSULT LETTER ;BMC*4.0*2 9-21-06 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 ;
Q:'BMCCPRV
S BMCV=BMCCPRV ;Secondary Primary Vendor - CHS only
S X="Referred to: "_BMCCPRVP_$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 BMCCPRVS'="" S X="Specific Provider: "_BMCCPRVS S N=1,C=0,T=0 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
S BMCVIEN=$P(^AUTTVNDR(BMCV,13),U,3)
S X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
S N=1,C=0,T=9 D W Q:BMCQUIT
I $$VAL^XBDIQ1(9999999.11,BMCV,1306)'="" D
.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 Q:BMCQUIT
W !
Q
;
I ;IHS Secondary Provider Referrals
Q:'BMCCPRV
S BMCV=BMCCPRV
S X="Referred to: "_$$VAL^XBDIQ1(90001,BMCRSIEN,.08)_$S($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":" ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"") S N=1,C=0,T=0 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
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 ;
; 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
BMCFPRN2 ; IHS/OIT/FCJ - PRINT REFERRAL FORM-SECONDARY PROVIDER ; [ 09/27/2006 2:27 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1,2,12**;JAN 09, 2006;Build 101
+2 ;
+3 ;This Routine Prints the Actual Data for Secondary Provider Letter
+4 ;The Main Driver Routine = BMCFDR2
+5 ;The RCIS Output Report Defintion=SECONDARY PROVIDER LETTER-IEN #4
+6 ;4.0 IHS/FCJ/ITSC Modified to add dates, in/out pat, correct ref prov,
+7 ; priority and print info fr sec ref
+8 ;4.0*1 2.15.06 IHS/OIT/FCJ ADDED PRINTING ADDRESS FR PARM
+9 ;4.0*1 5.17.06 IHS/OIT/FCJ CALL TO OTH INS ^BMCFPRN1
+10 ;4.0*2 9-21-06 IHS/OIT/FCJ ASK TO PRNT CONSULT LETTER
+11 ;4.0*3 9.15.08 IHS.OIT.FCJ FX FOR UNDEF VAR WHEN QUEUED
+12 ;
PRINT ;
+1 ;print referral form
+2 SET BMCR0=^BMCREF(BMCREF,0)
SET BMCPG=0
SET BMCDFN=$PIECE(BMCR0,U,3)
+3 SET BMCR1=^BMCREF(BMCSRIEN,0)
+4 DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+5 SET BMCQUIT=0
+6 SET X=$PIECE(^BMCTFORM(BMCFTYPE,0),U,2)
SET N=0
SET C=1
DO W
+7 SET X=$$VAL^XBDIQ1(90001,BMCSRIEN,.01)
SET C=0
SET N=0
SET T=67
DO W
+8 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 ;S X="SSN: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.09),C=0,T=9,N=1 D W Q:BMCQUIT ;BMC*3.1*12
+6 ;S X="Sex: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.02),N=0,T=56,C=0 D W Q:BMCQUIT ;BMC*3.1*12
+7 ;BMC*3.1*12
SET X="Sex: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.02)
SET N=1
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 ;
+3 ;IHS Type Referrals
IF BMCKIND=1
DO I
IF BMCQUIT
QUIT
+4 ;Contract or Other Type Referrals
IF BMCKIND=0
DO C
IF BMCQUIT
QUIT
+5 ;
DATE ;
+1 ;Secondary Provider Date Print
+2 SET X="Referral: "_$$VAL^XBDIQ1(90001,BMCREF,.02)_" "_$$VAL^XBDIQ1(90001,BMCSRIEN,101)
SET N=0
SET C=0
SET T=40
DO W
IF BMCQUIT
QUIT
+3 SET X=$$VAL^XBDIQ1(90001,BMCSRIEN,.14)_" Services "_$SELECT($PIECE(BMCR1,U,14)="I":"Admission Date",1:"Appointment Date")_": "_$$AVDOS^BMCRLU(BMCSRIEN,"E")
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+4 ;
+5 IF $PIECE($GET(^BMCREF(BMCSRIEN,0)),U,14)="O"
SET X="# of Outpatient Visits: "_$$VAL^XBDIQ1(90001,BMCSRIEN,1111)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+6 IF $PIECE(BMCR1,U,14)="I"
WRITE !
+7 SET X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCSRIEN,1107)
SET C=0
SET T=40
SET N=0
DO W
IF BMCQUIT
QUIT
+8 IF $PIECE(BMCR1,U,32)'=""
SET X="Priority Rating: "_$$VAL^XBDIQ1(90001,BMCSRIEN,.32)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+9 DO L
PURPOSE ;
+1 SET X="Purpose/Services Requested: "_$$VAL^XBDIQ1(90001,BMCSRIEN,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 ; FROM PRIMARY AND SECONDARY REFERAL
+1 IF BMCPHX=1
SET BMCREF=BMCRIEN
DO PERTMED1
+2 SET BMCREF=BMCSRIEN
DO PERTMED1
+3 SET BMCREF=BMCRIEN
+4 GOTO ADDMED
PERTMED1 ;
+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 BMCFILE=90001.03
SET BMCDA=BMCCMT
DO PERTMEDW
End DoDot:1
+5 QUIT
PERTMEDW ;WRITE PERT MED INFO
+1 SET BMCNODE=1
SET BMCIOM=70
SET BMCNODE=1
+2 DO WP
KILL BMCIOM
+3 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+5 WRITE !?5,BMCWP(Y)
End DoDot:1
+6 QUIT
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
REFFROM ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","_")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 SET BMCV=$PIECE(BMCR1,U,5)
+3 SET Y=$PIECE(BMCR1,U,4)
+4 IF Y="N"
SET X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCSRIEN,.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 ;
+9 ;4.0*1 2.15.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRNT ADDRESS FR PARM
+10 IF $$VAL^XBDIQ1(90001.31,BMCV,201)'=""
Begin DoDot:1
+11 SET X=$$VAL^XBDIQ1(90001.31,BMCV,201)
+12 IF BMCV
IF X]""
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+13 SET X=$$VAL^XBDIQ1(90001.31,BMCV,202)
+14 IF BMCV
IF X]""
Begin DoDot:2
+15 SET X=X_", "_$$VAL^XBDIQ1(90001.31,BMCV,203)
+16 SET X=X_" "_$$VAL^XBDIQ1(90001.31,BMCV,204)
+17 SET X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")"
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
End DoDot:2
End DoDot:1
+18 IF '$TEST
IF $$VAL^XBDIQ1(9999999.06,BMCV,.14)'=""
Begin DoDot:1
+19 SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
+20 IF BMCV
IF X]""
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+21 SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
+22 IF BMCV
IF X]""
Begin DoDot:2
+23 SET X=X_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)
+24 SET X=X_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)
+25 SET X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")"
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
End DoDot:2
End DoDot:1
+26 ;4.0*1 2.15.06 IHS/OIT/FCJ END OF CHANGES
+27 SET X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCSRIEN,.06)
SET N=1
SET T=6
SET C=0
DO W
IF BMCQUIT
QUIT
+28 SET X="Case Manager: "_$$VAL^XBDIQ1(90001,BMCREF,.19)
SET N=1
SET T=6
SET C=0
DO W
IF BMCQUIT
QUIT
+29 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 ;CALL BMCFPRN1 TO PRINT OTHER PAYOR INFORMATION
+1 ;4.0*1 5.17.06 IHS/OIT/FCJ REM PAYOR SECTION AND ADDED CALL
+2 DO OTHPAY^BMCFPRN1
TEXT ;
+1 WRITE !
DO S
+2 KILL BMCWP
+3 SET BMCCHSAS=$PIECE($GET(^BMCREF(BMCSRIEN,11)),U,12)
+4 ;BMC 4.0*12 IN THE NEXT 3 LINES CHANGED BMCR0 TO BMCR1
+5 IF $PIECE(BMCR1,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(BMCR1,U,4)="O"
SET BMCNODE=2
SET BMCFILE=90001.33
SET BMCDA=BMCFTYPE
DO WPTXT
+7 IF $PIECE(BMCR1,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 ;
LINE ;CHS Supervisor Signature (if Type=CHS)
+1 ;Q:$P(BMCR1,U,4)'="C" ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ
+2 ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ
IF $PIECE(BMCR1,U,4)'="C"
GOTO CONSULT
+3 WRITE !!!!!
+4 SET X="____________________"
SET C=0
SET T=50
SET N=1
DO W
IF BMCQUIT
QUIT
+5 WRITE !
+6 SET X="Contract Health Service Office"
SET C=0
SET T=50
SET N=1
DO W
IF BMCQUIT
QUIT
+7 ;D W ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ ADDED LINE
CONSULT ;PRNT CONSULT LETTER ;BMC*4.0*2 9-21-06 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 ;
+1 IF 'BMCCPRV
QUIT
+2 ;Secondary Primary Vendor - CHS only
SET BMCV=BMCCPRV
+3 SET X="Referred to: "_BMCCPRVP_$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 BMCCPRVS'=""
SET X="Specific Provider: "_BMCCPRVS
SET N=1
SET C=0
SET T=0
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 SET BMCVIEN=$PIECE(^AUTTVNDR(BMCV,13),U,3)
+8 SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
+9 SET N=1
SET C=0
SET T=9
DO W
IF BMCQUIT
QUIT
+10 IF $$VAL^XBDIQ1(9999999.11,BMCV,1306)'=""
Begin DoDot:1
+11 SET BMCVIEN=$PIECE(^AUTTVNDR(BMCV,13),U,8)
+12 SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1307)_", "
+13 IF BMCVIEN'=""
SET X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)
+14 SET X=X_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1309)
+15 IF X'?1A.E
SET X=""
+16 SET N=0
SET C=0
SET T=50
DO W
IF BMCQUIT
QUIT
End DoDot:1
+17 WRITE !
+18 QUIT
+19 ;
I ;IHS Secondary Provider Referrals
+1 IF 'BMCCPRV
QUIT
+2 SET BMCV=BMCCPRV
+3 SET X="Referred to: "_$$VAL^XBDIQ1(90001,BMCRSIEN,.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 $$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
+5 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
+6 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 ; 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
