PSOTPPRV ;BIR/MHA-TPB NON-VA provider selection ;08/21/03
;;7.0;OUTPATIENT PHARMACY;**146,153**;DEC 1997
ST K DA,DIC,DIE,X,Y,XLFNC
W !!,"Select Provider: " R X:$S($D(DTIME):DTIME,1:300) I '$T G KV
G:X=""!(X["^")!($D(DTOUT)) KV
I X?1."?" D G ST
.W !!,"Answer with NEW PERSON NAME, or INITIAL, or SSN, or DEA#, or VA#"
S (DIE,DIC)=200,DIC(0)="EMQZ"
;S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
D ^DIC G:$D(DUOUT)!($D(DTOUT)) ST N CNT S CNT=0
I +Y>0,'$P($G(^VA(200,+Y,"PS")),"^"),$P($G(^VA(200,+Y,"PS")),"^",4),$P(^("PS"),"^",4)'>DT D G ST
.W !!,"This Provider is not Authorized to Write Med Orders and flagged as Inactive."
.W !,"Use the Edit Provider [PSO PROVIDER EDIT] option to change them."
I +Y>0,'$P($G(^VA(200,+Y,"PS")),"^") D G ST
.W !!,"This Provider is not Authorized to Write Med Orders. Use the Edit Provider"
.W !,"[PSO PROVIDER EDIT] option to change the Authorization flag."
I +Y>0 I $P($G(^VA(200,+Y,"PS")),"^",4),$P(^("PS"),"^",4)'>DT D G ST
.W !!,"This Provider is flagged as Inactive. Use the Edit Provider"
.W !,"[PSO PROVIDER EDIT] option to change the Inactive Date."
I +Y>0 D G:CNT STC
.I $D(^VA(200,+Y,"PS")),$P(^("PS"),"^"),$S('$P(^("PS"),"^",4):1,1:$P(^("PS"),"^",4)'<DT) Q
.S CNT=1
I +Y>0 D I 'CNT S DA=+Y G GD
.I $P($G(^VA(200,+Y,"TPB")),"^"),$P(^("TPB"),"^",5)=0 Q
.S CNT=1
STC I CNT K CNT S DA=+Y D G:$D(DIRUT)!('Y) ST G:Y EDT
.W !,"Please identify Provider as a NON-VA PRESCRIBER in the Provider File.",!
.D KV S DIR("A")="Do you want to edit Provider:",DIR("B")="Y",DIR(0)="YN" D ^DIR
I Y<0 D G:'$D(X) ST G:$D(DIRUT)!('Y) ST G:Y ADD
.I X[""""!($A(X)=45)!($L(X,",")'=2)!(X'?1.E1","1.E) K X Q
.S XLFNC=X D STDNAME^XLFNAME(.XLFNC,"C")
.S X=XLFNC I $L(X)>35!($L(X)<3) K X Q
.W !!,"Provider not found in Provider File"
.D KV S DIR("A")="Do you want to enter a new Provider:",DIR("B")="Y",DIR(0)="YN" D ^DIR
Q
EDT D ASK1^PSOPRVW G GD
ADD D ADD^PSOPRVW
GD G:'$D(DA) ST
I $D(^VA(200,DA,"PS")),$P(^("PS"),"^"),$S('$P(^("PS"),"^",4):1,1:$P(^("PS"),"^",4)'<DT) G STQ
G ST
STQ I $P($G(^VA(200,+DA,"TPB")),"^"),$P(^("TPB"),"^",5)=0 G KV
G ST
KV K DIR,DIRUT,DTOUT,DUOUT,D,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPPRV 2245 printed Sep 23, 2025@20:12:25 Page 2
PSOTPPRV ;BIR/MHA-TPB NON-VA provider selection ;08/21/03
+1 ;;7.0;OUTPATIENT PHARMACY;**146,153**;DEC 1997
ST KILL DA,DIC,DIE,X,Y,XLFNC
+1 WRITE !!,"Select Provider: "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
GOTO KV
+2 if X=""!(X["^")!($DATA(DTOUT))
GOTO KV
+3 IF X?1."?"
Begin DoDot:1
+4 WRITE !!,"Answer with NEW PERSON NAME, or INITIAL, or SSN, or DEA#, or VA#"
End DoDot:1
GOTO ST
+5 SET (DIE,DIC)=200
SET DIC(0)="EMQZ"
+6 ;S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
+7 DO ^DIC
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO ST
NEW CNT
SET CNT=0
+8 IF +Y>0
IF '$PIECE($GET(^VA(200,+Y,"PS")),"^")
IF $PIECE($GET(^VA(200,+Y,"PS")),"^",4)
IF $PIECE(^("PS"),"^",4)'>DT
Begin DoDot:1
+9 WRITE !!,"This Provider is not Authorized to Write Med Orders and flagged as Inactive."
+10 WRITE !,"Use the Edit Provider [PSO PROVIDER EDIT] option to change them."
End DoDot:1
GOTO ST
+11 IF +Y>0
IF '$PIECE($GET(^VA(200,+Y,"PS")),"^")
Begin DoDot:1
+12 WRITE !!,"This Provider is not Authorized to Write Med Orders. Use the Edit Provider"
+13 WRITE !,"[PSO PROVIDER EDIT] option to change the Authorization flag."
End DoDot:1
GOTO ST
+14 IF +Y>0
IF $PIECE($GET(^VA(200,+Y,"PS")),"^",4)
IF $PIECE(^("PS"),"^",4)'>DT
Begin DoDot:1
+15 WRITE !!,"This Provider is flagged as Inactive. Use the Edit Provider"
+16 WRITE !,"[PSO PROVIDER EDIT] option to change the Inactive Date."
End DoDot:1
GOTO ST
+17 IF +Y>0
Begin DoDot:1
+18 IF $DATA(^VA(200,+Y,"PS"))
IF $PIECE(^("PS"),"^")
IF $SELECT('$PIECE(^("PS"),"^",4):1,1:$PIECE(^("PS"),"^",4)'<DT)
QUIT
+19 SET CNT=1
End DoDot:1
if CNT
GOTO STC
+20 IF +Y>0
Begin DoDot:1
+21 IF $PIECE($GET(^VA(200,+Y,"TPB")),"^")
IF $PIECE(^("TPB"),"^",5)=0
QUIT
+22 SET CNT=1
End DoDot:1
IF 'CNT
SET DA=+Y
GOTO GD
STC IF CNT
KILL CNT
SET DA=+Y
Begin DoDot:1
+1 WRITE !,"Please identify Provider as a NON-VA PRESCRIBER in the Provider File.",!
+2 DO KV
SET DIR("A")="Do you want to edit Provider:"
SET DIR("B")="Y"
SET DIR(0)="YN"
DO ^DIR
End DoDot:1
if $DATA(DIRUT)!('Y)
GOTO ST
if Y
GOTO EDT
+3 IF Y<0
Begin DoDot:1
+4 IF X[""""!($ASCII(X)=45)!($LENGTH(X,",")'=2)!(X'?1.E1","1.E)
KILL X
QUIT
+5 SET XLFNC=X
DO STDNAME^XLFNAME(.XLFNC,"C")
+6 SET X=XLFNC
IF $LENGTH(X)>35!($LENGTH(X)<3)
KILL X
QUIT
+7 WRITE !!,"Provider not found in Provider File"
+8 DO KV
SET DIR("A")="Do you want to enter a new Provider:"
SET DIR("B")="Y"
SET DIR(0)="YN"
DO ^DIR
End DoDot:1
if '$DATA(X)
GOTO ST
if $DATA(DIRUT)!('Y)
GOTO ST
if Y
GOTO ADD
+9 QUIT
EDT DO ASK1^PSOPRVW
GOTO GD
ADD DO ADD^PSOPRVW
GD if '$DATA(DA)
GOTO ST
+1 IF $DATA(^VA(200,DA,"PS"))
IF $PIECE(^("PS"),"^")
IF $SELECT('$PIECE(^("PS"),"^",4):1,1:$PIECE(^("PS"),"^",4)'<DT)
GOTO STQ
+2 GOTO ST
STQ IF $PIECE($GET(^VA(200,+DA,"TPB")),"^")
IF $PIECE(^("TPB"),"^",5)=0
GOTO KV
+1 GOTO ST
KV KILL DIR,DIRUT,DTOUT,DUOUT,D,X,Y
+1 QUIT
