- LRUCN ;AVAMC/REG/CYM - LAB CONSULTS ;2/18/98 12:34 ;
- ;;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 !
- 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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUCN 1772 printed Feb 18, 2025@23:47:13 Page 2
- LRUCN ;AVAMC/REG/CYM - LAB CONSULTS ;2/18/98 12:34 ;
- +1 ;;5.2;LAB SERVICE;**203,247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 DO END
- WRITE !!?20,"CONSULTATION REPORT"
- +4 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
- +5 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 DO W
- WRITE !,LRP,?40,"LOC: ",LRLLOC,!,"SSN:",SSN,?16,"SEX:",SEX," DOB: ",DOB
- if $DATA(AGE)
- WRITE " AGE:",AGE
- WRITE !
- +3 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 IF '$ORDER(^LR(LRDFN,LRSS,0))
- SET LRI=-1
- WRITE $CHAR(7),!!,"There are no specimen dates for ",LRP," ",SSN
- QUIT
- +1 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
