source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPRVW.m@ 767

Last change on this file since 767 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.2 KB
RevLine 
[613]1PSOPRVW ;BIR/SAB,MHA-enter/edit/view provider ; 2/9/07 10:39am
2 ;;7.0;OUTPATIENT PHARMACY;**11,146,153,263,268,264**;DEC 1997;Build 19
3 ;
4 ;Ref. to ^VA(200 supp. by IA 224
5 ;Ref. to ^DIC(7 supp. by IA 491
6 ;Ref. to $$NPI^XUSNPI supp. by IA 4532
7 ;
8START 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
9 W @IOF,"Name: "_$P(^VA(200,PRNO,0),"^")
10 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)," * * *"
11 ;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)
12 W !,"Initials: "_$P(^VA(200,PRNO,0),"^",2)
13 W !,"NON-VA Prescriber: "
14 I $P($G(^VA(200,PRNO,"TPB")),"^")]"" W $S($P(^("TPB"),"^"):"Yes",1:"No")
15 W ?40,"Tax ID: "_$P($G(^VA(200,PRNO,"TPB")),"^",2)
16 W !,"Exclusionary Check Performed: " I $P($G(^VA(200,PRNO,"TPB")),"^",3)]"" W $S($P(^("TPB"),"^",3):"Yes",1:"No")
17 W ?40,"Date Exclusionary List Checked: "
18 S Y=$P($G(^VA(200,PRNO,"TPB")),"^",4) I Y W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
19 W !,"On Exclusionary List: " I $P($G(^VA(200,PRNO,"TPB")),"^",5)]"" W $S($P(^("TPB"),"^",5):"Yes",1:"No")
20 W !,"Exclusionary Checked By: "
21 I $P($G(^VA(200,PRNO,"TPB")),"^",6) W $P($G(^VA(200,$P(^("TPB"),"^",6),0)),"^")
22 W !,"Authorized to Write Orders: "_$S($P(^VA(200,PRNO,"PS"),"^"):"Yes",1:"No")
23 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),"^")
24 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)
25 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
26 N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",PRNO),"^") W ?40,"NPI# "_$S(NPI>0:+NPI,1:"")
27 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:"")
28 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
29 I $TR($G(^VA(200,PRNO,.11)),"^","")="" G NUM
30 W !!,"Address: ",?10,$P(^VA(200,PRNO,.11),"^") W:$P(^(.11),"^",2)'="" !?10,$P(^(.11),"^",2) W:$P(^(.11),"^",3)'="" !?10,$P(^(.11),"^",3)
31 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)
32NUM G:'$D(^VA(200,PRNO,.13)) START
33 W !,"Phone: "_$P(^VA(200,PRNO,.13),"^"),! W:$P(^(.13),"^",2)]"" "Office: ",$P(^(.13),"^",2),!
34 W:$P(^VA(200,PRNO,.13),"^",3)]"" "Phone #3: "_$P(^(.13),"^",3),?40 W:$P(^(.13),"^",7)]"" "Voice Pager #: "_$P(^(.13),"^",7) W !
35 W:$P(^VA(200,PRNO,.13),"^",4)]"" "Phone #4: "_$P(^(.13),"^",4),?40 W:$P(^(.13),"^",8)]"" "Digital Pager#: "_$P(^(.13),"^",8)
36 W:$P(^VA(200,PRNO,.13),"^",6)]"" !,"Fax #: "_$P(^(.13),"^",6)
37 W:$P($G(^VA(200,PRNO,.14)),"^")]"" !,"Room Loc: "_$P(^(.14),"^")
38 G START
39EX 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
40 Q
41ASK ;edit providers
42 K DIR,DTOUT,DUOUT,DIROUT,DIRUT
43 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
44 I '$D(^VA(200,DA,"PS")) G NPRV
45ASK1 W @IOF,?25,"Provider: "_$P(^VA(200,DA,0),"^"),! F DR="TPB","PS",".11",".13",".14" D EN^DIQ
46 K DIC,Y
47EDT W ! L +^VA(200,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
48 I '$T W $C(7),!!,"Provider Data is Being Edited by Another User!",! G QX
49 N RTPB S RTPB=$G(^VA(200,DA,"TPB"))
50 S DR="53.91" D ^DIE I $D(Y)!$D(DTOUT) G QX
51 I 'X,$G(PSOTPBFG) G QX
52 I X S DR="53.92R;53.93R;53.94R;53.95R"
53 E S DR="53.92;53.93;53.94;53.95"
54 S DR=DR_";D:X MS^PSOPRVW",DIE("NO^")="OUTOK" D ^DIE K DIE("NO^")
55 I '$D(^VA(200,DA,"TPB")),$G(PSOTPBFG) G QX
56 I $D(Y)!$D(DTOUT) D:$P($G(^VA(200,DA,"TPB")),"^",3) G QX
57 .I RTPB=""!('$P(RTPB,"^",3)) S DR="53.96////"_DUZ D ^DIE
58 I $P($G(^VA(200,DA,"TPB")),"^",3) D
59 .I RTPB=""!('$P(RTPB,"^",3)) S DR="53.96////"_DUZ D ^DIE
60 G:$G(PSOTPBFG) QX
61ED1 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"
62 D ^DIE S FADA=DA D:'$D(Y) KEY
63QX K FADA,RTPB L -^VA(200,DA) Q:$G(PSOTPBFG) G:+$G(VADA) ADD G ASK
64 Q
65 G:'$D(^VA(200,DA,"TPB")) ED1
66ADD ;add new providers (kernel 7)
67 W !
68 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")
69 S (FADA,DA)=+VADA,(DIC,DIE)="^VA(200,"
70 I VADA>0,$P(VADA,"^",3),$P($G(^VA(200,DA,"TPB")),"^") D
71 .S DR="53.96////"_DUZ D ^DIE
72 I VADA>0,'$P(VADA,"^",3) S DIC(0)="AEQMZ" G:'$D(^VA(200,+VADA,"PS")) NPRV G:$D(^VA(200,+VADA,"PS")) ASK1
73 D:VADA>0 KEY K DIK,DIC,Y,X,VADA,VA,DEA Q:$G(PSOTPBFG) K DA G EX
74 Q
75NPRV 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"
76 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
77 G:'Y!($D(DIRUT))&('+$G(VADA)) ASK G:'$P(+$G(VADA),"^",3)&('Y) ADD
78 G EDT
79 Q
80KEY I $D(^VA(200,DA,"PS")) D
81 .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
82 ..S:'$D(^VA(200,FADA,51,0)) ^VA(200,FADA,51,0)="^"_$P(^DD(200,51,0),"^",2)_"^^"
83 ..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
84 ..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
85 Q
86MS ;
87 W !!,$C(7),"This provider will not be selectable during TPB medication order entry!!",!
88 Q
Note: See TracBrowser for help on using the repository browser.