Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRMLRCP

LRMLRCP.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; from option LR NDS SPECIMENS W/O VUIDS
  1. ;
  1. ; print tests and specimens that do not have a create date
  1. EN ;entry point
  1. N DA,DIE,DR,A,LD,LT,B,PS,PDT,LDT,DIDEL,LRSITE,LRFDAT,LRTDAT,LRFD,LRDTA,C,D,E,K,PAGE,LRTST
  1. N LRTSTN,LRTE,X,FO,FN,CRT,LR1,PGHD,QUIT,LRDT,ULINE,XDD,Y,LRROOT,LRROOTA,LRNTI,AR,LXB,LXA
  1. N AA,DIC,DDIQ,FF,HD,I,LRNT,LRTC,LSITE,POP,DIQ
  1. S U="^" I $G(DT)="" S DT=$$DT^XLFDT
  1. S B=$$SITE^VASITE,B=$P(B,U,1) I 'B S LRSITE="Not specified" G ST ; not set up
  1. S PS=$O(^LAB(66.4,"B",B,0)) I PS="" S LRSITE="Not specified" G ST ; 66.4 not set up
  1. S A=$$GET1^DIQ(66.4,PS_",",.01,"I"),LRSITE=$$KSP^XUPARAM("WHERE")
  1. I LRSITE="" S LRSITE="Not specified"
  1. ST ;
  1. K EDPRT,ULINE S XDD=^DD("DD"),$P(ULINE,"_",79)="_" K AUTO
  1. D HOME^%ZIS S FF=IOF,HD="Lab NDS File 60 Tests/Specimens Without MLTF Vuids Report" W @IOF,!?(IOM-$L(HD)\2),HD,!!!
  1. S Y=DT X XDD S LRDT(0)=Y,PGHD="Lab NDS File 60 Tests/Specimens Without MLTF Vuids Report"
  1. S LRFD=$$NOW^XLFDT
  1. ; skip the date questions
  1. ; S DIR(0)="D^3160101:"_LRFD_":EX",DIR("A")="Enter From Date" D ^DIR K DIR
  1. ; I $D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) W !,*7,"Starting Date Not Selected" G DONE
  1. ; S LRFDAT=Y\1
  1. ; S DIR(0)="D^"_LRFDAT_":"_LRFD_":EX",DIR("A")="Enter To Date" D ^DIR K DIR
  1. ; I $D(DUOUT)!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) W !,*7,"Ending Date Not Selected" G DONE
  1. ; S LRTDAT=Y
  1. ;
  1. DEVICE S %ZIS="Q",%ZIS("A")="Output device: " D ^%ZIS
  1. I POP D HOME^ZIS W !,*7,"No Device Selected" G DONE
  1. 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
  1. . F I="D*","XDD","ULINE","HD","FF","PGHD","LRSITE","LRFDAT","LRTDAT","LRFD" S ZTSAVE(I)=""
  1. . ; I IOT="HFS" S:$G(IO("HFSIO"))="" IO("HFSIO")=IO
  1. G PRT
  1. ;
  1. ;
  1. DO K ZTSK,ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTIO,ZTSAVE
  1. G DONE
  1. ;
  1. DONE ; exit
  1. K DA,DIE,DR,A,LD,LT,B,PS,PDT,LDT,DIDEL,LRSITE,LRFDAT,LRTDAT,LRFD,LRDTA,C,D,E,K,PAGE,LRTST
  1. K LRTSTN,LRTE,X,FO,FN,CRT,LR1,PGHD,QUIT,LRDT,ULINE,XDD,Y,LRROOT,LRROOTA,LRNTI,AR,LXB,LXA
  1. K AA,DIC,DDIQ,FF,HD,I,LRNT,LRTC,LSITE,POP,DIQ
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. Q
  1. ;
  1. BK ;entry if queued
  1. PRT ; print report
  1. D GET664
  1. S (QUIT,PAGE)=0,CRT=$S($E(IOST,1,2)="C-":1,1:0),(LRTST,LRTE,LRTSTN)=""
  1. I CRT,PAGE=0 W @IOF
  1. S PAGE=PAGE+1 D HEADER
  1. S LRROOT="^LAB(60,""B"")",LRROOTA="^LAB(60,""B"""
  1. PL ; Step down the B X-ref - exclude synomyms
  1. S LRROOT=$Q(@LRROOT) I $E(LRROOT,1,$L(LRROOTA))'=LRROOTA G PDONE
  1. I $G(@LRROOT)=1 G PL
  1. S LRTST=$QS(LRROOT,4)
  1. ;
  1. D GET60T
  1. ; check test is valid for NTRT
  1. S AA=$G(LXA(4,"I"))
  1. I AA="WK" G PL
  1. I AA="BB" G PL
  1. ;
  1. S LRTSTN=$G(LXA(.01,"I")),LRTSTN=$E(LRTSTN,1,40)
  1. ;
  1. S LRTC=$G(LXA(131,"I")) I LRTC'="" S LRTC=$$FMTE^XLFDT(LRTC,9)
  1. ; check test subscript is valid for NTRT
  1. S LRTE=0,LR1=0
  1. PLE S LRTE=$O(^LAB(60,LRTST,1,LRTE)) I 'LRTE G PL
  1. S B=+LRTE_","_(+LRTST)
  1. K LRDTA,C,LRER D GETS^DIQ(60.01,B,"**","IE","C","LRER")
  1. I $G(LRER("DIERR"))'="" G PLE
  1. M LRDTA=C("60.01",B_",") K C
  1. I $G(LRDTA(30,"I"))'="" G PLE
  1. I LR1=0 W !,LRTSTN,?42,"Create Date: ",LRTC,?67,"Inactive: " S B=$G(LXA(132,"I")) W $S(B="":"N",1:B)
  1. S LR1=1
  1. ; specimen name if one
  1. S D=$G(LRDTA(.01,"E")) S:D'="" D=$E(D,1,30)
  1. ; create date
  1. S K=$G(LRDTA(35,"I")) I K'="" S K=$$FMTE^XLFDT(K,"7")
  1. ; inactive flag
  1. S C=$G(LRDTA(32,"I")) I C="" S C="N"
  1. ; exception flag
  1. S E=$G(LRDTA(34,"I")) I E="" S E="N"
  1. W !,?2,D,?35,K,?47,C,?57,E
  1. ;
  1. I CRT,($Y>(IOSL-4)) D I QUIT G PDONE
  1. .D PAUSE
  1. .Q:QUIT
  1. .W @IOF
  1. .D HEADER
  1. E I ('CRT),($Y>(IOSL-2)) D
  1. .W @IOF
  1. .D HEADER
  1. ;
  1. G PLE
  1. ;
  1. PDONE ; print done
  1. W !!,?29,$S(QUIT'=1:"--- Report Finished ---",1:"--- Report Aborted ---") G DONE
  1. ;
  1. Q:QUIT
  1. N LINE
  1. I $Y>1 W @IOF
  1. W !,?11,HD
  1. W !,?27,"Date Printed: "_$$FMTE^XLFDT(DT),?70,"Page ",PAGE,!
  1. S PAGE=PAGE+1
  1. ;
  1. W !,?2,"Specimen",?35,"Create DT",?47,"Inactive",?57,"Exception"
  1. W !,ULINE
  1. I PAGE>2 D ;<
  1. . S B=$O(^LAB(60,LRTST,1,LRTE)) I 'B Q
  1. . W !,LRTSTN
  1. Q
  1. ;
  1. PAUSE N DIR,DIRUT,X,Y
  1. F Q:$Y>(IOSL-3) W !
  1. S DIR(0)="E" D ^DIR
  1. I ('(+Y))!$D(DIRUT) S QUIT=1
  1. Q
  1. ;
  1. GET664 ; get file 66.4 info
  1. S LSITE=$$SITE^VASITE,LSITE=$P(LSITE,U,1)
  1. S LRNT=$O(^LAB(66.4,"B",LSITE,0))
  1. D GETS^DIQ(66.4,LRNT_",","**","IE","AR")
  1. M LRNTI=AR("66.4",LRNT_",") K AR
  1. Q
  1. ;
  1. GET60T ; get top of file 60 test info
  1. S DA=LRTST,DIQ="LXB",DIQ(0)="IE",DIC=60,DR=".01;4;64.1;5;13;131;132;133" D EN^DIQ1
  1. K LXA M LXA=LXB(60,DA) K LXB
  1. Q
  1. ;