- 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 Feb 18, 2025@23:23:51 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 ;