- PSOHELP2 ;B'ham ISC/SAB - utility routine #3 ; 3/23/11 8:17am
- ;;7.0;OUTPATIENT PHARMACY;**282**;DEC 1997;Build 18
- EN ; validate
- ;*282 Allow multi-word schedules
- I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>$S(X["PRN":4,1:3))!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N") K X Q
- I X?.E1L.E S X=$$ENLU^PSGMI(X) W " (",X,")"
- ;
- ENOS ; order set entry
- S (PSGS0XT,PSGS0Y,XT,Y)="" I X["PRN"!(X="ON CALL") G Q
- S X0=X I X,X'["X" D ENCHK S:$D(X) Y=X G Q
- I X["@" D DW S:$D(X) Y=$P(X,"@",2) G Q
- I $E(X)="?" S Y="?" D DIC K X Q
- I Y'>0,$S(X="NOW":1,X="ONCE":1,X="STAT":1,X="ONE TIME":1,1:X="ONE-TIME") W:'$D(PSGOES) " (ONCE ONLY)" S Y="",XT="O" G Q
- ;
- NS I Y'>0 W:'$D(PSGOES) " (Nonstandard schedule)" S X=X0,Y=""
- I X="BID"!(X="TID")!(X="QID") S XT=1440/$F("BTQ",$E(X)) G Q
- S:$E(X)="Q" X=$E(X,2,99) S:'X X="1"_X S X1=+X,X=$P(X,+X,2),X2=0 S:X1<0 X1=-X1 S:$E(X)="X" X2=1,X=$E(X,2,99)
- S XT=$S(X["'":1,X["AC"!(X["PC"):480,X["D"!(X["AM")!(X["PM")!(X["HS"):1440,X["H":60,X["W":10080,X["M":40320,1:-1) I XT<0,Y'>0 K X G Q
- S X=X0 I XT S:X2 XT=XT\X1 I 'X2 S:X["O" XT=XT*2 S XT=XT*X1
- ;
- Q ;
- S PSGS0XT=$S(XT]"":XT,1:""),PSGS0Y=$S(Y:Y,1:"") K QX,SDW,SWD,X0,XT,Z Q
- ;
- ENCHK ;
- I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q
- S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q
- S X(1)=$L(X(1)) I X'["-",X>$E(2400,1,X(1)) K X Q
- F X(2)=2:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $S($L(X(3))'=X(1):1,X(3)>$E(2400,1,X(1)):1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q
- K:$D(X) X(1),X(2),X(3) Q
- ;
- DW ;
- S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) D ENCHK Q:'$D(X) S X=$P(SDW,"@"),X(1)="-" I X?.E1P.E,X'["-" F QX=1:1:$L(X) I $E(X,QX)?1P S X(1)=$E(X,QX) Q
- F Q=1:1:$L(X,X(1)) K:SWD="" X Q:SWD="" S Z=$P(X,X(1),Q) D DWC Q:'$D(X)
- K X(1) S:$D(X) X=SDW Q
- DWC I $L(Z)<2 K X Q
- F QX=1:1:$L(SWD,"^") S Y=$P(SWD,"^",QX) I $P(Y,Z)="" S SWD=$P(SWD,Y,2) S:$L(SWD) SWD=$E(SWD,2,50) Q
- E K X
- Q
- DIC ;
- K DIC S DIC="^PS(51.1,",DIC(0)="EISZ",D="APPSJ"
- D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE Q:Y'>0 S X=+Y
- S (X,X0)=Y(0,0) S:Y="" Y=$P(Y(0),"^",2)
- Q
- ENLU(X) ; convert lower case to upper case
- Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- ;
- ENUL(X) ; convert upper case to lower case
- Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHELP2 2333 printed Feb 18, 2025@23:56:04 Page 2
- PSOHELP2 ;B'ham ISC/SAB - utility routine #3 ; 3/23/11 8:17am
- +1 ;;7.0;OUTPATIENT PHARMACY;**282**;DEC 1997;Build 18
- EN ; validate
- +1 ;*282 Allow multi-word schedules
- +2 IF X[""""!($ASCII(X)=45)!(X?.E1C.E)!($LENGTH(X," ")>$SELECT(X["PRN":4,1:3))!($LENGTH(X)>70)!($LENGTH(X)<1)!(X["P RN")!(X["PR N")
- KILL X
- QUIT
- +3 IF X?.E1L.E
- SET X=$$ENLU^PSGMI(X)
- WRITE " (",X,")"
- +4 ;
- ENOS ; order set entry
- +1 SET (PSGS0XT,PSGS0Y,XT,Y)=""
- IF X["PRN"!(X="ON CALL")
- GOTO Q
- +2 SET X0=X
- IF X
- IF X'["X"
- DO ENCHK
- if $DATA(X)
- SET Y=X
- GOTO Q
- +3 IF X["@"
- DO DW
- if $DATA(X)
- SET Y=$PIECE(X,"@",2)
- GOTO Q
- +4 IF $EXTRACT(X)="?"
- SET Y="?"
- DO DIC
- KILL X
- QUIT
- +5 IF Y'>0
- IF $SELECT(X="NOW":1,X="ONCE":1,X="STAT":1,X="ONE TIME":1,1:X="ONE-TIME")
- if '$DATA(PSGOES)
- WRITE " (ONCE ONLY)"
- SET Y=""
- SET XT="O"
- GOTO Q
- +6 ;
- NS IF Y'>0
- if '$DATA(PSGOES)
- WRITE " (Nonstandard schedule)"
- SET X=X0
- SET Y=""
- +1 IF X="BID"!(X="TID")!(X="QID")
- SET XT=1440/$FIND("BTQ",$EXTRACT(X))
- GOTO Q
- +2 if $EXTRACT(X)="Q"
- SET X=$EXTRACT(X,2,99)
- if 'X
- SET X="1"_X
- SET X1=+X
- SET X=$PIECE(X,+X,2)
- SET X2=0
- if X1<0
- SET X1=-X1
- if $EXTRACT(X)="X"
- SET X2=1
- SET X=$EXTRACT(X,2,99)
- +3 SET XT=$SELECT(X["'":1,X["AC"!(X["PC"):480,X["D"!(X["AM")!(X["PM")!(X["HS"):1440,X["H":60,X["W":10080,X["M":40320,1:-1)
- IF XT<0
- IF Y'>0
- KILL X
- GOTO Q
- +4 SET X=X0
- IF XT
- if X2
- SET XT=XT\X1
- IF 'X2
- if X["O"
- SET XT=XT*2
- SET XT=XT*X1
- +5 ;
- Q ;
- +1 SET PSGS0XT=$SELECT(XT]"":XT,1:"")
- SET PSGS0Y=$SELECT(Y:Y,1:"")
- KILL QX,SDW,SWD,X0,XT,Z
- QUIT
- +2 ;
- ENCHK ;
- +1 IF $SELECT($LENGTH($PIECE(X,"-"))>4:1,$LENGTH(X)>119:1,$LENGTH(X)<2:1,X'>0:1,1:X'?.ANP)
- KILL X
- QUIT
- +2 SET X(1)=$PIECE(X,"-")
- IF X(1)'?2N
- IF X(1)'?4N
- KILL X
- QUIT
- +3 SET X(1)=$LENGTH(X(1))
- IF X'["-"
- IF X>$EXTRACT(2400,1,X(1))
- KILL X
- QUIT
- +4 FOR X(2)=2:1:$LENGTH(X,"-")
- SET X(3)=$PIECE(X,"-",X(2))
- IF $SELECT($LENGTH(X(3))'=X(1):1,X(3)>$EXTRACT(2400,1,X(1)):1,1:X(3)'>$PIECE(X,"-",X(2)-1))
- KILL X
- QUIT
- +5 if $DATA(X)
- KILL X(1),X(2),X(3)
- QUIT
- +6 ;
- DW ;
- +1 SET SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS"
- SET SDW=X
- SET X=$PIECE(X,"@",2)
- DO ENCHK
- if '$DATA(X)
- QUIT
- SET X=$PIECE(SDW,"@")
- SET X(1)="-"
- IF X?.E1P.E
- IF X'["-"
- FOR QX=1:1:$LENGTH(X)
- IF $EXTRACT(X,QX)?1P
- SET X(1)=$EXTRACT(X,QX)
- QUIT
- +2 FOR Q=1:1:$LENGTH(X,X(1))
- if SWD=""
- KILL X
- if SWD=""
- QUIT
- SET Z=$PIECE(X,X(1),Q)
- DO DWC
- if '$DATA(X)
- QUIT
- +3 KILL X(1)
- if $DATA(X)
- SET X=SDW
- QUIT
- DWC IF $LENGTH(Z)<2
- KILL X
- QUIT
- +1 FOR QX=1:1:$LENGTH(SWD,"^")
- SET Y=$PIECE(SWD,"^",QX)
- IF $PIECE(Y,Z)=""
- SET SWD=$PIECE(SWD,Y,2)
- if $LENGTH(SWD)
- SET SWD=$EXTRACT(SWD,2,50)
- QUIT
- +2 IF '$TEST
- KILL X
- +3 QUIT
- DIC ;
- +1 KILL DIC
- SET DIC="^PS(51.1,"
- SET DIC(0)="EISZ"
- SET D="APPSJ"
- +2 DO IX^DIC
- KILL DIC
- if $DATA(DIE)#2
- SET DIC=DIE
- if Y'>0
- QUIT
- SET X=+Y
- +3 SET (X,X0)=Y(0,0)
- if Y=""
- SET Y=$PIECE(Y(0),"^",2)
- +4 QUIT
- ENLU(X) ; convert lower case to upper case
- +1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +2 ;
- ENUL(X) ; convert upper case to lower case
- +1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
