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

BMCFPRNP.m

Go to the documentation of this file. 
  1. BMCFPRNP ; IHS/OIT/FCJ - PRINT PHYSICIAN CONSULT LETTER ;   [ 10/31/2006  2:40 PM ]
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**2,9**;JAN 09, 2006;Build 101
  1.  ;Consultation Letter to recieve information back from the consult visit
  1.  ;letter to be sent with patient
  1.  ;BMC*4.0*9 ;IHS.OIT.FCJ ICD-10 CHANGES
  1.  ;
  1. PRINT ;print consult letter
  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="CONSULT REQUEST" S N=1,C=1 D W
  1.  S BMCFTYP=$S($E($P(^BMCTFORM(BMCFTYPE,0),U),1,4)="CALL":"CI",1:"S")
  1.  S Y=DT X ^DD("DD")
  1.  S X="DATE: "_Y S N=1,C=0,T=0 D W
  1. PHY ;PHYSICIAN INFORMATION; REFERRED TO AND REFERRED FROM
  1.  D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
  1.  ;
  1. PURPOSE ;
  1.  S X="REASON FOR REQUEST: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
  1.  I $L(X)>IOM D  I 1
  1.  .S BMCX=X S X=$E(BMCX,1,IOM),N=2,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. DX ;BMC*4.1*9 REWROTE SECTION, WAS PRINTING DRG NOT DX
  1.  ;S X="PROVISIONAL DIAGNOSIS: "_$$VAL^XBDIQ1(90001,BMCREF,.21),C=0,T=0,N=2 D W Q:BMCQUIT
  1.  I $D(^BMCDX("AD",BMCREF)) S (CT,DX)=0 F  S DX=$O(^BMCDX("AD",BMCREF,DX)) Q:DX'=+DX  S BMCD=+^BMCDX(DX,0) D  Q:BMCQUIT
  1.  .Q:$P($G(^BMCDX(DX,0)),U,4)'="P"
  1.  .S CT=CT+1,BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
  1.  .I CT=1 S X="PROVISIONAL DIAGNOSIS: "_$P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2)_" - "_$E($P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,50),C=0,T=0,N=2 D W Q
  1.  .E  S X=$P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,2)_"-"_$E($P($$ICDDX^ICDEX(BMCD,BMCDOS,,"I"),U,4),1,50),C=0,T=23,N=2 D W Q
  1.  I BMCFTYP'="CI" S X="PHYSICIAN'S SIGNATURE (ELECTONIC SIGNATURE):  "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=2,T=0,C=0 D W Q:BMCQUIT
  1. CONSULT ;CONSULT INFORMATION
  1.  S X="CONSULTATION REPORT:" S N=2,C=1,T=0 D W
  1.  S X="CONSULTING PHYSICIAN SIGNATURE:                  "
  1.  S X=X_"              DATE:" S N=10,C=0,T=0 D W Q:BMCQUIT
  1. REFFROM ;
  1.  S BMCV=$P(BMCR0,U,5)
  1.  S Y=$P(BMCR0,U,4)
  1.  S X="Return To: "_$$VAL^XBDIQ1(90001,BMCV,.05),N=2,C=0,T=0 D W
  1.  I $$VAL^XBDIQ1(90001.31,BMCV,201)'="" D
  1.  .S X=$$VAL^XBDIQ1(90001.31,BMCV,201)
  1.  .I BMCV,X]"" S N=1,C=0,T=11 D W Q:BMCQUIT
  1.  .S X=$$VAL^XBDIQ1(90001.31,BMCV,202)
  1.  .I BMCV,X]"" D
  1.  ..S X=X_",  "_$$VAL^XBDIQ1(90001.31,BMCV,203)
  1.  ..S X=X_"   "_$$VAL^XBDIQ1(90001.31,BMCV,204),N=1,C=0,T=11 D W Q:BMCQUIT
  1.  E  I $$VAL^XBDIQ1(9999999.06,BMCV,.14)'="" D
  1.  .S X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
  1.  .I BMCV,X]"" S N=1,C=0,T=11 D W Q:BMCQUIT
  1.  .S X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
  1.  .I BMCV,X]"" D
  1.  ..S X=X_",  "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)
  1.  ..S X=X_"   "_$$VAL^XBDIQ1(9999999.06,BMCV,.17),N=1,C=0,T=11 D W Q:BMCQUIT
  1.  S X=$$VAL^XBDIQ1(90001.31,BMCV,.17)
  1.  S X=X_"     (phone:  "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")",N=1,C=0,T=11 D W Q:BMCQUIT
  1.  ;
  1. DEMO ;Demographic Data
  1.  S X="Patient Name:  "_$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,T=0,N=2 D W Q:BMCQUIT
  1.  S X="DOB:  "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.03),N=0,T=54,C=0 D W Q:BMCQUIT
  1.  S X="IHS ID Number:  "_$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2),2),N=1,T=0,C=0 D W Q:BMCQUIT
  1.  S X="Referral #: "_$$VAL^XBDIQ1(90001,BMCREF,.02),N=0,C=0,T=25 D W Q:BMCQUIT
  1.  S X="Date of Service: "_$$AVDOS^BMCRLU(BMCREF,"E"),N=0,C=0,T=54 D W Q:BMCQUIT
  1.  Q
  1. TEXT ;
  1.  W ! D S
  1.  K BMCWP
  1.  S BMCCHSAS=$P($G(^BMCREF(BMCREF,11)),U,12)
  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.  ;
  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. S ;
  1.  S T=0,X=$TR($J(" ",IOM)," ","*"),N=1,C=0 D W
  1.  Q
  1. C ;
  1.  S BMCV=$P(BMCR0,U,7)
  1.  Q:'BMCV
  1.  S X="To:  "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$S($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":"  ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:""),N=2,C=0,T=0 D W Q:BMCQUIT
  1.  S X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=0,T=40,C=0 D W Q:BMCQUIT
  1.  I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")",N=1,C=0,T=5 D W Q:BMCQUIT
  1.  S X=$$VAL^XBDIQ1(9999999.11,BMCV,1301),N=1,C=0,T=5 D W Q:BMCQUIT
  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=5 D W
  1.  W !
  1.  Q
  1. I ;
  1.  S BMCV=$P(BMCR0,U,8)
  1.  Q:'BMCV
  1.  S X="To: "_$$VAL^XBDIQ1(90001,BMCREF,.08)_$S($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":"  ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"") S N=2,C=0,T=0 D W Q:BMCQUIT
  1.  S X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=0,T=40,C=0 D W Q:BMCQUIT
  1.  I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=5 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=5 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=5 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="To:  "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic",N=1,C=0,T=0 D W Q:BMCQUIT
  1.  S X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=0,T=40,C=0 D W Q:BMCQUIT
  1.  Q
  1. O ;
  1.  S BMCV=$P(BMCR0,U,7)
  1.  I BMCV D  I 1
  1.  .S X="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.  .S X="Referring Provider: "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=0,T=40,C=0 D W Q:BMCQUIT
  1.  .I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=5 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=5 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=5 D W Q:BMCQUIT
  1.  E  S X="To:  "_$$VAL^XBDIQ1(90001,BMCREF,.09),N=1,C=0,T=0 D W Q:BMCQUIT
  1.  Q
  1. WPTXT ;
  1.  ; get site-specific text (if any)
  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.  ; fall through to WP to get the text
  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