Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGS0.m

    r613 r623  
    1 PSGS0   ;BIR/CML3-SCHEDULE PROCESSOR ;29 Jan 99 / 8:04 AM
    2         ;;5.0; INPATIENT MEDICATIONS ;**12,25,26,50,63,74,83,116,110,111,133,138,174,134**;16 DEC 97;Build 124
    3         ;
    4         ; Reference to ^PS(51.1 is supported by DBIA 2177
    5         ; Reference to ^PS(55   is supported by DBIA 2191
    6         ;
    7 ENA     ; entry point for train option
    8         D ENCV^PSGSETU Q:$D(XQUIT)
    9         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"
    10         K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q
    11         ;
    12 EN3     ;
    13         S PSGST=$P($G(^PS(53.1,DA,0)),"^",7) G EN
    14         ;
    15 EN5     ;
    16         S PSGST=$P($G(^PS(55,DA(1),5,DA,0)),"^",7)
    17         ;
    18 EN      ; validate
    19         K PSGS0Y
    20         I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X)>70)!($L(X)<1) K X Q
    21         S X=$$TRIM^XLFSTR(X,"R"," ")
    22         I X?.E1L.E S X=$$ENLU^PSGMI(X) I '$D(PSGOES) D EN^DDIOL("  ("_X_")")
    23         ;
    24 ENOS    ; order set entry
    25         N X0,Y0,PSJXI,PSJDIC2,TMPAT
    26         I $G(X)="",$G(P(2)),$G(P(3)) S X=$G(P(9))
    27         I $G(X)="" Q
    28         S PSGXT=$G(PSGS0XT),(PSGS0XT,PSGS0Y,XT,Y,PSJNSS)=""
    29         S X0=X I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q
    30         ; * GUI 27 CHANGES * Check for admin times to be derived from 'base' schedule
    31         I X["@" S TMPAT=$P(X,"@",2) I TMPAT]"" D
    32         .I '$D(^PS(51.1,"AC","PSJ",TMPAT)) K TMPAT Q
    33         .I '$$DOW^PSIVUTL($P(X,"@")) K TMPAT Q
    34         .N LYN,ZZND,PSGS0XT,PSGS0Y,X S (PSGS0Y,PSGS0XT,X)=""
    35         .S X=TMPAT D DIC I $G(Y0)>0 S TMPAT=Y0
    36         I $G(TMPAT) S (PSGS0Y,$P(X,"@",2))=TMPAT,PSGS0XT="D"
    37         ; * GUI 27 CHANGES *
    38         I X["PRN",$$PRNOK(X),'$D(^PS(51.1,"AC","PSJ",X)) D  G Q
    39         .I X["@"!$$DOW^PSIVUTL($P(X," PRN")) N DOW D  I $G(DOW) S (Y0,Y,PSGS0Y)=$P($P(X,"@",2)," ")
    40         ..N TMP S TMP=X N X S X=$P(TMP," PRN") D DW I $G(X)]"" S DOW=1
    41         ..I $G(DOW),$G(PSGST)]"" I ",P,R,"'[(","_PSGST_",") S (XT,PSGS0XT)="D"
    42         D DIC I $G(XT)]""!$G(Y0)!($G(X)]""&$G(PSJXI)) D  I $G(X)]"" G:$D(^PS(51.1,"AC","PSJ",X)) Q3 I $P(X,"@")]"" G:$D(^PS(51.1,"AC","PSJ",$P(X,"@"))) Q3
    43         .S PSGS0XT=XT S:$G(Y0) (Y,PSGS0Y)=Y0 S:'PSGS0Y&((PSGS0XT)="D")&(X["@") PSGS0Y=$P(X,"@",2)
    44         .S PSGS0Y=$P(PSGS0Y," ")
    45         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
    46         .S Y=$S(($G(TMPSCHX)["@"):$P(TMPSCHX,"@",2),1:"")
    47         .I Y,(X'["@"),(TMPSCHX["@") S X=TMPSCHX
    48         S X=TMPSCHX
    49         I X'="" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS G Q
    50         ;
    51 NS      I ($G(X)="^")!($G(X)="") K X S Y="" Q
    52         N NS S NS=0,PSJNSS=0
    53         I $G(Y)'>0 S X=X0,Y="",NS=1,PSJNSS=1
    54 Q       ;
    55         S PSGS0XT=$S(XT]"":XT,1:$G(PSGS0XT)),PSGS0Y=$S($G(Y):Y,$G(PSGS0Y):PSGS0Y,1:"") S:PSGS0XT<0 PSGS0XT=""
    56         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)
    57 Q2      K YY
    58         I '$G(PSJNSS),'$G(PSGS0Y),$G(YY) S PSGS0Y=YY
    59         I $G(X)]"",$$SCHREQ^PSJLIVFD(.P) D
    60         .I $$DOW^PSIVUTL(X)!$$PRNOK(X)!$D(^PS(51.1,"AC","PSJ",X)) S PSJNSS=0 Q
    61         .I $G(P(2))&$G(P(3)) D NSSCONT(X,PSGS0XT) S TMPX="" K X
    62         I ($G(PSJNSS)&($G(VALMBCK)'="Q"))!($G(PSJNSS)&$G(PSJLIFNI))!($G(PSJNSS)&$G(PSJTUD)) D
    63         .I $G(P(2))&$G(P(3)) Q
    64         .I ($G(X)]"") I ($G(PSGS0XT)'="D") D NSSCONT(X,PSGS0XT) S TMPX="" K X
    65 Q3      I $G(X)]"" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS
    66         K QX,SDW,SWD,X0,XT,Z Q
    67         ;
    68 NSSCONT(SCH,FREQ)       ;
    69         Q:SCH=""!($G(VALMBCK)]"")!$G(PSGMARSD)!$G(PSIVFN1)
    70         I $G(PSGOES),'$G(NSFF) Q
    71         N PSGS0XT,PSGSCH,DIR,X,Y S PSGSCH=SCH,PSGS0XT=FREQ,PSJNSS=1
    72         D NSSMSG I ($L(PSJNSS)>2),'$G(PSJXI) W !!,PSJNSS,! S PSJNSS=1
    73         S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR
    74         K NSFF Q
    75         ;
    76 NSSMSG  ;
    77         Q:$G(PSJXI)
    78         I '(",O,"[(","_$G(PSGST)_",")),$G(PSJNSS),$G(PSGSCH)]"" D
    79         .S PSJNSS=" WARNING - "_PSGSCH_" is an invalid schedule."
    80         S PSGSCH="",PSGS0XT=""
    81         Q
    82         ;
    83 NSO(FQ) ;
    84         Q:'FQ!(FQ<0)!(",D,O,"[(","_$G(PSGST)_",")) ""
    85         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
    86         . S:(+FRQOUT'=1) FRQOUT=FRQOUT_"s"
    87         Q FRQOUT
    88         ;
    89 ENCHK   ;
    90         I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q
    91         S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q
    92         S X(1)=$L(X(1)) I X'["-"&((X>$E(2400,1,X(1))!($E(X,3,4)>59))) K X Q
    93         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
    94         K:$D(X) X(1),X(2),X(3) Q
    95         ;
    96 DIC     ; Check for schedule's existence in ADMINISTRATION SCHEDULE file (#51.1)
    97         ; Input:   
    98         ;           X = Schedule Name
    99         ;     PSJSLUP = If $G(PSJSLUP), perform interactive fileman lookup (optional).
    100         ;     PSGSFLG = If $G(PSGSFLG), return schedule IEN in PSGSCIEN variable (optional)
    101         ;    PSJLIFNI = Flag indicating a U/D order is being finished as an IV (optional).
    102         ;      PSGOES = If PSGOES=1, IX^DIC is called silently. If PSGOES=2, IX^DIC is not called (optional).
    103         ;      PSJPWD = IEN of Inpatient Ward associated with the patient/order/schedule combination (optional).
    104         ; Output:
    105         ;           X = Schedule Name if valid Input Schedule X, undefined if invalid Input Schedule X.
    106         ;     PSGS0XT = Frequency of validated schedule.
    107         ;     PSGS0Y  = Default Admin Times of validated schedule.
    108         ;    PSGSCIEN = IEN of validated schedule, if PSGSLFG is passed in and is evaluated to TRUE.
    109         ;     
    110         ;
    111         K Y0,PSJXI N Y
    112         S Z=0 F PSJXI=0:1 S Z=$O(^PS(51.1,"AC","PSJ",X,Z)) Q:'Z
    113         I $G(X)]"",'$G(PSJSLUP) D
    114         .I $D(^PS(51.1,"AC","PSJ",X)) D  Q:$G(PSGS0Y)&($G(PSGS0XT)]"")
    115         ..I $$DOW^PSIVUTL(X) S PSGS0XT="D",PSJNSS=0 S:X["@" (Y0,PSGS0Y)=$P(X,"@",2) Q
    116         ..I $G(NSFF) S Y0=$S($G(PSGS0Y):PSGS0Y,$G(PSGAT)&'$G(PSJNEWOE):PSGAT,1:"") S:Y0 PSGS0Y=Y0
    117         .; Check for duplicate schedules - force selection
    118         .Q:PSJXI>1&('$G(PSGOES))&($G(PSGS0XT)]"")
    119         .I $D(^PS(51.1,"AC","PSJ",X)) N FREQ,ADMATCH S FREQ=$G(PSGS0XT) D
    120         ..N PSGS0XT,PSGS0Y,PSGST D ADMIN^PSJORPOE S:$G(PSGS0XT) XT=PSGS0XT S:$G(PSGS0Y) (Y0,Y)=PSGS0Y
    121         ..;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
    122         .S:$G(XT)]"" PSGS0XT=XT S:$G(Y) PSGS0Y=Y
    123         .I $$DOW^PSIVUTL(X) S:PSGS0XT="" (XT,PSGS0XT)="D" S:PSGS0Y="" (Y0,PSGS0Y)=$S($P(X,"@",2):$P(X,"@",2),1:"")
    124         I $G(PSJLIFNI)!($G(P(4))]""&($G(P(2))]"")) I '$D(^PS(51.1,"AC","PSJ",X))!($G(PSJXI)>1) S PSJSLUP=1
    125         I $G(NSFF),$G(PSJXI)>1 D
    126         .I $G(PSGS0XT)="",$G(NSFF),$G(PSGXT)]"" S PSGS0XT=PSGXT Q
    127         .I $G(PSGS0XT)=""!($G(PSGS0Y)="") S PSJSLUP=1
    128         I '$G(PSJSLUP) Q:$G(PSGS0XT)]""&($G(PSGS0Y)]"")  Q:($G(PSGS0XT)="D"&('$D(^PS(51.1,"AC","PSJ",X))))
    129         Q:$G(PSGOES)=2
    130         Q:$G(PSGS0XT)]""&(PSJXI=1)
    131         K PSJSLUP
    132         ;
    133         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"
    134         I $D(PSGST) ;S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O"""
    135         S PSJDIC2=1
    136         D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D  Q
    137         .I '$$DOW^PSIVUTL(X),'$$PRNOK(X) S X="",PSJNSS=1,XT="",PSJXI=""
    138         S XT=$S("C"[$P(Y(0),"^",5):$P(Y(0),"^",3),1:$P(Y(0),"^",5))
    139         S X=+Y,Y="" I $D(PSJPWD),$D(^PS(51.1,+X,1,+PSJPWD,0)) S Y=$P(^(0),"^",2)
    140         ;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
    141         I $G(PSGSFLG) S PSGSCIEN=X
    142         S (X,X0)=Y(0,0) S:$G(Y)="" Y=$P(Y(0),"^",2)
    143         S (PSGS0Y,Y0)=$G(Y),Y0(0)=Y(0) I $P(Y(0),"^",3) S XT=$P(Y(0),"^",3)
    144         I $G(PSGS0XT)="",$$DOW^PSIVUTL(X) S (XT,PSGS0XT)="D"
    145         Q
    146         ;
    147 DW      ;
    148         N Y
    149         Q:($L(X,"@")>2)
    150         N AT I X["@" S AT=$P(X,"@",2)
    151         S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB=""
    152         I X]"" D ENCHK Q:'$D(X)
    153         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
    154         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)
    155         I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-"
    156         K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1)
    157         I $G(AT) S PSGS0Y=AT
    158         Q
    159 DWC     I $L(Z)<2 K X Q
    160         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
    161         E  K X
    162         Q
    163         ;
    164 PRNOK(PSCH)     ;
    165         Q:PSCH'["PRN" 0
    166         I $TR(PSCH," ")="PRN" Q 1
    167         N BASE,I,OK S OK=0 S I=$P(PSCH," PRN") I I]"",$D(^PS(51.1,"AC","PSJ",I)) S OK=1
    168         I 'OK D
    169         .I PSCH["@" I $D(^PS(51.1,"AC","PSJ",$P(PSCH,"@")))!$$DOW^PSIVUTL($P(PSCH,"@")) S OK=1 Q
    170         .I $$DOW^PSIVUTL($P(PSCH," PRN")) S OK=1
    171         Q OK
    172 ODD(PSF)        ;determine if this is an odd schedule
    173         I PSF>1439,PSF#1440 Q 1
    174         I PSF,PSF<1440,1440#PSF Q 1
    175         Q 0
     1PSGS0 ;BIR/CML3-SCHEDULE PROCESSOR ;29 Jan 99 / 8:04 AM
     2 ;;5.0; INPATIENT MEDICATIONS ;**12,25,26,50,63,74,83,116,110,111,133,138,174**;16 DEC 97
     3 ;
     4 ; Reference to ^PS(51.1 is supported by DBIA 2177
     5 ; Reference to ^PS(55   is supported by DBIA 2191
     6 ;
     7ENA ; entry point for train option
     8 D ENCV^PSGSETU Q:$D(XQUIT)
     9 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"
     10 K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT 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 ; validate
     19 K PSGS0Y
     20 I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X)>70)!($L(X)<1) K X Q
     21 S X=$$TRIM^XLFSTR(X,"R"," ")
     22 I X?.E1L.E S X=$$ENLU^PSGMI(X) I '$D(PSGOES) D EN^DDIOL("  ("_X_")")
     23 ;
     24ENOS ; order set entry
     25 N X0,Y0,PSJXI,PSJDIC2
     26 I $G(X)="",$G(P(2)),$G(P(3)) S X=$G(P(9))
     27 I $G(X)="" Q
     28 S PSGXT=$G(PSGS0XT),(PSGS0XT,PSGS0Y,XT,Y,PSJNSS)=""
     29 S X0=X I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q
     30 I X["PRN",$$PRNOK(X),'$D(^PS(51.1,"AC","PSJ",X)) D  G Q
     31 .I X["@"!$$DOW^PSIVUTL($P(X," PRN")) N DOW D  I $G(DOW) S (Y0,Y,PSGS0Y)=$P($P(X,"@",2)," ")
     32 ..N TMP S TMP=X N X S X=$P(TMP," PRN") D DW I $G(X)]"" S DOW=1
     33 ..I $G(DOW),$G(PSGST)]"" I ",P,R,"'[(","_PSGST_",") S (XT,PSGS0XT)="D"
     34 D DIC I $G(XT)]""!$G(Y0)!($G(X)]""&$G(PSJXI)) D  I $G(X)]"" G:$D(^PS(51.1,"AC","PSJ",X)) Q3 I $P(X,"@")]"" G:$D(^PS(51.1,"AC","PSJ",$P(X,"@"))) Q3
     35 .S PSGS0XT=XT S:$G(Y0) (Y,PSGS0Y)=Y0 S:'PSGS0Y&((PSGS0XT)="D")&(X["@") PSGS0Y=$P(X,"@",2)
     36 .S PSGS0Y=$P(PSGS0Y," ")
     37 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
     38 .S Y=$S(($G(TMPSCHX)["@"):$P(TMPSCHX,"@",2),1:"")
     39 .I Y,(X'["@"),(TMPSCHX["@") S X=TMPSCHX
     40 S X=TMPSCHX
     41 I X'="" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS G Q
     42 ;
     43NS I ($G(X)="^")!($G(X)="") K X S Y="" Q
     44 N NS S NS=0,PSJNSS=0
     45 I $G(Y)'>0 S X=X0,Y="",NS=1,PSJNSS=1
     46Q ;
     47 S PSGS0XT=$S(XT]"":XT,1:$G(PSGS0XT)),PSGS0Y=$S($G(Y):Y,$G(PSGS0Y):PSGS0Y,1:"") S:PSGS0XT<0 PSGS0XT=""
     48 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)
     49Q2 K YY
     50 I '$G(PSJNSS),'$G(PSGS0Y),$G(YY) S PSGS0Y=YY
     51 I $G(X)]"",$$SCHREQ^PSJLIVFD(.P) D
     52 .I $$DOW^PSIVUTL(X)!$$PRNOK(X)!$D(^PS(51.1,"AC","PSJ",X)) S PSJNSS=0 Q
     53 .I $G(P(2))&$G(P(3)) D NSSCONT(X,PSGS0XT) S TMPX="" K X
     54 I ($G(PSJNSS)&($G(VALMBCK)'="Q"))!($G(PSJNSS)&$G(PSJLIFNI))!($G(PSJNSS)&$G(PSJTUD)) D
     55 .I $G(P(2))&$G(P(3)) Q
     56 .I ($G(X)]"") I ($G(PSGS0XT)'="D") D NSSCONT(X,PSGS0XT) S TMPX="" K X
     57Q3 I $G(X)]"" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS
     58 K QX,SDW,SWD,X0,XT,Z Q
     59 ;
     60NSSCONT(SCH,FREQ) ;
     61 Q:SCH=""!($G(VALMBCK)]"")!$G(PSGMARSD)!$G(PSIVFN1)
     62 I $G(PSGOES),'$G(NSFF) Q
     63 N PSGS0XT,PSGSCH,DIR,X,Y S PSGSCH=SCH,PSGS0XT=FREQ,PSJNSS=1
     64 D NSSMSG I ($L(PSJNSS)>2),'$G(PSJXI) W !!,PSJNSS,! S PSJNSS=1
     65 S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR
     66 K NSFF Q
     67 ;
     68NSSMSG ;
     69 Q:$G(PSJXI)
     70 I '(",O,"[(","_$G(PSGST)_",")),$G(PSJNSS),$G(PSGSCH)]"" D
     71 .S PSJNSS=" WARNING - "_PSGSCH_" is an invalid schedule."
     72 S PSGSCH="",PSGS0XT=""
     73 Q
     74 ;
     75NSO(FQ) ;
     76 Q:'FQ!(FQ<0)!(",D,O,"[(","_$G(PSGST)_",")) ""
     77 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
     78 . S:(+FRQOUT'=1) FRQOUT=FRQOUT_"s"
     79 Q FRQOUT
     80 ;
     81ENCHK ;
     82 I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q
     83 S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q
     84 S X(1)=$L(X(1)) I X'["-"&((X>$E(2400,1,X(1))!($E(X,3,4)>59))) K X Q
     85 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
     86 K:$D(X) X(1),X(2),X(3) Q
     87 ;
     88DIC ;
     89 K Y0,PSJXI N Y
     90 S Z=0 F PSJXI=0:1 S Z=$O(^PS(51.1,"AC","PSJ",X,Z)) Q:'Z
     91 I $G(X)]"",'$G(PSJSLUP) D
     92 .I $D(^PS(51.1,"AC","PSJ",X)) D  Q:$G(PSGS0Y)&($G(PSGS0XT)]"")
     93 ..I $$DOW^PSIVUTL(X) S PSGS0XT="D",PSJNSS=0 S:X["@" (Y0,PSGS0Y)=$P(X,"@",2) Q
     94 ..I $G(NSFF) S Y0=$S($G(PSGS0Y):PSGS0Y,$G(PSGAT)&'$G(PSJNEWOE):PSGAT,1:"") S:Y0 PSGS0Y=Y0
     95 .; Check for duplicate schedules - force selection
     96 .Q:PSJXI>1&('$G(PSGOES))&($G(PSGS0XT)]"")
     97 .I $D(^PS(51.1,"AC","PSJ",X)) N FREQ,ADMATCH S FREQ=PSGS0XT D
     98 ..N PSGS0XT,PSGS0Y,PSGST D ADMIN^PSJORPOE S:$G(PSGS0XT) XT=PSGS0XT S:$G(PSGS0Y) (Y0,Y)=PSGS0Y
     99 .S:$G(XT)]"" PSGS0XT=XT S:$G(Y) PSGS0Y=Y
     100 .I $$DOW^PSIVUTL(X) S:PSGS0XT="" (XT,PSGS0XT)="D" S:PSGS0Y="" (Y0,PSGS0Y)=$S($P(X,"@",2):$P(X,"@",2),1:"")
     101 I $G(PSJLIFNI)!($G(P(4))]""&($G(P(2))]"")) I '$D(^PS(51.1,"AC","PSJ",X))!($G(PSJXI)>1) S PSJSLUP=1
     102 I $G(NSFF),$G(PSJXI)>1 D
     103 .I $G(PSGS0XT)="",$G(NSFF),$G(PSGXT)]"" S PSGS0XT=PSGXT Q
     104 .I $G(PSGS0XT)=""!($G(PSGS0Y)="") S PSJSLUP=1
     105 I '$G(PSJSLUP) Q:$G(PSGS0XT)]""&($G(PSGS0Y)]"")  Q:($G(PSGS0XT)="D"&('$D(^PS(51.1,"AC","PSJ",X))))
     106 Q:$G(PSGOES)=2
     107 Q:$G(PSGS0XT)]""&(PSJXI=1)
     108 K PSJSLUP
     109 ;
     110 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"
     111 I $D(PSGST) ;S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O"""
     112 S PSJDIC2=1
     113 D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D  Q
     114 .I '$$DOW^PSIVUTL(X),'$$PRNOK(X) S X="",PSJNSS=1,XT="",PSJXI=""
     115 S XT=$S("C"[$P(Y(0),"^",5):$P(Y(0),"^",3),1:$P(Y(0),"^",5))
     116 S X=+Y,Y="" I $D(PSJPWD),$D(^PS(51.1,+X,1,+PSJPWD,0)) S Y=$P(^(0),"^",2)
     117 S (X,X0)=Y(0,0) S:$G(Y)="" Y=$P(Y(0),"^",2)
     118 S (PSGS0Y,Y0)=$G(Y),Y0(0)=Y(0) I $P(Y(0),"^",3) S XT=$P(Y(0),"^",3)
     119 I $G(PSGS0XT)="",$$DOW^PSIVUTL(X) S (XT,PSGS0XT)="D"
     120 Q
     121 ;
     122DW ;
     123 N Y
     124 Q:($L(X,"@")>2)
     125 N AT I X["@" S AT=$P(X,"@",2)
     126 S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB=""
     127 I X]"" D ENCHK Q:'$D(X)
     128 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
     129 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)
     130 I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-"
     131 K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1)
     132 I $G(AT) S PSGS0Y=AT
     133 Q
     134DWC I $L(Z)<2 K X Q
     135 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
     136 E  K X
     137 Q
     138 ;
     139PRNOK(PSCH) ;
     140 Q:PSCH'["PRN" 0
     141 I $TR(PSCH," ")="PRN" Q 1
     142 N BASE,I,OK S OK=0 S I=$P(PSCH," PRN") I I]"",$D(^PS(51.1,"AC","PSJ",I)) S OK=1
     143 I 'OK D
     144 .I PSCH["@" I $D(^PS(51.1,"AC","PSJ",$P(PSCH,"@")))!$$DOW^PSIVUTL($P(PSCH,"@")) S OK=1 Q
     145 .I $$DOW^PSIVUTL($P(PSCH," PRN")) S OK=1
     146 Q OK
     147ODD(PSF) ;determine if this is an odd schedule
     148 I PSF>1439,PSF#1440 Q 1
     149 I PSF,PSF<1440,1440#PSF Q 1
     150 Q 0
Note: See TracChangeset for help on using the changeset viewer.