BLRRLMU3 ; IHS/MSC/MKK - Reference Lab Meaningful use Utilities, Part 3 ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033**;NOV 1, 1997
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
PEP ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S BLRVERN=$TR($P($T(+1),";")," ")
;
D ADDTMENU^BLRGMENU("LAHTESTS^BLRRLMU3","62.49 Tests Report")
D ADDTMENU^BLRGMENU("LAHSPMS^BLRRLMU3","IHSSPM Values")
D ADDTMENU^BLRGMENU("LAHLRASR^BLRRLMU3","LRAS Report")
D ADDTMENU^BLRGMENU("LAHUIDS^BLRRLMU3","UIDs Report")
D ADDTMENU^BLRGMENU("LRLLUIDS^BLRRLMU3","Load/Work List UIDs Report")
D ADDTMENU^BLRGMENU("LAHDETAC^BLRRLMU3","Accession/UID Detail Report")
D ADDTMENU^BLRGMENU("DUPCINDX^BLRRLMU3","Duplicate 'C' Index Entries")
;
;
; Main Menu driver
D MENUDRVR^BLRGMENU("RPMS Lab MU Stage 2","Miscellaneous Debug Utilities",$$CJ^XLFSTR("^LAH Global Reports",IOM))
Q
;
LAHTESTS ; EP - ^LAH 62.49 Tests Report
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
;
D LAHTESTI
;
F S LAHIEN=$O(^LAH(37,1,LAHIEN)) Q:LAHIEN<1 D
. S UID=$G(^LAH(37,1,LAHIEN,.3))
. Q:$L(UID)<1
. Q:$D(^TMP("BLRRLMUU",$J,"UID",UID))<1
. ;
. W ?4,LAHIEN,?19,UID,?34,$G(^TMP("BLRRLMUU",$J,"UID",UID)),!
. S LINES=LINES+1
. S CNT=CNT+1
;
W !!
;
W:CNT<1 ?4,"No UIDs in ^LAH match 62.49",!
W:CNT ?4,"Number of UIDs in ^LAH that Match 62.49 = ",CNT,!
;
W !,?9,"Number of UIDs in 62.49 = ",UID6249,!
;
D PRESSKEY^BLRGMENU
Q
;
LAHTESTI ; EP - Initialization
S BLRVERN=$TR($P($T(+1),";")," ")
;
S HEADER(1)="^LAH NIST Entries with 62.49 Data"
;
S HEADER(2)=" "
S $E(HEADER(3),5)="IEN"
S $E(HEADER(3),20)="UID"
S $E(HEADER(3),35)="IHSSPM"
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S (CNT,PG,UID6249)=0
S (HDRONE,QFLG)="NO"
;
D LAHTESTU(.UID6249)
;
S LAHIEN=.9999999
D HEADERDT^BLRGMENU
;
Q
;
LAHTESTU(UID6249) ; EP - Create UID index into 62.49
NEW IEN,INST,UID
;
K ^TMP("BLRRLMUU",$J,"UID")
;
S INST=""
F S INST=$O(^LAHM(62.49,"C",INST)) Q:INST="" D
. S UID=$P(INST,"-",3)
. Q:$L(UID)<1
. ;
. S IEN=$O(^LAHM(62.49,"C",INST,"A"),-1)
. S ^TMP("BLRRLMUU",$J,"UID",UID)=IEN
. S UID6249=UID6249+1
Q
;
LAHSPMS ; EP - ^LAH IHSSPM Values
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
;
Q:$$LAHSPMSI()="Q"
;
F S IEN=$O(^LAH(LOADWORK,1,IEN),-1) Q:IEN<1 D
. Q:$D(^LAH(LOADWORK,1,IEN,"IHSSPM"))<1
. W IEN
. W ?9,$G(^LAH(LOADWORK,1,IEN,.3))
. W ?24,$E($G(^LAH(LOADWORK,1,IEN,"IHSSPM")),1,60)
. W !
;
D PRESSKEY^BLRGMENU(4)
Q
;
LAHSPMSI() ; EP - Initialization
S BLRVERN=$TR($P($T(+1),";")," ")
;
S HEADER(1)="^LAH IHSSPM Entries"
S HEADER(2)=" "
S HEADER(3)="IEN"
S $E(HEADER(3),10)="UID"
S $E(HEADER(3),25)="IHSSPM"
;
S LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
I $G(LA7INST)=""
Q:$G(LA7INST)="" "Q" ; Quit with zero if no Reference Lab
;
S AUTOIEN=+$O(^LAB(62.4,"B",LA7INST,"")) ; Auto Instrument IEN
Q:AUTOIEN<1 "Q" ; Quit with zero if No Auto Instrument
;
S LOADWORK=$$GET1^DIQ(62.4,AUTOIEN,"LOAD/WORK LIST","I")
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S (CNT,PG)=0
S (HDRONE,QFLG)="NO"
S IEN="AA"
D HEADERDT^BLRGMENU
Q "OK"
;
LAHLRASR ; EP - LAH LRAS Report
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
;
D LAHLRASI
;
F S LAHIEN=$O(^LAH(37,1,LAHIEN)) Q:LAHIEN<1 D
. S UID=$G(^LAH(37,1,LAHIEN,.3))
. Q:$L(UID)<1
. ;
. W ?4,LAHIEN,?19,UID,?34,$G(^TMP("BLRRLMUU",$J,"UID",UID)),?54,$$GETLRAS(UID),!
. S LINES=LINES+1
. S CNT=CNT+1
;
W !!
;
W:CNT<1 ?4,"No UIDs in ^LAH",!
W:CNT ?4,"Number of UIDs in ^LAH = ",CNT,!
;
D PRESSKEY^BLRGMENU
Q
;
LAHLRASI ; EP - Initialization
D LAHTESTI
K HEADER(1)
S HEADER(1)="^LAH NIST Entries"
S $E(HEADER(3),55)="LRAS"
;
S LAHIEN=.9999999
D HEADERDT^BLRGMENU
Q
;
LAHUIDS ; EP - List the UIDs found in the ^LAH global
NEW HEADER,IEN,UID,UIDCNT,UIDPTR
;
S HEADER(1)="^LAH Global Listing"
S HEADER(2)="Entries with UIDs ONLY"
S HEADER(3)=" "
S $E(HEADER(4),5)="IEN"
S $E(HEADER(4),15)="LOAD/WORK LIST"
S $E(HEADER(4),35)="UID"
;
D HEADERDT^BLRGMENU
;
S IEN=.9999999
F S IEN=$O(^LAH(IEN)) Q:IEN<1 D
. S LOADWORK=$$GET1^DIQ(68.2,IEN,"NAME")
. S LOADWORK=$TR(LOADWORK," ","@")
. W !,?5,$TR($$CJ^XLFSTR("@LOAD/WORK@LIST:@"_LOADWORK_"@["_IEN_"]@",66)," @","= "),!
. W ?9
. S UID="AAA",UIDCNT=0
. F S UID=$O(^LAH(IEN,1,"U",UID),-1) Q:UID<1!(UIDCNT>19) D
.. S UIDPTR=+$O(^LAH(IEN,1,"U",UID,0))
.. Q:$D(^LAH(IEN,1,UIDPTR))<1
.. ;
.. W $$LJ^XLFSTR(UID,12)
.. W:$X>64 !,?9
.. S UIDCNT=UIDCNT+1
. W:UIDCNT<20 !
;
D PRESSKEY^BLRGMENU(9)
Q
;
LAHDETAC ; EP -- Accession/UID Detail Report
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$$LAHDETAI()="Q"
;
Q
;
LAHDETAI() ; EP - Initialization
Q ""
;
LRLLUIDS ; EP - Load/Work List UIDs Report
NEW HEADER,IEN,LRIFN,LRLL,LRLLDESC,UID,UIDCNT,UIDPTR
;
S HEADER(1)="^LAH Global Listing"
;
D HEADERDT^BLRGMENU
D ^XBFMK
S DIR(0)="PO^68.2:AE"
D ^DIR
I +$G(DIRUT) D Q
. W !!,?4,"Invalid/No Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
S LRLL=+Y
S LRLLDESC=$P(Y,"^",2)
;
S HEADER(2)=LRLLDESC_" ["_LRLL_"] LOAD/WORK LIST"
S HEADER(3)=$$CJ^XLFSTR("UIDs Report",IOM)
S HEADER(4)=" "
S HEADER(5)="IEN"
S $E(HEADER(5),10)="UID"
S $E(HEADER(5),25)="Accession #"
S $E(HEADER(5),40)="^LAH(LRLL,1,LRIFN,0)"
;
D HEADERDT^BLRGMENU
;
S UID="",UIDCNT=0
F S UID=$O(^LAH(LRLL,1,"U",UID)) Q:UID<1 D
. S LRIFN=+$O(^LAH(LRLL,1,"U",UID,0))
. Q:'$D(^LAH(LRLL,1,LRIFN,0))#2
. ;
. W LRIFN
. W ?9,UID
. W ?24,$$GETLRAS(UID)
. W ?39,$E($G(^LAH(LRLL,1,LRIFN,0)),1,40)
. W !
. S UIDCNT=UIDCNT+1
;
D PRESSKEY^BLRGMENU(9)
Q
;
GETLRAS(UID) ; EP - Get the Accession # from the UID
NEW X,LRAA,LRAD,LRAN
;
S X=$Q(^LRO(68,"C",UID,0))
S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
Q LRAS
;
DUPCINDX ; EP - Duplicate 'C' Index Entries
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVR
Q:$$GETLOADW()="Q"
;
Q:$$DUPCNDXI()="Q"
;
F S NUM=$O(^LAH(LRLL,1,"C",NUM)) Q:NUM=""!(QFLG="Q") D
. S CNTNUM=CNTNUM+1
. S IEN=0
. K IENCNT
. F S IEN=$O(^LAH(LRLL,1,"C",NUM,IEN)) Q:IEN<1!(QFLG="Q") D
.. S IENCNT=1+$G(IENCNT)
.. S IENCNT(IENCNT)=IEN
. D:IENCNT>1 DUPCNDXL
;
W:CNT<1 !!,?4,"Number of entries for ",$G(HEADER(1))," examined = ",CNTNUM
D PRESSKEY^BLRGMENU(9)
Q
;
SETBLRVR(TWO) ; EP - Set the BLRVERN variable(s)
S BLRVERN=$TR($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=TWO
Q
;
GETLOADW() ; EP - Get the LOAD/WORK LIST
NEW HEADER
S HEADER(1)="LOAD/WORK LIST"
D HEADERDT^BLRGMENU
;
D ^XBFMK
S DIR(0)="PO^68.2:AE"
D ^DIR
I +$G(DIRUT) D Q "Q"
. W !!,?4,"Invalid/No Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
S LRLL=+Y
S LRLLDESC=$P(Y,"^",2)
Q "OK"
;
DUPCNDXI() ; EP - Initialization
S HEADER(1)=LRLLDESC_" ["_LRLL_"] LOAD/WORK LIST"
S HEADER(2)="Duplicate Counts"
S HEADER(3)=" "
S $E(HEADER(4),5)="NUM"
S $E(HEADER(4),20)="CNT"
S $E(HEADER(4),30)="IEN"
S $E(HEADER(4),40)="UID"
S $E(HEADER(4),55)="IHSSPM"
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S (CNT,CNTNUM,NUM,PG)=0
S (HDRONE,QFLG)="NO"
Q "OK"
;
DUPCNDXL ; EP - Line of Data
S CNT2=0
F S CNT2=$O(IENCNT(CNT2)) Q:CNT2<1!(QFLG="Q") D
. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO") Q:QFLG="Q"
. S IEN2=$G(IENCNT(CNT2))
. W ?4,NUM
. W ?19,CNT2
. W ?29,IEN2
. W ?39,$G(^LAH(LRLL,1,IEN2,.3)) ; UID
. W ?54,$E($G(^LAH(LRLL,1,IEN2,"IHSSPM")),1,25)
. W !
. S LINES=LINES+1
. S CNT=CNT+1
Q
BLRRLMU3 ; IHS/MSC/MKK - Reference Lab Meaningful use Utilities, Part 3 ; 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
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+4 ;
+5 DO ADDTMENU^BLRGMENU("LAHTESTS^BLRRLMU3","62.49 Tests Report")
+6 DO ADDTMENU^BLRGMENU("LAHSPMS^BLRRLMU3","IHSSPM Values")
+7 DO ADDTMENU^BLRGMENU("LAHLRASR^BLRRLMU3","LRAS Report")
+8 DO ADDTMENU^BLRGMENU("LAHUIDS^BLRRLMU3","UIDs Report")
+9 DO ADDTMENU^BLRGMENU("LRLLUIDS^BLRRLMU3","Load/Work List UIDs Report")
+10 DO ADDTMENU^BLRGMENU("LAHDETAC^BLRRLMU3","Accession/UID Detail Report")
+11 DO ADDTMENU^BLRGMENU("DUPCINDX^BLRRLMU3","Duplicate 'C' Index Entries")
+12 ;
+13 ;
+14 ; Main Menu driver
+15 DO MENUDRVR^BLRGMENU("RPMS Lab MU Stage 2","Miscellaneous Debug Utilities",$$CJ^XLFSTR("^LAH Global Reports",IOM))
+16 QUIT
+17 ;
LAHTESTS ; EP - ^LAH 62.49 Tests Report
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
+2 ;
+3 DO LAHTESTI
+4 ;
+5 FOR
SET LAHIEN=$ORDER(^LAH(37,1,LAHIEN))
IF LAHIEN<1
QUIT
Begin DoDot:1
+6 SET UID=$GET(^LAH(37,1,LAHIEN,.3))
+7 IF $LENGTH(UID)<1
QUIT
+8 IF $DATA(^TMP("BLRRLMUU",$JOB,"UID",UID))<1
QUIT
+9 ;
+10 WRITE ?4,LAHIEN,?19,UID,?34,$GET(^TMP("BLRRLMUU",$JOB,"UID",UID)),!
+11 SET LINES=LINES+1
+12 SET CNT=CNT+1
End DoDot:1
+13 ;
+14 WRITE !!
+15 ;
+16 IF CNT<1
WRITE ?4,"No UIDs in ^LAH match 62.49",!
+17 IF CNT
WRITE ?4,"Number of UIDs in ^LAH that Match 62.49 = ",CNT,!
+18 ;
+19 WRITE !,?9,"Number of UIDs in 62.49 = ",UID6249,!
+20 ;
+21 DO PRESSKEY^BLRGMENU
+22 QUIT
+23 ;
LAHTESTI ; EP - Initialization
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="^LAH NIST Entries with 62.49 Data"
+4 ;
+5 SET HEADER(2)=" "
+6 SET $EXTRACT(HEADER(3),5)="IEN"
+7 SET $EXTRACT(HEADER(3),20)="UID"
+8 SET $EXTRACT(HEADER(3),35)="IHSSPM"
+9 ;
+10 SET MAXLINES=IOSL-4
+11 SET LINES=MAXLINES+10
+12 SET (CNT,PG,UID6249)=0
+13 SET (HDRONE,QFLG)="NO"
+14 ;
+15 DO LAHTESTU(.UID6249)
+16 ;
+17 SET LAHIEN=.9999999
+18 DO HEADERDT^BLRGMENU
+19 ;
+20 QUIT
+21 ;
LAHTESTU(UID6249) ; EP - Create UID index into 62.49
+1 NEW IEN,INST,UID
+2 ;
+3 KILL ^TMP("BLRRLMUU",$JOB,"UID")
+4 ;
+5 SET INST=""
+6 FOR
SET INST=$ORDER(^LAHM(62.49,"C",INST))
IF INST=""
QUIT
Begin DoDot:1
+7 SET UID=$PIECE(INST,"-",3)
+8 IF $LENGTH(UID)<1
QUIT
+9 ;
+10 SET IEN=$ORDER(^LAHM(62.49,"C",INST,"A"),-1)
+11 SET ^TMP("BLRRLMUU",$JOB,"UID",UID)=IEN
+12 SET UID6249=UID6249+1
End DoDot:1
+13 QUIT
+14 ;
LAHSPMS ; EP - ^LAH IHSSPM Values
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$LAHSPMSI()="Q"
QUIT
+4 ;
+5 FOR
SET IEN=$ORDER(^LAH(LOADWORK,1,IEN),-1)
IF IEN<1
QUIT
Begin DoDot:1
+6 IF $DATA(^LAH(LOADWORK,1,IEN,"IHSSPM"))<1
QUIT
+7 WRITE IEN
+8 WRITE ?9,$GET(^LAH(LOADWORK,1,IEN,.3))
+9 WRITE ?24,$EXTRACT($GET(^LAH(LOADWORK,1,IEN,"IHSSPM")),1,60)
+10 WRITE !
End DoDot:1
+11 ;
+12 DO PRESSKEY^BLRGMENU(4)
+13 QUIT
+14 ;
LAHSPMSI() ; EP - Initialization
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="^LAH IHSSPM Entries"
+4 SET HEADER(2)=" "
+5 SET HEADER(3)="IEN"
+6 SET $EXTRACT(HEADER(3),10)="UID"
+7 SET $EXTRACT(HEADER(3),25)="IHSSPM"
+8 ;
+9 SET LA7INST=$$GET1^DIQ(9009029,DUZ(2),3001)
+10 IF $GET(LA7INST)=""
+11 ; Quit with zero if no Reference Lab
IF $GET(LA7INST)=""
QUIT "Q"
+12 ;
+13 ; Auto Instrument IEN
SET AUTOIEN=+$ORDER(^LAB(62.4,"B",LA7INST,""))
+14 ; Quit with zero if No Auto Instrument
IF AUTOIEN<1
QUIT "Q"
+15 ;
+16 SET LOADWORK=$$GET1^DIQ(62.4,AUTOIEN,"LOAD/WORK LIST","I")
+17 ;
+18 SET MAXLINES=IOSL-4
+19 SET LINES=MAXLINES+10
+20 SET (CNT,PG)=0
+21 SET (HDRONE,QFLG)="NO"
+22 SET IEN="AA"
+23 DO HEADERDT^BLRGMENU
+24 QUIT "OK"
+25 ;
LAHLRASR ; EP - LAH LRAS Report
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRUID,U,XPARSYS,XQXFLG)
+2 ;
+3 DO LAHLRASI
+4 ;
+5 FOR
SET LAHIEN=$ORDER(^LAH(37,1,LAHIEN))
IF LAHIEN<1
QUIT
Begin DoDot:1
+6 SET UID=$GET(^LAH(37,1,LAHIEN,.3))
+7 IF $LENGTH(UID)<1
QUIT
+8 ;
+9 WRITE ?4,LAHIEN,?19,UID,?34,$GET(^TMP("BLRRLMUU",$JOB,"UID",UID)),?54,$$GETLRAS(UID),!
+10 SET LINES=LINES+1
+11 SET CNT=CNT+1
End DoDot:1
+12 ;
+13 WRITE !!
+14 ;
+15 IF CNT<1
WRITE ?4,"No UIDs in ^LAH",!
+16 IF CNT
WRITE ?4,"Number of UIDs in ^LAH = ",CNT,!
+17 ;
+18 DO PRESSKEY^BLRGMENU
+19 QUIT
+20 ;
LAHLRASI ; EP - Initialization
+1 DO LAHTESTI
+2 KILL HEADER(1)
+3 SET HEADER(1)="^LAH NIST Entries"
+4 SET $EXTRACT(HEADER(3),55)="LRAS"
+5 ;
+6 SET LAHIEN=.9999999
+7 DO HEADERDT^BLRGMENU
+8 QUIT
+9 ;
LAHUIDS ; EP - List the UIDs found in the ^LAH global
+1 NEW HEADER,IEN,UID,UIDCNT,UIDPTR
+2 ;
+3 SET HEADER(1)="^LAH Global Listing"
+4 SET HEADER(2)="Entries with UIDs ONLY"
+5 SET HEADER(3)=" "
+6 SET $EXTRACT(HEADER(4),5)="IEN"
+7 SET $EXTRACT(HEADER(4),15)="LOAD/WORK LIST"
+8 SET $EXTRACT(HEADER(4),35)="UID"
+9 ;
+10 DO HEADERDT^BLRGMENU
+11 ;
+12 SET IEN=.9999999
+13 FOR
SET IEN=$ORDER(^LAH(IEN))
IF IEN<1
QUIT
Begin DoDot:1
+14 SET LOADWORK=$$GET1^DIQ(68.2,IEN,"NAME")
+15 SET LOADWORK=$TRANSLATE(LOADWORK," ","@")
+16 WRITE !,?5,$TRANSLATE($$CJ^XLFSTR("@LOAD/WORK@LIST:@"_LOADWORK_"@["_IEN_"]@",66)," @","= "),!
+17 WRITE ?9
+18 SET UID="AAA"
SET UIDCNT=0
+19 FOR
SET UID=$ORDER(^LAH(IEN,1,"U",UID),-1)
IF UID<1!(UIDCNT>19)
QUIT
Begin DoDot:2
+20 SET UIDPTR=+$ORDER(^LAH(IEN,1,"U",UID,0))
+21 IF $DATA(^LAH(IEN,1,UIDPTR))<1
QUIT
+22 ;
+23 WRITE $$LJ^XLFSTR(UID,12)
+24 IF $X>64
WRITE !,?9
+25 SET UIDCNT=UIDCNT+1
End DoDot:2
+26 IF UIDCNT<20
WRITE !
End DoDot:1
+27 ;
+28 DO PRESSKEY^BLRGMENU(9)
+29 QUIT
+30 ;
LAHDETAC ; EP -- Accession/UID Detail Report
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$LAHDETAI()="Q"
QUIT
+4 ;
+5 QUIT
+6 ;
LAHDETAI() ; EP - Initialization
+1 QUIT ""
+2 ;
LRLLUIDS ; EP - Load/Work List UIDs Report
+1 NEW HEADER,IEN,LRIFN,LRLL,LRLLDESC,UID,UIDCNT,UIDPTR
+2 ;
+3 SET HEADER(1)="^LAH Global Listing"
+4 ;
+5 DO HEADERDT^BLRGMENU
+6 DO ^XBFMK
+7 SET DIR(0)="PO^68.2:AE"
+8 DO ^DIR
+9 IF +$GET(DIRUT)
Begin DoDot:1
+10 WRITE !!,?4,"Invalid/No Entry. Routine Ends."
+11 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+12 ;
+13 SET LRLL=+Y
+14 SET LRLLDESC=$PIECE(Y,"^",2)
+15 ;
+16 SET HEADER(2)=LRLLDESC_" ["_LRLL_"] LOAD/WORK LIST"
+17 SET HEADER(3)=$$CJ^XLFSTR("UIDs Report",IOM)
+18 SET HEADER(4)=" "
+19 SET HEADER(5)="IEN"
+20 SET $EXTRACT(HEADER(5),10)="UID"
+21 SET $EXTRACT(HEADER(5),25)="Accession #"
+22 SET $EXTRACT(HEADER(5),40)="^LAH(LRLL,1,LRIFN,0)"
+23 ;
+24 DO HEADERDT^BLRGMENU
+25 ;
+26 SET UID=""
SET UIDCNT=0
+27 FOR
SET UID=$ORDER(^LAH(LRLL,1,"U",UID))
IF UID<1
QUIT
Begin DoDot:1
+28 SET LRIFN=+$ORDER(^LAH(LRLL,1,"U",UID,0))
+29 IF '$DATA(^LAH(LRLL,1,LRIFN,0))#2
QUIT
+30 ;
+31 WRITE LRIFN
+32 WRITE ?9,UID
+33 WRITE ?24,$$GETLRAS(UID)
+34 WRITE ?39,$EXTRACT($GET(^LAH(LRLL,1,LRIFN,0)),1,40)
+35 WRITE !
+36 SET UIDCNT=UIDCNT+1
End DoDot:1
+37 ;
+38 DO PRESSKEY^BLRGMENU(9)
+39 QUIT
+40 ;
GETLRAS(UID) ; EP - Get the Accession # from the UID
+1 NEW X,LRAA,LRAD,LRAN
+2 ;
+3 SET X=$QUERY(^LRO(68,"C",UID,0))
+4 SET LRAA=+$QSUBSCRIPT(X,4)
SET LRAD=+$QSUBSCRIPT(X,5)
SET LRAN=+$QSUBSCRIPT(X,6)
+5 SET LRAS=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+6 QUIT LRAS
+7 ;
DUPCINDX ; EP - Duplicate 'C' Index Entries
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVR
+4 IF $$GETLOADW()="Q"
QUIT
+5 ;
+6 IF $$DUPCNDXI()="Q"
QUIT
+7 ;
+8 FOR
SET NUM=$ORDER(^LAH(LRLL,1,"C",NUM))
IF NUM=""!(QFLG="Q")
QUIT
Begin DoDot:1
+9 SET CNTNUM=CNTNUM+1
+10 SET IEN=0
+11 KILL IENCNT
+12 FOR
SET IEN=$ORDER(^LAH(LRLL,1,"C",NUM,IEN))
IF IEN<1!(QFLG="Q")
QUIT
Begin DoDot:2
+13 SET IENCNT=1+$GET(IENCNT)
+14 SET IENCNT(IENCNT)=IEN
End DoDot:2
+15 IF IENCNT>1
DO DUPCNDXL
End DoDot:1
+16 ;
+17 IF CNT<1
WRITE !!,?4,"Number of entries for ",$GET(HEADER(1))," examined = ",CNTNUM
+18 DO PRESSKEY^BLRGMENU(9)
+19 QUIT
+20 ;
SETBLRVR(TWO) ; EP - Set the BLRVERN variable(s)
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 IF $LENGTH($GET(TWO))
SET BLRVERN2=TWO
+3 QUIT
+4 ;
GETLOADW() ; EP - Get the LOAD/WORK LIST
+1 NEW HEADER
+2 SET HEADER(1)="LOAD/WORK LIST"
+3 DO HEADERDT^BLRGMENU
+4 ;
+5 DO ^XBFMK
+6 SET DIR(0)="PO^68.2:AE"
+7 DO ^DIR
+8 IF +$GET(DIRUT)
Begin DoDot:1
+9 WRITE !!,?4,"Invalid/No Entry. Routine Ends."
+10 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT "Q"
+11 ;
+12 SET LRLL=+Y
+13 SET LRLLDESC=$PIECE(Y,"^",2)
+14 QUIT "OK"
+15 ;
DUPCNDXI() ; EP - Initialization
+1 SET HEADER(1)=LRLLDESC_" ["_LRLL_"] LOAD/WORK LIST"
+2 SET HEADER(2)="Duplicate Counts"
+3 SET HEADER(3)=" "
+4 SET $EXTRACT(HEADER(4),5)="NUM"
+5 SET $EXTRACT(HEADER(4),20)="CNT"
+6 SET $EXTRACT(HEADER(4),30)="IEN"
+7 SET $EXTRACT(HEADER(4),40)="UID"
+8 SET $EXTRACT(HEADER(4),55)="IHSSPM"
+9 ;
+10 SET MAXLINES=IOSL-4
+11 SET LINES=MAXLINES+10
+12 SET (CNT,CNTNUM,NUM,PG)=0
+13 SET (HDRONE,QFLG)="NO"
+14 QUIT "OK"
+15 ;
DUPCNDXL ; EP - Line of Data
+1 SET CNT2=0
+2 FOR
SET CNT2=$ORDER(IENCNT(CNT2))
IF CNT2<1!(QFLG="Q")
QUIT
Begin DoDot:1
+3 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,"NO")
IF QFLG="Q"
QUIT
+4 SET IEN2=$GET(IENCNT(CNT2))
+5 WRITE ?4,NUM
+6 WRITE ?19,CNT2
+7 WRITE ?29,IEN2
+8 ; UID
WRITE ?39,$GET(^LAH(LRLL,1,IEN2,.3))
+9 WRITE ?54,$EXTRACT($GET(^LAH(LRLL,1,IEN2,"IHSSPM")),1,25)
+10 WRITE !
+11 SET LINES=LINES+1
+12 SET CNT=CNT+1
End DoDot:1
+13 QUIT
