LRLAM ;SLC/CJS - STUFF AMIS DATA INTO LAM GLOBAL ;2/5/91 14:18 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
; CALL WITH LRDFN AND LRIDT AND LRLLOC
Q:'$D(^LR(LRDFN,"CH",LRIDT,0)) S Y=^(0),LRSPEC=$P(Y,U,5),LRMETH=$P(Y,U,8),U="^"
S N=$O(^LAB(62.4,"D",LRMETH,0)),LRSUF=$S($D(^LAB(62.4,N,6)):+(6),1:".00")
S LRSITE=$S($D(DUZ(2)):DUZ(2),1:0) Q:'LRSITE
S LRSB=0 F S LRSB=$O(^LR(LRDFN,"CH",LRIDT,LRSB)) Q:LRSB<1 D PIECE
END K LRCODE,LRSUF
Q
PIECE F LRSSP=1:1:99 Q:'$L($P(^LR(LRDFN,"CH",LRIDT,LRSB),U,LRSSP,99)) I $L($P(^(LRSB),U,LRSSP)) D COUNT
Q
CHECK I $D(^LAM(LRLN,1,LRSITE,1,DT,1,N,0)) S N=N+1 G CHECK
S ^LAM(LRLN,1,LRSITE,1,DT,1,"B",LRLLOC,N)="",C=$P(^LAM(LRLN,1,LRSITE,1,DT,1,0),U,4),^(0)="^64.03A^"_C_U_C
Q
COUNT S LRTEST=$O(^LAB(60,"C",("CH;"_LRSB_";"_LRSSP),0)),LRCODE=$S($D(^LAB(60,LRTEST,1,LRSPEC,2,1,0)):^(0),1:-1),LRCODE=$S($D(^LAM(LRCODE,0)):$P(^(0),".",1),1:"80000")_LRSUF
S LRLN=$O(^LAM("C",LRCODE,0)) I '$D(^LAM(LRLN,1,0)) S ^LAM(LRLN,1,0)="^64.01^1^1",^(LRSITE,0)=LRSITE
I '$D(^LAM(LRLN,1,LRSITE,1,0)) S ^LAM(LRLN,1,LRSITE,1,0)="",^(DT,0)=DT
S N=$P(^LAM(LRLN,1,LRSITE,1,0),U,4),^(0)="^64.02DA^"_DT_U_(N+1)
I '$D(^LAM(LRLN,1,LRSITE,1,DT,1,0)) S ^LAM(LRLN,1,LRSITE,1,DT,1,0)="^64.03A^"
S N=$O(^LAM(LRLN,1,LRSITE,1,DT,1,"B",LRLLOC,0)) I N<1 S N=1+$P(^LAM(LRLN,1,LRSITE,1,DT,1,0),U,3) D CHECK
S $P(^LAM(LRLN,1,LRSITE,1,DT,1,N,0),U,1)=1+^LAM(LRLN,1,LRSITE,1,DT,1,N,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLAM 1408 printed Dec 13, 2024@02:16:10 Page 2
LRLAM ;SLC/CJS - STUFF AMIS DATA INTO LAM GLOBAL ;2/5/91 14:18 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 ; CALL WITH LRDFN AND LRIDT AND LRLLOC
+3 if '$DATA(^LR(LRDFN,"CH",LRIDT,0))
QUIT
SET Y=^(0)
SET LRSPEC=$PIECE(Y,U,5)
SET LRMETH=$PIECE(Y,U,8)
SET U="^"
+4 SET N=$ORDER(^LAB(62.4,"D",LRMETH,0))
SET LRSUF=$SELECT($DATA(^LAB(62.4,N,6)):+(6),1:".00")
+5 SET LRSITE=$SELECT($DATA(DUZ(2)):DUZ(2),1:0)
if 'LRSITE
QUIT
+6 SET LRSB=0
FOR
SET LRSB=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSB))
if LRSB<1
QUIT
DO PIECE
END KILL LRCODE,LRSUF
+1 QUIT
PIECE FOR LRSSP=1:1:99
if '$LENGTH($PIECE(^LR(LRDFN,"CH",LRIDT,LRSB),U,LRSSP,99))
QUIT
IF $LENGTH($PIECE(^(LRSB),U,LRSSP))
DO COUNT
+1 QUIT
CHECK IF $DATA(^LAM(LRLN,1,LRSITE,1,DT,1,N,0))
SET N=N+1
GOTO CHECK
+1 SET ^LAM(LRLN,1,LRSITE,1,DT,1,"B",LRLLOC,N)=""
SET C=$PIECE(^LAM(LRLN,1,LRSITE,1,DT,1,0),U,4)
SET ^(0)="^64.03A^"_C_U_C
+2 QUIT
COUNT SET LRTEST=$ORDER(^LAB(60,"C",("CH;"_LRSB_";"_LRSSP),0))
SET LRCODE=$SELECT($DATA(^LAB(60,LRTEST,1,LRSPEC,2,1,0)):^(0),1:-1)
SET LRCODE=$SELECT($DATA(^LAM(LRCODE,0)):$PIECE(^(0),".",1),1:"80000")_LRSUF
+1 SET LRLN=$ORDER(^LAM("C",LRCODE,0))
IF '$DATA(^LAM(LRLN,1,0))
SET ^LAM(LRLN,1,0)="^64.01^1^1"
SET ^(LRSITE,0)=LRSITE
+2 IF '$DATA(^LAM(LRLN,1,LRSITE,1,0))
SET ^LAM(LRLN,1,LRSITE,1,0)=""
SET ^(DT,0)=DT
+3 SET N=$PIECE(^LAM(LRLN,1,LRSITE,1,0),U,4)
SET ^(0)="^64.02DA^"_DT_U_(N+1)
+4 IF '$DATA(^LAM(LRLN,1,LRSITE,1,DT,1,0))
SET ^LAM(LRLN,1,LRSITE,1,DT,1,0)="^64.03A^"
+5 SET N=$ORDER(^LAM(LRLN,1,LRSITE,1,DT,1,"B",LRLLOC,0))
IF N<1
SET N=1+$PIECE(^LAM(LRLN,1,LRSITE,1,DT,1,0),U,3)
DO CHECK
+6 SET $PIECE(^LAM(LRLN,1,LRSITE,1,DT,1,N,0),U,1)=1+^LAM(LRLN,1,LRSITE,1,DT,1,N,0)
+7 QUIT
