- 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 Jan 18, 2025@03:18:43 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