Changeset 623 for WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS
- Files:
-
- 15 edited
-
PSS51P1.m (modified) (1 diff)
-
PSS51P2.m (modified) (1 diff)
-
PSSDDUT2.m (modified) (1 diff)
-
PSSGSGUI.m (modified) (1 diff)
-
PSSHLU.m (modified) (1 diff)
-
PSSJORDF.m (modified) (1 diff)
-
PSSMARK.m (modified) (1 diff)
-
PSSQOC.m (modified) (1 diff)
-
PSSVX6.m (modified) (1 diff)
-
PSSVX61.m (modified) (1 diff)
-
PSSVX62.m (modified) (1 diff)
-
PSSVX63.m (modified) (1 diff)
-
PSSVX64.m (modified) (1 diff)
-
PSSVX65.m (modified) (1 diff)
-
PSSVX66.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSS51P1.m
r613 r623 1 PSS51P1 ;BIR/LDT - API FOR INFORMATION FROM FILE 51.1 ;5 Sep 03 2 ;;1.0;PHARMACY DATA MANAGEMENT;**85,91,108,118,94**;9/30/97;Build 26 3 ; 4 ZERO(PSSIEN,PSSFT,PSSPP,PSSTSCH,LIST) ; 5 ;PSSIEN - IEN of entry in ADMINISTRATION SCHEDULE file (#51.1). 6 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 7 ;PSSPP - PACKAGE PREFIX field (#4) in ADMINISTRATION SCHEDULE file (#51.1). Screens for Administration 8 ;Schedules for the Package Prefix passed. 9 ;PSSTSCH - TYPE OF SCHEDULE field (#5) of ADMINISTRATION SCHEDULE file (#51.1). Screens for 10 ; One-time "O" if PSSTSCH passed in. 11 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 12 ; Field Number of the data piece being returned. 13 ;Returns NAME field (#.01), STANDARD ADMINISTRATION TIMES field (#1), FREQUENCY (IN MINUTES) field (#2), 14 ;MAXIMUM DAYS FOR ORDERS field (#2.5), PACKAGE PREFIX field (#4), TYPE OF SCHEDULE field (#5), 15 ;STANDARD SHIFTS field (#6), OUTPATIENT EXPANSION field (#8), and OTHER LANGUAGE EXPANSIONS field (#8.1) 16 ;of ADMINISTRATION SCHEDULE file (#51.1). 17 N DIERR,ZZERR,PSS51P1,SCR,PSS 18 I $G(LIST)']"" Q 19 K ^TMP($J,LIST) 20 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 21 I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 22 I $G(PSSTSCH)]"",PSSTSCH'="O" S PSSTSCH="" 23 S SCR("S")="" I $G(PSSTSCH)]""!$G(PSSPP)]"" D SETSCR 24 I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(51.1,"","A","`"_PSSIEN,"B",SCR("S"),"") D 25 .I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 26 .S ^TMP($J,LIST,0)=1 27 .D GETS^DIQ(51.1,+PSSIEN2,".01;1;2;4;5;6;2.5;8;8.1","IE","PSS51P1") S PSS(1)=0 28 .F S PSS(1)=$O(PSS51P1(51.1,PSS(1))) Q:'PSS(1) D SETZRO^PSS51P1B 29 I +$G(PSSIEN)'>0,$G(PSSFT)]"" D 30 .I PSSFT["??" D LOOP^PSS51P1B(1) Q 31 .D FIND^DIC(51.1,,"@;.01;1","QP",PSSFT,,"B",SCR("S"),,"") 32 .I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 33 .I +^TMP("DILIST",$J,0)>0 S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D 34 ..S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) K PSS51P1 D GETS^DIQ(51.1,+PSSIEN,".01;1;2;4;5;6;2.5;8;8.1","IE","PSS51P1") S PSS(1)=0 35 ..F S PSS(1)=$O(PSS51P1(51.1,PSS(1))) Q:'PSS(1) D SETZRO^PSS51P1B 36 K ^TMP("DILIST",$J) 37 Q 38 ; 39 WARD(PSSIEN,PSSFT,PSSIEN2,LIST) ; 40 ;PSSIEN - IEN of entry in ADMINISTRATION SCHEDULE file (#51.1). 41 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 42 ;PSSIEN2 - IEN of entry in WARD sub-file (#51.11) 43 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 44 ; Field Number of the data piece being returned. 45 ;Returns NAME field (#.01), WARD multiple (#51.11) WARD field (#.01), and WARD ADMINISTRATION TIMES field (#1) 46 ;of ADMINISTRATION SCHEDULE file (#51.1). 47 N DIERR,ZZERR,PSS51P1,PSS,CNT 48 S CNT=0 49 I $G(LIST)']"" Q 50 K ^TMP($J,LIST) 51 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 52 I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 53 I $G(PSSIEN2)]"",+$G(PSSIEN2)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 54 D WARD^PSS51P1C 55 Q 56 ; 57 HOSP(PSSIEN,PSSFT,LIST) ; 58 ;PSSIEN - IEN of entry in ADMINISTRATION SCHEDULE file (#51.1). 59 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 60 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 61 ; Field Number of the data piece being returned. 62 ;Returns NAME field (#.01), HOSPITAL LOCATION multiple (#51.17) HOSPITAL LOCATION field (#.01), ADMINISTRATION TIMES field (#1), 63 ;and SHIFTS field (#2) of ADMINISTRATION SCHEDULE file (#51.1). 64 N DIERR,ZZERR,PSS51P1,SCR,PSS,CNT 65 I $G(LIST)']"" Q 66 D HOSP^PSS51P1A 67 Q 68 ; 69 IEN(PSSFT,LIST) ; 70 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 71 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 72 ; Field Number of the data piece being returned. 73 ;Returns NAME field (#.01) and STANDARD ADMINISTRATION TIMES field (#1) of ADMINISTRATION SCHEDULE file (#51.1). 74 N DIERR,ZZERR,PSS51P1,SCR,PSS 75 I $G(LIST)']"" Q 76 K ^TMP($J,LIST) 77 I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 78 D IEN^PSS51P1A 79 Q 80 ; 81 AP(PSSPP,PSSFT,PSSWDIEN,PSSTYP,LIST,PSSFREQ) ; 82 ;PSSPP - PACKAGE PREFIX in ADMINISTRATION SCHEDULE file (#51.1). 83 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 84 ;PSSWDIEN - IEN of entry of WARD multiple in ADMINISTRATION SCHEDULE file (#51.1). 85 ;PSSSTYP - TYPE OF SCHEDULE field (#5) in ADMINISTRATION SCHEDULE file (#51.1). 86 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 87 ; Field Number of the data piece being returned. 88 ;Returns NAME field (#.01), STANDARD ADMINISTRATION TIMES field (#1), and PACKAGE PREFIX field (#4) 89 ;of ADMINISTRATION SCHEDULE file (#51.1). 90 ;If PSSWDIEN is passed in then the WARD multiple (#51.11) WARD field (#.01), and WARD ADMINISTRATION TIMES field (#1) 91 ;of ADMINISTRATION SCHEDULE file (#51.1) is returned. 92 N DIERR,ZZERR,PSS51P1,SCR,PSS,PSSIEN,PSSVAL,PSSTMP 93 I $G(PSSFREQ)']"" S PSSFREQ="" 94 I $G(LIST)']"" Q 95 D AP^PSS51P1A 96 Q 97 ; 98 IX(PSSFT,PSSPP,LIST) ; 99 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 100 ;PSSPP - PACKAGE PREFIX in ADMINISTRATION SCHEDULE file (#51.1). 101 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 102 ; Field Number of the data piece being returned. 103 ;Returns NAME field (#.01), STANDARD ADMINISTRATION TIMES field (#1), FREQUENCY (IN MINUTES) field (#2), 104 ;MAXIMUM DAYS FOR ORDERS field (#2.5),PACKAGE PREFIX field (#4), TYPE OF SCHEDULE field (#5), STANDARD 105 ;SHIFTS field (#6), OUTPATIENT EXPANSION field (#8), and OTHER LANGUAGE EXPANSION field (#8.1) of 106 ;ADMINISTRATION SCHEDULE file (#51.1). 107 N DIERR,ZZERR,PSS51P1,PSS 108 I $G(LIST)']"" Q 109 D IX^PSS51P1A 110 Q 111 ; 112 ADM(PSSADM) ; admin times 113 N X S X=PSSADM 114 I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q "^" 115 S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q "^" 116 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 117 I '$D(X) Q "^" 118 K:$D(X) X(1),X(2),X(3) Q PSSADM 119 ; 120 ALL(PSSIEN,PSSFT,LIST) ; 121 ;PSSIEN - IEN of entry in ADMINISTRATION SCHEDULE file (#51.1). 122 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 123 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 124 ; Field Number of the data piece being returned. 125 ;Returns NAME field (#.01), STANDARD ADMINISTRATION TIMES field (#1), FREQUENCY (IN MINUTES) field (#2), 126 ;MAXIMUM DAYS FOR ORDERS field (#2.5), PACKAGE PREFIX field (#4), TYPE OF SCHEDULE field (#5), 127 ;STANDARD SHIFTS field (#6), OUTPATIENT EXPANSION field (#8), OTHER LANGUAGE EXPANSIONS field (#8.1), 128 ; HOSPITAL LOCATION multiple (#51.17) HOSPITAL LOCATION field (#.01), ADMINISTRATION TIMES field (#1), 129 ;SHIFTS field (#2), WARD multiple (#51.11) WARD field (#.01), and WARD ADMINISTRATION TIMES field (#1) 130 ;of ADMINISTRATION SCHEDULE file (#51.1). 131 N DIERR,ZZERR,PSS 132 I $G(LIST)']"" Q 133 K ^TMP($J,LIST) 134 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 135 I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 136 D ALL^PSS51P1C 137 Q 138 ; 139 SETSCR ;Set Screen for One-time schedule type 140 ;Naked reference below refers to ^PS(51.1,+Y,0) 141 I $G(PSSTSCH)]"" S SCR("S")="I $P(^(0),""^"",5)=""O""" 142 ;Naked reference below refers to ^PS(51.1,+Y,0) 143 I $G(PSSPP)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $P(^(0),""^"",4)=PSSPP",1:"I $P(^(0),""^"",4)=PSSPP") 144 Q 145 FREQ(PSSVAL,PSSFREQ) ; VALIDATES FREQUNCY FIELD 146 S PSSTMP=0 147 I PSSVAL>PSSFREQ S PSSTMP=1 148 I PSSVAL<1 S PSSTMP=1 149 I PSSFREQ="" S PSSTMP=0 150 Q PSSTMP 151 PSSDQ ;DQ^DICQ call on 51.1 152 N DIC,D,DZ S DIC="^PS(51.1,",D="B",DIC(0)="EQS",DZ="??" D DQ^DICQ Q 153 ; 154 SCHED(PSSWIEN,PSSARRY) ; 155 I $G(PSSWIEN)="" S PSSWIEN=0 156 D SCHED^PSSSCHED(PSSWIEN,.PSSARRY) Q 1 PSS51P1 ;BIR/LDT - API FOR INFORMATION FROM FILE 51.1 ;5 Sep 03 2 ;;1.0;PHARMACY DATA MANAGEMENT;**85,91,108,118**;9/30/97;Build 8 3 ; 4 ZERO(PSSIEN,PSSFT,PSSPP,PSSTSCH,LIST) ; 5 ;PSSIEN - IEN of entry in ADMINISTRATION SCHEDULE file (#51.1). 6 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 7 ;PSSPP - PACKAGE PREFIX field (#4) in ADMINISTRATION SCHEDULE file (#51.1). Screens for Administration 8 ;Schedules for the Package Prefix passed. 9 ;PSSTSCH - TYPE OF SCHEDULE field (#5) of ADMINISTRATION SCHEDULE file (#51.1). Screens for 10 ; One-time "O" if PSSTSCH passed in. 11 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 12 ; Field Number of the data piece being returned. 13 ;Returns NAME field (#.01), STANDARD ADMINISTRATION TIMES field (#1), FREQUENCY (IN MINUTES) field (#2), 14 ;MAXIMUM DAYS FOR ORDERS field (#2.5), PACKAGE PREFIX field (#4), TYPE OF SCHEDULE field (#5), 15 ;STANDARD SHIFTS field (#6), OUTPATIENT EXPANSION field (#8), and OTHER LANGUAGE EXPANSIONS field (#8.1) 16 ;of ADMINISTRATION SCHEDULE file (#51.1). 17 N DIERR,ZZERR,PSS51P1,SCR,PSS 18 I $G(LIST)']"" Q 19 K ^TMP($J,LIST) 20 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 21 I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 22 I $G(PSSTSCH)]"",PSSTSCH'="O" S PSSTSCH="" 23 S SCR("S")="" I $G(PSSTSCH)]""!$G(PSSPP)]"" D SETSCR 24 I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(51.1,"","A","`"_PSSIEN,"B",SCR("S"),"") D 25 .I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 26 .S ^TMP($J,LIST,0)=1 27 .D GETS^DIQ(51.1,+PSSIEN2,".01;1;2;4;5;6;2.5;8;8.1","IE","PSS51P1") S PSS(1)=0 28 .F S PSS(1)=$O(PSS51P1(51.1,PSS(1))) Q:'PSS(1) D SETZRO^PSS51P1B 29 I +$G(PSSIEN)'>0,$G(PSSFT)]"" D 30 .I PSSFT["??" D LOOP^PSS51P1B(1) Q 31 .D FIND^DIC(51.1,,"@;.01;1","QP",PSSFT,,"B",SCR("S"),,"") 32 .I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 33 .I +^TMP("DILIST",$J,0)>0 S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D 34 ..S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) K PSS51P1 D GETS^DIQ(51.1,+PSSIEN,".01;1;2;4;5;6;2.5;8;8.1","IE","PSS51P1") S PSS(1)=0 35 ..F S PSS(1)=$O(PSS51P1(51.1,PSS(1))) Q:'PSS(1) D SETZRO^PSS51P1B 36 K ^TMP("DILIST",$J) 37 Q 38 ; 39 WARD(PSSIEN,PSSFT,PSSIEN2,LIST) ; 40 ;PSSIEN - IEN of entry in ADMINISTRATION SCHEDULE file (#51.1). 41 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 42 ;PSSIEN2 - IEN of entry in WARD sub-file (#51.11) 43 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 44 ; Field Number of the data piece being returned. 45 ;Returns NAME field (#.01), WARD multiple (#51.11) WARD field (#.01), and WARD ADMINISTRATION TIMES field (#1) 46 ;of ADMINISTRATION SCHEDULE file (#51.1). 47 N DIERR,ZZERR,PSS51P1,PSS,CNT 48 S CNT=0 49 I $G(LIST)']"" Q 50 K ^TMP($J,LIST) 51 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 52 I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 53 I $G(PSSIEN2)]"",+$G(PSSIEN2)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 54 D WARD^PSS51P1C 55 Q 56 ; 57 HOSP(PSSIEN,PSSFT,LIST) ; 58 ;PSSIEN - IEN of entry in ADMINISTRATION SCHEDULE file (#51.1). 59 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 60 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 61 ; Field Number of the data piece being returned. 62 ;Returns NAME field (#.01), HOSPITAL LOCATION multiple (#51.17) HOSPITAL LOCATION field (#.01), ADMINISTRATION TIMES field (#1), 63 ;and SHIFTS field (#2) of ADMINISTRATION SCHEDULE file (#51.1). 64 N DIERR,ZZERR,PSS51P1,SCR,PSS,CNT 65 I $G(LIST)']"" Q 66 D HOSP^PSS51P1A 67 Q 68 ; 69 IEN(PSSFT,LIST) ; 70 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 71 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 72 ; Field Number of the data piece being returned. 73 ;Returns NAME field (#.01) and STANDARD ADMINISTRATION TIMES field (#1) of ADMINISTRATION SCHEDULE file (#51.1). 74 N DIERR,ZZERR,PSS51P1,SCR,PSS 75 I $G(LIST)']"" Q 76 K ^TMP($J,LIST) 77 I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 78 D IEN^PSS51P1A 79 Q 80 ; 81 AP(PSSPP,PSSFT,PSSWDIEN,PSSTYP,LIST,PSSFREQ) ; 82 ;PSSPP - PACKAGE PREFIX in ADMINISTRATION SCHEDULE file (#51.1). 83 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 84 ;PSSWDIEN - IEN of entry of WARD multiple in ADMINISTRATION SCHEDULE file (#51.1). 85 ;PSSSTYP - TYPE OF SCHEDULE field (#5) in ADMINISTRATION SCHEDULE file (#51.1). 86 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 87 ; Field Number of the data piece being returned. 88 ;Returns NAME field (#.01), STANDARD ADMINISTRATION TIMES field (#1), and PACKAGE PREFIX field (#4) 89 ;of ADMINISTRATION SCHEDULE file (#51.1). 90 ;If PSSWDIEN is passed in then the WARD multiple (#51.11) WARD field (#.01), and WARD ADMINISTRATION TIMES field (#1) 91 ;of ADMINISTRATION SCHEDULE file (#51.1) is returned. 92 N DIERR,ZZERR,PSS51P1,SCR,PSS,PSSIEN,PSSVAL,PSSTMP 93 I $G(PSSFREQ)']"" S PSSFREQ="" 94 I $G(LIST)']"" Q 95 D AP^PSS51P1A 96 Q 97 ; 98 IX(PSSFT,PSSPP,LIST) ; 99 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 100 ;PSSPP - PACKAGE PREFIX in ADMINISTRATION SCHEDULE file (#51.1). 101 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 102 ; Field Number of the data piece being returned. 103 ;Returns NAME field (#.01), STANDARD ADMINISTRATION TIMES field (#1), FREQUENCY (IN MINUTES) field (#2), 104 ;MAXIMUM DAYS FOR ORDERS field (#2.5),PACKAGE PREFIX field (#4), TYPE OF SCHEDULE field (#5), STANDARD 105 ;SHIFTS field (#6), OUTPATIENT EXPANSION field (#8), and OTHER LANGUAGE EXPANSION field (#8.1) of 106 ;ADMINISTRATION SCHEDULE file (#51.1). 107 N DIERR,ZZERR,PSS51P1,PSS 108 I $G(LIST)']"" Q 109 D IX^PSS51P1A 110 Q 111 ; 112 ADM(PSSADM) ; admin times 113 N X S X=PSSADM 114 I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q "^" 115 S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q "^" 116 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 117 I '$D(X) Q "^" 118 K:$D(X) X(1),X(2),X(3) Q PSSADM 119 ; 120 ALL(PSSIEN,PSSFT,LIST) ; 121 ;PSSIEN - IEN of entry in ADMINISTRATION SCHEDULE file (#51.1). 122 ;PSSFT - Free Text name in ADMINISTRATION SCHEDULE file (#51.1). 123 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the 124 ; Field Number of the data piece being returned. 125 ;Returns NAME field (#.01), STANDARD ADMINISTRATION TIMES field (#1), FREQUENCY (IN MINUTES) field (#2), 126 ;MAXIMUM DAYS FOR ORDERS field (#2.5), PACKAGE PREFIX field (#4), TYPE OF SCHEDULE field (#5), 127 ;STANDARD SHIFTS field (#6), OUTPATIENT EXPANSION field (#8), OTHER LANGUAGE EXPANSIONS field (#8.1), 128 ; HOSPITAL LOCATION multiple (#51.17) HOSPITAL LOCATION field (#.01), ADMINISTRATION TIMES field (#1), 129 ;SHIFTS field (#2), WARD multiple (#51.11) WARD field (#.01), and WARD ADMINISTRATION TIMES field (#1) 130 ;of ADMINISTRATION SCHEDULE file (#51.1). 131 N DIERR,ZZERR,PSS 132 I $G(LIST)']"" Q 133 K ^TMP($J,LIST) 134 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 135 I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 136 D ALL^PSS51P1C 137 Q 138 ; 139 SETSCR ;Set Screen for One-time schedule type 140 ;Naked reference below refers to ^PS(51.1,+Y,0) 141 I $G(PSSTSCH)]"" S SCR("S")="I $P(^(0),""^"",5)=""O""" 142 ;Naked reference below refers to ^PS(51.1,+Y,0) 143 I $G(PSSPP)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $P(^(0),""^"",4)=PSSPP",1:"I $P(^(0),""^"",4)=PSSPP") 144 Q 145 FREQ(PSSVAL,PSSFREQ) ; VALIDATES FREQUNCY FIELD 146 S PSSTMP=0 147 I PSSVAL>PSSFREQ S PSSTMP=1 148 I PSSVAL<1 S PSSTMP=1 149 I PSSFREQ="" S PSSTMP=0 150 Q PSSTMP 151 PSSDQ ;DQ^DICQ call on 51.1 152 N DIC,D,DZ S DIC="^PS(51.1,",D="B",DIC(0)="EQS",DZ="??" D DQ^DICQ Q -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSS51P2.m
r613 r623 1 PSS51P2 ;BIR/LDT - API FOR INFORMATION FROM FILE 51.2 ; 5 Sep 03 2 ;;1.0;PHARMACY DATA MANAGEMENT;**85,112,118,88,94**;9/30/97;Build 26 3 ; 4 ALL(PSSIEN,PSSFT,PSSFL,PSSPK,LIST) ; 5 ;PSSIEN - IEN of entry in MEDICATION ROUTES file (#51.2). 6 ;PSSFT - Free Text name in MEDICATION ROUTES file (#51.2). 7 ;PSSFL - Inactive flag - "" - All entries 8 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date. 9 ;PSSPK - PACKAGE USE field (#3) of the MEDICATION ROUTES file (#51.2). 10 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is 11 ;the Field Number of the data piece being returned. 12 ;Returns NAME field (#.01), ABBREVIATION field (#1), PACKAGE USE field (#3), OUTPATIENT EXPANSION field (#4), 13 ;OTHER LANGUAGE EXPANSION field (#4.1), INACTIVATION DATE field (#5), and IV FLAG field (#6) 14 ;of MEDICATION ROUTES file (#51.2). 15 N DIERR,ZZERR,PSS51P2,SCR,PSS,PSSBGCNT,PSSCNT,PSSTIEN,PSSTMP,PSSNAM,PSSCAP 16 S PSSBGCNT=0 17 S SCR("S")="" 18 I $G(LIST)']"" Q 19 K ^TMP("DILIST",$J) 20 K ^TMP($J,LIST) 21 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 22 S SCR("S")="" 23 I +$G(PSSFL)>0 N ND D SETSCRN 24 ;Naked reference below refers to ^PS(51.2,+Y,0) 25 I $G(PSSPK)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $P($G(^(0)),U,4)=$G(PSSPK)",1:"I $P($G(^(0)),U,4)=$G(PSSPK)") 26 I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(51.2,"","A","`"_PSSIEN,,SCR("S"),"") D D COUNTBG Q 27 .I PSSIEN2>0 D DIRREAD 28 I +$G(PSSIEN)=0 D 29 .I PSSFT="??" D LOOPDIR D COUNTBG Q 30 .D FIND^DIC(51.2,,"@;.01;1","QP",PSSFT,,"B^C",SCR("S"),,"") D LOOPDI D COUNTBG 31 Q 32 ; 33 COUNTBG ;CHECKS PSSBGCNT AND FILLS COUNT IN ON 0 NODE OF ^TMP($J,LIST) 34 I PSSBGCNT>0 D 35 .S ^TMP($J,LIST,0)=PSSBGCNT 36 ELSE S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" 37 Q 38 ; 39 LOOPDI ;LOOPS ON "DILIST" FROM FILEMAN CALL (USED FOR RETURNING MULTIPLE DRUGS FROM PSSFT) 40 S PSSTIEN=0 ;TEMP IEN TO ITERATE OVER DILIST 41 F S PSSTIEN=$O(^TMP("DILIST",$J,PSSTIEN)) Q:PSSTIEN="" D 42 .S PSSIEN2=($P(^TMP("DILIST",$J,PSSTIEN,0),U,1)) 43 .D DIRREAD 44 Q 45 ; 46 LOOPDIR ;LOOP FOR A DIRECT READ. READS ALL IENs FOR ^PSDRUG( 47 S PSSIEN2=0 48 F S PSSIEN2=$O(^PS(51.2,PSSIEN2)) Q:'PSSIEN2 D 49 .D DIRALL 50 Q 51 ; 52 DIRALL ;TEST FOR PSSFL, PSSPK, BAILS IF CONDITIONS MEET TRUE 53 I $G(PSSFL),$P($G(^PS(51.2,PSSIEN2,0)),U,5),$P($G(^PS(51.2,PSSIEN2,0)),U,5)'>PSSFL Q 54 I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^PS(51.2,PSSIEN2,0)),U,4)[$E(PSSPK,PSSZ6) S PSSZ5=1 55 I $G(PSSPK)]"",'PSSZ5 Q 56 D DIRREAD 57 Q 58 ; 59 DIRREAD ;MAIN DIRECT READ FOR ENTIRE ROUTINE 60 S PSSNAM=$P($G(^PS(51.2,PSSIEN2,0)),U,1) 61 S ^TMP($J,LIST,PSSIEN2,.01)=PSSNAM 62 S ^TMP($J,LIST,PSSIEN2,1)=$P($G(^PS(51.2,PSSIEN2,0)),U,3) 63 S PSSTMP=$P($G(^PS(51.2,PSSIEN2,0)),U,4) 64 I PSSTMP="0" S ^TMP($J,LIST,PSSIEN2,3)=PSSTMP_U_"NATIONAL DRUG FILE ONLY" 65 I PSSTMP="1" S ^TMP($J,LIST,PSSIEN2,3)=PSSTMP_U_"ALL PACKAGES" 66 I PSSTMP="" S ^TMP($J,LIST,PSSIEN2,3)="" 67 S ^TMP($J,LIST,PSSIEN2,4)=$P($G(^PS(51.2,PSSIEN2,0)),U,2) 68 S ^TMP($J,LIST,PSSIEN2,4.1)=$P($G(^PS(51.2,PSSIEN2,0)),U,7) 69 I $P($G(^PS(51.2,PSSIEN2,0)),U,5)'="" D 70 .S PSSCAP=$$UP^XLFSTR($$FMTE^XLFDT($P($G(^PS(51.2,PSSIEN2,0)),U,5))) 71 .S ^TMP($J,LIST,PSSIEN2,5)=$P($G(^PS(51.2,PSSIEN2,0)),U,5)_U_PSSCAP 72 ELSE S ^TMP($J,LIST,PSSIEN2,5)="" 73 N PSSTMP S PSSTMP=$P($G(^PS(51.2,PSSIEN2,0)),U,6) 74 I PSSTMP="0"!PSSTMP="" S ^TMP($J,LIST,PSSIEN2,6)=PSSTMP_U_"NO" 75 I PSSTMP="1" D 76 .S ^TMP($J,LIST,PSSIEN2,6)=PSSTMP_U_"YES" 77 .S ^TMP($J,LIST,"IV",PSSNAM,PSSIEN2)="" 78 I PSSTMP="" S ^TMP($J,LIST,PSSIEN2,6)="" 79 S ^TMP($J,LIST,"B",$P($G(^PS(51.2,PSSIEN2,0)),U,1),PSSIEN2)="" 80 N PSSAB S PSSAB=$P($G(^PS(51.2,PSSIEN2,0)),U,3) I PSSAB]"" S ^TMP($J,LIST,"C",PSSAB,PSSIEN2)="" 81 S PSSTMP=$P($G(^PS(51.2,PSSIEN2,0)),U,8) 82 S ^TMP($J,LIST,PSSIEN2,7)=PSSTMP I PSSTMP]"" S ^(7)=^(7)_U_$S(PSSTMP:"YES",1:"NO") 83 S PSSTMP=$P($G(^PS(51.2,PSSIEN2,0)),U,9) 84 S ^TMP($J,LIST,PSSIEN2,8)=PSSTMP I PSSTMP]"" S ^(8)=^(8)_U_$S(PSSTMP:"YES",1:"NO") 85 S PSSBGCNT=PSSBGCNT+1 86 Q 87 ; 88 SETSCRN ;Set Screen for inactive Medication Routes 89 ;Naked reference below refers to ^PS(51.2,+Y,0) 90 S SCR("S")="S ND=$P($G(^(0)),U,5) I ND=""""!(ND>PSSFL)" 91 Q 92 ; 93 NAME(PSSFT,PSSPK,LIST) ; 94 ;PSSFT - Free Text name in MEDICATION ROUTES file (#51.2). 95 ;PSSPK - PACKAGE USE field (#3) of the MEDICATION ROUTES file (#51.2). 96 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is 97 ;the Field Number of the data piece being returned. 98 ;Returns NAME field (#.01), ABBREVIATION field (#1), and INACTIVATION DATE field (#5) 99 ;of MEDICATION ROUTES file (#51.2). 100 N DIERR,ZZERR,PSS51P2,SCR,PSS 101 I $G(LIST)']"" Q 102 K ^TMP($J,LIST) 103 I ($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 104 ;Naked reference below refers to ^PS(51.2,+Y,0) 105 S SCR("S")=$S($G(PSSPK)]"":"I $P($G(^(0)),""^"",4)=$G(PSSPK)",1:"") 106 I PSSFT["??" D LOOP(2) Q 107 D FIND^DIC(51.2,,"@;.01;1","QP",PSSFT,,"B",SCR("S"),,"") 108 I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 109 S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) 110 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D 111 .S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) K ^TMP("PSS51P2",$J) D GETS^DIQ(51.2,+PSSIEN,".01;1;5","IE","^TMP(""PSS51P2"",$J)") S PSS(1)=0 112 .F S PSS(1)=$O(^TMP("PSS51P2",$J,51.2,PSS(1))) Q:'PSS(1) D SETZRO2 113 K TMP("DILIST",$J),^TMP("PSS51P2",$J) 114 Q 115 ; 116 IEN(PSSABBR,LIST) ; 117 ;PSSABBR - ABBREVIATION field (#1) in MEDICATION ROUTES file (#51.2). 118 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is 119 ;the Field Number of the data piece being returned. 120 ;Returns NAME field (#.01), ABBREVIATION field (#1), and INACTIVATION DATE field (#5) 121 ;of MEDICATION ROUTES file (#51.2). 122 N DIERR,ZZERR,PSS51P2,SCR,PSS 123 I $G(LIST)']"" Q 124 K ^TMP($J,LIST) 125 I ($G(PSSABBR)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 126 D FIND^DIC(51.2,,"@;.01;1","QP",PSSABBR,,"C",,,"") 127 I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 128 S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) 129 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D 130 .S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) K ^TMP("PSS51P2",$J) D GETS^DIQ(51.2,+PSSIEN,".01;1;3;4;5;6;4.1","IE","^TMP(""PSS51P2"",$J)") S PSS(1)=0 131 .F S PSS(1)=$O(^TMP("PSS51P2",$J,51.2,PSS(1))) Q:'PSS(1) D SETZRO2 132 K TMP("DILIST",$J),^TMP("PSS51P2",$J) 133 Q 134 ; 135 SETZRO ; 136 S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),.01,"I")) 137 S ^TMP($J,LIST,"B",$G(^TMP("PSS51P2",$J,51.2,PSS(1),.01,"I")),+PSS(1))="" 138 S ^TMP($J,LIST,+PSS(1),4)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),4,"I")) 139 S ^TMP($J,LIST,+PSS(1),1)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),1,"I")) 140 S ^TMP($J,LIST,+PSS(1),3)=$S($G(^TMP("PSS51P2",$J,51.2,PSS(1),3,"I"))="":"",1:^TMP("PSS51P2",$J,51.2,PSS(1),3,"I")_"^"_^TMP("PSS51P2",$J,51.2,PSS(1),3,"E")) 141 S ^TMP($J,LIST,+PSS(1),5)=$S($G(^TMP("PSS51P2",$J,51.2,PSS(1),5,"I"))="":"",1:^TMP("PSS51P2",$J,51.2,PSS(1),5,"I")_"^"_^TMP("PSS51P2",$J,51.2,PSS(1),5,"E")) 142 S ^TMP($J,LIST,+PSS(1),6)=$S($G(^TMP("PSS51P2",$J,51.2,PSS(1),6,"I"))="":"",1:^TMP("PSS51P2",$J,51.2,PSS(1),6,"I")_"^"_^TMP("PSS51P2",$J,51.2,PSS(1),6,"E")) 143 S ^TMP($J,LIST,+PSS(1),4.1)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),4.1,"I")) 144 Q 145 ; 146 SETZRO2 ; 147 S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),.01,"I")) 148 S ^TMP($J,LIST,"B",$G(^TMP("PSS51P2",$J,51.2,PSS(1),.01,"I")),+PSS(1))="" 149 S ^TMP($J,LIST,+PSS(1),1)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),1,"I")) 150 S ^TMP($J,LIST,+PSS(1),5)=$S($G(^TMP("PSS51P2",$J,51.2,PSS(1),5,"I"))="":"",1:^TMP("PSS51P2",$J,51.2,PSS(1),5,"I")_"^"_^TMP("PSS51P2",$J,51.2,PSS(1),5,"E")) 151 Q 152 ; 153 LOOP(PSS) ; 154 N CNT S CNT=0 155 S PSSIEN=0 F S PSSIEN=$O(^PS(51.2,PSSIEN)) Q:'PSSIEN D @(PSS) 156 S ^TMP($J,LIST,0)=$S($G(CNT)>0:CNT,1:"-1^NO DATA FOUND") 157 Q 158 ; 159 1 ; 160 S ND=$G(^PS(51.2,+PSSIEN,0)) 161 I +$G(PSSFL)>0 Q:$P($G(ND),"^",5)]""&($P($G(ND),"^",5)'>$G(PSSFL)) 162 I $G(PSSPK)]"" Q:$P($G(ND),"^",4)'=$G(PSSPK) 163 K ^TMP("PSS51P2",$J) D GETS^DIQ(51.2,+PSSIEN,".01;1;3;4;5;6;4.1","IE","^TMP(""PSS51P2"",$J)") S PSS(1)=0 D 164 .F S PSS(1)=$O(^TMP("PSS51P2",$J,51.2,PSS(1))) Q:'PSS(1) D SETZRO S CNT=CNT+1 165 Q 166 ; 167 2 ; 168 I $G(PSSPK)]"",$P($G(^PS(51.2,+PSSIEN,0)),"^",4)'=$G(PSSPK) Q 169 K ^TMP("PSS51P2",$J) D GETS^DIQ(51.2,+PSSIEN,".01;1;5","IE","^TMP(""PSS51P2"",$J)") S PSS(1)=0 D 170 .F S PSS(1)=$O(^TMP("PSS51P2",$J,51.2,PSS(1))) Q:'PSS(1) D SETZRO2 S CNT=CNT+1 171 Q 1 PSS51P2 ;BIR/LDT - API FOR INFORMATION FROM FILE 51.2 ; 5 Sep 03 2 ;;1.0;PHARMACY DATA MANAGEMENT;**85,112,118,88**;9/30/97;Build 12 3 ; 4 ALL(PSSIEN,PSSFT,PSSFL,PSSPK,LIST) ; 5 ;PSSIEN - IEN of entry in MEDICATION ROUTES file (#51.2). 6 ;PSSFT - Free Text name in MEDICATION ROUTES file (#51.2). 7 ;PSSFL - Inactive flag - "" - All entries 8 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date. 9 ;PSSPK - PACKAGE USE field (#3) of the MEDICATION ROUTES file (#51.2). 10 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is 11 ;the Field Number of the data piece being returned. 12 ;Returns NAME field (#.01), ABBREVIATION field (#1), PACKAGE USE field (#3), OUTPATIENT EXPANSION field (#4), 13 ;OTHER LANGUAGE EXPANSION field (#4.1), INACTIVATION DATE field (#5), and IV FLAG field (#6) 14 ;of MEDICATION ROUTES file (#51.2). 15 N DIERR,ZZERR,PSS51P2,SCR,PSS,PSSBGCNT,PSSCNT,PSSTIEN,PSSTMP,PSSNAM,PSSCAP 16 S PSSBGCNT=0 17 S SCR("S")="" 18 I $G(LIST)']"" Q 19 K ^TMP("DILIST",$J) 20 K ^TMP($J,LIST) 21 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 22 S SCR("S")="" 23 I +$G(PSSFL)>0 N ND D SETSCRN 24 ;Naked reference below refers to ^PS(51.2,+Y,0) 25 I $G(PSSPK)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $P($G(^(0)),U,4)=$G(PSSPK)",1:"I $P($G(^(0)),U,4)=$G(PSSPK)") 26 I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(51.2,"","A","`"_PSSIEN,,SCR("S"),"") D D COUNTBG Q 27 .I PSSIEN2>0 D DIRREAD 28 I +$G(PSSIEN)=0 D 29 .I PSSFT="??" D LOOPDIR D COUNTBG Q 30 .D FIND^DIC(51.2,,"@;.01;1","QP",PSSFT,,"B",SCR("S"),,"") D LOOPDI D COUNTBG 31 Q 32 ; 33 COUNTBG ;CHECKS PSSBGCNT AND FILLS COUNT IN ON 0 NODE OF ^TMP($J,LIST) 34 I PSSBGCNT>0 D 35 .S ^TMP($J,LIST,0)=PSSBGCNT 36 ELSE S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" 37 Q 38 ; 39 LOOPDI ;LOOPS ON "DILIST" FROM FILEMAN CALL (USED FOR RETURNING MULTIPLE DRUGS FROM PSSFT) 40 S PSSTIEN=0 ;TEMP IEN TO ITERATE OVER DILIST 41 F S PSSTIEN=$O(^TMP("DILIST",$J,PSSTIEN)) Q:PSSTIEN="" D 42 .S PSSIEN2=($P(^TMP("DILIST",$J,PSSTIEN,0),U,1)) 43 .D DIRREAD 44 Q 45 ; 46 LOOPDIR ;LOOP FOR A DIRECT READ. READS ALL IENs FOR ^PSDRUG( 47 S PSSIEN2=0 48 F S PSSIEN2=$O(^PS(51.2,PSSIEN2)) Q:'PSSIEN2 D 49 .D DIRALL 50 Q 51 ; 52 DIRALL ;TEST FOR PSSFL, PSSPK, BAILS IF CONDITIONS MEET TRUE 53 I $G(PSSFL),$P($G(^PS(51.2,PSSIEN2,0)),U,5),$P($G(^PS(51.2,PSSIEN2,0)),U,5)'>PSSFL Q 54 I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^PS(51.2,PSSIEN2,0)),U,4)[$E(PSSPK,PSSZ6) S PSSZ5=1 55 I $G(PSSPK)]"",'PSSZ5 Q 56 D DIRREAD 57 Q 58 ; 59 DIRREAD ;MAIN DIRECT READ FOR ENTIRE ROUTINE 60 S PSSNAM=$P($G(^PS(51.2,PSSIEN2,0)),U,1) 61 S ^TMP($J,LIST,PSSIEN2,.01)=PSSNAM 62 S ^TMP($J,LIST,PSSIEN2,1)=$P($G(^PS(51.2,PSSIEN2,0)),U,3) 63 S PSSTMP=$P($G(^PS(51.2,PSSIEN2,0)),U,4) 64 I PSSTMP="0" S ^TMP($J,LIST,PSSIEN2,3)=PSSTMP_U_"NATIONAL DRUG FILE ONLY" 65 I PSSTMP="1" S ^TMP($J,LIST,PSSIEN2,3)=PSSTMP_U_"ALL PACKAGES" 66 I PSSTMP="" S ^TMP($J,LIST,PSSIEN2,3)="" 67 S ^TMP($J,LIST,PSSIEN2,4)=$P($G(^PS(51.2,PSSIEN2,0)),U,2) 68 S ^TMP($J,LIST,PSSIEN2,4.1)=$P($G(^PS(51.2,PSSIEN2,0)),U,7) 69 I $P($G(^PS(51.2,PSSIEN2,0)),U,5)'="" D 70 .S PSSCAP=$$UP^XLFSTR($$FMTE^XLFDT($P($G(^PS(51.2,PSSIEN2,0)),U,5))) 71 .S ^TMP($J,LIST,PSSIEN2,5)=$P($G(^PS(51.2,PSSIEN2,0)),U,5)_U_PSSCAP 72 ELSE S ^TMP($J,LIST,PSSIEN2,5)="" 73 N PSSTMP S PSSTMP=$P($G(^PS(51.2,PSSIEN2,0)),U,6) 74 I PSSTMP="0"!PSSTMP="" S ^TMP($J,LIST,PSSIEN2,6)=PSSTMP_U_"NO" 75 I PSSTMP="1" D 76 .S ^TMP($J,LIST,PSSIEN2,6)=PSSTMP_U_"YES" 77 .S ^TMP($J,LIST,"IV",PSSNAM,PSSIEN2)="" 78 I PSSTMP="" S ^TMP($J,LIST,PSSIEN2,6)="" 79 S ^TMP($J,LIST,"B",$P($G(^PS(51.2,PSSIEN2,0)),U,1),PSSIEN2)="" 80 S PSSTMP=$P($G(^PS(51.2,PSSIEN2,0)),U,8) 81 S ^TMP($J,LIST,PSSIEN2,7)=PSSTMP I PSSTMP]"" S ^(7)=^(7)_U_$S(PSSTMP:"YES",1:"NO") 82 S PSSTMP=$P($G(^PS(51.2,PSSIEN2,0)),U,9) 83 S ^TMP($J,LIST,PSSIEN2,8)=PSSTMP I PSSTMP]"" S ^(8)=^(8)_U_$S(PSSTMP:"YES",1:"NO") 84 S PSSBGCNT=PSSBGCNT+1 85 Q 86 ; 87 SETSCRN ;Set Screen for inactive Medication Routes 88 ;Naked reference below refers to ^PS(51.2,+Y,0) 89 S SCR("S")="S ND=$P($G(^(0)),U,5) I ND=""""!(ND>PSSFL)" 90 Q 91 ; 92 NAME(PSSFT,PSSPK,LIST) ; 93 ;PSSFT - Free Text name in MEDICATION ROUTES file (#51.2). 94 ;PSSPK - PACKAGE USE field (#3) of the MEDICATION ROUTES file (#51.2). 95 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is 96 ;the Field Number of the data piece being returned. 97 ;Returns NAME field (#.01), ABBREVIATION field (#1), and INACTIVATION DATE field (#5) 98 ;of MEDICATION ROUTES file (#51.2). 99 N DIERR,ZZERR,PSS51P2,SCR,PSS 100 I $G(LIST)']"" Q 101 K ^TMP($J,LIST) 102 I ($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 103 ;Naked reference below refers to ^PS(51.2,+Y,0) 104 S SCR("S")=$S($G(PSSPK)]"":"I $P($G(^(0)),""^"",4)=$G(PSSPK)",1:"") 105 I PSSFT["??" D LOOP(2) Q 106 D FIND^DIC(51.2,,"@;.01;1","QP",PSSFT,,"B",SCR("S"),,"") 107 I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 108 S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) 109 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D 110 .S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) K ^TMP("PSS51P2",$J) D GETS^DIQ(51.2,+PSSIEN,".01;1;5","IE","^TMP(""PSS51P2"",$J)") S PSS(1)=0 111 .F S PSS(1)=$O(^TMP("PSS51P2",$J,51.2,PSS(1))) Q:'PSS(1) D SETZRO2 112 K TMP("DILIST",$J),^TMP("PSS51P2",$J) 113 Q 114 ; 115 IEN(PSSABBR,LIST) ; 116 ;PSSABBR - ABBREVIATION field (#1) in MEDICATION ROUTES file (#51.2). 117 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is 118 ;the Field Number of the data piece being returned. 119 ;Returns NAME field (#.01), ABBREVIATION field (#1), and INACTIVATION DATE field (#5) 120 ;of MEDICATION ROUTES file (#51.2). 121 N DIERR,ZZERR,PSS51P2,SCR,PSS 122 I $G(LIST)']"" Q 123 K ^TMP($J,LIST) 124 I ($G(PSSABBR)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 125 D FIND^DIC(51.2,,"@;.01;1","QP",PSSABBR,,"C",,,"") 126 I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q 127 S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) 128 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D 129 .S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) K ^TMP("PSS51P2",$J) D GETS^DIQ(51.2,+PSSIEN,".01;1;3;4;5;6;4.1","IE","^TMP(""PSS51P2"",$J)") S PSS(1)=0 130 .F S PSS(1)=$O(^TMP("PSS51P2",$J,51.2,PSS(1))) Q:'PSS(1) D SETZRO2 131 K TMP("DILIST",$J),^TMP("PSS51P2",$J) 132 Q 133 ; 134 SETZRO ; 135 S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),.01,"I")) 136 S ^TMP($J,LIST,"B",$G(^TMP("PSS51P2",$J,51.2,PSS(1),.01,"I")),+PSS(1))="" 137 S ^TMP($J,LIST,+PSS(1),4)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),4,"I")) 138 S ^TMP($J,LIST,+PSS(1),1)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),1,"I")) 139 S ^TMP($J,LIST,+PSS(1),3)=$S($G(^TMP("PSS51P2",$J,51.2,PSS(1),3,"I"))="":"",1:^TMP("PSS51P2",$J,51.2,PSS(1),3,"I")_"^"_^TMP("PSS51P2",$J,51.2,PSS(1),3,"E")) 140 S ^TMP($J,LIST,+PSS(1),5)=$S($G(^TMP("PSS51P2",$J,51.2,PSS(1),5,"I"))="":"",1:^TMP("PSS51P2",$J,51.2,PSS(1),5,"I")_"^"_^TMP("PSS51P2",$J,51.2,PSS(1),5,"E")) 141 S ^TMP($J,LIST,+PSS(1),6)=$S($G(^TMP("PSS51P2",$J,51.2,PSS(1),6,"I"))="":"",1:^TMP("PSS51P2",$J,51.2,PSS(1),6,"I")_"^"_^TMP("PSS51P2",$J,51.2,PSS(1),6,"E")) 142 S ^TMP($J,LIST,+PSS(1),4.1)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),4.1,"I")) 143 Q 144 ; 145 SETZRO2 ; 146 S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),.01,"I")) 147 S ^TMP($J,LIST,"B",$G(^TMP("PSS51P2",$J,51.2,PSS(1),.01,"I")),+PSS(1))="" 148 S ^TMP($J,LIST,+PSS(1),1)=$G(^TMP("PSS51P2",$J,51.2,PSS(1),1,"I")) 149 S ^TMP($J,LIST,+PSS(1),5)=$S($G(^TMP("PSS51P2",$J,51.2,PSS(1),5,"I"))="":"",1:^TMP("PSS51P2",$J,51.2,PSS(1),5,"I")_"^"_^TMP("PSS51P2",$J,51.2,PSS(1),5,"E")) 150 Q 151 ; 152 LOOP(PSS) ; 153 N CNT S CNT=0 154 S PSSIEN=0 F S PSSIEN=$O(^PS(51.2,PSSIEN)) Q:'PSSIEN D @(PSS) 155 S ^TMP($J,LIST,0)=$S($G(CNT)>0:CNT,1:"-1^NO DATA FOUND") 156 Q 157 ; 158 1 ; 159 S ND=$G(^PS(51.2,+PSSIEN,0)) 160 I +$G(PSSFL)>0 Q:$P($G(ND),"^",5)]""&($P($G(ND),"^",5)'>$G(PSSFL)) 161 I $G(PSSPK)]"" Q:$P($G(ND),"^",4)'=$G(PSSPK) 162 K ^TMP("PSS51P2",$J) D GETS^DIQ(51.2,+PSSIEN,".01;1;3;4;5;6;4.1","IE","^TMP(""PSS51P2"",$J)") S PSS(1)=0 D 163 .F S PSS(1)=$O(^TMP("PSS51P2",$J,51.2,PSS(1))) Q:'PSS(1) D SETZRO S CNT=CNT+1 164 Q 165 ; 166 2 ; 167 I $G(PSSPK)]"",$P($G(^PS(51.2,+PSSIEN,0)),"^",4)'=$G(PSSPK) Q 168 K ^TMP("PSS51P2",$J) D GETS^DIQ(51.2,+PSSIEN,".01;1;5","IE","^TMP(""PSS51P2"",$J)") S PSS(1)=0 D 169 .F S PSS(1)=$O(^TMP("PSS51P2",$J,51.2,PSS(1))) Q:'PSS(1) D SETZRO2 S CNT=CNT+1 170 Q -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDDUT2.m
r613 r623 1 PSSDDUT2 ;BIR/LDT - Pharmacy Data Management DD Utility ; 8/21/07 8:43am 2 ;;1.0; PHARMACY DATA MANAGEMENT; **3,21,61,81,95,127,126**;9/30/97;Build 11 3 ; 4 ;Reference to ^DIC(42 supported by DBIA #10039 5 ;Reference to ^DD(59.723 supported by DBIA #2159 6 ;Reference to ^PSNDF(50.68 supported by DBIA 3735 7 ; 8 DEA ;(Replaces ^PSODEA) 9 S PSSHLP(1)="THE SPECIAL HANDLING CODE IS A 2 TO 6 POSTION FIELD. IF APPLICABLE," 10 S PSSHLP(2)="A SCHEDULE CODE MUST APPEAR IN THE FIRST POSITION. FOR EXAMPLE," 11 S PSSHLP(3)="A SCHEDULE 3 NARCOTIC WILL BE CODED '3A', A SCHEDULE 3 NON-NARCOTIC WILL BE" 12 S PSSHLP(4)="CODED '3C' AND A SCHEDULE 2 DEPRESSANT WILL BE CODED '2L'." 13 S PSSHLP(5)="THE CODES ARE:" 14 D WRITE 15 F II=1:1 Q:$P($T(D+II),";",3)="" S PSSHLP(II)=$P($T(D+II),";",3,99) 16 S PSSHLP(1,"F")="!!" D WRITE 17 D PKIND,WRITE 18 D K II Q 19 ;;0 MANUFACTURED IN PHARMACY 20 ;;1 SCHEDULE 1 ITEM 21 ;;2 SCHEDULE 2 ITEM 22 ;;3 SCHEDULE 3 ITEM 23 ;;4 SCHEDULE 4 ITEM 24 ;;5 SCHEDULE 5 ITEM 25 ;;6 LEGEND ITEM 26 ;;9 OVER-THE-COUNTER 27 ;;L DEPRESSANTS AND STIMULANTS 28 ;;A NARCOTICS AND ALCOHOLS 29 ;;P DATED DRUGS 30 ;;I INVESTIGATIONAL DRUGS 31 ;;M BULK COMPOUND ITEMS 32 ;;C CONTROLLED SUBSTANCES - NON NARCOTIC 33 ;;R RESTRICTED ITEMS 34 ;;S SUPPLY ITEMS 35 ;;B ALLOW REFILL (SCH. 3, 4, 5 ONLY) 36 ;;W NOT RENEWABLE 37 ;;F NON REFILLABLE 38 ;;E ELECTRONICALLY BILLABLE 39 ;; 40 DEATBL ; More Help regarding DEA Codes 41 K PSSHLP 42 F II=1:1 Q:$P($T(TBL+II),";",3)="" S PSSHLP(II)=$P($T(TBL+II),";",3,99) 43 S PSSHLP(1,"F")="!!" D WRITE 44 ; 45 TBL K II Q 46 ;; DEA CODE TABLE 47 ;; CODE ALLOW RENEWS ALLOW REFILLS 48 ;; 1 NO NO 49 ;; 2 NO NO 50 ;; 2A NO NO 51 ;; 3 YES YES 52 ;; 3A YES NO 53 ;; 3AB YES YES 54 ;; 4 YES YES 55 ;; 4A YES NO 56 ;; 4AB YES YES 57 ;; 5 YES YES 58 ;; 5A YES NO 59 ;; 5AB YES YES 60 ;; ADDING W TO A SCHED. 3,4,OR 5 CODE DISALLOWS RENEWS. 61 ;; ADDING F TO A SCHED. 3,4,OR 5 CODE DISALLOWS REFILLS 62 ;; IF A CODE IS NOT LISTED IN THE ABOVE TABLE 63 ;; IT HAS NO EFFECT ON RENEW OR REFILL 64 SIG ;checks SIG for RXs (Replaces SIG^PSOHELP) 65 I $E(X)=" " D EN^DDIOL("Leading spaces are not allowed in the SIG! ","","$C(7),!") K X Q 66 SIGONE S SIG="" Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" EN S Z1=$P(X," ",Z0) D G:'$D(X) EN 67 .I $L(Z1)>32 D EN^DDIOL("MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.","","$C(7),!?5") K X Q 68 .D:$D(X)&($G(Z1)]"") S SIG=SIG_" "_Z1 69 ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9) 70 EN K Z1,Z0 ;S:$G(POERR) PSOERR("SIG")="("_$E(SIG,2,999999999)_")" 71 Q 72 ; 73 DRUGW ;(Replaces DRUGW^PSOUTLA) 74 F Z0=1:1 Q:$P(X,",",Z0,99)="" S Z1=$P(X,",",Z0) D:$D(^PS(54,Z1,0)) EN^DDIOL($P(^(0),"^"),"","!,?35") I '$D(^(0)) D EN^DDIOL("NO SUCH WARNING LABEL","","?35") K X Q 75 Q 76 ; 77 P ;(Replaces ^PSODSRC) 78 S PSSHLP(1)="A TWO OR THREE POSITION CODE IDENTIFIES THE SOURCE OF SUPPLY AND WHETHER" 79 S PSSHLP(2)="THE DRUG IS STOCKED BY THE STATION SUPPLY DIVISION. THE FIRST" 80 S PSSHLP(3)="POSITION OF THE CODE IDENTIFIES SOURCE OF SUPPLY. THE CODES ARE:" 81 D WRITE 82 F II=0:1:10 S PSSHLP(II+1)=$P($T(S+II+1),";",3),PSSHLP(II+1,"F")="!?10" 83 S PSSHLP(1,"F")="!!?10" 84 D WRITE 85 S PSSHLP(1)="THE SECOND POSITION OF THE CODE INDICATES WHETHER THE ITEM IS" 86 S PSSHLP(2)="OR IS NOT AVAILABLE FROM SUPPLY WAREHOUSE STOCK. THE CODES ARE:" 87 S PSSHLP(3)="P POSTED STOCK" 88 S PSSHLP(3,"F")="!!?10" 89 S PSSHLP(4)="U UNPOSTED" 90 S PSSHLP(4,"F")="!?10" 91 S PSSHLP(5)="M BULK COMPOUND" 92 S PSSHLP(5,"F")="!?10" 93 S PSSHLP(6)="* USE CODE 0 ONLY WITH SECOND POSITION M." 94 D WRITE Q 95 ; 96 S ;;DESCRIPTION MEANINGS 97 ;;0 BULK COMPOUND ITEMS * 98 ;;1 VA SERVICING SUPPLY DEPOT 99 ;;2 OPEN MARKET 100 ;;3 GSA STORES DEPOT 101 ;;4 VA DECENTRALIZED CONTRACTS 102 ;;5 FEDERAL PRISON INDUSTRIES, INC. 103 ;;6 FEDERAL SUPPLY SCHEDULES 104 ;;7 VA SUPPLY DEPOT, HINES 105 ;;8 VA SUPPLY DEPOT, SOMERVILLE 106 ;;9 APPROPRIATE MARKETING DIVISION 107 ;;10 VA SUPPLY DEPOT, BELL 108 EDIT ;INPUT XFORM FOR DEA FIELD IN DRUG FILE (Replaces EDIT^PSODEA) 109 I X["F",X["B" D EN^DDIOL("Inappropriate F designation!","","$C(7),!") K X Q 110 ;;DEA CHANGE PSS*1*126 111 I X["B",(+X<3) D EN^DDIOL("The B designation is only valid for schedule 3, 4, 5 !","","$C(7),!") K X Q 112 I X["A"&(X["C"),+X=2!(+X=3) D EN^DDIOL("The A & C designation is not valid for schedule 2 or 3 narcotics !","","$C(7),!") K X Q 113 I $E(X)=1,X[2!(X[3)!(X[4)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 2-5 narcotics!","","$C(7),!") K X Q 114 I $E(X)=2,X[1!(X[3)!(X[4)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 1,3-5 narcotics!","","$C(7),!") K X Q 115 I $E(X)=3,X[1!(X[2)!(X[4)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 1-2,4-5 narcotics!","","$C(7),!") K X Q 116 I $E(X)=4,X[1!(X[2)!(X[3)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 1-3,5 narcotics!","","$C(7),!") K X Q 117 I $E(X)=5,X[1!(X[2)!(X[3)!(X[4) D EN^DDIOL("It contains other inappropriate schedule 1-4 narcotics!","","$C(7),!") K X Q 118 I $E(X)="E" D EN^DDIOL("Inappropriate E designation! Can only modify other codes.","","$C(7),!") K X Q 119 Q 120 ; 121 WRITE ;Calls EN^DDIOL to write text 122 D EN^DDIOL(.PSSHLP) K PSSHLP Q 123 Q 124 ; 125 PKIND I +$P($G(^PSDRUG(DA,"ND")),"^",3) S PSSK=$P(^("ND"),"^",3) D 126 .S PSSK=$$GET1^DIQ(50.68,PSSK,19,"I") I PSSK S PSSK=$$CSDEA^PSSDDUT2(PSSK) D 127 ..I $L(PSSK)=1,$P(^PSDRUG(DA,0),"^",3)[PSSK Q 128 ..I $P(^PSDRUG(DA,0),"^",3)[$E(PSSK),$P(^PSDRUG(DA,0),"^",3)[$E(PSSK,2) Q 129 ..W !!,"The CS Federal Schedule associated with this drug in the VA Product file" 130 ..W !,"represents a DEA, Special Handling code of "_PSSK 131 Q 132 ; 133 CSDEA(CS) ; 134 Q:'CS "" 135 Q $S(CS?1(1"2n",1"3n"):+CS_"C",+CS=2!(+CS=3)&(CS'["C"):+CS_"A",1:CS) 136 ; 137 CLOZ ;DEL node of DRUG file 50, fields 17.2, 17.3, 17.4 138 S PSSHLP(1)="To delete this field use the Unmark Clozapine Drug option in the" 139 S PSSHLP(2)="Clozapine Pharmacy Manager menu." 140 D WRITE 141 Q 142 ; 143 NONF ;Non-Formulary Input Transform DRUG file 50, field 51 144 S PSSHLP(1)="This drug cannot be marked as a non-formulary item because it is" 145 S PSSHLP(2)="designated as a formulary alternative for the following drugs." 146 S PSSHLP(3)=" ",PSSHLP(1,"F")="!!" 147 D WRITE 148 F MM=0:0 S MM=$O(^PSDRUG("AFA",DA,MM)) Q:'MM S SHEMP=$P(^PSDRUG(MM,0),"^") D EN^DDIOL(SHEMP,"","!?3") 149 S X="" 150 Q 151 ; 152 ATC ;Executable help for field 212.2, DRUG file 50 153 S PSSHLP(1)="The mnemonic entered here must match the mnemonic entered into the" 154 S PSSHLP(2)="ATC for this drug EXACTLY, and cannot be numbers only." 155 D WRITE 156 Q 157 ; 158 ADTM ;ADMINISTRATION SCHEDULE file 51.1, field 1 Executable Help 159 S PSSHLP(1)="ALL TIMES MUST BE THE SAME LENGTH (2 OR 4 CHARACTERS), MUST BE" 160 S PSSHLP(2)="SEPARATED BY DASHES ('-'), AND BE IN ASCENDING ORDER" 161 D WRITE 162 Q 163 ; 164 LBLS ;PHARMACY SYSTEM file 59.7, field 61.2 Executable Help 165 S PSSHLP(1)="ANY NEW LABELS OLDER THAN THE NUMBER OF DAYS SPECIFIED HERE WILL" 166 S PSSHLP(2)="AUTOMATICALLY BE PURGED." 167 D WRITE 168 Q 169 NFH I '$D(DA(1)) D EN^DDIOL(" (This non-formulary item is "_$P(^PSDRUG($S($D(DA(1)):DA(1),1:DA),0),"^")_".)") 170 Q 171 STRTH S STR=" "_$P(X," ",2),PSSHLP(1)=STR,PSSHLP(1,"F")="" D WRITE K STR 172 Q 173 PSYS1 D EN^DDIOL("(""From"" ward is "_$S('$D(^PS(59.7,D0,22,D1,0)):"UNKNOWN",'$D(^DIC(42,+^(0),0)):"UNKNOWN",$P(^(0),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_")","","!?3") 174 Q 175 PSYS2 ;PSS*1.0*95 176 D EN^DDIOL("(""From"" service is "_$S('$D(^PS(59.7,D0,23,D1,0)):"UNKNOWN",$P(^(0),"^")]"":$P($P(";"_$P(^DD(59.723,.01,0),"^",3),";"_$P(^PS(59.7,D0,23,D1,0),"^")_":",2),";"),1:"UNKNOWN")_")") 177 Q 178 ; 179 NCINIT ; 180 K PSSNQM,PSSNQM2,PSSNQM3,PSSONDU,PSSONQM 181 NCINIT1 ; 182 I $P($G(^PSDRUG(DA,"EPH")),"^",2)="" S $P(^PSDRUG(DA,"EPH"),"^",2)="EA",$P(^PSDRUG(DA,"EPH"),"^",3)=1 D 183 . S PSSHLP(1)=" Note: Defaulting the NCPDP DISPENSE UNIT to EACH and the" 184 . S PSSHLP(2)=" NCPDP QUANTITY MULTIPLIER to 1 (one)." S PSSHLP(1,"F")="!!" 185 . D WRITE S PSSHLP(2,"F")="!" D WRITE 186 S PSSONDU=$P(^PSDRUG(DA,"EPH"),"^",2),PSSONQM=$P(^PSDRUG(DA,"EPH"),"^",3) 187 Q 188 ; 189 NCPDPDU ;Drug file 50, field 82 190 S:X="" X="EA" 191 D NCINIT1:'$D(PSSONDU) 192 I $G(PSSONDU)'=X&($G(PSSONQM)'=1) D 193 . S PSSHLP(1)="Defaulting the NCPDP QUANTITY MULTIPLIER to 1 (one)." S PSSHLP(1,"F")="!!" D WRITE 194 . S $P(^PSDRUG(DA,"EPH"),"^",3)=1,PSSONDU=$P(^PSDRUG(DA,"EPH"),"^",2),PSSONQM=$P(^PSDRUG(DA,"EPH"),"^",3) 195 Q 196 ; 197 NCPDPQM ;Drug file 50, field 83 198 N ZXX S PSSNQM=0,(PSSNQM2,PSSNQM3)="" 199 I $G(X)<.001 K X S PSSNQM3=1 Q 200 S:$G(X)="" X=1 201 I +$G(X)'=1 D NCPDPWRN D 202 NCPDPQM1 . ; 203 . R !,"Ok to continue? (Y/N) ",ZXX:30 S ZXX=$TR(ZXX,"yn","YN") 204 . I ZXX="^" S X=1 W !!?5,"Warning: Defaulting NCPDP QUANTITY MULTIPLIER to 1 (one).",!! Q 205 . I ZXX'="Y"&(ZXX'="N") W !,"Y or N must be entered." G NCPDPQM1 206 . I ZXX'="Y"&(ZXX'="y") S PSSNQM=1,PSSNQM2=X K X 207 Q 208 ; 209 NCPDPWRN ; 210 S PSSHLP(2)="WARNING: For most drug products, the value for this field should be 1 (one)." 211 S PSSHLP(3)=" Answering NO for the following prompt will display more information" 212 S PSSHLP(4)=" on how this field is used." 213 S PSSHLP(2,"F")="!!" D WRITE 214 S PSSHLP(5,"F")="!" D WRITE 215 Q 216 ; 1 PSSDDUT2 ;BIR/LDT - Pharmacy Data Management DD Utility ;10/30/97 9:41 2 ;;1.0; PHARMACY DATA MANAGEMENT; **3,21,61,81,95,127**;9/30/97;Build 41 3 ; 4 ;Reference to ^DIC(42 supported by DBIA #10039 5 ;Reference to ^DD(59.723 supported by DBIA #2159 6 ;Reference to ^PSNDF(50.68 supported by DBIA 3735 7 ; 8 DEA ;(Replaces ^PSODEA) 9 S PSSHLP(1)="THE SPECIAL HANDLING CODE IS A 2 TO 6 POSTION FIELD. IF APPLICABLE," 10 S PSSHLP(2)="A SCHEDULE CODE MUST APPEAR IN THE FIRST POSITION. FOR EXAMPLE," 11 S PSSHLP(3)="A SCHEDULE 3 NARCOTIC WILL BE CODED '3A', A SCHEDULE 3 NON-NARCOTIC WILL BE" 12 S PSSHLP(4)="CODED '3C' AND A SCHEDULE 2 DEPRESSANT WILL BE CODED '2L'." 13 S PSSHLP(5)="THE CODES ARE:" 14 D WRITE 15 F II=1:1 Q:$P($T(D+II),";",3)="" S PSSHLP(II)=$P($T(D+II),";",3,99) 16 S PSSHLP(1,"F")="!!" D WRITE 17 D PKIND,WRITE 18 D K II Q 19 ;;0 MANUFACTURED IN PHARMACY 20 ;;1 SCHEDULE 1 ITEM 21 ;;2 SCHEDULE 2 ITEM 22 ;;3 SCHEDULE 3 ITEM 23 ;;4 SCHEDULE 4 ITEM 24 ;;5 SCHEDULE 5 ITEM 25 ;;6 LEGEND ITEM 26 ;;9 OVER-THE-COUNTER 27 ;;L DEPRESSANTS AND STIMULANTS 28 ;;A NARCOTICS AND ALCOHOLS 29 ;;P DATED DRUGS 30 ;;I INVESTIGATIONAL DRUGS 31 ;;M BULK COMPOUND ITEMS 32 ;;C CONTROLLED SUBSTANCES - NON NARCOTIC 33 ;;R RESTRICTED ITEMS 34 ;;S SUPPLY ITEMS 35 ;;B ALLOW REFILL (SCH. 3, 4, 5 NARCOTICS ONLY) 36 ;;W NOT RENEWABLE 37 ;;F NON REFILLABLE 38 ;;E ELECTRONICALLY BILLABLE 39 ;; 40 SIG ;checks SIG for RXs (Replaces SIG^PSOHELP) 41 I $E(X)=" " D EN^DDIOL("Leading spaces are not allowed in the SIG! ","","$C(7),!") K X Q 42 SIGONE S SIG="" Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" EN S Z1=$P(X," ",Z0) D G:'$D(X) EN 43 .I $L(Z1)>32 D EN^DDIOL("MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.","","$C(7),!?5") K X Q 44 .D:$D(X)&($G(Z1)]"") S SIG=SIG_" "_Z1 45 ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9) 46 EN K Z1,Z0 ;S:$G(POERR) PSOERR("SIG")="("_$E(SIG,2,999999999)_")" 47 Q 48 ; 49 DRUGW ;(Replaces DRUGW^PSOUTLA) 50 F Z0=1:1 Q:$P(X,",",Z0,99)="" S Z1=$P(X,",",Z0) D:$D(^PS(54,Z1,0)) EN^DDIOL($P(^(0),"^"),"","!,?35") I '$D(^(0)) D EN^DDIOL("NO SUCH WARNING LABEL","","?35") K X Q 51 Q 52 ; 53 P ;(Replaces ^PSODSRC) 54 S PSSHLP(1)="A TWO OR THREE POSITION CODE IDENTIFIES THE SOURCE OF SUPPLY AND WHETHER" 55 S PSSHLP(2)="THE DRUG IS STOCKED BY THE STATION SUPPLY DIVISION. THE FIRST" 56 S PSSHLP(3)="POSITION OF THE CODE IDENTIFIES SOURCE OF SUPPLY. THE CODES ARE:" 57 D WRITE 58 F II=0:1:10 S PSSHLP(II+1)=$P($T(S+II+1),";",3),PSSHLP(II+1,"F")="!?10" 59 S PSSHLP(1,"F")="!!?10" 60 D WRITE 61 S PSSHLP(1)="THE SECOND POSITION OF THE CODE INDICATES WHETHER THE ITEM IS" 62 S PSSHLP(2)="OR IS NOT AVAILABLE FROM SUPPLY WAREHOUSE STOCK. THE CODES ARE:" 63 S PSSHLP(3)="P POSTED STOCK" 64 S PSSHLP(3,"F")="!!?10" 65 S PSSHLP(4)="U UNPOSTED" 66 S PSSHLP(4,"F")="!?10" 67 S PSSHLP(5)="M BULK COMPOUND" 68 S PSSHLP(5,"F")="!?10" 69 S PSSHLP(6)="* USE CODE 0 ONLY WITH SECOND POSITION M." 70 D WRITE Q 71 ; 72 S ;;DESCRIPTION MEANINGS 73 ;;0 BULK COMPOUND ITEMS * 74 ;;1 VA SERVICING SUPPLY DEPOT 75 ;;2 OPEN MARKET 76 ;;3 GSA STORES DEPOT 77 ;;4 VA DECENTRALIZED CONTRACTS 78 ;;5 FEDERAL PRISON INDUSTRIES, INC. 79 ;;6 FEDERAL SUPPLY SCHEDULES 80 ;;7 VA SUPPLY DEPOT, HINES 81 ;;8 VA SUPPLY DEPOT, SOMERVILLE 82 ;;9 APPROPRIATE MARKETING DIVISION 83 ;;10 VA SUPPLY DEPOT, BELL 84 EDIT ;INPUT XFORM FOR DEA FIELD IN DRUG FILE (Replaces EDIT^PSODEA) 85 I X["F",X["B" D EN^DDIOL("Inappropriate F designation!","","$C(7),!") K X Q 86 I X["B",(+X<3!(X'["A")) D EN^DDIOL("The B designation is only valid for schedule 3, 4, 5 narcotics !","","$C(7),!") K X Q 87 I X["A"&(X["C"),+X=2!(+X=3) D EN^DDIOL("The A & C designation is not valid for schedule 2 or 3 narcotics !","","$C(7),!") K X Q 88 I $E(X)=1,X[2!(X[3)!(X[4)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 2-5 narcotics!","","$C(7),!") K X Q 89 I $E(X)=2,X[1!(X[3)!(X[4)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 1,3-5 narcotics!","","$C(7),!") K X Q 90 I $E(X)=3,X[1!(X[2)!(X[4)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 1-2,4-5 narcotics!","","$C(7),!") K X Q 91 I $E(X)=4,X[1!(X[2)!(X[3)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 1-3,5 narcotics!","","$C(7),!") K X Q 92 I $E(X)=5,X[1!(X[2)!(X[3)!(X[4) D EN^DDIOL("It contains other inappropriate schedule 1-4 narcotics!","","$C(7),!") K X Q 93 I $E(X)="E" D EN^DDIOL("Inappropriate E designation! Can only modify other codes.","","$C(7),!") K X Q 94 Q 95 ; 96 WRITE ;Calls EN^DDIOL to write text 97 D EN^DDIOL(.PSSHLP) K PSSHLP Q 98 Q 99 ; 100 PKIND I +$P($G(^PSDRUG(DA,"ND")),"^",3) S PSSK=$P(^("ND"),"^",3) D 101 .S PSSK=$$GET1^DIQ(50.68,PSSK,19,"I") I PSSK S PSSK=$$CSDEA^PSSDDUT2(PSSK) D 102 ..I $L(PSSK)=1,$P(^PSDRUG(DA,0),"^",3)[PSSK Q 103 ..I $P(^PSDRUG(DA,0),"^",3)[$E(PSSK),$P(^PSDRUG(DA,0),"^",3)[$E(PSSK,2) Q 104 ..W !!,"The CS Federal Schedule associated with this drug in the VA Product file" 105 ..W !,"represents a DEA, Special Handling code of "_PSSK 106 Q 107 ; 108 CSDEA(CS) ; 109 Q:'CS "" 110 Q $S(CS?1(1"2n",1"3n"):+CS_"C",+CS=2!(+CS=3)&(CS'["C"):+CS_"A",1:CS) 111 ; 112 CLOZ ;DEL node of DRUG file 50, fields 17.2, 17.3, 17.4 113 S PSSHLP(1)="To delete this field use the Unmark Clozapine Drug option in the" 114 S PSSHLP(2)="Clozapine Pharmacy Manager menu." 115 D WRITE 116 Q 117 ; 118 NONF ;Non-Formulary Input Transform DRUG file 50, field 51 119 S PSSHLP(1)="This drug cannot be marked as a non-formulary item because it is" 120 S PSSHLP(2)="designated as a formulary alternative for the following drugs." 121 S PSSHLP(3)=" ",PSSHLP(1,"F")="!!" 122 D WRITE 123 F MM=0:0 S MM=$O(^PSDRUG("AFA",DA,MM)) Q:'MM S SHEMP=$P(^PSDRUG(MM,0),"^") D EN^DDIOL(SHEMP,"","!?3") 124 S X="" 125 Q 126 ; 127 ATC ;Executable help for field 212.2, DRUG file 50 128 S PSSHLP(1)="The mnemonic entered here must match the mnemonic entered into the" 129 S PSSHLP(2)="ATC for this drug EXACTLY, and cannot be numbers only." 130 D WRITE 131 Q 132 ; 133 ADTM ;ADMINISTRATION SCHEDULE file 51.1, field 1 Executable Help 134 S PSSHLP(1)="ALL TIMES MUST BE THE SAME LENGTH (2 OR 4 CHARACTERS), MUST BE" 135 S PSSHLP(2)="SEPARATED BY DASHES ('-'), AND BE IN ASCENDING ORDER" 136 D WRITE 137 Q 138 ; 139 LBLS ;PHARMACY SYSTEM file 59.7, field 61.2 Executable Help 140 S PSSHLP(1)="ANY NEW LABELS OLDER THAN THE NUMBER OF DAYS SPECIFIED HERE WILL" 141 S PSSHLP(2)="AUTOMATICALLY BE PURGED." 142 D WRITE 143 Q 144 NFH I '$D(DA(1)) D EN^DDIOL(" (This non-formulary item is "_$P(^PSDRUG($S($D(DA(1)):DA(1),1:DA),0),"^")_".)") 145 Q 146 STRTH S STR=" "_$P(X," ",2),PSSHLP(1)=STR,PSSHLP(1,"F")="" D WRITE K STR 147 Q 148 PSYS1 D EN^DDIOL("(""From"" ward is "_$S('$D(^PS(59.7,D0,22,D1,0)):"UNKNOWN",'$D(^DIC(42,+^(0),0)):"UNKNOWN",$P(^(0),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_")","","!?3") 149 Q 150 PSYS2 ;PSS*1.0*95 151 D EN^DDIOL("(""From"" service is "_$S('$D(^PS(59.7,D0,23,D1,0)):"UNKNOWN",$P(^(0),"^")]"":$P($P(";"_$P(^DD(59.723,.01,0),"^",3),";"_$P(^PS(59.7,D0,23,D1,0),"^")_":",2),";"),1:"UNKNOWN")_")") 152 Q 153 ; 154 NCINIT ; 155 K PSSNQM,PSSNQM2,PSSNQM3,PSSONDU,PSSONQM 156 NCINIT1 ; 157 I $P($G(^PSDRUG(DA,"EPH")),"^",2)="" S $P(^PSDRUG(DA,"EPH"),"^",2)="EA",$P(^PSDRUG(DA,"EPH"),"^",3)=1 D 158 . S PSSHLP(1)=" Note: Defaulting the NCPDP DISPENSE UNIT to EACH and the" 159 . S PSSHLP(2)=" NCPDP QUANTITY MULTIPLIER to 1 (one)." S PSSHLP(1,"F")="!!" 160 . D WRITE S PSSHLP(2,"F")="!" D WRITE 161 S PSSONDU=$P(^PSDRUG(DA,"EPH"),"^",2),PSSONQM=$P(^PSDRUG(DA,"EPH"),"^",3) 162 Q 163 ; 164 NCPDPDU ;Drug file 50, field 82 165 S:X="" X="EA" 166 D NCINIT1:'$D(PSSONDU) 167 I $G(PSSONDU)'=X&($G(PSSONQM)'=1) D 168 . S PSSHLP(1)="Defaulting the NCPDP QUANTITY MULTIPLIER to 1 (one)." S PSSHLP(1,"F")="!!" D WRITE 169 . S $P(^PSDRUG(DA,"EPH"),"^",3)=1,PSSONDU=$P(^PSDRUG(DA,"EPH"),"^",2),PSSONQM=$P(^PSDRUG(DA,"EPH"),"^",3) 170 Q 171 ; 172 NCPDPQM ;Drug file 50, field 83 173 N ZXX S PSSNQM=0,(PSSNQM2,PSSNQM3)="" 174 I $G(X)<.001 K X S PSSNQM3=1 Q 175 S:$G(X)="" X=1 176 I +$G(X)'=1 D NCPDPWRN D 177 NCPDPQM1 . ; 178 . R !,"Ok to continue? (Y/N) ",ZXX:30 S ZXX=$TR(ZXX,"yn","YN") 179 . I ZXX="^" S X=1 W !!?5,"Warning: Defaulting NCPDP QUANTITY MULTIPLIER to 1 (one).",!! Q 180 . I ZXX'="Y"&(ZXX'="N") W !,"Y or N must be entered." G NCPDPQM1 181 . I ZXX'="Y"&(ZXX'="y") S PSSNQM=1,PSSNQM2=X K X 182 Q 183 ; 184 NCPDPWRN ; 185 S PSSHLP(2)="WARNING: For most drug products, the value for this field should be 1 (one)." 186 S PSSHLP(3)=" Answering NO for the following prompt will display more information" 187 S PSSHLP(4)=" on how this field is used." 188 S PSSHLP(2,"F")="!!" D WRITE 189 S PSSHLP(5,"F")="!" D WRITE 190 Q 191 ; -
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") -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSHLU.m
r613 r623 1 PSSHLU 2 ;;1.0;PHARMACY DATA MANAGEMENT;**38,124,132**;9/30/97;Build 1 3 4 INIT 5 6 7 8 9 10 11 SEGMENT(LIMIT) 12 13 14 15 16 17 18 19 20 21 22 CALL(HLEVN) 23 24 25 26 27 28 29 MF(HLEVN) 30 31 32 33 34 35 36 SCH(HLEVN) 37 38 39 40 41 USAGE(POI) 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 IVFLAG 57 58 1 PSSHLU ;BIR/RLW-UTILITIES USED IN BUILDING HL7 SEGMENTS ;11/14/96 2 ;;1.0;PHARMACY DATA MANAGEMENT;**38**;9/30/97 3 ; 4 INIT ; set up HL7 application variables 5 ;I '$D(HLNDAP) S HLNDAP=0,HLNDAP=$O(^HL(770,"B","OE/RR",HLNDAP)),HLSDT="PS" D INIT^HLTRANS I $D(HLERR) W !!?7,"THE HL7 INITIALIZATION FAILED",!! Q 6 S PSJI=1 7 S PSSHINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^") S ^TMP("HLS",$J,"PS",PSJI)="MSH|^~\&|PHARMACY|"_$G(PSSHINST)_"|||||MFN" K PSSHINST 8 S PSJCLEAR="F J=0:1:LIMIT S FIELD(J)=""""" 9 Q 10 ; 11 SEGMENT(LIMIT) ; 12 N SUBSEG,SEGLENGT S SUBSEG=0,SEGMENT(SUBSEG)="" F J=0:1:LIMIT D 13 .I SEGMENT(SUBSEG)']"" S SEGMENT(SUBSEG)=FIELD(J) Q 14 .S SEGLENGT=$L(SEGMENT(SUBSEG))+$L(FIELD(J)) 15 .I SEGLENGT<245 S SEGMENT(SUBSEG)=SEGMENT(SUBSEG)_"|"_FIELD(J) Q 16 .I $L(SEGMENT(SUBSEG))=245 S SUBSEG=SUBSEG+1,SEGMENT(SUBSEG)="|"_FIELD(J) Q 17 .S SEGMENT(SUBSEG)=SEGMENT(SUBSEG)_"|"_$E(FIELD(J),1,244-$L(SEGMENT(SUBSEG))),SUBSEG=SUBSEG+1,SEGMENT(SUBSEG)=$E(FIELD(J),SEGLENGT-245,SEGLENGT+1) 18 S PSJI=PSJI+1,^TMP("HLS",$J,"PS",PSJI)=SEGMENT(0) 19 F J=1:1 Q:'$D(SEGMENT(J)) S ^TMP("HLS",$J,"PS",PSJI,J)=SEGMENT(J) 20 Q 21 ; 22 CALL(HLEVN) ; call DHCP HL7 package -or- protocol, to pass Orders 23 ; HLEVN = number of segments in message 24 ;D EN^HLTRANS W:$D(HLERR) !!?7,"***ERROR IN CREATING HL7 MAIL MESSAGE***" 25 S MSG="^TMP(""HLS"",$J,""PS"")" 26 D MSG^XQOR("PS EVSEND OR",.MSG) 27 Q 28 ; 29 MF(HLEVN) ; call DHCP HL7 -or- protocol, to pass Master File transactions 30 ; HLEVN = number of segments in message 31 ;D EN^HLTRANS W:$D(HLERR) !!?7,"***ERROR IN CREATING HL7 MAIL MESSAGE***" 32 S MSG="^TMP(""HLS"",$J,""PS"")" 33 D MSG^XQOR("PS MFSEND OR",.MSG) 34 Q 35 ; 36 SCH(HLEVN) ; call to pass Schedule file to OE/RR 37 S MSG="^TMP(""HLS"",$J,""PS"")" 38 D MSG^XQOR("PS EVSEND SCH",.MSG) 39 Q 40 ; 41 USAGE(POI) ; 42 N USAGE,PSSDDINX,I F I="O","I","B","A","V" S USAGE(I)=0 43 I $P($G(^PS(50.7,POI,0)),"^",3) G IVFLAG 44 S I="" F PSSDDINX=0:0 S PSSDDINX=$O(^PS(50.7,"A50",POI,PSSDDINX)) Q:'PSSDDINX D 45 .I '$P($G(^PSDRUG(PSSDDINX,"I")),"^")!(+$P($G(^("I")),"^")>DT) D 46 ..S USAGE=$P($G(^PSDRUG(PSSDDINX,2)),"^",3),USAGE=$TR(USAGE,"U","I") F I="O","I" S:USAGE[I USAGE(I)=USAGE(I)+1 47 .N PSSOAD,PSSOSD 48 .F PSSOAD=0:0 S PSSOAD=$O(^PSDRUG("A526",PSSDDINX,PSSOAD)) Q:'PSSOAD D 49 ..Q:$P($G(^PS(52.6,PSSOAD,"I")),"^")&(+$P($G(^PS(52.6,PSSOAD,"I")),"^")'>DT) 50 ..S USAGE("I")=USAGE("I")+1,USAGE("V")=USAGE("V")+1 51 ..I $P($G(^PS(52.6,PSSOAD,0)),"^",13) S USAGE("A")=USAGE("A")+1 52 .F PSSOSD=0:0 S PSSOSD=$O(^PSDRUG("A527",PSSDDINX,PSSOSD)) Q:'PSSOSD D 53 ..Q:$P($G(^PS(52.7,PSSOSD,"I")),"^")&(+$P($G(^PS(52.7,PSSOSD,"I")),"^")'>DT) 54 ..S USAGE("I")=USAGE("I")+1,USAGE("V")=USAGE("V")+1 55 ..I $P($G(^PS(52.7,PSSOSD,0)),"^",13) S USAGE("B")=USAGE("B")+1 56 IVFLAG ; 57 S USAGE="" F I="O","I","B","A","V" S USAGE=USAGE_I_USAGE(I) 58 Q USAGE -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJORDF.m
r613 r623 1 PSSJORDF ;BIR/MV-RETURN MED ROUTES(MR) AND INSTRUCTIONS(INS) ;06/26/98 2 ;;1.0;PHARMACY DATA MANAGEMENT;**5,13,34,38,69,113,94**;9/30/97;Build 26 3 ;; 4 ; Reference to ^PS(50.7 is supported by DBIA 2180. 5 ; Reference to ^PS(51.2 is supported by DBIA 2178. 6 ; Reference to ^PS(50.606 is supported by DBIA 2174. 7 ; 8 ;* PSJORD is the Orderable Item IEN pass to Pharmacy by OE/RR. 9 ;* 1. If the dosage form is valid, this routine will return all med 10 ;* routes and instructions associated with that dose form. 11 ;* 2. If the dose form is null, this routine will return all med routes 12 ;* that exist in the medication routes file. 13 ;* 3. ^TMP format: 14 ;* ^TMP("PSJMR",$J,#)=MED ROUTE^MED ROUTE ABREVATION^IEN^OUTPATIENT 15 ;* EXPANSION^IV FLAG^DEFAULT FLAG 16 ;* ^TMP("PSJNOUN",$J,D0)=NOUN^VERB^PREPOSITION 17 ;* ^TMP("PSJSCH",$J)=DEFAULT SCHEDULE NAME 18 ; 19 START(PSJORD,PSJOPAC) ; 20 NEW MR,MRNODE,INS,PSJDFNO,X,MCT,Z,PSJOISC 21 I '+PSJORD D MEDROUTE Q 22 S PSJDFNO=+$P($G(^PS(50.7,+PSJORD,0)),U,2) 23 ;S ^TMP("PSJSCH",$J)=$P($G(^PS(50.7,+PSJORD,0)),"^",8) ;default schedule 24 S PSJOISC=$P($G(^PS(50.7,+PSJORD,0)),"^",8) 25 I $G(PSJOPAC)="O"!($G(PSJOPAC)="X") D:$G(PSJOISC)'="" EN^PSSOUTSC(.PSJOISC) S:$G(PSJOISC)'="" ^TMP("PSJSCH",$J)=$G(PSJOISC) G SCPASS 26 I $G(PSJOISC)'="" D EN^PSSGSGUI(.PSJOISC,"I") S:$G(PSJOISC)'="" ^TMP("PSJSCH",$J)=$G(PSJOISC) 27 SCPASS ; 28 I $G(^PS(50.606,PSJDFNO,0))="" D NOD Q:$D(^TMP("PSJMR",$J,1)) D MEDROUTE Q 29 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J) 30 D DF 31 Q 32 ; 33 DF ;* Loop thru DF node to find all available med routes, nouns, and instructions. 34 N VERB,MR,INS,X 35 S (MR,INS,X,MCT)=0 36 S VERB=$P($G(^PS(50.606,PSJDFNO,"MISC")),U) 37 S MR=+$P($G(^PS(50.7,+PSJORD,0)),"^",6) I MR,$D(^PS(51.2,MR,0)),$P($G(^(0)),"^",4)=1 S ^TMP("PSJMR",$J,1)=$P(^PS(51.2,MR,0),"^")_U_$P(^(0),"^",3)_U_MR_U_$P(^(0),"^",2)_U_$S($P(^(0),"^",6):1,1:0)_"^D",MCT=MCT+1 38 S MR=0 F S MR=$O(^PS(50.606,PSJDFNO,"MR",MR)) Q:'MR D 39 . S X=+$G(^PS(50.606,PSJDFNO,"MR",MR,0)) Q:'X!($P($G(^TMP("PSJMR",$J,1)),"^",3)=X) 40 . S MRNODE=$G(^PS(51.2,X,0)) 41 . I $P($G(MRNODE),"^",4)'=1 Q 42 . S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_X_U_$P(MRNODE,U,2)_U_$S($P(MRNODE,U,6):1,1:0) 43 S X=0 44 ;F S INS=$O(^PS(50.606,PSJDFNO,"INS",INS)) Q:'INS S X=X+1,^TMP("PSJINS",$J,X)=VERB_U_$G(^PS(50.606,PSJDFNO,"INS",INS,0)) 45 ;I '$D(^TMP("PSJINS",$J)),VERB]"" S ^TMP("PSJINS",$J,1)=VERB 46 S X=0 47 I $D(^PS(50.606,PSJDFNO,"NOUN")) F Z=0:0 S Z=$O(^PS(50.606,PSJDFNO,"NOUN",Z)) Q:'Z S X=X+1,^TMP("PSJNOUN",$J,X)=$P($G(^PS(50.606,PSJDFNO,"NOUN",Z,0)),U)_U_$P($G(^PS(50.606,PSJDFNO,"MISC")),U)_U_$P($G(^("MISC")),U,3) 48 Q 49 ; 50 MEDROUTE ;* Return all med routes in the med routes file. 51 S (MR,MCT)=0 K ^TMP("PSJMR",$J) 52 F S MR=$O(^PS(51.2,MR)) Q:'MR S MRNODE=^PS(51.2,MR,0) I $P(^PS(51.2,MR,0),"^",4)=1 S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_MR_U_$P(MRNODE,U,2)_U_$S($P(MRNODE,U,6):1,1:0) 53 Q 54 NOD K ^TMP("PSJMR",$J) 55 S MR=+$P($G(^PS(50.7,+PSJORD,0)),"^",6) I MR,$D(^PS(51.2,MR,0)),$P(^PS(51.2,MR,0),"^",4)=1 S ^TMP("PSJMR",$J,1)=$P(^PS(51.2,MR,0),"^")_U_$P(^(0),"^",3)_U_MR_U_$P(^(0),"^",2)_U_$S($P(^(0),"^",6):1,1:0)_"^D" 56 Q 57 START1(PSJORD,PSJQOF) ;Entry point for IV dialog PSS*1*94 58 ; This is the new entry point for the IV Dialog box from CPRS GUI 27. PSJORD will be an array 59 ; sent by CPRS that contains all the IENS for all orderable items that are part of the order. The zero node of the array 60 ; will contain the total number of orderable items in the order. 61 ; 62 ; PSJQOF is the quick order flag. 0=not a quick order 1=quick order 63 ; 64 ; If there is only one orderable item, any default defined in the Pharmacy Orderable Item file (50.7) will be 65 ; marked with a D at the end of the data string. 66 ; 67 ; If there is more than one orderable item in the order, no default will be sent, and a union (the overlapping) 68 ; of the med routes will be returned. For example if Dextrose can be given IV or IM, and the Ampicillin is only 69 ; given IM, IM is the only med route that will be returned because it is the only overlapping med route between 70 ; the two orderable items. If there is no overlapping med route to be returned, then a NULL will be returned to CPRS. 71 ; 72 ; If the quick order flag PSJQOF is set to 1, then CPRS is expecting the overlapping med routes for the orderable items 73 ; as well as the entire list of med routes that are flagged for IV's. 74 ; 75 I PSJQOF="" S PSJQOF=0 76 K PSJORD1,^TMP("PSJMR",$J) 77 I $G(PSJORD(0))=1 S PSJOPAC="I" D Q 78 . S PSJORD=$P($G(PSJORD(1)),"^",1) 79 . D MEDRT(PSJORD) 80 . I PSJQOF=1 S MCT=$O(^TMP("PSJMR",$J,"A"),-1) D ALLMED(MCT) 81 . M PSJORD1=^TMP("PSJMR",$J) 82 . D REMDUP 83 . K PSJORD 84 . M PSJORD=PSJORD1 85 . K PSJORD1,^TMP("PSJMR",$J) 86 S X=0 87 F S X=$O(PSJORD(X)) Q:X="" D 88 . S PSJORD=$P($G(PSJORD(X)),"^",1) 89 . D MEDRT(PSJORD) 90 . M PSJORD1(X)=^TMP("PSJMR",$J) K ^TMP("PSJMR",$J) ;Start with fresh TMP for each OI 91 D OVERLAP 92 I PSJQOF=1 S MCT=$O(MRTEMP2("A"),-1) D ALLMED(MCT) 93 M PSJORD1=^TMP("PSJMR",$J) 94 D REMDUP 95 K PSJORD 96 M PSJORD=PSJORD1 97 K PSJORD1,MRTEMP2,MRTEMP,MRNODE,MRNODE1,^TMP("PSJMR",$J),PSSCNTR1 98 Q 99 MEDRT(PSJORD) ;All Med Routes for dosage form. 100 N MR,X,PSJDFNO,MCT 101 S (MR,MCT,X,PSJDFNO)=0 102 S PSJDFNO=+$P($G(^PS(50.7,+PSJORD,0)),U,2) 103 S MR=+$P($G(^PS(50.7,+PSJORD,0)),"^",6) I MR,$D(^PS(51.2,MR,0)),$P($G(^(0)),"^",4)=1 S ^TMP("PSJMR",$J,1)=MR_U_$P(^PS(51.2,MR,0),"^")_U_$P(^(0),"^",3)_U_$P(^(0),"^",2)_U_"D",MCT=MCT+1 104 S MR=0 F S MR=$O(^PS(50.606,PSJDFNO,"MR",MR)) Q:'MR D 105 . S X=+$G(^PS(50.606,PSJDFNO,"MR",MR,0)) 106 . I X=$P($G(^PS(50.7,+PSJORD,0)),"^",6) Q ;Already counted as the default. Don't count twice. 107 . S MRNODE=$G(^PS(51.2,X,0)) 108 . I $P($G(MRNODE),"^",4)'=1 Q 109 . S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=X_U_$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_$P(MRNODE,U,2)_U 110 Q 111 ALLMED(MCT) ;Return all med routes with IV flag set to 1 112 N MR,MRNODE 113 I MCT="" S MCT=0 114 S (MR,MRNODE)="" 115 F S MR=$O(^PS(51.2,MR)) Q:MR="" D 116 . S MRNODE=$G(^PS(51.2,MR,0)) 117 . I $P(MRNODE,U,4)'=1 Q ;Not defined for all packages 118 . I $P(MRNODE,U,6)'=1 Q ;IV flag not set 119 . S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=MR_U_$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_$P(MRNODE,U,2)_U 120 Q 121 OVERLAP ; Only maintains any overlapping med routes between orderable items in order 122 N MR,MRNODE,X,PSSCNTR1 123 K MRTEMP,MRTEMP2 124 S (MR,MRNODE,X)="" 125 F S X=$O(PSJORD1(X)) Q:X="" D 126 . F S MR=$O(PSJORD1(X,MR)) Q:MR="" D 127 . . S MRNODE=$P($G(PSJORD1(X,MR)),"^",1) 128 . . S MRTEMP(MRNODE)=$G(MRTEMP(MRNODE))+1 129 S MR="" 130 F S MR=$O(MRTEMP(MR)) Q:MR="" D 131 . I MRTEMP(MR)'=$G(PSJORD(0)) K MRTEMP(MR) Q 132 I '$D(MRTEMP) K PSJORD1 S PSJORD1="" Q ;No overlapping med routes between orderable items. 133 S (MR,MRNODE)="",PSSCNTR1=1 134 F S MR=$O(MRTEMP(MR)) Q:MR="" D 135 . S MRNODE=$G(^PS(51.2,MR,0)) 136 . S MRTEMP2(PSSCNTR1)=MR_U_$P(MRNODE,U,1)_U_$P(MRNODE,U,3)_U_$P(MRNODE,U,2)_U,PSSCNTR1=PSSCNTR1+1 137 K PSJORD1,MRTEMP 138 M PSJORD1=MRTEMP2 139 Q 140 REMDUP ; Remove duplicate entries 141 N MR,MRNODE 142 S MR="",MRNODE="" 143 F S MR=$O(PSJORD1(MR)) Q:MR="" D 144 . S MRNODE=$P($G(PSJORD1(MR)),"^",2) 145 . I $D(MRTEMP(MRNODE)) K PSJORD1(MR) Q 146 . S MRTEMP(MRNODE)=$G(PSJORD1(MR)) 147 . I MR=1,$P($G(PSJORD1(MR)),"^",5)="D" S MRTEMP(MR)=PSJORD1(MR) Q ;Maintain default if there is one. 148 . S MRTEMP(MR)=PSJORD1(MR) 149 S MR="" 150 F S MR=$O(MRTEMP(MR)) Q:MR="" D 151 . I MR'?1.N K MRTEMP(MR) 152 I PSJORD(0)=1 M PSJORD1=MRTEMP 153 K MRTEMP 154 Q 1 PSSJORDF ;BIR/MV-RETURN MED ROUTES(MR) AND INSTRUCTIONS(INS) ;06/26/98 2 ;;1.0;PHARMACY DATA MANAGEMENT;**5,13,34,38,69,113**;9/30/97;Build 1 3 ;; 4 ;* PSJORD is the Orderable Item IEN pass to Pharmacy by OE/RR. 5 ;* 1. If the dosage form is valid, this routine will return all med 6 ;* routes and instructions associated with that dose form. 7 ;* 2. If the dose form is null, this routine will return all med routes 8 ;* that exist in the medication routes file. 9 ;* 3. ^TMP format: 10 ;* ^TMP("PSJMR",$J,#)=MED ROUTE^MED ROUTE ABREVATION^IEN^OUTPATIENT 11 ;* EXPANSION^IV FLAG^DEFAULT FLAG 12 ;* ^TMP("PSJNOUN",$J,D0)=NOUN^VERB^PREPOSITION 13 ;* ^TMP("PSJSCH",$J)=DEFAULT SCHEDULE NAME 14 ; 15 START(PSJORD,PSJOPAC) ; 16 NEW MR,MRNODE,INS,PSJDFNO,X,MCT,Z,PSJOISC 17 I '+PSJORD D MEDROUTE Q 18 S PSJDFNO=+$P($G(^PS(50.7,+PSJORD,0)),U,2) 19 ;S ^TMP("PSJSCH",$J)=$P($G(^PS(50.7,+PSJORD,0)),"^",8) ;default schedule 20 S PSJOISC=$P($G(^PS(50.7,+PSJORD,0)),"^",8) 21 I $G(PSJOPAC)="O"!($G(PSJOPAC)="X") D:$G(PSJOISC)'="" EN^PSSOUTSC(.PSJOISC) S:$G(PSJOISC)'="" ^TMP("PSJSCH",$J)=$G(PSJOISC) G SCPASS 22 I $G(PSJOISC)'="" D EN^PSSGSGUI(.PSJOISC,"I") S:$G(PSJOISC)'="" ^TMP("PSJSCH",$J)=$G(PSJOISC) 23 SCPASS ; 24 I $G(^PS(50.606,PSJDFNO,0))="" D NOD Q:$D(^TMP("PSJMR",$J,1)) D MEDROUTE Q 25 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J) 26 D DF 27 Q 28 ; 29 DF ;* Loop thru DF node to find all available med routes, nouns, and instructions. 30 N VERB,MR,INS,X 31 S (MR,INS,X,MCT)=0 32 S VERB=$P($G(^PS(50.606,PSJDFNO,"MISC")),U) 33 S MR=+$P($G(^PS(50.7,+PSJORD,0)),"^",6) I MR,$D(^PS(51.2,MR,0)),$P($G(^(0)),"^",4)=1 S ^TMP("PSJMR",$J,1)=$P(^PS(51.2,MR,0),"^")_U_$P(^(0),"^",3)_U_MR_U_$P(^(0),"^",2)_U_$S($P(^(0),"^",6):1,1:0)_"^D",MCT=MCT+1 34 S MR=0 F S MR=$O(^PS(50.606,PSJDFNO,"MR",MR)) Q:'MR D 35 . S X=+$G(^PS(50.606,PSJDFNO,"MR",MR,0)) Q:'X!($P($G(^TMP("PSJMR",$J,1)),"^",3)=X) 36 . S MRNODE=$G(^PS(51.2,X,0)) 37 . I $P($G(MRNODE),"^",4)'=1 Q 38 . S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_X_U_$P(MRNODE,U,2)_U_$S($P(MRNODE,U,6):1,1:0) 39 S X=0 40 ;F S INS=$O(^PS(50.606,PSJDFNO,"INS",INS)) Q:'INS S X=X+1,^TMP("PSJINS",$J,X)=VERB_U_$G(^PS(50.606,PSJDFNO,"INS",INS,0)) 41 ;I '$D(^TMP("PSJINS",$J)),VERB]"" S ^TMP("PSJINS",$J,1)=VERB 42 S X=0 43 I $D(^PS(50.606,PSJDFNO,"NOUN")) F Z=0:0 S Z=$O(^PS(50.606,PSJDFNO,"NOUN",Z)) Q:'Z S X=X+1,^TMP("PSJNOUN",$J,X)=$P($G(^PS(50.606,PSJDFNO,"NOUN",Z,0)),U)_U_$P($G(^PS(50.606,PSJDFNO,"MISC")),U)_U_$P($G(^("MISC")),U,3) 44 Q 45 ; 46 MEDROUTE ;* Return all med routes in the med routes file. 47 S (MR,MCT)=0 K ^TMP("PSJMR",$J) 48 F S MR=$O(^PS(51.2,MR)) Q:'MR S MRNODE=^PS(51.2,MR,0) I $P(^PS(51.2,MR,0),"^",4)=1 S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_MR_U_$P(MRNODE,U,2)_U_$S($P(MRNODE,U,6):1,1:0) 49 Q 50 NOD K ^TMP("PSJMR",$J) 51 S MR=+$P($G(^PS(50.7,+PSJORD,0)),"^",6) I MR,$D(^PS(51.2,MR,0)),$P(^PS(51.2,MR,0),"^",4)=1 S ^TMP("PSJMR",$J,1)=$P(^PS(51.2,MR,0),"^")_U_$P(^(0),"^",3)_U_MR_U_$P(^(0),"^",2)_U_$S($P(^(0),"^",6):1,1:0)_"^D" 52 Q -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSMARK.m
r613 r623 1 PSSMARK ;BIR/WRT-Review single NDF matches for CMOP ; 10/27/98 13:44 2 ;;1.0;PHARMACY DATA MANAGEMENT;**15,17,20,28,57,82,124**;9/30/97;Build 2 3 ; 4 ;Reference to ^PS(59 supported by DBIA #1976 5 ;Reference to ^PS(50.605 supported by DBIA #2138 6 ;Reference to ^PSNTRAN("END" supported by DBIA #2527 7 ;Reference to $$PROD2^PSNAPIS(P1,P3) supported by DBIA #2531 8 ; 9 PICK S U="^" S PSXFL=0 D TEXT F PSXMM=1:1 D PICK1 S:'$D(PSXFL) PSXFL=0 Q:PSXFL 10 DONE K PSXBT,PSXF,PSXFL,PSXVAP,PSXVP,PSXGN,PSXUM,PSXDN,PSXDP,PSXCMOP,PSXLOC,PSXZERO,PSXODE,PSXMM,PSXOU,PSXG,X,Y,PSXIDENT,PSXNDF,PSXVAPN,NONCE,PSXNEXT,PSXLAST,RTC,PSXNOW,PSXID,PSSEXP 11 Q 12 TEXT W !!,"This option allows you to choose entries from your drug file and helps you",!,"review your NDF matches and mark individual entries to send to CMOP.",! 13 W !,"If you mark the entry to transmit to CMOP, it will replace your Dispense Unit",!,"with the VA Dispense Unit. In addition, you may overwrite the local drug name",!,"with the VA Print Name and the entry will remain uneditable.",! 14 Q 15 DISPLAY W @IOF W !!?3,"Local Drug Generic Name: ",PSXLOC W !!,?16,"ORDER UNIT: " 16 I $D(^PSDRUG(PSXUM,660)) S PSXODE=^PSDRUG(PSXUM,660) I $P(PSXODE,"^",2) S PSXOU=$P(PSXODE,"^",2) I $D(^DIC(51.5)),$D(^DIC(51.5,PSXOU)) W ?28,$S('$D(PSXOU):"",1:$P(^DIC(51.5,PSXOU,0),"^",1)) 17 W !,"DISPENSE UNITS/ORDER UNITS: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",5)),!,?13,"DISPENSE UNIT: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",8)),!," PRICE PER DISPENSE UNIT: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",6)) 18 W !!,"VA Print Name: ",PSXVAP,?59,"VA Dispense Unit: ",PSXDP,!,"VA Drug Class: ",$P(^PS(50.605,$P(PSXDN,"^",6),0),"^",1),?50,"CMOP ID: ",PSXID D CHECK 19 Q 20 CHECK I $D(^PSDRUG("AQ",PSXUM)),$P(^PSDRUG(PSXUM,3),"^",1)=1 D UNMARK 21 Q:PSXBT=1 I '$D(^PSDRUG("AQ",PSXUM)) D MARK 22 Q 23 MARK Q:PSXBT=1 W !!,"Do you wish to mark this drug to transmit to CMOP? " K DIR S DIR(0)="Y" D ^DIR D OUT I "Nn^"[X K X,Y,DIRUT S PSXBT=1,PSXF=1 Q:PSXF=1 Q:PSXBT=1 24 I "Yy"[X S $P(^PSDRUG(PSXUM,660),"^",8)=PSXDP,^PSDRUG(PSXUM,3)=1,^PSDRUG("AQ",PSXUM)="",DA=PSXUM D ^PSSREF,IDENT K DA D QDM,QUEST,QUES2 S PSXF=1 25 Q 26 UNMARK Q:PSXF=1 W !!,"Do you wish to UNmark this drug to transmit to CMOP? " K DIR S DIR(0)="Y" D ^DIR D OUT I "Nn^"[X K X,Y,DIRUT S PSXF=1 Q 27 I "Yy"[X S $P(^PSDRUG(PSXUM,3),"^",1)=0 K ^PSDRUG("AQ",PSXUM) S DA=PSXUM D ^PSSREF K DA S PSXF=1,PSXBT=1 Q:PSXBT=1 28 Q 29 QUES2 W !!,"Do you wish to overwrite your local name? " K DIR S DIR(0)="Y",DIR("?")="If you answer ""yes"", you will overwrite GENERIC NAME with the VA Print Name." D ^DIR D OUT I "Nn^"[X D SYN K X,Y,DIRUT S PSXG=1 Q:PSXG=1 30 I "Yy"[X D DUP I '$D(^PSDRUG("B",PSXVAP)) S $P(^PSDRUG(PSXUM,0),"^",1)=PSXVAP D XREF,OLDNM S PSXF=1,PSXG=1 31 Q 32 DUP I PSXVAP'=PSXLOC,$D(^PSDRUG("B",PSXVAP)) W !,"You cannot write over the GENERIC NAME because one already has that",!,"VA Print Name. You cannot have duplicate names.",! 33 Q 34 XREF K:PSXLOC'=PSXVAP ^PSDRUG("B",PSXLOC,PSXUM) S:PSXLOC'=PSXVAP ^PSDRUG("B",PSXVAP,PSXUM)="" I $D(^PSNTRAN(PSXUM,"END")) S $P(^PSNTRAN(PSXUM,"END"),"^",3)=PSXVAP,$P(^PSNTRAN("END"),"^",3)=PSXVAP 35 Q 36 BLD ; 37 I $D(^PSDRUG(PSXUM,"I")) D ;; <*124 RJS 38 .N X,X1,X2 39 .S X1=$G(^PSDRUG(PSXUM,"I")),X2=DT D ^%DTC 40 .S:X<1 PSSEXP(1)="It has been inactivated." ;; *124 RJS > 41 I $D(^PSDRUG(PSXUM,2)),$P(^PSDRUG(PSXUM,2),"^",3)'["O" S PSSEXP(2)="It is not marked for outpatient pharmacy use." 42 BLD5 I $P(^PSDRUG(PSXUM,0),"^",3)[1!($P(^(0),"^",3)[2) S PSSEXP(3)="It is a schedule I or schedule II controlled substance." 43 I '$D(^PSDRUG(PSXUM,"ND")) S PSSEXP(4)="It is not matched to NDF." 44 I $D(^PSDRUG(PSXUM,"ND")),$P(^PSDRUG(PSXUM,"ND"),"^",2)']"" S PSSEXP(5)="It is not matched to NDF." 45 ; 46 BLD1 S PSSXX="" I $D(^PSDRUG(PSXUM,"ND")) S PSXDN=^PSDRUG(PSXUM,"ND"),PSXGN=$P(PSXDN,"^",1),PSXVP=$P(PSXDN,"^",3) S PSSXX=$$PROD2^PSNAPIS(PSXGN,PSXVP) 47 I $P(PSSXX,"^",3)'=1 S PSSEXP(6)="It is not marked for CMOP in NDF." Q 48 I '$O(PSSEXP(0)),PSSXX]"",$P(PSSXX,"^",3)=1 S PSXVAP=$P(PSSXX,"^"),PSXDP=$P(PSSXX,"^",4) 49 Q 50 PICK1 S DIC="^PSDRUG(",DIC(0)="QEAM" D ^DIC K DIC I Y<0 S PSXFL=1 Q 51 K PSSEXP 52 S PSXUM=+Y,PSXLOC=$P(Y,"^",2) S PSSEXP(0)="",PSXF=0,PSXBT=0 D BLD 53 PICK2 I $O(PSSEXP(0)) W !!,"This drug cannot be marked for the following reason(s).",! F PSSXX=0:0 S PSSXX=$O(PSSEXP(PSSXX)) Q:'PSSXX W !,PSSEXP(PSSXX) 54 I $O(PSSEXP(0)) K PSSEXP W ! Q 55 GOTIT S PSXID=$P(PSSXX,"^",2),PSXZERO=^PSDRUG(PSXUM,0) D DISPLAY 56 N XX,DNSNAM,DNSPORT,DVER,DMFU S XX="" 57 I '$G(PSSHUIDG) D DRG^PSSHUIDG(PSXUM) D Q:PSXF Q:PSXBT 58 . F XX=0:0 S XX=$O(^PS(59,XX)) Q:'XX D 59 ..S DVER=$$GET1^DIQ(59,XX_",",105,"I"),DMFU=$$GET1^DIQ(59,XX_",",105.2) 60 ..I DVER="2.4" S DNSNAM=$$GET1^DIQ(59,XX_",",2006),DNSPORT=$$GET1^DIQ(59,XX_",",2007) D:$G(DNSNAM)&(DMFU="YES") DRG^PSSDGUPD(PSXUM,"",DNSNAM,DNSPORT) 61 Q 62 OUT I $D(DTOUT),DTOUT=1 S PSXFL=1 63 Q 64 IDENT S PSXNDF=$P(^PSDRUG(PSXUM,"ND"),"^",1),PSXVAPN=$P(^PSDRUG(PSXUM,"ND"),"^",3),DA=PSXNDF,K=PSXVAPN S X=$$PROD2^PSNAPIS(DA,K),PSXIDENT=$P(X,"^",2),$P(^PSDRUG(PSXUM,"ND"),"^",10)=PSXIDENT,^PSDRUG("AQ1",PSXIDENT,PSXUM)="" 65 Q 66 QUEST I $D(PSXODE),$P(PSXODE,"^",8)'=PSXDP W !!,"Your old Dispense Unit ",$P(PSXODE,"^",8)," does not match the new one ",PSXDP,".",!,"You may wish to edit the Price Per Order Unit and/or The Dispense",!,"Units Per Order Unit.",! D QUESTA 67 Q 68 QUESTA S DIE="^PSDRUG(",DA=PSXUM,DR="13;15",DIE("NO^")="BACK" D ^DIE K DIE("NO^") 69 Q 70 OLDNM D OLD I $D(NONCE) D OLD1 71 Q 72 OLD D NOW^%DTC I $D(^PSDRUG(PSXUM,900,1,0)) S NONCE=0,PSXLAST=0 F RTC=0:0 S RTC=$O(^PSDRUG(PSXUM,900,RTC)) Q:'RTC S PSXLAST=PSXLAST+1,PSXNEXT=PSXLAST+1 73 I '$D(^PSDRUG(PSXUM,900,1,0)) S ^PSDRUG(PSXUM,900,1,0)=PSXLOC_"^"_X 74 Q 75 OLD1 I NONCE=0 S ^PSDRUG(PSXUM,900,PSXNEXT,0)=PSXLOC_"^"_X,NONCE=1 76 Q 77 SYN S:'$D(^PSDRUG(PSXUM,1,0)) ^PSDRUG(PSXUM,1,0)="^50.1A^0^0" I '$D(^PSDRUG("C",PSXVAP,PSXUM)) S PSXNOW=$P(^PSDRUG(PSXUM,1,0),"^",3)+1,^PSDRUG(PSXUM,1,PSXNOW,0)=PSXVAP,^PSDRUG("C",PSXVAP,PSXUM,PSXNOW)="" D SYN1 78 Q 79 SYN1 S $P(^PSDRUG(PSXUM,1,0),"^",3)=PSXNOW,$P(^PSDRUG(PSXUM,1,0),"^",4)=$P(^PSDRUG(PSXUM,1,0),"^",4)+1 80 Q 81 QDM S DIE="^PSDRUG(",DA=PSXUM,DR=215 D ^DIE 82 Q 1 PSSMARK ;BIR/WRT-Review single NDF matches for CMOP ; 10/27/98 13:44 2 ;;1.0;PHARMACY DATA MANAGEMENT;**15,17,20,28,57,82**;9/30/97 3 ; 4 ;Reference to ^PS(59 supported by DBIA #1976 5 ;Reference to ^PS(50.605 supported by DBIA #2138 6 ;Reference to ^PSNTRAN("END" supported by DBIA #2527 7 ;Reference to $$PROD2^PSNAPIS(P1,P3) supported by DBIA #2531 8 ; 9 PICK S U="^" S PSXFL=0 D TEXT F PSXMM=1:1 D PICK1 S:'$D(PSXFL) PSXFL=0 Q:PSXFL 10 DONE K PSXBT,PSXF,PSXFL,PSXVAP,PSXVP,PSXGN,PSXUM,PSXDN,PSXDP,PSXCMOP,PSXLOC,PSXZERO,PSXODE,PSXMM,PSXOU,PSXG,X,Y,PSXIDENT,PSXNDF,PSXVAPN,NONCE,PSXNEXT,PSXLAST,RTC,PSXNOW,PSXID,PSSEXP 11 Q 12 TEXT W !!,"This option allows you to choose entries from your drug file and helps you",!,"review your NDF matches and mark individual entries to send to CMOP.",! 13 W !,"If you mark the entry to transmit to CMOP, it will replace your Dispense Unit",!,"with the VA Dispense Unit. In addition, you may overwrite the local drug name",!,"with the VA Print Name and the entry will remain uneditable.",! 14 Q 15 DISPLAY W @IOF W !!?3,"Local Drug Generic Name: ",PSXLOC W !!,?16,"ORDER UNIT: " 16 I $D(^PSDRUG(PSXUM,660)) S PSXODE=^PSDRUG(PSXUM,660) I $P(PSXODE,"^",2) S PSXOU=$P(PSXODE,"^",2) I $D(^DIC(51.5)),$D(^DIC(51.5,PSXOU)) W ?28,$S('$D(PSXOU):"",1:$P(^DIC(51.5,PSXOU,0),"^",1)) 17 W !,"DISPENSE UNITS/ORDER UNITS: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",5)),!,?13,"DISPENSE UNIT: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",8)),!," PRICE PER DISPENSE UNIT: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",6)) 18 W !!,"VA Print Name: ",PSXVAP,?59,"VA Dispense Unit: ",PSXDP,!,"VA Drug Class: ",$P(^PS(50.605,$P(PSXDN,"^",6),0),"^",1),?50,"CMOP ID: ",PSXID D CHECK 19 Q 20 CHECK I $D(^PSDRUG("AQ",PSXUM)),$P(^PSDRUG(PSXUM,3),"^",1)=1 D UNMARK 21 Q:PSXBT=1 I '$D(^PSDRUG("AQ",PSXUM)) D MARK 22 Q 23 MARK Q:PSXBT=1 W !!,"Do you wish to mark this drug to transmit to CMOP? " K DIR S DIR(0)="Y" D ^DIR D OUT I "Nn^"[X K X,Y,DIRUT S PSXBT=1,PSXF=1 Q:PSXF=1 Q:PSXBT=1 24 I "Yy"[X S $P(^PSDRUG(PSXUM,660),"^",8)=PSXDP,^PSDRUG(PSXUM,3)=1,^PSDRUG("AQ",PSXUM)="",DA=PSXUM D ^PSSREF,IDENT K DA D QDM,QUEST,QUES2 S PSXF=1 25 Q 26 UNMARK Q:PSXF=1 W !!,"Do you wish to UNmark this drug to transmit to CMOP? " K DIR S DIR(0)="Y" D ^DIR D OUT I "Nn^"[X K X,Y,DIRUT S PSXF=1 Q 27 I "Yy"[X S $P(^PSDRUG(PSXUM,3),"^",1)=0 K ^PSDRUG("AQ",PSXUM) S DA=PSXUM D ^PSSREF K DA S PSXF=1,PSXBT=1 Q:PSXBT=1 28 Q 29 QUES2 W !!,"Do you wish to overwrite your local name? " K DIR S DIR(0)="Y",DIR("?")="If you answer ""yes"", you will overwrite GENERIC NAME with the VA Print Name." D ^DIR D OUT I "Nn^"[X D SYN K X,Y,DIRUT S PSXG=1 Q:PSXG=1 30 I "Yy"[X D DUP I '$D(^PSDRUG("B",PSXVAP)) S $P(^PSDRUG(PSXUM,0),"^",1)=PSXVAP D XREF,OLDNM S PSXF=1,PSXG=1 31 Q 32 DUP I PSXVAP'=PSXLOC,$D(^PSDRUG("B",PSXVAP)) W !,"You cannot write over the GENERIC NAME because one already has that",!,"VA Print Name. You cannot have duplicate names.",! 33 Q 34 XREF K:PSXLOC'=PSXVAP ^PSDRUG("B",PSXLOC,PSXUM) S:PSXLOC'=PSXVAP ^PSDRUG("B",PSXVAP,PSXUM)="" I $D(^PSNTRAN(PSXUM,"END")) S $P(^PSNTRAN(PSXUM,"END"),"^",3)=PSXVAP,$P(^PSNTRAN("END"),"^",3)=PSXVAP 35 Q 36 BLD ; 37 I $D(^PSDRUG(PSXUM,"I")) S PSSEXP(1)="It has been inactivated." 38 I $D(^PSDRUG(PSXUM,2)),$P(^PSDRUG(PSXUM,2),"^",3)'["O" S PSSEXP(2)="It is not marked for outpatient pharmacy use." 39 BLD5 I $P(^PSDRUG(PSXUM,0),"^",3)[1!($P(^(0),"^",3)[2) S PSSEXP(3)="It is a schedule I or schedule II controlled substance." 40 I '$D(^PSDRUG(PSXUM,"ND")) S PSSEXP(4)="It is not matched to NDF." 41 I $D(^PSDRUG(PSXUM,"ND")),$P(^PSDRUG(PSXUM,"ND"),"^",2)']"" S PSSEXP(5)="It is not matched to NDF." 42 ; 43 BLD1 S PSSXX="" I $D(^PSDRUG(PSXUM,"ND")) S PSXDN=^PSDRUG(PSXUM,"ND"),PSXGN=$P(PSXDN,"^",1),PSXVP=$P(PSXDN,"^",3) S PSSXX=$$PROD2^PSNAPIS(PSXGN,PSXVP) 44 I $P(PSSXX,"^",3)'=1 S PSSEXP(6)="It is not marked for CMOP in NDF." Q 45 I '$O(PSSEXP(0)),PSSXX]"",$P(PSSXX,"^",3)=1 S PSXVAP=$P(PSSXX,"^"),PSXDP=$P(PSSXX,"^",4) 46 Q 47 PICK1 S DIC="^PSDRUG(",DIC(0)="QEAM" D ^DIC K DIC I Y<0 S PSXFL=1 Q 48 K PSSEXP 49 S PSXUM=+Y,PSXLOC=$P(Y,"^",2) S PSSEXP(0)="",PSXF=0,PSXBT=0 D BLD 50 PICK2 I $O(PSSEXP(0)) W !!,"This drug cannot be marked for the following reason(s).",! F PSSXX=0:0 S PSSXX=$O(PSSEXP(PSSXX)) Q:'PSSXX W !,PSSEXP(PSSXX) 51 I $O(PSSEXP(0)) K PSSEXP W ! Q 52 GOTIT S PSXID=$P(PSSXX,"^",2),PSXZERO=^PSDRUG(PSXUM,0) D DISPLAY 53 N XX,DNSNAM,DNSPORT,DVER,DMFU S XX="" 54 I '$G(PSSHUIDG) D DRG^PSSHUIDG(PSXUM) D Q:PSXF Q:PSXBT 55 . F XX=0:0 S XX=$O(^PS(59,XX)) Q:'XX D 56 ..S DVER=$$GET1^DIQ(59,XX_",",105,"I"),DMFU=$$GET1^DIQ(59,XX_",",105.2) 57 ..I DVER="2.4" S DNSNAM=$$GET1^DIQ(59,XX_",",2006),DNSPORT=$$GET1^DIQ(59,XX_",",2007) D:$G(DNSNAM)&(DMFU="YES") DRG^PSSDGUPD(PSXUM,"",DNSNAM,DNSPORT) 58 Q 59 OUT I $D(DTOUT),DTOUT=1 S PSXFL=1 60 Q 61 IDENT S PSXNDF=$P(^PSDRUG(PSXUM,"ND"),"^",1),PSXVAPN=$P(^PSDRUG(PSXUM,"ND"),"^",3),DA=PSXNDF,K=PSXVAPN S X=$$PROD2^PSNAPIS(DA,K),PSXIDENT=$P(X,"^",2),$P(^PSDRUG(PSXUM,"ND"),"^",10)=PSXIDENT,^PSDRUG("AQ1",PSXIDENT,PSXUM)="" 62 Q 63 QUEST I $D(PSXODE),$P(PSXODE,"^",8)'=PSXDP W !!,"Your old Dispense Unit ",$P(PSXODE,"^",8)," does not match the new one ",PSXDP,".",!,"You may wish to edit the Price Per Order Unit and/or The Dispense",!,"Units Per Order Unit.",! D QUESTA 64 Q 65 QUESTA S DIE="^PSDRUG(",DA=PSXUM,DR="13;15",DIE("NO^")="BACK" D ^DIE K DIE("NO^") 66 Q 67 OLDNM D OLD I $D(NONCE) D OLD1 68 Q 69 OLD D NOW^%DTC I $D(^PSDRUG(PSXUM,900,1,0)) S NONCE=0,PSXLAST=0 F RTC=0:0 S RTC=$O(^PSDRUG(PSXUM,900,RTC)) Q:'RTC S PSXLAST=PSXLAST+1,PSXNEXT=PSXLAST+1 70 I '$D(^PSDRUG(PSXUM,900,1,0)) S ^PSDRUG(PSXUM,900,1,0)=PSXLOC_"^"_X 71 Q 72 OLD1 I NONCE=0 S ^PSDRUG(PSXUM,900,PSXNEXT,0)=PSXLOC_"^"_X,NONCE=1 73 Q 74 SYN S:'$D(^PSDRUG(PSXUM,1,0)) ^PSDRUG(PSXUM,1,0)="^50.1A^0^0" I '$D(^PSDRUG("C",PSXVAP,PSXUM)) S PSXNOW=$P(^PSDRUG(PSXUM,1,0),"^",3)+1,^PSDRUG(PSXUM,1,PSXNOW,0)=PSXVAP,^PSDRUG("C",PSXVAP,PSXUM,PSXNOW)="" D SYN1 75 Q 76 SYN1 S $P(^PSDRUG(PSXUM,1,0),"^",3)=PSXNOW,$P(^PSDRUG(PSXUM,1,0),"^",4)=$P(^PSDRUG(PSXUM,1,0),"^",4)+1 77 Q 78 QDM S DIE="^PSDRUG(",DA=PSXUM,DR=215 D ^DIE 79 Q -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSQOC.m
r613 r623 1 PSSQOC 2 ;;1.0;PHARMACY DATA MANAGEMENT;*100,123*;9/30/97;Build 6 3 4 5 6 EN(PROTIEN) 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1 23 24 25 .S UNITS=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL",U,+$P(Y,U,3))26 27 28 29 30 31 32 33 34 35 36 37 38 2 39 40 41 42 43 44 45 46 47 48 GTPC 49 50 51 52 53 54 ENI 55 56 57 58 59 60 61 SPSOL 1 PSSQOC ;BIR/MLM-CONVERT PSJ 4.5 QUICK ORDERS FOR USE IN OE/RR 3.0 ;09/09/97 2 ;;1.0;PHARMACY DATA MANAGEMENT;*100*;9/30/97 3 ;External reference to ^ORD(101 supported by DBIA 872 4 ;External reference to ^PS(57.1 supported by DBIA 2139 5 ; 6 EN(PROTIEN) ; 7 N DD,OI,ND0,ND1,PSJBAD,TVOLUME,X S (PSJBAD,TVOLUME)=0 K ^TMP("PSJQO",$J) 8 S PSJQOPTR=+$E($P($P($G(^ORD(101,+PROTIEN,0)),U)," "),5,99) 9 S ND0=$G(^PS(57.1,PSJQOPTR,0)),ND1=$G(^(1)) I ND0=""!(ND1="") Q 10 I $P(ND0,U,3)'=1,$P(ND0,U,3)'=2 Q 11 D @$P(ND0,U,3) Q:'OI 12 S ^TMP("PSJQO",$J,1)=$P(ND0,U)_U_$P(ND0,U,3)_U_OI_U_$P(ND1,U,2,6) 13 S:$G(DD) ^TMP("PSJQO",$J,"DD")=DD 14 D GTPC 15 ; check infusion rate 16 S X=$P(ND1,"^",5) I $G(X) D 17 .D ENI K FREQ I '$D(X) S PSJBAD=1 18 .E S $P(^TMP("PSJQO",$J,1),"^",7)=X 19 K:PSJBAD=1 ^TMP("PSJQO",$J) 20 Q 21 ; 22 1 ; Convert IV Fluid Quick Order 23 S CNT=0 F X=0:0 S X=$O(^PS(57.1,PSJQOPTR,3,X)) Q:'X D 24 .S Y=$G(^PS(52.6,+$G(^PS(57.1,PSJQOPTR,3,X,0)),0)),OI=$P(Y,U,11) 25 .S UNITS=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM",U,+$P(Y,U,3)) 26 .I OI]"" S CNT=CNT+1 27 .I S ^TMP("PSJQO",$J,"AD",CNT,0)=OI_U_+$P($G(^PS(57.1,PSJQOPTR,3,X,0)),"^",2)_U_UNITS 28 I CNT S ^TMP("PSJQO",$J,"AD",0)=CNT_U_CNT 29 S CNT=0 F X=0:0 S X=$O(^PS(57.1,PSJQOPTR,4,X)) Q:'X D 30 .S Y=$G(^PS(52.7,+$G(^PS(57.1,PSJQOPTR,4,X,0)),0)),OI=$P(Y,U,11) 31 .N VOL S VOL=$P($G(^PS(57.1,PSJQOPTR,4,X,0)),"^",2) 32 .S TVOLUME=TVOLUME++VOL 33 .I (VOL'=+VOL)&(VOL'?1.6N1" "1"ML") S PSJBAD=1 34 .I OI]"" S CNT=CNT+1 35 .I S ^TMP("PSJQO",$J,"SOL",CNT,0)=OI_U_VOL 36 I CNT S ^TMP("PSJQO",$J,"SOL",0)=CNT_U_CNT 37 Q 38 2 ; 39 S OI="",PD=+ND1 40 F DD=0:0 S DD=$O(^PSDRUG("AP",PD,DD)) Q:'DD I $G(^PSDRUG(DD,"I"))=""!($G(^PSDRUG(DD,"I"))>DT) S OI=+$G(^PSDRUG(DD,2)) 41 I '$O(^PSDRUG("AP",PD,DD)) S ^TMP("PSJQO",$J,"DD")=DD Q 42 S MATCH=1 F S DD=$O(^PSDRUG("AP",PD,DD)) Q:'DD!'MATCH D 43 .I ($G(^PSDRUG(DD,"I"))=""!($G(^PSDRUG(DD,"I"))>DT))&(+$G(^PSDRUG(DD,2))'=OI) S MATCH=0 Q 44 S:'MATCH OI="" 45 Q 46 ; 47 ; 48 GTPC ; Set up TMP for provider comments 49 I $O(^PS(57.1,+PSJQOPTR,2,0)) D 50 .S CNT=0 F X=0:0 S X=$O(^PS(57.1,+PSJQOPTR,2,X)) Q:'X D 51 ..S Y=$G(^PS(57.1,PSJQOPTR,2,X,0)) S:Y]"" CNT=CNT+1,^TMP("PSJQO",$J,"PC",CNT,0)=Y 52 .S:$O(^TMP("PSJQO",$J,"PC",0)) ^TMP("PSJQO",$J,"PC",0)=CNT_U_CNT 53 Q 54 ENI ;Calculate Frequency for IV orders 55 K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q 56 I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)),($P(X," ml/hr")'=+$P(X," ml/hr")!(+$P(X," ml/hr")<0)) K X Q 57 I X=+X S X=X_" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q 58 I X[" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q 59 S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" S FREQ=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL 60 Q 61 SPSOL S SPSOL=+TVOLUME Q -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX6.m
r613 r623 1 PSSVX6 ; DRIVER FOR COMPILED XREFS FOR FILE #52.6 ; 11/08/091 PSSVX6 ; DRIVER FOR COMPILED XREFS FOR FILE #52.6 ; 04/10/06 2 2 ; 3 3 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX61.m
r613 r623 1 PSSVX61 ; COMPILED XREF FOR FILE #52.6 ; 11/08/091 PSSVX61 ; COMPILED XREF FOR FILE #52.6 ; 04/10/06 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX62.m
r613 r623 1 PSSVX62 ; COMPILED XREF FOR FILE #52.61 ; 11/08/091 PSSVX62 ; COMPILED XREF FOR FILE #52.61 ; 04/10/06 2 2 ; 3 3 S DA(1)=DA S DA=0 -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX63.m
r613 r623 1 PSSVX63 ; COMPILED XREF FOR FILE #52.63 ; 11/08/091 PSSVX63 ; COMPILED XREF FOR FILE #52.63 ; 04/10/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX64.m
r613 r623 1 PSSVX64 ; COMPILED XREF FOR FILE #52.6 ; 11/08/091 PSSVX64 ; COMPILED XREF FOR FILE #52.6 ; 04/10/06 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX65.m
r613 r623 1 PSSVX65 ; COMPILED XREF FOR FILE #52.61 ; 11/08/091 PSSVX65 ; COMPILED XREF FOR FILE #52.61 ; 04/10/06 2 2 ; 3 3 S DA(1)=DA S DA=0 -
WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX66.m
r613 r623 1 PSSVX66 ; COMPILED XREF FOR FILE #52.63 ; 11/08/091 PSSVX66 ; COMPILED XREF FOR FILE #52.63 ; 04/10/06 2 2 ; 3 3 S DA=0
Note:
See TracChangeset
for help on using the changeset viewer.
