BMCFAHC1.m

BMCFAHC1 ; IHS/PHXAO/TMJ - PRINT REFERRAL FORM ;      

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;IHS/ITSC/FCJ MED HX COMMENTS FR RCIS COMMENTS FILE

 ;

PRINT ;EP

 ;print AHCCCS FORM

 S BMCR0=^BMCREF(BMCREF,0),BMCPG=0

 D @("HEAD"_(2-($E(IOST,1,2)="C-")))

 S BMCQUIT=0

 D L

 S X="AHCCCS REFERRAL DATE" S T=3,N=1,C=0 D W

 S X="ARIZONA HEALTH CARE COST CONTAINMENT SYSTEM",T=45,N=0,C=0 D W Q:BMCQUIT

 S X=$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2)),T=110,C=0,N=0 D W Q:BMCQUIT

 S Y=DT D DD^%DT S X=Y,T=5,C=0,N=1 D W Q:BMCQUIT

 S X="REFERRAL FORM",C=0,T=61,N=0 D W Q:BMCQUIT

 S X="MEDICAL RECORD NO",C=0,T=105,N=0 D W Q:BMCQUIT

 D L Q:BMCQUIT

REFTO ;

 S X="REFERRED TO:",N=1,T=3,C=0 D W Q:BMCQUIT

 S X="PROVIDER ID NO.",N=0,T=16,C=0 D W Q:BMCQUIT

 S X="PROVIDER NAME/FACILITY",N=0,C=0,T=33 D W Q:BMCQUIT

 S X="APPOINTMENT DATE",N=0,C=0,T=85 D W Q:BMCQUIT

 S X="APPOINTMENT TIME",N=0,T=105,C=0 D W Q:BMCQUIT

 D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT

 S X=F,T=33,N=1,C=0 D W Q:BMCQUIT

 S X=$$FMTE^XLFDT($$AVDOS^BMCRLU(BMCREF,"I"),"5D"),T=85,C=0,N=0 D W Q:BMCQUIT

 S X="ADDRESS",T=16,N=1,C=0 D W Q:BMCQUIT

 S X=A,T=33,N=0,C=0 D W Q:BMCQUIT

 S X="TELEPHONE:  "_P,T=100,N=0,C=0 D W Q:BMCQUIT

 S X=P,T=112,N=0,C=0 D W Q:BMCQUIT

MEMBER ;

 D L

 S X="Member Information:",N=1,T=3,C=0 D W Q:BMCQUIT

 S X="Member ID NO.",N=0,T=23,C=0 D W Q:BMCQUIT

 S X="Member Name",N=0,T=40,C=0 D W Q:BMCQUIT

 S X="Birth Date   ",N=0,T=105,C=0 D W Q:BMCQUIT

 S BMCX=$$MCDPN($P(BMCR0,U,3),$S($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:$P(BMCR0,U)),"E")

 S X=$P(BMCX,U,2),N=1,T=3,C=0 D W Q:BMCQUIT

 S X=$P(^DPT($P(BMCR0,U,3),0),U),N=0,T=40,C=0 D W Q:BMCQUIT

 K BMCX S X=$$FMTE^XLFDT($$DOB^AUPNPAT($P(BMCR0,U,3),"I"),"5D"),T=105,C=0,N=0 D W Q:BMCQUIT

 D L

PCP ;

 S X="PRIMARY CARE PHYSICIAN",N=1,T=3,C=0 D W Q:BMCQUIT

 S X="ID NO.",N=1,T=3,C=0 D W Q:BMCQUIT

 S X="LOC.",N=0,T=12,C=0 D W Q:BMCQUIT

 S X="NAME",N=0,T=18,C=0 D W Q:BMCQUIT

 S X="ADDRESS",T=50,C=0,N=0 D W Q:BMCQUIT

 S X="TELEPHONE",T=97,C=0,N=0 D W Q:BMCQUIT

 S X="CONTRACTED PROV NO.",T=110,C=0,N=0 D W Q:BMCQUIT

 S X=$$VAL^XBDIQ1(90001.31,DUZ(2),1101),T=3,N=1,C=0 D W Q:BMCQUIT

 S X=$$VAL^XBDIQ1(90001.31,DUZ(2),1102),T=12,N=0,C=0 D W Q:BMCQUIT

 S X=$$VAL^XBDIQ1(90001.31,DUZ(2),1103),T=18,N=0,C=0 D W Q:BMCQUIT

 S X=$$VAL^XBDIQ1(90001.31,DUZ(2),1104),T=50,N=0,C=0 D W Q:BMCQUIT

 S X=$$VAL^XBDIQ1(90001.31,DUZ(2),1105),T=97,N=0,C=0 D W Q:BMCQUIT

 S X=$$VAL^XBDIQ1(90001.31,DUZ(2),1106),T=115,N=0,C=0 D W Q:BMCQUIT

 D L

