Routine: LRMISEZ2

LRMISEZ2 ; IHS/DIR/AAB - MICRO INFECTION CTRL SURVEY 10/1/87 17:12 ; [ 05/15/2003  12:30 PM ]

 ;;5.2T9;LR;**1006,1018**;Nov 17, 2004

 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994

 ;from LRMISEZ1

TYPE I LRM("L")'="N" S LRPG=0,S="LOC" D HDR,M W @IOF

 I LRM("O")'="N" D ^LRMISEZ3 W @IOF

 I LRM("D")'="N" S LRPG=0,S="DOC" D HDR,M W @IOF

 I LRM("P")'="N" S LRPG=0,S="PAT" D HDR,M W @IOF

M S M=0 F I=0:0 S M=$O(^TMP($J,S,M)) Q:M=""  S LRAD=$E(M,1,3)_"0000",Y=M_"00" D D^LRU S LRMY=Y D LLOC

LLOC S LRLLOC=0 F I=0:0 S LRLLOC=$O(^TMP($J,S,M,LRLLOC)) Q:LRLLOC=""  D:$Y>61 HDR D NLOC W !!,$E($P(LRNLOC,U),1,25) W:S'="PAT" ! S LRPAT=0,X=43 D:S'="PAT" LIN D NAME

NLOC I S="LOC" S LRNLOC=LRLLOC Q

 S LRNLOC=$P(LRLLOC,U,2) I S="PAT" S LRNLOC=^TMP($J,"XPAT",LRNLOC) Q

 I S="DOC" S LRNLOC=$S(LRNLOC="":"Unknown",1:^TMP($J,"XDOC",LRNLOC))

NAME S LRNAME=0 F I=0:0 S LRNAME=$O(^TMP($J,S,M,LRLLOC,LRNAME)) Q:LRNAME=""  D:$Y>61 HDR,LD D SIT

SIT S LRSIT=0 F I=0:0 S LRSIT=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT)) Q:LRSIT=""  D:$Y>61 HDR,LD D AC

AC S (LRAC,LRSUM)=0 F I=0:0 S LRAC=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC)) Q:LRAC=""  D:$Y>61 HDR,LD D OR

OR S LROR=0 F I=0:0 S LROR=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR)) Q:LROR=""  D:$Y>61 HDR,LD D BG

BG S LRBG=0 F I=0:0 S LRBG=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG)) Q:LRBG=""  S:S="LOC" ^TMP($J,"SE",LRBG,M,LRLLOC,LRSIT,LRAC,LROR,LRNAME)=$P(^(LRBG),U,1,4) S LRBUG=$P(^LAB(61.2,+$E(LRBG,4,25),0),U) D:$Y>61 HDR,LD D FX

FX ;S X=^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG),SSN=$P(X,U,2),LRQUANT=$P(X,U,3),X=+X,LRDAT=$$Y2K^LRX(X)_" ",LRPNM=$P(LRNAME,U)

 S X=^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG),SSN=$P(X,U,2),HRCN=$P(X,U,2),LRQUANT=$P(X,U,3),X=+X,LRDAT=$$Y2K^LRX(X)_" ",LRPNM=$P(LRNAME,U)  ;IHS/ANMC/CLS 08/18/96

 ;I 'LRPAT,S="PAT" W ?25,$E(SSN,1,3),"-",$E(SSN,4,5),"-",$E(SSN,6,9),! S LRPAT=1,X=43 D LIN

 I 'LRPAT,S="PAT" W ?25,HRCN,! S LRPAT=1,X=43 D LIN  ;IHS/ANMC/CLS 08/18/96

 I $Y>61 D HDR,LD W !,$E(LRBUG,1,13),?13,$E($P(LRSIT,U),1,7)

 ;W:S'="PAT" !,$E(LRPNM,1,10),?11,SSN,?21,LRDAT,$E($P(LRSIT,U),1,7)," Quantity: ",LRQUANT

 W:S'="PAT" !,$E(LRPNM,1,10),?11,HRCN,?21,LRDAT,$E($P(LRSIT,U),1,7)," Quantity: ",LRQUANT  ;IHS/ANMC/CLS 08/18/96

 W:S="PAT" !,LRDAT,$E($P(LRSIT,U),1,7)," Quantity: ",LRQUANT

 S LRSUM=LRSUM+1 W !?2,$E(LRBUG,1,32),?34,$J(LRSUM,3),")",?37,$J(LRAC,5),?43

 S LRLIN="",$P(LRLIN,"| ",O+1)="|"

 S LRYA=0 F I=0:0 S LRYA=$O(^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG,LRYA)) Q:LRYA=""  D NOD S:S="LOC" ^TMP($J,"SE",LRBG,M,LRLLOC,LRSIT,LRAC,LROR,LRNAME,LRYA)=^(LRYA)

 W LRLIN,!

