LRMIPSZ ; IHS/DIR/FJE - MICRO PRINT/SINGLE SPECIMEN REPORT 2/19/91 10:55 ;
;;5.2;LR;**1013**;JUL 15, 2002
;
;;5.2;LAB SERVICE;**104**;Sep 27, 1994
;from option LRMIPSZ
BEGIN D ^LRPARAM W !!?23,"MICROBIOLOGY SINGLE SPECIMEN REPORT" S LREND=0,LRNL=1,LRPG=0 D CHOOSE
END ;K ^TMP("LR",$J),%,AGE,DFN,DIC,DOB,I,J,K,LRAA,LRACC,LRAD,LRAN,LRANOK,LRCMNT,LRCNT,LRDFN,LRDPF,LREND,LREP,LRIDT,LRLIDT,LRLLT,LRNL,LRONESPC,LRONETST,LRPG,LRSMP,LRSTOP,PNM,SSN,X,Y
K ^TMP("LR",$J),%,AGE,DFN,DIC,DOB,I,J,K,LRAA,LRACC,LRAD,LRAN,LRANOK,LRCMNT,LRCNT,LRDFN,LRDPF,LREND,LREP,LRIDT,LRLIDT,LRLLT,LRNL,LRONESPC,LRONETST,LRPG,LRSMP,LRSTOP,PNM,SSN,HRCN,X,Y ;IHS/ANMC/CLS 08/18/96
Q
CHOOSE F W !,"1 Look-up by Accession number",!,"2 Look-up by name/ssn",!," Choose: 1// " R X:DTIME S:X="" X=1 Q:"12"[X&(X?1N)!(X[U)
Q:X[U S LREP=X S:LREP="" LREP=1
S %ZIS="MQ" F K LRAN,DIC D @$S(LREP=1:"ACC",1:"PAT") Q:LREND S ZTRTN="DQ^LRMIPSZ" 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 D ^LRMIU4 S:LRAN<1 LREND=1 Q:LREND
S X=LRAN F R:'$D(LRAN) !!,"Accession #: ",X:DTIME S:X=""!(X[U) LREND=1 Q:LREND S LRANOK=1,LRPG=0 D LRANX^LRMIU4 D:LRANOK ACC1 Q:LREND!LRANOK W !,"Enter the accession number" K LRAN
Q
ACC1 S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRIDT=$P(^(3),U,5),LRLLT=^LR(LRDFN,"MI",LRIDT,0),LRACC=$P(LRLLT,U,6),LRCMNT=$S($D(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:"")
;S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !?20,PNM,?40,SSN
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !?20,PNM,?40,HRCN,?50,"DOB: ",DOB ;IHS/ANMC/CLS 08/18/96
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 D ^LRDPA S:LRDFN=-1 LREND=1 Q:LREND
D PAST S:'$D(LRLLT) LREND=1 Q:LREND
S LRAN=^LR(LRDFN,"MI",LRIDT,0),LRACC=$P(LRAN,U,6),LRAD=$E(LRAN)_$P(LRACC," ",2)_"0000",LRAN=+$P(LRACC," ",3),X=$P(LRACC," "),DIC=68,DIC(0)="M" D ^DIC S:Y<1 LREND=1 Q:LREND 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
LRMIPSZ ; IHS/DIR/FJE - MICRO PRINT/SINGLE SPECIMEN REPORT 2/19/91 10:55 ;
+1 ;;5.2;LR;**1013**;JUL 15, 2002
+2 ;
+3 ;;5.2;LAB SERVICE;**104**;Sep 27, 1994
+4 ;from option LRMIPSZ
BEGIN DO ^LRPARAM
WRITE !!?23,"MICROBIOLOGY SINGLE SPECIMEN REPORT"
SET LREND=0
SET LRNL=1
SET LRPG=0
DO CHOOSE
END ;K ^TMP("LR",$J),%,AGE,DFN,DIC,DOB,I,J,K,LRAA,LRACC,LRAD,LRAN,LRANOK,LRCMNT,LRCNT,LRDFN,LRDPF,LREND,LREP,LRIDT,LRLIDT,LRLLT,LRNL,LRONESPC,LRONETST,LRPG,LRSMP,LRSTOP,PNM,SSN,X,Y
+1 ;IHS/ANMC/CLS 08/18/96
KILL ^TMP("LR",$JOB),%,AGE,DFN,DIC,DOB,I,J,K,LRAA,LRACC,LRAD,LRAN,LRANOK,LRCMNT,LRCNT,LRDFN,LRDPF,LREND,LREP,LRIDT,LRLIDT,LRLLT,LRNL,LRONESPC,LRONETST,LRPG,LRSMP,LRSTOP,PNM,SSN,HRCN,X,Y
+2 QUIT
CHOOSE FOR
WRITE !,"1 Look-up by Accession number",!,"2 Look-up by name/ssn",!," Choose: 1// "
READ X:DTIME
IF X=""
SET X=1
IF "12"[X&(X?1N)!(X[U)
QUIT
+1 IF X[U
QUIT
SET LREP=X
IF LREP=""
SET LREP=1
+2 SET %ZIS="MQ"
FOR
KILL LRAN,DIC
DO @$SELECT(LREP=1:"ACC",1:"PAT")
IF LREND
QUIT
SET ZTRTN="DQ^LRMIPSZ"
DO IO^LRWU
IF LREND
QUIT
+3 QUIT
DQ ;dequeued
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
+2 SET LRONETST=""
SET LRONESPC=""
DO EN^LRMIPSZ1
KILL LRONETST,LRONESPC
+3 QUIT
ACC DO ^LRMIU4
IF LRAN<1
SET LREND=1
IF LREND
QUIT
+1 SET X=LRAN
FOR
IF '$DATA(LRAN)
READ !!,"Accession #: ",X:DTIME
IF X=""!(X[U)
SET LREND=1
IF LREND
QUIT
SET LRANOK=1
SET LRPG=0
DO LRANX^LRMIU4
IF LRANOK
DO ACC1
IF LREND!LRANOK
QUIT
WRITE !,"Enter the accession number"
KILL LRAN
+2 QUIT
ACC1 SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRIDT=$PIECE(^(3),U,5)
SET LRLLT=^LR(LRDFN,"MI",LRIDT,0)
SET LRACC=$PIECE(LRLLT,U,6)
SET LRCMNT=$SELECT($DATA(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:"")
+1 ;S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !?20,PNM,?40,SSN
+2 ;IHS/ANMC/CLS 08/18/96
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
WRITE !?20,PNM,?40,HRCN,?50,"DOB: ",DOB
+3 FOR
WRITE !,?20,"OK"
SET %=1
DO YN^DICN
IF %
QUIT
WRITE !,"Answer 'Y'es or 'N'o"
+4 IF %=-1
SET LREND=1
IF %=2
SET LRANOK=0
+5 QUIT
PAT DO ^LRDPA
IF LRDFN=-1
SET LREND=1
IF LREND
QUIT
+1 DO PAST
IF '$DATA(LRLLT)
SET LREND=1
IF LREND
QUIT
+2 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)
SET X=$PIECE(LRACC," ")
SET DIC=68
SET DIC(0)="M"
DO ^DIC
IF Y<1
SET LREND=1
IF LREND
QUIT
SET LRAA=+Y
+3 QUIT
PAST WRITE !
KILL LRAN
+1 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
+2 IF LRCNT=1
WRITE !,"Nothing accessioned"
KILL LRLLT
QUIT
+3 IF LRCNT=2
SET LRIDT=LRLIDT
IF LRCNT'=2
DO SELECT
IF X=""!(X[U)
QUIT
+4 SET LRLLT=^LR(LRDFN,"MI",LRIDT,0)
SET LRCMNT=$SELECT($DATA(^(99)):^(99),1:"")
+5 QUIT
WAIT READ !,"PRESS '^' TO STOP ",X:DTIME
IF X=""
SET X=1
SET LRSTOP=".^"[X
+1 QUIT
PAST1 SET LRAN=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,6)
SET LRAN(LRCNT)=LRIDT
SET LRLIDT=LRIDT
WRITE !?13,LRCNT
SET Y=$PIECE(^(0),U)
SET LRSMP=$PIECE(^(0),U,5)
DO D^LRU
WRITE ?20,Y," "
IF LRSMP
WRITE ?41,$PIECE(^LAB(61,LRSMP,0),U),?60,"Acc ",LRAN
+1 QUIT
SELECT KILL LRLLT
SET LRSTOP=0
FOR
READ !!,"Select #: ",X:DTIME
IF X=""!(X[U)
QUIT
IF $DATA(LRAN(X))
QUIT
WRITE !,"Doesn't exist."
+1 IF X'=""
IF X'[U
SET LRIDT=LRAN(X)
+2 QUIT
