source: WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSGS0.m@ 775

Last change on this file since 775 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
RevLine 
[613]1PSSGS0 ;BIR/CML3-SCHEDULE PROCESSOR ;06/01/98
2 ;;1.0;PHARMACY DATA MANAGEMENT;**12,27,38,44,56,69,59**;9/30/97
3 ;Reference to $$TRIM^XLFSTR supported by DBIA #10104
4 ;Reference to ^PS(53.1 supported by DBIA #2140
5 ;
6ENA ; entry point for train option
7 ;N X S X="PSGSETU" X ^%ZOSF("TEST") I D ENCV^PSGSETU Q:$D(XQUIT)
8 ;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"
9 ;K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q
10 Q
11 ;
12EN3 ;
13 S PSGST=$P($G(^PS(53.1,DA,0)),"^",7) G EN
14 ;
15EN5 ;
16 S PSGST=$P($G(^PS(55,DA(1),5,DA,0)),"^",7)
17 ;
18EN(X,PSSLSTPK) ; validate
19 ;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
20 I $G(PSSLSTPK)="O"!(PSSLSTPK="X") Q:$G(X)="" G ENOP
21 I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L(X)>70)!($L(X)<1) K X Q
22 S X=$$TRIM^XLFSTR(X,"R"," ")
23 I X?.E1L.E S X=$$ENLU^PSSGMI(X)
24 ;
25ENOS ; order set entry
26 S (PSGS0XT,PSGS0Y,XT,Y)=""
27 I X="OTHER" G Q
28 I X["PRN",$$PRNOK(X) G Q
29 S X0=X I X,X'["X",(X?2.4N1"-".E!(X?2.4N)) D ENCHK S:$D(X) Y=X G Q
30 I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I XT]"" G Q
31 I X["@" D DW S:$D(X) Y=$P(X,"@",2) G Q
32 I $G(PSGSCH)=X S PSGS0Y=$G(PSGAT) Q
33 K X Q
34 ;
35NS I (X="^")!(X="") K X Q
36 I Y'>0 S X=X0,Y=""
37Q ;
38 S PSGS0XT=$S(XT]"":XT,1:""),PSGS0Y=$S(Y:Y,1:"") K QX,SDW,SWD,X0,XT,Z Q
39 ;
40ENCHK ;
41 I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q
42 S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q
43 S X(1)=$L(X(1)) I X'["-",X>$E(2400,1,X(1)) K X Q
44 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
45 K:$D(X) X(1),X(2),X(3) Q
46 ;
47ENOP ;
48 I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L(X)>20)!($L(X)<1) K X Q
49 N PSSUPPER S X=$$UPPER(X)
50 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
51 K Y,DIC S DIC=51,DIC(0)="ME" D ^DIC I Y>0 S X=$P(Y,"^",2)
52 Q
53DIC ;
54 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"
55 S DIC("W")=""
56 I $D(PSGST) S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O"""
57 D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE Q:Y'>0
58 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)
59 S (X,X0)=Y(0,0) S:Y="" Y=$P(Y(0),"^",2) Q
60DW ;
61 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
62 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)
63 K X(1) S:$D(X) X=SDW Q
64DWC I $L(Z)<2 K X Q
65 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
66 E K X
67 Q
68 ;
69UPPER(PSSUPPER) ;
70 Q $TR(PSSUPPER,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
71DICW ;
72 S Z=^PS(51.1,+Y,0) W $P(Z,"^",8) Q
73PRNOK(PSCH) ;
74 Q:PSCH'["PRN" 0
75 I $TR(PSCH," ")="PRN" Q 1
76 N BASE,I,OK S OK=0 S I=$P(PSCH," PRN") I I]"",$D(^PS(51.1,"AC","PSJ",I)) S OK=1
77 I 'OK D
78 .I PSCH["@" I $D(^PS(51.1,"AC","PSJ",$P(PSCH,"@")))!$$DOW^PSIVUTL($P(PSCH,"@")) S OK=1 Q
79 .I $$DOW^PSIVUTL($TR(PSCH," PRN")) S OK=1
80 Q OK
Note: See TracBrowser for help on using the repository browser.