- PSOHLSIG ;BIR/RTR-Parse out and create possible Sig ; 7/21/96
- ;;7.0;OUTPATIENT PHARMACY;**1,18,41,60,282**;DEC 1997;Build 18
- ;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
- Q:'$D(^PS(52.41,PENDING,1,0))
- N SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW
- S SIGRT=$P(^PS(52.41,PENDING,0),"^",15),SIGDS=$P(^PS(50.7,$P(^(0),"^",8),0),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3)
- F SSS=0:0 S SSS=$O(^PS(52.41,PENDING,1,SSS)) Q:'SSS S SIG0(SSS)=$G(^PS(52.41,PENDING,1,SSS,0)),SIG1(SSS)=$G(^(1)) D NON
- ;I SIG0(1)'["&" D SIG1 G STUFF
- S PSOROUTE=$S($P($G(^PS(51.2,+SIGRT,0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP=$S($P($G(^PS(51.2,+SIGRT,0)),"^",2)="":0,1:1)
- ;282 Schedule Expander Changed
- F GGG=0:0 S GGG=$O(SIG1(GGG)) Q:'GGG S SCHED(GGG)=$$SCHE^PSOSIG($P(SIG1(GGG),"^"))
- ;282 End Change
- F TT=0:0 S TT=$O(SIG1(TT)) Q:'TT D DAYS S PSDUR(TT)=$S($P(SIG1(TT),"^",2)=""!($E($P(SIG1(TT),"^",2))="I"):"NULL",1:"FOR "_$E($P(SIG1(TT),"^",2),2,$L($P(SIG1(TT),"^",2)))) D I PSDUR(TT)'="NULL" S PSDUR(TT)=PSDUR(TT)_" "_INTERVAL
- .I PSDUR(TT)'="NULL" S INTERVAL=$P(SIG1(TT),"^",2),INTERVAL=$S($E(INTERVAL)="D":"DAY(S)",$E(INTERVAL)="W":"WEEK(S)",$E(INTERVAL)="H":"HOUR(S)",$E(INTERVAL)="L":"MONTH(S)",$E(INTERVAL)="M":"MINUTE(S)",$E(INTERVAL)="S":"SECOND(S)",1:"")
- F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF D
- .;I SIG0(FFF)'["&" S SIG2(FFF)=SIG0(FFF) Q
- .;S SIG2(FFF)=VERB_" "_$P($P(SIG0(FFF),"^"),"&")_" "_$G(PSNOUN(FFF))_" "_PREP_" "_PSOROUTE_$S(SCHED(FFF)'="":" "_SCHED(FFF),1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF),1:"")_$S($P(SIG1(FFF),"^",6)="A":" AND",$P(SIG1(FFF),"^",6)="S":" THEN",1:"")
- .K PSOSG1,PSOSG2 D VERB
- .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($P($P(SIG0(FFF),"^"),"&")'="":$P($P(SIG0(FFF),"^"),"&")_" ",1:"")_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP)):PREP_" ",1:"")
- .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE'="":PSOROUTE_" ",1:"")
- .S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($P(SIG1(FFF),"^",6)="A":"AND",$P(SIG1(FFF),"^",6)="S":"THEN",1:"")
- .K PSOSG1,PSOSG2
- STUFF ;
- S DCOUNT=0
- I '$D(SIG2(1)) G QUIT
- 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) G QUIT
- 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 SIG3(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 SIG3(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
- 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
- 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)),"^")'="",$P($G(^(0)),"^",3) 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($P($P(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=$P($P(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")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLSIG 4765 printed Jan 18, 2025@03:31:17 Page 2
- PSOHLSIG ;BIR/RTR-Parse out and create possible Sig ; 7/21/96
- +1 ;;7.0;OUTPATIENT PHARMACY;**1,18,41,60,282**;DEC 1997;Build 18
- +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 if '$DATA(^PS(52.41,PENDING,1,0))
- QUIT
- +8 NEW SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW
- +9 SET SIGRT=$PIECE(^PS(52.41,PENDING,0),"^",15)
- SET SIGDS=$PIECE(^PS(50.7,$PIECE(^(0),"^",8),0),"^",2)
- SET VERB=$PIECE($GET(^PS(50.606,SIGDS,"MISC")),"^")
- SET PREP=$PIECE($GET(^("MISC")),"^",3)
- +10 FOR SSS=0:0
- SET SSS=$ORDER(^PS(52.41,PENDING,1,SSS))
- if 'SSS
- QUIT
- SET SIG0(SSS)=$GET(^PS(52.41,PENDING,1,SSS,0))
- SET SIG1(SSS)=$GET(^(1))
- DO NON
- +11 ;I SIG0(1)'["&" D SIG1 G STUFF
- +12 SET PSOROUTE=$SELECT($PIECE($GET(^PS(51.2,+SIGRT,0)),"^",2)'="":$PIECE(^(0),"^",2),$PIECE($GET(^(0)),"^",3)'="":$PIECE(^(0),"^",3),1:$PIECE($GET(^(0)),"^"))
- SET MEDEXP=$SELECT($PIECE($GET(^PS(51.2,+SIGRT,0)),"^",2)="":0,1:1)
- +13 ;282 Schedule Expander Changed
- +14 FOR GGG=0:0
- SET GGG=$ORDER(SIG1(GGG))
- if 'GGG
- QUIT
- SET SCHED(GGG)=$$SCHE^PSOSIG($PIECE(SIG1(GGG),"^"))
- +15 ;282 End Change
- +16 FOR TT=0:0
- SET TT=$ORDER(SIG1(TT))
- if 'TT
- QUIT
- DO DAYS
- SET PSDUR(TT)=$SELECT($PIECE(SIG1(TT),"^",2)=""!($EXTRACT($PIECE(SIG1(TT),"^",2))="I"):"NULL",1:"FOR "_$EXTRACT($PIECE(SIG1(TT),"^",2),2,$LENGTH($PIECE(SIG1(TT),"^",2))))
- Begin DoDot:1
- +17 IF PSDUR(TT)'="NULL"
- SET INTERVAL=$PIECE(SIG1(TT),"^",2)
- SET INTERVAL=$SELECT($EXTRACT(INTERVAL)="D":"DAY(S)",$EXTRACT(INTERVAL)="W":"WEEK(S)",$EXTRACT(INTERVAL)="H":"HOUR(S)",$EXTRACT(INTERVAL)="L":"MONTH(S)",$EXTRACT(INTERVAL)="M":"MINUTE(S)",$EXTRACT(INTERVAL)="S":"SECOND(S)",1:"")
- End DoDot:1
- IF PSDUR(TT)'="NULL"
- SET PSDUR(TT)=PSDUR(TT)_" "_INTERVAL
- +18 FOR FFF=0:0
- SET FFF=$ORDER(SIG0(FFF))
- if 'FFF
- QUIT
- Begin DoDot:1
- +19 ;I SIG0(FFF)'["&" S SIG2(FFF)=SIG0(FFF) Q
- +20 ;S SIG2(FFF)=VERB_" "_$P($P(SIG0(FFF),"^"),"&")_" "_$G(PSNOUN(FFF))_" "_PREP_" "_PSOROUTE_$S(SCHED(FFF)'="":" "_SCHED(FFF),1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF),1:"")_$S($P(SIG1(FFF),"^",6)="A":" AND",$P(SIG1(FFF),"^",6)="S":" THEN",1:"")
- +21 KILL PSOSG1,PSOSG2
- DO VERB
- +22 SET SIG2(FFF)=$SELECT(VERB'=""&('$GET(PSOSG1)):VERB_" ",1:"")_$SELECT($PIECE($PIECE(SIG0(FFF),"^"),"&")'="":$PIECE(...
- ... $PIECE(SIG0(FFF),"^"),"&")_" ",1:"")_$SELECT($GET(PSNOUN(FFF))'=""&('$GET(PSOSG2)):$GET(PSNOUN(FFF))_" ",1:"")_$SELECT(PREP'=""&($GET(MEDEXP)):PREP_" ",1:"")
- +23 SET SIG2(FFF)=SIG2(FFF)_$SELECT(PSOROUTE'="":PSOROUTE_" ",1:"")
- +24 SET SIG2(FFF)=SIG2(FFF)_$SELECT(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$SELECT(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$SELECT($PIECE(SIG1(FFF),"^",6)="A":"AND",$PIECE(SIG1(FFF),"^",6)="S":"THEN",1:"")
- +25 KILL PSOSG1,PSOSG2
- End DoDot:1
- STUFF ;
- +1 SET DCOUNT=0
- +2 IF '$DATA(SIG2(1))
- GOTO QUIT
- +3 IF '$ORDER(SIG2(1))
- IF $LENGTH(SIG2(1))<71
- SET ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1
- SET ^PS(52.41,PENDING,"SIG",1,0)=SIG2(1)
- GOTO QUIT
- +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 SIG3(II)=LIM_" "
- SET II=II+1
- SET VAR=VAR1
- +9 IF $GET(VAR)'=""
- SET SIG3(II)=VAR
- +10 FOR II=0:0
- SET II=$ORDER(SIG3(II))
- if 'II
- QUIT
- SET DCOUNT=DCOUNT+1
- SET ^PS(52.41,PENDING,"SIG",DCOUNT,0)=SIG3(II)
- +11 IF DCOUNT
- SET ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT
- 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 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)),"^")'=""
- IF $PIECE($GET(^(0)),"^",3)
- SET PSNOUN(SSS)=$PIECE(^(0),"^")
- +3 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($PIECE($PIECE(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=$PIECE($PIECE(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")