BLRLRRD ;SLC/DCM/BA - INTERIM REPORT BY PHYSICIAN ;2/19/91 11:33 ; [ 08/01/2002 7:56 AM ]
;;5.2;BLR;**1001,1008**;JUN 10, 1998
;;5.2;BLR;**1001**;FEB 1, 1998
;;5.2;LAB SERVICE;;Sep 27, 1994
;from option LRRD
BEGIN D ^LRPARAM S:'$D(LRSINGLE) LRSINGLE=0 D MD
END D ^LRRK K LREDTR,LRSDTR
Q
MD S (LREND,LRSTOP)=0,(LRONETST,LRONESPC,LRPHY,LRFPHY)="",LREPHY="ZZZZZZZZ",LRLAB=$S($D(LRLABKY):1,1:0) K DIC
DTRG ;Allow a date range for look up
K LREDT D ^LRWU3 Q:LREND S LRSDTR=$P(LRSDT,"."),LREDTR=LREDT,LREDT=9999999-LREDT
;K %DT S %DT("A")="DAILY REPORT FOR DAY: ",%DT="EQ" D DATE^LRWU Q:Y<1 K %DT S LRODT=Y,LRSDT=LRODT+.5,LREDT=9999999-LRODT
I 'LRSINGLE F I=0:0 R !,"Do you want (A)ll providers, a (R)ange of physicians,",!,"or (S)elected physicans? S// ",X:DTIME S:X="" X="S" Q:$L(X)=1&("ARS^"[X) W !,"Enter 'A', 'R', 'S' or '^' to exit"
I 'LRSINGLE Q:X[U S LRMD=X
D @$S(LRMD="S":"SELECT",LRMD="R":"RANGE",1:"QUE")
Q
SELECT F I=0:0 K DIC S DIC("A")="Select PROVIDER NAME: ",DIC="^VA(200,",DIC(0)="AEMQ",DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))",D="AK.PROVIDER" D ^DIC Q:Y<1 S LROK=1 D CHECK I LROK,LRSINGLE Q
Q:$D(DUOUT)!$D(DTOUT)!'$L($O(LRPHY(0))) D QUE
Q
CHECK S LRPHY($E($P(Y,U,2),1,20))=""
Q
RANGE K DIC S DIC("A")="Select STARTING PROVIDER NAME: ",DIC="^VA(200,",DIC(0)="AEMQ",DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))",D="AK.PROVIDER" D ^DIC Q:X=U
S LRFPHY=$E($P(Y,U,2),1,20),LRFPHY=$S('$L(LRFPHY):"",1:$E(LRFPHY,1,$L(LRFPHY)-1)_$C($A(LRFPHY,$L(LRFPHY))-1))
S DIC("A")="Select ENDING PROVIDER NAME: " D ^DIC Q:Y<1 S LREPHY=$E($P(Y,U,2),1,20)
QUE S %ZIS="MQ",ZTRTN="DQ^BLRLRRD" D IO^LRWU
Q
DQ ;dequeued
K ^TMP($J) S:$D(ZTQUEUED) ZTREQ="@" U IO
I $D(LREDTR),$D(LRSDTR) S LRODT=(LREDTR-.0001) F S LRODT=$O(^LRO(69,LRODT)) Q:'LRODT!(LRODT>LRSDTR)!(LREND=1) D @$S(LRMD="S":"SEL",1:"RNG")
I '$D(LREDTR),'$D(LRSDTR) D @$S(LRMD="S":"SEL",1:"RNG")
K ^TMP($J)
Q
SEL S (LREND,LRPHY)="",LRJ0=1 F I=0:0 S LRPHY=$O(LRPHY(LRPHY)) Q:LRPHY="" W:'LRJ0 @IOF S LRLTR=LRPHY D:$E(IOST,1,2)'="C-" ^LRLTR D PNAME S LRJ0=0 Q:LREND
W @IOF
Q
RNG S LREND=0,LRJ0=1
F I=0:0 S LRPHY=$O(^LRO(69,LRODT,1,"AP",LRFPHY)) Q:LRPHY=""!($E(LRPHY,20)]LREPHY) D
.S LRFPHY=LRPHY
.W:'LRJ0 @IOF
.S LRLTR=$S(LRPHY="":"UNK",1:LRPHY)
.;D:$E(IOST,1,2)'="C-" ^LRLTR ;IHS/ANMC/CLS 08/18/96
.D PNAME
.S LRJ0=0
.Q:LREND
W @IOF
Q
PNAME S LRPHY1=LRPHY,LREND=0 Q:LREND
D PNAME1 Q:LREND
F I=0:0 S LRPHY1=$O(^LRO(69,LRODT,1,"AP",LRPHY1)) Q:$E(LRPHY1,1,$L(LRPHY))'=LRPHY D PNAME1 Q:LREND
K LRPHY1
Q
PNAME1 ;
S LRNAME="" F I=0:0 S LRNAME=$O(^LRO(69,LRODT,1,"AP",LRPHY1,LRNAME)) Q:LRNAME=""!(LREND=1) D PAT Q:LREND
Q
PAT S LRDFN=0 F I=0:0 S LRDFN=+$O(^LRO(69,LRODT,1,"AP",LRPHY1,LRNAME,LRDFN)) Q:LRDFN<1!(LREND=1) S LRIDT=9999999-LRSDT D:'$D(^TMP($J,LRDFN)) DS^BLRLRRP2 S:LRSTOP LREND=1 Q:LREND S ^TMP($J,LRDFN)=""
Q
SINGLE ;from option LRRD BY MD
S LRSINGLE=1,LRMD="S" D BEGIN
Q
BLRLRRD ;SLC/DCM/BA - INTERIM REPORT BY PHYSICIAN ;2/19/91 11:33 ; [ 08/01/2002 7:56 AM ]
+1 ;;5.2;BLR;**1001,1008**;JUN 10, 1998
+2 ;;5.2;BLR;**1001**;FEB 1, 1998
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 ;from option LRRD
BEGIN DO ^LRPARAM
IF '$DATA(LRSINGLE)
SET LRSINGLE=0
DO MD
END DO ^LRRK
KILL LREDTR,LRSDTR
+1 QUIT
MD SET (LREND,LRSTOP)=0
SET (LRONETST,LRONESPC,LRPHY,LRFPHY)=""
SET LREPHY="ZZZZZZZZ"
SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
KILL DIC
DTRG ;Allow a date range for look up
+1 KILL LREDT
DO ^LRWU3
IF LREND
QUIT
SET LRSDTR=$PIECE(LRSDT,".")
SET LREDTR=LREDT
SET LREDT=9999999-LREDT
+2 ;K %DT S %DT("A")="DAILY REPORT FOR DAY: ",%DT="EQ" D DATE^LRWU Q:Y<1 K %DT S LRODT=Y,LRSDT=LRODT+.5,LREDT=9999999-LRODT
+3 IF 'LRSINGLE
FOR I=0:0
READ !,"Do you want (A)ll providers, a (R)ange of physicians,",!,"or (S)elected physicans? S// ",X:DTIME
IF X=""
SET X="S"
IF $LENGTH(X)=1&("ARS^"[X)
QUIT
WRITE !,"Enter 'A', 'R', 'S' or '^' to exit"
+4 IF 'LRSINGLE
IF X[U
QUIT
SET LRMD=X
+5 DO @$SELECT(LRMD="S":"SELECT",LRMD="R":"RANGE",1:"QUE")
+6 QUIT
SELECT FOR I=0:0
KILL DIC
SET DIC("A")="Select PROVIDER NAME: "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))"
SET D="AK.PROVIDER"
DO ^DIC
IF Y<1
QUIT
SET LROK=1
DO CHECK
IF LROK
IF LRSINGLE
QUIT
+1 IF $DATA(DUOUT)!$DATA(DTOUT)!'$LENGTH($ORDER(LRPHY(0)))
QUIT
DO QUE
+2 QUIT
CHECK SET LRPHY($EXTRACT($PIECE(Y,U,2),1,20))=""
+1 QUIT
RANGE KILL DIC
SET DIC("A")="Select STARTING PROVIDER NAME: "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))"
SET D="AK.PROVIDER"
DO ^DIC
IF X=U
QUIT
+1 SET LRFPHY=$EXTRACT($PIECE(Y,U,2),1,20)
SET LRFPHY=$SELECT('$LENGTH(LRFPHY):"",1:$EXTRACT(LRFPHY,1,$LENGTH(LRFPHY)-1)_$CHAR($ASCII(LRFPHY,$LENGTH(LRFPHY))-1))
+2 SET DIC("A")="Select ENDING PROVIDER NAME: "
DO ^DIC
IF Y<1
QUIT
SET LREPHY=$EXTRACT($PIECE(Y,U,2),1,20)
QUE SET %ZIS="MQ"
SET ZTRTN="DQ^BLRLRRD"
DO IO^LRWU
+1 QUIT
DQ ;dequeued
+1 KILL ^TMP($JOB)
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
+2 IF $DATA(LREDTR)
IF $DATA(LRSDTR)
SET LRODT=(LREDTR-.0001)
FOR
SET LRODT=$ORDER(^LRO(69,LRODT))
IF 'LRODT!(LRODT>LRSDTR)!(LREND=1)
QUIT
DO @$SELECT(LRMD="S":"SEL",1:"RNG")
+3 IF '$DATA(LREDTR)
IF '$DATA(LRSDTR)
DO @$SELECT(LRMD="S":"SEL",1:"RNG")
+4 KILL ^TMP($JOB)
+5 QUIT
SEL SET (LREND,LRPHY)=""
SET LRJ0=1
FOR I=0:0
SET LRPHY=$ORDER(LRPHY(LRPHY))
IF LRPHY=""
QUIT
IF 'LRJ0
WRITE @IOF
SET LRLTR=LRPHY
IF $EXTRACT(IOST,1,2)'="C-"
DO ^LRLTR
DO PNAME
SET LRJ0=0
IF LREND
QUIT
+1 WRITE @IOF
+2 QUIT
RNG SET LREND=0
SET LRJ0=1
+1 FOR I=0:0
SET LRPHY=$ORDER(^LRO(69,LRODT,1,"AP",LRFPHY))
IF LRPHY=""!($EXTRACT(LRPHY,20)]LREPHY)
QUIT
Begin DoDot:1
+2 SET LRFPHY=LRPHY
+3 IF 'LRJ0
WRITE @IOF
+4 SET LRLTR=$SELECT(LRPHY="":"UNK",1:LRPHY)
+5 ;D:$E(IOST,1,2)'="C-" ^LRLTR ;IHS/ANMC/CLS 08/18/96
+6 DO PNAME
+7 SET LRJ0=0
+8 IF LREND
QUIT
End DoDot:1
+9 WRITE @IOF
+10 QUIT
PNAME SET LRPHY1=LRPHY
SET LREND=0
IF LREND
QUIT
+1 DO PNAME1
IF LREND
QUIT
+2 FOR I=0:0
SET LRPHY1=$ORDER(^LRO(69,LRODT,1,"AP",LRPHY1))
IF $EXTRACT(LRPHY1,1,$LENGTH(LRPHY))'=LRPHY
QUIT
DO PNAME1
IF LREND
QUIT
+3 KILL LRPHY1
+4 QUIT
PNAME1 ;
+1 SET LRNAME=""
FOR I=0:0
SET LRNAME=$ORDER(^LRO(69,LRODT,1,"AP",LRPHY1,LRNAME))
IF LRNAME=""!(LREND=1)
QUIT
DO PAT
IF LREND
QUIT
+2 QUIT
PAT SET LRDFN=0
FOR I=0:0
SET LRDFN=+$ORDER(^LRO(69,LRODT,1,"AP",LRPHY1,LRNAME,LRDFN))
IF LRDFN<1!(LREND=1)
QUIT
SET LRIDT=9999999-LRSDT
IF '$DATA(^TMP($JOB,LRDFN))
DO DS^BLRLRRP2
IF LRSTOP
SET LREND=1
IF LREND
QUIT
SET ^TMP($JOB,LRDFN)=""
+1 QUIT
SINGLE ;from option LRRD BY MD
+1 SET LRSINGLE=1
SET LRMD="S"
DO BEGIN
+2 QUIT
