Changeset 636 for FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m (modified) (8 diffs)

FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m

@@ -1 +1 @@
 PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM
- ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175,201,185**;16 DEC 97;Build 6
+ ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175**;16 DEC 97;Build 18
  ;
- ; Reference to ^PS(50.605 is supported by DBIA 696.
  ; Reference to EN^PSOORDRG is supported by DBIA 2190.
  ; Reference to ^PSI(58.1 is supported by DBIA 2284.
@@ -12 +11 @@
  ; Reference to ^ORRDI1 is supported by DBIA 4659.
  ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660.
- ; Reference to GETDATA^GMRAOR supported by DBIA 4847.
- ; Reference to ^TMP("GMRAOC" supported by DBIA 4848.
  ;
 START ;
@@ -28 +25 @@
 ENSET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y
  N X1,X2,Y S Y=""
- ;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow.
- ;             ;Removed code I X2]"" Before Set of Y and created argumentless DO structure.
- F X1=1:1:$L(X," ") S X2=$P(X," ",X1) D
- . 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
- . 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)_" "
- . Q
- ;BHW;Modified stripping of spaces at end of string
- F X1=$L(Y):-1:0 Q:$E(Y,X1,X1)'=" "  S Y=$E(Y,1,X1-1)
- Q Y
+ 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)_" "
+ S Y=$E(Y,1,$L(Y)-1) Q Y
  ;
 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
  . I $P($G(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSJLMUT1
+ K ^TMP($J,"DUPDRG")  ;DEM - Duplicate Drug Check Ehancement.
  I $D(^TMP($J,"DD")) D ORDCHK^PSJLMUT1(PSGP,"DD",4)
  I $D(^TMP($J,"DC")) D ORDCHK^PSJLMUT1(PSGP,"DC",6)
@@ -63 +54 @@
  I '$D(PSJFST) N PSJFST S PSJFST=0
  I $D(^TMP($J,"DI")) S INTERVEN=1 D ORDCHK^PSJLMUT1(PSGP,"DI",8)
+ D DUPDRG^PSJLMUT2(PSGP) K ^TMP($J,"DUPDRG")  ;DEM - Duplicate Drug Check Ehancement.
  ;*** Allergy/adverse reaction check.
  N PTR,X
@@ -75 +67 @@
  .W !!
  K PSJACK,GMRAING,I,^TMP($J)
- D ALGCLASS
+ D ALGCLASS^PSGSICH1
 CONT ; Ask user if they wish to continue in spite of an order check.
- 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,"
- 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
+ ;Variable PSJDDCON is the order continuation flag for Duplicate Drug Check Enhancement.
+ I $D(PSJDDCON("DD")),'PSJDDCON("DD") Q
+ I '$D(PSJDDCON("DD")) Q:'$D(PSJPDRG)  N DIR D  I 'Y S PSGORQF=1,X="^",COMQUIT=1 K PSJDDCON Q
+ . 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")
+ . 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")
+ . D ^DIR
+ . Q
+ ;
+ K PSJDDCON  ;Order continuation flag for Duplicate Drug Check Enhancement.
  I 'INTERVEN!($P(PSJSYSU,";")'=3) Q
- NEW PSJY
+ N PSJY
  W:PSJIREQ !!,"This is a CRITICAL interaction, you must enter an intervention log to continue"
  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)
  F  S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0  D SF
- D ENKV^PSGSETU K N5,ND,Q,Y Q
+ D ENKV^PSGSETU K N5,ND,Q,Y
+ Q
  ;
 SF ;
+ N PSGID
  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)
  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),!!
  Q
-ALGCLASS ; checks any Drug allergies or reactions to see if
- ;         the new drug is the same class
- ; this call can be removed by commenting out the call on IVSOL+16
- N PSJLIST,CT,CLS,CLCHK,CNT,PSJL,LIST,DCCNT,PSCLASS,LEN
- S PSCLASS=$P($G(^PSDRUG(PSJDD,0)),"^",2),LEN=4 I $E(PSCLASS,1,4)="CN10" S LEN=5 ;look at 5 chars if ANALGESICS
- I $T(GETDATA^GMRAOR)]"" G ALGC2
- S GMRA="0^0^111" D EN1^GMRADPT
- F PSJLIST=0:0 S PSJLIST=$O(GMRAL(PSJLIST)) Q:'PSJLIST  D
- .K PSJAGL D EN1^GMRAOR2(PSJLIST,"PSJAGL")
- .; is the allergy/reaction drug class first four digits the same as the
- .; the class for the drug being entered?
- .S (CT,CLS)="",DCCNT=0
- .I $D(PSJAGL("V")) D
- ..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)
- D:$G(CLCHK)
- .W !!,$C(7),"A Drug-Allergy Reaction exists for this medication and/or class!"
- .F PSJL=0:0 S PSJL=$O(LIST(PSJL)) Q:'PSJL  D
- ..W !?6,"Drug: "_$P(LIST(PSJL),"^"),!,"Drug Class: "_$P(LIST(PSJL),"^",2),!
- Q
-ALGC2 ;
- K GMRADRCL
- D GETDATA^GMRAOR(DFN) Q:'$D(^TMP("GMRAOC",$J,"APC"))
- N GMRACL,RET
- S RET=0,GMRACL="" F  S GMRACL=$O(^TMP("GMRAOC",$J,"APC",GMRACL)) Q:'$L(GMRACL)  D
- .N GMRANM,GMRALOC
- .S GMRALOC=^TMP("GMRAOC",$J,"APC",GMRACL)
- .S GMRANM=$P(^PS(50.605,+$O(^PS(50.605,"B",GMRACL,0)),0),U,2)
- .S GMRADRCL(GMRACL)=GMRACL_U_GMRANM_" ("_GMRALOC_")"
- .S RET=RET+1
- Q:'RET  K ^TMP("GMRAOC",$J)
- S CLCHK="",CT="" F  S CT=$O(GMRADRCL(CT)) Q:CT=""  D
- .I $E(PSCLASS,1,LEN)=$E(CT,1,LEN) S CLCHK=$G(CLCHK)+1,^TMP($J,"PSJDRCLS",CLCHK)=CT_" "_$P(GMRADRCL(CT),"^",2)
-CLASSDSP ;
- I '$D(^TMP($J,"PSJDRCLS")) Q
- W $C(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
- W !,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^")
- S CT="" F  S CT=$O(^TMP($J,"PSJDRCLS",CT)) Q:CT=""  W !,"Drug Class: "_^TMP($J,"PSJDRCLS",CT)
- K ^TMP($J,"PSJDRCLS")
- S DIR("?",1)="Answer 'YES' if you DO want to enter a reaction for this medication,"
- S DIR("?")="       'NO' if you DON'T want to enter a reaction for this medication,"
- S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Intervene? ",DIR("B")="Y" W ! D ^DIR
- I Y D ^PSJRXI
- I '$G(Y) K DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y Q
- Q