- PSGORS0 ;BIR/CML3-SCHEDULE PROCESSOR FOR FINISH ;29 Jan 99 / 8:07 AM
- ;;5.0; INPATIENT MEDICATIONS ;**25,50,83,116,111**;16 DEC 97
- ;
- ; Reference to ^PS(51.1 is supported by DBIA 2177
- ; Reference to ^PS(55 is supported by DBIA 2191
- ;
- ENA ; entry point for train option
- 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^PSGSH 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
- ;
- 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 ; validate
- ;/I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>2)!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N") K X Q
- I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>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) ; I '$D(PSGOES) W " (",X,")"
- I X["Q0" K X Q
- ;
- ENOS ; order set entry
- D ENOS^PSGS0 Q
- ;
- S (PSGS0XT,PSGS0Y,XT,Y)="" I X["PRN"!(X="ON CALL")!(X="ONCALL")!(X="ON-CALL") 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 X["@" D DW S:$D(X) Y=$P(X,"@",2) 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 Y'>0,$S(X="NOW":1,X="ONCE":1,X="STAT":1,X="ONE TIME":1,X="ONETIME":1,X="1TIME":1,X="1 TIME":1,X="1-TIME":1,1:X="ONE-TIME") W:'$D(PSGOES) " (ONCE ONLY)" S Y="",XT="O" G Q
- ;CHANGED LINE BELOW TO FIX THE NON-STANDARD SCHEDULES - RSB 2-10-97
- ;THE FREQUENCY VARIABLE "PSGS0XT" WAS NOT GETTING SET
- ;I $G(PSGSCH)=X S PSGS0Y=$G(PSGAT) Q
- S PSGS0Y=$G(PSGAT)
- ;
- NS ;I Y'>0 W:'$D(PSGOES) " (Nonstandard schedule)" S X=X0,Y=""
- ;I Y'>0 S X=X0,Y="",PSJNSS=1
- ;I $E(X,1,2)="AD" K X G Q
- ;I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="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["D"&(X'["AD"))!(X["AM")!(X["PM")!(X["HS"&(X'["THS")):1440,X["H"&(X'["TH"):60,X["AC"!(X["PC"):480,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["QO" XT=XT*2 S XT=XT*X1
- ;
- Q ;
- S PSGS0XT=$S(XT]"":XT,1:""),PSGS0Y=$S(Y:Y,1:"")
- I $G(PSJNSS),$G(PSGS0XT)>0,($G(VALMBCK)'="Q") D
- . I $G(PSGOES),$G(PSGS0XT)>0,($G(VALMBCK)'="Q"),'$G(NSFF) D NSSCONT^PSGS0(X,PSGS0XT) Q
- K QX,SDW,SWD,X0,XT,Z,NSFF 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
- ;
- DIC ;
- S Y="" F TEST=0:0 S TEST=$O(^PS(51.1,"APPSJ",X,TEST)) Q:'TEST!(Y]"") D
- .I $G(PSGST)="O",$P($G(^PS(51.1,TEST,0)),U,5)'="O" Q
- .S:$D(^PS(51.1,TEST,0)) Y=TEST
- Q:Y="" K DIC S X="`"_Y,DIC="^PS(51.1,",DIC(0)="XISZ",D="APPSJ"
- 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
- PSGORS0 ;BIR/CML3-SCHEDULE PROCESSOR FOR FINISH ;29 Jan 99 / 8:07 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**25,50,83,116,111**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(51.1 is supported by DBIA 2177
- +4 ; Reference to ^PS(55 is supported by DBIA 2191
- +5 ;
- ENA ; entry point for train option
- +1 DO ENCV^PSGSETU
- IF $DATA(XQUIT)
- QUIT
- +2 ;W " Every ",PSGS0XT," minutes"
- FOR
- SET (PSGS0Y,PSGS0XT)=""
- READ !!,"Select STANDARD SCHEDULE: ",X:DTIME
- IF '$TEST
- WRITE $CHAR(7)
- IF '$TEST
- SET X="^"
- IF "^"[X
- QUIT
- IF X?1."?"
- DO ENQ^PSGSH
- IF X'?1."?"
- DO EN
- IF $DATA(X)[0
- WRITE $CHAR(7)," ??"
- IF $DATA(X)#2
- IF 'PSGS0Y
- IF PSGS0XT
- +3 KILL DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT
- QUIT
- +4 ;
- 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 ; 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") K X Q
- +2 IF X[""""!($ASCII(X)=45)!(X?.E1C.E)!($LENGTH(X," ")>3)!($LENGTH(X)>70)!($LENGTH(X)<1)!(X["P RN")!(X["PR N")
- KILL X
- QUIT
- +3 ; I '$D(PSGOES) W " (",X,")"
- IF X?.E1L.E
- SET X=$$ENLU^PSGMI(X)
- +4 IF X["Q0"
- KILL X
- QUIT
- +5 ;
- ENOS ; order set entry
- +1 DO ENOS^PSGS0
- QUIT
- +2 ;
- +3 SET (PSGS0XT,PSGS0Y,XT,Y)=""
- IF X["PRN"!(X="ON CALL")!(X="ONCALL")!(X="ON-CALL")
- GOTO Q
- +4 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
- +5 IF X["@"
- DO DW
- IF $DATA(X)
- SET Y=$PIECE(X,"@",2)
- 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 Y'>0
- IF $SELECT(X="NOW":1,X="ONCE":1,X="STAT":1,X="ONE TIME":1,X="ONETIME":1,X="1TIME":1,X="1 TIME":1,X="1-TIME":1,1:X="ONE-TIME")
- IF '$DATA(PSGOES)
- WRITE " (ONCE ONLY)"
- SET Y=""
- SET XT="O"
- GOTO Q
- +8 ;CHANGED LINE BELOW TO FIX THE NON-STANDARD SCHEDULES - RSB 2-10-97
- +9 ;THE FREQUENCY VARIABLE "PSGS0XT" WAS NOT GETTING SET
- +10 ;I $G(PSGSCH)=X S PSGS0Y=$G(PSGAT) Q
- +11 SET PSGS0Y=$GET(PSGAT)
- +12 ;
- NS ;I Y'>0 W:'$D(PSGOES) " (Nonstandard schedule)" S X=X0,Y=""
- +1 ;I Y'>0 S X=X0,Y="",PSJNSS=1
- +2 ;I $E(X,1,2)="AD" K X G Q
- +3 ;I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="QID") S XT=1440/$F("BTQ",$E(X)) G Q
- +4 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)
- +5 ;S XT=$S(X["'":1,(X["D"&(X'["AD"))!(X["AM")!(X["PM")!(X["HS"&(X'["THS")):1440,X["H"&(X'["TH"):60,X["AC"!(X["PC"):480,X["W":10080,X["M":40320,1:-1) I XT<0,Y'>0 K X G Q
- +6 SET X=X0
- IF XT
- IF X2
- SET XT=XT\X1
- IF 'X2
- IF X["QO"
- SET XT=XT*2
- SET XT=XT*X1
- +7 ;
- Q ;
- +1 SET PSGS0XT=$SELECT(XT]"":XT,1:"")
- SET PSGS0Y=$SELECT(Y:Y,1:"")
- +2 IF $GET(PSJNSS)
- IF $GET(PSGS0XT)>0
- IF ($GET(VALMBCK)'="Q")
- Begin DoDot:1
- +3 IF $GET(PSGOES)
- IF $GET(PSGS0XT)>0
- IF ($GET(VALMBCK)'="Q")
- IF '$GET(NSFF)
- DO NSSCONT^PSGS0(X,PSGS0XT)
- QUIT
- End DoDot:1
- +4 KILL QX,SDW,SWD,X0,XT,Z,NSFF
- QUIT
- +5 ;
- 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 ;
- DIC ;
- +1 SET Y=""
- FOR TEST=0:0
- SET TEST=$ORDER(^PS(51.1,"APPSJ",X,TEST))
- IF 'TEST!(Y]"")
- QUIT
- Begin DoDot:1
- +2 IF $GET(PSGST)="O"
- IF $PIECE($GET(^PS(51.1,TEST,0)),U,5)'="O"
- QUIT
- +3 IF $DATA(^PS(51.1,TEST,0))
- SET Y=TEST
- End DoDot:1
- +4 IF Y=""
- QUIT
- KILL DIC
- SET X="`"_Y
- SET DIC="^PS(51.1,"
- SET DIC(0)="XISZ"
- SET D="APPSJ"
- +5 DO IX^DIC
- KILL DIC
- IF $DATA(DIE)#2
- SET DIC=DIE
- IF Y'>0
- QUIT
- +6 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)
- +7 SET (X,X0)=Y(0,0)
- IF Y=""
- SET Y=$PIECE(Y(0),"^",2)
- QUIT
- 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
