BMCFAHC3 ; IHS/PHXAO/TMJ - RE-PRINT SECONDARY PROVIDER REFERRALAHCCCS 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
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=F,T=33,N=1,C=0 D W Q:BMCQUIT
S X=$$VAL^XBDIQ1(90001.04,BMCPROV,.06),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.04,BMCPROV,.07),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)
;
MCDPNX ;
Q Y
C ;
S BMCV=$P($G(^BMCPROV(BMCPROV,0)),U,5)
I 'BMCV S F="<??? UNKNOWN>",A="???",P="???" Q
S F=$$VAL^XBDIQ1(90001.04,BMCPROV,.05)_$S($$VAL^XBDIQ1(90001.04,BMCPROV,.05)]"":"-"_$$VAL^XBDIQ1(90001.04,BMCPROV,.05),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($G(^BMCPROV(BMCPROV,0)),U,8)
I 'BMCV S F="<?? UNKNOWN>",A="???",P="???" Q
S F=$$VAL^XBDIQ1(90001.04,BMCPROV,.12)_$S($$VAL^XBDIQ1(90001.04,BMCPROV,.12)]"":$$VAL^XBDIQ1(90001.04,BMCPROV,.12),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
BMCFAHC3 ; IHS/PHXAO/TMJ - RE-PRINT SECONDARY PROVIDER REFERRALAHCCCS 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 SET BMCTYPE=$PIECE($GET(^BMCREF(BMCREF,0)),U,4)
+7 IF BMCTYPE=""
QUIT
+8 ;IHS Type Referrals
IF BMCTYPE="I"
DO I
IF BMCQUIT
QUIT
+9 ;Contract & Other Type Referrals
IF BMCTYPE'="I"
DO C
IF BMCQUIT
QUIT
+10 SET X=F
SET T=33
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+11 SET X=$$VAL^XBDIQ1(90001.04,BMCPROV,.06)
SET T=85
SET C=0
SET N=0
DO W
IF BMCQUIT
QUIT
+12 SET X="ADDRESS"
SET T=16
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+13 SET X=A
SET T=33
SET N=0
SET C=0
DO W
IF BMCQUIT
QUIT
+14 SET X="TELEPHONE: "_P
SET T=100
SET N=0
SET C=0
DO W
IF BMCQUIT
QUIT
+15 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.04,BMCPROV,.07)
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)
QUIT ""
+4 IF '$GET(D)
QUIT ""
+5 SET F=$GET(F)
+6 NEW I,J,Y
+7 SET Y=""
SET U="^"
+8 IF '$DATA(^DPT(P,0))
GOTO MCDPNX
+9 IF $PIECE(^DPT(P,0),U,19)
GOTO MCDPNX
+10 IF '$DATA(^AUPNPAT(P,0))
GOTO MCDPNX
+11 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCDPNX
+12 SET I=0
+13 FOR
SET I=$ORDER(^AUPNMCD("B",P,I))
IF I'=+I
QUIT
Begin DoDot:1
+14 IF '$DATA(^AUPNMCD(I,11))
QUIT
+15 SET J=0
+16 FOR
SET J=$ORDER(^AUPNMCD(I,11,J))
IF J'=+J
QUIT
Begin DoDot:2
+17 IF J>D
QUIT
+18 IF $PIECE(^AUPNMCD(I,11,J,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+19 SET Y=$PIECE(^AUPNMCD(I,0),U,10)
+20 IF Y]""
SET Y=$SELECT(F="E":$PIECE(^AUTNINS(Y,0),U),1:Y)_"^"_$PIECE(^AUPNMCD(I,0),U,3)
End DoDot:2
End DoDot:1
+21 ;
MCDPNX ;
+1 QUIT Y
C ;
+1 SET BMCV=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,5)
+2 IF 'BMCV
SET F="<??? UNKNOWN>"
SET A="???"
SET P="???"
QUIT
+3 SET F=$$VAL^XBDIQ1(90001.04,BMCPROV,.05)_$SELECT($$VAL^XBDIQ1(90001.04,BMCPROV,.05)]"":"-"_$$VAL^XBDIQ1(90001.04,BMCPROV,.05),1:"")
+4 SET 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)
+5 SET P=$$VAL^XBDIQ1(9999999.11,BMCV,1309)
+6 QUIT
I ;
+1 SET BMCV=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,8)
+2 IF 'BMCV
SET F="<?? UNKNOWN>"
SET A="???"
SET P="???"
QUIT
+3 SET F=$$VAL^XBDIQ1(90001.04,BMCPROV,.12)_$SELECT($$VAL^XBDIQ1(90001.04,BMCPROV,.12)]"":$$VAL^XBDIQ1(90001.04,BMCPROV,.12),1:"")
+4 SET 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)
+5 SET P=$$VAL^XBDIQ1(9999999.06,BMCV,.13)
+6 QUIT
N ;
+1 SET F="IN HOUSE REFERRAL - "_$$VAL^XBDIQ1(90001,BMCREF,.21)
+2 SET (A,P)=""
+3 QUIT
O ;
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF BMCV
Begin DoDot:1
+3 SET F=$$VAL^XBDIQ1(90001,BMCREF,.07)_$SELECT($$VAL^XBDIQ1(90001,BMCREF,.09)]"":"-"_$$VAL^XBDIQ1(90001,BMCREF,.09),1:"")
+4 SET 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)
+5 SET P=$$VAL^XBDIQ1(9999999.11,BMCV,1309)
End DoDot:1
IF 1
+6 IF '$TEST
SET F=$$VAL^XBDIQ1(90001,BMCREF,.09)
SET A=""
SET P=""
+7 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
WP ;EP - Entry point to print wp fields pass node in BMCWP
+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
