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
PSAPUR ;BIR/LTL-Nightly Background Job - CONT'D ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
+2 ;This routine purges all DA transactions greater than 120 days old. It
+3 ;also purges all invoices from the DA ORDERS file if they are over the
+4 ;number of days set in 58.8. It is called by PSAPSI5.
+5 ;
+6 NEW DIC,DIE,DINUM,D0,D1,DLAYGO,DR,PSAS,PSA,PSALOC,PSAOUT,PSADT,DA,PSADRUG,PSADRUGN,PSAT,PSAR,X,Y
+7 SET PSALOC=0
+8 SET X="T-120"
DO ^%DT
SET PSADT=Y
+9 FOR
SET PSALOC=$ORDER(^PSD(58.8,PSALOC))
IF 'PSALOC
GOTO END
IF $PIECE($GET(^PSD(58.8,+PSALOC,0)),U,2)="P"
Begin DoDot:1
+10 SET PSADRUG=0
LUP FOR
SET PSADRUG=$ORDER(^PSD(58.8,+PSALOC,1,PSADRUG))
IF 'PSADRUG
QUIT
IF $ORDER(^PSD(58.8,+PSALOC,1,+PSADRUG,4,0))
Begin DoDot:2
+1 SET PSAT=0
+2 FOR
SET PSAT=$ORDER(^PSD(58.8,+PSALOC,1,+PSADRUG,4,PSAT))
IF 'PSAT
QUIT
IF $PIECE($GET(^PSD(58.81,+PSAT,0)),U,4)<PSADT&('$PIECE($GET(^PSD(58.81,+PSAT,"CS")),U))
Begin DoDot:3
+3 SET DIE="^PSD(58.8,+PSALOC,1,+PSADRUG,4,"
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DA=PSAT
SET DR=".01////@"
DO ^DIE
+4 SET DIE="^PSD(58.81,"
SET DA=PSAT
SET DR=".01////@"
DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+5 ;
ORDERS ;Deletes invoices from the DA ORDERS file if they are over the number
+1 ;of days set in 58.8.
+2 SET PSALOC=0
FOR
SET PSALOC=$ORDER(^PSD(58.811,"ALOC",PSALOC))
IF 'PSALOC
QUIT
Begin DoDot:1
+3 SET PSALOCDT=$SELECT(+$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",15):+$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",15),1:120)
SET X1=DT
SET X2=-PSALOCDT
DO C^%DTC
SET PSALOCDT=X
+4 SET PSADT=0
FOR
SET PSADT=$ORDER(^PSD(58.811,"ALOC",PSALOC,PSADT))
IF 'PSADT!(PSADT>PSALOCDT)
QUIT
Begin DoDot:2
+5 SET PSAIEN=0
FOR
SET PSAIEN=$ORDER(^PSD(58.811,"ALOC",PSALOC,PSADT,PSAIEN))
IF 'PSAIEN
QUIT
Begin DoDot:3
+6 SET PSAIEN1=0
FOR
SET PSAIEN1=$ORDER(^PSD(58.811,"ALOC",PSALOC,PSADT,PSAIEN,PSAIEN1))
IF 'PSAIEN1
QUIT
Begin DoDot:4
+7 IF $PIECE($GET(^PSD(58.811,PSAIEN,1,PSAIEN1,0)),"^",3)'="C"!('$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,0)))
QUIT
+8 SET DA(1)=PSAIEN
SET DA=PSAIEN1
SET DIK="^PSD(58.811,"_DA(1)_",1,"
DO ^DIK
KILL DA,DIK
End DoDot:4
+9 IF '$ORDER(^PSD(58.811,PSAIEN,1,0))
SET DA=PSAIEN
SET DIK="^PSD(58.811,"
DO ^DIK
KILL DA,DIK
End DoDot:3
End DoDot:2
End DoDot:1
+10 KILL PSADT,PSAIEN,PSAIEN1,PSALOC,PSALOCDT,X,X1,X2
END QUIT
