Routine: LRAR06

LRAR06 ;DALLAS/HOAK CUME ARCHIVE INITIATIVE part of 00 ; 12/12/96  10:16 ;

 ;;5.2;LAB SERVICE;**111**;Sep 27, 1994

INIT ;

RESTART ;

 W !,"Search not complete." L +^LAR:1

 I '$T W !,"Searching in progress, please wait for it to finish." G QUIT

 L -^LAR

 W !,"Do you want to restart the search"

 S %=1 D YN^DICN

 I %'=1 W:%=0 !,"Continue where the last search stopped." G RESTART:%=0,QUIT

 D DEV^LRAR01

 G QUIT:POP S LRDFN=$S($D(^LAB(69.9,1,"LRDFN")):^("LRDFN"),1:0)

 D STEPOUT^LRARCHIV QUIT

TAPE ;

 S DA=0,DIC="^LAB(69.9,1,6,"

 S DIC("A")="Please enter a name for the archive session: "

 S DIC(0)="AEMQL"

 S DLAYGO=69 D ^DIC

 K DLAYGO Q:Y<1

 S LRDA9=+Y

 I '$P(Y,U,3) W !,"You must create a NEW name for this ARCHIVE." G TAPE

DT ;

 S OK=1

SET S DIR(0)="S^1:CH Subcript only;2:Micro Only;3:Both CH and Micro"

 S DIR("??")="Enter 1 for CH subscripted. Micro will be with next patch"

 S DIR("?")="Please enter a number 1"

 S DIR("A")="What lab section do you wish to Search"

 S DIR("B")="1"

 D ^DIR

 I $D(DTOUT)!($D(DUOUT)) S OK=0 S DA=-1

 Q:'OK

 ;S LRWHICH=$S(Y=1:"CH",Y=2:"MI",1:"BOTH") ;--NEXT PATCH

 S LRWHICH="CH"

 K DIR

 S DIR(0)="D",DIR("A")="Archive Start DATE: "

 S DIR("?")="Enter a date in the past where I should begin looking."

 S DIR("B")="T-90"

 D ^DIR

 I $D(DTOUT)!($D(DUOUT)) S OK=0 S DA=-1

 S LR(1)=+Y

 Q:'OK

 S DA=LRDA9

 Q:'$G(DA)

 S P1=DA,DIE=DIC,DR="1;2///N;4///"_LR(1)

 D ^DIE

 K DIC

 ;QUIT

 K DIR

