- 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
