- LRBLPC1 ;AVAMC/REG - PT ADM,RX SPECIALTY,ICD9CM CODES ;11/18/91 20:36 ;
- ;;5.2;LAB SERVICE;**247,315**;Sep 27, 1994;Build 25
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- ;Reference to ^DGPT is supported by ICR# 418
- ;Reference to ^DGPM is supported by ICR# 2360
- ;Reference to $$ICDDX^ICDCODE Supported by ICR# 3990
- ;Reference to $$ICDOP^ICDCODE Supported by ICR# 3990
- K LRF,LRC S LRA=$O(^DGPM("APID",DFN,0)) Q:'LRA S LRX=$O(^(LRA,0)) D:$Y>(IOSL-9) H Q:LR("Q") I LRX,$D(^DGPM(LRX,0)) S X=^(0) I $P(X,"^",14),$D(^DGPM($P(X,"^",14),0)) S LRX=$P(X,"^",14) D A ;MAS
- F LRA=LRA:0 S LRA=$O(^DGPM("APID",DFN,LRA)) Q:'LRA!(LRA>LRSDT)!(LR("Q")) S LRX=$O(^(LRA,0)) D:$Y>(IOSL-9) H Q:LR("Q") D:LRX A ;MAS
- Q
- A S Y=$S($D(^DGPM(LRX,0)):^(0),1:""),LR=$P(Y,"^",16) W !,"Adm:",+$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_$E(Y,2,3) S Z=$P(Y,"^",17) I Z S Z=$S($D(^DGPM(Z,0)):+^(0),1:"") W ?13,"Discharge:",+$E(Z,4,5)_"/"_+$E(Z,6,7)_"/"_$E(Z,2,3) ;MAS
- S Z=$P(Y,"^",6) I Z,$D(^DIC(42,Z,0)) W ?35,$P(^(0),"^") ;MAS
- S A=0 F B=0:0 S A=$O(^DGPM("ATS",DFN,LRX,A)) Q:'A!(LR("Q")) S C=$O(^(A,0)) D B Q:LR("Q") ;MAS
- Q:'LR
- I $D(^DGPT(LR,70)),$P(^(70),"^",10) S W=^(70) F X=10,11,16:1:24 I $P(W,"^",X) S LRF($P(W,"^",X))=""
- F Y=0:0 S Y=$O(^DGPT(LR,"M",Y)) Q:'Y S W=^(Y,0) F X=5:1:9,11:1:15 I $P(W,"^",X) S LRF($P(W,"^",X))=""
- I $D(^DGPT(LR,"401P")) S W=^("401P") F X=1:1:5 I $P(W,"^",X) S LRC($P(W,"^",X))=""
- F Y=0:0 S Y=$O(^DGPT(LR,"P",Y)) Q:'Y S W=^(Y,0) F X=5:1:9 I $P(W,"^",X) S LRC($P(W,"^",X))=""
- F Y=0:0 S Y=$O(^DGPT(LR,"S",Y)) Q:'Y S W=^(Y,0) F X=8:1:12 I $P(W,"^",X) S LRC($P(W,"^",X))=""
- N LRTMP,LRX
- F LRTMP=0:0 S LRTMP=$O(LRF(LRTMP)) Q:'LRTMP!(LR("Q")) D
- . S LRX=$$ICDDX^ICDCODE(LRTMP,,,1)
- . I +LRX=-1 Q
- . D:$Y>(IOSL-9) H Q:LR("Q")
- . W !,$P(LRX,"^",2),?10,$P(LRX,"^",4)
- . Q
- F LRTMP=0:0 S LRTMP=$O(LRC(LRTMP)) Q:'LRTMP!(LR("Q")) D
- . S LRX=$$ICDOP^ICDCODE(LRTMP,,,1)
- . I +LRX=-1 Q
- . D:$Y>(IOSL-9) H Q:LR("Q")
- . W !,$P(LRX,"^",2),?10,$P(LRX,"^",5)
- . Q
- Q
- B I C S LRY=9999999.9999999-A D:$Y>(IOSL-9) H Q:LR("Q") W !?12,"Specialty:",+$E(LRY,4,5)_"/"_+$E(LRY,6,7)_"/"_$E(LRY,2,3) I C,$D(^DIC(45.7,C,0)) W ?35,$P(^(0),"^") ;MAS
- Q
- H I $D(LR("D")) D H2^LRBLTXA Q
- D H^LRBLPC Q:LR("Q") W !,W(2),?31,W(10),?45,"DOB: ",W(4),!,LR("%") Q
- ;
- SET K ^LRO(69.2,LRAA,7,DUZ) L +^LRO(69.2,LRAA,7,0):15 S X=^LRO(69.2,LRAA,7,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1) L -^LRO(69.2,LRAA,7,0) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPC1 2484 printed Feb 18, 2025@23:37:36 Page 2
- LRBLPC1 ;AVAMC/REG - PT ADM,RX SPECIALTY,ICD9CM CODES ;11/18/91 20:36 ;
- +1 ;;5.2;LAB SERVICE;**247,315**;Sep 27, 1994;Build 25
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 ;Reference to ^DGPT is supported by ICR# 418
- +4 ;Reference to ^DGPM is supported by ICR# 2360
- +5 ;Reference to $$ICDDX^ICDCODE Supported by ICR# 3990
- +6 ;Reference to $$ICDOP^ICDCODE Supported by ICR# 3990
- +7 ;MAS
- KILL LRF,LRC
- SET LRA=$ORDER(^DGPM("APID",DFN,0))
- if 'LRA
- QUIT
- SET LRX=$ORDER(^(LRA,0))
- if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- IF LRX
- IF $DATA(^DGPM(LRX,0))
- SET X=^(0)
- IF $PIECE(X,"^",14)
- IF $DATA(^DGPM($PIECE(X,"^",14),0))
- SET LRX=$PIECE(X,"^",14)
- DO A
- +8 ;MAS
- FOR LRA=LRA:0
- SET LRA=$ORDER(^DGPM("APID",DFN,LRA))
- if 'LRA!(LRA>LRSDT)!(LR("Q"))
- QUIT
- SET LRX=$ORDER(^(LRA,0))
- if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- if LRX
- DO A
- +9 QUIT
- A ;MAS
- SET Y=$SELECT($DATA(^DGPM(LRX,0)):^(0),1:"")
- SET LR=$PIECE(Y,"^",16)
- WRITE !,"Adm:",+$EXTRACT(Y,4,5)_"/"_+$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
- SET Z=$PIECE(Y,"^",17)
- IF Z
- SET Z=$SELECT($DATA(^DGPM(Z,0)):+^(0),1:"")
- WRITE ?13,"Discharge:",+$EXTRACT(Z,4,5)_"/"_+$EXTRACT(Z,6,7)_"/"_$EXTRACT(Z,2,3)
- +1 ;MAS
- SET Z=$PIECE(Y,"^",6)
- IF Z
- IF $DATA(^DIC(42,Z,0))
- WRITE ?35,$PIECE(^(0),"^")
- +2 ;MAS
- SET A=0
- FOR B=0:0
- SET A=$ORDER(^DGPM("ATS",DFN,LRX,A))
- if 'A!(LR("Q"))
- QUIT
- SET C=$ORDER(^(A,0))
- DO B
- if LR("Q")
- QUIT
- +3 if 'LR
- QUIT
- +4 IF $DATA(^DGPT(LR,70))
- IF $PIECE(^(70),"^",10)
- SET W=^(70)
- FOR X=10,11,16:1:24
- IF $PIECE(W,"^",X)
- SET LRF($PIECE(W,"^",X))=""
- +5 FOR Y=0:0
- SET Y=$ORDER(^DGPT(LR,"M",Y))
- if 'Y
- QUIT
- SET W=^(Y,0)
- FOR X=5:1:9,11:1:15
- IF $PIECE(W,"^",X)
- SET LRF($PIECE(W,"^",X))=""
- +6 IF $DATA(^DGPT(LR,"401P"))
- SET W=^("401P")
- FOR X=1:1:5
- IF $PIECE(W,"^",X)
- SET LRC($PIECE(W,"^",X))=""
- +7 FOR Y=0:0
- SET Y=$ORDER(^DGPT(LR,"P",Y))
- if 'Y
- QUIT
- SET W=^(Y,0)
- FOR X=5:1:9
- IF $PIECE(W,"^",X)
- SET LRC($PIECE(W,"^",X))=""
- +8 FOR Y=0:0
- SET Y=$ORDER(^DGPT(LR,"S",Y))
- if 'Y
- QUIT
- SET W=^(Y,0)
- FOR X=8:1:12
- IF $PIECE(W,"^",X)
- SET LRC($PIECE(W,"^",X))=""
- +9 NEW LRTMP,LRX
- +10 FOR LRTMP=0:0
- SET LRTMP=$ORDER(LRF(LRTMP))
- if 'LRTMP!(LR("Q"))
- QUIT
- Begin DoDot:1
- +11 SET LRX=$$ICDDX^ICDCODE(LRTMP,,,1)
- +12 IF +LRX=-1
- QUIT
- +13 if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- +14 WRITE !,$PIECE(LRX,"^",2),?10,$PIECE(LRX,"^",4)
- +15 QUIT
- End DoDot:1
- +16 FOR LRTMP=0:0
- SET LRTMP=$ORDER(LRC(LRTMP))
- if 'LRTMP!(LR("Q"))
- QUIT
- Begin DoDot:1
- +17 SET LRX=$$ICDOP^ICDCODE(LRTMP,,,1)
- +18 IF +LRX=-1
- QUIT
- +19 if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- +20 WRITE !,$PIECE(LRX,"^",2),?10,$PIECE(LRX,"^",5)
- +21 QUIT
- End DoDot:1
- +22 QUIT
- B ;MAS
- IF C
- SET LRY=9999999.9999999-A
- if $Y>(IOSL-9)
- DO H
- if LR("Q")
- QUIT
- WRITE !?12,"Specialty:",+$EXTRACT(LRY,4,5)_"/"_+$EXTRACT(LRY,6,7)_"/"_$EXTRACT(LRY,2,3)
- IF C
- IF $DATA(^DIC(45.7,C,0))
- WRITE ?35,$PIECE(^(0),"^")
- +1 QUIT
- H IF $DATA(LR("D"))
- DO H2^LRBLTXA
- QUIT
- +1 DO H^LRBLPC
- if LR("Q")
- QUIT
- WRITE !,W(2),?31,W(10),?45,"DOB: ",W(4),!,LR("%")
- QUIT
- +2 ;
- SET KILL ^LRO(69.2,LRAA,7,DUZ)
- LOCK +^LRO(69.2,LRAA,7,0):15
- SET X=^LRO(69.2,LRAA,7,0)
- SET X(1)=$ORDER(^(0))
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
- LOCK -^LRO(69.2,LRAA,7,0)
- QUIT
