LRUPA2.m

LRUPA2 ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PAT ;9/25/00

 ;;5.2;LAB SERVICE;**72,248**;Sep 27, 1994

 ;

 ;Reference to ^DIC( supported by IA #916

 ;Reference to ^VA(200 supported by IA #10060

 ;Reference to DIC supported by IA #10006

 ;

 S ZTRTN="QUE^LRUPA2" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO K ^TMP($J) S (B(5),C(1))="",N=N(1)-1

 F B=0:0 S N=$O(^LRO(68,LRAA,1,LRAD,1,N)) Q:'N!(N>N(2))  S (B(5),C(1))="" S:$D(^LRO(68,LRAA,1,LRAD,1,N,5,1,0)) X=^(0),B(5)=+X,C(1)=$P(X,"^",2) D PRT

 D L^LRU,S^LRU,H S LR("F")=1,V=0 F B=1:1 S V=$O(^TMP($J,V)) Q:V=""!(LR("Q"))  D XT

 W:IOST'?1"C".E&($E(IOST,1,2)'="P-"!($D(LR("FORM")))) @IOF

 K ^TMP($J) D END^LRUTL,END

 Q

W S X=$S($D(^LR(LRDFN,LRSS,LRI,0)):^(0),1:"") I X="" W ?50,"Not in lab results file" Q

 S Z(2)=$S($P(X,"^",3):"","CHBBMI"[LRSS:"",1:"%"),Z=0 F A=0:1 S Z=$O(^LRO(68,LRAA,1,LRAD,1,N,4,Z)) Q:'Z!(LR("Q"))  S Z(3)=^(Z,0) D:+Z(3) L

 Q

O S C(4)=0 I '$D(^LR(LRDFN,LRSS,LRI,0)) W ?40,"Entry not in lab result file #63." Q

 F E=0:1 S C(4)=$O(^LR(LRDFN,LRSS,LRI,2,C(4))) Q:'C(4)!(LR("Q"))  S C(3)=+^(C(4),0) D:$Y>(IOSL-8) H2 Q:LR("Q")  W:E>0 ! W ?43,$S($D(^LAB(61,C(3),0)):$E($P(^(0),"^"),1,35),1:"")

 Q:LR("Q")  W:E=0 ?43,"No SNOMED code" Q

L Q:LR("Q")!($P($G(^LAB(60,Z,0)),"^",4)="WK")

 W:A=0 ?55,Z(2) W:A>0 !?55 W $S(LRSS="BB"&($P(Z(3),"^",4)=""):"%",1:"") W ?56,$E($P(^LAB(60,Z,0),"^"),1,19),?76 S X=$P(Z(3),"^",4) W $S('X:X,1:$P($G(^VA(200,X,0)),"^",2)) Q

 ;

XT S M=0 F Y=0:0 S M=$O(^TMP($J,V,M)) Q:M=""!(LR("Q"))  D A

 Q

A D:$Y>(IOSL-8) H Q:LR("Q")  W !,$J(B,3),")",?6,$P(M,"-",3),?12,V I LRSS="BB" W !?12,M," " S X=$O(^TMP($J,V,M,0)) S:X X=^(X),X=$P(X,"^",2),X=^LR(X,0) W " ",$P(X,"^",5)," ",$P(X,"^",6)

 S N=0 F B(2)=0:1 S N=$O(^TMP($J,V,M,N)) Q:'N!(LR("Q"))  S B(3)=^(N),B(4)=$P(B(3),"^"),LRI=$P(B(3),"^",3),LRDFN=$P(B(3),"^",2) D C

 Q

C D:$Y>(IOSL-8) H1 Q:LR("Q")  W:B(2)>0 ! D:LRSS="BB" D W ?33,$J(N,4),?38,B(4) D:"AUEMSPCY"[LRSS B I "SPCYEMAU"'[LRSS D W

 Q

B S LRDFN=$P(B(3),"^",2),LRI=$P(B(3),"^",3)

 D:"SPCYEM"[LRSS O

 Q:LR("Q")  W:LRSS="AU" ?40,LRI Q

PRT Q:'$D(^LRO(68,LRAA,1,LRAD,1,N,3))  S X=^(3),A(3)=$P(X,"^",3)

 S LRI=$P(X,"^",5),X=^LRO(68,LRAA,1,LRAD,1,N,0),LRDFN=+X

 S A(3)=$S(A(3):A(3),1:$P(X,"^",3))

 S B(5)=$S(B(5)>0:$P(^LAB(61,B(5),0),"^"),C(1)>0:$P(^LAB(62,C(1),0),"^"),1:"")

 S B(5)=$S(B(5)]"":B(5),1:C(1))

 Q:'$D(^LR(LRDFN,0))  S X=^(0),DA=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2)

 S DIC="^DIC(",DIC(0)="Z" D ^DIC Q:Y=-1

 S P(0)=Y(0,0) K DIC,Y

 S DIC=^DIC(X,0,"GL"),DIC(0)="NZ",X=DA D ^DIC Q:Y=-1

 S SSN=$P(Y(0),"^",9),LRP=$P(Y(0),"^") K DIC,DA,Y

 D SSN^LRU

 S:P(0)'="PATIENT" LRP="#"_LRP

 I LRSS="AU",$D(^LR(LRDFN,"AU")) D

 .S X=^("AU"),B(5)=$S($P(X,"^",3):"",1:"%") S Y=+X D D^LRU S LRI=Y

 I "CYSPEM"[LRSS S B(5)="" D

 .I $D(^LR(LRDFN,LRSS,LRI,0)),'$P(^(0),"^",3) S B(5)="%"

 S ^TMP($J,$E(LRP,1,20),SSN,N)=B(5)_"^"_LRDFN_"^"_LRI

 S (B(5),LRDFN,LRI)=""

 Q

D S Y=+^LR($P(B(3),"^",2),"BB",$P(B(3),"^",3),0) D DT^LRU S B(4)=Y Q

H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")

 D F^LRU W !,LRO(68)," ACCESSIONS for ",Z(1),"  BY PATIENT"

 W !,"# =Not VA patient",?36,$S("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")

 W !,"Count",?7,"ID",?12,"Patient",?35,"ACC#" W ?36 W:"AUBBCYEMSP"'[LRSS "Specimen" W:LRSS="BB" "Specimen date" W:"AUCYEMSP"'[LRSS ?50,"Test",?76,"Tech" W:"CYEMSP"[LRSS ?43,"Organ/tissue" W:LRSS="AU" ?40,"Date/time of Autopsy"

 W !,LR("%") Q

H1 D H Q:LR("Q")  S B(2)=0 W !,$J(B,3),")",?6,$P(M,"-",3),?12,V Q

H2 D H Q:LR("Q")  W !,$J(B,3),")",?6,$P(M,"-",3),?12,V,?33,$J(N,4) S E=0 Q

 ;

END D V^LRU Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRUPA2   3538     printed  Feb 18, 2025@23:47:44                                                                                                                                                                                                      Page 2

LRUPA2    ;AVAMC/REG/WTY - LAB ACCESSION LIST BY PAT ;9/25/00

 +1       ;;5.2;LAB SERVICE;**72,248**;Sep 27, 1994

 +2       ;

 +3       ;Reference to ^DIC( supported by IA #916

 +4       ;Reference to ^VA(200 supported by IA #10060

 +5       ;Reference to DIC supported by IA #10006

 +6       ;

 +7        SET ZTRTN="QUE^LRUPA2"

           DO BEG^LRUTL

           if POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           KILL ^TMP($JOB)

           SET (B(5),C(1))=""

           SET N=N(1)-1

 +1        FOR B=0:0

               SET N=$ORDER(^LRO(68,LRAA,1,LRAD,1,N))

               if 'N!(N>N(2))

                   QUIT 

               SET (B(5),C(1))=""

               if $DATA(^LRO(68,LRAA,1,LRAD,1,N,5,1,0))

                   SET X=^(0)

                   SET B(5)=+X

                   SET C(1)=$PIECE(X,"^",2)

               DO PRT

 +2        DO L^LRU

           DO S^LRU

           DO H

           SET LR("F")=1

           SET V=0

           FOR B=1:1

               SET V=$ORDER(^TMP($JOB,V))

               if V=""!(LR("Q"))

                   QUIT 

               DO XT

 +3        if IOST'?1"C".E&($EXTRACT(IOST,1,2)'="P-"!($DATA(LR("FORM"))))

               WRITE @IOF

 +4        KILL ^TMP($JOB)

           DO END^LRUTL

           DO END

 +5        QUIT 

W          SET X=$SELECT($DATA(^LR(LRDFN,LRSS,LRI,0)):^(0),1:"")

           IF X=""

               WRITE ?50,"Not in lab results file"

               QUIT 

 +1        SET Z(2)=$SELECT($PIECE(X,"^",3):"","CHBBMI"[LRSS:"",1:"%")

           SET Z=0

           FOR A=0:1

               SET Z=$ORDER(^LRO(68,LRAA,1,LRAD,1,N,4,Z))

               if 'Z!(LR("Q"))

                   QUIT 

               SET Z(3)=^(Z,0)

               if +Z(3)

                   DO L

 +2        QUIT 

O          SET C(4)=0

           IF '$DATA(^LR(LRDFN,LRSS,LRI,0))

               WRITE ?40,"Entry not in lab result file #63."

               QUIT 

 +1        FOR E=0:1

               SET C(4)=$ORDER(^LR(LRDFN,LRSS,LRI,2,C(4)))

               if 'C(4)!(LR("Q"))

                   QUIT 

               SET C(3)=+^(C(4),0)

               if $Y>(IOSL-8)

                   DO H2

               if LR("Q")

                   QUIT 

               if E>0

                   WRITE !

               WRITE ?43,$SELECT($DATA(^LAB(61,C(3),0)):$EXTRACT($PIECE(^(0),"^"),1,35),1:"")

 +2        if LR("Q")

               QUIT 

           if E=0

               WRITE ?43,"No SNOMED code"

           QUIT 

L          if LR("Q")!($PIECE($GET(^LAB(60,Z,0)),"^",4)="WK")

               QUIT 

 +1        if A=0

               WRITE ?55,Z(2)

           if A>0

               WRITE !?55

           WRITE $SELECT(LRSS="BB"&($PIECE(Z(3),"^",4)=""):"%",1:"")

           WRITE ?56,$EXTRACT($PIECE(^LAB(60,Z,0),"^"),1,19),?76

           SET X=$PIECE(Z(3),"^",4)

           WRITE $SELECT('X:X,1:$PIECE($GET(^VA(200,X,0)),"^",2))

           QUIT 

 +2       ;

XT         SET M=0

           FOR Y=0:0

               SET M=$ORDER(^TMP($JOB,V,M))

               if M=""!(LR("Q"))

                   QUIT 

               DO A

 +1        QUIT 

A          if $Y>(IOSL-8)

               DO H

           if LR("Q")

               QUIT 

           WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?12,V

           IF LRSS="BB"

               WRITE !?12,M," "

               SET X=$ORDER(^TMP($JOB,V,M,0))

               if X

                   SET X=^(X)

                   SET X=$PIECE(X,"^",2)

                   SET X=^LR(X,0)

               WRITE " ",$PIECE(X,"^",5)," ",$PIECE(X,"^",6)

 +1        SET N=0

           FOR B(2)=0:1

               SET N=$ORDER(^TMP($JOB,V,M,N))

               if 'N!(LR("Q"))

                   QUIT 

               SET B(3)=^(N)

               SET B(4)=$PIECE(B(3),"^")

               SET LRI=$PIECE(B(3),"^",3)

               SET LRDFN=$PIECE(B(3),"^",2)

               DO C

 +2        QUIT 

C          if $Y>(IOSL-8)

               DO H1

           if LR("Q")

               QUIT 

           if B(2)>0

               WRITE !

           if LRSS="BB"

               DO D

           WRITE ?33,$JUSTIFY(N,4),?38,B(4)

           if "AUEMSPCY"[LRSS

               DO B

           IF "SPCYEMAU"'[LRSS

               DO W

 +1        QUIT 

B          SET LRDFN=$PIECE(B(3),"^",2)

           SET LRI=$PIECE(B(3),"^",3)

 +1        if "SPCYEM"[LRSS

               DO O

 +2        if LR("Q")

               QUIT 

           if LRSS="AU"

               WRITE ?40,LRI

           QUIT 

PRT        if '$DATA(^LRO(68,LRAA,1,LRAD,1,N,3))

               QUIT 

           SET X=^(3)

           SET A(3)=$PIECE(X,"^",3)

 +1        SET LRI=$PIECE(X,"^",5)

           SET X=^LRO(68,LRAA,1,LRAD,1,N,0)

           SET LRDFN=+X

 +2        SET A(3)=$SELECT(A(3):A(3),1:$PIECE(X,"^",3))

 +3        SET B(5)=$SELECT(B(5)>0:$PIECE(^LAB(61,B(5),0),"^"),C(1)>0:$PIECE(^LAB(62,C(1),0),"^"),1:"")

 +4        SET B(5)=$SELECT(B(5)]"":B(5),1:C(1))

 +5        if '$DATA(^LR(LRDFN,0))

               QUIT 

           SET X=^(0)

           SET DA=$PIECE(X,"^",3)

           SET (LRDPF,X)=$PIECE(X,"^",2)

 +6        SET DIC="^DIC("

           SET DIC(0)="Z"

           DO ^DIC

           if Y=-1

               QUIT 

 +7        SET P(0)=Y(0,0)

           KILL DIC,Y

 +8        SET DIC=^DIC(X,0,"GL")

           SET DIC(0)="NZ"

           SET X=DA

           DO ^DIC

           if Y=-1

               QUIT 

 +9        SET SSN=$PIECE(Y(0),"^",9)

           SET LRP=$PIECE(Y(0),"^")

           KILL DIC,DA,Y

 +10       DO SSN^LRU

 +11       if P(0)'="PATIENT"

               SET LRP="#"_LRP

 +12       IF LRSS="AU"

               IF $DATA(^LR(LRDFN,"AU"))

                   Begin DoDot:1

 +13                   SET X=^("AU")

                       SET B(5)=$SELECT($PIECE(X,"^",3):"",1:"%")

                       SET Y=+X

                       DO D^LRU

                       SET LRI=Y

                   End DoDot:1

 +14       IF "CYSPEM"[LRSS

               SET B(5)=""

               Begin DoDot:1

 +15               IF $DATA(^LR(LRDFN,LRSS,LRI,0))

                       IF '$PIECE(^(0),"^",3)

                           SET B(5)="%"

               End DoDot:1

 +16       SET ^TMP($JOB,$EXTRACT(LRP,1,20),SSN,N)=B(5)_"^"_LRDFN_"^"_LRI

 +17       SET (B(5),LRDFN,LRI)=""

 +18       QUIT 

D          SET Y=+^LR($PIECE(B(3),"^",2),"BB",$PIECE(B(3),"^",3),0)

           DO DT^LRU

           SET B(4)=Y

           QUIT 

H          IF $DATA(LR("F"))

               IF IOST?1"C".E

                   DO M^LRU

                   if LR("Q")

                       QUIT 

 +1        DO F^LRU

           WRITE !,LRO(68)," ACCESSIONS for ",Z(1),"  BY PATIENT"

 +2        WRITE !,"# =Not VA patient",?36,$SELECT("AUBBCYEMSP"[LRSS:"% =Incomplete",1:"")

 +3        WRITE !,"Count",?7,"ID",?12,"Patient",?35,"ACC#"

           WRITE ?36

           if "AUBBCYEMSP"'[LRSS

               WRITE "Specimen"

           if LRSS="BB"

               WRITE "Specimen date"

           if "AUCYEMSP"'[LRSS

               WRITE ?50,"Test",?76,"Tech"

           if "CYEMSP"[LRSS

               WRITE ?43,"Organ/tissue"

           if LRSS="AU"

               WRITE ?40,"Date/time of Autopsy"

 +4        WRITE !,LR("%")

           QUIT 

H1         DO H

           if LR("Q")

               QUIT 

           SET B(2)=0

           WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?12,V

           QUIT 

H2         DO H

           if LR("Q")

               QUIT 

           WRITE !,$JUSTIFY(B,3),")",?6,$PIECE(M,"-",3),?12,V,?33,$JUSTIFY(N,4)

           SET E=0

           QUIT 

 +1       ;

END        DO V^LRU

           QUIT