Routine: PSOSPSIG

PSOSPSIG ;BIR/RTR,SAB-Parse out and create other lang. Sig ;9/24/01

 ;;7.0;OUTPATIENT PHARMACY;**117**;DEC 1997

 ;PSSORPH - DBIA 3234 ;^PS(50.606 - DBIA 2174 ;^PS(50.7 - DBIA 2223

 ;^PS(51.2 - DBIA 2226 ;^PS(51 - DBIA 2224 ;^PSDRUG - DBIA 221

 ;^PS(59.7 - DBIA 694 ;^PS(51.1 - DBIA 2225

EN(PSOFX) ;

 K SIG9,PSNOUN,PSOROUTE,SIG0 S OI=$P($G(^PSRX(RX,"OR1")),"^") Q:'$G(OI)

 S (FND,TODOSE)=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW  S TODOSE=WW

 S:TODOSE FND=1 Q:'TODOSE  S SIGDS=+$P($G(^PS(50.7,OI,0)),"^",2)

 S PREP=$S($P($G(^PS(50.606,SIGDS,"MISC1")),"^",2)]"":$P(^PS(50.606,SIGDS,"MISC1"),"^",2),1:$P($G(^PS(50.606,SIGDS,"MISC")),"^",3))

 S RTCNT=0 K RTC,RTCA,RTCF F SSS=1:1:TODOSE D

 .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS))) ;local dosage check

 .I $G(PSOFX("DOSE ORDERED",SSS))="" S LODS=$O(^PSDRUG($P(^PSRX(RX,0),"^",6),"DOS2","B",SIG0(SSS),0)) I LODS D

 ..S:$P(^PSDRUG($P(^PSRX(RX,0),"^",6),"DOS2",LODS,0),"^",4)]"" PSOFX("DOSE ORDERED",SSS)=$P(^PSDRUG($P(^PSRX(RX,0),"^",6),"DOS2",LODS,0),"^",4) K LODS

 .S VERBX(SSS)=$S($G(PSOFX("VERB",SSS))]""&($P($G(^PS(50.606,SIGDS,"MISC1")),"^")]""):$P(^PS(50.606,SIGDS,"MISC1"),"^"),1:$G(PSOFX("VERB",SSS)))

 .I $G(PSOFX("NOUN",SSS))]"" D NON

 .S RTC=+$G(PSOFX("ROUTE",SSS)) I RTC S:'RTCNT RTCA=RTC S RTCNT=RTCNT+1

 .I RTCNT>1,$G(RTC),$G(RTC)'=$G(RTCA) S RTCF=1

 .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",7)]"":$P(^(0),"^",7),$P($G(^(0)),"^",2)]"":$P(^(0),"^",2),$P($G(^(0)),"^",3)]"":$P(^(0),"^",3),1:$P($G(^(0)),"^"))

 .S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1)

 .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS))

 .I $G(PSOFX("DURATION",SSS))]"",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D"

 .S FOR=$O(^PS(59.7,"AOTH","FOR","")) S FOR=$S(FOR]"":FOR,1:"FOR")

 .S PSDUR(SSS)=$S($G(PDAYS(SSS))']"":"NULL",1:FOR_" "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D  I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL

 ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D

 ...Q:$G(INTERVAL)']""  S INTERVAL=$O(^PS(59.7,"AOTH",INTERVAL,""))

 ...I $G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1))

 F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG)) D

 .I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q

 .S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG))  D

 ..I $G(^PS(51.1,WW,3))]"" S SCHED(GGG)=^(3),SGLFLAG=1 Q

 ..I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1

 .Q:$G(SGLFLAG)

 .I $O(^PS(51,"B",ZSCHED(GGG),0)) S IN=$O(^PS(51,"B",ZSCHED(GGG),0)) I $P($G(^PS(51,IN,4)),"^")]"" S SCHED(GGG)=$P(^PS(51,IN,4),"^") K IN Q

 .I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q

 .K IN S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1

 .S ZZSB=ZZSB+1

 .K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D

 ..Q:$G(SDL)=""

 ..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG))  D

 ...I $G(^PS(51.1,WW,3))]"" S SCHED(GGG)=^(3),SCHHOLD(GGGZ)=^(3),SGLFLAG=1 Q

 ...I $P($G(^PS(51.1,WW,0)),"^",8)]"" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1

 ..Q:$G(SGLFLAG)

 ..I $G(^PS(51,"A",SDL))]"" S IN=$O(^PS(51,"B",SDL,0)) D:IN  Q

 ...S SCHHOLD(GGGZ)=$S($G(^PS(51,IN,4))]"":^PS(51,IN,4),1:$P(^PS(51,"A",SDL),"^"))

 .S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1

 S (RTC,RTCA,PSOBDCT)=0 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  D

 .K PSOSG1,PSOSG2 S VERB=$G(VERBX(FFF)) D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS

 .D FRAC

 .S SIG2(FFF)=$S($G(VERB)'=""&('$G(PSOSG1)):$G(VERB)_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ")

 .S PSOBDCT=PSOBDCT+1

 .K PSOFRAC,PSOFRACX

 .I RTC>0,$G(PSOROUTE(FFF))'="",'$G(RTCF) S RTCA=1

 .I $G(PSOROUTE(FFF))'="" S RTC=RTC+1

 .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF)))&('RTCA):PREP_" ",1:"")

 .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'=""&('RTCA):PSOROUTE(FFF)_" ",1:"")

 .S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"")

 .S PSOCJ=$E($G(PSOFX("CONJUNCTION",FFF)))

 .S CON=$S($G(PSOCJ)="A":"AND",$G(PSOCJ)="T":"THEN",$G(PSOCJ)="S":"THEN",$G(PSOCJ)="X":"EXCEPT",1:"") I CON]"" S CON=$O(^PS(59.7,"AOTH",CON,""))

 .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_CON

 .K PSOSG1,PSOSG2

 .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS

 S PSODCT="" F  S PSODCT=$O(PSOFX("SIG",PSODCT)) Q:PSODCT=""  S PSOBDCT=PSOBDCT+1 S SIG2(PSOBDCT)=$G(PSOFX("SIG",PSODCT)) K PSOUCS S SIG2(PSOBDCT)=$$UPPER(SIG2(PSOBDCT)) K PSOUCS

