source: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVER6.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1PSAVER6 ;BIR/JMB-Verify Invoices - CONT'D ;10/3/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**1,3,21,42,53,57,61,64**; 10/24/97;Build 4
3 ;Background Job:
4 ;References to ^PSDRUG( are covered by IA #2095
5 ;This routine increments pharmacy location and master vault balances
6 ;in 58.8 after invoices have been verified.
7 ;
8START ;|=> *42 add Post Verify variance report
9 K ^TMP($J,"PSADD")
10 K DIC,DA,DR,DIE ;|=> *52 MOVE POST VERIFY E-MAIL LOGIC FROM START+17
11 S PSAIEN=0 F S PSAIEN=+$O(PSAVBKG(PSAIEN)) Q:'PSAIEN D
12 .Q:'$D(^PSD(58.811,PSAIEN,0))
13 .S PSAORD=$P(^PSD(58.811,PSAIEN,0),"^"),PSAVEND=$P(^(0),"^",2),PSAIEN1=0
14 .F S PSAIEN1=+$O(PSAVBKG(PSAIEN,PSAIEN1)) Q:'PSAIEN1 D
15 ..Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
16 ..D SCANDIF ; *57 <=|
17 S PSAIEN=0 F S PSAIEN=+$O(PSAVBKG(PSAIEN)) Q:'PSAIEN D
18 .Q:'$D(^PSD(58.811,PSAIEN,0))
19 .S PSAORD=$P(^PSD(58.811,PSAIEN,0),"^"),PSAVEND=$P(^(0),"^",2),PSAIEN1=0
20 .F S PSAIEN1=+$O(PSAVBKG(PSAIEN,PSAIEN1)) Q:'PSAIEN1 D
21 ..Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
22 ..S PSAIN=^PSD(58.811,PSAIEN,1,PSAIEN1,0)
23 ..K DIC,DA,DR,DIE
24 ..I +$P(PSAIN,"^",13) K DA S DIE="^PSD(58.811,"_PSAIEN_",1,",DA(1)=PSAIEN,DA=PSAIEN1,DR="2////C" D ^DIE K DIE,DA,DR Q
25 ..S PSAINV=$P(PSAIN,"^"),PSAINVDT=$P(PSAIN,"^",2),PSALINE=0
26 ..F S PSALINE=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)) Q:'PSALINE D
27 ...Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
28 ...S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0) D GETDATA I 'PSASUP,'$D(PSA0QTY) D FILE ;PSA*3*42
29 ..K DIC,DA,DR,DIE
30 ..K DA S DIE="^PSD(58.811,"_PSAIEN_",1,",DA(1)=PSAIEN,DA=PSAIEN1,DR="2////C" D ^DIE K DIE,DA,DR
31 ;;*57 => START+17 THRU START+22 MOVED TO START+3 <=|
32 ; *42 <=|
33EXIT ;Kills variables
34 K %,DA,DD,DIC,DIE,DINUM,DLAYGO,DO,PSA,PSAA,PSABAL,PSACBAL,PSACNT,PSACNT,PSACOD,PSACOST,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJO,PSADJP,PSADJQ
35 K PSADRG,PSADT,PSADUOU,PSADUQTY,PSADUREC,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAINVDT,PSALEN,PSALINE,PSALOC,PSAMSG,PSANDC,PSANODE,PSANPDU,PSANPOU
36 K PSAODASH,PSAONDC,PSAORD,PSAOU,PSAPDU,PSAPOU,PSAQTY,PSAREORD,PSASET,PSASTOCK,PSASUP,PSAT,PSATDRG,PSATEMP,PSAVBKG,PSAVDUZ,PSAVEND,PSAVSN,X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y
37 K PSA0QTY
38 Q
39 ;
40GETDATA ;Gets invoice data to help file the data
41 S PSAVDUZ=$P(PSADATA,"^",9),PSASUP=0
42 S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
43 I '$G(PSADJ) S PSADRG=$S(+$P(PSADATA,"^",2):+$P(PSADATA,"^",2),1:0) G CS
44 I $G(PSADJ) D
45 .S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
46 .S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
47 .I PSADJD'?1.N S PSASUP=1
48 .S PSADRG=$S(PSADJ&('PSASUP):+PSADJD,PSADJ&(PSASUP):0,1:+$P(PSADATA,"^",2))
49 .I +PSADJD,$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" S PSADRG=+PSADJD Q
50 .I +PSADJD,$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q
51CS Q:PSASUP!('PSADRG)
52 S PSACS=$S(+$P(PSADATA,"^",10):1,1:0)
53 S PSADJQ=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0))
54 I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
55 ;
56 ;PSA*3*1 (DAVE B)
57 S PSAQTY=$S(($G(PSADJQ)'=""&(+PSADJ)):PSADJQ,1:+$P(PSADATA,"^",3))
58 S PSAOU=$S(+$P(PSADATA,"^",4):+$P(PSADATA,"^",4),1:"")
59 ;
60 ;DAVE B (PSA*3*3)
61 ;I +$P($P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",5),"~",2) S PSAOU=$P($P($G(^(2)),"^",5),"~",2)
62 ;
63 S PSADJO=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0))
64 I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
65 S:$G(PSADJO) PSAOU=$G(PSADJO)
66 S PSANDC=$P(PSADATA,"^",11) D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX
67 S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0))
68 I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2))
69 S (PSAPOU,PSANPOU)=$S($G(PSADJP):PSADJP,1:+$P(PSADATA,"^",5)),PSALEN=$L($P(PSANPOU,".")),(PSAPOU,PSANPOU)=$J(PSANPOU,PSALEN,2)
70 S PSAVSN=$P(PSADATA,"^",12)
71 S PSALOC=$S(+PSACS:+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",5))
72TEMP S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
73 S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4)
74 S PSADUOU=$S(+PSADUOU:+PSADUOU,+PSASUB&(+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7),1:1)
75 S PSADUREC=$S(PSADUOU:PSAQTY*PSADUOU,1:0)
76 ;
77 ;DAVE B (18NOV98)
78 I PSADUREC=0,$D(PSAQTY),$P($G(^PSDRUG(PSADRG,660)),"^",5)'="" S PSADUREC=(PSAQTY*($P(^PSDRUG(PSADRG,660),"^",5)))
79 Q:'+$P($G(^PSD(58.8,PSALOC,0)),"^",14)
80 S PSAREORD=$S(+PSAREORD:+PSAREORD,+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5):+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5),1:0)
81 S PSASTOCK=$S(+PSASTOCK:+PSASTOCK,+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3):+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3),1:0)
82 K PSA0QTY I '$G(PSAQTY),'$G(PSADJQ) S PSA0QTY=1 Q ;PSA*3*42 (0 QTY)
83 Q
84 ;
85FILE ;File data in 58.8
86 I $D(PSADUREC),PSADUREC'>0 S PSADUREC=$S($D(PSADJQ):PSADJQ,$D(PSAQTY):PSAQTY,1:0)
87 D NOW^%DTC S PSADT=+$E(%,1,14)
88 I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
89 .K DIC,DA,DR,DIE
90 .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)
91 .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8
92 .F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
93 .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO
94 .D MM ;*42 send mailmessage
95 F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
96 S PSABAL=+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
97 ;
98 ;DAVE B (PSA*3*3)
99 I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
100 S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
101 I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D
102 .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
103 .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
104 S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)
105 I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D
106 .K DIC,DA,DR,DIE
107 .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)"
108 .S (X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC("DR")
109 .S X="T-1M" D ^%DT S (X,DINUM)=$E(Y,1,5)*100,DA=PSADRG D ^DIC K DIC,DLAYGO
110 .K DIC,DA,DR,DIE
111 .S DA=+Y,DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DR="3////^S X=$G(PSABAL)" D ^DIE K DIE
112 K DIC,DA,DR,DIE
113 S DA=$E(DT,1,5)*100
114 S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="3////^S X=($G(PSABAL)+$G(PSADUREC));5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE
115 L -^PSD(58.8,PSALOC,1,PSADRG,0)
116 G TR^PSAVER7
117MM ;
118 ;*42 Mail Message to holders of PSDMGR, PSAMGR key
119 ;*53 Consolidate messages
120 N PSACS S PSACS=$S($$GET1^DIQ(50,PSADRG,63)["N":" Controlled Substance ",1:"")
121 S ^TMP($J,"PSADD",$$GET1^DIQ(58.8,PSALOC,.01),$$GET1^DIQ(50,PSADRG,.01))=""
122 Q
123SCANDIF ;*42 inspect invoice for noted differences in OU,DUOU,PPDU,NDC
124 ;NEEDS PSAIEN, PSAIEN1
125 K ^TMP($J,"PSADIF"),PSADIFLC
126 S PSALINE=0 F S PSALINE=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)) Q:PSALINE'>0 D CHECK^PSAPROC7 ;checks and stores differences in ^TMP($J,
127 I $D(^TMP($J,"PSADD")) D ADDMM
128 I $D(^TMP($J,"PSADIF")) D MESSAGE
129 Q
130MESSAGE ;differences found, notify user and send message to g.PSA NDC UPDATES.
131 K DIR N IENS
132 S PSAORD=$$GET1^DIQ(58.811,PSAIEN,.01),IENS=PSAIEN1_","_PSAIEN
133 S PSAINV=$$GET1^DIQ(58.8112,IENS,.01)
134 S XMSUB="POST Verify Variance Report Ord: "_PSAORD_" Inv: "_PSAINV ;*52
135 S ^TMP($J,"PSADIF",1,0)=XMSUB,^TMP($J,"PSADIF",2,0)=" "
136 S XMTEXT="^TMP($J,""PSADIF"",",XMY("G.PSA NDC UPDATES")=""
137 S XMDUZ="Price & NDC Updater"
138 D ^XMD
139 K PSADIFLC,^TMP($J,"PSADIF")
140 Q
141ADDMM ; SEND MESSAGE REGARDING DRUGS ADDED TO PHARMACY LOCATIONS
142 K ^TMP($J,"PSADDMM")
143 S XMSUB="New Drugs Added by Order: "_$G(PSAORD)_" Invoice: "_$G(PSAINV)
144 S XMDUZ="Verified by: "_$$GET1^DIQ(200,DUZ,.01)
145 S LC=0,X=XMSUB D MMLINE S X=XMDUZ D MMLINE
146 S X="Please use DA and CS menus to populate the balances, stock and re-order levels." D MMLINE
147 S PSALOC="" F S PSALOC=$O(^TMP($J,"PSADD",PSALOC)) Q:PSALOC="" D
148 . S X=PSALOC D MMLINE
149 . S PSADRG="" F S PSADRG=$O(^TMP($J,"PSADD",PSALOC,PSADRG)) Q:PSADRG="" S X=" "_PSADRG D MMLINE
150 S XMTEXT="^TMP($J,""PSADDMM"","
151 S XMY("G.PSA NDC UPDATES")=""
152 D ^XMD
153 K ^TMP($J,"PSADD"),^TMP($J,"PSADDMM"),LC
154 Q
155MMLINE S LC=LC+1,^TMP($J,"PSADDMM",LC,0)=X W !,X Q
Note: See TracBrowser for help on using the repository browser.