BPCRXSIG.m

BPCRXSIG ; IHS/OIT/MJL - EXPANDS SIG FOR BPC GUI ;

 ;;1.5;BPC;;MAY 26, 2005

GETSIG(BPCARRAY,BPCSIGV,BPCQTY) ;EP CALL FROM REMOTE PROC: BPC RX EXPAND SIG

TEST S BPCGUI=1,XWBWRAP=1 K ^TMP($J)

 S BPCARRAY="^TMP("_$J_")"

 ;S BPCSIGV="T3T TID"

 ;S BPCQTY=30

SIG ;checks SIG for RXs

 I $G(BPCSIGV)="" S ^TMP($J,1)=-1,^TMP($J,2)="No SIG DEFINED! " Q

 I $E(BPCSIGV)=" " S ^TMP($J,1)=-1,^TMP($J,2)="Leading spaces are not allowed in the SIG! " Q

 F BPCZ0=1:1:$L(BPCSIGV," ") S BPCZ1=$P(BPCSIGV," ",BPCZ0) I $L(BPCZ1)>32 S ^TMP($J,1)=-1,^TMP($J,2)="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES." K BPCSIG,BPCZ0,BPCZ1 Q

 S BPCSIG="" F BPCZ0=1:1:$L(BPCSIGV," ") S BPCZ1=$P(BPCSIGV," ",BPCZ0) D:BPCZ1'=""  S BPCSIG=BPCSIG_" "_BPCZ1

 .S BPCY=$O(^PS(51,"B",BPCZ1,0)) Q:'BPCY  Q:$P($G(^PS(51,+BPCY,0)),"^",4)>1  S BPCZ1=$P(^PS(51,BPCY,0),"^",2) Q:'$D(^(9))  S BPCY=$P(BPCSIGV," ",BPCZ0-1),BPCY=$E(BPCY,$L(BPCY)) S:BPCY>1 BPCZ1=^(9)

 K BPCY,BPCZ1,BPCZ0

 I $L(BPCSIG)>100 S ^TMP($J,1)=-1,^TMP($J,2)="MAX OF 100 CHARACTERS ALLOWED IN SIG." K BPCSIG Q

 I +$G(BPCQTY) D DISPENSE

 S ^TMP($J,1)=2,^TMP($J,2)=BPCSIG,^TMP($J,3)=$G(PSOZDAY)

 K BPCSIG,PSOEXQTY,PSOEXSIG,BPCQTY,PSOZDAY

 Q

DFTSIG(BPCARRAY,BPCDRUG) ;EP CALL FROM REMOTE PROC: BPC RX DEFLT SIG

TESTA S BPCGUI=1,XWBWRAP=1 K ^TMP($J)

 S BPCARRAY="^TMP("_$J_")"

 S:'$D(U) U="^"

 S BPCDRUG=84103

 I $G(BPCDRUG)="" S ^TMP($J,1)=-1,^TMP($J,2)="No DRUG DEFINED! " Q

 S BPCDSIG=$P($G(^PSDRUG(BPCDRUG,0)),U,5)

 S BPCDPENS=$P($G(^PSDRUG(BPCDRUG,660)),U,8)

 S ^TMP($J,1)=2,^TMP($J,2)=BPCDSIG,^TMP($J,3)=BPCDPENS

 K BPCDRUG,BPCDPENS,BPCDRUG

 Q

GETDPENS(BPCARRAY,BPCSIGV,BPCQTY) ;EP CALL FROM REMOTE PROC: BPC RX EXPAND SIG

TEST1 S BPCGUI=1 K ^TMP($J)

 S BPCARRAY="^TMP("_$J_")"

 S BPCSIGV="T3T TID"

 S BPCQTY=30

 ;checks SIG for RXs

 I $G(BPCSIGV)="" S ^TMP($J,1)=-1,^TMP($J,2)="No SIG DEFINED! " Q

 I $E(BPCSIGV)=" " S ^TMP($J,1)=-1,^TMP($J,2)="Leading spaces are not allowed in the SIG! " Q

 I $G(BPCQTY)="" S ^TMP($J,1)=-1,^TMP($J,2)="No QUANTITY DEFINED! " Q

 F BPCZ0=1:1:$L(BPCSIGV," ") S BPCZ1=$P(BPCSIGV," ",BPCZ0) I $L(BPCZ1)>32 S ^TMP($J,1)=-1,^TMP($J,2)="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES." K BPCSIG,BPCZ0,BPCZ1 Q

 S BPCSIG="" F BPCZ0=1:1:$L(BPCSIGV," ") S BPCZ1=$P(BPCSIGV," ",BPCZ0) D:BPCZ1'=""  S BPCSIG=BPCSIG_" "_BPCZ1

 .S BPCY=$O(^PS(51,"B",BPCZ1,0)) Q:'BPCY  Q:$P($G(^PS(51,+BPCY,0)),"^",4)>1  S BPCZ1=$P(^PS(51,BPCY,0),"^",2) Q:'$D(^(9))  S BPCY=$P(BPCSIGV," ",BPCZ0-1),BPCY=$E(BPCY,$L(BPCY)) S:BPCY>1 BPCZ1=^(9)

 K BPCY,BPCZ1,BPCZ0

 I $L(BPCSIG)>100 S ^TMP($J,1)=-1,^TMP($J,2)="MAX OF 100 CHARACTERS ALLOWED IN SIG." K BPCSIG Q

 I +BPCQTY D DISPENSE

 I '$L(PSOZDAY) S ^TMP($J,1)=1,^TMP($J,2)=BPCSIG K BPCSIG Q

 I $L(PSOZDAY) S ^TMP($J,1)=2,^TMP($J,2)=BPCSIG,^TMP($J,3)=PSOZDAY K BPCSIG,PSOEXQTY,PSOEXSIG,BPCQTY Q

 Q

