PSODIR2 ;IHS/DSD/JCM - rx order entry contd ;Apr 08, 2020@14:45:14
;;7.0;OUTPATIENT PHARMACY;**3,9,26,46,124,146,139,152,166,504,526,457,574,441**;DEC 1997;Build 208
;External reference to ^DD(52 supported by DBIA 999
;External reference to ^VA(200 supported by DBIA 10060
;External reference to ^%DTC supported by DBIA 10000
;External reference to ^DIC supported by DBIA 10006
;External reference to ^DIR supported by DBIA 10026
;
;---------------------------------------------------------------------
;
EXP(PSODIR) ;
K DIR,DIC
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"
S 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
;
CLINIC(PSODIR) ;
K DIR,DIC S PSODIR("FIELD")=0
S DIR(0)="52,5" S:$G(PSORX("CLINIC"))]"" DIR("B")=PSORX("CLINIC"),DIR("A")="CLINIC"
D ^DIR G:$G(PSODIR("DFLG"))!$G(PSODIR("FIELD")) CLINICX ;526
I +Y>0 S PSODIR("CLINIC")=+Y,PSORX("CLINIC")=$P(Y,"^",2)
E S (PSORX("CLINIC"),PSODIR("CLINIC"))=""
CLINICX K X,Y,PSOX,DIC
Q
;
MW(PSODIR) ;
K DIR,DIC,PSOIEN52,PSOIEN50,PSODEAHD,PSOCLOZ ;441 PAPI
I '$D(PSORX("MAIL/WINDOW")),$D(PSODIR("MAIL/WINDOW")) S PSORX("MAIL/WINDOW")=$S($G(PSODIR("MAIL/WINDOW"))="M":"MAIL",$G(PSODIR("MAIL/WINDOW"))="P":"PARK",1:"WINDOW")
S DIR(0)="52,11" S:$G(POERR)&'$D(PSORX("MAIL/WINDOW")) PSORX("MAIL/WINDOW")=$S($P($G(OR0),"^",17)="M":"MAIL",$P($G(OR0),"^",17)="P":"PARK",1:"WINDOW") ;441 PAPI
S DIR("B")=$S(($G(PSODRUG("DEA"))["D")!($G(PSODRUG("NAME"))["CLOZAPINE")&($G(PSORX("MAIL/WINDOW"))="PARK"):"WINDOW",$G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),$G(PSOTPBFG)&($G(PSOFROM)="NEW"):"MAIL",1:"WINDOW")
; DO NOT ALLOW "PARK" CHOICE FOR REFILLS OR RENEWS FOR DEA NOT-PARKABLE MEDICATIONS
I $G(SPEED),$D(PSOLST) D
. Q:'$G(LST)
. S PSOIEN52=$P(PSOLST(+LST),U,2)
. Q:PSOIEN52=""
. S PSOIEN50=$$GET1^DIQ(52,PSOIEN52_",",6,"I")
. Q:PSOIEN50=""
. S PSODEAHD=$$GET1^DIQ(50,PSOIEN50_",",3),PSOCLOZ=$$GET1^DIQ(50,PSOIEN50_",",.01) ;441 PAPI set PSOCLOZ for Clozapine check
I $E($G(DIR("B")))="P" I (($G(PSODEAHD)["D")!($G(PSODRUG("DEA"))["D")) S DIR("B")="WINDOW" G MW0 ;IF NOT PARKABLE REMOVE PARK OPTION FROM PROMPT
I $G(PSOFROM)="REFILL"!($G(PSODRUG("DEA"))["D")!($G(PSODEAHD)["D")!($G(PSODRUG("NAME"))["CLOZAPINE") S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW" G MW0
I $G(PSOCLOZ)["CLOZAPINE" S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW" G MW0 ;for SPEED refills
N RESULTS,PSOPARKX
S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
I $G(PSOPARKX(0))="YES",$G(PSODIR("FLD"))'=2 S DIR(0)="S^M:MAIL;W:WINDOW;P:PARK",DIR("A")="MAIL/WINDOW/PARK"
I $G(PSOPARKX(0))'="YES"!($G(PSODIR("FLD"))=2) S DIR(0)="S^M:MAIL;W:WINDOW",DIR("A")="MAIL/WINDOW"
MW0 D DIR G:$G(PSODIR("DFLG"))!$G(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:$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
;
RMK(PSODIR) ;
RMKEN K DIR,DIC
S DIR(0)="52,12"
S:$G(PSODIR("REMARKS"))]"" DIR("B")=PSODIR("REMARKS")
D DIR G:$G(PSODIR("DFLG")) RMKX ;*526
I X[U W !,"Cannot jump to another field ..",! G RMKEN
S:$L(X)>0 PSODIR("REMARKS")=X
S:X="@" PSODIR("REMARKS")=""
RMKX K X,Y
Q
;
ISSDT(PSODIR) ;
K DIR,DIC
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")
I DIR("B") S Y=DIR("B") X ^DD("DD") S DIR("B")=Y
S DIR(0)="52,1"
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") ISSDTX
S (PSODIR("ISSUE DATE"),PSOID)=Y
X ^DD("DD") S (PSORX("ISSUE DATE"),PSODIR("ISSUE DATE"))=Y
ISSDTX K X,Y
Q
;
FILLDT(PSODIR) ;
K DIR,DIC
S:'$G(PSONEW("DAYS SUPPLY")) PSONEW("DAYS SUPPLY")=30,PSONEW("# OF REFILLS")=1
S DIR("A")="FILL DATE",DIR("B")=$S($G(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")
S X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
S X1=$S($G(PSOID):PSOID,1:DT)
S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSODIR("CS")):184,1:366)
I X2<30 D
. N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
. S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
; START NCC REMEDIATION >> 457*RJS
; PSO*7*574 ADJUST EXPIRE DATE FOR 4 DAY SUPPLY, fix defect 969788?
I $G(CLOZFLG),PSONEW("DAYS SUPPLY")<5 S X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
; END NCC REMEDIATION << 457*RJS
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
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")
I $G(PSODIR("MAIL/WINDOW"))="P" D FILLDTPK G FILLDTX ;441 PAPI
S Y=PSOFDMX X ^DD("DD")
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 or AFTER the Expiration Date "
S DIR("?")=Y_". 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,PSOFDMX
Q
;
CLERK(PSODIR) ;
I $G(DUZ("AG"))'="I" D G CLERKX
.S PSODIR("CLERK CODE")=$S($G(PSOFDR):$P(OR0,"^",4),1:DUZ),PSORX("CLERK CODE")=$P($G(^VA(200,PSODIR("CLERK CODE"),0)),"^")
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 X="^^" S (PSODIR("QFLG"),PSODIR("DFLG"))=1 G DIRX
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 S:$G(SPEED) PSODIR("QFLG")=1 G DIRX
I $D(DUOUT)!($D(DTOUT)),$G(SPEED) 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")=$G(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
;Reset refills when drug changed to a controlled sub
RFRSET ;
N RFN,RFNC
S (RFN,RFNC)=0
F S RFN=$O(^PSRX(+$G(PSODIR("IRXN")),1,RFN)) Q:'RFN S RFNC=RFNC+1
I $D(PSODIR("FIELD")) S PSODIR("FIELD")=0
S PSODIR("# OF REFILLS")=RFNC
S VALMSG="The drug has been changed and no longer allows refills."
W !,VALMSG,!
Q
;
FILLDTPK ; If parked, don't prompt for fill date, but save it to be set to next possible fill date when filed 441 PAPI
D NOW^%DTC
S Y=%
D DD^%DT
S PSODIR("FILL DATE")=X
S PSORX("FILL DATE")=$P(Y,"@")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODIR2 7392 printed Sep 23, 2025@20:03:19 Page 2
PSODIR2 ;IHS/DSD/JCM - rx order entry contd ;Apr 08, 2020@14:45:14
+1 ;;7.0;OUTPATIENT PHARMACY;**3,9,26,46,124,146,139,152,166,504,526,457,574,441**;DEC 1997;Build 208
+2 ;External reference to ^DD(52 supported by DBIA 999
+3 ;External reference to ^VA(200 supported by DBIA 10060
+4 ;External reference to ^%DTC supported by DBIA 10000
+5 ;External reference to ^DIC supported by DBIA 10006
+6 ;External reference to ^DIR supported by DBIA 10026
+7 ;
+8 ;---------------------------------------------------------------------
+9 ;
EXP(PSODIR) ;
+1 KILL DIR,DIC
+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"
+5 SET DIR("?")="Both the month and date are required."
+6 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO EXPX
+7 SET PSODIR("EXPIRATION DATE")=Y
EXPX KILL X,Y
+1 QUIT
+2 ;
CLINIC(PSODIR) ;
+1 KILL DIR,DIC
SET PSODIR("FIELD")=0
+2 SET DIR(0)="52,5"
if $GET(PSORX("CLINIC"))]""
SET DIR("B")=PSORX("CLINIC")
SET DIR("A")="CLINIC"
+3 ;526
DO ^DIR
if $GET(PSODIR("DFLG"))!$GET(PSODIR("FIELD"))
GOTO CLINICX
+4 IF +Y>0
SET PSODIR("CLINIC")=+Y
SET PSORX("CLINIC")=$PIECE(Y,"^",2)
+5 IF '$TEST
SET (PSORX("CLINIC"),PSODIR("CLINIC"))=""
CLINICX KILL X,Y,PSOX,DIC
+1 QUIT
+2 ;
MW(PSODIR) ;
+1 ;441 PAPI
KILL DIR,DIC,PSOIEN52,PSOIEN50,PSODEAHD,PSOCLOZ
+2 IF '$DATA(PSORX("MAIL/WINDOW"))
IF $DATA(PSODIR("MAIL/WINDOW"))
SET PSORX("MAIL/WINDOW")=$SELECT($GET(PSODIR("MAIL/WINDOW"))="M":"MAIL",$GET(PSODIR("MAIL/WINDOW"))="P":"PARK",1:"WINDOW")
+3 ;441 PAPI
SET DIR(0)="52,11"
if $GET(POERR)&'$DATA(PSORX("MAIL/WINDOW"))
SET PSORX("MAIL/WINDOW")=$SELECT($PIECE($GET(OR0),"^",17)="M":"MAIL",$PIECE($GET(OR0),"^",17)="P":"PARK",1:"WINDOW")
+4 SET DIR("B")=$SELECT(($GET(PSODRUG("DEA"))["D")!($GET(PSODRUG("NAME"))["CLOZAPINE")&($GET(PSORX("MAIL/WINDOW"))="PARK"):"WINDOW",$GET(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),$GET(PSOTPBFG)&($GET(PSOFROM)="NEW"):"MAIL",1:"WINDOW")
+5 ; DO NOT ALLOW "PARK" CHOICE FOR REFILLS OR RENEWS FOR DEA NOT-PARKABLE MEDICATIONS
+6 IF $GET(SPEED)
IF $DATA(PSOLST)
Begin DoDot:1
+7 if '$GET(LST)
QUIT
+8 SET PSOIEN52=$PIECE(PSOLST(+LST),U,2)
+9 if PSOIEN52=""
QUIT
+10 SET PSOIEN50=$$GET1^DIQ(52,PSOIEN52_",",6,"I")
+11 if PSOIEN50=""
QUIT
+12 ;441 PAPI set PSOCLOZ for Clozapine check
SET PSODEAHD=$$GET1^DIQ(50,PSOIEN50_",",3)
SET PSOCLOZ=$$GET1^DIQ(50,PSOIEN50_",",.01)
End DoDot:1
+13 ;IF NOT PARKABLE REMOVE PARK OPTION FROM PROMPT
IF $EXTRACT($GET(DIR("B")))="P"
IF (($GET(PSODEAHD)["D")!($GET(PSODRUG("DEA"))["D"))
SET DIR("B")="WINDOW"
GOTO MW0
+14 IF $GET(PSOFROM)="REFILL"!($GET(PSODRUG("DEA"))["D")!($GET(PSODEAHD)["D")!($GET(PSODRUG("NAME"))["CLOZAPINE")
SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("A")="MAIL/WINDOW"
GOTO MW0
+15 ;for SPEED refills
IF $GET(PSOCLOZ)["CLOZAPINE"
SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("A")="MAIL/WINDOW"
GOTO MW0
+16 NEW RESULTS,PSOPARKX
+17 SET RESULTS="PSOPARKX"
DO GETPARK^PSORPC01()
+18 IF $GET(PSOPARKX(0))="YES"
IF $GET(PSODIR("FLD"))'=2
SET DIR(0)="S^M:MAIL;W:WINDOW;P:PARK"
SET DIR("A")="MAIL/WINDOW/PARK"
+19 IF $GET(PSOPARKX(0))'="YES"!($GET(PSODIR("FLD"))=2)
SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("A")="MAIL/WINDOW"
MW0 DO DIR
if $GET(PSODIR("DFLG"))!$GET(PSODIR("FIELD"))
GOTO MWX
+1 IF $GET(Y(0))']""
SET PSODIR("DFLG")=1
GOTO MWX
+2 SET PSODIR("MAIL/WINDOW")=Y
SET PSORX("MAIL/WINDOW")=Y(0)
+3 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 $GET(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 ;
RMK(PSODIR) ;
RMKEN KILL DIR,DIC
+1 SET DIR(0)="52,12"
+2 if $GET(PSODIR("REMARKS"))]""
SET DIR("B")=PSODIR("REMARKS")
+3 ;*526
DO DIR
if $GET(PSODIR("DFLG"))
GOTO RMKX
+4 IF X[U
WRITE !,"Cannot jump to another field ..",!
GOTO RMKEN
+5 if $LENGTH(X)>0
SET PSODIR("REMARKS")=X
+6 if X="@"
SET PSODIR("REMARKS")=""
RMKX KILL X,Y
+1 QUIT
+2 ;
ISSDT(PSODIR) ;
+1 KILL DIR,DIC
+2 SET DIR("A")="ISSUE DATE"
SET DIR("B")=$SELECT($GET(POERR)&($GET(PSORX("ISSUE DATE"))']"")&($GET(PSODIR("ISSUE DATE"))]""):PSODIR("ISSUE DATE"),$GET(PSORX("ISSUE DATE"))]"":PSORX("ISSUE DATE"),1:"TODAY")
+3 IF DIR("B")
SET Y=DIR("B")
XECUTE ^DD("DD")
SET DIR("B")=Y
+4 SET DIR(0)="52,1"
+5 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO ISSDTX
+6 SET (PSODIR("ISSUE DATE"),PSOID)=Y
+7 XECUTE ^DD("DD")
SET (PSORX("ISSUE DATE"),PSODIR("ISSUE DATE"))=Y
ISSDTX KILL X,Y
+1 QUIT
+2 ;
FILLDT(PSODIR) ;
+1 KILL DIR,DIC
+2 if '$GET(PSONEW("DAYS SUPPLY"))
SET PSONEW("DAYS SUPPLY")=30
SET PSONEW("# OF REFILLS")=1
+3 SET DIR("A")="FILL DATE"
SET DIR("B")=$SELECT($GET(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")
+4 SET X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
+5 SET X1=$SELECT($GET(PSOID):PSOID,1:DT)
+6 SET X2=$SELECT(PSONEW("DAYS SUPPLY")=X2:X2,+$GET(PSODIR("CS")):184,1:366)
+7 IF X2<30
Begin DoDot:1
+8 NEW %
SET %=$PIECE($GET(PSORX("PATIENT STATUS")),"^")
SET X2=30
+9 if %?.N
SET %=$PIECE($GET(^PS(53,+%,0)),"^")
IF %["AUTH ABS"
SET X2=5
End DoDot:1
+10 ; START NCC REMEDIATION >> 457*RJS
+11 ; PSO*7*574 ADJUST EXPIRE DATE FOR 4 DAY SUPPLY, fix defect 969788?
+12 IF $GET(CLOZFLG)
IF PSONEW("DAYS SUPPLY")<5
SET X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
+13 ; END NCC REMEDIATION << 457*RJS
+14 DO C^%DTC
SET PSOFDMX=$PIECE(X,".")
IF DT>X
SET Y=$SELECT($GET(PSOID):PSOID,1:PSORX("ISSUE DATE"))
XECUTE ^DD("DD")
SET DIR("B")=Y
+15 SET DIR(0)="D^"_$SELECT($GET(PSOID):PSOID,+$GET(PSODIR("ISSUE DATE")):PSODIR("ISSUE DATE"),1:DT)_$SELECT($GET(DUZ("AG"))="I":":"_DT_":EX",1:":"_PSOFDMX_":EX")
+16 ;441 PAPI
IF $GET(PSODIR("MAIL/WINDOW"))="P"
DO FILLDTPK
GOTO FILLDTX
+17 SET Y=PSOFDMX
XECUTE ^DD("DD")
+18 SET DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"
+19 SET DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE or AFTER the Expiration Date "
+20 SET DIR("?")=Y_". Both the month and date are required."
+21 ;*526
DO DIR
if $GET(PSODIR("DFLG"))!$GET(PSODIR("FIELD"))
GOTO FILLDTX
+22 SET PSODIR("FILL DATE")=Y
+23 XECUTE ^DD("DD")
SET PSORX("FILL DATE")=Y
FILLDTX KILL X,Y,PSOFDMX
+1 QUIT
+2 ;
CLERK(PSODIR) ;
+1 IF $GET(DUZ("AG"))'="I"
Begin DoDot:1
+2 SET PSODIR("CLERK CODE")=$SELECT($GET(PSOFDR):$PIECE(OR0,"^",4),1:DUZ)
SET PSORX("CLERK CODE")=$PIECE($GET(^VA(200,PSODIR("CLERK CODE"),0)),"^")
End DoDot:1
GOTO CLERKX
+3 KILL DIR,DIC
+4 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"
+5 DO DIR
if PSODIR("DFLG")!PSODIR("FIELD")
GOTO CLERKX
+6 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
IF X="^^"
SET (PSODIR("QFLG"),PSODIR("DFLG"))=1
GOTO DIRX
+4 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
IF $LENGTH($GET(X))'>1!(Y="")
SET PSODIR("DFLG")=1
if $GET(SPEED)
SET PSODIR("QFLG")=1
GOTO DIRX
+5 IF $DATA(DUOUT)!($DATA(DTOUT))
IF $GET(SPEED)
SET PSODIR("DFLG")=1
GOTO DIRX
+6 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")=$GET(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 ;Reset refills when drug changed to a controlled sub
RFRSET ;
+1 NEW RFN,RFNC
+2 SET (RFN,RFNC)=0
+3 FOR
SET RFN=$ORDER(^PSRX(+$GET(PSODIR("IRXN")),1,RFN))
if 'RFN
QUIT
SET RFNC=RFNC+1
+4 IF $DATA(PSODIR("FIELD"))
SET PSODIR("FIELD")=0
+5 SET PSODIR("# OF REFILLS")=RFNC
+6 SET VALMSG="The drug has been changed and no longer allows refills."
+7 WRITE !,VALMSG,!
+8 QUIT
+9 ;
FILLDTPK ; If parked, don't prompt for fill date, but save it to be set to next possible fill date when filed 441 PAPI
+1 DO NOW^%DTC
+2 SET Y=%
+3 DO DD^%DT
+4 SET PSODIR("FILL DATE")=X
+5 SET PSORX("FILL DATE")=$PIECE(Y,"@")
+6 QUIT
