PSODIR ;BHAM ISC/SAB - asks data for rx order entry ;Oct 20, 2022@17:03
;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275,391,372,416,422,504,457,572,587,441,682,545**;DEC 1997;Build 270
;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
; Reference to ^XTV(8991.9) in ICR #7002
; Reference to ^VA(200.5321) in ICR #7000
;----------------------------------------------------------------
;
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 '$D(PSODIR("CS")),$D(PSODRUG("DEA")) D
.N DEA S PSODIR("CS")=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1
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($G(^(""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"
;p682 change condition for setting DIC("B"); do not overwrite
;S:$G(PSORX("PROVIDER NAME"))]"" DIC("B")=PSORX("PROVIDER NAME")
S DIC("B")=$S($G(DIC("B"))]"":DIC("B"),1:$G(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)
L +^VA(200,+Y):1 I '$T D G PROVEN ;572
. N PSOED S PSOED=$P($G(^VA(200,+Y,1)),"^",8)
. I PSOED W $C(7),!!,"Provider is being edited by "_$P($G(^VA(200,PSOED,0)),"^") Q ;587
. W $C(7),!!,"Provider is being edited by an unknown user or has been deleted"
L -^VA(200,+Y) ;572
;PSO*7*211; ADD CHECK FOR DEA# AND VA#
;*545; DEA/VA selection
I $$DETOX^PSSOPKI($G(PSODRUG("IEN"))) N DETX S DETX="" D G:'$L(DETX) PROVEN
. S DETX=$$DETOX^XUSER(+Y) I '$L(DETX) W $C(7),!!,"Provider must have a DETOX# to order this drug.",! Q
. S PSORX("DETX")=DETX
I $P($G(PSODIR("CS")),"^",1)!($D(CLOZPAT)) N NDEA D I $L($P($G(NDEA),"^"))<3 G PROVEN
. N SDEA S SDEA=$$DRGSCH()
. N PSOPROVD S PSOPROVD=+Y S NDEA=$$SLDEA(PSOPROVD,.PSORX) Q
. I NDEA=2 W $C(7),!!,"Provider not authorized to write Federal Schedule "_SDEA_" prescriptions." D Q
. . W !,"Please contact the provider.",!
. W $C(7),!!,"Provider must have a valid DEA# or VA# to write prescriptions for this drug.",!
. Q
;PSO*7.0*391; Added check for DETOX#
I $$DETOX^PSSOPKI($G(PSODRUG("IEN"))),$$DETOX^XUSER(+Y)="" W $C(7),!!,"Provider must have a DETOX# to order this drug.",! G PROVEN
I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D G PROVEN
.W $C(7),!!,$$CLKEYWRN^PSOCLUTL,! ; PSO*7*457
I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG
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
;
DRGSCH() ; determine the drug schedule
N ND3,SCH
S SCH="",ND3=$P($G(^PSDRUG(PSODRUG("IEN"),"ND")),"^",3) S:+ND3 SCH=$$GET1^DIQ(50.68,ND3,19,"I")
I +SCH>0!($G(PSODRUG("DEA"))="") Q SCH
I "^4^5^"[+PSODRUG("DEA") Q +PSODRUG("DEA")
Q $S($G(PSODRUG("DEA"))["A":+PSODRUG("DEA"),1:+PSODRUG("DEA")_"n")
;
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
N PSODOSNW S PSODOSNW=1
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:'$P($G(^PS(55,PSODFN,"LAN")),"^") INDICAT^PSODIR(.PSODIR)
.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"))]"",'$D(PSODIR("FLD",114)) S (DIR("B"),PSOOEINS)=^PS(50.7,PSODRUG("OI"),"INS") G INSD ;*422
S (DIR("B"),PSOOEINS)=$G(PSODIR("SIG",1)) ;*422
INSD S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS")
K PSODIR("DFLG")
D DIR
I $G(PSODIR("DFLG")) S (PSODIR("INS"),PSODIR("SIG"),PSODIR("SIG",1))=$G(PSOOEINS),PSODIR("SINS")=$G(PSOOSINS) D EN^PSOFSIG(.PSODIR,0)
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="@" S PSODELINS=1 D DELINS^PSOHELP3 I $G(PSODELINS) S (PSODIR("FLD",114),PSODIR("FLD",114.1))="" K PSODIR("INS"),PSODIR("SIG"),PSODIR("SINS") ;*422
;*441 - indication
I '$P($G(^PS(55,PSODFN,"LAN")),"^") D INDICAT^PSODIR(.PSODIR) K DIRUT,DTOUT,DUOUT,DIROUT
I '$G(PSOEDIT),$G(PSODIR("DFLG")) G EX
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"))]"",'$D(PSODIR("FLD",114)),$G(PSOOEINS)]"" S (DIR("B"),PSOOSINS)=^PS(50.7,PSODRUG("OI"),"INS1")
D DIR I $G(PSODIR("DFLG")) S (PSODIR("INS"),PSODIR("SIG"),PSODIR("SIG",1))=$G(PSOOEINS),PSODIR("SINS")=$G(PSOOSINS) D EN^PSOFSIG(.PSODIR,0) G 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="@" S PSODELINS=2 D DELINS^PSOHELP3 I $G(PSODELINS) S (PSODIR("FLD",114),PSODIR("FLD",114.1))="" K PSODIR("INS"),PSODIR("SIG"),PSODIR("SINS") D EN^PSOFSIG(.PSODIR,1) ;*422
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
;
INDICAT(PSODIR) ;*441
N INDLST,DIR,SEL,I,INDCAT,CHK,CNT K DUOUT,DTOUT,DIROUT,DIRUT
S (CHK,CNT,PSODIR("DFLG"),PSODIR("FIELD"))=0
D INDCATN^PSS50P7(PSODRUG("OI"),"PSODIND")
I '$O(^TMP($J,"PSODIND",0)) S Y=99 G INDICAT1
S (SEL,I)="" F S I=$O(^TMP($J,"PSODIND",I)) Q:I="" D
. S INDCAT=$P($G(^TMP($J,"PSODIND",I)),"^") Q:'$L(INDCAT)
. I $G(PSODIR("IND"))]"",INDCAT=PSODIR("IND") S CHK=1
. S CNT=CNT+1,INDLST(CNT)=INDCAT,DIR("L",CNT)=" "_CNT_" "_INDCAT S:CNT=1 SEL=CNT_":"_INDCAT S:CNT>1 SEL=SEL_";"_CNT_":"_INDCAT
W !!,"INDICATION:"
K DIRUT,DTOUT,DUOUT,DIROUT
S DIR(0)="SO^"_SEL_";99:Free Text entry",DIR("A")="Select INDICATION from the list"
S DIR("L")=" 99 Free Text entry"
S:CHK DIR("B")=PSODIR("IND") S:'CHK&($G(PSODIR("IND"))]"") DIR("B")=99
S DIR("?")="Answer must be 3-40 characters in length."
S DIR("?",1)="This field contains the Indication For Use."
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S PSODIR("DFLG")=1 Q
I $G(PSOEDIT)!($G(PSOFDR))!($G(PSOCOPY)),X="" S:$G(PSODIR("IND"))]"" Y=99 G INDICAT1
I X="@" N KF S KF=0 D:$G(PSOEDIT)!($G(PSOFDR))!($G(PSOCOPY)) K:'KF PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO") Q
. S PSODELINS=2,KF=1 D DELIND
. I $G(PSODELINS) S (PSODIR("FLD",128),PSODIR("FLD",129),PSODIR("FLD",130))="" K PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
I Y=99 S:CHK PSODIR("IND")="" G INDICAT1
I Y S PSODIR("IND")=Y(0) S:$G(PSOEDIT) PSODIR("FLD",128)=Y(0)
INDICAT1 ;
I Y=99 N I,J,IND,DA D G:$G(Y)=99 INDICAT1 Q:$G(PSODIR("DFLG"))!(X="")
. K X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
. S:$G(PSODIR("IND"))]"" DIR("B")=$G(PSODIR("IND"))
. S DIR(0)="52,128",DIR("A")="INDICATION" D ^DIR
. I $D(DUOUT)!($D(DTOUT)) S PSODIR("DFLG")=1 Q
. I X="" S PSODIR("FLD",128)="" K PSODIR("IND") Q
. I X="@" N KF S KF=0 D:$G(PSOEDIT)!($G(PSOFDR))!($G(PSOCOPY)) K:'KF PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO") Q
. . S PSODELINS=2,KF=1 D DELIND
. . I $G(PSODELINS) S (PSODIR("FLD",128),PSODIR("FLD",129),PSODIR("FLD",130))="" K PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
. I $L(X," ")=1,$L(X)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED WITHOUT SPACES.",! S Y=99 Q
. S IND="" F I=1:1:$L(X," ") Q:I="" S J=$P(X," ",I) D I '$D(X) S Y=99 Q
. .I $L(J)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
. .S:J]"" IND=$S($G(IND)]"":IND_" ",1:"")_J
. Q:$G(Y)=99
. S IND=$$UPPER^PSOSIG(IND),PSODIR("IND")=IND
. I $L(IND) S:$G(PSOEDIT) PSODIR("FLD",128)=IND
I $G(PSODIR("IND"))]"" D
. W !,PSODIR("IND"),!
. N DIR,PSOZ S PSOZ=$$GET1^DIQ(59.7,1,96),DIR("B")=$S(PSOZ]"":PSOZ,1:"YES")
. S DIR(0)="Y",DIR("A")="Copy INDICATION into the Sig" D ^DIR
. I $G(DIRUT) S PSODIR("DFLG")=1 Q
. I Y>0 S PSODIR("INDF")=1 S:$G(PSOEDIT) PSODIR("FLD",129)=1
. I 'Y S PSODIR("INDF")=0 S:$G(PSOEDIT) PSODIR("FLD",129)=""
Q
;
SIND(PSODIR) ;
S (PSODONE,PSODELINS)=0
F D Q:PSODONE
. D INDICAT^PSODIR(.PSODIR)
. I $G(PSODIR("DFLG")) D S PSODONE=1 Q
. . I $G(PSODIR("IND"))="",$G(PSODIR("INDO"))="" Q
. . I $G(PSODIR("IND"))]"",$G(PSODIR("INDO"))]"" Q
. . I $G(PSODIR("IND"))]"",$G(PSODIR("INDO"))="" S PSODIR("IND")="" Q
. . I $G(PSODIR("IND"))="",$G(PSODIR("INDO"))]"" S PSODIR("INDO")=""
. Q:$G(PSODELINS)
. D OIND
. I $G(PSODIR("DFLG")) D S PSODONE=1 Q
. . I $G(PSODIR("IND"))="",$G(PSODIR("INDO"))="" Q
. . I $G(PSODIR("IND"))]"",$G(PSODIR("INDO"))]"" Q
. . I $G(PSODIR("IND"))]"",$G(PSODIR("INDO"))="" S PSODIR("IND")="" Q
. . I $G(PSODIR("IND"))="",$G(PSODIR("INDO"))]"" S PSODIR("INDO")=""
. I $G(PSODIR("IND"))="",$G(PSODIR("INDO"))="" S PSODONE=1 Q
. I $G(PSODIR("IND"))]"",$G(PSODIR("INDO"))]"" S PSODONE=1 Q
. I $G(PSODIR("IND"))]"",$G(PSODIR("INDO"))="" W $C(7),!!?5,"OTHER INDICATION REQUIRED",! H 2 Q
. I $G(PSODIR("IND"))="",$G(PSODIR("INDO"))]"" W $C(7),!!?5,"INDICATION REQUIRED",! H 2
D EN^PSOFSIG(.PSODIR,1)
Q
;
OIND ;
I '$D(^TMP($J,"PSODIND","OTH")) S Y=99 G OINDI1
N SEL,I,INDCAT,CHK,CNT
S (CHK,CNT,PSODIR("DFLG"))=0
S (SEL,I)="" F S I=$O(^TMP($J,"PSODIND","OTH",I)) Q:I="" D
. S INDCAT=$P($G(^TMP($J,"PSODIND","OTH",I)),"^") Q:'$L(INDCAT)
. I $G(PSODIR("INDO"))]"",INDCAT=PSODIR("INDO") S CHK=1
. S CNT=CNT+1,INDLST(CNT)=INDCAT,DIR("L",CNT)=" "_CNT_" "_INDCAT S:CNT=1 SEL=CNT_":"_INDCAT S:CNT>1 SEL=SEL_";"_CNT_":"_INDCAT
W !!,"OTHER LANGUAGE INDICATION:"
K DIRUT,DTOUT,DUOUT,DIROUT
S DIR(0)="SO^"_SEL_";99:Free Text entry",DIR("A")="Select OTHER LANGUAGE INDICATION from the list"
S DIR("L")=" 99 Free Text entry"
S:CHK DIR("B")=PSODIR("INDO") S:'CHK&($G(PSODIR("INDO"))]"") DIR("B")=99
S DIR("?")="Answer must be 3-40 characters in length."
S DIR("?",1)="This field contains the Other Language Indication For Use."
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S PSODIR("DFLG")=1 Q
I '$G(PSOEDIT),X="" Q
I $G(PSOEDIT),X="" S:$G(PSODIR("INDO"))]"" Y=99 G OINDI1
I X="@" D:$G(PSOEDIT)!($G(PSOFDR))!($G(PSOCOPY)) Q ;K:'$G(PSOEDIT) PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO") Q
. S PSODELINS=1 D DELIND
. I $G(PSODELINS) S (PSODIR("FLD",128),PSODIR("FLD",129),PSODIR("FLD",130))="" K PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
I Y=99 S:CHK PSODIR("INDO")="" G OINDI1
I Y S PSODIR("INDO")=Y(0) S:$G(PSOEDIT) PSODIR("FLD",130)=Y(0)
OINDI1 ;
I Y=99 N I,J,IND,DA D G:$G(Y)=99 OINDI1 Q:$G(PSODIR("DFLG"))!(X="")
. K X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
. S:$G(PSODIR("INDO"))]"" DIR("B")=PSODIR("INDO")
. S DIR(0)="52,130",DIR("A")="OTHER LANGUAGE INDICATION" D ^DIR
. I $D(DUOUT)!($D(DTOUT)) S PSODIR("DFLG")=1 Q
. I X="" S PSODIR("FLD",130)="" K PSODIR("INDO") Q
. I X="@" D:$G(PSOEDIT)!($G(PSOCOPY)) K:'$G(PSOEDIT) PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO") Q
. . S PSODELINS=1 D DELIND
. . I $G(PSODELINS) S (PSODIR("FLD",128),PSODIR("FLD",129),PSODIR("FLD",130))="" K PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
. I $L(X," ")=1,$L(X)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED WITHOUT SPACES.",! S Y=99 Q
. S IND="" F I=1:1:$L(X," ") Q:I="" S J=$P(X," ",I) D I '$D(X) S Y=99 Q
. .I $L(J)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
. .S:J]"" IND=$S($G(IND)]"":IND_" ",1:"")_J
. Q:$G(Y)=99
. S IND=$$UPPER^PSOSIG(IND),PSODIR("INDO")=IND
. I $L(IND) S:$G(PSOEDIT) PSODIR("FLD",130)=IND
Q
DELIND ;*441-IND-CONFIRM INDICATION DELETION
I '$P($G(^PS(55,PSODFN,"LAN")),"^") Q
N X,Y,DIR,DIRUT
W $C(7),!!?5,"ANY DATA ENTERED FOR "_$S($G(PSODELINS)=2:"OTHER INDICATION",1:"INDICATION")
W $C(7),!?5,"WILL ALSO BE DELETED.",!
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Continue with Deletion" D ^DIR
S:$G(DIRUT) Y=0
S (PSODONE,PSODELINS)=Y
Q
;
;*545; DEA selection
SLDEA(PROVIEN,PSORX,DFLTDEA,PSODRIEN) ; DEA Selection
Q $$SLDEA^PSODIR5(PROVIEN,.PSORX,$G(DFLTDEA),$G(PSODRIEN))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODIR 14971 printed Jan 18, 2025@03:28:10 Page 2
PSODIR ;BHAM ISC/SAB - asks data for rx order entry ;Oct 20, 2022@17:03
+1 ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275,391,372,416,422,504,457,572,587,441,682,545**;DEC 1997;Build 270
+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 ; Reference to ^XTV(8991.9) in ICR #7002
+6 ; Reference to ^VA(200.5321) in ICR #7000
+7 ;----------------------------------------------------------------
+8 ;
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 '$DATA(PSODIR("CS"))
IF $DATA(PSODRUG("DEA"))
Begin DoDot:1
+3 NEW DEA
SET PSODIR("CS")=0
FOR DEA=1:1
if $EXTRACT(PSODRUG("DEA"),DEA)=""
QUIT
IF $EXTRACT(+PSODRUG("DEA"),DEA)>1
IF $EXTRACT(+PSODRUG("DEA"),DEA)<6
SET PSODIR("CS")=1
End DoDot:1
+4 IF $GET(PSODIR("PROVIDER"))]""
SET PSODIR("OLD VAL")=PSODIR("PROVIDER")
+5 SET DIC="^VA(200,"
SET DIC(0)="QEAM"
SET PSODIR("FIELD")=0
+6 SET DIC("W")="W "" "",$P($G(^(""PS"")),""^"",9)"
+7 SET DIC("A")="PROVIDER: "
SET DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
+8 IF $GET(PSOTPBFG)
IF $GET(PSOFROM)="NEW"
SET DIC("S")=DIC("S")_",$P($G(^(""TPB"")),""^""),$P($G(^(""TPB"")),""^"",5)=0"
+9 ;p682 change condition for setting DIC("B"); do not overwrite
+10 ;S:$G(PSORX("PROVIDER NAME"))]"" DIC("B")=PSORX("PROVIDER NAME")
+11 SET DIC("B")=$SELECT($GET(DIC("B"))]"":DIC("B"),1:$GET(PSORX("PROVIDER NAME")))
+12 DO ^DIC
KILL DIC
+13 IF X[U
IF $LENGTH(X)>1
if '$GET(PSOEDIT)
DO JUMP
GOTO PROVX
+14 IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSODIR("DFLG")=1
GOTO PROVX
+15 IF '$GET(SPEED)
IF Y=-1
GOTO PROVEN
+16 if $GET(SPEED)&(Y=-1)
QUIT
+17 ;572
LOCK +^VA(200,+Y):1
IF '$TEST
Begin DoDot:1
+18 NEW PSOED
SET PSOED=$PIECE($GET(^VA(200,+Y,1)),"^",8)
+19 ;587
IF PSOED
WRITE $CHAR(7),!!,"Provider is being edited by "_$PIECE($GET(^VA(200,PSOED,0)),"^")
QUIT
+20 WRITE $CHAR(7),!!,"Provider is being edited by an unknown user or has been deleted"
End DoDot:1
GOTO PROVEN
+21 ;572
LOCK -^VA(200,+Y)
+22 ;PSO*7*211; ADD CHECK FOR DEA# AND VA#
+23 ;*545; DEA/VA selection
+24 IF $$DETOX^PSSOPKI($GET(PSODRUG("IEN")))
NEW DETX
SET DETX=""
Begin DoDot:1
+25 SET DETX=$$DETOX^XUSER(+Y)
IF '$LENGTH(DETX)
WRITE $CHAR(7),!!,"Provider must have a DETOX# to order this drug.",!
QUIT
+26 SET PSORX("DETX")=DETX
End DoDot:1
if '$LENGTH(DETX)
GOTO PROVEN
+27 IF $PIECE($GET(PSODIR("CS")),"^",1)!($DATA(CLOZPAT))
NEW NDEA
Begin DoDot:1
+28 NEW SDEA
SET SDEA=$$DRGSCH()
+29 NEW PSOPROVD
SET PSOPROVD=+Y
SET NDEA=$$SLDEA(PSOPROVD,.PSORX)
QUIT
+30 IF NDEA=2
WRITE $CHAR(7),!!,"Provider not authorized to write Federal Schedule "_SDEA_" prescriptions."
Begin DoDot:2
+31 WRITE !,"Please contact the provider.",!
End DoDot:2
QUIT
+32 WRITE $CHAR(7),!!,"Provider must have a valid DEA# or VA# to write prescriptions for this drug.",!
+33 QUIT
End DoDot:1
IF $LENGTH($PIECE($GET(NDEA),"^"))<3
GOTO PROVEN
+34 ;PSO*7.0*391; Added check for DETOX#
+35 IF $$DETOX^PSSOPKI($GET(PSODRUG("IEN")))
IF $$DETOX^XUSER(+Y)=""
WRITE $CHAR(7),!!,"Provider must have a DETOX# to order this drug.",!
GOTO PROVEN
+36 IF $DATA(CLOZPAT)
IF '$DATA(^XUSEC("YSCL AUTHORIZED",+Y))
Begin DoDot:1
+37 ; PSO*7*457
WRITE $CHAR(7),!!,$$CLKEYWRN^PSOCLUTL,!
End DoDot:1
GOTO PROVEN
+38 IF '$GET(PSODRUG("IEN"))
IF '$GET(PSORENW("DRUG IEN"))
GOTO NODRUG
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 ;
DRGSCH() ; determine the drug schedule
+1 NEW ND3,SCH
+2 SET SCH=""
SET ND3=$PIECE($GET(^PSDRUG(PSODRUG("IEN"),"ND")),"^",3)
if +ND3
SET SCH=$$GET1^DIQ(50.68,ND3,19,"I")
+3 IF +SCH>0!($GET(PSODRUG("DEA"))="")
QUIT SCH
+4 IF "^4^5^"[+PSODRUG("DEA")
QUIT +PSODRUG("DEA")
+5 QUIT $SELECT($GET(PSODRUG("DEA"))["A":+PSODRUG("DEA"),1:+PSODRUG("DEA")_"n")
+6 ;
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 NEW PSODOSNW
SET PSODOSNW=1
+2 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
+2 KILL INS1,DD,DIR,DIRUT
SET D=0
FOR
SET D=$ORDER(PSODIR("SIG",D))
if 'D
QUIT
SET DD=$GET(DD)+1
+3 IF $GET(DD)=1
SET PSODIR("INS")=$GET(PSODIR("SIG",1))
GOTO INSD
+4 ;PSO*7*275 remove check for PSOINSFL just check for multi line sig
+5 IF $GET(DD)>1
Begin DoDot:1
+6 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)
+7 SET DWPK=2
SET DWLW=80
SET DIC="^TMP($J,""SIG"","
DO EN^DIWE
KILL PSODIR("SIG")
+8 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"SIG",D))
if 'D
QUIT
SET PSODIR("SIG",D)=^TMP($JOB,"SIG",D,0)
+9 if '$PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
DO INDICAT^PSODIR(.PSODIR)
+10 DO EN^PSOFSIG(.PSODIR,1)
KILL DWLW,D,DWPK,^TMP($JOB)
End DoDot:1
GOTO EX
+11 IF $GET(PSOINSFL)=0
GOTO INSD
+12 IF $GET(PSOFDR)
IF $GET(ORD)
IF $PIECE($GET(^PS(52.41,+$GET(ORD),"EXT")),"^")'=""
GOTO INSD
+13 ;*422
IF $GET(PSODIR("INS"))']""
IF $GET(^PS(50.7,PSODRUG("OI"),"INS"))]""
IF '$DATA(PSODIR("FLD",114))
SET (DIR("B"),PSOOEINS)=^PS(50.7,PSODRUG("OI"),"INS")
GOTO INSD
+14 ;*422
SET (DIR("B"),PSOOEINS)=$GET(PSODIR("SIG",1))
INSD SET DIR(0)="52,114"
if $GET(PSODIR("INS"))]""
SET DIR("B")=PSODIR("INS")
+1 KILL PSODIR("DFLG")
+2 DO DIR
+3 IF $GET(PSODIR("DFLG"))
SET (PSODIR("INS"),PSODIR("SIG"),PSODIR("SIG",1))=$GET(PSOOEINS)
SET PSODIR("SINS")=$GET(PSOOSINS)
DO EN^PSOFSIG(.PSODIR,0)
+4 if $GET(PSODIR("DFLG"))!(PSODIR("FIELD"))
GOTO EX
+5 IF X'=""
IF X'="@"
SET PSODIR("INS")=Y
DO SIG^PSOHELP
if '$DATA(X)
GOTO INSD
+6 IF $GET(INS1)]""
DO EN^DDIOL($EXTRACT(INS1,2,9999999))
SET (PSODIR("SIG",1),PSODIR("SIG"))=$EXTRACT(INS1,2,9999999)
+7 ;*422
IF X="@"
SET PSODELINS=1
DO DELINS^PSOHELP3
IF $GET(PSODELINS)
SET (PSODIR("FLD",114),PSODIR("FLD",114.1))=""
KILL PSODIR("INS"),PSODIR("SIG"),PSODIR("SINS")
+8 ;*441 - indication
+9 IF '$PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
DO INDICAT^PSODIR(.PSODIR)
KILL DIRUT,DTOUT,DUOUT,DIROUT
+10 IF '$GET(PSOEDIT)
IF $GET(PSODIR("DFLG"))
GOTO EX
+11 DO EN^PSOFSIG(.PSODIR,1)
IF $ORDER(SIG(0))
SET SIGOK=1
+12 GOTO EX
+13 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"))]""
IF '$DATA(PSODIR("FLD",114))
IF $GET(PSOOEINS)]""
SET (DIR("B"),PSOOSINS)=^PS(50.7,PSODRUG("OI"),"INS1")
+4 DO DIR
IF $GET(PSODIR("DFLG"))
SET (PSODIR("INS"),PSODIR("SIG"),PSODIR("SIG",1))=$GET(PSOOEINS)
SET PSODIR("SINS")=$GET(PSOOSINS)
DO EN^PSOFSIG(.PSODIR,0)
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 ;*422
IF X="@"
SET PSODELINS=2
DO DELINS^PSOHELP3
IF $GET(PSODELINS)
SET (PSODIR("FLD",114),PSODIR("FLD",114.1))=""
KILL PSODIR("INS"),PSODIR("SIG"),PSODIR("SINS")
DO EN^PSOFSIG(.PSODIR,1)
+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
+2 ;
INDICAT(PSODIR) ;*441
+1 NEW INDLST,DIR,SEL,I,INDCAT,CHK,CNT
KILL DUOUT,DTOUT,DIROUT,DIRUT
+2 SET (CHK,CNT,PSODIR("DFLG"),PSODIR("FIELD"))=0
+3 DO INDCATN^PSS50P7(PSODRUG("OI"),"PSODIND")
+4 IF '$ORDER(^TMP($JOB,"PSODIND",0))
SET Y=99
GOTO INDICAT1
+5 SET (SEL,I)=""
FOR
SET I=$ORDER(^TMP($JOB,"PSODIND",I))
if I=""
QUIT
Begin DoDot:1
+6 SET INDCAT=$PIECE($GET(^TMP($JOB,"PSODIND",I)),"^")
if '$LENGTH(INDCAT)
QUIT
+7 IF $GET(PSODIR("IND"))]""
IF INDCAT=PSODIR("IND")
SET CHK=1
+8 SET CNT=CNT+1
SET INDLST(CNT)=INDCAT
SET DIR("L",CNT)=" "_CNT_" "_INDCAT
if CNT=1
SET SEL=CNT_":"_INDCAT
if CNT>1
SET SEL=SEL_";"_CNT_":"_INDCAT
End DoDot:1
+9 WRITE !!,"INDICATION:"
+10 KILL DIRUT,DTOUT,DUOUT,DIROUT
+11 SET DIR(0)="SO^"_SEL_";99:Free Text entry"
SET DIR("A")="Select INDICATION from the list"
+12 SET DIR("L")=" 99 Free Text entry"
+13 if CHK
SET DIR("B")=PSODIR("IND")
if 'CHK&($GET(PSODIR("IND"))]"")
SET DIR("B")=99
+14 SET DIR("?")="Answer must be 3-40 characters in length."
+15 SET DIR("?",1)="This field contains the Indication For Use."
+16 DO ^DIR
+17 IF $DATA(DUOUT)!($DATA(DTOUT))
SET PSODIR("DFLG")=1
QUIT
+18 IF $GET(PSOEDIT)!($GET(PSOFDR))!($GET(PSOCOPY))
IF X=""
if $GET(PSODIR("IND"))]""
SET Y=99
GOTO INDICAT1
+19 IF X="@"
NEW KF
SET KF=0
if $GET(PSOEDIT)!($GET(PSOFDR))!($GET(PSOCOPY))
Begin DoDot:1
+20 SET PSODELINS=2
SET KF=1
DO DELIND
+21 IF $GET(PSODELINS)
SET (PSODIR("FLD",128),PSODIR("FLD",129),PSODIR("FLD",130))=""
KILL PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
End DoDot:1
if 'KF
KILL PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
QUIT
+22 IF Y=99
if CHK
SET PSODIR("IND")=""
GOTO INDICAT1
+23 IF Y
SET PSODIR("IND")=Y(0)
if $GET(PSOEDIT)
SET PSODIR("FLD",128)=Y(0)
INDICAT1 ;
+1 IF Y=99
NEW I,J,IND,DA
Begin DoDot:1
+2 KILL X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
+3 if $GET(PSODIR("IND"))]""
SET DIR("B")=$GET(PSODIR("IND"))
+4 SET DIR(0)="52,128"
SET DIR("A")="INDICATION"
DO ^DIR
+5 IF $DATA(DUOUT)!($DATA(DTOUT))
SET PSODIR("DFLG")=1
QUIT
+6 IF X=""
SET PSODIR("FLD",128)=""
KILL PSODIR("IND")
QUIT
+7 IF X="@"
NEW KF
SET KF=0
if $GET(PSOEDIT)!($GET(PSOFDR))!($GET(PSOCOPY))
Begin DoDot:2
+8 SET PSODELINS=2
SET KF=1
DO DELIND
+9 IF $GET(PSODELINS)
SET (PSODIR("FLD",128),PSODIR("FLD",129),PSODIR("FLD",130))=""
KILL PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
End DoDot:2
if 'KF
KILL PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
QUIT
+10 IF $LENGTH(X," ")=1
IF $LENGTH(X)>32
WRITE $CHAR(7),!?5,"MAX OF 32 CHARACTERS ALLOWED WITHOUT SPACES.",!
SET Y=99
QUIT
+11 SET IND=""
FOR I=1:1:$LENGTH(X," ")
if I=""
QUIT
SET J=$PIECE(X," ",I)
Begin DoDot:2
+12 IF $LENGTH(J)>32
WRITE $CHAR(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",!
KILL X
QUIT
+13 if J]""
SET IND=$SELECT($GET(IND)]"":IND_" ",1:"")_J
End DoDot:2
IF '$DATA(X)
SET Y=99
QUIT
+14 if $GET(Y)=99
QUIT
+15 SET IND=$$UPPER^PSOSIG(IND)
SET PSODIR("IND")=IND
+16 IF $LENGTH(IND)
if $GET(PSOEDIT)
SET PSODIR("FLD",128)=IND
End DoDot:1
if $GET(Y)=99
GOTO INDICAT1
if $GET(PSODIR("DFLG"))!(X="")
QUIT
+17 IF $GET(PSODIR("IND"))]""
Begin DoDot:1
+18 WRITE !,PSODIR("IND"),!
+19 NEW DIR,PSOZ
SET PSOZ=$$GET1^DIQ(59.7,1,96)
SET DIR("B")=$SELECT(PSOZ]"":PSOZ,1:"YES")
+20 SET DIR(0)="Y"
SET DIR("A")="Copy INDICATION into the Sig"
DO ^DIR
+21 IF $GET(DIRUT)
SET PSODIR("DFLG")=1
QUIT
+22 IF Y>0
SET PSODIR("INDF")=1
if $GET(PSOEDIT)
SET PSODIR("FLD",129)=1
+23 IF 'Y
SET PSODIR("INDF")=0
if $GET(PSOEDIT)
SET PSODIR("FLD",129)=""
End DoDot:1
+24 QUIT
+25 ;
SIND(PSODIR) ;
+1 SET (PSODONE,PSODELINS)=0
+2 FOR
Begin DoDot:1
+3 DO INDICAT^PSODIR(.PSODIR)
+4 IF $GET(PSODIR("DFLG"))
Begin DoDot:2
+5 IF $GET(PSODIR("IND"))=""
IF $GET(PSODIR("INDO"))=""
QUIT
+6 IF $GET(PSODIR("IND"))]""
IF $GET(PSODIR("INDO"))]""
QUIT
+7 IF $GET(PSODIR("IND"))]""
IF $GET(PSODIR("INDO"))=""
SET PSODIR("IND")=""
QUIT
+8 IF $GET(PSODIR("IND"))=""
IF $GET(PSODIR("INDO"))]""
SET PSODIR("INDO")=""
End DoDot:2
SET PSODONE=1
QUIT
+9 if $GET(PSODELINS)
QUIT
+10 DO OIND
+11 IF $GET(PSODIR("DFLG"))
Begin DoDot:2
+12 IF $GET(PSODIR("IND"))=""
IF $GET(PSODIR("INDO"))=""
QUIT
+13 IF $GET(PSODIR("IND"))]""
IF $GET(PSODIR("INDO"))]""
QUIT
+14 IF $GET(PSODIR("IND"))]""
IF $GET(PSODIR("INDO"))=""
SET PSODIR("IND")=""
QUIT
+15 IF $GET(PSODIR("IND"))=""
IF $GET(PSODIR("INDO"))]""
SET PSODIR("INDO")=""
End DoDot:2
SET PSODONE=1
QUIT
+16 IF $GET(PSODIR("IND"))=""
IF $GET(PSODIR("INDO"))=""
SET PSODONE=1
QUIT
+17 IF $GET(PSODIR("IND"))]""
IF $GET(PSODIR("INDO"))]""
SET PSODONE=1
QUIT
+18 IF $GET(PSODIR("IND"))]""
IF $GET(PSODIR("INDO"))=""
WRITE $CHAR(7),!!?5,"OTHER INDICATION REQUIRED",!
HANG 2
QUIT
+19 IF $GET(PSODIR("IND"))=""
IF $GET(PSODIR("INDO"))]""
WRITE $CHAR(7),!!?5,"INDICATION REQUIRED",!
HANG 2
End DoDot:1
if PSODONE
QUIT
+20 DO EN^PSOFSIG(.PSODIR,1)
+21 QUIT
+22 ;
OIND ;
+1 IF '$DATA(^TMP($JOB,"PSODIND","OTH"))
SET Y=99
GOTO OINDI1
+2 NEW SEL,I,INDCAT,CHK,CNT
+3 SET (CHK,CNT,PSODIR("DFLG"))=0
+4 SET (SEL,I)=""
FOR
SET I=$ORDER(^TMP($JOB,"PSODIND","OTH",I))
if I=""
QUIT
Begin DoDot:1
+5 SET INDCAT=$PIECE($GET(^TMP($JOB,"PSODIND","OTH",I)),"^")
if '$LENGTH(INDCAT)
QUIT
+6 IF $GET(PSODIR("INDO"))]""
IF INDCAT=PSODIR("INDO")
SET CHK=1
+7 SET CNT=CNT+1
SET INDLST(CNT)=INDCAT
SET DIR("L",CNT)=" "_CNT_" "_INDCAT
if CNT=1
SET SEL=CNT_":"_INDCAT
if CNT>1
SET SEL=SEL_";"_CNT_":"_INDCAT
End DoDot:1
+8 WRITE !!,"OTHER LANGUAGE INDICATION:"
+9 KILL DIRUT,DTOUT,DUOUT,DIROUT
+10 SET DIR(0)="SO^"_SEL_";99:Free Text entry"
SET DIR("A")="Select OTHER LANGUAGE INDICATION from the list"
+11 SET DIR("L")=" 99 Free Text entry"
+12 if CHK
SET DIR("B")=PSODIR("INDO")
if 'CHK&($GET(PSODIR("INDO"))]"")
SET DIR("B")=99
+13 SET DIR("?")="Answer must be 3-40 characters in length."
+14 SET DIR("?",1)="This field contains the Other Language Indication For Use."
+15 DO ^DIR
+16 IF $DATA(DUOUT)!($DATA(DTOUT))
SET PSODIR("DFLG")=1
QUIT
+17 IF '$GET(PSOEDIT)
IF X=""
QUIT
+18 IF $GET(PSOEDIT)
IF X=""
if $GET(PSODIR("INDO"))]""
SET Y=99
GOTO OINDI1
+19 ;K:'$G(PSOEDIT) PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO") Q
IF X="@"
if $GET(PSOEDIT)!($GET(PSOFDR))!($GET(PSOCOPY))
Begin DoDot:1
+20 SET PSODELINS=1
DO DELIND
+21 IF $GET(PSODELINS)
SET (PSODIR("FLD",128),PSODIR("FLD",129),PSODIR("FLD",130))=""
KILL PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
End DoDot:1
QUIT
+22 IF Y=99
if CHK
SET PSODIR("INDO")=""
GOTO OINDI1
+23 IF Y
SET PSODIR("INDO")=Y(0)
if $GET(PSOEDIT)
SET PSODIR("FLD",130)=Y(0)
OINDI1 ;
+1 IF Y=99
NEW I,J,IND,DA
Begin DoDot:1
+2 KILL X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
+3 if $GET(PSODIR("INDO"))]""
SET DIR("B")=PSODIR("INDO")
+4 SET DIR(0)="52,130"
SET DIR("A")="OTHER LANGUAGE INDICATION"
DO ^DIR
+5 IF $DATA(DUOUT)!($DATA(DTOUT))
SET PSODIR("DFLG")=1
QUIT
+6 IF X=""
SET PSODIR("FLD",130)=""
KILL PSODIR("INDO")
QUIT
+7 IF X="@"
if $GET(PSOEDIT)!($GET(PSOCOPY))
Begin DoDot:2
+8 SET PSODELINS=1
DO DELIND
+9 IF $GET(PSODELINS)
SET (PSODIR("FLD",128),PSODIR("FLD",129),PSODIR("FLD",130))=""
KILL PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
End DoDot:2
if '$GET(PSOEDIT)
KILL PSODIR("IND"),PSODIR("INDF"),PSODIR("INDO")
QUIT
+10 IF $LENGTH(X," ")=1
IF $LENGTH(X)>32
WRITE $CHAR(7),!?5,"MAX OF 32 CHARACTERS ALLOWED WITHOUT SPACES.",!
SET Y=99
QUIT
+11 SET IND=""
FOR I=1:1:$LENGTH(X," ")
if I=""
QUIT
SET J=$PIECE(X," ",I)
Begin DoDot:2
+12 IF $LENGTH(J)>32
WRITE $CHAR(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",!
KILL X
QUIT
+13 if J]""
SET IND=$SELECT($GET(IND)]"":IND_" ",1:"")_J
End DoDot:2
IF '$DATA(X)
SET Y=99
QUIT
+14 if $GET(Y)=99
QUIT
+15 SET IND=$$UPPER^PSOSIG(IND)
SET PSODIR("INDO")=IND
+16 IF $LENGTH(IND)
if $GET(PSOEDIT)
SET PSODIR("FLD",130)=IND
End DoDot:1
if $GET(Y)=99
GOTO OINDI1
if $GET(PSODIR("DFLG"))!(X="")
QUIT
+17 QUIT
DELIND ;*441-IND-CONFIRM INDICATION DELETION
+1 IF '$PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
QUIT
+2 NEW X,Y,DIR,DIRUT
+3 WRITE $CHAR(7),!!?5,"ANY DATA ENTERED FOR "_$SELECT($GET(PSODELINS)=2:"OTHER INDICATION",1:"INDICATION")
+4 WRITE $CHAR(7),!?5,"WILL ALSO BE DELETED.",!
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Continue with Deletion"
DO ^DIR
+6 if $GET(DIRUT)
SET Y=0
+7 SET (PSODONE,PSODELINS)=Y
+8 QUIT
+9 ;
+10 ;*545; DEA selection
SLDEA(PROVIEN,PSORX,DFLTDEA,PSODRIEN) ; DEA Selection
+1 QUIT $$SLDEA^PSODIR5(PROVIEN,.PSORX,$GET(DFLTDEA),$GET(PSODRIEN))
