source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRUA.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1LRUA ;AVAMC/REG/WTY - ANAT PATH UTILITY ;10/23/01
2 ;;5.2;LAB SERVICE;**72,173,201,213,259**;Sep 27, 1994
3 ;
4 ;Reference to ^DIC supported by IA #916
5 ;Reference to ^DIC(7 supported by IA #2252
6 ;
7 S LRPF=^DIC($P(^LR(LRDFN,0),"^",2),0,"GL"),LRFLN=+$P(@(LRPF_"0)"),"^",2)
8 S DFN=$P(^LR(LRDFN,0),"^",3),LRDPF=$P(^(0),U,2),W=^(LRSS,LRI,0)
9 S LRW(1)=$E($P(W,"^",10),2,3)
10 S LRLLOC=$P(W,"^",8),LRAC=$P(W,"^",6),LRPMD=$P(W,"^",2)
11 S LRRMD=$P(W,"^",4),LRMD=$P(W,"^",7),LRW(5)=$P(W,"^",5)
12 S LRW(9)=$P(W,"^",9),SSN=@(LRPF_DFN_",0)")
13 S Y=+W D DATE S LRTK=Y,Y=$P(W,"^",10) D DATE S LRTK(1)=Y
14 I LRMD S X=LRMD D D S LRMD=X
15 I LRPMD S X=LRPMD D D S LRPMD=X
16 I LRRMD S X=LRRMD D D S LRRMD=X
17 S (LRADM,LRADX,DOB)=""
18 S Y=$P(W,"^",3) D DATE S LRRC=$S(Y["1700":"",1:Y)
19 S LRP=$P(SSN,"^"),SEX=$P(SSN,"^",2),(X2,Y)=$P(SSN,"^",3)
20 S SSN=$P(SSN,"^",9) D SSN^LRU
21 D DEM^LRX,DD^LRX S DOB=Y
22 I LRPF="^DPT(" K VAIN D INPPT^LRX S LRADX=VAIN(9),LRADM=$P(VAIN(7),U,2)
23 Q
24SET ;
25 S X=$G(^LRO(69.2,LRAA,0)),LR(69.2,.03)=$P(X,U,3),LR(69.2,.04)=$P(X,U,4),LR(69.2,.05)=$P(X,U,5),LR(69.2,.13)=$P(X,U,13),LR(69.2,.14)=$P(X,U,14)
26 ;
27EN ;
28 S X=+$O(^LRO(68,"B","AUTOPSY",0)),X=$S($D(^LRO(69.2,X,0)):^(0),1:""),LRAU(1)=$P(X,"^",3),LRAU(2)=$P(X,"^",4)
29 D FIELD^DID(63.819,.01,"","POINTER","LR") S LR("SP")=LR("POINTER")
30 D FIELD^DID(63.219,.01,"","POINTER","LR") S LR("EM")=LR("POINTER")
31 D FIELD^DID(63.919,.01,"","POINTER","LR") S LR("CY")=LR("POINTER")
32 D FIELD^DID(63.26,.01,"","POINTER","LR") S LR("AU")=LR("POINTER")
33 D FIELD^DID(63,13.7,"","POINTER","LR") S LRAU("T")=LR("POINTER")
34 D FIELD^DID(63,14.5,"","POINTER","LR") S LRAU("L")=LR("POINTER")
35 D FIELD^DID(63.26,.01,"","POINTER","LR") S LRAU("S")=LR("POINTER")
36 Q
37C ;
38 S X("L")="" F X(1)=1:1:$L(X) S X("L")=X("L")_$C($A(X,X(1))+($E(X,X(1))?1U*32))
39 S X=X("L") Q
40 ;string X => lower case do C; upper case do U
41U S X("U")="" F X(1)=1:1:$L(X) S X("U")=X("U")_$C($A(X,X(1))-($E(X,X(1))?1L*32))
42 S X=X("U") Q
43P S LRMD(1)="" D D S LRMD=X Q
44 ;
45D ;Name formatting
46 I $D(^VA(200,X,0)) D
47 .Q:'$D(LRSS)
48 .I LRSS'="BB" D
49 ..N LRNAME,FMTNAM
50 ..S LRNAME("FILE")=200,LRNAME("FIELD")=.01,LRNAME("IENS")=X_","
51 ..S LRMD(1)=X,X=+$P($G(^VA(200,X,"PS")),"^",5)
52 ..S FMTNAM=$$NAMEFMT^XLFNAME(.LRNAME,"G","D")
53 ..S X=FMTNAM
54 .I LRSS="BB" D
55 ..S LRMD(1)=X,X(2)=$P(^(0),"^"),X=+$P($G(^("PS")),"^",5)
56 ..S X(1)=$P($G(^DIC(7,X,0)),"^",2)
57 ..S X=$P(X(2),",",2)_" "_$P(X(2),",")_" "_X(1)
58 Q
59EN1 ;
60 W !?21,"1. Add patient(s) to report print queue",!?21,"2. Delete report print queue",!?21,"3. Print single report only",!?21,"4. Print all reports on print queue"
61 R !,"Select print option: ",LRAPX:DTIME I LRAPX=""!(X[U) K LRAPX Q
62 I LRAPX<1!(LRAPX>4) W $C(7)," SELECT A NUMBER FROM 1-4",! G EN1
63 Q
64EN2 ; set variable for accession prefix
65 S LRQ(8)=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),"^",8),1:"")
66 Q
67 ;
68DATE ; Returns date in Mon day,year time (if appropriate) format
69 S Y=$TR($$FMTE^XLFDT(Y,"M"),"@"," ")
70 Q
Note: See TracBrowser for help on using the repository browser.