- 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
- 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
