LRRS12 ;SLC/DCM,BA/DALOI/FHS/DRH - INTERIM REPORT BY LOCATION (MANUAL QUEUE) ;2/19/91 11:39
;;5.2;LAB SERVICE;**1,283**;Sep 27, 1994
;from option LRRS
BEGIN ;
K LRLLOC
S LRPRTPG=0
D:'$D(LRPARAM) ^LRPARAM
G:$G(LREND) ^LRRK Q:$G(LREND)
S:'$D(LRSINGLE) LRSINGLE=0
ASKPG I 'LRPRTPG D
.S DIR(0)="Y",DIR("A")="Print address page",DIR("B")="NO"
.D ^DIR K DIR
.I Y S LRPRTPG=1
D LOC
END ;
D ^LRRK
K LRLOCXY,LRX1,LRY1,OK,LRX13
Q
LOC ;
K LRLLOC
S (LREND,LRSTOP)=0
S (LRONETST,LRONESPC,LRLLOC,LRFLOC)=""
S LRELOC="ZZZZZZZZ"
S LRLAB=$S($D(LRLABKY):1,1:0)
K DTOUT,DUOUT
S LREND=0
D DTRANG Q:$G(LREND)
D CHKLOC Q:$G(LREND)
Q
QUIT ;
S LREND=1
Q
DTRANG ;
K LRX13
S LREDT="T-7"
D ^LRWU3
S:($D(DUOUT))!($D(DTOUT)) LREND=1 Q:LREND
;I LRSDT=LREDT S X1=LREDT,X2=1 D C^%DTC S LREDT=X
S LRSDT=LRSDT-.5
I LREDT=LRSDT S LRX13=1
S LRSWTCH=LRSDT,LRSDT=LREDT,LREDT=LRSWTCH K LRSWTCH
;I LRSDT=LREDT S X1=LREDT,X2=1 D C^%DTC S LREDT=X
S LRODT=LRSDT
S LRDT=LRODT,LRDTXX=LRODT
S LRBDT=LRODT
S LRSD=LRODT,LRLAST=LREDT
;S X1=LRLAST,X2=1 D C^%DTC S LRLAST=X
DTSINGL ;
Q
;EDITED 1-18-94
CHKLOC ;
K LRNGCHK
D CHOOSE
Q:$G(LREND)
D @$S(LRLOC="S":"SELECT",LRLOC="R":"RANGE",1:"QUE")
Q
CHOOSE ;
N Y
S LREND=0
K DIR
S DIR("A")="Please select one of the following"
S DIR(0)="S^S:Selected Locations;R:A Range of locations;A:All locations"
S DIR("?")="Enter the letter that cooresponds to what you want."
D ^DIR
S:($D(DUOUT))!($D(DTOUT)) LREND=1 Q:LREND
S LRLOC=Y
Q
QUER ;
;D QUE
Q
NODATA ;
S LRNOD=1
W !,"No Reports for ",$$DTF^LRAFUNC1(LRODT),! Q
Q
DIS ;
N I
F I=1:1:LRCNT W !,I,?4,LRLOCX(I) S I=I+1 Q:I>LRCNT!($G(LREND)) D
. W:$D(LRLOCX(I)) ?39," ",I,?44,LRLOCX(I)
W ! Q
Q
Q
RANGE ;
S (DTOUT,DUOUT)=""
K LRLLOC1,LRLLOC
S LRNGCHK=1
N Y
K DIC
S DIC=44,DIC(0)="AEMQZ"
S DIC("A")="Select Starting Location: "
D ^DIC
I $D(DUOUT)!($D(DTOUT))!(Y=-1) S LREND=1 Q:LREND
S:Y'=-1 LRY7=$L($P(Y(0),U))
I $D(LRY7) S LRY8=$E($P(Y(0),U),LRY7,LRY7) D
. S LRY8=$A(LRY8)
. S LRY8=$C(LRY8-1)
. S LRY7=LRY7-1
. S LRFLOC=$E($P(Y,"^",2),1,LRY7)_LRY8
I '$D(LRFLOC) G RANGE
S DIC("A")="Select Ending Location: "
S (DTOUT,DUOUT)=""
ENDING D ^DIC
I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q:LREND
I Y=-1 G END
S:Y'=-1 LRELOC=$P(Y(0),U)_"Z"
K LRY7,LRY8,LRLOCXY
I +LRFLOC=0&(+LRELOC=0)&($A($E(LRFLOC,1,1))>$A($E(LRELOC,1,1))) D
. S LX8=1 D HELP QUIT
I +LRFLOC>0&(+LRELOC>0)&(LRFLOC>LRELOC) S LX9=1 D HELP QUIT
S LRX1=LRFLOC
F S LRX1=$O(^SC("B",LRX1)) Q:LRX1=""!(LRX1]LRELOC) D
. S LRY1=$O(^SC("B",LRX1,"0")) S LRY1=$P(^SC(LRY1,0),U,2) Q:LRY1=""
. S LRLLOC(LRY1)=LRY1
S OK=0,LRODT=LRDTXX-.5
D QUE
QUIT
SELECT ;
K ^TMP("LR",$J)
S LRSCRN=24
N LRNOD,LRTAC
S LRLLOC=""
S LRDT=LRODT
D READ
S LRODT=LRDT D QUE
Q
READ ;
S OK=0
K DIC
S DIC=44,DIC(0)="QAEZNM"
S DIC("S")="I $L($P(^(0),U,2))"
S X1=LRODT,X2=-1 D C^%DTC S LRODT=X
D ^DIC
Q:Y<0
S Y1=$P(Y(0),U,2)
S LRLLOC(Y1)=Y1
K DIC
G READ
Q
HELP ;
W !!,"I cannot search a range of locations that are not in"
W " sequential order"
I $D(LX8) W !,"Please enter the starting and ending locations in" D
. W " ALPHABETICAL order" K LX8
I $D(LX9) W !,"Please enter the starting and ending locations in" D
. W " NUMERICAL order" K LX9
W !
G RANGE
Q
QUE S %ZIS="MQ",ZTSAVE("^TMP(""LR"",$J,")="",ZTRTN="DQ^LRRS13" D IO^LRWU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRS12 3469 printed Dec 13, 2024@02:20:13 Page 2
LRRS12 ;SLC/DCM,BA/DALOI/FHS/DRH - INTERIM REPORT BY LOCATION (MANUAL QUEUE) ;2/19/91 11:39
+1 ;;5.2;LAB SERVICE;**1,283**;Sep 27, 1994
+2 ;from option LRRS
BEGIN ;
+1 KILL LRLLOC
+2 SET LRPRTPG=0
+3 if '$DATA(LRPARAM)
DO ^LRPARAM
+4 if $GET(LREND)
GOTO ^LRRK
if $GET(LREND)
QUIT
+5 if '$DATA(LRSINGLE)
SET LRSINGLE=0
ASKPG IF 'LRPRTPG
Begin DoDot:1
+1 SET DIR(0)="Y"
SET DIR("A")="Print address page"
SET DIR("B")="NO"
+2 DO ^DIR
KILL DIR
+3 IF Y
SET LRPRTPG=1
End DoDot:1
+4 DO LOC
END ;
+1 DO ^LRRK
+2 KILL LRLOCXY,LRX1,LRY1,OK,LRX13
+3 QUIT
LOC ;
+1 KILL LRLLOC
+2 SET (LREND,LRSTOP)=0
+3 SET (LRONETST,LRONESPC,LRLLOC,LRFLOC)=""
+4 SET LRELOC="ZZZZZZZZ"
+5 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
+6 KILL DTOUT,DUOUT
+7 SET LREND=0
+8 DO DTRANG
if $GET(LREND)
QUIT
+9 DO CHKLOC
if $GET(LREND)
QUIT
+10 QUIT
QUIT ;
+1 SET LREND=1
+2 QUIT
DTRANG ;
+1 KILL LRX13
+2 SET LREDT="T-7"
+3 DO ^LRWU3
+4 if ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
if LREND
QUIT
+5 ;I LRSDT=LREDT S X1=LREDT,X2=1 D C^%DTC S LREDT=X
+6 SET LRSDT=LRSDT-.5
+7 IF LREDT=LRSDT
SET LRX13=1
+8 SET LRSWTCH=LRSDT
SET LRSDT=LREDT
SET LREDT=LRSWTCH
KILL LRSWTCH
+9 ;I LRSDT=LREDT S X1=LREDT,X2=1 D C^%DTC S LREDT=X
+10 SET LRODT=LRSDT
+11 SET LRDT=LRODT
SET LRDTXX=LRODT
+12 SET LRBDT=LRODT
+13 SET LRSD=LRODT
SET LRLAST=LREDT
+14 ;S X1=LRLAST,X2=1 D C^%DTC S LRLAST=X
DTSINGL ;
+1 QUIT
+2 ;EDITED 1-18-94
CHKLOC ;
+1 KILL LRNGCHK
+2 DO CHOOSE
+3 if $GET(LREND)
QUIT
+4 DO @$SELECT(LRLOC="S":"SELECT",LRLOC="R":"RANGE",1:"QUE")
+5 QUIT
CHOOSE ;
+1 NEW Y
+2 SET LREND=0
+3 KILL DIR
+4 SET DIR("A")="Please select one of the following"
+5 SET DIR(0)="S^S:Selected Locations;R:A Range of locations;A:All locations"
+6 SET DIR("?")="Enter the letter that cooresponds to what you want."
+7 DO ^DIR
+8 if ($DATA(DUOUT))!($DATA(DTOUT))
SET LREND=1
if LREND
QUIT
+9 SET LRLOC=Y
+10 QUIT
QUER ;
+1 ;D QUE
+2 QUIT
NODATA ;
+1 SET LRNOD=1
+2 WRITE !,"No Reports for ",$$DTF^LRAFUNC1(LRODT),!
QUIT
+3 QUIT
DIS ;
+1 NEW I
+2 FOR I=1:1:LRCNT
WRITE !,I,?4,LRLOCX(I)
SET I=I+1
if I>LRCNT!($GET(LREND))
QUIT
Begin DoDot:1
+3 if $DATA(LRLOCX(I))
WRITE ?39," ",I,?44,LRLOCX(I)
End DoDot:1
+4 WRITE !
QUIT
+5 QUIT
+6 QUIT
RANGE ;
+1 SET (DTOUT,DUOUT)=""
+2 KILL LRLLOC1,LRLLOC
+3 SET LRNGCHK=1
+4 NEW Y
+5 KILL DIC
+6 SET DIC=44
SET DIC(0)="AEMQZ"
+7 SET DIC("A")="Select Starting Location: "
+8 DO ^DIC
+9 IF $DATA(DUOUT)!($DATA(DTOUT))!(Y=-1)
SET LREND=1
if LREND
QUIT
+10 if Y'=-1
SET LRY7=$LENGTH($PIECE(Y(0),U))
+11 IF $DATA(LRY7)
SET LRY8=$EXTRACT($PIECE(Y(0),U),LRY7,LRY7)
Begin DoDot:1
+12 SET LRY8=$ASCII(LRY8)
+13 SET LRY8=$CHAR(LRY8-1)
+14 SET LRY7=LRY7-1
+15 SET LRFLOC=$EXTRACT($PIECE(Y,"^",2),1,LRY7)_LRY8
End DoDot:1
+16 IF '$DATA(LRFLOC)
GOTO RANGE
+17 SET DIC("A")="Select Ending Location: "
+18 SET (DTOUT,DUOUT)=""
ENDING DO ^DIC
+1 IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
if LREND
QUIT
+2 IF Y=-1
GOTO END
+3 if Y'=-1
SET LRELOC=$PIECE(Y(0),U)_"Z"
+4 KILL LRY7,LRY8,LRLOCXY
+5 IF +LRFLOC=0&(+LRELOC=0)&($ASCII($EXTRACT(LRFLOC,1,1))>$ASCII($EXTRACT(LRELOC,1,1)))
Begin DoDot:1
+6 SET LX8=1
DO HELP
QUIT
End DoDot:1
+7 IF +LRFLOC>0&(+LRELOC>0)&(LRFLOC>LRELOC)
SET LX9=1
DO HELP
QUIT
+8 SET LRX1=LRFLOC
+9 FOR
SET LRX1=$ORDER(^SC("B",LRX1))
if LRX1=""!(LRX1]LRELOC)
QUIT
Begin DoDot:1
+10 SET LRY1=$ORDER(^SC("B",LRX1,"0"))
SET LRY1=$PIECE(^SC(LRY1,0),U,2)
if LRY1=""
QUIT
+11 SET LRLLOC(LRY1)=LRY1
End DoDot:1
+12 SET OK=0
SET LRODT=LRDTXX-.5
+13 DO QUE
+14 QUIT
SELECT ;
+1 KILL ^TMP("LR",$JOB)
+2 SET LRSCRN=24
+3 NEW LRNOD,LRTAC
+4 SET LRLLOC=""
+5 SET LRDT=LRODT
+6 DO READ
+7 SET LRODT=LRDT
DO QUE
+8 QUIT
READ ;
+1 SET OK=0
+2 KILL DIC
+3 SET DIC=44
SET DIC(0)="QAEZNM"
+4 SET DIC("S")="I $L($P(^(0),U,2))"
+5 SET X1=LRODT
SET X2=-1
DO C^%DTC
SET LRODT=X
+6 DO ^DIC
+7 if Y<0
QUIT
+8 SET Y1=$PIECE(Y(0),U,2)
+9 SET LRLLOC(Y1)=Y1
+10 KILL DIC
+11 GOTO READ
+12 QUIT
HELP ;
+1 WRITE !!,"I cannot search a range of locations that are not in"
+2 WRITE " sequential order"
+3 IF $DATA(LX8)
WRITE !,"Please enter the starting and ending locations in"
Begin DoDot:1
+4 WRITE " ALPHABETICAL order"
KILL LX8
End DoDot:1
+5 IF $DATA(LX9)
WRITE !,"Please enter the starting and ending locations in"
Begin DoDot:1
+6 WRITE " NUMERICAL order"
KILL LX9
End DoDot:1
+7 WRITE !
+8 GOTO RANGE
+9 QUIT
QUE SET %ZIS="MQ"
SET ZTSAVE("^TMP(""LR"",$J,")=""
SET ZTRTN="DQ^LRRS13"
DO IO^LRWU
+1 QUIT