STUFF ;

 S DCOUNT=0

 I '$D(SIG2(1)) G QUIT

 I '$O(SIG2(1)),$L(SIG2(1))<71 S SIG9(1)=SIG2(1)

 S (VAR,VAR1)="",II=1

 F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF  S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D  I $L(VAR)>70 S SIG9(II)=LIM_" ",II=II+1,VAR=VAR1

 .S VAR1=$P(SIG2(FF)," ",(CT))

 .S LIM=VAR

 .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1)

 I $G(VAR)'="" S SIG9(II)=VAR

QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q

SIG1 ;

 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  S SIG2(FFF)=SIG0(FFF)

DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2)

NON ;

 S NN=PSOFX("NOUN",SSS)

 S NOUN=$O(^PS(50.606,SIGDS,"NOUN","B",NN,0)) I NOUN S PSNOUN(SSS)=$S($G(^PS(50.606,SIGDS,"NOUN",NOUN,1))]"":^PS(50.606,SIGDS,"NOUN",NOUN,1),1:NN) K NN Q

 K NN,NOUN D DOSE^PSSORPH(.XDOSE,$P(^PSRX(RX,0),"^",6),"O") Q:$P(XDOSE("DD",$P(^PSRX(RX,0),"^",6)),"^",9)=""

 S NN=$P(XDOSE("DD",$P(^PSRX(RX,0),"^",6)),"^",9),NOUN=$O(^PS(50.606,SIGDS,"NOUN","B",NN,0))

 I NOUN S PSNOUN(SSS)=$S($G(^PS(50.606,SIGDS,"NOUN",NOUN,1))]"":^PS(50.606,SIGDS,"NOUN",NOUN,1),1:NN)

 K XDOSE,NN Q

VERB ;Check if verb and noun need to be added to SIG

 K PSOLCS,PSOUCS,PSOISL,PSOVL

 I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D

 .S PSOUCS=VERB

 .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q

 .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q

 .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q

 I $G(PSNOUN(FFF))="" G VERBEX

 S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX

 S PSOVL=$F(PSNOUN(FFF),"(")

 I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2))

 I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF)

 I $G(PSOISL)'="" D

 .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q

 .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q

 .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1

VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q

UPPER(PSOUCS) ;

 Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

LOWER(PSOLCS) ;

 Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")

SSS ;

 K PSOFNL,PSOFNLF,PSOFNLX

 Q:$G(PSNOUN(FFF))=""

 Q:$L(PSNOUN(FFF))'>3

 Q:'$G(PSOFX("DOSE ORDERED",FFF))

 S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF)))

 I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D

 .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))

 .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2)

FRAC ;

 K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2

 I $G(PSOFX("DOSE ORDERED",FFF))="" Q

 I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D  G FRACQ

 .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q

 .S PSOFRAC=$G(PSOFRAC1)

 S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2)

 S PSOFRACX="."_$G(PSOFRAC2)

 S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:PSOFRACX)

 S PSOFRAC9=$O(^PS(59.7,"AOTH",PSOFRAC,"")) I PSOFRAC9]"" S PSOFRAC=PSOFRAC9

 K PSOFRAC9

 I $G(PSOFRAC)="" K PSOFRAC G FRACQ

 I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D

 .D NUM S AND=$O(^PS(59.7,"AOTH","AND",""))

 .S PSOFRAC=$G(PSOFRAC1)_" "_$S(AND]"":AND,1:"AND")_" "_$S($E($G(PSOFRAC),1)=".":"0",1:"")_$G(PSOFRAC)

 I $E($G(PSOFRAC),1)="." S PSOFRAC="0"_$G(PSOFRAC)

FRACQ K PSOFRAC1,PSOFRAC2,AND

NUM ;

 Q:$G(PSOFRAC1)=""

 S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1)

 S PSOFRAC9=$O(^PS(59.7,"AOTH",PSOFRAC1,"")) I PSOFRAC9]"" S PSOFRAC1=PSOFRAC9

 K PSOFRAC9

