LRMISR ;SLC/CJS/BA - INPUT TRANSFORM FOR ANTIBIOTIC SENSITIVITIES ;6/14/89 08:36 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
;input transform for antibiotics
FILE I $L(X)>20!($L(X)<1) K X Q
S C6=+$O(^LAB(62.06,"C",$P(DQ(DQ),U),0)) I X["*" D STAR^LRMISR1 D @$S($D(X):"SET",1:"OUT") Q
I '$D(^LAB(62.06,C6,1,"B",X)) K X,C6 Q
S LRBN=+$P(DQ(DQ),U,4) I 'LRBN K C6,LRBN Q
S LRR=X D IS^LRMISR1
SET S $P(^LR(LRDFN,"MI",DA(1),3,DA,LRBN),U,2)=LRISR,$P(^(LRBN),U,3)=LRSCREEN W:$L(LRISR) " (",LRISR,")" I $L(LRSCREEN) W $S(LRSCREEN="N":" (not displayed)",LRSCREEN="R":" (restricted display)",1:"")
OUT K C6,C4,C2,LRBN,LRR,LRISR,LRSCREEN
Q
EN ;help prompts for antibiotic interpretations
S LRBN=+$P(DQ(DQ),U,4) Q:'LRBN S C8=$S($D(^LR(LRDFN,"MI",LRIDT,3,DA,LRBN))#2:^(LRBN),1:"")
I $L($P(C8,U)) W !,"Result: ",$P(C8,U),?25,"Interpretation: ",$S($L($P(C8,U,2)):$P(C8,U,2),1:$P(C8,U)),?53,"Screen: ",$S($P(C8,U,3)="N":"Never",$P(C8,U,3)="R":"Restricted",1:"Always")," Display",!
S C6=+$O(^LAB(62.06,"C",$P(DQ(DQ),U),0)) W !,"CHOOSE FROM:"
S LRR="" F A6=0:1 S LRR=$O(^LAB(62.06,C6,1,"B",LRR)) Q:LRR="" S C4=+$O(^(LRR,0)) D INTRP^LRMISR1 W ?15,LRR,?24,$S('A6:" FOR: ",1:" "),?32,LRISR,! K C2,C4,LRISR
K A6,C6,C8,LRBN,LRR
Q
HELP S XQH="LRHM LRMIEDZ Example1" H 1 D EN^XQH K X
Q
INT I '$D(^LAB(62.06,"AJ",$P($P(DQ(DQ),U,4),";"),X)) K X
Q
HINT W !,"Interpretations for this antibiotic:" S J=0 F I=0:0 S J=$O(^LAB(62.06,"AJ",$P($P(DQ(DQ),U,4),";"),J)) Q:J="" W !,?25,J
Q
COM ;input transform for AFB antibiotics - will expand lab descriptions
I $L(X)>20!($L(X)<1)!(X'?.ANP) K X Q
S B3="" F A6=1:1 Q:$P(X," ",A6,99)="" S B6=$P(X," ",A6) D:B6]"" Z2 S A4=$L(B3)+$L(B6) S:A4'>68 B3=B3_B6_" " I A4>68 W " too long",! K X Q
W " (",$E(B3,1,$L(B3)-1),")" S X=B3 K A4,A6,B3,B6
Q
Z2 S A2=0 F I=0:0 S A2=$O(^LAB(62.5,"B",B6,A2)) Q:A2<1 I "KMTVP"[$P(^LAB(62.5,A2,0),U,4) S B6=$P(^LAB(62.5,A2,0),U,2) Q:'$D(^(9)) S B4=$P(X," ",A6-1),B4=$E(B4,$L(B4)) S:B4>1 B6=^(9) Q
K A2,B4
Q
ZQ ;AFB prompts from lab descriptions
S X=$S(X="??":"??",1:"?"),DIC="^LAB(62.5,",DIC(0)="Q",DIC("S")="I ""KMTVP""[$P(^(0),U,4)",D="B",DZ=X K DO D DQ^DICQ K DIC S DIC=DIE D DO^DIC1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMISR 2187 printed Dec 13, 2024@02:17:25 Page 2
LRMISR ;SLC/CJS/BA - INPUT TRANSFORM FOR ANTIBIOTIC SENSITIVITIES ;6/14/89 08:36 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 ;input transform for antibiotics
FILE IF $LENGTH(X)>20!($LENGTH(X)<1)
KILL X
QUIT
+1 SET C6=+$ORDER(^LAB(62.06,"C",$PIECE(DQ(DQ),U),0))
IF X["*"
DO STAR^LRMISR1
DO @$SELECT($DATA(X):"SET",1:"OUT")
QUIT
+2 IF '$DATA(^LAB(62.06,C6,1,"B",X))
KILL X,C6
QUIT
+3 SET LRBN=+$PIECE(DQ(DQ),U,4)
IF 'LRBN
KILL C6,LRBN
QUIT
+4 SET LRR=X
DO IS^LRMISR1
SET SET $PIECE(^LR(LRDFN,"MI",DA(1),3,DA,LRBN),U,2)=LRISR
SET $PIECE(^(LRBN),U,3)=LRSCREEN
if $LENGTH(LRISR)
WRITE " (",LRISR,")"
IF $LENGTH(LRSCREEN)
WRITE $SELECT(LRSCREEN="N":" (not displayed)",LRSCREEN="R":" (restricted display)",1:"")
OUT KILL C6,C4,C2,LRBN,LRR,LRISR,LRSCREEN
+1 QUIT
EN ;help prompts for antibiotic interpretations
+1 SET LRBN=+$PIECE(DQ(DQ),U,4)
if 'LRBN
QUIT
SET C8=$SELECT($DATA(^LR(LRDFN,"MI",LRIDT,3,DA,LRBN))#2:^(LRBN),1:"")
+2 IF $LENGTH($PIECE(C8,U))
WRITE !,"Result: ",$PIECE(C8,U),?25,"Interpretation: ",$SELECT($LENGTH($PIECE(C8,U,2)):$PIECE(C8,U,2),1:$PIECE(C8,U)),?53,"Screen: ",$SELECT($PIECE(C8,U,3)="N":"Never",$PIECE(C8,U,3)="R":"Restricted",1:"Always")," Display",!
+3 SET C6=+$ORDER(^LAB(62.06,"C",$PIECE(DQ(DQ),U),0))
WRITE !,"CHOOSE FROM:"
+4 SET LRR=""
FOR A6=0:1
SET LRR=$ORDER(^LAB(62.06,C6,1,"B",LRR))
if LRR=""
QUIT
SET C4=+$ORDER(^(LRR,0))
DO INTRP^LRMISR1
WRITE ?15,LRR,?24,$SELECT('A6:" FOR: ",1:" "),?32,LRISR,!
KILL C2,C4,LRISR
+5 KILL A6,C6,C8,LRBN,LRR
+6 QUIT
HELP SET XQH="LRHM LRMIEDZ Example1"
HANG 1
DO EN^XQH
KILL X
+1 QUIT
INT IF '$DATA(^LAB(62.06,"AJ",$PIECE($PIECE(DQ(DQ),U,4),";"),X))
KILL X
+1 QUIT
HINT WRITE !,"Interpretations for this antibiotic:"
SET J=0
FOR I=0:0
SET J=$ORDER(^LAB(62.06,"AJ",$PIECE($PIECE(DQ(DQ),U,4),";"),J))
if J=""
QUIT
WRITE !,?25,J
+1 QUIT
COM ;input transform for AFB antibiotics - will expand lab descriptions
+1 IF $LENGTH(X)>20!($LENGTH(X)<1)!(X'?.ANP)
KILL X
QUIT
+2 SET B3=""
FOR A6=1:1
if $PIECE(X," ",A6,99)=""
QUIT
SET B6=$PIECE(X," ",A6)
if B6]""
DO Z2
SET A4=$LENGTH(B3)+$LENGTH(B6)
if A4'>68
SET B3=B3_B6_" "
IF A4>68
WRITE " too long",!
KILL X
QUIT
+3 WRITE " (",$EXTRACT(B3,1,$LENGTH(B3)-1),")"
SET X=B3
KILL A4,A6,B3,B6
+4 QUIT
Z2 SET A2=0
FOR I=0:0
SET A2=$ORDER(^LAB(62.5,"B",B6,A2))
if A2<1
QUIT
IF "KMTVP"[$PIECE(^LAB(62.5,A2,0),U,4)
SET B6=$PIECE(^LAB(62.5,A2,0),U,2)
if '$DATA(^(9))
QUIT
SET B4=$PIECE(X," ",A6-1)
SET B4=$EXTRACT(B4,$LENGTH(B4))
if B4>1
SET B6=^(9)
QUIT
+1 KILL A2,B4
+2 QUIT
ZQ ;AFB prompts from lab descriptions
+1 SET X=$SELECT(X="??":"??",1:"?")
SET DIC="^LAB(62.5,"
SET DIC(0)="Q"
SET DIC("S")="I ""KMTVP""[$P(^(0),U,4)"
SET D="B"
SET DZ=X
KILL DO
DO DQ^DICQ
KILL DIC
SET DIC=DIE
DO DO^DIC1
+2 QUIT
