- LROE2 ;DALISC/FHS - CONTINUED MORE ORDER ENTRY ;Aug 11, 1997
- ;;5.2;LAB SERVICE;**121,424,444,573**;Sep 27, 1994;Build 7
- ;Formerly apart of LROE1
- Q15 ;from LROE1
- Q:'$D(^LRO(69,LRODT,1,LRSN,0))
- I $D(^LRO(69,LRODT,1,LRSN,1)),$P(^(1),"^",4)="U" W !,"This specimen has already been marked as UNCOLLECTED. Are you sure" S %=2 D YN^DICN Q:%'=1 S ^(1)=LRTIM_"^^"_DUZ,DA=LRSN,DA(1)=LRODT,DIE="^LRO(69,"_DA(1)_",1,",DR=16 D ^DIE
- I M9>1 D LRSPEC^LROE1 S S1=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),S2=$P(^LAB(62,LRSAMP,0),U),S4=$P(^(0),U,3),S3=S1_$S(S1'=S2:" "_S2,1:"") W !,"Do you have the ",S3," ",S4 K S1,S2,S3,S4 S %=2 D YN^DICN G Q15:%=0 Q:%'=1
- S DA=DT,LRDFN=+^LRO(69,LRODT,1,LRSN,0),LRDPF=+$P(^LR(LRDFN,0),U,2)
- IF '$D(^LRO(69,LRODT,1,LRSN,1)) S LRSTATUS="C",DA=LRODT I '$D(LRSND) D P15^LROE1 Q:LRCDT<1
- I $D(LRSND),$P(^LRO(69,LRODT,1,LRSN,0),U,4)="LC",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15^LRPHITEM G PH
- I $D(LRSND) N COMB S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7) S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_DUZ_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2) S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
- PH G Q16:LRORD D ORDER^LROW2 G Q16A
- Q16 S J=0 D CHECK^LROW2 I J D BAD^LROW2
- Q16A I $D(LRLONG),$D(LRSND) S LRSN=LRSND,^TMP("LROE",$J,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_SSN
- K DR S LRTSTS=0
- S LRSN=0 F S LRSN=$O(LRSN(LRSN)) Q:'LRSN D Q17
- I $D(LRLONG),$D(LRSND) S LRSN=LRSND D LROE^LRFAST S X=^TMP("LROE",$J,"LRORD"),LRORD=+X,LRODT=$P(X,"^",2),LRTIM=$P(X,"^",3),LRLONG="",PNM=$P(X,"^",4),SSN=$P(X,"^",5)
- Q
- Q17 S I=$O(^LRO(69,LRODT,1,LRSN,6,0)),J=$O(^(1)) S:'$D(IOM) IOM=80 K LRSPCDSC S:J LRSPCDSC=^(J,0) S:I DA=LRSN,DA(1)=LRODT,DR=6,DIC="^LRO(69,"_LRODT_",1," D EN^DIQ:I D LRSPEC^LROE1
- D OLD^LRORDST K ^TMP("LR",$J,"TMP")
- S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="C",$P(^LRO(69,LRODT,1,LRSN,1),U,8)=DUZ(2),^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
- Q
- ;LR*5.2*573
- Q18(LRU) ;Find out if Accession Areas conflict with user
- ;User or HOWDY DUZ(2) - INSTITUTION
- N LRTEST,LRPARENT,LRIX,LRI,LRNAA,LROTS
- D Q19
- S (LRIX,LRI)=0 F S LRIX=$O(LROTS(LRIX)) Q:LRIX<1 S LROTS(LRIX)=$S('$D(^LAB(60,LRIX,8,LRU)):0,1:1)
- S LRIX=0,LRNAA=1 F S LRIX=$O(LROTS(LRIX)) Q:LRIX<1 I 'LROTS(LRIX) S LRNAA=0 Q
- I LRNAA Q 1
- I '$G(LRNAAAC) D
- . W !!,"One or more of the ordered tests does not have an "
- . W "appropriate accession area.",!!,"ORDER # ",LRORD," IS NOT ACCESSIONED",!
- H 1 S LRNAAAC=1
- Q 0
- ;
- Q19 ;Get tests on the order
- N LRJ,LRTE,LRTN,LROS
- S LRJ=0 F S LRJ=$O(^LRO(69,"C",LRORD,LRJ)) Q:LRJ<1 D
- . S LRTE=0 F S LRTE=$O(^LRO(69,"C",LRORD,LRJ,LRTE)) Q:LRTE<1 D
- . . S LRTN=0 F S LRTN=$O(^LRO(69,LRJ,1,LRTE,2,"B",LRTN)) Q:LRTN<1 D
- . . . S LROS=0 F S LROS=$O(^LRO(69,LRJ,1,LRTE,2,"B",LRTN,LROS)) Q:LROS<1 D
- . . . . I $P($G(^LRO(69,LRJ,1,LRTE,2,LROS,0)),U,9)'="CA" S LROTS(LRTN)=1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROE2 2960 printed Feb 18, 2025@23:44:24 Page 2
- LROE2 ;DALISC/FHS - CONTINUED MORE ORDER ENTRY ;Aug 11, 1997
- +1 ;;5.2;LAB SERVICE;**121,424,444,573**;Sep 27, 1994;Build 7
- +2 ;Formerly apart of LROE1
- Q15 ;from LROE1
- +1 if '$DATA(^LRO(69,LRODT,1,LRSN,0))
- QUIT
- +2 IF $DATA(^LRO(69,LRODT,1,LRSN,1))
- IF $PIECE(^(1),"^",4)="U"
- WRITE !,"This specimen has already been marked as UNCOLLECTED. Are you sure"
- SET %=2
- DO YN^DICN
- if %'=1
- QUIT
- SET ^(1)=LRTIM_"^^"_DUZ
- SET DA=LRSN
- SET DA(1)=LRODT
- SET DIE="^LRO(69,"_DA(1)_",1,"
- SET DR=16
- DO ^DIE
- +3 IF M9>1
- DO LRSPEC^LROE1
- SET S1=$SELECT($DATA(^LAB(61,+LRSPEC,0)):$PIECE(^(0),U),1:"")
- SET S2=$PIECE(^LAB(62,LRSAMP,0),U)
- SET S4=$PIECE(^(0),U,3)
- SET S3=S1_$SELECT(S1'=S2:" "_S2,1:"")
- WRITE !,"Do you have the ",S3," ",S4
- KILL S1,S2,S3,S4
- SET %=2
- DO YN^DICN
- if %=0
- GOTO Q15
- if %'=1
- QUIT
- +4 SET DA=DT
- SET LRDFN=+^LRO(69,LRODT,1,LRSN,0)
- SET LRDPF=+$PIECE(^LR(LRDFN,0),U,2)
- +5 IF '$DATA(^LRO(69,LRODT,1,LRSN,1))
- SET LRSTATUS="C"
- SET DA=LRODT
- IF '$DATA(LRSND)
- DO P15^LROE1
- if LRCDT<1
- QUIT
- +6 IF $DATA(LRSND)
- IF $PIECE(^LRO(69,LRODT,1,LRSN,0),U,4)="LC"
- IF $DATA(^(1))
- SET LRLLOC=$PIECE(^(0),U,7)
- SET LROLLOC=$PIECE(^(0),U,9)
- SET LRNT=$SELECT($DATA(LRNT):LRNT,$DATA(LRTIM):LRTIM,$DATA(LRCDT):+LRCDT,1:"")
- DO P15^LRPHITEM
- GOTO PH
- +7 IF $DATA(LRSND)
- NEW COMB
- SET COMB=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7)
- SET ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_DUZ_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2)
- if LRSTATUS="C"
- SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
- PH if LRORD
- GOTO Q16
- DO ORDER^LROW2
- GOTO Q16A
- Q16 SET J=0
- DO CHECK^LROW2
- IF J
- DO BAD^LROW2
- Q16A IF $DATA(LRLONG)
- IF $DATA(LRSND)
- SET LRSN=LRSND
- SET ^TMP("LROE",$JOB,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_SSN
- +1 KILL DR
- SET LRTSTS=0
- +2 SET LRSN=0
- FOR
- SET LRSN=$ORDER(LRSN(LRSN))
- if 'LRSN
- QUIT
- DO Q17
- +3 IF $DATA(LRLONG)
- IF $DATA(LRSND)
- SET LRSN=LRSND
- DO LROE^LRFAST
- SET X=^TMP("LROE",$JOB,"LRORD")
- SET LRORD=+X
- SET LRODT=$PIECE(X,"^",2)
- SET LRTIM=$PIECE(X,"^",3)
- SET LRLONG=""
- SET PNM=$PIECE(X,"^",4)
- SET SSN=$PIECE(X,"^",5)
- +4 QUIT
- Q17 SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,0))
- SET J=$ORDER(^(1))
- if '$DATA(IOM)
- SET IOM=80
- KILL LRSPCDSC
- if J
- SET LRSPCDSC=^(J,0)
- if I
- SET DA=LRSN
- SET DA(1)=LRODT
- SET DR=6
- SET DIC="^LRO(69,"_LRODT_",1,"
- if I
- DO EN^DIQ
- DO LRSPEC^LROE1
- +1 DO OLD^LRORDST
- KILL ^TMP("LR",$JOB,"TMP")
- +2 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,4)="C"
- SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,8)=DUZ(2)
- SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
- +3 QUIT
- +4 ;LR*5.2*573
- Q18(LRU) ;Find out if Accession Areas conflict with user
- +1 ;User or HOWDY DUZ(2) - INSTITUTION
- +2 NEW LRTEST,LRPARENT,LRIX,LRI,LRNAA,LROTS
- +3 DO Q19
- +4 SET (LRIX,LRI)=0
- FOR
- SET LRIX=$ORDER(LROTS(LRIX))
- if LRIX<1
- QUIT
- SET LROTS(LRIX)=$SELECT('$DATA(^LAB(60,LRIX,8,LRU)):0,1:1)
- +5 SET LRIX=0
- SET LRNAA=1
- FOR
- SET LRIX=$ORDER(LROTS(LRIX))
- if LRIX<1
- QUIT
- IF 'LROTS(LRIX)
- SET LRNAA=0
- QUIT
- +6 IF LRNAA
- QUIT 1
- +7 IF '$GET(LRNAAAC)
- Begin DoDot:1
- +8 WRITE !!,"One or more of the ordered tests does not have an "
- +9 WRITE "appropriate accession area.",!!,"ORDER # ",LRORD," IS NOT ACCESSIONED",!
- End DoDot:1
- +10 HANG 1
- SET LRNAAAC=1
- +11 QUIT 0
- +12 ;
- Q19 ;Get tests on the order
- +1 NEW LRJ,LRTE,LRTN,LROS
- +2 SET LRJ=0
- FOR
- SET LRJ=$ORDER(^LRO(69,"C",LRORD,LRJ))
- if LRJ<1
- QUIT
- Begin DoDot:1
- +3 SET LRTE=0
- FOR
- SET LRTE=$ORDER(^LRO(69,"C",LRORD,LRJ,LRTE))
- if LRTE<1
- QUIT
- Begin DoDot:2
- +4 SET LRTN=0
- FOR
- SET LRTN=$ORDER(^LRO(69,LRJ,1,LRTE,2,"B",LRTN))
- if LRTN<1
- QUIT
- Begin DoDot:3
- +5 SET LROS=0
- FOR
- SET LROS=$ORDER(^LRO(69,LRJ,1,LRTE,2,"B",LRTN,LROS))
- if LROS<1
- QUIT
- Begin DoDot:4
- +6 IF $PIECE($GET(^LRO(69,LRJ,1,LRTE,2,LROS,0)),U,9)'="CA"
- SET LROTS(LRTN)=1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