DISPENSE ;GETS DISPENSING UNITS

 S (X,PSOEXSIG)=BPCSIG

 S PSOEXQTY=BPCQTY

 ;SET EXPANDED SIG EQUAL TO PSOEXSIG

 ;SET QTY EQUAL TO PSOEXQTY

 ;GET BACK PSOZDAY AS THE DAYS SUPPLY-IF VALUE NULL COULDNT CALCULATE

 ;

 D CHANGER

 D CHANGES

 D FUZZY

 D CHANGEN

 D CHANGET

 D CHANGEH

 D DAY

 D END

 Q

END ;CLEAN UP

 D EN^XBVK("PSOEX")

 K Q,Z,X,I,J,K,P,PART,QUIT,REPLANEW,SIG,TEXT,TIMES,TR,TRTO

 K CHECK,QUT,FIRST,SECOND,FIND,LOOP,MANY,PSOSIGS

 Q

 ;

NTEXT ;;NUMBERS FOR TEXT

 ;;TABLESPOON;BIGSPOON;SO IT WONT GET MESSED UP BY TAB

 ;;1&1/2;1.5

 ;;2&1/2;2.5

 ;;3&1/2;3.5

 ;;4&1/2;4.5

 ;;&;AND

 ;;1/3;.33;ADDED 3/10/98

 ;;2/3;.66;ADDED 3/10/98

 ;;3/4;.75;ADDED 3/10/98

 ;;1/2;.5

 ;;1/4;.25

 ;;ONE AND THREE FOURTHS;1.75

 ;;ONE AND THREE-FOURTHS;1.75

 ;;ONE AND ONE HALF;1.5

 ;;ONE AND ONE-HALF;1.5

 ;;ONE AND ONE FOURTH;1.25

 ;;ONE AND ONE-FOURTH;1.25

 ;;TWO AND ONE HALF;2.5

 ;;TWO AND ONE-HALF;2.5

 ;;THREE AND ONE HALF;3.5

 ;;THREE AND ONE-HALF;3.5

 ;;FOUR AND ONE HALF;4.5

 ;;FOUR AND ONE-HALF;4.5

 ;;FIVE AND ONE HALF;5.5

 ;;FIVE AND ONE-HALF;5.5

 ;;SIX AND ONE HALF;6.5

 ;;SIX AND ONE-HALF;6.5

 ;;SEVEN AND ONE HALF;7.5

 ;;SEVEN AND ONE-HALF;7.5

 ;;ONE;1

 ;;TWO;2

 ;;THREE;3

 ;;FOUR;4

 ;;FIVE;5

 ;;SIX;6

 ;;SEVEN;7

 ;;EIGHT;8

 ;;NINE;9

 ;;TEN;10

 ;;TWELVE;12

 ;;TWENTY FOUR;24

 ;;ONE HALF;.5

 ;;ONE-HALF;.5

 ;;ONE THIRD;.33

 ;;ONE-THIRD;.33

 ;;TWO THIRDS;.66

 ;;TWO-THIRDS;.66

 ;;THREE FOURTHS;.75

 ;;THREE-FOURTHS;.75

 ;;ONE FOURTH;.25

 ;;ONE-FOURTH;.25

 ;;QUIT

TTEXT ;;CHANGE TIME AROUND

 ;;EVERY OTHER DAY;EVERYOTHERDAY

 ;;EVERY 12 HOURS;TWOTIMESDAILY

 ;;EVERY 24 HOURS;ONCEDAILY

 ;;EVERY 8 HOURS;THREETIMESDAILY

 ;;EVERY 6 HOURS;FOURTIMESDAILY

 ;;EVERY 5 HOURS;FIVETIMESDAILY

 ;;EVERY 4 HOURS;SIXTIMESDAILY

 ;;EVERY 3 HOURS;EIGHTTIMESDAILY

 ;;EVERY 2 HOURS;TWELVETIMESDAILY

 ;;EVERY 1 HOUR;TWENTYFOURTIMESDAILY

 ;;EVERY 1 HOURS;TWENTYFOURTIMESDAILY

 ;;TIMES A DAY;TIMES DAILY

 ;;TIMES EACH DAY;TIMES DAILY

 ;;8 TIMES DAILY;EIGHTTIMESDAILY

 ;;6 TIMES DAILY;SIXTIMESDAILY

 ;;5 TIMES DAILY;FIVETIMESDAILY

 ;;6 TIMES DAILY;SIXTIMESDAILY

 ;;4 TIMES DAILY;FOURTIMESDAILY

 ;;3 TIMES DAILY;THREETIMESDAILY

 ;;2 TIMES DAILY;TWOTIMESDAILY

 ;;TWICE DAILY;TWOTIMESDAILY

 ;;AFTER MEALS AND AT BEDTIME;FOURTIMESDAILY

 ;;AFTER EACH MEAL AND AT BEDTIME;FOURTIMESDAILY

 ;;BEFORE MEALS AND AT BEDTIME;FOURTIMESDAILY

 ;;BEFORE EACH MEAL AND AT BEDTIME;FOURTIMESDAILY

 ;;MORNING, NOON, EVENING, AND AT BEDTIME;FOURTIMESDAILY

 ;;MORNING NOON EVENING AND AT BEDTIME;FOURTIMESDAILY

 ;;MORNING, NOON, AND EVENING;THREETIMESDAILY

 ;;MORNING NOON AND EVENING;THREETIMESDAILY

 ;;MORNING, NOON, AND NIGHT;THREETIMESDAILY

 ;;MORNING NOON AND NIGHT;THREETIMESDAILY

 ;;MORNING AND AT BEDTIME;TWOTIMESDAILY

 ;;MORNING AND BEDTIME;TWOTIMESDAILY

 ;;MORNING AND EVENING;TWOTIMESDAILY

 ;;AT BEDTIME;ONCEDAILY

 ;;ONCE DAILY;ONCEDAILY

 ;;A DAY;ONCEDAILY

 ;;ONCE A DAY;ONCEDAILY

 ;;IN THE EVENING;ONCEDAILY

 ;;EVERY NIGHT;ONCEDAILY

 ;;NIGHTLY;ONCEDAILY

 ;;IN THE MORNING;ONCEDAILY

 ;;EVERY MORNING;ONCEDAILY

 ;;EVERY PM;ONCEDAILY

 ;;EVERY EVENING;ONCEDAILY

 ;;EVERY AM;ONCEDAILY

 ;;EACH DAY;ONCEDAILY;LEAVE AT BOTTOM 3/10/98

 ;;EVERY DAY;ONCEDAILY;LEAVE AT BOTTOM 3/10/98

 ;;AT NOON;ONCEDAILY

 ;;MLS;ZGLOB

 ;;ML;ZGLOB

 ;;CCS;ZGLOB

 ;;CC;ZGLOB

 ;;CAPSULES;ZGLOB

 ;;TABLETS;ZGLOB

 ;;CAPSULE;ZGLOB

 ;;TABLET;ZGLOB

 ;;SUPPOSITORY;ZGLOB

 ;;CAPS;ZGLOB

 ;;TABS;ZGLOB

 ;;TAB;ZGLOB

 ;;CAP;ZGLOB

 ;;ZGLOB DAILY;ZGLOB ONCEDAILY;THIS IS A SPECIAL CASE PROBLEM WITH DAILY

 ;;QUIT

 ;

