Routine: BLRLAHGU

BLRLAHGU ; IHS/MSC/MKK - LOAD/WORK List in the ^LAH Global  ; 22-Oct-2013 09:22 ; MKK

 ;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997

EEP ; Ersatz EP

 D EEP^BLRGMENU

PEP ; EP

ACCFILEL ; EP

 ; NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 S LRLL=0

 D SETLBRVS("ACCFILEL")

 D B^LRU

 Q:+$G(LRSDT)<1!(+$G(LRLDT)<1)

 Q:$$GETAUTOI()="Q"

 S NOGO=0

 F  Q:NOGO  D

 . D GETUID(LRSDT,LRLDT)

GETUID(LRSDT,LRLDT) ; EP

 ; The following code reads the ^LAH global for the LOAD/WORK LIST "tied" to

 ; the selected AUTO INSTRUMENT and creates the necessary string to setup

 ; the D ^DIR call to "select from a list"

 NEW BELOW,CNT,DIRZERO,DRAWDATE,ENTRY,IENSTR,LRUID,LUIDINDX,NUMCOL,STR

 S DIRZERO="SO^"

 S (CNT,ENTRY)=0

 F  S ENTRY=$O(^LAH(LRLL,1,ENTRY))  Q:ENTRY<1  D

 . S LRUID=+$G(^LAH(LRLL,1,ENTRY,.3))

 . Q:LRUID<1

. ;

 . S X=$Q(^LRO(68,"C",LRUID,0)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)

 . Q:LRAA<1!(LRAD<1)!(LRAN<1)  ; If no Accession, skip

. ;

 . S IENSTR=LRAN_","_LRAD_","_LRAA_","

 . S DRAWDATE=$P($$GET1^DIQ(68.02,IENSTR,"DRAW TIME","I"),".")

 . Q:DRAWDATE<LRSDT!(DRAWDATE>LRLDT)     ; Skip if not in date range

