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

BMCFPRN2.m

Go to the documentation of this file. 
  1. BMCFPRN2 ; IHS/OIT/FCJ - PRINT REFERRAL FORM-SECONDARY PROVIDER ;         [ 09/27/2006  2:27 PM ]
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**1,2,12**;JAN 09, 2006;Build 101
  1.  ;
  1.  ;This Routine Prints the Actual Data for Secondary Provider Letter
  1.  ;The Main Driver Routine = BMCFDR2
  1.  ;The RCIS Output Report Defintion=SECONDARY PROVIDER LETTER-IEN #4
  1.  ;4.0 IHS/FCJ/ITSC Modified to add dates, in/out pat, correct ref prov,
  1.  ;    priority and print info fr sec ref
  1.  ;4.0*1 2.15.06 IHS/OIT/FCJ ADDED PRINTING ADDRESS FR PARM
  1.  ;4.0*1 5.17.06 IHS/OIT/FCJ CALL TO OTH INS ^BMCFPRN1
  1.  ;4.0*2 9-21-06 IHS/OIT/FCJ ASK TO PRNT CONSULT LETTER
  1.  ;4.0*3 9.15.08 IHS.OIT.FCJ FX FOR UNDEF VAR WHEN QUEUED
  1.  ;
  1. PRINT ;
  1.  ;print referral form
  1.  S BMCR0=^BMCREF(BMCREF,0),BMCPG=0,BMCDFN=$P(BMCR0,U,3)
  1.  S BMCR1=^BMCREF(BMCSRIEN,0)
  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,BMCSRIEN,.01),C=0,N=0,T=67 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.  ;S X="SSN:  "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.09),C=0,T=9,N=1 D W Q:BMCQUIT   ;BMC*3.1*12
  1.  ;S X="Sex:  "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.02),N=0,T=56,C=0 D W Q:BMCQUIT  ;BMC*3.1*12
  1.  S X="Sex:  "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.02),N=1,T=56,C=0 D W Q:BMCQUIT   ;BMC*3.1*12
  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.  ;
  1.  I BMCKIND=1 D I Q:BMCQUIT  ;IHS Type Referrals
  1.  I BMCKIND=0 D C Q:BMCQUIT  ;Contract or Other Type Referrals
  1.  ;
  1. DATE ;
  1.  ;Secondary Provider Date Print
  1.  S X="Referral: "_$$VAL^XBDIQ1(90001,BMCREF,.02)_" "_$$VAL^XBDIQ1(90001,BMCSRIEN,101)  S N=0,C=0,T=40 D W Q:BMCQUIT
  1.  S X=$$VAL^XBDIQ1(90001,BMCSRIEN,.14)_" Services                     "_$S($P(BMCR1,U,14)="I":"Admission Date",1:"Appointment Date")_":  "_$$AVDOS^BMCRLU(BMCSRIEN,"E"),N=1,C=0,T=0 D W Q:BMCQUIT
  1.  ;
  1.  I $P($G(^BMCREF(BMCSRIEN,0)),U,14)="O" S X="# of Outpatient Visits: "_$$VAL^XBDIQ1(90001,BMCSRIEN,1111),C=0,T=0,N=1 D W Q:BMCQUIT
  1.  I $P(BMCR1,U,14)="I" W !
  1.  S X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCSRIEN,1107),C=0,T=40,N=0 D W Q:BMCQUIT
  1.  I $P(BMCR1,U,32)'="" S X="Priority Rating:  "_$$VAL^XBDIQ1(90001,BMCSRIEN,.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,BMCSRIEN,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 ; FROM PRIMARY AND SECONDARY REFERAL
  1.  I BMCPHX=1 S BMCREF=BMCRIEN D PERTMED1
  1.  S BMCREF=BMCSRIEN D PERTMED1
  1.  S BMCREF=BMCRIEN
  1.  G ADDMED
  1. PERTMED1 ;
  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 BMCFILE=90001.03,BMCDA=BMCCMT D PERTMEDW
  1.  Q
  1. PERTMEDW ;WRITE PERT MED INFO  
  1.  S BMCNODE=1,BMCIOM=70,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.  Q
  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. REFFROM ;
  1.  S T=0,X=$TR($J(" ",IOM)," ","_") S N=1,C=0 D W Q:BMCQUIT
  1.  S BMCV=$P(BMCR1,U,5)
  1.  S Y=$P(BMCR1,U,4)
  1.  I Y="N" S X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCSRIEN,.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:"")_")",N=1,C=0,T=0 D W Q:BMCQUIT
  1.  ;
  1.  ;4.0*1 2.15.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRNT ADDRESS FR PARM
  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=5 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)
  1.  ..S X=X_"     (phone:  "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")",N=1,C=0,T=5 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=5 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)
  1.  ..S X=X_"     (phone:  "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")",N=1,C=0,T=5 D W Q:BMCQUIT
  1.  ;4.0*1 2.15.06 IHS/OIT/FCJ END OF CHANGES
  1.  S X="Referring Provider (ELECTRONIC SIGNATURE):  "_$$VAL^XBDIQ1(90001,BMCSRIEN,.06),N=1,T=6,C=0 D W Q:BMCQUIT
  1.  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 ;CALL BMCFPRN1 TO PRINT OTHER PAYOR INFORMATION
  1.  ;4.0*1 5.17.06 IHS/OIT/FCJ REM PAYOR SECTION AND ADDED CALL
  1.  D OTHPAY^BMCFPRN1
  1. TEXT ;
  1.  W ! D S
  1.  K BMCWP
  1.  S BMCCHSAS=$P($G(^BMCREF(BMCSRIEN,11)),U,12)
  1.  ;BMC 4.0*12 IN THE NEXT 3 LINES CHANGED BMCR0 TO BMCR1
  1.  I $P(BMCR1,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(BMCR1,U,4)="O" S BMCNODE=2,BMCFILE=90001.33,BMCDA=BMCFTYPE D WPTXT
  1.  I $P(BMCR1,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. LINE ;CHS Supervisor Signature (if Type=CHS)
  1.  ;Q:$P(BMCR1,U,4)'="C" ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ
  1.  G:$P(BMCR1,U,4)'="C" CONSULT ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ
  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.  ;D W  ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ ADDED LINE
  1. CONSULT ;PRNT CONSULT LETTER ;BMC*4.0*2 9-21-06 IHS/OIT/FCJ
  1.  I $G(BMCPCON)=1 W # D PRINT^BMCFDRP  ;BMC*4.0*4 IHS/OIT/FCJ ADDED $G
  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.  Q:'BMCCPRV
  1.  S BMCV=BMCCPRV ;Secondary Primary Vendor - CHS only
  1.  S X="Referred to:   "_BMCCPRVP_$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 BMCCPRVS'="" S X="Specific Provider:  "_BMCCPRVS S N=1,C=0,T=0 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.  S BMCVIEN=$P(^AUTTVNDR(BMCV,13),U,3)
  1.  S X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
  1.  S N=1,C=0,T=9 D W Q:BMCQUIT
  1.  I $$VAL^XBDIQ1(9999999.11,BMCV,1306)'="" D
  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 Q:BMCQUIT
  1.  W !
  1.  Q
  1.  ;
  1. I ;IHS Secondary Provider Referrals
  1.  Q:'BMCCPRV
  1.  S BMCV=BMCCPRV
  1.  S X="Referred to:       "_$$VAL^XBDIQ1(90001,BMCRSIEN,.08)_$S($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":"  ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"") S N=1,C=0,T=0 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. 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 ;
  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