Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m	(revision 636)
@@ -1,4 +1,4 @@
 PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM
- ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175,201**;16 DEC 97;Build 2
+ ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175**;16 DEC 97;Build 18
  ;
  ; Reference to ^PS(55 is supported by DBIA# 2191.
@@ -96,4 +96,5 @@
  N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0
  S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME=""
+ I $G(PSJRQPND) S PROVIDER=0
  I PROVIDER>0 D
  .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m	(revision 636)
@@ -1,4 +1,4 @@
-PSGPLR ;BIR/CML3-PRINTS PICK LIST REPORT ; 6/15/07 1:12pm
- ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129,191**;16 DEC 97;Build 9
+PSGPLR ;BIR/CML3-PRINTS PICK LIST REPORT ;04 May 98 / 11:23 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129**;16 DEC 97
  ;
  ; Reference to ^PS(55 is supported by DBIA# 2191.
@@ -31,10 +31,9 @@
  .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
  .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
- .F PSGPLXRX="AU","AC" Q:CNT  F I=0:1 S DDRG=$O(PSGPLREN(53.5,PSGPLXRX,PSGPLG,TM,WDN,RM,PN,PST,TMPDRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  D
+ .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
  ..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
  ..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)
  ..S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0)
- ..;GMZ;PSJ*5*191;Allow for Multiple Dispensed Drug units needed
- ..S PSJRNW(I)=1_"^"_+NEED
+ ..S PSJRNW=1_"^"_+NEED
  ..Q
  .K PSGPLREN("B",PSGP,PSJJORD),PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND) W !!
@@ -47,7 +46,5 @@
  .I ATC S X=0,X=$O(^PS(59.7,X)) I $P($G(^(X,26)),U,2)=1,PST="OC" S ATC=0
  .S UD=$S('UD:1,UD=.5:"1/2",UD=.25:"1/4",UD<1:"0"_UD,1:UD)
- .I $D(PSJRNW) D
- ..I 'CNT W !?35,"**** RENEWAL ****"
- ..S NEED=NEED-$P(PSJRNW(CNT),"^",2) S:NEED<0 NEED=0 S CNT=CNT+1
+ .I $G(PSJRNW),'CNT W !?35,"**** RENEWAL ****" S CNT=CNT+1,NEED=NEED-$P(PSJRNW,"^",2) S:NEED<0 NEED=0
  .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:"____")
  .S:ST="DISCONTINUED" OLDWARD=1 S ST=""
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m	(revision 636)
@@ -1,6 +1,5 @@
 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,6 +11,4 @@
  ; 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,13 +25,6 @@
 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,4 +48,5 @@
  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,4 +54,5 @@
  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,10 +67,17 @@
  .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,7 +88,9 @@
  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,46 +117,2 @@
  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
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 12/12/07
+PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 01/17/08
  ; 
  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
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 12/12/07
+PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08
  ; 
  S DIKZK=2
@@ -32,5 +32,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^PS(53.1,"B",$E(X,1,30),DA)
-CR1 S DIXR=502
+CR1 S DIXR=498
  K X
  S DIKZ("DSS")=$G(^PS(53.1,DA,"DSS"))
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 12/12/07
+PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 12/12/07
+PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 12/12/07
+PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 12/12/07
+PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 12/12/07
+PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 12/12/07
+PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 12/12/07
+PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 12/12/07
+PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 12/12/07
+PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08
  ; 
  S DIKZK=1
@@ -48,5 +48,5 @@
  S X=$P(DIKZ(.2),U,8)
  I X'="" S ^PS(53.1,"ACX",$E(X,1,30),DA)=""
-CR1 S DIXR=502
+CR1 S DIXR=498
  K X
  S DIKZ("DSS")=$G(^PS(53.1,DA,"DSS"))
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 12/12/07
+PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 12/12/07
+PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m	(revision 636)
@@ -1,4 +1,4 @@
 PSJLMPRU ;BIR/MLM-INPATIENT LISTMAN UD PROFILE UTILITIES ;27 Aug 98 / 8:45 AM
- ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110,185**;16 DEC 97;Build 6
+ ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110**;16 DEC 97
  ;
  ; Reference to ^PSDRUG is supported by DBIA 2192.
@@ -44,11 +44,6 @@
  ;                       LM  = Begin display of text after LM spaces.
  ;                       RM  = Length of display text.
- ;
- ;BHW;PSJ*5*185;Extra spaces causes display to "skip" part of the field.                      
- ;S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD=""  D
- S PSJL="",$P(PSJL," ",LM)=""
- F X=1:1:$L(TXT," ") S WRD=$P(TXT," ",X) D
- .;BHW;PSJ*5*185;check if end of string or just extra space.
- .I WRD="" S PSJL=PSJL_" " Q
+ ;                       
+ S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD=""  D
  .I $L(PSJL_" "_WRD)'<RM D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)=""
  .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))
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m	(revision 636)
@@ -1,6 +1,6 @@
 PSJLMUDE ;BIR/MLM-SHOW FIELDS FOR EDIT (LISTMAN STYLE) ;01 JUNE 00 / 2:40 PM
- ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175,201**;16 DEC 97;Build 2
-  ;NFI-UD Fr#:2 chgs@init+4 to display non-formulary (N/F)
-  ;also chgs @init+23
+ ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175**;16 DEC 97;Build 18
+ ;NFI-UD Fr#:2 chgs@init+4 to display non-formulary (N/F)
+ ;also chgs @init+23
  ;
  ; Reference to ^PS(55 is supported by DBIA# 2191
@@ -12,10 +12,10 @@
  D CLEAN^VALM10
  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)
- . NEW Q,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S PSJDDA(+$G(^(Q,0)))=""
+ . N Q,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S PSJDDA(+$G(^(Q,0)))=""
  . S PSJVD=$$DINFLUD^PSJDIN(PSGPD,.PSJDDA)
  . S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,80)
  . D:PSJVD]"" CNTRL^VALM10(1,75,5,IORVON,IORVOFF,0)
  I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD)
- S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6,80)
+ S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6,120)
  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)
  I $G(PSGRDTX) S PSJDUR=$$FMTDUR^PSJLIVMD($P($G(PSGRDTX),U,2))
@@ -48,5 +48,4 @@
  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)
  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
- ;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)
  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)
  S PSJL="" D SETTMP D:$G(PSGOEEF(8)) HILITE(11)
@@ -54,6 +53,5 @@
  I $O(^PS(53.45,PSJSYSP,2,1)) F  S PSJL="" D SETTMP Q:PSJLN>15
  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)
- ;S $P(PSJL,"-",80)="" D SETTMP
- NEW PSJX
+ N PSJX,PSGID
  F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S ND=$G(^(Q,0)) D
  .S D=$P(ND,"^"),PSGID=$P(ND,"^",3) I PSGID S PSGID=$$ENDTC^PSGMI(PSGID)
@@ -75,9 +73,10 @@
  .D SETTMP S PSJL="Order Checks:" D SETTMP
  .F Q=0:0 S Q=$O(^PS(53.1,+PSGORD,10,Q)) Q:'Q  D
- ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) D SETTMP
+ ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) S PSJWPL=PSJL D DISPLAY
  ..S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+PSGORD,10,Q,1)),U) D SETTMP
  ..S PSJL="Overriding Reason: " F X=0:0 S X=$O(^PS(53.1,+PSGORD,10,Q,2,X)) Q:'X   D
  ...S PSJL=PSJL_$G(^PS(53.1,+PSGORD,10,Q,2,X,0)) D SETTMP S PSJL="                   "
 ACTFLG ;
