BMCFDRS ; IHS/PHXAO/TMJ - DRIVER TO PRINT ROUTING SLIP ;
;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
;IHS/ITSC/FCJ MOD ADDL DOC SECTION WAS NOT FORMATING CORRECTLY
;4.0*3 3.19.2007 IHS/OIT/FCJ REMOVED KILL OF BMCCHSA VAR IN KILL LINE
;
; This program prints a routing slip that lists the
; additional documentation which will accompany a referral.
;
START ;EP - ENTRY POINT FROM OPTION LIST
W:$D(IOF) @IOF
W "********** ROUTING SLIP PRINT **********",!!
W "This report will produce a hard copy computer-generated routing slip.",!
S BMCQUIT=0
GETREF ;
W !! S BMCREF=""
S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select Referral by Patient Name, Date of Referral or Referral #: " D ^DIC K DA,DIC
G:Y=-1 XIT
S BMCREF=+Y
ZIS ;
W !! S XBRC="COMP^BMCFDRS",XBRP="PRINT^BMCFDRS",XBNS="BMC",XBRX="XIT^BMCFDRS"
D ^XBDBQUE
Q
COMP ;
Q
XIT ;
K BMCAR,BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS,BMCCHSAP
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
Q
;
;
;-------------------------------------------------------
PRINT ;EP - PRINT ROUTING SLIP
S BMCR0=^BMCREF(BMCREF,0),BMCPG=0,BMCDFN=$P(BMCR0,U,3)
D @("HEAD"_(2-($E(IOST,1,2)="C-")))
S BMCQUIT=0
S X="Routing Slip for Contract Health",C=1,N=1,T=0 D W Q:BMCQUIT
D S
Q:BMCQUIT
DEMO ;Demographic Data
S X="Patient Name: "_$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,N=1,T=3 D W Q:BMCQUIT
S X="ID Number: "_$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2),2),C=0,N=0,T=55 D W Q:BMCQUIT
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
S X="Date Initiated: "_$$VAL^XBDIQ1(90001,BMCREF,.01),C=0,N=0,T=50 D W
;
DATE ;
S X="Appointment Date: "_$$AVDOS^BMCRLU(BMCREF),C=0,N=1,T=48 D W Q:BMCQUIT
;
W !
REFTO ;
D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
D L Q:BMCQUIT
;
; get listed documents here...
F BMCY=401:1:412 D Q:BMCQUIT
.I $Y>(IOSL-3) D HEAD Q:BMCQUIT
.W !!,"____"_$S($$VALI^XBDIQ1(90001,BMCREF,BMCY)="Y":"X",1:"_")_"______ ",$P($T(DOCLIST+(BMCY-400)),";",3),?60,"__________"
.Q
;
ADDLDOC ; get any additional documents
K BMCAR D ENP^XBDIQ1(90001,BMCREF,501,"BMCAR(","E")
W !!,"Additional Documentation:"
S BMCY="" F S BMCY=$O(BMCAR(501,BMCY)) Q:BMCY=""!(BMCQUIT) D
.I $Y>(IOSL-3) D HEAD Q:BMCQUIT
.W !,BMCAR(501,BMCY)
PRTDISP ; bottom of routing slip - include space to write in disposition
N IX W !!,"Disposition: " F IX=1:1:57 W "_"
W !!," " F IX=1:1:57 W "_"
W !!," " F IX=1:1:57 W "_"
K IX
Q
;---------------------------------------------------------------
W ;
Q:X=""
NEW %
S %=$L(X)
I $Y>(IOSL-4) D HEAD Q:BMCQUIT
I N F I=1:1:N W !
I $G(C) W ?(IOM-$L(X)/2),X Q
S %=$S($G(T):T,1:0) W ?%,X
Q
C ;
S BMCV=$P(BMCR0,U,7)
Q:'BMCV
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
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=17 D W Q:BMCQUIT
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
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
Q
I ;
S BMCV=$P(BMCR0,U,8)
Q:'BMCV
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
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=17 D W Q:BMCQUIT
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
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
Q
N ;
S X="IN HOUSE REFERRAL",N=1,C=0,T=0 D W Q:BMCQUIT
S X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic",N=1,C=0,T=3 D W Q:BMCQUIT
Q
O ;
S BMCV=$P(BMCR0,U,7)
I BMCV D I 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
.I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=17 D W Q:BMCQUIT
.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
.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
E S X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.09),N=1,C=0,T=0 D W Q:BMCQUIT
Q
L ;
S T=0,X=$TR($J(" ",IOM)," ","_") S N=1,C=0 D W Q:BMCQUIT
Q
D ;
S T=0,X=$TR($J(" ",IOM)," ","-") S N=1,C=0 D W Q:BMCQUIT
Q
S ;
S T=0,X=$TR($J(" ",IOM)," ","*") S N=1,C=0 D W Q:BMCQUIT
Q
HEAD ;
NEW N,T,C,X,Y
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
HEAD1 ;
W:$D(IOF) @IOF
HEAD2 ;
I 'BMCPG S BMCPG=BMCPG+1 Q
S BMCPG=BMCPG+1 W:$D(IOF) @IOF W !,?(IOM-20),"Page ",BMCPG
Q
DOCLIST ;
;;PCC Visit Form
;;Specialty Clinic Notes
;;Prenatal Record(s)
;;Signed Tubal Consent
;;Face Sheet
;;Health Summary
;;Most Recent EKG
;;History and Physical
;;X-Ray / Report
;;X-Ray Film
;;Consultation Report
;;Most Recent Lab Report
Q
BMCFDRS ; IHS/PHXAO/TMJ - DRIVER TO PRINT ROUTING SLIP ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
+2 ;IHS/ITSC/FCJ MOD ADDL DOC SECTION WAS NOT FORMATING CORRECTLY
+3 ;4.0*3 3.19.2007 IHS/OIT/FCJ REMOVED KILL OF BMCCHSA VAR IN KILL LINE
+4 ;
+5 ; This program prints a routing slip that lists the
+6 ; additional documentation which will accompany a referral.
+7 ;
START ;EP - ENTRY POINT FROM OPTION LIST
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE "********** ROUTING SLIP PRINT **********",!!
+3 WRITE "This report will produce a hard copy computer-generated routing slip.",!
+4 SET BMCQUIT=0
GETREF ;
+1 WRITE !!
SET BMCREF=""
+2 SET DIC="^BMCREF("
SET DIC(0)="AEMQ"
SET DIC("A")="Select Referral by Patient Name, Date of Referral or Referral #: "
DO ^DIC
KILL DA,DIC
+3 IF Y=-1
GOTO XIT
+4 SET BMCREF=+Y
ZIS ;
+1 WRITE !!
SET XBRC="COMP^BMCFDRS"
SET XBRP="PRINT^BMCFDRS"
SET XBNS="BMC"
SET XBRX="XIT^BMCFDRS"
+2 DO ^XBDBQUE
+3 QUIT
COMP ;
+1 QUIT
XIT ;
+1 KILL BMCAR,BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS,BMCCHSAP
+2 KILL 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
+3 QUIT
+4 ;
+5 ;
+6 ;-------------------------------------------------------
PRINT ;EP - PRINT ROUTING SLIP
+1 SET BMCR0=^BMCREF(BMCREF,0)
SET BMCPG=0
SET BMCDFN=$PIECE(BMCR0,U,3)
+2 DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+3 SET BMCQUIT=0
+4 SET X="Routing Slip for Contract Health"
SET C=1
SET N=1
SET T=0
DO W
IF BMCQUIT
QUIT
+5 DO S
+6 IF BMCQUIT
QUIT
DEMO ;Demographic Data
+1 SET X="Patient Name: "_$$VAL^XBDIQ1(90001,BMCREF,.03)
SET C=0
SET N=1
SET T=3
DO W
IF BMCQUIT
QUIT
+2 SET X="ID Number: "_$$HRN^AUPNPAT($PIECE(BMCR0,U,3),DUZ(2),2)
SET C=0
SET N=0
SET T=55
DO W
IF BMCQUIT
QUIT
+3 SET X="Referral Number: "_$$VAL^XBDIQ1(90001,BMCREF,.02)_" "_$PIECE($GET(^BMCREF(BMCREF,1)),U)
SET C=0
SET N=1
SET T=0
DO W
IF BMCQUIT
QUIT
+4 SET X="Date Initiated: "_$$VAL^XBDIQ1(90001,BMCREF,.01)
SET C=0
SET N=0
SET T=50
DO W
+5 ;
DATE ;
+1 SET X="Appointment Date: "_$$AVDOS^BMCRLU(BMCREF)
SET C=0
SET N=1
SET T=48
DO W
IF BMCQUIT
QUIT
+2 ;
+3 WRITE !
REFTO ;
+1 DO @$$VALI^XBDIQ1(90001,BMCREF,.04)
IF BMCQUIT
QUIT
+2 DO L
IF BMCQUIT
QUIT
+3 ;
+4 ; get listed documents here...
+5 FOR BMCY=401:1:412
Begin DoDot:1
+6 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+7 WRITE !!,"____"_$SELECT($$VALI^XBDIQ1(90001,BMCREF,BMCY)="Y":"X",1:"_")_"______ ",$PIECE($TEXT(DOCLIST+(BMCY-400)),";",3),?60,"__________"
+8 QUIT
End DoDot:1
IF BMCQUIT
QUIT
+9 ;
ADDLDOC ; get any additional documents
+1 KILL BMCAR
DO ENP^XBDIQ1(90001,BMCREF,501,"BMCAR(","E")
+2 WRITE !!,"Additional Documentation:"
+3 SET BMCY=""
FOR
SET BMCY=$ORDER(BMCAR(501,BMCY))
IF BMCY=""!(BMCQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+5 WRITE !,BMCAR(501,BMCY)
End DoDot:1
PRTDISP ; bottom of routing slip - include space to write in disposition
+1 NEW IX
WRITE !!,"Disposition: "
FOR IX=1:1:57
WRITE "_"
+2 WRITE !!," "
FOR IX=1:1:57
WRITE "_"
+3 WRITE !!," "
FOR IX=1:1:57
WRITE "_"
+4 KILL IX
+5 QUIT
+6 ;---------------------------------------------------------------
W ;
+1 IF X=""
QUIT
+2 NEW %
+3 SET %=$LENGTH(X)
+4 IF $Y>(IOSL-4)
DO HEAD
IF BMCQUIT
QUIT
+5 IF N
FOR I=1:1:N
WRITE !
+6 IF $GET(C)
WRITE ?(IOM-$LENGTH(X)/2),X
QUIT
+7 SET %=$SELECT($GET(T):T,1:0)
WRITE ?%,X
+8 QUIT
C ;
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF 'BMCV
QUIT
+3 SET X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:"")
SET N=1
SET C=0
SET T=3
DO W
IF BMCQUIT
QUIT
+4 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
+5 IF $$VAL^XBDIQ1(9999999.11,BMCV,1301)]""
SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1301)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1310)]"":", "_$$VAL^XBDIQ1(9999999.11,BMCV,1310),1:"")
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
+6 IF $$VAL^XBDIQ1(9999999.11,BMCV,1302)]""
SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(9999999.11,BMCV,1303)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
+7 QUIT
I ;
+1 SET BMCV=$PIECE(BMCR0,U,8)
+2 IF 'BMCV
QUIT
+3 SET X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.08)_$SELECT($$VAL^XBDIQ1(9999999.06,BMCV,.13)]"":" ("_$$VAL^XBDIQ1(9999999.06,BMCV,.13)_")",1:"")
SET N=1
SET C=0
SET T=3
DO W
IF BMCQUIT
QUIT
+4 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
+5 IF $$VAL^XBDIQ1(9999999.06,BMCV,.14)]""
SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
+6 IF $$VAL^XBDIQ1(9999999.06,BMCV,.15)]""
SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
+7 QUIT
N ;
+1 SET X="IN HOUSE REFERRAL"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+2 SET X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic"
SET N=1
SET C=0
SET T=3
DO W
IF BMCQUIT
QUIT
+3 QUIT
O ;
+1 SET BMCV=$PIECE(BMCR0,U,7)
+2 IF BMCV
Begin DoDot:1
+3 SET X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.07)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1109)]"":" ("_$$VAL^XBDIQ1(9999999.11,BMCV,1109)_")",1:"")
SET N=1
SET C=0
SET T=3
DO W
IF BMCQUIT
QUIT
+4 IF $PIECE(BMCR0,U,9)
SET X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")"
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
+5 IF $$VAL^XBDIQ1(9999999.11,BMCV,1301)]""
SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1301)_$SELECT($$VAL^XBDIQ1(9999999.11,BMCV,1310)]"":", "_$$VAL^XBDIQ1(9999999.11,BMCV,1310),1:"")
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
+6 IF $$VAL^XBDIQ1(9999999.11,BMCV,1302)]""
SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "_$$VAL^XBDIQ1(9999999.11,BMCV,1303)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
SET N=1
SET C=0
SET T=17
DO W
IF BMCQUIT
QUIT
End DoDot:1
IF 1
+7 IF '$TEST
SET X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.09)
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+8 QUIT
L ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","_")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 QUIT
D ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 QUIT
S ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","*")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 QUIT
HEAD ;
+1 NEW N,T,C,X,Y
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BMCQUIT=1
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
HEAD2 ;
+1 IF 'BMCPG
SET BMCPG=BMCPG+1
QUIT
+2 SET BMCPG=BMCPG+1
IF $DATA(IOF)
WRITE @IOF
WRITE !,?(IOM-20),"Page ",BMCPG
+3 QUIT
DOCLIST ;
+1 ;;PCC Visit Form
+2 ;;Specialty Clinic Notes
+3 ;;Prenatal Record(s)
+4 ;;Signed Tubal Consent
+5 ;;Face Sheet
+6 ;;Health Summary
+7 ;;Most Recent EKG
+8 ;;History and Physical
+9 ;;X-Ray / Report
+10 ;;X-Ray Film
+11 ;;Consultation Report
+12 ;;Most Recent Lab Report
+13 QUIT
