LRUCN ;AVAMC/REG/CYM - LAB CONSULTS ;2/18/98 12:34 ; [ 05/15/2003 12:31 PM ]
;;5.2T9;LR;**1006,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**203,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
D END W !!?20,"CONSULTATION REPORT"
S DIC=65.9,DIC(0)="AEQMZ",DIC("A")="Select CONSULTATION: ",DIC("S")="I $P(^(0),U,2)=2" D ^DIC K DIC G:Y<1 END S LRL(1)=$P(Y,U,2),LRL=+Y,LRAA=$P(Y(0),U,9) I 'LRAA W $C(7),!,"Must have an accession area for ",LRL(1) G END
S LRSS=$P(^LRO(68,LRAA,0),U,2),LRDPAF=1
PT D ^LRDPA G:LRDFN<1 END
I LRL(1)="DIRECT COOMBS TEST REPORT" D ASK G:LRI<1 END
S ZTRTN="QUE^LRUCN" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO S %DT="",X="T" D ^%DT,D^LRU S LRD=Y D L^LRU,S^LRU,H I '$D(^LAB(65.9,LRL,0)) W !,LRL(1)," entry in LAB LETTER file (#65.9) was deleted." G OUT
D SET D:LRSS="BB" ^LRUCNBB
OUT D END^LRUTL,END Q
H S LRQ=LRQ+1 W @IOF,!!!!,LR("%"),!?5,"CLINICAL RECORD ",LRL(1),?51,"|" W:LRQ>1 ?(IOM-8),"Pg:",LRQ W !?5,LRQ(1),?51,"|" W:$D(LRI) "Specimen:",LRI(1) W !,LR("%") Q
W W !,LR("%") Q
F F X=0:0 Q:$Y>(IOSL-12) W !
D W W !?60,"(",$S($D(LRE):"End of report",1:"See next page"),")",!,LRS,!,LRS(1),?60,LRD
;D W W !,LRP,?40,"LOC: ",LRLLOC,!,"SSN:",SSN,?16,"SEX:",SEX," DOB: ",DOB W:$D(AGE) " AGE:",AGE W !
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D W W !,LRP,?40,"LOC: ",LRLLOC,!,"HRCN:",HRCN,?16,"SEX:",SEX," DOB: ",DOB W:$D(AGE) " AGE:",AGE W ! ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
W:$L(LRADM) "ADM:",$E(LRADM,1,12) W:$D(LRADX) ?17,"DX:",$E(LRADX,1,28) W:$L(LRMD) ?46,LRMD Q
SET S X=^LAB(65.9,LRL,0),DIWL=$S($P(X,U,5):$P(X,U,5),1:5),DIWR=IOM-$P(X,U,6),DIWF=$S($P(X,U,7):"D",1:""),DIWF=DIWF_$S($P(X,U,8):"R",1:"")
S X=$S($D(^LAB(65.9,LRL,3)):^(3),1:""),LRS=$P(X,"^"),LRS(1)=$P(X,"^",2) Q
ASK ;I '$O(^LR(LRDFN,LRSS,0)) S LRI=-1 W $C(7),!!,"There are no specimen dates for ",LRP," ",SSN Q
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
I '$O(^LR(LRDFN,LRSS,0)) S LRI=-1 W $C(7),!!,"There are no specimen dates for ",LRP," ",HRCN Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
K DIC S DIC="^LR(LRDFN,LRSS,",DIC(0)="AEQM" D ^DIC K DIC S LRI=+Y,Y=$P(Y,U,2),LRI(1)=$$FMTE^XLFDT(Y,"M") Q
END D V^LRU Q
LRUCN ;AVAMC/REG/CYM - LAB CONSULTS ;2/18/98 12:34 ; [ 05/15/2003 12:31 PM ]
+1 ;;5.2T9;LR;**1006,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**203,247**;Sep 27, 1994
+3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+4 DO END
WRITE !!?20,"CONSULTATION REPORT"
+5 SET DIC=65.9
SET DIC(0)="AEQMZ"
SET DIC("A")="Select CONSULTATION: "
SET DIC("S")="I $P(^(0),U,2)=2"
DO ^DIC
KILL DIC
IF Y<1
GOTO END
SET LRL(1)=$PIECE(Y,U,2)
SET LRL=+Y
SET LRAA=$PIECE(Y(0),U,9)
IF 'LRAA
WRITE $CHAR(7),!,"Must have an accession area for ",LRL(1)
GOTO END
+6 SET LRSS=$PIECE(^LRO(68,LRAA,0),U,2)
SET LRDPAF=1
PT DO ^LRDPA
IF LRDFN<1
GOTO END
+1 IF LRL(1)="DIRECT COOMBS TEST REPORT"
DO ASK
IF LRI<1
GOTO END
+2 SET ZTRTN="QUE^LRUCN"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
SET %DT=""
SET X="T"
DO ^%DT
DO D^LRU
SET LRD=Y
DO L^LRU
DO S^LRU
DO H
IF '$DATA(^LAB(65.9,LRL,0))
WRITE !,LRL(1)," entry in LAB LETTER file (#65.9) was deleted."
GOTO OUT
+1 DO SET
IF LRSS="BB"
DO ^LRUCNBB
OUT DO END^LRUTL
DO END
QUIT
H SET LRQ=LRQ+1
WRITE @IOF,!!!!,LR("%"),!?5,"CLINICAL RECORD ",LRL(1),?51,"|"
IF LRQ>1
WRITE ?(IOM-8),"Pg:",LRQ
WRITE !?5,LRQ(1),?51,"|"
IF $DATA(LRI)
WRITE "Specimen:",LRI(1)
WRITE !,LR("%")
QUIT
W WRITE !,LR("%")
QUIT
F FOR X=0:0
IF $Y>(IOSL-12)
QUIT
WRITE !
+1 DO W
WRITE !?60,"(",$SELECT($DATA(LRE):"End of report",1:"See next page"),")",!,LRS,!,LRS(1),?60,LRD
+2 ;D W W !,LRP,?40,"LOC: ",LRLLOC,!,"SSN:",SSN,?16,"SEX:",SEX," DOB: ",DOB W:$D(AGE) " AGE:",AGE W !
+3 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+4 ;IHS/ANMC/CLS 08/18/96
DO W
WRITE !,LRP,?40,"LOC: ",LRLLOC,!,"HRCN:",HRCN,?16,"SEX:",SEX," DOB: ",DOB
IF $DATA(AGE)
WRITE " AGE:",AGE
WRITE !
+5 ;----- END IHS MODIFICATIONS
+6 IF $LENGTH(LRADM)
WRITE "ADM:",$EXTRACT(LRADM,1,12)
IF $DATA(LRADX)
WRITE ?17,"DX:",$EXTRACT(LRADX,1,28)
IF $LENGTH(LRMD)
WRITE ?46,LRMD
QUIT
SET SET X=^LAB(65.9,LRL,0)
SET DIWL=$SELECT($PIECE(X,U,5):$PIECE(X,U,5),1:5)
SET DIWR=IOM-$PIECE(X,U,6)
SET DIWF=$SELECT($PIECE(X,U,7):"D",1:"")
SET DIWF=DIWF_$SELECT($PIECE(X,U,8):"R",1:"")
+1 SET X=$SELECT($DATA(^LAB(65.9,LRL,3)):^(3),1:"")
SET LRS=$PIECE(X,"^")
SET LRS(1)=$PIECE(X,"^",2)
QUIT
ASK ;I '$O(^LR(LRDFN,LRSS,0)) S LRI=-1 W $C(7),!!,"There are no specimen dates for ",LRP," ",SSN Q
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;IHS/ANMC/CLS 08/18/96
IF '$ORDER(^LR(LRDFN,LRSS,0))
SET LRI=-1
WRITE $CHAR(7),!!,"There are no specimen dates for ",LRP," ",HRCN
QUIT
+3 ;----- END IHS MODIFICATIONS
+4 KILL DIC
SET DIC="^LR(LRDFN,LRSS,"
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
SET LRI=+Y
SET Y=$PIECE(Y,U,2)
SET LRI(1)=$$FMTE^XLFDT(Y,"M")
QUIT
END DO V^LRU
QUIT
