LRAPBK1 ;DALOI/STAFF - AP LOG BOOK ;Dec 19 , 2007
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
;
N LRSCT,LRX
;
F Z=0:0 S Z=$O(^LR(LRDFN,LRSS,LRI,2,Z)) Q:'Z D
. S LRT=+^LR(LRDFN,LRSS,LRI,2,Z,0)
. D:$Y>(IOSL-6) H1^LRAPBK Q:LR("Q")
. S X=$G(^LAB(61,LRT,0),"?")
. I LRPSNM?1(1"1",1"3") W !?14,"T-",$P(X,"^",2)," (SNM) ",$P(X,"^")
. I LRPSNM>1 D
. . S LRSCT=$$IEN2SCT^LA7VHLU6(61,LRT,DT,"")
. . I LRSCT'="" W !,?14,$S(LRPSNM=2:"Topography: ",1:""),$P(LRSCT,"^")," (",$P(LRSCT,"^",3),") ",$P(LRSCT,"^",2)
. D M
Q
;
;
M ;
S LRM=0
F S LRM=$O(^LR(LRDFN,LRSS,LRI,2,Z,2,LRM)) Q:'LRM!(LR("Q")) D
. S X=+^LR(LRDFN,LRSS,LRI,2,Z,2,LRM,0),LRM(1)=$S($D(^LAB(61.1,X,0)):^(0),1:"?")
. D:$Y>(IOSL-6) H1^LRAPBK
. W !?17,"M-",$P(LRM(1),"^",2)," ",$P(LRM(1),"^")
. I LRB=1 D E
;
I LRB=2 Q
;
S J=0
F S J=$O(^LR(LRDFN,LRSS,LRI,2,Z,4,J)) Q:'J!(LR("Q")) D
. S LRX=^LR(LRDFN,LRSS,LRI,2,Z,4,J,0),LRX(1)=$P(LRX,"^",2)
. D:$Y>(IOSL-6) H1^LRAPBK
. S X=$S($D(^LAB(61.5,+LRX,0)):^(0),1:"?")
. W !?17,"P-",$P(X,"^",2)," ",$P(X,"^")
. I LRX(1)'="" D W
;
S LRM=0
F S LRM=$O(^LR(LRDFN,LRSS,LRI,2,Z,1,LRM)) Q:'LRM!(LR("Q")) D
. S X=+^LR(LRDFN,LRSS,LRI,2,Z,1,LRM,0),LRM(1)=$G(^LAB(61.4,X,0),"?")
. D:$Y>(IOSL-6) H1^LRAPBK
. W !?17,"D-",$P(LRM(1),"^",2)," ",$P(LRM(1),"^")
;
S LRM=0
F S LRM=$O(^LR(LRDFN,LRSS,LRI,2,Z,3,LRM)) Q:'LRM!(LR("Q")) D
. S X=+^LR(LRDFN,LRSS,LRI,2,Z,3,LRM,0),LRM(1)=$G(^LAB(61.3,X,0),"?")
. D:$Y>(IOSL-6) H1^LRAPBK
. W !?17,"F-",$P(LRM(1),"^",2)," ",$P(LRM(1),"^")
Q
;
;
E ;
S LRE=0
F S LRE=$O(^LR(LRDFN,LRSS,LRI,2,Z,2,LRM,1,LRE)) Q:'LRE D
. S LRX=+^LR(LRDFN,LRSS,LRI,2,Z,2,LRM,1,LRE,0),LRE(1)=$G(^LAB(61.2,LRX,0),"?")
. I LRPSNM?1(1"1",1"3") W !?20,"E-",$P(LRE(1),"^",2)," (SNM) ",$P(LRE(1),"^")
. I LRPSNM>1 D
. . S LRSCT=$$IEN2SCT^LA7VHLU6(61.2,LRX,DT,"")
. . I LRSCT'="" W !,?20,$S(LRPSNM=2:"Etiology: ",1:""),$P(LRSCT,"^")," (",$P(LRSCT,"^",3),") ",$P(LRSCT,"^",2)
Q
;
;
AU ;
S Z=0
F S Z=$O(^LR(LRDFN,"AY",Z)) Q:'Z D
. S LRT=+^(Z,0)
. D:$Y>(IOSL-6) H1^LRAPBK Q:LR("Q")
. S X=$S($D(^LAB(61,LRT,0)):^(0),1:"?")
. W !?14,"T-",$P(X,"^",2)," ",$P(X,"^")
. D MA
Q
;
;
MA ;
S LRM=0
F S LRM=$O(^LR(LRDFN,"AY",Z,2,LRM)) Q:'LRM!(LR("Q")) D
. S X=+^LR(LRDFN,"AY",Z,2,LRM,0),LRM(1)=$S($D(^LAB(61.1,X,0)):^(0),1:"?")
. D:$Y>(IOSL-6) H1^LRAPBK
. W !?17,"M-",$P(LRM(1),"^",2)," ",$P(LRM(1),"^")
. I LRB=1 D EA
;
I LRB=2 Q
;
S J=0
F S J=$O(^LR(LRDFN,"AY",Z,4,J)) Q:'J!(LR("Q")) D
. S LRX=^LR(LRDFN,"AY",Z,4,J,0),LRX(1)=$P(LRX,"^")
. D:$Y>(IOSL-6) H1^LRAPBK
. S X=$S($D(^LAB(61.5,+LRX,0)):^(0),1:"?")
. W !?17,"P-",$P(X,"^",2)," ",$P(X,"^")
. D:LRX(1)]"" W
;
S LRM=0
F S LRM=$O(^LR(LRDFN,"AY",Z,1,LRM)) Q:'LRM!(LR("Q")) D
. S X=+^LR(LRDFN,"AY",Z,1,LRM,0),LRM(1)=$S($D(^LAB(61.4,X,0)):^(0),1:"?")
. D:$Y>(IOSL-6) H1^LRAPBK
. W !?17,"D-",$P(LRM(1),"^",2)," ",$P(LRM(1),"^")
;
S LRM=0
F S LRM=$O(^LR(LRDFN,"AY",Z,3,LRM)) Q:'LRM!(LR("Q")) D
. S X=+^LR(LRDFN,"AY",Z,3,LRM,0),LRM(1)=$S($D(^LAB(61.3,X,0)):^(0),1:"?")
. D:$Y>(IOSL-6) H1^LRAPBK
. W !?17,"F-",$P(LRM(1),"^",2)," ",$P(LRM(1),"^")
Q
;
;
EA ;
S LRE=0
F S LRE=$O(^LR(LRDFN,"AY",Z,2,LRM,1,LRE)) Q:'LRE D
. S LRX=+^LR(LRDFN,"AY",Z,2,LRM,1,LRE,0),LRE(1)=$G(^LAB(61.2,LRX,0),"?")
. I LRPSNM?1(1"1",1"3") W !?20,"E-",$P(LRE(1),"^",2)," (SNM) ",$P(LRE(1),"^")
. I LRPSNM>1 D
. . S LRSCT=$$IEN2SCT^LA7VHLU6(61.2,LRX,DT,"")
. . I LRSCT'="" W !,?20,$S(LRPSNM=2:"Etiology: ",1:""),$P(LRSCT,"^")," (",$P(LRSCT,"^",3),") ",$P(LRSCT,"^",2)
Q
;
;
W ;
W " (",$S(LRX(1)=1:"Positive",LRX(1)=0:"Negative",1:"?"),")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPBK1 3689 printed Sep 23, 2025@19:42:37 Page 2
LRAPBK1 ;DALOI/STAFF - AP LOG BOOK ;Dec 19 , 2007
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 ;
+4 NEW LRSCT,LRX
+5 ;
+6 FOR Z=0:0
SET Z=$ORDER(^LR(LRDFN,LRSS,LRI,2,Z))
if 'Z
QUIT
Begin DoDot:1
+7 SET LRT=+^LR(LRDFN,LRSS,LRI,2,Z,0)
+8 if $Y>(IOSL-6)
DO H1^LRAPBK
if LR("Q")
QUIT
+9 SET X=$GET(^LAB(61,LRT,0),"?")
+10 IF LRPSNM?1(1"1",1"3")
WRITE !?14,"T-",$PIECE(X,"^",2)," (SNM) ",$PIECE(X,"^")
+11 IF LRPSNM>1
Begin DoDot:2
+12 SET LRSCT=$$IEN2SCT^LA7VHLU6(61,LRT,DT,"")
+13 IF LRSCT'=""
WRITE !,?14,$SELECT(LRPSNM=2:"Topography: ",1:""),$PIECE(LRSCT,"^")," (",$PIECE(LRSCT,"^",3),") ",$PIECE(LRSCT,"^",2)
End DoDot:2
+14 DO M
End DoDot:1
+15 QUIT
+16 ;
+17 ;
M ;
+1 SET LRM=0
+2 FOR
SET LRM=$ORDER(^LR(LRDFN,LRSS,LRI,2,Z,2,LRM))
if 'LRM!(LR("Q"))
QUIT
Begin DoDot:1
+3 SET X=+^LR(LRDFN,LRSS,LRI,2,Z,2,LRM,0)
SET LRM(1)=$SELECT($DATA(^LAB(61.1,X,0)):^(0),1:"?")
+4 if $Y>(IOSL-6)
DO H1^LRAPBK
+5 WRITE !?17,"M-",$PIECE(LRM(1),"^",2)," ",$PIECE(LRM(1),"^")
+6 IF LRB=1
DO E
End DoDot:1
+7 ;
+8 IF LRB=2
QUIT
+9 ;
+10 SET J=0
+11 FOR
SET J=$ORDER(^LR(LRDFN,LRSS,LRI,2,Z,4,J))
if 'J!(LR("Q"))
QUIT
Begin DoDot:1
+12 SET LRX=^LR(LRDFN,LRSS,LRI,2,Z,4,J,0)
SET LRX(1)=$PIECE(LRX,"^",2)
+13 if $Y>(IOSL-6)
DO H1^LRAPBK
+14 SET X=$SELECT($DATA(^LAB(61.5,+LRX,0)):^(0),1:"?")
+15 WRITE !?17,"P-",$PIECE(X,"^",2)," ",$PIECE(X,"^")
+16 IF LRX(1)'=""
DO W
End DoDot:1
+17 ;
+18 SET LRM=0
+19 FOR
SET LRM=$ORDER(^LR(LRDFN,LRSS,LRI,2,Z,1,LRM))
if 'LRM!(LR("Q"))
QUIT
Begin DoDot:1
+20 SET X=+^LR(LRDFN,LRSS,LRI,2,Z,1,LRM,0)
SET LRM(1)=$GET(^LAB(61.4,X,0),"?")
+21 if $Y>(IOSL-6)
DO H1^LRAPBK
+22 WRITE !?17,"D-",$PIECE(LRM(1),"^",2)," ",$PIECE(LRM(1),"^")
End DoDot:1
+23 ;
+24 SET LRM=0
+25 FOR
SET LRM=$ORDER(^LR(LRDFN,LRSS,LRI,2,Z,3,LRM))
if 'LRM!(LR("Q"))
QUIT
Begin DoDot:1
+26 SET X=+^LR(LRDFN,LRSS,LRI,2,Z,3,LRM,0)
SET LRM(1)=$GET(^LAB(61.3,X,0),"?")
+27 if $Y>(IOSL-6)
DO H1^LRAPBK
+28 WRITE !?17,"F-",$PIECE(LRM(1),"^",2)," ",$PIECE(LRM(1),"^")
End DoDot:1
+29 QUIT
+30 ;
+31 ;
E ;
+1 SET LRE=0
+2 FOR
SET LRE=$ORDER(^LR(LRDFN,LRSS,LRI,2,Z,2,LRM,1,LRE))
if 'LRE
QUIT
Begin DoDot:1
+3 SET LRX=+^LR(LRDFN,LRSS,LRI,2,Z,2,LRM,1,LRE,0)
SET LRE(1)=$GET(^LAB(61.2,LRX,0),"?")
+4 IF LRPSNM?1(1"1",1"3")
WRITE !?20,"E-",$PIECE(LRE(1),"^",2)," (SNM) ",$PIECE(LRE(1),"^")
+5 IF LRPSNM>1
Begin DoDot:2
+6 SET LRSCT=$$IEN2SCT^LA7VHLU6(61.2,LRX,DT,"")
+7 IF LRSCT'=""
WRITE !,?20,$SELECT(LRPSNM=2:"Etiology: ",1:""),$PIECE(LRSCT,"^")," (",$PIECE(LRSCT,"^",3),") ",$PIECE(LRSCT,"^",2)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
+10 ;
AU ;
+1 SET Z=0
+2 FOR
SET Z=$ORDER(^LR(LRDFN,"AY",Z))
if 'Z
QUIT
Begin DoDot:1
+3 SET LRT=+^(Z,0)
+4 if $Y>(IOSL-6)
DO H1^LRAPBK
if LR("Q")
QUIT
+5 SET X=$SELECT($DATA(^LAB(61,LRT,0)):^(0),1:"?")
+6 WRITE !?14,"T-",$PIECE(X,"^",2)," ",$PIECE(X,"^")
+7 DO MA
End DoDot:1
+8 QUIT
+9 ;
+10 ;
MA ;
+1 SET LRM=0
+2 FOR
SET LRM=$ORDER(^LR(LRDFN,"AY",Z,2,LRM))
if 'LRM!(LR("Q"))
QUIT
Begin DoDot:1
+3 SET X=+^LR(LRDFN,"AY",Z,2,LRM,0)
SET LRM(1)=$SELECT($DATA(^LAB(61.1,X,0)):^(0),1:"?")
+4 if $Y>(IOSL-6)
DO H1^LRAPBK
+5 WRITE !?17,"M-",$PIECE(LRM(1),"^",2)," ",$PIECE(LRM(1),"^")
+6 IF LRB=1
DO EA
End DoDot:1
+7 ;
+8 IF LRB=2
QUIT
+9 ;
+10 SET J=0
+11 FOR
SET J=$ORDER(^LR(LRDFN,"AY",Z,4,J))
if 'J!(LR("Q"))
QUIT
Begin DoDot:1
+12 SET LRX=^LR(LRDFN,"AY",Z,4,J,0)
SET LRX(1)=$PIECE(LRX,"^")
+13 if $Y>(IOSL-6)
DO H1^LRAPBK
+14 SET X=$SELECT($DATA(^LAB(61.5,+LRX,0)):^(0),1:"?")
+15 WRITE !?17,"P-",$PIECE(X,"^",2)," ",$PIECE(X,"^")
+16 if LRX(1)]""
DO W
End DoDot:1
+17 ;
+18 SET LRM=0
+19 FOR
SET LRM=$ORDER(^LR(LRDFN,"AY",Z,1,LRM))
if 'LRM!(LR("Q"))
QUIT
Begin DoDot:1
+20 SET X=+^LR(LRDFN,"AY",Z,1,LRM,0)
SET LRM(1)=$SELECT($DATA(^LAB(61.4,X,0)):^(0),1:"?")
+21 if $Y>(IOSL-6)
DO H1^LRAPBK
+22 WRITE !?17,"D-",$PIECE(LRM(1),"^",2)," ",$PIECE(LRM(1),"^")
End DoDot:1
+23 ;
+24 SET LRM=0
+25 FOR
SET LRM=$ORDER(^LR(LRDFN,"AY",Z,3,LRM))
if 'LRM!(LR("Q"))
QUIT
Begin DoDot:1
+26 SET X=+^LR(LRDFN,"AY",Z,3,LRM,0)
SET LRM(1)=$SELECT($DATA(^LAB(61.3,X,0)):^(0),1:"?")
+27 if $Y>(IOSL-6)
DO H1^LRAPBK
+28 WRITE !?17,"F-",$PIECE(LRM(1),"^",2)," ",$PIECE(LRM(1),"^")
End DoDot:1
+29 QUIT
+30 ;
+31 ;
EA ;
+1 SET LRE=0
+2 FOR
SET LRE=$ORDER(^LR(LRDFN,"AY",Z,2,LRM,1,LRE))
if 'LRE
QUIT
Begin DoDot:1
+3 SET LRX=+^LR(LRDFN,"AY",Z,2,LRM,1,LRE,0)
SET LRE(1)=$GET(^LAB(61.2,LRX,0),"?")
+4 IF LRPSNM?1(1"1",1"3")
WRITE !?20,"E-",$PIECE(LRE(1),"^",2)," (SNM) ",$PIECE(LRE(1),"^")
+5 IF LRPSNM>1
Begin DoDot:2
+6 SET LRSCT=$$IEN2SCT^LA7VHLU6(61.2,LRX,DT,"")
+7 IF LRSCT'=""
WRITE !,?20,$SELECT(LRPSNM=2:"Etiology: ",1:""),$PIECE(LRSCT,"^")," (",$PIECE(LRSCT,"^",3),") ",$PIECE(LRSCT,"^",2)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
+10 ;
W ;
+1 WRITE " (",$SELECT(LRX(1)=1:"Positive",LRX(1)=0:"Negative",1:"?"),")"
+2 QUIT
