LRAPCUM1 ;AVAMC/REG - AP PATIENT CUM ;7/15/93 10:36
;;5.2;LAB SERVICE;**315,422**;Sep 27, 1994;Build 29
;
; Reference to $$ICDDX^ICDEX supported by ICR #5747
;
D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P
W !,LR("%"),!,"SNOMED/ICD codes:" F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,2,C)) Q:'C S T=+^(C,0),T=^LAB(61,T,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !,"T-",$P(T,"^",2),": " S X=$P(T,"^") D:LR(69.2,.05) C^LRUA W X D M
Q:LRA(2)?1P
W !
N LRX
F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,3,C)) Q:'C D Q:LRA(2)?1P
. D:$Y>LRA(1)!'$T MORE
. Q:LRA(2)?1P
. S LRX=+^LR(LRDFN,LRSS,LRI,3,C,0),LRX=$$ICDDX^ICDEX(LRX,,,"I")
. S X=$P(LRX,"^",4)
. W !,"ICD code: ",$P(LRX,"^",2),?20
. D:LR(69.2,.05) C^LRUA
. W X
. Q
Q
M F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,2,C,2,B)) Q:'B S M=+^(B,0),M=^LAB(61.1,M,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !?5,"M-",$P(M,"^",2),": " S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X D EX
Q:LRA(2)?1P F B=1.4,3.3,4.5 F F=0:0 S F=$O(^LR(LRDFN,LRSS,LRI,2,C,$P(B,"."),F)) Q:'F D A
Q
A S M=+^LR(LRDFN,LRSS,LRI,2,C,$P(B,"."),F,0),E="61."_$P(B,".",2),M=^LAB(E,M,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !?5,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$P(M,"^",2),?12,": " S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X
Q
EX F G=0:0 S G=$O(^LR(LRDFN,LRSS,LRI,2,C,2,B,1,G)) Q:'G S E=+^(G,0),E=^LAB(61.2,E,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !?10,"E-",$P(E,"^",2),": " S X=$P(E,"^") D:LR(69.2,.05) C^LRUA W X
Q
MORE D MORE^LRAPCUM Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPCUM1 1451 printed Apr 09, 2024@21:11:40 Page 2
LRAPCUM1 ;AVAMC/REG - AP PATIENT CUM ;7/15/93 10:36
+1 ;;5.2;LAB SERVICE;**315,422**;Sep 27, 1994;Build 29
+2 ;
+3 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+4 ;
+5 if $Y>LRA(1)!'$Y
DO MORE
if LRA(2)?1P
QUIT
+6 WRITE !,LR("%"),!,"SNOMED/ICD codes:"
FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,C))
if 'C
QUIT
SET T=+^(C,0)
SET T=^LAB(61,T,0)
if $Y>LRA(1)!'$Y
DO MORE
if LRA(2)?1P
QUIT
WRITE !,"T-",$PIECE(T,"^",2),": "
SET X=$PIECE(T,"^")
if LR(69.2,.05)
DO C^LRUA
WRITE X
DO M
+7 if LRA(2)?1P
QUIT
+8 WRITE !
+9 NEW LRX
+10 FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,3,C))
if 'C
QUIT
Begin DoDot:1
+11 if $Y>LRA(1)!'$TEST
DO MORE
+12 if LRA(2)?1P
QUIT
+13 SET LRX=+^LR(LRDFN,LRSS,LRI,3,C,0)
SET LRX=$$ICDDX^ICDEX(LRX,,,"I")
+14 SET X=$PIECE(LRX,"^",4)
+15 WRITE !,"ICD code: ",$PIECE(LRX,"^",2),?20
+16 if LR(69.2,.05)
DO C^LRUA
+17 WRITE X
+18 QUIT
End DoDot:1
if LRA(2)?1P
QUIT
+19 QUIT
M FOR B=0:0
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,2,B))
if 'B
QUIT
SET M=+^(B,0)
SET M=^LAB(61.1,M,0)
if $Y>LRA(1)!'$Y
DO MORE
if LRA(2)?1P
QUIT
WRITE !?5,"M-",$PIECE(M,"^",2),": "
SET X=$PIECE(M,"^")
if LR(69.2,.05)
DO C^LRUA
WRITE X
DO EX
+1 if LRA(2)?1P
QUIT
FOR B=1.4,3.3,4.5
FOR F=0:0
SET F=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,$PIECE(B,"."),F))
if 'F
QUIT
DO A
+2 QUIT
A SET M=+^LR(LRDFN,LRSS,LRI,2,C,$PIECE(B,"."),F,0)
SET E="61."_$PIECE(B,".",2)
SET M=^LAB(E,M,0)
if $Y>LRA(1)!'$Y
DO MORE
if LRA(2)?1P
QUIT
WRITE !?5,$SELECT(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$PIECE(M,"^",2),?12,": "
SET X=$PIECE(M,"^")
if LR(69.2,.05)
DO C^LRUA
WRITE X
+1 QUIT
EX FOR G=0:0
SET G=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,2,B,1,G))
if 'G
QUIT
SET E=+^(G,0)
SET E=^LAB(61.2,E,0)
if $Y>LRA(1)!'$Y
DO MORE
if LRA(2)?1P
QUIT
WRITE !?10,"E-",$PIECE(E,"^",2),": "
SET X=$PIECE(E,"^")
if LR(69.2,.05)
DO C^LRUA
WRITE X
+1 QUIT
MORE DO MORE^LRAPCUM
QUIT
