- 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
