PSSGS0 ;BIR/CML3-SCHEDULE PROCESSOR ;06/01/98
;;1.0;PHARMACY DATA MANAGEMENT;**12,27,38,44,56,69,59,143,119**;9/30/97;Build 9
;Reference to $$TRIM^XLFSTR supported by DBIA #10104
;Reference to ^PS(53.1 supported by DBIA #2140
;
ENA ; entry point for train option
;N X S X="PSGSETU" X ^%ZOSF("TEST") I D ENCV^PSGSETU Q:$D(XQUIT)
;F S (PSGS0Y,PSGS0XT)="" R !!,"Select STANDARD SCHEDULE: ",X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D:X?1."?" ENQ^PSSGSH I X'?1."?" D EN W:$D(X)[0 $C(7)," ??" I $D(X)#2,'PSGS0Y,PSGS0XT W " Every ",PSGS0XT," minutes"
;K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q
Q
;
EN3 ;
S PSGST=$P($G(^PS(53.1,DA,0)),"^",7) G EN
;
EN5 ;
S PSGST=$P($G(^PS(55,DA(1),5,DA,0)),"^",7)
;
EN(X,PSSLSTPK) ; validate
;I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>2)!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N")!($E(X,1)=" ") K X Q
I $G(PSSLSTPK)="O"!(PSSLSTPK="X") Q:$G(X)="" G ENOP
;*119 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) K X Q
S X=$$TRIM^XLFSTR(X,"R"," ")
I X?.E1L.E S X=$$ENLU^PSSGMI(X)
;
ENOS ; order set entry
S (PSGS0XT,PSGS0Y,XT,Y)=""
I X="OTHER" G Q
I X["PRN",$$PRNOK(X) G Q
I X["@" D DW S:$D(X) Y=$P(X,"@",2) G Q
S X0=X I X,X'["X",(X?2.4N1"-".E!(X?2.4N)) D ENCHK S:$D(X) Y=X G Q
I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I XT]"" G Q
I $G(PSGSCH)=X S PSGS0Y=$G(PSGAT) Q
K X Q
;
NS I (X="^")!(X="") K X Q
I Y'>0 S X=X0,Y=""
Q ;
S PSGS0XT=$S(XT]"":XT,1:""),PSGS0Y=$S(Y:Y,1:"") K QX,SDW,SWD,X0,XT,Z Q
;
ENCHK ;Ward times
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
;
ENOP ;
;*119 Allow multi-word schedules
I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>$S(X["PRN":4,1:3))!($L(X)>20)!($L(X)<1) K X Q
N PSSUPPER S X=$$UPPER(X)
K Y,DIC S DIC="^PS(51.1,",DIC(0)="E",D="APPSJ",DIC("W")="D DICW^PSSGS0" D IX^DIC I Y>0 S X=$P(Y,"^",2) Q
K Y,DIC S DIC=51,DIC(0)="ME" D ^DIC I Y>0 S X=$P(Y,"^",2)
Q
;
DIC ;
K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(PSGOES))_"ISZ",DIC("W")="W "" "","_$S('$D(PSJPWD):"$P(^(0),""^"",2)",'PSJPWD:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+PSJPWD,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ"
S DIC("W")=""
I $D(PSGST) S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O"""
D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE Q:Y'>0
S XT=$S("C"[$P(Y(0),"^",5):$P(Y(0),"^",3),1:$P(Y(0),"^",5)),X=+Y,Y="" I $D(PSJPWD),$D(^PS(51.1,X,1,+PSJPWD,0)) S Y=$P(^(0),"^",2)
S (X,X0)=Y(0,0) S:Y="" Y=$P(Y(0),"^",2) 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
;
UPPER(PSSUPPER) ;
Q $TR(PSSUPPER,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
DICW ;
S Z=^PS(51.1,+Y,0) W $P(Z,"^",8) Q
;
PRNOK(PSCH) ;
Q:PSCH'["PRN" 0
I $TR(PSCH," ")="PRN" Q 1
N BASE,I,OK S OK=0 S I=$P(PSCH," PRN") I I]"",$D(^PS(51.1,"AC","PSJ",I)) S OK=1
I 'OK D
.I PSCH["@" I $D(^PS(51.1,"AC","PSJ",$P(PSCH,"@")))!$$DOW^PSIVUTL($P(PSCH,"@")) S OK=1 Q
.I $$DOW^PSIVUTL($TR(PSCH," PRN")) S OK=1
Q OK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSGS0 3705 printed Sep 23, 2025@20:07:20 Page 2
PSSGS0 ;BIR/CML3-SCHEDULE PROCESSOR ;06/01/98
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**12,27,38,44,56,69,59,143,119**;9/30/97;Build 9
+2 ;Reference to $$TRIM^XLFSTR supported by DBIA #10104
+3 ;Reference to ^PS(53.1 supported by DBIA #2140
+4 ;
ENA ; entry point for train option
+1 ;N X S X="PSGSETU" X ^%ZOSF("TEST") I D ENCV^PSGSETU Q:$D(XQUIT)
+2 ;F S (PSGS0Y,PSGS0XT)="" R !!,"Select STANDARD SCHEDULE: ",X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D:X?1."?" ENQ^PSSGSH I X'?1."?" D EN W:$D(X)[0 $C(7)," ??" I $D(X)#2,'PSGS0Y,PSGS0XT W " Every ",PSGS0XT," minutes"
+3 ;K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q
+4 QUIT
+5 ;
EN3 ;
+1 SET PSGST=$PIECE($GET(^PS(53.1,DA,0)),"^",7)
GOTO EN
+2 ;
EN5 ;
+1 SET PSGST=$PIECE($GET(^PS(55,DA(1),5,DA,0)),"^",7)
+2 ;
EN(X,PSSLSTPK) ; validate
+1 ;I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>2)!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N")!($E(X,1)=" ") K X Q
+2 IF $GET(PSSLSTPK)="O"!(PSSLSTPK="X")
if $GET(X)=""
QUIT
GOTO ENOP
+3 ;*119 Allow multi-word schedules
+4 IF X[""""!($ASCII(X)=45)!(X?.E1C.E)!($LENGTH(X," ")>$SELECT(X["PRN":4,1:3))!($LENGTH(X)>70)!($LENGTH(X)<1)
KILL X
QUIT
+5 SET X=$$TRIM^XLFSTR(X,"R"," ")
+6 IF X?.E1L.E
SET X=$$ENLU^PSSGMI(X)
+7 ;
ENOS ; order set entry
+1 SET (PSGS0XT,PSGS0Y,XT,Y)=""
+2 IF X="OTHER"
GOTO Q
+3 IF X["PRN"
IF $$PRNOK(X)
GOTO Q
+4 IF X["@"
DO DW
if $DATA(X)
SET Y=$PIECE(X,"@",2)
GOTO Q
+5 SET X0=X
IF X
IF X'["X"
IF (X?2.4N1"-".E!(X?2.4N))
DO ENCHK
if $DATA(X)
SET Y=X
GOTO Q
+6 IF $SELECT($DATA(^PS(51.1,"AC","PSJ",X)):1,1:$EXTRACT($ORDER(^(X)),1,$LENGTH(X))=X)
DO DIC
IF XT]""
GOTO Q
+7 IF $GET(PSGSCH)=X
SET PSGS0Y=$GET(PSGAT)
QUIT
+8 KILL X
QUIT
+9 ;
NS IF (X="^")!(X="")
KILL X
QUIT
+1 IF Y'>0
SET X=X0
SET Y=""
Q ;
+1 SET PSGS0XT=$SELECT(XT]"":XT,1:"")
SET PSGS0Y=$SELECT(Y:Y,1:"")
KILL QX,SDW,SWD,X0,XT,Z
QUIT
+2 ;
ENCHK ;Ward times
+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)
+6 QUIT
+7 ;
ENOP ;
+1 ;*119 Allow multi-word schedules
+2 IF X[""""!($ASCII(X)=45)!(X?.E1C.E)!($LENGTH(X," ")>$SELECT(X["PRN":4,1:3))!($LENGTH(X)>20)!($LENGTH(X)<1)
KILL X
QUIT
+3 NEW PSSUPPER
SET X=$$UPPER(X)
+4 KILL Y,DIC
SET DIC="^PS(51.1,"
SET DIC(0)="E"
SET D="APPSJ"
SET DIC("W")="D DICW^PSSGS0"
DO IX^DIC
IF Y>0
SET X=$PIECE(Y,"^",2)
QUIT
+5 KILL Y,DIC
SET DIC=51
SET DIC(0)="ME"
DO ^DIC
IF Y>0
SET X=$PIECE(Y,"^",2)
+6 QUIT
+7 ;
DIC ;
+1 KILL DIC
SET DIC="^PS(51.1,"
SET DIC(0)=$EXTRACT("E",'$DATA(PSGOES))_"ISZ"
SET DIC("W")="W "" "","_$SELECT('$DATA(PSJPWD):"$P(^(0),""^"",2)",'PSJPWD:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+PSJPWD,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))")
SET D="APPSJ"
+2 SET DIC("W")=""
+3 IF $DATA(PSGST)
SET DIC("S")="I $P(^(0),""^"",5)"_$EXTRACT("'",PSGST'="O")_"=""O"""
+4 DO IX^DIC
KILL DIC
if $DATA(DIE)#2
SET DIC=DIE
if Y'>0
QUIT
+5 SET XT=$SELECT("C"[$PIECE(Y(0),"^",5):$PIECE(Y(0),"^",3),1:$PIECE(Y(0),"^",5))
SET X=+Y
SET Y=""
IF $DATA(PSJPWD)
IF $DATA(^PS(51.1,X,1,+PSJPWD,0))
SET Y=$PIECE(^(0),"^",2)
+6 SET (X,X0)=Y(0,0)
if Y=""
SET Y=$PIECE(Y(0),"^",2)
QUIT
+7 ;
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
+4 ;
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
+4 ;
UPPER(PSSUPPER) ;
+1 QUIT $TRANSLATE(PSSUPPER,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
DICW ;
+1 SET Z=^PS(51.1,+Y,0)
WRITE $PIECE(Z,"^",8)
QUIT
+2 ;
PRNOK(PSCH) ;
+1 if PSCH'["PRN"
QUIT 0
+2 IF $TRANSLATE(PSCH," ")="PRN"
QUIT 1
+3 NEW BASE,I,OK
SET OK=0
SET I=$PIECE(PSCH," PRN")
IF I]""
IF $DATA(^PS(51.1,"AC","PSJ",I))
SET OK=1
+4 IF 'OK
Begin DoDot:1
+5 IF PSCH["@"
IF $DATA(^PS(51.1,"AC","PSJ",$PIECE(PSCH,"@")))!$$DOW^PSIVUTL($PIECE(PSCH,"@"))
SET OK=1
QUIT
+6 IF $$DOW^PSIVUTL($TRANSLATE(PSCH," PRN"))
SET OK=1
End DoDot:1
+7 QUIT OK
