PSODIR3.m

PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;29-May-2012 14:44;PLS

 ;;7.0;OUTPATIENT PHARMACY;**3,46,1008,184,222,206,1015**;DEC 1997;Build 62

 ;Modified - IHS/MSC/PLS - 12/30/2008 - Line FILLDT+3

 ;                         06/01/2010 - Line REFOR+6

 ;

EXP(PSODIR) ;

 K DIC,DIR

 I $G(PSODRUG("EXPIRATION DATE"))]"" S Y=PSODRUG("EXPIRATION DATE") X ^DD("DD") S PSORX("EXPIRATION DATE")=Y

 S DIR("A")="EXPIRES",DIR("B")=$S($G(PSORX("EXPIRATION DATE"))]"":PSORX("EXPIRATION DATE"),1:"T+6M")

 S DIR(0)="D^NOW::EX",DIR("?")="Both the month and date are required." D ^DIR

 G:PSODIR("DFLG")!PSODIR("FIELD") EXPX

 S PSODIR("EXPIRATION DATE")=Y

EXPX K X,Y

 Q

 ;

MW(PSODIR) ;

 K DIR,DIC

 S DIR(0)="52,11"

 S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")

 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX

 I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX

 S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0)

 I $G(PSORX("EDIT"))]"",PSODIR("MAIL/WINDOW")'="W" K PSODIR("METHOD OF PICK-UP")

MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX

 S DIR(0)="52,35O"

 S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP")

 D DIR G:PSODIR("DFLG") MWX

 I X[U W !,"Cannot jump to another field ..",! G MW1

 S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y

MWX K X,Y

 Q

 ;

FILLDT(PSODIR) ;

 K DIR,DIC

 S DIR("A")="FILL DATE",DIR("B")=$S($G(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")

 ;IHS/MSC/PLS - 12/30/2008 - Added check for Suspense

 ;S DIR(0)="D^"_$S($G(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I":":"_DT_":EX",1:"::EX")

 S DIR(0)="D^"_$S($G(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I"&('$P(PSOPAR,U,24)):":"_DT_":EX",1:"::EX")

 S DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"

 S DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE."

 S DIR("?")="Both the month and date are required."

 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") FILLDTX

 S PSODIR("FILL DATE")=Y

 X ^DD("DD") S PSORX("FILL DATE")=Y

FILLDTX K X,Y

 Q

 ;

CLERK(PSODIR) ;

 I $G(DUZ("AG"))'="I",$G(DUZ) S PSODIR("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^") G CLERKX

 K DIR,DIC

 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"

 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") CLERKX

 S PSODIR("CLERK CODE")=+Y,PSORX("CLERK CODE")=$P(Y,"^")

CLERKX Q

 ;

DIR ;

 S PSODIR("FIELD")=0

 G:$G(DIR(0))']"" DIRX

 D ^DIR K DIR,DIE,DIC,DA

 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX

 I X[U,$L(X)>1 D JUMP

DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX

 Q

 ;

JUMP ;

 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q

 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC

 I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX

 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX

 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX

 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX

JUMPX S X="^"_X

 Q

 ;Continued from PSODIR1, Tag REFOR, Added PSOCS set and changed G REFILLX references to a QUIT

REFOR ;

 F DEA=1:1 Q:$E($G(PSODRUG("DEA")),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1

 I $G(PSOCS) D

 .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:5)

 .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)

 E  D

 .;IHS/MSC/PLS - 03/29/09 - Changed default from 11 to 15

 .;S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:11)

 .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:15)

 .;IHS/MSC/PLS - 12/10/08

 .;S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)

 .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:15,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)

 K PSOELSE I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D  Q

 .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["A":"this narcotic drug.",1:"this drug.")

 .W !,VALMSG,!

 .S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0

 I $D(CLOZPAT) D

 .S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)

 .S (PSODIR("# OF REFILLS"),PSODIR("N# REF"))=PSOX

 S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS"

 S DIR("B")=$S($G(POERR)&($G(PSODIR("# OF REFILLS"))):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)

 S DIR("?")="Enter a whole number.  The maximum is set by the DAYS SUPPLY field."

 D DIR Q:PSODIR("DFLG")!PSODIR("FIELD")

 S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y

 Q

PSODIR3   ;ISC-BIRM/SAB - rx order entry contd ;29-May-2012 14:44;PLS

 +1       ;;7.0;OUTPATIENT PHARMACY;**3,46,1008,184,222,206,1015**;DEC 1997;Build 62

 +2       ;Modified - IHS/MSC/PLS - 12/30/2008 - Line FILLDT+3

 +3       ;                         06/01/2010 - Line REFOR+6

 +4       ;

EXP(PSODIR) ;

 +1        KILL DIC,DIR

 +2        IF $GET(PSODRUG("EXPIRATION DATE"))]""

               SET Y=PSODRUG("EXPIRATION DATE")

               XECUTE ^DD("DD")

               SET PSORX("EXPIRATION DATE")=Y

 +3        SET DIR("A")="EXPIRES"

           SET DIR("B")=$SELECT($GET(PSORX("EXPIRATION DATE"))]"":PSORX("EXPIRATION DATE"),1:"T+6M")

 +4        SET DIR(0)="D^NOW::EX"

           SET DIR("?")="Both the month and date are required."

           DO ^DIR

 +5        IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO EXPX

 +6        SET PSODIR("EXPIRATION DATE")=Y

