Routine: LRMIPSZ

LRMIPSZ ;DALIO/STAFF - MICRO PRINT/SINGLE SPECIMEN REPORT ;08/26/10  14:16

 ;;5.2;LAB SERVICE;**104,350**;Sep 27, 1994;Build 230

 ;from option LRMIPSZ

BEGIN ;

 N LRACC

 S LRACC=""

 D EN^LRPARAM

 W !!?23,"MICROBIOLOGY SINGLE SPECIMEN REPORT"

 S LREND=0,LRNL=1,LRPG=0

 D CHOOSE

END ;

 K ^TMP("LR",$J)

 K %,AGE,DFN,DIC,DOB,I,J,K,PNM,SSN,X,Y

 K LRAA,LRACC,LRAD,LRAN,LRANOK,LRCMNT,LRCNT,LRDFN,LRDPF,LREND,LREP,LRIDT,LRLIDT,LRLLT,LRNL,LRONESPC,LRONETST,LRPG,LRPRAC,LRRB,LRSB,LRSMP,LRSTOP,LRUID

CHOOSE ; Choose the method of selecting the report to print.

 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 S DIR(0)="SO^1:Accession Number or UID;2:Name/SSN"

 S DIR("A")="Look-up by"

 S DIR("B")=1

 D ^DIR

 I $D(DIRUT) Q

 S LREP=+Y

 F  K LRAN,DIC D @$S(LREP=1:"ACC",1:"PAT") Q:LREND  I LRANOK S ZTRTN="DQ^LRMIPSZ",%ZIS="MQ" D IO^LRWU Q:LREND

DQ ;dequeued

 S:$D(ZTQUEUED) ZTREQ="@" U IO

 S LRONETST="",LRONESPC="" D EN^LRMIPSZ1 K LRONETST,LRONESPC

ACC ; Lookup by accession number/UID

 D ENA^LRWU4("MI")

 I LRAN<1 S LREND=1 Q

 S LRANOK=1,LRPG=0 D ACC1

ACC1 ;

 S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRIDT=$P(^(3),U,5)

 S LRLLT=^LR(LRDFN,"MI",LRIDT,0),LRACC=$P(LRLLT,U,6),LRCMNT=$G(^LR(LRDFN,"MI",LRIDT,99))

 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)

 D PT^LRX

 W !?20,PNM,?40,SSN

 F  W !,?20,"OK" S %=1 D YN^DICN Q:%  W !,"Answer 'Y'es or 'N'o"

 S:%=-1 LREND=1 S:%=2 LRANOK=0

PAT ;

 S LRANOK=1

 D ^LRDPA

 I LRDFN=-1 S LREND=1,LRANOK=0 Q

 D PAST

 I '$D(LRLLT) S LREND=1,LRANOK=0 Q

 S LRAN=^LR(LRDFN,"MI",LRIDT,0),LRACC=$P(LRAN,U,6),LRAD=$E(LRAN)_$P(LRACC," ",2)_"0000",LRAN=+$P(LRACC," ",3)

 S X=$P(LRACC," "),DIC=68,DIC(0)="M"

 D ^DIC

 I Y<1 S LREND=1,LRANOK=0 Q

 S LRAA=+Y

PAST ;

 W ! K LRAN

 S (LRSTOP,LRIDT)=0 F LRCNT=1:1 S LRIDT=+$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1  D:'(LRCNT#5) WAIT Q:LRSTOP  D PAST1

 I LRCNT=1 W !,"Nothing accessioned" K LRLLT Q

 S:LRCNT=2 LRIDT=LRLIDT I LRCNT'=2 D SELECT Q:X=""!(X[U)

 S LRLLT=^LR(LRDFN,"MI",LRIDT,0),LRCMNT=$S($D(^(99)):^(99),1:"")