. ;

 . S LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")

 . S CNT=CNT+1

 . S DIRZERO=DIRZERO_CNT_":"_LRUID_";"

 . S DIRZERO(CNT)=$$LJ^XLFSTR($J(CNT,2)_") "_$$LJ^XLFSTR(LRUID,11)_LRAS,27)

 . S LUIDINDX(CNT)=LRUID_U_ENTRY_U_LRAA_U_LRAD_U_LRAN

 S CNT=CNT+1

 S DIRZERO=DIRZERO_(CNT)_":AL"

 I $D(LUIDINDX)<1 D  Q

 . W !!,?4,"No Entries for Date Range ",$$FMTE^XLFDT(LRSDT,"5DZ")," thru ",$$FMTE^XLFDT(LRLDT,"5DZ")

 . D PRESSKEY^BLRGMENU(9)

 . S LREND=1

 S NUMCOL=3

 K LRUID

 D ^XBFMK

 S DIR(0)=DIRZERO

 S DIR("L",1)="    UID        Accession       UID        Accession       UID        Accession"

 S DIR("L",2)="    ---------- -----------     ---------- -----------     ---------- ----------"

 S BELOW=3

 S CNT=0

 F  S CNT=$O(DIRZERO(CNT))  Q:CNT<1  D

 . S:(CNT#NUMCOL)=1 DIR("L",BELOW)=""

 . S DIR("L",BELOW)=$G(DIR("L",BELOW))_$S((CNT#NUMCOL)=0:$$TRIM^XLFSTR(DIRZERO(CNT),"R"," "),1:DIRZERO(CNT))

 . S:(CNT#NUMCOL)=0 BELOW=BELOW+1

 S DIR("L")=""

 S DIR("A")="Select number"    ; Change default prompt

 D HEADERDT^BLRGMENU

 D ^DIR

 I +Y<1!(+$G(DIRUT)) D  Q

 . W !,?4,"No/Invalid Entry.  Routine Ends."

 . D PRESSKEY^BLRGMENU(9)

 . S LREND=1

 S STR=$G(LUIDINDX(+$G(Y)))

 S LRUID=+STR

 S LRIFN=+$P(STR,U,2),LRAA=$P(STR,U,3),LRAD=$P(STR,U,4),LRAN=$P(STR,U,5)

ONGO(NOGO) ; EP - Continue?

 D ^XBFMK

 S DIR(0)="YO"

 S DIR("A")="Continue"

 S DIR("B")="NO"

 D ^DIR

 S:+Y<1 NOGO=1

REPORT ; EP - Report on UIDs for a Specific LOAD/WORK LIST

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 D SETLBRVS("REPORT")

 Q:$$GETAUTOI()="Q"

 Q:$$REPORTI()="Q"

 F  S ENTRY=$O(^LAH(LRLL,1,ENTRY),-1)  Q:ENTRY<1!(QFLG="Q")  D REPORTL

 D PRESSKEY^BLRGMENU(9)

REPORTI() ; EP - Initialization of variables

 K HEADER

 S HEADER(1)=LRAUTON_" AUTO INSTRUMENT"

 S HEADER(2)=$$CJ^XLFSTR(LRLLNAME_" ^LAH Entries",IOM)

 S HEADER(3)=" "

 S $E(HEADER(4),5)="Entry"

 S $E(HEADER(4),15)="UID"

 S $E(HEADER(4),28)="Accession"

 S $E(HEADER(4),48)="Order #"

 S $E(HEADER(4),58)="Order Date"

 S $E(HEADER(4),70)="Draw Date"

 S (CNT,PG)=0,ENTRY="A"

 S MAXLINES=20,LINES=MAXLINES+10

 S QFLG="NO"

 Q "OK"

REPORTL ; EP - Line of data

 Q:$$REPORTB()="Q"

 I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO")  Q:QFLG="Q"

 W ?5,ENTRY

 W ?14,LRUID

 W ?27,LRAS

 W ?47,ORDERNUM

 W ?57,DATEORD

 W ?69,DRAWDATE

W !

 S LINES=LINES+1

 S CNT=CNT+1

REPORTB() ; EP - Breakout data

 S LRUID=+$G(^LAH(LRLL,1,ENTRY,.3))

 Q:LRUID<1 "Q"

 S X=$Q(^LRO(68,"C",LRUID,0)),LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)

 Q:LRAA<1!(LRAD<1)!(LRAN<1) "Q"

 S IENSTR=LRAN_","_LRAD_","_LRAA_","

 S ORDERNUM=$$GET1^DIQ(68.02,IENSTR,"ORDER #")

 S LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")

 S DATEORD=$$FMTE^XLFDT($$GET1^DIQ(68.02,IENSTR,"DATE ORDERED","I"),"5DZ")

 S DRAWDATE=$$FMTE^XLFDT($$GET1^DIQ(68.02,IENSTR,"DRAW TIME","I"),"5DZ")

 Q "OK"

SETLBRVS(TWO) ; EP - Set the BLRVERN & BLRVERN2 variables

 S BLRVERN=$TR($P($T(+1),";")," ")

 S:$L($G(TWO)) BLRVERN2=TWO

GETAUTOI() ; EP - Get the AUTO INSTRUMENT

 S HEADER(1)="AUTO INSTRUMENT"

 D HEADERDT^BLRGMENU

 D ^XBFMK

 S DIR(0)="PO^62.4:E"

 D ^DIR

 I +Y<1!(+$G(DIRUT)) D  Q "Q"

 . W !,?4,"No/Invalid Entry.  Routine Ends."

 . D PRESSKEY^BLRGMENU(9)

 S LRAUTO=+Y,LRAUTON=$P(Y,U,2)

 I $$GETLWRKL()="Q" Q "Q"

 Q "OK"

 S LRLL=+$$GET1^DIQ(62.4,LRAUTO,"LOAD/WORK LIST","I")

 S LRLLNAME=$$GET1^DIQ(62.4,LRAUTO,"LOAD/WORK LIST")

 I LRLL<1 D  Q "Q"

 . W !,?4,"No LOAD/WORK LIST associated with ",LRAUTON,".  Routine Ends."

 . D PRESSKEY^BLRGMENU(9)

 K HEADER(1)

 S HEADER(1)=LRAUTON_" AUTO INSTRUMENT"

 S HEADER(2)=$$CJ^XLFSTR(LRLLNAME_" ^LAH Entries",IOM)

 Q "OK"

GETLWRKL() ; EP - Get the LOAD/WORK list

 S HEADER(1)="LOAD/WORK LIST"

 D HEADERDT^BLRGMENU

 ; Get LOAD/WORK list IEN

 D ^XBFMK

 S DIR(0)="PO^68.2:E"

 D ^DIR

 I +Y<1!(+$G(DIRUT)) D  Q "Q"

 . W !,?4,"No/Invalid Entry.  Routine Ends."

 . D PRESSKEY^BLRGMENU(9)

 S LRLL=+Y,LRLLNAME=$P(Y,U,2)

 S HEADER(2)=LRLLNAME_" ^LAH Entries"

 Q "OK"

BLRLAHGU  ; IHS/MSC/MKK - LOAD/WORK List in the ^LAH Global  ; 22-Oct-2013 09:22 ; MKK

 +1       ;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997

 +2       ;

EEP       ; Ersatz EP

 +1        DO EEP^BLRGMENU

 +2        QUIT

 +3       ;

PEP       ; EP

ACCFILEL  ; EP

 +1       ; NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        SET LRLL=0

 +4       ;

 +5        DO SETLBRVS("ACCFILEL")

 +6       ;

 +7        DO B^LRU

 +8        IF +$GET(LRSDT)<1!(+$GET(LRLDT)<1)

               QUIT

 +9       ;

 +10       IF $$GETAUTOI()="Q"

               QUIT

 +11      ;

 +12       QUIT

 +13       SET NOGO=0

 +14       FOR

               IF NOGO

                   QUIT

               Begin DoDot:1

 +15               DO GETUID(LRSDT,LRLDT)

               End DoDot:1

 +16       QUIT

 +17      ;

GETUID(LRSDT,LRLDT) ; EP

 +1       ; The following code reads the ^LAH global for the LOAD/WORK LIST "tied" to

 +2       ; the selected AUTO INSTRUMENT and creates the necessary string to setup

 +3       ; the D ^DIR call to "select from a list"

 +4       ;

 +5        NEW BELOW,CNT,DIRZERO,DRAWDATE,ENTRY,IENSTR,LRUID,LUIDINDX,NUMCOL,STR

 +6       ;

 +7        SET DIRZERO="SO^"

 +8        SET (CNT,ENTRY)=0

 +9        FOR

               SET ENTRY=$ORDER(^LAH(LRLL,1,ENTRY))

               IF ENTRY<1

                   QUIT

               Begin DoDot:1

 +10               SET LRUID=+$GET(^LAH(LRLL,1,ENTRY,.3))

 +11               IF LRUID<1

                       QUIT

 +12      ;

 +13               SET X=$QUERY(^LRO(68,"C",LRUID,0))

                   SET LRAA=+$QSUBSCRIPT(X,4)

                   SET LRAD=+$QSUBSCRIPT(X,5)

                   SET LRAN=+$QSUBSCRIPT(X,6)

 +14      ; If no Accession, skip

                   IF LRAA<1!(LRAD<1)!(LRAN<1)

                       QUIT

 +15      ;

 +16               SET IENSTR=LRAN_","_LRAD_","_LRAA_","

 +17               SET DRAWDATE=$PIECE($$GET1^DIQ(68.02,IENSTR,"DRAW TIME","I"),".")

 +18      ; Skip if not in date range

                   IF DRAWDATE<LRSDT!(DRAWDATE>LRLDT)

                       QUIT

 +19      ;

 +20               SET LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")

 +21               SET CNT=CNT+1

 +22               SET DIRZERO=DIRZERO_CNT_":"_LRUID_";"

 +23               SET DIRZERO(CNT)=$$LJ^XLFSTR($JUSTIFY(CNT,2)_") "_$$LJ^XLFSTR(LRUID,11)_LRAS,27)

 +24               SET LUIDINDX(CNT)=LRUID_U_ENTRY_U_LRAA_U_LRAD_U_LRAN

               End DoDot:1

 +25       SET CNT=CNT+1

 +26       SET DIRZERO=DIRZERO_(CNT)_":AL"

 +27      ;

 +28       IF $DATA(LUIDINDX)<1

               Begin DoDot:1

 +29               WRITE !!,?4,"No Entries for Date Range ",$$FMTE^XLFDT(LRSDT,"5DZ")," thru ",$$FMTE^XLFDT(LRLDT,"5DZ")

 +30               DO PRESSKEY^BLRGMENU(9)

 +31               SET LREND=1

               End DoDot:1

               QUIT

 +32      ;

 +33       SET NUMCOL=3

 +34       KILL LRUID

 +35       DO ^XBFMK

 +36       SET DIR(0)=DIRZERO

 +37       SET DIR("L",1)="    UID        Accession       UID        Accession       UID        Accession"

 +38       SET DIR("L",2)="    ---------- -----------     ---------- -----------     ---------- ----------"

 +39       SET BELOW=3

 +40       SET CNT=0

 +41       FOR

               SET CNT=$ORDER(DIRZERO(CNT))

               IF CNT<1

                   QUIT

               Begin DoDot:1

 +42               IF (CNT#NUMCOL)=1

                       SET DIR("L",BELOW)=""

 +43               SET DIR("L",BELOW)=$GET(DIR("L",BELOW))_$SELECT((CNT#NUMCOL)=0:$$TRIM^XLFSTR(DIRZERO(CNT),"R"," "),1:DIRZERO(CNT))

 +44               IF (CNT#NUMCOL)=0

                       SET BELOW=BELOW+1

               End DoDot:1

 +45      ;

 +46       SET DIR("L")=""

 +47      ; Change default prompt

           SET DIR("A")="Select number"

 +48      ;

 +49       DO HEADERDT^BLRGMENU

 +50      ;

 +51       DO ^DIR

 +52       IF +Y<1!(+$GET(DIRUT))

               Begin DoDot:1

 +53               WRITE !,?4,"No/Invalid Entry.  Routine Ends."

 +54               DO PRESSKEY^BLRGMENU(9)

 +55               SET LREND=1

               End DoDot:1

               QUIT

 +56      ;

 +57       SET STR=$GET(LUIDINDX(+$GET(Y)))

 +58       SET LRUID=+STR

 +59       SET LRIFN=+$PIECE(STR,U,2)

           SET LRAA=$PIECE(STR,U,3)

           SET LRAD=$PIECE(STR,U,4)

           SET LRAN=$PIECE(STR,U,5)

 +60       QUIT

 +61      ;

ONGO(NOGO) ; EP - Continue?

 +1        DO ^XBFMK

 +2        SET DIR(0)="YO"

 +3        SET DIR("A")="Continue"

 +4        SET DIR("B")="NO"

 +5        DO ^DIR

 +6        IF +Y<1

               SET NOGO=1

 +7        QUIT

 +8       ;

REPORT    ; EP - Report on UIDs for a Specific LOAD/WORK LIST

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        DO SETLBRVS("REPORT")

 +4        IF $$GETAUTOI()="Q"

               QUIT

 +5        IF $$REPORTI()="Q"

               QUIT

 +6       ;

 +7        FOR

               SET ENTRY=$ORDER(^LAH(LRLL,1,ENTRY),-1)

               IF ENTRY<1!(QFLG="Q")

                   QUIT

               DO REPORTL

 +8       ;

 +9        DO PRESSKEY^BLRGMENU(9)

 +10       QUIT

 +11      ;

REPORTI() ; EP - Initialization of variables

 +1        KILL HEADER

 +2        SET HEADER(1)=LRAUTON_" AUTO INSTRUMENT"

 +3        SET HEADER(2)=$$CJ^XLFSTR(LRLLNAME_" ^LAH Entries",IOM)

 +4        SET HEADER(3)=" "

 +5        SET $EXTRACT(HEADER(4),5)="Entry"

 +6        SET $EXTRACT(HEADER(4),15)="UID"

 +7        SET $EXTRACT(HEADER(4),28)="Accession"

 +8        SET $EXTRACT(HEADER(4),48)="Order #"

 +9        SET $EXTRACT(HEADER(4),58)="Order Date"

 +10       SET $EXTRACT(HEADER(4),70)="Draw Date"

 +11      ;

 +12       SET (CNT,PG)=0

           SET ENTRY="A"

 +13       SET MAXLINES=20

           SET LINES=MAXLINES+10

 +14       SET QFLG="NO"

 +15       QUIT "OK"

 +16      ;

REPORTL   ; EP - Line of data

 +1        IF $$REPORTB()="Q"

               QUIT

 +2       ;

 +3        IF LINES>MAXLINES

               DO HEADERPG^BLRGMENU(.PG,.QFLG,"NO")

               IF QFLG="Q"

                   QUIT

 +4       ;

 +5        WRITE ?5,ENTRY

 +6        WRITE ?14,LRUID

 +7        WRITE ?27,LRAS

 +8        WRITE ?47,ORDERNUM

 +9        WRITE ?57,DATEORD

 +10       WRITE ?69,DRAWDATE

 +11       WRITE !

 +12       SET LINES=LINES+1

 +13       SET CNT=CNT+1

 +14       QUIT

 +15      ;

REPORTB() ; EP - Breakout data

 +1        SET LRUID=+$GET(^LAH(LRLL,1,ENTRY,.3))

 +2        IF LRUID<1

               QUIT "Q"

 +3       ;

 +4        SET X=$QUERY(^LRO(68,"C",LRUID,0))

           SET LRAA=+$QSUBSCRIPT(X,4)

           SET LRAD=+$QSUBSCRIPT(X,5)

           SET LRAN=+$QSUBSCRIPT(X,6)

 +5       ;

 +6        IF LRAA<1!(LRAD<1)!(LRAN<1)

               QUIT "Q"

 +7       ;

 +8        SET IENSTR=LRAN_","_LRAD_","_LRAA_","

 +9       ;

 +10       SET ORDERNUM=$$GET1^DIQ(68.02,IENSTR,"ORDER #")

 +11       SET LRAS=$$GET1^DIQ(68.02,IENSTR,"ACCESSION")

 +12       SET DATEORD=$$FMTE^XLFDT($$GET1^DIQ(68.02,IENSTR,"DATE ORDERED","I"),"5DZ")

 +13       SET DRAWDATE=$$FMTE^XLFDT($$GET1^DIQ(68.02,IENSTR,"DRAW TIME","I"),"5DZ")

 +14       QUIT "OK"

 +15      ;

SETLBRVS(TWO) ; EP - Set the BLRVERN & BLRVERN2 variables

 +1        SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")

 +2        IF $LENGTH($GET(TWO))

               SET BLRVERN2=TWO

 +3        QUIT

 +4       ;

GETAUTOI() ; EP - Get the AUTO INSTRUMENT

 +1        SET HEADER(1)="AUTO INSTRUMENT"

 +2        DO HEADERDT^BLRGMENU

 +3       ;

 +4        DO ^XBFMK

 +5        SET DIR(0)="PO^62.4:E"

 +6        DO ^DIR

 +7        IF +Y<1!(+$GET(DIRUT))

               Begin DoDot:1

 +8                WRITE !,?4,"No/Invalid Entry.  Routine Ends."

 +9                DO PRESSKEY^BLRGMENU(9)

               End DoDot:1

               QUIT "Q"

 +10      ;

 +11       SET LRAUTO=+Y

           SET LRAUTON=$PIECE(Y,U,2)

 +12       IF $$GETLWRKL()="Q"

               QUIT "Q"

 +13       QUIT "OK"

 +14      ;

 +15       SET LRLL=+$$GET1^DIQ(62.4,LRAUTO,"LOAD/WORK LIST","I")

 +16       SET LRLLNAME=$$GET1^DIQ(62.4,LRAUTO,"LOAD/WORK LIST")

 +17       IF LRLL<1

               Begin DoDot:1

 +18               WRITE !,?4,"No LOAD/WORK LIST associated with ",LRAUTON,".  Routine Ends."

 +19               DO PRESSKEY^BLRGMENU(9)

               End DoDot:1

               QUIT "Q"

 +20      ;

 +21       KILL HEADER(1)

 +22       SET HEADER(1)=LRAUTON_" AUTO INSTRUMENT"

 +23       SET HEADER(2)=$$CJ^XLFSTR(LRLLNAME_" ^LAH Entries",IOM)

 +24      ;

 +25       QUIT "OK"

 +26      ;

GETLWRKL() ; EP - Get the LOAD/WORK list

 +1        SET HEADER(1)="LOAD/WORK LIST"

 +2        DO HEADERDT^BLRGMENU

 +3       ;

 +4       ; Get LOAD/WORK list IEN

 +5        DO ^XBFMK

 +6        SET DIR(0)="PO^68.2:E"

 +7        DO ^DIR

 +8        IF +Y<1!(+$GET(DIRUT))

               Begin DoDot:1

 +9                WRITE !,?4,"No/Invalid Entry.  Routine Ends."

 +10               DO PRESSKEY^BLRGMENU(9)

               End DoDot:1

               QUIT "Q"

 +11      ;

 +12       SET LRLL=+Y

           SET LRLLNAME=$PIECE(Y,U,2)

 +13       SET HEADER(2)=LRLLNAME_" ^LAH Entries"

 +14      ;

 +15       QUIT "OK"

BLRLAHGU.m