- PSGS0 ;BIR/CML3 - SCHEDULE PROCESSOR ;06/22/09 7:12 PM
- ;;5.0;INPATIENT MEDICATIONS;**12,25,26,50,63,74,83,116,110,111,133,138,174,134,213,207,190,113,245,227,256,347,358,353**;16 DEC 97;Build 49
- ;
- ; 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'=" " X=$$TRIM^XLFSTR(X,"R"," ") ;PSJ*5*227 - Prevent schedule crash
- 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($G(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 Q:'$D(X) 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," ")
- .; If entering from Verify action, and schedule exists in schedule file, and order's schedule is continuous,
- .; OR the order's schedule type is fill on request and the order's schedule is defined as continuous in schedule file,
- .; AND the order's schedule is not a PRN schedule, the order must have admin times.
- .Q:$G(PSGOES)'=2 Q:'$D(^PS(51.1,"AC","PSJ",X))
- .I $G(PSGST)="C"!($G(PSGST)="R"&($P($G(ZZND),"^",3))) I ($G(PSGST)'="P"),($G(PSGSCH)'[" PRN"),('$G(PSGAT)&'$G(PSGS0Y)),'$$ODD^PSGS0($G(PSGS0XT)) Q:($P($G(ZZND),"^",5)="O") Q:$$ODD^PSGS0($P(ZZND,"^",3)) K X Q
- 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 ;
- N H,I
- 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
- Q:'$D(X)
- F X(2)=1:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $E(X(3),3,4)>59 K X Q
- Q:'$D(X)
- S X(1)=$L(X,"-"),X(2)=$G(PSGS0XT),PSGSCH=$S($G(PSGSCH)]"":PSGSCH,1:$G(P(9)))
- I $G(PSGSCH)="" Q ;No schedule info, so just validate the numbers and quit.
- I $D(^PS(51.1,"AC","PSJ",PSGSCH)) S H=+$O(^PS(51.1,"AC","PSJ",PSGSCH,0)) S I=$P($G(^PS(51.1,H,0)),"^",5)
- I $G(I)="" S I=$S(PSGSCH["PRN":"P",1:"C")
- I I="D",$L(X,"-")>0 K:$D(X) X(1),X(2),X(3) S I="C" Q ;DOW schedules require at least one admin time
- I $G(I)="O" D Q ;One Time schedules
- . I $L(X,"-")>1 K X Q ;One Time schedules allow one admin time
- I X(2)="" Q ;No frequency - cannot validate admin times to frequency
- I X(2)>1439,$L(X,"-")>1 K X Q ;PSJ*5*113 Schedules with frequency greater than 1 day can only have one admin time.
- I X(2)>0,X(2)<1440,X(1)>(1440/X(2)) K X Q ;PSJ*5*113 Admin times must match frequency or fewer
- I X(2)>0,X(2)<1440,1440#X(2)'=0,X(1)>0 K X Q ;PSJ*5*113 Odd schedules cannot have admin times
- I X(2)>0,X(2)>1440,X(2)#1440'=0,X(1)>1 K X Q ;PSJ*5*113 Odd schedules cannot have admin times
- 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)]"")
- ..;*** PSJ*5*256
- ..NEW PSGIEN,PSGSCHX
- ..S PSGIEN=$O(^PS(51.1,"AC","PSJ",X,0)) I +PSGIEN S PSGSCHX=$G(^PS(51.1,+PSGIEN,0)) I $P(PSGSCHX,U,5)="D" S PSGS0XT="D",PSJNSS=0,PSGS0Y=$P(PSGSCHX,U,2) Q
- ..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(P(4))]"" 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
- ;*** PSJ*5*256; "E" is needed FN as IV when multiple entries with same schedule name so the user can select a schedule from it. chk pending so vf not prompt for the schedule again
- K DIC S DIC="^PS(51.1,",DIC(0)=$S($D(PSGOES):"MZVK",$D(PSJOLDNM):"MZVK",1:"CEMVZK")_$S((+$G(PSJLIFNI)&($G(ON)["P")):"E",1:"")
- ;*** PSJ*5*358 - Lookup isn't working when edit during finishing UD or IV
- I (DIC(0)'["E"),($G(PSJOCFG)["FN"),($S($G(PSGOEER)[26:1,$G(EDIT)[26:1,$G(PSGOEEF(26))=1:1,1:"")) S DIC(0)=DIC(0)_"E"
- ; The naked reference below refers to the full reference inside indirection to ^PS(51.1
- S 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^D"
- S DIC("W")=DIC("W")_",$S($P(^PS(51.1,+Y,0),U,12):"" **INACTIVE** "",1:"""")" ;*353 display inactive when needed
- S PSJDIC2=1
- ;D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D Q
- D MIX^DIC1 K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D Q
- .I '$$DOW^PSIVUTL(X),'$$PRNOK(X),'$$ODD($G(PSGS0XT)),'$$ODD($P($G(ZZND),"^",3)),($P($G(ZZND),"^",5)'="O") 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGS0 11368 printed Jan 18, 2025@03:04:21 Page 2
- PSGS0 ;BIR/CML3 - SCHEDULE PROCESSOR ;06/22/09 7:12 PM
- +1 ;;5.0;INPATIENT MEDICATIONS;**12,25,26,50,63,74,83,116,110,111,133,138,174,134,213,207,190,113,245,227,256,347,358,353**;16 DEC 97;Build 49
- +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 ;PSJ*5*227 - Prevent schedule crash
- if X'=" "
- 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($GET(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," ")
- +23 ; If entering from Verify action, and schedule exists in schedule file, and order's schedule is continuous,
- +24 ; OR the order's schedule type is fill on request and the order's schedule is defined as continuous in schedule file,
- +25 ; AND the order's schedule is not a PRN schedule, the order must have admin times.
- +26 if $GET(PSGOES)'=2
- QUIT
- if '$DATA(^PS(51.1,"AC","PSJ",X))
- QUIT
- +27 IF $GET(PSGST)="C"!($GET(PSGST)="R"&($PIECE($GET(ZZND),"^",3)))
- IF ($GET(PSGST)'="P")
- IF ($GET(PSGSCH)'[" PRN")
- IF ('$GET(PSGAT)&'$GET(PSGS0Y))
- IF '$$ODD^PSGS0($GET(PSGS0XT))
- if ($PIECE($GET(ZZND),"^",5)="O")
- QUIT
- if $$ODD^PSGS0($PIECE(ZZND,"^",3))
- QUIT
- KILL X
- QUIT
- End DoDot:1
- if '$DATA(X)
- QUIT
- 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
- +28 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
- +29 SET Y=$SELECT(($GET(TMPSCHX)["@"):$PIECE(TMPSCHX,"@",2),1:"")
- +30 IF Y
- IF (X'["@")
- IF (TMPSCHX["@")
- SET X=TMPSCHX
- End DoDot:1
- GOTO Q
- +31 SET X=TMPSCHX
- +32 IF X'=""
- IF $DATA(^PS(51.1,"AC","PSJ",X))
- KILL PSJNSS
- GOTO Q
- +33 ;
- 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 NEW H,I
- +2 IF $SELECT($LENGTH($PIECE(X,"-"))>4:1,$LENGTH(X)>119:1,$LENGTH(X)<2:1,X'>0:1,1:X'?.ANP)
- KILL X
- QUIT
- +3 SET X(1)=$PIECE(X,"-")
- IF X(1)'?2N
- IF X(1)'?4N
- KILL X
- QUIT
- +4 SET X(1)=$LENGTH(X(1))
- IF X'["-"&((X>$EXTRACT(2400,1,X(1))!($EXTRACT(X,3,4)>59)))
- KILL X
- QUIT
- +5 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
- +6 if '$DATA(X)
- QUIT
- +7 FOR X(2)=1:1:$LENGTH(X,"-")
- SET X(3)=$PIECE(X,"-",X(2))
- IF $EXTRACT(X(3),3,4)>59
- KILL X
- QUIT
- +8 if '$DATA(X)
- QUIT
- +9 SET X(1)=$LENGTH(X,"-")
- SET X(2)=$GET(PSGS0XT)
- SET PSGSCH=$SELECT($GET(PSGSCH)]"":PSGSCH,1:$GET(P(9)))
- +10 ;No schedule info, so just validate the numbers and quit.
- IF $GET(PSGSCH)=""
- QUIT
- +11 IF $DATA(^PS(51.1,"AC","PSJ",PSGSCH))
- SET H=+$ORDER(^PS(51.1,"AC","PSJ",PSGSCH,0))
- SET I=$PIECE($GET(^PS(51.1,H,0)),"^",5)
- +12 IF $GET(I)=""
- SET I=$SELECT(PSGSCH["PRN":"P",1:"C")
- +13 ;DOW schedules require at least one admin time
- IF I="D"
- IF $LENGTH(X,"-")>0
- if $DATA(X)
- KILL X(1),X(2),X(3)
- SET I="C"
- QUIT
- +14 ;One Time schedules
- IF $GET(I)="O"
- Begin DoDot:1
- +15 ;One Time schedules allow one admin time
- IF $LENGTH(X,"-")>1
- KILL X
- QUIT
- End DoDot:1
- QUIT
- +16 ;No frequency - cannot validate admin times to frequency
- IF X(2)=""
- QUIT
- +17 ;PSJ*5*113 Schedules with frequency greater than 1 day can only have one admin time.
- IF X(2)>1439
- IF $LENGTH(X,"-")>1
- KILL X
- QUIT
- +18 ;PSJ*5*113 Admin times must match frequency or fewer
- IF X(2)>0
- IF X(2)<1440
- IF X(1)>(1440/X(2))
- KILL X
- QUIT
- +19 ;PSJ*5*113 Odd schedules cannot have admin times
- IF X(2)>0
- IF X(2)<1440
- IF 1440#X(2)'=0
- IF X(1)>0
- KILL X
- QUIT
- +20 ;PSJ*5*113 Odd schedules cannot have admin times
- IF X(2)>0
- IF X(2)>1440
- IF X(2)#1440'=0
- IF X(1)>1
- KILL X
- QUIT
- +21 if $DATA(X)
- KILL X(1),X(2),X(3)
- +22 QUIT
- +23 ;
- 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 KILL Y0,PSJXI
- NEW Y,PSGS0ST
- +15 SET Z=0
- FOR PSJXI=0:1
- SET Z=$ORDER(^PS(51.1,"AC","PSJ",X,Z))
- if 'Z
- QUIT
- +16 IF $GET(X)]""
- IF '$GET(PSJSLUP)
- Begin DoDot:1
- +17 IF $DATA(^PS(51.1,"AC","PSJ",X))
- Begin DoDot:2
- +18 ;*** PSJ*5*256
- +19 NEW PSGIEN,PSGSCHX
- +20 SET PSGIEN=$ORDER(^PS(51.1,"AC","PSJ",X,0))
- IF +PSGIEN
- SET PSGSCHX=$GET(^PS(51.1,+PSGIEN,0))
- IF $PIECE(PSGSCHX,U,5)="D"
- SET PSGS0XT="D"
- SET PSJNSS=0
- SET PSGS0Y=$PIECE(PSGSCHX,U,2)
- QUIT
- +21 IF $$DOW^PSIVUTL(X)
- SET PSGS0XT="D"
- SET PSJNSS=0
- if X["@"
- SET (Y0,PSGS0Y)=$PIECE(X,"@",2)
- QUIT
- +22 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
- +23 ; Check for duplicate schedules - force selection
- +24 if PSJXI>1&('$GET(PSGOES))&($GET(PSGS0XT)]"")
- QUIT
- +25 IF $DATA(^PS(51.1,"AC","PSJ",X))
- NEW FREQ,ADMATCH
- SET FREQ=$GET(PSGS0XT)
- Begin DoDot:2
- +26 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
- +27 ;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
- End DoDot:2
- +28 if $GET(XT)]""
- SET PSGS0XT=XT
- if $GET(Y)
- SET PSGS0Y=Y
- +29 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
- +30 ;I $G(PSJLIFNI)!($G(P(4))]""&($G(P(2))]"")) I '$D(^PS(51.1,"AC","PSJ",X))!($G(PSJXI)>1) S PSJSLUP=1
- +31 IF $GET(P(4))]""
- IF '$DATA(^PS(51.1,"AC","PSJ",X))!($GET(PSJXI)>1)
- SET PSJSLUP=1
- +32 IF $GET(NSFF)
- IF $GET(PSJXI)>1
- Begin DoDot:1
- +33 IF $GET(PSGS0XT)=""
- IF $GET(NSFF)
- IF $GET(PSGXT)]""
- SET PSGS0XT=PSGXT
- QUIT
- +34 IF $GET(PSGS0XT)=""!($GET(PSGS0Y)="")
- SET PSJSLUP=1
- End DoDot:1
- +35 IF '$GET(PSJSLUP)
- if $GET(PSGS0XT)]""&($GET(PSGS0Y)]"")
- QUIT
- if ($GET(PSGS0XT)="D"&('$DATA(^PS(51.1,"AC","PSJ",X))))
- QUIT
- +36 if $GET(PSGOES)=2
- QUIT
- +37 if $GET(PSGS0XT)]""&(PSJXI=1)
- QUIT
- +38 ;one-time order,exact match (PSJ*5*207)
- IF $GET(PSGS0ST)="O"
- IF PSJXI=1
- QUIT
- +39 KILL PSJSLUP
- +40 ;*** PSJ*5*256; "E" is needed FN as IV when multiple entries with same schedule name so the user can select a schedule from it. chk pending so vf not prompt for the schedule again
- +41 KILL DIC
- SET DIC="^PS(51.1,"
- SET DIC(0)=$SELECT($DATA(PSGOES):"MZVK",$DATA(PSJOLDNM):"MZVK",1:"CEMVZK")_$SELECT((+$GET(PSJLIFNI)&($GET(ON)["P")):"E",1:"")
- +42 ;*** PSJ*5*358 - Lookup isn't working when edit during finishing UD or IV
- +43 IF (DIC(0)'["E")
- IF ($GET(PSJOCFG)["FN")
- IF ($SELECT($GET(PSGOEER)[26:1,$GET(EDIT)[26:1,$GET(PSGOEEF(26))=1:1,1:""))
- SET DIC(0)=DIC(0)_"E"
- +44 ; The naked reference below refers to the full reference inside indirection to ^PS(51.1
- +45 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^D"
- +46 ;*353 display inactive when needed
- SET DIC("W")=DIC("W")_",$S($P(^PS(51.1,+Y,0),U,12):"" **INACTIVE** "",1:"""")"
- +47 SET PSJDIC2=1
- +48 ;D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D Q
- +49 DO MIX^DIC1
- KILL DIC
- if $DATA(DIE)#2
- SET DIC=DIE
- IF Y'>0
- Begin DoDot:1
- +50 IF '$$DOW^PSIVUTL(X)
- IF '$$PRNOK(X)
- IF '$$ODD($GET(PSGS0XT))
- IF '$$ODD($PIECE($GET(ZZND),"^",3))
- IF ($PIECE($GET(ZZND),"^",5)'="O")
- SET X=""
- SET PSJNSS=1
- SET XT=""
- SET PSJXI=""
- End DoDot:1
- QUIT
- +51 SET XT=$SELECT("C"[$PIECE(Y(0),"^",5):$PIECE(Y(0),"^",3),1:$PIECE(Y(0),"^",5))
- +52 SET X=+Y
- SET Y=""
- IF $DATA(PSJPWD)
- IF $DATA(^PS(51.1,+X,1,+PSJPWD,0))
- SET Y=$PIECE(^(0),"^",2)
- +53 ;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
- +54 IF $GET(PSGSFLG)
- SET PSGSCIEN=X
- +55 SET (X,X0)=Y(0,0)
- if $GET(Y)=""
- SET Y=$PIECE(Y(0),"^",2)
- +56 SET (PSGS0Y,Y0)=$GET(Y)
- SET Y0(0)=Y(0)
- IF $PIECE(Y(0),"^",3)
- SET XT=$PIECE(Y(0),"^",3)
- +57 IF $GET(PSGS0XT)=""
- IF $$DOW^PSIVUTL(X)
- SET (XT,PSGS0XT)="D"
- +58 QUIT
- +59 ;
- 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