PSOSPSIG  ;BIR/RTR,SAB-Parse out and create other lang. Sig ;9/24/01

 +1       ;;7.0;OUTPATIENT PHARMACY;**117**;DEC 1997

 +2       ;PSSORPH - DBIA 3234 ;^PS(50.606 - DBIA 2174 ;^PS(50.7 - DBIA 2223

 +3       ;^PS(51.2 - DBIA 2226 ;^PS(51 - DBIA 2224 ;^PSDRUG - DBIA 221

 +4       ;^PS(59.7 - DBIA 694 ;^PS(51.1 - DBIA 2225

 +5       ;

EN(PSOFX) ;

 +1        KILL SIG9,PSNOUN,PSOROUTE,SIG0

           SET OI=$PIECE($GET(^PSRX(RX,"OR1")),"^")

           IF '$GET(OI)

               QUIT

 +2        SET (FND,TODOSE)=0

           FOR WW=0:0

               SET WW=$ORDER(PSOFX("DOSE",WW))

               IF 'WW

                   QUIT

               SET TODOSE=WW

 +3        IF TODOSE

               SET FND=1

           IF 'TODOSE

               QUIT

           SET SIGDS=+$PIECE($GET(^PS(50.7,OI,0)),"^",2)

 +4        SET PREP=$SELECT($PIECE($GET(^PS(50.606,SIGDS,"MISC1")),"^",2)]"":$PIECE(^PS(50.606,SIGDS,"MISC1"),"^",2),1:$PIECE($GET(^PS(50.606,SIGDS,"MISC")),"^",3))

 +5        SET RTCNT=0

           KILL RTC,RTCA,RTCF

           FOR SSS=1:1:TODOSE

               Begin DoDot:1

 +6       ;local dosage check

                   SET SIG0(SSS)=$SELECT($GET(PSOFX("DOSE ORDERED",SSS))'="":$GET(PSOFX("DOSE ORDERED",SSS)),1:$GET(PSOFX("DOSE",SSS)))

 +7                IF $GET(PSOFX("DOSE ORDERED",SSS))=""

                       SET LODS=$ORDER(^PSDRUG($PIECE(^PSRX(RX,0),"^",6),"DOS2","B",SIG0(SSS),0))

                       IF LODS

                           Begin DoDot:2

 +8                            IF $PIECE(^PSDRUG($PIECE(^PSRX(RX,0),"^",6),"DOS2",LODS,0),"^",4)]""

                                   SET PSOFX("DOSE ORDERED",SSS)=$PIECE(^PSDRUG($PIECE(^PSRX(RX,0),"^",6),"DOS2",LODS,0),"^",4)

                               KILL LODS

                           End DoDot:2

 +9                SET VERBX(SSS)=$SELECT($GET(PSOFX("VERB",SSS))]""&($PIECE($GET(^PS(50.606,SIGDS,"MISC1")),"^")]""):$PIECE(^PS(50.606,SIGDS,"MISC1"),"^"),1:$GET(PSOFX("VERB",SSS)))

 +10               IF $GET(PSOFX("NOUN",SSS))]""

                       DO NON

 +11               SET RTC=+$GET(PSOFX("ROUTE",SSS))

                   IF RTC

                       IF 'RTCNT

                           SET RTCA=RTC

                       SET RTCNT=RTCNT+1

 +12               IF RTCNT>1

                       IF $GET(RTC)

                           IF $GET(RTC)'=$GET(RTCA)

                               SET RTCF=1

 +13               SET PSOROUTE(SSS)=$SELECT($PIECE($GET(^PS(51.2,+$GET(PSOFX("ROUTE",SSS)),0)),"^",7)]"":$PIECE(^(0),"^",7),$PIECE($GET(^(0)),"^",2)]"":$PIECE(^(0),"^",2),$PIECE($GET(^(0)),"^",3)]"":$PIECE(^(0),"^",3),1:$PIECE($GET(^(0)),"^"))

 +14               SET MEDEXP(SSS)=$SELECT($PIECE($GET(^PS(51.2,+$GET(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1)

 +15               SET PDAYS(SSS)=$GET(PSOFX("DURATION",SSS))

 +16               IF $GET(PSOFX("DURATION",SSS))]""

                       IF ($EXTRACT(PSOFX("DURATION",SSS),$LENGTH(PSOFX("DURATION",SSS)))'?1A)

                           SET PDAYS(SSS)=PDAYS(SSS)_"D"

 +17               SET FOR=$ORDER(^PS(59.7,"AOTH","FOR",""))

                   SET FOR=$SELECT(FOR]"":FOR,1:"FOR")

 +18               SET PSDUR(SSS)=$SELECT($GET(PDAYS(SSS))']"":"NULL",1:FOR_" "_$EXTRACT($GET(PDAYS(SSS)),1,($LENGTH($GET(PDAYS(SSS)))-1)))

                   Begin DoDot:2

 +19                   IF PSDUR(SSS)'="NULL"

                           SET INTERVAL=$EXTRACT(PDAYS(SSS),$LENGTH(PDAYS(SSS)))

                           SET INTERVAL=$SELECT(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"")

                           Begin DoDot:3

 +20                           IF $GET(INTERVAL)']""

                                   QUIT

                               SET INTERVAL=$ORDER(^PS(59.7,"AOTH",INTERVAL,""))

 +21                           IF $GET(PSOFX("DURATION",SSS))

                                   IF $GET(PSOFX("DURATION",SSS))'>1

                                       SET INTERVAL=$EXTRACT(INTERVAL,1,($LENGTH(INTERVAL)-1))

                           End DoDot:3

                   End DoDot:2

                   IF PSDUR(SSS)'="NULL"

                       SET PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL

               End DoDot:1

 +22       FOR GGG=1:1:TODOSE

               SET ZSCHED(GGG)=$GET(PSOFX("SCHEDULE",GGG))

               Begin DoDot:1

 +23               IF $GET(ZSCHED(GGG))=""

                       SET SCHED(GGG)=""

                       QUIT

 +24               SET SGLFLAG=0

                   FOR WW=0:0

                       SET WW=$ORDER(^PS(51.1,"B",ZSCHED(GGG),WW))

                       IF 'WW!($GET(SGLFLAG))

                           QUIT

                       Begin DoDot:2

 +25                       IF $GET(^PS(51.1,WW,3))]""

                               SET SCHED(GGG)=^(3)

                               SET SGLFLAG=1

                               QUIT

 +26                       IF $PIECE($GET(^PS(51.1,WW,0)),"^",8)'=""

                               SET SCHED(GGG)=$PIECE($GET(^(0)),"^",8)

                               SET SGLFLAG=1

                       End DoDot:2

 +27               IF $GET(SGLFLAG)

                       QUIT

 +28               IF $ORDER(^PS(51,"B",ZSCHED(GGG),0))

                       SET IN=$ORDER(^PS(51,"B",ZSCHED(GGG),0))

                       IF $PIECE($GET(^PS(51,IN,4)),"^")]""

                           SET SCHED(GGG)=$PIECE(^PS(51,IN,4),"^")

                           KILL IN

                           QUIT

 +29               IF $GET(^PS(51,"A",ZSCHED(GGG)))'=""

                       SET SCHED(GGG)=$PIECE(^(ZSCHED(GGG)),"^")

                       QUIT

 +30               KILL IN

                   SET ZZSB=0

                   FOR ZZS=1:1:$LENGTH(ZSCHED(GGG))

                       SET SZZ=$EXTRACT(ZSCHED(GGG),ZZS)

                       IF SZZ=" "

                           SET ZZSB=ZZSB+1

 +31               SET ZZSB=ZZSB+1

 +32               KILL SCHHOLD

                   FOR GGGZ=1:1:ZZSB

                       SET (SDL,SCHHOLD(GGGZ))=$PIECE(ZSCHED(GGG)," ",GGGZ)

                       Begin DoDot:2

 +33                       IF $GET(SDL)=""

                               QUIT

 +34                       SET SGLFLAG=0

                           FOR WW=0:0

                               SET WW=$ORDER(^PS(51.1,"B",SDL,WW))

                               IF 'WW!($GET(SGLFLAG))

                                   QUIT

                               Begin DoDot:3

 +35                               IF $GET(^PS(51.1,WW,3))]""

                                       SET SCHED(GGG)=^(3)

                                       SET SCHHOLD(GGGZ)=^(3)

                                       SET SGLFLAG=1

                                       QUIT

 +36                               IF $PIECE($GET(^PS(51.1,WW,0)),"^",8)]""

                                       SET SCHHOLD(GGGZ)=$PIECE($GET(^(0)),"^",8)

                                       SET SGLFLAG=1

                               End DoDot:3

 +37                       IF $GET(SGLFLAG)

                               QUIT

 +38                       IF $GET(^PS(51,"A",SDL))]""

                               SET IN=$ORDER(^PS(51,"B",SDL,0))

                               IF IN

                                   Begin DoDot:3

 +39                                   SET SCHHOLD(GGGZ)=$SELECT($GET(^PS(51,IN,4))]"":^PS(51,IN,4),1:$PIECE(^PS(51,"A",SDL),"^"))

                                   End DoDot:3

                               QUIT

                       End DoDot:2

 +40               SET SCHED(GGG)=""

                   SET SGLFLAG=0

                   FOR WW=1:1:ZZSB

                       SET SCHED(GGG)=SCHED(GGG)_$SELECT($GET(SGLFLAG):" ",1:"")_$GET(SCHHOLD(WW))

                       SET SGLFLAG=1

               End DoDot:1

 +41       SET (RTC,RTCA,PSOBDCT)=0

           FOR FFF=0:0

               SET FFF=$ORDER(SIG0(FFF))

               IF 'FFF

                   QUIT

               Begin DoDot:1

 +42               KILL PSOSG1,PSOSG2

                   SET VERB=$GET(VERBX(FFF))

                   DO VERB

                   IF $GET(PSNOUN(FFF))'=""&('$GET(PSOSG1))

                       DO SSS

 +43               DO FRAC

 +44               SET SIG2(FFF)=$SELECT($GET(VERB)'=""&('$GET(PSOSG1)):$GET(VERB)_" ",1:"")_$SELECT($GET(PSOFX("DOSE ORDERED",FFF))'="":$SELECT($GET(PSOFRAC)'="":$GET(PSOFRAC),1:$GET(PSOFX("DOSE ORDERED",FFF)))_" ",1:$GET(PSOFX("DOSE",FFF))_" ")

 +45               SET PSOBDCT=PSOBDCT+1

 +46               KILL PSOFRAC,PSOFRACX

 +47               IF RTC>0

                       IF $GET(PSOROUTE(FFF))'=""

                           IF '$GET(RTCF)

                               SET RTCA=1

 +48               IF $GET(PSOROUTE(FFF))'=""

                       SET RTC=RTC+1

 +49               SET SIG2(FFF)=SIG2(FFF)_$SELECT($GET(PSNOUN(FFF))'=""&('$GET(PSOSG2)):$GET(PSNOUN(FFF))_" ",1:"")_$SELECT(PREP'=""&($GET(MEDEXP(FFF)))&('RTCA):PREP_" ",1:"")

 +50               SET SIG2(FFF)=SIG2(FFF)_$SELECT(PSOROUTE(FFF)'=""&('RTCA):PSOROUTE(FFF)_" ",1:"")

 +51               SET SIG2(FFF)=SIG2(FFF)_$SELECT(SCHED(FFF)'="":SCHED(FFF)_$SELECT($GET(PSDUR(FFF))="NULL"&($GET(PSOFX("CONJUNCTION",FFF))="")&('$ORDER(SIG0(FFF))):"",1:" "),1:"")

 +52               SET PSOCJ=$EXTRACT($GET(PSOFX("CONJUNCTION",FFF)))

 +53               SET CON=$SELECT($GET(PSOCJ)="A":"AND",$GET(PSOCJ)="T":"THEN",$GET(PSOCJ)="S":"THEN",$GET(PSOCJ)="X":"EXCEPT",1:"")

                   IF CON]""

                       SET CON=$ORDER(^PS(59.7,"AOTH",CON,""))

 +54               SET SIG2(FFF)=SIG2(FFF)_$SELECT(PSDUR(FFF)'="NULL":PSDUR(FFF)_$SELECT($GET(PSOFX("CONJUNCTION",FFF))=""&('$ORDER(SIG0(FFF))):"",1:", "),1:"")_CON

 +55               KILL PSOSG1,PSOSG2

 +56               KILL PSOUCS

                   SET SIG2(FFF)=$$UPPER(SIG2(FFF))

                   KILL PSOUCS

               End DoDot:1

 +57       SET PSODCT=""

