- PSSJSV ;BIR/CML3/WRT-SCHEDULE VALIDATION ;06/24/96
- ;;1.0;PHARMACY DATA MANAGEMENT;**20,38,56,59,110,121,143,149,146,189,201,210**;9/30/97;Build 9
- ;
- ; Reference to ^PS(51.15 is supported by DBIA #2132
- ; Reference to $$UP^XLFSTR(P1) is supported by DBIA #10104
- ;
- EN ;
- S X=PSJX,(PSJAT,PSJM,PSJTS,PSJY,PSJAX)="" I $S(X["""":1,$A(X)=45:1,X'?.ANP:1,$L(X," ")>2:1,$L(X)>70:1,$L(X)<1:1,X["P RN":1,1:X["PR N") K PSJX,X Q
- I X["PRN"!(X="ON CALL")!(X="ONCALL")!(X="ON-CALL") G DONE
- I X?1."?" D:'$D(PSJNE) ENSVH^PSSJSV0 Q
- I X["@" D DW S:$D(X) PSJAT=$P(X,"@",2) G DONE
- S X0=X,(XT,Y)="" I X,X'["X",(X?2.4N1"-".E!(X?2.4N)) D ENCHK S:$D(X) PSJAT=X G DONE
- I $S($D(^PS(51.1,"AC",PSJPP,X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC G:$S(PSJY:PSJTS'="C",1:PSJM) DONE
- I $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") S PSJTS="O" W:'$D(PSJNE) " (ONCE ONLY)" G DONE
- S:PSJTS="" PSJTS="C" I PSJAT="" W:'$D(PSJNE) " (Non standard schedule)" S X=PSJX
- I $E(X,1,2)="AD" K X G DONE
- I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="QID") S PSJM=1440\$F("BTQ",$E(X)) G DONE
- 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=X1,X=$E(X,2,99) I 'X2,$E(X)="O" S X2=.5,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,PSJAT="" K X G DONE
- S X=PSJX I XT S:X2 XT=XT\X2 S:'X2 XT=XT*X1
- S PSJM=XT
- ;
- DONE ;
- K:$D(X)[0 PSJX K D,DIC,Q,QX,SDW,SWD,X,X0,X1,X2,XT,Y,Z Q
- ;
- ENCHK ; admin times
- N SCHED
- 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)) F X(2)=2:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $S($L(X(3))'=X(1):1,X(3)>$S(X(1)=2:24,1:2400):1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q
- Q:'$D(X)
- S X(1)=$L(X,"-")
- S SCHED=$S($G(DA(1)):$$GET1^DIQ(52.61,+$G(DA)_","_DA(1),4),$G(DA):$$GET1^DIQ(52.6,+DA,4),1:"")
- Q:(SCHED="")
- S IENS=$O(^PS(51.1,"B",SCHED,0))
- S X(4)=$S($G(PSSJSE)&($G(PSSSCT)]""):PSSSCT,1:$$GET1^DIQ(51.1,IENS,5,"I"))
- I X(4)="D" D Q ;DOW schedules require at least one admin time
- . I X(1)>0 K:$D(X) X(1),X(2),X(3) Q
- . K X
- I X(4)="O" D Q
- . I $L(X,"-")>1 K X Q ;One Time schedules allow one admin time
- . I X="" K X Q ;One Time schedules require one admin time
- S X(2)=$S($G(PSSJSE)&($G(PSSFRQ)):PSSFRQ,1:$$GET1^DIQ(51.1,IENS,2,"I"))
- I X(2)="" K:$D(X) X(1),X(2),X(3) Q
- I X(2)>0,X(2)<1440,(1440/X(2))'=X(1) K X Q ;PSS*1*143 Admin times must match frequency
- I X(2)>0,X(2)<1440,(1440#X(2))'=0,X(1)>0 K X Q ;PSS*1*143 Odd schedules cannot have admin times
- I X(2)>1440,(X(2)#1440)'=0,X(1)>1 K X Q ;PSS*1*143 Odd schedules cannot have admin times
- I X(2)>1439,$L(X,"-")'=1 K X Q ;PSS*1*143 Schedules with frequency equal to or greater than 1 day can only have one admin time.
- K:$D(X) X(1),X(2),X(3)
- Q
- ;
- DIC ; 51.1 look-up
- S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(PSJNE))_"ISZ",DIC("W")="I '$D(PSJNE) D DICW^PSSJSV0",D="AP"_PSJPP
- D IX^DIC K DIC Q:Y'>0 S PSJY=+Y,(PSJX,X,X0)=Y(0,0),PSJM=$P(Y(0),"^",3),PSJTS=$P(Y(0),"^",5),PSJAX=$P(Y(0),U,7) S:PSJTS="" PSJTS="C" Q:PSJTS="O"!(PSJTS["R") I $D(PSJW),$D(^PS(51.1,+Y,1,+PSJW,0)) S PSJAT=$P(^(0),"^",PSJTS="S"+2)
- E S PSJAT=$P(Y(0),"^",PSJTS="S"*4+2)
- Q:PSJTS'="S"
- F Y=1:1:$L(PSJAT,"-") S Y(1)=$P(PSJAT,"-",Y),PSJAT(Y(1))="",Y(2)=$O(^PS(51.15,"ACP",PSJPP,Y(1),0)) I Y(2),$D(^PS(51.15,Y(2),0)) S PSJAT(Y(1))=$P(^(0),"^",3) I $D(PSJW),$D(^(1,PSJW,0)),$P(^(0),"^",2)]"" S PSJAT(Y(1))=$P(^(0),"^",2)
- Q
- ;
- DW ; week days
- 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
- ;
- ENSNV ; schedule name
- I $S(X["""":1,$A(X)=45:1,X'?.ANP:1,$L(X)>20:1,$L(X)<2:1,1:X?1P.E) K X Q
- I $S('$D(PSJPP):0,PSJPP="":1,PSJPP'?.ANP:1,1:'$$VERSION^XPDUTL(PSJPP)) K X
- I $D(DA),$D(^PS(51.1,DA,0)),$P(^(0),"^",5)["D" S ZX=X D DNVX S:$D(X) X=ZX K Z1,Z2,Z3,Z4,ZX
- Q
- ;
- ENSHV ; shift in 51.1
- I $S($L(X)>11:1,$L(X)<1:1,'$D(PSJPP):1,PSJPP="":1,PSJPP'?.ANP:1,1:'$$VERSION^XPDUTL(PSJPP)) K X Q
- F X(1)=1:1:$L(X,"-") S X(2)=$P(X,"-",X(1)) I $S(X(2)="":1,X(2)'?.ANP:1,1:'$D(^PS(51.15,"ACP",PSJPP,X(2)))) K X Q
- K X(1),X(2) Q
- ;
- ENVSST ; shift start/stop times
- I X'?2N1"-"2N,X'?4N1"-"4N K X Q
- F X(1)=1,2 I $P(X,"-",X(1))>$S($L($P(X,"-",X(1)))<4:24,1:2400) K X Q
- K X(1) Q
- ;
- ENFQD ; frequency default
- N X1,X2,Z S Z=$S($D(^PS(51.1,DA,0)):$P(^(0),"^"),1:""),X=""
- S X=$P(Z,"^",3) I Z]"" Q
- S Z=DA I $E(Z,1,2)="AD" Q
- I $E(Z,1,3)="BID"!($E(Z,1,3)="TID")!($E(Z,1,3)="QID") S X=1440/$F("BTQ",$E(Z)) Q
- E S:$E(Z)="Q" Z=$E(Z,2,99) S:'Z Z="1"_Z S X1=+Z,Z=$P(Z,+Z,2),X2=0 S:$E(Z)="X" X2=X1,Z=$E(Z,2,99) I 'X2,$E(Z)="O" S X2=.5,Z=$E(Z,2,99)
- S X=$S(Z["'":1,(Z["D"&(Z'["AD"))!(Z["AM")!(Z["PM")!(Z["HS"&(Z'["THS")):1440,Z["H"&(Z'["TH"):60,Z["AC"!(Z["PC"):480,Z["W":10080,Z["M":40320,1:"") Q:'X S:X2 X=X\X2 S:'X2 X=X*X1 Q
- ;
- ENFREQ ; validate frequency
- K:+X'=X!(X>525600)!(X<1)!(X?.E1"."1N.N) X
- Q
- ;
- DFCHK ; validate dosing check frequency **pss_1_201**
- N PSSX1,PSSX2 S PSSX1="",X=$$UP^XLFSTR(X),PSSX2=$E(X,$L(X))
- ;
- I $L(X)>4!($L(X)<3) K X Q
- ;
- I '+($E(X,2)) K X Q
- I $L(X)=4 S PSSX1=($E(X,2,3)) I PSSX1'?.N K X Q
- ;
- I $L(X)=3,$E(X,1)="Q",PSSX2="L",$E(X,2)'<7 K X Q
- I $G(PSSX1),$E(X,1)="Q",PSSX2="L",PSSX1'<7 K X Q
- I $G(PSSX1),$E(X,1)="Q",PSSX2="W",PSSX1'<29 K X Q
- ;
- I $E(X,1)="Q"&(PSSX2="H"!(PSSX2="D")!(PSSX2="W")!(PSSX2="L")) Q
- I $E(X,1)="X"&(PSSX2="D"!(PSSX2="W")!(PSSX2="L")) Q
- E K X Q
- ;
- HPDCHK ; help prompt with specified formats for the dosing check frequency fields **pss_1_201**
- N MSG,PSSHFLG S (MSG,PSSHFLG)=""
- ;
- I $G(X)="??" S PSSHFLG=1
- ;
- I 'PSSHFLG D Q
- .S MSG(1)=" The numeric limit is 99, except for the following formats:"
- .S MSG(2)=""
- .S MSG(3)=" Q#W - Maximum 28 weeks allowed"
- .S MSG(4)=" Q#L - Maximum 6 months allowed"
- .S MSG(5)=""
- .S MSG(6)=" Enter '??' to view the available dosing check frequency formats"
- .S MSG(7)=" for this field."
- .S MSG(8)=""
- .D EN^DDIOL(.MSG,"","!")
- Q
- ;
- OASCHK ; check the 'D' cross reference to see if duplicates exist **pss_1_201**
- N MSG,PSSCNT,PSSD,PSSFLG,PSSDA,PSSDONE,PSSAIEN S (MSG,PSSAIEN)="",(PSSCNT,PSSD,PSSFLG)=0,PSSDA=$G(DA),PSSDONE=$G(DA(1))
- ;
- I $G(X)="@" S PSSD=1,DIR(0)="YAO",DIR("A")="SURE YOU WANT TO DELETE? " D ^DIR
- I $G(Y)=1 F S PSSCNT=$O(^PS(51.1,$G(DA),5,PSSCNT)) Q:PSSCNT=""!(PSSFLG=1) D
- .I $G(^PS(51.1,$G(DA),5,PSSCNT,0))=$P(PSSRN,"//",1) S PSSFLG=1 S DIE=DIC,DA(1)=$G(DA),DA=PSSCNT,DR=".01///@" D ^DIE K DIR,X
- .S DA=PSSDA,DA(1)=PSSDONE,PSSRN=$$OASLE^PSSOAS(DA),DIC("A")="Select OLD SCHEDULE NAME(S): "_$G(PSSRN)
- I $G(PSSD)=1 K X Q
- I $L($G(X))>20!($L($G(X))<2) D EN^DDIOL("Answer must be 2-20 characters in length.","","!") K X Q
- ;
- S X=$$UP^XLFSTR($G(X))
- ;
- N PSSRCHK,PSSRFL,MSG S (PSSRCHK,PSSRFL)=""
- F S PSSRCHK=$O(^PS(51.1,"D",PSSRCHK)) Q:PSSRCHK']""!($G(PSSRFL)) D
- .I PSSRCHK=$G(X) S PSSRFL=1 F S PSSAIEN=$O(^PS(51.1,"D",PSSRCHK,PSSAIEN)) Q:PSSAIEN'=""
- I $G(PSSRFL)=1,$G(PSSAIEN)'=$G(PSSDA) K X D Q
- .S MSG(1)=""
- .S MSG(2)=" Duplicate exists in Old Schedule Name multiple for the entry"
- .S MSG(3)=" "_$P(^PS(51.1,$G(PSSAIEN),0),U,1)_" ("_$G(PSSAIEN)_") in the file. Please enter a new name."
- .D EN^DDIOL(.MSG,"","!")
- ;
- N PSSMCHK,PSSMFL S PSSMCHK="",PSSMFL=0
- I $G(Y)=-1,$G(DA) F S PSSMCHK=$O(^PS(51.1,$G(DA),5,PSSMCHK)) Q:PSSMCHK']""!($G(PSSMFL)) D
- .I $G(^PS(51.1,$G(DA),5,PSSMCHK,0))=$G(X) S PSSMFL=1
- I $G(PSSMFL)=1 K X Q
- Q
- ;
- ENDNV ; day of the week name
- N Z1,Z2,Z3,Z4,PSSDASH,PSSTIME,PSSXTIME,PSSTIMCT
- S X=$S($D(^PS(51.1,DA,0)):$P(^(0),"^"),1:"") I X="" K X Q
- ;
- DNVX ; validate day of the week name
- S Z2=1,Z4="-" I X'["-",X?.E1P.E F Z1=1:1:$L(X) I $E(X,Z1)?1P S Z4=$E(X,Z1) Q
- F Z1=1:1:$L(X,Z4) Q:'Z2 S Z2=0 I $L($P(X,Z4,Z1))>1 F Z3="MONDAYS","TUESDAYS","WEDNESDAYS","THURSDAYS","FRIDAYS","SATURDAYS","SUNDAYS" I $P(Z3,$P(X,Z4,Z1))="" S Z2=1 Q
- I Z2=0 K X
- S PSSXTIME=$P(ZX,"@",2),PSSDASH=$L(PSSXTIME,"-")
- F PSSTIMCT=1:1:PSSDASH S PSSTIME=$P(PSSXTIME,"-",PSSTIMCT)
- I $L(PSSTIME)>4 K X
- I '$D(X) S PSSDOW=1
- S:Z2 X="D"
- Q
- ;
- ENPSJ ;validate schedule names for PSJ package **pss_1_201**
- N A,B,I,PSSCNT,PSSFLG SET (PSSFLG,PSSDOW)=0
- ;
- S X=$$UP^XLFSTR(X)
- I $G(X)'="",+$G(Y) D OASCHK I $G(X)="" Q
- I $G(PSSON)'="",$G(X)'=$G(PSSON) D ENOAS(PSSON,X)
- ;
- I $G(PSJPP)'="PSJ" Q
- S A=$TR(X,".","") I A="OTHER" K X Q
- F I=1:1:$L(A," ") S B=$P(A," ",I) I B="QD"!(B="QOD")!(B="HS")!(B="TIW") K X ;;>> *149 RJS
- Q:'$D(X)
- S DOW=0,ZX=X S X=$P(X,"@") D DNVX I $G(X)="" S X=ZX K ZX
- I X="D" S X=ZX,DOW=1 D:X["@" CHKORD I $D(X),$G(PSSCNT)>1 D S:'$D(X) X=ZX K Z1,Z2,Z3,Z4,ZX
- .N MSG
- .S MSG(1)="",MSG(2)="The day of the week schedule must be in the correct day of week order."
- .S MSG(3)="The correct order is: SU-MO-TU-WE-TH-FR-SA"
- .D EN^DDIOL(.MSG,"","!")
- .Q
- ;
- ENOAS(PSSOLD,PSSX) ; entry for new OLD SCHEDULE NAME(S) into the multiple **pss_1_201**
- N PSSMCHK,PSSRCHK,PSSBCHK,PSSCCHK,PSSMFL,PSSRFL,PSSBFL,PSSNNM,PSSDA,MSG S (PSSRCHK,PSSBCHK,MSG)="",(PSSMCHK,PSSCCHK,PSSMFL,PSSRFL,PSSBFL)=0,PSSNNM=$$UP^XLFSTR($G(X)),PSSDA=$G(DA)
- N PSSCHK,PSSAIEN,PSSDFL S (PSSCHK,PSSAIEN)="",PSSDFL=0
- ;
- I $G(DA) F S PSSMCHK=$O(^PS(51.1,$G(DA),5,PSSMCHK)) Q:'+PSSMCHK!($G(PSSMFL)) D
- .I $G(^PS(51.1,$G(DA),5,PSSMCHK,0))=$G(PSSX) S PSSMFL=1
- I $G(PSSMFL)=1 S X=$G(PSSOLD) D Q
- .S MSG(1)=""
- .S MSG(2)="A duplicate exists in the OLD SCHEDULE NAME(S) multiple for this entry."
- .S MSG(3)=""
- .D EN^DDIOL(.MSG,"","!")
- ;
- I $G(X)'="" F S PSSCHK=$O(^PS(51.1,"D",PSSCHK)) Q:PSSCHK=""!($G(PSSDFL)) D
- .I $G(PSSCHK)=$G(X) S PSSDFL=1 F S PSSAIEN=$O(^PS(51.1,"D",PSSCHK,PSSAIEN)) Q:PSSAIEN'=""
- .I $G(PSSDFL)=1 S X=$G(PSSOLD) D Q
- ..S MSG(1)=""
- ..S MSG(2)="A duplicate exists in the OLD SCHEDULE NAME(S) multiple for the entry"
- ..S MSG(3)=$P(^PS(51.1,$G(PSSAIEN),0),U,1)_" ("_$G(PSSAIEN)_")."
- ..S MSG(4)=""
- ..D EN^DDIOL(.MSG,"","!")
- ;
- I $G(X)["""" F S PSSBCHK=$O(^PS(51.1,"B",PSSBCHK)) Q:PSSBCHK']""!($G(PSSBFL)) D
- .I $G(PSSBCHK)=$G(PSSOLD) S PSSBFL=1
- ;
- I $G(X)'["""" F S PSSBCHK=$O(^PS(51.1,"B",PSSBCHK)) Q:PSSBCHK']""!($G(PSSBFL)) D
- .F S PSSCCHK=$O(^PS(51.1,"B",PSSBCHK,PSSCCHK)) Q:PSSCCHK']""!($G(PSSBFL)) D
- ..I $G(PSSBCHK)=$G(PSSOLD),$G(PSSCCHK)'=$G(DA) S PSSBFL=1
- ;
- F S PSSRCHK=$O(^PS(51.1,"D",PSSRCHK)) Q:PSSRCHK']""!($G(PSSRFL)) D
- .I $G(PSSRCHK)=$G(PSSOLD) S PSSRFL=1
- I '$G(PSSMFL),'$G(PSSRFL),'$G(PSSBFL),'$G(PSSDFL),$G(DA),$G(X)'="",$G(X)'?." " K DO S X=$G(PSSON),DA(1)=$G(DA),DIC=DIC_DA(1)_",5,",DIC(0)="L" D FILE^DICN S X=PSSNNM,DIC="^PS(51.1,"
- ;
- Q
- ;
- SCRN ;LOGIC TO SCREEN OUT @ IF NOT DAILY
- S (PSSFLG,PSSDFLG,PSSTFLG,PSSAFLG)=0
- Q:X'["@"
- I $G(PSSCNT) K PSSCNT,X Q
- D DAYS,TIMECHK
- I $L(X)<2!($L(X)>20) D MSG1
- I $G(PSSAFLG) D MSG4
- I $G(PSSTFLG) D MSG3
- I $G(PSSDFLG) D MSG2
- I $G(PSSFLG) S MSG(4)="",MSG(5)=" "_X D EN^DDIOL(.MSG,"","!") K MSG
- K:$G(PSSFLG) X
- K PSSFLG,PSSDFLG,PSSTFLG,PSSAFLG
- Q
- ;
- ENPSJT ; Validate schedule type (one-time PRN conflict)
- N A,B
- S A=$$GET1^DIQ(51.1,DA,.01),B=""
- I A["PRN",X'="P" D
- . S B="Conflict: Schedule Name contains PRN but selected Schedule Type is not PRN."
- . K X
- I A'["PRN",X="P" D
- . S B="Conflict: Schedule Name does not contain PRN but selected Schedule Type is PRN."
- . K X
- I $G(X)="D",$G(PSSDOW) D
- . S B="Conflict: Schedule Name contains free text but selected Schedule Type is Day of the Week."
- . K X
- I $L(B)>0 D EN^DDIOL(.B,"","!") Q
- S A=$$GET1^DIQ(51.1,DA,2),B=""
- Q
- ;
- CHKORD ;Check order of days in DOW schedule name
- N I,J,L,N,P,W
- S N=$P(X,"@"),L=0,P=$L(N,"-"),W="SUNDAYS,MONDAYS,TUESDAYS,WEDNESDAYS,THURSDAYS,FRIDAYS,SATURDAYS",PSSCNT=0
- F I=1:1:P F J=1:1:7 I $P(W,",",J)=$P(N,"-",I) K:J'>L X Q:'$D(X) S:J>L L=J,PSSCNT=PSSCNT+1
- Q
- ;
- RMTIME ;Remove ward times when schedule becomes odd
- N R
- S R=0 F S R=$O(^PS(51.1,D0,1,R)) Q:R="" K ^PS(51.1,D0,1,R)
- Q
- DAYS ; check days of week for correct order sequence
- N PSSD2,PSSD3,PSSD4,PSSD1,PSSD5,PSSD6,PSSFND
- S PSSD1=$P(X,"@"),PSSD4=0,PSSD5=$L(PSSD1,"-"),PSSD6="SU,MO,TU,WE,TH,FR,SA",PSSFND=0
- F PSSD2=1:1:PSSD5 Q:'$D(PSSD1) D
- .F PSSD3=1:1:7 D Q:'$D(PSSD1)
- ..I $P(PSSD6,",",PSSD3)=$P(PSSD1,"-",PSSD2) K:PSSD3'>PSSD4 PSSD1 Q:'$D(PSSD1) S PSSFND=PSSFND+1 S:PSSD3>PSSD4 PSSD4=PSSD3
- ..I $L($P(PSSD1,"-",PSSD2))>2 K PSSD1
- .K:PSSFND'=PSSD2 PSSD1
- I ('$D(PSSD1)!('$D(PSSFND))) S PSSDFLG=1
- Q
- MSG1 ; max length exceeded message
- S MSG(1)="",MSG(2)="The Administration Schedule you entered has "_$L(X)_" characters."
- S MSG(3)="Answer must be 2-20 characters in length."
- D EN^DDIOL(.MSG,"","!")
- S PSSFLG=1
- K MSG
- Q
- MSG2 ; day of week order squence message
- S MSG(1)="",MSG(2)="The day of the week schedule must be in the correct day of week order."
- S MSG(3)="The correct order is: SU-MO-TU-WE-TH-FR-SA"
- D EN^DDIOL(.MSG,"","!")
- S PSSFLG=1
- K MSG
- Q
- MSG3 ; time input message
- S MSG(1)="",MSG(2)="The time must be between 0001 - 2400."
- S MSG(3)="A correct time entry would be: 0800-1200-1600 etc."
- D EN^DDIOL(.MSG,"","!")
- S PSSFLG=1
- K MSG
- Q
- MSG4 ; time sequence message
- S MSG(1)="",MSG(2)="The time must be entered in ascending order."
- S MSG(3)="A correct time entry would be: 0800-1200-1600 etc."
- D EN^DDIOL(.MSG,"","!")
- S PSSFLG=1
- K MSG
- Q
- TIMECHK ; time validation
- N PSSXTIME,PSSTLN,PSSLOOP,PSSTCHR,PSSDASH,PSSLEN,PSSTCHK,PSSTIMCT,PSSTIME
- I $L(X,"@")>2 S (PSSDFLG,PSSTFLG)=1 Q
- S PSSXTIME=$P(X,"@",2),PSSTLN=$L(PSSXTIME),PSSTFLG=0,PSSDASH=$L(PSSXTIME,"-")
- I PSSXTIME=0 S PSSTFLG=1 Q
- F PSSTIMCT=1:1:PSSDASH S PSSTIME=$P(PSSXTIME,"-",PSSTIMCT) D
- .S PSSTCHK(PSSTIMCT)=PSSTIME,PSSLEN=$L(PSSTIME)
- .I $L(PSSTCHK(PSSTIMCT))=2 S PSSTCHK(PSSTIMCT)=PSSTCHK(PSSTIMCT)_"00"
- .F PSSLOOP=1:1:PSSLEN D
- ..S PSSTCHR=$E(PSSTIME,PSSLOOP)
- ..I $A(PSSTCHR)<48!($A(PSSTCHR)>57) S PSSTFLG=1
- .I ((PSSTIME<1)!(PSSLEN=1)!(PSSLEN=3)!(PSSLEN>4)) S PSSTFLG=1
- F PSSTIMCT=1:1:PSSDASH D
- .I $G(PSSTCHK(PSSTIMCT+1)),PSSTCHK(PSSTIMCT)>PSSTCHK(PSSTIMCT+1) S PSSAFLG=1
- .I $L(PSSTCHK(PSSTIMCT))=4 D
- ..I $E(PSSTCHK(PSSTIMCT),1,4)>2400 S PSSTFLG=1
- ..I $E(PSSTCHK(PSSTIMCT),1,2)<24 D
- ...I $E(PSSTCHK(PSSTIMCT),3,4)>59 S PSSTFLG=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSJSV 14619 printed Feb 18, 2025@23:58:13 Page 2
- PSSJSV ;BIR/CML3/WRT-SCHEDULE VALIDATION ;06/24/96
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**20,38,56,59,110,121,143,149,146,189,201,210**;9/30/97;Build 9
- +2 ;
- +3 ; Reference to ^PS(51.15 is supported by DBIA #2132
- +4 ; Reference to $$UP^XLFSTR(P1) is supported by DBIA #10104
- +5 ;
- EN ;
- +1 SET X=PSJX
- SET (PSJAT,PSJM,PSJTS,PSJY,PSJAX)=""
- IF $SELECT(X["""":1,$ASCII(X)=45:1,X'?.ANP:1,$LENGTH(X," ")>2:1,$LENGTH(X)>70:1,$LENGTH(X)<1:1,X["P RN":1,1:X["PR N")
- KILL PSJX,X
- QUIT
- +2 IF X["PRN"!(X="ON CALL")!(X="ONCALL")!(X="ON-CALL")
- GOTO DONE
- +3 IF X?1."?"
- if '$DATA(PSJNE)
- DO ENSVH^PSSJSV0
- QUIT
- +4 IF X["@"
- DO DW
- if $DATA(X)
- SET PSJAT=$PIECE(X,"@",2)
- GOTO DONE
- +5 SET X0=X
- SET (XT,Y)=""
- IF X
- IF X'["X"
- IF (X?2.4N1"-".E!(X?2.4N))
- DO ENCHK
- if $DATA(X)
- SET PSJAT=X
- GOTO DONE
- +6 IF $SELECT($DATA(^PS(51.1,"AC",PSJPP,X)):1,1:$EXTRACT($ORDER(^(X)),1,$LENGTH(X))=X)
- DO DIC
- if $SELECT(PSJY
- GOTO DONE
- +7 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")
- SET PSJTS="O"
- if '$DATA(PSJNE)
- WRITE " (ONCE ONLY)"
- GOTO DONE
- +8 if PSJTS=""
- SET PSJTS="C"
- IF PSJAT=""
- if '$DATA(PSJNE)
- WRITE " (Non standard schedule)"
- SET X=PSJX
- +9 IF $EXTRACT(X,1,2)="AD"
- KILL X
- GOTO DONE
- +10 IF $EXTRACT(X,1,3)="BID"!($EXTRACT(X,1,3)="TID")!($EXTRACT(X,1,3)="QID")
- SET PSJM=1440\$FIND("BTQ",$EXTRACT(X))
- GOTO DONE
- +11 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=X1
- SET X=$EXTRACT(X,2,99)
- IF 'X2
- IF $EXTRACT(X)="O"
- SET X2=.5
- SET X=$EXTRACT(X,2,99)
- +12 SET XT=$SELECT(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)
- IF XT<0
- IF PSJAT=""
- KILL X
- GOTO DONE
- +13 SET X=PSJX
- IF XT
- if X2
- SET XT=XT\X2
- if 'X2
- SET XT=XT*X1
- +14 SET PSJM=XT
- +15 ;
- DONE ;
- +1 if $DATA(X)[0
- KILL PSJX
- KILL D,DIC,Q,QX,SDW,SWD,X,X0,X1,X2,XT,Y,Z
- QUIT
- +2 ;
- ENCHK ; admin times
- +1 NEW SCHED
- +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))
- FOR X(2)=2:1:$LENGTH(X,"-")
- SET X(3)=$PIECE(X,"-",X(2))
- IF $SELECT($LENGTH(X(3))'=X(1):1,X(3)>$SELECT(X(1)=2:24,1:2400):1,1:X(3)'>$PIECE(X,"-",X(2)-1))
- KILL X
- QUIT
- +5 if '$DATA(X)
- QUIT
- +6 SET X(1)=$LENGTH(X,"-")
- +7 SET SCHED=$SELECT($GET(DA(1)):$$GET1^DIQ(52.61,+$GET(DA)_","_DA(1),4),$GET(DA):$$GET1^DIQ(52.6,+DA,4),1:"")
- +8 if (SCHED="")
- QUIT
- +9 SET IENS=$ORDER(^PS(51.1,"B",SCHED,0))
- +10 SET X(4)=$SELECT($GET(PSSJSE)&($GET(PSSSCT)]""):PSSSCT,1:$$GET1^DIQ(51.1,IENS,5,"I"))
- +11 ;DOW schedules require at least one admin time
- IF X(4)="D"
- Begin DoDot:1
- +12 IF X(1)>0
- if $DATA(X)
- KILL X(1),X(2),X(3)
- QUIT
- +13 KILL X
- End DoDot:1
- QUIT
- +14 IF X(4)="O"
- Begin DoDot:1
- +15 ;One Time schedules allow one admin time
- IF $LENGTH(X,"-")>1
- KILL X
- QUIT
- +16 ;One Time schedules require one admin time
- IF X=""
- KILL X
- QUIT
- End DoDot:1
- QUIT
- +17 SET X(2)=$SELECT($GET(PSSJSE)&($GET(PSSFRQ)):PSSFRQ,1:$$GET1^DIQ(51.1,IENS,2,"I"))
- +18 IF X(2)=""
- if $DATA(X)
- KILL X(1),X(2),X(3)
- QUIT
- +19 ;PSS*1*143 Admin times must match frequency
- IF X(2)>0
- IF X(2)<1440
- IF (1440/X(2))'=X(1)
- KILL X
- QUIT
- +20 ;PSS*1*143 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
- +21 ;PSS*1*143 Odd schedules cannot have admin times
- IF X(2)>1440
- IF (X(2)#1440)'=0
- IF X(1)>1
- KILL X
- QUIT
- +22 ;PSS*1*143 Schedules with frequency equal to or greater than 1 day can only have one admin time.
- IF X(2)>1439
- IF $LENGTH(X,"-")'=1
- KILL X
- QUIT
- +23 if $DATA(X)
- KILL X(1),X(2),X(3)
- +24 QUIT
- +25 ;
- DIC ; 51.1 look-up
- +1 SET DIC="^PS(51.1,"
- SET DIC(0)=$EXTRACT("E",'$DATA(PSJNE))_"ISZ"
- SET DIC("W")="I '$D(PSJNE) D DICW^PSSJSV0"
- SET D="AP"_PSJPP
- +2 DO IX^DIC
- KILL DIC
- if Y'>0
- QUIT
- SET PSJY=+Y
- SET (PSJX,X,X0)=Y(0,0)
- SET PSJM=$PIECE(Y(0),"^",3)
- SET PSJTS=$PIECE(Y(0),"^",5)
- SET PSJAX=$PIECE(Y(0),U,7)
- if PSJTS=""
- SET PSJTS="C"
- if PSJTS="O"!(PSJTS["R")
- QUIT
- IF $DATA(PSJW)
- IF $DATA(^PS(51.1,+Y,1,+PSJW,0))
- SET PSJAT=$PIECE(^(0),"^",PSJTS="S"+2)
- +3 IF '$TEST
- SET PSJAT=$PIECE(Y(0),"^",PSJTS="S"*4+2)
- +4 if PSJTS'="S"
- QUIT
- +5 FOR Y=1:1:$LENGTH(PSJAT,"-")
- SET Y(1)=$PIECE(PSJAT,"-",Y)
- SET PSJAT(Y(1))=""
- SET Y(2)=$ORDER(^PS(51.15,"ACP",PSJPP,Y(1),0))
- IF Y(2)
- IF $DATA(^PS(51.15,Y(2),0))
- SET PSJAT(Y(1))=$PIECE(^(0),"^",3)
- IF $DATA(PSJW)
- IF $DATA(^(1,PSJW,0))
- IF $PIECE(^(0),"^",2)]""
- SET PSJAT(Y(1))=$PIECE(^(0),"^",2)
- +6 QUIT
- +7 ;
- DW ; week days
- +1 SET SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS"
- SET SDW=X
- SET X=$PIECE(X,"@",2)
- DO ENCHK
- if '$DATA(X)
- QUIT
- +2 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
- +3 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
- +4 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
- +4 ;
- ENSNV ; schedule name
- +1 IF $SELECT(X["""":1,$ASCII(X)=45:1,X'?.ANP:1,$LENGTH(X)>20:1,$LENGTH(X)<2:1,1:X?1P.E)
- KILL X
- QUIT
- +2 IF $SELECT('$DATA(PSJPP):0,PSJPP="":1,PSJPP'?.ANP:1,1:'$$VERSION^XPDUTL(PSJPP))
- KILL X
- +3 IF $DATA(DA)
- IF $DATA(^PS(51.1,DA,0))
- IF $PIECE(^(0),"^",5)["D"
- SET ZX=X
- DO DNVX
- if $DATA(X)
- SET X=ZX
- KILL Z1,Z2,Z3,Z4,ZX
- +4 QUIT
- +5 ;
- ENSHV ; shift in 51.1
- +1 IF $SELECT($LENGTH(X)>11:1,$LENGTH(X)<1:1,'$DATA(PSJPP):1,PSJPP="":1,PSJPP'?.ANP:1,1:'$$VERSION^XPDUTL(PSJPP))
- KILL X
- QUIT
- +2 FOR X(1)=1:1:$LENGTH(X,"-")
- SET X(2)=$PIECE(X,"-",X(1))
- IF $SELECT(X(2)="":1,X(2)'?.ANP:1,1:'$DATA(^PS(51.15,"ACP",PSJPP,X(2))))
- KILL X
- QUIT
- +3 KILL X(1),X(2)
- QUIT
- +4 ;
- ENVSST ; shift start/stop times
- +1 IF X'?2N1"-"2N
- IF X'?4N1"-"4N
- KILL X
- QUIT
- +2 FOR X(1)=1,2
- IF $PIECE(X,"-",X(1))>$SELECT($LENGTH($PIECE(X,"-",X(1)))<4:24,1:2400)
- KILL X
- QUIT
- +3 KILL X(1)
- QUIT
- +4 ;
- ENFQD ; frequency default
- +1 NEW X1,X2,Z
- SET Z=$SELECT($DATA(^PS(51.1,DA,0)):$PIECE(^(0),"^"),1:"")
- SET X=""
- +2 SET X=$PIECE(Z,"^",3)
- IF Z]""
- QUIT
- +3 SET Z=DA
- IF $EXTRACT(Z,1,2)="AD"
- QUIT
- +4 IF $EXTRACT(Z,1,3)="BID"!($EXTRACT(Z,1,3)="TID")!($EXTRACT(Z,1,3)="QID")
- SET X=1440/$FIND("BTQ",$EXTRACT(Z))
- QUIT
- +5 IF '$TEST
- if $EXTRACT(Z)="Q"
- SET Z=$EXTRACT(Z,2,99)
- if 'Z
- SET Z="1"_Z
- SET X1=+Z
- SET Z=$PIECE(Z,+Z,2)
- SET X2=0
- if $EXTRACT(Z)="X"
- SET X2=X1
- SET Z=$EXTRACT(Z,2,99)
- IF 'X2
- IF $EXTRACT(Z)="O"
- SET X2=.5
- SET Z=$EXTRACT(Z,2,99)
- +6 SET X=$SELECT(Z["'":1,(Z["D"&(Z'["AD"))!(Z["AM")!(Z["PM")!(Z["HS"&(Z'["THS")):1440,Z["H"&(Z'["TH"):60,Z["AC"!(Z["PC"):480,Z["W":10080,Z["M":40320,1:"")
- if 'X
- QUIT
- if X2
- SET X=X\X2
- if 'X2
- SET X=X*X1
- QUIT
- +7 ;
- ENFREQ ; validate frequency
- +1 if +X'=X!(X>525600)!(X<1)!(X?.E1"."1N.N)
- KILL X
- +2 QUIT
- +3 ;
- DFCHK ; validate dosing check frequency **pss_1_201**
- +1 NEW PSSX1,PSSX2
- SET PSSX1=""
- SET X=$$UP^XLFSTR(X)
- SET PSSX2=$EXTRACT(X,$LENGTH(X))
- +2 ;
- +3 IF $LENGTH(X)>4!($LENGTH(X)<3)
- KILL X
- QUIT
- +4 ;
- +5 IF '+($EXTRACT(X,2))
- KILL X
- QUIT
- +6 IF $LENGTH(X)=4
- SET PSSX1=($EXTRACT(X,2,3))
- IF PSSX1'?.N
- KILL X
- QUIT
- +7 ;
- +8 IF $LENGTH(X)=3
- IF $EXTRACT(X,1)="Q"
- IF PSSX2="L"
- IF $EXTRACT(X,2)'<7
- KILL X
- QUIT
- +9 IF $GET(PSSX1)
- IF $EXTRACT(X,1)="Q"
- IF PSSX2="L"
- IF PSSX1'<7
- KILL X
- QUIT
- +10 IF $GET(PSSX1)
- IF $EXTRACT(X,1)="Q"
- IF PSSX2="W"
- IF PSSX1'<29
- KILL X
- QUIT
- +11 ;
- +12 IF $EXTRACT(X,1)="Q"&(PSSX2="H"!(PSSX2="D")!(PSSX2="W")!(PSSX2="L"))
- QUIT
- +13 IF $EXTRACT(X,1)="X"&(PSSX2="D"!(PSSX2="W")!(PSSX2="L"))
- QUIT
- +14 IF '$TEST
- KILL X
- QUIT
- +15 ;
- HPDCHK ; help prompt with specified formats for the dosing check frequency fields **pss_1_201**
- +1 NEW MSG,PSSHFLG
- SET (MSG,PSSHFLG)=""
- +2 ;
- +3 IF $GET(X)="??"
- SET PSSHFLG=1
- +4 ;
- +5 IF 'PSSHFLG
- Begin DoDot:1
- +6 SET MSG(1)=" The numeric limit is 99, except for the following formats:"
- +7 SET MSG(2)=""
- +8 SET MSG(3)=" Q#W - Maximum 28 weeks allowed"
- +9 SET MSG(4)=" Q#L - Maximum 6 months allowed"
- +10 SET MSG(5)=""
- +11 SET MSG(6)=" Enter '??' to view the available dosing check frequency formats"
- +12 SET MSG(7)=" for this field."
- +13 SET MSG(8)=""
- +14 DO EN^DDIOL(.MSG,"","!")
- End DoDot:1
- QUIT
- +15 QUIT
- +16 ;
- OASCHK ; check the 'D' cross reference to see if duplicates exist **pss_1_201**
- +1 NEW MSG,PSSCNT,PSSD,PSSFLG,PSSDA,PSSDONE,PSSAIEN
- SET (MSG,PSSAIEN)=""
- SET (PSSCNT,PSSD,PSSFLG)=0
- SET PSSDA=$GET(DA)
- SET PSSDONE=$GET(DA(1))
- +2 ;
- +3 IF $GET(X)="@"
- SET PSSD=1
- SET DIR(0)="YAO"
- SET DIR("A")="SURE YOU WANT TO DELETE? "
- DO ^DIR
- +4 IF $GET(Y)=1
- FOR
- SET PSSCNT=$ORDER(^PS(51.1,$GET(DA),5,PSSCNT))
- if PSSCNT=""!(PSSFLG=1)
- QUIT
- Begin DoDot:1
- +5 IF $GET(^PS(51.1,$GET(DA),5,PSSCNT,0))=$PIECE(PSSRN,"//",1)
- SET PSSFLG=1
- SET DIE=DIC
- SET DA(1)=$GET(DA)
- SET DA=PSSCNT
- SET DR=".01///@"
- DO ^DIE
- KILL DIR,X
- +6 SET DA=PSSDA
- SET DA(1)=PSSDONE
- SET PSSRN=$$OASLE^PSSOAS(DA)
- SET DIC("A")="Select OLD SCHEDULE NAME(S): "_$GET(PSSRN)
- End DoDot:1
- +7 IF $GET(PSSD)=1
- KILL X
- QUIT
- +8 IF $LENGTH($GET(X))>20!($LENGTH($GET(X))<2)
- DO EN^DDIOL("Answer must be 2-20 characters in length.","","!")
- KILL X
- QUIT
- +9 ;
- +10 SET X=$$UP^XLFSTR($GET(X))
- +11 ;
- +12 NEW PSSRCHK,PSSRFL,MSG
- SET (PSSRCHK,PSSRFL)=""
- +13 FOR
- SET PSSRCHK=$ORDER(^PS(51.1,"D",PSSRCHK))
- if PSSRCHK']""!($GET(PSSRFL))
- QUIT
- Begin DoDot:1
- +14 IF PSSRCHK=$GET(X)
- SET PSSRFL=1
- FOR
- SET PSSAIEN=$ORDER(^PS(51.1,"D",PSSRCHK,PSSAIEN))
- if PSSAIEN'=""
- QUIT
- End DoDot:1
- +15 IF $GET(PSSRFL)=1
- IF $GET(PSSAIEN)'=$GET(PSSDA)
- KILL X
- Begin DoDot:1
- +16 SET MSG(1)=""
- +17 SET MSG(2)=" Duplicate exists in Old Schedule Name multiple for the entry"
- +18 SET MSG(3)=" "_$PIECE(^PS(51.1,$GET(PSSAIEN),0),U,1)_" ("_$GET(PSSAIEN)_") in the file. Please enter a new name."
- +19 DO EN^DDIOL(.MSG,"","!")
- End DoDot:1
- QUIT
- +20 ;
- +21 NEW PSSMCHK,PSSMFL
- SET PSSMCHK=""
- SET PSSMFL=0
- +22 IF $GET(Y)=-1
- IF $GET(DA)
- FOR
- SET PSSMCHK=$ORDER(^PS(51.1,$GET(DA),5,PSSMCHK))
- if PSSMCHK']""!($GET(PSSMFL))
- QUIT
- Begin DoDot:1
- +23 IF $GET(^PS(51.1,$GET(DA),5,PSSMCHK,0))=$GET(X)
- SET PSSMFL=1
- End DoDot:1
- +24 IF $GET(PSSMFL)=1
- KILL X
- QUIT
- +25 QUIT
- +26 ;
- ENDNV ; day of the week name
- +1 NEW Z1,Z2,Z3,Z4,PSSDASH,PSSTIME,PSSXTIME,PSSTIMCT
- +2 SET X=$SELECT($DATA(^PS(51.1,DA,0)):$PIECE(^(0),"^"),1:"")
- IF X=""
- KILL X
- QUIT
- +3 ;
- DNVX ; validate day of the week name
- +1 SET Z2=1
- SET Z4="-"
- IF X'["-"
- IF X?.E1P.E
- FOR Z1=1:1:$LENGTH(X)
- IF $EXTRACT(X,Z1)?1P
- SET Z4=$EXTRACT(X,Z1)
- QUIT
- +2 FOR Z1=1:1:$LENGTH(X,Z4)
- if 'Z2
- QUIT
- SET Z2=0
- IF $LENGTH($PIECE(X,Z4,Z1))>1
- FOR Z3="MONDAYS","TUESDAYS","WEDNESDAYS","THURSDAYS","FRIDAYS","SATURDAYS","SUNDAYS"
- IF $PIECE(Z3,$PIECE(X,Z4,Z1))=""
- SET Z2=1
- QUIT
- +3 IF Z2=0
- KILL X
- +4 SET PSSXTIME=$PIECE(ZX,"@",2)
- SET PSSDASH=$LENGTH(PSSXTIME,"-")
- +5 FOR PSSTIMCT=1:1:PSSDASH
- SET PSSTIME=$PIECE(PSSXTIME,"-",PSSTIMCT)
- +6 IF $LENGTH(PSSTIME)>4
- KILL X
- +7 IF '$DATA(X)
- SET PSSDOW=1
- +8 if Z2
- SET X="D"
- +9 QUIT
- +10 ;
- ENPSJ ;validate schedule names for PSJ package **pss_1_201**
- +1 NEW A,B,I,PSSCNT,PSSFLG
- SET (PSSFLG,PSSDOW)=0
- +2 ;
- +3 SET X=$$UP^XLFSTR(X)
- +4 IF $GET(X)'=""
- IF +$GET(Y)
- DO OASCHK
- IF $GET(X)=""
- QUIT
- +5 IF $GET(PSSON)'=""
- IF $GET(X)'=$GET(PSSON)
- DO ENOAS(PSSON,X)
- +6 ;
- +7 IF $GET(PSJPP)'="PSJ"
- QUIT
- +8 SET A=$TRANSLATE(X,".","")
- IF A="OTHER"
- KILL X
- QUIT
- +9 ;;>> *149 RJS
- FOR I=1:1:$LENGTH(A," ")
- SET B=$PIECE(A," ",I)
- IF B="QD"!(B="QOD")!(B="HS")!(B="TIW")
- KILL X
- +10 if '$DATA(X)
- QUIT
- +11 SET DOW=0
- SET ZX=X
- SET X=$PIECE(X,"@")
- DO DNVX
- IF $GET(X)=""
- SET X=ZX
- KILL ZX
- +12 IF X="D"
- SET X=ZX
- SET DOW=1
- if X["@"
- DO CHKORD
- IF $DATA(X)
- IF $GET(PSSCNT)>1
- Begin DoDot:1
- +13 NEW MSG
- +14 SET MSG(1)=""
- SET MSG(2)="The day of the week schedule must be in the correct day of week order."
- +15 SET MSG(3)="The correct order is: SU-MO-TU-WE-TH-FR-SA"
- +16 DO EN^DDIOL(.MSG,"","!")
- +17 QUIT
- End DoDot:1
- if '$DATA(X)
- SET X=ZX
- KILL Z1,Z2,Z3,Z4,ZX
- +18 ;
- ENOAS(PSSOLD,PSSX) ; entry for new OLD SCHEDULE NAME(S) into the multiple **pss_1_201**
- +1 NEW PSSMCHK,PSSRCHK,PSSBCHK,PSSCCHK,PSSMFL,PSSRFL,PSSBFL,PSSNNM,PSSDA,MSG
- SET (PSSRCHK,PSSBCHK,MSG)=""
- SET (PSSMCHK,PSSCCHK,PSSMFL,PSSRFL,PSSBFL)=0
- SET PSSNNM=$$UP^XLFSTR($GET(X))
- SET PSSDA=$GET(DA)
- +2 NEW PSSCHK,PSSAIEN,PSSDFL
- SET (PSSCHK,PSSAIEN)=""
- SET PSSDFL=0
- +3 ;
- +4 IF $GET(DA)
- FOR
- SET PSSMCHK=$ORDER(^PS(51.1,$GET(DA),5,PSSMCHK))
- if '+PSSMCHK!($GET(PSSMFL))
- QUIT
- Begin DoDot:1
- +5 IF $GET(^PS(51.1,$GET(DA),5,PSSMCHK,0))=$GET(PSSX)
- SET PSSMFL=1
- End DoDot:1
- +6 IF $GET(PSSMFL)=1
- SET X=$GET(PSSOLD)
- Begin DoDot:1
- +7 SET MSG(1)=""
- +8 SET MSG(2)="A duplicate exists in the OLD SCHEDULE NAME(S) multiple for this entry."
- +9 SET MSG(3)=""
- +10 DO EN^DDIOL(.MSG,"","!")
- End DoDot:1
- QUIT
- +11 ;
- +12 IF $GET(X)'=""
- FOR
- SET PSSCHK=$ORDER(^PS(51.1,"D",PSSCHK))
- if PSSCHK=""!($GET(PSSDFL))
- QUIT
- Begin DoDot:1
- +13 IF $GET(PSSCHK)=$GET(X)
- SET PSSDFL=1
- FOR
- SET PSSAIEN=$ORDER(^PS(51.1,"D",PSSCHK,PSSAIEN))
- if PSSAIEN'=""
- QUIT
- +14 IF $GET(PSSDFL)=1
- SET X=$GET(PSSOLD)
- Begin DoDot:2
- +15 SET MSG(1)=""
- +16 SET MSG(2)="A duplicate exists in the OLD SCHEDULE NAME(S) multiple for the entry"
- +17 SET MSG(3)=$PIECE(^PS(51.1,$GET(PSSAIEN),0),U,1)_" ("_$GET(PSSAIEN)_")."
- +18 SET MSG(4)=""
- +19 DO EN^DDIOL(.MSG,"","!")
- End DoDot:2
- QUIT
- End DoDot:1
- +20 ;
- +21 IF $GET(X)[""""
- FOR
- SET PSSBCHK=$ORDER(^PS(51.1,"B",PSSBCHK))
- if PSSBCHK']""!($GET(PSSBFL))
- QUIT
- Begin DoDot:1
- +22 IF $GET(PSSBCHK)=$GET(PSSOLD)
- SET PSSBFL=1
- End DoDot:1
- +23 ;
- +24 IF $GET(X)'[""""
- FOR
- SET PSSBCHK=$ORDER(^PS(51.1,"B",PSSBCHK))
- if PSSBCHK']""!($GET(PSSBFL))
- QUIT
- Begin DoDot:1
- +25 FOR
- SET PSSCCHK=$ORDER(^PS(51.1,"B",PSSBCHK,PSSCCHK))
- if PSSCCHK']""!($GET(PSSBFL))
- QUIT
- Begin DoDot:2
- +26 IF $GET(PSSBCHK)=$GET(PSSOLD)
- IF $GET(PSSCCHK)'=$GET(DA)
- SET PSSBFL=1
- End DoDot:2
- End DoDot:1
- +27 ;
- +28 FOR
- SET PSSRCHK=$ORDER(^PS(51.1,"D",PSSRCHK))
- if PSSRCHK']""!($GET(PSSRFL))
- QUIT
- Begin DoDot:1
- +29 IF $GET(PSSRCHK)=$GET(PSSOLD)
- SET PSSRFL=1
- End DoDot:1
- +30 IF '$GET(PSSMFL)
- IF '$GET(PSSRFL)
- IF '$GET(PSSBFL)
- IF '$GET(PSSDFL)
- IF $GET(DA)
- IF $GET(X)'=""
- IF $GET(X)'?." "
- KILL DO
- SET X=$GET(PSSON)
- SET DA(1)=$GET(DA)
- SET DIC=DIC_DA(1)_",5,"
- SET DIC(0)="L"
- DO FILE^DICN
- SET X=PSSNNM
- SET DIC="^PS(51.1,"
- +31 ;
- +32 QUIT
- +33 ;
- SCRN ;LOGIC TO SCREEN OUT @ IF NOT DAILY
- +1 SET (PSSFLG,PSSDFLG,PSSTFLG,PSSAFLG)=0
- +2 if X'["@"
- QUIT
- +3 IF $GET(PSSCNT)
- KILL PSSCNT,X
- QUIT
- +4 DO DAYS
- DO TIMECHK
- +5 IF $LENGTH(X)<2!($LENGTH(X)>20)
- DO MSG1
- +6 IF $GET(PSSAFLG)
- DO MSG4
- +7 IF $GET(PSSTFLG)
- DO MSG3
- +8 IF $GET(PSSDFLG)
- DO MSG2
- +9 IF $GET(PSSFLG)
- SET MSG(4)=""
- SET MSG(5)=" "_X
- DO EN^DDIOL(.MSG,"","!")
- KILL MSG
- +10 if $GET(PSSFLG)
- KILL X
- +11 KILL PSSFLG,PSSDFLG,PSSTFLG,PSSAFLG
- +12 QUIT
- +13 ;
- ENPSJT ; Validate schedule type (one-time PRN conflict)
- +1 NEW A,B
- +2 SET A=$$GET1^DIQ(51.1,DA,.01)
- SET B=""
- +3 IF A["PRN"
- IF X'="P"
- Begin DoDot:1
- +4 SET B="Conflict: Schedule Name contains PRN but selected Schedule Type is not PRN."
- +5 KILL X
- End DoDot:1
- +6 IF A'["PRN"
- IF X="P"
- Begin DoDot:1
- +7 SET B="Conflict: Schedule Name does not contain PRN but selected Schedule Type is PRN."
- +8 KILL X
- End DoDot:1
- +9 IF $GET(X)="D"
- IF $GET(PSSDOW)
- Begin DoDot:1
- +10 SET B="Conflict: Schedule Name contains free text but selected Schedule Type is Day of the Week."
- +11 KILL X
- End DoDot:1
- +12 IF $LENGTH(B)>0
- DO EN^DDIOL(.B,"","!")
- QUIT
- +13 SET A=$$GET1^DIQ(51.1,DA,2)
- SET B=""
- +14 QUIT
- +15 ;
- CHKORD ;Check order of days in DOW schedule name
- +1 NEW I,J,L,N,P,W
- +2 SET N=$PIECE(X,"@")
- SET L=0
- SET P=$LENGTH(N,"-")
- SET W="SUNDAYS,MONDAYS,TUESDAYS,WEDNESDAYS,THURSDAYS,FRIDAYS,SATURDAYS"
- SET PSSCNT=0
- +3 FOR I=1:1:P
- FOR J=1:1:7
- IF $PIECE(W,",",J)=$PIECE(N,"-",I)
- if J'>L
- KILL X
- if '$DATA(X)
- QUIT
- if J>L
- SET L=J
- SET PSSCNT=PSSCNT+1
- +4 QUIT
- +5 ;
- RMTIME ;Remove ward times when schedule becomes odd
- +1 NEW R
- +2 SET R=0
- FOR
- SET R=$ORDER(^PS(51.1,D0,1,R))
- if R=""
- QUIT
- KILL ^PS(51.1,D0,1,R)
- +3 QUIT
- DAYS ; check days of week for correct order sequence
- +1 NEW PSSD2,PSSD3,PSSD4,PSSD1,PSSD5,PSSD6,PSSFND
- +2 SET PSSD1=$PIECE(X,"@")
- SET PSSD4=0
- SET PSSD5=$LENGTH(PSSD1,"-")
- SET PSSD6="SU,MO,TU,WE,TH,FR,SA"
- SET PSSFND=0
- +3 FOR PSSD2=1:1:PSSD5
- if '$DATA(PSSD1)
- QUIT
- Begin DoDot:1
- +4 FOR PSSD3=1:1:7
- Begin DoDot:2
- +5 IF $PIECE(PSSD6,",",PSSD3)=$PIECE(PSSD1,"-",PSSD2)
- if PSSD3'>PSSD4
- KILL PSSD1
- if '$DATA(PSSD1)
- QUIT
- SET PSSFND=PSSFND+1
- if PSSD3>PSSD4
- SET PSSD4=PSSD3
- +6 IF $LENGTH($PIECE(PSSD1,"-",PSSD2))>2
- KILL PSSD1
- End DoDot:2
- if '$DATA(PSSD1)
- QUIT
- +7 if PSSFND'=PSSD2
- KILL PSSD1
- End DoDot:1
- +8 IF ('$DATA(PSSD1)!('$DATA(PSSFND)))
- SET PSSDFLG=1
- +9 QUIT
- MSG1 ; max length exceeded message
- +1 SET MSG(1)=""
- SET MSG(2)="The Administration Schedule you entered has "_$LENGTH(X)_" characters."
- +2 SET MSG(3)="Answer must be 2-20 characters in length."
- +3 DO EN^DDIOL(.MSG,"","!")
+4 SET PSSFLG=1
+5 KILL MSG
+6 QUIT
MSG2 ; day of week order squence message
+1 SET MSG(1)=""
SET MSG(2)="The day of the week schedule must be in the correct day of week order."
+2 SET MSG(3)="The correct order is: SU-MO-TU-WE-TH-FR-SA"
+3 DO EN^DDIOL(.MSG,"","!")
+4 SET PSSFLG=1
+5 KILL MSG
+6 QUIT
MSG3 ; time input message
+1 SET MSG(1)=""
SET MSG(2)="The time must be between 0001 - 2400."
+2 SET MSG(3)="A correct time entry would be: 0800-1200-1600 etc."
+3 DO EN^DDIOL(.MSG,"","!")
+4 SET PSSFLG=1
+5 KILL MSG
+6 QUIT
MSG4 ; time sequence message
+1 SET MSG(1)=""
SET MSG(2)="The time must be entered in ascending order."
+2 SET MSG(3)="A correct time entry would be: 0800-1200-1600 etc."
+3 DO EN^DDIOL(.MSG,"","!")
+4 SET PSSFLG=1
+5 KILL MSG
+6 QUIT
TIMECHK ; time validation
+1 NEW PSSXTIME,PSSTLN,PSSLOOP,PSSTCHR,PSSDASH,PSSLEN,PSSTCHK,PSSTIMCT,PSSTIME
+2 IF $LENGTH(X,"@")>2
SET (PSSDFLG,PSSTFLG)=1
QUIT
+3 SET PSSXTIME=$PIECE(X,"@",2)
SET PSSTLN=$LENGTH(PSSXTIME)
SET PSSTFLG=0
SET PSSDASH=$LENGTH(PSSXTIME,"-")
+4 IF PSSXTIME=0
SET PSSTFLG=1
QUIT
+5 FOR PSSTIMCT=1:1:PSSDASH
SET PSSTIME=$PIECE(PSSXTIME,"-",PSSTIMCT)
Begin DoDot:1
+6 SET PSSTCHK(PSSTIMCT)=PSSTIME
SET PSSLEN=$LENGTH(PSSTIME)
+7 IF $LENGTH(PSSTCHK(PSSTIMCT))=2
SET PSSTCHK(PSSTIMCT)=PSSTCHK(PSSTIMCT)_"00"
+8 FOR PSSLOOP=1:1:PSSLEN
Begin DoDot:2
+9 SET PSSTCHR=$EXTRACT(PSSTIME,PSSLOOP)
+10 IF $ASCII(PSSTCHR)<48!($ASCII(PSSTCHR)>57)
SET PSSTFLG=1
End DoDot:2
+11 IF ((PSSTIME<1)!(PSSLEN=1)!(PSSLEN=3)!(PSSLEN>4))
SET PSSTFLG=1
End DoDot:1
+12 FOR PSSTIMCT=1:1:PSSDASH
Begin DoDot:1
+13 IF $GET(PSSTCHK(PSSTIMCT+1))
IF PSSTCHK(PSSTIMCT)>PSSTCHK(PSSTIMCT+1)
SET PSSAFLG=1
+14 IF $LENGTH(PSSTCHK(PSSTIMCT))=4
Begin DoDot:2
+15 IF $EXTRACT(PSSTCHK(PSSTIMCT),1,4)>2400
SET PSSTFLG=1
+16 IF $EXTRACT(PSSTCHK(PSSTIMCT),1,2)<24
Begin DoDot:3
+17 IF $EXTRACT(PSSTCHK(PSSTIMCT),3,4)>59
SET PSSTFLG=1
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT