LRMIPSZ1 ;AVAMC/REG/SLC/CJS/BA - MICRO PATIENT REPORT ;2/19/91 10:57
;;5.2T9;LR;**1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**283**;Sep 27, 1994
DQ ;tasked from LRTASK from IMMEDIATE INTERIM REPORTING thru LRTP
I $D(ZTQUEUED) S ZTREQ="@"
S LRPATLOC=$S($D(LRLLOC):LRLLOC,1:""),LRIDT=$S($D(LRIDT):LRIDT,1:0),LRSS=$S($D(LRSS):LRSS,1:0)
S LRONETST="",LRONESPC="",LREND=0 D ^LRPARAM
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"
Q:'$L(X) D ^DIC S LRAA=+Y,LRAN=+$P(LRACC," ",3),LRCMNT=$S($D(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:""),LRPG=0
EN ;from LRMINEW2, LRMIPC, LRMIPLOG, LRMIPSZ, LRMIVER1
I '$D(LRONESPC) S LRONESPC="",DIC="^LAB(61,",DIC("A")="Select SPECIMEN/SOURCE: ANY//",DIC(0)="AEMOQ" D ^DIC S:Y>0 LRONESPC=+Y K DIC("A")
I '$D(LRONETST) S LRONETST="",DIC="^LAB(60,",DIC(0)="AEOQ",DIC("S")="I $P(^(0),U,4)=""MI"")"_$S('$D(LRLABKY):",""BO""[$P(^(0),U,3)",1:""),D="E" D IX^DIC Q:Y<1 I Y>0 S LRONETST=+Y
S LRSPEC=$P(LRLLT,U,5) I LRONESPC'="",LRSPEC'=LRONESPC Q
D RPT
K %,A8,A,AB,B,B1,B2,B3,C,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($E(IOST,1,2)'="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:$G(VAIN(3)) DOB=$P(VADM(3),U) S LRPATLOC=$P(LRLLT,U,8)
S (LRADM,LRADX)="" I +$G(LRDPF)=2,'$G(VAERR) D
. S LRADM=$S($L(VAIN(7)):$P(VAIN(7),U,2),1:"")
. S LRADX=$S($L(VAIN(9)):VAIN(9),1:"")
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^LRMIPSU 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^LRMIPSU Q:LREND D ANTI^LRMIPSZ2
I $D(^LR(LRDFN,"MI",LRIDT,1)) D FH^LRMIPSU Q:LREND D BACT^LRMIPSZ2 Q:LREND D REFS^LRMIPSU Q:LREND
I $D(^LR(LRDFN,"MI",LRIDT,31)) D FH^LRMIPSU Q:LREND D STER^LRMIPSZ3
I $D(^LR(LRDFN,"MI",LRIDT,5)) D FH^LRMIPSU Q:LREND D PARA^LRMIPSZ3,REFS^LRMIPSU Q:LREND
I $D(^LR(LRDFN,"MI",LRIDT,16)) D FH^LRMIPSU Q:LREND D VIR^LRMIPSZ3,REFS^LRMIPSU Q:LREND
I $D(^LR(LRDFN,"MI",LRIDT,11)) D FH^LRMIPSU Q:LREND D TB^LRMIPSZ4,REFS^LRMIPSU Q:LREND
I $D(^LR(LRDFN,"MI",LRIDT,8)) D FH^LRMIPSU Q:LREND D FUNG^LRMIPSZ4,REFS^LRMIPSU Q:LREND
D FOOT^LRMIPSU,WAIT^LRMIPSU Q:LREND
Q
EN1 S LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0),LRTS(1)=$P(^(0),U,5)
Q:'$L($P($G(^LAB(60,LRTS,0)),U,3)) I '$D(LRLABKY),"BO"'[$P($G(^LAB(60,LRTS,0)),U,3) Q
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
LRMIPSZ1 ;AVAMC/REG/SLC/CJS/BA - MICRO PATIENT REPORT ;2/19/91 10:57
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**283**;Sep 27, 1994
DQ ;tasked from LRTASK from IMMEDIATE INTERIM REPORTING thru LRTP
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 SET LRPATLOC=$SELECT($DATA(LRLLOC):LRLLOC,1:"")
SET LRIDT=$SELECT($DATA(LRIDT):LRIDT,1:0)
SET LRSS=$SELECT($DATA(LRSS):LRSS,1:0)
+3 SET LRONETST=""
SET LRONESPC=""
SET LREND=0
DO ^LRPARAM
+4 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"
+5 IF '$LENGTH(X)
QUIT
DO ^DIC
SET LRAA=+Y
SET LRAN=+$PIECE(LRACC," ",3)
SET LRCMNT=$SELECT($DATA(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:"")
SET LRPG=0
EN ;from LRMINEW2, LRMIPC, LRMIPLOG, LRMIPSZ, LRMIVER1
+1 IF '$DATA(LRONESPC)
SET LRONESPC=""
SET DIC="^LAB(61,"
SET DIC("A")="Select SPECIMEN/SOURCE: ANY//"
SET DIC(0)="AEMOQ"
DO ^DIC
IF Y>0
SET LRONESPC=+Y
KILL DIC("A")
+2 IF '$DATA(LRONETST)
SET LRONETST=""
SET DIC="^LAB(60,"
SET DIC(0)="AEOQ"
SET DIC("S")="I $P(^(0),U,4)=""MI"")"_$SELECT('$DATA(LRLABKY):",""BO""[$P(^(0),U,3)",1:"")
SET D="E"
DO IX^DIC
IF Y<1
QUIT
IF Y>0
SET LRONETST=+Y
+3 SET LRSPEC=$PIECE(LRLLT,U,5)
IF LRONESPC'=""
IF LRSPEC'=LRONESPC
QUIT
+4 DO RPT
+5 KILL %,A8,A,AB,B,B1,B2,B3,C,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
+6 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
+7 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($EXTRACT(IOST,1,2)'="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
IF $GET(VAIN(3))
SET DOB=$PIECE(VADM(3),U)
SET LRPATLOC=$PIECE(LRLLT,U,8)
+3 SET (LRADM,LRADX)=""
IF +$GET(LRDPF)=2
IF '$GET(VAERR)
Begin DoDot:1
+4 SET LRADM=$SELECT($LENGTH(VAIN(7)):$PIECE(VAIN(7),U,2),1:"")
+5 SET LRADX=$SELECT($LENGTH(VAIN(9)):VAIN(9),1:"")
End DoDot:1
+6 SET LRCS=$SELECT($DATA(^LAB(62,+$PIECE(LRLLT,U,11),0)):$PIECE(^(0),U),1:"")
+7 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
+8 SET X=$PIECE(LRLLT,U,7)
DO DOC^LRX
+9 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
+10 IF 'LRPRINT
IF LRONETST
QUIT
+11 SET LRPG=0
DO HDR^LRMIPSU
IF LREND
QUIT
+12 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 !
+13 KILL ^TMP("LR",$JOB,"T"),LRTSTS
IF LRHC
WRITE !
+14 IF $DATA(^LR(LRDFN,"MI",LRIDT,14))
DO FH^LRMIPSU
IF LREND
QUIT
DO ANTI^LRMIPSZ2
+15 IF $DATA(^LR(LRDFN,"MI",LRIDT,1))
DO FH^LRMIPSU
IF LREND
QUIT
DO BACT^LRMIPSZ2
IF LREND
QUIT
DO REFS^LRMIPSU
IF LREND
QUIT
+16 IF $DATA(^LR(LRDFN,"MI",LRIDT,31))
DO FH^LRMIPSU
IF LREND
QUIT
DO STER^LRMIPSZ3
+17 IF $DATA(^LR(LRDFN,"MI",LRIDT,5))
DO FH^LRMIPSU
IF LREND
QUIT
DO PARA^LRMIPSZ3
DO REFS^LRMIPSU
IF LREND
QUIT
+18 IF $DATA(^LR(LRDFN,"MI",LRIDT,16))
DO FH^LRMIPSU
IF LREND
QUIT
DO VIR^LRMIPSZ3
DO REFS^LRMIPSU
IF LREND
QUIT
+19 IF $DATA(^LR(LRDFN,"MI",LRIDT,11))
DO FH^LRMIPSU
IF LREND
QUIT
DO TB^LRMIPSZ4
DO REFS^LRMIPSU
IF LREND
QUIT
+20 IF $DATA(^LR(LRDFN,"MI",LRIDT,8))
DO FH^LRMIPSU
IF LREND
QUIT
DO FUNG^LRMIPSZ4
DO REFS^LRMIPSU
IF LREND
QUIT
+21 DO FOOT^LRMIPSU
DO WAIT^LRMIPSU
IF LREND
QUIT
+22 QUIT
EN1 SET LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0)
SET LRTS(1)=$PIECE(^(0),U,5)
+1 IF '$LENGTH($PIECE($GET(^LAB(60,LRTS,0)),U,3))
QUIT
IF '$DATA(LRLABKY)
IF "BO"'[$PIECE($GET(^LAB(60,LRTS,0)),U,3)
QUIT
+2 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)
+3 QUIT
