- 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 Apr 23, 2025@18:20:56 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