REFPROV ;

 S X="To be completed by referring provider:",N=1,T=3,C=0 D W Q:BMCQUIT

 S X="Chief Complaint, Diagnosis and Other Relevant Information",T=50,C=0,N=0 D W Q:BMCQUIT

 S X="PURPOSE OF REFERRAL:   "_$$VAL^XBDIQ1(90001,BMCREF,1201),T=10,C=0,N=1 D W Q:BMCQUIT

PERTMED ;

 ;IHS/ITSC/FCJ MED HX COMMENTS FR RCIS COMMENTS FILE

 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=115,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)

REQSRV ;

 S X="Requested Services: "_$$VAL^XBDIQ1(90001,BMCREF,.13),C=0,T=10,N=2 D W Q:BMCQUIT

 D L

TEXT ;

 K BMCWP

 S BMCNODE=1,BMCIOM=125,BMCFILE=90001.33,BMCDA=BMCFTYPE D WP I 1

 S BMCY=0 F  S BMCY=$O(BMCWP(BMCY)) Q:BMCY'=+BMCY!(BMCQUIT)  D

 .I $Y>(IOSL-3) D HEAD Q:BMCQUIT

 .W !?3,BMCWP(BMCY)

 S X="_______________________________________________________________                          ___________",N=2,C=0,T=3 D W Q:BMCQUIT

 S X="Referring Provider Signature",N=1,T=3,C=0 D W Q:BMCQUIT

 D L

PERPROV ;

 S X="TO BE COMPLETED BY PERFORMING PROVIDER (Attach additional information if required.)",N=1,T=3 D W Q:BMCQUIT

 S X="Treatment and Recommendations",T=3,N=1,C=0 D W Q:BMCQUIT

 D L W ! D L W !

 S X="Diagnosis",T=3,N=1,C=0 D W Q:BMCQUIT

 W ! D L

MORE ;

 S X="Was an additional AHCCCS referral made?  ______  YES  ______  NO",T=3,C=0,N=1 D W Q:BMCQUIT

 S X="If yes, was Primary Care Provider approval received? ___ YES  ___ NO by  ___ PHONE  ___ OTHER Appt. Date/Time _______________ ",T=3,N=1,C=0 D W Q:BMCQUIT

 K BMCWP

 W !

 S BMCNODE=2,BMCIOM=125,BMCFILE=90001.33,BMCDA=BMCFTYPE D WP I 1

 S BMCY=0 F  S BMCY=$O(BMCWP(BMCY)) Q:BMCY'=+BMCY!(BMCQUIT)  D

 .I $Y>(IOSL-3) D HEAD Q:BMCQUIT

 .W !?3,BMCWP(BMCY)

 S X="_______________________________________________________________                          ___________",N=2,C=0,T=3 D W Q:BMCQUIT

 S X="Performing Provider Signature",N=1,T=3,C=0 D W Q:BMCQUIT

 S X="NO. AZ-108",T=112,N=0,C=0 D W Q:BMCQUIT

 Q

W ;

 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

MCDPN(P,D,F) ;(P,D,F) return medicaid plan name for patient P on date D in form F.

 ; I = IEN

 ; J = Node 11 IEN

 I '$G(P) Q ""

 I '$G(D) Q ""

 S F=$G(F)

 NEW I,J,Y

 S Y="",U="^"

 I '$D(^DPT(P,0)) G MCDPNX

 I $P(^DPT(P,0),U,19) G MCDPNX

 I '$D(^AUPNPAT(P,0)) G MCDPNX

 I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDPNX

 S I=0

 F  S I=$O(^AUPNMCD("B",P,I)) Q:I'=+I  D

 . Q:'$D(^AUPNMCD(I,11))

 . S J=0

 . F  S J=$O(^AUPNMCD(I,11,J)) Q:J'=+J  D

 .. Q:J>D

 .. I $P(^AUPNMCD(I,11,J,0),U,2)]"",$P(^(0),U,2)<D Q

 .. S Y=$P(^AUPNMCD(I,0),U,10)

 .. I Y]"" S Y=$S(F="E":$P(^AUTNINS(Y,0),U),1:Y)_"^"_$P(^AUPNMCD(I,0),U,3)

 ..Q

 .Q

 ;

