Changeset 636 for FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (15 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 13 edited
- 1 copied
-
. (copied) (copied from FOIAVistA/trunk/r )
-
DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m (modified) (3 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m (modified) (2 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAENTO.m (modified) (3 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m (modified) (2 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m (modified) (2 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAPROC7.m (modified) (3 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAUDP.m (modified) (3 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAUP4.m (modified) (3 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m (modified) (3 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m (modified) (2 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAVER7.m (modified) (4 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAVERA.m (modified) (5 diffs)
-
DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m
r628 r636 1 1 PSABRKU3 ;BIR/JMB/PDW-Upload and Process Prime Vendor Invoice Data - CONT'D ;8/13/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26,41,47 ,67**; 10/24/97;Build 152 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26,41,47**; 10/24/97 3 3 ;Checking the X12 invoice data. 4 4 S (PSASTCNT,PSAITCNT,PSACTRL(1))=0 … … 73 73 IT1 .;invoice line item 74 74 .I PSALAST="IT1" S PSASTCNT=PSASTCNT+1,PSAITCNT=PSAITCNT+1 D ITEM Q 75 .;BGN PSA*3*6776 PID .;generic vendor item name77 .I PSALAST="PID" S PSASTCNT=PSASTCNT+1,$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",29)=$S($P(PSADATA,"^",6)=$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",28):"Unknown",1:$P(PSADATA,"^",6)) Q78 PO4 .;DESCRIPTION OF ITEM79 .I PSALAST="PO4" S PSASTCNT=PSASTCNT+1,$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",30)=$P(PSADATA,"^",3)_"^"_$P(PSADATA,"^",9) D Q80 .;END PSA*3*6781 75 CTT .;item count 82 76 .I PSALAST="CTT" S PSASTCNT=PSASTCNT+1 D Q … … 99 93 S PSAITEM=+$P(PSADATA,"^",2),^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM)=+$P(PSADATA,"^",3)_"^"_$P(PSADATA,"^",4)_"^"_$P(PSADATA,"^",5)_"^"_$P(PSADATA,"^",8)_"^"_$P(PSADATA,"^",10) 100 94 I $P(PSADATA,"^",12)'="",$P(PSADATA,"^",11)="UP" S $P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",26)=$P(PSADATA,"^",12) 101 ;Next line to add vendor Generic Description102 I $P(PSADATA,"^",14)'="" S $P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",28)=$P(PSADATA,"^",14)103 ;Eop67104 95 Q 105 96 RESETST ;Reset PSACTRL -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m
r628 r636 1 PSABRKU5 ;BIR/ DB-Upload and Process Prime Vendor Invoice Data - CONT'D ;7/23/972 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26 ,67**; 10/24/97;Build 151 PSABRKU5 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data - CONT'D ;7/23/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26**; 10/24/97 3 3 ;This routine checks for correct X12 formating. 4 4 ; 5 5 ORDER ; check order of code sheets 6 ; isa <--------------+ 7 ; gs <----------+ | 8 ; st <------+ | | 9 ; | big | | | 10 ; | it1 <--+ | | | 11 ; | ... | | | |--repeats 12 ; | it1 <--+ | | | 13 ; | ctt | | | 14 ; se <------+ | | 15 ; ge <----------+ | 16 ; iea <--------------+ 6 17 S PSANEXT=$P(PSADATA,"^") 7 18 ; … … 20 31 I PSALAST="ST",PSANEXT'="BIG" D ORDERROR("ST",PSANEXT,"BIG") Q 21 32 ; 22 ;adding next two lines for new format 23 I PSALAST="IT1",PSANEXT="PID" Q 24 I PSALAST="PO4",PSANEXT'="IT1",PSANEXT'="CTT"&(PSANEXT'="TDS") D ORDERROR("PO4",PSANEXT,"CTT") Q 25 ;End of PSA*3*67 Changes 33 I PSALAST="IT1",PSANEXT="IT1" Q 34 I PSALAST="IT1",PSANEXT'="CTT"&(PSANEXT'="TDS") D ORDERROR("IT1",PSANEXT,"CTT") Q 26 35 Q 27 36 ; -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m
r628 r636 1 1 PSAENTO ;BIR/LTL,JMB-Set Up/Edit a Pharmacy Location - CONT'D ;7/23/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,43 ,63**; 10/24/97;Build 102 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,43**; 10/24/97 3 3 ;This routines is called by PSAENT. 4 4 ; … … 34 34 S:'$D(PSALOC) PSALOC=$O(^PSD(58.8,"AOP",+PSAOSIT,"")),PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U) 35 35 OPC W !!,"Outpatient site selection affects the collection of dispensing data.",! 36 S DIE="^PSD(58.8,",DA=PSALOC,DR="20//^S X=$P($G(^PS(59,+PSAOSIT,0)),U)" D ^DIE K DIE I $D(DTOUT)!($D(Y)) G QUIT ;; <3*63 RJS>36 S DIE="^PSD(58.8,",DA=PSALOC,DR="20//^S X=$P($G(^PS(59,+PSAOSIT,0)),U)" D ^DIE K DIE G:$D(Y) QUIT 37 37 S PSAOSIT=+$P($G(^PSD(58.8,PSALOC,0)),"^",10) 38 38 G:'PSALOC QUIT … … 55 55 ...S ^PSD(58.8,+PSALOC,1,+PSADRUG,5,0)="^58.801A^^" 56 56 ...S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DIC(0)="LM",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DIC("DR")="1////^S X=$G(PSAQTY);5////^S X=$G(PSAQTY)",DLAYGO=58.8 D ^DIC K DIC,DLAYGO 57 ...F L +^PSD(58.81,0): $S($G(DILOCKTM)>0:DILOCKTM,1:3)I Q57 ...F L +^PSD(58.81,0):0 I Q 58 58 FIND ...S PSAT=$P(^PSD(58.81,0),U,3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),U,3)=$P(^PSD(58.81,0),U,3)+1 G FIND 59 59 ...S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DLAYGO L -^PSD(58.81,0) -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m
r628 r636 1 1 PSAORDP1 ;BIR/JMB-Print Orders - CONT'D ;9/19/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,61,65 ,67**; 10/24/97;Build 152 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,61,65**; 10/24/97;Build 2 3 3 ;This routine prints invoices. 4 4 ; … … 124 124 .W:+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",2)'=0 !?9,"REORDER LEVEL: "_$FN(+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2),",") 125 125 .; 126 .;BGN 67127 .D DISP2^PSAP67128 .;END 67129 126 .I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2 D LINEHDR^PSAORDP2 130 127 .D ^PSAORDP2 Q:PSAOUT -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m
r628 r636 1 1 PSAPROC4 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;7/23/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21 ,63**; 10/24/97;Build 102 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21**; 10/24/97 3 3 ;References to ^PSDRUG( are covered by IA #2095 4 4 ;References to ^DIC(51.5 are covered by IA #1931 … … 52 52 ; 53 53 LIST Q:PSANODE=""!($P($G(^PSDRUG(PSAIEN50,0)),"^")="") 54 ;3*63 RJS55 N PSAPPOU,PSADUOU,PSAPPDU,PSAVEND,PSAOU,PSACPPDU,X,PSANDC,PSADU,PSASYNM,PSAVSN56 S X=PSANODE57 S PSASYNM=$P(X,U,1),PSANDC=$P(X,U,2),PSAVSN=$P(X,U,4),PSAOU=+$P(X,U,5),PSAPPOU=$P(X,U,6)58 S PSADUOU=$P(X,U,7),PSAPPDU=$P(X,U,8),PSAVEND=$P(X,U,9)59 S PSADU=$$GET1^DIQ(50,PSAIEN50,14.5),PSAOU=$P($G(^DIC(51.5,PSAOU,0)),"^")60 S PSACPPDU=$S('PSADUOU:"BLANK",1:(PSAPPOU*1000/PSADUOU\1/1000)) ;recalculate PPDU, file doesn't reset PPDU61 54 W !?1,PSAMENU_".",?4,$P($G(^PSDRUG(PSAIEN50,0)),"^") I $D(^PSDRUG(PSAIEN50,"I")) W ?60,"(INACTIVE)" 62 I PSANDC="",PSAVSN="" W !,?19,"SYN #",PSASYN,": ",PSASYNM,! Q 63 W !,?4,"NDC: ",PSANDC,?25,"Order Unit: ",PSAOU,?46,"Price Per Order Unit: $",$FN(PSAPPOU,",",2) 64 W !,?4,"VSN: ",PSAVSN,?19,"SYN #",PSASYN,": ",PSASYNM,?42,"Dose Unit Per Order Unit: ",PSADUOU 65 W !,?4,"Vendor: ",PSAVEND,?47,"Price Per Dose Unit: ",$FN(PSACPPDU,","),! 66 ;3*63 end 55 ;NOIS CTX-1200-71091 (PSA*3*21 Dave B) 56 I $P(PSANODE,"^",2)'="" W !,?4,"NDC : "_$P(PSANODE,"^",2) 57 I +$P(PSANODE,"^",5),$P($G(^DIC(51.5,+$P(PSANODE,"^",5),0)),"^")'="" W !?4,"Order Unit: "_$P(^DIC(51.5,+$P(PSANODE,"^",5),0),"^"),?45,"Price Per Order Unit : $"_$S(+$P(PSANODE,"^",6):$P(PSANODE,"^",6),1:"(Blank)") 58 E I +$P(PSANODE,"^",6) W !?4,"Price Per Order Unit: $"_$P(PSANODE,"^",6) 59 I $P(PSANODE,"^",9)'="" W !?4,"Vendor: "_$P(PSANODE,"^",9),?45,"VSN: "_$S($P(PSANODE,"^",4)'="":$P(PSANODE,"^",4),1:"(Blank)") 60 E I $P(PSANODE,"^",4)'="" W !?4,"VSN: "_$S($P(PSANODE,"^",4)'="":$P(PSANODE,"^",4),1:"(Blank)") 67 61 Q 68 62 ; -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC7.m
r628 r636 1 1 PSAPROC7 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;9/6/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,27,21,42,61,64 ,67**; 10/24/97;Build 152 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,27,21,42,61,64**; 10/24/97;Build 4 3 3 ;This routine takes the data in XTMP and moves it to DA ORDERS file. 4 4 ;It deletes the data in XTMP after it is copies. … … 65 65 S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",6)=DT 66 66 S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",7)=DUZ 67 ;BGN 6768 S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",1)=$P(PSADATA,"^",28)69 S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",2)=$P(PSADATA,"^",29)70 S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",3)=$P(PSADATA,"^",30)71 S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",4)=$P(PSADATA,"^",31)72 ;END 6773 67 S DIK=DIE D IX^DIK 74 68 ;End PSA*3*7 … … 81 75 I +$P(PSADATA,"^",7)!(+$P(PSADATA,"^",20))!(+$P(PSADATA,"^",21))!(+$P(PSADATA,"^",27)) D 82 76 .S ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,2)=$P(PSADATA,"^",20)_"^"_$P(PSADATA,"^",21)_"^"_$S(+$P(PSADATA,"^",7):+$P(PSADATA,"^",7),1:0)_"^"_+$P(PSADATA,"^",27) 83 ;Bgn 6784 I $P(PSADATA,"^",5)'="" S ^XTMP("PSAVSN",$P(PSADATA,"^",5))=$P(PSADATA,"^",28)_"^"_$P(PSADATA,"^",29)_"^"_$P(PSADATA,"^",30)_"^"_$P(PSADATA,"^",31)85 ;End 6786 77 K ^XTMP("PSAPV",PSACTRL,"IT",PSALINE) 87 78 Q -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m
r628 r636 1 1 PSAUDP ;BIR/LTL,JMB-Nightly Background Job - CONT'D ;7/23/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**6,3,12,14,25,64 ,66**; 10/24/97;Build 22 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**6,3,12,14,25,64**; 10/24/97;Build 4 3 3 ; 4 4 ;Reference to ^PS(57.6 are covered by IA #772 … … 47 47 S DIE="^PSD(58.8,PSALOC,1,PSA50,5,",DA(2)=PSALOC,DA(1)=PSA50,DA=$E(PSADT,1,5)*100,DR="9////^S X=$P($G(^(0)),U,6)+PSAQTY" D ^DIE K DIE,DA 48 48 ;Get next transaction node number 49 F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q ;; << *66 RJS50 49 FIND S PSANUM=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSANUM)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND 51 50 ;Add next transaction node with data. … … 53 52 S DIE="^PSD(58.81,",DA=PSANUM 54 53 S DR="1////2;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSA50;5////^S X=PSAQTY;9////^S X=$G(PSABAL)" D ^DIE K DIE,DA 55 L -^PSD(58.81,0) ;; >> *66 RJS56 54 ;Add activity node 57 55 S DIC="^PSD(58.8,PSALOC,1,PSA50,4,",DIC(0)="L",(X,DINUM)=PSANUM,DIC("P")=$P(^DD(58.8001,19,0),"^",2),DA(2)=PSALOC,DA(1)=PSA50,DLAYGO=58.8 D ^DIC K DA,DIC,DLAYGO -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m
r628 r636 1 1 PSAUP4 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data - CONT'D ;9/19/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,20,21 ,67**; 10/24/97;Build 152 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,20,21**; 10/24/97 3 3 ;This routine prints invoices from the ^XTMP global on the screen or 4 4 ;to a printer. … … 112 112 .I $Y+9>IOSL,+$P(PSADATA,"^",21),+$P(PSADATA,"^",27) D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR 113 113 .I $G(PSADRG) D HAVEDRG 114 .I '$G(PSADRG) W !?9,"STOCK LEVEL : ",!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21),!?9,"DISPENSE UNITS/ORDER UNIT: " D DISP^PSAP67114 .I '$G(PSADRG) W !?9,"STOCK LEVEL : ",!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21),!?9,"DISPENSE UNITS/ORDER UNIT: " 115 115 .; 116 116 .;Print Adj Qty … … 174 174 W !?9,"DISPENSE UNITS/ORDER UNIT: " 175 175 W $S(+$P(PSADATA,"^",20):+$P(PSADATA,"^",20),+$P($G(^PSDRUG(PSADRG,1,+$P(PSADATA,"^",7),0)),"^",7):+$P($G(^PSDRUG(PSADRG,1,+$P(PSADATA,"^",7),0)),"^",7),1:"") 176 D DISP^PSAP67177 176 Q -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m
r628 r636 1 1 PSAUTL1 ;BIR/JMB-Prime Vendor Invoice Data Utility ;9/19/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,15,21,48,49,54 ,67**; 10/24/97;Build 152 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,15,21,48,49,54**; 10/24/97 3 3 ;This routine contains utilities to get the location name, display an 4 4 ;error-free item, display an item with errors, and display a line ready … … 51 51 W !,"Unit Price : $"_$P(PSADATA,"^",3),?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! 52 52 I $P(PSADATA,U,13)=.5 D ;*48 AUTO OU UPDATE FOR MCKESSON 53 .W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability" 54 .W !," during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<" 55 ;bgn *67 56 W !,"PV-Drug-Description : ",$S($P(PSADATA,"^",28)'="":$P(PSADATA,"^",28),1:"Unknown") 57 W ?55,"PV-DUOU : ",$S($P(PSADATA,"^",31)'="":$P(PSADATA,"^",31),1:"Unknown") 58 W !,"PV-Drug-Generic Name : ",$S($P(PSADATA,"^",29)'="":$P(PSADATA,"^",29),1:"Unknown") 59 W ?55,"PV-UNITS : ",$S($P(PSADATA,"^",30)'="":$P(PSADATA,"^",30),1:"Unknown"),! 60 ;end *67 53 . W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability" 54 . W !," during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<" 55 ;*54 display VSN XTMP Drug Description and DUOU >==> 56 N PSAFLDT S PSAFLDT="February 2006" 57 N XXX S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D 58 . I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4) 59 . W !,"PV-Drug-Descrip: " 60 . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q 61 . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,! 62 ;*54 display VSN XTMP Drug Description and DUOU <==< 61 63 W !,"Dispense Units: "_$S(+PSAIEN&($P($G(^PSDRUG(+PSAIEN,660)),"^",8)'=""):$P($G(^PSDRUG(+PSAIEN,660)),"^",8),1:"Blank") 62 64 W !,"Dispense Units Per Order Unit: "_$S($P(PSADATA,"^",20):+$P(PSADATA,"^",20),+PSASUB&(+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7),1:"Blank") … … 98 100 W !,"Unit Price : $"_$S($G(PSAPRICE):PSAPRICE,PSAPRICE=0:0,1:"Blank"),?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! 99 101 I $P(PSADATA,U,13)=.5 D ;*48 AUTO OU UPDATE FOR MCKESSON 100 .N PSAOU S PSAOU=$P(PSADATA,U,12) 101 .W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability" 102 .W !," during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<" 103 ;bgn *67 104 W !,"PV-Drug-Description : ",$S($P(PSADATA,"^",28)'="":$P(PSADATA,"^",28),1:"Unknown") 105 W ?55,"PV-DUOU : ",$S($P(PSADATA,"^",31)'="":$P(PSADATA,"^",31),1:"Unknown") 106 W !,"PV-Drug-Generic Name : ",$S($P(PSADATA,"^",29)'="":$P(PSADATA,"^",29),1:"Unknown") 107 W ?55,"PV-UNITS : ",$S($P(PSADATA,"^",30)'="":$P(PSADATA,"^",30),1:"Unknown"),! 108 ;end *67 102 . N PSAOU S PSAOU=$P(PSADATA,U,12) 103 . W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability" 104 . W !," during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<" 105 N PSAFLDT S PSAFLDT="February 2006" 106 N XXX S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D 107 .I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4) 108 . W !,"PV-Drug-Descrip: " 109 . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q 110 . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,! 111 ;*54 display VSN XTMP Drug Description and DUOU <==< 109 112 S PSAIN=^XTMP("PSAPV",PSACTRL,"IN"),PSALOC=$S($P(PSADATA,"^",19)="CS":+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",7)) 110 113 DU W !,"Dispense Units: "_$S(+PSAIEN&($P($G(^PSDRUG(+PSAIEN,660)),"^",8)'=""):$P($G(^PSDRUG(+PSAIEN,660)),"^",8),1:"Blank") -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m
r628 r636 1 1 PSAUTL4 ;BIR ISC/JMB-Verify Invoices Utility ; 8/19/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,48,54,61 ,67**; 10/24/97;Build 152 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,48,54,61**; 10/24/97;Build 1 3 3 ; 4 4 ;References to ^DIC(51.5 are covered by IA #1931 … … 62 62 VSN S:$D(PSADATA) PSAVSN=$P(PSADATA,"^",12) ;*48 63 63 W ?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! 64 ;bgn *67 65 S PSAP67=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,3,PSALINE,0)) 66 W !,"PV-Drug-Description : ",$S($P(PSAP67,"^",1)'="":$P(PSAP67,"^",1),1:"Unknown") 67 W ?55,"PV-DUOU : ",$S($P(PSAP67,"^",4)'="":$P(PSAP67,"^",4),1:"Unknown") 68 W !,"PV-Drug-Generic Name : ",$S($P(PSAP67,"^",2)'="":$P(PSAP67,"^",2),1:"Unknown") 69 W ?55,"PV-UNITS : ",$S($P(PSAP67,"^",3)'="":$P(PSAP67,"^",3),1:"Unknown"),! 70 ;end *67 64 ;*54 display VSN XTMP Drug Description and DUOU |==> 65 N PSAFLDT S PSAFLDT="February 2006" 66 N XXX I PSAVSN'="" S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D 67 . I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4) 68 . W !,"PV-Drug-Descrip: " 69 . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q 70 . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,! 71 ;*54 display VSN XTMP Drug Description and DUOU <==| 71 72 VDU S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4) 72 73 W !,"Dispense Units: "_$S($P($G(^PSDRUG(+PSADRG,660)),"^",8)'="":$P($G(^PSDRUG(+PSADRG,660)),"^",8),1:"Blank") -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m
r628 r636 1 1 PSAVER7 ;BIR/JMB-Verify Invoices - CONT'D ;7/23/97 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,42,56,64 ,66**; 10/24/97;Build 22 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,42,56,64**; 10/24/97;Build 4 3 3 ;Background Job 4 4 ;This routine increments pharmacy location and master vault balances … … 43 43 S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,3) ;Price of Order Unit divide by Disp. Units per Order Unit 44 44 ;PSA*3*42 |> (let changes happen and file, put changes into mail message) 45 S DIE="^PSDRUG(", (DA,OLDDA)=PSADRG,DR="12////^S X=PSAOU;15////^S X=PSADUOU;Q;13////^S X=PSAPOU" ;*42;*5645 S DIE="^PSDRUG(",DA=PSADRG,DR="12////^S X=PSAOU;15////^S X=PSADUOU;Q;13////^S X=PSAPOU" ;*42;*56 46 46 F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q 47 47 D ^DIE K DIE,DA,DR … … 64 64 .F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q 65 65 .D ^DIE L -^PSDRUG(DA,0) K DIE,DA,DR 66 SYNONYM ;Adds/edits the SYNONYM multiple in DRUG file >>*66 RJS 67 G:PSANDC="" END 68 S DA(1)=PSADRG ;; << *66 RJS 66 SYNONYM ;Adds/edits the SYNONYM multiple in DRUG file 67 Q:PSANDC="" K DA,DR S DA(1)=PSADRG 69 68 ; 70 69 S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,3) ;Price of Order Unit divide by Disp. Units per Order Unit … … 92 91 D ^DIE L -^PSDRUG(PSADRG,0) 93 92 K DIE,DR,X1,X2,DATA 94 END ; FINAL CLEANUP << *66 RJS95 L -^PSDRUG(OLDDA,0) K OLDDA ;; >> *66 RJS96 93 Q -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m
r628 r636 1 1 PSAVERA ;BHM/DBM - Change verified invoice data;16AUG05 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53 ,63**; 10/24/97;Build 102 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53**; 10/24/97 3 3 ; 4 4 ;References to ^DIC(51.5 are covered by IA #1931 … … 11 11 INV ;Get Invoice Number 12 12 S DIC(0)="AEQMZ",DIC("A")="Select Invoice Number: ",DIC="^PSD(58.811,"_PSAIEN_",1,",D="ASTAT" D ^DIC K DIC G Q:+Y'>0 S PSAIEN1=+Y,PSAINV=$P(Y,U,2) 13 ; 13 14 S DATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,0)) 14 15 S PSALOC=$S($P(DATA,"^",12)'="":$P(DATA,"^",12),1:$P(DATA,"^",5)) I $G(PSALOC)="" S PSALOC="No Location identified" 15 16 D ^PSAVERA1 17 ; 16 18 K DATA,PSAITM,LINENUM,X,X1,X2,X3,DIC,DA,DR D HDR 17 19 DISP S PSAITM=$S('$D(PSAITM):$O(INVARRAY(PSAORD,PSAINV,0)),1:$O(INVARRAY(PSAORD,PSAINV,PSAITM))) G LINEASK:PSAITM'>0 S LINENUM=$G(LINENUM)+1 18 S DATA=$G(INVARRAY(PSAORD,PSAINV,PSAITM)),PSAOU=$P(DATA,"^",4) I $G(PSAOU) S PSAOU(1)=$P($G(^DIC(51.5,$P(DATA,"^",4),0)),"^") ;Current Order Unit ;; <*63 RJS 19 W !,PSAITM,?10,$S($P($P(DATA,"^",1),"~",1)'>0:$P($P(DATA,"^",1),"~",1),1:$P($P(DATA,"^",1),"~",2)),?45,$S($G(PSAOU)="":"none",$G(PSAOU(1))'="":$G(PSAOU(1)),1:$G(PSAAOU)),?55,$J($P($G(DATA),"^",2),4),?61,$P(DATA,"^",5) ;; *63 RJS> 20 S DATA=$G(INVARRAY(PSAORD,PSAINV,PSAITM)) 21 S PSAOU=$P(DATA,"^",4) I $G(PSAOU) S PSAOU(1)=$P($G(^DIC(51.5,$P(DATA,"^",4),0)),"^") ;Current Order Unit 22 W !,PSAITM,?10,$S($P($P(DATA,"^",1),"~",1)'>0:$P($P(DATA,"^",1),"~",1),1:$P($P(DATA,"^",1),"~",2)),?45,$S($G(PSAOU)="":"none",$G(PSAOU(1))'="":$G(PSAOU(1)),1:$G(PSAAOU)),?55,$J($P($G(DATA),"^",2),4),?61,$P(DATA,"^",5) 20 23 I IOST["C-",$Y>(IOSL-5) S DIR(0)="E" D ^DIR G Q:$G(DUOUT)=1 D HDR 21 24 G DISP … … 31 34 S PSALINEN="" D VERDISP^PSAUTL4 W !,PSASLN,! 32 35 S PSAVEND=$P(^PSD(58.811,PSAIEN,0),"^",2) 36 ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;GET ORIGINAL DISPENSE UNITS PER ORDER UNIT FOR SUBTRACTION 33 37 S PSAODUOU=PSADUOU 34 ;; *63 35 S PSA581="" F S PSA581=$O(^PSD(58.81,"PV",PSAINV,PSA581)) Q:'PSA581 I $P(^PSD(58.81,PSA581,0),U,5)=PSADRG S PSABFR(581)=$G(^PSD(58.81,PSA581,0)) 36 S:$G(PSABFR(581)) PSDTRN=$P(PSABFR(581),U,1),PSABFR("Q")=$S($G(^PSD(58.81,PSDTRN,4)):$P(^PSD(58.81,PSDTRN,4),"^",3),1:$P(^PSD(58.81,PSDTRN,0),"^",6)) ; <*63 RJS > 38 ; 37 39 DRG W !,"Select (D)rug or (O)rder Unit " R AN:DTIME G Q:AN["^"!(AN="") W $S("Dd"[AN:"rug","oO"[AN:"rder Unit",1:"??") I "DdOo"'[AN W !,"Enter a 'D' to edit the Drug, or 'O' to edit the order unit",! K AN G DRG 38 I "Dd"'[AN D ^PSAVERA3 G Q ;;*6340 I "Dd"'[AN G ^PSAVERA3 39 41 ;Get either new name of drug or supply item description 40 S PSABFR=$P(DATA,"~",1),PSABFR(1)=$S(PSABFR'?.N:PSABFR,1:$P($P(DATA,"^"),"~",2)),PSABFR("NDC")=$P(PSADATA,"^",11) ;;*63 42 S PSABEFOR=$P(DATA,"~",1),PSABEFOR(1)=$S(PSABEFOR'?.N:PSABEFOR,1:$P($P(DATA,"^"),"~",2)) 43 S PSABEFOR("NDC")=$P(PSADATA,"^",11) 41 44 DRGAGN D 42 .S X1=0 F S X1=$O(^PSDRUG(PSAB FR,1,X1)) Q:X1'>0 S DATA=$G(^PSDRUG(PSABFR,1,X1,0)) I $P(DATA,"^",2)=PSABFR("NDC") S PSABFR("SYNNODE")=X1 ;;*6345 .S X1=0 F S X1=$O(^PSDRUG(PSABEFOR,1,X1)) Q:X1'>0 S DATA=$G(^PSDRUG(PSABEFOR,1,X1,0)) I $P(DATA,"^",2)=PSABEFOR("NDC") S PSABEFOR("SYNNODE")=X1 43 46 D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX 44 I $G(PSAB FR("SYNNODE"))="",$E(PSABFR("NDC"))'="S" S PSABFR("NDC")="S"_PSABFR("NDC") G DRGAGN ;may be supply, try again45 I $G(PSAB FR("SYNNODE"))'="" S PSASUB=PSABFR("SYNNODE") D46 .S DATA=$G(^PSDRUG(PSAB FR,1,PSASUB,0)),PSAOU=$P(DATA,"^",5),PSAPOU=$P(DATA,"^",6),PSADUOU=$P(DATA,"^",7),PSAPDUOU=$P(DATA,"^",8)47 .S PSADU=$P($G(^PSDRUG(PSAB FR,660)),"^",8)47 I $G(PSABEFOR("SYNNODE"))="",$E(PSABEFOR("NDC"))'="S" S PSABEFOR("NDC")="S"_PSABEFOR("NDC") G DRGAGN ;may be supply, try again 48 I $G(PSABEFOR("SYNNODE"))'="" S PSASUB=PSABEFOR("SYNNODE") D 49 .S DATA=$G(^PSDRUG(PSABEFOR,1,PSASUB,0)),PSAOU=$P(DATA,"^",5),PSAPOU=$P(DATA,"^",6),PSADUOU=$P(DATA,"^",7),PSAPDUOU=$P(DATA,"^",8) 50 .S PSADU=$P($G(^PSDRUG(PSABEFOR,660)),"^",8) 48 51 I ($G(PSAOU)=""!$G(PSAPOU)=""!$G(PSADUOU)=""!$G(PSAPDUOU)="") W !!,"Sorry, I could not find the necessary information to change the drug selection.",! G Q 49 W !,"Current Drug : ",PSAB FR(1)50 DRG1 S PSAGAIN=0,DIC("A")="Select name of Correct Drug: ",PSAB FR=PSADRG,DIC(0)="AEQMZ",DIC="^PSDRUG(" D ^DIC K DIC G Q:PSAOUT51 I $G(DTOUT)!($G(DUOT)) !(Y<0)S PSAOUT=1 Q52 W !,"Current Drug : ",PSABEFOR(1) 53 DRG1 S PSAGAIN=0,DIC("A")="Select name of Correct Drug: ",PSABEFOR=PSADRG,DIC(0)="AEQMZ",DIC="^PSDRUG(" D ^DIC K DIC G Q:PSAOUT 54 I $G(DTOUT)!($G(DUOT)) S PSAOUT=1 Q 52 55 S (PSADJ,PSADRG)=+Y 53 56 W !!,"Comparing drug file data..." … … 55 58 I $P($G(^PSDRUG(PSADRG,660)),"^",2)'=$G(PSAOU) W !,"The Order Units are different between these two drugs." 56 59 I $P($G(^PSDRUG(PSADRG,660)),"^",8)'=$G(PSADU) W !,"Please Enter an appropriate Dispense Unit" S DIE="^PSDRUG(",DA=PSADRG,DR="14.5" D ^DIE S PSADU=$P(^PSDRUG(PSADRG,660),"^",8) 60 ;VMP OIFO BAY PINES;VGF;PSA*3.0*36 57 61 I $P($G(^PSDRUG(PSADRG,660)),"^",5)'=$G(PSADUOU) W !,"Please enter the appropriate Dispense Units per order unit" S DIE="^PSDRUG(",DA=PSADRG,DR="15" D ^DIE S PSADUOU=$P(^PSDRUG(PSADRG,660),"^",5) 58 62 K DIE,DA,DR … … 60 64 S AN=$E(AN) I "yYnN"'[AN W !,"Answer yes, and the data on file for the current drug will be transferred",!,"to the new drug selection.",!,"That includes Order Unit, Dispense Unit, Dispense Units per Order Unit, etc.",!! G ASK 61 65 I "Nn"[AN G NOCHNG ;*53 62 S PSAAFTER=PSADRG,PSADRG=PSABFR 63 I $D(^PSDRUG(PSADRG))&$G(PSABFR(581)) D 64 .W !,"Removing "_PSABFR("Q")_" from "_PSABFR(1) 65 .S FMDATA=$P($G(^PSDRUG(PSADRG,660.1)),"^")-PSABFR("Q"),DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_FMDATA 66 .F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q 67 .D ^DIE L -^PSDRUG(DA,0) K FMDATA 66 ;VMP OIFO BAY PINES;VGF;PSA*3.0*36 67 S PSAAFTER=PSADRG,PSADRG=PSABEFOR 68 I $D(^PSDRUG(PSADRG)) D 69 .;VMP OIFO BAY PINES;VGF;PSA*3.0*40 70 .W !,"Removing "_($G(PSAQTY)*$G(PSAODUOU))_" from "_PSABEFOR(1) 71 .S FMDATA=$P($G(^PSDRUG(PSADRG,660.1)),"^")-(PSAODUOU*PSAQTY) 72 .S DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_FMDATA 73 .F L +^PSDRUG(DA,0):0 I Q 74 .D ^DIE 75 .L -^PSDRUG(DA,0) 76 .K FMDATA 68 77 S PSADRG=PSAAFTER 69 78 I $G(PSAPOU)="",$G(PSAPRICE)'="" S PSAPOU=PSAPRICE 70 79 W !,"Adding "_($G(PSAQTY)*$G(PSADUOU))_" to "_$P($G(^PSDRUG(PSADRG,0)),"^") 71 80 W !,"Entering new drug selection as an adjustment." 72 S PSAREA="",PSADJFLD="D",PSADJ=PSADRG D RECORD^PSAVER2,50^PSAVER7 81 S PSAREA="",PSADJFLD="D",PSADJ=PSADRG D RECORD^PSAVER2 82 D 50^PSAVER7 73 83 FILE ;File dispense units per order units into 58.811 74 S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,",DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN,DR="10///"_PSADUOU D ^DIE 75 G:$D(^PSD(58.811,"ASTAT","P",PSAIEN,PSAIEN1)) Q ;; *63 RJS 76 D UPDATE^PSAVERA1 G Q 84 S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1," 85 S DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN 86 S DR="10///"_PSADUOU 87 D ^DIE 88 ;File data in 58.8 89 ;PSALOC= Either PSALOC or PSALOCB 90 ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;UPDATE 91 S PSADRG=PSABEFOR 92 F L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I Q 93 S PSADUREC=PSAQTY*$G(PSAODUOU) 94 S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4) 95 S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-PSADUREC 96 L -^PSD(58.8,PSALOC,1,PSADRG,0) 97 ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;ADDED *$G(PSADUOU) 98 S PSADRG=PSAAFTER 99 S PSADUREC=PSAQTY*$G(PSADUOU) 100 D NOW^%DTC S PSADT=+$E(%,1,14) 101 I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D 102 .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2) 103 .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8 ;*53 104 .F L +^PSD(58.8,PSALOC,0):0 I Q 105 .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO 106 F L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I Q 107 S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4) 108 I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG 109 S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL 110 I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D 111 .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK 112 .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD 113 S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2) 114 I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D 115 .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC 116 .S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100 D ^DIC K DIC,DLAYGO S DA=+Y 117 .S 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 118 S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE 119 L -^PSD(58.8,PSALOC,1,PSADRG,0) 120 W !,"updating pharmacy location file." 121 FILE581 ;Update transaction file 122 S PSAVDUZ=DUZ 123 FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND 124 S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0) 125 S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD" 126 I $G(PSACS)>0 S DR=DR_";100////^S X=PSACS" 127 F L +^PSD(58.81,DA,0):0 I Q 128 D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q 77 129 ; 78 130 HDR W @IOF,!?25,"EDIT VERIFIED INVOICED ITEM SCREEN",!,PSASLN,! 79 131 W !,?44,"Order",!,"#",?10,"Drug/Item Name",?45,"Unit",?56,"Qnty.",?67,"NDC",!,PSASLN,! Q 80 Q K AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,P OP,PSA50IEN,PSA581,PSAABAL,PSAAFTER,PSAAQTY,PSABAL,PSABFR,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJFLD,PSADJO,PSADJP,PSADJQ,PSADRG,PSADRUGN,PSADT81 K PSA DU,PSADUOU,PSADUREC,PSAEDTT,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAITM,PSALINE,PSALINEN,PSALOC,PSANDC,PSANDUOU,PSANEW,PSANODE,PSANPDU,PSANQTY,PSAODASH,PSAODU,PSAODUOU,PSAONDC,PSAORD82 K PSAO U,PSAOUT,PSAPOU,PSAPRICE,PSAQTY,PSAREA,PSAREORD,PSASET,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSATEMP,PSAUPC,PSAVDUZ,PSAVEND,PSAVER,PSAVSN,PSAXDUOU,PSDTRN,X,X1,X2,X3,XX,XXX,Y132 Q K AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,PSA50IEN,PSABAL,PSABEFOR,PSACS,PSADATA,PSADJ,PSADJFLD,PSADRG,PSADT,PSADUREC,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSALINE,PSALINEN 133 K PSALOC,PSANDC,PSAORD,PSAOUT,PSAQTY,PSAREA,PSAREORD,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSAVER,X,X1,X2,X3,XX,XXX,Y,PSAODUOU 134 K PSAODU,PSAODUOU,PSAXDUOU 83 135 Q 84 136 NOCHNG ;*53 said no to changes, backout the edits on the new drug choice. -
FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m
r628 r636 1 1 PSAVERA1 ;BHM/DB - Edit previously verified invoices;16NOV99 2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61 ,63**; 10/24/97;Build 102 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61**; 10/24/97;Build 1 3 3 ;References to ^DIC(51.5 are covered by IA #1931 4 4 ;References to ^PSDRUG( are covered by IA #2095 … … 81 81 .I PSAFLD=2 D OU^PSAVER2 Q 82 82 Q Q 83 ;84 UPDATE ; *63 RJS CODE REMOVED FROM PSAVERA AND CALLED BY PSAVERA85 ;File data in 58.886 ;PSALOC= Either PSALOC or PSALOCB87 S PSADRG=PSABFR88 F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q89 S PSADUREC=PSAQTY*$G(PSAODUOU),PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4),$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-$G(PSABFR("Q"))90 L -^PSD(58.8,PSALOC,1,PSADRG,0)91 S PSADRG=PSAAFTER,PSAABAL=PSABAL,PSADUREC=PSAQTY*$G(PSADUOU)92 D NOW^%DTC S PSADT=+$E(%,1,14)93 I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D94 .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)95 .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8 ;*5396 .F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q97 .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO98 F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q99 S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)100 I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG101 S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL102 I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D103 .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK104 .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD105 S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)106 I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D107 .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC108 .S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100 D ^DIC K DIC,DLAYGO S DA=+Y109 .S 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 DIE110 S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE111 L -^PSD(58.8,PSALOC,1,PSADRG,0)112 W !,"updating pharmacy location file."113 FILE581 ;Update transaction file ;;*63114 S PSAVDUZ=DUZ,PSAREA="EDIT VERIFIED INVOICE"115 I '$G(PSABFR(581)) D NEW581 Q116 I PSADRG'=PSABFR S PSANQTY=0,PSAAQTY=$G(PSABFR("Q"))*-1117 I PSADRG=PSABFR S PSANQTY=PSADUREC D118 .S PSAAQTY=PSADUREC-$G(PSABFR("Q"))119 FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND120 S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0)121 S DIE="^PSD(58.81,",DA=PSAT122 I PSAAFTER'=PSABFR S PSADRG=PSABFR123 S DR="1////14;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;48////^S X=PSADT;49////^S X=PSAVDUZ;50////^S X=PSANQTY;51////^S X=PSAAQTY;53////^S X=PSAREA;54////^S X=PSAABAL;71////^S X=PSAINV;106////^S X=PSAORD"124 F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q125 D ^DIE L -^PSD(58.81,DA,0) K DIE126 I PSAAFTER'=PSABFR S PSADRG=PSAAFTER D NEW581127 Q128 ;129 NEW581 S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G NEW581130 S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0)131 S PSADUREC=PSAQTY*$G(PSADUOU)132 S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD"133 I $G(PSACS)>0 S DR=DR_";100////^S X=PSACS"134 F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q135 D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q136 Q
Note:
See TracChangeset
for help on using the changeset viewer.
