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

BMCFDRS.m

Go to the documentation of this file. 
  1. BMCFDRS ; IHS/PHXAO/TMJ - DRIVER TO PRINT ROUTING SLIP ;  
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
  1.  ;IHS/ITSC/FCJ MOD ADDL DOC SECTION WAS NOT FORMATING CORRECTLY
  1.  ;4.0*3 3.19.2007 IHS/OIT/FCJ REMOVED KILL OF BMCCHSA VAR IN KILL LINE
  1.  ;
  1.  ; This program prints a routing slip that lists the
  1.  ; additional documentation which will accompany a referral.
  1.  ;
  1. START ;EP - ENTRY POINT FROM OPTION LIST
  1.  W:$D(IOF) @IOF
  1.  W "********** ROUTING SLIP PRINT **********",!!
  1.  W "This report will produce a hard copy computer-generated routing slip.",!
  1.  S BMCQUIT=0
  1. GETREF ;
  1.  W !! S BMCREF=""
  1.  S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select Referral by Patient Name, Date of Referral or Referral #: " D ^DIC K DA,DIC
  1.  G:Y=-1 XIT
  1.  S BMCREF=+Y
  1. ZIS ;     
  1.  W !! S XBRC="COMP^BMCFDRS",XBRP="PRINT^BMCFDRS",XBNS="BMC",XBRX="XIT^BMCFDRS"
  1.  D ^XBDBQUE
  1.  Q
  1. COMP ;
  1.  Q
  1. XIT ;
  1.  K BMCAR,BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS,BMCCHSAP
  1.  K A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT,F,G,I,J,N,P,T,X,Y,Z
  1.  Q
  1.  ;
  1.  ;
  1.  ;-------------------------------------------------------
  1. PRINT ;EP - PRINT ROUTING SLIP
  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.  S X="Routing Slip for Contract Health",C=1,N=1,T=0 D W Q:BMCQUIT
  1.  D S
  1.  Q:BMCQUIT
  1. DEMO ;Demographic Data
  1.  S X="Patient Name:  "_$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,N=1,T=3 D W Q:BMCQUIT
  1.  S X="ID Number:  "_$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2),2),C=0,N=0,T=55 D W Q:BMCQUIT
  1.  S X="Referral Number:  "_$$VAL^XBDIQ1(90001,BMCREF,.02)_" "_$P($G(^BMCREF(BMCREF,1)),U),C=0,N=1,T=0 D W Q:BMCQUIT
  1.  S X="Date Initiated:  "_$$VAL^XBDIQ1(90001,BMCREF,.01),C=0,N=0,T=50 D W
  1.  ;
  1. DATE ;
  1.  S X="Appointment Date:  "_$$AVDOS^BMCRLU(BMCREF),C=0,N=1,T=48 D W Q:BMCQUIT
  1.  ;
  1.  W !
  1. REFTO ;
  1.  D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
  1.  D L Q:BMCQUIT
  1.  ;
  1.  ; get listed documents here...
  1.  F BMCY=401:1:412 D  Q:BMCQUIT
  1.  .I $Y>(IOSL-3) D HEAD Q:BMCQUIT
  1.  .W !!,"____"_$S($$VALI^XBDIQ1(90001,BMCREF,BMCY)="Y":"X",1:"_")_"______   ",$P($T(DOCLIST+(BMCY-400)),";",3),?60,"__________"
  1.  .Q
  1.  ;
  1. ADDLDOC ; get any additional documents
  1.  K BMCAR D ENP^XBDIQ1(90001,BMCREF,501,"BMCAR(","E")
  1.  W !!,"Additional Documentation:"
  1.  S BMCY="" F  S BMCY=$O(BMCAR(501,BMCY)) Q:BMCY=""!(BMCQUIT)  D
  1.  .I $Y>(IOSL-3) D HEAD Q:BMCQUIT
  1.  .W !,BMCAR(501,BMCY)
  1. PRTDISP ; bottom of routing slip - include space to write in disposition
  1.  N IX W !!,"Disposition: " F IX=1:1:57 W "_"
  1.  W !!,"             " F IX=1:1:57 W "_"
  1.  W !!,"             " F IX=1:1:57 W "_"
  1.  K IX
  1.  Q
  1.  ;---------------------------------------------------------------
  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="Referred to:  "_$$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=3 D W Q:BMCQUIT
  1.  I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=17 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=17 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=17 D W Q:BMCQUIT
  1.  Q
  1. I ;
  1.  S BMCV=$P(BMCR0,U,8)
  1.  Q:'BMCV
  1.  S X="Referred to:  "_$$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=3 D W Q:BMCQUIT
  1.  I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=17 D W Q:BMCQUIT
  1.  I $$VAL^XBDIQ1(9999999.06,BMCV,.14)]"" S X=$$VAL^XBDIQ1(9999999.06,BMCV,.14) S N=1,C=0,T=17 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=17 D W Q:BMCQUIT
  1.  Q
  1. N ;
  1.  S X="IN HOUSE REFERRAL",N=1,C=0,T=0 D W Q:BMCQUIT
  1.  S X="Referred to:  "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic",N=1,C=0,T=3 D W Q:BMCQUIT
  1.  Q
  1. O ;
  1.  S BMCV=$P(BMCR0,U,7)
  1.  I BMCV D  I 1
  1.  .S X="Referred to:  "_$$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=3 D W Q:BMCQUIT
  1.  .I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=17 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=17 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=17 D W Q:BMCQUIT
  1.  E  S X="Referred to:  "_$$VAL^XBDIQ1(90001,BMCREF,.09),N=1,C=0,T=0 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
  1. DOCLIST ;
  1.  ;;PCC Visit Form
  1.  ;;Specialty Clinic Notes
  1.  ;;Prenatal Record(s)
  1.  ;;Signed Tubal Consent
  1.  ;;Face Sheet
  1.  ;;Health Summary
  1.  ;;Most Recent EKG
  1.  ;;History and Physical
  1.  ;;X-Ray / Report
  1.  ;;X-Ray Film
  1.  ;;Consultation Report
  1.  ;;Most Recent Lab Report
  1.  Q