BOPT3 ;IHS/ILC/ALG/CIA/PLS - Transmitter ORC/OBX/RXE/RXR;20-Nov-2006 09:44;SM
;;1.0;AUTOMATED DISPENSING INTERFACE;**1,2**;Jul 26, 2005
;
; Modified - IHS/MSC/PLS - 11/20/06 - Line AL1 - Changed to support allergies
Q
ORC ;EP - Common Order Segment
N ORCC,PLCON,ORSTAT,ORDTM,WHO1,WHO2,PDOC,X,QT,BOPWHO,PDOCID
S NODE2=^BOP(90355.1,COUNTER,2)
S NODE3=^BOP(90355.1,COUNTER,3)
S ORCC=$P(NODE2,"^",1)
S PLCON=$P(NODE2,"^",8)
S ORSTAT=$P(NODE2,"^",3)
S ORDTM=$P(NODE2,"^",4)
S ORDTM=$$HLDATE^HLFNC(ORDTM),ORDTM=$P(ORDTM,"-",1)
S BOPWHO=$$INTFACE^BOPTU(1)
S BFLD="||||||||||"
S X=$P(NODE2,"^",5)
S WHO1=$$HLNAME^HLFNC(X)
S X=$P(NODE2,"^",6)
S WHO2=$$HLNAME^HLFNC(X)
S X=$P(NODE2,"^",7)
S PDOC=$$HLNAME^HLFNC(X)
S PDOCID=$P($P(NODE2,U,9),"-",3)
S QT="" I BOPWHO="P" S QT=$$QT^BOPT3(NODE3)
S OUT5="ORC"_FLD_ORCC_FLD_PLCON_FLD_FLD_FLD_ORSTAT_FLD_FLD_QT_FLD_FLD_ORDTM_FLD_COM_WHO1_FLD_COM_WHO2_FLD_PDOCID_COM_PDOC_"|"_$C(13)
S CONT=CONT+1,OUT(CONT)=OUT5
Q
RXE ;EP - RXE SEGMENT
N QT,GC1,GC2,GAMN,GAMX,GUNIT,GUNITXT,GDOSE,PRINST,QUAN
N SPINST,ISINST,OUT6,NODE3,NODE4,NODE5,NODE6
S NODE3=^BOP(90355.1,COUNTER,3)
S NODE4=^BOP(90355.1,COUNTER,4)
S BOPWHO=$$INTFACE^BOPTU(1)
S GC1=$P(NODE4,"^",1)
S GC2=$P(NODE4,"^",2)
S GAMN=$P(NODE4,"^",3)
S GAMX=$P(NODE4,"^",4)
S GUNIT=$P(NODE4,"^",5)
S GUNITXT=$P(NODE4,"^",6)
S GDOSE=$P(NODE4,"^",7),GDOSE=COM_GDOSE
S NODE5=^BOP(90355.1,COUNTER,5)
S PRINST=$P(NODE5,"^",1)
S QUAN=$P(NODE5,"^",2)
S NODE6=^BOP(90355.1,COUNTER,6)
S SPINST=$P(NODE6,"^",1)
S ISINST=$P(NODE6,"^",2)
S SMFLD="|||||"
S BFLD="||||||||||"
S QT=$$QT(NODE3)
I BOPWHO="P" D QUIT
. S BOPMM=$$MINMAX(GAMN) S GAMN=$P(BOPMM,U),GUNIT=$P(BOPMM,U,2),GAMX=$P(BOPMM,U,3)
. S OUT6="RXE"_FLD_QT_FLD_GC1_COM_GC2_FLD_GAMN_FLD_GAMX_FLD
. S OUT6=OUT6_GUNIT_COM_GUNITXT_FLD_GDOSE_FLD_ISINST
. S OUT6=OUT6_FLD_FLD_FLD_QUAN_"||||"_$C(13)
. S CONT=CONT+1
. S OUT(CONT)=OUT6
S BOPMM=$$MINMAX(GAMN) S GAMN=$P(BOPMM,U),GUNIT=$P(BOPMM,U,2),GAMX=$P(BOPMM,U,3)
;
S QT="" I BOPWHO="O" S QT=$$QT^BOPT3(NODE3)
S OUT6="RXE"_FLD_QT_FLD_GC1_COM_GC2_FLD_GAMN_FLD_GAMX_FLD
I RECAPP="SUREMED" S OUT6=OUT6_GUNIT_FLD_GDOSE_FLD_ISINST
E S OUT6=OUT6_GUNIT_COM_GUNITXT_FLD_GDOSE_FLD_ISINST
S BOPMLEN=$L(OUT6),BOPMPIN=$L(PRINST) I BOPMLEN+BOPMPIN>252 S PRINST="INSTR TOO LONG-SEE VISTA ORDER FOR DETAILS"
S OUT6=OUT6_FLD_FLD_FLD_QUAN_"|||||||||||"_PRINST
I $P(NODE3,U,11)&($P(NODE3,U,8)'="") N A,B S A=+$P(NODE3,U,8) S:A>0 $P(OUT6,FLD,24)=A S B="" D S $P(OUT6,FLD,25)=B K A,B
. S A=$P(NODE3,U,8) N I F I=1:1:$L(A) I $E(A,I)?1A Q
. S B=$E(A,I,$L(A))
. K I Q
S OUT6=OUT6_$C(13)
S CONT=CONT+1
S OUT(CONT)=OUT6
Q
OBXH ;EP - OBX record
S X=$P($G(^BOP(90355.1,COUNTER,9)),U) I X S CONT=CONT+1 D
.S OUT(CONT)="OBX||ST|1010.3^HEIGHT||"_X_"|cm|"_$C(13)
Q
OBXW ;EP - OBX weight
S X=$P($G(^BOP(90355.1,COUNTER,9)),U,2) I X S CONT=CONT+1 D
.S OUT(CONT)="OBX||ST|1010.1^WEIGHT||"_X_"|kg|"_$C(13)
Q
DG1 ;EP - DG1 record
; I $G(BOPVA(9))]"" S CONT=CONT+1,OUT(CONT)="DG1||||"_BOPVA(9)_"|"_$C(13)
S BOPWHO=$$INTFACE^BOPTU(1)
I X=5 G DG15
; free text diag from admit
S X=$G(^BOP(90355.1,COUNTER,12)) I X="" Q
S CONT=CONT+1,OUT(CONT)="DG1||||^"_X_"|"_$C(13)
Q
DG15 ; discharge icd9
S X=$G(^BOP(90355.1,COUNTER,14)) I X="" Q
S A=$$HLDATE^HLFNC($P(X,U,3)),A=$P(A,"-",1)
S CONT=CONT+1,OUT(CONT)="DG1|"_($S(BOPWHO="P":"|I9|",1:"1||"))_$P(X,U,1)_U_$P(X,U,2)_"||"_A_"|||||||||||"_$C(13)
Q
AL1 ;EP - AL1 record
N X,BOPN
Q:'$P($G(^BOP(90355.1,COUNTER,11,0)),U,4)
S BOPN=0 F S BOPN=$O(^BOP(90355.1,COUNTER,11,BOPN)) Q:'BOPN D
.S X=$G(^BOP(90355.1,COUNTER,11,BOPN,0))
.Q:X=""
.S A=$P(X,U,2)_U_$P(X,U,1)
.S CONT=CONT+1,OUT(CONT)="AL1||DA|"_A_"|"_$C(13)
Q
RXR ;EP - Build RXR
S BOPWHO=$$INTFACE^BOPTU(1)
S NODE3=^BOP(90355.1,COUNTER,3)
S NODE8=^BOP(90355.1,COUNTER,8)
S ROUTE=$P(NODE8,"^",1)
I BOPWHO="P" S OUT7="RXR"_FLD_COM_ROUTE_FLD_$C(13) D FIN Q
I RECAPP="SUREMED" S OUT7="RXR"_FLD_ROUTE_FLD_$C(13)
E S OUT7="RXR"_FLD_COM_ROUTE_FLD D S OUT7=OUT7_$C(13)
. I '$P(NODE3,U,11) Q
. N A S A=$P(NODE3,U,5) I A'="" S $P(OUT7,FLD,5)=$S(A="A":"ADMIXTURE",A="P":"PIGGYBACK",A="H":"HYPERAL",A="S":"SYRINGE",A="C":"CHEMOTHERAPY",1:"")
. K A Q
FIN S CONT=CONT+1
S OUT(CONT)=OUT7
K ROUTE,NODE8,OUT7
Q
DOW ;SU;MO;TU;WE;TH;FR;SA
Q
QT(Y) ; EP
; get the quantity/timing of the order
; Y is from node3 ^BOP(90355.1,COUNTER
; W IS IV FLAG
;
N PSGSCH,PSGSD,PSGFD,PSGST,PSGS0Y,X,I,L,P,DOW
S PSGSCH=$P(Y,U)
S PSGSD=$P(Y,U,3),PSGSD=$$HLDATE^HLFNC(PSGSD),PSGSD=$P(PSGSD,"-",1)
S PSGFD=$P(Y,U,4),PSGFD=$$HLDATE^HLFNC(PSGFD),PSGFD=$P(PSGFD,"-",1)
S PSGST=$P(Y,U,5)
S PSGS0Y=$P(Y,U,7),PSGS0Y=$TR(PSGS0Y,"-",",")
I $L(PSGS0Y) D
.F I=1:1:$L(PSGS0Y,",") D
..S P=$P(PSGS0Y,",",I),L=$L(P)
..I L<4 S X=P,P=X_$E("0000",1,4-L),$P(PSGS0Y,",",I)=P
S DOW="00000000"
N I F I=1:1:7 I PSGSCH[$P($T(DOW),";",I+1) S $E(DOW,I)=1
I DOW'[1 S DOW=""
S X=COM_PSGSCH_"&"_PSGS0Y_COM_COM_PSGSD_COM_PSGFD
I $P(Y,U,11) S X=COM_"c"_COM_COM_PSGSD_COM_PSGFD
I BOPWHO="P" Q X
S X=X_COM_COM_$S(RECAPP="SUREMED":"",PSGST="P":1,1:0)_COM_DOW
Q X
;
MINMAX(X) ; extract quantity and units from free text field
N AMT1,AMT2,I,UNITS,Y,Y1,Y2,B,C S (AMT1,AMT2,I,UNITS,Y,Y1,Y2)=""
F I=1:1:$L(X) I $E(X,I)?1C S $E(X,I)="" ;remove control chars
X ^%ZOSF("UPPERCASE") S Y=$TR(Y,",","") ; x=input y = output
; take out unnecessary spaces
I $E(Y)=" "!(Y[" ") F I=1:1:$L(Y) I $P(Y," ",I)]" " S Y1=Y1_$P(Y," ",I)_" "
I Y1 S Y=$E(Y1,1,$L(Y1)-1)
F I=1:1:$L(Y) I $E(Y,I)?1A,$E(Y,I-1)?1N S $E(Y,I)=" "_$E(Y,I) ;create spaces
F I=1:1:$L(Y) I $E(Y,I)?1N,$E(Y,I-1)?1A S $E(Y,I)=" "_$E(Y,I) ;create spaces
I $P(Y," ")?.A S B=$P(Y," ") D
. S $P(Y," ")=$S(B="ONE":1,B="TWO":2,B="THREE":3,B="FOUR":4,B="FIVE":5,B="SIX":6,B="SEVEN":7,B="EIGHT":8,B="NINE":9,1:B)
I $P(Y," ")?.A1"/".E S B=$P(Y,"/") D
. S C=$S(B="ONE":1,B="TWO":2,B="THREE":3,B="FOUR":4,B="FIVE":5,B="SIX":6,B="SEVEN":7,B="EIGHT":8,B="NINE":9,1:B)
. S $P(Y," ")=C_"/"_$P(Y,"/",2)
; in the first 3 pieces, find a number, then reorder the pieces
I '+Y D I '+Y S UNITS=X G MINMAXQ ; no units is unacceptable
. I +$P(Y," ",2) S Y=$P(Y," ",2,99)_" "_$P(Y," ",1)
. I +$P(Y," ",3) S Y=$P(Y," ",3,99)_" "_$P(Y," ",1,2)
I $P(Y," ")["/" S B=$P(Y," ") I B?1N1"/"1N S $P(Y," ")=$E($P(B,"/")/$P(B,"/",2),1,4)
I $P(Y," ",2)="TO"!($P(Y," ",2)="OR"),+$P(Y," ",3) S $P(Y," ",2)="-"
I Y["-" S:Y["- " $E(Y,$F(Y,"-"))="" S:Y[" -" $E(Y,$F(Y,"-")-2)=""
S Y1=$P(Y," ",1),UNITS=$P(Y," ",2,99) S:Y1["-" Y2=$P(Y1,"-",2),Y1=$P(Y1,"-",1) D ;->
. F I=1:1:$L(Y1) I $E(Y1,I)?1A D Q ;separaate dose amt num from units
. . S AMT1=+$E(Y1,1,I-1) I 'Y2 S UNITS=$E(Y1,I,99)_$S(UNITS="":UNITS,1:" "_UNITS)
I 'AMT1 S AMT1=+Y1
I Y2 F I=1:1:$L(Y2) I $E(Y2,I)?1A D Q ;if there is a maximum dose
. S AMT2=+$E(Y2,1,I-1),UNITS=$E(Y2,I,99)_$S(UNITS="":UNITS,1:" "_UNITS)
I Y2,'AMT2 S AMT2=+Y2
I Y2,AMT1>AMT2 S Y=AMT1,AMT1=AMT2,AMT2=Y ; min dose less than max
I UNITS="" S (AMT1,AMT2)="",UNITS=X G MINMAXQ ; no units is unacceptable
S:AMT1=AMT2 AMT2="" S:$E(AMT1)="." AMT1=0_AMT1 S:$E(AMT2)="." AMT2=0_AMT2
MINMAXQ Q AMT1_U_UNITS_U_AMT2
;
RXC ;EP
N A,B,C S (A,B,C)="",A=$O(^BOP(90355.1,COUNTER,20,0)) I A D ;
. S B=0 F S B=$O(^BOP(90355.1,COUNTER,20,B)) Q:'B S C=$G(^BOP(90355.1,COUNTER,20,B,0)) Q:C="" D ;
. . S CONT=CONT+1
. . S OUT(CONT)="RXC"_FLD_"B"_FLD_$P(C,U,1)_COM_$P(C,U,2)_FLD_$P(C,U,3)_$C(13)
S (A,B,C)="",A=$O(^BOP(90355.1,COUNTER,21,0)) I A D ;
. S B=0 F S B=$O(^BOP(90355.1,COUNTER,21,B)) Q:'B S C=$G(^BOP(90355.1,COUNTER,21,B,0)) Q:C="" D ;
. . S CONT=CONT+1
. . S OUT(CONT)="RXC"_FLD_"A"_FLD_$P(C,U,1)_COM_$P(C,U,2)_FLD_$P(C,U,3)_$C(13)
Q
BOPT3 ;IHS/ILC/ALG/CIA/PLS - Transmitter ORC/OBX/RXE/RXR;20-Nov-2006 09:44;SM
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1,2**;Jul 26, 2005
+2 ;
+3 ; Modified - IHS/MSC/PLS - 11/20/06 - Line AL1 - Changed to support allergies
+4 QUIT
ORC ;EP - Common Order Segment
+1 NEW ORCC,PLCON,ORSTAT,ORDTM,WHO1,WHO2,PDOC,X,QT,BOPWHO,PDOCID
+2 SET NODE2=^BOP(90355.1,COUNTER,2)
+3 SET NODE3=^BOP(90355.1,COUNTER,3)
+4 SET ORCC=$PIECE(NODE2,"^",1)
+5 SET PLCON=$PIECE(NODE2,"^",8)
+6 SET ORSTAT=$PIECE(NODE2,"^",3)
+7 SET ORDTM=$PIECE(NODE2,"^",4)
+8 SET ORDTM=$$HLDATE^HLFNC(ORDTM)
SET ORDTM=$PIECE(ORDTM,"-",1)
+9 SET BOPWHO=$$INTFACE^BOPTU(1)
+10 SET BFLD="||||||||||"
+11 SET X=$PIECE(NODE2,"^",5)
+12 SET WHO1=$$HLNAME^HLFNC(X)
+13 SET X=$PIECE(NODE2,"^",6)
+14 SET WHO2=$$HLNAME^HLFNC(X)
+15 SET X=$PIECE(NODE2,"^",7)
+16 SET PDOC=$$HLNAME^HLFNC(X)
+17 SET PDOCID=$PIECE($PIECE(NODE2,U,9),"-",3)
+18 SET QT=""
IF BOPWHO="P"
SET QT=$$QT^BOPT3(NODE3)
+19 SET OUT5="ORC"_FLD_ORCC_FLD_PLCON_FLD_FLD_FLD_ORSTAT_FLD_FLD_QT_FLD_FLD_ORDTM_FLD_COM_WHO1_FLD_COM_WHO2_FLD_PDOCID_COM_PDOC_"|"_$CHAR(13)
+20 SET CONT=CONT+1
SET OUT(CONT)=OUT5
+21 QUIT
RXE ;EP - RXE SEGMENT
+1 NEW QT,GC1,GC2,GAMN,GAMX,GUNIT,GUNITXT,GDOSE,PRINST,QUAN
+2 NEW SPINST,ISINST,OUT6,NODE3,NODE4,NODE5,NODE6
+3 SET NODE3=^BOP(90355.1,COUNTER,3)
+4 SET NODE4=^BOP(90355.1,COUNTER,4)
+5 SET BOPWHO=$$INTFACE^BOPTU(1)
+6 SET GC1=$PIECE(NODE4,"^",1)
+7 SET GC2=$PIECE(NODE4,"^",2)
+8 SET GAMN=$PIECE(NODE4,"^",3)
+9 SET GAMX=$PIECE(NODE4,"^",4)
+10 SET GUNIT=$PIECE(NODE4,"^",5)
+11 SET GUNITXT=$PIECE(NODE4,"^",6)
+12 SET GDOSE=$PIECE(NODE4,"^",7)
SET GDOSE=COM_GDOSE
+13 SET NODE5=^BOP(90355.1,COUNTER,5)
+14 SET PRINST=$PIECE(NODE5,"^",1)
+15 SET QUAN=$PIECE(NODE5,"^",2)
+16 SET NODE6=^BOP(90355.1,COUNTER,6)
+17 SET SPINST=$PIECE(NODE6,"^",1)
+18 SET ISINST=$PIECE(NODE6,"^",2)
+19 SET SMFLD="|||||"
+20 SET BFLD="||||||||||"
+21 SET QT=$$QT(NODE3)
+22 IF BOPWHO="P"
Begin DoDot:1
+23 SET BOPMM=$$MINMAX(GAMN)
SET GAMN=$PIECE(BOPMM,U)
SET GUNIT=$PIECE(BOPMM,U,2)
SET GAMX=$PIECE(BOPMM,U,3)
+24 SET OUT6="RXE"_FLD_QT_FLD_GC1_COM_GC2_FLD_GAMN_FLD_GAMX_FLD
+25 SET OUT6=OUT6_GUNIT_COM_GUNITXT_FLD_GDOSE_FLD_ISINST
+26 SET OUT6=OUT6_FLD_FLD_FLD_QUAN_"||||"_$CHAR(13)
+27 SET CONT=CONT+1
+28 SET OUT(CONT)=OUT6
End DoDot:1
QUIT
+29 SET BOPMM=$$MINMAX(GAMN)
SET GAMN=$PIECE(BOPMM,U)
SET GUNIT=$PIECE(BOPMM,U,2)
SET GAMX=$PIECE(BOPMM,U,3)
+30 ;
+31 SET QT=""
IF BOPWHO="O"
SET QT=$$QT^BOPT3(NODE3)
+32 SET OUT6="RXE"_FLD_QT_FLD_GC1_COM_GC2_FLD_GAMN_FLD_GAMX_FLD
+33 IF RECAPP="SUREMED"
SET OUT6=OUT6_GUNIT_FLD_GDOSE_FLD_ISINST
+34 IF '$TEST
SET OUT6=OUT6_GUNIT_COM_GUNITXT_FLD_GDOSE_FLD_ISINST
+35 SET BOPMLEN=$LENGTH(OUT6)
SET BOPMPIN=$LENGTH(PRINST)
IF BOPMLEN+BOPMPIN>252
SET PRINST="INSTR TOO LONG-SEE VISTA ORDER FOR DETAILS"
+36 SET OUT6=OUT6_FLD_FLD_FLD_QUAN_"|||||||||||"_PRINST
+37 IF $PIECE(NODE3,U,11)&($PIECE(NODE3,U,8)'="")
NEW A,B
SET A=+$PIECE(NODE3,U,8)
IF A>0
SET $PIECE(OUT6,FLD,24)=A
SET B=""
Begin DoDot:1
+38 SET A=$PIECE(NODE3,U,8)
NEW I
FOR I=1:1:$LENGTH(A)
IF $EXTRACT(A,I)?1A
QUIT
+39 SET B=$EXTRACT(A,I,$LENGTH(A))
+40 KILL I
QUIT
End DoDot:1
SET $PIECE(OUT6,FLD,25)=B
KILL A,B
+41 SET OUT6=OUT6_$CHAR(13)
+42 SET CONT=CONT+1
+43 SET OUT(CONT)=OUT6
+44 QUIT
OBXH ;EP - OBX record
+1 SET X=$PIECE($GET(^BOP(90355.1,COUNTER,9)),U)
IF X
SET CONT=CONT+1
Begin DoDot:1
+2 SET OUT(CONT)="OBX||ST|1010.3^HEIGHT||"_X_"|cm|"_$CHAR(13)
End DoDot:1
+3 QUIT
OBXW ;EP - OBX weight
+1 SET X=$PIECE($GET(^BOP(90355.1,COUNTER,9)),U,2)
IF X
SET CONT=CONT+1
Begin DoDot:1
+2 SET OUT(CONT)="OBX||ST|1010.1^WEIGHT||"_X_"|kg|"_$CHAR(13)
End DoDot:1
+3 QUIT
DG1 ;EP - DG1 record
+1 ; I $G(BOPVA(9))]"" S CONT=CONT+1,OUT(CONT)="DG1||||"_BOPVA(9)_"|"_$C(13)
+2 SET BOPWHO=$$INTFACE^BOPTU(1)
+3 IF X=5
GOTO DG15
+4 ; free text diag from admit
+5 SET X=$GET(^BOP(90355.1,COUNTER,12))
IF X=""
QUIT
+6 SET CONT=CONT+1
SET OUT(CONT)="DG1||||^"_X_"|"_$CHAR(13)
+7 QUIT
DG15 ; discharge icd9
+1 SET X=$GET(^BOP(90355.1,COUNTER,14))
IF X=""
QUIT
+2 SET A=$$HLDATE^HLFNC($PIECE(X,U,3))
SET A=$PIECE(A,"-",1)
+3 SET CONT=CONT+1
SET OUT(CONT)="DG1|"_($SELECT(BOPWHO="P":"|I9|",1:"1||"))_$PIECE(X,U,1)_U_$PIECE(X,U,2)_"||"_A_"|||||||||||"_$CHAR(13)
+4 QUIT
AL1 ;EP - AL1 record
+1 NEW X,BOPN
+2 IF '$PIECE($GET(^BOP(90355.1,COUNTER,11,0)),U,4)
QUIT
+3 SET BOPN=0
FOR
SET BOPN=$ORDER(^BOP(90355.1,COUNTER,11,BOPN))
IF 'BOPN
QUIT
Begin DoDot:1
+4 SET X=$GET(^BOP(90355.1,COUNTER,11,BOPN,0))
+5 IF X=""
QUIT
+6 SET A=$PIECE(X,U,2)_U_$PIECE(X,U,1)
+7 SET CONT=CONT+1
SET OUT(CONT)="AL1||DA|"_A_"|"_$CHAR(13)
End DoDot:1
+8 QUIT
RXR ;EP - Build RXR
+1 SET BOPWHO=$$INTFACE^BOPTU(1)
+2 SET NODE3=^BOP(90355.1,COUNTER,3)
+3 SET NODE8=^BOP(90355.1,COUNTER,8)
+4 SET ROUTE=$PIECE(NODE8,"^",1)
+5 IF BOPWHO="P"
SET OUT7="RXR"_FLD_COM_ROUTE_FLD_$CHAR(13)
DO FIN
QUIT
+6 IF RECAPP="SUREMED"
SET OUT7="RXR"_FLD_ROUTE_FLD_$CHAR(13)
+7 IF '$TEST
SET OUT7="RXR"_FLD_COM_ROUTE_FLD
Begin DoDot:1
+8 IF '$PIECE(NODE3,U,11)
QUIT
+9 NEW A
SET A=$PIECE(NODE3,U,5)
IF A'=""
SET $PIECE(OUT7,FLD,5)=$SELECT(A="A":"ADMIXTURE",A="P":"PIGGYBACK",A="H":"HYPERAL",A="S":"SYRINGE",A="C":"CHEMOTHERAPY",1:"")
+10 KILL A
QUIT
End DoDot:1
SET OUT7=OUT7_$CHAR(13)
FIN SET CONT=CONT+1
+1 SET OUT(CONT)=OUT7
+2 KILL ROUTE,NODE8,OUT7
+3 QUIT
DOW ;SU;MO;TU;WE;TH;FR;SA
+1 QUIT
QT(Y) ; EP
+1 ; get the quantity/timing of the order
+2 ; Y is from node3 ^BOP(90355.1,COUNTER
+3 ; W IS IV FLAG
+4 ;
+5 NEW PSGSCH,PSGSD,PSGFD,PSGST,PSGS0Y,X,I,L,P,DOW
+6 SET PSGSCH=$PIECE(Y,U)
+7 SET PSGSD=$PIECE(Y,U,3)
SET PSGSD=$$HLDATE^HLFNC(PSGSD)
SET PSGSD=$PIECE(PSGSD,"-",1)
+8 SET PSGFD=$PIECE(Y,U,4)
SET PSGFD=$$HLDATE^HLFNC(PSGFD)
SET PSGFD=$PIECE(PSGFD,"-",1)
+9 SET PSGST=$PIECE(Y,U,5)
+10 SET PSGS0Y=$PIECE(Y,U,7)
SET PSGS0Y=$TRANSLATE(PSGS0Y,"-",",")
+11 IF $LENGTH(PSGS0Y)
Begin DoDot:1
+12 FOR I=1:1:$LENGTH(PSGS0Y,",")
Begin DoDot:2
+13 SET P=$PIECE(PSGS0Y,",",I)
SET L=$LENGTH(P)
+14 IF L<4
SET X=P
SET P=X_$EXTRACT("0000",1,4-L)
SET $PIECE(PSGS0Y,",",I)=P
End DoDot:2
End DoDot:1
+15 SET DOW="00000000"
+16 NEW I
FOR I=1:1:7
IF PSGSCH[$PIECE($TEXT(DOW),";",I+1)
SET $EXTRACT(DOW,I)=1
+17 IF DOW'[1
SET DOW=""
+18 SET X=COM_PSGSCH_"&"_PSGS0Y_COM_COM_PSGSD_COM_PSGFD
+19 IF $PIECE(Y,U,11)
SET X=COM_"c"_COM_COM_PSGSD_COM_PSGFD
+20 IF BOPWHO="P"
QUIT X
+21 SET X=X_COM_COM_$SELECT(RECAPP="SUREMED":"",PSGST="P":1,1:0)_COM_DOW
+22 QUIT X
+23 ;
MINMAX(X) ; extract quantity and units from free text field
+1 NEW AMT1,AMT2,I,UNITS,Y,Y1,Y2,B,C
SET (AMT1,AMT2,I,UNITS,Y,Y1,Y2)=""
+2 ;remove control chars
FOR I=1:1:$LENGTH(X)
IF $EXTRACT(X,I)?1C
SET $EXTRACT(X,I)=""
+3 ; x=input y = output
XECUTE ^%ZOSF("UPPERCASE")
SET Y=$TRANSLATE(Y,",","")
+4 ; take out unnecessary spaces
+5 IF $EXTRACT(Y)=" "!(Y[" ")
FOR I=1:1:$LENGTH(Y)
IF $PIECE(Y," ",I)]" "
SET Y1=Y1_$PIECE(Y," ",I)_" "
+6 IF Y1
SET Y=$EXTRACT(Y1,1,$LENGTH(Y1)-1)
+7 ;create spaces
FOR I=1:1:$LENGTH(Y)
IF $EXTRACT(Y,I)?1A
IF $EXTRACT(Y,I-1)?1N
SET $EXTRACT(Y,I)=" "_$EXTRACT(Y,I)
+8 ;create spaces
FOR I=1:1:$LENGTH(Y)
IF $EXTRACT(Y,I)?1N
IF $EXTRACT(Y,I-1)?1A
SET $EXTRACT(Y,I)=" "_$EXTRACT(Y,I)
+9 IF $PIECE(Y," ")?.A
SET B=$PIECE(Y," ")
Begin DoDot:1
+10 SET $PIECE(Y," ")=$SELECT(B="ONE":1,B="TWO":2,B="THREE":3,B="FOUR":4,B="FIVE":5,B="SIX":6,B="SEVEN":7,B="EIGHT":8,B="NINE":9,1:B)
End DoDot:1
+11 IF $PIECE(Y," ")?.A1"/".E
SET B=$PIECE(Y,"/")
Begin DoDot:1
+12 SET C=$SELECT(B="ONE":1,B="TWO":2,B="THREE":3,B="FOUR":4,B="FIVE":5,B="SIX":6,B="SEVEN":7,B="EIGHT":8,B="NINE":9,1:B)
+13 SET $PIECE(Y," ")=C_"/"_$PIECE(Y,"/",2)
End DoDot:1
+14 ; in the first 3 pieces, find a number, then reorder the pieces
+15 ; no units is unacceptable
IF '+Y
Begin DoDot:1
+16 IF +$PIECE(Y," ",2)
SET Y=$PIECE(Y," ",2,99)_" "_$PIECE(Y," ",1)
+17 IF +$PIECE(Y," ",3)
SET Y=$PIECE(Y," ",3,99)_" "_$PIECE(Y," ",1,2)
End DoDot:1
IF '+Y
SET UNITS=X
GOTO MINMAXQ
+18 IF $PIECE(Y," ")["/"
SET B=$PIECE(Y," ")
IF B?1N1"/"1N
SET $PIECE(Y," ")=$EXTRACT($PIECE(B,"/")/$PIECE(B,"/",2),1,4)
+19 IF $PIECE(Y," ",2)="TO"!($PIECE(Y," ",2)="OR")
IF +$PIECE(Y," ",3)
SET $PIECE(Y," ",2)="-"
+20 IF Y["-"
IF Y["- "
SET $EXTRACT(Y,$FIND(Y,"-"))=""
IF Y[" -"
SET $EXTRACT(Y,$FIND(Y,"-")-2)=""
+21 ;->
SET Y1=$PIECE(Y," ",1)
SET UNITS=$PIECE(Y," ",2,99)
IF Y1["-"
SET Y2=$PIECE(Y1,"-",2)
SET Y1=$PIECE(Y1,"-",1)
Begin DoDot:1
+22 ;separaate dose amt num from units
FOR I=1:1:$LENGTH(Y1)
IF $EXTRACT(Y1,I)?1A
Begin DoDot:2
+23 SET AMT1=+$EXTRACT(Y1,1,I-1)
IF 'Y2
SET UNITS=$EXTRACT(Y1,I,99)_$SELECT(UNITS="":UNITS,1:" "_UNITS)
End DoDot:2
QUIT
End DoDot:1
+24 IF 'AMT1
SET AMT1=+Y1
+25 ;if there is a maximum dose
IF Y2
FOR I=1:1:$LENGTH(Y2)
IF $EXTRACT(Y2,I)?1A
Begin DoDot:1
+26 SET AMT2=+$EXTRACT(Y2,1,I-1)
SET UNITS=$EXTRACT(Y2,I,99)_$SELECT(UNITS="":UNITS,1:" "_UNITS)
End DoDot:1
QUIT
+27 IF Y2
IF 'AMT2
SET AMT2=+Y2
+28 ; min dose less than max
IF Y2
IF AMT1>AMT2
SET Y=AMT1
SET AMT1=AMT2
SET AMT2=Y
+29 ; no units is unacceptable
IF UNITS=""
SET (AMT1,AMT2)=""
SET UNITS=X
GOTO MINMAXQ
+30 IF AMT1=AMT2
SET AMT2=""
IF $EXTRACT(AMT1)="."
SET AMT1=0_AMT1
IF $EXTRACT(AMT2)="."
SET AMT2=0_AMT2
MINMAXQ QUIT AMT1_U_UNITS_U_AMT2
+1 ;
RXC ;EP
+1 ;
NEW A,B,C
SET (A,B,C)=""
SET A=$ORDER(^BOP(90355.1,COUNTER,20,0))
IF A
Begin DoDot:1
+2 ;
SET B=0
FOR
SET B=$ORDER(^BOP(90355.1,COUNTER,20,B))
IF 'B
QUIT
SET C=$GET(^BOP(90355.1,COUNTER,20,B,0))
IF C=""
QUIT
Begin DoDot:2
+3 SET CONT=CONT+1
+4 SET OUT(CONT)="RXC"_FLD_"B"_FLD_$PIECE(C,U,1)_COM_$PIECE(C,U,2)_FLD_$PIECE(C,U,3)_$CHAR(13)
End DoDot:2
End DoDot:1
+5 ;
SET (A,B,C)=""
SET A=$ORDER(^BOP(90355.1,COUNTER,21,0))
IF A
Begin DoDot:1
+6 ;
SET B=0
FOR
SET B=$ORDER(^BOP(90355.1,COUNTER,21,B))
IF 'B
QUIT
SET C=$GET(^BOP(90355.1,COUNTER,21,B,0))
IF C=""
QUIT
Begin DoDot:2
+7 SET CONT=CONT+1
+8 SET OUT(CONT)="RXC"_FLD_"A"_FLD_$PIECE(C,U,1)_COM_$PIECE(C,U,2)_FLD_$PIECE(C,U,3)_$CHAR(13)
End DoDot:2
End DoDot:1
+9 QUIT
