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

LRUA.m

Go to the documentation of this file.
  1. LRUA ;AVAMC/REG/WTY - ANAT PATH UTILITY ;10/23/01
  1. ;;5.2;LAB SERVICE;**72,173,201,213,259**;Sep 27, 1994
  1. ;
  1. ;Reference to ^DIC supported by IA #916
  1. ;Reference to ^DIC(7 supported by IA #2252
  1. ;
  1. S LRPF=^DIC($P(^LR(LRDFN,0),"^",2),0,"GL"),LRFLN=+$P(@(LRPF_"0)"),"^",2)
  1. S DFN=$P(^LR(LRDFN,0),"^",3),LRDPF=$P(^(0),U,2),W=^(LRSS,LRI,0)
  1. S LRW(1)=$E($P(W,"^",10),2,3)
  1. S LRLLOC=$P(W,"^",8),LRAC=$P(W,"^",6),LRPMD=$P(W,"^",2)
  1. S LRRMD=$P(W,"^",4),LRMD=$P(W,"^",7),LRW(5)=$P(W,"^",5)
  1. S LRW(9)=$P(W,"^",9),SSN=@(LRPF_DFN_",0)")
  1. S Y=+W D DATE S LRTK=Y,Y=$P(W,"^",10) D DATE S LRTK(1)=Y
  1. I LRMD S X=LRMD D D S LRMD=X
  1. I LRPMD S X=LRPMD D D S LRPMD=X
  1. I LRRMD S X=LRRMD D D S LRRMD=X
  1. S (LRADM,LRADX,DOB)=""
  1. S Y=$P(W,"^",3) D DATE S LRRC=$S(Y["1700":"",1:Y)
  1. S LRP=$P(SSN,"^"),SEX=$P(SSN,"^",2),(X2,Y)=$P(SSN,"^",3)
  1. S SSN=$P(SSN,"^",9) D SSN^LRU
  1. D DEM^LRX,DD^LRX S DOB=Y
  1. I LRPF="^DPT(" K VAIN D INPPT^LRX S LRADX=VAIN(9),LRADM=$P(VAIN(7),U,2)
  1. Q
  1. SET ;
  1. 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)
  1. ;
  1. EN ;
  1. 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)
  1. D FIELD^DID(63.819,.01,"","POINTER","LR") S LR("SP")=LR("POINTER")
  1. D FIELD^DID(63.219,.01,"","POINTER","LR") S LR("EM")=LR("POINTER")
  1. D FIELD^DID(63.919,.01,"","POINTER","LR") S LR("CY")=LR("POINTER")
  1. D FIELD^DID(63.26,.01,"","POINTER","LR") S LR("AU")=LR("POINTER")
  1. D FIELD^DID(63,13.7,"","POINTER","LR") S LRAU("T")=LR("POINTER")
  1. D FIELD^DID(63,14.5,"","POINTER","LR") S LRAU("L")=LR("POINTER")
  1. D FIELD^DID(63.26,.01,"","POINTER","LR") S LRAU("S")=LR("POINTER")
  1. Q
  1. C ;
  1. 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))
  1. S X=X("L") Q
  1. ;string X => lower case do C; upper case do U
  1. U 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))
  1. S X=X("U") Q
  1. P S LRMD(1)="" D D S LRMD=X Q
  1. ;
  1. D ;Name formatting
  1. I $D(^VA(200,X,0)) D
  1. .Q:'$D(LRSS)
  1. .I LRSS'="BB" D
  1. ..N LRNAME,FMTNAM
  1. ..S LRNAME("FILE")=200,LRNAME("FIELD")=.01,LRNAME("IENS")=X_","
  1. ..S LRMD(1)=X,X=+$P($G(^VA(200,X,"PS")),"^",5)
  1. ..S FMTNAM=$$NAMEFMT^XLFNAME(.LRNAME,"G","D")
  1. ..S X=FMTNAM
  1. .I LRSS="BB" D
  1. ..S LRMD(1)=X,X(2)=$P(^(0),"^"),X=+$P($G(^("PS")),"^",5)
  1. ..S X(1)=$P($G(^DIC(7,X,0)),"^",2)
  1. ..S X=$P(X(2),",",2)_" "_$P(X(2),",")_" "_X(1)
  1. Q
  1. EN1 ;
  1. 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"
  1. R !,"Select print option: ",LRAPX:DTIME I LRAPX=""!(X[U) K LRAPX Q
  1. I LRAPX<1!(LRAPX>4) W $C(7)," SELECT A NUMBER FROM 1-4",! G EN1
  1. Q
  1. EN2 ; set variable for accession prefix
  1. S LRQ(8)=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),"^",8),1:"")
  1. Q
  1. ;
  1. DATE ; Returns date in Mon day,year time (if appropriate) format
  1. S Y=$TR($$FMTE^XLFDT(Y,"M"),"@"," ")
  1. Q