- LRMISEZ4 ; IHS/DIR/AAB - MICRO INF CTRL SURVEY COND'T 3/28/87 6:41 PM ; [ 07/22/2002 1:25 PM ]
- ;;5.2;LR;**1006,1013**;JUL 15, 2002
- ;
- ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- ;from LRMISEZ3
- A S M=0 F I=0:0 S M=$O(^TMP($J,S,M)) Q:M="" S LRAD=$E(M,1,3)_"0000",Y=M_"00" D D^LRU S LRMY=Y D LOC
- Q
- LOC S LRLLOC=0 F I=0:0 S LRLLOC=$O(^TMP($J,S,M,LRLLOC)) Q:LRLLOC="" D NAME
- Q
- NAME S LRNAME=0 F I=0:0 S LRNAME=$O(^TMP($J,S,M,LRLLOC,LRNAME)) Q:LRNAME="" D SIT
- Q
- SIT S LRSIT=0 F I=0:0 S LRSIT=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT)) Q:LRSIT="" D AC
- Q
- AC S LRAC=0 F I=0:0 S LRAC=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC)) Q:LRAC="" D OR
- Q
- OR S LROR=0 F I=0:0 S LROR=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR)) Q:LROR="" D BG
- Q
- BG S LRBG=0 F I=0:0 S LRBG=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG)) Q:LRBG="" S ^TMP($J,"SE",LRBG,M,LRLLOC,LRSIT,LRAC,LROR,LRNAME)=$P(^(LRBG),U,1,4) S LRBUG=$P(^LAB(61.2,+$E(LRBG,4,25),0),U) D FX
- Q
- FX ;S X=^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG),SSN=$P(X,U,2),LRQUANT=$P(X,U,3),X=+X,LRDAT=$$Y2K^LRX(X)_" ",LRPNM=$P(LRNAME,U)
- S X=^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG),SSN=$P(X,U,2),HRCN=$P(X,U,2),LRQUANT=$P(X,U,3),X=+X,LRDAT=$$Y2K^LRX(X)_" ",LRPNM=$P(LRNAME,U) ;IHS/ANMC/CLS 08/18/96
- S (B,LRBO,LRYA)=0 F I=0:0 S LRYA=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG,LRYA)) Q:LRYA="" S ^TMP($J,"SE",LRBG,M,LRLLOC,LRSIT,LRAC,LROR,LRNAME,LRYA)=^(LRYA)
- Q
- LRMISEZ4 ; IHS/DIR/AAB - MICRO INF CTRL SURVEY COND'T 3/28/87 6:41 PM ; [ 07/22/2002 1:25 PM ]
- +1 ;;5.2;LR;**1006,1013**;JUL 15, 2002
- +2 ;
- +3 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- +4 ;from LRMISEZ3
- A SET M=0
- FOR I=0:0
- SET M=$ORDER(^TMP($JOB,S,M))
- IF M=""
- QUIT
- SET LRAD=$EXTRACT(M,1,3)_"0000"
- SET Y=M_"00"
- DO D^LRU
- SET LRMY=Y
- DO LOC
- +1 QUIT
- LOC SET LRLLOC=0
- FOR I=0:0
- SET LRLLOC=$ORDER(^TMP($JOB,S,M,LRLLOC))
- IF LRLLOC=""
- QUIT
- DO NAME
- +1 QUIT
- NAME SET LRNAME=0
- FOR I=0:0
- SET LRNAME=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME))
- IF LRNAME=""
- QUIT
- DO SIT
- +1 QUIT
- SIT SET LRSIT=0
- FOR I=0:0
- SET LRSIT=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT))
- IF LRSIT=""
- QUIT
- DO AC
- +1 QUIT
- AC SET LRAC=0
- FOR I=0:0
- SET LRAC=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC))
- IF LRAC=""
- QUIT
- DO OR
- +1 QUIT
- OR SET LROR=0
- FOR I=0:0
- SET LROR=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR))
- IF LROR=""
- QUIT
- DO BG
- +1 QUIT
- BG SET LRBG=0
- FOR I=0:0
- SET LRBG=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG))
- IF LRBG=""
- QUIT
- SET ^TMP($JOB,"SE",LRBG,M,LRLLOC,LRSIT,LRAC,LROR,LRNAME)=$PIECE(^(LRBG),U,1,4)
- SET LRBUG=$PIECE(^LAB(61.2,+$EXTRACT(LRBG,4,25),0),U)
- DO FX
- +1 QUIT
- FX ;S X=^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG),SSN=$P(X,U,2),LRQUANT=$P(X,U,3),X=+X,LRDAT=$$Y2K^LRX(X)_" ",LRPNM=$P(LRNAME,U)
- +1 ;IHS/ANMC/CLS 08/18/96
- SET X=^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG)
- SET SSN=$PIECE(X,U,2)
- SET HRCN=$PIECE(X,U,2)
- SET LRQUANT=$PIECE(X,U,3)
- SET X=+X
- SET LRDAT=$$Y2K^LRX(X)_" "
- SET LRPNM=$PIECE(LRNAME,U)
- +2 SET (B,LRBO,LRYA)=0
- FOR I=0:0
- SET LRYA=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG,LRYA))
- IF LRYA=""
- QUIT
- SET ^TMP($JOB,"SE",LRBG,M,LRLLOC,LRSIT,LRAC,LROR,LRNAME,LRYA)=^(LRYA)
- +3 QUIT