NOD Q:'$D(LRZ(LRYA))  S $P(LRLIN,"|",LRZ(LRYA)+1)=^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG,LRYA)

HDR S LRPG=LRPG+1,%DT="T",X="N" D ^%DT,D^LRU W @IOF,!,Y,?21,"INFECTION CONTROL SURVEY REPORT BY ",$S(S="LOC":"LOCATION",S="DOC":"PROVIDER",1:"PATIENT"),?70,"PAGE ",$J(LRPG,5)

 I LRLOS W !,?2,"** Reports only those specimens collected > ",LRLOS,$S(LRLOS>1:" days",1:" day")," from admission date **"

 W !,LRAAN,?6,"From: ",LRST," To: ",LRLST,?43 F I=0:0 S I=$O(B(I)) Q:I=""  W "|",$E($P(B(I),U,2),1)

 ;W "|",!,$S(S="LOC":"Location",S="DOC":"Provider",1:"Patient") W:S="PAT" ?25,"SSN" W ?43 F I=0:0 S I=$O(B(I)) Q:I=""  W "|",$E($P(B(I),U,2),2)

 W "|",!,$S(S="LOC":"Location",S="DOC":"Provider",1:"Patient") W:S="PAT" ?25,"HRCN" W ?43 F I=0:0 S I=$O(B(I)) Q:I=""  W "|",$E($P(B(I),U,2),2)  ;IHS/ANMC/CLS 08/18/96

 ;W:S'="PAT" "|",!,?2,"Patient",?11,"SSN",?21,"Date",?30,$S(LRSIT(1)="S":"Spec",1:"Sample"),?43

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS TESTING CHANGE

 W:S'="PAT" "|",!,?2,"Patient",?11,"HCRN",?21,"Date",?30,$S(LRSIT(1)="S":"Spec",1:"Sample"),?43

 ;----- END IHS MODIFICATIONS

 W:S="PAT" "|",!,?2,"Date",?11,"Spec",?43

 F I=0:0 S I=$O(B(I)) Q:I=""  W "|",$E($P(B(I),U,2),3)

 I $D(LRAP) W "|",!,?10,"** ANTIBIOTIC PATTERN **",?43 F I=0:0 S I=$O(B(I)) Q:I=""  W "|",$S($L($P(B(I),U,3)):$P(B(I),U,3),1:" ")

 W "|",! F A1=1:1:IOM-1 W "-"

LD W !!,$E($P(LRNLOC,U),1,14),?15,LRMY,":" S X=$X W ! D LIN

LIN F A1=1:1:X W "-"

LRMISEZ2  ; IHS/DIR/AAB - MICRO INFECTION CTRL SURVEY 10/1/87 17:12 ; [ 05/15/2003  12:30 PM ]

 +1       ;;5.2T9;LR;**1006,1018**;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**201**;Sep 27, 1994

 +3       ;from LRMISEZ1

TYPE       IF LRM("L")'="N"

               SET LRPG=0

               SET S="LOC"

               DO HDR

               DO M

               WRITE @IOF

 +1        IF LRM("O")'="N"

               DO ^LRMISEZ3

               WRITE @IOF

 +2        IF LRM("D")'="N"

               SET LRPG=0

               SET S="DOC"

               DO HDR

               DO M

               WRITE @IOF

 +3        IF LRM("P")'="N"

               SET LRPG=0

               SET S="PAT"

               DO HDR

               DO M

               WRITE @IOF

 +4        QUIT

M          SET M=0

           FOR I=0:0

               SET M=$ORDER(^TMP($JOB,S,M))

               IF M=""

                   QUIT

               SET LRAD=$EXTRACT(M,1,3)_"0000"

               SET Y=M_"00"

               DO D^LRU

               SET LRMY=Y

               DO LLOC

 +1        QUIT

