- LRBLJI ; IHS/DIR/FJE - CHECK FILE ENTRIES 2/18/93 09:14 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- D END W !!?17,"Check inventory file entries for missing data.",!!
- S ZTRTN="QUE^LRBLJI" D BEG^LRUTL G:POP!($D(ZTSK)) END D QUE W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC Q
- QUE U IO S:$D(ZTQUEUED) ZTREQ="@"
- D L^LRU,S^LRU,H S LR("F")=1 F LRI=0:0 S LRI=$O(^LRD(65,LRI)) Q:'LRI!(LR("Q")) K LRB S W=$S($D(^(LRI,0)):^(0),1:"?"),W(4)=$S($D(^(4)):^(4),1:"") D C
- D K W !!,"Done." W !! W:$E(IOST,1,2)="P-" @IOF D END^LRUTL,END Q
- C S LR=$P(W,"^") I LR="?" W !,"IFN: ",LRI," 0th subscript missing- Database degradation!" Q
- I $L(LR)>4 F X(1)=2:1:4 I $A($E(LR,X(1)))>64 S ^LRD(65,"C",$E(LR,X(1),$L(LR)),LRI)="" Q
- I '$D(^LRD(65,"B",LR,LRI)) S ^LRD(65,"B",LR,LRI)="" D W Q:LR("Q") W !,"""B"" Cross reference required re-setting"
- I $P(W,"^",2)="" D W Q:LR("Q") W !,"SOURCE missing"
- I '$P(W,"^",5) D W Q:LR("Q") W !,"DATE/TIME RECEIVED missing"
- I $P(W,"^",3)="" D W Q:LR("Q") W !,"INVOICE# missing"
- I '$P(W,"^",6) D W Q:LR("Q") W !,"EXPIRATION DATE/TIME missing"
- I $P(W(4),"^",2),$P(W(4),"^")="" D W Q:LR("Q") W !,"DISPOSITION DATE present but DISPOSITION missing" Q
- Q:$P(W(4),"^")="" I '$P(W(4),"^",2) D W Q:LR("Q") W !,"DISPOSITION DATE missing"
- I $P(W(4),"^",3)="" D W Q:LR("Q") W !,"DISPOSITION ENTERING PERSON missing"
- I $P(W(4),"^")="MO",$O(^LRD(65,LRI,9,0))="" D W Q:LR("Q") W !,"MODIFIED TO/FROM missing" Q
- S X=+$P(W,"^",4),X=$S($D(^LAB(66,X,0)):$P(^(0),"^",27),1:"") I X,$P(W,"^",2)="SELF",$O(^LRD(65,LRI,9,0))="" D W Q:LR("Q") W !,"MODIFIED TO/FROM missing"
- Q
- W D:$Y>(IOSL-6) H Q:LR("Q") Q:$D(LRB) W !,LR("%"),!,"(IFN:",LRI,") Unit ID: ",LR,?39 S LRB=1,X=$P(W,"^",4),X=$S('X:"",$D(^LAB(66,X,0)):$P(^(0),"^"),1:"") W:X]"" X I X="" W "Component missing"
- Q
- K S X=0 F LRA=0:0 S X=$O(^LRD(65,"B",X)) Q:X="" F DA=0:0 S DA=$O(^LRD(65,"B",X,DA)) Q:'DA K:'$D(^LRD(65,DA,0)) ^LRD(65,"B",X,DA) I $D(^LRD(65,DA,0)) D:X'=$P(^(0),"^") D
- S X=0 F LRA=0:0 S X=$O(^LRD(65,"C",X)) Q:X="" F DA=0:0 S DA=$O(^LRD(65,"C",X,DA)) Q:'DA K:'$D(^LRD(65,DA,0)) ^LRD(65,"C",X,DA)
- Q
- D F LRF=1,2,3 X:$D(^DD(65,.01,1,LRF,2)) ^(2)
- S Y=^LRD(65,DA,0),S=$P(Y,"^",2),C=$P(Y,"^",4) I C,S]"" S Y=$O(^LAB(66,C,"SU","B",S,0)) S:Y Y=$L($P(^LAB(66,C,"SU",Y,0),"^",10)) K:Y ^LRD(65,"C",$E(X,Y+1,$L(X)),DA)
- Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !?20,"Missing data from Blood Bank Inventory File",!,LR("%") Q
- ;
- END D V^LRU Q
- LRCKF ; Entry point for check all laboratory files option Routine LRCKF
- D END G QUE
- LRBLJI ; IHS/DIR/FJE - CHECK FILE ENTRIES 2/18/93 09:14 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 DO END
- WRITE !!?17,"Check inventory file entries for missing data.",!!
- +5 SET ZTRTN="QUE^LRBLJI"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- DO QUE
- WRITE !!
- IF $EXTRACT(IOST,1,2)="P-"
- WRITE @IOF
- DO ^%ZISC
- QUIT
- QUE USE IO
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 DO L^LRU
- DO S^LRU
- DO H
- SET LR("F")=1
- FOR LRI=0:0
- SET LRI=$ORDER(^LRD(65,LRI))
- IF 'LRI!(LR("Q"))
- QUIT
- KILL LRB
- SET W=$SELECT($DATA(^(LRI,0)):^(0),1:"?")
- SET W(4)=$SELECT($DATA(^(4)):^(4),1:"")
- DO C
- +2 DO K
- WRITE !!,"Done."
- WRITE !!
- IF $EXTRACT(IOST,1,2)="P-"
- WRITE @IOF
- DO END^LRUTL
- DO END
- QUIT
- C SET LR=$PIECE(W,"^")
- IF LR="?"
- WRITE !,"IFN: ",LRI," 0th subscript missing- Database degradation!"
- QUIT
- +1 IF $LENGTH(LR)>4
- FOR X(1)=2:1:4
- IF $ASCII($EXTRACT(LR,X(1)))>64
- SET ^LRD(65,"C",$EXTRACT(LR,X(1),$LENGTH(LR)),LRI)=""
- QUIT
- +2 IF '$DATA(^LRD(65,"B",LR,LRI))
- SET ^LRD(65,"B",LR,LRI)=""
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"""B"" Cross reference required re-setting"
- +3 IF $PIECE(W,"^",2)=""
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"SOURCE missing"
- +4 IF '$PIECE(W,"^",5)
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"DATE/TIME RECEIVED missing"
- +5 IF $PIECE(W,"^",3)=""
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"INVOICE# missing"
- +6 IF '$PIECE(W,"^",6)
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"EXPIRATION DATE/TIME missing"
- +7 IF $PIECE(W(4),"^",2)
- IF $PIECE(W(4),"^")=""
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"DISPOSITION DATE present but DISPOSITION missing"
- QUIT
- +8 IF $PIECE(W(4),"^")=""
- QUIT
- IF '$PIECE(W(4),"^",2)
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"DISPOSITION DATE missing"
- +9 IF $PIECE(W(4),"^",3)=""
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"DISPOSITION ENTERING PERSON missing"
- +10 IF $PIECE(W(4),"^")="MO"
- IF $ORDER(^LRD(65,LRI,9,0))=""
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"MODIFIED TO/FROM missing"
- QUIT
- +11 SET X=+$PIECE(W,"^",4)
- SET X=$SELECT($DATA(^LAB(66,X,0)):$PIECE(^(0),"^",27),1:"")
- IF X
- IF $PIECE(W,"^",2)="SELF"
- IF $ORDER(^LRD(65,LRI,9,0))=""
- DO W
- IF LR("Q")
- QUIT
- WRITE !,"MODIFIED TO/FROM missing"
- +12 QUIT
- W IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- IF $DATA(LRB)
- QUIT
- WRITE !,LR("%"),!,"(IFN:",LRI,") Unit ID: ",LR,?39
- SET LRB=1
- SET X=$PIECE(W,"^",4)
- SET X=$SELECT('X:"",$DATA(^LAB(66,X,0)):$PIECE(^(0),"^"),1:"")
- IF X]""
- WRITE X
- IF X=""
- WRITE "Component missing"
- +1 QUIT
- K SET X=0
- FOR LRA=0:0
- SET X=$ORDER(^LRD(65,"B",X))
- IF X=""
- QUIT
- FOR DA=0:0
- SET DA=$ORDER(^LRD(65,"B",X,DA))
- IF 'DA
- QUIT
- IF '$DATA(^LRD(65,DA,0))
- KILL ^LRD(65,"B",X,DA)
- IF $DATA(^LRD(65,DA,0))
- IF X'=$PIECE(^(0),"^")
- DO D
- +1 SET X=0
- FOR LRA=0:0
- SET X=$ORDER(^LRD(65,"C",X))
- IF X=""
- QUIT
- FOR DA=0:0
- SET DA=$ORDER(^LRD(65,"C",X,DA))
- IF 'DA
- QUIT
- IF '$DATA(^LRD(65,DA,0))
- KILL ^LRD(65,"C",X,DA)
- +2 QUIT
- D FOR LRF=1,2,3
- IF $DATA(^DD(65,.01,1,LRF,2))
- XECUTE ^(2)
- +1 SET Y=^LRD(65,DA,0)
- SET S=$PIECE(Y,"^",2)
- SET C=$PIECE(Y,"^",4)
- IF C
- IF S]""
- SET Y=$ORDER(^LAB(66,C,"SU","B",S,0))
- IF Y
- SET Y=$LENGTH($PIECE(^LAB(66,C,"SU",Y,0),"^",10))
- IF Y
- KILL ^LRD(65,"C",$EXTRACT(X,Y+1,$LENGTH(X)),DA)
- +2 QUIT
- +3 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !?20,"Missing data from Blood Bank Inventory File",!,LR("%")
- QUIT
- +2 ;
- END DO V^LRU
- QUIT
- LRCKF ; Entry point for check all laboratory files option Routine LRCKF
- +1 DO END
- GOTO QUE
