- 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
