LRMIPSU ; IHS/DIR/FJE - MICRO PATIENT REPORT ; 13-Oct-2017 14:04 ; MKK
;;5.2;LR;**1013,1015,1018,1022,1030,1039,1041**;NOV 01, 1997;Build 23
;;5.2;LAB SERVICE;;Sep 27, 1994
FH ;EP - from LRMIPSZ1, LRMIPSZ2, LRMIPSZ5
D:$Y>(IOSL-LRFLIP) FOOT,HDR
Q
FHR ;EP - from LRMIPSZ1, LRMIPSZ2
D:$Y>(IOSL-LRFLIP) FOOT,HDR Q:LREND D REFS
Q
REFS ;EP - from LRMIPSZ1
S B=1,LREF=0
F I=0:0 S LREF=$O(LRBUG(LREF)) Q:LREF="" S LRIFN=LRBUG(LREF) D LIST Q:LREND
K LRBUG
Q
LIST Q:'$D(^LAB(61.2,LRIFN,"JR",0))
S LRNUM=0
F I=0:0 S LRNUM=$O(^LAB(61.2,LRIFN,"JR",LRNUM)) Q:LRNUM="" D WR Q:LREND
Q
WR S X1=^LAB(61.2,LRIFN,"JR",LRNUM,0) Q:$P(X1,U,7)'=1
D:$Y>(IOSL-LRFLIP-2) FOOT,HDR Q:LREND
W:B=1 !!,"Reference(s): " S B=0
W !!,$J(LREF,2),". ",$P(X1,U,2),!,$P(X1,U)
W ! W:$L($P(X1,U,3)) $P(^LAB(95,$P(X1,U,3),0),U)," ",$P(X1,U,4),":"
W $P(X1,U,5) W:$L($P(X1,U,6)) ",",$E($P(X1,U,6),1,3)+1700
Q
; F X=1:1 W ! Q:$Y>(IOSL-LRFLIP)
F X=1:1 W ! Q:$Y>(IOSL-(LRFLIP+6)) ; IHS/OIT/MKK - LR*5.2*1030
Q:'LRHC W !,"Collection sample: ",LRCS,?40,"Collection date: ",LRTK
;W:LRCS'=LRST !,"Site/Specimen: ",LRST W !!
W:LRCS'=LRST !,"Site/Specimen: ",LRST W ! ;IHS/ANMC/CLS 08/18/96
;W !!,PNM,?$X+3,SSN,?$X+3 W:$D(IA) IA W ?60," ROUTING: ",LRPATLOC,!
;
D IHSKEY ; IHS/OIT/MKK - LR*5.2*1030
;
W !,PNM,?$X+3,HRCN,?$X+3 W:$D(IA) IA W ?60," ROUTING: ",LRPATLOC,! ;IHS/ANMC/CLS 08/18/96
W $$INS^LRU," LABORATORY",?62,LRACC,!,"MICROBIOLOGY",?62,"page ",LRPG,!
Q
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
IHSKEY ; EP -- Legends for Micro Reports
W !,$TR($J("",IOM)," ","=")
W !,$$CJ^XLFSTR("S=Sensitive I=Intermediate R=Resistant NI=Not Immune I=Immune",IOM)
W !,$$CJ^XLFSTR(" IB=Inducible Beta Lactam NR=Non Reactive WR=Weakly Reactive R=Reactive",IOM),!
Q
; ----- END IHS/OIT/MKK - LR*5.2*1030
;
HDR ;EP - from LRMIPSZ1
S LRPG=LRPG+1 D:LRPG>1 WAIT Q:LREND
W:($G(LRJ02))!($G(LRJ0))!($E(IOST,1,2)="C-") @IOF S LRJ02=1
;W !,PNM,?20," ",SSN,?35," AGE: ",AGE W:$L(LRWRD) ?46,"LOC: ",LRWRD
; W !,PNM,?20," ",HRCN,?35," AGE: ",AGE W:$L(LRWRD) ?46,"LOC: ",LRWRD ;IHS/ANMC/CLS 08/18/96
; W ?61," ",LRDT0 S A8=$P($H,",",2),Y=A8\3600_":"_$E((A8\60#60+100),2,3)
; W " ",Y W:LRHC !
;
; --- BEGIN IHS/MSC/MKK - LR*5.2*1041
W !,$E(PNM,1,18),?19,HRCN
I $$GET^XPAR("ALL","BLR DOB ONLY",1,"Q") W ?29,"DOB: ",$$FMTE^XLFDT(DOB,"5DZ")
E W ?29,"AGE: ",AGE
W:$L(LRWRD) ?46,"LOC: ",LRWRD
W ?64,$TR($$HTE^XLFDT($H,"5MZ"),"@"," ")
W:LRHC !
; --- END IHS/MSC/MKK - LR*5.2*1041
;
; W:LRPG=1 !?27,"----MICROBIOLOGY----",?70,"page 1"
;----- BEGIN IHS MODIFICATIONS LR*5.2*1022 -- Institution Name & Address
NEW HDRSTR
I LRPG=1 S HDRSTR=$$CJ^XLFSTR("----MICROBIOLOGY----",IOM)
I LRPG>1 S HDRSTR=$$CJ^XLFSTR(">> CONTINUATION OF "_LRACC_" <<",IOM)
; S LRPG=LRPG+1 ; IHS/MSC/MKK - LR*5.2*1041
S $E(HDRSTR,70,79)="Page "_LRPG
; W !,HDRSTR
W !,HDRSTR,! ; IHS/MSC/MKK - LR*5.2*1039
D LABHDR^BLRUTIL2
;----- END IHS MODIFICATIONS LR*5.2*1022 -- Institution Name & Address
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,?40,"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,!
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D ESIGINFO^BLRUTIL
;----- END IHS MODIFICATIONS
;----- BEGIN IHS MODIFICATIONS LR*5.2*1022 -- Institution Name & Address
; Comment out the following line.
; W:LRPG>1 !?20,">> CONTINUATION OF ",LRACC," <<",?70,"page ",LRPG
;----- END IHS MODIFICATIONS LR*5.2*1022 -- Institution Name & Address
Q
;
WAIT ; EP - from LRMIPSZ1, LRMIPSZ2
;
;The following lines added per Appendix A of RPMS Lab E-Sig Enhancement V 5.2 Techinical Manual IHS/HQW/SCR - 8/23/01
I $P($G(XQY0),U)="LLRS"!($P($G(XQY0),U)="LRRS BY LOC")!($P($G(XQY0),U)="LRRD")!($P($G(XQY0),U)="LRRP2")!($P($G(XQY0),U)="BLR LRRD BY MD") D ;IHS/HQW/SCR-8/23/01
.I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2)) D ^BLRALAU ;IHS/HQW/SCR-8/23/01
;
; D IHSKEY ; IHS/OIT/MKK - LR*5.2*1030
D:IOST["C-VT" IHSKEY ; IHS/OIT/MKK - LR*5.2*1039
;
F I=$Y:1:IOSL-3 W !
;I 'LRHC W !,PNM,?25," ",SSN," ROUTING: ",LRPATLOC,?59," PRESS '^' TO STOP " R X:DTIME S:X="" X=1 S:(".^"[X)!('$T) LREND=1
I 'LRHC W !,PNM,?25," ",HRCN," ROUTING: ",LRPATLOC,?59," PRESS '^' TO STOP " R X:DTIME S:X="" X=1 S:(".^"[X)!('$T) LREND=1 ;IHS/ANMC/CLS 08/18/96
Q
PRE ;EP - from LRMIPSZ2, LRMIPSZ3, LRMIPSZ4
Q:LRTUS["F"&('$D(^XUSEC("LRLAB",DUZ))!$D(LRWRDVEW)) W:+$O(^LR(LRDFN,"MI",LRIDT,LRPRE,0)) !,"Preliminary Comments: " S J=0 F I=0:0 S J=+$O(^LR(LRDFN,"MI",LRIDT,LRPRE,J)) Q:J<1 W !?3,^(J,0)
W !
Q
LRMIPSU ; IHS/DIR/FJE - MICRO PATIENT REPORT ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;LR;**1013,1015,1018,1022,1030,1039,1041**;NOV 01, 1997;Build 23
+2 ;;5.2;LAB SERVICE;;Sep 27, 1994
FH ;EP - from LRMIPSZ1, LRMIPSZ2, LRMIPSZ5
+1 IF $Y>(IOSL-LRFLIP)
DO FOOT
DO HDR
+2 QUIT
FHR ;EP - from LRMIPSZ1, LRMIPSZ2
+1 IF $Y>(IOSL-LRFLIP)
DO FOOT
DO HDR
IF LREND
QUIT
DO REFS
+2 QUIT
REFS ;EP - from LRMIPSZ1
+1 SET B=1
SET LREF=0
+2 FOR I=0:0
SET LREF=$ORDER(LRBUG(LREF))
IF LREF=""
QUIT
SET LRIFN=LRBUG(LREF)
DO LIST
IF LREND
QUIT
+3 KILL LRBUG
+4 QUIT
LIST IF '$DATA(^LAB(61.2,LRIFN,"JR",0))
QUIT
+1 SET LRNUM=0
+2 FOR I=0:0
SET LRNUM=$ORDER(^LAB(61.2,LRIFN,"JR",LRNUM))
IF LRNUM=""
QUIT
DO WR
IF LREND
QUIT
+3 QUIT
WR SET X1=^LAB(61.2,LRIFN,"JR",LRNUM,0)
IF $PIECE(X1,U,7)'=1
QUIT
+1 IF $Y>(IOSL-LRFLIP-2)
DO FOOT
DO HDR
IF LREND
QUIT
+2 IF B=1
WRITE !!,"Reference(s): "
SET B=0
+3 WRITE !!,$JUSTIFY(LREF,2),". ",$PIECE(X1,U,2),!,$PIECE(X1,U)
+4 WRITE !
IF $LENGTH($PIECE(X1,U,3))
WRITE $PIECE(^LAB(95,$PIECE(X1,U,3),0),U)," ",$PIECE(X1,U,4),":"
+5 WRITE $PIECE(X1,U,5)
IF $LENGTH($PIECE(X1,U,6))
WRITE ",",$EXTRACT($PIECE(X1,U,6),1,3)+1700
+6 QUIT
+1 ; F X=1:1 W ! Q:$Y>(IOSL-LRFLIP)
+2 ; IHS/OIT/MKK - LR*5.2*1030
FOR X=1:1
WRITE !
IF $Y>(IOSL-(LRFLIP+6))
QUIT
+3 IF 'LRHC
QUIT
WRITE !,"Collection sample: ",LRCS,?40,"Collection date: ",LRTK
+4 ;W:LRCS'=LRST !,"Site/Specimen: ",LRST W !!
+5 ;IHS/ANMC/CLS 08/18/96
IF LRCS'=LRST
WRITE !,"Site/Specimen: ",LRST
WRITE !
+6 ;W !!,PNM,?$X+3,SSN,?$X+3 W:$D(IA) IA W ?60," ROUTING: ",LRPATLOC,!
+7 ;
+8 ; IHS/OIT/MKK - LR*5.2*1030
DO IHSKEY
+9 ;
+10 ;IHS/ANMC/CLS 08/18/96
WRITE !,PNM,?$X+3,HRCN,?$X+3
IF $DATA(IA)
WRITE IA
WRITE ?60," ROUTING: ",LRPATLOC,!
+11 WRITE $$INS^LRU," LABORATORY",?62,LRACC,!,"MICROBIOLOGY",?62,"page ",LRPG,!
+12 QUIT
+13 ;
+14 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
IHSKEY ; EP -- Legends for Micro Reports
+1 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","=")
+2 WRITE !,$$CJ^XLFSTR("S=Sensitive I=Intermediate R=Resistant NI=Not Immune I=Immune",IOM)
+3 WRITE !,$$CJ^XLFSTR(" IB=Inducible Beta Lactam NR=Non Reactive WR=Weakly Reactive R=Reactive",IOM),!
+4 QUIT
+5 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+6 ;
HDR ;EP - from LRMIPSZ1
+1 SET LRPG=LRPG+1
IF LRPG>1
DO WAIT
IF LREND
QUIT
+2 IF ($GET(LRJ02))!($GET(LRJ0))!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
SET LRJ02=1
+3 ;W !,PNM,?20," ",SSN,?35," AGE: ",AGE W:$L(LRWRD) ?46,"LOC: ",LRWRD
+4 ; W !,PNM,?20," ",HRCN,?35," AGE: ",AGE W:$L(LRWRD) ?46,"LOC: ",LRWRD ;IHS/ANMC/CLS 08/18/96
+5 ; W ?61," ",LRDT0 S A8=$P($H,",",2),Y=A8\3600_":"_$E((A8\60#60+100),2,3)
+6 ; W " ",Y W:LRHC !
+7 ;
+8 ; --- BEGIN IHS/MSC/MKK - LR*5.2*1041
+9 WRITE !,$EXTRACT(PNM,1,18),?19,HRCN
+10 IF $$GET^XPAR("ALL","BLR DOB ONLY",1,"Q")
WRITE ?29,"DOB: ",$$FMTE^XLFDT(DOB,"5DZ")
+11 IF '$TEST
WRITE ?29,"AGE: ",AGE
+12 IF $LENGTH(LRWRD)
WRITE ?46,"LOC: ",LRWRD
+13 WRITE ?64,$TRANSLATE($$HTE^XLFDT($HOROLOG,"5MZ"),"@"," ")
+14 IF LRHC
WRITE !
+15 ; --- END IHS/MSC/MKK - LR*5.2*1041
+16 ;
+17 ; W:LRPG=1 !?27,"----MICROBIOLOGY----",?70,"page 1"
+18 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1022 -- Institution Name & Address
+19 NEW HDRSTR
+20 IF LRPG=1
SET HDRSTR=$$CJ^XLFSTR("----MICROBIOLOGY----",IOM)
+21 IF LRPG>1
SET HDRSTR=$$CJ^XLFSTR(">> CONTINUATION OF "_LRACC_" <<",IOM)
+22 ; S LRPG=LRPG+1 ; IHS/MSC/MKK - LR*5.2*1041
+23 SET $EXTRACT(HDRSTR,70,79)="Page "_LRPG
+24 ; W !,HDRSTR
+25 ; IHS/MSC/MKK - LR*5.2*1039
WRITE !,HDRSTR,!
+26 DO LABHDR^BLRUTIL2
+27 ;----- END IHS MODIFICATIONS LR*5.2*1022 -- Institution Name & Address
+28 IF $DATA(DUZ("AG"))
IF $LENGTH(DUZ("AG"))
IF "ARMYAFN"[DUZ("AG")
DO ^LRAIPRIV
+29 IF '$DATA(LRH)
IF LRHC
WRITE !?32,$SELECT($DATA(^XUSEC("LRLAB",DUZ))&'$DATA(LRWRDVEW):"LAB",1:"CHART")," COPY"
+30 IF LRPG=1
WRITE !,"Accession: ",LRACC,?40,"Received: ",LRRC
+31 WRITE !,"Collection sample: ",LRCS,?40,"Collection date: ",LRTK
+32 IF LRCS'=LRST
IF LRPG=1
WRITE !,"Site/Specimen: ",LRST
+33 IF LRPG=1
WRITE !,"Provider: ",LRDOC,!
IF $LENGTH(LRCMNT)
WRITE "Comment on specimen: ",LRCMNT,!
+34 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+35 DO ESIGINFO^BLRUTIL
+36 ;----- END IHS MODIFICATIONS
+37 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1022 -- Institution Name & Address
+38 ; Comment out the following line.
+39 ; W:LRPG>1 !?20,">> CONTINUATION OF ",LRACC," <<",?70,"page ",LRPG
+40 ;----- END IHS MODIFICATIONS LR*5.2*1022 -- Institution Name & Address
+41 QUIT
+42 ;
WAIT ; EP - from LRMIPSZ1, LRMIPSZ2
+1 ;
+2 ;The following lines added per Appendix A of RPMS Lab E-Sig Enhancement V 5.2 Techinical Manual IHS/HQW/SCR - 8/23/01
+3 ;IHS/HQW/SCR-8/23/01
IF $PIECE($GET(XQY0),U)="LLRS"!($PIECE($GET(XQY0),U)="LRRS BY LOC")!($PIECE($GET(XQY0),U)="LRRD")!($PIECE($GET(XQY0),U)="LRRP2")!($PIECE($GET(XQY0),U)="BLR LRRD BY MD")
Begin DoDot:1
+4 ;IHS/HQW/SCR-8/23/01
IF $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2))
DO ^BLRALAU
End DoDot:1
+5 ;
+6 ; D IHSKEY ; IHS/OIT/MKK - LR*5.2*1030
+7 ; IHS/OIT/MKK - LR*5.2*1039
IF IOST["C-VT"
DO IHSKEY
+8 ;
+9 FOR I=$Y:1:IOSL-3
WRITE !
+10 ;I 'LRHC W !,PNM,?25," ",SSN," ROUTING: ",LRPATLOC,?59," PRESS '^' TO STOP " R X:DTIME S:X="" X=1 S:(".^"[X)!('$T) LREND=1
+11 ;IHS/ANMC/CLS 08/18/96
IF 'LRHC
WRITE !,PNM,?25," ",HRCN," ROUTING: ",LRPATLOC,?59," PRESS '^' TO STOP "
READ X:DTIME
IF X=""
SET X=1
IF (".^"[X)!('$TEST)
SET LREND=1
+12 QUIT
PRE ;EP - from LRMIPSZ2, LRMIPSZ3, LRMIPSZ4
+1 IF LRTUS["F"&('$DATA(^XUSEC("LRLAB",DUZ))!$DATA(LRWRDVEW))
QUIT
IF +$ORDER(^LR(LRDFN,"MI",LRIDT,LRPRE,0))
WRITE !,"Preliminary Comments: "
SET J=0
FOR I=0:0
SET J=+$ORDER(^LR(LRDFN,"MI",LRIDT,LRPRE,J))
IF J<1
QUIT
WRITE !?3,^(J,0)
+2 WRITE !
+3 QUIT
