PSGS0 ;BIR/CML3-SCHEDULE PROCESSOR ; 6/22/09 7:12am
;;5.0; INPATIENT MEDICATIONS ;**12,25,26,50,63,74,83,116,110,111,133,138,174,134,213,207,190**;16 DEC 97;Build 12
;
; 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
K PSGS0Y
I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X)>70)!($L(X)<1) K X Q
S X=$$TRIM^XLFSTR(X,"R"," ")
I X?.E1L.E S X=$$ENLU^PSGMI(X) I '$D(PSGOES) D EN^DDIOL(" ("_X_")")
;
ENOS ; order set entry
N X0,Y0,PSJXI,PSJDIC2,TMPAT
I $G(X)="",$G(P(2)),$G(P(3)) S X=$G(P(9))
I $G(X)="" Q
S PSGXT=$G(PSGS0XT),(PSGS0XT,PSGS0Y,XT,Y,PSJNSS)=""
S X0=X I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q
; * GUI 27 CHANGES * Check for admin times to be derived from 'base' schedule
I X["@" S TMPAT=$P(X,"@",2) I TMPAT]"" D
.I '$D(^PS(51.1,"AC","PSJ",TMPAT)) K TMPAT Q
.I '$$DOW^PSIVUTL($P(X,"@")) K TMPAT Q
.N LYN,ZZND,PSGS0XT,PSGS0Y,X S (PSGS0Y,PSGS0XT,X)=""
.S X=TMPAT D DIC I $G(Y0)>0 S TMPAT=Y0
I $G(TMPAT) S (PSGS0Y,$P(X,"@",2))=TMPAT,PSGS0XT="D"
; * GUI 27 CHANGES *
I X["PRN",$$PRNOK(X),'$D(^PS(51.1,"AC","PSJ",X)) D G Q
.;PSJ*5*190 Check for One-time PRN
.I $$ONE^PSJBCMA(DFN,$G(ON),X)="O" S XT="O" Q
.I X["@"!$$DOW^PSIVUTL($P(X," PRN")) N DOW D I $G(DOW) S (Y0,Y,PSGS0Y)=$P($P(X,"@",2)," ")
..N TMP S TMP=X N X S X=$P(TMP," PRN") D DW I $G(X)]"" S DOW=1
..I $G(DOW),$G(PSGST)]"" I ",P,R,"'[(","_PSGST_",") S (XT,PSGS0XT)="D"
D DIC I $G(XT)]""!$G(Y0)!($G(X)]""&$G(PSJXI)) D I $G(X)]"",PSGS0XT'="D" G:$D(^PS(51.1,"AC","PSJ",X)) Q3 I $P(X,"@")]"" G:$D(^PS(51.1,"AC","PSJ",$P(X,"@"))) Q3
.S PSGS0XT=XT S:$G(Y0) (Y,PSGS0Y)=Y0 S:'PSGS0Y&((PSGS0XT)="D")&(X["@") PSGS0Y=$P(X,"@",2)
.S PSGS0Y=$P(PSGS0Y," ")
N TMPSCHX S TMPSCHX=X I $L(X,"@")<3 S TMPX=X D DW I $G(X)]"" K PSJNSS S (PSGS0XT,XT)="D" D G Q
.S Y=$S(($G(TMPSCHX)["@"):$P(TMPSCHX,"@",2),1:"")
.I Y,(X'["@"),(TMPSCHX["@") S X=TMPSCHX
S X=TMPSCHX
I X'="" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS G Q
;
NS I ($G(X)="^")!($G(X)="") K X S Y="" Q
N NS S NS=0,PSJNSS=0
I $G(Y)'>0 S X=X0,Y="",NS=1,PSJNSS=1
Q ;
S PSGS0XT=$S(XT]"":XT,1:$G(PSGS0XT)),PSGS0Y=$S($G(Y):Y,$G(PSGS0Y):PSGS0Y,1:"") S:PSGS0XT<0 PSGS0XT=""
I ('$G(PSGS0Y)&'$G(PSJDIC2)&$G(PSGAT))&'$G(PSJNEWOE)&$G(PSGS0XT) I PSGS0XT<1441 I ($L($G(PSGAT),"-")=PSGS0XT/1440)!($G(X)]""&($G(PSGSCH)=$G(X))) S PSGS0Y=$G(PSGAT)
Q2 K YY
I '$G(PSJNSS),'$G(PSGS0Y),$G(YY) S PSGS0Y=YY
I $G(X)]"",$$SCHREQ^PSJLIVFD(.P) D
.I $$DOW^PSIVUTL(X)!$$PRNOK(X)!$D(^PS(51.1,"AC","PSJ",X)) S PSJNSS=0 Q
.I $G(P(2))&$G(P(3)) D NSSCONT(X,PSGS0XT) S TMPX="" K X
I ($G(PSJNSS)&($G(VALMBCK)'="Q"))!($G(PSJNSS)&$G(PSJLIFNI))!($G(PSJNSS)&$G(PSJTUD)) D
.I $G(P(2))&$G(P(3)) Q
.I ($G(X)]"") I ($G(PSGS0XT)'="D") D NSSCONT(X,PSGS0XT) S TMPX="" K X
Q3 I $G(X)]"" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS
K QX,SDW,SWD,X0,XT,Z Q
;
NSSCONT(SCH,FREQ) ;
Q:SCH=""!($G(VALMBCK)]"")!$G(PSGMARSD)!$G(PSIVFN1)
I $G(PSGOES),'$G(NSFF) Q
N PSGS0XT,PSGSCH,DIR,X,Y S PSGSCH=SCH,PSGS0XT=FREQ,PSJNSS=1
D NSSMSG I ($L(PSJNSS)>2),'$G(PSJXI) W !!,PSJNSS,! S PSJNSS=1
S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR
K NSFF Q
;
NSSMSG ;
Q:$G(PSJXI)
I '(",O,"[(","_$G(PSGST)_",")),$G(PSJNSS),$G(PSGSCH)]"" D
.S PSJNSS=" WARNING - "_PSGSCH_" is an invalid schedule."
S PSGSCH="",PSGS0XT=""
Q
;
NSO(FQ) ;
Q:'FQ!(FQ<0)!(",D,O,"[(","_$G(PSGST)_",")) ""
K FRQOUT S FRQOUT=$S(FQ<60:(FQ_"minute"),(FQ<1440)&(FQ#60):(FQ_" minute"),(FQ<1440)!(FQ#1440):(FQ/60_" hour"),1:(FQ/1440_" day")) D
. S:(+FRQOUT'=1) FRQOUT=FRQOUT_"s"
Q FRQOUT
;
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))!($E(X,3,4)>59))) 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,$E(X(3),3,4)>59:1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q
K:$D(X) X(1),X(2),X(3) Q
;
DIC ; Check for schedule's existence in ADMINISTRATION SCHEDULE file (#51.1)
; Input:
; X = Schedule Name
; PSJSLUP = If $G(PSJSLUP), perform interactive fileman lookup (optional).
; PSGSFLG = If $G(PSGSFLG), return schedule IEN in PSGSCIEN variable (optional)
; PSJLIFNI = Flag indicating a U/D order is being finished as an IV (optional).
; PSGOES = If PSGOES=1, IX^DIC is called silently. If PSGOES=2, IX^DIC is not called (optional).
; PSJPWD = IEN of Inpatient Ward associated with the patient/order/schedule combination (optional).
; Output:
; X = Schedule Name if valid Input Schedule X, undefined if invalid Input Schedule X.
; PSGS0XT = Frequency of validated schedule.
; PSGS0Y = Default Admin Times of validated schedule.
; PSGSCIEN = IEN of validated schedule, if PSGSLFG is passed in and is evaluated to TRUE.
;
;
K Y0,PSJXI N Y,PSGS0ST
S Z=0 F PSJXI=0:1 S Z=$O(^PS(51.1,"AC","PSJ",X,Z)) Q:'Z
I $G(X)]"",'$G(PSJSLUP) D
.I $D(^PS(51.1,"AC","PSJ",X)) D Q:$G(PSGS0Y)&($G(PSGS0XT)]"")
..I $$DOW^PSIVUTL(X) S PSGS0XT="D",PSJNSS=0 S:X["@" (Y0,PSGS0Y)=$P(X,"@",2) Q
..I $G(NSFF) S Y0=$S($G(PSGS0Y):PSGS0Y,$G(PSGAT)&'$G(PSJNEWOE):PSGAT,1:"") S:Y0 PSGS0Y=Y0
.; Check for duplicate schedules - force selection
.Q:PSJXI>1&('$G(PSGOES))&($G(PSGS0XT)]"")
.I $D(^PS(51.1,"AC","PSJ",X)) N FREQ,ADMATCH S FREQ=$G(PSGS0XT) D
..N PSGS0XT,PSGS0Y,PSGST D ADMIN^PSJORPOE S:$G(PSGS0XT) XT=PSGS0XT S:$G(PSGS0Y) (Y0,Y)=PSGS0Y I $G(PSGST)'="" S PSGS0ST=PSGST
..;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
.S:$G(XT)]"" PSGS0XT=XT S:$G(Y) PSGS0Y=Y
.I $$DOW^PSIVUTL(X) S:PSGS0XT="" (XT,PSGS0XT)="D" S:PSGS0Y="" (Y0,PSGS0Y)=$S($P(X,"@",2):$P(X,"@",2),1:"")
I $G(PSJLIFNI)!($G(P(4))]""&($G(P(2))]"")) I '$D(^PS(51.1,"AC","PSJ",X))!($G(PSJXI)>1) S PSJSLUP=1
I $G(NSFF),$G(PSJXI)>1 D
.I $G(PSGS0XT)="",$G(NSFF),$G(PSGXT)]"" S PSGS0XT=PSGXT Q
.I $G(PSGS0XT)=""!($G(PSGS0Y)="") S PSJSLUP=1
I '$G(PSJSLUP) Q:$G(PSGS0XT)]""&($G(PSGS0Y)]"") Q:($G(PSGS0XT)="D"&('$D(^PS(51.1,"AC","PSJ",X))))
Q:$G(PSGOES)=2
Q:$G(PSGS0XT)]""&(PSJXI=1)
I $G(PSGS0ST)="O",PSJXI=1 Q ;one-time order,exact match (PSJ*5*207)
K PSJSLUP
;
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 PSJDIC2=1
D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D Q
.I '$$DOW^PSIVUTL(X),'$$PRNOK(X) S X="",PSJNSS=1,XT="",PSJXI=""
S XT=$S("C"[$P(Y(0),"^",5):$P(Y(0),"^",3),1:$P(Y(0),"^",5))
S X=+Y,Y="" I $D(PSJPWD),$D(^PS(51.1,+X,1,+PSJPWD,0)) S Y=$P(^(0),"^",2)
;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
I $G(PSGSFLG) S PSGSCIEN=X
S (X,X0)=Y(0,0) S:$G(Y)="" Y=$P(Y(0),"^",2)
S (PSGS0Y,Y0)=$G(Y),Y0(0)=Y(0) I $P(Y(0),"^",3) S XT=$P(Y(0),"^",3)
I $G(PSGS0XT)="",$$DOW^PSIVUTL(X) S (XT,PSGS0XT)="D"
Q
;
DW ;
N Y
Q:($L(X,"@")>2)
N AT I X["@" S AT=$P(X,"@",2)
S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB=""
I X]"" 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)
I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-"
K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1)
I $G(AT) S PSGS0Y=AT
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
;
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($P(PSCH," PRN")) S OK=1
Q OK
ODD(PSF) ;determine if this is an odd schedule
I PSF>1439,PSF#1440 Q 1
I PSF,PSF<1440,1440#PSF Q 1
Q 0
PSGS0 ;BIR/CML3-SCHEDULE PROCESSOR ; 6/22/09 7:12am
+1 ;;5.0; INPATIENT MEDICATIONS ;**12,25,26,50,63,74,83,116,110,111,133,138,174,134,213,207,190**;16 DEC 97;Build 12
+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 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
WRITE " Every ",PSGS0XT," minutes"
+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 KILL PSGS0Y
+2 IF X[""""!($ASCII(X)=45)!(X?.E1C.E)!($LENGTH(X)>70)!($LENGTH(X)<1)
KILL X
QUIT
+3 SET X=$$TRIM^XLFSTR(X,"R"," ")
+4 IF X?.E1L.E
SET X=$$ENLU^PSGMI(X)
IF '$DATA(PSGOES)
DO EN^DDIOL(" ("_X_")")
+5 ;
ENOS ; order set entry
+1 NEW X0,Y0,PSJXI,PSJDIC2,TMPAT
+2 IF $GET(X)=""
IF $GET(P(2))
IF $GET(P(3))
SET X=$GET(P(9))
+3 IF $GET(X)=""
QUIT
+4 SET PSGXT=$GET(PSGS0XT)
SET (PSGS0XT,PSGS0Y,XT,Y,PSJNSS)=""
+5 SET X0=X
IF X?2.4N1"-".E!(X?2.4N)
DO ENCHK
IF $DATA(X)
SET Y=X
GOTO Q
+6 ; * GUI 27 CHANGES * Check for admin times to be derived from 'base' schedule
+7 IF X["@"
SET TMPAT=$PIECE(X,"@",2)
IF TMPAT]""
Begin DoDot:1
+8 IF '$DATA(^PS(51.1,"AC","PSJ",TMPAT))
KILL TMPAT
QUIT
+9 IF '$$DOW^PSIVUTL($PIECE(X,"@"))
KILL TMPAT
QUIT
+10 NEW LYN,ZZND,PSGS0XT,PSGS0Y,X
SET (PSGS0Y,PSGS0XT,X)=""
+11 SET X=TMPAT
DO DIC
IF $GET(Y0)>0
SET TMPAT=Y0
End DoDot:1
+12 IF $GET(TMPAT)
SET (PSGS0Y,$PIECE(X,"@",2))=TMPAT
SET PSGS0XT="D"
+13 ; * GUI 27 CHANGES *
+14 IF X["PRN"
IF $$PRNOK(X)
IF '$DATA(^PS(51.1,"AC","PSJ",X))
Begin DoDot:1
+15 ;PSJ*5*190 Check for One-time PRN
+16 IF $$ONE^PSJBCMA(DFN,$GET(ON),X)="O"
SET XT="O"
QUIT
+17 IF X["@"!$$DOW^PSIVUTL($PIECE(X," PRN"))
NEW DOW
Begin DoDot:2
+18 NEW TMP
SET TMP=X
NEW X
SET X=$PIECE(TMP," PRN")
DO DW
IF $GET(X)]""
SET DOW=1
+19 IF $GET(DOW)
IF $GET(PSGST)]""
IF ",P,R,"'[(","_PSGST_",")
SET (XT,PSGS0XT)="D"
End DoDot:2
IF $GET(DOW)
SET (Y0,Y,PSGS0Y)=$PIECE($PIECE(X,"@",2)," ")
End DoDot:1
GOTO Q
+20 DO DIC
IF $GET(XT)]""!$GET(Y0)!($GET(X)]""&$GET(PSJXI))
Begin DoDot:1
+21 SET PSGS0XT=XT
IF $GET(Y0)
SET (Y,PSGS0Y)=Y0
IF 'PSGS0Y&((PSGS0XT)="D")&(X["@")
SET PSGS0Y=$PIECE(X,"@",2)
+22 SET PSGS0Y=$PIECE(PSGS0Y," ")
End DoDot:1
IF $GET(X)]""
IF PSGS0XT'="D"
IF $DATA(^PS(51.1,"AC","PSJ",X))
GOTO Q3
IF $PIECE(X,"@")]""
IF $DATA(^PS(51.1,"AC","PSJ",$PIECE(X,"@")))
GOTO Q3
+23 NEW TMPSCHX
SET TMPSCHX=X
IF $LENGTH(X,"@")<3
SET TMPX=X
DO DW
IF $GET(X)]""
KILL PSJNSS
SET (PSGS0XT,XT)="D"
Begin DoDot:1
+24 SET Y=$SELECT(($GET(TMPSCHX)["@"):$PIECE(TMPSCHX,"@",2),1:"")
+25 IF Y
IF (X'["@")
IF (TMPSCHX["@")
SET X=TMPSCHX
End DoDot:1
GOTO Q
+26 SET X=TMPSCHX
+27 IF X'=""
IF $DATA(^PS(51.1,"AC","PSJ",X))
KILL PSJNSS
GOTO Q
+28 ;
NS IF ($GET(X)="^")!($GET(X)="")
KILL X
SET Y=""
QUIT
+1 NEW NS
SET NS=0
SET PSJNSS=0
+2 IF $GET(Y)'>0
SET X=X0
SET Y=""
SET NS=1
SET PSJNSS=1
Q ;
+1 SET PSGS0XT=$SELECT(XT]"":XT,1:$GET(PSGS0XT))
SET PSGS0Y=$SELECT($GET(Y):Y,$GET(PSGS0Y):PSGS0Y,1:"")
IF PSGS0XT<0
SET PSGS0XT=""
+2 IF ('$GET(PSGS0Y)&'$GET(PSJDIC2)&$GET(PSGAT))&'$GET(PSJNEWOE)&$GET(PSGS0XT)
IF PSGS0XT<1441
IF ($LENGTH($GET(PSGAT),"-")=PSGS0XT/1440)!($GET(X)]""&($GET(PSGSCH)=$GET(X)))
SET PSGS0Y=$GET(PSGAT)
Q2 KILL YY
+1 IF '$GET(PSJNSS)
IF '$GET(PSGS0Y)
IF $GET(YY)
SET PSGS0Y=YY
+2 IF $GET(X)]""
IF $$SCHREQ^PSJLIVFD(.P)
Begin DoDot:1
+3 IF $$DOW^PSIVUTL(X)!$$PRNOK(X)!$DATA(^PS(51.1,"AC","PSJ",X))
SET PSJNSS=0
QUIT
+4 IF $GET(P(2))&$GET(P(3))
DO NSSCONT(X,PSGS0XT)
SET TMPX=""
KILL X
End DoDot:1
+5 IF ($GET(PSJNSS)&($GET(VALMBCK)'="Q"))!($GET(PSJNSS)&$GET(PSJLIFNI))!($GET(PSJNSS)&$GET(PSJTUD))
Begin DoDot:1
+6 IF $GET(P(2))&$GET(P(3))
QUIT
+7 IF ($GET(X)]"")
IF ($GET(PSGS0XT)'="D")
DO NSSCONT(X,PSGS0XT)
SET TMPX=""
KILL X
End DoDot:1
Q3 IF $GET(X)]""
IF $DATA(^PS(51.1,"AC","PSJ",X))
KILL PSJNSS
+1 KILL QX,SDW,SWD,X0,XT,Z
QUIT
+2 ;
NSSCONT(SCH,FREQ) ;
+1 IF SCH=""!($GET(VALMBCK)]"")!$GET(PSGMARSD)!$GET(PSIVFN1)
QUIT
+2 IF $GET(PSGOES)
IF '$GET(NSFF)
QUIT
+3 NEW PSGS0XT,PSGSCH,DIR,X,Y
SET PSGSCH=SCH
SET PSGS0XT=FREQ
SET PSJNSS=1
+4 DO NSSMSG
IF ($LENGTH(PSJNSS)>2)
IF '$GET(PSJXI)
WRITE !!,PSJNSS,!
SET PSJNSS=1
+5 SET DIR(0)="EA"
SET DIR("A")="Press Return to continue..."
DO ^DIR
+6 KILL NSFF
QUIT
+7 ;
NSSMSG ;
+1 IF $GET(PSJXI)
QUIT
+2 IF '(",O,"[(","_$GET(PSGST)_","))
IF $GET(PSJNSS)
IF $GET(PSGSCH)]""
Begin DoDot:1
+3 SET PSJNSS=" WARNING - "_PSGSCH_" is an invalid schedule."
End DoDot:1
+4 SET PSGSCH=""
SET PSGS0XT=""
+5 QUIT
+6 ;
NSO(FQ) ;
+1 IF 'FQ!(FQ<0)!(",D,O,"[(","_$GET(PSGST)_","))
QUIT ""
+2 KILL FRQOUT
SET FRQOUT=$SELECT(FQ<60:(FQ_"minute"),(FQ<1440)&(FQ#60):(FQ_" minute"),(FQ<1440)!(FQ#1440):(FQ/60_" hour"),1:(FQ/1440_" day"))
Begin DoDot:1
+3 IF (+FRQOUT'=1)
SET FRQOUT=FRQOUT_"s"
End DoDot:1
+4 QUIT FRQOUT
+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'["-"&((X>$EXTRACT(2400,1,X(1))!($EXTRACT(X,3,4)>59)))
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,$EXTRACT(X(3),3,4)>59: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 ; Check for schedule's existence in ADMINISTRATION SCHEDULE file (#51.1)
+1 ; Input:
+2 ; X = Schedule Name
+3 ; PSJSLUP = If $G(PSJSLUP), perform interactive fileman lookup (optional).
+4 ; PSGSFLG = If $G(PSGSFLG), return schedule IEN in PSGSCIEN variable (optional)
+5 ; PSJLIFNI = Flag indicating a U/D order is being finished as an IV (optional).
+6 ; PSGOES = If PSGOES=1, IX^DIC is called silently. If PSGOES=2, IX^DIC is not called (optional).
+7 ; PSJPWD = IEN of Inpatient Ward associated with the patient/order/schedule combination (optional).
+8 ; Output:
+9 ; X = Schedule Name if valid Input Schedule X, undefined if invalid Input Schedule X.
+10 ; PSGS0XT = Frequency of validated schedule.
+11 ; PSGS0Y = Default Admin Times of validated schedule.
+12 ; PSGSCIEN = IEN of validated schedule, if PSGSLFG is passed in and is evaluated to TRUE.
+13 ;
+14 ;
+15 KILL Y0,PSJXI
NEW Y,PSGS0ST
+16 SET Z=0
FOR PSJXI=0:1
SET Z=$ORDER(^PS(51.1,"AC","PSJ",X,Z))
IF 'Z
QUIT
+17 IF $GET(X)]""
IF '$GET(PSJSLUP)
Begin DoDot:1
+18 IF $DATA(^PS(51.1,"AC","PSJ",X))
Begin DoDot:2
+19 IF $$DOW^PSIVUTL(X)
SET PSGS0XT="D"
SET PSJNSS=0
IF X["@"
SET (Y0,PSGS0Y)=$PIECE(X,"@",2)
QUIT
+20 IF $GET(NSFF)
SET Y0=$SELECT($GET(PSGS0Y):PSGS0Y,$GET(PSGAT)&'$GET(PSJNEWOE):PSGAT,1:"")
IF Y0
SET PSGS0Y=Y0
End DoDot:2
IF $GET(PSGS0Y)&($GET(PSGS0XT)]"")
QUIT
+21 ; Check for duplicate schedules - force selection
+22 IF PSJXI>1&('$GET(PSGOES))&($GET(PSGS0XT)]"")
QUIT
+23 IF $DATA(^PS(51.1,"AC","PSJ",X))
NEW FREQ,ADMATCH
SET FREQ=$GET(PSGS0XT)
Begin DoDot:2
+24 NEW PSGS0XT,PSGS0Y,PSGST
DO ADMIN^PSJORPOE
IF $GET(PSGS0XT)
SET XT=PSGS0XT
IF $GET(PSGS0Y)
SET (Y0,Y)=PSGS0Y
IF $GET(PSGST)'=""
SET PSGS0ST=PSGST
+25 ;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
End DoDot:2
+26 IF $GET(XT)]""
SET PSGS0XT=XT
IF $GET(Y)
SET PSGS0Y=Y
+27 IF $$DOW^PSIVUTL(X)
IF PSGS0XT=""
SET (XT,PSGS0XT)="D"
IF PSGS0Y=""
SET (Y0,PSGS0Y)=$SELECT($PIECE(X,"@",2):$PIECE(X,"@",2),1:"")
End DoDot:1
+28 IF $GET(PSJLIFNI)!($GET(P(4))]""&($GET(P(2))]""))
IF '$DATA(^PS(51.1,"AC","PSJ",X))!($GET(PSJXI)>1)
SET PSJSLUP=1
+29 IF $GET(NSFF)
IF $GET(PSJXI)>1
Begin DoDot:1
+30 IF $GET(PSGS0XT)=""
IF $GET(NSFF)
IF $GET(PSGXT)]""
SET PSGS0XT=PSGXT
QUIT
+31 IF $GET(PSGS0XT)=""!($GET(PSGS0Y)="")
SET PSJSLUP=1
End DoDot:1
+32 IF '$GET(PSJSLUP)
IF $GET(PSGS0XT)]""&($GET(PSGS0Y)]"")
QUIT
IF ($GET(PSGS0XT)="D"&('$DATA(^PS(51.1,"AC","PSJ",X))))
QUIT
+33 IF $GET(PSGOES)=2
QUIT
+34 IF $GET(PSGS0XT)]""&(PSJXI=1)
QUIT
+35 ;one-time order,exact match (PSJ*5*207)
IF $GET(PSGS0ST)="O"
IF PSJXI=1
QUIT
+36 KILL PSJSLUP
+37 ;
+38 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"
+39 SET PSJDIC2=1
+40 DO IX^DIC
KILL DIC
IF $DATA(DIE)#2
SET DIC=DIE
IF Y'>0
Begin DoDot:1
+41 IF '$$DOW^PSIVUTL(X)
IF '$$PRNOK(X)
SET X=""
SET PSJNSS=1
SET XT=""
SET PSJXI=""
End DoDot:1
QUIT
+42 SET XT=$SELECT("C"[$PIECE(Y(0),"^",5):$PIECE(Y(0),"^",3),1:$PIECE(Y(0),"^",5))
+43 SET X=+Y
SET Y=""
IF $DATA(PSJPWD)
IF $DATA(^PS(51.1,+X,1,+PSJPWD,0))
SET Y=$PIECE(^(0),"^",2)
+44 ;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
+45 IF $GET(PSGSFLG)
SET PSGSCIEN=X
+46 SET (X,X0)=Y(0,0)
IF $GET(Y)=""
SET Y=$PIECE(Y(0),"^",2)
+47 SET (PSGS0Y,Y0)=$GET(Y)
SET Y0(0)=Y(0)
IF $PIECE(Y(0),"^",3)
SET XT=$PIECE(Y(0),"^",3)
+48 IF $GET(PSGS0XT)=""
IF $$DOW^PSIVUTL(X)
SET (XT,PSGS0XT)="D"
+49 QUIT
+50 ;
DW ;
+1 NEW Y
+2 IF ($LENGTH(X,"@")>2)
QUIT
+3 NEW AT
IF X["@"
SET AT=$PIECE(X,"@",2)
+4 SET SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS"
SET SDW=X
SET X=$PIECE(X,"@",2)
NEW XABB
SET XABB=""
+5 IF X]""
DO ENCHK
IF '$DATA(X)
QUIT
+6 ;F QX=1:1:$L(X) I $E(X,QX)?1P S X(1)=$E(X,QX) Q
SET X=$PIECE(SDW,"@")
SET X(1)="-"
IF X?.E1P.E
IF X'["-"
+7 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
+8 IF $DATA(X)
FOR II=1:1:$LENGTH(X,X(1))
SET XABB=$GET(XABB)_$EXTRACT($PIECE(X,X(1),II),1,2)_"-"
+9 KILL X(1)
IF $DATA(X)
SET X=SDW
IF $GET(X)]""
IF $TRANSLATE(XABB,"-")]""
SET X=$EXTRACT($GET(XABB),1,$LENGTH(XABB)-1)
+10 IF $GET(AT)
SET PSGS0Y=AT
+11 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
+4 ;
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($PIECE(PSCH," PRN"))
SET OK=1
End DoDot:1
+7 QUIT OK
ODD(PSF) ;determine if this is an odd schedule
+1 IF PSF>1439
IF PSF#1440
QUIT 1
+2 IF PSF
IF PSF<1440
IF 1440#PSF
QUIT 1
+3 QUIT 0