+ N ND4,AT,Y,X
  S ND4=$S(PSGORD["P":$G(^PS(53.1,+PSGORD,4)),1:$G(^PS(55,PSGP,5,+PSGORD,4)))
  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,10 +95,15 @@
  I $G(PSGPI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" PROVIDER"
  Q
+ ;
 DISPLAY ;
- S PSJL=PSJWPL D SETTMP
- ;F X=1:1 S WRD=$P(PSJWPL," ",X) Q:WRD=""  D
- ;.I $L(PSJL_" "_WRD)'<80 D SETTMP S PSJL=$P(PSJWPL,PSJL,2) S:$E(PSJL,1)=" " PSJL=$E(PSJL,2,999),PSJWPL="" Q
- ;.S PSJL=PSJL_$S(PSJL="":"",1:" ")_WRD
- Q
+ N X,LEN,LIM,PCS
+ S LIM=$L(PSJWPL," "),PCS=1
+ F X=1:1:LIM S LEN=$L($P(PSJWPL," ",PCS,X)) D
+ . I LEN'<72!(X=LIM) D
+ .. S PSJL=$P(PSJWPL," ",PCS,X)
+ .. I PCS>1 S PSJL="   "_PSJL
+ .. S PCS=X+1
+ .. D SETTMP
+ Q 
  ;
 SETTMP ;
@@ -108,8 +112,6 @@
  ;
 HILITE(FLD) ; 
- N COL,LIN,WID,X
- ;Q:'$G(PSGOEENO)
+ N COL,LAB,LIN,WID,X
  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))
- ;D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IOINORM,0)
  I FLD=7 S LIN=+$G(PSJLN)-1 Q:LIN<13
  D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IORVOFF_IOBOFF,0)
@@ -128,3 +130,5 @@
 11 ;;11,7,22,PSGSI
 ENKILL ;