LLOC       SET LRLLOC=0

           FOR I=0:0

               SET LRLLOC=$ORDER(^TMP($JOB,S,M,LRLLOC))

               IF LRLLOC=""

                   QUIT

               IF $Y>61

                   DO HDR

               DO NLOC

               WRITE !!,$EXTRACT($PIECE(LRNLOC,U),1,25)

               IF S'="PAT"

                   WRITE !

               SET LRPAT=0

               SET X=43

               IF S'="PAT"

                   DO LIN

               DO NAME

 +1        QUIT

NLOC       IF S="LOC"

               SET LRNLOC=LRLLOC

               QUIT

 +1        SET LRNLOC=$PIECE(LRLLOC,U,2)

           IF S="PAT"

               SET LRNLOC=^TMP($JOB,"XPAT",LRNLOC)

               QUIT

 +2        IF S="DOC"

               SET LRNLOC=$SELECT(LRNLOC="":"Unknown",1:^TMP($JOB,"XDOC",LRNLOC))

 +3        QUIT

NAME       SET LRNAME=0

           FOR I=0:0

               SET LRNAME=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME))

               IF LRNAME=""

                   QUIT

               IF $Y>61

                   DO HDR

                   DO LD

               DO SIT

 +1        QUIT

SIT        SET LRSIT=0

           FOR I=0:0

               SET LRSIT=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT))

               IF LRSIT=""

                   QUIT

               IF $Y>61

                   DO HDR

                   DO LD

               DO AC

 +1        QUIT

AC         SET (LRAC,LRSUM)=0

           FOR I=0:0

               SET LRAC=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC))

               IF LRAC=""

                   QUIT

               IF $Y>61

                   DO HDR

                   DO LD

               DO OR

 +1        QUIT

OR         SET LROR=0

           FOR I=0:0

               SET LROR=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR))

               IF LROR=""

                   QUIT

               IF $Y>61

                   DO HDR

                   DO LD

               DO BG

 +1        QUIT

BG         SET LRBG=0

           FOR I=0:0

               SET LRBG=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG))

               IF LRBG=""

                   QUIT

               IF S="LOC"

                   SET ^TMP($JOB,"SE",LRBG,M,LRLLOC,LRSIT,LRAC,LROR,LRNAME)=$PIECE(^(LRBG),U,1,4)

               SET LRBUG=$PIECE(^LAB(61.2,+$EXTRACT(LRBG,4,25),0),U)

               IF $Y>61

                   DO HDR

                   DO LD

               DO FX

 +1        QUIT

FX        ;S X=^TMP($J,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG),SSN=$P(X,U,2),LRQUANT=$P(X,U,3),X=+X,LRDAT=$$Y2K^LRX(X)_" ",LRPNM=$P(LRNAME,U)

 +1       ;IHS/ANMC/CLS 08/18/96

           SET X=^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG)

           SET SSN=$PIECE(X,U,2)

           SET HRCN=$PIECE(X,U,2)

           SET LRQUANT=$PIECE(X,U,3)

           SET X=+X

           SET LRDAT=$$Y2K^LRX(X)_" "

           SET LRPNM=$PIECE(LRNAME,U)

 +2       ;I 'LRPAT,S="PAT" W ?25,$E(SSN,1,3),"-",$E(SSN,4,5),"-",$E(SSN,6,9),! S LRPAT=1,X=43 D LIN

 +3       ;IHS/ANMC/CLS 08/18/96

           IF 'LRPAT

               IF S="PAT"

                   WRITE ?25,HRCN,!

                   SET LRPAT=1

                   SET X=43

                   DO LIN

 +4        IF $Y>61

               DO HDR

               DO LD

               WRITE !,$EXTRACT(LRBUG,1,13),?13,$EXTRACT($PIECE(LRSIT,U),1,7)

 +5       ;W:S'="PAT" !,$E(LRPNM,1,10),?11,SSN,?21,LRDAT,$E($P(LRSIT,U),1,7)," Quantity: ",LRQUANT

 +6       ;IHS/ANMC/CLS 08/18/96

           IF S'="PAT"

               WRITE !,$EXTRACT(LRPNM,1,10),?11,HRCN,?21,LRDAT,$EXTRACT($PIECE(LRSIT,U),1,7)," Quantity: ",LRQUANT

 +7        IF S="PAT"

               WRITE !,LRDAT,$EXTRACT($PIECE(LRSIT,U),1,7)," Quantity: ",LRQUANT

 +8        SET LRSUM=LRSUM+1

           WRITE !?2,$EXTRACT(LRBUG,1,32),?34,$JUSTIFY(LRSUM,3),")",?37,$JUSTIFY(LRAC,5),?43

 +9        SET LRLIN=""

           SET $PIECE(LRLIN,"| ",O+1)="|"

 +10       SET LRYA=0

           FOR I=0:0

               SET LRYA=$ORDER(^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG,LRYA))

               IF LRYA=""

                   QUIT

               DO NOD

               IF S="LOC"

                   SET ^TMP($JOB,"SE",LRBG,M,LRLLOC,LRSIT,LRAC,LROR,LRNAME,LRYA)=^(LRYA)

 +11       WRITE LRLIN,!

 +12       QUIT

