Changeset 636 for FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (14 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 21 edited
- 1 copied
-
. (copied) (copied from FOIAVistA/trunk/r )
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m (modified) (2 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m (modified) (3 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m (modified) (8 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m (modified) (2 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m (modified) (2 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m (modified) (1 diff)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m (modified) (2 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m (modified) (8 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m (modified) (12 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m (modified) (3 diffs)
-
INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m
r628 r636 1 1 PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM 2 ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175 ,201**;16 DEC 97;Build 22 ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175**;16 DEC 97;Build 18 3 3 ; 4 4 ; Reference to ^PS(55 is supported by DBIA# 2191. … … 96 96 N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0 97 97 S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME="" 98 I $G(PSJRQPND) S PROVIDER=0 98 99 I PROVIDER>0 D 99 100 .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m
r628 r636 1 PSGPLR ;BIR/CML3-PRINTS PICK LIST REPORT ; 6/15/07 1:12pm2 ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129 ,191**;16 DEC 97;Build 91 PSGPLR ;BIR/CML3-PRINTS PICK LIST REPORT ;04 May 98 / 11:23 AM 2 ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129**;16 DEC 97 3 3 ; 4 4 ; Reference to ^PS(55 is supported by DBIA# 2191. … … 31 31 .N OSTOP,DRGND S (DDRG,OLDWARD)="" S DRGND=$O(PSGPLREN("B",PSGP,PSJJORD,0)) Q:'DRGND S OSTOP=PSGPLREN("B",PSGP,PSJJORD,DRGND) Q:'OSTOP 32 32 .N ST,TMPDRG S CNT=0,ST=$P(ND0,"^",7) S TMPDRG=0 S TMPDRG=$O(PSGPLREN("B",PSGP,PSJJORD,TMPDRG)) S TMPDRG=$P(DRG,"^")_"^"_TMPDRG 33 .F PSGPLXRX="AU","AC" Q:CNT F I=0:1S DDRG=$O(PSGPLREN(53.5,PSGPLXRX,PSGPLG,TM,WDN,RM,PN,PST,TMPDRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG") D33 .F PSGPLXRX="AU","AC" Q:CNT F S DDRG=$O(PSGPLREN(53.5,PSGPLXRX,PSGPLG,TM,WDN,RM,PN,PST,TMPDRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG") D 34 34 ..S X=$G(PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND,1,$P(DDRG,"^",2),0)) S DR=+X,DND=$P(X,U,2,4) Q:'X 35 35 ..S DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),DR=$$ENDDN^PSGMI($P(DRN,"^")) I DND?7N1"DI" S DND=$E($$ENDTC^PSGMI(+DND),1,8) 36 36 ..S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0) 37 ..;GMZ;PSJ*5*191;Allow for Multiple Dispensed Drug units needed 38 ..S PSJRNW(I)=1_"^"_+NEED 37 ..S PSJRNW=1_"^"_+NEED 39 38 ..Q 40 39 .K PSGPLREN("B",PSGP,PSJJORD),PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND) W !! … … 47 46 .I ATC S X=0,X=$O(^PS(59.7,X)) I $P($G(^(X,26)),U,2)=1,PST="OC" S ATC=0 48 47 .S UD=$S('UD:1,UD=.5:"1/2",UD=.25:"1/4",UD<1:"0"_UD,1:UD) 49 .I $D(PSJRNW) D 50 ..I 'CNT W !?35,"**** RENEWAL ****" 51 ..S NEED=NEED-$P(PSJRNW(CNT),"^",2) S:NEED<0 NEED=0 S CNT=CNT+1 48 .I $G(PSJRNW),'CNT W !?35,"**** RENEWAL ****" S CNT=CNT+1,NEED=NEED-$P(PSJRNW,"^",2) S:NEED<0 NEED=0 52 49 .W !?6,DR,?48,ST W:(ATC)&(NEED>0) ?57,"ATC" W ?61,$J(UD,4),?68,$J(NEED,4),?75,$S(DIS]"":$J(DIS,4),1:"____") 53 50 .S:ST="DISCONTINUED" OLDWARD=1 S ST="" -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m
r628 r636 1 1 PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM 2 ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175 ,201,185**;16 DEC 97;Build 62 ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175**;16 DEC 97;Build 18 3 3 ; 4 ; Reference to ^PS(50.605 is supported by DBIA 696.5 4 ; Reference to EN^PSOORDRG is supported by DBIA 2190. 6 5 ; Reference to ^PSI(58.1 is supported by DBIA 2284. … … 12 11 ; Reference to ^ORRDI1 is supported by DBIA 4659. 13 12 ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660. 14 ; Reference to GETDATA^GMRAOR supported by DBIA 4847.15 ; Reference to ^TMP("GMRAOC" supported by DBIA 4848.16 13 ; 17 14 START ; … … 28 25 ENSET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y 29 26 N X1,X2,Y S Y="" 30 ;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow. 31 ; ;Removed code I X2]"" Before Set of Y and created argumentless DO structure. 32 F X1=1:1:$L(X," ") S X2=$P(X," ",X1) D 33 . I X2']"" S Y=Y_" " Q ;if multiple spaces in text and were $P'ing through text, X2 will="" so just add space and continue 34 . S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" " 35 . Q 36 ;BHW;Modified stripping of spaces at end of string 37 F X1=$L(Y):-1:0 Q:$E(Y,X1,X1)'=" " S Y=$E(Y,1,X1-1) 38 Q Y 27 F X1=1:1:$L(X," ") S X2=$P(X," ",X1) I X2]"" S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" " 28 S Y=$E(Y,1,$L(Y)-1) Q Y 39 29 ; 40 30 END ; used by DRUG (55.06,101 & 53.1,101) x-refs to warn user if patient is receiving or about to receive the drug just ordered … … 58 48 I $T(HAVEHDR^ORRDI1)]"",$$HAVEHDR^ORRDI1,'$D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D 59 49 . I $P($G(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSJLMUT1 50 K ^TMP($J,"DUPDRG") ;DEM - Duplicate Drug Check Ehancement. 60 51 I $D(^TMP($J,"DD")) D ORDCHK^PSJLMUT1(PSGP,"DD",4) 61 52 I $D(^TMP($J,"DC")) D ORDCHK^PSJLMUT1(PSGP,"DC",6) … … 63 54 I '$D(PSJFST) N PSJFST S PSJFST=0 64 55 I $D(^TMP($J,"DI")) S INTERVEN=1 D ORDCHK^PSJLMUT1(PSGP,"DI",8) 56 D DUPDRG^PSJLMUT2(PSGP) K ^TMP($J,"DUPDRG") ;DEM - Duplicate Drug Check Ehancement. 65 57 ;*** Allergy/adverse reaction check. 66 58 N PTR,X … … 75 67 .W !! 76 68 K PSJACK,GMRAING,I,^TMP($J) 77 D ALGCLASS 69 D ALGCLASS^PSGSICH1 78 70 CONT ; Ask user if they wish to continue in spite of an order check. 79 Q:'$D(PSJPDRG) N DIR S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order," 80 S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="NO" D ^DIR I 'Y S PSGORQF=1,X="^",COMQUIT=1 Q 71 ;Variable PSJDDCON is the order continuation flag for Duplicate Drug Check Enhancement. 72 I $D(PSJDDCON("DD")),'PSJDDCON("DD") Q 73 I '$D(PSJDDCON("DD")) Q:'$D(PSJPDRG) N DIR D I 'Y S PSGORQF=1,X="^",COMQUIT=1 K PSJDDCON Q 74 . S DIR(0)="Y",DIR("A")=$S($G(PSJDDCON("DI")):"Do you wish to continue with the current order",1:"Do you wish to continue entering this order") 75 . S DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,",DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")=$S($G(PSJDDCON("DI")):"YES",1:"NO") 76 . D ^DIR 77 . Q 78 ; 79 K PSJDDCON ;Order continuation flag for Duplicate Drug Check Enhancement. 81 80 I 'INTERVEN!($P(PSJSYSU,";")'=3) Q 82 N EWPSJY81 N PSJY 83 82 W:PSJIREQ !!,"This is a CRITICAL interaction, you must enter an intervention log to continue" 84 83 S DIR(0)="Y",DIR("A")="Do you wish to log an intervention",DIR("?",1)="Enter ""N"" if you do not wish to log an intervention,",DIR("?")="or ""Y"" to log an intervention." D ^DIR S PSJY=Y D:Y ^PSJRXI … … 89 88 D ENCV^PSGSETU Q:$D(XQUIT) 90 89 F S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0 D SF 91 D ENKV^PSGSETU K N5,ND,Q,Y Q 90 D ENKV^PSGSETU K N5,ND,Q,Y 91 Q 92 92 ; 93 93 SF ; 94 N PSGID 94 95 S Y=+Y,ND=$G(^PSDRUG(Y,0)),PSGID=+$G(^("I")) I PSGID W !!,"THIS DRUG IS INACTIVE AS OF ",$E($$ENDTC^PSGMI(PSGID),1,8) 95 96 W !!,$S($P(ND,"^",9):"NON-",1:""),"FORMULARY ITEM" W:$P(ND,"^",10)]"" !,$P(ND,"^",10) … … 116 117 W ?10,$P(ND,U),!,?13,"Give: ",X," ",$$ENMRN^PSGMI(+$P(ND0,U,3))," ",$P(ND2,U),!! 117 118 Q 118 ALGCLASS ; checks any Drug allergies or reactions to see if119 ; the new drug is the same class120 ; this call can be removed by commenting out the call on IVSOL+16121 N PSJLIST,CT,CLS,CLCHK,CNT,PSJL,LIST,DCCNT,PSCLASS,LEN122 S PSCLASS=$P($G(^PSDRUG(PSJDD,0)),"^",2),LEN=4 I $E(PSCLASS,1,4)="CN10" S LEN=5 ;look at 5 chars if ANALGESICS123 I $T(GETDATA^GMRAOR)]"" G ALGC2124 S GMRA="0^0^111" D EN1^GMRADPT125 F PSJLIST=0:0 S PSJLIST=$O(GMRAL(PSJLIST)) Q:'PSJLIST D126 .K PSJAGL D EN1^GMRAOR2(PSJLIST,"PSJAGL")127 .; is the allergy/reaction drug class first four digits the same as the128 .; the class for the drug being entered?129 .S (CT,CLS)="",DCCNT=0130 .I $D(PSJAGL("V")) D131 ..F S DCCNT=$O(PSJAGL("V",DCCNT)) Q:'DCCNT S:$E($P($G(PSJAGL("V",DCCNT)),"^"),1,LEN)=$E(PSCLASS,1,LEN) (PSJPDRG,CLCHK)=1,CNT=$S('$D(CNT):1,1:CNT+1),LIST(CNT)=$P($G(PSJAGL),"^")_"^"_$P($G(PSJAGL("V",DCCNT)),"^",2)132 D:$G(CLCHK)133 .W !!,$C(7),"A Drug-Allergy Reaction exists for this medication and/or class!"134 .F PSJL=0:0 S PSJL=$O(LIST(PSJL)) Q:'PSJL D135 ..W !?6,"Drug: "_$P(LIST(PSJL),"^"),!,"Drug Class: "_$P(LIST(PSJL),"^",2),!136 Q137 ALGC2 ;138 K GMRADRCL139 D GETDATA^GMRAOR(DFN) Q:'$D(^TMP("GMRAOC",$J,"APC"))140 N GMRACL,RET141 S RET=0,GMRACL="" F S GMRACL=$O(^TMP("GMRAOC",$J,"APC",GMRACL)) Q:'$L(GMRACL) D142 .N GMRANM,GMRALOC143 .S GMRALOC=^TMP("GMRAOC",$J,"APC",GMRACL)144 .S GMRANM=$P(^PS(50.605,+$O(^PS(50.605,"B",GMRACL,0)),0),U,2)145 .S GMRADRCL(GMRACL)=GMRACL_U_GMRANM_" ("_GMRALOC_")"146 .S RET=RET+1147 Q:'RET K ^TMP("GMRAOC",$J)148 S CLCHK="",CT="" F S CT=$O(GMRADRCL(CT)) Q:CT="" D149 .I $E(PSCLASS,1,LEN)=$E(CT,1,LEN) S CLCHK=$G(CLCHK)+1,^TMP($J,"PSJDRCLS",CLCHK)=CT_" "_$P(GMRADRCL(CT),"^",2)150 CLASSDSP ;151 I '$D(^TMP($J,"PSJDRCLS")) Q152 W $C(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",!153 W !,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^")154 S CT="" F S CT=$O(^TMP($J,"PSJDRCLS",CT)) Q:CT="" W !,"Drug Class: "_^TMP($J,"PSJDRCLS",CT)155 K ^TMP($J,"PSJDRCLS")156 S DIR("?",1)="Answer 'YES' if you DO want to enter a reaction for this medication,"157 S DIR("?")=" 'NO' if you DON'T want to enter a reaction for this medication,"158 S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Intervene? ",DIR("B")="Y" W ! D ^DIR159 I Y D ^PSJRXI160 I '$G(Y) K DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y Q161 Q -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m
r628 r636 1 PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 12/12/071 PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 01/17/08 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 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m
r628 r636 1 PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 12/12/071 PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08 2 2 ; 3 3 S DIKZK=2 … … 32 32 S X=$P(DIKZ(0),U,1) 33 33 I X'="" K ^PS(53.1,"B",$E(X,1,30),DA) 34 CR1 S DIXR= 50234 CR1 S DIXR=498 35 35 K X 36 36 S DIKZ("DSS")=$G(^PS(53.1,DA,"DSS")) -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m
r628 r636 1 PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 12/12/071 PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08 2 2 ; 3 3 S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m
r628 r636 1 PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 12/12/071 PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08 2 2 ; 3 3 S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m
r628 r636 1 PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 12/12/071 PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08 2 2 ; 3 3 S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m
r628 r636 1 PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 12/12/071 PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08 2 2 ; 3 3 S DA(1)=DA S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m
r628 r636 1 PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 12/12/071 PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08 2 2 ; 3 3 S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m
r628 r636 1 PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 12/12/071 PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08 2 2 ; 3 3 S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m
r628 r636 1 PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 12/12/071 PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08 2 2 ; 3 3 S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m
r628 r636 1 PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 12/12/071 PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08 2 2 ; 3 3 S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m
r628 r636 1 PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 12/12/071 PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08 2 2 ; 3 3 S DIKZK=1 … … 48 48 S X=$P(DIKZ(.2),U,8) 49 49 I X'="" S ^PS(53.1,"ACX",$E(X,1,30),DA)="" 50 CR1 S DIXR= 50250 CR1 S DIXR=498 51 51 K X 52 52 S DIKZ("DSS")=$G(^PS(53.1,DA,"DSS")) -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m
r628 r636 1 PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 12/12/071 PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08 2 2 ; 3 3 S DA(1)=DA S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m
r628 r636 1 PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 12/12/071 PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08 2 2 ; 3 3 S DA=0 -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m
r628 r636 1 1 PSJLMPRU ;BIR/MLM-INPATIENT LISTMAN UD PROFILE UTILITIES ;27 Aug 98 / 8:45 AM 2 ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110 ,185**;16 DEC 97;Build 62 ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110**;16 DEC 97 3 3 ; 4 4 ; Reference to ^PSDRUG is supported by DBIA 2192. … … 44 44 ; LM = Begin display of text after LM spaces. 45 45 ; RM = Length of display text. 46 ; 47 ;BHW;PSJ*5*185;Extra spaces causes display to "skip" part of the field. 48 ;S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD="" D 49 S PSJL="",$P(PSJL," ",LM)="" 50 F X=1:1:$L(TXT," ") S WRD=$P(TXT," ",X) D 51 .;BHW;PSJ*5*185;check if end of string or just extra space. 52 .I WRD="" S PSJL=PSJL_" " Q 46 ; 47 S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD="" D 53 48 .I $L(PSJL_" "_WRD)'<RM D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)="" 54 49 .I $L(PSJL_" "_WRD)'<RM S PSJL=PSJL_" "_$E(WRD,1,(RM-10)) D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)="",WRD=$E(WRD,(RM-9),$L(WRD)) -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m
r628 r636 1 1 PSJLMUDE ;BIR/MLM-SHOW FIELDS FOR EDIT (LISTMAN STYLE) ;01 JUNE 00 / 2:40 PM 2 ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175 ,201**;16 DEC 97;Build 23 4 2 ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175**;16 DEC 97;Build 18 3 ;NFI-UD Fr#:2 chgs@init+4 to display non-formulary (N/F) 4 ;also chgs @init+23 5 5 ; 6 6 ; Reference to ^PS(55 is supported by DBIA# 2191 … … 12 12 D CLEAN^VALM10 13 13 S PSJL=$S($D(PSGEFN(1)):$E(" *",PSGEFN(1)+1)_"(1)",1:" "),PSJL=$$SETSTR^VALM1("Orderable Item: "_PSGPDN_$$OINF^PSJDIN(PSGPD),PSJL,5,74) D D SETTMP D:$G(PSGOEEF(108))!($G(PSGOEEF(101))) HILITE(1) 14 . N EWQ,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q S PSJDDA(+$G(^(Q,0)))=""14 . N Q,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q S PSJDDA(+$G(^(Q,0)))="" 15 15 . S PSJVD=$$DINFLUD^PSJDIN(PSGPD,.PSJDDA) 16 16 . S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,80) 17 17 . D:PSJVD]"" CNTRL^VALM10(1,75,5,IORVON,IORVOFF,0) 18 18 I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD) 19 S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6, 80)19 S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6,120) 20 20 S PSJL=$S($D(PSGEFN(2)):$E(" *",PSGEFN(2)+1)_"(2)",1:" "),PSJL=$$SETSTR^VALM1("Dosage Ordered: "_PSGDO,PSJL,5,76) D SETTMP D:$G(PSGOEEF(109)) HILITE(2) 21 21 I $G(PSGRDTX) S PSJDUR=$$FMTDUR^PSJLIVMD($P($G(PSGRDTX),U,2)) … … 48 48 S PSJL=$S($D(PSGEFN(9)):$E(" *",PSGEFN(9)+1)_"(9)",1:" "),PSJL=$$SETSTR^VALM1("Admin Times: "_PSGAT,PSJL,8,71) D SETTMP D:$G(PSGOEEF(39))!($G(PSGOEEF(41))) HILITE(9) 49 49 S PSJL=$S($D(PSGEFN(10)):$E(" *",PSGEFN(10)+1)_"(10)",1:" "),PSJL=$$SETSTR^VALM1("Provider: "_PSGPRN,PSJL,11,68) D:$G(PSGOEEF(1)) HILITE(10) D SETTMP 50 ;S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(7)):$E(" *",PSGEFN(7)+1)_"(7)",1:" ")_"Self Med: "_PSGSMN,PSJL,56,24) S:PSGSM&PSGHSM PSJL=$$SETSTR^VALM1(" (HS)",PSJL,71,7) D SETTMP D:$G(PSGOEEF(5)) HILITE(7)51 50 S PSJL=$S($D(PSGEFN(11)):$E(" *",PSGEFN(11))_"(11)",1:" ")_" Special Instructions"_$S($P(PSGSI,"^",2)=1:"!: ",1:": ")_$P(PSGSI,"^") D PTXT^PSJLMPRU(PSJL,"PSJUDE",1,80) 52 51 S PSJL="" D SETTMP D:$G(PSGOEEF(8)) HILITE(11) … … 54 53 I $O(^PS(53.45,PSJSYSP,2,1)) F S PSJL="" D SETTMP Q:PSJLN>15 55 54 S PSJL=$S($D(PSGEFN(12)):$E(" *",PSGEFN(12))_" (12)",1:" ")_" Dispense Drug",PSJL=$$SETSTR^VALM1("U/D",PSJL,54,60),PSJL=$$SETSTR^VALM1("Inactive Date",PSJL,65,16) D SETTMP,CNTRL^VALM10(13,1,80,IOUON,IOUOFF,0) 56 ;S $P(PSJL,"-",80)="" D SETTMP 57 NEW PSJX 55 N PSJX,PSGID 58 56 F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q S ND=$G(^(Q,0)) D 59 57 .S D=$P(ND,"^"),PSGID=$P(ND,"^",3) I PSGID S PSGID=$$ENDTC^PSGMI(PSGID) … … 75 73 .D SETTMP S PSJL="Order Checks:" D SETTMP 76 74 .F Q=0:0 S Q=$O(^PS(53.1,+PSGORD,10,Q)) Q:'Q D 77 ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) D SETTMP75 ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) S PSJWPL=PSJL D DISPLAY 78 76 ..S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+PSGORD,10,Q,1)),U) D SETTMP 79 77 ..S PSJL="Overriding Reason: " F X=0:0 S X=$O(^PS(53.1,+PSGORD,10,Q,2,X)) Q:'X D 80 78 ...S PSJL=PSJL_$G(^PS(53.1,+PSGORD,10,Q,2,X,0)) D SETTMP S PSJL=" " 81 79 ACTFLG ; 80 N ND4,AT,Y,X 82 81 S ND4=$S(PSGORD["P":$G(^PS(53.1,+PSGORD,4)),1:$G(^PS(55,PSGP,5,+PSGORD,4))) 83 82 S AT="",Y="12,13,D,18,19,H1,22,23,H0,15,16,R" F X=1:3:12 I $P(ND4,"^",$P(Y,",",X)),$P(ND4,"^",$P(Y,",",X+1)) S AT=$P(Y,",",X+2) Q … … 96 95 I $G(PSGPI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" PROVIDER" 97 96 Q 97 ; 98 98 DISPLAY ; 99 S PSJL=PSJWPL D SETTMP 100 ;F X=1:1 S WRD=$P(PSJWPL," ",X) Q:WRD="" D 101 ;.I $L(PSJL_" "_WRD)'<80 D SETTMP S PSJL=$P(PSJWPL,PSJL,2) S:$E(PSJL,1)=" " PSJL=$E(PSJL,2,999),PSJWPL="" Q 102 ;.S PSJL=PSJL_$S(PSJL="":"",1:" ")_WRD 103 Q 99 N X,LEN,LIM,PCS 100 S LIM=$L(PSJWPL," "),PCS=1 101 F X=1:1:LIM S LEN=$L($P(PSJWPL," ",PCS,X)) D 102 . I LEN'<72!(X=LIM) D 103 .. S PSJL=$P(PSJWPL," ",PCS,X) 104 .. I PCS>1 S PSJL=" "_PSJL 105 .. S PCS=X+1 106 .. D SETTMP 107 Q 104 108 ; 105 109 SETTMP ; … … 108 112 ; 109 113 HILITE(FLD) ; 110 N COL,LIN,WID,X 111 ;Q:'$G(PSGOEENO) 114 N COL,LAB,LIN,WID,X 112 115 S X="$T("_FLD_"^PSJLMUDE)",@("X="_X),X=$P(X,";;",2),LIN=+X,COL=$P(X,",",2),LAB=$P(X,",",3),X=$P(X,",",4),WID=(LAB+$L(@X)) 113 ;D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IOINORM,0)114 116 I FLD=7 S LIN=+$G(PSJLN)-1 Q:LIN<13 115 117 D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IORVOFF_IOBOFF,0) … … 128 130 11 ;;11,7,22,PSGSI 129 131 ENKILL ; 130 K PSGAT,PSGEB,PSGEFN,PSGFD,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGOMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD,PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM Q 132 K PSGAT,PSGDO,PSGEB,PSGEFN,PSGFD,PSGFDN,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD 133 K PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM,PSGOINST,PSGPRN,PSGRFDN,PSGRSDN,PSGSCH,PSGSDN,PSGSI,PSGSTN,PSJWPL,RNDT 134 Q -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m
r628 r636 1 1 PSJLMUT1 ;BIR/MLM-DRUG NAME DISPLAY ;05 Feb 98 / 1:39 PM 2 ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175 ,201**;16 DEC 97;Build 22 ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175**;16 DEC 97;Build 18 3 3 ; 4 4 ; Reference to ^PS(55 is supported by DBIA# 2191. … … 25 25 I +$O(@(F_"1,0)")),'+$O(@(F_"1,1)")),PSGUPDDO="" D DD(F,.DRUGNAME) 26 26 S:($G(DRUGNAME)=""!($G(DRUGNAME)["NOT FOUND")) DRUGNAME=$$OIDF(OIND) 27 ;S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_PSGINS_PSGUPDDO_" "_MR_" "_SCH28 27 S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_$S(('$D(PSJPDDDP)&('$L(PSGUPDDO))):PSGINS,1:PSGUPDDO)_" "_MR_" "_SCH 29 28 S PSGX=0 K PSJPDDDP … … 34 33 . S NAME(PSGX+X)=$S(X>1:" ",1:"")_MARX(X) 35 34 Q 35 ; 36 36 OIDF(OIND) ; Return Orderable Item name and Dosage form. 37 37 ;; +OIND = orderable item IEN … … 50 50 S PSJPDDDP=1 51 51 Q 52 ; 52 53 DSPLORDU(PSGP,ON) ; Display UD order for order check as in the Inpat Profile. 53 54 NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y … … 66 67 . S PSJLINE=PSJLINE+1 67 68 Q 69 ; 68 70 DSPLORDV(DFN,ON) ; Display IV order for order check as in the Inpat Profile. 69 N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJ IVFLG,PSJORIFN,TYP,X,Y71 N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJCT,PSJIVFLG,PSJORIFN,TYP,X,Y 70 72 S TYP="?" I ON["V" D 71 73 .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X) … … 76 78 S PSJIVFLG=1 D PIVAD,SOL 77 79 Q 80 ; 78 81 SOL ; 79 82 S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_" in" 80 83 S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP S PSJL=" " 81 84 Q 85 ; 82 86 PIVAD ; Print IV Additives. 83 87 F DRG=0:0 S DRG=$O(DRG("AD",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1) F DRGX=0:0 S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP … … 90 94 E S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1) 91 95 Q 96 ; 92 97 SETTMP ; 93 98 S PSJOC(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1 94 99 Q 100 ; 95 101 ORDCHK(DFN,TYPE,PIECE) ; 96 102 ;TYPE ="DD" - Duplicate drug … … 114 120 . ; Adding Drug Interactions check for use in Intervention defaults in PSJRXI. 115 121 . I TYPE="DI" S PSJRXREQ=$S($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL":1,1:2) 116 . ;I $P(PSJPACK,";",2)["O" D Q117 122 . N X S X=$P(PSJPACK,";",2) I X["O" D Q 118 123 .. D:PSJFST=1 PAUSE … … 123 128 . I ON=$G(PSIVOCON),+PSJORIEN Q 124 129 . I ON=$G(PSIVOCON),'+PSJORIEN D SETPSJOC Q 125 . ;S PSJOC=PSJOC+1,PSJPDRG=1 D:PSJOC=1 WRITE(TYPE)126 130 . I ON["V" D 127 131 .. I '$O(^PS(55,DFN,"IV",+ON,0)) D SETPSJOC Q … … 129 133 . I ON'["V" D DSPLORDU(DFN,ON) S PSJOC=PSJOC+1 130 134 . S PSJOC(ON,PSJLINE)="",PSJLINE=PSJLINE+1 131 D:PSJOC WRITE(TYPE) 132 S ON="" F S ON=$O(PSJOC(ON)) Q:ON="" W ! S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D 133 . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1 D:'(PSIVX#6) PAUSE 134 W ! 135 ; DEM - If TYPE="DI", and there are "DI" orders, 136 ; then display "DI" orders. 137 I TYPE="DI",PSJOC D WRITE(TYPE) D ;DEM 138 . S ON="" F S ON=$O(PSJOC(ON)) Q:ON="" S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D ;DEM 139 .. F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1 ;DEM 140 Q:(TYPE="DI") ;DEM - Don't continue if TYPE="DI". Code that follows is for TYPEs "DD" and "DC" only. 141 Q:'PSJOC ;DEM - No need to continue if no "DD", or "DC" orders. 142 ; DEM - If we are here, then there are "DD", or "DC" orders in 143 ; PSJOC array. Loop on PSJOC array and set orders into 144 ; ^TMP($J,"DUPDRG",TYPE) global. The ^TMP($J,"DUPDRG",TYPE) 145 ; global will be used for display of "DD" and "DC" orders 146 ; for possible discontinuation of the "DD", or "DC" orders. 147 ; See subroutine DUPDRG and calling routine ENDDC^PSGSICHK 148 ; for details. 149 S ON="" F S ON=$O(PSJOC(ON)) Q:ON="" D ;DEM 150 . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX S ^TMP($J,"DUPDRG",TYPE,ON,PSIVX)=PSJOC(ON,PSIVX) ;DEM 135 151 Q 152 ; 136 153 SETPSJOC ;Set PSJOC array to be displayed later 137 154 NEW PIECE S PIECE=$S(TYPE="DC":4,1:2) … … 140 157 S PSJOC(ON,PSJLINE)=X,PSJLINE=PSJLINE+1,PSJOC=PSJOC+1 141 158 Q 159 ; 142 160 WRITE(TYPE) ;Display order check description 143 161 S PSJPDRG=1 … … 146 164 I TYPE="DI" W !!,"This patient is receiving the following medication",$S(PSJOC>1:"s",1:"")," that ha",$S(PSJOC>1:"ve",1:"s")," an interaction",!,"with ",$P($G(^PSDRUG(PSJDD,0)),U),":",! 147 165 Q 166 ; 148 167 PAUSE ; 149 168 K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m
r628 r636 1 1 PSJLMUT2 ;BIR/JLC-DISPLAY UTILITIES ;22 Jun 05 2 ;;5.0; INPATIENT MEDICATIONS ;**146,175 ,201**;16 DEC 97;Build 22 ;;5.0; INPATIENT MEDICATIONS ;**146,175**;16 DEC 97;Build 18 3 3 ; 4 ; Reference to ^PS(55 is supported by DBIA# 2191. 5 ; Reference to ^PSDRUG is supported by DBIA# 2192. 6 ; Reference to ^PSSLOCK is supported by DBIA# 2789. 7 ; Reference to ^VA(200 is supported by DBIA# 10060. 8 ; 4 9 SHOR(PSJT,PSJI) ;Display outpatient remote order checks. 5 10 ;; PSJT = Type of order check in ^TMP … … 25 30 W !,PSJULN 26 31 Q 32 ; 27 33 FSIG(FSIG) ;Format sig from remote site 28 34 ;returned in the FSIG array … … 37 43 I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2) 38 44 FQUIT Q 45 ; 46 DUPDRG(DFN) ;DEM - Duplicate Drug Check Ehancement 47 ; 48 ; Note: Display of Drug Interaction, Non-VA Meds, and Outpatient 49 ; orders is done by ORDCHK^PSJLMUT1. ORDCHK is called by 50 ; routine ENDDC^PSGSICHK before routine ENDDC^PSGSICHK calls 51 ; DUPDRG^PSJLMUT2. If ORDCHK finds "DD", or "DC" orders, 52 ; then ORDCHK will set "DD", or "DC" orders into 53 ; ^TMP($J,"DUPDRG",TYPE) global. 54 ; 55 K PSJDDCON ;Order continuation flag used by routine PSGSICHK. 56 S:$D(^TMP($J,"DI")) PSJDDCON("DI")=1 ;Order continuation flag used by routine PSGSICHK. 57 ; Quit if no duplicate drug orders(s), or duplicate drug class 58 ; order(s) found. 59 Q:'$D(^TMP($J,"DUPDRG","DD"))&'$D(^TMP($J,"DUPDRG","DC")) 60 S PSJDDCON("DD")=0 ;Order continuation flag used by routine PSGSICHK. 61 ; 62 ; Display orders in ^TMP($J,"DUPDRG",DUPLICATE_TYPE,ON,LINE_#) 63 ; (DUPLICATE TYPEs: "DD" - "Duplicate Drug" 64 ; "DC" - "Duplicate Drug Class" 65 ; 66 S PSJPDRG=1 ;If we are here, then set PSJPDRG=1. ORDCHK^PSJLMUT1 addresses this variable for Outpatient orders and "DI" orders. 67 N X,Y,DIR,TYPE,ON,PSJOC,PSJOCPOP,PSJSYSL 68 W !!,"This patient is already receiving the following INPATIENT order(s) for the same drug or in the same drug class as "_$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!! 69 D DSPLDD ;Display patients orders for the same drug or same drug class as drug selected. 70 ; Ask user if they wish to continue in spite of an order check. 71 S DIR(0)="Y",DIR("A")="Do you wish to continue with the current order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order," 72 S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="YES" D ^DIR I 'Y S PSGORQF=1,COMQUIT=1 K X,Y,DIR W ! Q 73 K X,Y,DIR 74 S PSJDDCON("DD")=1,PSJSYSL=0 ;Order continuation flag used by routine PSGSICHK. 75 W ! 76 F D Q:('PSJOC)!(PSJOCPOP) ;Order discontinuation loop. 77 . N TYPE,ON,PSJOCSEQ 78 . S PSJOCPOP=0 79 . ; Ask user if they wish to discontinue any of the listed orders. 80 . S DIR(0)="Y",DIR("A")="Do you wish to DISCONTINUE any of the listed orders",DIR("?",1)="Enter ""N"" if you wish to exit without discontinuing any of the listed orders," 81 . S DIR("?")="or ""Y"" to discontinue any of the listed orders.",DIR("B")="NO" D ^DIR I 'Y K X,Y,DIR S PSJOCPOP=1 W ! Q 82 . K X,Y,DIR 83 . W ! 84 . ; Choose for DISCONTINUE 1-PSJOC (PSJOC is the total number of duplicate and duplicate class orders). 85 . S DIR(0)="N^1:"_PSJOC,DIR("A")="Choose for DISCONTINUE",DIR("?")="Choose an order 1-"_PSJOC D ^DIR I 'Y K X,Y,DIR S PSJOCPOP=1 W ! Q 86 . S PSJOCSEQ=+Y 87 . K X,Y,DIR 88 . ; 89 . ; *** Discontinue order *** 90 . S ON=$P(PSJOC(PSJOCSEQ),"^",2) 91 . I '$$LS^PSSLOCK(DFN,ON) S PSJOCPOP=1 Q 92 . S PSGSTAT=$$GTSTATUS^PSJOE(DFN,ON) 93 . D ;Set PSGOEEWF for order being discontinued - DRF 94 .. I ON["P" S PSGOEEWF="^PS(53.1,"_+ON_"," Q 95 .. I ON["U" S PSGOEEWF="^PS(55,"_DFN_",5,"_+ON_"," Q 96 .. S PSGOEEWF="^PS(55,"_DFN_",""IV"","_+ON_"," 97 . D ;The following variables must be newed or they are stomped on by the discontinue code 98 .. N %DT,CF,D,D0,DA,DI,DIC,DIE,DISYS,DQ,DR,DRG,DRGT,DRGTMP,DRGX 99 .. N DTIME,FIL,I,JJ,LOC,OCXDT,OCXI,OCXSEG,ORIFN,ORO,POP,PSGALR 100 .. N PSGDT,PSGOEAV,PSJNOO,PSGOEDMR,PSGOEPR,PSGPDRG,PSGTOO,PSGTOL 101 .. N PSGUOW,PSIVOI,PSIVX,PSJCOM,PSJDD,PSJHLMTN,PSJMSG,PSJQO,PSOC 102 .. N Q,QQ,T,VA,VADM,VAERR,VAIN,XPARSYS,XQXFLG,Y,PSJRQPND 103 .. D 104 ... S PSJRQPND=1 105 ... I ON["V" D Q ;IV order 106 .... N PSJORD 107 .... S PSJORD=ON 108 .... D DC^PSJLIACT 109 ... D DC^PSJOE(DFN,ON) ;UD order 110 .. I $$GTSTATUS^PSJOE(DFN,ON)="D" D ; Clean up PSJOC and ^TMP($J,"DUPDRG") arrays, and reset PSJOC counter IF and after selected order has been discontinued. 111 ... S TYPE=$P(PSJOC(PSJOCSEQ),"^",1),ON=$P(PSJOC(PSJOCSEQ),"^",2),PSJOC=PSJOC-1 112 ... K PSJOC(PSJOCSEQ),^TMP($J,"DUPDRG",TYPE,ON),PSJOCSEQ 113 . D UNL^PSSLOCK(DFN,ON) 114 . Q:'PSJOC 115 . W !!,"Now, this patient is already receiving the following INPATIENT order(s) for the same drug or in the same drug class as "_$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!! 116 . D DSPLDD 117 . Q 118 W ! 119 K PSJOCPOP,PSGSTAT 120 Q 121 ; 122 DSPLDD ; 123 ; Display patients orders for the same drug or same drug class as drug selected. 124 N X,REQPROV,PSJLINE,PSJFLN 125 K PSJOC 126 ; Requesting Provider 127 S PSJOC=0 128 F TYPE="DD","DC" S ON="" F S ON=$O(^TMP($J,"DUPDRG",TYPE,ON)) Q:ON="" S PSJFLN=1 D 129 . I ON["U" S REQPROV=$P(^PS(55,DFN,5,+ON,0),"^",2) 130 . I ON["V" S REQPROV=$P(^PS(55,DFN,"IV",+ON,0),"^",6) 131 . I ON["P" S REQPROV=$P(^PS(53.1,+ON,0),"^",2) 132 . S REQPROV=$S(REQPROV>0:$P($G(^VA(200,REQPROV,0)),"^",1),1:"") S:REQPROV="" REQPROV="Requesting Provider Unknown" 133 . F PSJLINE=0:0 S PSJLINE=$O(^TMP($J,"DUPDRG",TYPE,ON,PSJLINE)) Q:'PSJLINE D 134 .. I PSJFLN=1 S PSJOC=PSJOC+1,PSJOC(PSJOC)=TYPE_"^"_ON W PSJOC_".",^TMP($J,"DUPDRG",TYPE,ON,PSJLINE),! S PSJFLN=PSJFLN+1 Q 135 .. S X=^TMP($J,"DUPDRG",TYPE,ON,PSJLINE) S:PSJFLN=2 X=$$SETSTR^VALM1(REQPROV,X,(48+$L(PSJOC_".")),25) W ?($L(PSJOC_".")),X,! S PSJFLN=PSJFLN+1 Q 136 .. Q 137 . Q 138 Q 139 ; 39 140 PAUSE ; 40 141 K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! -
FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m
r628 r636 1 PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ; 6/18/07 12:11pm2 ;;5.0; INPATIENT MEDICATIONS ; **191**;16 DEC 97;Build 91 PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ;20 DEC 96 / 3:15 PM 2 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97 3 3 ; 4 4 PEND ;*** Only select orders that were acknowledged by nurses and are … … 8 8 F ON=0:0 S ON=$O(^PS(53.1,"AV",PSGP,ON)) Q:'ON D 9 9 . S ND=$G(^PS(53.1,ON,0)),TYPE=$P(ND,U,4) 10 . S ND2=$G(^PS(53.1,ON,2)),PSGLSD=$P(ND2,U,2),PSGLFD=$P(ND2,U,4)11 10 . I $P(ND,U,7)="P"!($P($G(^PS(53.1,ON,2)),U)["PRN") S QST="PZ"_$S($P(ND,U,4)="F":"V",1:"A") 12 11 . E S QST="CZ"_$S($P(ND,U,4)="F":"V",1:"A") … … 25 24 D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_ON 26 25 ;*** Set up ^TMP for sort by patients 27 S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCH E=$P($G(^PS(53.1,ON,2)),U)26 S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCH=$P($G(^PS(53.1,ON,2)),U) 28 27 S PSJHOLD=$S($P(ND,U,9)["H":1,1:0),PSGLOD=$P(ND,U,14),PSJATME=9999,PSJADT=$S(QST["C":"8999999",1:"9999999") 29 28 D SI
Note:
See TracChangeset
for help on using the changeset viewer.
