Changeset 636 for FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m (modified) (2 diffs)

FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m

@@ -1 +1 @@
 PSAVERA1 ;BHM/DB - Edit previously verified invoices;16NOV99
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61,63**; 10/24/97;Build 10
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61**; 10/24/97;Build 1
  ;References to ^DIC(51.5 are covered by IA #1931
  ;References to ^PSDRUG( are covered by IA #2095
@@ -81 +81 @@
  .I PSAFLD=2 D OU^PSAVER2 Q
 Q Q
- ;
-UPDATE ; *63 RJS CODE REMOVED FROM PSAVERA AND CALLED BY PSAVERA
- ;File data in 58.8
- ;PSALOC= Either PSALOC or PSALOCB
- S PSADRG=PSABFR
- F  L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- 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"))
- L -^PSD(58.8,PSALOC,1,PSADRG,0)
- S PSADRG=PSAAFTER,PSAABAL=PSABAL,PSADUREC=PSAQTY*$G(PSADUOU)
- D NOW^%DTC S PSADT=+$E(%,1,14)
- I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
- .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)
- .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8 ;*53
- .F  L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO
- F  L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
- S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
- I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D
- .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
- .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
- S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)
- I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D
- .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
- .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
- .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
- 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
- L -^PSD(58.8,PSALOC,1,PSADRG,0)
- W !,"updating pharmacy location file."
-FILE581 ;Update transaction file ;;*63
- S PSAVDUZ=DUZ,PSAREA="EDIT VERIFIED INVOICE"
- I '$G(PSABFR(581)) D NEW581 Q
- I PSADRG'=PSABFR S PSANQTY=0,PSAAQTY=$G(PSABFR("Q"))*-1
- I PSADRG=PSABFR S PSANQTY=PSADUREC D
- .S PSAAQTY=PSADUREC-$G(PSABFR("Q"))
-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
- 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)
- S DIE="^PSD(58.81,",DA=PSAT
- I PSAAFTER'=PSABFR S PSADRG=PSABFR
- 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"
- F  L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- D ^DIE L -^PSD(58.81,DA,0) K DIE
- I PSAAFTER'=PSABFR S PSADRG=PSAAFTER D NEW581
- Q
- ;
-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 NEW581
- 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)
- S PSADUREC=PSAQTY*$G(PSADUOU)
- 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"
- I $G(PSACS)>0 S DR=DR_";100////^S X=PSACS"
- F  L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q
- Q