EXPX       KILL X,Y

 +1        QUIT 

 +2       ;

MW(PSODIR) ;

 +1        KILL DIR,DIC

 +2        SET DIR(0)="52,11"

 +3        SET DIR("B")=$SELECT($GET(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")

 +4        DO DIR

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO MWX

 +5        IF $GET(Y(0))']""

               SET PSODIR("DFLG")=1

               GOTO MWX

 +6        SET PSODIR("MAIL/WINDOW")=Y

           SET PSORX("MAIL/WINDOW")=Y(0)

 +7        IF $GET(PSORX("EDIT"))]""

               IF PSODIR("MAIL/WINDOW")'="W"

                   KILL PSODIR("METHOD OF PICK-UP")

MW1        IF PSODIR("MAIL/WINDOW")'="W"!('$PIECE($GET(PSOPAR),"^",12))

               GOTO MWX

 +1        SET DIR(0)="52,35O"

 +2        IF $GET(PSORX("METHOD OF PICK-UP"))]""

               SET DIR("B")=PSORX("METHOD OF PICK-UP")

 +3        DO DIR

           IF PSODIR("DFLG")

               GOTO MWX

 +4        IF X[U

               WRITE !,"Cannot jump to another field ..",!

               GOTO MW1

 +5        SET (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y

MWX        KILL X,Y

 +1        QUIT 

 +2       ;

FILLDT(PSODIR) ;

 +1        KILL DIR,DIC

 +2        SET DIR("A")="FILL DATE"

           SET DIR("B")=$SELECT($GET(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")

 +3       ;IHS/MSC/PLS - 12/30/2008 - Added check for Suspense

 +4       ;S DIR(0)="D^"_$S($G(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I":":"_DT_":EX",1:"::EX")

 +5        SET DIR(0)="D^"_$SELECT($GET(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$SELECT($GET(DUZ("AG"))="I"&('$PIECE(PSOPAR,U,24)):":"_DT_":EX",1:"::EX")

 +6        SET DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"

 +7        SET DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE."

 +8        SET DIR("?")="Both the month and date are required."

 +9        DO DIR

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO FILLDTX

 +10       SET PSODIR("FILL DATE")=Y

 +11       XECUTE ^DD("DD")

           SET PSORX("FILL DATE")=Y

FILLDTX    KILL X,Y

 +1        QUIT 

 +2       ;

CLERK(PSODIR) ;

 +1        IF $GET(DUZ("AG"))'="I"

               IF $GET(DUZ)

                   SET PSODIR("CLERK CODE")=DUZ

                   SET PSORX("CLERK CODE")=$PIECE($GET(^VA(200,DUZ,0)),"^")

                   GOTO CLERKX

 +2        KILL DIR,DIC

 +3        SET DIR("A")="CLERK"

           SET DIR("B")=$SELECT($GET(PSORX("CLERK CODE"))]"":PSORX("CLERK CODE"),1:$PIECE($GET(^VA(200,DUZ,0)),"^",2))

           SET DIR(0)="52,16"

 +4        DO DIR

           IF PSODIR("DFLG")!PSODIR("FIELD")

               GOTO CLERKX

 +5        SET PSODIR("CLERK CODE")=+Y

           SET PSORX("CLERK CODE")=$PIECE(Y,"^")

CLERKX     QUIT 

 +1       ;

DIR       ;

 +1        SET PSODIR("FIELD")=0

 +2        IF $GET(DIR(0))']""

               GOTO DIRX

 +3        DO ^DIR

           KILL DIR,DIE,DIC,DA

 +4        IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))

               IF $LENGTH($GET(X))'>1!(Y="")

                   SET PSODIR("DFLG")=1

                   GOTO DIRX

 +5        IF X[U

               IF $LENGTH(X)>1

                   DO JUMP

DIRX       KILL DIRUT,DTOUT,DUOUT,DIROUT,PSOX

 +1        QUIT 

 +2       ;

JUMP      ;

 +1        IF $GET(PSOEDIT)!($GET(OR0))

               SET PSODIR("DFLG")=1

               QUIT 

 +2        SET X=$PIECE(X,"^",2)

           SET DIC="^DD(52,"

           SET DIC(0)="QM"

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               SET PSODIR("FIELD")=PSODIR("FLD")

               GOTO JUMPX

 +4        IF $GET(PSONEW1)=0

               DO JUMP^PSONEW1

               GOTO JUMPX

 +5        IF $GET(PSONEW3)=0

               DO JUMP^PSONEW3

               GOTO JUMPX

 +6        IF $GET(PSORENW3)=0

               DO JUMP^PSORENW3

               GOTO JUMPX

JUMPX      SET X="^"_X

 +1        QUIT 

 +2       ;Continued from PSODIR1, Tag REFOR, Added PSOCS set and changed G REFILLX references to a QUIT

REFOR     ;

 +1        FOR DEA=1:1

               IF $EXTRACT($GET(PSODRUG("DEA")),DEA)=""

                   QUIT 

               IF $EXTRACT(+PSODRUG("DEA"),DEA)>1

                   IF $EXTRACT(+PSODRUG("DEA"),DEA)<6

                       SET $PIECE(PSOCS,"^")=1

                       IF $EXTRACT(+PSODRUG("DEA"),DEA)=2

                           SET $PIECE(PSOCS,"^",2)=1

 +2        IF $GET(PSOCS)

               Begin DoDot:1

 +3                SET (PSOX,PSOMAX)=$SELECT($GET(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$GET(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$GET(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$DATA(CLOZPAT):0,1:5)

 +4                SET PSOX=$SELECT('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX)

                   SET PSDY=PSODIR("DAYS SUPPLY")

                   SET PSDY1=$SELECT(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0)

                   SET PSOX=$SELECT(PSOX'>PSDY1:PSOX,1:PSDY1)

               End DoDot:1

 +5       IF '$TEST

               Begin DoDot:1

 +6       ;IHS/MSC/PLS - 03/29/09 - Changed default from 11 to 15

 +7       ;S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:11)

 +8                SET (PSOX,PSOMAX)=$SELECT($GET(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$GET(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$GET(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$DATA(CLOZPAT):0,1:15)

 +9       ;IHS/MSC/PLS - 12/10/08

 +10      ;S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)

 +11               SET PSDY=PSODIR("DAYS SUPPLY")

                   SET PSDY1=$SELECT(PSDY<60:15,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0)

                   SET PSOX=$SELECT(PSOX'>PSDY1:PSOX,1:PSDY1)

               End DoDot:1

 +12       KILL PSOELSE

           IF '$DATA(CLOZPAT)

               IF $GET(PSODRUG("DEA"))["A"&($GET(PSODRUG("DEA"))'["B")!($GET(PSODRUG("DEA"))["F")!($GET(PSODRUG("DEA"))[1)!($GET(PSODRUG("DEA"))[2)

                   Begin DoDot:1

 +13                   SET VALMSG="No refills allowed on "_$SELECT($GET(PSODRUG("DEA"))["A":"this narcotic drug.",1:"this drug.")

 +14                   WRITE !,VALMSG,!

 +15                   IF $DATA(PSODIR("FIELD"))

                           SET PSODIR("FIELD")=0

                       SET PSODIR("# OF REFILLS")=0

                   End DoDot:1

                   QUIT 

 +16       IF $DATA(CLOZPAT)

               Begin DoDot:1

 +17               SET PSOX=$SELECT($GET(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$GET(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$GET(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)

 +18               SET (PSODIR("# OF REFILLS"),PSODIR("N# REF"))=PSOX

               End DoDot:1

 +19       SET DIR(0)="N^0:"_PSOX

           SET DIR("A")="# OF REFILLS"

 +20       SET DIR("B")=$SELECT($GET(POERR)&($GET(PSODIR("# OF REFILLS"))):PSODIR("# OF REFILLS"),$GET(PSODIR("N# REF"))]"":PSODIR("N# REF"),$GET(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$GET(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)

 +21       SET DIR("?")="Enter a whole number.  The maximum is set by the DAYS SUPPLY field."

 +22       DO DIR

           IF PSODIR("DFLG")!PSODIR("FIELD")

               QUIT 

 +23       SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y

 +24       QUIT