- LROR4 ;SLC/DCM - MICRO DETAILED DISPLAY ON ORDERS ;4/17/91 14:29 ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- ;
- EN ;from LROR2
- S LRLLT=^LR(LRDFN,"MI",LRIDT,0),LRACC=$P(LRLLT,U,6),LRAD=$E(LRLLT)_$P(LRACC," ",2)_"0000",X=$P(LRACC," "),DIC=68,DIC(0)="M"
- I $L(X) D ^DIC S LRAA=+Y,LRAN=+$P(LRACC," ",3),LRCMNT=$S($D(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:""),LRPG=0 D A Q:LREND
- Q
- A ;
- S LRSPEC=$P(LRLLT,U,5) I LRONESPC'="",LRSPEC'=LRONESPC Q
- D RPT
- K %,A8,A,AB,B,B1,B2,B3,C,DZ,IA,LR1PASS,LR2ORMOR,LRABCNT,LRACNT,LRADM,LRADX,LRAFS,LRAMT,LRAX,LRBN,LRBRR,LRBUG,LRCOMTAB,LRCS,LRDCOM,LRDOC,LRDRTM1,LRDRTM2,LREF,LRFLIP,LRFMT,LRGRM,LRHC,LRIFN,LRINT,LRPATLOC,LRMYC,LRNS,LRNUM
- K LRORG,LRPAR,LRPC,LRPRE,LRPRINT,LRQU,LRRC,LRRES,LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST,LRTA,LRTB,LRTBA,LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,N
- Q
- RPT S:'$D(LRSB) LRSB=0 S LRPRINT=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,4)):"",1:1),LRHC=$S(IOST'["C-":1,1:0),LRFLIP=$S(LRHC:11,1:6)
- I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG"),LRDPF=2 S LRFDT=9999999-LRIDT D REG^LRAC9 K LRFDT
- K DIC D DT^LRX S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S Y=DOB D:Y D^LRU S DOB=Y,LRPATLOC=$P(LRLLT,U,8)
- S (LRADM,LRADX)="",LRWRD=$S($D(LRWRD):LRWRD,1:"") I LRDPF=2 S N=$O(^DGPM("APID",DFN,0)) I N S N=$O(^(N,0)) I N S X=^DGPM(N,0) I $P(X,"^",14),$D(^DGPM($P(X,"^",14),0)) S X=^(0),Y=+X,LRADX=$P(^(0),"^",10) D:Y D^LRU S LRADM=Y ;MAS
- S LRCS=$S($D(^LAB(62,+$P(LRLLT,U,11),0)):$P(^(0),U),1:"")
- S LRTK=$P(LRLLT,U),LRRC=$P(LRLLT,U,10),LRST=$S(LRSPEC:$P(^LAB(61,LRSPEC,0),U),1:""),Y=LRTK D D^LRU S LRTK=Y,Y=LRRC D D^LRU S LRRC=Y
- S X=$P(LRLLT,U,7) D DOC^LRX
- K ^TMP("LR",$J,"T"),LRTSTS S LRBRR=0 F I=0:0 S LRBRR=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR)) Q:LRBRR<1 D EN1
- I 'LRPRINT,LRONETST Q
- S LRPG=0 D HDR Q:LREND
- I $D(^TMP("LR",$J,"T")) W !?5,"Test(s) ordered:" S J="" F I=0:0 S J=$O(^TMP("LR",$J,"T",J)) Q:J="" S X=^(J) W ?23,$P(X,U) S Y=$P(X,U,2) D:$L(Y) D^LRU W:$L(Y) ?43," completed: ",Y W !
- K ^TMP("LR",$J,"T"),LRTSTS W:LRHC !
- I $D(^LR(LRDFN,"MI",LRIDT,14)) D FH Q:LREND D ANTI^LROR4A
- I $D(^LR(LRDFN,"MI",LRIDT,1)) D FH Q:LREND D BACT^LROR4A Q:LREND D REFS^LRMIPSU Q:LREND
- I $D(^LR(LRDFN,"MI",LRIDT,31)) D FH Q:LREND D STER^LRMIPSZ3
- I $D(^LR(LRDFN,"MI",LRIDT,5)) D FH Q:LREND D PARA^LRMIPSZ3,REFS^LRMIPSU Q:LREND
- I $D(^LR(LRDFN,"MI",LRIDT,16)) D FH Q:LREND D VIR^LRMIPSZ3,REFS^LRMIPSU Q:LREND
- I $D(^LR(LRDFN,"MI",LRIDT,11)) D FH Q:LREND D TB^LRMIPSZ4,REFS^LRMIPSU Q:LREND
- I $D(^LR(LRDFN,"MI",LRIDT,8)) D FH Q:LREND D FUNG^LRMIPSZ4,REFS^LRMIPSU Q:LREND
- Q
- EN1 S LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0),LRTS(1)=$P(^(0),U,5)
- S:LRTS=LRONETST LRPRINT=1 S LRTSTS=$S($D(^LAB(60,LRTS,0)):$P(^(0),U),1:"deleted test"),^TMP("LR",$J,"T",$S($D(^LAB(60,LRTS,.1)):$P(^(.1),U,6),1:"")_","_LRBRR)=LRTSTS_U_LRTS(1)
- Q
- FH D:$Y>(IOSL-LRFLIP) HDR
- Q
- HDR ;
- S LRPG=LRPG+1 D WAIT Q:LREND D EXT^ORUHDR
- W !?27,"----MICROBIOLOGY----"
- I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") D ^LRAIPRIV
- I '$D(LRH),LRHC W !?32,$S($D(^XUSEC("LRLAB",DUZ))&'$D(LRWRDVEW):"LAB",1:"CHART")," COPY"
- W:LRPG=1 !,"Accession: ",LRACC,?47,"Received: ",LRRC
- W !,"Collection sample: ",LRCS,?40,"Collection date: ",LRTK
- I LRCS'=LRST,LRPG=1 W !,"Site/Specimen: ",LRST
- I LRPG=1 W !,"Provider: ",LRDOC,! W:$L(LRCMNT) "Comment on specimen: ",LRCMNT,!
- W:LRPG>1 !?20,">> CONTINUATION OF ",LRACC," <<"
- Q
- WAIT ;
- F I=$Y:1:IOSL-4 W !
- I 'LRHC D PGBRK^ORUHDR I OREND S LREND=1 Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROR4 3483 printed Feb 18, 2025@23:44:32 Page 2
- LROR4 ;SLC/DCM - MICRO DETAILED DISPLAY ON ORDERS ;4/17/91 14:29 ;
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +2 ;
- EN ;from LROR2
- +1 SET LRLLT=^LR(LRDFN,"MI",LRIDT,0)
- SET LRACC=$PIECE(LRLLT,U,6)
- SET LRAD=$EXTRACT(LRLLT)_$PIECE(LRACC," ",2)_"0000"
- SET X=$PIECE(LRACC," ")
- SET DIC=68
- SET DIC(0)="M"
- +2 IF $LENGTH(X)
- DO ^DIC
- SET LRAA=+Y
- SET LRAN=+$PIECE(LRACC," ",3)
- SET LRCMNT=$SELECT($DATA(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:"")
- SET LRPG=0
- DO A
- if LREND
- QUIT
- +3 QUIT
- A ;
- +1 SET LRSPEC=$PIECE(LRLLT,U,5)
- IF LRONESPC'=""
- IF LRSPEC'=LRONESPC
- QUIT
- +2 DO RPT
- +3 KILL %,A8,A,AB,B,B1,B2,B3,C,DZ,IA,LR1PASS,LR2ORMOR,LRABCNT,LRACNT,LRADM,LRADX,LRAFS,LRAMT,LRAX,LRBN,LRBRR,LRBUG,LRCOMTAB,LRCS,LRDCOM,LRDOC,LRDRTM1,LRDRTM2,LREF,LRFLIP,LRFMT,LRGRM,LRHC,LRIFN,LRINT,LRPATLOC,LRMYC,LRNS,LRNUM
- +4 KILL LRORG,LRPAR,LRPC,LRPRE,LRPRINT,LRQU,LRRC,LRRES,LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST,LRTA,LRTB,LRTBA,LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,N
- +5 QUIT
- RPT if '$DATA(LRSB)
- SET LRSB=0
- SET LRPRINT=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4)):"",1:1)
- SET LRHC=$SELECT(IOST'["C-":1,1:0)
- SET LRFLIP=$SELECT(LRHC:11,1:6)
- +1 IF $DATA(DUZ("AG"))
- IF $LENGTH(DUZ("AG"))
- IF "ARMYAFN"[DUZ("AG")
- IF LRDPF=2
- SET LRFDT=9999999-LRIDT
- DO REG^LRAC9
- KILL LRFDT
- +2 KILL DIC
- DO DT^LRX
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- SET Y=DOB
- if Y
- DO D^LRU
- SET DOB=Y
- SET LRPATLOC=$PIECE(LRLLT,U,8)
- +3 ;MAS
- SET (LRADM,LRADX)=""
- SET LRWRD=$SELECT($DATA(LRWRD):LRWRD,1:"")
- IF LRDPF=2
- SET N=$ORDER(^DGPM("APID",DFN,0))
- IF N
- SET N=$ORDER(^(N,0))
- IF N
- SET X=^DGPM(N,0)
- IF $PIECE(X,"^",14)
- IF $DATA(^DGPM($PIECE(X,"^",14),0))
- SET X=^(0)
- SET Y=+X
- SET LRADX=$PIECE(^(0),"^",10)
- if Y
- DO D^LRU
- SET LRADM=Y
- +4 SET LRCS=$SELECT($DATA(^LAB(62,+$PIECE(LRLLT,U,11),0)):$PIECE(^(0),U),1:"")
- +5 SET LRTK=$PIECE(LRLLT,U)
- SET LRRC=$PIECE(LRLLT,U,10)
- SET LRST=$SELECT(LRSPEC:$PIECE(^LAB(61,LRSPEC,0),U),1:"")
- SET Y=LRTK
- DO D^LRU
- SET LRTK=Y
- SET Y=LRRC
- DO D^LRU
- SET LRRC=Y
- +6 SET X=$PIECE(LRLLT,U,7)
- DO DOC^LRX
- +7 KILL ^TMP("LR",$JOB,"T"),LRTSTS
- SET LRBRR=0
- FOR I=0:0
- SET LRBRR=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR))
- if LRBRR<1
- QUIT
- DO EN1
- +8 IF 'LRPRINT
- IF LRONETST
- QUIT
- +9 SET LRPG=0
- DO HDR
- if LREND
- QUIT
- +10 IF $DATA(^TMP("LR",$JOB,"T"))
- WRITE !?5,"Test(s) ordered:"
- SET J=""
- FOR I=0:0
- SET J=$ORDER(^TMP("LR",$JOB,"T",J))
- if J=""
- QUIT
- SET X=^(J)
- WRITE ?23,$PIECE(X,U)
- SET Y=$PIECE(X,U,2)
- if $LENGTH(Y)
- DO D^LRU
- if $LENGTH(Y)
- WRITE ?43," completed: ",Y
- WRITE !
- +11 KILL ^TMP("LR",$JOB,"T"),LRTSTS
- if LRHC
- WRITE !
- +12 IF $DATA(^LR(LRDFN,"MI",LRIDT,14))
- DO FH
- if LREND
- QUIT
- DO ANTI^LROR4A
- +13 IF $DATA(^LR(LRDFN,"MI",LRIDT,1))
- DO FH
- if LREND
- QUIT
- DO BACT^LROR4A
- if LREND
- QUIT
- DO REFS^LRMIPSU
- if LREND
- QUIT
- +14 IF $DATA(^LR(LRDFN,"MI",LRIDT,31))
- DO FH
- if LREND
- QUIT
- DO STER^LRMIPSZ3
- +15 IF $DATA(^LR(LRDFN,"MI",LRIDT,5))
- DO FH
- if LREND
- QUIT
- DO PARA^LRMIPSZ3
- DO REFS^LRMIPSU
- if LREND
- QUIT
- +16 IF $DATA(^LR(LRDFN,"MI",LRIDT,16))
- DO FH
- if LREND
- QUIT
- DO VIR^LRMIPSZ3
- DO REFS^LRMIPSU
- if LREND
- QUIT
- +17 IF $DATA(^LR(LRDFN,"MI",LRIDT,11))
- DO FH
- if LREND
- QUIT
- DO TB^LRMIPSZ4
- DO REFS^LRMIPSU
- if LREND
- QUIT
- +18 IF $DATA(^LR(LRDFN,"MI",LRIDT,8))
- DO FH
- if LREND
- QUIT
- DO FUNG^LRMIPSZ4
- DO REFS^LRMIPSU
- if LREND
- QUIT
- +19 QUIT
- EN1 SET LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0)
- SET LRTS(1)=$PIECE(^(0),U,5)
- +1 if LRTS=LRONETST
- SET LRPRINT=1
- SET LRTSTS=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE(^(0),U),1:"deleted test")
- SET ^TMP("LR",$JOB,"T",$SELECT($DATA(^LAB(60,LRTS,.1)):$PIECE(^(.1),U,6),1:"")_","_LRBRR)=LRTSTS_U_LRTS(1)
- +2 QUIT
- FH if $Y>(IOSL-LRFLIP)
- DO HDR
- +1 QUIT
- HDR ;
- +1 SET LRPG=LRPG+1
- DO WAIT
- if LREND
- QUIT
- DO EXT^ORUHDR
- +2 WRITE !?27,"----MICROBIOLOGY----"
- +3 IF $DATA(DUZ("AG"))
- IF $LENGTH(DUZ("AG"))
- IF "ARMYAFN"[DUZ("AG")
- DO ^LRAIPRIV
- +4 IF '$DATA(LRH)
- IF LRHC
- WRITE !?32,$SELECT($DATA(^XUSEC("LRLAB",DUZ))&'$DATA(LRWRDVEW):"LAB",1:"CHART")," COPY"
- +5 if LRPG=1
- WRITE !,"Accession: ",LRACC,?47,"Received: ",LRRC
- +6 WRITE !,"Collection sample: ",LRCS,?40,"Collection date: ",LRTK
- +7 IF LRCS'=LRST
- IF LRPG=1
- WRITE !,"Site/Specimen: ",LRST
- +8 IF LRPG=1
- WRITE !,"Provider: ",LRDOC,!
- if $LENGTH(LRCMNT)
- WRITE "Comment on specimen: ",LRCMNT,!
- +9 if LRPG>1
- WRITE !?20,">> CONTINUATION OF ",LRACC," <<"
- +10 QUIT
- WAIT ;
- +1 FOR I=$Y:1:IOSL-4
- WRITE !
- +2 IF 'LRHC
- DO PGBRK^ORUHDR
- IF OREND
- SET LREND=1
- QUIT
- +3 QUIT