HTEXT ;;THIS PART CHANGES 2ND PARTO FO SIG FOURTIMESDAILY=4

 ;;EVERYOTHERDAY,.5

 ;;ONCEDAILY,1

 ;;TWOTIMESDAILY,2

 ;;THREETIMESDAILY,3

 ;;FOURTIMESDAILY,4

 ;;FIVETIMESDAILY,5

 ;;SIXTIMESDAILY,6

 ;;EIGHTTIMESDAILY,8

 ;;TWELVETIMESDAILY,12

 ;;TWENTYFOURTIMESDAILY,24

 ;;DAILY,1

 ;;QUIT

 ;

CHANGEN ;CHANGE TEXT TO NUMBERS

 ;N X,Y,STRING,TEXT,LOOK,REPLACE,NUMBER

 N X,Y

 S X=PSOEXSIG X ^%ZOSF("UPPERCASE") S PSOEXSIG=Y

 S PSOEXSIG=$TR(PSOEXSIG,"()")

 ;S PSOEXSIG=$TR(PSOEXSIG,"-"," ") ;IHS/OKCAO/POC 3/10/98

 S STRING=PSOEXSIG

 ;S STRING=X

 F I=1:1 S TEXT=$P($T(NTEXT+I),";;",2) Q:TEXT="QUIT"  D

 .S LOOK=$P(TEXT,";",1)

 .S REPLACE=$P(TEXT,";",2)

 .S NUMBER=$L(STRING,LOOK)-1

 .Q:NUMBER<1

 .F J=1:1:NUMBER D

 ..S STRING=$P(STRING,LOOK,1)_REPLACE_$P(STRING,LOOK,2,999)

 ..;W !,"MY TEXT= ",STRING," TEXT= ",TEXT H 2 ;****DELETE

 S PSOEXSIG=STRING

 K STRING,TEXT,LOOK,REPLACE,NUMBER

 Q

CHANGET ;CHANGE TIME AROUND

 S STRING=PSOEXSIG

 ;S STRING=X

 F I=1:1 S TEXT=$P($T(TTEXT+I),";;",2) Q:TEXT="QUIT"  D

 .S LOOK=$P(TEXT,";",1)

 .S REPLACE=$P(TEXT,";",2)

 .S NUMBER=$L(STRING,LOOK)-1

 .Q:NUMBER<1

 .F J=1:1:NUMBER D

 ..S STRING=$P(STRING,LOOK,1)_REPLACE_$P(STRING,LOOK,2,999)

 ..;W !,"MY TEXT= ",STRING," TEXT= ",TEXT H 2 ;****DELETE

 S PSOEXSIG=STRING

 K STRING,TEXT,LOOK,REPLACE,NUMBER

 Q

CHANGEH ;CHANGE TIME TO NUMBERS 

 S PSOEXMX=0

 ;S (PIECE(1),PIECE(2))=""

 S (QUIT(1),QUIT(2))="" ;TO STOP WHEN FIND SOMETHING

 ;PSOEXSIG DEFINED

 ;1 THE BELOW DEFINES TYPE OF ITEM TABLET, TEASPOON ETC

 ;2 LOOP THRU T2T BID AND T1T HS AND BREAKS UP

 ;3 CALCULATES FIRST PART OF SIG-THE NUMBER OF TABLETS ETC

 ;4 CALCULATES THE TIME PERIOD OF SIG-THE SECOND PORTION 4XDAILY ETC

LOOP S (FIRST,SECOND,FIND)=0,PSOSIGS=PSOEXSIG

 I $L(PSOEXSIG,"ZGLOB")>1 S DELIMIT="ZGLOB",MANY=$L(PSOEXSIG,"ZGLOB")-1,MULT=1 F LOOP=1:1:MANY D A Q:$G(QUT)

 I $L(PSOEXSIG,"TEASPOON")>1 S DELIMIT="TEASPOON",MANY=$L(PSOEXSIG,"TEASPOON")-1,MULT=5 F LOOP=1:1:MANY D A Q:$G(QUT)

 I $L(PSOEXSIG,"BIGSPOON")>1 S DELIMIT="BIGSPOON",MANY=$L(PSOEXSIG,"BIGSPOON")-1,MULT=15 F LOOP=1:1:MANY D A Q:$G(QUT)

 I $L(PSOEXSIG,"UNIT")>1 S DELIMIT="UNIT",MANY=$L(PSOEXSIG,"UNIT")-1,MULT=.01 F LOOP=1:1:MANY D A Q:$G(QUT)

 D KILLH

 Q

 ;

