- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPIS.m
r613 r623 1 PSOHLPIS 2 ;;7.0;OUTPATIENT PHARMACY;**46,225**;DEC 1997;Build 29 3 4 5 6 7 8 EN 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 STUFF 64 65 66 I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC(SIG2(1)) S DCOUNT=1 G QUITIN67 68 69 70 71 72 73 F II=0:0 S II=$O(SIG(II)) Q:'II S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,"SIG",DCOUNT,0)=$$UNESC^ORHLESC(SIG(II))74 75 QUITIN 76 77 QUIT 78 SIG1 79 80 81 DAYS 82 83 NON 84 85 86 87 88 VERB 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 VERBEX 105 106 UPPER(PSOUCS) 107 108 109 LOWER(PSOLCS) 110 111 112 113 SSS 114 115 116 117 118 119 120 121 122 123 124 FRAC 125 126 127 128 129 130 131 132 133 134 135 FRACQ 136 137 NUM 138 139 140 1 PSOHLPIS ;BIR/RTR-Parse out and create CPRS Sig ;7/21/96 2 ;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997 3 ;External reference to File #50.7 supported by DBIA 2223 4 ;External reference to File #51 supported by DBIA 2224 5 ;External reference to File #51.1 supported by DBIA 2225 6 ;External reference to File #51.2 supported by DBIA 2226 7 ;External reference to File #50.606 supported by DBIA 2174 8 EN ; 9 Q:'$D(^PS(52.41,PENDING,1,0)) 10 N PISI,PSOFX,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,PSOCJS,PSOFDCT,PSODCT 11 N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2,FTC,FTCA,FTCF,FTCNT 12 N SIG 13 F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI D:$D(^(PISI,0)) 14 .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2) 15 .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6) 16 .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI)) 17 .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI)) 18 S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW S TODOSE=WW 19 Q:'TODOSE 20 S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3) 21 S FTCNT=0 K FTC,FTCA,FTCF F SSS=1:1:TODOSE D 22 .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS))) 23 .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS)) 24 .S FTC=+$G(PSOFX("ROUTE",SSS)) I FTC S:'FTCNT FTCA=FTC S FTCNT=FTCNT+1 25 .I FTCNT>1,$G(FTC),$G(FTC)'=$G(FTCA) S FTCF=1 26 .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) 27 .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS)) 28 .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D" 29 .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 30 ..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 31 ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1)) 32 F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG)) D 33 .I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q 34 .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 35 .Q:$G(SGLFLAG) 36 .I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q 37 .S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1 38 .S ZZSB=ZZSB+1 39 .K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D 40 ..Q:$G(SDL)="" 41 ..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 42 ..Q:$G(SGLFLAG) 43 ..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^") 44 .S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1 45 S (FTC,FTCA,PSOFDCT)=0 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF D 46 .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS 47 .D FRAC 48 .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ") 49 .S PSOFDCT=PSOFDCT+1 50 .K PSOFRAC,PSOFRACX 51 .I FTC>0,$G(PSOROUTE(FFF))'="",'$G(FTCF) S FTCA=1 52 .I $G(PSOROUTE(FFF))'="" S FTC=FTC+1 53 .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF)))&('FTCA):PREP_" ",1:"") 54 .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'=""&('FTCA):PSOROUTE(FFF)_" ",1:"") 55 .;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:"") 56 .S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"") 57 .S PSOCJS=$G(PSOFX("CONJUNCTION",FFF)) 58 .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJS)="A":"AND",$G(PSOCJS)="T":"THEN",$G(PSOCJS)="S":"THEN",$G(PSOCJS)="X":"EXCEPT",1:"") 59 .K PSOSG1,PSOSG2 60 .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS 61 ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS")) 62 S PSODCT="" F S PSODCT=$O(^PS(52.41,PENDING,"INS1",PSODCT)) Q:PSODCT="" I $D(^(PSODCT,0)) S PSOFDCT=PSOFDCT+1 S SIG2(PSOFDCT)=$G(^(0)) K PSOUCS S SIG2(PSOFDCT)=$$UPPER(SIG2(PSOFDCT)) K PSOUCS 63 STUFF ; 64 S DCOUNT=0 65 I '$D(SIG2(1)) G QUIT 66 I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=SIG2(1) S DCOUNT=1 G QUITIN 67 S (VAR,VAR1)="",II=1 68 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 69 .S VAR1=$P(SIG2(FF)," ",(CT)) 70 .S LIM=VAR 71 .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1) 72 I $G(VAR)'="" S SIG(II)=VAR 73 F II=0:0 S II=$O(SIG(II)) Q:'II S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,"SIG",DCOUNT,0)=SIG(II) 74 I DCOUNT S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT 75 QUITIN ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="",DCOUNT S DCOUNT=DCOUNT+1,^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT,^PS(52.41,PENDING,"SIG",DCOUNT,0)=$P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^") 76 ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^")=$P(^PS(50.7,+$G(PSORDITE),"INS"),"^") 77 QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q 78 SIG1 ; 79 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF S SIG2(FFF)=SIG0(FFF) 80 Q 81 DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2) 82 Q 83 NON ; 84 I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q 85 Q 86 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),"^") 87 Q 88 VERB ;Check if verb and noun need to be added to SIG 89 K PSOLCS,PSOUCS,PSOISL,PSOVL 90 I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D 91 .S PSOUCS=VERB 92 .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q 93 .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q 94 .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q 95 I $G(PSNOUN(FFF))="" G VERBEX 96 S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX 97 S PSOVL=$F(PSNOUN(FFF),"(") 98 I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2)) 99 I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF) 100 I $G(PSOISL)'="" D 101 .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q 102 .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q 103 .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1 104 VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q 105 ; 106 UPPER(PSOUCS) ; 107 Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 108 ; 109 LOWER(PSOLCS) ; 110 Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 111 Q 112 ; 113 SSS ; 114 K PSOFNL,PSOFNLF,PSOFNLX 115 Q:$G(PSNOUN(FFF))="" 116 Q:$L(PSNOUN(FFF))'>3 117 Q:'$G(PSOFX("DOSE ORDERED",FFF)) 118 ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1 119 S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF))) 120 I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D 121 .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3)) 122 .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2) 123 Q 124 FRAC ; 125 K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2 126 I $G(PSOFX("DOSE ORDERED",FFF))="" Q 127 I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D G FRACQ 128 .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q 129 .S PSOFRAC=$G(PSOFRAC1) 130 S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2) 131 S PSOFRACX="."_$G(PSOFRAC2) 132 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:"") 133 I $G(PSOFRAC)="" K PSOFRAC G FRACQ 134 I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC) 135 FRACQ K PSOFRAC1,PSOFRAC2 136 Q 137 NUM ; 138 Q:$G(PSOFRAC1)="" 139 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) 140 Q
Note:
See TracChangeset
for help on using the changeset viewer.
