Routine: LRMIPC

LRMIPC ;SLC/CJS/BA - MICROBIOLOGY CUMULATIVE PATIENT REPORT ;DEC 09, 2008 8:30 AM

 ;;5.2;LAB SERVICE;**1018,1025**;NOV 01, 1997

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

 ;from option LRMIPC

BEGIN K DIC W !!?21,"MICROBIOLOGY CUMULATIVE PATIENT REPORT" D ^LRPARAM D ^LRDPA I LRDFN'=-1 D EN

END K DFN,DIC,DOB,I,J,K,LRAA,LRACC,LRAD,LRAN,LRCMNT,LRDFN,LRDPF,LREDT,LREND,LRIDT,LRLLT,LRONESPC,LRONETST,LRPG,LRSDT,PNM,POP,SSN,X,X1,Y

ALL ;from pretty print

 S LRONETST=""

EN ;from pretty print

 I $D(LRPRETTY) S LRIDT=LRSDT D DQ Q

 I '$D(LRONESPC) S LRONESPC="",DIC="^LAB(61,",DIC("A")="Select SPECIMEN/SOURCE: ANY//",DIC(0)="AEMOQ" D ^DIC Q:X[U  S:Y>0 LRONESPC=+Y

 I '$D(LRONETST) S LRONETST="",DIC="^LAB(60,",DIC("A")="Select MICROBIOLOGY TEST: ALL MICRO//",DIC(0)="AEOQ",DIC("S")="I $P(^(0),U,4)=""MI""" D ^DIC K DIC Q:$D(DTOUT)!$D(DUOUT)  I Y>0 S LRONETST=+Y

 S LREDT="T-14" D ^LRWU3 Q:LREND  S LREDT=9999999-LREDT,LRIDT=9999999-LRSDT

 S ZTRTN="DQ^LRMIPC" D IO^LRWU

DQ ;dequeued

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

 S LREND=0,LRPG=0 F  S LRIDT=+$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1!(LRIDT>LREDT)  D EN1 Q:LREND

EN1 ;from LRRP1, LRRP2, LRRP3, LRAC1, LRACO1, LRACSUM1

 ; S LRLLT=^LR(LRDFN,"MI",LRIDT,0),LRACC=$P(LRLLT,U,6),LRAD=$E(LRLLT)_$P(LRACC," ",2)_"0000",X=$P(LRACC," "),DIC=68,DIC(0)="M"

 ; ----- BEGIN/IHS/OIT/MKK -- Naked Reference Caused <UNDEFINED> at GIMC (Service Center # 27753) -- LR*5.2*1025

 S LRLLT=$G(^LR(LRDFN,"MI",LRIDT,0)),LRACC=$P(LRLLT,U,6),LRAD=$E(LRLLT)_$P(LRACC," ",2)_"0000",X=$P(LRACC," "),DIC=68,DIC(0)="M"

 ; ----- END/IHS/OIT/MKK -- LR*5.2*1025

 I $L(X) D ^DIC S LRAA=+Y,LRAN=+$P(LRACC," ",3),LRCMNT=$S($D(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:"") D EN^LRMIPSZ1 Q:LREND

LRMIPC    ;SLC/CJS/BA - MICROBIOLOGY CUMULATIVE PATIENT REPORT ;DEC 09, 2008 8:30 AM

 +1       ;;5.2;LAB SERVICE;**1018,1025**;NOV 01, 1997

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

 +3       ;from option LRMIPC

BEGIN      KILL DIC

           WRITE !!?21,"MICROBIOLOGY CUMULATIVE PATIENT REPORT"

           DO ^LRPARAM

           DO ^LRDPA

           IF LRDFN'=-1

               DO EN

END        KILL DFN,DIC,DOB,I,J,K,LRAA,LRACC,LRAD,LRAN,LRCMNT,LRDFN,LRDPF,LREDT,LREND,LRIDT,LRLLT,LRONESPC,LRONETST,LRPG,LRSDT,PNM,POP,SSN,X,X1,Y

 +1        QUIT

ALL       ;from pretty print

 +1        SET LRONETST=""

EN        ;from pretty print

 +1        IF $DATA(LRPRETTY)

               SET LRIDT=LRSDT

               DO DQ

               QUIT

 +2        IF '$DATA(LRONESPC)

               SET LRONESPC=""

               SET DIC="^LAB(61,"

               SET DIC("A")="Select SPECIMEN/SOURCE: ANY//"

               SET DIC(0)="AEMOQ"

               DO ^DIC

               IF X[U

                   QUIT

               IF Y>0

                   SET LRONESPC=+Y

 +3        IF '$DATA(LRONETST)

               SET LRONETST=""

               SET DIC="^LAB(60,"

               SET DIC("A")="Select MICROBIOLOGY TEST: ALL MICRO//"

               SET DIC(0)="AEOQ"

               SET DIC("S")="I $P(^(0),U,4)=""MI"""

               DO ^DIC

               KILL DIC

               IF $DATA(DTOUT)!$DATA(DUOUT)

                   QUIT

               IF Y>0

                   SET LRONETST=+Y

 +4        SET LREDT="T-14"

           DO ^LRWU3

           IF LREND

               QUIT

           SET LREDT=9999999-LREDT

           SET LRIDT=9999999-LRSDT

 +5        SET ZTRTN="DQ^LRMIPC"

           DO IO^LRWU

 +6        QUIT

DQ        ;dequeued

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           USE IO

 +2        SET LREND=0

           SET LRPG=0

FOR

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

               IF LRIDT<1!(LRIDT>LREDT)

                   QUIT

               DO EN1

               IF LREND

                   QUIT

 +3        QUIT

EN1       ;from LRRP1, LRRP2, LRRP3, LRAC1, LRACO1, LRACSUM1

 +1       ; S LRLLT=^LR(LRDFN,"MI",LRIDT,0),LRACC=$P(LRLLT,U,6),LRAD=$E(LRLLT)_$P(LRACC," ",2)_"0000",X=$P(LRACC," "),DIC=68,DIC(0)="M"

 +2       ; ----- BEGIN/IHS/OIT/MKK -- Naked Reference Caused <UNDEFINED> at GIMC (Service Center # 27753) -- LR*5.2*1025

 +3        SET LRLLT=$GET(^LR(LRDFN,"MI",LRIDT,0))

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

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

           SET X=$PIECE(LRACC," ")

           SET DIC=68

           SET DIC(0)="M"

 +4       ; ----- END/IHS/OIT/MKK -- LR*5.2*1025

 +5        IF $LENGTH(X)

               DO ^DIC

               SET LRAA=+Y

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

               SET LRCMNT=$SELECT($DATA(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:"")

               DO EN^LRMIPSZ1

               IF LREND

                   QUIT

 +6        QUIT

LRMIPC.m