- 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
+ K PSGAT,PSGDO,PSGEB,PSGEFN,PSGFD,PSGFDN,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD
+ K PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM,PSGOINST,PSGPRN,PSGRFDN,PSGRSDN,PSGSCH,PSGSDN,PSGSI,PSGSTN,PSJWPL,RNDT
+ Q
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSJLMUT1 ;BIR/MLM-DRUG NAME DISPLAY ;05 Feb 98 / 1:39 PM
- ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175,201**;16 DEC 97;Build 2
+ ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175**;16 DEC 97;Build 18
  ;
  ; Reference to ^PS(55 is supported by DBIA# 2191.
@@ -25,5 +25,4 @@
  I +$O(@(F_"1,0)")),'+$O(@(F_"1,1)")),PSGUPDDO="" D DD(F,.DRUGNAME)
  S:($G(DRUGNAME)=""!($G(DRUGNAME)["NOT FOUND")) DRUGNAME=$$OIDF(OIND)
- ;S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_PSGINS_PSGUPDDO_" "_MR_" "_SCH
  S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_$S(('$D(PSJPDDDP)&('$L(PSGUPDDO))):PSGINS,1:PSGUPDDO)_" "_MR_" "_SCH
  S PSGX=0 K PSJPDDDP
@@ -34,4 +33,5 @@
  . S NAME(PSGX+X)=$S(X>1:"      ",1:"")_MARX(X)
  Q
+ ;
 OIDF(OIND)    ; Return Orderable Item name and Dosage form.
  ;; +OIND = orderable item IEN
@@ -50,4 +50,5 @@
  S PSJPDDDP=1
  Q
+ ;
 DSPLORDU(PSGP,ON)   ; Display UD order for order check as in the Inpat Profile.
  NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y
@@ -66,6 +67,7 @@
  . S PSJLINE=PSJLINE+1
  Q
+ ;
 DSPLORDV(DFN,ON)   ; Display IV order for order check as in the Inpat Profile.
- N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJIVFLG,PSJORIFN,TYP,X,Y
+ N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJCT,PSJIVFLG,PSJORIFN,TYP,X,Y
  S TYP="?" I ON["V" D
  .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,8 +78,10 @@
  S PSJIVFLG=1 D PIVAD,SOL
  Q
+ ;
 SOL ;
  S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_"        in"
  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="      "
  Q
+ ;
 PIVAD ; Print IV Additives.
  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,7 +94,9 @@
  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)
  Q
+ ;
 SETTMP ;
  S PSJOC(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1
  Q
+ ;
 ORDCHK(DFN,TYPE,PIECE)   ;
  ;TYPE ="DD" - Duplicate drug
@@ -114,5 +120,4 @@
  . ; Adding Drug Interactions check for use in Intervention defaults in PSJRXI.
  . I TYPE="DI" S PSJRXREQ=$S($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL":1,1:2)
- . ;I $P(PSJPACK,";",2)["O" D  Q
  . N X S X=$P(PSJPACK,";",2) I X["O" D  Q
  ..  D:PSJFST=1 PAUSE
@@ -123,5 +128,4 @@
  . I ON=$G(PSIVOCON),+PSJORIEN Q
  . I ON=$G(PSIVOCON),'+PSJORIEN D SETPSJOC Q
- . ;S PSJOC=PSJOC+1,PSJPDRG=1 D:PSJOC=1 WRITE(TYPE)
  . I ON["V" D
  .. I '$O(^PS(55,DFN,"IV",+ON,0)) D SETPSJOC Q
@@ -129,9 +133,22 @@
  . I ON'["V" D DSPLORDU(DFN,ON) S PSJOC=PSJOC+1
  . S PSJOC(ON,PSJLINE)="",PSJLINE=PSJLINE+1
- D:PSJOC WRITE(TYPE)
- S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  W ! S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D
- . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1 D:'(PSIVX#6) PAUSE
- W !
+ ;  DEM - If TYPE="DI", and there are "DI" orders,
+ ;        then display "DI" orders.
+ I TYPE="DI",PSJOC D WRITE(TYPE) D  ;DEM
+ . S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D  ;DEM
+ .. F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1  ;DEM
+ Q:(TYPE="DI")  ;DEM - Don't continue if TYPE="DI". Code that follows is for TYPEs "DD" and "DC" only.
+ Q:'PSJOC  ;DEM - No need to continue if no "DD", or "DC" orders.
+ ;  DEM - If we are here, then there are "DD", or "DC" orders in
+ ;        PSJOC array. Loop on PSJOC array and set orders into
+ ;        ^TMP($J,"DUPDRG",TYPE) global. The ^TMP($J,"DUPDRG",TYPE)
+ ;        global will be used for display of "DD" and "DC" orders
+ ;        for possible discontinuation of the "DD", or "DC" orders.
+ ;        See subroutine DUPDRG and calling routine ENDDC^PSGSICHK
+ ;        for details.
+ S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  D  ;DEM
+ . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  S ^TMP($J,"DUPDRG",TYPE,ON,PSIVX)=PSJOC(ON,PSIVX)  ;DEM
  Q
+ ;
 SETPSJOC ;Set PSJOC array to be displayed later
  NEW PIECE S PIECE=$S(TYPE="DC":4,1:2)
@@ -140,4 +157,5 @@
  S PSJOC(ON,PSJLINE)=X,PSJLINE=PSJLINE+1,PSJOC=PSJOC+1
  Q
+ ;
 WRITE(TYPE)        ;Display order check description
  S PSJPDRG=1
@@ -146,4 +164,5 @@
  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),":",!
  Q
+ ;
 PAUSE ;
  K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m	(revision 636)
@@ -1,5 +1,10 @@
 PSJLMUT2 ;BIR/JLC-DISPLAY UTILITIES ;22 Jun 05
- ;;5.0; INPATIENT MEDICATIONS ;**146,175,201**;16 DEC 97;Build 2
+ ;;5.0; INPATIENT MEDICATIONS ;**146,175**;16 DEC 97;Build 18
  ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PSDRUG is supported by DBIA# 2192.
+ ; Reference to ^PSSLOCK is supported by DBIA# 2789.
+ ; Reference to ^VA(200 is supported by DBIA# 10060.
+ ; 
 SHOR(PSJT,PSJI)       ;Display outpatient remote order checks.
  ;; PSJT = Type of order check in ^TMP
@@ -25,4 +30,5 @@
  W !,PSJULN
  Q
+ ;
 FSIG(FSIG) ;Format sig from remote site
  ;returned in the FSIG array
@@ -37,4 +43,99 @@
  I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
 FQUIT Q
+ ;
+DUPDRG(DFN) ;DEM - Duplicate Drug Check Ehancement
+ ;
+ ;  Note: Display of Drug Interaction, Non-VA Meds, and Outpatient
+ ;        orders is done by ORDCHK^PSJLMUT1. ORDCHK is called by
+ ;        routine ENDDC^PSGSICHK before routine ENDDC^PSGSICHK calls
+ ;        DUPDRG^PSJLMUT2. If ORDCHK finds "DD", or "DC" orders,
+ ;        then ORDCHK will set "DD", or "DC" orders into
+ ;        ^TMP($J,"DUPDRG",TYPE) global.
+ ;
+ K PSJDDCON  ;Order continuation flag used by routine PSGSICHK.
+ S:$D(^TMP($J,"DI")) PSJDDCON("DI")=1  ;Order continuation flag used by routine PSGSICHK.
+ ;  Quit if no duplicate drug orders(s), or duplicate drug class
+ ;  order(s) found.
+ Q:'$D(^TMP($J,"DUPDRG","DD"))&'$D(^TMP($J,"DUPDRG","DC"))
+ S PSJDDCON("DD")=0  ;Order continuation flag used by routine PSGSICHK.
+ ;
+ ;  Display orders in ^TMP($J,"DUPDRG",DUPLICATE_TYPE,ON,LINE_#)
+ ;  (DUPLICATE TYPEs: "DD" - "Duplicate Drug"
+ ;                    "DC" - "Duplicate Drug Class"
+ ;
+ S PSJPDRG=1  ;If we are here, then set PSJPDRG=1. ORDCHK^PSJLMUT1 addresses this variable for Outpatient orders and "DI" orders.
+ N X,Y,DIR,TYPE,ON,PSJOC,PSJOCPOP,PSJSYSL
+ 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"),":",!!
+ D DSPLDD  ;Display patients orders for the same drug or same drug class as drug selected.
+ ;  Ask user if they wish to continue in spite of an order check.
+ 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,"
+ 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
+ K X,Y,DIR
+ S PSJDDCON("DD")=1,PSJSYSL=0  ;Order continuation flag used by routine PSGSICHK. 
+ W !
+ F  D  Q:('PSJOC)!(PSJOCPOP)  ;Order discontinuation loop.
+ . N TYPE,ON,PSJOCSEQ
+ . S PSJOCPOP=0
+ . ;  Ask user if they wish to discontinue any of the listed orders.
+ . 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,"
+ . 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
+ . K X,Y,DIR
+ . W !
+ . ;  Choose for DISCONTINUE 1-PSJOC (PSJOC is the total number of duplicate and duplicate class orders).
+ . 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
+ . S PSJOCSEQ=+Y
+ . K X,Y,DIR
+ . ;
+ . ;  *** Discontinue order ***
+ . S ON=$P(PSJOC(PSJOCSEQ),"^",2)
+ . I '$$LS^PSSLOCK(DFN,ON) S PSJOCPOP=1 Q
+ . S PSGSTAT=$$GTSTATUS^PSJOE(DFN,ON)
+ . D  ;Set PSGOEEWF for order being discontinued - DRF
+ .. I ON["P" S PSGOEEWF="^PS(53.1,"_+ON_"," Q
+ .. I ON["U" S PSGOEEWF="^PS(55,"_DFN_",5,"_+ON_"," Q
+ .. S PSGOEEWF="^PS(55,"_DFN_",""IV"","_+ON_","
+ . D  ;The following variables must be newed or they are stomped on by the discontinue code
+ .. N %DT,CF,D,D0,DA,DI,DIC,DIE,DISYS,DQ,DR,DRG,DRGT,DRGTMP,DRGX
+ .. N DTIME,FIL,I,JJ,LOC,OCXDT,OCXI,OCXSEG,ORIFN,ORO,POP,PSGALR
+ .. N PSGDT,PSGOEAV,PSJNOO,PSGOEDMR,PSGOEPR,PSGPDRG,PSGTOO,PSGTOL
+ .. N PSGUOW,PSIVOI,PSIVX,PSJCOM,PSJDD,PSJHLMTN,PSJMSG,PSJQO,PSOC
+ .. N Q,QQ,T,VA,VADM,VAERR,VAIN,XPARSYS,XQXFLG,Y,PSJRQPND
+ .. D
+ ... S PSJRQPND=1
+ ... I ON["V" D  Q  ;IV order
+ .... N PSJORD
+ .... S PSJORD=ON
+ .... D DC^PSJLIACT
+ ... D DC^PSJOE(DFN,ON)  ;UD order
+ .. 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.
+ ... S TYPE=$P(PSJOC(PSJOCSEQ),"^",1),ON=$P(PSJOC(PSJOCSEQ),"^",2),PSJOC=PSJOC-1
+ ... K PSJOC(PSJOCSEQ),^TMP($J,"DUPDRG",TYPE,ON),PSJOCSEQ
+ . D UNL^PSSLOCK(DFN,ON)
+ . Q:'PSJOC
+ . 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"),":",!!
+ . D DSPLDD
+ . Q
+ W !
+ K PSJOCPOP,PSGSTAT
+ Q
+ ;
+DSPLDD ;
+ ;  Display patients orders for the same drug or same drug class as drug selected.
+ N X,REQPROV,PSJLINE,PSJFLN
+ K PSJOC
+ ;  Requesting Provider
+ S PSJOC=0
+ F TYPE="DD","DC" S ON="" F  S ON=$O(^TMP($J,"DUPDRG",TYPE,ON)) Q:ON=""  S PSJFLN=1 D
+ . I ON["U" S REQPROV=$P(^PS(55,DFN,5,+ON,0),"^",2)
+ . I ON["V" S REQPROV=$P(^PS(55,DFN,"IV",+ON,0),"^",6)
+ . I ON["P" S REQPROV=$P(^PS(53.1,+ON,0),"^",2)
+ . S REQPROV=$S(REQPROV>0:$P($G(^VA(200,REQPROV,0)),"^",1),1:"") S:REQPROV="" REQPROV="Requesting Provider Unknown"
+ . F PSJLINE=0:0 S PSJLINE=$O(^TMP($J,"DUPDRG",TYPE,ON,PSJLINE)) Q:'PSJLINE  D
+ .. I PSJFLN=1 S PSJOC=PSJOC+1,PSJOC(PSJOC)=TYPE_"^"_ON W PSJOC_".",^TMP($J,"DUPDRG",TYPE,ON,PSJLINE),! S PSJFLN=PSJFLN+1 Q
+ .. 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
+ .. Q
+ . Q
+ Q
+ ;
 PAUSE ;
  K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m	(revision 636)
@@ -1,4 +1,4 @@
-PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ; 6/18/07 12:11pm
- ;;5.0; INPATIENT MEDICATIONS ;**191**;16 DEC 97;Build 9
+PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ;20 DEC 96 / 3:15 PM
+ ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
  ;
 PEND ;*** Only select orders that were acknowledged by nurses and are
@@ -8,5 +8,4 @@
  F ON=0:0 S ON=$O(^PS(53.1,"AV",PSGP,ON)) Q:'ON  D
  . S ND=$G(^PS(53.1,ON,0)),TYPE=$P(ND,U,4)
- . S ND2=$G(^PS(53.1,ON,2)),PSGLSD=$P(ND2,U,2),PSGLFD=$P(ND2,U,4)
  . 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")
  . E  S QST="CZ"_$S($P(ND,U,4)="F":"V",1:"A")
@@ -25,5 +24,5 @@
  D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_ON
  ;*** Set up ^TMP for sort by patients
- 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),PSJSCHE=$P($G(^PS(53.1,ON,2)),U)
+ 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)
  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")
  D SI
