- 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 Mar 13, 2025@21:11:31 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