FOR

               SET PSODCT=$ORDER(PSOFX("SIG",PSODCT))

               IF PSODCT=""

                   QUIT

               SET PSOBDCT=PSOBDCT+1

               SET SIG2(PSOBDCT)=$GET(PSOFX("SIG",PSODCT))

               KILL PSOUCS

               SET SIG2(PSOBDCT)=$$UPPER(SIG2(PSOBDCT))

               KILL PSOUCS

STUFF     ;

 +1        SET DCOUNT=0

 +2        IF '$DATA(SIG2(1))

               GOTO QUIT

 +3        IF '$ORDER(SIG2(1))

               IF $LENGTH(SIG2(1))<71

                   SET SIG9(1)=SIG2(1)

 +4        SET (VAR,VAR1)=""

           SET II=1

 +5        FOR FF=0:0

               SET FF=$ORDER(SIG2(FF))

               IF 'FF

                   QUIT

               SET CT=0

               FOR NN=1:1:$LENGTH(SIG2(FF))

                   IF $EXTRACT(SIG2(FF),NN)=" "!($LENGTH(SIG2(FF))=NN)

                       SET CT=CT+1

                       Begin DoDot:1

 +6                        SET VAR1=$PIECE(SIG2(FF)," ",(CT))

 +7                        SET LIM=VAR

 +8                        SET VAR=$SELECT(VAR="":VAR1,1:VAR_" "_VAR1)

                       End DoDot:1

                       IF $LENGTH(VAR)>70

                           SET SIG9(II)=LIM_" "

                           SET II=II+1

                           SET VAR=VAR1

 +9        IF $GET(VAR)'=""

               SET SIG9(II)=VAR

