LRRS12.m

LRRS12 ;SLC/DCM,BA/DALOI/FHS/DRH - INTERIM REPORT BY LOCATION (MANUAL QUEUE) ;2/19/91  11:39

 ;;5.2T9;LR;**1018**;Nov 17, 2004

 ;;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

LRRS12    ;SLC/DCM,BA/DALOI/FHS/DRH - INTERIM REPORT BY LOCATION (MANUAL QUEUE) ;2/19/91  11:39

 +1       ;;5.2T9;LR;**1018**;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**1,283**;Sep 27, 1994

 +3       ;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