- 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 Jan 18, 2025@03:21:56 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