- LRUPA1 ;AVAMC/REG - LAB ACCESSION LIST COND'T ;3/3/94 10:07 ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- S X=$S($D(^LRO(68,LRAA,1,LRAD,1,N,5,1,0)):^(0),1:""),C(3)=+X S:'C(3) C(3)=LRU S C(2)=$P(X,"^",2) S:'C(2) C(2)=LRU(1) I $D(C(1)),C(1)'=C(2) Q
- Q:'$D(^LRO(68,LRAA,1,LRAD,1,N,0)) S X=^(0),LRDFN=+X,A(3)=$P(X,"^",3),A(7)=$P(X,"^",7) Q:'$D(^(3)) S X=^(3),LRI=$P(X,"^",5),A(3)=$S($P(X,"^",3):$P(X,"^",3),1:A(3))
- S N(6)=$S($D(^LRO(68,LRAA,1,LRAD,1,N,6)):^(6),1:"") I '$D(^LR(LRDFN,0)) D:$Y>(IOSL-8) H^LRUPA Q:LR("Q") W !,$J(N,7),?11,"Entry not in lab results file" Q
- S:LRSS="CY" Q(2)=Q(2)+N(6),Q(1)=Q(1)+$P(N(6),"^",2) D V Q:LR("Q") W:$L(LRC(5)) !,LRC(5),! Q
- V D:$Y>(IOSL-8) H^LRUPA Q:LR("Q") W ! I A(3)<LRAD W $E(A(3),4,5),"/",$E(A(3),6,7)
- W ?5,$J(N,5) S (X,Z)=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),P(0)=$P(^DIC(X,0),"^"),X=^DIC(X,0,"GL")
- S X=@(X_Y_",0)"),SSN=$P(X,"^",9),LRP=$P(X,"^") D SSN^LRU
- W ?12 W:P(0)'="PATIENT" "#" W $E(LRP,1,15),?28,SSN(1),?34,$E(A(7),1,5) I LRSS="BB" D:$Y>(IOSL-8) H^LRUPA Q:LR("Q") W !?7,SSN," ",$P(Z,"^",5)," ",$P(Z,"^",6)
- I LRSS="AU" Q:'$D(^LR(LRDFN,"AU")) S X=^("AU") W ?40,$S('$P(X,"^",3):"%",1:"") S Y=+X D:Y D^LRU W ?42,Y Q
- I '$D(^LR(LRDFN,LRSS,LRI,0)) W ?40,"Not in lab results file" Q
- I "CYEMSP"[LRSS S X=^LR(LRDFN,LRSS,LRI,0),C(6)=$S($P(X,"^",12):"*",1:"") W:'$P(X,"^",3) ?40,"%" I "CYEMSP"[LRSS D O Q:LR("Q") Q:"EMSP"[LRSS
- I LRSS="CY" W ?72,$J(+N(6),5) W:$P(N(6),"^",2) "b" W ?79,C(6) Q
- I LRSS="BB" S Y=+^LR(LRDFN,LRSS,LRI,0) D DT^LRU W ?40,Y S LRA=Y
- E W ?41,$S(C(2)>0&(P(0)="STERILIZER"!(P(0)="ENVIRONMENTAL")):$E($P(^LAB(62,C(2),0),"^"),1,14),$D(^LAB(61,C(3),0)):$E($P(^(0),"^"),1,13),1:"")
- W S Z(2)=$S($P(^LR(LRDFN,LRSS,LRI,0),"^",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
- L Q:LR("Q")!($P($G(^LAB(60,Z,0)),"^",4)="WK")
- D:$Y>(IOSL-8) H Q:LR("Q") W:A>0 ! I LRSS="CH",$P(Z(3),"^",2)=1 W ?54,"*"
- W:A=0 ?55,Z(2) W ?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
- ;
- O S C(4)=0 F B=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) H^LRUPA Q:LR("Q") W:B>0 ! W ?46,$S($D(^LAB(61,C(3),0)):$E($P(^(0),"^"),1,23),1:"")
- Q:LR("Q") W:B=0 ?46,"No SNOMED code" Q
- ;
- H D H^LRUPA Q:LR("Q") W ! I A(3)<LRAD W $E(A(3),4,5),"/",$E(A(3),6,7)
- W ?5,$J(N,5),?12 W:P(0)'="PATIENT" "#" W $E(LRP,1,20),?28,SSN(1),?34,$E(A(7),1,5) W:LRSS="BB" ?40,LRA Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUPA1 2547 printed Feb 18, 2025@23:47:43 Page 2
- LRUPA1 ;AVAMC/REG - LAB ACCESSION LIST COND'T ;3/3/94 10:07 ;
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +2 SET X=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,N,5,1,0)):^(0),1:"")
- SET C(3)=+X
- if 'C(3)
- SET C(3)=LRU
- SET C(2)=$PIECE(X,"^",2)
- if 'C(2)
- SET C(2)=LRU(1)
- IF $DATA(C(1))
- IF C(1)'=C(2)
- QUIT
- +3 if '$DATA(^LRO(68,LRAA,1,LRAD,1,N,0))
- QUIT
- SET X=^(0)
- SET LRDFN=+X
- SET A(3)=$PIECE(X,"^",3)
- SET A(7)=$PIECE(X,"^",7)
- if '$DATA(^(3))
- QUIT
- SET X=^(3)
- SET LRI=$PIECE(X,"^",5)
- SET A(3)=$SELECT($PIECE(X,"^",3):$PIECE(X,"^",3),1:A(3))
- +4 SET N(6)=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,N,6)):^(6),1:"")
- IF '$DATA(^LR(LRDFN,0))
- if $Y>(IOSL-8)
- DO H^LRUPA
- if LR("Q")
- QUIT
- WRITE !,$JUSTIFY(N,7),?11,"Entry not in lab results file"
- QUIT
- +5 if LRSS="CY"
- SET Q(2)=Q(2)+N(6)
- SET Q(1)=Q(1)+$PIECE(N(6),"^",2)
- DO V
- if LR("Q")
- QUIT
- if $LENGTH(LRC(5))
- WRITE !,LRC(5),!
- QUIT
- V if $Y>(IOSL-8)
- DO H^LRUPA
- if LR("Q")
- QUIT
- WRITE !
- IF A(3)<LRAD
- WRITE $EXTRACT(A(3),4,5),"/",$EXTRACT(A(3),6,7)
- +1 WRITE ?5,$JUSTIFY(N,5)
- SET (X,Z)=^LR(LRDFN,0)
- SET Y=$PIECE(X,"^",3)
- SET (LRDPF,X)=$PIECE(X,"^",2)
- SET P(0)=$PIECE(^DIC(X,0),"^")
- SET X=^DIC(X,0,"GL")
- +2 SET X=@(X_Y_",0)")
- SET SSN=$PIECE(X,"^",9)
- SET LRP=$PIECE(X,"^")
- DO SSN^LRU
- +3 WRITE ?12
- if P(0)'="PATIENT"
- WRITE "#"
- WRITE $EXTRACT(LRP,1,15),?28,SSN(1),?34,$EXTRACT(A(7),1,5)
- IF LRSS="BB"
- if $Y>(IOSL-8)
- DO H^LRUPA
- if LR("Q")
- QUIT
- WRITE !?7,SSN," ",$PIECE(Z,"^",5)," ",$PIECE(Z,"^",6)
- +4 IF LRSS="AU"
- if '$DATA(^LR(LRDFN,"AU"))
- QUIT
- SET X=^("AU")
- WRITE ?40,$SELECT('$PIECE(X,"^",3):"%",1:"")
- SET Y=+X
- if Y
- DO D^LRU
- WRITE ?42,Y
- QUIT
- +5 IF '$DATA(^LR(LRDFN,LRSS,LRI,0))
- WRITE ?40,"Not in lab results file"
- QUIT
- +6 IF "CYEMSP"[LRSS
- SET X=^LR(LRDFN,LRSS,LRI,0)
- SET C(6)=$SELECT($PIECE(X,"^",12):"*",1:"")
- if '$PIECE(X,"^",3)
- WRITE ?40,"%"
- IF "CYEMSP"[LRSS
- DO O
- if LR("Q")
- QUIT
- if "EMSP"[LRSS
- QUIT
- +7 IF LRSS="CY"
- WRITE ?72,$JUSTIFY(+N(6),5)
- if $PIECE(N(6),"^",2)
- WRITE "b"
- WRITE ?79,C(6)
- QUIT
- +8 IF LRSS="BB"
- SET Y=+^LR(LRDFN,LRSS,LRI,0)
- DO DT^LRU
- WRITE ?40,Y
- SET LRA=Y
- +9 IF '$TEST
- WRITE ?41,$SELECT(C(2)>0&(P(0)="STERILIZER"!(P(0)="ENVIRONMENTAL")):$EXTRACT($PIECE(^LAB(62,C(2),0),"^"),1,14),$DATA(^LAB(61,C(3),0)):$EXTRACT($PIECE(^(0),"^"),1,13),1:"")
- W SET Z(2)=$SELECT($PIECE(^LR(LRDFN,LRSS,LRI,0),"^",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
- +1 QUIT
- L if LR("Q")!($PIECE($GET(^LAB(60,Z,0)),"^",4)="WK")
- QUIT
- +1 if $Y>(IOSL-8)
- DO H
- if LR("Q")
- QUIT
- if A>0
- WRITE !
- IF LRSS="CH"
- IF $PIECE(Z(3),"^",2)=1
- WRITE ?54,"*"
- +2 if A=0
- WRITE ?55,Z(2)
- 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
- +3 ;
- O SET C(4)=0
- FOR B=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 H^LRUPA
- if LR("Q")
- QUIT
- if B>0
- WRITE !
- WRITE ?46,$SELECT($DATA(^LAB(61,C(3),0)):$EXTRACT($PIECE(^(0),"^"),1,23),1:"")
- +1 if LR("Q")
- QUIT
- if B=0
- WRITE ?46,"No SNOMED code"
- QUIT
- +2 ;
- H DO H^LRUPA
- if LR("Q")
- QUIT
- WRITE !
- IF A(3)<LRAD
- WRITE $EXTRACT(A(3),4,5),"/",$EXTRACT(A(3),6,7)
- +1 WRITE ?5,$JUSTIFY(N,5),?12
- if P(0)'="PATIENT"
- WRITE "#"
- WRITE $EXTRACT(LRP,1,20),?28,SSN(1),?34,$EXTRACT(A(7),1,5)
- if LRSS="BB"
- WRITE ?40,LRA
- QUIT
