- 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
