- PSOFSIG ;BIR/RTR-Parse out and create Pharmacy Sig ;Apr 05, 2022@13:02:06
- ;;7.0;OUTPATIENT PHARMACY;**46,282,441**;DEC 1997;Build 208
- ;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
- 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))
- ;282 Schedule Expander Changed
- F GGG=1:1:TODOSE S SCHED(GGG)=$$SCHE^PSOSIG($G(PSOFX("SCHEDULE",GGG)))
- ;282 End Change
- 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 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("INDF")),$L($G(PSOFX("IND"))) S PSOBDCT=PSOBDCT+1,SIG2(PSOBDCT)=PSOFX("IND") ;*441
- 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
- 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))
- 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)
- 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 $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)=""
- 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)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOFSIG 7706 printed Jan 18, 2025@03:30:38 Page 2
- PSOFSIG ;BIR/RTR-Parse out and create Pharmacy Sig ;Apr 05, 2022@13:02:06
- +1 ;;7.0;OUTPATIENT PHARMACY;**46,282,441**;DEC 1997;Build 208
- +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
- 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 ;282 Schedule Expander Changed
- +21 FOR GGG=1:1:TODOSE
- SET SCHED(GGG)=$$SCHE^PSOSIG($GET(PSOFX("SCHEDULE",GGG)))
- +22 ;282 End Change
- +23 SET (RTC,RTCA,PSOBDCT)=0
- FOR FFF=0:0
- SET FFF=$ORDER(SIG0(FFF))
- if 'FFF
- QUIT
- Begin DoDot:1
- +24 KILL PSOSG1,PSOSG2
- SET VERB=$GET(VERBX(FFF))
- DO VERB
- if $GET(PSNOUN(FFF))'=""&('$GET(PSOSG1))
- DO SSS
- +25 DO FRAC
- +26 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))_" ")
- +27 SET PSOBDCT=PSOBDCT+1
- +28 KILL PSOFRAC,PSOFRACX
- +29 IF RTC>0
- IF $GET(PSOROUTE(FFF))'=""
- IF '$GET(RTCF)
- SET RTCA=1
- +30 IF $GET(PSOROUTE(FFF))'=""
- SET RTC=RTC+1
- +31 SET SIG2(FFF)=SIG2(FFF)_$SELECT($GET(PSNOUN(FFF))'=""&('$GET(PSOSG2)):$GET(PSNOUN(FFF))_" ",1:"")_$SELECT(PREP'=""&($GET(MEDEXP(FFF)))&('RTCA):PREP_" ",1:"")
- +32 SET SIG2(FFF)=SIG2(FFF)_$SELECT(PSOROUTE(FFF)'=""&('RTCA):PSOROUTE(FFF)_" ",1:"")
- +33 SET SIG2(FFF)=SIG2(FFF)_$SELECT(SCHED(FFF)'="":SCHED(FFF)_$SELECT($GET(PSDUR(FFF))="NULL"&($GET(PSOFX("CONJUNCTION",FFF))="")&('$ORDER(SIG0(FFF))):"",1:" "),1:"")
- +34 SET PSOCJ=$EXTRACT($GET(PSOFX("CONJUNCTION",FFF)))
- +35 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:"")
- +36 KILL PSOSG1,PSOSG2
- +37 KILL PSOUCS
- SET SIG2(FFF)=$$UPPER(SIG2(FFF))
- KILL PSOUCS
- End DoDot:1
- +38 ;*441
- IF $GET(PSOFX("INDF"))
- IF $LENGTH($GET(PSOFX("IND")))
- SET PSOBDCT=PSOBDCT+1
- SET SIG2(PSOBDCT)=PSOFX("IND")
- +39 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
- 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 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:""
- )
- +9 IF $GET(PSOFRAC)=""
- KILL PSOFRAC
- GOTO FRACQ
- +10 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 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 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