TIME ;

 ;--> Maximize user interaction.

 S OK=1

 I '$G(LR(1)) S LR(1)=DT

 S DIR(0)="S^1:Number of days;2:Date Range;3:By the month;4:Quarterly;5:By the year"

 S DIR("?")="Enter 1 for days to archive ie 1,7,30,60,90 etc"

 S DIR("?",1)="Enter 2 for Patients results between a date range."

 S DIR("?",2)="Enter 3 for a specific month and year...11/97"

 S DIR("?",3)="Enter 4 ... 1/97 for Jan-Feb-Mar of 1997 or 2/97 for Apr-May-June of 1997 etc"

 S DIR("?",4)="Enter 5 year 1996 gets you all of 1996"

 S DIR("B")="1"

 D ^DIR

 I $D(DUOUT)!($D(DTOUT))!(+Y'>0) W !!,"OK BYE BYE" S OK=0 QUIT

 S LRD0=$S(Y=1:"FIRST",Y=2:"SECOND",Y=3:"THIRD",Y=4:"FOURTH",1:"FIFTH")

 S OK=1 S LRD0="D "_LRD0

 X LRD0

 K DIR

 I 'OK D END QUIT

 S LREDT3=LREDT

 QUIT

END ;

QUIT ;

 D QUIT^LRARCHIV

 QUIT

FIRST ;--------->by nuber of days

 K DIR SET DIR(0)="N" S DIR("B")="90" S DIR("A")="Enter # of days"

 D ^DIR

 I $D(DUOUT)!($D(DTOUT))!(+Y'>0) W !!,"OK BYE BYE" S OK=0 QUIT

 S X1=LR(1),X2=-Y D C^%DTC

 W !,$$FMTE^XLFDT(X,"D")," TO ",$$FMTE^XLFDT(LR(1),"D")

 S LREDT=X

 K DIR D PASTIT

 QUIT

SECOND ;---------->by date range

 S %DT="AE"

 S %DT("B")="T-90"

 S %DT("A")="Start Date: "

 D ^%DT I Y'>0 S OK=0 D END QUIT

 S LR(1)=Y

 S %DT("B")="T-30"

 S %DT("A")="Ending Date: "

 D ^%DT I Y'>0 S OK=0 D END QUIT

 S LREDT=Y

 S LRY0=LREDT,LREDT=LR(1),LR(1)=LRY0 ;SWAP

 ;I LR(1)>LREDT S X=LR(1),LR(1)=LREDT,LREDT=X

 K %DT

 D PASTIT

 QUIT

THIRD ;----------->by month

 S %DT="AE"

 S %DT("B")=+$E(DT,4,5)_"/"_+$E(DT,2,3)

 S %DT("?")="Enter Month/Year...May 1997...June 1994"

 S %DT("??")="9/94 for September 1994"

 S %DT("A")="Month and year: "

 D ^%DT I Y'>0 S OK=0 QUIT

 I +$E(Y,4,4)++$E(Y,5,5)'>0 W !!,"You forgot the month." G THIRD

 S LR(1)=$E(Y,1,5)_"01" S LREDT=$E(LR(1),1,3)_$E(LR(1),4,5)+1_"01"

 S LRY0=LREDT,LREDT=LR(1),LR(1)=LRY0 ;SWAP

 K %DT

 D PASTIT

 QUIT

FOURTH ;--------------->by quarter

 K DIR

 S DIR(0)="S^1:1st Quarter;2:2nd Quarter;3:3rd Quarter;4:4th Quarter"

 S DIR("B")=1

 S DIR("?")="1=Jan-Feb-Mar 2=Apr-May-June 3=Jul-Aug-Sep 4=Oct-Nov-Dec"

 D ^DIR

 I $D(DTOUT)!($D(DUOUT)) S OK=0 D END QUIT

 S LRQQ=Y

 D AGAIN

 S LRQQ=$S(LRQQ=1:"FIRSTQ(LRYEAR)",LRQQ=2:"SECONDQ(LRYEAR)",LRQQ=3:"THIRDQ(LRYEAR)",1:"FOURTHQ(LRYEAR)")

 S LRQQ="D "_LRQQ X LRQQ

 D PASTIT

 QUIT

AGAIN ;

 I 'OK D END QUIT

 K %DT

 S %DT="AE" S %DT("A")="Please Enter a Year: "

 S %DT("B")=$S($E(DT,1,1)=2:19_$E(DT,2,3),1:20_$E(DT,2,3))

 D ^%DT

 I Y'>0 S OK=0 D END QUIT

 S LRYEAR=Y

 QUIT

FIFTH ;

 D AGAIN

 I 'OK D END QUIT

 S LR(1)=$E(Y,1,3)_0101

 S LREDT=$E(Y,1,3)_1231

PASTIT ;

 ;W !!,"LREDT=",LREDT,"<------>LR(1)=",LR(1)

QUARTER ;

FIRSTQ(LRYEAR) ;

 S LRYQ=$E(LRYEAR,2,3)

 S LR(1)=2_LRYQ_"0101",LREDT=2_LRYQ_"0331"

 QUIT

SECONDQ(LRYEAR) ;

 S LRYQ=$E(LRYEAR,2,3)

 S LR(1)=2_LRYQ_"0401",LREDT=2_LRYQ_"0630"

 QUIT

THIRDQ(LRYEAR) ;

 S LRYQ=$E(LRYEAR,2,3)

 S LR(1)=2_LRYQ_"0701",LREDT=2_LRYQ_"0930"

 QUIT

FOURTHQ(LRYEAR) ;

 S LRYQ=$E(LRYEAR,2,3)

 S LR(1)=2_LRYQ_"1001",LREDT=2_LRYQ_"1231"

 QUIT

DAYS ;

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAR06   4626     printed  Feb 18, 2025@23:34:46                                                                                                                                                                                                      Page 2

LRAR06    ;DALLAS/HOAK CUME ARCHIVE INITIATIVE part of 00 ; 12/12/96  10:16 ;

 +1       ;;5.2;LAB SERVICE;**111**;Sep 27, 1994

INIT      ;

RESTART   ;

 +1        WRITE !,"Search not complete."

           LOCK +^LAR:1

 +2        IF '$TEST

               WRITE !,"Searching in progress, please wait for it to finish."

               GOTO QUIT

 +3        LOCK -^LAR

 +4        WRITE !,"Do you want to restart the search"

 +5        SET %=1

           DO YN^DICN

 +6        IF %'=1

               if %=0

                   WRITE !,"Continue where the last search stopped."

               if %=0

                   GOTO RESTART

               GOTO QUIT

 +7       ;

 +8        DO DEV^LRAR01

 +9        if POP

               GOTO QUIT

           SET LRDFN=$SELECT($DATA(^LAB(69.9,1,"LRDFN")):^("LRDFN"),1:0)

 +10       DO STEPOUT^LRARCHIV

           QUIT

TAPE      ;

 +1        SET DA=0

           SET DIC="^LAB(69.9,1,6,"

 +2        SET DIC("A")="Please enter a name for the archive session: "

 +3        SET DIC(0)="AEMQL"

 +4        SET DLAYGO=69

           DO ^DIC

 +5        KILL DLAYGO

           if Y<1

               QUIT

 +6        SET LRDA9=+Y

 +7        IF '$PIECE(Y,U,3)

               WRITE !,"You must create a NEW name for this ARCHIVE."

               GOTO TAPE

DT        ;

 +1        SET OK=1

SET        SET DIR(0)="S^1:CH Subcript only;2:Micro Only;3:Both CH and Micro"

 +1        SET DIR("??")="Enter 1 for CH subscripted. Micro will be with next patch"

 +2        SET DIR("?")="Please enter a number 1"

 +3        SET DIR("A")="What lab section do you wish to Search"

 +4        SET DIR("B")="1"

 +5        DO ^DIR

 +6        IF $DATA(DTOUT)!($DATA(DUOUT))

               SET OK=0

               SET DA=-1

 +7        if 'OK

               QUIT

 +8       ;S LRWHICH=$S(Y=1:"CH",Y=2:"MI",1:"BOTH") ;--NEXT PATCH

 +9        SET LRWHICH="CH"

 +10      ;

 +11       KILL DIR

 +12      ;

 +13       SET DIR(0)="D"

           SET DIR("A")="Archive Start DATE: "

 +14       SET DIR("?")="Enter a date in the past where I should begin looking."

 +15       SET DIR("B")="T-90"

 +16       DO ^DIR

 +17       IF $DATA(DTOUT)!($DATA(DUOUT))

               SET OK=0

               SET DA=-1

 +18       SET LR(1)=+Y

 +19       if 'OK

               QUIT

 +20       SET DA=LRDA9

 +21       if '$GET(DA)

               QUIT

 +22       SET P1=DA

           SET DIE=DIC

           SET DR="1;2///N;4///"_LR(1)

 +23       DO ^DIE

 +24       KILL DIC

 +25      ;QUIT

 +26      ;

 +27       KILL DIR

 +28      ;

TIME      ;

 +1       ;--> Maximize user interaction.

 +2        SET OK=1

 +3        IF '$GET(LR(1))

               SET LR(1)=DT

 +4        SET DIR(0)="S^1:Number of days;2:Date Range;3:By the month;4:Quarterly;5:By the year"

 +5        SET DIR("?")="Enter 1 for days to archive ie 1,7,30,60,90 etc"

 +6        SET DIR("?",1)="Enter 2 for Patients results between a date range."

 +7        SET DIR("?",2)="Enter 3 for a specific month and year...11/97"

 +8        SET DIR("?",3)="Enter 4 ... 1/97 for Jan-Feb-Mar of 1997 or 2/97 for Apr-May-June of 1997 etc"

 +9        SET DIR("?",4)="Enter 5 year 1996 gets you all of 1996"

 +10       SET DIR("B")="1"

 +11       DO ^DIR

 +12       IF $DATA(DUOUT)!($DATA(DTOUT))!(+Y'>0)

               WRITE !!,"OK BYE BYE"

               SET OK=0

               QUIT

 +13      ;

 +14       SET LRD0=$SELECT(Y=1:"FIRST",Y=2:"SECOND",Y=3:"THIRD",Y=4:"FOURTH",1:"FIFTH")

 +15       SET OK=1

           SET LRD0="D "_LRD0

 +16       XECUTE LRD0

 +17      ;

 +18       KILL DIR

 +19       IF 'OK

               DO END

               QUIT

 +20       SET LREDT3=LREDT

 +21      ;

 +22       QUIT

 +23      ;

END       ;

QUIT      ;

 +1        DO QUIT^LRARCHIV

 +2        QUIT

 +3       ;

 +4       ;

FIRST     ;--------->by nuber of days

 +1        KILL DIR

           SET DIR(0)="N"

           SET DIR("B")="90"

           SET DIR("A")="Enter # of days"

 +2        DO ^DIR

 +3        IF $DATA(DUOUT)!($DATA(DTOUT))!(+Y'>0)

               WRITE !!,"OK BYE BYE"

               SET OK=0

               QUIT

 +4        SET X1=LR(1)

           SET X2=-Y

           DO C^%DTC

 +5        WRITE !,$$FMTE^XLFDT(X,"D")," TO ",$$FMTE^XLFDT(LR(1),"D")

 +6        SET LREDT=X

 +7        KILL DIR

           DO PASTIT

 +8        QUIT

SECOND    ;---------->by date range

 +1        SET %DT="AE"

 +2        SET %DT("B")="T-90"

 +3        SET %DT("A")="Start Date: "

 +4        DO ^%DT

           IF Y'>0

               SET OK=0

               DO END

               QUIT

 +5        SET LR(1)=Y

 +6        SET %DT("B")="T-30"

 +7        SET %DT("A")="Ending Date: "

 +8        DO ^%DT

           IF Y'>0

               SET OK=0

               DO END

               QUIT

 +9        SET LREDT=Y

 +10      ;SWAP

           SET LRY0=LREDT

           SET LREDT=LR(1)

           SET LR(1)=LRY0

 +11      ;I LR(1)>LREDT S X=LR(1),LR(1)=LREDT,LREDT=X

 +12       KILL %DT

 +13       DO PASTIT

 +14       QUIT

THIRD     ;----------->by month

 +1        SET %DT="AE"

 +2        SET %DT("B")=+$EXTRACT(DT,4,5)_"/"_+$EXTRACT(DT,2,3)

 +3        SET %DT("?")="Enter Month/Year...May 1997...June 1994"

 +4        SET %DT("??")="9/94 for September 1994"

 +5        SET %DT("A")="Month and year: "

 +6        DO ^%DT

           IF Y'>0

               SET OK=0

               QUIT

 +7       ;

 +8        IF +$EXTRACT(Y,4,4)++$EXTRACT(Y,5,5)'>0

               WRITE !!,"You forgot the month."

               GOTO THIRD

 +9       ;

 +10       SET LR(1)=$EXTRACT(Y,1,5)_"01"

           SET LREDT=$EXTRACT(LR(1),1,3)_$EXTRACT(LR(1),4,5)+1_"01"

 +11      ;SWAP

           SET LRY0=LREDT

           SET LREDT=LR(1)

           SET LR(1)=LRY0

 +12       KILL %DT

 +13       DO PASTIT

 +14       QUIT

 +15      ;

FOURTH    ;--------------->by quarter

 +1        KILL DIR

 +2        SET DIR(0)="S^1:1st Quarter;2:2nd Quarter;3:3rd Quarter;4:4th Quarter"

 +3        SET DIR("B")=1

 +4        SET DIR("?")="1=Jan-Feb-Mar 2=Apr-May-June 3=Jul-Aug-Sep 4=Oct-Nov-Dec"

 +5        DO ^DIR

 +6        IF $DATA(DTOUT)!($DATA(DUOUT))

               SET OK=0

               DO END

               QUIT

 +7        SET LRQQ=Y

 +8        DO AGAIN

 +9        SET LRQQ=$SELECT(LRQQ=1:"FIRSTQ(LRYEAR)",LRQQ=2:"SECONDQ(LRYEAR)",LRQQ=3:"THIRDQ(LRYEAR)",1:"FOURTHQ(LRYEAR)")

 +10       SET LRQQ="D "_LRQQ

           XECUTE LRQQ

 +11       DO PASTIT

 +12       QUIT

AGAIN     ;

 +1       ;

 +2        IF 'OK

               DO END

               QUIT

 +3        KILL %DT

 +4        SET %DT="AE"

           SET %DT("A")="Please Enter a Year: "

 +5        SET %DT("B")=$SELECT($EXTRACT(DT,1,1)=2:19_$EXTRACT(DT,2,3),1:20_$EXTRACT(DT,2,3))

 +6        DO ^%DT

 +7        IF Y'>0

               SET OK=0

               DO END

               QUIT

 +8        SET LRYEAR=Y

 +9        QUIT

 +10      ;

FIFTH     ;

 +1        DO AGAIN

 +2        IF 'OK

               DO END

               QUIT

 +3        SET LR(1)=$EXTRACT(Y,1,3)_0101

 +4        SET LREDT=$EXTRACT(Y,1,3)_1231

 +5       ;

PASTIT    ;

 +1       ;W !!,"LREDT=",LREDT,"<------>LR(1)=",LR(1)

 +2        QUIT

QUARTER   ;

 +1       ;

FIRSTQ(LRYEAR) ;

 +1        SET LRYQ=$EXTRACT(LRYEAR,2,3)

 +2        SET LR(1)=2_LRYQ_"0101"

           SET LREDT=2_LRYQ_"0331"

 +3        QUIT

 +4       ;

SECONDQ(LRYEAR) ;

 +1        SET LRYQ=$EXTRACT(LRYEAR,2,3)

 +2        SET LR(1)=2_LRYQ_"0401"

           SET LREDT=2_LRYQ_"0630"

 +3        QUIT

 +4       ;

THIRDQ(LRYEAR) ;

 +1        SET LRYQ=$EXTRACT(LRYEAR,2,3)

 +2        SET LR(1)=2_LRYQ_"0701"

           SET LREDT=2_LRYQ_"0930"

 +3        QUIT

 +4       ;

FOURTHQ(LRYEAR) ;

 +1        SET LRYQ=$EXTRACT(LRYEAR,2,3)

 +2        SET LR(1)=2_LRYQ_"1001"

           SET LREDT=2_LRYQ_"1231"

 +3        QUIT

 +4       ;

DAYS      ;

 +1       ;

 +2        QUIT

 +3       ;

 +4        QUIT

LRAR06.m