LRUA ;AVAMC/REG/WTY - ANAT PATH UTILITY ;10/23/01
;;5.2;LAB SERVICE;**72,173,201,213,259**;Sep 27, 1994
;
;Reference to ^DIC supported by IA #916
;Reference to ^DIC(7 supported by IA #2252
;
S LRPF=^DIC($P(^LR(LRDFN,0),"^",2),0,"GL"),LRFLN=+$P(@(LRPF_"0)"),"^",2)
S DFN=$P(^LR(LRDFN,0),"^",3),LRDPF=$P(^(0),U,2),W=^(LRSS,LRI,0)
S LRW(1)=$E($P(W,"^",10),2,3)
S LRLLOC=$P(W,"^",8),LRAC=$P(W,"^",6),LRPMD=$P(W,"^",2)
S LRRMD=$P(W,"^",4),LRMD=$P(W,"^",7),LRW(5)=$P(W,"^",5)
S LRW(9)=$P(W,"^",9),SSN=@(LRPF_DFN_",0)")
S Y=+W D DATE S LRTK=Y,Y=$P(W,"^",10) D DATE S LRTK(1)=Y
I LRMD S X=LRMD D D S LRMD=X
I LRPMD S X=LRPMD D D S LRPMD=X
I LRRMD S X=LRRMD D D S LRRMD=X
S (LRADM,LRADX,DOB)=""
S Y=$P(W,"^",3) D DATE S LRRC=$S(Y["1700":"",1:Y)
S LRP=$P(SSN,"^"),SEX=$P(SSN,"^",2),(X2,Y)=$P(SSN,"^",3)
S SSN=$P(SSN,"^",9) D SSN^LRU
D DEM^LRX,DD^LRX S DOB=Y
I LRPF="^DPT(" K VAIN D INPPT^LRX S LRADX=VAIN(9),LRADM=$P(VAIN(7),U,2)
Q
SET ;
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)
;
EN ;
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)
D FIELD^DID(63.819,.01,"","POINTER","LR") S LR("SP")=LR("POINTER")
D FIELD^DID(63.219,.01,"","POINTER","LR") S LR("EM")=LR("POINTER")
D FIELD^DID(63.919,.01,"","POINTER","LR") S LR("CY")=LR("POINTER")
D FIELD^DID(63.26,.01,"","POINTER","LR") S LR("AU")=LR("POINTER")
D FIELD^DID(63,13.7,"","POINTER","LR") S LRAU("T")=LR("POINTER")
D FIELD^DID(63,14.5,"","POINTER","LR") S LRAU("L")=LR("POINTER")
D FIELD^DID(63.26,.01,"","POINTER","LR") S LRAU("S")=LR("POINTER")
Q
C ;
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))
S X=X("L") Q
;string X => lower case do C; upper case do U
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))
S X=X("U") Q
P S LRMD(1)="" D D S LRMD=X Q
;
D ;Name formatting
I $D(^VA(200,X,0)) D
.Q:'$D(LRSS)
.I LRSS'="BB" D
..N LRNAME,FMTNAM
..S LRNAME("FILE")=200,LRNAME("FIELD")=.01,LRNAME("IENS")=X_","
..S LRMD(1)=X,X=+$P($G(^VA(200,X,"PS")),"^",5)
..S FMTNAM=$$NAMEFMT^XLFNAME(.LRNAME,"G","D")
..S X=FMTNAM
.I LRSS="BB" D
..S LRMD(1)=X,X(2)=$P(^(0),"^"),X=+$P($G(^("PS")),"^",5)
..S X(1)=$P($G(^DIC(7,X,0)),"^",2)
..S X=$P(X(2),",",2)_" "_$P(X(2),",")_" "_X(1)
Q
EN1 ;
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"
R !,"Select print option: ",LRAPX:DTIME I LRAPX=""!(X[U) K LRAPX Q
I LRAPX<1!(LRAPX>4) W $C(7)," SELECT A NUMBER FROM 1-4",! G EN1
Q
EN2 ; set variable for accession prefix
S LRQ(8)=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),"^",8),1:"")
Q
;
DATE ; Returns date in Mon day,year time (if appropriate) format
S Y=$TR($$FMTE^XLFDT(Y,"M"),"@"," ")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUA 2976 printed Oct 16, 2024@18:21:58 Page 2
LRUA ;AVAMC/REG/WTY - ANAT PATH UTILITY ;10/23/01
+1 ;;5.2;LAB SERVICE;**72,173,201,213,259**;Sep 27, 1994
+2 ;
+3 ;Reference to ^DIC supported by IA #916
+4 ;Reference to ^DIC(7 supported by IA #2252
+5 ;
+6 SET LRPF=^DIC($PIECE(^LR(LRDFN,0),"^",2),0,"GL")
SET LRFLN=+$PIECE(@(LRPF_"0)"),"^",2)
+7 SET DFN=$PIECE(^LR(LRDFN,0),"^",3)
SET LRDPF=$PIECE(^(0),U,2)
SET W=^(LRSS,LRI,0)
+8 SET LRW(1)=$EXTRACT($PIECE(W,"^",10),2,3)
+9 SET LRLLOC=$PIECE(W,"^",8)
SET LRAC=$PIECE(W,"^",6)
SET LRPMD=$PIECE(W,"^",2)
+10 SET LRRMD=$PIECE(W,"^",4)
SET LRMD=$PIECE(W,"^",7)
SET LRW(5)=$PIECE(W,"^",5)
+11 SET LRW(9)=$PIECE(W,"^",9)
SET SSN=@(LRPF_DFN_",0)")
+12 SET Y=+W
DO DATE
SET LRTK=Y
SET Y=$PIECE(W,"^",10)
DO DATE
SET LRTK(1)=Y
+13 IF LRMD
SET X=LRMD
DO D
SET LRMD=X
+14 IF LRPMD
SET X=LRPMD
DO D
SET LRPMD=X
+15 IF LRRMD
SET X=LRRMD
DO D
SET LRRMD=X
+16 SET (LRADM,LRADX,DOB)=""
+17 SET Y=$PIECE(W,"^",3)
DO DATE
SET LRRC=$SELECT(Y["1700":"",1:Y)
+18 SET LRP=$PIECE(SSN,"^")
SET SEX=$PIECE(SSN,"^",2)
SET (X2,Y)=$PIECE(SSN,"^",3)
+19 SET SSN=$PIECE(SSN,"^",9)
DO SSN^LRU
+20 DO DEM^LRX
DO DD^LRX
SET DOB=Y
+21 IF LRPF="^DPT("
KILL VAIN
DO INPPT^LRX
SET LRADX=VAIN(9)
SET LRADM=$PIECE(VAIN(7),U,2)
+22 QUIT
SET ;
+1 SET X=$GET(^LRO(69.2,LRAA,0))
SET LR(69.2,.03)=$PIECE(X,U,3)
SET LR(69.2,.04)=$PIECE(X,U,4)
SET LR(69.2,.05)=$PIECE(X,U,5)
SET LR(69.2,.13)=$PIECE(X,U,13)
SET LR(69.2,.14)=$PIECE(X,U,14)
+2 ;
EN ;
+1 SET X=+$ORDER(^LRO(68,"B","AUTOPSY",0))
SET X=$SELECT($DATA(^LRO(69.2,X,0)):^(0),1:"")
SET LRAU(1)=$PIECE(X,"^",3)
SET LRAU(2)=$PIECE(X,"^",4)
+2 DO FIELD^DID(63.819,.01,"","POINTER","LR")
SET LR("SP")=LR("POINTER")
+3 DO FIELD^DID(63.219,.01,"","POINTER","LR")
SET LR("EM")=LR("POINTER")
+4 DO FIELD^DID(63.919,.01,"","POINTER","LR")
SET LR("CY")=LR("POINTER")
+5 DO FIELD^DID(63.26,.01,"","POINTER","LR")
SET LR("AU")=LR("POINTER")
+6 DO FIELD^DID(63,13.7,"","POINTER","LR")
SET LRAU("T")=LR("POINTER")
+7 DO FIELD^DID(63,14.5,"","POINTER","LR")
SET LRAU("L")=LR("POINTER")
+8 DO FIELD^DID(63.26,.01,"","POINTER","LR")
SET LRAU("S")=LR("POINTER")
+9 QUIT
C ;
+1 SET X("L")=""
FOR X(1)=1:1:$LENGTH(X)
SET X("L")=X("L")_$CHAR($ASCII(X,X(1))+($EXTRACT(X,X(1))?1U*32))
+2 SET X=X("L")
QUIT
+3 ;string X => lower case do C; upper case do U
U SET X("U")=""
FOR X(1)=1:1:$LENGTH(X)
SET X("U")=X("U")_$CHAR($ASCII(X,X(1))-($EXTRACT(X,X(1))?1L*32))
+1 SET X=X("U")
QUIT
P SET LRMD(1)=""
DO D
SET LRMD=X
QUIT
+1 ;
D ;Name formatting
+1 IF $DATA(^VA(200,X,0))
Begin DoDot:1
+2 if '$DATA(LRSS)
QUIT
+3 IF LRSS'="BB"
Begin DoDot:2
+4 NEW LRNAME,FMTNAM
+5 SET LRNAME("FILE")=200
SET LRNAME("FIELD")=.01
SET LRNAME("IENS")=X_","
+6 SET LRMD(1)=X
SET X=+$PIECE($GET(^VA(200,X,"PS")),"^",5)
+7 SET FMTNAM=$$NAMEFMT^XLFNAME(.LRNAME,"G","D")
+8 SET X=FMTNAM
End DoDot:2
+9 IF LRSS="BB"
Begin DoDot:2
+10 SET LRMD(1)=X
SET X(2)=$PIECE(^(0),"^")
SET X=+$PIECE($GET(^("PS")),"^",5)
+11 SET X(1)=$PIECE($GET(^DIC(7,X,0)),"^",2)
+12 SET X=$PIECE(X(2),",",2)_" "_$PIECE(X(2),",")_" "_X(1)
End DoDot:2
End DoDot:1
+13 QUIT
EN1 ;
+1 WRITE !?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"
+2 READ !,"Select print option: ",LRAPX:DTIME
IF LRAPX=""!(X[U)
KILL LRAPX
QUIT
+3 IF LRAPX<1!(LRAPX>4)
WRITE $CHAR(7)," SELECT A NUMBER FROM 1-4",!
GOTO EN1
+4 QUIT
EN2 ; set variable for accession prefix
+1 SET LRQ(8)=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),"^",8),1:"")
+2 QUIT
+3 ;
DATE ; Returns date in Mon day,year time (if appropriate) format
+1 SET Y=$TRANSLATE($$FMTE^XLFDT(Y,"M"),"@"," ")
+2 QUIT
