LRMLRIV ;BPFO/DTG - FILE 60 TEST-SPECIMENS WITH INACTIVE VUIDS REPORT ;02/10/2016
;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
;
; From Option LR NDS TESTS W/INACTIVE VUIDS
;
EN ;entry point
N DA,DIE,DR,A,LD,LT,B,PS,PDT,LDT,DIDEL,LRSITE,LRFDAT,LRTDAT,LRFD,LRDTA,C,D,E,K,PAGE,LRTST
N LRTSTN,LRTE,X,FO,FN,CRT,LR1,PGHD,QUIT,LRDT,ULINE,XDD,Y,LRROOT,LRROOTA,LRNTI,AR,LXB,LXA
N AA,DIC,DIQ,FF,HD,I,KA,LRNT,LRTC,LSITE,POP
S U="^" I $G(DT)="" S DT=$$DT^XLFDT
S B=$$SITE^VASITE,B=$P(B,U,1) I 'B S LRSITE="Not specified" G ST ; not set up
S PS=$O(^LAB(66.4,"B",B,0)) I PS="" S LRSITE="Not specified" G ST ; 66.4 not set up
S A=$$GET1^DIQ(66.4,PS_",",.01,"I"),LRSITE=$$KSP^XUPARAM("WHERE")
I LRSITE="" S LRSITE="Not specified"
ST ;
K EDPRT,ULINE S XDD=^DD("DD"),$P(ULINE,"_",79)="_" K AUTO
D HOME^%ZIS S FF=IOF,HD="Lab NDS File 60 Tests/Specimens With Inactive MLTF Vuids Report" W @IOF,!?(IOM-$L(HD)\2),HD,!!!
S Y=DT X XDD S LRDT(0)=Y,PGHD="Lab NDS File 60 Tests/Specimens With Inactive MLTF Vuids Report"
S LRFD=$$NOW^XLFDT
DEVICE S %ZIS="Q",%ZIS("A")="Output device: " D ^%ZIS
I POP D HOME^ZIS W !,*7,"No Device Selected" G DONE
I $D(IO("Q"))!(IOT="HFS") N ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTIO,ZTSAVE S ZTDTH=$$NOW^XLFDT,ZTRTN="BK^LRMLRCP",ZTIO=ION,ZTDESC="Lab NTRT Edit Items Report" D D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! G DO
. F I="D*","XDD","ULINE","HD","FF","PGHD","LRSITE","LRFDAT","LRTDAT","LRFD" S ZTSAVE(I)=""
. ; I IOT="HFS" S:$G(IO("HFSIO"))="" IO("HFSIO")=IO
G PRT
;
;
DO K ZTSK,ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTIO,ZTSAVE
G DONE
;
DONE ; exit
K DA,DIE,DR,A,LD,LT,B,PS,PDT,LDT,DIDEL,LRSITE,LRFDAT,LRTDAT,LRFD,LRDTA,C,D,E,K,PAGE,LRTST
K LRTSTN,LRTE,X,FO,FN,CRT,LR1,PGHD,QUIT,LRDT,ULINE,XDD,Y,LRROOT,LRROOTA,LRNTI,AR,LXB,LXA
K AA,DIC,DIQ,FF,HD,I,KA,LRNT,LRTC,LSITE,POP
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
BK ;entry if queued
PRT ; print report
D GET664
S (QUIT,PAGE)=0,CRT=$S($E(IOST,1,2)="C-":1,1:0),(LRTST,LRTE,LRTSTN)=""
I CRT,PAGE=0 W @IOF
S PAGE=PAGE+1 D HEADER
S LRROOT="^LAB(60,""B"")",LRROOTA="^LAB(60,""B"""
PL ; Step down the B X-ref - exclude synomyms
S LRROOT=$Q(@LRROOT) I $E(LRROOT,1,$L(LRROOTA))'=LRROOTA G PDONE
I $G(@LRROOT)=1 G PL
S LRTST=$QS(LRROOT,4)
;
D GET60T
; check test is valid for NTRT
S AA=$G(LXA(4,"I"))
S LRTSTN=$G(LXA(.01,"I"))
;
S LRTC=$G(LXA(131,"I")) I LRTC'="" S LRTC=$$FMTE^XLFDT(LRTC,9)
; check test subscript is valid for NTRT
S LRTE=0,LR1=0
PLE S LRTE=$O(^LAB(60,LRTST,1,LRTE)) I 'LRTE G PL
S B=+LRTE_","_(+LRTST)
K LRDTA,C,LRER D GETS^DIQ(60.01,B,"**","IE","C","LRER")
I $G(LRER("DIERR"))'="" G PLE
M LRDTA=C("60.01",B_",") K C
S K=$G(LRDTA(30,"I")) I 'K G PLE
S KA=$$SCREEN^XTID(66.3,"",(+K_",")) I 'KA G PLE
I LR1=0 W !,LRTSTN," [",LRTST,"]"
S LR1=1
; specimen name if one
S D=$G(LRDTA(.01,"E")) S:D'="" D=$E(D,1,30)
; inactive flag
S C=$$GET1^DIQ(66.3,K_",",.01)
; exception flag
S E=$G(LRDTA(34,"I")) I E="" S E="N"
W !,?2,D," [",LRTE,"]",?42,$E(C,1,30)," [",K,"]"
;
I CRT,($Y>(IOSL-4)) D I QUIT G PDONE
.D PAUSE
.Q:QUIT
.W @IOF
.D HEADER
E I ('CRT),($Y>(IOSL-2)) D
.W @IOF
.D HEADER
;
G PLE
;
PDONE ; print done
W !!,?29,$S(QUIT'=1:"--- Report Finished ---",1:"--- Report Aborted ---") G DONE
;
Q:QUIT
N LINE
I $Y>1 W @IOF
W !,?11,HD
W !,?27,"Date Printed: "_$$FMTE^XLFDT(DT),?70,"Page ",PAGE,!
S PAGE=PAGE+1
;
W !,?2,"Specimen",?42,"MLTF"
W !,ULINE
I PAGE>2 D ;<
. S B=$O(^LAB(60,LRTST,1,LRTE)) I 'B Q
. W !,LRTSTN," [",LRTST,"]"
Q
;
PAUSE N DIR,DIRUT,X,Y
F Q:$Y>(IOSL-3) W !
S DIR(0)="E" D ^DIR
I ('(+Y))!$D(DIRUT) S QUIT=1
Q
;
GET664 ; get file 66.4 info
S LSITE=$$SITE^VASITE,LSITE=$P(LSITE,U,1)
S LRNT=$O(^LAB(66.4,"B",LSITE,0))
D GETS^DIQ(66.4,LRNT_",","**","IE","AR")
M LRNTI=AR("66.4",LRNT_",") K AR
Q
;
GET60T ; get top of file 60 test info
S DA=LRTST,DIQ="LXB",DIQ(0)="IE",DIC=60,DR=".01;4;64.1;5;13;131;132;133" D EN^DIQ1
K LXA M LXA=LXB(60,DA) K LXB
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMLRIV 4084 printed Dec 13, 2024@02:18:02 Page 2
LRMLRIV ;BPFO/DTG - FILE 60 TEST-SPECIMENS WITH INACTIVE VUIDS REPORT ;02/10/2016
+1 ;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
+2 ;
+3 ; From Option LR NDS TESTS W/INACTIVE VUIDS
+4 ;
EN ;entry point
+1 NEW DA,DIE,DR,A,LD,LT,B,PS,PDT,LDT,DIDEL,LRSITE,LRFDAT,LRTDAT,LRFD,LRDTA,C,D,E,K,PAGE,LRTST
+2 NEW LRTSTN,LRTE,X,FO,FN,CRT,LR1,PGHD,QUIT,LRDT,ULINE,XDD,Y,LRROOT,LRROOTA,LRNTI,AR,LXB,LXA
+3 NEW AA,DIC,DIQ,FF,HD,I,KA,LRNT,LRTC,LSITE,POP
+4 SET U="^"
IF $GET(DT)=""
SET DT=$$DT^XLFDT
+5 ; not set up
SET B=$$SITE^VASITE
SET B=$PIECE(B,U,1)
IF 'B
SET LRSITE="Not specified"
GOTO ST
+6 ; 66.4 not set up
SET PS=$ORDER(^LAB(66.4,"B",B,0))
IF PS=""
SET LRSITE="Not specified"
GOTO ST
+7 SET A=$$GET1^DIQ(66.4,PS_",",.01,"I")
SET LRSITE=$$KSP^XUPARAM("WHERE")
+8 IF LRSITE=""
SET LRSITE="Not specified"
ST ;
+1 KILL EDPRT,ULINE
SET XDD=^DD("DD")
SET $PIECE(ULINE,"_",79)="_"
KILL AUTO
+2 DO HOME^%ZIS
SET FF=IOF
SET HD="Lab NDS File 60 Tests/Specimens With Inactive MLTF Vuids Report"
WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!!
+3 SET Y=DT
XECUTE XDD
SET LRDT(0)=Y
SET PGHD="Lab NDS File 60 Tests/Specimens With Inactive MLTF Vuids Report"
+4 SET LRFD=$$NOW^XLFDT
DEVICE SET %ZIS="Q"
SET %ZIS("A")="Output device: "
DO ^%ZIS
+1 IF POP
DO HOME^ZIS
WRITE !,*7,"No Device Selected"
GOTO DONE
+2 IF $DATA(IO("Q"))!(IOT="HFS")
NEW ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTIO,ZTSAVE
SET ZTDTH=$$NOW^XLFDT
SET ZTRTN="BK^LRMLRCP"
SET ZTIO=ION
SET ZTDESC="Lab NTRT Edit Items Report"
Begin DoDot:1
+3 FOR I="D*","XDD","ULINE","HD","FF","PGHD","LRSITE","LRFDAT","LRTDAT","LRFD"
SET ZTSAVE(I)=""
+4 ; I IOT="HFS" S:$G(IO("HFSIO"))="" IO("HFSIO")=IO
End DoDot:1
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued",!!
GOTO DO
+5 GOTO PRT
+6 ;
+7 ;
DO KILL ZTSK,ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTIO,ZTSAVE
+1 GOTO DONE
+2 ;
DONE ; exit
+1 KILL DA,DIE,DR,A,LD,LT,B,PS,PDT,LDT,DIDEL,LRSITE,LRFDAT,LRTDAT,LRFD,LRDTA,C,D,E,K,PAGE,LRTST
+2 KILL LRTSTN,LRTE,X,FO,FN,CRT,LR1,PGHD,QUIT,LRDT,ULINE,XDD,Y,LRROOT,LRROOTA,LRNTI,AR,LXB,LXA
+3 KILL AA,DIC,DIQ,FF,HD,I,KA,LRNT,LRTC,LSITE,POP
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
+6 ;
BK ;entry if queued
PRT ; print report
+1 DO GET664
+2 SET (QUIT,PAGE)=0
SET CRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
SET (LRTST,LRTE,LRTSTN)=""
+3 IF CRT
IF PAGE=0
WRITE @IOF
+4 SET PAGE=PAGE+1
DO HEADER
+5 SET LRROOT="^LAB(60,""B"")"
SET LRROOTA="^LAB(60,""B"""
PL ; Step down the B X-ref - exclude synomyms
+1 SET LRROOT=$QUERY(@LRROOT)
IF $EXTRACT(LRROOT,1,$LENGTH(LRROOTA))'=LRROOTA
GOTO PDONE
+2 IF $GET(@LRROOT)=1
GOTO PL
+3 SET LRTST=$QSUBSCRIPT(LRROOT,4)
+4 ;
+5 DO GET60T
+6 ; check test is valid for NTRT
+7 SET AA=$GET(LXA(4,"I"))
+8 SET LRTSTN=$GET(LXA(.01,"I"))
+9 ;
+10 SET LRTC=$GET(LXA(131,"I"))
IF LRTC'=""
SET LRTC=$$FMTE^XLFDT(LRTC,9)
+11 ; check test subscript is valid for NTRT
+12 SET LRTE=0
SET LR1=0
PLE SET LRTE=$ORDER(^LAB(60,LRTST,1,LRTE))
IF 'LRTE
GOTO PL
+1 SET B=+LRTE_","_(+LRTST)
+2 KILL LRDTA,C,LRER
DO GETS^DIQ(60.01,B,"**","IE","C","LRER")
+3 IF $GET(LRER("DIERR"))'=""
GOTO PLE
+4 MERGE LRDTA=C("60.01",B_",")
KILL C
+5 SET K=$GET(LRDTA(30,"I"))
IF 'K
GOTO PLE
+6 SET KA=$$SCREEN^XTID(66.3,"",(+K_","))
IF 'KA
GOTO PLE
+7 IF LR1=0
WRITE !,LRTSTN," [",LRTST,"]"
+8 SET LR1=1
+9 ; specimen name if one
+10 SET D=$GET(LRDTA(.01,"E"))
if D'=""
SET D=$EXTRACT(D,1,30)
+11 ; inactive flag
+12 SET C=$$GET1^DIQ(66.3,K_",",.01)
+13 ; exception flag
+14 SET E=$GET(LRDTA(34,"I"))
IF E=""
SET E="N"
+15 WRITE !,?2,D," [",LRTE,"]",?42,$EXTRACT(C,1,30)," [",K,"]"
+16 ;
+17 IF CRT
IF ($Y>(IOSL-4))
Begin DoDot:1
+18 DO PAUSE
+19 if QUIT
QUIT
+20 WRITE @IOF
+21 DO HEADER
End DoDot:1
IF QUIT
GOTO PDONE
+22 IF '$TEST
IF ('CRT)
IF ($Y>(IOSL-2))
Begin DoDot:1
+23 WRITE @IOF
+24 DO HEADER
End DoDot:1
+25 ;
+26 GOTO PLE
+27 ;
PDONE ; print done
+1 WRITE !!,?29,$SELECT(QUIT'=1:"--- Report Finished ---",1:"--- Report Aborted ---")
GOTO DONE
+2 ;
+1 if QUIT
QUIT
+2 NEW LINE
+3 IF $Y>1
WRITE @IOF
+4 WRITE !,?11,HD
+5 WRITE !,?27,"Date Printed: "_$$FMTE^XLFDT(DT),?70,"Page ",PAGE,!
+6 SET PAGE=PAGE+1
+7 ;
+8 WRITE !,?2,"Specimen",?42,"MLTF"
+9 WRITE !,ULINE
+10 ;<
IF PAGE>2
Begin DoDot:1
+11 SET B=$ORDER(^LAB(60,LRTST,1,LRTE))
IF 'B
QUIT
+12 WRITE !,LRTSTN," [",LRTST,"]"
End DoDot:1
+13 QUIT
+14 ;
PAUSE NEW DIR,DIRUT,X,Y
+1 FOR
if $Y>(IOSL-3)
QUIT
WRITE !
+2 SET DIR(0)="E"
DO ^DIR
+3 IF ('(+Y))!$DATA(DIRUT)
SET QUIT=1
+4 QUIT
+5 ;
GET664 ; get file 66.4 info
+1 SET LSITE=$$SITE^VASITE
SET LSITE=$PIECE(LSITE,U,1)
+2 SET LRNT=$ORDER(^LAB(66.4,"B",LSITE,0))
+3 DO GETS^DIQ(66.4,LRNT_",","**","IE","AR")
+4 MERGE LRNTI=AR("66.4",LRNT_",")
KILL AR
+5 QUIT
+6 ;
GET60T ; get top of file 60 test info
+1 SET DA=LRTST
SET DIQ="LXB"
SET DIQ(0)="IE"
SET DIC=60
SET DR=".01;4;64.1;5;13;131;132;133"
DO EN^DIQ1
+2 KILL LXA
MERGE LXA=LXB(60,DA)
KILL LXB
+3 QUIT
+4 ;
