BMCFPRN3.m

BMCFPRN3 ; IHS/PHXAO/TMJ - PRINT REFERRAL FORM-EXISTING SECONDARY PROVIDER ;       [ 09/26/2006  4:15 PM ]

 ;;4.0;REFERRED CARE INFO SYSTEM;**1,2,4**;JAN 09, 2006;Build 101

 ;IHS/ITSC/FCJ CHG VEND SECTION TO PRT BTH MAIL/PHY ADD

 ;   PRINT MED HX COMMENTS FR RCIS COMMENTS FILE

 ;4.0*1 2.15.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRNT ADDRESS FR PARM

 ;4.0*1 5.17.06 IHS/OIT/FCJ CALL TO OTH INS ^BMCFPRN1

 ;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

 ;

 ;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

 ;

 ;

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

 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

 ;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

 S BMCTYPE=$P($G(^BMCREF(BMCREF,0)),U,4)

 Q:BMCTYPE=""

 I BMCTYPE="I" D I Q:BMCQUIT  ;IHS Type Referrals

 I BMCTYPE'="I" D C Q:BMCQUIT  ;Contract & Other Type Referrals

 S X=$$VAL^XBDIQ1(90001,BMCREF,.02),N=0,C=0,T=64 D W Q:BMCQUIT

DATE ;

 ;Secondary Provider Date Print

 S X="Patient Services -                             Appointment Date: "_$$VAL^XBDIQ1(90001.04,BMCPROV,.06) S N=1,C=0,T=0 D W Q:BMCQUIT

 ;

 ;

 D L

PURPOSE ;

 S X="Purpose/Services Requested: "_$$VAL^XBDIQ1(90001.04,BMCPROV,.07)

 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

REFFROM ;

 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

 ;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,BMCREF,.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(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)

 ;

LINE ;CHS Supervisor Signature (if Type=CHS)

 ;Q:$P(BMCR0,U,4)'="C" ;4.0*2 IHS/OIT/FCJ

 G:$P(BMCR0,U,4)'="C" CONSULT ;4.0*2 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

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

CONSULT ;PRNT CONSULT LETTER  ;4.0*2 IHS/OIT/FCJ

 I $G(BMCPCON)=1 W # D PRINT^BMCFDRP ;BMC*4.0*4 IHS/OIT/FCJ ADDED $G

 Q

C ;

 S BMCV=BMCCPRV ;Secondary Primary Vendor - CHS only

 Q:'BMCV

 S X="Referred to:       "_$$VAL^XBDIQ1(90001.04,BMCPROV,.05)_$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="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 X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$E($$VAL^XBDIQ1(9999999.11,BMCV,1303),1,2)_" "_$$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 X=$$VAL^XBDIQ1(9999999.11,BMCV,1307)_", "_$E($$VAL^XBDIQ1(9999999.11,BMCV,1308),1,2)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1309)

 .S N=0,C=0,T=50 D W Q:BMCQUIT

 W !

 Q

I ;IHS Secondary Provider Referrals

 S BMCV=BMCCPRV

 Q:'BMCV

 S X="Referred to:       "_$$VAL^XBDIQ1(90001.04,BMCPROV,.12)_$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

 . Q

 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

BMCFPRN3  ; IHS/PHXAO/TMJ - PRINT REFERRAL FORM-EXISTING SECONDARY PROVIDER ;       [ 09/26/2006  4:15 PM ]

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**1,2,4**;JAN 09, 2006;Build 101

 +2       ;IHS/ITSC/FCJ CHG VEND SECTION TO PRT BTH MAIL/PHY ADD

 +3       ;   PRINT MED HX COMMENTS FR RCIS COMMENTS FILE

 +4       ;4.0*1 2.15.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRNT ADDRESS FR PARM

 +5       ;4.0*1 5.17.06 IHS/OIT/FCJ CALL TO OTH INS ^BMCFPRN1

 +6       ;4.0*2 IHS/OIT/FCJ ADDED CONSULT PRINT TEST

 +7       ;4.0*3 9.15.08 IHS.OIT.FCJ FX FOR UNDEF VAR WHEN QUEUED

 +8       ;

 +9       ;This Routine Prints the Actual Data for Secondary Provider Letter

 +10      ;The Main Driver Routine = BMCFDR2

 +11      ;The RCIS Output Report Defintion=SECONDARY PROVIDER LETTER-IEN #4

 +12      ;

 +13      ;

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        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       ;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        SET BMCTYPE=$PIECE($GET(^BMCREF(BMCREF,0)),U,4)

 +3        IF BMCTYPE=""

               QUIT 

 +4       ;IHS Type Referrals

           IF BMCTYPE="I"

               DO I

               IF BMCQUIT

                   QUIT 

 +5       ;Contract & Other Type Referrals

           IF BMCTYPE'="I"

               DO C

               IF BMCQUIT

                   QUIT 

 +6        SET X=$$VAL^XBDIQ1(90001,BMCREF,.02)

           SET N=0

           SET C=0

           SET T=64

           DO W

           IF BMCQUIT

               QUIT 

