- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSGSGUI.m
r613 r623 1 PSSGSGUI ;BIR/CML3-SCHEDULE PROCESSOR FOR GUI ONLY ;05/29/98 2 ;;1.0;PHARMACY DATA MANAGEMENT;**12,27,38,44,56,59,94**;9/30/97;Build 26 3 ; 4 ; Reference to ^PS(53.1 supported by DBIA #2140 5 ; Reference to ^PSIVUTL supported by DBIA #4580 6 ; Reference to ^PS(59.6 supported by DBIA #2110 7 ; Reference to ^DIC(42 is supported by DBIA# 10039 8 ; 9 ENA ; entry point for train option 10 ;N X S X="PSGSETU" X ^%ZOSF("TEST") I D ENCV^PSGSETU Q:$D(XQUIT) 11 ;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" 12 ;K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q 13 Q 14 ; 15 EN3 ; 16 S PSGST=$P($G(^PS(53.1,DA,0)),"^",7) G EN 17 ; 18 EN5 ; 19 S PSGST=$P($G(^PS(55,DA(1),5,DA,0)),"^",7) 20 ; 21 EN(X,PSSGUIPK) ; validate 22 ;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 23 I $G(PSSGUIPK)="O" D Q 24 .Q:$G(X)="" 25 .I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!(X["^")!($L(X)>20)!($L(X)<1) K X Q 26 .N PSSUPGUI S X=$$UPPER(X) 27 ;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 28 I $TR(X," ")="PRN" S X="PRN" 29 S X=$$TRIM^XLFSTR(X,"R"," ") 30 I X?.E1L.E S X=$$ENLU^PSSGMI(X) 31 ;I X["Q0" K X Q 32 ; 33 ENOS ; order set entry 34 ; NSS 35 ; * GUI 27 CHANGES * Check for admin times to be derived from 'base' schedule 36 N TMPAT I X["@" S TMPAT=$P(X,"@",2) I TMPAT]"" D 37 .I '$D(^PS(51.1,"AC","PSJ",TMPAT)) K TMPAT Q 38 .N II I '$$DOW^PSIVUTL($P(X,"@")) K TMPAT Q 39 .N WARD I $G(DFN) S WARD=$G(^DPT(DFN,.1)) I WARD]"" D 40 ..N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0 41 ..S WARD=$O(^PS(59.6,"B",WARD,0)) 42 .N TMPIEN S TMPIEN=$O(^PS(51.1,"AC","PSJ",TMPAT,0)),TMPAT=$P($G(^PS(51.1,+TMPIEN,0)),"^",2) D 43 ..I $G(WARD) I $P($G(^PS(51.1,+TMPIEN,1,WARD,0)),"^",2) S TMPAT=$P($G(^(0)),"^",2) 44 I $G(TMPAT) S (PSGS0Y,$P(X,"@",2))=TMPAT,PSGS0XT="D" 45 ; * GUI 27 CHANGES END * 46 S (PSGS0XT,PSGS0Y,XT,Y)="" ;I X["PRN"!(X="ON CALL")!(X="ONCALL")!(X="ON-CALL")!($D(^PS(51.1,"APPSJ",X))) G Q 47 I $L(X)>63!(X?.E1C.E) S OK=0 G Q 48 I X["PRN",$$PRNOK^PSSGS0(X) G Q 49 I $D(^PS(51.1,"APPSJ",X)) S OK=1 G Q 50 I X="PRN" S OK=1 G Q 51 I X["PRN" D I OK G Q 52 . S OK=0 F I=1:1:2 S A=$P($TR(X," "),"PRN",I) Q:A]"" 53 . Q:A="" N X S X=A 54 . I $D(^PS(51.1,"APPSJ",X)) S OK=1 Q 55 . I X?2.4N1"-".E!(X?2.4N) D ENCHK I $D(X) S OK=1 Q 56 . D DW I $D(X) S OK=1 57 S X0=X I X,X'["X",(X?2.4N1"-".E!(X?2.4N)) D ENCHK S:$D(X) Y=X G Q 58 I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I XT]"" G Q 59 I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q 60 ;D DW G Q 61 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 62 ;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 63 ;I $G(PSGSCH)=X S PSGS0Y=$G(PSGAT) Q 64 K X Q 65 ; 66 NS I (X="^")!(X="") K X Q 67 I Y'>0 S X=X0,Y="" 68 I $E(X,1,2)="AD" K X G Q 69 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 70 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) 71 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 72 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 73 ; 74 Q ; 75 S PSGS0XT=$S(XT]"":XT,1:""),PSGS0Y=$S(Y:Y,1:"") K QX,SDW,SWD,X0,XT,Z Q 76 ; 77 ENCHK ; 78 I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q 79 S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q 80 S X(1)=$L(X(1)) I X'["-",X>$E(2400,1,X(1)) K X Q 81 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 82 K:$D(X) X(1),X(2),X(3) Q 83 ; 84 DIC ; 85 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" 86 S DIC("W")="" 87 ; Naked reference below refers to global reference ^PS(51.1 stored in variable DIC. 88 I $D(PSGST) S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O""" 89 D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE Q:Y'>0 90 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) 91 S (X,X0)=Y(0,0) S:Y="" Y=$P(Y(0),"^",2) Q 92 ;DW ; 93 ;S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) 94 ;I X]"" D ENCHK Q:'$D(X) 95 ;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 96 ;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) 97 ;K X(1) S:$D(X) X=SDW Q 98 ;DWC I $L(Z)<2 K X Q 99 ;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 100 ;E K X 101 ;Q 102 ; 103 DW ; 104 S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB="" 105 I X]"" D ENCHK Q:'$D(X) 106 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 107 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) 108 I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-" 109 K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1) 110 Q 111 DWC I $L(Z)<2 K X Q 112 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 113 E K X 114 Q 115 ; 116 UPPER(PSSUPGUI) ; 117 Q $TR(PSSUPGUI,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 1 PSSGSGUI ;BIR/CML3-SCHEDULE PROCESSOR FOR GUI ONLY ;05/29/98 2 ;;1.0;PHARMACY DATA MANAGEMENT;**12,27,38,44,56,59**;9/30/97 3 ; 4 ;Reference to ^PS(53.1 supported by DBIA #2140 5 ; 6 ENA ; 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 ; 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(X,PSSGUIPK) ; 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(PSSGUIPK)="O" D Q 21 .Q:$G(X)="" 22 .I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L(X)>20)!($L(X)<1) K X Q 23 .N PSSUPGUI S X=$$UPPER(X) 24 ;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 25 I $TR(X," ")="PRN" S X="PRN" 26 S X=$$TRIM^XLFSTR(X,"R"," ") 27 I X?.E1L.E S X=$$ENLU^PSSGMI(X) 28 ;I X["Q0" K X Q 29 ; 30 ENOS ; order set entry 31 ; NSS 32 S (PSGS0XT,PSGS0Y,XT,Y)="" ;I X["PRN"!(X="ON CALL")!(X="ONCALL")!(X="ON-CALL")!($D(^PS(51.1,"APPSJ",X))) G Q 33 I $L(X)>63!(X?.E1C.E) S OK=0 G Q 34 I X["PRN",$$PRNOK^PSSGS0(X) G Q 35 I $D(^PS(51.1,"APPSJ",X)) S OK=1 G Q 36 I X="PRN" S OK=1 G Q 37 I X["PRN" D I OK G Q 38 . S OK=0 F I=1:1:2 S A=$P($TR(X," "),"PRN",I) Q:A]"" 39 . Q:A="" N X S X=A 40 . I $D(^PS(51.1,"APPSJ",X)) S OK=1 Q 41 . I X?2.4N1"-".E!(X?2.4N) D ENCHK I $D(X) S OK=1 Q 42 . D DW I $D(X) S OK=1 43 S X0=X I X,X'["X",(X?2.4N1"-".E!(X?2.4N)) D ENCHK S:$D(X) Y=X G Q 44 I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I XT]"" G Q 45 I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q 46 ;D DW G Q 47 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 48 ;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 49 ;I $G(PSGSCH)=X S PSGS0Y=$G(PSGAT) Q 50 K X Q 51 ; 52 NS I (X="^")!(X="") K X Q 53 I Y'>0 S X=X0,Y="" 54 I $E(X,1,2)="AD" K X G Q 55 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 56 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) 57 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 58 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 59 ; 60 Q ; 61 S PSGS0XT=$S(XT]"":XT,1:""),PSGS0Y=$S(Y:Y,1:"") K QX,SDW,SWD,X0,XT,Z Q 62 ; 63 ENCHK ; 64 I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q 65 S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q 66 S X(1)=$L(X(1)) I X'["-",X>$E(2400,1,X(1)) K X Q 67 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 68 K:$D(X) X(1),X(2),X(3) Q 69 ; 70 DIC ; 71 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" 72 S DIC("W")="" 73 ; Naked reference below refers to global reference ^PS(51.1 stored in variable DIC. 74 I $D(PSGST) S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O""" 75 D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE Q:Y'>0 76 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) 77 S (X,X0)=Y(0,0) S:Y="" Y=$P(Y(0),"^",2) Q 78 ;DW ; 79 ;S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) 80 ;I X]"" D ENCHK Q:'$D(X) 81 ;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 82 ;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) 83 ;K X(1) S:$D(X) X=SDW Q 84 ;DWC I $L(Z)<2 K X Q 85 ;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 86 ;E K X 87 ;Q 88 ; 89 DW ; 90 S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB="" 91 I X]"" D ENCHK Q:'$D(X) 92 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 93 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) 94 I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-" 95 K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1) 96 Q 97 DWC I $L(Z)<2 K X Q 98 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 99 E K X 100 Q 101 ; 102 UPPER(PSSUPGUI) ; 103 Q $TR(PSSUPGUI,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note:
See TracChangeset
for help on using the changeset viewer.