LRAPCUM1 ;VA/AVAMC/REG - AP PATIENT CUM ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**1031,1034**;NOV 1, 1997;Build 188
;
;;VA LR Patche(s): 315
;
EP ; EP
;
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
NEW LRX,BLRTAB,BLREDT ; IHS/MSC/MKK - LR*5.2*1034
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^ICDCODE(LRX,,,1)
. ;
. S LRX=+$G(^LR(LRDFN,LRSS,LRI,3,C,0)),LRX=$$ICDDX^ICDEX(LRX,,,"I") ; IHS/MSC/MKK - LR*5.2*1034
. ;
. S X=$P(LRX,"^",4)
. ; W !,"ICD code: ",$P(LRX,"^",2),?20
. W !,"ICD Code: ",$P(LRX,"^",2)," " S BLRTAB=$X ; IHS/MSC/MKK - LR*5.2*1034
. D:LR(69.2,.05) C^LRUA
. ; W X
. D LINEWRAP^BLRGMENU(BLRTAB,X,(IOM-BLRTAB)-1) W ! ; IHS/MSC/MKK - LR*5.2*1034
. 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
LRAPCUM1 ;VA/AVAMC/REG - AP PATIENT CUM ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1031,1034**;NOV 1, 1997;Build 188
+2 ;
+3 ;;VA LR Patche(s): 315
+4 ;
EP ; EP
+1 ;
+2 IF $Y>LRA(1)!'$Y
DO MORE
IF LRA(2)?1P
QUIT
+3 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
+4 IF LRA(2)?1P
QUIT
+5 WRITE !
+6 ; N LRX
+7 ; IHS/MSC/MKK - LR*5.2*1034
NEW LRX,BLRTAB,BLREDT
+8 FOR C=0:0
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,3,C))
IF 'C
QUIT
Begin DoDot:1
+9 IF $Y>LRA(1)!'$TEST
DO MORE
+10 IF LRA(2)?1P
QUIT
+11 ; S LRX=+^LR(LRDFN,LRSS,LRI,3,C,0),LRX=$$ICDDX^ICDCODE(LRX,,,1)
+12 ;
+13 ; IHS/MSC/MKK - LR*5.2*1034
SET LRX=+$GET(^LR(LRDFN,LRSS,LRI,3,C,0))
SET LRX=$$ICDDX^ICDEX(LRX,,,"I")
+14 ;
+15 SET X=$PIECE(LRX,"^",4)
+16 ; W !,"ICD code: ",$P(LRX,"^",2),?20
+17 ; IHS/MSC/MKK - LR*5.2*1034
WRITE !,"ICD Code: ",$PIECE(LRX,"^",2)," "
SET BLRTAB=$X
+18 IF LR(69.2,.05)
DO C^LRUA
+19 ; W X
+20 ; IHS/MSC/MKK - LR*5.2*1034
DO LINEWRAP^BLRGMENU(BLRTAB,X,(IOM-BLRTAB)-1)
WRITE !
+21 QUIT
End DoDot:1
IF LRA(2)?1P
QUIT
+22 QUIT
+23 ;
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
+3 ;
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
+2 ;
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
+2 ;
MORE DO MORE^LRAPCUM
QUIT
