LRSOR.m

LRSOR ; IHS/DIR/AAB - SOME SPECIAL OUTPUT ROUTINES 2/6/91 15:19 ; [ 11/13/97 9:46 AM ]

 ;;5.2;LR;**1003**;JUN 01, 1998

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

 D ^LRDPA G DONE:LRDFN<1 G LRA

LRC ;NON SMAC CHEMISTRIES

 I LRDFN<1 W !,"NO DATA",! Q

 R !,"DO YOU WANT (R)IA TESTS, (N)ON SMAC TESTS, (H)EMA other than CBC: ",X:DTIME

 Q:"RNH"'[$E(X,1)  G HEM:$E(X,1)="H",LRR:$E(X,1)="R"

LRCC D LPA G DONE:POP S DIC=DIC_Q_"CH"","

 S LRIDT=0 F  S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1  S LRMETH=$P(^(LRIDT,0),U,8) D LROK IF LROK,'(LRMETH="ASTRA"!(LRMETH="SMAC"))!$L($S($D(^(40)):^(40),1:"")) S DA=LRIDT,DR="0:99999999" D EN^LRDIQ D WAIT Q:LREND  W !!

 G DONE

LROK S LROK=0 Q:'$P(^LR(LRDFN,"CH",LRIDT,0),U,3)  S LRZX=$O(^LR(LRDFN,"CH",LRIDT,21)) S:LRZX>0&(LRZX<384) LROK=1 Q

LPA ;

 I $D(LRPRETTY) S DIC="^LR("_LRDFN_",",Q="""",LREND=0,LRIDTE=LRSDT,LRIDTS=LREDT Q

 S POP=1 W:LRDFN<1 !,"NO DATA",! Q:LRDFN<1

LPT R !,"Starting Date: N//",X:DTIME Q:X["^"  S:X="" X="N" S %DT="ETX" D ^%DT G LPT:Y<1

 S Y=9999999-Y,Y=$O(^LR(LRDFN,"CH",Y-.00001)),X=9999999-Y,LRIDTE=Y-.00001

 W !,"First data of any kind on ",$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)

LPT1 R !,"Number of days to check for data: 20//",X:DTIME Q:X["^"  S:X="" X=20 I +X'=X!(X>99999)!(X<1)!(X?.E1"."1N.N) W !,"Type a number between 1 and 99999." G LPT1

 S X="T-"_X,%DT="E" D ^%DT S LRIDTS=9999999-Y G LPT1:Y<1

 K %ZIS D ^%ZIS Q:POP

 U IO S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D DT^LRX,PT^LRX D HEAD S DIC="^LR("_LRDFN_",",Q="""",LREND=0 Q

LPB Q:LRDFN<1  S DIC=DIC_Q_LRSS_Q_"," S LRIDT=LRIDTE F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LRIDT<1  Q:LRIDT>LRIDTS  IF $P(^LR(LRDFN,LRSS,LRIDT,0),U,3) D LPC Q:LREND  W !

 G DONE

LPC S LRDR=$O(^LR(LRDFN,LRSS,LRIDT,LRDR1-1)) I LRDR>LRDR2!(LRDR<1) Q

 S DA=LRIDT,Z=^LR(LRDFN,LRSS,LRIDT,0),Y=+Z,X=$P(Z,U,5) D DD^LRX

 W !,"DATE&TIME: ",Y W:$L($P(Z,U,8)) ?35,"METHOD/SITE: ",$P(Z,U,8) W ?55,"ACC: ",$P(Z,U,6)

 W !,"SPECIMEN: ",$S($D(^LAB(61,+X,0)):$P(^(0),U,1),1:"??"),!?2

 S DR="0:9999999" K DX D EN^LRDIQ,WAIT Q

