BMCFPIN ; IHS/ITSC/FCJ - PRINT IN-HOUSE REFERRAL FORM ;
;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
;IHS/ITSC/FCJ
;ORIGINAL ROUTINE FROM BMCFPRN
;11-1-12 BMC*4.0*9 IHS.OIT.FCJ ADDED ICD-10 CALL
;
PRINT ;
;print referral form
S BMCR0=^BMCREF(BMCREF,0),BMCPG=0,BMCDFN=$P(BMCR0,U,3)
D @("HEAD"_(2-($E(IOST,1,2)="C-")))
S BMCQUIT=0
I $$VAL^XBDIQ1(90001,BMCREF,.04)'="IN-HOUSE" W !," Please select an IN-HOUSE Referral" S BMCQUIT=1 Q
D REFTYP,REFTO,DATE,PURPOSE Q
REFTYP ;REFERRAL TYPE
D L
S X="In-House Referral",N=1,C=1,T=0 D W Q:BMCQUIT
W !
S X="Referral Number: "_$$VAL^XBDIQ1(90001,BMCREF,.02),N=0,C=1,T=0 D W Q:BMCQUIT
Q
REFTO ;
D L
S X="Referred to: "_$$VAL^XBDIQ1(90001,BMCREF,.23)_" clinic",N=1,C=0,T=0 D W Q:BMCQUIT
S X="Address: "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.14),N=1,C=0,T=4 D W Q:BMCQUIT
S X=$$VAL^XBDIQ1(9999999.06,DUZ(2),.15)_",",N=1,C=0,T=14 D W Q:BMCQUIT
S X=$$VAL^XBDIQ1(9999999.06,DUZ(2),.16),N=0,C=0,T=0 D W Q:BMCQUIT
S X=" "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.17),N=0,C=0,T=0 D W Q:BMCQUIT
Q
DATE ;
D L
S X=$$VAL^XBDIQ1(90001,BMCREF,.14)_" Services",N=1,C=1,T=0 D W Q:BMCQUIT
S X=$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
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,14)="O" S X="# of Outpatient Visits: "_$$VAL^XBDIQ1(90001,BMCREF,1111),C=0,T=0,N=1 D W Q:BMCQUIT
D L Q
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
;CHECK FOR DX
I $D(^BMCDX("AD",BMCREF)) D
.W !,"DIAGNOSIS: "
.S BMCX=0,X=0 F S BMCX=$O(^BMCDX("AD",BMCREF,BMCX)) Q:BMCX'?1N.N D
..S X=X+1 W:X>1 ", "
..;BMC*4.0*9 11-1-12 IHS/OIT/FCJ;NEW LINE FOR ICD-10 CHANGES
..;W $$VAL^XBDIQ1(90001.01,BMCX,.01)
..S BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N") ;BMC*4.0*9
..W $P($$ICDDX^ICDEX($P(^BMCDX(BMCX,0),U),BMCDOS,,"I"),U,2)
;CHECK FOR CPT
I $D(^BMCPX("AD",BMCREF)) D
.W !,"PROCEDURE: "
.S BMCX=0,X=0 F S BMCX=$O(^BMCPX("AD",BMCREF,BMCX)) Q:BMCX'?1N.N D
..S X=X+1 W:X>1 ", "
..W $$VAL^XBDIQ1(90001.02,BMCX,.01)
D L
PERTMED ;
S X="Pertinent Medical History: ",C=0,T=0,N=1 D W Q:BMCQUIT
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
.D WP K BMCIOM
.S Y=0 F S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT) D
..I $Y>(IOSL-3) D HEAD Q:BMCQUIT
..W !?5,BMCWP(Y)
ADDMED ;
D L
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=1 D W Q:BMCQUIT
FLUP ;FOLLOW UP INFO
D L
W "Follow up visit MUST be approved by an IHS physcian.",!,"Please provide additional Notes: ",!!!!
PRIORITY ;
D L
S X="Procedure Category: "_$$VAL^XBDIQ1(90001,BMCREF,.13),C=0,T=0,N=1 D W Q:BMCQUIT
S X="Medical Priority: "_$$VAL^XBDIQ1(90001,BMCREF,.32),C=0,T=54,N=0 D W Q:BMCQUIT
S X="Review/Approval by CHS/Managed Care Committee",C=1,T=0,N=2 D W Q:BMCQUIT
W !! F I=1:1:40 W "_"
W ?45,"____________________"
W !,"SIGNATURE",?45,"DATE"
REFFROM ;
D L
W "Referring Facility: ",$$VAL^XBDIQ1(9999999.06,DUZ(2),.01)
W !,"Referring Provider: "
W !! F I=1:1:40 W "_"
W ?45,"____________________"
W !,"SIGNATURE",?45,"DATE",!
DEMO ;Demographic Data
Q:BMCQUIT
S X="Patient Identification (Name,DOB and HRN)",C=0,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="DOB: "_$$VAL^XBDIQ1(2,$P(BMCR0,U,3),.03),N=1,T=0,C=0 D W Q:BMCQUIT
S X="Health Record Number: "_$$HRN^AUPNPAT($P(BMCR0,U,3),DUZ(2),2),N=0,T=40,C=0 D W Q:BMCQUIT
ADDINFO ;
D L
S X="INCLUDE WHICH OF THE FOLLOWING ITEMS?",C=0,T=0,N=1 D W Q:BMCQUIT
W !,"PCC VISIT FORM: ",$$VAL^XBDIQ1(90001,BMCREF,401)
W ?28,"SPECIALTY CLINIC NOTES: ",$$VAL^XBDIQ1(90001,BMCREF,402)
W ?55,"PRENATAL RECORD/S: ",$$VAL^XBDIQ1(90001,BMCREF,403)
W !,"FACE SHEET: ",$$VAL^XBDIQ1(90001,BMCREF,405)
W ?28,"HEALTH SUMMARY: ",$$VAL^XBDIQ1(90001,BMCREF,406)
W ?55,"MOST RECENT EKG: ",$$VAL^XBDIQ1(90001,BMCREF,407)
W !,"HISTORY AND PHYSICAL: ",$$VAL^XBDIQ1(90001,BMCREF,408)
W ?28,"E-RAY/REPORT: ",$$VAL^XBDIQ1(90001,BMCREF,409)
W ?55,"MOST RECENT LAB REPORT: ",$$VAL^XBDIQ1(90001,BMCREF,412)
W !?32,"E-RAY FILM: ",$$VAL^XBDIQ1(90001,BMCREF,410)
W !,"ADDITIONAL DOCUMENTS: "
S BMCNODE=5,BMCIOM=70,BMCFILE=90001,BMCDA=BMCREF D WP K BMCIOM
S Y=0 F S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT) D
.I $Y>(IOSL-3) D HEAD Q:BMCQUIT
.W !?5,BMCWP(Y)
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
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
WP ;
D WP^BMCFDR
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
BMCFPIN ; IHS/ITSC/FCJ - PRINT IN-HOUSE REFERRAL FORM ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
+2 ;IHS/ITSC/FCJ
+3 ;ORIGINAL ROUTINE FROM BMCFPRN
+4 ;11-1-12 BMC*4.0*9 IHS.OIT.FCJ ADDED ICD-10 CALL
+5 ;
PRINT ;
+1 ;print referral form
+2 SET BMCR0=^BMCREF(BMCREF,0)
SET BMCPG=0
SET BMCDFN=$PIECE(BMCR0,U,3)
+3 DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+4 SET BMCQUIT=0
+5 IF $$VAL^XBDIQ1(90001,BMCREF,.04)'="IN-HOUSE"
WRITE !," Please select an IN-HOUSE Referral"
SET BMCQUIT=1
QUIT
+6 DO REFTYP
DO REFTO
DO DATE
DO PURPOSE
QUIT
REFTYP ;REFERRAL TYPE
+1 DO L
+2 SET X="In-House Referral"
SET N=1
SET C=1
SET T=0
DO W
IF BMCQUIT
QUIT
+3 WRITE !
+4 SET X="Referral Number: "_$$VAL^XBDIQ1(90001,BMCREF,.02)
SET N=0
SET C=1
SET T=0
DO W
IF BMCQUIT
QUIT
+5 QUIT
REFTO ;
+1 DO L
+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 SET X="Address: "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.14)
SET N=1
SET C=0
SET T=4
DO W
IF BMCQUIT
QUIT
+4 SET X=$$VAL^XBDIQ1(9999999.06,DUZ(2),.15)_","
SET N=1
SET C=0
SET T=14
DO W
IF BMCQUIT
QUIT
+5 SET X=$$VAL^XBDIQ1(9999999.06,DUZ(2),.16)
SET N=0
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+6 SET X=" "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.17)
SET N=0
SET C=0
SET T=0
DO W
IF BMCQUIT
QUIT
+7 QUIT
DATE ;
+1 DO L
+2 SET X=$$VAL^XBDIQ1(90001,BMCREF,.14)_" Services"
SET N=1
SET C=1
SET T=0
DO W
IF BMCQUIT
QUIT
+3 SET X=$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
+4 SET X="Expected Ending Date: "_$$VAL^XBDIQ1(90001,BMCREF,1107)
SET C=0
SET T=40
SET N=0
DO W
IF BMCQUIT
QUIT
+5 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
+6 DO L
QUIT
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
+6 ;CHECK FOR DX
+7 IF $DATA(^BMCDX("AD",BMCREF))
Begin DoDot:1
+8 WRITE !,"DIAGNOSIS: "
+9 SET BMCX=0
SET X=0
FOR
SET BMCX=$ORDER(^BMCDX("AD",BMCREF,BMCX))
IF BMCX'?1N.N
QUIT
Begin DoDot:2
+10 SET X=X+1
IF X>1
WRITE ", "
+11 ;BMC*4.0*9 11-1-12 IHS/OIT/FCJ;NEW LINE FOR ICD-10 CHANGES
+12 ;W $$VAL^XBDIQ1(90001.01,BMCX,.01)
+13 ;BMC*4.0*9
SET BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N")
+14 WRITE $PIECE($$ICDDX^ICDEX($PIECE(^BMCDX(BMCX,0),U),BMCDOS,,"I"),U,2)
End DoDot:2
End DoDot:1
+15 ;CHECK FOR CPT
+16 IF $DATA(^BMCPX("AD",BMCREF))
Begin DoDot:1
+17 WRITE !,"PROCEDURE: "
+18 SET BMCX=0
SET X=0
FOR
SET BMCX=$ORDER(^BMCPX("AD",BMCREF,BMCX))
IF BMCX'?1N.N
QUIT
Begin DoDot:2
+19 SET X=X+1
IF X>1
WRITE ", "
+20 WRITE $$VAL^XBDIQ1(90001.02,BMCX,.01)
End DoDot:2
End DoDot:1
+21 DO L
PERTMED ;
+1 SET X="Pertinent Medical History: "
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+2 SET BMCCMT=0
+3 FOR
SET BMCCMT=$ORDER(^BMCCOM("AD",BMCREF,BMCCMT))
IF BMCCMT'?1N.N
QUIT
Begin DoDot:1
+4 IF $PIECE(^BMCCOM(BMCCMT,0),U,5)'="M"
QUIT
+5 SET BMCNODE=1
SET BMCIOM=70
SET BMCFILE=90001.03
SET BMCDA=BMCCMT
+6 DO WP
KILL BMCIOM
+7 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:2
+8 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+9 WRITE !?5,BMCWP(Y)
End DoDot:2
End DoDot:1
ADDMED ;
+1 DO L
+2 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=1
DO W
IF BMCQUIT
QUIT
FLUP ;FOLLOW UP INFO
+1 DO L
+2 WRITE "Follow up visit MUST be approved by an IHS physcian.",!,"Please provide additional Notes: ",!!!!
PRIORITY ;
+1 DO L
+2 SET X="Procedure Category: "_$$VAL^XBDIQ1(90001,BMCREF,.13)
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+3 SET X="Medical Priority: "_$$VAL^XBDIQ1(90001,BMCREF,.32)
SET C=0
SET T=54
SET N=0
DO W
IF BMCQUIT
QUIT
+4 SET X="Review/Approval by CHS/Managed Care Committee"
SET C=1
SET T=0
SET N=2
DO W
IF BMCQUIT
QUIT
+5 WRITE !!
FOR I=1:1:40
WRITE "_"
+6 WRITE ?45,"____________________"
+7 WRITE !,"SIGNATURE",?45,"DATE"
REFFROM ;
+1 DO L
+2 WRITE "Referring Facility: ",$$VAL^XBDIQ1(9999999.06,DUZ(2),.01)
+3 WRITE !,"Referring Provider: "
+4 WRITE !!
FOR I=1:1:40
WRITE "_"
+5 WRITE ?45,"____________________"
+6 WRITE !,"SIGNATURE",?45,"DATE",!
DEMO ;Demographic Data
+1 IF BMCQUIT
QUIT
+2 SET X="Patient Identification (Name,DOB and HRN)"
SET C=0
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="DOB: "_$$VAL^XBDIQ1(2,$PIECE(BMCR0,U,3),.03)
SET N=1
SET T=0
SET C=0
DO W
IF BMCQUIT
QUIT
+5 SET X="Health Record Number: "_$$HRN^AUPNPAT($PIECE(BMCR0,U,3),DUZ(2),2)
SET N=0
SET T=40
SET C=0
DO W
IF BMCQUIT
QUIT
ADDINFO ;
+1 DO L
+2 SET X="INCLUDE WHICH OF THE FOLLOWING ITEMS?"
SET C=0
SET T=0
SET N=1
DO W
IF BMCQUIT
QUIT
+3 WRITE !,"PCC VISIT FORM: ",$$VAL^XBDIQ1(90001,BMCREF,401)
+4 WRITE ?28,"SPECIALTY CLINIC NOTES: ",$$VAL^XBDIQ1(90001,BMCREF,402)
+5 WRITE ?55,"PRENATAL RECORD/S: ",$$VAL^XBDIQ1(90001,BMCREF,403)
+6 WRITE !,"FACE SHEET: ",$$VAL^XBDIQ1(90001,BMCREF,405)
+7 WRITE ?28,"HEALTH SUMMARY: ",$$VAL^XBDIQ1(90001,BMCREF,406)
+8 WRITE ?55,"MOST RECENT EKG: ",$$VAL^XBDIQ1(90001,BMCREF,407)
+9 WRITE !,"HISTORY AND PHYSICAL: ",$$VAL^XBDIQ1(90001,BMCREF,408)
+10 WRITE ?28,"E-RAY/REPORT: ",$$VAL^XBDIQ1(90001,BMCREF,409)
+11 WRITE ?55,"MOST RECENT LAB REPORT: ",$$VAL^XBDIQ1(90001,BMCREF,412)
+12 WRITE !?32,"E-RAY FILM: ",$$VAL^XBDIQ1(90001,BMCREF,410)
+13 WRITE !,"ADDITIONAL DOCUMENTS: "
+14 SET BMCNODE=5
SET BMCIOM=70
SET BMCFILE=90001
SET BMCDA=BMCREF
DO WP
KILL BMCIOM
+15 SET Y=0
FOR
SET Y=$ORDER(BMCWP(Y))
IF Y'=+Y!(BMCQUIT)
QUIT
Begin DoDot:1
+16 IF $Y>(IOSL-3)
DO HEAD
IF BMCQUIT
QUIT
+17 WRITE !?5,BMCWP(Y)
End DoDot:1
+18 QUIT
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
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
WP ;
+1 DO WP^BMCFDR
+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
