LRAPLG2 ;DALOI/STAFF - LOG-IN DATA FROM FILE #63 ;05/30/12 16:50
;;5.2;LAB SERVICE;**72,115,350**;Sep 27, 1994;Build 230
;
;
EN ;
N X
;
S LRDFN=$O(^LR(LRXREF,LRH(2),LRABV,LRAN,0))
I 'LRDFN G END
;
S LRI=$O(^LR(LRXREF,LRH(2),LRABV,LRAN,LRDFN,0))
I '$D(^LR(LRDFN,0))!('LRI&(LRSS'="AU")) G END
;
S X=^LR(LRDFN,0),(LRDPF,LRPFN)=$P(X,U,2),DFN=$P(X,U,3)
I 'LRPFN!('DFN) G END
;
S LRPF=$$GET1^DID(LRPFN,"","","GLOBAL NAME"),LRP=@(LRPF_DFN_",0)"),SSN=$P(LRP,U,9),LRP=$P(LRP,U)
D SSN^LRU
;
I LRSS'="AU" D Q
. I '$D(^LR(LRDFN,LRSS,LRI,0)) D END Q
. S X=^LR(LRDFN,LRSS,LRI,0),LRIDT=LRI,LRCAPLOC=""
. S LRSD=$P(X,U),LRRC=$P(X,U,10),LRACC=$P(X,U,6),LRMD(1)=$P(X,U,7),LRSIT=$P(X,U,5),LRCS=$P(X,U,11),LRLLOC=$P(X,U,8),LRC(5)=""
. D SETUP
;
I LRSS="AU" D Q
. I '$D(^LR(LRDFN,"AU")) D END Q
. S X=^LR(LRDFN,"AU"),LRCAPLOC=""
. S LRRC=$P(X,U),LRLLOC=$P(X,U,5),LRACC=$P(X,U,6),LRMD(1)=$P(X,U,12),LRSVC=$P(X,U,14),(LRCS,LRIDT,LRSIT,LRC(5))="",DA=LRDFN
. D D^LRAUAW
. S LRSD=LR(63,12)
. D SETUP
;
Q
;
;
SETUP ; Setup accession
;
S Y=LRRC D D^LRU
W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)
W !,"In ",LRAA(1)," file but not in Accession file."
W !,"Entry: ",LRP," ID: ",SSN," Dated: ",Y
W !,"Enter in Accession file "
S %=2 D YN^LRU
I %'=1 D END^LRAPLG1 S LRFND=1 Q
;
I '$D(LRTS) S LRTS=""
;
D CRE868^LRAPLG1
I $D(LRMSG) D END^LRAPLG1 S LRFND=1 Q
;
D EN^LRUWLF
;
;L +^LRO(68,LRAA)
;S ^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRDFN_"^^"_LRRC_"^^^^"_LRLLOC_"^"_LRMD(1)_"^"_LRSVC_"^"_DUZ
;S ^LRO(68,LRAA,1,LRAD,1,LRAN,3)=LRSD_"^^^^"_LRI_"^"_LRC(5)
;S ^LRO(68,LRAA,1,LRAD,1,0)=$P(^LRO(68,LRAA,1,LRAD,1,0),"^",1,2)_"^"_LRAN_"^"_($P(^(0),"^",4)+1)
;S ^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)=""
;L -^LRO(68,LRAA)
;K LRSD
;
;S:LRRC ^LRO(68,LRAA,1,LRAD,1,"E",LRRC,LRAN)=""
;
;I "AUCYEMSP"'[LRSS D
;. S ^LRO(68,LRAA,1,LRAD,1,LRAN,5,0)="^68.05PA^1^1"
;. S ^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)=LRSIT_"^"_LRCS
S LRIDT=LRI
;
Q
;
;
END ;
;
K ^LR(LRXREF,LRH(2),LRABV,LRAN)
W $C(7),!!,"Sorry, try again",!!
D END^LRAPLG1
S LRFND=1
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPLG2 2140 printed Oct 16, 2024@18:08:25 Page 2
LRAPLG2 ;DALOI/STAFF - LOG-IN DATA FROM FILE #63 ;05/30/12 16:50
+1 ;;5.2;LAB SERVICE;**72,115,350**;Sep 27, 1994;Build 230
+2 ;
+3 ;
EN ;
+1 NEW X
+2 ;
+3 SET LRDFN=$ORDER(^LR(LRXREF,LRH(2),LRABV,LRAN,0))
+4 IF 'LRDFN
GOTO END
+5 ;
+6 SET LRI=$ORDER(^LR(LRXREF,LRH(2),LRABV,LRAN,LRDFN,0))
+7 IF '$DATA(^LR(LRDFN,0))!('LRI&(LRSS'="AU"))
GOTO END
+8 ;
+9 SET X=^LR(LRDFN,0)
SET (LRDPF,LRPFN)=$PIECE(X,U,2)
SET DFN=$PIECE(X,U,3)
+10 IF 'LRPFN!('DFN)
GOTO END
+11 ;
+12 SET LRPF=$$GET1^DID(LRPFN,"","","GLOBAL NAME")
SET LRP=@(LRPF_DFN_",0)")
SET SSN=$PIECE(LRP,U,9)
SET LRP=$PIECE(LRP,U)
+13 DO SSN^LRU
+14 ;
+15 IF LRSS'="AU"
Begin DoDot:1
+16 IF '$DATA(^LR(LRDFN,LRSS,LRI,0))
DO END
QUIT
+17 SET X=^LR(LRDFN,LRSS,LRI,0)
SET LRIDT=LRI
SET LRCAPLOC=""
+18 SET LRSD=$PIECE(X,U)
SET LRRC=$PIECE(X,U,10)
SET LRACC=$PIECE(X,U,6)
SET LRMD(1)=$PIECE(X,U,7)
SET LRSIT=$PIECE(X,U,5)
SET LRCS=$PIECE(X,U,11)
SET LRLLOC=$PIECE(X,U,8)
SET LRC(5)=""
+19 DO SETUP
End DoDot:1
QUIT
+20 ;
+21 IF LRSS="AU"
Begin DoDot:1
+22 IF '$DATA(^LR(LRDFN,"AU"))
DO END
QUIT
+23 SET X=^LR(LRDFN,"AU")
SET LRCAPLOC=""
+24 SET LRRC=$PIECE(X,U)
SET LRLLOC=$PIECE(X,U,5)
SET LRACC=$PIECE(X,U,6)
SET LRMD(1)=$PIECE(X,U,12)
SET LRSVC=$PIECE(X,U,14)
SET (LRCS,LRIDT,LRSIT,LRC(5))=""
SET DA=LRDFN
+25 DO D^LRAUAW
+26 SET LRSD=LR(63,12)
+27 DO SETUP
End DoDot:1
QUIT
+28 ;
+29 QUIT
+30 ;
+31 ;
SETUP ; Setup accession
+1 ;
+2 SET Y=LRRC
DO D^LRU
+3 WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)
+4 WRITE !,"In ",LRAA(1)," file but not in Accession file."
+5 WRITE !,"Entry: ",LRP," ID: ",SSN," Dated: ",Y
+6 WRITE !,"Enter in Accession file "
+7 SET %=2
DO YN^LRU
+8 IF %'=1
DO END^LRAPLG1
SET LRFND=1
QUIT
+9 ;
+10 IF '$DATA(LRTS)
SET LRTS=""
+11 ;
+12 DO CRE868^LRAPLG1
+13 IF $DATA(LRMSG)
DO END^LRAPLG1
SET LRFND=1
QUIT
+14 ;
+15 DO EN^LRUWLF
+16 ;
+17 ;L +^LRO(68,LRAA)
+18 ;S ^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRDFN_"^^"_LRRC_"^^^^"_LRLLOC_"^"_LRMD(1)_"^"_LRSVC_"^"_DUZ
+19 ;S ^LRO(68,LRAA,1,LRAD,1,LRAN,3)=LRSD_"^^^^"_LRI_"^"_LRC(5)
+20 ;S ^LRO(68,LRAA,1,LRAD,1,0)=$P(^LRO(68,LRAA,1,LRAD,1,0),"^",1,2)_"^"_LRAN_"^"_($P(^(0),"^",4)+1)
+21 ;S ^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)=""
+22 ;L -^LRO(68,LRAA)
+23 ;K LRSD
+24 ;
+25 ;S:LRRC ^LRO(68,LRAA,1,LRAD,1,"E",LRRC,LRAN)=""
+26 ;
+27 ;I "AUCYEMSP"'[LRSS D
+28 ;. S ^LRO(68,LRAA,1,LRAD,1,LRAN,5,0)="^68.05PA^1^1"
+29 ;. S ^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)=LRSIT_"^"_LRCS
+30 SET LRIDT=LRI
+31 ;
+32 QUIT
+33 ;
+34 ;
END ;
+1 ;
+2 KILL ^LR(LRXREF,LRH(2),LRABV,LRAN)
+3 WRITE $CHAR(7),!!,"Sorry, try again",!!
+4 DO END^LRAPLG1
+5 SET LRFND=1
+6 ;
+7 QUIT
