- 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 Jan 18, 2025@03:20:29 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