FBBPG7Y ;SLT - PURGE BATCH FILE ENTRIES AFTER 7 YRS ;03/01/2015
;;3.5;FEE BASIS;**158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
Q
;
EN ; Main Entry Point
;
N PRGDT,FNLZDT,IEN,ZNODE,BCNT,B,FBTYPE,FBDUZ
S PRGDT=$$FMADD^XLFDT(DT,-2555)
;S PRGDT=2940121 ;$$FMADD^XLFDT(DT,-7650) - debug
S BCNT=0
;
S FNLZDT="" K ^TMP($J,"FBBPG7Y")
F S FNLZDT=$O(^FBAA(161.7,"AF",FNLZDT)) Q:('FNLZDT!(FNLZDT>PRGDT)) D
. S IEN=""
. F S IEN=$O(^FBAA(161.7,"AF",FNLZDT,IEN)) Q:'IEN D
. . S ZNODE=^FBAA(161.7,IEN,0),B=$P(ZNODE,U),FBTYPE=$P(ZNODE,U,3),FBDUZ=$P(ZNODE,U,5)
. . ;
. . I FBTYPE="B3" D MEDP(IEN)
. . I FBTYPE="B2" D TRAVP(IEN)
. . I FBTYPE="B5" D RPHP(IEN)
. . I FBTYPE="B9" D CHP(IEN)
. . ;
. . S BCNT=BCNT+1
. . S ^TMP($J,"FBBPG7Y",BCNT)=IEN_U_FNLZDT
. . S DIK="^FBAA(161.7,",DA=IEN D ^DIK
. ;
;
D SNDBUL(PRGDT,BCNT)
Q
;
MEDP(BIEN) ;outpatient
;
N PIEN,K,L,M
S PIEN=0
F S PIEN=$O(^FBAAC("AC",BIEN,PIEN)) Q:'PIEN D
. S K=0
. F S K=$O(^FBAAC("AC",BIEN,PIEN,K)) Q:'K D
. . S L=0
. . F S L=$O(^FBAAC("AC",BIEN,PIEN,K,L)) Q:'L D
. . . S M=0
. . . F S M=$O(^FBAAC("AC",BIEN,PIEN,K,L,M)) Q:'M D
. . . . I $D(^FBAAC(PIEN,1,K,1,L,1,M,0)) D
. . . . . S ^TMP($J,"FBBPG7Y",BCNT,"MEDP",K,L,M)=PIEN
. . . . . S $P(^(0),U,8)=""
K ^FBAAC("AC",BIEN)
Q
;
TRAVP(BIEN) ;travel
;
N PIEN,K
S PIEN=0
F S PIEN=$O(^FBAAC("AD",BIEN,PIEN)) Q:'PIEN D
. S K=0
. F S K=$O(^FBAAC("AD",BIEN,PIEN,K)) Q:'K D
. . I $D(^FBAAC(PIEN,3,K,0)) D
. . . S ^TMP($J,"FBBPG7Y",BCNT,"TRAVP",K)=PIEN
. . . S $P(^(0),U,2)=""
K ^FBAAC("AD",BIEN)
Q
;
RPHP(BIEN) ;Rx
;
N PIEN,K
S PIEN=0
F S PIEN=$O(^FBAA(162.1,"AE",BIEN,PIEN)) Q:'PIEN D
. S K=0
. F S K=$O(^FBAA(162.1,"AE",BIEN,PIEN,K)) Q:'K D
. . I $D(^FBAA(162.1,PIEN,"RX",K,0)) D
. . . S ^TMP($J,"FBBPG7Y",BCNT,"RPHP",K)=PIEN
. . . S $P(^(0),U,17)=""
K ^FBAA(162.1,"AE",BIEN),^FBAA(162.1,"AJ",BIEN)
Q
;
CHP(BIEN) ;inpatient
;
N IIEN
S IIEN=0
F S IIEN=$O(^FBAAI("AC",BIEN,IIEN)) Q:'IIEN D
. I $D(^FBAAI(IIEN,0)) D
. . S ^TMP($J,"FBBPG7Y",BCNT,"CHP")=IIEN
. . S $P(^FBAAI(IIEN,0),U,17)=""
K ^FBAAI("AC",BIEN),^FBAAI("AE",BIEN)
Q
;
SNDBUL(PRGDT,BCNT) ;send a bulletin to a mail group
;
N XMB,FBPGDT,Y,XMY
S XMB(1)=$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"Unknown User")
S Y=DT D PDF^FBAAUTL S FBPGDT=Y,XMB(2)=FBPGDT
S Y=PRGDT D PDF^FBAAUTL S XMB(3)=Y
S XMB(4)=BCNT
S XMB="FBAA BATCH PURGE"
;debug
S XMY=DUZ
;
D ^XMB
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBBPG7Y 2559 printed Dec 13, 2024@01:57:25 Page 2
FBBPG7Y ;SLT - PURGE BATCH FILE ENTRIES AFTER 7 YRS ;03/01/2015
+1 ;;3.5;FEE BASIS;**158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EN ; Main Entry Point
+1 ;
+2 NEW PRGDT,FNLZDT,IEN,ZNODE,BCNT,B,FBTYPE,FBDUZ
+3 SET PRGDT=$$FMADD^XLFDT(DT,-2555)
+4 ;S PRGDT=2940121 ;$$FMADD^XLFDT(DT,-7650) - debug
+5 SET BCNT=0
+6 ;
+7 SET FNLZDT=""
KILL ^TMP($JOB,"FBBPG7Y")
+8 FOR
SET FNLZDT=$ORDER(^FBAA(161.7,"AF",FNLZDT))
if ('FNLZDT!(FNLZDT>PRGDT))
QUIT
Begin DoDot:1
+9 SET IEN=""
+10 FOR
SET IEN=$ORDER(^FBAA(161.7,"AF",FNLZDT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+11 SET ZNODE=^FBAA(161.7,IEN,0)
SET B=$PIECE(ZNODE,U)
SET FBTYPE=$PIECE(ZNODE,U,3)
SET FBDUZ=$PIECE(ZNODE,U,5)
+12 ;
+13 IF FBTYPE="B3"
DO MEDP(IEN)
+14 IF FBTYPE="B2"
DO TRAVP(IEN)
+15 IF FBTYPE="B5"
DO RPHP(IEN)
+16 IF FBTYPE="B9"
DO CHP(IEN)
+17 ;
+18 SET BCNT=BCNT+1
+19 SET ^TMP($JOB,"FBBPG7Y",BCNT)=IEN_U_FNLZDT
+20 SET DIK="^FBAA(161.7,"
SET DA=IEN
DO ^DIK
End DoDot:2
+21 ;
End DoDot:1
+22 ;
+23 DO SNDBUL(PRGDT,BCNT)
+24 QUIT
+25 ;
MEDP(BIEN) ;outpatient
+1 ;
+2 NEW PIEN,K,L,M
+3 SET PIEN=0
+4 FOR
SET PIEN=$ORDER(^FBAAC("AC",BIEN,PIEN))
if 'PIEN
QUIT
Begin DoDot:1
+5 SET K=0
+6 FOR
SET K=$ORDER(^FBAAC("AC",BIEN,PIEN,K))
if 'K
QUIT
Begin DoDot:2
+7 SET L=0
+8 FOR
SET L=$ORDER(^FBAAC("AC",BIEN,PIEN,K,L))
if 'L
QUIT
Begin DoDot:3
+9 SET M=0
+10 FOR
SET M=$ORDER(^FBAAC("AC",BIEN,PIEN,K,L,M))
if 'M
QUIT
Begin DoDot:4
+11 IF $DATA(^FBAAC(PIEN,1,K,1,L,1,M,0))
Begin DoDot:5
+12 SET ^TMP($JOB,"FBBPG7Y",BCNT,"MEDP",K,L,M)=PIEN
+13 SET $PIECE(^(0),U,8)=""
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 KILL ^FBAAC("AC",BIEN)
+15 QUIT
+16 ;
TRAVP(BIEN) ;travel
+1 ;
+2 NEW PIEN,K
+3 SET PIEN=0
+4 FOR
SET PIEN=$ORDER(^FBAAC("AD",BIEN,PIEN))
if 'PIEN
QUIT
Begin DoDot:1
+5 SET K=0
+6 FOR
SET K=$ORDER(^FBAAC("AD",BIEN,PIEN,K))
if 'K
QUIT
Begin DoDot:2
+7 IF $DATA(^FBAAC(PIEN,3,K,0))
Begin DoDot:3
+8 SET ^TMP($JOB,"FBBPG7Y",BCNT,"TRAVP",K)=PIEN
+9 SET $PIECE(^(0),U,2)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 KILL ^FBAAC("AD",BIEN)
+11 QUIT
+12 ;
RPHP(BIEN) ;Rx
+1 ;
+2 NEW PIEN,K
+3 SET PIEN=0
+4 FOR
SET PIEN=$ORDER(^FBAA(162.1,"AE",BIEN,PIEN))
if 'PIEN
QUIT
Begin DoDot:1
+5 SET K=0
+6 FOR
SET K=$ORDER(^FBAA(162.1,"AE",BIEN,PIEN,K))
if 'K
QUIT
Begin DoDot:2
+7 IF $DATA(^FBAA(162.1,PIEN,"RX",K,0))
Begin DoDot:3
+8 SET ^TMP($JOB,"FBBPG7Y",BCNT,"RPHP",K)=PIEN
+9 SET $PIECE(^(0),U,17)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 KILL ^FBAA(162.1,"AE",BIEN),^FBAA(162.1,"AJ",BIEN)
+11 QUIT
+12 ;
CHP(BIEN) ;inpatient
+1 ;
+2 NEW IIEN
+3 SET IIEN=0
+4 FOR
SET IIEN=$ORDER(^FBAAI("AC",BIEN,IIEN))
if 'IIEN
QUIT
Begin DoDot:1
+5 IF $DATA(^FBAAI(IIEN,0))
Begin DoDot:2
+6 SET ^TMP($JOB,"FBBPG7Y",BCNT,"CHP")=IIEN
+7 SET $PIECE(^FBAAI(IIEN,0),U,17)=""
End DoDot:2
End DoDot:1
+8 KILL ^FBAAI("AC",BIEN),^FBAAI("AE",BIEN)
+9 QUIT
+10 ;
SNDBUL(PRGDT,BCNT) ;send a bulletin to a mail group
+1 ;
+2 NEW XMB,FBPGDT,Y,XMY
+3 SET XMB(1)=$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"Unknown User")
+4 SET Y=DT
DO PDF^FBAAUTL
SET FBPGDT=Y
SET XMB(2)=FBPGDT
+5 SET Y=PRGDT
DO PDF^FBAAUTL
SET XMB(3)=Y
+6 SET XMB(4)=BCNT
+7 SET XMB="FBAA BATCH PURGE"
+8 ;debug
+9 SET XMY=DUZ
+10 ;
+11 DO ^XMB
+12 QUIT
+13 ;
