BPCRXDAY ; IHS/OIT/MJL - PROGRAM TO CALCULATE DEFAULT DAYS SUP ;
;;1.5;BPC;;MAY 26, 2005
;THIS IS REALLY PSORDAY WITH WRITE REMOVED PHARM 6.0 PATCH 3
;W !,"ENTER THE STRING "
;R X:30
;I (X="")!(X["^") QUIT
IF $D(PSORENW("SIG")) S X=$G(PSORENW("SIG")) Q:X'[""
IF $D(PSONEW("SIG")) S X=$G(PSONEW("SIG")) Q:X'[""
D SIG^PSOHELP S (X,PSOEXSIG)=SIG
;X ^DD(52,10,9.2) S (X,PSOEXSIG)=SIG
I (PSOEXSIG="")!(PSOEXSIG["^") QUIT
;S PSOEXSIG=X
;W !,"ENTER QYT "
;R PSOEXQTY:30
IF $D(PSORENW("QTY")) S PSOEXQTY=$G(PSORENW("QTY")) Q:'PSOEXQTY
IF $D(PSONEW("QTY")) S PSOEXQTY=$G(PSONEW("QTY")) Q:'PSOEXQTY
I (PSOEXQTY="")!(PSOEXQTY["^") QUIT
;SET EXPANDED SIG EQUAL TO PSOEXSIG
;SET QTY EQUAL TO PSOEXQTY
;GET BACK PSOZDAY AS THE DAYS SUPPLY-IF VALUE NULL COULDNT CALCULATE
;
;D CHANGEN
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
BPCRXDAY ; IHS/OIT/MJL - PROGRAM TO CALCULATE DEFAULT DAYS SUP ;
+1 ;;1.5;BPC;;MAY 26, 2005
+2 ;THIS IS REALLY PSORDAY WITH WRITE REMOVED PHARM 6.0 PATCH 3
+3 ;W !,"ENTER THE STRING "
+4 ;R X:30
+5 ;I (X="")!(X["^") QUIT
+6 IF $DATA(PSORENW("SIG"))
SET X=$GET(PSORENW("SIG"))
IF X'[""
QUIT
+7 IF $DATA(PSONEW("SIG"))
SET X=$GET(PSONEW("SIG"))
IF X'[""
QUIT
+8 DO SIG^PSOHELP
SET (X,PSOEXSIG)=SIG
+9 ;X ^DD(52,10,9.2) S (X,PSOEXSIG)=SIG
+10 IF (PSOEXSIG="")!(PSOEXSIG["^")
QUIT
+11 ;S PSOEXSIG=X
+12 ;W !,"ENTER QYT "
+13 ;R PSOEXQTY:30
+14 IF $DATA(PSORENW("QTY"))
SET PSOEXQTY=$GET(PSORENW("QTY"))
IF 'PSOEXQTY
QUIT
+15 IF $DATA(PSONEW("QTY"))
SET PSOEXQTY=$GET(PSONEW("QTY"))
IF 'PSOEXQTY
QUIT
+16 IF (PSOEXQTY="")!(PSOEXQTY["^")
QUIT
+17 ;SET EXPANDED SIG EQUAL TO PSOEXSIG
+18 ;SET QTY EQUAL TO PSOEXQTY
+19 ;GET BACK PSOZDAY AS THE DAYS SUPPLY-IF VALUE NULL COULDNT CALCULATE
+20 ;
+21 ;D CHANGEN
+22 DO CHANGER
+23 DO CHANGES
+24 DO FUZZY
+25 DO CHANGEN
+26 DO CHANGET
+27 DO CHANGEH
+28 DO DAY
+29 DO END
+30 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
SET DELIMIT="UNIT"
SET MANY=$LENGTH(PSOEXSIG,"UNIT")-1
SET MULT=.01
FOR LOOP=1:1:MANY
DO A
IF $GET(QUT)
QUIT
+5 DO KILLH
+6 QUIT
+7 ;
A SET (PIECE(1),PIECE(2))=""
+1 ;TAKE 1 WHATEVER TWOTIMESDAILY AND TAKE 2 WHATEVER ONETIMESDAILY
+2 ;SEPARATE THE PARTS TAKE 1 WHATEVER TWOTIMESDAILY
+3 ;S FIRST=FIRST+FIND
+4 SET FIRST=FIND
+5 SET FIND=$FIND(PSOSIGS,"DAILY",FIRST)
+6 SET SECOND=FIND-1
+7 SET PSOEXSIG=$EXTRACT(PSOSIGS,FIRST,SECOND)
+8 ;W !,"EACH SECTION IS= ",PSOEXSIG ;****DELETE
+9 ;
+10 SET STRING(1)=$PIECE(PSOEXSIG,DELIMIT)
SET STRING(2)=$PIECE(PSOEXSIG,DELIMIT,2)
+11 ;W !,"LOOP= ",LOOP H 2 ;****DELETE
+12 ;
FOR Q=1:1:20
Begin DoDot:1
+13 ;
FOR P=1:1:20
Begin DoDot:2
+14 SET CHECK=Q_" TO "_P
SET PART=Q_" TO"
+15 IF STRING(1)[CHECK
Begin DoDot:3
+16 ;W !,STRING(1)," BECOMES " ;****DELETE
+17 ;SO 1 TO 2 BECOMES 2
SET STRING(1)=$PIECE(STRING(1),PART,2)
+18 ;W STRING(1) ;****DELETE
End DoDot:3
End DoDot:2
End DoDot:1
B ;B ADDED 3/10/98 NEXT 7 LINES
+1 ;
FOR Q=1:1:5,.25,.33,.5,.66,.75
Begin DoDot:1
+2 ;
FOR P=1:1:5,.25,.33,.5,.66,.75
Begin DoDot:2
+3 SET CHECK=Q_" TO "_P
SET PART=Q_" TO"
+4 IF STRING(1)[CHECK
Begin DoDot:3
+5 ;W !,STRING(1)," BECOMES " ;****DELETE
+6 ;SO .25 TO .33 BECOMES .33
SET STRING(1)=$PIECE(STRING(1),PART,2)
+7 ;W STRING(1) ;****DELETE
End DoDot:3
End DoDot:2
End DoDot:1
+8 ;COMMENTED OUT 3/10/98
+9 SET LENGTH=$LENGTH(STRING(1))
+10 ;W !,"PIECE(1) BECOMES ",PIECE(1)
FOR K=1:1:LENGTH
SET TEST=$EXTRACT(STRING(1),K)
IF TEST?1N!(TEST?1".")
SET PIECE(1)=PIECE(1)_TEST
+11 ;G:PIECE(1)="" KILLH
+12 ;NOTE SECOND HALF OF SIG
+13 FOR I=1:1
SET TEXT=$PIECE($TEXT(HTEXT+I),";;",2)
IF TEXT="QUIT"!QUIT(2)
QUIT
Begin DoDot:1
+14 SET COMPARE(2)=$PIECE(TEXT,",",1)
+15 SET REPLACE(2)=$PIECE(TEXT,",",2)
+16 IF STRING(2)[COMPARE(2)
SET PIECE(2)=REPLACE(2)
SET QUIT(2)=1
QUIT
End DoDot:1
+17 ;ADDED NEXT 4 LINES 3/10/98
+18 ;W !,"PIECE(1) ",PIECE(1)," BECOMES " ;****DELETE
+19 ;W PIECE(1) ;****DELETE
SET PIECE(1)=+PIECE(1)
+20 ;W !,"PIECE(2) ",PIECE(2)," BECOMES ";****DELETE
+21 ;W PIECE(2) ;****DELETE
SET PIECE(2)=+PIECE(2)
+22 ;3/10/98 POC ABOVE 4 LINES
+23 IF PIECE(1)
IF PIECE(2)
SET PSOEXMX=PIECE(1)*PIECE(2)*MULT
+24 ;W !,"PIECE(1)= ",PIECE(1)," PIECE(2)= ",PIECE(2)," MULT= ",MULT H 2
+25 ;RESET QUIT VARIABLES
SET (QUIT(1),QUIT(2))=""
+26 ;PSOEXMXT IS TOTAL OF ALL PSOEXMX
SET PSOEXMXT=$GET(PSOEXMXT)+PSOEXMX
+27 ;IF 'PSOEXMX W !,*7,*7,"I DONT KNOW THE DAYS SUPPLY-GO FIGURE!" S PSOZDAY="",QUT=1 Q
+28 IF 'PSOEXMX
SET PSOEXMXT=0
SET QUT=1
QUIT
+29 SET PSOEXMX=0
+30 ;DELETE THE ABOVE LATER ****DELETE
+31 QUIT
KILLH ;KILL VARIABLES
+1 KILL TEST,LENGTH,PIECE,STRING,DELIMIT,COMPARE,REPLACE,MULT
+2 QUIT
+3 ;
DAY ;CALCULATE THE DAYS SUPPLY
+1 IF '$GET(PSOEXMXT)
SET PSOZDAY=""
WRITE !,*7,*7,"I DONT KNOW THE DAYS SUPPLY-GO FIGURE!"
+2 ;W !,"PSOZDAY= ",PSOZDAY ;****DELETE
IF '$TEST
SET PSOZDAY=PSOEXQTY\PSOEXMXT
+3 QUIT
CHANGER ;GOES LIKE THIS '4 TO 6' GETS CHANGED TO '4 OR 6'
+1 ;VARIABLE
+2 FOR Z=1:1
SET TEXT=$PIECE($TEXT(TRTEXT+Z),";;",2)
IF TEXT="QUIT"
QUIT
SET TR=$PIECE(TEXT,";",1)
SET TRTO=$PIECE(TEXT,";",2)
DO TRA
+3 QUIT
TRA FOR I=1:1:20
Begin DoDot:1
+1 FOR J=1:1:20
Begin DoDot:2
+2 SET REPLACE=I_" "_TR_" "_J
+3 SET REPLANEW=I_" "_TRTO_" "_J
+4 SET TIMES=$LENGTH(PSOEXSIG,REPLACE)-1
+5 IF TIMES=0
QUIT
+6 FOR K=1:1:TIMES
Begin DoDot:3
+7 SET SAVE(K)=$PIECE(PSOEXSIG,REPLACE,K)
+8 SET CUT(K)=$LENGTH(SAVE(K))+1
End DoDot:3
+9 SET SAVE(K+1)=$PIECE(PSOEXSIG,REPLACE,K+1)
+10 SET CONVERT=""
+11 FOR C=1:1:TIMES
Begin DoDot:3
+12 SET CONVERT=CONVERT_SAVE(C)_REPLANEW
End DoDot:3
+13 SET CONVERT=CONVERT_SAVE(C+1)
+14 ;W !,"MY TEXT= ",CONVERT," TEXT= ",TEXT ;****DELETE
+15 SET PSOEXSIG=CONVERT
End DoDot:2
End DoDot:1
+16 QUIT
TRTEXT ;REPLACES SOME MORE STUFF
+1 ;;OR;TO
+2 ;;-;TO
+3 ;;QUIT
CHANGES ;GOES LIKE THIS '1-2' GETS CHANGED TO '1 OR 2'
+1 ;VARIABLE
+2 FOR Z=1:1
SET TEXT=$PIECE($TEXT(TSTEXT+Z),";;",2)
IF TEXT="QUIT"
QUIT
SET TR=$PIECE(TEXT,";",1)
SET TRTO=$PIECE(TEXT,";",2)
DO TRS
+3 QUIT
TRS FOR I=1:1:20
Begin DoDot:1
+1 FOR J=1:1:20
Begin DoDot:2
+2 SET REPLACE=I_TR_J
+3 SET REPLANEW=I_" "_TRTO_" "_J
+4 SET TIMES=$LENGTH(PSOEXSIG,REPLACE)-1
+5 IF TIMES=0
QUIT
+6 FOR K=1:1:TIMES
Begin DoDot:3
+7 SET SAVE(K)=$PIECE(PSOEXSIG,REPLACE,K)
+8 SET CUT(K)=$LENGTH(SAVE(K))+1
End DoDot:3
+9 SET SAVE(K+1)=$PIECE(PSOEXSIG,REPLACE,K+1)
+10 SET CONVERT=""
+11 FOR C=1:1:TIMES
Begin DoDot:3
+12 SET CONVERT=CONVERT_SAVE(C)_REPLANEW
End DoDot:3
+13 SET CONVERT=CONVERT_SAVE(C+1)
+14 ;W !,"MY TEXT= ",CONVERT," TEXT= ",TEXT ;****DELETE
+15 SET PSOEXSIG=CONVERT
End DoDot:2
End DoDot:1
+16 QUIT
TSTEXT ;REPLACES SOME MORE STUFF
+1 ;;-;TO
+2 ;;QUIT
+3 ;
FUZZY ;CHANGES EVERY 4 TO 6 HOURS - EVERY 4 HOURS
+1 ;CHANGES 4 TO 6 TIMES - TO 4 TIMES
+2 FOR I=1:1
SET TEXT=$PIECE($TEXT(TEXTF+I),";;",2)
IF TEXT="QUIT"
QUIT
SET FIRST=$PIECE(TEXT,";")
SET SECOND=$PIECE(TEXT,";",2)
Begin DoDot:1
+3 FOR Q=1:1:24
Begin DoDot:2
+4 FOR P=1:1:24
Begin DoDot:3
+5 SET CHECK=FIRST_" "_Q_" TO "_P_" "_SECOND
SET PART=FIRST_" "_Q_" "_SECOND
+6 ;
IF PSOEXSIG[CHECK
Begin DoDot:4
+7 ;W !,PSOEXSIG," BECOMES "
+8 SET PSOEXSIG=$PIECE(PSOEXSIG,CHECK,1)_PART_$PIECE(PSOEXSIG,CHECK,2)
+9 ;W PSOEXSIG H 2
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
TEXTF ;;FIRST WORD;LAST WORD
+1 ;;EVERY;HOURS
+2 ;;;TIMES
+3 ;;QUIT