A S (PIECE(1),PIECE(2))=""

 ;TAKE 1 WHATEVER TWOTIMESDAILY AND TAKE 2 WHATEVER ONETIMESDAILY

 ;SEPARATE THE PARTS TAKE 1 WHATEVER TWOTIMESDAILY

 ;S FIRST=FIRST+FIND

 S FIRST=FIND

 S FIND=$F(PSOSIGS,"DAILY",FIRST)

 S SECOND=FIND-1

 S PSOEXSIG=$E(PSOSIGS,FIRST,SECOND)

 ;W !,"EACH SECTION IS= ",PSOEXSIG ;****DELETE

 ;

 S STRING(1)=$P(PSOEXSIG,DELIMIT),STRING(2)=$P(PSOEXSIG,DELIMIT,2)

 ;W !,"LOOP= ",LOOP H 2 ;****DELETE

 F Q=1:1:20 D  ;

 .F P=1:1:20 D  ;

 ..S CHECK=Q_" TO "_P,PART=Q_" TO"

 ..I STRING(1)[CHECK D

 ...;W !,STRING(1)," BECOMES " ;****DELETE

 ...S STRING(1)=$P(STRING(1),PART,2) ;SO 1 TO 2 BECOMES 2

 ...;W STRING(1) ;****DELETE

B ;B ADDED 3/10/98 NEXT 7 LINES

 F Q=1:1:5,.25,.33,.5,.66,.75 D  ;

 .F P=1:1:5,.25,.33,.5,.66,.75 D  ;

 ..S CHECK=Q_" TO "_P,PART=Q_" TO"

 ..I STRING(1)[CHECK D

 ...;W !,STRING(1)," BECOMES " ;****DELETE

 ...S STRING(1)=$P(STRING(1),PART,2) ;SO .25 TO .33 BECOMES .33

 ...;W STRING(1) ;****DELETE

 ;COMMENTED OUT 3/10/98

 S LENGTH=$L(STRING(1))

 F K=1:1:LENGTH S TEST=$E(STRING(1),K) IF TEST?1N!(TEST?1".") S PIECE(1)=PIECE(1)_TEST ;W !,"PIECE(1) BECOMES ",PIECE(1)

 ;G:PIECE(1)="" KILLH

 ;NOTE SECOND HALF OF SIG

 F I=1:1 S TEXT=$P($T(HTEXT+I),";;",2) Q:TEXT="QUIT"!QUIT(2)  D

 .S COMPARE(2)=$P(TEXT,",",1)

 .S REPLACE(2)=$P(TEXT,",",2)

 .I STRING(2)[COMPARE(2) S PIECE(2)=REPLACE(2),QUIT(2)=1 Q

 ;ADDED NEXT 4 LINES 3/10/98

 ;W !,"PIECE(1) ",PIECE(1)," BECOMES " ;****DELETE

 S PIECE(1)=+PIECE(1) ;W PIECE(1) ;****DELETE

 ;W !,"PIECE(2) ",PIECE(2)," BECOMES ";****DELETE

 S PIECE(2)=+PIECE(2) ;W PIECE(2) ;****DELETE

 ;3/10/98 POC ABOVE 4 LINES

 I PIECE(1),PIECE(2) S PSOEXMX=PIECE(1)*PIECE(2)*MULT

 ;W !,"PIECE(1)= ",PIECE(1)," PIECE(2)= ",PIECE(2)," MULT= ",MULT H 2 

 S (QUIT(1),QUIT(2))="" ;RESET QUIT VARIABLES

 S PSOEXMXT=$G(PSOEXMXT)+PSOEXMX ;PSOEXMXT IS TOTAL OF ALL PSOEXMX

 ;IF 'PSOEXMX W !,*7,*7,"I DONT KNOW THE DAYS SUPPLY-GO FIGURE!" S PSOZDAY="",QUT=1 Q

 I 'PSOEXMX S PSOEXMXT=0,QUT=1 Q

 S PSOEXMX=0

 ;DELETE THE ABOVE LATER ****DELETE

 Q

KILLH ;KILL VARIABLES

 K TEST,LENGTH,PIECE,STRING,DELIMIT,COMPARE,REPLACE,MULT

 Q

 ;

DAY ;CALCULATE THE DAYS SUPPLY

 I '$G(PSOEXMXT) S PSOZDAY=""  ;W !,*7,*7,"I DONT KNOW THE DAYS SUPPLY-GO FIGURE!"

 E  S PSOZDAY=PSOEXQTY\PSOEXMXT ;W !,"PSOZDAY= ",PSOZDAY ;****DELETE

 Q

CHANGER ;GOES LIKE THIS '4 TO 6' GETS CHANGED TO '4 OR 6'

 ;VARIABLE

 F Z=1:1 S TEXT=$P($T(TRTEXT+Z),";;",2) QUIT:TEXT="QUIT"  S TR=$P(TEXT,";",1),TRTO=$P(TEXT,";",2) D TRA

 Q

TRA F I=1:1:20 D

 .F J=1:1:20 D

 ..S REPLACE=I_" "_TR_" "_J

 ..S REPLANEW=I_" "_TRTO_" "_J

 ..S TIMES=$L(PSOEXSIG,REPLACE)-1

 ..Q:TIMES=0

 ..F K=1:1:TIMES D

 ...S SAVE(K)=$P(PSOEXSIG,REPLACE,K)

 ...S CUT(K)=$L(SAVE(K))+1

 ..S SAVE(K+1)=$P(PSOEXSIG,REPLACE,K+1)

 ..S CONVERT=""

 ..F C=1:1:TIMES D

 ...S CONVERT=CONVERT_SAVE(C)_REPLANEW

 ..S CONVERT=CONVERT_SAVE(C+1)

 ..;W !,"MY TEXT= ",CONVERT," TEXT= ",TEXT ;****DELETE

 ..S PSOEXSIG=CONVERT

 QUIT

TRTEXT ;REPLACES SOME MORE STUFF

 ;;OR;TO

 ;;-;TO

 ;;QUIT

CHANGES ;GOES LIKE THIS '1-2' GETS CHANGED TO '1 OR 2'

 ;VARIABLE

 F Z=1:1 S TEXT=$P($T(TSTEXT+Z),";;",2) QUIT:TEXT="QUIT"  S TR=$P(TEXT,";",1),TRTO=$P(TEXT,";",2) D TRS

 Q

TRS F I=1:1:20 D

 .F J=1:1:20 D

 ..S REPLACE=I_TR_J

 ..S REPLANEW=I_" "_TRTO_" "_J

 ..S TIMES=$L(PSOEXSIG,REPLACE)-1

 ..Q:TIMES=0

 ..F K=1:1:TIMES D

 ...S SAVE(K)=$P(PSOEXSIG,REPLACE,K)

 ...S CUT(K)=$L(SAVE(K))+1

 ..S SAVE(K+1)=$P(PSOEXSIG,REPLACE,K+1)

 ..S CONVERT=""

 ..F C=1:1:TIMES D

 ...S CONVERT=CONVERT_SAVE(C)_REPLANEW

 ..S CONVERT=CONVERT_SAVE(C+1)

 ..;W !,"MY TEXT= ",CONVERT," TEXT= ",TEXT ;****DELETE

 ..S PSOEXSIG=CONVERT

 QUIT

TSTEXT ;REPLACES SOME MORE STUFF

 ;;-;TO

 ;;QUIT

 ;

FUZZY ;CHANGES EVERY 4 TO 6 HOURS - EVERY 4 HOURS

 ;CHANGES 4 TO 6 TIMES - TO 4 TIMES

 F I=1:1 S TEXT=$P($T(TEXTF+I),";;",2) Q:TEXT="QUIT"  S FIRST=$P(TEXT,";"),SECOND=$P(TEXT,";",2) D 

 .F Q=1:1:24 D

 ..F P=1:1:24 D

 ...S CHECK=FIRST_" "_Q_" TO "_P_" "_SECOND,PART=FIRST_" "_Q_" "_SECOND

 ...I PSOEXSIG[CHECK D  ; 

 ....;W !,PSOEXSIG," BECOMES "

 ....S PSOEXSIG=$P(PSOEXSIG,CHECK,1)_PART_$P(PSOEXSIG,CHECK,2)

 ....;W PSOEXSIG H 2 

 QUIT

TEXTF ;;FIRST WORD;LAST WORD

 ;;EVERY;HOURS

 ;;;TIMES

 ;;QUIT

BPCRXSIG  ; IHS/OIT/MJL - EXPANDS SIG FOR BPC GUI ;

 +1       ;;1.5;BPC;;MAY 26, 2005

GETSIG(BPCARRAY,BPCSIGV,BPCQTY) ;EP CALL FROM REMOTE PROC: BPC RX EXPAND SIG

TEST       SET BPCGUI=1

           SET XWBWRAP=1

           KILL ^TMP($JOB)

 +1        SET BPCARRAY="^TMP("_$JOB_")"

 +2       ;S BPCSIGV="T3T TID"

 +3       ;S BPCQTY=30

SIG       ;checks SIG for RXs

 +1        IF $GET(BPCSIGV)=""

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="No SIG DEFINED! "

               QUIT 

 +2        IF $EXTRACT(BPCSIGV)=" "

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="Leading spaces are not allowed in the SIG! "

               QUIT 

 +3        FOR BPCZ0=1:1:$LENGTH(BPCSIGV," ")

               SET BPCZ1=$PIECE(BPCSIGV," ",BPCZ0)

               IF $LENGTH(BPCZ1)>32

                   SET ^TMP($JOB,1)=-1

                   SET ^TMP($JOB,2)="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES."

                   KILL BPCSIG,BPCZ0,BPCZ1

                   QUIT 

 +4        SET BPCSIG=""

           FOR BPCZ0=1:1:$LENGTH(BPCSIGV," ")

               SET BPCZ1=$PIECE(BPCSIGV," ",BPCZ0)

               IF BPCZ1'=""

                   Begin DoDot:1

 +5                    SET BPCY=$ORDER(^PS(51,"B",BPCZ1,0))

                       IF 'BPCY

                           QUIT 

                       IF $PIECE($GET(^PS(51,+BPCY,0)),"^",4)>1

                           QUIT 

                       SET BPCZ1=$PIECE(^PS(51,BPCY,0),"^",2)

                       IF '$DATA(^(9))

                           QUIT 

                       SET BPCY=$PIECE(BPCSIGV," ",BPCZ0-1)

                       SET BPCY=$EXTRACT(BPCY,$LENGTH(BPCY))

                       IF BPCY>1

                           SET BPCZ1=^(9)

                   End DoDot:1

               SET BPCSIG=BPCSIG_" "_BPCZ1

 +6        KILL BPCY,BPCZ1,BPCZ0

 +7        IF $LENGTH(BPCSIG)>100

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="MAX OF 100 CHARACTERS ALLOWED IN SIG."

               KILL BPCSIG

               QUIT 

 +8        IF +$GET(BPCQTY)

               DO DISPENSE

 +9        SET ^TMP($JOB,1)=2

           SET ^TMP($JOB,2)=BPCSIG

           SET ^TMP($JOB,3)=$GET(PSOZDAY)

 +10       KILL BPCSIG,PSOEXQTY,PSOEXSIG,BPCQTY,PSOZDAY

 +11       QUIT 

DFTSIG(BPCARRAY,BPCDRUG) ;EP CALL FROM REMOTE PROC: BPC RX DEFLT SIG

TESTA      SET BPCGUI=1

           SET XWBWRAP=1

           KILL ^TMP($JOB)

 +1        SET BPCARRAY="^TMP("_$JOB_")"

 +2        IF '$DATA(U)

               SET U="^"

 +3        SET BPCDRUG=84103

 +4        IF $GET(BPCDRUG)=""

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="No DRUG DEFINED! "

               QUIT 

 +5        SET BPCDSIG=$PIECE($GET(^PSDRUG(BPCDRUG,0)),U,5)

 +6        SET BPCDPENS=$PIECE($GET(^PSDRUG(BPCDRUG,660)),U,8)

 +7        SET ^TMP($JOB,1)=2

           SET ^TMP($JOB,2)=BPCDSIG

           SET ^TMP($JOB,3)=BPCDPENS

 +8        KILL BPCDRUG,BPCDPENS,BPCDRUG

 +9        QUIT 

GETDPENS(BPCARRAY,BPCSIGV,BPCQTY) ;EP CALL FROM REMOTE PROC: BPC RX EXPAND SIG

TEST1      SET BPCGUI=1

           KILL ^TMP($JOB)

 +1        SET BPCARRAY="^TMP("_$JOB_")"

 +2        SET BPCSIGV="T3T TID"

 +3        SET BPCQTY=30

 +4       ;checks SIG for RXs

 +5        IF $GET(BPCSIGV)=""

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="No SIG DEFINED! "

               QUIT 

 +6        IF $EXTRACT(BPCSIGV)=" "

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="Leading spaces are not allowed in the SIG! "

               QUIT 

 +7        IF $GET(BPCQTY)=""

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="No QUANTITY DEFINED! "

               QUIT 

 +8        FOR BPCZ0=1:1:$LENGTH(BPCSIGV," ")

               SET BPCZ1=$PIECE(BPCSIGV," ",BPCZ0)

               IF $LENGTH(BPCZ1)>32

                   SET ^TMP($JOB,1)=-1

                   SET ^TMP($JOB,2)="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES."

                   KILL BPCSIG,BPCZ0,BPCZ1

                   QUIT 

 +9        SET BPCSIG=""

           FOR BPCZ0=1:1:$LENGTH(BPCSIGV," ")

               SET BPCZ1=$PIECE(BPCSIGV," ",BPCZ0)

               IF BPCZ1'=""

                   Begin DoDot:1

 +10                   SET BPCY=$ORDER(^PS(51,"B",BPCZ1,0))

                       IF 'BPCY

                           QUIT 

                       IF $PIECE($GET(^PS(51,+BPCY,0)),"^",4)>1

                           QUIT 

                       SET BPCZ1=$PIECE(^PS(51,BPCY,0),"^",2)

                       IF '$DATA(^(9))

                           QUIT 

                       SET BPCY=$PIECE(BPCSIGV," ",BPCZ0-1)

                       SET BPCY=$EXTRACT(BPCY,$LENGTH(BPCY))

                       IF BPCY>1

                           SET BPCZ1=^(9)

                   End DoDot:1

               SET BPCSIG=BPCSIG_" "_BPCZ1

 +11       KILL BPCY,BPCZ1,BPCZ0

 +12       IF $LENGTH(BPCSIG)>100

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="MAX OF 100 CHARACTERS ALLOWED IN SIG."

               KILL BPCSIG

               QUIT 

 +13       IF +BPCQTY

               DO DISPENSE

 +14       IF '$LENGTH(PSOZDAY)

               SET ^TMP($JOB,1)=1

               SET ^TMP($JOB,2)=BPCSIG

               KILL BPCSIG

               QUIT 

 +15       IF $LENGTH(PSOZDAY)

               SET ^TMP($JOB,1)=2

               SET ^TMP($JOB,2)=BPCSIG

               SET ^TMP($JOB,3)=PSOZDAY

               KILL BPCSIG,PSOEXQTY,PSOEXSIG,BPCQTY

               QUIT 

 +16       QUIT 

DISPENSE  ;GETS DISPENSING UNITS

 +1        SET (X,PSOEXSIG)=BPCSIG

 +2        SET PSOEXQTY=BPCQTY

 +3       ;SET EXPANDED SIG EQUAL TO PSOEXSIG

 +4       ;SET QTY EQUAL TO PSOEXQTY

 +5       ;GET BACK PSOZDAY AS THE DAYS SUPPLY-IF VALUE NULL COULDNT CALCULATE

 +6       ;

 +7        DO CHANGER

 +8        DO CHANGES

 +9        DO FUZZY

 +10       DO CHANGEN

 +11       DO CHANGET

 +12       DO CHANGEH

 +13       DO DAY

 +14       DO END

 +15       QUIT 

END       ;CLEAN UP

 +1        DO EN^XBVK("PSOEX")

 +2        KILL Q,Z,X,I,J,K,P,PART,QUIT,REPLANEW,SIG,TEXT,TIMES,TR,TRTO

 +3        KILL CHECK,QUT,FIRST,SECOND,FIND,LOOP,MANY,PSOSIGS

 +4        QUIT 

 +5       ;

NTEXT     ;;NUMBERS FOR TEXT

 +1       ;;TABLESPOON;BIGSPOON;SO IT WONT GET MESSED UP BY TAB

 +2       ;;1&1/2;1.5

 +3       ;;2&1/2;2.5

 +4       ;;3&1/2;3.5

 +5       ;;4&1/2;4.5

 +6       ;;&;AND

 +7       ;;1/3;.33;ADDED 3/10/98

 +8       ;;2/3;.66;ADDED 3/10/98

 +9       ;;3/4;.75;ADDED 3/10/98

 +10      ;;1/2;.5

 +11      ;;1/4;.25

 +12      ;;ONE AND THREE FOURTHS;1.75

 +13      ;;ONE AND THREE-FOURTHS;1.75

 +14      ;;ONE AND ONE HALF;1.5

 +15      ;;ONE AND ONE-HALF;1.5

 +16      ;;ONE AND ONE FOURTH;1.25

 +17      ;;ONE AND ONE-FOURTH;1.25

 +18      ;;TWO AND ONE HALF;2.5

 +19      ;;TWO AND ONE-HALF;2.5

 +20      ;;THREE AND ONE HALF;3.5

 +21      ;;THREE AND ONE-HALF;3.5

 +22      ;;FOUR AND ONE HALF;4.5

 +23      ;;FOUR AND ONE-HALF;4.5

 +24      ;;FIVE AND ONE HALF;5.5

 +25      ;;FIVE AND ONE-HALF;5.5

 +26      ;;SIX AND ONE HALF;6.5

 +27      ;;SIX AND ONE-HALF;6.5

 +28      ;;SEVEN AND ONE HALF;7.5

 +29      ;;SEVEN AND ONE-HALF;7.5

 +30      ;;ONE;1

 +31      ;;TWO;2

 +32      ;;THREE;3

 +33      ;;FOUR;4

 +34      ;;FIVE;5

 +35      ;;SIX;6

 +36      ;;SEVEN;7

 +37      ;;EIGHT;8

 +38      ;;NINE;9

 +39      ;;TEN;10

 +40      ;;TWELVE;12

 +41      ;;TWENTY FOUR;24

 +42      ;;ONE HALF;.5

 +43      ;;ONE-HALF;.5

 +44      ;;ONE THIRD;.33

 +45      ;;ONE-THIRD;.33

 +46      ;;TWO THIRDS;.66

 +47      ;;TWO-THIRDS;.66

 +48      ;;THREE FOURTHS;.75

 +49      ;;THREE-FOURTHS;.75

 +50      ;;ONE FOURTH;.25

 +51      ;;ONE-FOURTH;.25

 +52      ;;QUIT

TTEXT     ;;CHANGE TIME AROUND

 +1       ;;EVERY OTHER DAY;EVERYOTHERDAY

 +2       ;;EVERY 12 HOURS;TWOTIMESDAILY

 +3       ;;EVERY 24 HOURS;ONCEDAILY

 +4       ;;EVERY 8 HOURS;THREETIMESDAILY

 +5       ;;EVERY 6 HOURS;FOURTIMESDAILY

 +6       ;;EVERY 5 HOURS;FIVETIMESDAILY

 +7       ;;EVERY 4 HOURS;SIXTIMESDAILY

 +8       ;;EVERY 3 HOURS;EIGHTTIMESDAILY

 +9       ;;EVERY 2 HOURS;TWELVETIMESDAILY

 +10      ;;EVERY 1 HOUR;TWENTYFOURTIMESDAILY

 +11      ;;EVERY 1 HOURS;TWENTYFOURTIMESDAILY

 +12      ;;TIMES A DAY;TIMES DAILY

 +13      ;;TIMES EACH DAY;TIMES DAILY

 +14      ;;8 TIMES DAILY;EIGHTTIMESDAILY

 +15      ;;6 TIMES DAILY;SIXTIMESDAILY

 +16      ;;5 TIMES DAILY;FIVETIMESDAILY

 +17      ;;6 TIMES DAILY;SIXTIMESDAILY

 +18      ;;4 TIMES DAILY;FOURTIMESDAILY

 +19      ;;3 TIMES DAILY;THREETIMESDAILY

 +20      ;;2 TIMES DAILY;TWOTIMESDAILY

 +21      ;;TWICE DAILY;TWOTIMESDAILY

 +22      ;;AFTER MEALS AND AT BEDTIME;FOURTIMESDAILY

 +23      ;;AFTER EACH MEAL AND AT BEDTIME;FOURTIMESDAILY

 +24      ;;BEFORE MEALS AND AT BEDTIME;FOURTIMESDAILY

 +25      ;;BEFORE EACH MEAL AND AT BEDTIME;FOURTIMESDAILY

 +26      ;;MORNING, NOON, EVENING, AND AT BEDTIME;FOURTIMESDAILY

 +27      ;;MORNING NOON EVENING AND AT BEDTIME;FOURTIMESDAILY

 +28      ;;MORNING, NOON, AND EVENING;THREETIMESDAILY

 +29      ;;MORNING NOON AND EVENING;THREETIMESDAILY

 +30      ;;MORNING, NOON, AND NIGHT;THREETIMESDAILY

 +31      ;;MORNING NOON AND NIGHT;THREETIMESDAILY

 +32      ;;MORNING AND AT BEDTIME;TWOTIMESDAILY

 +33      ;;MORNING AND BEDTIME;TWOTIMESDAILY

 +34      ;;MORNING AND EVENING;TWOTIMESDAILY

 +35      ;;AT BEDTIME;ONCEDAILY

 +36      ;;ONCE DAILY;ONCEDAILY

 +37      ;;A DAY;ONCEDAILY

 +38      ;;ONCE A DAY;ONCEDAILY

 +39      ;;IN THE EVENING;ONCEDAILY

 +40      ;;EVERY NIGHT;ONCEDAILY

 +41      ;;NIGHTLY;ONCEDAILY

 +42      ;;IN THE MORNING;ONCEDAILY

 +43      ;;EVERY MORNING;ONCEDAILY

 +44      ;;EVERY PM;ONCEDAILY

 +45      ;;EVERY EVENING;ONCEDAILY

 +46      ;;EVERY AM;ONCEDAILY

 +47      ;;EACH DAY;ONCEDAILY;LEAVE AT BOTTOM 3/10/98

 +48      ;;EVERY DAY;ONCEDAILY;LEAVE AT BOTTOM 3/10/98

 +49      ;;AT NOON;ONCEDAILY

 +50      ;;MLS;ZGLOB

 +51      ;;ML;ZGLOB

 +52      ;;CCS;ZGLOB

 +53      ;;CC;ZGLOB

 +54      ;;CAPSULES;ZGLOB

 +55      ;;TABLETS;ZGLOB

 +56      ;;CAPSULE;ZGLOB

 +57      ;;TABLET;ZGLOB

 +58      ;;SUPPOSITORY;ZGLOB

 +59      ;;CAPS;ZGLOB

 +60      ;;TABS;ZGLOB

 +61      ;;TAB;ZGLOB

 +62      ;;CAP;ZGLOB

 +63      ;;ZGLOB DAILY;ZGLOB ONCEDAILY;THIS IS A SPECIAL CASE PROBLEM WITH DAILY

 +64      ;;QUIT

 +65      ;

HTEXT     ;;THIS PART CHANGES 2ND PARTO FO SIG FOURTIMESDAILY=4

 +1       ;;EVERYOTHERDAY,.5

 +2       ;;ONCEDAILY,1

 +3       ;;TWOTIMESDAILY,2

 +4       ;;THREETIMESDAILY,3

 +5       ;;FOURTIMESDAILY,4

 +6       ;;FIVETIMESDAILY,5

 +7       ;;SIXTIMESDAILY,6

 +8       ;;EIGHTTIMESDAILY,8

 +9       ;;TWELVETIMESDAILY,12

 +10      ;;TWENTYFOURTIMESDAILY,24

 +11      ;;DAILY,1

 +12      ;;QUIT

 +13      ;

CHANGEN   ;CHANGE TEXT TO NUMBERS

 +1       ;N X,Y,STRING,TEXT,LOOK,REPLACE,NUMBER

 +2        NEW X,Y

 +3        SET X=PSOEXSIG

           XECUTE ^%ZOSF("UPPERCASE")

           SET PSOEXSIG=Y

 +4        SET PSOEXSIG=$TRANSLATE(PSOEXSIG,"()")

 +5       ;S PSOEXSIG=$TR(PSOEXSIG,"-"," ") ;IHS/OKCAO/POC 3/10/98

 +6        SET STRING=PSOEXSIG

 +7       ;S STRING=X

 +8        FOR I=1:1

               SET TEXT=$PIECE($TEXT(NTEXT+I),";;",2)

               IF TEXT="QUIT"

                   QUIT 

               Begin DoDot:1

 +9                SET LOOK=$PIECE(TEXT,";",1)

 +10               SET REPLACE=$PIECE(TEXT,";",2)

 +11               SET NUMBER=$LENGTH(STRING,LOOK)-1

 +12               IF NUMBER<1

                       QUIT 

 +13               FOR J=1:1:NUMBER

                       Begin DoDot:2

 +14                       SET STRING=$PIECE(STRING,LOOK,1)_REPLACE_$PIECE(STRING,LOOK,2,999)

 +15      ;W !,"MY TEXT= ",STRING," TEXT= ",TEXT H 2 ;****DELETE

                       End DoDot:2

               End DoDot:1

 +16       SET PSOEXSIG=STRING

 +17       KILL STRING,TEXT,LOOK,REPLACE,NUMBER

 +18       QUIT 

CHANGET   ;CHANGE TIME AROUND

 +1        SET STRING=PSOEXSIG

 +2       ;S STRING=X

 +3        FOR I=1:1

               SET TEXT=$PIECE($TEXT(TTEXT+I),";;",2)

               IF TEXT="QUIT"

                   QUIT 

               Begin DoDot:1

 +4                SET LOOK=$PIECE(TEXT,";",1)

 +5                SET REPLACE=$PIECE(TEXT,";",2)

 +6                SET NUMBER=$LENGTH(STRING,LOOK)-1

 +7                IF NUMBER<1

                       QUIT 

 +8                FOR J=1:1:NUMBER

                       Begin DoDot:2

 +9                        SET STRING=$PIECE(STRING,LOOK,1)_REPLACE_$PIECE(STRING,LOOK,2,999)

 +10      ;W !,"MY TEXT= ",STRING," TEXT= ",TEXT H 2 ;****DELETE

                       End DoDot:2

               End DoDot:1

 +11       SET PSOEXSIG=STRING

 +12       KILL STRING,TEXT,LOOK,REPLACE,NUMBER

 +13       QUIT 

CHANGEH   ;CHANGE TIME TO NUMBERS 

 +1        SET PSOEXMX=0

 +2       ;S (PIECE(1),PIECE(2))=""

 +3       ;TO STOP WHEN FIND SOMETHING

           SET (QUIT(1),QUIT(2))=""

 +4       ;PSOEXSIG DEFINED

 +5       ;1 THE BELOW DEFINES TYPE OF ITEM TABLET, TEASPOON ETC

 +6       ;2 LOOP THRU T2T BID AND T1T HS AND BREAKS UP

 +7       ;3 CALCULATES FIRST PART OF SIG-THE NUMBER OF TABLETS ETC

 +8       ;4 CALCULATES THE TIME PERIOD OF SIG-THE SECOND PORTION 4XDAILY ETC

LOOP       SET (FIRST,SECOND,FIND)=0

           SET PSOSIGS=PSOEXSIG

 +1        IF $LENGTH(PSOEXSIG,"ZGLOB")>1

               SET DELIMIT="ZGLOB"

               SET MANY=$LENGTH(PSOEXSIG,"ZGLOB")-1

               SET MULT=1

               FOR LOOP=1:1:MANY

                   DO A

                   IF $GET(QUT)

                       QUIT 

 +2        IF $LENGTH(PSOEXSIG,"TEASPOON")>1

               SET DELIMIT="TEASPOON"

               SET MANY=$LENGTH(PSOEXSIG,"TEASPOON")-1

               SET MULT=5

               FOR LOOP=1:1:MANY

                   DO A

                   IF $GET(QUT)

                       QUIT 

 +3        IF $LENGTH(PSOEXSIG,"BIGSPOON")>1

               SET DELIMIT="BIGSPOON"

               SET MANY=$LENGTH(PSOEXSIG,"BIGSPOON")-1

               SET MULT=15

               FOR LOOP=1:1:MANY

                   DO A

                   IF $GET(QUT)

                       QUIT 

 +4        IF $LENGTH(PSOEXSIG,"UNIT")>1