WAIT ;I $E(IOST,1,2)="C-" W !,PNM,"  ",SSN,"  PRESS '^' TO STOP " R X:DTIME S:$L(X) LREND=".^"[X Q

 I $E(IOST,1,2)="C-" W !,PNM,"  ",HRCN,"  PRESS '^' TO STOP " R X:DTIME S:$L(X) LREND=".^"[X Q  ;IHS/ANMC/CLS 08/18/96

 Q:$Y+6<IOSL  W !! W:$E(IOST)="P" @IOF

HEAD ;W !!,"WORK COPY ONLY - DO NOT FILE",!,PNM,?30,SSN,?50,LRDT0,! Q

 W !!,"WORK COPY ONLY - DO NOT FILE",!,PNM,?30,HRCN,?50,LRDT0,! Q  ;IHS/ANMC/CLS 08/18/96

LRR ;RADIO IMMUNO ASSAY / NUCLEAR ENDOCRINOLOGY

 D LPA G DONE:POP S LRSS="CH",LRDR1=734,LRDR2=774 G LPB

LRP ;SURGICAL PATHOLOGY

 D LPA G DONE:POP S LRSS="SP" G LPB

MIC ;MICROBIOLOGY

 D LPA G DONE:POP S LRSS="MI" G LPB

HIS ;HISTOLOGY & CYTOLOGY

 D LPA G DONE:POP S LRSS="HI" G LPB

SER ;SEROLOGY

 D LPA G DONE:POP S LRSS="CH",LRDR1=541,LRDR2=680 G LPB

LUR ;URINALYSIS

 D LPA G DONE:POP S LRSS="CH",LRDR1=683,LRDR2=733 G LPB

HEM ;HEMATOLOGY

 D LPA G DONE:POP S LRSS="CH",LRDR1=384,LRDR2=540 G LPB

DIFF ;DIFFERENTIAL

 D LPA G DONE:POP S LRSS="CH",LRDR1=394,LRDR2=404 G LPB

LRA ;LISTS ALL LAB RESULTS

 D LPA G DONE:POP S LRSS="CH",LRDR1=1,LRDR2=1000000 G LPB

DONE D ^%ZISC K LRDR,LRDR1,LRDR2,LRIDTE,LRIDTS Q

LRSOR     ; IHS/DIR/AAB - SOME SPECIAL OUTPUT ROUTINES 2/6/91 15:19 ; [ 11/13/97 9:46 AM ]

 +1       ;;5.2;LR;**1003**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**121**;Sep 27, 1994

 +3        DO ^LRDPA

           IF LRDFN<1

               GOTO DONE

           GOTO LRA

LRC       ;NON SMAC CHEMISTRIES

 +1        IF LRDFN<1

               WRITE !,"NO DATA",!

               QUIT 

 +2        READ !,"DO YOU WANT (R)IA TESTS, (N)ON SMAC TESTS, (H)EMA other than CBC: ",X:DTIME

 +3        IF "RNH"'[$EXTRACT(X,1)

               QUIT 

           IF $EXTRACT(X,1)="H"

               GOTO HEM

           IF $EXTRACT(X,1)="R"

               GOTO LRR

LRCC       DO LPA

           IF POP

               GOTO DONE

           SET DIC=DIC_Q_"CH"","

 +1        SET LRIDT=0

           FOR 

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

               IF LRIDT<1

                   QUIT 

               SET LRMETH=$PIECE(^(LRIDT,0),U,8)

               DO LROK

               IF LROK

                   IF '(LRMETH="ASTRA"!(LRMETH="SMAC"))!$LENGTH($SELECT($DATA(^(40)):^(40),1:""))

                       SET DA=LRIDT

                       SET DR="0:99999999"

                       DO EN^LRDIQ

                       DO WAIT

                       IF LREND

                           QUIT 

                       WRITE !!

 +2        GOTO DONE

LROK       SET LROK=0

           IF '$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,3)

               QUIT 

           SET LRZX=$ORDER(^LR(LRDFN,"CH",LRIDT,21))

           IF LRZX>0&(LRZX<384)

               SET LROK=1

           QUIT 

LPA       ;

 +1        IF $DATA(LRPRETTY)

               SET DIC="^LR("_LRDFN_","

               SET Q=""""

               SET LREND=0

               SET LRIDTE=LRSDT

               SET LRIDTS=LREDT

               QUIT 

 +2        SET POP=1

           IF LRDFN<1

               WRITE !,"NO DATA",!

           IF LRDFN<1

               QUIT 

LPT        READ !,"Starting Date: N//",X:DTIME

           IF X["^"

               QUIT 

           IF X=""

               SET X="N"

           SET %DT="ETX"

           DO ^%DT

           IF Y<1

               GOTO LPT

 +1        SET Y=9999999-Y

           SET Y=$ORDER(^LR(LRDFN,"CH",Y-.00001))

           SET X=9999999-Y

           SET LRIDTE=Y-.00001

 +2        WRITE !,"First data of any kind on ",$EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)

LPT1       READ !,"Number of days to check for data: 20//",X:DTIME

           IF X["^"

               QUIT 

           IF X=""

               SET X=20

           IF +X'=X!(X>99999)!(X<1)!(X?.E1"."1N.N)

               WRITE !,"Type a number between 1 and 99999."

               GOTO LPT1

 +1        SET X="T-"_X

           SET %DT="E"

           DO ^%DT

           SET LRIDTS=9999999-Y

           IF Y<1

               GOTO LPT1

 +2        KILL %ZIS

           DO ^%ZIS

           IF POP

               QUIT 

 +3        USE IO

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

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

           DO DT^LRX

           DO PT^LRX

           DO HEAD

           SET DIC="^LR("_LRDFN_","

           SET Q=""""

           SET LREND=0

           QUIT 

LPB        IF LRDFN<1

               QUIT 

           SET DIC=DIC_Q_LRSS_Q_","

           SET LRIDT=LRIDTE

           FOR 

               SET LRIDT=$ORDER(^LR(LRDFN,LRSS,LRIDT))

               IF LRIDT<1

                   QUIT 

               IF LRIDT>LRIDTS

                   QUIT 

               IF $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,3)

                   DO LPC

                   IF LREND

                       QUIT 

                   WRITE !

 +1        GOTO DONE

LPC        SET LRDR=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRDR1-1))

           IF LRDR>LRDR2!(LRDR<1)

               QUIT 

 +1        SET DA=LRIDT

           SET Z=^LR(LRDFN,LRSS,LRIDT,0)

           SET Y=+Z

           SET X=$PIECE(Z,U,5)

           DO DD^LRX

 +2        WRITE !,"DATE&TIME: ",Y

           IF $LENGTH($PIECE(Z,U,8))

               WRITE ?35,"METHOD/SITE: ",$PIECE(Z,U,8)

           WRITE ?55,"ACC: ",$PIECE(Z,U,6)

 +3        WRITE !,"SPECIMEN: ",$SELECT($DATA(^LAB(61,+X,0)):$PIECE(^(0),U,1),1:"??"),!?2

 +4        SET DR="0:9999999"

           KILL DX

           DO EN^LRDIQ

           DO WAIT

           QUIT 

