LRMLREI ;BPFO/DTG - EDITED ITEMS REPORT PGM FOR NTRT PROCESS ;02/10/2016
;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
;
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,POP
N DIROUT,DTOUT,FF,HD,I
S U="^" I $G(DT)="" S DT=$$DT^XLFDT
S B=$$SITE^VASITE,B=$P(B,U,1) I 'B D I B="" S LRSITE="Not specified" G ST ; not set up
. S B=$$GET1^DIQ(8989.3,"1,",217,"I")
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 NTRT File 60 Audited items Report" W @IOF,!?(IOM-$L(HD)\2),HD,!!!
S Y=DT X XDD S LRDT(0)=Y,PGHD="Lab NTRT File 60 Audited items Report"
S LRFD=$$NOW^XLFDT
;
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^LRMLREI",ZTIO=ION,ZTDESC="Lab NTRT Audit 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)=""
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,POP
K DIROUT,DTOUT,FF,HD,I
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
LRS(A) ; get edit type/field
N LRSTRING
I A="" Q ""
S LRSTRING=$S(A="M":"MLTF VUID",A="C":"CREATION DATE",A="T":"TST INACT DT",A="R":"SPEC INACT DT",A="E":"NTRT EXPT FLG",A="Y":"TEST TYPE",A="S":"SPEC CREATE DT",1:"")
Q LRSTRING
;
BK ;entry if queued
PRT ; print report
S (QUIT,PAGE)=0,CRT=$S($E(IOST,1,2)="C-":1,1:0),LRTSTN=""
I CRT,PAGE=0 W @IOF
S PAGE=PAGE+1 D HEADER
S LRROOT="^LAB(60,""B"")",LRROOTA="^LAB(60,""B"""
;S LRTST=0
PL ;S LRTST=$O(^LAB(60,LRTST)) I 'LRTST G PDONE
; 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
I $G(@LRROOT) G PL
S LRTST=$QS(LRROOT,4)
;
S LRTSTN=$$GET1^DIQ(60,LRTST_",",.01,"I"),LRTSTN=$E(LRTSTN,1,40)
S LRTE=0,LR1=0
PLE S LRTE=$O(^LAB(60,LRTST,15,LRTE)) I 'LRTE G PL
S B=+LRTE_","_(+LRTST)
K LRDTA,C,LRER D GETS^DIQ(60.28,B,"**","IE","C","LRER")
I $G(LRER("DIERR"))'="" G PLE
M LRDTA=C("60.28",B_",") K C
; edit date
S C=$G(LRDTA(.01,"I")) I C="" G PLE
S D=C\1 I D<LRFDAT G PLE
I D>LRTDAT G PLE
S C=$$FMTE^XLFDT(C,"7M")
I LR1=0 W !,"TEST: ",LRTSTN
S LR1=1
; specimen name if one
S D=$G(LRDTA(.06,"I")) I D'="" S X=$$GET1^DIQ(60.01,D_","_LRTST,.01,"E"),X=$E(X,1,30) W !,?10,"Specimen: ",X
; edit field
S K=$G(LRDTA(.03,"I")) I K'="" S B=$$LRS(K)
; user who did transaction
S E=$G(LRDTA(.02,"E")) I E'="" S E=$E(E,1,14)
; test type
S FO=$G(LRDTA(.04,"I")) I FO'="" D ;<
. I K="M" S FO=$$GET1^DIQ(66.3,FO_",",.01),FO=$E(FO,1,15) Q
. I K="C"!(K="T")!(K="R")!(K="S") S FO=FO\1 S:FO<2 FO="" I FO>1 S FO=$$FMTE^XLFDT(FO,9)
S FN=$G(LRDTA(.05,"I")) I FN'="" D ;<
. I K="M" S FN=$$GET1^DIQ(66.3,FN_",",.01),FN=$E(FN,1,15) Q
. I K="C"!(K="T")!(K="R")!(K="S") S FN=FN\1 S:FN<2 FN="" I FN>1 S FN=$$FMTE^XLFDT(FN,9)
W !,?1,C,?18,B,?32,E,?48,FO,?65,FN
;
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 !,?22,HD
W ?70,"Page ",PAGE,!,?27,"Date Printed: "_$$FMTE^XLFDT(DT),!
S PAGE=PAGE+1
;
W !,?1,"Date",?18,"Edit Field",?32,"User",?48,"Old Value",?65,"New Value"
W !,ULINE
I PAGE>2 W !,"TEST: ",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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMLREI 4575 printed Dec 13, 2024@02:18:01 Page 2
LRMLREI ;BPFO/DTG - EDITED ITEMS REPORT PGM FOR NTRT PROCESS ;02/10/2016
+1 ;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
+2 ;
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,POP
+3 NEW DIROUT,DTOUT,FF,HD,I
+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
Begin DoDot:1
+6 SET B=$$GET1^DIQ(8989.3,"1,",217,"I")
End DoDot:1
IF B=""
SET LRSITE="Not specified"
GOTO ST
+7 ; 66.4 not set up
SET PS=$ORDER(^LAB(66.4,"B",B,0))
IF PS=""
SET LRSITE="Not specified"
GOTO ST
+8 SET A=$$GET1^DIQ(66.4,PS_",",.01,"I")
SET LRSITE=$$KSP^XUPARAM("WHERE")
+9 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 NTRT File 60 Audited items Report"
WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!!
+3 SET Y=DT
XECUTE XDD
SET LRDT(0)=Y
SET PGHD="Lab NTRT File 60 Audited items Report"
+4 SET LRFD=$$NOW^XLFDT
+5 ;
+6 SET DIR(0)="D^3160101:"_LRFD_":EX"
SET DIR("A")="Enter From Date"
DO ^DIR
KILL DIR
+7 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIRUT))!($DATA(DIROUT))
WRITE !,*7,"Starting Date Not Selected"
GOTO DONE
+8 SET LRFDAT=Y\1
+9 SET DIR(0)="D^"_LRFDAT_":"_LRFD_":EX"
SET DIR("A")="Enter To Date"
DO ^DIR
KILL DIR
+10 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIRUT))!($DATA(DIROUT))
WRITE !,*7,"Ending Date Not Selected"
GOTO DONE
+11 SET 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^LRMLREI"
SET ZTIO=ION
SET ZTDESC="Lab NTRT Audit Items Report"
Begin DoDot:1
+3 FOR I="D*","XDD","ULINE","HD","FF","PGHD","LRSITE","LRFDAT","LRTDAT","LRFD"
SET ZTSAVE(I)=""
End DoDot:1
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued",!!
GOTO DO
+4 GOTO PRT
+5 ;
+6 ;
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,POP
+3 KILL DIROUT,DTOUT,FF,HD,I
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
+6 ;
LRS(A) ; get edit type/field
+1 NEW LRSTRING
+2 IF A=""
QUIT ""
+3 SET LRSTRING=$SELECT(A="M":"MLTF VUID",A="C":"CREATION DATE",A="T":"TST INACT DT",A="R":"SPEC INACT DT",A="E":"NTRT EXPT FLG",A="Y":"TEST TYPE",A="S":"SPEC CREATE DT",1:"")
+4 QUIT LRSTRING
+5 ;
BK ;entry if queued
PRT ; print report
+1 SET (QUIT,PAGE)=0
SET CRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
SET LRTSTN=""
+2 IF CRT
IF PAGE=0
WRITE @IOF
+3 SET PAGE=PAGE+1
DO HEADER
+4 SET LRROOT="^LAB(60,""B"")"
SET LRROOTA="^LAB(60,""B"""
+5 ;S LRTST=0
PL ;S LRTST=$O(^LAB(60,LRTST)) I 'LRTST G PDONE
+1 ; Step down the B X-ref - exclude synomyms
+2 SET LRROOT=$QUERY(@LRROOT)
IF $EXTRACT(LRROOT,1,$LENGTH(LRROOTA))'=LRROOTA
GOTO PDONE
+3 IF $GET(@LRROOT)=1
GOTO PL
+4 IF $GET(@LRROOT)
GOTO PL
+5 SET LRTST=$QSUBSCRIPT(LRROOT,4)
+6 ;
+7 SET LRTSTN=$$GET1^DIQ(60,LRTST_",",.01,"I")
SET LRTSTN=$EXTRACT(LRTSTN,1,40)
+8 SET LRTE=0
SET LR1=0
PLE SET LRTE=$ORDER(^LAB(60,LRTST,15,LRTE))
IF 'LRTE
GOTO PL
+1 SET B=+LRTE_","_(+LRTST)
+2 KILL LRDTA,C,LRER
DO GETS^DIQ(60.28,B,"**","IE","C","LRER")
+3 IF $GET(LRER("DIERR"))'=""
GOTO PLE
+4 MERGE LRDTA=C("60.28",B_",")
KILL C
+5 ; edit date
+6 SET C=$GET(LRDTA(.01,"I"))
IF C=""
GOTO PLE
+7 SET D=C\1
IF D<LRFDAT
GOTO PLE
+8 IF D>LRTDAT
GOTO PLE
+9 SET C=$$FMTE^XLFDT(C,"7M")
+10 IF LR1=0
WRITE !,"TEST: ",LRTSTN
+11 SET LR1=1
+12 ; specimen name if one
+13 SET D=$GET(LRDTA(.06,"I"))
IF D'=""
SET X=$$GET1^DIQ(60.01,D_","_LRTST,.01,"E")
SET X=$EXTRACT(X,1,30)
WRITE !,?10,"Specimen: ",X
+14 ; edit field
+15 SET K=$GET(LRDTA(.03,"I"))
IF K'=""
SET B=$$LRS(K)
+16 ; user who did transaction
+17 SET E=$GET(LRDTA(.02,"E"))
IF E'=""
SET E=$EXTRACT(E,1,14)
+18 ; test type
+19 ;<
SET FO=$GET(LRDTA(.04,"I"))
IF FO'=""
Begin DoDot:1
+20 IF K="M"
SET FO=$$GET1^DIQ(66.3,FO_",",.01)
SET FO=$EXTRACT(FO,1,15)
QUIT
+21 IF K="C"!(K="T")!(K="R")!(K="S")
SET FO=FO\1
if FO<2
SET FO=""
IF FO>1
SET FO=$$FMTE^XLFDT(FO,9)
End DoDot:1
+22 ;<
SET FN=$GET(LRDTA(.05,"I"))
IF FN'=""
Begin DoDot:1
+23 IF K="M"
SET FN=$$GET1^DIQ(66.3,FN_",",.01)
SET FN=$EXTRACT(FN,1,15)
QUIT
+24 IF K="C"!(K="T")!(K="R")!(K="S")
SET FN=FN\1
if FN<2
SET FN=""
IF FN>1
SET FN=$$FMTE^XLFDT(FN,9)
End DoDot:1
+25 WRITE !,?1,C,?18,B,?32,E,?48,FO,?65,FN
+26 ;
+27 IF CRT
IF ($Y>(IOSL-4))
Begin DoDot:1
+28 DO PAUSE
+29 if QUIT
QUIT
+30 WRITE @IOF
+31 DO HEADER
End DoDot:1
IF QUIT
GOTO PDONE
+32 IF '$TEST
IF ('CRT)
IF ($Y>(IOSL-2))
Begin DoDot:1
+33 WRITE @IOF
+34 DO HEADER
End DoDot:1
+35 ;
+36 GOTO PLE
+37 ;
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 !,?22,HD
+5 WRITE ?70,"Page ",PAGE,!,?27,"Date Printed: "_$$FMTE^XLFDT(DT),!
+6 SET PAGE=PAGE+1
+7 ;
+8 WRITE !,?1,"Date",?18,"Edit Field",?32,"User",?48,"Old Value",?65,"New Value"
+9 WRITE !,ULINE
+10 IF PAGE>2
WRITE !,"TEST: ",LRTSTN
+11 QUIT
+12 ;
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
