- BMCRRSPP ; IHS/PHXAO/TMJ - SECONDARY PROVIDER LETTER ;
- ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
- ;
- ;IHS/ITSC/FCJ WAS NOT PRINTING COMMENTS ;WRONG FIELDS WERE PRINTING
- ; PRINT REF TYPE;REMOVED KILL AND RESET BMCOLOC; PRT SUFFIX
- ;
- S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRRSP",BMCJOB,BMCBT)) W !,"No referrals to report",! G XIT
- S BMCPN=0,BMCQUIT=0
- S BMCDATE="" F S BMCDATE=$O(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE)) Q:BMCDATE=""!(BMCQUIT) D P
- XIT ;
- K ^XTMP("BMCRRSP",BMCJOB,BMCBT)
- D DONE^BMCRLP2
- D KILL^AUPNPAT
- K BMCI,BMCDATE,BMCOMDT,BMCRDT,BMCREVN,BMCREVP
- S BMCOLOC=$P(^BMCPARM(DUZ(2),0),U,11)
- Q
- P ;
- S BMCPN="" F S BMCPN=$O(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN)) Q:BMCPN=""!(BMCQUIT) D PRINT
- Q
- PRINT ;print one referral
- I $Y>(IOSL-10) D HEAD Q:BMCQUIT
- S BMCRDT=0
- F S BMCRDT=$O(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCRDT)) Q:BMCRDT'=+BMCRDT!(BMCQUIT) D D PRINT1
- .S BMCRREC=^BMCREF(BMCRDT,0),DFN=$P(BMCRREC,U,3)
- .S BMCREF=$P(^BMCREF(BMCRDT,1),U,2)
- .S BMCSUF=$P($G(^BMCREF(BMCRDT,1)),U)
- Q
- PRINT1 ;
- I $Y>(IOSL-3) D HEAD Q:BMCQUIT
- S BMCHRN="????" I $D(^AUPNPAT(DFN,41,DUZ(2)))
- S BMCHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
- W !,$E($P(^DPT(DFN,0),U),1,30),?32,BMCHRN,?43,"DOB: ",$$DOB^AUPNPAT(DFN,"E")," ",$$AGE^AUPNPAT(DFN,DT,"R")," ",$$SSN^AUPNPAT(DFN)
- W !,"Referral #: ",$P($G(^BMCREF(BMCRDT,0)),U,2)," ",BMCSUF
- W ?29,"Date Init: ",$$REFDTI^BMCRLU(BMCRDT,"S")
- W ?50,"Tribe: ",$E($$TRIBE^AUPNPAT(DFN,"E"),1,20)
- ;
- ;
- LETTER ;Print Letter Information
- ;
- W !,"Refferal Type: "_$$VAL^XBDIQ1(90001,BMCREF,.04)
- S Y=$P(BMCRREC,U,1) D DD^%DT S BMCCOMDT=Y
- W !,"LETTER DATE: "_BMCCOMDT
- S BMCREVP=$P(BMCRREC,U,25) S BMCREVN=$P(^VA(200,BMCREVP,0),U,1)
- W ?43,"USER CREATED: "_BMCREVN,!
- S BMCAPPT=$P(^BMCREF(BMCRDT,11),U,5) ;Exp Appt Date
- S BMCPUR=$P($G(^BMCREF(BMCRDT,12)),U) ; Purpose
- S BMCIHSP=$P(BMCRREC,U,8) ;IHS Provider
- S BMCSPRV=$P(BMCRREC,U,7) ;Provider/Vendor IEN
- S:BMCSPRV'="" BMCSPRV=$P(^AUTTVNDR(BMCSPRV,0),U)
- S Y=BMCAPPT D DD^%DT S BMCAPPT=Y
- W !,"Expected Appoinment Date: ",BMCAPPT
- W !,"Purpose of Appointment: ",BMCPUR
- W !,"Contract Vendor: ",BMCSPRV
- S:BMCIHSP'="" BMCIHSP=$P(^DIC(4,BMCIHSP,0),U)
- W !,"IHS Facility: ",BMCIHSP
- ;
- LOCAT ;Print Local Categories
- I $D(^BMCREF(BMCREF,21,0)) D
- . S BMCLOCC=0
- .F S BMCLOCC=$O(^BMCREF(BMCREF,21,"B",BMCLOCC)) Q:BMCLOCC'=+BMCLOCC D
- ..S BMCLOCI=0
- ..F S BMCLOCI=$O(^BMCREF(BMCREF,21,"B",BMCLOCC,BMCLOCI)) Q:BMCLOCI'=+BMCLOCI D
- ... S BMCLOCP=$P(^BMCREF(BMCREF,21,BMCLOCI,0),U)
- ... Q:BMCLOCP=""
- ... S BMCLOCPP=$P(^BMCLCAT(BMCLOCP,0),U)
- ... W !,"Local Category: "_BMCLOCPP
- ;
- ;
- ALT ;Alternate Resource Letter Date
- I $Y>(IOSL-3) D HEAD Q:BMCQUIT
- W !,"Alternate Resource Letter Date: ",$$VAL^XBDIQ1(90001,BMCREF,1401)
- ;
- BO ;Business office comments
- S BMCI=0,Y=0
- F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'?1N.N D Q:BMCQUIT
- .Q:$P(^BMCCOM(BMCI,0),U,5)'="B"
- .I Y=0 W !,"Business Office Comments:"
- .S BMCNODE=1,BMCIOM=70,BMCFILE=90001.03,BMCDA=BMCI D WP^BMCFDR 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:BMCQUIT
- NEXT ;
- W !,"--------------------",!
- Q
- HEAD ;ENTRY POINT
- NEW X,Y,Z,C
- 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 ;
- S BMCPG=BMCPG+1
- W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
- W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
- S Y=DT D DD^%DT W ?(80-$L(Y)/2),Y,!
- W ?21,"**SECONDARY PROVIDER LETTER BY DATE**",!
- S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y
- S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!
- W !,$TR($J(" ",80)," ","-")
- Q
- BMCRRSPP ; IHS/PHXAO/TMJ - SECONDARY PROVIDER LETTER ;
- +1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
- +2 ;
- +3 ;IHS/ITSC/FCJ WAS NOT PRINTING COMMENTS ;WRONG FIELDS WERE PRINTING
- +4 ; PRINT REF TYPE;REMOVED KILL AND RESET BMCOLOC; PRT SUFFIX
- +5 ;
- +6 SET BMCPG=0
- DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
- IF '$DATA(^XTMP("BMCRRSP",BMCJOB,BMCBT))
- WRITE !,"No referrals to report",!
- GOTO XIT
- +7 SET BMCPN=0
- SET BMCQUIT=0
- +8 SET BMCDATE=""
- FOR
- SET BMCDATE=$ORDER(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE))
- IF BMCDATE=""!(BMCQUIT)
- QUIT
- DO P
- XIT ;
- +1 KILL ^XTMP("BMCRRSP",BMCJOB,BMCBT)
- +2 DO DONE^BMCRLP2
- +3 DO KILL^AUPNPAT
- +4 KILL BMCI,BMCDATE,BMCOMDT,BMCRDT,BMCREVN,BMCREVP
- +5 SET BMCOLOC=$PIECE(^BMCPARM(DUZ(2),0),U,11)
- +6 QUIT
- P ;
- +1 SET BMCPN=""
- FOR
- SET BMCPN=$ORDER(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN))
- IF BMCPN=""!(BMCQUIT)
- QUIT
- DO PRINT
- +2 QUIT
- PRINT ;print one referral
- +1 IF $Y>(IOSL-10)
- DO HEAD
- IF BMCQUIT
- QUIT
- +2 SET BMCRDT=0
- +3 FOR
- SET BMCRDT=$ORDER(^XTMP("BMCRRSP",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCRDT))
- IF BMCRDT'=+BMCRDT!(BMCQUIT)
- QUIT
- Begin DoDot:1
- +4 SET BMCRREC=^BMCREF(BMCRDT,0)
- SET DFN=$PIECE(BMCRREC,U,3)
- +5 SET BMCREF=$PIECE(^BMCREF(BMCRDT,1),U,2)
- +6 SET BMCSUF=$PIECE($GET(^BMCREF(BMCRDT,1)),U)
- End DoDot:1
- DO PRINT1
- +7 QUIT
- PRINT1 ;
- +1 IF $Y>(IOSL-3)
- DO HEAD
- IF BMCQUIT
- QUIT
- +2 SET BMCHRN="????"
- IF $DATA(^AUPNPAT(DFN,41,DUZ(2)))
- +3 SET BMCHRN=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
- +4 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,30),?32,BMCHRN,?43,"DOB: ",$$DOB^AUPNPAT(DFN,"E")," ",$$AGE^AUPNPAT(DFN,DT,"R")," ",$$SSN^AUPNPAT(DFN)
- +5 WRITE !,"Referral #: ",$PIECE($GET(^BMCREF(BMCRDT,0)),U,2)," ",BMCSUF
- +6 WRITE ?29,"Date Init: ",$$REFDTI^BMCRLU(BMCRDT,"S")
- +7 WRITE ?50,"Tribe: ",$EXTRACT($$TRIBE^AUPNPAT(DFN,"E"),1,20)
- +8 ;
- +9 ;
- LETTER ;Print Letter Information
- +1 ;
- +2 WRITE !,"Refferal Type: "_$$VAL^XBDIQ1(90001,BMCREF,.04)
- +3 SET Y=$PIECE(BMCRREC,U,1)
- DO DD^%DT
- SET BMCCOMDT=Y
- +4 WRITE !,"LETTER DATE: "_BMCCOMDT
- +5 SET BMCREVP=$PIECE(BMCRREC,U,25)
- SET BMCREVN=$PIECE(^VA(200,BMCREVP,0),U,1)
- +6 WRITE ?43,"USER CREATED: "_BMCREVN,!
- +7 ;Exp Appt Date
- SET BMCAPPT=$PIECE(^BMCREF(BMCRDT,11),U,5)
- +8 ; Purpose
- SET BMCPUR=$PIECE($GET(^BMCREF(BMCRDT,12)),U)
- +9 ;IHS Provider
- SET BMCIHSP=$PIECE(BMCRREC,U,8)
- +10 ;Provider/Vendor IEN
- SET BMCSPRV=$PIECE(BMCRREC,U,7)
- +11 IF BMCSPRV'=""
- SET BMCSPRV=$PIECE(^AUTTVNDR(BMCSPRV,0),U)
- +12 SET Y=BMCAPPT
- DO DD^%DT
- SET BMCAPPT=Y
- +13 WRITE !,"Expected Appoinment Date: ",BMCAPPT
- +14 WRITE !,"Purpose of Appointment: ",BMCPUR
- +15 WRITE !,"Contract Vendor: ",BMCSPRV
- +16 IF BMCIHSP'=""
- SET BMCIHSP=$PIECE(^DIC(4,BMCIHSP,0),U)
- +17 WRITE !,"IHS Facility: ",BMCIHSP
- +18 ;
- LOCAT ;Print Local Categories
- +1 IF $DATA(^BMCREF(BMCREF,21,0))
- Begin DoDot:1
- +2 SET BMCLOCC=0
- +3 FOR
- SET BMCLOCC=$ORDER(^BMCREF(BMCREF,21,"B",BMCLOCC))
- IF BMCLOCC'=+BMCLOCC
- QUIT
- Begin DoDot:2
- +4 SET BMCLOCI=0
- +5 FOR
- SET BMCLOCI=$ORDER(^BMCREF(BMCREF,21,"B",BMCLOCC,BMCLOCI))
- IF BMCLOCI'=+BMCLOCI
- QUIT
- Begin DoDot:3
- +6 SET BMCLOCP=$PIECE(^BMCREF(BMCREF,21,BMCLOCI,0),U)
- +7 IF BMCLOCP=""
- QUIT
- +8 SET BMCLOCPP=$PIECE(^BMCLCAT(BMCLOCP,0),U)
- +9 WRITE !,"Local Category: "_BMCLOCPP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 ;
- +11 ;
- ALT ;Alternate Resource Letter Date
- +1 IF $Y>(IOSL-3)
- DO HEAD
- IF BMCQUIT
- QUIT
- +2 WRITE !,"Alternate Resource Letter Date: ",$$VAL^XBDIQ1(90001,BMCREF,1401)
- +3 ;
- BO ;Business office comments
- +1 SET BMCI=0
- SET Y=0
- +2 FOR
- SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
- IF BMCI'?1N.N
- QUIT
- Begin DoDot:1
- +3 IF $PIECE(^BMCCOM(BMCI,0),U,5)'="B"
- QUIT
- +4 IF Y=0
- WRITE !,"Business Office Comments:"
- +5 SET BMCNODE=1
- SET BMCIOM=70
- SET BMCFILE=90001.03
- SET BMCDA=BMCI
- DO WP^BMCFDR
- KILL BMCIOM
- +6 SET Y=0
- FOR
- SET Y=$ORDER(BMCWP(Y))
- IF Y'=+Y!(BMCQUIT)
- QUIT
- Begin DoDot:2
- +7 IF $Y>(IOSL-3)
- DO HEAD
- IF BMCQUIT
- QUIT
- +8 WRITE !?5,BMCWP(Y)
- End DoDot:2
- End DoDot:1
- IF BMCQUIT
- QUIT
- +9 IF BMCQUIT
- QUIT
- NEXT ;
- +1 WRITE !,"--------------------",!
- +2 QUIT
- HEAD ;ENTRY POINT
- +1 NEW X,Y,Z,C
- +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 SET BMCPG=BMCPG+1
- +2 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
- +3 WRITE !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
- +4 SET Y=DT
- DO DD^%DT
- WRITE ?(80-$LENGTH(Y)/2),Y,!
- +5 WRITE ?21,"**SECONDARY PROVIDER LETTER BY DATE**",!
- +6 SET Y=BMCBD
- DO DD^%DT
- WRITE ?17,"BEG DATE: "_Y
- +7 SET Y=BMCED
- DO DD^%DT
- WRITE ?40,"END DATE: "_Y,!
- +8 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
- +9 QUIT
