PSODIR ;BHAM ISC/SAB - asks data for rx order entry ; 9/17/07 5:03pm
;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275**;DEC 1997;Build 8
;External reference PSDRUG( supported by DBIA 221
;External reference PS(50.7 supported by DBIA 2223
;External reference to VA(200 is supported by DBIA 10060
;----------------------------------------------------------------
;
PROV(PSODIR) ;
PROVEN ; Entry point for failed lookup
K DIC,X,Y S:$G(PSOFDR)&($G(OR0)) DIC("B")=$P(^VA(200,$P($G(OR0),"^",5),0),"^")
I $G(PSODIR("PROVIDER"))]"" S PSODIR("OLD VAL")=PSODIR("PROVIDER")
S DIC="^VA(200,",DIC(0)="QEAM",PSODIR("FIELD")=0
S DIC("W")="W "" "",$P(^(""PS""),""^"",9)"
S DIC("A")="PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
I $G(PSOTPBFG),$G(PSOFROM)="NEW" S DIC("S")=DIC("S")_",$P($G(^(""TPB"")),""^""),$P($G(^(""TPB"")),""^"",5)=0"
S:$G(PSORX("PROVIDER NAME"))]"" DIC("B")=PSORX("PROVIDER NAME")
D ^DIC K DIC
I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PROVX
I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G PROVX
I '$G(SPEED),Y=-1 G PROVEN
Q:$G(SPEED)&(Y=-1)
;PSO*7*211; ADD CHECK FOR DEA# AND VA#
I $P($G(PSODIR("CS")),"^",1)!($D(CLOZPAT)) I '$L($P($G(^VA(200,+Y,"PS")),U,2)),'$L($P($G(^VA(200,+Y,"PS")),U,3)) D G PROVEN
.W $C(7),!!,"Provider must have a DEA# or VA#"_$S($D(CLOZPAT):" to write prescriptions for clozapine.",1:""),!
I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D G PROVEN
.W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG
;I '$G(SPEED),$P($G(^PSDRUG($S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:PSORENW("DRUG IEN")),"CLOZ1")),"^")="PSOCLO1",$P(^VA(200,+Y,"PS"),"^",2)'?2U7N D K Y,PSORX("PROVIDER NAME"),DIC("B") G PROVEN
;.W $C(7),!!,"Only providers with DEA numbers can write prescriptions for clozapine.",!
NODRUG S PSODIR("PROVIDER")=+Y
S (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P(Y,"^",2)
I $G(PSODIR("OLD VAL"))'=+Y K PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER")
I $G(PSODIR("OLD VAL"))'=$G(PSODIR("PROVIDER")),$P(Y,"^",2)="PROVIDER,OTHER"!($P(Y,"^",2)="PROVIDER,OUTSIDE") D GENERIC
I $P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7),$P(^("PS"),"^",8) D COSIGN
I $G(PSODIR("COSIGNING PROVIDER")),'$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7) K PSODIR("COSIGNING PROVIDER")
PROVX K X,Y
Q
;
GENERIC ;
K DIR,DIC,PSODIR("GENERIC PROVIDER")
S DIR(0)="52,30"
D DIR G:PSODIR("DFLG")!PSODIR("FIELD") GENERICX
S PSODIR("GENERIC PROVIDER")=Y
GENERICX K X,Y
Q
;
COSIGN ;
K DIC
I '$G(PSODIR("COSIGNING PROVIDER")),$P($G(RX3),"^",3) S PSODIR("COSIGNING PROVIDER")=$P(RX3,"^",3) G COSIGN1
I $P($G(RX3),"^",3),$P($G(RX3),"^",3)'=$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8) D
.W !!,"Previous Co-Signing Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^")
.S PSODIR("COSIGNING PROVIDER")=$S($P(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
COSIGN1 S DIC(0)="QEAM",DIC="^VA(200,",DIC("B")=$S($G(PSODIR("COSIGNING PROVIDER")):$P(^VA(200,PSODIR("COSIGNING PROVIDER"),0),"^"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
S DIC("W")="W "" "",$P(^(""PS""),""^"",9)",DIC("S")=DIC("S")_",'$P(^(""PS""),""^"",7)"
S DIC("A")="COSIGNING PROVIDER: " D ^DIC K DIC
I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G COSIGNX
S:+Y>0 PSODIR("COSIGNING PROVIDER")=+Y G:Y<0 COSIGN
COSIGNX K X,Y
Q
DOSE(PSODIR) ;add dosing info
D DOSE1^PSOORED5(.PSODIR)
EX K PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1
Q
INS(PSODIR) ;patient instructions
N DA K INS1,DD,DIR,DIRUT S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S DD=$G(DD)+1
I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD
;PSO*7*275 remove check for PSOINSFL just check for multi line sig
I $G(DD)>1 D G EX
.K ^TMP($J) S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D)
.S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG")
.S D=0 F S D=$O(^TMP($J,"SIG",D)) Q:'D S PSODIR("SIG",D)=^TMP($J,"SIG",D,0)
.D EN^PSOFSIG(.PSODIR,1) K DWLW,D,DWPK,^TMP($J)
I $G(PSOINSFL)=0 G INSD
I $G(PSOFDR),$G(ORD),$P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="" G INSD
I $G(PSODIR("INS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS")
INSD S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS")
D DIR G:$G(PSODIR("DFLG"))!(PSODIR("FIELD")) EX
I X'="",X'="@" S PSODIR("INS")=Y D SIG^PSOHELP G INSD:'$D(X)
I $G(INS1)]"" D EN^DDIOL($E(INS1,2,9999999)) S (PSODIR("SIG",1),PSODIR("SIG"))=$E(INS1,2,9999999)
I X="@" K PSODIR("INS"),PSODIR("SIG")
D EN^PSOFSIG(.PSODIR,1) I $O(SIG(0)) S SIGOK=1
G EX
Q
SINS(PSODIR) ;other lang. patient instructions
K SINS1,DIR
S DIR(0)="52,114.1" S:$G(PSODIR("SINS"))]"" DIR("B")=PSODIR("SINS")
I $G(PSODIR("SINS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1")
D DIR G:$G(PSODIR("DFLG")) EX
I X'="",X'="@" S PSODIR("SINS")=Y D SSIG^PSOHELP
I $G(SINS1)]"" D EN^DDIOL($E(SINS1,2,9999999)) S PSODIR("SINS")=$E(SINS1,2,9999999)
I X="@" K PSODIR("SINS")
G EX
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 S PSODIR("DFLG")=1 G DIRX
I X[U,$L(X)>1 D:'$G(PSOEDIT) 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(PSOREF1)=0 D JUMP^PSOREF1 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
PSODIR ;BHAM ISC/SAB - asks data for rx order entry ; 9/17/07 5:03pm
+1 ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275**;DEC 1997;Build 8
+2 ;External reference PSDRUG( supported by DBIA 221
+3 ;External reference PS(50.7 supported by DBIA 2223
+4 ;External reference to VA(200 is supported by DBIA 10060
+5 ;----------------------------------------------------------------
+6 ;
PROV(PSODIR) ;
PROVEN ; Entry point for failed lookup
+1 KILL DIC,X,Y
IF $GET(PSOFDR)&($GET(OR0))
SET DIC("B")=$PIECE(^VA(200,$PIECE($GET(OR0),"^",5),0),"^")
+2 IF $GET(PSODIR("PROVIDER"))]""
SET PSODIR("OLD VAL")=PSODIR("PROVIDER")
+3 SET DIC="^VA(200,"
SET DIC(0)="QEAM"
SET PSODIR("FIELD")=0
+4 SET DIC("W")="W "" "",$P(^(""PS""),""^"",9)"
+5 SET DIC("A")="PROVIDER: "
SET DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
+6 IF $GET(PSOTPBFG)
IF $GET(PSOFROM)="NEW"
SET DIC("S")=DIC("S")_",$P($G(^(""TPB"")),""^""),$P($G(^(""TPB"")),""^"",5)=0"
+7 IF $GET(PSORX("PROVIDER NAME"))]""
SET DIC("B")=PSORX("PROVIDER NAME")
+8 DO ^DIC
KILL DIC
+9 IF X[U
IF $LENGTH(X)>1
IF '$GET(PSOEDIT)
DO JUMP
GOTO PROVX
+10 IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSODIR("DFLG")=1
GOTO PROVX
+11 IF '$GET(SPEED)
IF Y=-1
GOTO PROVEN
+12 IF $GET(SPEED)&(Y=-1)
QUIT
+13 ;PSO*7*211; ADD CHECK FOR DEA# AND VA#
+14 IF $PIECE($GET(PSODIR("CS")),"^",1)!($DATA(CLOZPAT))
IF '$LENGTH($PIECE($GET(^VA(200,+Y,"PS")),U,2))
IF '$LENGTH($PIECE($GET(^VA(200,+Y,"PS")),U,3))
Begin DoDot:1
+15 WRITE $CHAR(7),!!,"Provider must have a DEA# or VA#"_$SELECT($DATA(CLOZPAT):" to write prescriptions for clozapine.",1:""),!
End DoDot:1
GOTO PROVEN
+16 IF $DATA(CLOZPAT)
IF '$DATA(^XUSEC("YSCL AUTHORIZED",+Y))
Begin DoDot:1
+17 WRITE $CHAR(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
End DoDot:1
GOTO PROVEN
+18 IF '$GET(PSODRUG("IEN"))
IF '$GET(PSORENW("DRUG IEN"))
GOTO NODRUG
+19 ;I '$G(SPEED),$P($G(^PSDRUG($S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:PSORENW("DRUG IEN")),"CLOZ1")),"^")="PSOCLO1",$P(^VA(200,+Y,"PS"),"^",2)'?2U7N D K Y,PSORX("PROVIDER NAME"),DIC("B") G PROVEN
+20 ;.W $C(7),!!,"Only providers with DEA numbers can write prescriptions for clozapine.",!
NODRUG SET PSODIR("PROVIDER")=+Y
+1 SET (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$PIECE(Y,"^",2)
+2 IF $GET(PSODIR("OLD VAL"))'=+Y
KILL PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER")
+3 IF $GET(PSODIR("OLD VAL"))'=$GET(PSODIR("PROVIDER"))
IF $PIECE(Y,"^",2)="PROVIDER,OTHER"!($PIECE(Y,"^",2)="PROVIDER,OUTSIDE")
DO GENERIC
+4 IF $PIECE(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7)
IF $PIECE(^("PS"),"^",8)
DO COSIGN
+5 IF $GET(PSODIR("COSIGNING PROVIDER"))
IF '$PIECE(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7)
KILL PSODIR("COSIGNING PROVIDER")
PROVX KILL X,Y
+1 QUIT
+2 ;
GENERIC ;
+1 KILL DIR,DIC,PSODIR("GENERIC PROVIDER")
+2 SET DIR(0)="52,30"
+3 DO DIR
IF PSODIR("DFLG")!PSODIR("FIELD")
GOTO GENERICX
+4 SET PSODIR("GENERIC PROVIDER")=Y
GENERICX KILL X,Y
+1 QUIT
+2 ;
COSIGN ;
+1 KILL DIC
+2 IF '$GET(PSODIR("COSIGNING PROVIDER"))
IF $PIECE($GET(RX3),"^",3)
SET PSODIR("COSIGNING PROVIDER")=$PIECE(RX3,"^",3)
GOTO COSIGN1
+3 IF $PIECE($GET(RX3),"^",3)
IF $PIECE($GET(RX3),"^",3)'=$PIECE(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8)
Begin DoDot:1
+4 WRITE !!,"Previous Co-Signing Provider: "_$PIECE(^VA(200,$PIECE(RX3,"^",3),0),"^")
+5 SET PSODIR("COSIGNING PROVIDER")=$SELECT($PIECE(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$PIECE(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
End DoDot:1
COSIGN1 SET DIC(0)="QEAM"
SET DIC="^VA(200,"
SET DIC("B")=$SELECT($GET(PSODIR("COSIGNING PROVIDER")):$PIECE(^VA(200,PSODIR("COSIGNING PROVIDER"),0),"^"),1:$PIECE(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
+1 SET DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
+2 SET DIC("W")="W "" "",$P(^(""PS""),""^"",9)"
SET DIC("S")=DIC("S")_",'$P(^(""PS""),""^"",7)"
+3 SET DIC("A")="COSIGNING PROVIDER: "
DO ^DIC
KILL DIC
+4 IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSODIR("DFLG")=1
GOTO COSIGNX
+5 IF +Y>0
SET PSODIR("COSIGNING PROVIDER")=+Y
IF Y<0
GOTO COSIGN
COSIGNX KILL X,Y
+1 QUIT
DOSE(PSODIR) ;add dosing info
+1 DO DOSE1^PSOORED5(.PSODIR)
EX KILL PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1
+1 QUIT
INS(PSODIR) ;patient instructions
+1 NEW DA
KILL INS1,DD,DIR,DIRUT
SET D=0
FOR
SET D=$ORDER(PSODIR("SIG",D))
IF 'D
QUIT
SET DD=$GET(DD)+1
+2 IF $GET(DD)=1
SET PSODIR("INS")=$GET(PSODIR("SIG",1))
GOTO INSD
+3 ;PSO*7*275 remove check for PSOINSFL just check for multi line sig
+4 IF $GET(DD)>1
Begin DoDot:1
+5 KILL ^TMP($JOB)
SET D=0
FOR
SET D=$ORDER(PSODIR("SIG",D))
IF 'D
QUIT
SET ^TMP($JOB,"SIG",D,0)=PSODIR("SIG",D)
+6 SET DWPK=2
SET DWLW=80
SET DIC="^TMP($J,""SIG"","
DO EN^DIWE
KILL PSODIR("SIG")
+7 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"SIG",D))
IF 'D
QUIT
SET PSODIR("SIG",D)=^TMP($JOB,"SIG",D,0)
+8 DO EN^PSOFSIG(.PSODIR,1)
KILL DWLW,D,DWPK,^TMP($JOB)
End DoDot:1
GOTO EX
+9 IF $GET(PSOINSFL)=0
GOTO INSD
+10 IF $GET(PSOFDR)
IF $GET(ORD)
IF $PIECE($GET(^PS(52.41,+$GET(ORD),"EXT")),"^")'=""
GOTO INSD
+11 IF $GET(PSODIR("INS"))']""
IF $GET(^PS(50.7,PSODRUG("OI"),"INS"))]""
SET DIR("B")=^PS(50.7,PSODRUG("OI"),"INS")
INSD SET DIR(0)="52,114"
IF $GET(PSODIR("INS"))]""
SET DIR("B")=PSODIR("INS")
+1 DO DIR
IF $GET(PSODIR("DFLG"))!(PSODIR("FIELD"))
GOTO EX
+2 IF X'=""
IF X'="@"
SET PSODIR("INS")=Y
DO SIG^PSOHELP
IF '$DATA(X)
GOTO INSD
+3 IF $GET(INS1)]""
DO EN^DDIOL($EXTRACT(INS1,2,9999999))
SET (PSODIR("SIG",1),PSODIR("SIG"))=$EXTRACT(INS1,2,9999999)
+4 IF X="@"
KILL PSODIR("INS"),PSODIR("SIG")
+5 DO EN^PSOFSIG(.PSODIR,1)
IF $ORDER(SIG(0))
SET SIGOK=1
+6 GOTO EX
+7 QUIT
SINS(PSODIR) ;other lang. patient instructions
+1 KILL SINS1,DIR
+2 SET DIR(0)="52,114.1"
IF $GET(PSODIR("SINS"))]""
SET DIR("B")=PSODIR("SINS")
+3 IF $GET(PSODIR("SINS"))']""
IF $GET(^PS(50.7,PSODRUG("OI"),"INS1"))]""
SET DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1")
+4 DO DIR
IF $GET(PSODIR("DFLG"))
GOTO EX
+5 IF X'=""
IF X'="@"
SET PSODIR("SINS")=Y
DO SSIG^PSOHELP
+6 IF $GET(SINS1)]""
DO EN^DDIOL($EXTRACT(SINS1,2,9999999))
SET PSODIR("SINS")=$EXTRACT(SINS1,2,9999999)
+7 IF X="@"
KILL PSODIR("SINS")
+8 GOTO EX
+9 QUIT
+10 ;
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
SET PSODIR("DFLG")=1
GOTO DIRX
+5 IF X[U
IF $LENGTH(X)>1
IF '$GET(PSOEDIT)
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(PSOREF1)=0
DO JUMP^PSOREF1
GOTO JUMPX
+6 IF $GET(PSONEW3)=0
DO JUMP^PSONEW3
GOTO JUMPX
+7 IF $GET(PSORENW3)=0
DO JUMP^PSORENW3
GOTO JUMPX
JUMPX SET X="^"_X
+1 QUIT