WAIT      ;I $E(IOST,1,2)="C-" W !,PNM,"  ",SSN,"  PRESS '^' TO STOP " R X:DTIME S:$L(X) LREND=".^"[X Q

 +1       ;IHS/ANMC/CLS 08/18/96

           IF $EXTRACT(IOST,1,2)="C-"

               WRITE !,PNM,"  ",HRCN,"  PRESS '^' TO STOP "

               READ X:DTIME

               IF $LENGTH(X)

                   SET LREND=".^"[X

               QUIT 

 +2        IF $Y+6<IOSL

               QUIT 

           WRITE !!

           IF $EXTRACT(IOST)="P"

               WRITE @IOF

HEAD      ;W !!,"WORK COPY ONLY - DO NOT FILE",!,PNM,?30,SSN,?50,LRDT0,! Q

 +1       ;IHS/ANMC/CLS 08/18/96

           WRITE !!,"WORK COPY ONLY - DO NOT FILE",!,PNM,?30,HRCN,?50,LRDT0,!

           QUIT 

LRR       ;RADIO IMMUNO ASSAY / NUCLEAR ENDOCRINOLOGY

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="CH"

           SET LRDR1=734

           SET LRDR2=774

           GOTO LPB

LRP       ;SURGICAL PATHOLOGY

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="SP"

           GOTO LPB

MIC       ;MICROBIOLOGY

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="MI"

           GOTO LPB

HIS       ;HISTOLOGY & CYTOLOGY

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="HI"

           GOTO LPB

SER       ;SEROLOGY

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="CH"

           SET LRDR1=541

           SET LRDR2=680

           GOTO LPB

LUR       ;URINALYSIS

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="CH"

           SET LRDR1=683

           SET LRDR2=733

           GOTO LPB

HEM       ;HEMATOLOGY

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="CH"

           SET LRDR1=384

           SET LRDR2=540

           GOTO LPB

DIFF      ;DIFFERENTIAL

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="CH"

           SET LRDR1=394

           SET LRDR2=404

           GOTO LPB

LRA       ;LISTS ALL LAB RESULTS

 +1        DO LPA

           IF POP

               GOTO DONE

           SET LRSS="CH"

           SET LRDR1=1

           SET LRDR2=1000000

           GOTO LPB

DONE       DO ^%ZISC

           KILL LRDR,LRDR1,LRDR2,LRIDTE,LRIDTS

           QUIT