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
Q
;
;
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
Q
;
;
DQ ;dequeued
S:$D(ZTQUEUED) ZTREQ="@" U IO
S LRONETST="",LRONESPC="" D EN^LRMIPSZ1 K LRONETST,LRONESPC
Q
;
;
ACC ; Lookup by accession number/UID
;
D ENA^LRWU4("MI")
I LRAN<1 S LREND=1 Q
S LRANOK=1,LRPG=0 D ACC1
Q
;
;
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
Q
;
;
;
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
Q
;
;
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:"")
Q
;
;
WAIT ;
R !,"PRESS '^' TO STOP ",X:DTIME S:X="" X=1 S LRSTOP=".^"[X
Q
;
;
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
Q
;
;
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)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIPSZ 2559 printed Apr 09, 2024@21:08:41 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
