- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m
r613 r623 1 PSODIR ;BHAM ISC/SAB - asks data for rx order entry ; 9/17/07 5:03pm 2 ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275**;DEC 1997;Build 8 3 ;External reference PSDRUG( supported by DBIA 221 4 ;External reference PS(50.7 supported by DBIA 2223 5 ;External reference to VA(200 is supported by DBIA 10060 6 ;---------------------------------------------------------------- 7 ; 8 PROV(PSODIR) ; 9 PROVEN ; Entry point for failed lookup 10 K DIC,X,Y S:$G(PSOFDR)&($G(OR0)) DIC("B")=$P(^VA(200,$P($G(OR0),"^",5),0),"^") 11 I $G(PSODIR("PROVIDER"))]"" S PSODIR("OLD VAL")=PSODIR("PROVIDER") 12 S DIC="^VA(200,",DIC(0)="QEAM",PSODIR("FIELD")=0 13 S DIC("W")="W "" "",$P(^(""PS""),""^"",9)" 14 S DIC("A")="PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)" 15 I $G(PSOTPBFG),$G(PSOFROM)="NEW" S DIC("S")=DIC("S")_",$P($G(^(""TPB"")),""^""),$P($G(^(""TPB"")),""^"",5)=0" 16 S:$G(PSORX("PROVIDER NAME"))]"" DIC("B")=PSORX("PROVIDER NAME") 17 D ^DIC K DIC 18 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PROVX 19 I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G PROVX 20 I '$G(SPEED),Y=-1 G PROVEN 21 Q:$G(SPEED)&(Y=-1) 22 ;PSO*7*211; ADD CHECK FOR DEA# AND VA# 23 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 24 .W $C(7),!!,"Provider must have a DEA# or VA#"_$S($D(CLOZPAT):" to write prescriptions for clozapine.",1:""),! 25 I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D G PROVEN 26 .W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",! 27 I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG 28 ;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 29 ;.W $C(7),!!,"Only providers with DEA numbers can write prescriptions for clozapine.",! 30 NODRUG S PSODIR("PROVIDER")=+Y 31 S (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P(Y,"^",2) 32 I $G(PSODIR("OLD VAL"))'=+Y K PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER") 33 I $G(PSODIR("OLD VAL"))'=$G(PSODIR("PROVIDER")),$P(Y,"^",2)="PROVIDER,OTHER"!($P(Y,"^",2)="PROVIDER,OUTSIDE") D GENERIC 34 I $P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7),$P(^("PS"),"^",8) D COSIGN 35 I $G(PSODIR("COSIGNING PROVIDER")),'$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7) K PSODIR("COSIGNING PROVIDER") 36 PROVX K X,Y 37 Q 38 ; 39 GENERIC ; 40 K DIR,DIC,PSODIR("GENERIC PROVIDER") 41 S DIR(0)="52,30" 42 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") GENERICX 43 S PSODIR("GENERIC PROVIDER")=Y 44 GENERICX K X,Y 45 Q 46 ; 47 COSIGN ; 48 K DIC 49 I '$G(PSODIR("COSIGNING PROVIDER")),$P($G(RX3),"^",3) S PSODIR("COSIGNING PROVIDER")=$P(RX3,"^",3) G COSIGN1 50 I $P($G(RX3),"^",3),$P($G(RX3),"^",3)'=$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8) D 51 .W !!,"Previous Co-Signing Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^") 52 .S PSODIR("COSIGNING PROVIDER")=$S($P(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8)) 53 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)) 54 S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)" 55 S DIC("W")="W "" "",$P(^(""PS""),""^"",9)",DIC("S")=DIC("S")_",'$P(^(""PS""),""^"",7)" 56 S DIC("A")="COSIGNING PROVIDER: " D ^DIC K DIC 57 I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G COSIGNX 58 S:+Y>0 PSODIR("COSIGNING PROVIDER")=+Y G:Y<0 COSIGN 59 COSIGNX K X,Y 60 Q 61 DOSE(PSODIR) ;add dosing info 62 D DOSE1^PSOORED5(.PSODIR) 63 EX K PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1 64 Q 65 INS(PSODIR) ;patient instructions 66 N DA K INS1,DD,DIR,DIRUT S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S DD=$G(DD)+1 67 I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD 68 ;PSO*7*275 remove check for PSOINSFL just check for multi line sig 69 I $G(DD)>1 D G EX 70 .K ^TMP($J) S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D) 71 .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG") 72 .S D=0 F S D=$O(^TMP($J,"SIG",D)) Q:'D S PSODIR("SIG",D)=^TMP($J,"SIG",D,0) 73 .D EN^PSOFSIG(.PSODIR,1) K DWLW,D,DWPK,^TMP($J) 74 I $G(PSOINSFL)=0 G INSD 75 I $G(PSOFDR),$G(ORD),$P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="" G INSD 76 I $G(PSODIR("INS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS") 77 INSD S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS") 78 D DIR G:$G(PSODIR("DFLG"))!(PSODIR("FIELD")) EX 79 I X'="",X'="@" S PSODIR("INS")=Y D SIG^PSOHELP G INSD:'$D(X) 80 I $G(INS1)]"" D EN^DDIOL($E(INS1,2,9999999)) S (PSODIR("SIG",1),PSODIR("SIG"))=$E(INS1,2,9999999) 81 I X="@" K PSODIR("INS"),PSODIR("SIG") 82 D EN^PSOFSIG(.PSODIR,1) I $O(SIG(0)) S SIGOK=1 83 G EX 84 Q 85 SINS(PSODIR) ;other lang. patient instructions 86 K SINS1,DIR 87 S DIR(0)="52,114.1" S:$G(PSODIR("SINS"))]"" DIR("B")=PSODIR("SINS") 88 I $G(PSODIR("SINS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1") 89 D DIR G:$G(PSODIR("DFLG")) EX 90 I X'="",X'="@" S PSODIR("SINS")=Y D SSIG^PSOHELP 91 I $G(SINS1)]"" D EN^DDIOL($E(SINS1,2,9999999)) S PSODIR("SINS")=$E(SINS1,2,9999999) 92 I X="@" K PSODIR("SINS") 93 G EX 94 Q 95 ; 96 DIR ; 97 S PSODIR("FIELD")=0 98 G:$G(DIR(0))']"" DIRX 99 D ^DIR K DIR,DIE,DIC,DA 100 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX 101 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP 102 DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX 103 Q 104 ; 105 JUMP ; 106 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q 107 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC 108 I Y=-1 S PSODIR("FIELD")=$G(PSODIR("FLD")) G JUMPX 109 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX 110 I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX 111 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX 112 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX 113 JUMPX S X="^"_X 114 Q 1 PSODIR ;BHAM ISC/SAB - asks data for rx order entry ;02/12/93 8:49 2 ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264**;DEC 1997;Build 19 3 ;External reference PSDRUG( supported by DBIA 221 4 ;External reference PS(50.7 supported by DBIA 2223 5 ;External reference to VA(200 is supported by DBIA 10060 6 ;---------------------------------------------------------------- 7 ; 8 PROV(PSODIR) ; 9 PROVEN ; Entry point for failed lookup 10 K DIC,X,Y S:$G(PSOFDR)&($G(OR0)) DIC("B")=$P(^VA(200,$P($G(OR0),"^",5),0),"^") 11 I $G(PSODIR("PROVIDER"))]"" S PSODIR("OLD VAL")=PSODIR("PROVIDER") 12 S DIC="^VA(200,",DIC(0)="QEAM",PSODIR("FIELD")=0 13 S DIC("W")="W "" "",$P(^(""PS""),""^"",9)" 14 S DIC("A")="PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)" 15 I $G(PSOTPBFG),$G(PSOFROM)="NEW" S DIC("S")=DIC("S")_",$P($G(^(""TPB"")),""^""),$P($G(^(""TPB"")),""^"",5)=0" 16 S:$G(PSORX("PROVIDER NAME"))]"" DIC("B")=PSORX("PROVIDER NAME") 17 D ^DIC K DIC 18 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PROVX 19 I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G PROVX 20 I '$G(SPEED),Y=-1 G PROVEN 21 Q:$G(SPEED)&(Y=-1) 22 ;PSO*7*211; ADD CHECK FOR DEA# AND VA# 23 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 24 .W $C(7),!!,"Provider must have a DEA# or VA#"_$S($D(CLOZPAT):" to write prescriptions for clozapine.",1:""),! 25 I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D G PROVEN 26 .W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",! 27 I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG 28 ;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 29 ;.W $C(7),!!,"Only providers with DEA numbers can write prescriptions for clozapine.",! 30 NODRUG S PSODIR("PROVIDER")=+Y 31 S (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P(Y,"^",2) 32 I $G(PSODIR("OLD VAL"))'=+Y K PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER") 33 I $G(PSODIR("OLD VAL"))'=$G(PSODIR("PROVIDER")),$P(Y,"^",2)="PROVIDER,OTHER"!($P(Y,"^",2)="PROVIDER,OUTSIDE") D GENERIC 34 I $P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7),$P(^("PS"),"^",8) D COSIGN 35 I $G(PSODIR("COSIGNING PROVIDER")),'$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7) K PSODIR("COSIGNING PROVIDER") 36 PROVX K X,Y 37 Q 38 ; 39 GENERIC ; 40 K DIR,DIC,PSODIR("GENERIC PROVIDER") 41 S DIR(0)="52,30" 42 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") GENERICX 43 S PSODIR("GENERIC PROVIDER")=Y 44 GENERICX K X,Y 45 Q 46 ; 47 COSIGN ; 48 K DIC 49 I '$G(PSODIR("COSIGNING PROVIDER")),$P($G(RX3),"^",3) S PSODIR("COSIGNING PROVIDER")=$P(RX3,"^",3) G COSIGN1 50 I $P($G(RX3),"^",3),$P($G(RX3),"^",3)'=$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8) D 51 .W !!,"Previous Co-Signing Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^") 52 .S PSODIR("COSIGNING PROVIDER")=$S($P(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8)) 53 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)) 54 S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)" 55 S DIC("W")="W "" "",$P(^(""PS""),""^"",9)",DIC("S")=DIC("S")_",'$P(^(""PS""),""^"",7)" 56 S DIC("A")="COSIGNING PROVIDER: " D ^DIC K DIC 57 I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G COSIGNX 58 S:+Y>0 PSODIR("COSIGNING PROVIDER")=+Y G:Y<0 COSIGN 59 COSIGNX K X,Y 60 Q 61 DOSE(PSODIR) ;add dosing info 62 D DOSE1^PSOORED5(.PSODIR) 63 EX K PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1 64 Q 65 INS(PSODIR) ;patient instructions 66 N DA K INS1,DD,DIR,DIRUT S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S DD=$G(DD)+1 67 I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD 68 I ($G(PSOINSFL)=1&($G(DD)>1))!($G(PSOFDR)&($G(ORD))&($P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="")&($G(DD)>1)) D G EX 69 .K ^TMP($J) S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D) 70 .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG") 71 .S D=0 F S D=$O(^TMP($J,"SIG",D)) Q:'D S PSODIR("SIG",D)=^TMP($J,"SIG",D,0) 72 .D EN^PSOFSIG(.PSODIR,1) K DWLW,D,DWPK,^TMP($J) 73 I $G(PSOINSFL)=0 G INSD 74 I $G(PSOFDR),$G(ORD),$P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="" G INSD 75 I $G(PSODIR("INS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS") 76 INSD S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS") 77 D DIR G:$G(PSODIR("DFLG"))!(PSODIR("FIELD")) EX 78 I X'="",X'="@" S PSODIR("INS")=Y D SIG^PSOHELP G INSD:'$D(X) 79 I $G(INS1)]"" D EN^DDIOL($E(INS1,2,9999999)) S (PSODIR("SIG",1),PSODIR("SIG"))=$E(INS1,2,9999999) 80 I X="@" K PSODIR("INS"),PSODIR("SIG") 81 D EN^PSOFSIG(.PSODIR,1) I $O(SIG(0)) S SIGOK=1 82 G EX 83 Q 84 SINS(PSODIR) ;other lang. patient instructions 85 K SINS1,DIR 86 S DIR(0)="52,114.1" S:$G(PSODIR("SINS"))]"" DIR("B")=PSODIR("SINS") 87 I $G(PSODIR("SINS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1") 88 D DIR G:$G(PSODIR("DFLG")) EX 89 I X'="",X'="@" S PSODIR("SINS")=Y D SSIG^PSOHELP 90 I $G(SINS1)]"" D EN^DDIOL($E(SINS1,2,9999999)) S PSODIR("SINS")=$E(SINS1,2,9999999) 91 I X="@" K PSODIR("SINS") 92 G EX 93 Q 94 ; 95 DIR ; 96 S PSODIR("FIELD")=0 97 G:$G(DIR(0))']"" DIRX 98 D ^DIR K DIR,DIE,DIC,DA 99 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX 100 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP 101 DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX 102 Q 103 ; 104 JUMP ; 105 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q 106 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC 107 I Y=-1 S PSODIR("FIELD")=$G(PSODIR("FLD")) G JUMPX 108 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX 109 I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX 110 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX 111 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX 112 JUMPX S X="^"_X 113 Q
Note:
See TracChangeset
for help on using the changeset viewer.
