Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSODIR2

PSODIR2.m

Go to the documentation of this file. 
  1. PSODIR2 ;IHS/DSD/JCM - rx order entry contd ;29-May-2012 14:44;PLS
  1.  ;;7.0;OUTPATIENT PHARMACY;**3,9,26,46,124,146,139,152,166,1005,1008,1013,1014,1015**;DEC 1997;Build 62
  1.  ;External reference to ^DD(52 supported by DBIA 999
  1.  ;External reference to ^VA(200 supported by DBIA 10060
  1.  ;External reference to ^%DTC supported by DBIA 10000
  1.  ;External reference to ^DIC supported by DBIA 10006
  1.  ;External reference to ^DIR supported by DBIA 10026
  1.  ;
  1.  ;---------------------------------------------------------------------
  1.  ; Modified - IHS/CIA/PLS - 12/29/03 - Line DIR+4 and CLERK+6
  1.  ;            IHS/MSC/PLS - 12/30/2008 - Line FILLDT+11
  1.  ;                          10/31/2011 - Line CLERK+1
  1.  ;                          02/13/2012 - Line FILLDT+7
  1.  ;                          05/22/2012 - Line CLERK+1
  1. EXP(PSODIR) ;
  1.  K DIR,DIC
  1.  I $G(PSODRUG("EXPIRATION DATE"))]"" S Y=PSODRUG("EXPIRATION DATE") X ^DD("DD") S PSORX("EXPIRATION DATE")=Y
  1.  S DIR("A")="EXPIRES",DIR("B")=$S($G(PSORX("EXPIRATION DATE"))]"":PSORX("EXPIRATION DATE"),1:"T+6M")
  1.  S DIR(0)="D^NOW::EX"
  1.  S DIR("?")="Both the month and date are required."
  1.  D DIR G:PSODIR("DFLG")!PSODIR("FIELD") EXPX
  1.  S PSODIR("EXPIRATION DATE")=Y
  1. EXPX K X,Y
  1.  Q
  1.  ;
  1. CLINIC(PSODIR) ;
  1.  K DIR,DIC S PSODIR("FIELD")=0
  1.  S DIR(0)="52,5" S:$G(PSORX("CLINIC"))]"" DIR("B")=PSORX("CLINIC"),DIR("A")="CLINIC"
  1.  D ^DIR G:PSODIR("DFLG")!PSODIR("FIELD") CLINICX
  1.  I +Y>0 S PSODIR("CLINIC")=+Y,PSORX("CLINIC")=$P(Y,"^",2)
  1.  E  S (PSORX("CLINIC"),PSODIR("CLINIC"))=""
  1. CLINICX K X,Y,PSOX,DIC
  1.  Q
  1.  ;
  1. MW(PSODIR) ;
  1.  K DIR,DIC
  1.  S DIR(0)="52,11" S:$G(POERR)&'$D(PSORX("MAIL/WINDOW")) PSORX("MAIL/WINDOW")=$S($P($G(OR0),"^",17)="M":"MAIL",1:"WINDOW")
  1.  S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),$G(PSOTPBFG)&($G(PSOFROM)="NEW"):"MAIL",1:"WINDOW")
  1.  D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX
  1.  I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX
  1.  S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0)
  1.  I $G(PSORX("EDIT"))]"",PSODIR("MAIL/WINDOW")'="W" K PSODIR("METHOD OF PICK-UP")
  1. MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX
  1.  S DIR(0)="52,35O"
  1.  S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP")
  1.  D DIR G:PSODIR("DFLG") MWX
  1.  I X[U W !,"Cannot jump to another field ..",! G MW1
  1.  S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y
  1. MWX K X,Y
  1.  Q
  1.  ;
  1. RMK(PSODIR) ;
  1. RMKEN K DIR,DIC
  1.  S DIR(0)="52,12"
  1.  S:$G(PSODIR("REMARKS"))]"" DIR("B")=PSODIR("REMARKS")
  1.  D DIR G:PSODIR("DFLG") RMKX
  1.  I X[U W !,"Cannot jump to another field ..",! G RMKEN
  1.  S:$L(X)>0 PSODIR("REMARKS")=X
  1.  S:X="@" PSODIR("REMARKS")=""
  1. RMKX K X,Y
  1.  Q
  1.  ;
  1. ISSDT(PSODIR) ;
  1.  K DIR,DIC
  1.  S DIR("A")="ISSUE DATE",DIR("B")=$S($G(POERR)&($G(PSORX("ISSUE DATE"))']"")&($G(PSODIR("ISSUE DATE"))]""):PSODIR("ISSUE DATE"),$G(PSORX("ISSUE DATE"))]"":PSORX("ISSUE DATE"),1:"TODAY")
  1.  I DIR("B") S Y=DIR("B") X ^DD("DD") S DIR("B")=Y
  1.  S DIR(0)="52,1"
  1.  D DIR G:PSODIR("DFLG")!PSODIR("FIELD") ISSDTX
  1.  S (PSODIR("ISSUE DATE"),PSOID)=Y
  1.  X ^DD("DD") S (PSORX("ISSUE DATE"),PSODIR("ISSUE DATE"))=Y
  1. ISSDTX K X,Y
  1.  Q
  1.  ;
  1. FILLDT(PSODIR) ;
  1.  K DIR,DIC
  1.  S:'$G(PSONEW("DAYS SUPPLY")) PSONEW("DAYS SUPPLY")=30,PSONEW("# OF REFILLS")=1
  1.  S DIR("A")="FILL DATE",DIR("B")=$S($G(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")
  1.  S X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
  1.  S X1=$S($G(PSOID):PSOID,1:DT)
  1.  ;S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSODIR("CS")):184,1:366)
  1.  S X2=$S(+$G(PSODIR("CS")):184,1:366)  ;IHS/MSC/PLS - 02/10/2012
  1.  ;I X2<30 D
  1.  ;. N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
  1.  ;. S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
  1.  D C^%DTC S PSOFDMX=$P(X,".") I DT>X S Y=$S($G(PSOID):PSOID,1:PSORX("ISSUE DATE")) X ^DD("DD") S DIR("B")=Y
  1.  ;IHS/MSC/PLS - 12/30/2008 - Check for Suspense
  1.  ;S DIR(0)="D^"_$S($G(PSOID):PSOID,+$G(PSODIR("ISSUE DATE")):PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I":":"_DT_":EX",1:":"_PSOFDMX_":EX")
  1.  S DIR(0)="D^"_$S($G(PSOID):PSOID,+$G(PSODIR("ISSUE DATE")):PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I"&('$P(PSOPAR,U,24)):":"_DT_":EX",1:":"_PSOFDMX_":EX")
  1.  S Y=PSOFDMX X ^DD("DD")
  1.  S DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"
  1.  S DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE or AFTER the Expiration Date "
  1.  S DIR("?")=Y_".  Both the month and date are required."
  1.  D DIR G:PSODIR("DFLG")!PSODIR("FIELD") FILLDTX
  1.  S PSODIR("FILL DATE")=Y
  1.  X ^DD("DD") S PSORX("FILL DATE")=Y
  1. FILLDTX K X,Y,PSOFDMX
  1.  Q
  1.  ;
  1. CLERK(PSODIR) ;
  1.  ;IHS/MSC/PLS - 10/31/2011
  1.  ;I $G(DUZ("AG"))'="I" D  G CLERKX
  1.  ;IHS/MSC/PLS - 05/22/2012 REMOVED THE DOTTED DO
  1.  ;D  G CLERKX
  1.  S PSODIR("CLERK CODE")=$S($G(PSOFDR):$P(OR0,"^",4),1:DUZ),PSORX("CLERK CODE")=$P($G(^VA(200,PSODIR("CLERK CODE"),0)),"^")
  1.  K DIR,DIC
  1.  S DIR("A")="CLERK",DIR("B")=$S($G(PSORX("CLERK CODE"))]"":PSORX("CLERK CODE"),1:$P($G(^VA(200,DUZ,0)),"^",2)),DIR(0)="52,16"
  1.  D DIR G:PSODIR("DFLG")!PSODIR("FIELD") CLERKX
  1.  ; IHS/CIA/PLS - 01/25/04 - Next line commented out
  1.  ;S PSODIR("CLERK CODE")=+Y,PSORX("CLERK CODE")=$P(Y,"^")
  1.  S PSODIR("CLERK CODE")=+Y,PSORX("CLERK CODE")=$P(Y,"^",2)  ; IHS/CIA/PLS - 01/25/04 - Changed to Name from initials
  1. CLERKX Q
  1.  ;
  1. DIR ;
  1.  S PSODIR("FIELD")=0
  1.  G:$G(DIR(0))']"" DIRX
  1.  D ^DIR K DIR,DIE,DIC,DA I X="^^" S (PSODIR("QFLG"),PSODIR("DFLG"))=1 G DIRX
  1. DIRS ; EP - IHS/CIA/PLS - 12/23/03 - New entry point DIRS added.
  1.  I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 S:$G(SPEED) PSODIR("QFLG")=1 G DIRX
  1.  I $D(DUOUT)!($D(DTOUT)),$G(SPEED) S PSODIR("DFLG")=1 G DIRX
  1.  I X[U,$L(X)>1 D JUMP
  1. DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
  1.  Q
  1.  ;
  1. JUMP ;
  1.  I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
  1.  S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
  1.  I Y=-1 S PSODIR("FIELD")=$G(PSODIR("FLD")) G JUMPX
  1.  I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
  1.  I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
  1.  I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
  1. JUMPX S X="^"_X
  1.  Q
  1.  ;Reset refills when drug changed to a controlled sub
  1. RFRSET ;
  1.  N RFN,RFNC
  1.  S (RFN,RFNC)=0
  1.  F  S RFN=$O(^PSRX(+$G(PSODIR("IRXN")),1,RFN)) Q:'RFN  S RFNC=RFNC+1
  1.  I $D(PSODIR("FIELD")) S PSODIR("FIELD")=0
  1.  S PSODIR("# OF REFILLS")=RFNC
  1.  S VALMSG="The drug has been changed and no longer allows refills."
  1.  W !,VALMSG,!
  1.  Q