source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPV.m@ 1590

Last change on this file since 1590 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1LRAPV ;AVAMC/REG/WTY - ANAT PATH REPORTS NOT VERIFIED ;1/17/02
2 ;;5.2;LAB SERVICE;**72,201,259,317**;Sep 27, 1994
3 ;
4 ;Reference to ^DIC supported by IA #916
5 ;
6A ;Initialize some variables
7 N LRI,LRFILE,LRFILE1,LRFILE2,LRPD,LRA
8 D ^LRAP G:'$D(Y) END
9 S LR("AU1")=$S(LRSS="AU":1,1:0)
10 S:'LR("AU1") LRFILE="^LR(LRPD,LRSS,LRI",LRFILE1=LRFILE_",1.2,"
11 S:LR("AU1") LRFILE="^LR(LRPD,LRSS",LRFILE1="^LR(LRPD,84,"
12ASK ;Ask which option to run
13 W !!?3,"1) List of Unverified ",LRO(68)," Reports"
14 W !?3,"2) List of Unverified ",LRO(68)," Supplementary Reports"
15 W !?3,"3) List of ",LRO(68)," Reports Missing SNOMED Codes"
16 W !!,"Select 1,2 or 3: "
17 R X:DTIME
18 I X=""!(X[U) D END Q
19 I X'?1N!("123"'[X) D G ASK
20 .W $C(7),!!,"Enter a single numeric digit 1,2 or 3"
21 ;Give date ranges
22 S LRB=X D B^LRU
23 I Y<0 D END Q
24DEV ;Get Device Info
25 W !
26 S %ZIS="Q" D ^%ZIS
27 I POP W ! D END Q
28 I $D(IO("Q")) D Q
29 .S ZTDESC="LIST OF ACC UNVERIF,MISSING SNOMED OR CPT"
30 .S ZTSAVE("LR*")="",ZTRTN="QUE^LRAPV"
31 .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
32 .K ZTSK,IO("Q") D HOME^%ZIS
33 .D END
34QUE ;
35 U IO W:IOST["C-" @IOF
36 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
37 D XR^LRU,L^LRU,S^LRU,H S LR("F")=1
38 F S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT)!(LR("Q")) D Y
39 D END
40 Q
41Y ;Get patient info
42 S LRPD=0 F S LRPD=$O(^LR(LRXR,LRSDT,LRPD)) Q:'LRPD!(LR("Q")) D
43 .S X=^LR(LRPD,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2)
44 .S X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9)
45 .D SSN^LRU
46 .I 'LR("AU1") D I Q
47 .I LR("AU1") D SEL
48 Q
49I ;Order through the cross reference
50 S LRI=0 F S LRI=$O(^LR(LRXR,LRSDT,LRPD,LRI)) Q:'LRI!(LR("Q")) D
51 .D:$Y>(IOSL-6) H Q:LR("Q")
52 .I $P($P($G(@(LRFILE_$S('LR("AU1"):",0)",1:")"))),"^",6)," ")'=LRABV Q
53 .D SEL
54 Q
55SEL ;
56 D:LRB=1 RPT
57 D:LRB=2 SUPP
58 D:LRB=3 SNO
59 Q
60N ;
61 Q
62RPT ;Unverified reports
63 S X=$G(@(LRFILE_$S('LR("AU1"):",0)",1:")")))
64 I $L(X),'$P(X,"^",$S('LR("AU1"):11,1:15)) D
65 .S LRDATE=@(LRFILE_$S('LR("AU1"):",0)",1:")"))
66 .D W
67 Q
68SUPP ;Unverified Supplementary Reports
69 ;If RELEASE SUPPLEMENTARY REPORT is null, or if RELEASE SUPP
70 ; REPORT MODIFIED is set to 1, then supp report is unverified
71 S (LRA,LRC)=0 F S LRA=$O(@(LRFILE1_"LRA)")) Q:'LRA!(LRC) D
72 .I '$P(@(LRFILE1_"LRA,0)"),"^",2) S LRC=1
73 .;Flag if released supp has been modified but not yet released
74 .I 'LRC,$P(@(LRFILE1_"LRA,0)"),"^",3) S LRC=1
75 I LRC D
76 .S LRDATE=@(LRFILE_$S('LR("AU1"):",0)",1:")"))
77 .D W
78 Q
79SNO ;Missing SNOMED
80 S LRC=0
81 S:'LR("AU1") LRFILE2=LRFILE_",2"
82 S:LR("AU1") LRFILE2="^LR(LRPD,""AY"""
83 I '$D(@(LRFILE2_")")) S LRC=1
84 I 'LRC,'+$P($G(@(LRFILE2_",0)")),"^",4) S LRC=1
85 I LRC D
86 .S LRDATE=@(LRFILE_$S('LR("AU1"):",0)",1:")"))
87 .D W
88 Q
89W ;Write the report
90 W !,$$FMTE^XLFDT(LRDATE,"D"),?19,$J($P(LRDATE,"^",6),5),?32,LRP
91 W ?63,SSN
92 I 'LR("AU1") D
93 .S LRA=0 F S LRA=$O(^LR(LRPD,LRSS,LRI,97,LRA)) Q:'LRA!(LR("Q")) D
94 ..S B=^LR(LRPD,LRSS,LRI,97,LRA,0)
95 ..D:$Y>(IOSL-6) H1 Q:LR("Q") W !?3,B
96 Q
97H ;Header
98 I LRQ>0,IOST?1"C-".E D Q:LR("Q")
99 .K DIR S DIR(0)="E"
100 .D ^DIR W !
101 .S:$D(DTOUT)!(X[U) LR("Q")=1
102 W:LRQ>0 @IOF S LRQ=LRQ+1
103 S X="N",%DT="T" D ^%DT,D^LRU
104 W !,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ
105 W !,LRO(68)," (",LRABV,") "
106 I LRB<3 W "UNVERIFIED" W:LRB=2 " SUPPLEMENTARY" W " REPORTS"
107 W:LRB=3 "REPORTS MISSING SNOMED CODING"
108 W !,"BY DATE SPECIMEN TAKEN FROM ",LRSTR," TO ",LRLST
109 W !,"DATE",?15,"Accession number",?32,"Patient",?66,"SSN",!,LR("%")
110 Q
111H1 ;
112 D H Q:LR("Q") W !?19,$J($P(LRDATE,"^",6),5),?32,LRP,?63,SSN
113 Q
114END ;
115 W:IOST?1"P-".E @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
116 K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
117 D V^LRU
118 Q
Note: See TracBrowser for help on using the repository browser.