QUIT       KILL SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2

           QUIT

SIG1      ;

 +1        FOR FFF=0:0

               SET FFF=$ORDER(SIG0(FFF))

               IF 'FFF

                   QUIT

               SET SIG2(FFF)=SIG0(FFF)

 +2        QUIT

DAYS       IF +$EXTRACT($PIECE(SIG1(TT),"^",2))!($EXTRACT($PIECE(SIG1(TT),"^",2))=0)

               SET $PIECE(SIG1(TT),"^",2)="D"_$PIECE(SIG1(TT),"^",2)

 +1        QUIT

NON       ;

 +1        SET NN=PSOFX("NOUN",SSS)

 +2        SET NOUN=$ORDER(^PS(50.606,SIGDS,"NOUN","B",NN,0))

           IF NOUN

               SET PSNOUN(SSS)=$SELECT($GET(^PS(50.606,SIGDS,"NOUN",NOUN,1))]"":^PS(50.606,SIGDS,"NOUN",NOUN,1),1:NN)

               KILL NN

               QUIT

 +3        KILL NN,NOUN

           DO DOSE^PSSORPH(.XDOSE,$PIECE(^PSRX(RX,0),"^",6),"O")

           IF $PIECE(XDOSE("DD",$PIECE(^PSRX(RX,0),"^",6)),"^",9)=""

               QUIT

 +4        SET NN=$PIECE(XDOSE("DD",$PIECE(^PSRX(RX,0),"^",6)),"^",9)

           SET NOUN=$ORDER(^PS(50.606,SIGDS,"NOUN","B",NN,0))

 +5        IF NOUN

               SET PSNOUN(SSS)=$SELECT($GET(^PS(50.606,SIGDS,"NOUN",NOUN,1))]"":^PS(50.606,SIGDS,"NOUN",NOUN,1),1:NN)

 +6        KILL XDOSE,NN

           QUIT

