PSAPUR ;BIR/LTL-Nightly Background Job - CONT'D ;7/23/97
 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
 ;This routine purges all DA transactions greater than 120 days old. It
 ;also purges all invoices from the DA ORDERS file if they are over the
 ;number of days set in 58.8. It is called by PSAPSI5.
 ;
 N DIC,DIE,DINUM,D0,D1,DLAYGO,DR,PSAS,PSA,PSALOC,PSAOUT,PSADT,DA,PSADRUG,PSADRUGN,PSAT,PSAR,X,Y
 S PSALOC=0
 S X="T-120" D ^%DT S PSADT=Y
 F  S PSALOC=$O(^PSD(58.8,PSALOC)) G:'PSALOC END D:$P($G(^PSD(58.8,+PSALOC,0)),U,2)="P"
 .S PSADRUG=0
LUP .F  S PSADRUG=$O(^PSD(58.8,+PSALOC,1,PSADRUG)) Q:'PSADRUG  D:$O(^PSD(58.8,+PSALOC,1,+PSADRUG,4,0))
 ..S PSAT=0
 ..F  S PSAT=$O(^PSD(58.8,+PSALOC,1,+PSADRUG,4,PSAT)) Q:'PSAT  D:$P($G(^PSD(58.81,+PSAT,0)),U,4)<PSADT&('$P($G(^PSD(58.81,+PSAT,"CS")),U))
 ...S DIE="^PSD(58.8,+PSALOC,1,+PSADRUG,4,",DA(2)=PSALOC,DA(1)=PSADRUG,DA=PSAT,DR=".01////@" D ^DIE
 ...S DIE="^PSD(58.81,",DA=PSAT,DR=".01////@" D ^DIE
 ;
ORDERS ;Deletes invoices from the DA ORDERS file if they are over the number
 ;of days set in 58.8.
 S PSALOC=0 F  S PSALOC=$O(^PSD(58.811,"ALOC",PSALOC)) Q:'PSALOC  D
 .S PSALOCDT=$S(+$P($G(^PSD(58.8,PSALOC,0)),"^",15):+$P($G(^PSD(58.8,PSALOC,0)),"^",15),1:120) S X1=DT,X2=-PSALOCDT D C^%DTC S PSALOCDT=X
 .S PSADT=0 F  S PSADT=$O(^PSD(58.811,"ALOC",PSALOC,PSADT)) Q:'PSADT!(PSADT>PSALOCDT)  D
 ..S PSAIEN=0 F  S PSAIEN=$O(^PSD(58.811,"ALOC",PSALOC,PSADT,PSAIEN)) Q:'PSAIEN  D
 ...S PSAIEN1=0 F  S PSAIEN1=$O(^PSD(58.811,"ALOC",PSALOC,PSADT,PSAIEN,PSAIEN1)) Q:'PSAIEN1  D
 ....Q:$P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,0)),"^",3)'="C"!('$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0)))
 ....S DA(1)=PSAIEN,DA=PSAIEN1,DIK="^PSD(58.811,"_DA(1)_",1," D ^DIK K DA,DIK
 ...I '$O(^PSD(58.811,PSAIEN,1,0)) S DA=PSAIEN,DIK="^PSD(58.811," D ^DIK K DA,DIK
 K PSADT,PSAIEN,PSAIEN1,PSALOC,PSALOCDT,X,X1,X2
END Q