DATE      ;

 +1       ;Secondary Provider Date Print

 +2        SET X="Patient Services -                             Appointment Date: "_$$VAL^XBDIQ1(90001.04,BMCPROV,.06)

           SET N=1

           SET C=0

           SET T=0

           DO W

           IF BMCQUIT

               QUIT 

 +3       ;

 +4       ;

 +5        DO L

PURPOSE   ;

 +1        SET X="Purpose/Services Requested: "_$$VAL^XBDIQ1(90001.04,BMCPROV,.07)

 +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 

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(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       ;4.0*1 2.15.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRNT ADDRESS FR PARM

 +9        IF $$VAL^XBDIQ1(90001.31,BMCV,201)'=""

               Begin DoDot:1

 +10               SET X=$$VAL^XBDIQ1(90001.31,BMCV,201)

 +11               IF BMCV

                       IF X]""

                           SET N=1

                           SET C=0

                           SET T=5

                           DO W

                           IF BMCQUIT

                               QUIT 

 +12               SET X=$$VAL^XBDIQ1(90001.31,BMCV,202)

 +13               IF BMCV

                       IF X]""

                           Begin DoDot:2

 +14                           SET X=X_",  "_$$VAL^XBDIQ1(90001.31,BMCV,203)

 +15                           SET X=X_"   "_$$VAL^XBDIQ1(90001.31,BMCV,204)

 +16                           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

 +17      IF '$TEST

               IF $$VAL^XBDIQ1(9999999.06,BMCV,.14)'=""

                   Begin DoDot:1

 +18                   SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)

 +19                   IF BMCV

                           IF X]""

                               SET N=1

                               SET C=0

                               SET T=5

                               DO W

                               IF BMCQUIT

                                   QUIT 

 +20                   SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)

 +21                   IF BMCV

                           IF X]""

                               Begin DoDot:2

 +22                               SET X=X_",  "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)

 +23                               SET X=X_"   "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)

 +24                               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

 +25      ;4.0*1 2.15.06 IHS/OIT/FCJ END OF CHANGES

 +26       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 

 +27       SET X="Case Manager:  "_$$VAL^XBDIQ1(90001,BMCREF,.19)

           SET N=1

           SET T=6

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +28       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(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      ;

LINE      ;CHS Supervisor Signature (if Type=CHS)

 +1       ;Q:$P(BMCR0,U,4)'="C" ;4.0*2 IHS/OIT/FCJ

 +2       ;4.0*2 IHS/OIT/FCJ

           IF $PIECE(BMCR0,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 

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 

CONSULT   ;PRNT CONSULT LETTER  ;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 

C         ;

 +1       ;Secondary Primary Vendor - CHS only

           SET BMCV=BMCCPRV

 +2        IF 'BMCV

               QUIT 

 +3        SET X="Referred to:       "_$$VAL^XBDIQ1(90001.04,BMCPROV,.05)_$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="Mailing: "_$$VAL^XBDIQ1(9999999.11,BMCV,1301)

           SET N=1

           SET C=0

           SET T=0

           DO W

           IF BMCQUIT

               QUIT 

 +5        SET X="Physical: "_$$VAL^XBDIQ1(9999999.11,BMCV,1306)

           SET N=0

           SET C=0

           SET T=40

           DO W

           IF BMCQUIT

               QUIT 

 +6        SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$EXTRACT($$VAL^XBDIQ1(9999999.11,BMCV,1303),1,2)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)

 +7        SET N=1

           SET C=0

           SET T=9

           DO W

           IF BMCQUIT

               QUIT 

 +8        IF $$VAL^XBDIQ1(9999999.11,BMCV,1306)'=""

               Begin DoDot:1

 +9                SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1307)_", "_$EXTRACT($$VAL^XBDIQ1(9999999.11,BMCV,1308),1,2)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1309)