LRAPD ;AVAMC/REG/WTY - AP DATA ENTRY ;11/27/01
;;5.2;LAB SERVICE;**72,91,259**;Sep 27, 1994
MAIN ;
S:'$D(LRSOP) LRSOP=""
I LRCAPA D G:'$D(X) END
.D @(LRSS_"^LRAPSWK")
S LRD(1)=LRD,LRD=LRD_LRSS_"^LRAPD1",LR("TR")=""
D @LRD
I LRD(1)="P" D Q
.D AK^LRAPDA,END
D ^LRAPDA
D END
Q
A ;also from LRAPOLD,LRAPM,LRAPQAMR,LRAPQAT
S LRDICS="SPCYEM" D ^LRAP Q:'$D(Y)
S LRV=$P($G(^LRO(69.2,LRAA,0)),U,10)
S X=$G(^LAB(69.9,1,11))
S LR("FS")=+X
S LR("DX")=$S(LRSS="SP":$P(X,U,2),LRSS="CY":$P(X,U,3),1:"")
S:LR("DX")="" LR("DX")=$S(LRSS="EM":$P(X,U,4),1:0)
Q
R ;
S Y=$S('X:0,'$D(^LAB(61.5,X,0)):0,'$P(^LAB(61.5,X,0),U,3):0,1:.02)
Q
T ;
S LR(8)=$S('X:0,'$D(^LAB(61,X,0)):0,1:$P(^LAB(61,X,0),U,4))
Q
EN ;Gross Description/Clinical HX
D A
I '$D(Y) D END Q
S LRD=""
D MAIN
Q
EN1 ;Gross Review/Micro Description
D A
I '$D(Y) D END Q
S LRD="M"
D MAIN
Q
EN2 ;Micro Description/SNOMED Coding
D A
I '$D(Y) D END Q
S LRD="B"
D MAIN
Q
EN3 ;Micro Description/ICD9CM Coding
D A
I '$D(Y) D END Q
I '$O(^ICD0(0)) D Q
.W $C(7),!!,"No entries in the ICD DIAGNOSIS File (#80)."
S LRD="A"
D MAIN
Q
EN4 ;Supplementary Report
D A
I '$D(Y) D END Q
S LRD="S"
D MAIN
Q
EN5 ;Special Studies
D A
I '$D(Y) D END Q
S LRD="P"
D MAIN
Q
END ;Clean-up
K DR,LRSFLG,LRREL
D V^LRU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPD 1359 printed Jan 18, 2025@03:07:55 Page 2
LRAPD ;AVAMC/REG/WTY - AP DATA ENTRY ;11/27/01
+1 ;;5.2;LAB SERVICE;**72,91,259**;Sep 27, 1994
MAIN ;
+1 if '$DATA(LRSOP)
SET LRSOP=""
+2 IF LRCAPA
Begin DoDot:1
+3 DO @(LRSS_"^LRAPSWK")
End DoDot:1
if '$DATA(X)
GOTO END
+4 SET LRD(1)=LRD
SET LRD=LRD_LRSS_"^LRAPD1"
SET LR("TR")=""
+5 DO @LRD
+6 IF LRD(1)="P"
Begin DoDot:1
+7 DO AK^LRAPDA
DO END
End DoDot:1
QUIT
+8 DO ^LRAPDA
+9 DO END
+10 QUIT
A ;also from LRAPOLD,LRAPM,LRAPQAMR,LRAPQAT
+1 SET LRDICS="SPCYEM"
DO ^LRAP
if '$DATA(Y)
QUIT
+2 SET LRV=$PIECE($GET(^LRO(69.2,LRAA,0)),U,10)
+3 SET X=$GET(^LAB(69.9,1,11))
+4 SET LR("FS")=+X
+5 SET LR("DX")=$SELECT(LRSS="SP":$PIECE(X,U,2),LRSS="CY":$PIECE(X,U,3),1:"")
+6 if LR("DX")=""
SET LR("DX")=$SELECT(LRSS="EM":$PIECE(X,U,4),1:0)
+7 QUIT
R ;
+1 SET Y=$SELECT('X:0,'$DATA(^LAB(61.5,X,0)):0,'$PIECE(^LAB(61.5,X,0),U,3):0,1:.02)
+2 QUIT
T ;
+1 SET LR(8)=$SELECT('X:0,'$DATA(^LAB(61,X,0)):0,1:$PIECE(^LAB(61,X,0),U,4))
+2 QUIT
EN ;Gross Description/Clinical HX
+1 DO A
+2 IF '$DATA(Y)
DO END
QUIT
+3 SET LRD=""
+4 DO MAIN
+5 QUIT
EN1 ;Gross Review/Micro Description
+1 DO A
+2 IF '$DATA(Y)
DO END
QUIT
+3 SET LRD="M"
+4 DO MAIN
+5 QUIT
EN2 ;Micro Description/SNOMED Coding
+1 DO A
+2 IF '$DATA(Y)
DO END
QUIT
+3 SET LRD="B"
+4 DO MAIN
+5 QUIT
EN3 ;Micro Description/ICD9CM Coding
+1 DO A
+2 IF '$DATA(Y)
DO END
QUIT
+3 IF '$ORDER(^ICD0(0))
Begin DoDot:1
+4 WRITE $CHAR(7),!!,"No entries in the ICD DIAGNOSIS File (#80)."
End DoDot:1
QUIT
+5 SET LRD="A"
+6 DO MAIN
+7 QUIT
EN4 ;Supplementary Report
+1 DO A
+2 IF '$DATA(Y)
DO END
QUIT
+3 SET LRD="S"
+4 DO MAIN
+5 QUIT
EN5 ;Special Studies
+1 DO A
+2 IF '$DATA(Y)
DO END
QUIT
+3 SET LRD="P"
+4 DO MAIN
+5 QUIT
END ;Clean-up
+1 KILL DR,LRSFLG,LRREL
+2 DO V^LRU
+3 QUIT