VERB      ;Check if verb and noun need to be added to SIG

 +1        KILL PSOLCS,PSOUCS,PSOISL,PSOVL

 +2        IF $GET(VERB)'=""

               SET PSOVL=$LENGTH(VERB)

               SET PSOISL=$EXTRACT($GET(SIG0(FFF)),1,$GET(PSOVL))

               IF $GET(PSOISL)'=""

                   Begin DoDot:1

 +3                    SET PSOUCS=VERB

 +4                    SET PSOUCS=$$UPPER(PSOUCS)

                       IF PSOUCS=PSOISL

                           SET PSOSG1=1

                           QUIT

 +5                    SET PSOUCS=$$LOWER(PSOUCS)

                       IF PSOUCS=PSOISL

                           SET PSOSG1=1

                           QUIT

 +6                    SET PSOUCS=$$UPPER($EXTRACT(PSOUCS,1))_$$LOWER($EXTRACT(PSOUCS,2,99))

                       IF PSOUCS=PSOISL

                           SET PSOSG1=1

                           QUIT

                   End DoDot:1

 +7        IF $GET(PSNOUN(FFF))=""

               GOTO VERBEX

 +8        SET PSOISL=$GET(SIG0(FFF))

           IF $GET(PSOISL)=""

               GOTO VERBEX

 +9        SET PSOVL=$FIND(PSNOUN(FFF),"(")

 +10       IF $GET(PSOVL)>2

               SET PSOUCS=$EXTRACT(PSNOUN(FFF),1,(PSOVL-2))

 +11       IF $GET(PSOVL)'>2

               SET PSOUCS=PSNOUN(FFF)

 +12       IF $GET(PSOISL)'=""

               Begin DoDot:1

 +13               SET PSOUCS=$$UPPER(PSOUCS)

                   IF PSOISL[PSOUCS

                       SET PSOSG2=1

                       QUIT

 +14               SET PSOUCS=$$LOWER(PSOUCS)

                   IF PSOISL[PSOUCS

                       SET PSOSG2=1

                       QUIT

 +15               SET PSOUCS=$$UPPER($EXTRACT(PSOUCS,1))_$$LOWER($EXTRACT(PSOUCS,2,99))

                   IF PSOISL[PSOUCS

                       SET PSOSG2=1

               End DoDot:1

VERBEX     KILL PSOLCS,PSOUCS,PSOISL,PSOVL

           QUIT

 +1       ;

UPPER(PSOUCS) ;

 +1        QUIT $TRANSLATE(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

 +2       ;

LOWER(PSOLCS) ;

 +1        QUIT $TRANSLATE(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")

 +2        QUIT

 +3       ;

SSS       ;

 +1        KILL PSOFNL,PSOFNLF,PSOFNLX

 +2        IF $GET(PSNOUN(FFF))=""

               QUIT

 +3        IF $LENGTH(PSNOUN(FFF))'>3

               QUIT

 +4        IF '$GET(PSOFX("DOSE ORDERED",FFF))

               QUIT

 +5        SET PSOFNL=$EXTRACT(PSNOUN(FFF),($LENGTH(PSNOUN(FFF))-2),$LENGTH(PSNOUN(FFF)))

 +6        IF $GET(PSOFNL)="(S)"!($GET(PSOFNL)="(s)")

               Begin DoDot:1

 +7                IF $GET(PSOFX("DOSE ORDERED",FFF))'>1

                       SET PSNOUN(FFF)=$EXTRACT(PSNOUN(FFF),1,($LENGTH(PSNOUN(FFF))-3))

 +8                IF $GET(PSOFX("DOSE ORDERED",FFF))>1

                       SET PSNOUN(FFF)=$EXTRACT(PSNOUN(FFF),1,($LENGTH(PSNOUN(FFF))-3))_$EXTRACT(PSOFNL,2)

               End DoDot:1

 +9        QUIT

FRAC      ;

 +1        KILL PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2

 +2        IF $GET(PSOFX("DOSE ORDERED",FFF))=""

               QUIT

 +3        IF $GET(PSOFX("DOSE ORDERED",FFF))'["."

               SET (PSOFRAC1,PSOFRAC)=$GET(PSOFX("DOSE ORDERED",FFF))

               DO NUM

               Begin DoDot:1

 +4                IF $GET(PSOFRAC1)=$GET(PSOFRAC)

                       KILL PSOFRAC,PSOFRAC1

                       QUIT

 +5                SET PSOFRAC=$GET(PSOFRAC1)

               End DoDot:1

               GOTO FRACQ

 +6        SET PSOFRAC1=$PIECE(PSOFX("DOSE ORDERED",FFF),".")

           SET PSOFRAC2=$PIECE(PSOFX("DOSE ORDERED",FFF),".",2)

 +7        SET PSOFRACX="."_$GET(PSOFRAC2)

 +8        SET PSOFRAC=$SELECT(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:PS

OFRACX)

 +9        SET PSOFRAC9=$ORDER(^PS(59.7,"AOTH",PSOFRAC,""))

           IF PSOFRAC9]""

               SET PSOFRAC=PSOFRAC9

 +10       KILL PSOFRAC9

 +11       IF $GET(PSOFRAC)=""

               KILL PSOFRAC

               GOTO FRACQ

 +12       IF $GET(PSOFRAC1)'=""

               IF +$GET(PSOFRAC1)

                   Begin DoDot:1

 +13                   DO NUM

                       SET AND=$ORDER(^PS(59.7,"AOTH","AND",""))

 +14                   SET PSOFRAC=$GET(PSOFRAC1)_" "_$SELECT(AND]"":AND,1:"AND")_" "_$SELECT($EXTRACT($GET(PSOFRAC),1)=".":"0",1:"")_$GET(PSOFRAC)

                   End DoDot:1

 +15       IF $EXTRACT($GET(PSOFRAC),1)="."

               SET PSOFRAC="0"_$GET(PSOFRAC)

FRACQ      KILL PSOFRAC1,PSOFRAC2,AND

 +1        QUIT

NUM       ;

 +1        IF $GET(PSOFRAC1)=""

               QUIT

 +2        SET PSOFRAC1=$SELECT(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1)

 +3        SET PSOFRAC9=$ORDER(^PS(59.7,"AOTH",PSOFRAC1,""))

           IF PSOFRAC9]""

               SET PSOFRAC1=PSOFRAC9

 +4        KILL PSOFRAC9

 +5        QUIT

PSOSPSIG.m