- 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 Feb 18, 2025@23:43:54 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 ;