LRRD ;SLC/DCM/BA-INTERIM REPORT BY PHYSICIAN ;2/19/91 11:33
;;5.2;LAB SERVICE;**221,283**;Sep 27, 1994
;from option LRRD
BEGIN D ^LRPARAM S:'$D(LRSINGLE) LRSINGLE=0 S LRPRTPG=0 D MD
I LRPRTPG,$D(PNM) D PLSPG^LRRP2
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
S DIR(0)="Y",DIR("A")="Print address page",DIR("B")="NO"
D ^DIR K DIR
I Y S LRPRTPG=1
I 'LRSINGLE F R !,"Do you want (A)ll providers, a (R)ange of providers,",!,"or (S)elected providers? 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 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,30))=""
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,30),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,30)
QUE S %ZIS="MQ",ZTRTN="DQ^LRRD" 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) S:LRMD="A" LRFPHY="" 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 S LRPHY=$O(LRPHY(LRPHY)) Q:LRPHY="" D PNAME S LRJ0=0 Q:LREND
Q
RNG S LREND=0,LRJ0=1
F S LRPHY=$O(^LRO(69,LRODT,1,"AP",LRFPHY)) Q:LRPHY=""!(LRPHY]LREPHY) D
.S LRFPHY=LRPHY
.D PNAME
.S LRJ0=0
.Q:LREND
Q
PNAME S LRNAME="" F S LRNAME=$O(^LRO(69,LRODT,1,"AP",LRPHY,LRNAME)) Q:LRNAME=""!(LREND=1) D PAT Q:LREND
Q
PAT S LRDFN=0 F S LRDFN=+$O(^LRO(69,LRODT,1,"AP",LRPHY,LRNAME,LRDFN)) Q:LRDFN<1!(LREND=1) S LRIDT=9999999-LRSDT D:'$D(^TMP($J,LRDFN)) DS^LRRP2 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRD 2621 printed Oct 16, 2024@18:20:31 Page 2
LRRD ;SLC/DCM/BA-INTERIM REPORT BY PHYSICIAN ;2/19/91 11:33
+1 ;;5.2;LAB SERVICE;**221,283**;Sep 27, 1994
+2 ;from option LRRD
BEGIN DO ^LRPARAM
if '$DATA(LRSINGLE)
SET LRSINGLE=0
SET LRPRTPG=0
DO MD
+1 IF LRPRTPG
IF $DATA(PNM)
DO PLSPG^LRRP2
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 SET DIR(0)="Y"
SET DIR("A")="Print address page"
SET DIR("B")="NO"
+4 DO ^DIR
KILL DIR
+5 IF Y
SET LRPRTPG=1
+6 IF 'LRSINGLE
FOR
READ !,"Do you want (A)ll providers, a (R)ange of providers,",!,"or (S)elected providers? S// ",X:DTIME
if X=""
SET X="S"
if $LENGTH(X)=1&("ARS^"[X)
QUIT
WRITE !,"Enter 'A', 'R', 'S' or '^' to exit"
+7 IF 'LRSINGLE
if X[U
QUIT
SET LRMD=X
+8 DO @$SELECT(LRMD="S":"SELECT",LRMD="R":"RANGE",1:"QUE")
+9 QUIT
SELECT FOR
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,30))=""
+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,30)
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,30)
QUE SET %ZIS="MQ"
SET ZTRTN="DQ^LRRD"
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
if LRMD="A"
SET LRFPHY=""
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
SET LRPHY=$ORDER(LRPHY(LRPHY))
if LRPHY=""
QUIT
DO PNAME
SET LRJ0=0
if LREND
QUIT
+1 QUIT
RNG SET LREND=0
SET LRJ0=1
+1 FOR
SET LRPHY=$ORDER(^LRO(69,LRODT,1,"AP",LRFPHY))
if LRPHY=""!(LRPHY]LREPHY)
QUIT
Begin DoDot:1
+2 SET LRFPHY=LRPHY
+3 DO PNAME
+4 SET LRJ0=0
+5 if LREND
QUIT
End DoDot:1
+6 QUIT
PNAME SET LRNAME=""
FOR
SET LRNAME=$ORDER(^LRO(69,LRODT,1,"AP",LRPHY,LRNAME))
if LRNAME=""!(LREND=1)
QUIT
DO PAT
if LREND
QUIT
+1 QUIT
PAT SET LRDFN=0
FOR
SET LRDFN=+$ORDER(^LRO(69,LRODT,1,"AP",LRPHY,LRNAME,LRDFN))
if LRDFN<1!(LREND=1)
QUIT
SET LRIDT=9999999-LRSDT
if '$DATA(^TMP($JOB,LRDFN))
DO DS^LRRP2
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
