LRUWLF ;DALOI/STAFF - FILE #68 UTILITY ;01/23/17 01:14
;;5.2;LAB SERVICE;**72,350,462,479**;Sep 27, 1994;Build 8
;
;
EN ;
;
S:'$D(LRCS) LRCS=""
;
STF ;
S:'$D(LRSIT) LRSIT=LRU S:'$D(LRSVC) LRSVC=""
;
;;*
I '$G(LRAPDIAL) S LRACC=LRABV_" "_LRWHN_" "_LRAN
;
; File information in file #68 for this accession
K LRFDA,LR6802,LRDIE
;;;*
S LR6802=LRAN_","_LRAD_","_LRAA_","
S LRFDA(1,68.02,LR6802,.01)=LRDFN
S LRFDA(1,68.02,LR6802,1)=+LRDPF
S LRFDA(1,68.02,LR6802,2)=LRAD
;;*
I $G(LRODT) S LRFDA(1,68.02,LR6802,3)=LRODT ;ORDER DATE
I $G(LRSN) S LRFDA(1,68.02,LR6802,4)=LRSN ; ORDER DATE IEN
I $G(LROLLOC) S LRFDA(1,68.02,LR6802,94)=LROLLOC ; ORDER LOCATION POINTER
;;;*
S LRFDA(1,68.02,LR6802,6)=LRLLOC
;
; No ordering provider/location on controls
I LRDPF'=62.3 D
. S LRFDA(1,68.02,LR6802,6.5)=LRMD(1)
. ;;*
. I $G(LROLLOC) S LRFDA(1,68.02,LR6802,94)=LROLLOC
. ;;;*
;
; Only store treating specialty on file #2 patients
; If no treating specialty then use specialty from file #44 location
I LRDPF=2 D
. N LRTREA
. S LRTREA=$P($G(^DPT(DFN,.103)),U)
. ;;*
. ;I 'LRTREA S LRTREA=$P($G(^SC(+LRLLOC,0)),U,20)
. I 'LRTREA,$G(LROLLOC) S LRTREA=$P($G(^SC(LROLLOC,0)),U,20)
. I LRTREA S LRFDA(1,68.02,LR6802,6.6)=LRTREA
;
S LRFDA(1,68.02,LR6802,6.7)=DUZ
S LRFDA(1,68.02,LR6802,9)=LRSD
S LRFDA(1,68.02,LR6802,12)=LRRC
S LRFDA(1,68.02,LR6802,13.5)=LRI
I LRC(5)'="" S LRFDA(1,68.02,LR6802,13.6)=LRC(5)
;;*
I $G(LRORD) S LRFDA(1,68.02,LR6802,14)=LRORD
;;;*
S LRFDA(1,68.02,LR6802,15)=LRACC
S LRFDA(1,68.02,LR6802,26)=DUZ(2)
S LRFDA(1,68.02,LR6802,92)=LRCAPLOC
D FILE^DIE("S","LRFDA(1)","LRDIE(1)")
I $D(LRDIE(1)) D MAILALRT^LRWLST12("STF~LRUWLF")
;
; Create and store UID on accession.
S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
;
I LRSS="CY" D
. S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
. L +^LRO(69.2,LRAA,1):DILOCKTM
. S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
. L -^LRO(69.2,LRAA,1)
Q
;
;
EN1 ; add more tests ;used by LRUTAD
S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^^"
W !
;
TST ;
K LRTEST
S DIC=60,DIC("A")=" Add Test/Procedure: ",DIC(0)="AEMOQZ",DIC("S")="I $P(^(0),U,4)=LRAA(2),$A($P(^(0),U,3))<78"
D ^DIC K DIC
I Y<1 S LRSIT="" Q
;
S (LRTEST,Y)=+Y,LRTNAM=$P(Y,U,2)
S N=0
F S N=$O(^LAB(60,LRTEST,1,N)) Q:'N S LRTEST(1)=$S($D(^LAB(60,LRTEST,1,N,0)):+^LAB(60,LRTEST,1,N,0),1:"") Q:LRTEST(1)=LRSIT
I LRSS="CH",N<1 W $C(7),!!,"CANNOT ORDER ",LRTNAM," FOR ",$P(^LAB(61,LRSIT,0),U) G TST
D SUM
K LRRP
G TST
;
;
SUM ;
;
S N=0
F X=0:1 S N=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,N)) Q:'N S:Y=N LRRP=1
Q:$D(LRRP)
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,Y,0)=LRTEST_"^^"
I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),"^",4)<1 S ^(0)="^68.04PA^"_Y_"^"_1 Q
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^"_Y_"^"_($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),"^",4)+1)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUWLF 2981 printed Apr 09, 2024@21:05:25 Page 2
LRUWLF ;DALOI/STAFF - FILE #68 UTILITY ;01/23/17 01:14
+1 ;;5.2;LAB SERVICE;**72,350,462,479**;Sep 27, 1994;Build 8
+2 ;
+3 ;
EN ;
+1 ;
+2 if '$DATA(LRCS)
SET LRCS=""
+3 ;
STF ;
+1 if '$DATA(LRSIT)
SET LRSIT=LRU
if '$DATA(LRSVC)
SET LRSVC=""
+2 ;
+3 ;;*
+4 IF '$GET(LRAPDIAL)
SET LRACC=LRABV_" "_LRWHN_" "_LRAN
+5 ;
+6 ; File information in file #68 for this accession
+7 KILL LRFDA,LR6802,LRDIE
+8 ;;;*
+9 SET LR6802=LRAN_","_LRAD_","_LRAA_","
+10 SET LRFDA(1,68.02,LR6802,.01)=LRDFN
+11 SET LRFDA(1,68.02,LR6802,1)=+LRDPF
+12 SET LRFDA(1,68.02,LR6802,2)=LRAD
+13 ;;*
+14 ;ORDER DATE
IF $GET(LRODT)
SET LRFDA(1,68.02,LR6802,3)=LRODT
+15 ; ORDER DATE IEN
IF $GET(LRSN)
SET LRFDA(1,68.02,LR6802,4)=LRSN
+16 ; ORDER LOCATION POINTER
IF $GET(LROLLOC)
SET LRFDA(1,68.02,LR6802,94)=LROLLOC
+17 ;;;*
+18 SET LRFDA(1,68.02,LR6802,6)=LRLLOC
+19 ;
+20 ; No ordering provider/location on controls
+21 IF LRDPF'=62.3
Begin DoDot:1
+22 SET LRFDA(1,68.02,LR6802,6.5)=LRMD(1)
+23 ;;*
+24 IF $GET(LROLLOC)
SET LRFDA(1,68.02,LR6802,94)=LROLLOC
+25 ;;;*
End DoDot:1
+26 ;
+27 ; Only store treating specialty on file #2 patients
+28 ; If no treating specialty then use specialty from file #44 location
+29 IF LRDPF=2
Begin DoDot:1
+30 NEW LRTREA
+31 SET LRTREA=$PIECE($GET(^DPT(DFN,.103)),U)
+32 ;;*
+33 ;I 'LRTREA S LRTREA=$P($G(^SC(+LRLLOC,0)),U,20)
+34 IF 'LRTREA
IF $GET(LROLLOC)
SET LRTREA=$PIECE($GET(^SC(LROLLOC,0)),U,20)
+35 IF LRTREA
SET LRFDA(1,68.02,LR6802,6.6)=LRTREA
End DoDot:1
+36 ;
+37 SET LRFDA(1,68.02,LR6802,6.7)=DUZ
+38 SET LRFDA(1,68.02,LR6802,9)=LRSD
+39 SET LRFDA(1,68.02,LR6802,12)=LRRC
+40 SET LRFDA(1,68.02,LR6802,13.5)=LRI
+41 IF LRC(5)'=""
SET LRFDA(1,68.02,LR6802,13.6)=LRC(5)
+42 ;;*
+43 IF $GET(LRORD)
SET LRFDA(1,68.02,LR6802,14)=LRORD
+44 ;;;*
+45 SET LRFDA(1,68.02,LR6802,15)=LRACC
+46 SET LRFDA(1,68.02,LR6802,26)=DUZ(2)
+47 SET LRFDA(1,68.02,LR6802,92)=LRCAPLOC
+48 DO FILE^DIE("S","LRFDA(1)","LRDIE(1)")
+49 IF $DATA(LRDIE(1))
DO MAILALRT^LRWLST12("STF~LRUWLF")
+50 ;
+51 ; Create and store UID on accession.
+52 SET LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
+53 ;
+54 IF LRSS="CY"
Begin DoDot:1
+55 SET ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+56 LOCK +^LRO(69.2,LRAA,1):DILOCKTM
+57 SET X=^LRO(69.2,LRAA,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+58 LOCK -^LRO(69.2,LRAA,1)
End DoDot:1
+59 QUIT
+60 ;
+61 ;
EN1 ; add more tests ;used by LRUTAD
+1 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^^"
+2 WRITE !
+3 ;
TST ;
+1 KILL LRTEST
+2 SET DIC=60
SET DIC("A")=" Add Test/Procedure: "
SET DIC(0)="AEMOQZ"
SET DIC("S")="I $P(^(0),U,4)=LRAA(2),$A($P(^(0),U,3))<78"
+3 DO ^DIC
KILL DIC
+4 IF Y<1
SET LRSIT=""
QUIT
+5 ;
+6 SET (LRTEST,Y)=+Y
SET LRTNAM=$PIECE(Y,U,2)
+7 SET N=0
+8 FOR
SET N=$ORDER(^LAB(60,LRTEST,1,N))
if 'N
QUIT
SET LRTEST(1)=$SELECT($DATA(^LAB(60,LRTEST,1,N,0)):+^LAB(60,LRTEST,1,N,0),1:"")
if LRTEST(1)=LRSIT
QUIT
+9 IF LRSS="CH"
IF N<1
WRITE $CHAR(7),!!,"CANNOT ORDER ",LRTNAM," FOR ",$PIECE(^LAB(61,LRSIT,0),U)
GOTO TST
+10 DO SUM
+11 KILL LRRP
+12 GOTO TST
+13 ;
+14 ;
SUM ;
+1 ;
+2 SET N=0
+3 FOR X=0:1
SET N=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,N))
if 'N
QUIT
if Y=N
SET LRRP=1
+4 if $DATA(LRRP)
QUIT
+5 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,Y,0)=LRTEST_"^^"
+6 IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),"^",4)<1
SET ^(0)="^68.04PA^"_Y_"^"_1
QUIT
+7 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^"_Y_"^"_($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),"^",4)+1)
+8 ;
+9 QUIT
