- 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
