Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOFSIG

PSOFSIG.m

Go to the documentation of this file.
  1. 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
  1. ;External reference to File #50.7 supported by DBIA 2223
  1. ;External reference to File #51 supported by DBIA 2224
  1. ;External reference to File #51.1 supported by DBIA 2225
  1. ;External reference to File #51.2 supported by DBIA 2226
  1. ;External reference to File #50.606 supported by DBIA 2174
  1. EN(PSOFX,PSOPTSIG) ;
  1. N LIM,VAR,VAR1
  1. 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
  1. N VERBX,SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2,RTC,RTCA,RTCF,RTCNT,PSODCT,PSOBDCT
  1. K SIG
  1. S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW S TODOSE=WW
  1. Q:'TODOSE
  1. S SIGDS=+$P($G(^PS(50.7,+$G(PSODRUG("OI")),0)),"^",2),PREP=$P($G(^PS(50.606,SIGDS,"MISC")),"^",3)
  1. S RTCNT=0 K RTC,RTCA,RTCF F SSS=1:1:TODOSE D
  1. .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS)))
  1. .S VERBX(SSS)=$S($G(PSOFX("VERB",SSS))'="":$G(PSOFX("VERB",SSS)),1:"")
  1. .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS))
  1. .S RTC=+$G(PSOFX("ROUTE",SSS)) I RTC S:'RTCNT RTCA=RTC S RTCNT=RTCNT+1
  1. .I RTCNT>1,$G(RTC),$G(RTC)'=$G(RTCA) S RTCF=1
  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)
  1. .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS))
  1. .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D"
  1. .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
  1. ..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
  1. ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1))
  1. ;282 Schedule Expander Changed
  1. F GGG=1:1:TODOSE S SCHED(GGG)=$$SCHE^PSOSIG($G(PSOFX("SCHEDULE",GGG)))
  1. ;282 End Change
  1. S (RTC,RTCA,PSOBDCT)=0 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF D
  1. .K PSOSG1,PSOSG2 S VERB=$G(VERBX(FFF)) D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS
  1. .D FRAC
  1. .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))_" ")
  1. .S PSOBDCT=PSOBDCT+1
  1. .K PSOFRAC,PSOFRACX
  1. .I RTC>0,$G(PSOROUTE(FFF))'="",'$G(RTCF) S RTCA=1
  1. .I $G(PSOROUTE(FFF))'="" S RTC=RTC+1
  1. .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF)))&('RTCA):PREP_" ",1:"")
  1. .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'=""&('RTCA):PSOROUTE(FFF)_" ",1:"")
  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:"")
  1. .S PSOCJ=$E($G(PSOFX("CONJUNCTION",FFF)))
  1. .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:"")
  1. .K PSOSG1,PSOSG2
  1. .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS
  1. I $G(PSOFX("INDF")),$L($G(PSOFX("IND"))) S PSOBDCT=PSOBDCT+1,SIG2(PSOBDCT)=PSOFX("IND") ;*441
  1. 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
  1. STUFF ;
  1. S DCOUNT=0
  1. I '$D(SIG2(1)) G QUIT
  1. I '$O(SIG2(1)),$L(SIG2(1))<71 S SIG(1)=SIG2(1) G PTSIG
  1. S (VAR,VAR1)="",II=1
  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
  1. .S VAR1=$P(SIG2(FF)," ",(CT))
  1. .S LIM=VAR
  1. .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1)
  1. I $G(VAR)'="" S SIG(II)=VAR
  1. PTSIG ;
  1. I '$G(PSOPTSIG) G QUIT
  1. I $O(SIG(0)) W ! S WWFL=0 F WW=0:0 S WW=$O(SIG(WW)) Q:'WW D
  1. .W ! I 'WWFL W "("
  1. .W $G(SIG(WW)) S WWFL=1
  1. I $O(SIG(0)) W ")",!
  1. QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q
  1. SIG1 ;
  1. F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF S SIG2(FFF)=SIG0(FFF)
  1. Q
  1. DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2)
  1. Q
  1. NON ;
  1. I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q
  1. Q
  1. 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),"^")
  1. Q
  1. VERB ;Check if verb and noun need to be added to SIG
  1. K PSOLCS,PSOUCS,PSOISL,PSOVL
  1. I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D
  1. .S PSOUCS=VERB
  1. .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
  1. .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
  1. .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q
  1. I $G(PSNOUN(FFF))="" G VERBEX
  1. S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX
  1. S PSOVL=$F(PSNOUN(FFF),"(")
  1. I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2))
  1. I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF)
  1. I $G(PSOISL)'="" D
  1. .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
  1. .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
  1. .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1
  1. VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q
  1. ;
  1. UPPER(PSOUCS) ;
  1. Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. ;
  1. LOWER(PSOLCS) ;
  1. Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
  1. Q
  1. ;
  1. SSS ;
  1. K PSOFNL,PSOFNLF,PSOFNLX
  1. Q:$G(PSNOUN(FFF))=""
  1. Q:$L(PSNOUN(FFF))'>3
  1. Q:'$G(PSOFX("DOSE ORDERED",FFF))
  1. S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF)))
  1. I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D
  1. .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))
  1. .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2)
  1. Q
  1. FRAC ;
  1. K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2
  1. I $G(PSOFX("DOSE ORDERED",FFF))="" Q
  1. I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D G FRACQ
  1. .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q
  1. .S PSOFRAC=$G(PSOFRAC1)
  1. S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2)
  1. S PSOFRACX="."_$G(PSOFRAC2)
  1. 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:"")
  1. I $G(PSOFRAC)="" K PSOFRAC G FRACQ
  1. I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC)
  1. FRACQ K PSOFRAC1,PSOFRAC2
  1. Q
  1. NUM ;
  1. Q:$G(PSOFRAC1)=""
  1. 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)
  1. Q
  1. SET ;Set duration to proper format for storage
  1. Q
  1. KILL ;kills duration data field
  1. Q
  1. DUR ;Input Transform for duration
  1. 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
  1. K:'$G(X) X
  1. Q