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

LRMLRIV.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; From Option LR NDS TESTS W/INACTIVE VUIDS
  1. ;
  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,DIQ,FF,HD,I,KA,LRNT,LRTC,LSITE,POP
  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 With Inactive 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 With Inactive MLTF Vuids Report"
  1. S LRFD=$$NOW^XLFDT
  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,DIQ,FF,HD,I,KA,LRNT,LRTC,LSITE,POP
  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. S LRTSTN=$G(LXA(.01,"I"))
  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. S K=$G(LRDTA(30,"I")) I 'K G PLE
  1. S KA=$$SCREEN^XTID(66.3,"",(+K_",")) I 'KA G PLE
  1. I LR1=0 W !,LRTSTN," [",LRTST,"]"
  1. S LR1=1
  1. ; specimen name if one
  1. S D=$G(LRDTA(.01,"E")) S:D'="" D=$E(D,1,30)
  1. ; inactive flag
  1. S C=$$GET1^DIQ(66.3,K_",",.01)
  1. ; exception flag
  1. S E=$G(LRDTA(34,"I")) I E="" S E="N"
  1. W !,?2,D," [",LRTE,"]",?42,$E(C,1,30)," [",K,"]"
  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",?42,"MLTF"
  1. W !,ULINE
  1. I PAGE>2 D ;<
  1. . S B=$O(^LAB(60,LRTST,1,LRTE)) I 'B Q
  1. . W !,LRTSTN," [",LRTST,"]"
  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. ;