NOD        IF '$DATA(LRZ(LRYA))

               QUIT

           SET $PIECE(LRLIN,"|",LRZ(LRYA)+1)=^TMP($JOB,S,M,LRLLOC,LRNAME,LRSIT,LRAC,LROR,LRBG,LRYA)

 +1        QUIT

HDR        SET LRPG=LRPG+1

           SET %DT="T"

           SET X="N"

           DO ^%DT

           DO D^LRU

           WRITE @IOF,!,Y,?21,"INFECTION CONTROL SURVEY REPORT BY ",$SELECT(S="LOC":"LOCATION",S="DOC":"PROVIDER",1:"PATIENT"),?70,"PAGE ",$JUSTIFY(LRPG,5)

 +1        IF LRLOS

               WRITE !,?2,"** Reports only those specimens collected > ",LRLOS,$SELECT(LRLOS>1:" days",1:" day")," from admission date **"

 +2        WRITE !,LRAAN,?6,"From: ",LRST," To: ",LRLST,?43

           FOR I=0:0

               SET I=$ORDER(B(I))

               IF I=""

                   QUIT

               WRITE "|",$EXTRACT($PIECE(B(I),U,2),1)

 +3       ;W "|",!,$S(S="LOC":"Location",S="DOC":"Provider",1:"Patient") W:S="PAT" ?25,"SSN" W ?43 F I=0:0 S I=$O(B(I)) Q:I=""  W "|",$E($P(B(I),U,2),2)

 +4       ;IHS/ANMC/CLS 08/18/96

           WRITE "|",!,$SELECT(S="LOC":"Location",S="DOC":"Provider",1:"Patient")

           IF S="PAT"

               WRITE ?25,"HRCN"

           WRITE ?43

           FOR I=0:0

               SET I=$ORDER(B(I))

               IF I=""

                   QUIT

               WRITE "|",$EXTRACT($PIECE(B(I),U,2),2)

 +5       ;W:S'="PAT" "|",!,?2,"Patient",?11,"SSN",?21,"Date",?30,$S(LRSIT(1)="S":"Spec",1:"Sample"),?43

 +6       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS TESTING CHANGE

 +7        IF S'="PAT"

               WRITE "|",!,?2,"Patient",?11,"HCRN",?21,"Date",?30,$SELECT(LRSIT(1)="S":"Spec",1:"Sample"),?43

 +8       ;----- END IHS MODIFICATIONS

 +9        IF S="PAT"

               WRITE "|",!,?2,"Date",?11,"Spec",?43

 +10       FOR I=0:0

               SET I=$ORDER(B(I))

               IF I=""

                   QUIT

               WRITE "|",$EXTRACT($PIECE(B(I),U,2),3)

 +11       IF $DATA(LRAP)

               WRITE "|",!,?10,"** ANTIBIOTIC PATTERN **",?43

               FOR I=0:0

                   SET I=$ORDER(B(I))

                   IF I=""

                       QUIT

                   WRITE "|",$SELECT($LENGTH($PIECE(B(I),U,3)):$PIECE(B(I),U,3),1:" ")

 +12       WRITE "|",!

           FOR A1=1:1:IOM-1

               WRITE "-"

 +13       QUIT

LD         WRITE !!,$EXTRACT($PIECE(LRNLOC,U),1,14),?15,LRMY,":"

           SET X=$X

           WRITE !

           DO LIN

 +1        QUIT

LIN        FOR A1=1:1:X

               WRITE "-"

 +1        QUIT

LRMISEZ2.m