WAIT ;

 R !,"PRESS '^' TO STOP ",X:DTIME S:X="" X=1 S LRSTOP=".^"[X

PAST1 ;

 S LRAN=$P(^LR(LRDFN,"MI",LRIDT,0),U,6),LRAN(LRCNT)=LRIDT,LRLIDT=LRIDT

 W !?13,LRCNT S Y=$P(^(0),U),LRSMP=$P(^(0),U,5)

 D D^LRU W ?20,Y,"  "

 W:LRSMP ?41,$P(^LAB(61,LRSMP,0),U),?60,"Acc ",LRAN

SELECT ;

 K LRLLT S LRSTOP=0

 F  R !!,"Select #: ",X:DTIME Q:X=""!(X[U)  Q:$D(LRAN(X))  W !,"Doesn't exist."

 I X'="",X'[U S LRIDT=LRAN(X)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIPSZ   2559     printed  Feb 18, 2025@23:43:04                                                                                                                                                                                                     Page 2

LRMIPSZ   ;DALIO/STAFF - MICRO PRINT/SINGLE SPECIMEN REPORT ;08/26/10  14:16

 +1       ;;5.2;LAB SERVICE;**104,350**;Sep 27, 1994;Build 230

 +2       ;

 +3       ;from option LRMIPSZ

BEGIN     ;

 +1        NEW LRACC

 +2        SET LRACC=""

 +3        DO EN^LRPARAM

 +4        WRITE !!?23,"MICROBIOLOGY SINGLE SPECIMEN REPORT"

 +5        SET LREND=0

           SET LRNL=1

           SET LRPG=0

 +6        DO CHOOSE

 +7       ;

END       ;

 +1        KILL ^TMP("LR",$JOB)

 +2        KILL %,AGE,DFN,DIC,DOB,I,J,K,PNM,SSN,X,Y

 +3        KILL LRAA,LRACC,LRAD,LRAN,LRANOK,LRCMNT,LRCNT,LRDFN,LRDPF,LREND,LREP,LRIDT,LRLIDT,LRLLT,LRNL,LRONESPC,LRONETST,LRPG,LRPRAC,LRRB,LRSB,LRSMP,LRSTOP,LRUID

 +4        QUIT

 +5       ;

 +6       ;

CHOOSE    ; Choose the method of selecting the report to print.

 +1        NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 +2        SET DIR(0)="SO^1:Accession Number or UID;2:Name/SSN"

 +3        SET DIR("A")="Look-up by"

 +4        SET DIR("B")=1

 +5        DO ^DIR

 +6        IF $DATA(DIRUT)

               QUIT

 +7        SET LREP=+Y

 +8        FOR

               KILL LRAN,DIC

               DO @$SELECT(LREP=1:"ACC",1:"PAT")

               if LREND

                   QUIT

               IF LRANOK

                   SET ZTRTN="DQ^LRMIPSZ"

                   SET %ZIS="MQ"

                   DO IO^LRWU

                   if LREND

                       QUIT

 +9        QUIT

 +10      ;

 +11      ;

DQ        ;dequeued

 +1        if $DATA(ZTQUEUED)

               SET ZTREQ="@"

           USE IO

 +2        SET LRONETST=""

           SET LRONESPC=""

           DO EN^LRMIPSZ1

           KILL LRONETST,LRONESPC

 +3        QUIT

 +4       ;

 +5       ;

ACC       ; Lookup by accession number/UID

 +1       ;

 +2        DO ENA^LRWU4("MI")

 +3        IF LRAN<1

               SET LREND=1

               QUIT

 +4        SET LRANOK=1

           SET LRPG=0

           DO ACC1

 +5        QUIT

 +6       ;

 +7       ;

ACC1      ;

 +1        SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)

           SET LRIDT=$PIECE(^(3),U,5)

 +2        SET LRLLT=^LR(LRDFN,"MI",LRIDT,0)

           SET LRACC=$PIECE(LRLLT,U,6)

           SET LRCMNT=$GET(^LR(LRDFN,"MI",LRIDT,99))

 +3        SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

           SET DFN=$PIECE(^(0),U,3)

 +4        DO PT^LRX

 +5        WRITE !?20,PNM,?40,SSN

 +6        FOR

               WRITE !,?20,"OK"

               SET %=1

               DO YN^DICN

               if %

                   QUIT

               WRITE !,"Answer 'Y'es or 'N'o"

 +7        if %=-1

               SET LREND=1

           if %=2

               SET LRANOK=0

 +8        QUIT

 +9       ;

 +10      ;

 +11      ;

PAT       ;

 +1        SET LRANOK=1

 +2        DO ^LRDPA

 +3        IF LRDFN=-1

               SET LREND=1

               SET LRANOK=0

               QUIT

 +4        DO PAST

 +5        IF '$DATA(LRLLT)

               SET LREND=1

               SET LRANOK=0

               QUIT

 +6        SET LRAN=^LR(LRDFN,"MI",LRIDT,0)

           SET LRACC=$PIECE(LRAN,U,6)

           SET LRAD=$EXTRACT(LRAN)_$PIECE(LRACC," ",2)_"0000"

           SET LRAN=+$PIECE(LRACC," ",3)

 +7        SET X=$PIECE(LRACC," ")

           SET DIC=68

           SET DIC(0)="M"

 +8        DO ^DIC

 +9        IF Y<1

               SET LREND=1

               SET LRANOK=0

               QUIT

 +10       SET LRAA=+Y

 +11       QUIT

 +12      ;

 +13      ;

PAST      ;

 +1        WRITE !

           KILL LRAN

 +2        SET (LRSTOP,LRIDT)=0

           FOR LRCNT=1:1

               SET LRIDT=+$ORDER(^LR(LRDFN,"MI",LRIDT))

               if LRIDT<1

                   QUIT

               if '(LRCNT#5)

                   DO WAIT

               if LRSTOP

                   QUIT

               DO PAST1

 +3        IF LRCNT=1

               WRITE !,"Nothing accessioned"

               KILL LRLLT

               QUIT

 +4        if LRCNT=2

               SET LRIDT=LRLIDT

           IF LRCNT'=2

               DO SELECT

               if X=""!(X[U)

                   QUIT

 +5        SET LRLLT=^LR(LRDFN,"MI",LRIDT,0)

           SET LRCMNT=$SELECT($DATA(^(99)):^(99),1:"")

 +6        QUIT

 +7       ;

 +8       ;

WAIT      ;

 +1        READ !,"PRESS '^' TO STOP ",X:DTIME

           if X=""

               SET X=1

           SET LRSTOP=".^"[X

 +2        QUIT

 +3       ;

 +4       ;

PAST1     ;

 +1        SET LRAN=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,6)

           SET LRAN(LRCNT)=LRIDT

           SET LRLIDT=LRIDT

 +2        WRITE !?13,LRCNT

           SET Y=$PIECE(^(0),U)

           SET LRSMP=$PIECE(^(0),U,5)

 +3        DO D^LRU

           WRITE ?20,Y,"  "

 +4        if LRSMP

               WRITE ?41,$PIECE(^LAB(61,LRSMP,0),U),?60,"Acc ",LRAN

 +5        QUIT

 +6       ;

 +7       ;

SELECT    ;

 +1        KILL LRLLT

           SET LRSTOP=0

 +2        FOR

               READ !!,"Select #: ",X:DTIME

               if X=""!(X[U)

                   QUIT

               if $DATA(LRAN(X))

                   QUIT

               WRITE !,"Doesn't exist."

 +3        IF X'=""

               IF X'[U

                   SET LRIDT=LRAN(X)

 +4        QUIT

LRMIPSZ.m