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

BMCFUTL.m

Go to the documentation of this file. 
  1. BMCFUTL ; IHS/OIT/FCJ - PRINT REFERRAL FORM UTILITY ROUTINE;        [ 09/22/2006  4:24 PM ]
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
  1.  ;4.0*3 12.10.2007 IHS.OIT.FCJ ADDED EP LABEL TO LINES I, N, O, C, PRINT, REFFROM, TEXT AND WPTXT
  1.  ;
  1. PRINT ;EP
  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.  S X=$P(^BMCTFORM(BMCFTYPE,0),U,2) S N=0,C=1 D W
  1.  S X=$$VAL^XBDIQ1(90001,BMCREF,.01),C=0,N=0,T=66 D W
  1.  D S Q:BMCQUIT
  1. DEMO ;Demographic Data
  1.  Q:BMCQUIT
  1.  S X="Patient Identification, Address, Phone",C=1,T=0,N=1 D W Q:BMCQUIT
  1.  S X="Patient Name:  "_$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,T=0,N=1 D W Q:BMCQUIT
  1.  S X="ID Number:  "_$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2),2),N=0,T=50,C=0 D W Q:BMCQUIT
  1.  I $P($G(^BMCPARM(DUZ(2),4100)),U,2)="" S X="SSN:  "_"",C=0,T=9,N=1 D W Q:BMCQUIT
  1.  I $P($G(^BMCPARM(DUZ(2),4100)),U,2)="Y" S X="SSN:  "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.09),C=0,T=9,N=1 D W Q:BMCQUIT
  1.  S X="Sex:  "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.02),N=0,T=56,C=0 D W Q:BMCQUIT
  1.  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
  1.  S X="DOB:  "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.03),N=0,T=56,C=0 D W Q:BMCQUIT
  1.  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
  1.  S X="Hm Phone: "_$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1606.2) S C=0,T=51,N=0 D W Q:BMCQUIT
  1.  ;
  1. REFTO ;
  1.  D L
  1.  D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
  1.  S X=$$VAL^XBDIQ1(90001,BMCREF,.02),N=0,C=0,T=64 D W Q:BMCQUIT
  1. DATE ;
  1.  S X=$$VAL^XBDIQ1(90001,BMCREF,.14)_" Services                     "_$S($P(BMCR0,U,14)="I":"Admission Date",1:"Appointment Date")_":  "_$$AVDOS^BMCRLU(BMCREF,"E"),N=1,C=0,T=0 D W Q:BMCQUIT
  1.  ;
  1.  I $P($G(^BMCREF(BMCREF,0)),U,14)="O" S X="# of Outpatient Visits: "_$$VAL^XBDIQ1(90001,BMCREF,1111),C=0,T=0,N=1 D W Q:BMCQUIT
  1.  I $P($G(^BMCREF(BMCREF,0)),U,14)="I" W !
  1.  S X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCREF,1107),C=0,T=40,N=0 D W Q:BMCQUIT
  1.  I $P($G(^BMCREF(BMCREF,0)),U,32)'="" S X="Priority Rating:  "_$$VAL^XBDIQ1(90001,BMCREF,.32),C=0,T=0,N=1 D W Q:BMCQUIT
  1.  D L
  1. PURPOSE ;
  1.  S X="Purpose/Services Requested: "_$$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=0 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=0 D W Q:BMCQUIT
  1. PERTMED ;
  1.  S BMCCMT=0
  1.  F  S BMCCMT=$O(^BMCCOM("AD",BMCREF,BMCCMT)) Q:BMCCMT'?1N.N  D
  1.  .Q:$P(^BMCCOM(BMCCMT,0),U,5)'="M"
  1.  .S BMCNODE=1,BMCIOM=70,BMCFILE=90001.03,BMCDA=BMCCMT,BMCNODE=1
  1.  .D WP 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. ADDMED ;
  1.  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
  1.  Q:BMCFTYP="CI"
  1. REFFROM ;EP
  1.  S T=0,X=$TR($J(" ",IOM)," ","_") S N=1,C=0 D W Q:BMCQUIT
  1.  S BMCV=$P(BMCR0,U,5)
  1.  S Y=$P(BMCR0,U,4)
  1.  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
  1.  ;
  1.  S X="If you have any questions concerning this referral, please contact:",N=1,C=0,T=0 D W Q:BMCQUIT
  1.  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
  1.  S X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
  1.  I BMCV,X]"" S N=1,C=0,T=5 D W Q:BMCQUIT
  1.  S X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
  1.  I BMCV,X]"" S X=X_",  "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)_"   "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)_"     (phone:  "_$$VAL^XBDIQ1(90001.31,DUZ(2),.18)_")",N=1,C=0,T=5 D W Q:BMCQUIT
  1.  I BMCTYP'="CI" S X="Referring Provider (ELECTRONIC SIGNATURE):  "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=1,T=6,C=0 D W Q:BMCQUIT
  1.  I BMCTYP'="CI" S X="Case Manager:  "_$$VAL^XBDIQ1(90001,BMCREF,.19),N=1,T=6,C=0 D W Q:BMCQUIT
  1.  S X="Veteran: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),1901),N=0,T=56,C=0 D W Q:BMCQUIT
  1. PAYOR ;OTHER PAYOR INFORMATION
  1.  D OTHPAY^BMCFPRN1
  1.  Q:BMCQUIT
  1.  Q
  1. TEXT ;EP
  1.  W ! D S
  1.  K BMCWP
  1.  S BMCCHSAS=$P($G(^BMCREF(BMCREF,11)),U,12)
  1.  ;
  1.  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
  1.  I $P(BMCR0,U,4)="O" S BMCNODE=2,BMCFILE=90001.33,BMCDA=BMCFTYPE D WPTXT
  1.  I $P(BMCR0,U,4)="I"!($P(BMCR0,U,4)="N") W ! S BMCWP(1)=""
  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.  Q:BMCFTYP="CI"
  1.  ;
  1. LINE ;CHS Supervisor Signature (if Type=CHS)
  1.  G:$P(BMCR0,U,4)'="C" ROUT
  1.  W !!!!!
  1.  S X="____________________",C=0,T=50,N=1 D W Q:BMCQUIT
  1.  W !
  1.  S X="Contract Health Service Office",C=0,T=50,N=1 D W Q:BMCQUIT
  1. ROUT ;Print Routing slip
  1.  I BMCPROUT=1 W # D PRINT^BMCFDRS
  1. W ;Entry Point
  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 ;EP
  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=0 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.  S X="Mailing: "_$$VAL^XBDIQ1(9999999.11,BMCV,1301) S N=1,C=0,T=0 D W Q:BMCQUIT
  1.  S X="Physical: "_$$VAL^XBDIQ1(9999999.11,BMCV,1306) S N=0,C=0,T=40 D W Q:BMCQUIT
  1.  ;IHS/ITSC/FCJ MOD TO NOT REQUIRE ADDRESS FOR VENDOR
  1.  I $G(^AUTTVNDR(BMCV,13))'="" D  Q:BMCQUIT
  1.  .S BMCVIEN=$P(^AUTTVNDR(BMCV,13),U,3)
  1.  .S X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "
  1.  .I BMCVIEN'="" S X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
  1.  .S N=1,C=0,T=9 D W
  1.  .I $$VAL^XBDIQ1(9999999.11,BMCV,1306)'="" D  Q:BMCQUIT
  1.  ..S BMCVIEN=$P(^AUTTVNDR(BMCV,13),U,8)
  1.  ..S X=$$VAL^XBDIQ1(9999999.11,BMCV,1307)_", "
  1.  ..I BMCVIEN'="" S X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)
  1.  ..S X=X_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1309)
  1.  ..S:X'?1A.E X=""
  1.  ..S N=0,C=0,T=50 D W
  1.  W !
  1.  Q
  1. I ;EP
  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:""),N=1,C=0,T=0 D W Q:BMCQUIT
  1.  I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")",N=1,C=0,T=19 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=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 ;EP
  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=0 D W Q:BMCQUIT
  1.  Q
  1. O ;EP
  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:""),N=1,C=0,T=0 D W Q:BMCQUIT
  1.  .I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")",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="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. WPTXT ;EP
  1.  ; site-specific txt
  1.  I $P(BMCR0,U,4)="C" D
  1.  .I BMCCHSAS="A",$D(^BMCPARM(DUZ(2),31)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=31
  1.  .I BMCCHSAS="D",$D(^BMCPARM(DUZ(2),32)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=32
  1.  .I BMCCHSAS="P"!(BMCCHSAS=""),$D(^BMCPARM(DUZ(2),33)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=33
  1.  I $P(BMCR0,U,4)="O",$D(^BMCPARM(DUZ(2),33)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=34
  1. WP ;
  1.  D WP^BMCFDR
  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