PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;Jul 24, 2018@22:48
;;7.0;OUTPATIENT PHARMACY;**3,46,184,222,206,318,444,526,441**;DEC 1997;Build 208
;
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
I $G(PSOBBC1("FROM"))="REFILL" D ;PAPI 441 BEGIN EXCLUDE-PARKED FROM PROMPT FOR INTERNET AND PHONE REFILLS
. S DIR(0)="SA^W:WINDOW;M:MAIL",DIR("A")="MAIL/WINDOW: ",DIR("B")="MAIL"
E D
. S DIR(0)="52,11"
. S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW") ;PAPI 441 END
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")
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("?",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:$G(PSODIR("DFLG"))!$G(PSODIR("FIELD")) FILLDTX ;*526
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 ;
N PSOX
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
;
; Retrieving the Maximum Number of Refills allowed
S PSOX=$$MAXNUMRF^PSOUTIL(+$G(PSODRUG("IEN")),+$G(PSODIR("DAYS SUPPLY")),+$G(PSODIR("PATIENT STATUS")),.CLOZPAT)
;
I $D(CLOZPAT) D
.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"),1:PSOX)
S DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field."
D DIR Q:$G(PSODIR("DFLG"))!$G(PSODIR("FIELD")) ;*526
S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODIR3 4071 printed Apr 09, 2024@21:38:26 Page 2
PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;Jul 24, 2018@22:48
+1 ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222,206,318,444,526,441**;DEC 1997;Build 208
+2 ;
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 ;PAPI 441 BEGIN EXCLUDE-PARKED FROM PROMPT FOR INTERNET AND PHONE REFILLS
IF $GET(PSOBBC1("FROM"))="REFILL"
Begin DoDot:1
+3 SET DIR(0)="SA^W:WINDOW;M:MAIL"
SET DIR("A")="MAIL/WINDOW: "
SET DIR("B")="MAIL"
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET DIR(0)="52,11"
+6 ;PAPI 441 END
SET DIR("B")=$SELECT($GET(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")
End DoDot:1
+7 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO MWX
+8 IF $GET(Y(0))']""
SET PSODIR("DFLG")=1
GOTO MWX
+9 SET PSODIR("MAIL/WINDOW")=Y
SET PSORX("MAIL/WINDOW")=Y(0)
+10 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 SET DIR(0)="D^"_$SELECT($GET(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$SELECT($GET(DUZ("AG"))="I":":"_DT_":EX",1:"::EX")
+4 SET DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"
+5 SET DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE."
+6 SET DIR("?")="Both the month and date are required."
+7 ;*526
DO DIR
if $GET(PSODIR("DFLG"))!$GET(PSODIR("FIELD"))
GOTO FILLDTX
+8 SET PSODIR("FILL DATE")=Y
+9 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 NEW PSOX
+2 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
+3 SET VALMSG="No refills allowed on "_$SELECT($GET(PSODRUG("DEA"))["A":"this narcotic drug.",1:"this drug.")
+4 WRITE !,VALMSG,!
+5 if $DATA(PSODIR("FIELD"))
SET PSODIR("FIELD")=0
SET PSODIR("# OF REFILLS")=0
End DoDot:1
QUIT
+6 ;
+7 ; Retrieving the Maximum Number of Refills allowed
+8 SET PSOX=$$MAXNUMRF^PSOUTIL(+$GET(PSODRUG("IEN")),+$GET(PSODIR("DAYS SUPPLY")),+$GET(PSODIR("PATIENT STATUS")),.CLOZPAT)
+9 ;
+10 IF $DATA(CLOZPAT)
Begin DoDot:1
+11 SET (PSODIR("# OF REFILLS"),PSODIR("N# REF"))=PSOX
End DoDot:1
+12 SET DIR(0)="N^0:"_PSOX
SET DIR("A")="# OF REFILLS"
+13 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"),1:PSOX)
+14 SET DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field."
+15 ;*526
DO DIR
if $GET(PSODIR("DFLG"))!$GET(PSODIR("FIELD"))
QUIT
+16 SET (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
+17 QUIT
