- LRMLRCP ;BPFO/DTG - FILE 60 ITEMS WITHOUT MLTF REPORT PGM FOR NTRT PROCESS ;02/10/2016
- ;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
- ;
- ; from option LR NDS SPECIMENS W/O VUIDS
- ;
- ; print tests and specimens that do not have a create date
- 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,DDIQ,FF,HD,I,LRNT,LRTC,LSITE,POP,DIQ
- 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 Without 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 Without MLTF Vuids Report"
- S LRFD=$$NOW^XLFDT
- ; skip the date questions
- ; S DIR(0)="D^3160101:"_LRFD_":EX",DIR("A")="Enter From Date" D ^DIR K DIR
- ; I $D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) W !,*7,"Starting Date Not Selected" G DONE
- ; S LRFDAT=Y\1
- ; S DIR(0)="D^"_LRFDAT_":"_LRFD_":EX",DIR("A")="Enter To Date" D ^DIR K DIR
- ; I $D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) W !,*7,"Ending Date Not Selected" G DONE
- ; S LRTDAT=Y
- ;
- 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,DDIQ,FF,HD,I,LRNT,LRTC,LSITE,POP,DIQ
- 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"))
- I AA="WK" G PL
- I AA="BB" G PL
- ;
- S LRTSTN=$G(LXA(.01,"I")),LRTSTN=$E(LRTSTN,1,40)
- ;
- 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
- I $G(LRDTA(30,"I"))'="" G PLE
- I LR1=0 W !,LRTSTN,?42,"Create Date: ",LRTC,?67,"Inactive: " S B=$G(LXA(132,"I")) W $S(B="":"N",1:B)
- S LR1=1
- ; specimen name if one
- S D=$G(LRDTA(.01,"E")) S:D'="" D=$E(D,1,30)
- ; create date
- S K=$G(LRDTA(35,"I")) I K'="" S K=$$FMTE^XLFDT(K,"7")
- ; inactive flag
- S C=$G(LRDTA(32,"I")) I C="" S C="N"
- ; exception flag
- S E=$G(LRDTA(34,"I")) I E="" S E="N"
- W !,?2,D,?35,K,?47,C,?57,E
- ;
- 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",?35,"Create DT",?47,"Inactive",?57,"Exception"
- W !,ULINE
- I PAGE>2 D ;<
- . S B=$O(^LAB(60,LRTST,1,LRTE)) I 'B Q
- . W !,LRTSTN
- 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[HLRMLRCP 4699 printed Jan 18, 2025@03:18:42 Page 2
- LRMLRCP ;BPFO/DTG - FILE 60 ITEMS WITHOUT MLTF REPORT PGM FOR NTRT PROCESS ;02/10/2016
- +1 ;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
- +2 ;
- +3 ; from option LR NDS SPECIMENS W/O VUIDS
- +4 ;
- +5 ; print tests and specimens that do not have a create date
- 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,DDIQ,FF,HD,I,LRNT,LRTC,LSITE,POP,DIQ
- +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 Without 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 Without MLTF Vuids Report"
- +4 SET LRFD=$$NOW^XLFDT
- +5 ; skip the date questions
- +6 ; S DIR(0)="D^3160101:"_LRFD_":EX",DIR("A")="Enter From Date" D ^DIR K DIR
- +7 ; I $D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) W !,*7,"Starting Date Not Selected" G DONE
- +8 ; S LRFDAT=Y\1
- +9 ; S DIR(0)="D^"_LRFDAT_":"_LRFD_":EX",DIR("A")="Enter To Date" D ^DIR K DIR
- +10 ; I $D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) W !,*7,"Ending Date Not Selected" G DONE
- +11 ; S LRTDAT=Y
- +12 ;
- 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,DDIQ,FF,HD,I,LRNT,LRTC,LSITE,POP,DIQ
- +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 IF AA="WK"
- GOTO PL
- +9 IF AA="BB"
- GOTO PL
- +10 ;
- +11 SET LRTSTN=$GET(LXA(.01,"I"))
- SET LRTSTN=$EXTRACT(LRTSTN,1,40)
- +12 ;
- +13 SET LRTC=$GET(LXA(131,"I"))
- IF LRTC'=""
- SET LRTC=$$FMTE^XLFDT(LRTC,9)
- +14 ; check test subscript is valid for NTRT
- +15 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 IF $GET(LRDTA(30,"I"))'=""
- GOTO PLE
- +6 IF LR1=0
- WRITE !,LRTSTN,?42,"Create Date: ",LRTC,?67,"Inactive: "
- SET B=$GET(LXA(132,"I"))
- WRITE $SELECT(B="":"N",1:B)
- +7 SET LR1=1
- +8 ; specimen name if one
- +9 SET D=$GET(LRDTA(.01,"E"))
- if D'=""
- SET D=$EXTRACT(D,1,30)
- +10 ; create date
- +11 SET K=$GET(LRDTA(35,"I"))
- IF K'=""
- SET K=$$FMTE^XLFDT(K,"7")
- +12 ; inactive flag
- +13 SET C=$GET(LRDTA(32,"I"))
- IF C=""
- SET C="N"
- +14 ; exception flag
- +15 SET E=$GET(LRDTA(34,"I"))
- IF E=""
- SET E="N"
- +16 WRITE !,?2,D,?35,K,?47,C,?57,E
- +17 ;
- +18 IF CRT
- IF ($Y>(IOSL-4))
- Begin DoDot:1
- +19 DO PAUSE
- +20 if QUIT
- QUIT
- +21 WRITE @IOF
- +22 DO HEADER
- End DoDot:1
- IF QUIT
- GOTO PDONE
- +23 IF '$TEST
- IF ('CRT)
- IF ($Y>(IOSL-2))
- Begin DoDot:1
- +24 WRITE @IOF
- +25 DO HEADER
- End DoDot:1
- +26 ;
- +27 GOTO PLE
- +28 ;
- 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",?35,"Create DT",?47,"Inactive",?57,"Exception"
- +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
- 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 ;