- PSSGSGUI ;BIR/CML3-SCHEDULE PROCESSOR FOR GUI ONLY ;05/29/98
- ;;1.0;PHARMACY DATA MANAGEMENT;**12,27,38,44,56,59,94,119**;9/30/97;Build 9
- ;
- ; Reference to ^PS(53.1 supported by DBIA #2140
- ; Reference to ^PSIVUTL supported by DBIA #4580
- ; Reference to ^PS(59.6 supported by DBIA #2110
- ; Reference to ^DIC(42 is supported by DBIA# 10039
- ;
- ENA ; entry point for train option
- ;N X S X="PSGSETU" X ^%ZOSF("TEST") I 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^PSSGSH 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
- 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(X,PSSGUIPK) ; validate
- ;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
- I $G(PSSGUIPK)="O" D Q
- .Q:$G(X)=""
- .;*119 Allow multi-word schedules
- .I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>$S(X["PRN":4,1:3))!(X["^")!($L(X)>20)!($L(X)<1) K X Q
- .N PSSUPGUI S X=$$UPPER(X)
- ;I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N")!($E(X,1)=" ") K X Q
- I $TR(X," ")="PRN" S X="PRN"
- S X=$$TRIM^XLFSTR(X,"R"," ")
- I X?.E1L.E S X=$$ENLU^PSSGMI(X)
- ;I X["Q0" K X Q
- ;
- ENOS ; order set entry
- ; NSS
- ; * GUI 27 CHANGES * Check for admin times to be derived from 'base' schedule
- N TMPAT I X["@" S TMPAT=$P(X,"@",2) I TMPAT]"" D
- .I '$D(^PS(51.1,"AC","PSJ",TMPAT)) K TMPAT Q
- .N II I '$$DOW^PSIVUTL($P(X,"@")) K TMPAT Q
- .N WARD I $G(DFN) S WARD=$G(^DPT(DFN,.1)) I WARD]"" D
- ..N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0
- ..S WARD=$O(^PS(59.6,"B",WARD,0))
- .N TMPIEN S TMPIEN=$O(^PS(51.1,"AC","PSJ",TMPAT,0)),TMPAT=$P($G(^PS(51.1,+TMPIEN,0)),"^",2) D
- ..I $G(WARD) I $P($G(^PS(51.1,+TMPIEN,1,WARD,0)),"^",2) S TMPAT=$P($G(^(0)),"^",2)
- I $G(TMPAT) S (PSGS0Y,$P(X,"@",2))=TMPAT,PSGS0XT="D"
- ; * GUI 27 CHANGES END *
- S (PSGS0XT,PSGS0Y,XT,Y)="" ;I X["PRN"!(X="ON CALL")!(X="ONCALL")!(X="ON-CALL")!($D(^PS(51.1,"APPSJ",X))) G Q
- I $L(X)>63!(X?.E1C.E) S OK=0 G Q
- I X["PRN",$$PRNOK^PSSGS0(X) G Q
- I $D(^PS(51.1,"APPSJ",X)) S OK=1 G Q
- I X="PRN" S OK=1 G Q
- I X["PRN" D I OK G Q
- . S OK=0 F I=1:1:2 S A=$P($TR(X," "),"PRN",I) Q:A]""
- . Q:A="" N X S X=A
- . I $D(^PS(51.1,"APPSJ",X)) S OK=1 Q
- . I X?2.4N1"-".E!(X?2.4N) D ENCHK I $D(X) S OK=1 Q
- . D DW I $D(X) S OK=1
- S X0=X I X,X'["X",(X?2.4N1"-".E!(X?2.4N)) D ENCHK S:$D(X) Y=X G Q
- I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I XT]"" G Q
- I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q
- ;D DW G Q
- N TMPSCHX S TMPSCHX=X S TMPX=X D DW I $G(X)]"" K PSJNSS S PSGSCH=X S:'$D(^PS(51.1,"AC","PSJ",$P(TMPSCHX,"@"))) (PSGS0XT,XT)="D" S Y=$P(TMPSCHX,"@",2) G Q
- ;I Y'>0,$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") W:'$D(PSGOES) " (ONCE ONLY)" S Y="",XT="O" G Q
- ;I $G(PSGSCH)=X S PSGS0Y=$G(PSGAT) Q
- K X Q
- ;
- NS I (X="^")!(X="") K X Q
- I Y'>0 S X=X0,Y=""
- I $E(X,1,2)="AD" K X G Q
- I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="QID") S XT=1440/$F("BTQ",$E(X)) G Q
- 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=1,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,Y'>0 K X G Q
- S X=X0 I XT S:X2 XT=XT\X1 I 'X2 S:$E(X,1,2)="QO" XT=XT*2 S XT=XT*X1
- ;
- Q ;
- S PSGS0XT=$S(XT]"":XT,1:""),PSGS0Y=$S(Y:Y,1:"") K QX,SDW,SWD,X0,XT,Z Q
- ;
- 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)) 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,1:X(3)'>$P(X,"-",X(2)-1)) K X Q
- K:$D(X) X(1),X(2),X(3) Q
- ;
- DIC ;
- K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(PSGOES))_"ISZ"_"X",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 DIC("W")=""
- ; Naked reference below refers to global reference ^PS(51.1 stored in variable DIC.
- I $D(PSGST) S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O"""
- D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE Q:Y'>0
- 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)
- S (X,X0)=Y(0,0) S:Y="" Y=$P(Y(0),"^",2) Q
- ;DW ;
- ;S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2)
- ;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)
- ;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
- ;
- DW ;
- 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)
- 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
- ;
- UPPER(PSSUPGUI) ;
- Q $TR(PSSUPGUI,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSGSGUI 5897 printed Feb 18, 2025@23:57:42 Page 2
- PSSGSGUI ;BIR/CML3-SCHEDULE PROCESSOR FOR GUI ONLY ;05/29/98
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**12,27,38,44,56,59,94,119**;9/30/97;Build 9
- +2 ;
- +3 ; Reference to ^PS(53.1 supported by DBIA #2140
- +4 ; Reference to ^PSIVUTL supported by DBIA #4580
- +5 ; Reference to ^PS(59.6 supported by DBIA #2110
- +6 ; Reference to ^DIC(42 is supported by DBIA# 10039
- +7 ;
- ENA ; entry point for train option
- +1 ;N X S X="PSGSETU" X ^%ZOSF("TEST") I D ENCV^PSGSETU Q:$D(XQUIT)
- +2 ;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"
- +3 ;K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q
- +4 QUIT
- +5 ;
- 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(X,PSSGUIPK) ; validate
- +1 ;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
- +2 IF $GET(PSSGUIPK)="O"
- Begin DoDot:1
- +3 if $GET(X)=""
- QUIT
- +4 ;*119 Allow multi-word schedules
- +5 IF X[""""!($ASCII(X)=45)!(X?.E1C.E)!($LENGTH(X," ")>$SELECT(X["PRN":4,1:3))!(X["^")!($LENGTH(X)>20)!($LENGTH(X)<1)
- KILL X
- QUIT
- +6 NEW PSSUPGUI
- SET X=$$UPPER(X)
- End DoDot:1
- QUIT
- +7 ;I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N")!($E(X,1)=" ") K X Q
- +8 IF $TRANSLATE(X," ")="PRN"
- SET X="PRN"
- +9 SET X=$$TRIM^XLFSTR(X,"R"," ")
- +10 IF X?.E1L.E
- SET X=$$ENLU^PSSGMI(X)
- +11 ;I X["Q0" K X Q
- +12 ;
- ENOS ; order set entry
- +1 ; NSS
- +2 ; * GUI 27 CHANGES * Check for admin times to be derived from 'base' schedule
- +3 NEW TMPAT
- IF X["@"
- SET TMPAT=$PIECE(X,"@",2)
- IF TMPAT]""
- Begin DoDot:1
- +4 IF '$DATA(^PS(51.1,"AC","PSJ",TMPAT))
- KILL TMPAT
- QUIT
- +5 NEW II
- IF '$$DOW^PSIVUTL($PIECE(X,"@"))
- KILL TMPAT
- QUIT
- +6 NEW WARD
- IF $GET(DFN)
- SET WARD=$GET(^DPT(DFN,.1))
- IF WARD]""
- Begin DoDot:2
- +7 NEW DIC,X,Y
- SET DIC="^DIC(42,"
- SET DIC(0)="BOXZ"
- SET X=WARD
- DO ^DIC
- SET WARD=+Y
- if WARD=0
- QUIT
- +8 SET WARD=$ORDER(^PS(59.6,"B",WARD,0))
- End DoDot:2
- +9 NEW TMPIEN
- SET TMPIEN=$ORDER(^PS(51.1,"AC","PSJ",TMPAT,0))
- SET TMPAT=$PIECE($GET(^PS(51.1,+TMPIEN,0)),"^",2)
- Begin DoDot:2
- +10 IF $GET(WARD)
- IF $PIECE($GET(^PS(51.1,+TMPIEN,1,WARD,0)),"^",2)
- SET TMPAT=$PIECE($GET(^(0)),"^",2)
- End DoDot:2
- End DoDot:1
- +11 IF $GET(TMPAT)
- SET (PSGS0Y,$PIECE(X,"@",2))=TMPAT
- SET PSGS0XT="D"
- +12 ; * GUI 27 CHANGES END *
- +13 ;I X["PRN"!(X="ON CALL")!(X="ONCALL")!(X="ON-CALL")!($D(^PS(51.1,"APPSJ",X))) G Q
- SET (PSGS0XT,PSGS0Y,XT,Y)=""
- +14 IF $LENGTH(X)>63!(X?.E1C.E)
- SET OK=0
- GOTO Q
- +15 IF X["PRN"
- IF $$PRNOK^PSSGS0(X)
- GOTO Q
- +16 IF $DATA(^PS(51.1,"APPSJ",X))
- SET OK=1
- GOTO Q
- +17 IF X="PRN"
- SET OK=1
- GOTO Q
- +18 IF X["PRN"
- Begin DoDot:1
- +19 SET OK=0
- FOR I=1:1:2
- SET A=$PIECE($TRANSLATE(X," "),"PRN",I)
- if A]""
- QUIT
- +20 if A=""
- QUIT
- NEW X
- SET X=A
- +21 IF $DATA(^PS(51.1,"APPSJ",X))
- SET OK=1
- QUIT
- +22 IF X?2.4N1"-".E!(X?2.4N)
- DO ENCHK
- IF $DATA(X)
- SET OK=1
- QUIT
- +23 DO DW
- IF $DATA(X)
- SET OK=1
- End DoDot:1
- IF OK
- GOTO Q
- +24 SET X0=X
- IF X
- IF X'["X"
- IF (X?2.4N1"-".E!(X?2.4N))
- DO ENCHK
- if $DATA(X)
- SET Y=X
- GOTO Q
- +25 IF $SELECT($DATA(^PS(51.1,"AC","PSJ",X)):1,1:$EXTRACT($ORDER(^(X)),1,$LENGTH(X))=X)
- DO DIC
- IF XT]""
- GOTO Q
- +26 IF X?2.4N1"-".E!(X?2.4N)
- DO ENCHK
- if $DATA(X)
- SET Y=X
- GOTO Q
- +27 ;D DW G Q
- +28 NEW TMPSCHX
- SET TMPSCHX=X
- SET TMPX=X
- DO DW
- IF $GET(X)]""
- KILL PSJNSS
- SET PSGSCH=X
- if '$DATA(^PS(51.1,"AC","PSJ",$PIECE(TMPSCHX,"@")))
- SET (PSGS0XT,XT)="D"
- SET Y=$PIECE(TMPSCHX,"@",2)
- GOTO Q
- +29 ;I Y'>0,$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") W:'$D(PSGOES) " (ONCE ONLY)" S Y="",XT="O" G Q
- +30 ;I $G(PSGSCH)=X S PSGS0Y=$G(PSGAT) Q
- +31 KILL X
- QUIT
- +32 ;
- NS IF (X="^")!(X="")
- KILL X
- QUIT
- +1 IF Y'>0
- SET X=X0
- SET Y=""
- +2 IF $EXTRACT(X,1,2)="AD"
- KILL X
- GOTO Q
- +3 IF $EXTRACT(X,1,3)="BID"!($EXTRACT(X,1,3)="TID")!($EXTRACT(X,1,3)="QID")
- SET XT=1440/$FIND("BTQ",$EXTRACT(X))
- GOTO Q
- +4 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=1
- SET X=$EXTRACT(X,2,99)
- +5 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 Y'>0
- KILL X
- GOTO Q
- +6 SET X=X0
- IF XT
- if X2
- SET XT=XT\X1
- IF 'X2
- if $EXTRACT(X,1,2)="QO"
- SET XT=XT*2
- SET XT=XT*X1
- +7 ;
- Q ;
- +1 SET PSGS0XT=$SELECT(XT]"":XT,1:"")
- SET PSGS0Y=$SELECT(Y:Y,1:"")
- KILL QX,SDW,SWD,X0,XT,Z
- QUIT
- +2 ;
- 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'["-"
- IF X>$EXTRACT(2400,1,X(1))
- 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,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 ;
- +1 KILL DIC
- SET DIC="^PS(51.1,"
- SET DIC(0)=$EXTRACT("E",'$DATA(PSGOES))_"ISZ"_"X"
- 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"
- +2 SET DIC("W")=""
- +3 ; Naked reference below refers to global reference ^PS(51.1 stored in variable DIC.
- +4 IF $DATA(PSGST)
- SET DIC("S")="I $P(^(0),""^"",5)"_$EXTRACT("'",PSGST'="O")_"=""O"""
- +5 DO IX^DIC
- KILL DIC
- if $DATA(DIE)#2
- SET DIC=DIE
- if Y'>0
- QUIT
- +6 SET XT=$SELECT("C"[$PIECE(Y(0),"^",5):$PIECE(Y(0),"^",3),1:$PIECE(Y(0),"^",5))
- SET X=+Y
- SET Y=""
- IF $DATA(PSJPWD)
- IF $DATA(^PS(51.1,X,1,+PSJPWD,0))
- SET Y=$PIECE(^(0),"^",2)
- +7 SET (X,X0)=Y(0,0)
- if Y=""
- SET Y=$PIECE(Y(0),"^",2)
- QUIT
- +8 ;DW ;
- +9 ;S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2)
- +10 ;I X]"" D ENCHK Q:'$D(X)
- +11 ;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
- +12 ;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)
- +13 ;K X(1) S:$D(X) X=SDW Q
- +14 ;DWC I $L(Z)<2 K X Q
- +15 ;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
- +16 ;E K X
- +17 ;Q
- +18 ;
- DW ;
- +1 SET SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS"
- SET SDW=X
- SET X=$PIECE(X,"@",2)
- NEW XABB
- SET XABB=""
- +2 IF X]""
- DO ENCHK
- if '$DATA(X)
- QUIT
- +3 ;I X?.E1P.E,X'["-" 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)="-"
- +4 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
- +5 IF $DATA(X)
- FOR II=1:1:$LENGTH(X,X(1))
- SET XABB=$GET(XABB)_$EXTRACT($PIECE(X,X(1),II),1,2)_"-"
- +6 KILL X(1)
- if $DATA(X)
- SET X=SDW
- IF $GET(X)]""
- IF $TRANSLATE(XABB,"-")]""
- SET X=$EXTRACT($GET(XABB),1,$LENGTH(XABB)-1)
- +7 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 ;
- UPPER(PSSUPGUI) ;
- +1 QUIT $TRANSLATE(PSSUPGUI,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