MCDPNX ;

 Q Y

C ;

 S BMCV=$P(BMCR0,U,7)

 I 'BMCV S F="<??? UNKNOWN>",A="???",P="???" Q

 S F=$$VAL^XBDIQ1(90001,BMCREF,.07)_$S($$VAL^XBDIQ1(90001,BMCREF,.09)]"":"-"_$$VAL^XBDIQ1(90001,BMCREF,.09),1:"")

 S A=$$VAL^XBDIQ1(9999999.11,BMCV,1301)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(9999999.11,BMCV,1303)_"  "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)

 S P=$$VAL^XBDIQ1(9999999.11,BMCV,1309)

 Q

I ;

 S BMCV=$P(BMCR0,U,8)

 Q:'BMCV

 S F=$$VAL^XBDIQ1(90001,BMCREF,.08)_$S($$VAL^XBDIQ1(90001,BMCREF,.09)]"":$$VAL^XBDIQ1(90001,BMCREF,.09),1:"")

 S A=$$VAL^XBDIQ1(9999999.06,BMCV,.14)_"  "_$$VAL^XBDIQ1(9999999.06,BMCV,.15)_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)_"  "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)

 S P=$$VAL^XBDIQ1(9999999.06,BMCV,.13)

 Q

N ;

 S F="IN HOUSE REFERRAL - "_$$VAL^XBDIQ1(90001,BMCREF,.21)

 S (A,P)=""

 Q

O ;

 S BMCV=$P(BMCR0,U,7)

 I BMCV D  I 1

 .S F=$$VAL^XBDIQ1(90001,BMCREF,.07)_$S($$VAL^XBDIQ1(90001,BMCREF,.09)]"":"-"_$$VAL^XBDIQ1(90001,BMCREF,.09),1:"")

 .S A=$$VAL^XBDIQ1(9999999.11,BMCV,1301)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(9999999.11,BMCV,1303)_"  "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)

 .S P=$$VAL^XBDIQ1(9999999.11,BMCV,1309)

 E  S F=$$VAL^XBDIQ1(90001,BMCREF,.09),A="",P=""

 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

WP ;EP - Entry point to print wp fields pass node in BMCWP

 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

BMCFAHC1  ; IHS/PHXAO/TMJ - PRINT REFERRAL FORM ;      

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;IHS/ITSC/FCJ MED HX COMMENTS FR RCIS COMMENTS FILE

 +3       ;

PRINT     ;EP

 +1       ;print AHCCCS FORM

 +2        SET BMCR0=^BMCREF(BMCREF,0)

           SET BMCPG=0

 +3        DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))

 +4        SET BMCQUIT=0

 +5        DO L

 +6        SET X="AHCCCS REFERRAL DATE"

           SET T=3

           SET N=1

           SET C=0

           DO W

 +7        SET X="ARIZONA HEALTH CARE COST CONTAINMENT SYSTEM"

           SET T=45

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +8        SET X=$$HRN^AUPNPAT($PIECE(BMCR0,U,3),DUZ(2))

           SET T=110

           SET C=0

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +9        SET Y=DT

           DO DD^%DT

           SET X=Y

           SET T=5

           SET C=0

           SET N=1

           DO W

           IF BMCQUIT

               QUIT 

 +10       SET X="REFERRAL FORM"

           SET C=0

           SET T=61

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +11       SET X="MEDICAL RECORD NO"

           SET C=0

           SET T=105

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +12       DO L

           IF BMCQUIT

               QUIT 

