PSOPRVW ;BIR/SAB,MHA-enter/edit/view provider ;29-May-2012 15:05;PLS
;;7.0;OUTPATIENT PHARMACY;**11,146,153,1011,263,268,264,1015**;DEC 1997;Build 62
;
;Ref. to ^VA(200 supp. by IA 224
;Ref. to ^DIC(7 supp. by IA 491
;Ref. to $$NPI^XUSNPI supp. by IA 4532
;Modified - IHS/MSC/PLS - 04/18/2011 - Line ED1 and ADD+2
START W ! S DIC("A")="Select Provider: ",DIC("S")="I $D(^VA(200,+Y,""PS""))",DIC="^VA(200,",DIC(0)="AEQMZ" D ^DIC G:"^"[X EX G:Y<0 START K DIC S PRNO=+Y
W @IOF,"Name: "_$P(^VA(200,PRNO,0),"^")
I +$P(^VA(200,PRNO,"PS"),"^",4),$P(^("PS"),"^",4)'>DT W ?40,$C(7),"* * * INACTIVE AS OF ",$E($P(^("PS"),"^",4),4,5),"/",$E($P(^("PS"),"^",4),6,7),"/",$E($P(^("PS"),"^",4),2,3)," * * *"
;W !,"SSN#: " S T=$S($P(^VA(200,PRNO,1),"^",9)]"":$P(^(1),"^",9),1:"") W:T $E(T,1,3),"-",$E(T,4,5),"-",$E(T,6,9)
W !,"Initials: "_$P(^VA(200,PRNO,0),"^",2)
W !,"NON-VA Prescriber: "
I $P($G(^VA(200,PRNO,"TPB")),"^")]"" W $S($P(^("TPB"),"^"):"Yes",1:"No")
W ?40,"Tax ID: "_$P($G(^VA(200,PRNO,"TPB")),"^",2)
W !,"Exclusionary Check Performed: " I $P($G(^VA(200,PRNO,"TPB")),"^",3)]"" W $S($P(^("TPB"),"^",3):"Yes",1:"No")
W ?40,"Date Exclusionary List Checked: "
S Y=$P($G(^VA(200,PRNO,"TPB")),"^",4) I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
W !,"On Exclusionary List: " I $P($G(^VA(200,PRNO,"TPB")),"^",5)]"" W $S($P(^("TPB"),"^",5):"Yes",1:"No")
W !,"Exclusionary Checked By: "
I $P($G(^VA(200,PRNO,"TPB")),"^",6) W $P($G(^VA(200,$P(^("TPB"),"^",6),0)),"^")
W !,"Authorized to Write Orders: "_$S($P(^VA(200,PRNO,"PS"),"^"):"Yes",1:"No")
W !,"Requires Cosigner: "_$S($P(^("PS"),"^",7):"Yes",1:"No"),?40,"DEA# "_$P(^VA(200,PRNO,"PS"),"^",2) I $P(^("PS"),"^",7),$D(^VA(200,+$P(^("PS"),"^",8),0)) W !,"Usual Cosigner: "_$P(^(0),"^")
W !,"Class: " S PRCLS=+$P(^VA(200,PRNO,"PS"),"^",5),PRCLS=$S(PRCLS>0&$D(^DIC(7,PRCLS,0)):$P(^(0),"^"),1:"") W PRCLS,?40,"VA# "_$P(^VA(200,PRNO,"PS"),"^",3)
W !," Type: " S T=+$P(^("PS"),"^",6),L=$P(^DD(200,53.6,0),"^",3)_";"_T_":Unknown" F I=1:1 I $P($P(L,";",I),":",1)=T W $P($P(L,";",I),":",2) Q
N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",PRNO),"^") W ?40,"NPI# "_$S(NPI>0:+NPI,1:"")
W !,"Remarks: "_$P(^VA(200,PRNO,"PS"),"^",9),!,"Synonym(s): "_$S($P($G(^VA(200,PRNO,.1)),"^",4)]"":$P(^(.1),"^",4)_",",1:"")_$S($P(^(0),"^",2)]"":" "_$P(^(0),"^",2),1:"")
W !,"Service/Section: " S PSOSSDA=$G(DA) I $P($G(^VA(200,PRNO,5)),"^") K DIQ S DIC="^DIC(49,",DA=$P(^VA(200,PRNO,5),"^"),DR=.01,DIQ="PSOSECT",DIQ(0)="E" D EN^DIQ1 W $G(PSOSECT(49,DA,.01,"E")) S DA=$G(PSOSSDA) K DR,DIC,DIQ,PSOSSDA,PSOSECT
I $TR($G(^VA(200,PRNO,.11)),"^","")="" G NUM
W !!,"Address: ",?10,$P(^VA(200,PRNO,.11),"^") W:$P(^(.11),"^",2)'="" !?10,$P(^(.11),"^",2) W:$P(^(.11),"^",3)'="" !?10,$P(^(.11),"^",3)
W !?10,$P(^VA(200,PRNO,.11),"^",4) W:$P(^(.11),"^",4)]"" ", " S STAT=+$P($G(^(.11)),"^",5) W $S($D(^DIC(5,STAT,0)):$P(^(0),"^"),1:"")_" "_$P(^VA(200,PRNO,.11),"^",6)
NUM G:'$D(^VA(200,PRNO,.13)) START
W !,"Phone: "_$P(^VA(200,PRNO,.13),"^"),! W:$P(^(.13),"^",2)]"" "Office: ",$P(^(.13),"^",2),!
W:$P(^VA(200,PRNO,.13),"^",3)]"" "Phone #3: "_$P(^(.13),"^",3),?40 W:$P(^(.13),"^",7)]"" "Voice Pager #: "_$P(^(.13),"^",7) W !
W:$P(^VA(200,PRNO,.13),"^",4)]"" "Phone #4: "_$P(^(.13),"^",4),?40 W:$P(^(.13),"^",8)]"" "Digital Pager#: "_$P(^(.13),"^",8)
W:$P(^VA(200,PRNO,.13),"^",6)]"" !,"Fax #: "_$P(^(.13),"^",6)
W:$P($G(^VA(200,PRNO,.14)),"^")]"" !,"Room Loc: "_$P(^(.14),"^")
G START
EX K DIC,DIE,DA,DR,D0,PRNO,PRCLS,STAT,T,Y,X,L,LF,I,DIR,DIROUT,DUOUT,DTOUT,DIRUT,%,%Y,%W,%Z,C,DDH,DI,DIH,DLAYGO,DQ,X1,XMDT,XMN
Q
ASK ;edit providers
K DIR,DTOUT,DUOUT,DIROUT,DIRUT
W !! S DIC("A")="Select Provider: ",(DIC,DIE)=200,DIC(0)="AEQMZ" D ^DIC G:"^"[X EX G:Y<0 ASK S (FADA,DA)=+Y
I '$D(^VA(200,DA,"PS")) G NPRV
ASK1 W @IOF,?25,"Provider: "_$P(^VA(200,DA,0),"^"),! F DR="TPB","PS",".11",".13",".14" D EN^DIQ
K DIC,Y
EDT W ! L +^VA(200,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
I '$T W $C(7),!!,"Provider Data is Being Edited by Another User!",! G QX
N RTPB S RTPB=$G(^VA(200,DA,"TPB"))
S DR="53.91" D ^DIE I $D(Y)!$D(DTOUT) G QX
I 'X,$G(PSOTPBFG) G QX
I X S DR="53.92R;53.93R;53.94R;53.95R"
E S DR="53.92;53.93;53.94;53.95"
S DR=DR_";D:X MS^PSOPRVW",DIE("NO^")="OUTOK" D ^DIE K DIE("NO^")
I '$D(^VA(200,DA,"TPB")),$G(PSOTPBFG) G QX
I $D(Y)!$D(DTOUT) D:$P($G(^VA(200,DA,"TPB")),"^",3) G QX
.I RTPB=""!('$P(RTPB,"^",3)) S DR="53.96////"_DUZ D ^DIE
I $P($G(^VA(200,DA,"TPB")),"^",3) D
.I RTPB=""!('$P(RTPB,"^",3)) S DR="53.96////"_DUZ D ^DIE
G:$G(PSOTPBFG) QX
ED1 ;S DR="53.1:53.6;I X'=4 S Y=""@1"";29;8932.1;@1;53.7;I 'X S Y=""@2"";53.8;@2;53.9;.111:.116;.131:.134;.136;.137;.138;.141",DR(2,200.05)=".01;2;3"
S DR="53.1:53.2;747.44;53.3:53.7;I 'X S Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141;.151;" ;IHS/MSC/PLS - 04/18/2011
D ^DIE S FADA=DA D:'$D(Y) KEY
QX K FADA,RTPB L -^VA(200,DA) Q:$G(PSOTPBFG) G:+$G(VADA) ADD G ASK
Q
G:'$D(^VA(200,DA,"TPB")) ED1
ADD ;add new providers (kernel 7)
W !
;IHS/MSC/PLS - 04/18/2011 - Added .151 and 747.44
;S VADA=$$ADD^XUSERNEW("53.91;S:'X Y=""@2"";53.92R;53.93R;53.94R;53.95R;D:X MS^PSOPRVW;@2;53.1;53.2;53.3;53.4;53.5;53.6;53.7;S:'X Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141")
S VADA=$$ADD^XUSERNEW("53.91;S:'X Y=""@2"";53.92R;53.93R;53.94R;53.95R;D:X MS^PSOPRVW;@2;53.1;53.2;747.44;53.3;53.4;53.5;53.6;53.7;S:'X Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141;.151")
S (FADA,DA)=+VADA,(DIC,DIE)="^VA(200,"
I VADA>0,$P(VADA,"^",3),$P($G(^VA(200,DA,"TPB")),"^") D
.S DR="53.96////"_DUZ D ^DIE
I VADA>0,'$P(VADA,"^",3) S DIC(0)="AEQMZ" G:'$D(^VA(200,+VADA,"PS")) NPRV G:$D(^VA(200,+VADA,"PS")) ASK1
D:VADA>0 KEY K DIK,DIC,Y,X,VADA,VA,DEA Q:$G(PSOTPBFG) K DA G EX
Q
NPRV W ! S DIR("A",1)=$P(^VA(200,DA,0),"^")_" is NOT currently indicated as being a provider.",DIR("A")="Do you want to make "_$P(^VA(200,DA,0),"^")_" a provider? (Y/N): ",DIR(0)="SA^1:YES;0:NO",DIR("B")="NO"
S DIR("?",1)="Answer with '1' or 'Yes' if "_$P(^VA(200,DA,0),"^")_" is to become a provider",DIR("?")="otherwise press return for 'No' and re-enter name." D ^DIR G:$D(DTOUT) EX
G:'Y!($D(DIRUT))&('+$G(VADA)) ASK G:'$P(+$G(VADA),"^",3)&('Y) ADD
G EDT
Q
KEY I $D(^VA(200,DA,"PS")) D
.I '$P(^VA(200,DA,"PS"),"^",4)!($P(^("PS"),"^",4)>DT) S PSOPDA=DA K DIC S DIC="^DIC(19.1,",DIC(0)="MZ",X="PROVIDER" D ^DIC K DIC S DA=PSOPDA K PSOPDA I +Y>0 S X=+Y D
..S:'$D(^VA(200,FADA,51,0)) ^VA(200,FADA,51,0)="^"_$P(^DD(200,51,0),"^",2)_"^^"
..S DIC="^VA(200,"_FADA_",51,",DIC(0)="LM",DIC("DR")="1////"_$S($G(DUZ):DUZ,1:"")_";2///"_DT,DLAYGO=200.051,DINUM=X,DA(1)=FADA
..L +^VA(200,FADA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) K DD,DO D FILE^DICN L -^VA(200,FADA) K DIC,DR,X,Y
Q
MS ;
W !!,$C(7),"This provider will not be selectable during TPB medication order entry!!",!
Q
PSOPRVW ;BIR/SAB,MHA-enter/edit/view provider ;29-May-2012 15:05;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**11,146,153,1011,263,268,264,1015**;DEC 1997;Build 62
+2 ;
+3 ;Ref. to ^VA(200 supp. by IA 224
+4 ;Ref. to ^DIC(7 supp. by IA 491
+5 ;Ref. to $$NPI^XUSNPI supp. by IA 4532
+6 ;Modified - IHS/MSC/PLS - 04/18/2011 - Line ED1 and ADD+2
START WRITE !
SET DIC("A")="Select Provider: "
SET DIC("S")="I $D(^VA(200,+Y,""PS""))"
SET DIC="^VA(200,"
SET DIC(0)="AEQMZ"
DO ^DIC
IF "^"[X
GOTO EX
IF Y<0
GOTO START
KILL DIC
SET PRNO=+Y
+1 WRITE @IOF,"Name: "_$PIECE(^VA(200,PRNO,0),"^")
+2 IF +$PIECE(^VA(200,PRNO,"PS"),"^",4)
IF $PIECE(^("PS"),"^",4)'>DT
WRITE ?40,$CHAR(7),"* * * INACTIVE AS OF ",$EXTRACT($PIECE(^("PS"),"^",4),4,5),"/",$EXTRACT($PIECE(^("PS"),"^",4),6,7),"/",$EXTRACT($PIECE(^("PS"),"^",4),2,3)," * * *"
+3 ;W !,"SSN#: " S T=$S($P(^VA(200,PRNO,1),"^",9)]"":$P(^(1),"^",9),1:"") W:T $E(T,1,3),"-",$E(T,4,5),"-",$E(T,6,9)
+4 WRITE !,"Initials: "_$PIECE(^VA(200,PRNO,0),"^",2)
+5 WRITE !,"NON-VA Prescriber: "
+6 IF $PIECE($GET(^VA(200,PRNO,"TPB")),"^")]""
WRITE $SELECT($PIECE(^("TPB"),"^"):"Yes",1:"No")
+7 WRITE ?40,"Tax ID: "_$PIECE($GET(^VA(200,PRNO,"TPB")),"^",2)
+8 WRITE !,"Exclusionary Check Performed: "
IF $PIECE($GET(^VA(200,PRNO,"TPB")),"^",3)]""
WRITE $SELECT($PIECE(^("TPB"),"^",3):"Yes",1:"No")
+9 WRITE ?40,"Date Exclusionary List Checked: "
+10 SET Y=$PIECE($GET(^VA(200,PRNO,"TPB")),"^",4)
IF Y
WRITE $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+11 WRITE !,"On Exclusionary List: "
IF $PIECE($GET(^VA(200,PRNO,"TPB")),"^",5)]""
WRITE $SELECT($PIECE(^("TPB"),"^",5):"Yes",1:"No")
+12 WRITE !,"Exclusionary Checked By: "
+13 IF $PIECE($GET(^VA(200,PRNO,"TPB")),"^",6)
WRITE $PIECE($GET(^VA(200,$PIECE(^("TPB"),"^",6),0)),"^")
+14 WRITE !,"Authorized to Write Orders: "_$SELECT($PIECE(^VA(200,PRNO,"PS"),"^"):"Yes",1:"No")
+15 WRITE !,"Requires Cosigner: "_$SELECT($PIECE(^("PS"),"^",7):"Yes",1:"No"),?40,"DEA# "_$PIECE(^VA(200,PRNO,"PS"),"^",2)
IF $PIECE(^("PS"),"^",7)
IF $DATA(^VA(200,+$PIECE(^("PS"),"^",8),0))
WRITE !,"Usual Cosigner: "_$PIECE(^(0),"^")
+16 WRITE !,"Class: "
SET PRCLS=+$PIECE(^VA(200,PRNO,"PS"),"^",5)
SET PRCLS=$SELECT(PRCLS>0&$DATA(^DIC(7,PRCLS,0)):$PIECE(^(0),"^"),1:"")
WRITE PRCLS,?40,"VA# "_$PIECE(^VA(200,PRNO,"PS"),"^",3)
+17 WRITE !," Type: "
SET T=+$PIECE(^("PS"),"^",6)
SET L=$PIECE(^DD(200,53.6,0),"^",3)_";"_T_":Unknown"
FOR I=1:1
IF $PIECE($PIECE(L,";",I),":",1)=T
WRITE $PIECE($PIECE(L,";",I),":",2)
QUIT
+18 NEW NPI
SET NPI=$PIECE($$NPI^XUSNPI("Individual_ID",PRNO),"^")
WRITE ?40,"NPI# "_$SELECT(NPI>0:+NPI,1:"")
+19 WRITE !,"Remarks: "_$PIECE(^VA(200,PRNO,"PS"),"^",9),!,"Synonym(s): "_$SELECT($PIECE($GET(^VA(200,PRNO,.1)),"^",4)]"":$PIECE(^(.1),"^",4)_",",1:"")_$SELECT($PIECE(^(0),"^",2)]"":" "_$PIECE(^(0),"^",2),1:"")
+20 WRITE !,"Service/Section: "
SET PSOSSDA=$GET(DA)
IF $PIECE($GET(^VA(200,PRNO,5)),"^")
KILL DIQ
SET DIC="^DIC(49,"
SET DA=$PIECE(^VA(200,PRNO,5),"^")
SET DR=.01
SET DIQ="PSOSECT"
SET DIQ(0)="E"
DO EN^DIQ1
WRITE $GET(PSOSECT(49,DA,.01,"E"))
SET DA=$GET(PSOSSDA)
KILL DR,DIC,DIQ,PSOSSDA,PSOSECT
+21 IF $TRANSLATE($GET(^VA(200,PRNO,.11)),"^","")=""
GOTO NUM
+22 WRITE !!,"Address: ",?10,$PIECE(^VA(200,PRNO,.11),"^")
IF $PIECE(^(.11),"^",2)'=""
WRITE !?10,$PIECE(^(.11),"^",2)
IF $PIECE(^(.11),"^",3)'=""
WRITE !?10,$PIECE(^(.11),"^",3)
+23 WRITE !?10,$PIECE(^VA(200,PRNO,.11),"^",4)
IF $PIECE(^(.11),"^",4)]""
WRITE ", "
SET STAT=+$PIECE($GET(^(.11)),"^",5)
WRITE $SELECT($DATA(^DIC(5,STAT,0)):$PIECE(^(0),"^"),1:"")_" "_$PIECE(^VA(200,PRNO,.11),"^",6)
NUM IF '$DATA(^VA(200,PRNO,.13))
GOTO START
+1 WRITE !,"Phone: "_$PIECE(^VA(200,PRNO,.13),"^"),!
IF $PIECE(^(.13),"^",2)]""
WRITE "Office: ",$PIECE(^(.13),"^",2),!
+2 IF $PIECE(^VA(200,PRNO,.13),"^",3)]""
WRITE "Phone #3: "_$PIECE(^(.13),"^",3),?40
IF $PIECE(^(.13),"^",7)]""
WRITE "Voice Pager #: "_$PIECE(^(.13),"^",7)
WRITE !
+3 IF $PIECE(^VA(200,PRNO,.13),"^",4)]""
WRITE "Phone #4: "_$PIECE(^(.13),"^",4),?40
IF $PIECE(^(.13),"^",8)]""
WRITE "Digital Pager#: "_$PIECE(^(.13),"^",8)
+4 IF $PIECE(^VA(200,PRNO,.13),"^",6)]""
WRITE !,"Fax #: "_$PIECE(^(.13),"^",6)
+5 IF $PIECE($GET(^VA(200,PRNO,.14)),"^")]""
WRITE !,"Room Loc: "_$PIECE(^(.14),"^")
+6 GOTO START
EX KILL DIC,DIE,DA,DR,D0,PRNO,PRCLS,STAT,T,Y,X,L,LF,I,DIR,DIROUT,DUOUT,DTOUT,DIRUT,%,%Y,%W,%Z,C,DDH,DI,DIH,DLAYGO,DQ,X1,XMDT,XMN
+1 QUIT
ASK ;edit providers
+1 KILL DIR,DTOUT,DUOUT,DIROUT,DIRUT
+2 WRITE !!
SET DIC("A")="Select Provider: "
SET (DIC,DIE)=200
SET DIC(0)="AEQMZ"
DO ^DIC
IF "^"[X
GOTO EX
IF Y<0
GOTO ASK
SET (FADA,DA)=+Y
+3 IF '$DATA(^VA(200,DA,"PS"))
GOTO NPRV
ASK1 WRITE @IOF,?25,"Provider: "_$PIECE(^VA(200,DA,0),"^"),!
FOR DR="TPB","PS",".11",".13",".14"
DO EN^DIQ
+1 KILL DIC,Y
EDT WRITE !
LOCK +^VA(200,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
+1 IF '$TEST
WRITE $CHAR(7),!!,"Provider Data is Being Edited by Another User!",!
GOTO QX
+2 NEW RTPB
SET RTPB=$GET(^VA(200,DA,"TPB"))
+3 SET DR="53.91"
DO ^DIE
IF $DATA(Y)!$DATA(DTOUT)
GOTO QX
+4 IF 'X
IF $GET(PSOTPBFG)
GOTO QX
+5 IF X
SET DR="53.92R;53.93R;53.94R;53.95R"
+6 IF '$TEST
SET DR="53.92;53.93;53.94;53.95"
+7 SET DR=DR_";D:X MS^PSOPRVW"
SET DIE("NO^")="OUTOK"
DO ^DIE
KILL DIE("NO^")
+8 IF '$DATA(^VA(200,DA,"TPB"))
IF $GET(PSOTPBFG)
GOTO QX
+9 IF $DATA(Y)!$DATA(DTOUT)
IF $PIECE($GET(^VA(200,DA,"TPB")),"^",3)
Begin DoDot:1
+10 IF RTPB=""!('$PIECE(RTPB,"^",3))
SET DR="53.96////"_DUZ
DO ^DIE
End DoDot:1
GOTO QX
+11 IF $PIECE($GET(^VA(200,DA,"TPB")),"^",3)
Begin DoDot:1
+12 IF RTPB=""!('$PIECE(RTPB,"^",3))
SET DR="53.96////"_DUZ
DO ^DIE
End DoDot:1
+13 IF $GET(PSOTPBFG)
GOTO QX
ED1 ;S DR="53.1:53.6;I X'=4 S Y=""@1"";29;8932.1;@1;53.7;I 'X S Y=""@2"";53.8;@2;53.9;.111:.116;.131:.134;.136;.137;.138;.141",DR(2,200.05)=".01;2;3"
+1 ;IHS/MSC/PLS - 04/18/2011
SET DR="53.1:53.2;747.44;53.3:53.7;I 'X S Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141;.151;"
+2 DO ^DIE
SET FADA=DA
IF '$DATA(Y)
DO KEY
QX KILL FADA,RTPB
LOCK -^VA(200,DA)
IF $GET(PSOTPBFG)
QUIT
IF +$GET(VADA)
GOTO ADD
GOTO ASK
+1 QUIT
+2 IF '$DATA(^VA(200,DA,"TPB"))
GOTO ED1
ADD ;add new providers (kernel 7)
+1 WRITE !
+2 ;IHS/MSC/PLS - 04/18/2011 - Added .151 and 747.44
+3 ;S VADA=$$ADD^XUSERNEW("53.91;S:'X Y=""@2"";53.92R;53.93R;53.94R;53.95R;D:X MS^PSOPRVW;@2;53.1;53.2;53.3;53.4;53.5;53.6;53.7;S:'X Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141")
+4 SET VADA=$$ADD^XUSERNEW("53.91;S:'X Y=""@2"";53.92R;53.93R;53.94R;53.95R;D:X MS^PSOPRVW;@2;53.1;53.2;747.44;53.3;53.4;53.5;53.6;53.7;S:'X Y=""@1"";53.8;@1;53.9;.111:.116;.131:.134;.136;.141;.151")
+5 SET (FADA,DA)=+VADA
SET (DIC,DIE)="^VA(200,"
+6 IF VADA>0
IF $PIECE(VADA,"^",3)
IF $PIECE($GET(^VA(200,DA,"TPB")),"^")
Begin DoDot:1
+7 SET DR="53.96////"_DUZ
DO ^DIE
End DoDot:1
+8 IF VADA>0
IF '$PIECE(VADA,"^",3)
SET DIC(0)="AEQMZ"
IF '$DATA(^VA(200,+VADA,"PS"))
GOTO NPRV
IF $DATA(^VA(200,+VADA,"PS"))
GOTO ASK1
+9 IF VADA>0
DO KEY
KILL DIK,DIC,Y,X,VADA,VA,DEA
IF $GET(PSOTPBFG)
QUIT
KILL DA
GOTO EX
+10 QUIT
NPRV WRITE !
SET DIR("A",1)=$PIECE(^VA(200,DA,0),"^")_" is NOT currently indicated as being a provider."
SET DIR("A")="Do you want to make "_$PIECE(^VA(200,DA,0),"^")_" a provider? (Y/N): "
SET DIR(0)="SA^1:YES;0:NO"
SET DIR("B")="NO"
+1 SET DIR("?",1)="Answer with '1' or 'Yes' if "_$PIECE(^VA(200,DA,0),"^")_" is to become a provider"
SET DIR("?")="otherwise press return for 'No' and re-enter name."
DO ^DIR
IF $DATA(DTOUT)
GOTO EX
+2 IF 'Y!($DATA(DIRUT))&('+$GET(VADA))
GOTO ASK
IF '$PIECE(+$GET(VADA),"^",3)&('Y)
GOTO ADD
+3 GOTO EDT
+4 QUIT
KEY IF $DATA(^VA(200,DA,"PS"))
Begin DoDot:1
+1 IF '$PIECE(^VA(200,DA,"PS"),"^",4)!($PIECE(^("PS"),"^",4)>DT)
SET PSOPDA=DA
KILL DIC
SET DIC="^DIC(19.1,"
SET DIC(0)="MZ"
SET X="PROVIDER"
DO ^DIC
KILL DIC
SET DA=PSOPDA
KILL PSOPDA
IF +Y>0
SET X=+Y
Begin DoDot:2
+2 IF '$DATA(^VA(200,FADA,51,0))
SET ^VA(200,FADA,51,0)="^"_$PIECE(^DD(200,51,0),"^",2)_"^^"
+3 SET DIC="^VA(200,"_FADA_",51,"
SET DIC(0)="LM"
SET DIC("DR")="1////"_$SELECT($GET(DUZ):DUZ,1:"")_";2///"_DT
SET DLAYGO=200.051
SET DINUM=X
SET DA(1)=FADA
+4 LOCK +^VA(200,FADA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
KILL DD,DO
DO FILE^DICN
LOCK -^VA(200,FADA)
KILL DIC,DR,X,Y
End DoDot:2
End DoDot:1
+5 QUIT
MS ;
+1 WRITE !!,$CHAR(7),"This provider will not be selectable during TPB medication order entry!!",!
+2 QUIT
