LRTOCOST ;KC/RENO/DALISC/FHS - ORDERING STATISTICS/COST REPORT ; 17-Oct-2014 09:22 ; MKK
;;5.2;LR;**153,201,221,1018,1022,1034**;NOV 1, 1997;Build 88
;
;Original routine written by Keith Cox - Reno VAMC
EN S LREND=0 K LRGLB
W @IOF,!!,$$CJ^XLFSTR("*** DATE RANGE SELECTION ***",80),!
S LREDT=$$FMTE^XLFDT(DT) D ^LRWU3 G:$G(LREND) EXIT
S LREDT=$P(LREDT,"."),LRSDT=$P(LRSDT,".")
S LRPBDAY=$$FMTE^XLFDT(LREDT)
S LRPEDAY=$$FMTE^XLFDT(LRSDT)
DIV ;
K DIR,LRCDIV D G:$G(LREND) EXIT
. S DIR(0)="PO^DIC(4,:AENM",DIR("A")="Select Accessioning Div "
. W !!?10,"<Optional Screen> Press return to select all Divisions",!
. F D READ Q:$G(LREND)!(Y<1) S LRCDIV(+Y)=Y
REF K DIR,LRLLOC,LRPRAC,LRSITE
S DIR("A")="Sort Report By ",DIR(0)="S^0:ALL Patients;1:REFFERAL Patients Only" D READ G:$G(LREND)!($D(DIRUT)) EXIT
S LRREF=Y W ! I LRREF=1 S LRSORT=1 G SORTBY
SORT K DIR S DIR("A")="Sort Report By ",DIR(0)="S^0:PROVIDER;1:LOCATION" D READ G:$G(LREND)!($D(DIRUT)) EXIT
S LRSORT=Y
;
SORTBY K DIR S (LRLLOC,LRPRAC)=""
I LRREF=1,LRSORT=1 D G:$G(LREND) EXIT
. S DIR(0)="PO^DIC(4,:AENM",DIR("A")="Select Referral Site "
. W !!?10,"<Optional Screen> Press return to select all Referral Sites",!
. F D READ Q:$G(LREND)!(Y<1) S LRLLOC($P(Y,U,2))=""
K DIR
I LRSORT=0,LRREF=0 D G:$G(LREND) EXIT
. S DIR(0)="PO^VA(200,:AENM",DIR("A")="Search for What Ordering Provider "
. W !!?10,"<Optional Screen> Press return to select all Providers",!
. F D READ Q:$G(LREND)!(Y<1) S LRPRAC(+Y)=""
K DIR
I LRREF=0,LRSORT=1 D G:$G(LREND) EXIT
. S DIR(0)="PO^SC(:AENZM",DIR("A")="Select Ordering Location "
. W !!?10,"<Optional Screen> Press return to select all Locations ",!
. F D READ Q:$G(LREND)!(Y<1) S LRLLOC($P(Y(0),U,2))=""
I LRSORT D
. W !!?5,"You can search for locations using a Free Text screen"
. W !?8,"Your entry must match exactly the stored location"
. S DIR(0)="FO^2:30",DIR("A")="Enter Non-Standard Locations"
. W !!?10,"<Optional Screen> Press return to select all Locations ",!
. F D READ Q:$G(LREND)!('$L(Y)) S LRLLOC(Y)=""
PRICE K DIR S DIR("A")="Print report using ",DIR(0)="S^1:Cost;2:Price" D READ
G:$G(LREND)!($D(DIRUT)) EXIT
S LRPRICE=Y
TEST K DIR,LRT S LRT=""
D G:$G(LREND) EXIT
. S DIR(0)="PO^LAB(60,:AENM",DIR("A")="Select Ordered Tests "
. W !!?10,"<Optional Screen> Press return to select all Tests",!
. F D READ Q:$G(LREND)!(Y<1) S LRT(+Y)=""
K DIR
DET S DIR("A")="Would you like a detailed patient listing? ",DIR(0)="S^0:No;1:Yes" D READ G:$G(LREND)!($D(DIRUT)) EXIT
S LRDET=Y W !!
QUE K ZTSAVE,I,DIR
S ZTSAVE("LR*")=""
D EN^XUTMDEVQ("START^LRTOCOST","Lab Order Stats",.ZTSAVE) D EXIT
Q
START S:$D(ZTQUEUED) ZTREQ="@"
W:$E(IOST,1,2)="C-" @IOF
K ^TMP("LR",$J) S LRODT=LREDT-.0001
S ^TMP("LR",$J,0)=DT_U_DT_U_"LEDI COST REPORT"
F S LRODT=$O(^LRO(69,LRODT)) Q:LRODT<1!(LRODT>LRSDT) D LOOP
PRT I $D(LRCDIV) S LRDIVP="Division(s) / ",I=0 F S I=$O(LRCDIV(I)) Q:I<1 S LRDIVP=LRDIVP_$P(LRCDIV(I),U,2)_" / "
S LRPAGE=0,LRLINE="",$P(LRLINE,"-",81)="",LRPNOW=$$FMTE^XLFDT($$NOW^XLFDT) D HDR G:$G(LREND) EXIT
PPHY S LRPPHY="" F S LRPPHY=$O(^TMP("LR",$J,1,LRPPHY)) Q:LRPPHY=""!($G(LREND)) S LRPHY=0 F S LRPHY=$O(^TMP("LR",$J,1,LRPPHY,LRPHY)) Q:LRPHY=""!($G(LREND)) D PHYS,PTST,PURG
RTOT S (LRFTOT,LRFCTOT)=0 D HDR G:$G(LREND) EXIT W !,"FACILITY TOTALS by : "_$S($G(LRSORT):"Location ",1:"Provider")
W !?10,$S($G(LRREF):" Referral Patients ",1:"All Patients "),!
W !!?28," ***TESTS*** QUANTITY "_$S(LRPRICE=1:" COST",1:"PRICE")_" TOTAL COST "
S LRPTST="" F S LRPTST=$O(^TMP("LR",$J,3,LRPTST)) Q:LRPTST=""!($G(LREND)) D:($Y>(IOSL-4)) HDR Q:$G(LREND) D RTOT1 D:$Y>(IOSL-4) HDR
G:$G(LREND) EXIT
W !?45,"--------",?69,"----------",!?43,$J(LRFTOT,10),?69,$J(LRFCTOT,10,2)
D:$Y>(IOSL-4) HDR G:$G(LREND) EXIT W !!?28,"***URGENCY***" S LRPURG=""
F S LRPURG=$O(^TMP("LR",$J,4,LRPURG)) Q:LRPURG=""!($G(LREND)) D:$Y>(IOSL-4) HDR Q:$G(LREND) W !,$J(LRPURG,41),": ",$J(^TMP("LR",$J,4,LRPURG),10)
DETAIL I $G(LRDET) D
. S LRLOC=""
. S I=$O(^TMP("LR",$J,6,0)) I '$L(I) D HDR W !?7,"No Detailed data to report",!! Q
. S LRGLB="^TMP(""LR"","_$J_",6)",LRPNM=""
. D HDR Q:$G(LREND)
.; F S LRGLB=$Q(@LRGLB) Q:$QS(LRGLB,2)'=$J!($QS(LRGLB,3)'=6)!($G(LREND)) D
.;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS TESTING CHANGE
. ; F S LRGLB=$Q(@LRGLB) Q:LRGLB="" Q:$QS(LRGLB,2)'=$J!($QS(LRGLB,3)'=6)!($G(LREND)) D
.;----- END IHS MODIFICATIONS
. ; ----- IHS/OIT/MKK - Begin IHS PATCH 1022 MODIFICATION
. ; The Patch 18 "fix" above doesn't work.
. F S LRGLB=$Q(@LRGLB) Q:$G(LRGLB)="" Q:$QS(LRGLB,2)'=$J!($QS(LRGLB,3)'=6)!($G(LREND)) D
. . ; ----- IHS/OIT/MKK - End IHS PATCH 1022 MODIFICATION
. . D:$Y>(IOSL-4) HDR Q:$G(LREND)
. . S LRLOCN=$QS(LRGLB,4) I LRLOCN'=LRLOC W !!?10,"***** "_LRLOCN_" *****" S LRLOC=LRLOCN
. . ; S LRNAME=$QS(LRGLB,5)_" "_$QS(LRGLB,6)_" "_$$FMTE^XLFDT($QS(LRGLB,7))
. . ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
. . S PTIEN=$$FIND1^DIC(2,,"C",$QS(LRGLB,5))
. . S HRCN=$$GET1^DIQ(9000001.41,DUZ(2)_","_PTIEN_",","HEALTH RECORD NO.")
. . S LRNAME=$QS(LRGLB,5)_" "_HRCN_" "_$$FMTE^XLFDT($QS(LRGLB,7))
. . ; ----- END IHS/MSC/MKK - LR*5.2*1034
. . I LRNAME'=LRPNM W !!,LRNAME S LRPNM=LRNAME
. . W !?10,$QS(LRGLB,8)_" $ "_@LRGLB
EXIT W ! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC
K ^TMP("LR",$J)
K DIR,DIRUT,DTOUT,DUOUT,I,LR0,LRBDAY,LRCDIV,LRCDT,LRCOST,LRDET,LRDIV,LRDFN,LREDAY
K LRDIVP,LRDPF,LRTST,LRPPHY,LRPNOW,LRFTOT
K LREDT,LREND,LRFCTOT,LRGLB,LRII,LRLINE,LRLLOC,LRLOC,LRLOCN,LRNAME
K LRNLT,LRNODE,LRODT,LRPAGE,LRPBDAY,LRPCTOT,LRPEDAY,LRPHY,LRPNM
K LRPRAC,LRPRICE,LRPTOT,LRPTST,LRPURG,LRREF,LRSDT,LRSITE,LRSN,LRSORT
K LRSPC,LRT,LRTCT,LRURG,PNM,POP,SSN,X,Y,ZTSAVE
K HRCN,PTIEN ; IHS/MSC/MKK - LR*5.2*1034
Q
LOOP S LRSN=0 F S LRSN=$O(^LRO(69,LRODT,1,LRSN)) Q:LRSN<1 I $D(^(LRSN,0))#2 S LRNODE=^(0) D
. Q:$P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C" S LRCDT=+$G(^(1)),LRDIV=$P($G(^(1)),U,8)
. Q:'LRCDT I $D(LRCDIV),'$D(LRCDIV(+LRDIV)) Q
. S LRSPC=+$G(^LRO(69,LRODT,1,LRSN,4,1,0))
. Q:'$D(^LR(+LRNODE,0))#2 S LRDPF=$P(^(0),U,2),LRDFN=$P(^(0),U,3)
. Q:$S('$G(LRDPF):1,'$G(LRDFN):1,LRDPF=2:0,LRDPF=67:0,1:1)
. I $G(LRREF) Q:LRDPF'=67
. I '$G(LRSORT) S LRPHY=$P(LRNODE,U,6) I $L(LRPHY) D LOOP1
. I $G(LRSORT) S LRPHY=$P(LRNODE,U,7) I $L(LRPHY) D LOOP1
Q
LOOP1 I '$G(LRSORT),$D(LRPRAC)=11,'$D(LRPRAC(LRPHY)) Q
I $G(LRSORT),$D(LRLLOC)=11,'$D(LRLLOC(LRPHY)) Q
S LRII=0 F S LRII=$O(^LRO(69,LRODT,1,LRSN,2,LRII)) Q:LRII<1 S LR0=^LRO(69,LRODT,1,LRSN,2,LRII,0),LRTST=+LR0,LRURG=$P(LR0,U,2) I '$P(LR0,U,11),LRTST,LRURG,$P(LR0,U,3) D SET
Q
SET I $D(LRT)=11,'$D(LRT(LRTST))#2 Q
I $G(LRSORT) S LRPPHY=LRPHY
I '$G(LRSORT) S LRPPHY=$S($D(^VA(200,+LRPHY,0)):$P(^(0),U),1:LRPHY)
Q:'$D(^LAB(60,+LRTST,0))#2 S LRPTST=$P(^(0),U),LRNLT=+$P($G(^(64)),U)
S LRCOST=""
I LRPRICE=1 S LRCOST=$S($P($G(^LAM(LRNLT,5,LRSPC,0)),U,2):$P(^(0),U,2),1:"")
I LRPRICE=2 S LRCOST=$S($P($G(^LAM(LRNLT,5,LRSPC,0)),U,3):$P(^(0),U,3),1:"")
I 'LRCOST D
. I LRPRICE=1 S LRCOST=+$S($P($G(^LAM(LRNLT,0)),U,10):$P(^(0),U,10),1:LRCOST)
. I LRPRICE=2 S LRCOST=+$S($P($G(^LAM(LRNLT,0)),U,11):$P(^(0),U,11),1:LRCOST)
I 'LRCOST S LRCOST=+$P(^LAB(60,+LRTST,0),U,11)
S ^TMP("LR",$J,5,LRPTST)=$S(LRCOST:LRCOST,1:1)
S ^TMP("LR",$J,1,LRPPHY,LRPHY,LRPTST)=$G(^TMP("LR",$J,1,LRPPHY,LRPHY,LRPTST))+1,^TMP("LR",$J,3,LRPTST)=$G(^TMP("LR",$J,3,LRPTST))+1
S LRPURG=$P(^LAB(62.05,LRURG,0),U),^TMP("LR",$J,2,LRPPHY,LRPHY,LRPURG)=$G(^TMP("LR",$J,2,LRPPHY,LRPHY,LRPURG))+1,^TMP("LR",$J,4,LRPURG)=$G(^TMP("LR",$J,4,LRPURG))+1
I $G(LRDET) D
. ;S LRDPF=$P(^LR(+LRNODE,0),U,2),LRDFN=$P(^(0),U,3)
. S X=^DIC(LRDPF,0,"GL")_LRDFN_",0)",X=$S($D(@X):@X,1:"")
. Q:X=""
. S PNM=$P(X,U),SSN=$P(X,U,9)
. ; ----- IHS/OIT/MKK - Begin IHS PATCH 1022 MODIFICATION
. ; The following IHS line of code was inadvertnatly left off during
. ; the Patch 18 process after the VA patches updated this routine.
. S:SSN="" SSN="999-99-9999" ;FJE
. ; ----- IHS/OIT/MKK - End IHS PATCH 1022 MODIFICATION
. S ^TMP("LR",$J,6,LRPPHY,PNM,SSN,LRCDT,LRPTST)=$S(LRCOST:LRCOST,1:1)
Q
HDR Q:$G(LREND) I $E(IOST)="C",$G(LRPAGE) S DIR(0)="E" D ^DIR S:$D(DUOUT)!($D(DIRUT))!($D(DTOUT)) LREND=1 Q:$G(LREND)
W:$G(LRPAGE) @IOF
S LRPAGE=$G(LRPAGE)+1
I $D(LRGLB) W LRLINE,!,$$CJ^XLFSTR("<*> Detailed Patient Listing <*>",80)
W:'$D(LRGLB) LRLINE,!?17,"<*> LABORATORY TEST ORDERING STATISTICS <*>"
I $L($G(LRDIVP)) W !,$$CJ^XLFSTR(LRDIVP,80)
I $G(LRREF) W !,$$CJ^XLFSTR("Referral Patients Only Report",80)
W !,$$CJ^XLFSTR("For tests ordered during the date range ",80)
W !,$$CJ^XLFSTR(LRPBDAY_" to "_LRPEDAY,80)
W !,$$CJ^XLFSTR("Dollar Amounts computed using "_$S(LRPRICE=1:"COST",1:"PRICE "),80)
I $D(LRT)=11 D
. W !,$$CJ^XLFSTR("** SELECTED TESTS ONLY **",80)
. W ! S I="" F S I=$O(LRT(I)) Q:I<1 W $P($G(^LAB(60,I,0)),U)_" / " W:$X+30>80 !
W !,"Date printed: ",LRPNOW,?(60-$L(LRPAGE)),"Page: ",LRPAGE,!,LRLINE,!
Q
PHYS Q:$G(LREND) S (LRPTOT,LRPCTOT)=0 D:$Y>(IOSL-8) HDR Q:$G(LREND) W !!,$S($G(LRSORT):"Location: ",1:"Provider: "),LRPPHY I '$G(LRSORT) W:LRPHY " (",LRPHY,")"
Q
PTST Q:$G(LREND) D:$Y>(IOSL-8) HDR Q:$G(LREND)
W !?28," ***TESTS*** QUANTITY "_$S(LRPRICE=1:" COST",1:" PRICE")_" TOTAL COST " S LRPTST=""
F S LRPTST=$O(^TMP("LR",$J,1,LRPPHY,LRPHY,LRPTST)) Q:LRPTST=""!($G(LREND)) D:$Y>(IOSL-4) HDR Q:$G(LREND) D PTST1
Q:$G(LREND)
W !?45,"--------",?69,"----------",!?43,$J(LRPTOT,10),?67,"$",$J(LRPCTOT,10,2)
Q
PTST1 D:$Y>(IOSL-4) HDR Q:$G(LREND)
W !,$J(LRPTST,41),": " S LRTCT=^TMP("LR",$J,1,LRPPHY,LRPHY,LRPTST),LRCOST=^TMP("LR",$J,5,LRPTST) W $J(LRTCT,10),?55,$J(LRCOST,10,2),?67,"$",$J(LRTCT*LRCOST,10,2)
S LRPTOT=LRPTOT+LRTCT,LRPCTOT=LRPCTOT+(LRTCT*LRCOST)
Q
PURG Q:$G(LREND) D:($Y>(IOSL-6)) HDR Q:$G(LREND) W !!?28,"***URGENCY***"
S LRPURG="" F S LRPURG=$O(^TMP("LR",$J,2,LRPPHY,LRPHY,LRPURG)) Q:LRPURG="" D
. D:$Y>(IOSL-4) HDR Q:$G(LREND) W !,$J(LRPURG,41),": ",$J(^TMP("LR",$J,2,LRPPHY,LRPHY,LRPURG),10)
Q
RTOT1 D:$Y>(IOSL-4) HDR Q:$G(LREND)
W !,$J(LRPTST,41),": " S LRTCT=^TMP("LR",$J,3,LRPTST),LRCOST=^TMP("LR",$J,5,LRPTST) W $J(LRTCT,10),?55,$J(LRCOST,10,2),?67,"$",$J(LRTCT*LRCOST,10,2)
S LRFTOT=LRFTOT+LRTCT,LRFCTOT=LRFCTOT+(LRTCT*LRCOST)
Q
READ ;
D ^DIR S:$D(DTOUT)!($D(DUOUT)) LREND=1
Q
LRTOCOST ;KC/RENO/DALISC/FHS - ORDERING STATISTICS/COST REPORT ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LR;**153,201,221,1018,1022,1034**;NOV 1, 1997;Build 88
+2 ;
+3 ;Original routine written by Keith Cox - Reno VAMC
EN SET LREND=0
KILL LRGLB
+1 WRITE @IOF,!!,$$CJ^XLFSTR("*** DATE RANGE SELECTION ***",80),!
+2 SET LREDT=$$FMTE^XLFDT(DT)
DO ^LRWU3
IF $GET(LREND)
GOTO EXIT
+3 SET LREDT=$PIECE(LREDT,".")
SET LRSDT=$PIECE(LRSDT,".")
+4 SET LRPBDAY=$$FMTE^XLFDT(LREDT)
+5 SET LRPEDAY=$$FMTE^XLFDT(LRSDT)
DIV ;
+1 KILL DIR,LRCDIV
Begin DoDot:1
+2 SET DIR(0)="PO^DIC(4,:AENM"
SET DIR("A")="Select Accessioning Div "
+3 WRITE !!?10,"<Optional Screen> Press return to select all Divisions",!
+4 FOR
DO READ
IF $GET(LREND)!(Y<1)
QUIT
SET LRCDIV(+Y)=Y
End DoDot:1
IF $GET(LREND)
GOTO EXIT
REF KILL DIR,LRLLOC,LRPRAC,LRSITE
+1 SET DIR("A")="Sort Report By "
SET DIR(0)="S^0:ALL Patients;1:REFFERAL Patients Only"
DO READ
IF $GET(LREND)!($DATA(DIRUT))
GOTO EXIT
+2 SET LRREF=Y
WRITE !
IF LRREF=1
SET LRSORT=1
GOTO SORTBY
SORT KILL DIR
SET DIR("A")="Sort Report By "
SET DIR(0)="S^0:PROVIDER;1:LOCATION"
DO READ
IF $GET(LREND)!($DATA(DIRUT))
GOTO EXIT
+1 SET LRSORT=Y
+2 ;
SORTBY KILL DIR
SET (LRLLOC,LRPRAC)=""
+1 IF LRREF=1
IF LRSORT=1
Begin DoDot:1
+2 SET DIR(0)="PO^DIC(4,:AENM"
SET DIR("A")="Select Referral Site "
+3 WRITE !!?10,"<Optional Screen> Press return to select all Referral Sites",!
+4 FOR
DO READ
IF $GET(LREND)!(Y<1)
QUIT
SET LRLLOC($PIECE(Y,U,2))=""
End DoDot:1
IF $GET(LREND)
GOTO EXIT
+5 KILL DIR
+6 IF LRSORT=0
IF LRREF=0
Begin DoDot:1
+7 SET DIR(0)="PO^VA(200,:AENM"
SET DIR("A")="Search for What Ordering Provider "
+8 WRITE !!?10,"<Optional Screen> Press return to select all Providers",!
+9 FOR
DO READ
IF $GET(LREND)!(Y<1)
QUIT
SET LRPRAC(+Y)=""
End DoDot:1
IF $GET(LREND)
GOTO EXIT
+10 KILL DIR
+11 IF LRREF=0
IF LRSORT=1
Begin DoDot:1
+12 SET DIR(0)="PO^SC(:AENZM"
SET DIR("A")="Select Ordering Location "
+13 WRITE !!?10,"<Optional Screen> Press return to select all Locations ",!
+14 FOR
DO READ
IF $GET(LREND)!(Y<1)
QUIT
SET LRLLOC($PIECE(Y(0),U,2))=""
End DoDot:1
IF $GET(LREND)
GOTO EXIT
+15 IF LRSORT
Begin DoDot:1
+16 WRITE !!?5,"You can search for locations using a Free Text screen"
+17 WRITE !?8,"Your entry must match exactly the stored location"
+18 SET DIR(0)="FO^2:30"
SET DIR("A")="Enter Non-Standard Locations"
+19 WRITE !!?10,"<Optional Screen> Press return to select all Locations ",!
+20 FOR
DO READ
IF $GET(LREND)!('$LENGTH(Y))
QUIT
SET LRLLOC(Y)=""
End DoDot:1
PRICE KILL DIR
SET DIR("A")="Print report using "
SET DIR(0)="S^1:Cost;2:Price"
DO READ
+1 IF $GET(LREND)!($DATA(DIRUT))
GOTO EXIT
+2 SET LRPRICE=Y
TEST KILL DIR,LRT
SET LRT=""
+1 Begin DoDot:1
+2 SET DIR(0)="PO^LAB(60,:AENM"
SET DIR("A")="Select Ordered Tests "
+3 WRITE !!?10,"<Optional Screen> Press return to select all Tests",!
+4 FOR
DO READ
IF $GET(LREND)!(Y<1)
QUIT
SET LRT(+Y)=""
End DoDot:1
IF $GET(LREND)
GOTO EXIT
+5 KILL DIR
DET SET DIR("A")="Would you like a detailed patient listing? "
SET DIR(0)="S^0:No;1:Yes"
DO READ
IF $GET(LREND)!($DATA(DIRUT))
GOTO EXIT
+1 SET LRDET=Y
WRITE !!
QUE KILL ZTSAVE,I,DIR
+1 SET ZTSAVE("LR*")=""
+2 DO EN^XUTMDEVQ("START^LRTOCOST","Lab Order Stats",.ZTSAVE)
DO EXIT
+3 QUIT
START IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 KILL ^TMP("LR",$JOB)
SET LRODT=LREDT-.0001
+3 SET ^TMP("LR",$JOB,0)=DT_U_DT_U_"LEDI COST REPORT"
+4 FOR
SET LRODT=$ORDER(^LRO(69,LRODT))
IF LRODT<1!(LRODT>LRSDT)
QUIT
DO LOOP
PRT IF $DATA(LRCDIV)
SET LRDIVP="Division(s) / "
SET I=0
FOR
SET I=$ORDER(LRCDIV(I))
IF I<1
QUIT
SET LRDIVP=LRDIVP_$PIECE(LRCDIV(I),U,2)_" / "
+1 SET LRPAGE=0
SET LRLINE=""
SET $PIECE(LRLINE,"-",81)=""
SET LRPNOW=$$FMTE^XLFDT($$NOW^XLFDT)
DO HDR
IF $GET(LREND)
GOTO EXIT
PPHY SET LRPPHY=""
FOR
SET LRPPHY=$ORDER(^TMP("LR",$JOB,1,LRPPHY))
IF LRPPHY=""!($GET(LREND))
QUIT
SET LRPHY=0
FOR
SET LRPHY=$ORDER(^TMP("LR",$JOB,1,LRPPHY,LRPHY))
IF LRPHY=""!($GET(LREND))
QUIT
DO PHYS
DO PTST
DO PURG
RTOT SET (LRFTOT,LRFCTOT)=0
DO HDR
IF $GET(LREND)
GOTO EXIT
WRITE !,"FACILITY TOTALS by : "_$SELECT($GET(LRSORT):"Location ",1:"Provider")
+1 WRITE !?10,$SELECT($GET(LRREF):" Referral Patients ",1:"All Patients "),!
+2 WRITE !!?28," ***TESTS*** QUANTITY "_$SELECT(LRPRICE=1:" COST",1:"PRICE")_" TOTAL COST "
+3 SET LRPTST=""
FOR
SET LRPTST=$ORDER(^TMP("LR",$JOB,3,LRPTST))
IF LRPTST=""!($GET(LREND))
QUIT
IF ($Y>(IOSL-4))
DO HDR
IF $GET(LREND)
QUIT
DO RTOT1
IF $Y>(IOSL-4)
DO HDR
+4 IF $GET(LREND)
GOTO EXIT
+5 WRITE !?45,"--------",?69,"----------",!?43,$JUSTIFY(LRFTOT,10),?69,$JUSTIFY(LRFCTOT,10,2)
+6 IF $Y>(IOSL-4)
DO HDR
IF $GET(LREND)
GOTO EXIT
WRITE !!?28,"***URGENCY***"
SET LRPURG=""
+7 FOR
SET LRPURG=$ORDER(^TMP("LR",$JOB,4,LRPURG))
IF LRPURG=""!($GET(LREND))
QUIT
IF $Y>(IOSL-4)
DO HDR
IF $GET(LREND)
QUIT
WRITE !,$JUSTIFY(LRPURG,41),": ",$JUSTIFY(^TMP("LR",$JOB,4,LRPURG),10)
DETAIL IF $GET(LRDET)
Begin DoDot:1
+1 SET LRLOC=""
+2 SET I=$ORDER(^TMP("LR",$JOB,6,0))
IF '$LENGTH(I)
DO HDR
WRITE !?7,"No Detailed data to report",!!
QUIT
+3 SET LRGLB="^TMP(""LR"","_$JOB_",6)"
SET LRPNM=""
+4 DO HDR
IF $GET(LREND)
QUIT
+5 ; F S LRGLB=$Q(@LRGLB) Q:$QS(LRGLB,2)'=$J!($QS(LRGLB,3)'=6)!($G(LREND)) D
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS TESTING CHANGE
+7 ; F S LRGLB=$Q(@LRGLB) Q:LRGLB="" Q:$QS(LRGLB,2)'=$J!($QS(LRGLB,3)'=6)!($G(LREND)) D
+8 ;----- END IHS MODIFICATIONS
+9 ; ----- IHS/OIT/MKK - Begin IHS PATCH 1022 MODIFICATION
+10 ; The Patch 18 "fix" above doesn't work.
+11 FOR
SET LRGLB=$QUERY(@LRGLB)
IF $GET(LRGLB)=""
QUIT
IF $QSUBSCRIPT(LRGLB,2)'=$JOB!($QSUBSCRIPT(LRGLB,3)'=6)!($GET(LREND))
QUIT
Begin DoDot:2
+12 ; ----- IHS/OIT/MKK - End IHS PATCH 1022 MODIFICATION
+13 IF $Y>(IOSL-4)
DO HDR
IF $GET(LREND)
QUIT
+14 SET LRLOCN=$QSUBSCRIPT(LRGLB,4)
IF LRLOCN'=LRLOC
WRITE !!?10,"***** "_LRLOCN_" *****"
SET LRLOC=LRLOCN
+15 ; S LRNAME=$QS(LRGLB,5)_" "_$QS(LRGLB,6)_" "_$$FMTE^XLFDT($QS(LRGLB,7))
+16 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+17 SET PTIEN=$$FIND1^DIC(2,,"C",$QSUBSCRIPT(LRGLB,5))
+18 SET HRCN=$$GET1^DIQ(9000001.41,DUZ(2)_","_PTIEN_",","HEALTH RECORD NO.")
+19 SET LRNAME=$QSUBSCRIPT(LRGLB,5)_" "_HRCN_" "_$$FMTE^XLFDT($QSUBSCRIPT(LRGLB,7))
+20 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+21 IF LRNAME'=LRPNM
WRITE !!,LRNAME
SET LRPNM=LRNAME
+22 WRITE !?10,$QSUBSCRIPT(LRGLB,8)_" $ "_@LRGLB
End DoDot:2
End DoDot:1
EXIT WRITE !
IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
+1 KILL ^TMP("LR",$JOB)
+2 KILL DIR,DIRUT,DTOUT,DUOUT,I,LR0,LRBDAY,LRCDIV,LRCDT,LRCOST,LRDET,LRDIV,LRDFN,LREDAY
+3 KILL LRDIVP,LRDPF,LRTST,LRPPHY,LRPNOW,LRFTOT
+4 KILL LREDT,LREND,LRFCTOT,LRGLB,LRII,LRLINE,LRLLOC,LRLOC,LRLOCN,LRNAME
+5 KILL LRNLT,LRNODE,LRODT,LRPAGE,LRPBDAY,LRPCTOT,LRPEDAY,LRPHY,LRPNM
+6 KILL LRPRAC,LRPRICE,LRPTOT,LRPTST,LRPURG,LRREF,LRSDT,LRSITE,LRSN,LRSORT
+7 KILL LRSPC,LRT,LRTCT,LRURG,PNM,POP,SSN,X,Y,ZTSAVE
+8 ; IHS/MSC/MKK - LR*5.2*1034
KILL HRCN,PTIEN
+9 QUIT
LOOP SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,LRODT,1,LRSN))
IF LRSN<1
QUIT
IF $DATA(^(LRSN,0))#2
SET LRNODE=^(0)
Begin DoDot:1
+1 IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C"
QUIT
SET LRCDT=+$GET(^(1))
SET LRDIV=$PIECE($GET(^(1)),U,8)
+2 IF 'LRCDT
QUIT
IF $DATA(LRCDIV)
IF '$DATA(LRCDIV(+LRDIV))
QUIT
+3 SET LRSPC=+$GET(^LRO(69,LRODT,1,LRSN,4,1,0))
+4 IF '$DATA(^LR(+LRNODE,0))#2
QUIT
SET LRDPF=$PIECE(^(0),U,2)
SET LRDFN=$PIECE(^(0),U,3)
+5 IF $SELECT('$GET(LRDPF)
QUIT
+6 IF $GET(LRREF)
IF LRDPF'=67
QUIT
+7 IF '$GET(LRSORT)
SET LRPHY=$PIECE(LRNODE,U,6)
IF $LENGTH(LRPHY)
DO LOOP1
+8 IF $GET(LRSORT)
SET LRPHY=$PIECE(LRNODE,U,7)
IF $LENGTH(LRPHY)
DO LOOP1
End DoDot:1
+9 QUIT
LOOP1 IF '$GET(LRSORT)
IF $DATA(LRPRAC)=11
IF '$DATA(LRPRAC(LRPHY))
QUIT
+1 IF $GET(LRSORT)
IF $DATA(LRLLOC)=11
IF '$DATA(LRLLOC(LRPHY))
QUIT
+2 SET LRII=0
FOR
SET LRII=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRII))
IF LRII<1
QUIT
SET LR0=^LRO(69,LRODT,1,LRSN,2,LRII,0)
SET LRTST=+LR0
SET LRURG=$PIECE(LR0,U,2)
IF '$PIECE(LR0,U,11)
IF LRTST
IF LRURG
IF $PIECE(LR0,U,3)
DO SET
+3 QUIT
SET IF $DATA(LRT)=11
IF '$DATA(LRT(LRTST))#2
QUIT
+1 IF $GET(LRSORT)
SET LRPPHY=LRPHY
+2 IF '$GET(LRSORT)
SET LRPPHY=$SELECT($DATA(^VA(200,+LRPHY,0)):$PIECE(^(0),U),1:LRPHY)
+3 IF '$DATA(^LAB(60,+LRTST,0))#2
QUIT
SET LRPTST=$PIECE(^(0),U)
SET LRNLT=+$PIECE($GET(^(64)),U)
+4 SET LRCOST=""
+5 IF LRPRICE=1
SET LRCOST=$SELECT($PIECE($GET(^LAM(LRNLT,5,LRSPC,0)),U,2):$PIECE(^(0),U,2),1:"")
+6 IF LRPRICE=2
SET LRCOST=$SELECT($PIECE($GET(^LAM(LRNLT,5,LRSPC,0)),U,3):$PIECE(^(0),U,3),1:"")
+7 IF 'LRCOST
Begin DoDot:1
+8 IF LRPRICE=1
SET LRCOST=+$SELECT($PIECE($GET(^LAM(LRNLT,0)),U,10):$PIECE(^(0),U,10),1:LRCOST)
+9 IF LRPRICE=2
SET LRCOST=+$SELECT($PIECE($GET(^LAM(LRNLT,0)),U,11):$PIECE(^(0),U,11),1:LRCOST)
End DoDot:1
+10 IF 'LRCOST
SET LRCOST=+$PIECE(^LAB(60,+LRTST,0),U,11)
+11 SET ^TMP("LR",$JOB,5,LRPTST)=$SELECT(LRCOST:LRCOST,1:1)
+12 SET ^TMP("LR",$JOB,1,LRPPHY,LRPHY,LRPTST)=$GET(^TMP("LR",$JOB,1,LRPPHY,LRPHY,LRPTST))+1
SET ^TMP("LR",$JOB,3,LRPTST)=$GET(^TMP("LR",$JOB,3,LRPTST))+1
+13 SET LRPURG=$PIECE(^LAB(62.05,LRURG,0),U)
SET ^TMP("LR",$JOB,2,LRPPHY,LRPHY,LRPURG)=$GET(^TMP("LR",$JOB,2,LRPPHY,LRPHY,LRPURG))+1
SET ^TMP("LR",$JOB,4,LRPURG)=$GET(^TMP("LR",$JOB,4,LRPURG))+1
+14 IF $GET(LRDET)
Begin DoDot:1
+15 ;S LRDPF=$P(^LR(+LRNODE,0),U,2),LRDFN=$P(^(0),U,3)
+16 SET X=^DIC(LRDPF,0,"GL")_LRDFN_",0)"
SET X=$SELECT($DATA(@X):@X,1:"")
+17 IF X=""
QUIT
+18 SET PNM=$PIECE(X,U)
SET SSN=$PIECE(X,U,9)
+19 ; ----- IHS/OIT/MKK - Begin IHS PATCH 1022 MODIFICATION
+20 ; The following IHS line of code was inadvertnatly left off during
+21 ; the Patch 18 process after the VA patches updated this routine.
+22 ;FJE
IF SSN=""
SET SSN="999-99-9999"
+23 ; ----- IHS/OIT/MKK - End IHS PATCH 1022 MODIFICATION
+24 SET ^TMP("LR",$JOB,6,LRPPHY,PNM,SSN,LRCDT,LRPTST)=$SELECT(LRCOST:LRCOST,1:1)
End DoDot:1
+25 QUIT
HDR IF $GET(LREND)
QUIT
IF $EXTRACT(IOST)="C"
IF $GET(LRPAGE)
SET DIR(0)="E"
DO ^DIR
IF $DATA(DUOUT)!($DATA(DIRUT))!($DATA(DTOUT))
SET LREND=1
IF $GET(LREND)
QUIT
+1 IF $GET(LRPAGE)
WRITE @IOF
+2 SET LRPAGE=$GET(LRPAGE)+1
+3 IF $DATA(LRGLB)
WRITE LRLINE,!,$$CJ^XLFSTR("<*> Detailed Patient Listing <*>",80)
+4 IF '$DATA(LRGLB)
WRITE LRLINE,!?17,"<*> LABORATORY TEST ORDERING STATISTICS <*>"
+5 IF $LENGTH($GET(LRDIVP))
WRITE !,$$CJ^XLFSTR(LRDIVP,80)
+6 IF $GET(LRREF)
WRITE !,$$CJ^XLFSTR("Referral Patients Only Report",80)
+7 WRITE !,$$CJ^XLFSTR("For tests ordered during the date range ",80)
+8 WRITE !,$$CJ^XLFSTR(LRPBDAY_" to "_LRPEDAY,80)
+9 WRITE !,$$CJ^XLFSTR("Dollar Amounts computed using "_$SELECT(LRPRICE=1:"COST",1:"PRICE "),80)
+10 IF $DATA(LRT)=11
Begin DoDot:1
+11 WRITE !,$$CJ^XLFSTR("** SELECTED TESTS ONLY **",80)
+12 WRITE !
SET I=""
FOR
SET I=$ORDER(LRT(I))
IF I<1
QUIT
WRITE $PIECE($GET(^LAB(60,I,0)),U)_" / "
IF $X+30>80
WRITE !
End DoDot:1
+13 WRITE !,"Date printed: ",LRPNOW,?(60-$LENGTH(LRPAGE)),"Page: ",LRPAGE,!,LRLINE,!
+14 QUIT
PHYS IF $GET(LREND)
QUIT
SET (LRPTOT,LRPCTOT)=0
IF $Y>(IOSL-8)
DO HDR
IF $GET(LREND)
QUIT
WRITE !!,$SELECT($GET(LRSORT):"Location: ",1:"Provider: "),LRPPHY
IF '$GET(LRSORT)
IF LRPHY
WRITE " (",LRPHY,")"
+1 QUIT
PTST IF $GET(LREND)
QUIT
IF $Y>(IOSL-8)
DO HDR
IF $GET(LREND)
QUIT
+1 WRITE !?28," ***TESTS*** QUANTITY "_$SELECT(LRPRICE=1:" COST",1:" PRICE")_" TOTAL COST "
SET LRPTST=""
+2 FOR
SET LRPTST=$ORDER(^TMP("LR",$JOB,1,LRPPHY,LRPHY,LRPTST))
IF LRPTST=""!($GET(LREND))
QUIT
IF $Y>(IOSL-4)
DO HDR
IF $GET(LREND)
QUIT
DO PTST1
+3 IF $GET(LREND)
QUIT
+4 WRITE !?45,"--------",?69,"----------",!?43,$JUSTIFY(LRPTOT,10),?67,"$",$JUSTIFY(LRPCTOT,10,2)
+5 QUIT
PTST1 IF $Y>(IOSL-4)
DO HDR
IF $GET(LREND)
QUIT
+1 WRITE !,$JUSTIFY(LRPTST,41),": "
SET LRTCT=^TMP("LR",$JOB,1,LRPPHY,LRPHY,LRPTST)
SET LRCOST=^TMP("LR",$JOB,5,LRPTST)
WRITE $JUSTIFY(LRTCT,10),?55,$JUSTIFY(LRCOST,10,2),?67,"$",$JUSTIFY(LRTCT*LRCOST,10,2)
+2 SET LRPTOT=LRPTOT+LRTCT
SET LRPCTOT=LRPCTOT+(LRTCT*LRCOST)
+3 QUIT
PURG IF $GET(LREND)
QUIT
IF ($Y>(IOSL-6))
DO HDR
IF $GET(LREND)
QUIT
WRITE !!?28,"***URGENCY***"
+1 SET LRPURG=""
FOR
SET LRPURG=$ORDER(^TMP("LR",$JOB,2,LRPPHY,LRPHY,LRPURG))
IF LRPURG=""
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-4)
DO HDR
IF $GET(LREND)
QUIT
WRITE !,$JUSTIFY(LRPURG,41),": ",$JUSTIFY(^TMP("LR",$JOB,2,LRPPHY,LRPHY,LRPURG),10)
End DoDot:1
+3 QUIT
RTOT1 IF $Y>(IOSL-4)
DO HDR
IF $GET(LREND)
QUIT
+1 WRITE !,$JUSTIFY(LRPTST,41),": "
SET LRTCT=^TMP("LR",$JOB,3,LRPTST)
SET LRCOST=^TMP("LR",$JOB,5,LRPTST)
WRITE $JUSTIFY(LRTCT,10),?55,$JUSTIFY(LRCOST,10,2),?67,"$",$JUSTIFY(LRTCT*LRCOST,10,2)
+2 SET LRFTOT=LRFTOT+LRTCT
SET LRFCTOT=LRFCTOT+(LRTCT*LRCOST)
+3 QUIT
READ ;
+1 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET LREND=1
+2 QUIT