REFTO     ;

 +1        SET X="REFERRED TO:"

           SET N=1

           SET T=3

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +2        SET X="PROVIDER ID NO."

           SET N=0

           SET T=16

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +3        SET X="PROVIDER NAME/FACILITY"

           SET N=0

           SET C=0

           SET T=33

           DO W

           IF BMCQUIT

               QUIT 

 +4        SET X="APPOINTMENT DATE"

           SET N=0

           SET C=0

           SET T=85

           DO W

           IF BMCQUIT

               QUIT 

 +5        SET X="APPOINTMENT TIME"

           SET N=0

           SET T=105

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +6        DO @$$VALI^XBDIQ1(90001,BMCREF,.04)

           IF BMCQUIT

               QUIT 

 +7        SET X=F

           SET T=33

           SET N=1

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +8        SET X=$$FMTE^XLFDT($$AVDOS^BMCRLU(BMCREF,"I"),"5D")

           SET T=85

           SET C=0

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +9        SET X="ADDRESS"

           SET T=16

           SET N=1

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +10       SET X=A

           SET T=33

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +11       SET X="TELEPHONE:  "_P

           SET T=100

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +12       SET X=P

           SET T=112

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

MEMBER    ;

 +1        DO L

 +2        SET X="Member Information:"

           SET N=1

           SET T=3

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +3        SET X="Member ID NO."

           SET N=0

           SET T=23

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +4        SET X="Member Name"

           SET N=0

           SET T=40

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +5        SET X="Birth Date   "

           SET N=0

           SET T=105

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +6        SET BMCX=$$MCDPN($PIECE(BMCR0,U,3),$SELECT($$AVDOS^BMCRLU(BMCREF,"I")]"":$$AVDOS^BMCRLU(BMCREF,"I"),1:$PIECE(BMCR0,U)),"E")

 +7        SET X=$PIECE(BMCX,U,2)

           SET N=1

           SET T=3

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +8        SET X=$PIECE(^DPT($PIECE(BMCR0,U,3),0),U)

           SET N=0

           SET T=40

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +9        KILL BMCX

           SET X=$$FMTE^XLFDT($$DOB^AUPNPAT($PIECE(BMCR0,U,3),"I"),"5D")

           SET T=105

           SET C=0

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +10       DO L

PCP       ;

 +1        SET X="PRIMARY CARE PHYSICIAN"

           SET N=1

           SET T=3

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +2        SET X="ID NO."

           SET N=1

           SET T=3

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +3        SET X="LOC."

           SET N=0

           SET T=12

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +4        SET X="NAME"

           SET N=0

           SET T=18

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +5        SET X="ADDRESS"

           SET T=50

           SET C=0

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +6        SET X="TELEPHONE"

           SET T=97

           SET C=0

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +7        SET X="CONTRACTED PROV NO."

           SET T=110

           SET C=0

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +8        SET X=$$VAL^XBDIQ1(90001.31,DUZ(2),1101)

           SET T=3

           SET N=1

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +9        SET X=$$VAL^XBDIQ1(90001.31,DUZ(2),1102)

           SET T=12

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +10       SET X=$$VAL^XBDIQ1(90001.31,DUZ(2),1103)

           SET T=18

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +11       SET X=$$VAL^XBDIQ1(90001.31,DUZ(2),1104)

           SET T=50

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +12       SET X=$$VAL^XBDIQ1(90001.31,DUZ(2),1105)

           SET T=97

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +13       SET X=$$VAL^XBDIQ1(90001.31,DUZ(2),1106)

           SET T=115

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +14       DO L

REFPROV   ;

 +1        SET X="To be completed by referring provider:"

           SET N=1

           SET T=3

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +2        SET X="Chief Complaint, Diagnosis and Other Relevant Information"

           SET T=50

           SET C=0

           SET N=0

           DO W

           IF BMCQUIT

               QUIT 

 +3        SET X="PURPOSE OF REFERRAL:   "_$$VAL^XBDIQ1(90001,BMCREF,1201)

           SET T=10

           SET C=0

           SET N=1

           DO W

           IF BMCQUIT

               QUIT 

