source: FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAVER3.m@ 1639

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1PSAVER3 ;BIR/JMB-Verify Invoices - CONT'D ;9/5/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,19,21,64**; 10/24/97;Build 4
3 ;This routine checks for verification errors, prints an error report,
4 ;& changes data in DA ORDERS to verification if there are no errors.
5 ;
6 ;References to ^DIC(51.5 are covered by IA #1931
7 ;References to ^PSDRUG( are covered by IA #2095
8 ;
9SETLINE ;Set line as verified if all data is present.
10 K PSADRG,PSAOU,PSAQTY S (PSADJN,PSADJ)=0
11 S PSADATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
12 I $O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,0)) D
13 .S PSAA=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,0)) Q:PSAA=2
14 .S PSADJ=0 F S PSADJ=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ)) Q:'PSADJ D
15 ..Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
16 ..S PSADJN=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)
17 ..I $P(PSADJN,"^")="D" D
18 ...I (+$P(PSADJN,"^",9)&($P(PSADJN,"^",6)'?.N))!('+$P(PSADJN,"^",9)&(+$P(PSADJN,"^",5))&($P(PSADJN,"^",2)'?.N)) S PSASUP=PSASUP+1,PSALNSU=1,PSADRG=0 Q
19 ...S PSADRG=$S($P(PSADJN,"^",6)'="":$P(PSADJN,"^",6),$P(PSADJN,"^",2)'="":$P(PSADJN,"^",2),1:0)
20 ..I $P(PSADJN,"^")="O" S PSAOU=$S(+$P(PSADJN,"^",6):+$P(PSADJN,"^",6),+$P(PSADJN,"^",2):+$P(PSADJN,"^",2),1:0)
21 ..I $P(PSADJN,"^")="Q" S PSAQTY=$S($P(PSADJN,"^",6)'="":+$P(PSADJN,"^",6),$P(PSADJN,"^",2)'="":+$P(PSADJN,"^",2),1:0)
22 S:'$G(PSADRG) PSADRG=+$P(PSADATA,"^",2) S:'$D(PSAQTY) PSAQTY=+$P(PSADATA,"^",3)
23 ;DAVE B (13SEP99) PSA*3*19 If item is supply, skip this area
24 I $G(PSALNSU)=1,$G(PSADRG)=0,$G(PSASUP)>0 G SUPPLY
25 S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),PSANDC=$P(PSADATA,"^",11)
26 ;DAVE B (PSA*3*19) Check for exisitence of NDC
27 S PSASUB=$S(+$P(PSATEMP,"^",3):+$P(PSATEMP,"^",3),1:0) ;NDC may be zero
28 I $G(PSANDC)'="",$G(PSANDC)'=0,$G(PSADRG)'="",$G(PSADRG)'=0,$D(^PSDRUG("C",PSANDC,PSADRG)) S PSASUB=$S($G(PSASUB):$G(PSASUB),+$O(^PSDRUG("C",PSANDC,PSADRG,0)):+$O(^PSDRUG("C",PSANDC,PSADRG,0)),1:0)
29 S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASTOCK=+$P(PSATEMP,"^",4)
30 I '$D(PSAOU) D
31 .I +$P(PSADATA,"^",4),$P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^")'="" S PSAOU=+$P(PSADATA,"^",4) Q
32 .I PSADRG,PSASUB,$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",5) S PSAOU=$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",5) Q
33 .I $P(PSATEMP,"^",5)'="",+$P($P(PSATEMP,"^",5),"~",2) S PSAOU=+$P($P(PSATEMP,"^",5),"~",2)
34 I PSASUB D
35 .;Next line added 8APR98 (Dave B)
36 .S PSALOC=$S($G(PSALOC)'="":PSALOC,1:$S($P(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",12):$P(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",12),$P(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",5):$P(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",5),1:0))
37 .S:'PSADUOU PSADUOU=$S(PSADRG&(+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7),1:1)
38 .S:'PSASTOCK PSASTOCK=$S(PSADRG:+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3),1:0)
39 .S:'PSAREORD PSAREORD=$S(PSADRG:+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5),1:0)
40 ;
41SUPPLY ;If it is a supply, automatically verify it.
42 I '+$G(PSAERR),PSALNSU,'$G(PSAPRINT) D VERIFY,VERIFY1 Q
43 ;
44NEWDRUG ;Store in array if drug is new to location/vault
45 I +PSADRG D
46 .I $P($G(^PSDRUG(PSADRG,2)),"^",3)["N",+$P(PSAIN,"^",12),'$D(^PSD(58.8,+$P(PSAIN,"^",12),1,PSADRG,0)) D
47 ..S PSAHOLD(+$P(PSAIN,"^",12),PSAIEN,PSAIEN1,$S($P($G(^PSDRUG(PSADRG,0)),"^")'="":$P($G(^PSDRUG(PSADRG,0)),"^"),1:"UNKNOWN"))=PSADRG,$P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),"^",10)=1
48 .I $P($G(^PSDRUG(PSADRG,2)),"^",3)'["N",+$P(PSAIN,"^",5),'$D(^PSD(58.8,+$P(PSAIN,"^",5),1,PSADRG,0)) D
49 ..S PSAHOLD(+$P(PSAIN,"^",5),PSAIEN,PSAIEN1,$S($P($G(^PSDRUG(PSADRG,0)),"^")'="":$P($G(^PSDRUG(PSADRG,0)),"^"),1:"UNKNOWN"))=PSADRG,$P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),"^",10)=0
50 ;
51NOTSUP ;If it is not a supply, look for drug, qty, dispense units, dispense
52 ;units/order unit, order unit, location/master vault, & reorder level
53 I '+$P(PSADATA,"^",2)&('$G(PSADRG)) S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_"D"
54 I $P(PSADATA,"^",3)=""&($G(PSAQTY)="") S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_"Q"
55 I $P($G(^PSDRUG(PSADRG,660)),"^",8)="" S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_8
56 I '+$P($G(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",7)&('+$G(PSADUOU)) S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_"U"
57 I '+$P(PSADATA,"^",4)&('$G(PSAOU)) S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_"O"
58 ;
59 I $P($G(^PSDRUG(PSADRG,2)),"^",3)'["N" D
60 .I '+$P(PSAIN,"^",5) S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_"P" D CS^PSAVER5
61 .S $P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),"^",10)=0,PSADATA=^(0)
62 I $P(PSAIN,"^",8)="N"!($P(PSAIN,"^",8)="S"),'+$P(PSAIN,"^",5),$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))'["P" S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_"P"
63 ;
64 I $P($G(^PSDRUG(PSADRG,2)),"^",3)["N" D
65 .I '+$P(PSAIN,"^",12) S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_"M" D CS^PSAVER5
66 .S $P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),"^",10)=1,PSADATA=^(0)
67 I $P(PSAIN,"^",8)="A"!($P(PSAIN,"^",8)="S"),'+$P(PSAIN,"^",12),$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))'["M" S PSANOVER(PSAIEN,PSAIEN1,PSALINE)=$G(PSANOVER(PSAIEN,PSAIEN1,PSALINE))_"M"
68 ;
69 S:$D(PSANOVER(PSAIEN,PSAIEN1,PSALINE)) PSAERR=PSAERR+1,PSALNERR=1
70 I 'PSAERR D GOOD Q
71 Q
72 ;
73GOOD ;If no errors found, verify invoice.
74 D VERIFY,VERIFY1
75 S PSAL=0 F S PSAL=+$O(PSAHOLD(PSAL)) Q:'PSAL D
76 .S PSANAME="" F S PSANAME=$O(PSAHOLD(PSAL,PSAIEN,PSAIEN1,PSANAME)) Q:PSANAME="" D
77 ..S PSANEWD(PSAL,PSANAME)=PSAHOLD(PSAL,PSAIEN,PSAIEN1,PSANAME)
78 K PSAHOLD
79 Q
80 ;
81PRINT ;Prints verification error list
82 S DIR(0)="Y",DIR("A")="Do you want to print the verification error report",DIR("B")="N"
83 S DIR("?",1)="Enter YES if you want to print the report just displayed.",DIR("?")="Enter NO if you do not want to print the report.",DIR("??")="^D PRINTYN^PSAVER3"
84 D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q
85 Q:Y=""!('+Y)
86 W ! S %ZIS="Q" D ^%ZIS Q:POP
87 I $D(IO("Q")) D Q
88 .S ZTDESC="Drug Acct. - Print Prime Vendor Invoices",ZTRTN="PRN^PSAVER3"
89 .I $O(PSANOVER(0))'="" S ZTSAVE("PSANOVER(")=""
90 .F PSASAVE="PSAIN","PSASLN" S:$D(@PSASAVE) ZTSAVE(PSASAVE)=""
91 .D ^%ZTLOAD
92PRN ;Entry point to print verification errors
93 S (PSAERR,PSALINE,PSAOUT,PSAPG)=0,PSAPRINT=1
94 S PSAIEN=0 F S PSAIEN=$O(PSANOVER(PSAIEN)) Q:'PSAIEN!(PSAOUT) D
95 .Q:'$D(^PSD(58.811,PSAIEN,0)) S PSAORD=$P(^PSD(58.811,PSAIEN,0),"^")
96 .S PSAIEN1=0 F S PSAIEN1=$O(PSANOVER(PSAIEN,PSAIEN1)) Q:'PSAIEN1!(PSAOUT) D
97 ..Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0)) S PSAIN=^PSD(58.811,PSAIEN,1,PSAIEN1,0),PSAINV=$P(PSAIN,"^")
98 ..S PSALINE=0 F S PSALINE=$O(PSANOVER(PSAIEN,PSAIEN1,PSALINE)) Q:'PSALINE!(PSAOUT) D
99 ...D NOVER
100 .K PSANOVER(PSAIEN)
101 W !!,"** The invoice has not been placed in a Verified status!",!
102 D:$E(IOST,1,2)="C-" END^PSAPROC W:$E(IOST)'="C" @IOF
103 D ^%ZISC
104 Q
105 ;
106NOVER ;Prints errors
107 S PSANO=PSANOVER(PSAIEN,PSAIEN1,PSALINE),PSALEN=$L(PSANO)
108 S PSALINEN=$P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)),"^"),PSATAB=$L(PSALINEN)+8
109 I $E(IOST,1,2)="C-" D:'PSAPG HDR I $Y+(4+PSALEN)>IOSL D END^PSAPROC Q:PSAOUT D HDR
110 I $E(IOST)'="C",$Y+(4+PSALEN)>IOSL!('PSAPG) D HDR
111 W "Line# "_PSALINEN_": "
112 W:PSANO[8 ?PSATAB,"Dispense unit",!
113 W:PSANO["U" ?PSATAB,"Dispense unit per order unit",!
114 W:PSANO["D" ?PSATAB,"Drug",!
115 I PSANO["M" W ?PSATAB,"Master Vault",!
116 W:PSANO["O" ?PSATAB,"Order unit",!
117 I PSANO["P" W ?PSATAB,"Pharmacy location",!
118 W:PSANO["Q" ?PSATAB,"Quantity",!
119 W !
120 Q
121 ;
122HDR ;Prints header
123 I $E(IOST,1,2)="C-" W @IOF,!?23,"<<< VERIFICATION ERROR REPORT >>>"
124 I $E(IOST)'="C" W:PSAPG'=1 @IOF W !?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE",!?27,"VERIFICATION ERROR REPORT",?72,"Page "_PSAPG,!
125 S PSAPG=PSAPG+1
126 W !,"Order#: "_PSAORD_" Invoice#: "_$P(PSAIN,"^")_" Invoice Date: "_$$FMTE^XLFDT(+$P(PSAIN,"^",2)) W:'$G(PSAERR) !,PSASLN,!
127 I $G(PSAERR) W !!,"The following line numbers' status cannot be changed to Verified.",!,"The fields that contain an error or need data are listed with the line item.",!,PSASLN,!
128 Q
129 ;
130STATUS ;Sets invoice's status to Verified
131 ;
132 ;PSA*3*3 (DAVE B)
133 S DA=PSAIEN1,DA(1)=PSAIEN,DIE="^PSD(58.811,"_DA(1)_",1,",DR="2///V;12////^S X="_DUZ
134 F L +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
135 D ^DIE L -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
136 K DIE
137 Q
138 ;
139VERIFY ;Set line item to verified
140 I PSADRG,$P($G(^PSDRUG(PSADRG,2)),"^",3)["N" S PSACSLN=1
141 E S PSACSLN=0
142 K DA S DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN,DIE="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,",DR="7///^S X="_DT_";8////^S X="_DUZ_";12///^S X=PSACSLN"
143 F L +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
144 D ^DIE L -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
145 K DIE
146 Q
147 ;
148VERIFY1 ;Set adjs if entire invioce was verified
149 S DA=0 F S DA=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,DA)) Q:'DA D
150 .Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,DA,0))
151 .Q:$P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,DA,0),"^",9)=DUZ
152 .S PSAREA="",PSADJ=$P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,DA,0),"^",2) D ADJ^PSAVER2
153 Q
154 ;
155DDQOR ;Extended help for 'Edit field'
156 W !?5,"Enter the number or range of numbers of the field you want to edit.",!?5,"For example, 1-3 or 1,3"
157 Q
158LNHELP ;Extended help for 'Line Number"
159 W !?5,"Enter the number of the item on the invoice you want to edit.",!?5,"You may enter several line item numbers separated by comas.",!!?5,"Do NOT enter a range of numbers separated by a dash."
160 Q
161PRINTYN ;Extended help for 'Print verification report'
162 W !?5,"Enter YES to print the Verification Error Report on a printer.",!?5,"Enter NO if you do not want to print the report."
163 Q
Note: See TracBrowser for help on using the repository browser.