Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCFPRNA

BMCFPRNA.m

Go to the documentation of this file. 
  1. BMCFPRNA ; IHS/PHXAO/TMJ - PRINT ALT RESOURCE LETTER ;      [ 09/27/2006  2:01 PM ]
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**1,4**;JAN 09, 2006;Build 101
  1.  ;4.0*1 2.15.06 IHS/OIT/FCJ ADDED TEST TO PRNT FRM SITE PARM
  1.  ;4.0*4 9.12.08 IHS/OIT/FCJ ADDED SIR NAME TO PRINT
  1.  ;
  1. PRINT ;
  1.  ;print referral form
  1.  S BMCR0=^BMCREF(BMCREF,0),BMCPG=0,BMCDFN=$P(BMCR0,U,3)
  1.  D @("HEAD"_(2-($E(IOST,1,2)="C-")))
  1.  S BMCQUIT=0
  1.  W !!,?50,"PUBLIC HEALTH SERVICE",!,?50,"PHS INDIAN HEALTH SERVICE"
  1.  W !!!!!!!
  1.  S Y=DT D DD^%DT W Y
  1.  I BMCLTYP="M" S X="Mail Certified #: "_$$VAL^XBDIQ1(90001,BMCREF,1403),C=0,T=0,N=1 D W Q:BMCQUIT
  1.  W !
  1. DEMO ;Demographic Data
  1.  ;Age - If under 19 Print "To Parents of"
  1.  S BMCAGE=$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.033)
  1.  W:BMCAGE<20 !,"**TO THE PARENTS OF "_$$VAL^XBDIQ1(90001,BMCREF,.03),":",!
  1.  S X=$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,T=0,N=1 D W Q:BMCQUIT
  1.  ;BMC*4.0*4 IHS/OIT/FCJ ADDED SIR TO NEXT 2 LINES
  1.  S BMCFIRST=$P(X,",",2),BMCLAST=$P(X,",",1),BMCSIR=$P(X,",",3)
  1.  S X=BMCFIRST_" "_BMCLAST_" "_BMCSIR,C=0,T=0,N=1 D W Q:BMCQUIT
  1.  S:$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1602.2)]"" X=$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1602.2) S C=0,T=0,N=1 D W Q:BMCQUIT
  1.  S T=0,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
  1.  ;
  1. REFTO ;
  1.  W !
  1.  D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
  1. DATE ;
  1.  S X=$S($P(BMCR0,U,14)="I":"  Admit Date",1:"Service Date")_":   "_$$AVDOS^BMCRLU(BMCREF,"E"),N=1,C=0,T=26 D W Q:BMCQUIT
  1.  S X=" #"_$$VAL^XBDIQ1(90001,BMCREF,.02)_" "_$P($G(^BMCREF(BMCREF,1)),U),N=0,C=0,T=30 D W Q:BMCQUIT
  1.  ;
  1. PURPOSE ;Comment Out Per Rebecca Hicks 1/11/01
  1.  S X="Services:   "_$$VAL^XBDIQ1(90001,BMCREF,1201)
  1.  I $L(X)>IOM D  I 1
  1.  .S BMCX=X S X=$E(BMCX,1,IOM),N=1,C=0,T=30 D W Q:BMCQUIT
  1.  .S X=$E(BMCX,(IOM+1),IOM),N=1,C=0,T=22 D W Q:BMCQUIT
  1.  E  S C=0,N=1,T=30 D W Q:BMCQUIT
  1.  ;
  1. AMOUNT ;Estimated Amount of Service
  1.  W !
  1.  S X=$$AVICOST^BMCRLU(BMCREF),X2="2$" D COMMA^%DTC S X=" Est. Amount: "_X,N=0,C=0,T=26 D W Q:BMCQUIT
  1.  ;
  1.  W !,"Dear Patient:"
  1. TEXT ;
  1.  W !
  1.  K BMCWP
  1.  S BMCPHONE=$P($G(^BMCPARM(DUZ(2),0)),U,18) ;Contact Phone #
  1.  S BMCNODE=1,BMCFILE=90001.33,BMCDA=BMCFTYPE D WP^BMCFDRA
  1.  ;
  1.  S BMCY=0 F  S BMCY=$O(BMCWP(BMCY)) Q:BMCY'=+BMCY!(BMCQUIT)  D
  1.  .I $Y>(IOSL-3) D HEAD Q:BMCQUIT
  1.  .W !,BMCWP(BMCY)
  1.  ;
  1. LINE ;CHS Supervisor Signature (if Type=CHS)
  1.  W !!,"___A.  You must contact "_BMCCPRVP_" to schedule an appointment",!
  1.  ;
  1.  W "to complete an application.  It is very important that you keep your scheduled",!,"appointment.",!
  1.  W !,"___B.  You will need to bring the following documentation with you to your",!,"appointment: ",!
  1.  ;
  1. DOC ;Appointment Documentation Code
  1.  ;
  1.  I '$D(^BMCREF(BMCREF,15)) G TEXT2
  1.  S BMCNODE=15,BMCIOM=70,BMCFILE=90001,BMCDA=BMCREF D WP^BMCFDRA K BMCIOM
  1.  S Y=0 F  S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT)  D
  1.  .I $Y>(IOSL-3) D HEAD Q:BMCQUIT
  1.  .W !?5,BMCWP(Y)
  1.  W !
  1. TEXT2 ;
  1.  ;Determine which text to print - CHS or PBC
  1.  S BMCTEXT=""
  1.  S BMCTEXT=$P($G(^BMCPARM(DUZ(2),0)),U,29) ;Is there a Benefits Coordinator
  1.  K BMCWP
  1.  S BMCNODE=$S(BMCTEXT'="":3,1:2),BMCFILE=90001.33,BMCDA=BMCFTYPE  D WP^BMCFDRA
  1.  S BMCY=0 F  S BMCY=$O(BMCWP(BMCY)) Q:BMCY'=+BMCY!(BMCQUIT)  D
  1.  . I $Y>(IOSL-3) D HEAD Q:BMCQUIT
  1.  . W !,BMCWP(BMCY)
  1.  W BMCPHONE W ".",!
  1.  W !,?50,"Sincerely,"
  1.  W !!!!
  1.  W ?50,$S(BMCTEXT'="":$$VAL^XBDIQ1(90001.31,DUZ(2),.29),1:$P($G(^BMCPARM(DUZ(2),0)),U,28))
  1.  W !!
  1.  W "cc:  file",!
  1.  S X="______________________________",C=0,T=50,N=1 D W Q:BMCQUIT
  1.  S X="PATIENT SIGNATURE         DATE",C=0,T=50,N=1 D W Q:BMCQUIT
  1. STUFF ;Stuff Date of Print/User
  1.  S DR=""
  1.  S DIE="^BMCREF(" S DA=BMCREF,DR="1401///"_DT D ^DIE K DIE,DR,DA,DIC
  1.  ;
  1.  Q
  1. W ;
  1.  Q:X=""
  1.  NEW %
  1.  S %=$L(X)
  1.  I $Y>(IOSL-4) D HEAD Q:BMCQUIT
  1.  I N F I=1:1:N W !
  1.  I $G(C) W ?(IOM-$L(X)/2),X Q
  1.  S %=$S($G(T):T,1:0) W ?%,X
  1.  Q
  1. C ;
  1.  S BMCV=$P(BMCR0,U,7)
  1.  Q:'BMCV
  1.  S X="Provider:   "_$$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=30 D W Q:BMCQUIT
  1.  I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=42 D W Q:BMCQUIT
  1.  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=42 D W Q:BMCQUIT
  1.  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=42 D W Q:BMCQUIT
  1.  Q
  1. I ;
  1.  S BMCV=$P(BMCR0,U,8)
  1.  Q:'BMCV
  1.  S X="Provider:  "_$$VAL^XBDIQ1(90001,BMCREF,.08)_$S($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":"  ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"") S N=1,C=0,T=30 D W Q:BMCQUIT
  1.  I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=19 D W Q:BMCQUIT
  1.  ;4.0*1 2.15.06 IHS/OIT/FCJ ADDED TEST TO PRNT FRM SITE PARM
  1.  I $$VAL^XBDIQ1(90001.31,BMCV,201)]"" D
  1.  .S X=$$VAL^XBDIQ1(90001.31,BMCV,201) S N=1,C=0,T=19 D W Q:BMCQUIT
  1.  .I $$VAL^XBDIQ1(90001.31,BMCV,202)]"" S X=$$VAL^XBDIQ1(90001.31,BMCV,202)_",  "_$$VAL^XBDIQ1(90001.31,BMCV,203)_"   "_$$VAL^XBDIQ1(90001.31,BMCV,204),N=1,C=0,T=19 D W Q:BMCQUIT
  1.  E  D
  1.  .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
  1.  .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
  1.  Q
  1. N ;
  1.  S X="Provider:   "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic",N=1,C=0,T=30 D W Q:BMCQUIT
  1.  Q
  1. O ;
  1.  S BMCV=$P(BMCR0,U,7)
  1.  I BMCV D  I 1
  1.  .S X="Provider:  "_$$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=30 D W Q:BMCQUIT
  1.  .I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=19 D W Q:BMCQUIT
  1.  .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
  1.  .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
  1.  E  S X="Provider:  "_$$VAL^XBDIQ1(90001,BMCREF,.09),N=1,C=0,T=30 D W Q:BMCQUIT
  1.  Q
  1. L ;
  1.  S T=0,X=$TR($J(" ",IOM)," ","_") S N=1,C=0 D W Q:BMCQUIT
  1.  Q
  1. D ;
  1.  S T=0,X=$TR($J(" ",IOM)," ","-") S N=1,C=0 D W Q:BMCQUIT
  1.  Q
  1. S ;
  1.  S T=0,X=$TR($J(" ",IOM)," ","*") S N=1,C=0 D W Q:BMCQUIT
  1.  Q
  1.  NEW N,T,C,X,Y
  1.  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
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF
  1. HEAD2 ;
  1.  I 'BMCPG S BMCPG=BMCPG+1 Q
  1.  S BMCPG=BMCPG+1 W:$D(IOF) @IOF W !,?(IOM-20),"Page ",BMCPG
  1.  Q