PERTMED   ;

 +1       ;IHS/ITSC/FCJ MED HX COMMENTS FR RCIS COMMENTS FILE

 +2        SET BMCCMT=0

 +3        FOR 

               SET BMCCMT=$ORDER(^BMCCOM("AD",BMCREF,BMCCMT))

               IF BMCCMT'?1N.N

                   QUIT 

               Begin DoDot:1

 +4                IF $PIECE(^BMCCOM(BMCCMT,0),U,5)'="M"

                       QUIT 

 +5                SET BMCNODE=1

                   SET BMCIOM=115

                   SET BMCFILE=90001.03

                   SET BMCDA=BMCCMT

                   SET BMCNODE=1

 +6                DO WP

                   KILL BMCIOM

 +7                SET Y=0

                   FOR 

                       SET Y=$ORDER(BMCWP(Y))

                       IF Y'=+Y!(BMCQUIT)

                           QUIT 

                       Begin DoDot:2

 +8                        IF $Y>(IOSL-3)

                               DO HEAD

                               IF BMCQUIT

                                   QUIT 

 +9                        WRITE !?5,BMCWP(Y)

                       End DoDot:2

               End DoDot:1

REQSRV    ;

 +1        SET X="Requested Services: "_$$VAL^XBDIQ1(90001,BMCREF,.13)

           SET C=0

           SET T=10

           SET N=2

           DO W

           IF BMCQUIT

               QUIT 

 +2        DO L

TEXT      ;

 +1        KILL BMCWP

 +2        SET BMCNODE=1

           SET BMCIOM=125

           SET BMCFILE=90001.33

           SET BMCDA=BMCFTYPE

           DO WP

           IF 1

 +3        SET BMCY=0

           FOR 

               SET BMCY=$ORDER(BMCWP(BMCY))

               IF BMCY'=+BMCY!(BMCQUIT)

                   QUIT 

               Begin DoDot:1

 +4                IF $Y>(IOSL-3)

                       DO HEAD

                       IF BMCQUIT

                           QUIT 

 +5                WRITE !?3,BMCWP(BMCY)

               End DoDot:1

 +6        SET X="_______________________________________________________________                          ___________"

           SET N=2

           SET C=0

           SET T=3

           DO W

           IF BMCQUIT

               QUIT 

 +7        SET X="Referring Provider Signature"

           SET N=1

           SET T=3

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +8        DO L

PERPROV   ;

 +1        SET X="TO BE COMPLETED BY PERFORMING PROVIDER (Attach additional information if required.)"

           SET N=1

           SET T=3

           DO W

           IF BMCQUIT

               QUIT 

 +2        SET X="Treatment and Recommendations"

           SET T=3

           SET N=1

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +3        DO L

           WRITE !

           DO L

           WRITE !

 +4        SET X="Diagnosis"

           SET T=3

           SET N=1

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +5        WRITE !

           DO L

MORE      ;

 +1        SET X="Was an additional AHCCCS referral made?  ______  YES  ______  NO"

           SET T=3

           SET C=0

           SET N=1

           DO W

           IF BMCQUIT

               QUIT 

 +2        SET X="If yes, was Primary Care Provider approval received? ___ YES  ___ NO by  ___ PHONE  ___ OTHER Appt. Date/Time _______________ "

           SET T=3

           SET N=1

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +3        KILL BMCWP

 +4        WRITE !

 +5        SET BMCNODE=2

           SET BMCIOM=125

           SET BMCFILE=90001.33

           SET BMCDA=BMCFTYPE

           DO WP

           IF 1

 +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 !?3,BMCWP(BMCY)

               End DoDot:1

 +9        SET X="_______________________________________________________________                          ___________"

           SET N=2

           SET C=0

           SET T=3

           DO W

           IF BMCQUIT

               QUIT 

 +10       SET X="Performing Provider Signature"

           SET N=1

           SET T=3

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +11       SET X="NO. AZ-108"

           SET T=112

           SET N=0

           SET C=0

           DO W

           IF BMCQUIT

               QUIT 

 +12       QUIT 

W         ;

 +1        NEW %

 +2        SET %=$LENGTH(X)

 +3        IF $Y>(IOSL-4)

               DO HEAD

               IF BMCQUIT

                   QUIT 

 +4        IF N

               FOR I=1:1:N

                   WRITE !

 +5        IF $GET(C)

               WRITE ?(IOM-$LENGTH(X)/2),X

               QUIT 

 +6        SET %=$SELECT($GET(T):T,1:0)

           WRITE ?%,X

 +7        QUIT 

MCDPN(P,D,F) ;(P,D,F) return medicaid plan name for patient P on date D in form F.

 +1       ; I = IEN

 +2       ; J = Node 11 IEN

 +3        IF '$GET(P)