PSOFSIG ;BIR/RTR-Parse out and create Pharmacy Sig ;25-Sep-2006 10:55;DU
;;7.0;OUTPATIENT PHARMACY;**46,1005**;DEC 1997
;External reference to File #50.7 supported by DBIA 2223
;External reference to File #51 supported by DBIA 2224
;External reference to File #51.1 supported by DBIA 2225
;External reference to File #51.2 supported by DBIA 2226
;External reference to File #50.606 supported by DBIA 2174
;
;Modified - IHS/MSC/PLS - 09/25/06 - Line FRAC+8 - Added numerical fractional value to SIG
; NUM+2 - Added numerical value to SIG
EN(PSOFX,PSOPTSIG) ;
N LIM,VAR,VAR1
N SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJ
N VERBX,SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2,RTC,RTCA,RTCF,RTCNT,PSODCT,PSOBDCT
K SIG
S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW S TODOSE=WW
Q:'TODOSE
S SIGDS=+$P($G(^PS(50.7,+$G(PSODRUG("OI")),0)),"^",2),PREP=$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)))
.S VERBX(SSS)=$S($G(PSOFX("VERB",SSS))'="":$G(PSOFX("VERB",SSS)),1:"")
.S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS))
.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)),"^",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 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
...I $G(INTERVAL)'="",$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)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1
.Q:$G(SGLFLAG)
.I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q
.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)) 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 SCHHOLD(GGGZ)=$P(^(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)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",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 SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJ)="A":"AND",$G(PSOCJ)="T":"THEN",$G(PSOCJ)="S":"THEN",$G(PSOCJ)="X":"EXCEPT",1:"")
.K PSOSG1,PSOSG2
.K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS
;I $G(PSOFX("SIG"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("SIG")) K PSOUCS S SIG2(TODOSE)=$$UPPER(SIG2(TODOSE)) 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 SIG(1)=SIG2(1) G PTSIG
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 SIG(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 SIG(II)=VAR
;F II=0:0 S II=$O(SIG3(II)) Q:'II S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,"SIG",DCOUNT,0)=SIG3(II)
;I DCOUNT S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT
PTSIG ;
I '$G(PSOPTSIG) G QUIT
I $O(SIG(0)) W ! S WWFL=0 F WW=0:0 S WW=$O(SIG(WW)) Q:'WW D
.W ! I 'WWFL W "("
.W $G(SIG(WW)) S WWFL=1
I $O(SIG(0)) W ")",!
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)
Q
DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2)
Q
NON ;
I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q
Q
F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="") I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^")
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")
Q
;
SSS ;
K PSOFNL,PSOFNLF,PSOFNLX
Q:$G(PSNOUN(FFF))=""
Q:$L(PSNOUN(FFF))'>3
Q:'$G(PSOFX("DOSE ORDERED",FFF))
;Q:$G(PSOFX("DOSE ORDERED",FFF))>1
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)
Q
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)
; IHS/MSC/PLS -- 09/25/06 - Line length required change to If/Then statement to include numerical fraction in SIG
;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:"")
I PSOFRACX=".5" S PSOFRAC="ONE-HALF (1/2)"
E I PSOFRACX=".25" S PSOFRAC="ONE-FOURTH (1/4)"
E I PSOFRACX=".33" S PSOFRAC="ONE-THIRD (1/3)"
E I PSOFRACX=".34" S PSOFRAC="ONE-THIRD (1/3)"
E I PSOFRACX=".50" S PSOFRAC="ONE-HALF (1/2)"
E I PSOFRACX=".66" S PSOFRAC="TWO-THIRDS (2/3)"
E I PSOFRACX=".67" S PSOFRAC="TWO-THIRDS (2/3)"
E I PSOFRACX=".75" S PSOFRAC="THREE-FOURTHS (3/4)"
E S PSOFRAC=""
I $G(PSOFRAC)="" K PSOFRAC G FRACQ
I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC)
FRACQ K PSOFRAC1,PSOFRAC2
Q
NUM ;
Q:$G(PSOFRAC1)=""
;IHS/MCS/PLS - 09/25/06 - Line length required change to If/Then statement to include numerical value in SIG
;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)
I PSOFRAC1="1" S PSOFRAC1="ONE (1)"
E I PSOFRAC1="2" S PSOFRAC1="TWO (2)"
E I PSOFRAC1="3" S PSOFRAC1="THREE (3)"
E I PSOFRAC1="4" S PSOFRAC1="FOUR (4)"
E I PSOFRAC1="5" S PSOFRAC1="FIVE (5)"
E I PSOFRAC1="6" S PSOFRAC1="SIX (6)"
E I PSOFRAC1="7" S PSOFRAC1="SEVEN (7)"
E I PSOFRAC1="8" S PSOFRAC1="EIGHT (8)"
E I PSOFRAC1="9" S PSOFRAC1="NINE (9)"
E I PSOFRAC1="10" S PSOFRAC1="TEN (10)"
Q
SET ;Set duration to proper format for storage
Q
KILL ;kills duration data field
Q
DUR ;Input Transform for duration
K:X'?.N&(X'?.N1".".N)&(X'?.N1"D")&(X'?.N1".".N1"D")&(X'?.N1"M")&(X'?.N1".".N1"M")&(X'?.N1"H")&(X'?.N1".".N1"H")&(X'?.N1"W")&(X'?.N1".".N1"W")&(X'?.N1"L")&(X'?.N1".".N1"L") X
K:'$G(X) X
Q
PSOFSIG ;BIR/RTR-Parse out and create Pharmacy Sig ;25-Sep-2006 10:55;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**46,1005**;DEC 1997
+2 ;External reference to File #50.7 supported by DBIA 2223
+3 ;External reference to File #51 supported by DBIA 2224
+4 ;External reference to File #51.1 supported by DBIA 2225
+5 ;External reference to File #51.2 supported by DBIA 2226
+6 ;External reference to File #50.606 supported by DBIA 2174
+7 ;
+8 ;Modified - IHS/MSC/PLS - 09/25/06 - Line FRAC+8 - Added numerical fractional value to SIG
+9 ; NUM+2 - Added numerical value to SIG
EN(PSOFX,PSOPTSIG) ;
+1 NEW LIM,VAR,VAR1
+2 NEW SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJ
+3 NEW VERBX,SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2,RTC,RTCA,RTCF,RTCNT,PSODCT,PSOBDCT
+4 KILL SIG
+5 SET TODOSE=0
FOR WW=0:0
SET WW=$ORDER(PSOFX("DOSE",WW))
IF 'WW
QUIT
SET TODOSE=WW
+6 IF 'TODOSE
QUIT
+7 SET SIGDS=+$PIECE($GET(^PS(50.7,+$GET(PSODRUG("OI")),0)),"^",2)
SET PREP=$PIECE($GET(^PS(50.606,SIGDS,"MISC")),"^",3)
+8 SET RTCNT=0
KILL RTC,RTCA,RTCF
FOR SSS=1:1:TODOSE
Begin DoDot:1
+9 SET SIG0(SSS)=$SELECT($GET(PSOFX("DOSE ORDERED",SSS))'="":$GET(PSOFX("DOSE ORDERED",SSS)),1:$GET(PSOFX("DOSE",SSS)))
+10 SET VERBX(SSS)=$SELECT($GET(PSOFX("VERB",SSS))'="":$GET(PSOFX("VERB",SSS)),1:"")
+11 SET PSNOUN(SSS)=$GET(PSOFX("NOUN",SSS))
+12 SET RTC=+$GET(PSOFX("ROUTE",SSS))
IF RTC
IF 'RTCNT
SET RTCA=RTC
SET RTCNT=RTCNT+1
+13 IF RTCNT>1
IF $GET(RTC)
IF $GET(RTC)'=$GET(RTCA)
SET RTCF=1
+14 SET PSOROUTE(SSS)=$SELECT($PIECE($GET(^PS(51.2,+$GET(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$PIECE(^(0),"^",2),$PIECE($GET(^(0)),"^",3)'="":$PIECE(^(0),"^",3),1:$PIECE($GET(^(0)),"^"))
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 PSDUR(SSS)=$SELECT($GET(PDAYS(SSS))="":"NULL",1:"FOR "_$EXTRACT($GET(PDAYS(SSS)),1,($LENGTH($GET(PDAYS(SSS)))-1)))
Begin DoDot:2
+18 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
+19 IF $GET(INTERVAL)'=""
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
+20 FOR GGG=1:1:TODOSE
SET ZSCHED(GGG)=$GET(PSOFX("SCHEDULE",GGG))
Begin DoDot:1
+21 IF $GET(ZSCHED(GGG))=""
SET SCHED(GGG)=""
QUIT
+22 SET SGLFLAG=0
FOR WW=0:0
SET WW=$ORDER(^PS(51.1,"B",ZSCHED(GGG),WW))
IF 'WW!($GET(SGLFLAG))
QUIT
IF $PIECE($GET(^PS(51.1,WW,0)),"^",8)'=""
SET SCHED(GGG)=$PIECE($GET(^(0)),"^",8)
SET SGLFLAG=1
+23 IF $GET(SGLFLAG)
QUIT
+24 IF $GET(^PS(51,"A",ZSCHED(GGG)))'=""
SET SCHED(GGG)=$PIECE(^(ZSCHED(GGG)),"^")
QUIT
+25 SET ZZSB=0
FOR ZZS=1:1:$LENGTH(ZSCHED(GGG))
SET SZZ=$EXTRACT(ZSCHED(GGG),ZZS)
IF SZZ=" "
SET ZZSB=ZZSB+1
+26 SET ZZSB=ZZSB+1
+27 KILL SCHHOLD
FOR GGGZ=1:1:ZZSB
SET (SDL,SCHHOLD(GGGZ))=$PIECE(ZSCHED(GGG)," ",GGGZ)
Begin DoDot:2
+28 IF $GET(SDL)=""
QUIT
+29 SET SGLFLAG=0
FOR WW=0:0
SET WW=$ORDER(^PS(51.1,"B",SDL,WW))
IF 'WW!($GET(SGLFLAG))
QUIT
IF $PIECE($GET(^PS(51.1,WW,0)),"^",8)'=""
SET SCHHOLD(GGGZ)=$PIECE($GET(^(0)),"^",8)
SET SGLFLAG=1
+30 IF $GET(SGLFLAG)
QUIT
+31 IF $GET(^PS(51,"A",SDL))'=""
SET SCHHOLD(GGGZ)=$PIECE(^(SDL),"^")
End DoDot:2
+32 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
+33 SET (RTC,RTCA,PSOBDCT)=0
FOR FFF=0:0
SET FFF=$ORDER(SIG0(FFF))
IF 'FFF
QUIT
Begin DoDot:1
+34 KILL PSOSG1,PSOSG2
SET VERB=$GET(VERBX(FFF))
DO VERB
IF $GET(PSNOUN(FFF))'=""&('$GET(PSOSG1))
DO SSS
+35 DO FRAC
+36 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))_" ")
+37 SET PSOBDCT=PSOBDCT+1
+38 KILL PSOFRAC,PSOFRACX
+39 IF RTC>0
IF $GET(PSOROUTE(FFF))'=""
IF '$GET(RTCF)
SET RTCA=1
+40 IF $GET(PSOROUTE(FFF))'=""
SET RTC=RTC+1
+41 SET SIG2(FFF)=SIG2(FFF)_$SELECT($GET(PSNOUN(FFF))'=""&('$GET(PSOSG2)):$GET(PSNOUN(FFF))_" ",1:"")_$SELECT(PREP'=""&($GET(MEDEXP(FFF)))&('RTCA):PREP_" ",1:"")
+42 SET SIG2(FFF)=SIG2(FFF)_$SELECT(PSOROUTE(FFF)'=""&('RTCA):PSOROUTE(FFF)_" ",1:"")
+43 ;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"")
+44 SET SIG2(FFF)=SIG2(FFF)_$SELECT(SCHED(FFF)'="":SCHED(FFF)_$SELECT($GET(PSDUR(FFF))="NULL"&($GET(PSOFX("CONJUNCTION",FFF))="")&('$ORDER(SIG0(FFF))):"",1:" "),1:"")
+45 SET PSOCJ=$EXTRACT($GET(PSOFX("CONJUNCTION",FFF)))
+46 SET SIG2(FFF)=SIG2(FFF)_$SELECT(PSDUR(FFF)'="NULL":PSDUR(FFF)_$SELECT($GET(PSOFX("CONJUNCTION",FFF))=""&('$ORDER(SIG0(FFF))):"",1:", "),1:"")_$SELECT($GET(PSOCJ)="A":"AND",$GET(PSOCJ)="T":"THEN",$GET(PSOCJ)="S":"THEN",$GET(PSOCJ)="X":"E
XCEPT",1:"")
+47 KILL PSOSG1,PSOSG2
+48 KILL PSOUCS
SET SIG2(FFF)=$$UPPER(SIG2(FFF))
KILL PSOUCS
End DoDot:1
+49 ;I $G(PSOFX("SIG"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("SIG")) K PSOUCS S SIG2(TODOSE)=$$UPPER(SIG2(TODOSE)) K PSOUCS
+50 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 SIG(1)=SIG2(1)
GOTO PTSIG
+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 SIG(II)=LIM_" "
SET II=II+1
SET VAR=VAR1
+9 IF $GET(VAR)'=""
SET SIG(II)=VAR
+10 ;F II=0:0 S II=$O(SIG3(II)) Q:'II S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,"SIG",DCOUNT,0)=SIG3(II)
+11 ;I DCOUNT S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT
PTSIG ;
+1 IF '$GET(PSOPTSIG)
GOTO QUIT
+2 IF $ORDER(SIG(0))
WRITE !
SET WWFL=0
FOR WW=0:0
SET WW=$ORDER(SIG(WW))
IF 'WW
QUIT
Begin DoDot:1
+3 WRITE !
IF 'WWFL
WRITE "("
+4 WRITE $GET(SIG(WW))
SET WWFL=1
End DoDot:1
+5 IF $ORDER(SIG(0))
WRITE ")",!
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 IF $PIECE($GET(SIG0(SSS)),"&",2)'=""
SET PSNOUN(SSS)=$PIECE($GET(SIG0(SSS)),"&",2)
QUIT
+2 QUIT
+3 FOR NOUN=0:0
SET NOUN=$ORDER(^PS(50.606,SIGDS,"NOUN",NOUN))
IF 'NOUN!($GET(PSNOUN(SSS))'="")
QUIT
IF $PIECE($GET(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'=""
SET PSNOUN(SSS)=$PIECE(^(0),"^")
+4 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 ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1
+6 SET PSOFNL=$EXTRACT(PSNOUN(FFF),($LENGTH(PSNOUN(FFF))-2),$LENGTH(PSNOUN(FFF)))
+7 IF $GET(PSOFNL)="(S)"!($GET(PSOFNL)="(s)")
Begin DoDot:1
+8 IF $GET(PSOFX("DOSE ORDERED",FFF))'>1
SET PSNOUN(FFF)=$EXTRACT(PSNOUN(FFF),1,($LENGTH(PSNOUN(FFF))-3))
+9 IF $GET(PSOFX("DOSE ORDERED",FFF))>1
SET PSNOUN(FFF)=$EXTRACT(PSNOUN(FFF),1,($LENGTH(PSNOUN(FFF))-3))_$EXTRACT(PSOFNL,2)
End DoDot:1
+10 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 ; IHS/MSC/PLS -- 09/25/06 - Line length required change to If/Then statement to include numerical fraction in SIG
+9 ;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:"")
+10 IF PSOFRACX=".5"
SET PSOFRAC="ONE-HALF (1/2)"
+11 IF '$TEST
IF PSOFRACX=".25"
SET PSOFRAC="ONE-FOURTH (1/4)"
+12 IF '$TEST
IF PSOFRACX=".33"
SET PSOFRAC="ONE-THIRD (1/3)"
+13 IF '$TEST
IF PSOFRACX=".34"
SET PSOFRAC="ONE-THIRD (1/3)"
+14 IF '$TEST
IF PSOFRACX=".50"
SET PSOFRAC="ONE-HALF (1/2)"
+15 IF '$TEST
IF PSOFRACX=".66"
SET PSOFRAC="TWO-THIRDS (2/3)"
+16 IF '$TEST
IF PSOFRACX=".67"
SET PSOFRAC="TWO-THIRDS (2/3)"
+17 IF '$TEST
IF PSOFRACX=".75"
SET PSOFRAC="THREE-FOURTHS (3/4)"
+18 IF '$TEST
SET PSOFRAC=""
+19 IF $GET(PSOFRAC)=""
KILL PSOFRAC
GOTO FRACQ
+20 IF $GET(PSOFRAC1)'=""
IF +$GET(PSOFRAC1)
DO NUM
SET PSOFRAC=$GET(PSOFRAC1)_" AND "_$GET(PSOFRAC)
FRACQ KILL PSOFRAC1,PSOFRAC2
+1 QUIT
NUM ;
+1 IF $GET(PSOFRAC1)=""
QUIT
+2 ;IHS/MCS/PLS - 09/25/06 - Line length required change to If/Then statement to include numerical value in SIG
+3 ;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)
+4 IF PSOFRAC1="1"
SET PSOFRAC1="ONE (1)"
+5 IF '$TEST
IF PSOFRAC1="2"
SET PSOFRAC1="TWO (2)"
+6 IF '$TEST
IF PSOFRAC1="3"
SET PSOFRAC1="THREE (3)"
+7 IF '$TEST
IF PSOFRAC1="4"
SET PSOFRAC1="FOUR (4)"
+8 IF '$TEST
IF PSOFRAC1="5"
SET PSOFRAC1="FIVE (5)"
+9 IF '$TEST
IF PSOFRAC1="6"
SET PSOFRAC1="SIX (6)"
+10 IF '$TEST
IF PSOFRAC1="7"
SET PSOFRAC1="SEVEN (7)"
+11 IF '$TEST
IF PSOFRAC1="8"
SET PSOFRAC1="EIGHT (8)"
+12 IF '$TEST
IF PSOFRAC1="9"
SET PSOFRAC1="NINE (9)"
+13 IF '$TEST
IF PSOFRAC1="10"
SET PSOFRAC1="TEN (10)"
+14 QUIT
SET ;Set duration to proper format for storage
+1 QUIT
KILL ;kills duration data field
+1 QUIT
DUR ;Input Transform for duration
+1 IF X'?.N&(X'?.N1".".N)&(X'?.N1"D")&(X'?.N1".".N1"D")&(X'?.N1"M")&(X'?.N1".".N1"M")&(X'?.N1"H")&(X'?.N1".".N1"H")&(X'?.N1"W")&(X'?.N1".".N1"W")&(X'?.N1"L")&(X'?.N1".".N1"L")
KILL X
+2 IF '$GET(X)
KILL X
+3 QUIT
