source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRWRKIN1.m@ 707

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1LRWRKIN1 ;SLC/DCM/CJS-LRWRKINC, CONT ;2/22/87 11:39 AM
2 ;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994
3LST1 ;from LRWRKINC
4 S (LRDLC,LRDTO)=""
5 S LRDX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
6 S LRCE=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
7 S LRACC=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
8 S LRDX(0)=$G(^LR(+LRDX,0))
9 S LRDPF=$P(LRDX(0),U,2),DFN=$P(LRDX(0),U,3) D PT^LRX
10 I $P(LRDX,U,4) S LRDTO=$$FMTE^XLFDT($P(LRDX,"^",4),"5MZ")
11 S Y=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),LRDLA=$P(Y,U,3),LRACO=$P(Y,U,6)
12 I $P(Y,"^") S LRDLC=$$FMTE^XLFDT($P(U,"^"),"5MZ")
13 I LRDLA S $P(LRDLA,"^",2)=$$FMTE^XLFDT(LRDLA,"5MZ")
14 Q
15 ;
16X ;from LRWRKINC
17 N LRTSTN,LRACC,LRACCN,LRAN,LRUR
18 S LRTSTN="",LREND=0
19 F S LRTSTN=$O(^TMP($J,LRTSTN)) Q:LRTSTN="" D Q:LREND
20 . S J=0,LRUR=""
21 . F S LRUR=$O(^TMP($J,LRTSTN,LRUR)) Q:LRUR="" S LRU=$G(LRURG(LRUR)) D Q:LREND
22 . . S LRACCN=""
23 . . F S LRACCN=$O(^TMP($J,LRTSTN,LRUR,LRACCN)) Q:LRACCN="" D Q:LREND
24 . . . S LRAN=""
25 . . . F S LRAN=$O(^TMP($J,LRTSTN,LRUR,LRACCN,LRAN)) Q:LRAN="" D Q:LREND
26 . . . . I ($Y+8)>IOSL D Q:LREND
27 . . . . . D EQUALS^LRX
28 . . . . . I $E(IOST,1,2)="C-" D WAIT Q:LREND
29 . . . . . D HED
30 . . . . S J=J+1
31 . . . . S W=^TMP($J,LRTSTN,LRUR,LRACCN,LRAN),LRST=$P(W,U,1),SSN=$P(W,U,2),PNM=$P(W,U,3),LRLLOC=$P(W,U,4),LRCOLL=$P(W,U,5),LRMAN=$P(W,U,6),LRACC=$P(W,U,7)
32 . . . . W !,$E($S(LRSORTBY=1:$P(LRTSTN,"^",2),1:LRTSTN),1,20),?23,$E(LRU,1,9),?34,LRACC,?47," ",LRCOLL,?65,$E(LRLLOC,1,15)
33 . . . . S LRCL=$S(IOM<120:5,1:82) W:IOM<120 ! I IOM<120!('LREXD) W ?LRCL,SSN
34 . . . . S LRCL=$S(IOM<120:20,LREXD:82,1:97) W ?LRCL,$E(PNM,1,19)
35 . . . . S LRCL=$S(IOM<120:40,LREXD:102,1:117) W ?LRCL,$S('LREXD&(IOM'<120):$E(LRST,1,15),1:$E(LRST,1,30))
36 . . . . I LREXD D
37 . . . . . N A
38 . . . . . S A=$G(^TMP($J,LRTSTN,LRUR,LRACCN,LRAN,.3))
39 . . . . . S Y=$P(A,"^",2) I Y S C=$P(^DD(68.02,16.1,0),"^",2) D Y^DIQ
40 . . . . . W !,?23,$P(A,"^"),?48,$E(Y,1,16),?65,$P(A,"^",5) I IOM'<120 W ?82,SSN
41 . . . . . W:IOM<120 ! S LRCL=$S(IOM<120:20,1:102) W ?LRCL,LRMAN
42 . W:'LREND !,?7,"------",!,$J(J,13)
43 Q
44 ;
45HED ; Print header
46 I LRPAGE!($E(IOST,1,2)="C-") W @IOF
47 S LRPAGE=LRPAGE+1
48 W "INCOMPLETE STATUS REPORT *** NOT FOR WARD USE ***",?(IOM-16),LRDT
49 W !,"Accession Area(s):",?(IOM-10),"Page: ",LRPAGE
50 S LRINDEX=0
51 F S LRINDEX=$O(LRNAME(LRINDEX)) Q:'LRINDEX W !,LRNAME(LRINDEX)
52 W !!,"Test",?23,"Urgency",?34,"Accession",?48,"Date/time",?65,"Location"
53 S LRCL=$S(IOM<120:5,1:82)
54 W:IOM<120 !
55 I IOM<120!('LREXD) W ?LRCL,"SSN"
56 S LRCL=$S(IOM<120:20,LREXD:82,1:97) W ?LRCL,"Patient"
57 S LRCL=$S(IOM<120:40,LREXD:102,1:117) W ?LRCL,"Status"
58 I $G(LREXD) W !,?23,"UID",?48,"Sending Site",?65,"Sender's UID"
59 I LREXD,IOM'<120 W ?82,"SSN"
60 I LREXD W:IOM<120 ! S LRCL=$S(IOM<120:20,1:102) W ?LRCL,"Shipping Manifest"
61 D DASH^LRX
62 W !
63 Q
64 ;
65WAIT ;from LRWRKINC
66 I $E(IOST,1,2)'="C-" Q
67 N DIR,DIRUT,DTOUT,DUOUT,X,Y
68 S DIR(0)="E" D ^DIR
69 I $D(DIRUT) S LREND=1
70 Q
71 ;
72LREND ;
73 I $E(IOST,1,2)="P-" W @IOF
74 I $D(ZTQUEUED) S ZTREQ="@"
75 E D ^%ZISC
76 D KVA^VADPT
77 K %,%DT,%X,%Y,%ZIS,A,AGE,B,C,DIC,DICS,DFN,DOB,I,K,J,L,LAST,PNM,POP,SEX,SSN,W,X,X1,X2,Y,Z,ZTSK
78 K LRCNT,LRCUTOFF,LRDLA,LRDLC,LRDX,LRLO69,LRSAMP
79 K LRRB,LRSPEC,LRTREA,LRURG,LRWRD,LRCOLL,LRACO
80 K LRAA,LRACC,LRAD,LRAN,LRNAC,LRCE,LRDPF,LRSN,LRDTO,LRINDEX
81 K LREXNREQ,LRPAGE,LRPRAC,LRSORTBY,LRSTAR,LRX
82 K LA,LRLAN,LRDAT,LRDT,LREND,LREXD,LREXTST,LRFAN,LRFI,LRIX,LRMAN,LRNAME,LRNOCNTL
83 K LRTSE,LRVERVER,LRLLOC,LRU,LRST,LRCL,LRDFN,LREDT,LRIOZERO,LRSDT,LRTK,LRTSE,LRWDTL
84 K LRX,LRY,LRZ
85 K ^TMP("LRWRKINC",$J),^TMP($J)
86 Q
87 ;
88CHKAA ; Check if user wants to use criteria from another chosen area.
89 N DIR,DIRUT,DTOUT,DUOUT,LRFAN,LRINDEX,LRLAST,LRSTAR,LRX,LRY,LRZ,X,Y
90 S (LRINDEX,LRZ)=0,(LRUSEAA,LRX)=""
91 F S LRX=$O(^TMP("LRWRKINC",$J,LRX)) Q:LRX="" D
92 . S LRZ=0
93 . F S LRZ=$O(^TMP("LRWRKINC",$J,LRX,LRZ)) Q:'LRZ D
94 . . S LRZ(0)=^TMP("LRWRKINC",$J,LRX,LRZ,0)
95 . . S LRZ(1)=^TMP("LRWRKINC",$J,LRX,LRZ,1)
96 . . S LRY=""
97 . . I $P(LRAA(0),"^",3)'=$P(LRZ(0),"^",3) Q ; Not same accession transform.
98 . . I LRAA=$P(LRX,"^",2) Q ; Don't use criteria from same accession area.
99 . . S LRFAN=$P(LRZ(1),"^",2),LRLAN=$P(LRZ(1),"^",3),LRSTAR=$P(LRZ(1),"^",4),LRLAST=$P(LRZ(1),"^",5)
100 . . I LRSTAR,LRLAST S LRY="From Date: "_$$FMTE^XLFDT(LRSTAR,"2DZ")_" To: "_$$FMTE^XLFDT(LRLAST,"2DZ")
101 . . E S LRY="For Date: "_$$FMTE^XLFDT(LRLAST,"2DZ")_" From: "_LRFAN_" To: "_LRLAN
102 . . S LRINDEX=LRINDEX+1,LRINDEX(LRINDEX)=LRX_"^"_LRZ
103 . . S DIR("A",LRINDEX)=$J(LRINDEX,4)_" "_$P(LRZ(0),"^")_" "_LRY
104 I $D(DIR("A")) D
105 . S DIR(0)="NO^1:"_LRINDEX_":0"
106 . S DIR("A",LRINDEX+1)=" "
107 . S DIR("A")="Use Criteria from Accession Area"
108 . S DIR("?",1)="Use previously selected accession area's date and number criteria."
109 . S DIR("?")="Or press <RET> to specify different date/number criteria for "_$P(LRAA(0),"^")_"."
110 . W ! D ^DIR
111 . I '$D(DIRUT) S LRUSEAA=LRINDEX(Y) Q
112 . I $D(DUOUT)!$D(DTOUT) S LREND=1
113 Q
Note: See TracBrowser for help on using the repository browser.