BMCFPRN ; IHS/OIT/FCJ - PRINT REFERRAL FORMS ; [ 09/27/2006 1:33 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1,2,3,4,12**;JAN 09, 2006;Build 101
;IHS/OIT/FCJ CHG VEND SECTION TO PRT BTH MAIL/PHY ADD, SPLIT
; RTN AT PAYOR LINE COPIED TO BMCFRPN1 FR PAYOR THRU RR LINE
; PRNT MED HX FR RCIS COMMENTS FILE; ADDED TEST FOR VENDOR ADDRESS
;4.0*1 2.15.06 IHS/OIT/FCJ COMBINED CALL IN REF AND PRINT OF NEW
; ADDRESS PARAMETERS
;BMC*4.0*2 9.14.06 IHS.OIT.FCJ ADDED SECTION TO PRINT CONSULT LTR
;BMC*4.0*3 8.10.07 IHS.OIT.FCJ ADDED NPI AND INS AUTH
;BMC*4.0*3 9.15.08 IHS.OIT.FCJ FX FOR UNDEF VAR WHEN QUEUED
;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Modifications to allow printing from EHR GUI
;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
;
;GDIT/HS/BEE 10/19/17 - p12 CR#5450: Renamed old PRINT tag to PRT
; created separate R&S (PRINT) and GUI (GPRINT) entry pts
PRINT ;EP print referral form - Roll and Scroll Front End
;
NEW PRTGUI,PGL
S PRTGUI=0
;
;Page length
S PGL=IOSL
;
;Print the Letter
D PRT
Q
;
GPRINT(BMCREF) ;EP print referral form - GUI
;
NEW PRTGUI,BMCFTYPE,BMCPROUT,PGL
S PRTGUI=1
;
S PGL=56
;
;Get the standard referral letter
S BMCFTYPE=$O(^BMCTFORM("B","STANDARD IHS REFERRAL LETTER","")) Q:BMCFTYPE=""
;
;Do not print routing slip
S BMCPROUT=0
;
;Print the Letter
D PRT
Q
;
;GDIT/HS/BEE 10/19/17 - p12 CR#5450;Old PRINT tag changed to PRT
;PRINT ;print referral form
PRT ;print referral form
NEW REFTO,BMCCHSAS,BMCCMT,BMCDA,BMCDFN,BMCFILE,BMCFTYP,BMCNODE,BMCPCON,BMCPG,BMCQUIT,BMCR0,BMCV,BMCVIEN,BMCX,BMCY
NEW DTOUT,I,X
;
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=$P(^BMCTFORM(BMCFTYPE,0),U,2) S N=0,C=1 D W
S BMCFTYP=$S($E($P(^BMCTFORM(BMCFTYPE,0),U),1,4)="CALL":"CI",1:"S")
S X=$$VAL^XBDIQ1(90001,BMCREF,.01),C=0,N=0,T=66 D W
D S
DEMO ;Demographic Data
Q:BMCQUIT
S X="Patient Identification, Address, Phone",C=1,T=0,N=1 D W Q:BMCQUIT
S X="Patient Name: "_$$VAL^XBDIQ1(90001,BMCREF,.03),C=0,T=0,N=1 D W Q:BMCQUIT
S X="ID Number: "_$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2),2),N=0,T=50,C=0 D W Q:BMCQUIT
I $P($G(^BMCPARM(DUZ(2),4100)),U,2)="" S X="SSN: "_"",C=0,T=9,N=1 D W Q:BMCQUIT
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
S X="Sex: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.02),N=0,T=56,C=0 D W Q:BMCQUIT
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
S X="DOB: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.03),N=0,T=56,C=0 D W Q:BMCQUIT
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
S X="Hm Phone: "_$$VAL^XBDIQ1(9000001,$P(BMCR0,U,3),1606.2) S C=0,T=51,N=0 D W Q:BMCQUIT
;
REFTO ;
D L
;GDIT/HS/BEE 10/19/17 - p12:Fixed code to address SAC issue
;D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
S REFTO=$$VALI^XBDIQ1(90001,BMCREF,.04)
D @REFTO Q:BMCQUIT
S X=$$VAL^XBDIQ1(90001,BMCREF,.02),N=0,C=0,T=64 D W Q:BMCQUIT
DATE ;
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
;
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
I $P($G(^BMCREF(BMCREF,0)),U,14)="I" W !
S X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCREF,1107),C=0,T=40,N=0 D W Q:BMCQUIT
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
;BMC*4.0*3 8.10.2007 IHS/OIT/FCJ ADDED NXT LINE
I $P($G(^BMCREF(BMCREF,14)),U,5)'="" S X="Insurance Auth No: "_$$VAL^XBDIQ1(90001,BMCREF,1405),C=0,T=40,N=0 D W Q:BMCQUIT
D L
PURPOSE ;
S X="Purpose/Services Requested: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
I $L(X)>IOM D I 1
.S BMCX=X S X=$E(BMCX,1,IOM),N=1,C=0,T=0 D W Q:BMCQUIT
.S X=$E(BMCX,(IOM+1),IOM),N=1,C=0,T=22 D W Q:BMCQUIT
E S C=0,N=1,T=0 D W Q:BMCQUIT
PERTMED ;
S BMCCMT=0
F S BMCCMT=$O(^BMCCOM("AD",BMCREF,BMCCMT)) Q:BMCCMT'?1N.N D
.Q:$P(^BMCCOM(BMCCMT,0),U,5)'="M"
.S BMCNODE=1,BMCIOM=70,BMCFILE=90001.03,BMCDA=BMCCMT,BMCNODE=1
.D WP K BMCIOM
.S Y=0 F S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT) D
..I $Y>($S($G(PGL)]"":PGL,1:IOSL)-3) D HEAD Q:BMCQUIT ;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Changed IOSL to PGL
..W !?5,BMCWP(Y)
ADDMED ;
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
REFFROM ;
S T=0,X=$TR($J(" ",IOM)," ","_") S N=1,C=0 D W Q:BMCQUIT
S BMCV=$P(BMCR0,U,5)
S Y=$P(BMCR0,U,4)
;BMC*4.0*3 8.10.2007 IHS/OIT/FCJ SPLIT NEXT LINE TO PRINT NPI IF AVAIL
I Y="N" D Q:BMCQUIT G PAYOR
.S X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=1,T=0,C=0 D W Q:BMCQUIT
.W "XXXXX"
.S I=$P(BMCR0,U,6) I I,$P($G(^VA(200,I,"NPI")),U) S X="NPI: "_$P(^VA(200,I,"NPI"),U),N=1,T=0,C=0 D W
;
S X="If you have any questions concerning this referral, please contact:",N=1,C=0,T=0 D W Q:BMCQUIT
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
;4.0*1 2.15.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRNT ADDRESS FR PARM
I $$VAL^XBDIQ1(90001.31,BMCV,201)'="" D
.S X=$$VAL^XBDIQ1(90001.31,BMCV,201)
.I BMCV,X]"" S N=1,C=0,T=5 D W Q:BMCQUIT
.S X=$$VAL^XBDIQ1(90001.31,BMCV,202)
.I BMCV,X]"" D
..S X=X_", "_$$VAL^XBDIQ1(90001.31,BMCV,203)
..S X=X_" "_$$VAL^XBDIQ1(90001.31,BMCV,204)
..S X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")",N=1,C=0,T=5 D W Q:BMCQUIT
E I $$VAL^XBDIQ1(9999999.06,BMCV,.14)'="" D
.S X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
.I BMCV,X]"" S N=1,C=0,T=5 D W Q:BMCQUIT
.S X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
.I BMCV,X]"" D
..S X=X_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)
..S X=X_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)
..S X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")",N=1,C=0,T=5 D W Q:BMCQUIT
;4.0*1 2.15.06 IHS/OIT/FCJ END OF CHANGES
I BMCFTYP'="CI" S X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06),N=1,T=6,C=0 D W Q:BMCQUIT
;BMC*4.0*3 8.10.2007 IHS/OIT/FCJ ADDED NXT LINE
I BMCFTYP'="CI" S I=$P(BMCR0,U,6) I I,$P($G(^VA(200,I,"NPI")),U) S X="NPI: "_$P(^VA(200,I,"NPI"),U),N=1,T=6,C=0 D W Q:BMCQUIT
I BMCFTYP'="CI" S X="Case Manager: "_$$VAL^XBDIQ1(90001,BMCREF,.19),N=1,T=6,C=0 D W Q:BMCQUIT
S X="Veteran: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),1901),N=1,T=56,C=0 D W
Q:BMCQUIT
PAYOR ;OTHER PAYOR INFORMATION
D OTHPAY^BMCFPRN1
Q:BMCQUIT
TEXT ;
W ! D S
K BMCWP
S BMCCHSAS=$P($G(^BMCREF(BMCREF,11)),U,12)
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
I $P(BMCR0,U,4)="O" S BMCNODE=2,BMCFILE=90001.33,BMCDA=BMCFTYPE D WPTXT
I $P(BMCR0,U,4)="I"!($P(BMCR0,U,4)="N") W ! S BMCWP(1)=""
;
S BMCY=0 F S BMCY=$O(BMCWP(BMCY)) Q:BMCY'=+BMCY!(BMCQUIT) D
.I $Y>($S($G(PGL)]"":PGL,1:IOSL)-3) D HEAD Q:BMCQUIT ;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Changed IOSL to PGL
.W !,BMCWP(BMCY)
;
LINE ;CHS Supervisor Signature (if Type=CHS)
G:$P(BMCR0,U,4)'="C" ROUT
W !!!!!
G:BMCFTYP="CI" ROUT
S X="____________________",C=0,T=50,N=1 D W Q:BMCQUIT
W !
S X="Contract Health Service Office",C=0,T=50,N=1 D W Q:BMCQUIT
ROUT ;Print Routing slip
I BMCPROUT=1 W # D PRINT^BMCFDRS
;BMC*4.0*2 9.14.06 IHS.OIT.FCJ ADDED NXT SECTION TO PRINT CONSULT LTR
CONSULT ;PRINT CONSULT LETTER
I $G(BMCPCON)=1 W # D PRINT^BMCFDRP ;BMC*4.0*4 IHS.OIT.FCJ CHANGED TO $G
Q
W ;Entry Point
Q:X=""
NEW %
S %=$L(X)
I $Y>($S($G(PGL)]"":PGL,1:IOSL)-4) D HEAD Q:BMCQUIT ;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Changed IOSL to PGL
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:""),N=1,C=0,T=0 D W Q:BMCQUIT
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")",N=1,C=0,T=19 D W Q:BMCQUIT
S X="Mailing: "_$$VAL^XBDIQ1(9999999.11,BMCV,1301),N=1,C=0,T=0 D W Q:BMCQUIT
S X="Physical: "_$$VAL^XBDIQ1(9999999.11,BMCV,1306),N=0,C=0,T=40 D W Q:BMCQUIT
;IHS/ITSC/FCJ MOD TO NOT REQUIRE ADDRESS FOR VENDOR
I $G(^AUTTVNDR(BMCV,13))'="" D Q:BMCQUIT
.S BMCVIEN=$P(^AUTTVNDR(BMCV,13),U,3)
.S X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "
.I BMCVIEN'="" S X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
.S N=1,C=0,T=9 D W
.I $$VAL^XBDIQ1(9999999.11,BMCV,1306)'="" D Q:BMCQUIT
..S BMCVIEN=$P(^AUTTVNDR(BMCV,13),U,8)
..S X=$$VAL^XBDIQ1(9999999.11,BMCV,1307)_", "
..I BMCVIEN'="" S X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)
..S X=X_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1309)
..S:X'?1A.E X=""
..S N=0,C=0,T=50 D W
W !
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=0 D W Q:BMCQUIT
I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=19 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=19 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=19 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=0 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=0 D W Q:BMCQUIT
.I $P(BMCR0,U,9) S X="("_$$VAL^XBDIQ1(90001,BMCREF,.09)_")" S N=1,C=0,T=19 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=19 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=19 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)," ","_"),N=1,C=0 D W Q:BMCQUIT
Q
D ;
S T=0,X=$TR($J(" ",IOM)," ","-"),N=1,C=0 D W Q:BMCQUIT
Q
S ;
S T=0,X=$TR($J(" ",IOM)," ","*"),N=1,C=0 D W Q:BMCQUIT
Q
WPTXT ;
; get site-specific text (if any)
I $P(BMCR0,U,4)="C" D
.I BMCCHSAS="A",$D(^BMCPARM(DUZ(2),31)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=31
.I BMCCHSAS="D",$D(^BMCPARM(DUZ(2),32)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=32
.I BMCCHSAS="P"!(BMCCHSAS=""),$D(^BMCPARM(DUZ(2),33)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=33
I $P(BMCR0,U,4)="O",$D(^BMCPARM(DUZ(2),33)) S BMCFILE=90001.31,BMCDA=DUZ(2),BMCNODE=34
; fall through to WP to get the text
WP ;
D WP^BMCFDR
Q
;
;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Added references to PRTGUI to control GUI display formatting
;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
HEAD I $G(PRTGUI) Q
NEW N,T,C,X,Y
I '$G(PRTGUI),$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 ;
I '$G(PRTGUI) W:$D(IOF) @IOF
HEAD2 ;
I 'BMCPG S BMCPG=BMCPG+1 Q
S BMCPG=BMCPG+1 I '$G(PRTGUI) W:$D(IOF) @IOF W !,?(IOM-20),"Page ",BMCPG
;End of CR#5450 changes
Q
BMCFPRN ; IHS/OIT/FCJ - PRINT REFERRAL FORMS ; [ 09/27/2006 1:33 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1,2,3,4,12**;JAN 09, 2006;Build 101
+2 ;IHS/OIT/FCJ CHG VEND SECTION TO PRT BTH MAIL/PHY ADD, SPLIT
+3 ; RTN AT PAYOR LINE COPIED TO BMCFRPN1 FR PAYOR THRU RR LINE
+4 ; PRNT MED HX FR RCIS COMMENTS FILE; ADDED TEST FOR VENDOR ADDRESS
+5 ;4.0*1 2.15.06 IHS/OIT/FCJ COMBINED CALL IN REF AND PRINT OF NEW
+6 ; ADDRESS PARAMETERS
+7 ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ ADDED SECTION TO PRINT CONSULT LTR
+8 ;BMC*4.0*3 8.10.07 IHS.OIT.FCJ ADDED NPI AND INS AUTH
+9 ;BMC*4.0*3 9.15.08 IHS.OIT.FCJ FX FOR UNDEF VAR WHEN QUEUED
+10 ;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Modifications to allow printing from EHR GUI
+11 ;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
+12 ;
+13 ;GDIT/HS/BEE 10/19/17 - p12 CR#5450: Renamed old PRINT tag to PRT
+14 ; created separate R&S (PRINT) and GUI (GPRINT) entry pts
PRINT ;EP print referral form - Roll and Scroll Front End
+1 ;
+2 NEW PRTGUI,PGL
+3 SET PRTGUI=0
+4 ;
+5 ;Page length
+6 SET PGL=IOSL
+7 ;
+8 ;Print the Letter
+9 DO PRT
+10 QUIT
+11 ;
GPRINT(BMCREF) ;EP print referral form - GUI
+1 ;
+2 NEW PRTGUI,BMCFTYPE,BMCPROUT,PGL
+3 SET PRTGUI=1
+4 ;
+5 SET PGL=56
+6 ;
+7 ;Get the standard referral letter
+8 SET BMCFTYPE=$ORDER(^BMCTFORM("B","STANDARD IHS REFERRAL LETTER",""))
IF BMCFTYPE=""
QUIT
+9 ;
+10 ;Do not print routing slip
+11 SET BMCPROUT=0
+12 ;
+13 ;Print the Letter
+14 DO PRT
+15 QUIT
+16 ;
+17 ;GDIT/HS/BEE 10/19/17 - p12 CR#5450;Old PRINT tag changed to PRT
+18 ;PRINT ;print referral form
PRT ;print referral form
+1 NEW REFTO,BMCCHSAS,BMCCMT,BMCDA,BMCDFN,BMCFILE,BMCFTYP,BMCNODE,BMCPCON,BMCPG,BMCQUIT,BMCR0,BMCV,BMCVIEN,BMCX,BMCY
+2 NEW DTOUT,I,X
+3 ;
+4 SET BMCR0=^BMCREF(BMCREF,0)
SET BMCPG=0
SET BMCDFN=$PIECE(BMCR0,U,3)
+5 DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+6 SET BMCQUIT=0
+7 SET X=$PIECE(^BMCTFORM(BMCFTYPE,0),U,2)
SET N=0
SET C=1
DO W
+8 SET BMCFTYP=$SELECT($EXTRACT($PIECE(^BMCTFORM(BMCFTYPE,0),U),1,4)="CALL":"CI",1:"S")
+9 SET X=$$VAL^XBDIQ1(90001,BMCREF,.01)
SET C=0
SET N=0
SET T=66
DO W
+10 DO S
DEMO ;Demographic Data
+1 IF BMCQUIT
QUIT
+2 SET X="Patient Identification, Address, Phone"
SET C=1
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+3 SET X="Patient Name: "_$$VAL^XBDIQ1(90001,BMCREF,.03)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+4 SET X="ID Number: "_$$HRN^AUPNPAT($PIECE(BMCR0,U,3),DUZ(2),2)
SET N=0
SET T=50
SET C=0
DO W
IF BMCQUIT
QUIT
+5 IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,2)=""
SET X="SSN: "_""
SET C=0
SET T=9
SET N=1
DO W
IF BMCQUIT
QUIT
+6 IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,2)="Y"
SET X="SSN: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.09)
SET C=0
SET T=9
SET N=1
DO W
IF BMCQUIT
QUIT
+7 SET X="Sex: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.02)
SET N=0
SET T=56
SET C=0
DO W
IF BMCQUIT
QUIT
+8 SET X="Address: "
IF $$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1602.2)]""
SET X=X_$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1602.2)
SET C=0
SET T=5
SET N=1
DO W
IF BMCQUIT
QUIT
+9 SET X="DOB: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.03)
SET N=0
SET T=56
SET C=0
DO W
IF BMCQUIT
QUIT
+10 SET T=15
SET C=0
SET N=1
SET X=$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1603.2)_", "_$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1604.2)_" "_$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1605.2)
DO W
IF BMCQUIT
QUIT
+11 SET X="Hm Phone: "_$$VAL^XBDIQ1(9000001,$PIECE(BMCR0,U,3),1606.2)
SET C=0
SET T=51
SET N=0
DO W
IF BMCQUIT
QUIT
+12 ;
REFTO ;
+1 DO L
+2 ;GDIT/HS/BEE 10/19/17 - p12:Fixed code to address SAC issue
+3 ;D @$$VALI^XBDIQ1(90001,BMCREF,.04) Q:BMCQUIT
+4 SET REFTO=$$VALI^XBDIQ1(90001,BMCREF,.04)
+5 DO @REFTO
IF BMCQUIT
QUIT
+6 SET X=$$VAL^XBDIQ1(90001,BMCREF,.02)
SET N=0
SET C=0
SET T=64
DO W
IF BMCQUIT
QUIT
DATE ;
+1 SET X=$$VAL^XBDIQ1(90001,BMCREF,.14)_" Services "_$SELECT($PIECE(BMCR0,U,14)="I":"Admission Date",1:"Appointment Date")_": "_$$AVDOS^BMCRLU(BMCREF,"E")
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+2 ;
+3 IF $PIECE($GET(^BMCREF(BMCREF,0)),U,14)="O"
SET X="# of Outpatient Visits: "_$$VAL^XBDIQ1(90001,BMCREF,1111)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+4 IF $PIECE($GET(^BMCREF(BMCREF,0)),U,14)="I"
WRITE !
+5 SET X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCREF,1107)
SET C=0
SET T=40
SET N=0
DO W
IF BMCQUIT
QUIT
+6 IF $PIECE($GET(^BMCREF(BMCREF,0)),U,32)'=""
SET X="Priority Rating: "_$$VAL^XBDIQ1(90001,BMCREF,.32)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+7 ;BMC*4.0*3 8.10.2007 IHS/OIT/FCJ ADDED NXT LINE
+8 IF $PIECE($GET(^BMCREF(BMCREF,14)),U,5)'=""
SET X="Insurance Auth No: "_$$VAL^XBDIQ1(90001,BMCREF,1405)
SET C=0
SET T=40
SET N=0
DO W
IF BMCQUIT
QUIT
+9 DO L
PURPOSE ;
+1 SET X="Purpose/Services Requested: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
+2 IF $LENGTH(X)>IOM
Begin DoDot:1
+3 SET BMCX=X
SET X=$EXTRACT(BMCX,1,IOM)
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+4 SET X=$EXTRACT(BMCX,(IOM+1),IOM)
SET N=1
SET C=0
SET T=22
DO W
IF BMCQUIT
QUIT
End DoDot:1
IF 1
+5 IF '$TEST
SET C=0
SET N=1
SET T=0
DO W
IF BMCQUIT
QUIT
PERTMED ;
+1 SET BMCCMT=0
+2 FOR
SET BMCCMT=$ORDER(^BMCCOM("AD",BMCREF,BMCCMT))
IF BMCCMT'?1N.N
QUIT
Begin DoDot:1
+3 IF $PIECE(^BMCCOM(BMCCMT,0),U,5)'="M"
QUIT
+4 SET BMCNODE=1
SET BMCIOM=70
SET BMCFILE=90001.03
SET BMCDA=BMCCMT
SET BMCNODE=1
+5 DO WP
KILL BMCIOM
+6 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:2
+7 ;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Changed IOSL to PGL
IF $Y>($SELECT($GET(PGL)]"":PGL,1:IOSL)-3)
DO HEAD
IF BMCQUIT
QUIT
+8 WRITE !?5,BMCWP(Y)
End DoDot:2
End DoDot:1
ADDMED ;
+1 SET X="Additional Medical Information Attached: "_$SELECT($$VAL^XBDIQ1(90001,BMCREF,.34)]"":$$VAL^XBDIQ1(90001,BMCREF,.34),1:" Not Documented by Provider")
SET C=0
SET T=0
SET N=2
DO W
IF BMCQUIT
QUIT
REFFROM ;
+1 SET T=0
SET X=$TRANSLATE($JUSTIFY(" ",IOM)," ","_")
SET N=1
SET C=0
DO W
IF BMCQUIT
QUIT
+2 SET BMCV=$PIECE(BMCR0,U,5)
+3 SET Y=$PIECE(BMCR0,U,4)
+4 ;BMC*4.0*3 8.10.2007 IHS/OIT/FCJ SPLIT NEXT LINE TO PRINT NPI IF AVAIL
+5 IF Y="N"
Begin DoDot:1
+6 SET X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=1
SET T=0
SET C=0
DO W
IF BMCQUIT
QUIT
+7 WRITE "XXXXX"
+8 SET I=$PIECE(BMCR0,U,6)
IF I
IF $PIECE($GET(^VA(200,I,"NPI")),U)
SET X="NPI: "_$PIECE(^VA(200,I,"NPI"),U)
SET N=1
SET T=0
SET C=0
DO W
End DoDot:1
IF BMCQUIT
QUIT
GOTO PAYOR
+9 ;
+10 SET X="If you have any questions concerning this referral, please contact:"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+11 SET X=" "_$$VAL^XBDIQ1(90001,BMCREF,.05)_$SELECT($$VAL^XBDIQ1(90001.31,DUZ(2),.17)]"":" (contact: "_$$VAL^XBDIQ1(90001.31,DUZ(2),.17)_")",1:"")_")"
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+12 ;4.0*1 2.15.06 IHS/OIT/FCJ REWROTE NXT SECTION TO PRNT ADDRESS FR PARM
+13 IF $$VAL^XBDIQ1(90001.31,BMCV,201)'=""
Begin DoDot:1
+14 SET X=$$VAL^XBDIQ1(90001.31,BMCV,201)
+15 IF BMCV
IF X]""
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+16 SET X=$$VAL^XBDIQ1(90001.31,BMCV,202)
+17 IF BMCV
IF X]""
Begin DoDot:2
+18 SET X=X_", "_$$VAL^XBDIQ1(90001.31,BMCV,203)
+19 SET X=X_" "_$$VAL^XBDIQ1(90001.31,BMCV,204)
+20 SET X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")"
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
End DoDot:2
End DoDot:1
+21 IF '$TEST
IF $$VAL^XBDIQ1(9999999.06,BMCV,.14)'=""
Begin DoDot:1
+22 SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.14)
+23 IF BMCV
IF X]""
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
+24 SET X=$$VAL^XBDIQ1(9999999.06,BMCV,.15)
+25 IF BMCV
IF X]""
Begin DoDot:2
+26 SET X=X_", "_$$VAL^XBDIQ1(9999999.06,BMCV,.16)
+27 SET X=X_" "_$$VAL^XBDIQ1(9999999.06,BMCV,.17)
+28 SET X=X_" (phone: "_$$VAL^XBDIQ1(90001.31,BMCV,.18)_")"
SET N=1
SET C=0
SET T=5
DO W
IF BMCQUIT
QUIT
End DoDot:2
End DoDot:1
+29 ;4.0*1 2.15.06 IHS/OIT/FCJ END OF CHANGES
+30 IF BMCFTYP'="CI"
SET X="Referring Provider (ELECTRONIC SIGNATURE): "_$$VAL^XBDIQ1(90001,BMCREF,.06)
SET N=1
SET T=6
SET C=0
DO W
IF BMCQUIT
QUIT
+31 ;BMC*4.0*3 8.10.2007 IHS/OIT/FCJ ADDED NXT LINE
+32 IF BMCFTYP'="CI"
SET I=$PIECE(BMCR0,U,6)
IF I
IF $PIECE($GET(^VA(200,I,"NPI")),U)
SET X="NPI: "_$PIECE(^VA(200,I,"NPI"),U)
SET N=1
SET T=6
SET C=0
DO W
IF BMCQUIT
QUIT
+33 IF BMCFTYP'="CI"
SET X="Case Manager: "_$$VAL^XBDIQ1(90001,BMCREF,.19)
SET N=1
SET T=6
SET C=0
DO W
IF BMCQUIT
QUIT
+34 SET X="Veteran: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),1901)
SET N=1
SET T=56
SET C=0
DO W
+35 IF BMCQUIT
QUIT
PAYOR ;OTHER PAYOR INFORMATION
+1 DO OTHPAY^BMCFPRN1
+2 IF BMCQUIT
QUIT
TEXT ;
+1 WRITE !
DO S
+2 KILL BMCWP
+3 SET BMCCHSAS=$PIECE($GET(^BMCREF(BMCREF,11)),U,12)
+4 IF $PIECE(BMCR0,U,4)="C"
SET BMCNODE=$SELECT(BMCCHSAS="A":1,BMCCHSAS="D":2,BMCCHSAS="P":3,1:3)
SET BMCFILE=90001.33
SET BMCDA=BMCFTYPE
DO WPTXT
+5 IF $PIECE(BMCR0,U,4)="O"
SET BMCNODE=2
SET BMCFILE=90001.33
SET BMCDA=BMCFTYPE
DO WPTXT
+6 IF $PIECE(BMCR0,U,4)="I"!($PIECE(BMCR0,U,4)="N")
WRITE !
SET BMCWP(1)=""
+7 ;
+8 SET BMCY=0
FOR
SET BMCY=$ORDER(BMCWP(BMCY))
IF BMCY'=+BMCY!(BMCQUIT)
QUIT
Begin DoDot:1
+9 ;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Changed IOSL to PGL
IF $Y>($SELECT($GET(PGL)]"":PGL,1:IOSL)-3)
DO HEAD
IF BMCQUIT
QUIT
+10 WRITE !,BMCWP(BMCY)
End DoDot:1
+11 ;
LINE ;CHS Supervisor Signature (if Type=CHS)
+1 IF $PIECE(BMCR0,U,4)'="C"
GOTO ROUT
+2 WRITE !!!!!
+3 IF BMCFTYP="CI"
GOTO ROUT
+4 SET X="____________________"
SET C=0
SET T=50
SET N=1
DO W
IF BMCQUIT
QUIT
+5 WRITE !
+6 SET X="Contract Health Service Office"
SET C=0
SET T=50
SET N=1
DO W
IF BMCQUIT
QUIT
ROUT ;Print Routing slip
+1 IF BMCPROUT=1
WRITE #
DO PRINT^BMCFDRS
+2 ;BMC*4.0*2 9.14.06 IHS.OIT.FCJ ADDED NXT SECTION TO PRINT CONSULT LTR
CONSULT ;PRINT CONSULT LETTER
+1 ;BMC*4.0*4 IHS.OIT.FCJ CHANGED TO $G
IF $GET(BMCPCON)=1
WRITE #
DO PRINT^BMCFDRP
+2 QUIT
W ;Entry Point
+1 IF X=""
QUIT
+2 NEW %
+3 SET %=$LENGTH(X)
+4 ;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Changed IOSL to PGL
IF $Y>($SELECT($GET(PGL)]"":PGL,1: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=0
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=19
DO W
IF BMCQUIT
QUIT
+5 SET X="Mailing: "_$$VAL^XBDIQ1(9999999.11,BMCV,1301)
SET N=1
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+6 SET X="Physical: "_$$VAL^XBDIQ1(9999999.11,BMCV,1306)
SET N=0
SET C=0
SET T=40
DO W
IF BMCQUIT
QUIT
+7 ;IHS/ITSC/FCJ MOD TO NOT REQUIRE ADDRESS FOR VENDOR
+8 IF $GET(^AUTTVNDR(BMCV,13))'=""
Begin DoDot:1
+9 SET BMCVIEN=$PIECE(^AUTTVNDR(BMCV,13),U,3)
+10 SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1302)_", "
+11 IF BMCVIEN'=""
SET X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1304)
+12 SET N=1
SET C=0
SET T=9
DO W
+13 IF $$VAL^XBDIQ1(9999999.11,BMCV,1306)'=""
Begin DoDot:2
+14 SET BMCVIEN=$PIECE(^AUTTVNDR(BMCV,13),U,8)
+15 SET X=$$VAL^XBDIQ1(9999999.11,BMCV,1307)_", "
+16 IF BMCVIEN'=""
SET X=X_$$VAL^XBDIQ1(5,BMCVIEN,1)
+17 SET X=X_" "_$$VAL^XBDIQ1(9999999.11,BMCV,1309)
+18 IF X'?1A.E
SET X=""
+19 SET N=0
SET C=0
SET T=50
DO W
End DoDot:2
IF BMCQUIT
QUIT
End DoDot:1
IF BMCQUIT
QUIT
+20 WRITE !
+21 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=0
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=19
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=19
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=19
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=0
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=0
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=19
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=19
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=19
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
WPTXT ;
+1 ; get site-specific text (if any)
+2 IF $PIECE(BMCR0,U,4)="C"
Begin DoDot:1
+3 IF BMCCHSAS="A"
IF $DATA(^BMCPARM(DUZ(2),31))
SET BMCFILE=90001.31
SET BMCDA=DUZ(2)
SET BMCNODE=31
+4 IF BMCCHSAS="D"
IF $DATA(^BMCPARM(DUZ(2),32))
SET BMCFILE=90001.31
SET BMCDA=DUZ(2)
SET BMCNODE=32
+5 IF BMCCHSAS="P"!(BMCCHSAS="")
IF $DATA(^BMCPARM(DUZ(2),33))
SET BMCFILE=90001.31
SET BMCDA=DUZ(2)
SET BMCNODE=33
End DoDot:1
+6 IF $PIECE(BMCR0,U,4)="O"
IF $DATA(^BMCPARM(DUZ(2),33))
SET BMCFILE=90001.31
SET BMCDA=DUZ(2)
SET BMCNODE=34
+7 ; fall through to WP to get the text
WP ;
+1 DO WP^BMCFDR
+2 QUIT
+3 ;
+4 ;GDIT/HS/BEE 10/19/17 - p12 CR#5450:Added references to PRTGUI to control GUI display formatting
+5 ;HEAD ;
+6 ; NEW N,T,C,X,Y
+7 ; 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
+8 ;HEAD1 ;
+9 ; W:$D(IOF) @IOF
+10 ;HEAD2 ;
+11 ; I 'BMCPG S BMCPG=BMCPG+1 Q
+12 ; S BMCPG=BMCPG+1 W:$D(IOF) @IOF W !,?(IOM-20),"Page ",BMCPG
HEAD IF $GET(PRTGUI)
QUIT
+1 NEW N,T,C,X,Y
+2 IF '$GET(PRTGUI)
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 '$GET(PRTGUI)
IF $DATA(IOF)
WRITE @IOF
HEAD2 ;
+1 IF 'BMCPG
SET BMCPG=BMCPG+1
QUIT
+2 SET BMCPG=BMCPG+1
IF '$GET(PRTGUI)
IF $DATA(IOF)
WRITE @IOF
WRITE !,?(IOM-20),"Page ",BMCPG
+3 ;End of CR#5450 changes
+4 QUIT
