LRMITRZ1 ;AVAMC/REG,SLC/BA- MICRO TREND SHEET CONTINUED ;4/10/89 11:28 ;
;;V~5.0~;LAB;;02/27/90 17:09
DQ ;dequeued from LRMITRZ
K:$D(ZTSK) ^%ZTSK(ZTSK),ZTSK U IO K ^UTILITY($J),Z S (B,LRAO,LRSEQ)=0
F I=0:0 S LRAO=$O(^LAB(62.06,"AO",LRAO)) Q:LRAO<.001 S J=$O(^LAB(62.06,"AO",LRAO,0)) I J>0,$D(^LAB(62.06,J,0)),$L($P(^(0),U,5)) S B=B+1,B(B)=J_U_$P(^(0),U,5) S LRBN=$P(^(0),U,2) I LRBN,$D(LRAP(LRBN)) S $P(B(B),U,3)=LRAP(LRBN)
S O=B,B=0 F I=0:0 S B=$O(B(B)) Q:B="" S LRZ=$P(B(B),U),LRZ(LRZ)=B
I LRM("O")="N",LRM("S")="N",LRM("L")="N",LRM("D")="N",LRM("C")="N",LRM("P")="S" D MI,^LRMITRZ2 Q
S LRDFN=0 F I=0:0 S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D MI
D ^LRMITRZ2 W !
Q
MI Q:'$D(^LR(LRDFN,0)) Q:$P(^LR(LRDFN,0),U,2)'=2 S LRIDT=LRTSAL F I=0:0 S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT=""!(($E(LRIDT,1,5)_"00")>LRATS) D TYPE
Q
TYPE Q:'$D(^LR(LRDFN,"MI",LRIDT,0)) S LRSSP=$S($L($P(^(0),U,5)):$P(^(0),U,5),1:"Unknown"),LRDOC=$S($L($P(^(0),U,7)):$P(^(0),U,7),1:"Unknown")
S LRDAT=+^LR(LRDFN,"MI",LRIDT,0)
I LRLOS S LROK=1 D LOS Q:'LROK
S LRLLOC=$S($L($P(^LR(LRDFN,"MI",LRIDT,0),U,8)):$P(^(0),U,8),1:"Unknown"),LRCOL=$S($L($P(^(0),U,11)):$P(^(0),U,11),1:"Unknown")
S LRPNM=$S($L($P(^LR(LRDFN,0),U,3)):$P(^LR(LRDFN,0),U,3),1:"Unknown")
I LRDOC S X=LRDOC D DOC^LRX
I LRSSP S LRSSP=$S($D(^LAB(61,LRSSP,0)):$P(^LAB(61,LRSSP,0),U),1:"Unknown")
I LRPNM S LRPNM=$S($D(^DPT(LRPNM,0)):$P(^(0),U),1:"Unknown")
I LRCOL S LRCOL=$S($D(^LAB(62,LRCOL,0)):$P(^(0),U),1:"Unknown")
S LRSEQ=LRSEQ+1,^UTILITY($J,"M",LRDFN,"SSP",LRSSP,LRSEQ)="",^UTILITY($J,"M",LRDFN,"DOC",LRDOC,LRSEQ)="",^UTILITY($J,"M",LRDFN,"LOC",LRLLOC,LRSEQ)="",^UTILITY($J,"M",LRDFN,"PAT",LRPNM,LRSEQ)="",^UTILITY($J,"M",LRDFN,"COL",LRCOL,LRSEQ)=""
Q:'$D(^LR(LRDFN,"MI",LRIDT,1)) Q:'+^(1)
I $D(LRAP) D AP Q
S LRBG=0 F I=0:0 S LRBG=$O(^LR(LRDFN,"MI",LRIDT,3,LRBG)) Q:LRBG="" S LRBUG=+^LR(LRDFN,"MI",LRIDT,3,LRBG,0) D:'$D(LRSGL) NUM I $D(LRSGL) D:LRSGL=LRBUG NUM
Q
AP S LRBG=0 F I=0:0 S LRBG=$O(^LR(LRDFN,"MI",LRIDT,3,LRBG)) Q:LRBG="" S LROK=1 D APCHK I LROK S LRBUG=+^LR(LRDFN,"MI",LRIDT,3,LRBG,0) D:'$D(LRSGL) NUM I $D(LRSGL) D:LRSGL=LRBUG NUM
Q
APCHK S LRBN=0 F I=0:0 S LRBN=$O(LRAP(LRBN)) Q:LRBN="" S:'$D(^LR(LRDFN,"MI",LRIDT,3,LRBG,LRBN)) LROK=0 Q:'LROK I $L(^(LRBN)) S LROK=$S($L($P(^(LRBN),U,2)):$P(^(LRBN),U,2)=LRAP(LRBN),1:$P(^(LRBN),U)=LRAP(LRBN)) Q
Q
NUM S LRNUM=1 I $D(^UTILITY($J,LRSEQ,LRBUG,LRNUM)) F I=0:0 S I=$O(^UTILITY($J,LRSEQ,LRBUG,I)) Q:I="" S LRNUM=I+1
S S=2 F I=0:0 S S=$O(^LR(LRDFN,"MI",LRIDT,3,LRBG,S)) Q:S=""!(S'<3) I $D(^LAB(62.06,"AI",S)) D AB
Q
AB S P=+$E(S_"0",5,6)
I P>0,$L($P(^LAB(62.06,"AI",S),U,2)) S R=^LR(LRDFN,"MI",LRIDT,3,LRBG,S) I $L($P(R,U)) D GETSENS Q:R="" S LRAB=$P(^LAB(62.06,"AI",S),U),^UTILITY($J,LRSEQ,LRBUG,LRNUM,LRAB)=R
Q
LOS S DFN=$S($P(^LR(LRDFN,0),U,2)=2:$P(^(0),U,3),1:"") Q:'DFN S LRADMS=+$O(^DPT(DFN,"DA","AA",0)) S:LRADMS<1 LROK=0 Q:'LROK S LRADMS=+$O(^(LRADMS,0)) S:LRADMS<1 LROK=0 Q:'LROK S LRADMD=$P(^DPT(DFN,"DA",LRADMS,0),U)
I $D(^DPT(DFN,"DA",LRADMS,1)) S LRDCHD=$P(^(1),U) I LRDCHD<LRDAT S LROK=0 Q
;S DFN=$S($P(^LR(LRDFN,0),"^",2)=2:$P(^(0),"^",3),1:"") Q:'DFN S X=$O(^DGPM("APID",DFN,0)) I X S X=$O(^DGPM("APID",DFN,X,X)) I X,$D(^DGPM(X,0)),$P(^(0),"^",14) S X=$P(^(0),"^",14) S X=$S($D(^DGPM(X,0)):^(0),1:"") ;MAS
;S:'X LROK=0 Q:'X S LRADMD=+X I $P(X,"^",17) S LRDCHD=$P(X,"^",17) I LRDCHD<LRDAT S LROK=0 Q ;MAS
S X1=LRDAT,X2=LRADMD D ^%DTC I X<LRLOS S LROK=0
Q
GETSENS ;Subroutine to set variable R to "S","R" or null sensitivity
S R=$S($L($P(R,U,2)):$P(R,U,2),1:$P(R,U)) Q:R="R"
I R["S" S R="S" Q
I R="I" S R="R" Q
S R=""
Q
LRMITRZ1 ;AVAMC/REG,SLC/BA- MICRO TREND SHEET CONTINUED ;4/10/89 11:28 ;
+1 ;;V~5.0~;LAB;;02/27/90 17:09
DQ ;dequeued from LRMITRZ
+1 IF $DATA(ZTSK)
KILL ^%ZTSK(ZTSK),ZTSK
USE IO
KILL ^UTILITY($JOB),Z
SET (B,LRAO,LRSEQ)=0
+2 FOR I=0:0
SET LRAO=$ORDER(^LAB(62.06,"AO",LRAO))
IF LRAO<.001
QUIT
SET J=$ORDER(^LAB(62.06,"AO",LRAO,0))
IF J>0
IF $DATA(^LAB(62.06,J,0))
IF $LENGTH($PIECE(^(0),U,5))
SET B=B+1
SET B(B)=J_U_$PIECE(^(0),U,5)
SET LRBN=$PIECE(^(0),U,2)
IF LRBN
IF $DATA(LRAP(LRBN))
SET $PIECE(B(B),U,3)=LRAP(LRBN)
+3 SET O=B
SET B=0
FOR I=0:0
SET B=$ORDER(B(B))
IF B=""
QUIT
SET LRZ=$PIECE(B(B),U)
SET LRZ(LRZ)=B
+4 IF LRM("O")="N"
IF LRM("S")="N"
IF LRM("L")="N"
IF LRM("D")="N"
IF LRM("C")="N"
IF LRM("P")="S"
DO MI
DO ^LRMITRZ2
QUIT
+5 SET LRDFN=0
FOR I=0:0
SET LRDFN=$ORDER(^LR(LRDFN))
IF LRDFN<1
QUIT
DO MI
+6 DO ^LRMITRZ2
WRITE !
+7 QUIT
MI IF '$DATA(^LR(LRDFN,0))
QUIT
IF $PIECE(^LR(LRDFN,0),U,2)'=2
QUIT
SET LRIDT=LRTSAL
FOR I=0:0
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
IF LRIDT=""!(($EXTRACT(LRIDT,1,5)_"00")>LRATS)
QUIT
DO TYPE
+1 QUIT
TYPE IF '$DATA(^LR(LRDFN,"MI",LRIDT,0))
QUIT
SET LRSSP=$SELECT($LENGTH($PIECE(^(0),U,5)):$PIECE(^(0),U,5),1:"Unknown")
SET LRDOC=$SELECT($LENGTH($PIECE(^(0),U,7)):$PIECE(^(0),U,7),1:"Unknown")
+1 SET LRDAT=+^LR(LRDFN,"MI",LRIDT,0)
+2 IF LRLOS
SET LROK=1
DO LOS
IF 'LROK
QUIT
+3 SET LRLLOC=$SELECT($LENGTH($PIECE(^LR(LRDFN,"MI",LRIDT,0),U,8)):$PIECE(^(0),U,8),1:"Unknown")
SET LRCOL=$SELECT($LENGTH($PIECE(^(0),U,11)):$PIECE(^(0),U,11),1:"Unknown")
+4 SET LRPNM=$SELECT($LENGTH($PIECE(^LR(LRDFN,0),U,3)):$PIECE(^LR(LRDFN,0),U,3),1:"Unknown")
+5 IF LRDOC
SET X=LRDOC
DO DOC^LRX
+6 IF LRSSP
SET LRSSP=$SELECT($DATA(^LAB(61,LRSSP,0)):$PIECE(^LAB(61,LRSSP,0),U),1:"Unknown")
+7 IF LRPNM
SET LRPNM=$SELECT($DATA(^DPT(LRPNM,0)):$PIECE(^(0),U),1:"Unknown")
+8 IF LRCOL
SET LRCOL=$SELECT($DATA(^LAB(62,LRCOL,0)):$PIECE(^(0),U),1:"Unknown")
+9 SET LRSEQ=LRSEQ+1
SET ^UTILITY($JOB,"M",LRDFN,"SSP",LRSSP,LRSEQ)=""
SET ^UTILITY($JOB,"M",LRDFN,"DOC",LRDOC,LRSEQ)=""
SET ^UTILITY($JOB,"M",LRDFN,"LOC",LRLLOC,LRSEQ)=""
SET ^UTILITY($JOB,"M",LRDFN,"PAT",LRPNM,LRSEQ)=""
SET ^UTILITY($JOB,"M",LRDFN,"COL",LRCOL,LRSEQ)=""
+10 IF '$DATA(^LR(LRDFN,"MI",LRIDT,1))
QUIT
IF '+^(1)
QUIT
+11 IF $DATA(LRAP)
DO AP
QUIT
+12 SET LRBG=0
FOR I=0:0
SET LRBG=$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBG))
IF LRBG=""
QUIT
SET LRBUG=+^LR(LRDFN,"MI",LRIDT,3,LRBG,0)
IF '$DATA(LRSGL)
DO NUM
IF $DATA(LRSGL)
IF LRSGL=LRBUG
DO NUM
+13 QUIT
AP SET LRBG=0
FOR I=0:0
SET LRBG=$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBG))
IF LRBG=""
QUIT
SET LROK=1
DO APCHK
IF LROK
SET LRBUG=+^LR(LRDFN,"MI",LRIDT,3,LRBG,0)
IF '$DATA(LRSGL)
DO NUM
IF $DATA(LRSGL)
IF LRSGL=LRBUG
DO NUM
+1 QUIT
APCHK SET LRBN=0
FOR I=0:0
SET LRBN=$ORDER(LRAP(LRBN))
IF LRBN=""
QUIT
IF '$DATA(^LR(LRDFN,"MI",LRIDT,3,LRBG,LRBN))
SET LROK=0
IF 'LROK
QUIT
IF $LENGTH(^(LRBN))
SET LROK=$SELECT($LENGTH($PIECE(^(LRBN),U,2)):$PIECE(^(LRBN),U,2)=LRAP(LRBN),1:$PIECE(^(LRBN),U)=LRAP(LRBN))
QUIT
+1 QUIT
NUM SET LRNUM=1
IF $DATA(^UTILITY($JOB,LRSEQ,LRBUG,LRNUM))
FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,LRSEQ,LRBUG,I))
IF I=""
QUIT
SET LRNUM=I+1
+1 SET S=2
FOR I=0:0
SET S=$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBG,S))
IF S=""!(S'<3)
QUIT
IF $DATA(^LAB(62.06,"AI",S))
DO AB
+2 QUIT
AB SET P=+$EXTRACT(S_"0",5,6)
+1 IF P>0
IF $LENGTH($PIECE(^LAB(62.06,"AI",S),U,2))
SET R=^LR(LRDFN,"MI",LRIDT,3,LRBG,S)
IF $LENGTH($PIECE(R,U))
DO GETSENS
IF R=""
QUIT
SET LRAB=$PIECE(^LAB(62.06,"AI",S),U)
SET ^UTILITY($JOB,LRSEQ,LRBUG,LRNUM,LRAB)=R
+2 QUIT
LOS SET DFN=$SELECT($PIECE(^LR(LRDFN,0),U,2)=2:$PIECE(^(0),U,3),1:"")
IF 'DFN
QUIT
SET LRADMS=+$ORDER(^DPT(DFN,"DA","AA",0))
IF LRADMS<1
SET LROK=0
IF 'LROK
QUIT
SET LRADMS=+$ORDER(^(LRADMS,0))
IF LRADMS<1
SET LROK=0
IF 'LROK
QUIT
SET LRADMD=$PIECE(^DPT(DFN,"DA",LRADMS,0),U)
+1 IF $DATA(^DPT(DFN,"DA",LRADMS,1))
SET LRDCHD=$PIECE(^(1),U)
IF LRDCHD<LRDAT
SET LROK=0
QUIT
+2 ;S DFN=$S($P(^LR(LRDFN,0),"^",2)=2:$P(^(0),"^",3),1:"") Q:'DFN S X=$O(^DGPM("APID",DFN,0)) I X S X=$O(^DGPM("APID",DFN,X,X)) I X,$D(^DGPM(X,0)),$P(^(0),"^",14) S X=$P(^(0),"^",14) S X=$S($D(^DGPM(X,0)):^(0),1:"") ;MAS
+3 ;S:'X LROK=0 Q:'X S LRADMD=+X I $P(X,"^",17) S LRDCHD=$P(X,"^",17) I LRDCHD<LRDAT S LROK=0 Q ;MAS
+4 SET X1=LRDAT
SET X2=LRADMD
DO ^%DTC
IF X<LRLOS
SET LROK=0
+5 QUIT
GETSENS ;Subroutine to set variable R to "S","R" or null sensitivity
+1 SET R=$SELECT($LENGTH($PIECE(R,U,2)):$PIECE(R,U,2),1:$PIECE(R,U))
IF R="R"
QUIT
+2 IF R["S"
SET R="S"
QUIT
+3 IF R="I"
SET R="R"
QUIT
+4 SET R=""
+5 QUIT
