Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBBPG7Y

FBBPG7Y.m

Go to the documentation of this file.
  1. FBBPG7Y ;SLT - PURGE BATCH FILE ENTRIES AFTER 7 YRS ;03/01/2015
  1. ;;3.5;FEE BASIS;**158**;JAN 30, 1995;Build 94
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. EN ; Main Entry Point
  1. ;
  1. N PRGDT,FNLZDT,IEN,ZNODE,BCNT,B,FBTYPE,FBDUZ
  1. S PRGDT=$$FMADD^XLFDT(DT,-2555)
  1. ;S PRGDT=2940121 ;$$FMADD^XLFDT(DT,-7650) - debug
  1. S BCNT=0
  1. ;
  1. S FNLZDT="" K ^TMP($J,"FBBPG7Y")
  1. F S FNLZDT=$O(^FBAA(161.7,"AF",FNLZDT)) Q:('FNLZDT!(FNLZDT>PRGDT)) D
  1. . S IEN=""
  1. . F S IEN=$O(^FBAA(161.7,"AF",FNLZDT,IEN)) Q:'IEN D
  1. . . S ZNODE=^FBAA(161.7,IEN,0),B=$P(ZNODE,U),FBTYPE=$P(ZNODE,U,3),FBDUZ=$P(ZNODE,U,5)
  1. . . ;
  1. . . I FBTYPE="B3" D MEDP(IEN)
  1. . . I FBTYPE="B2" D TRAVP(IEN)
  1. . . I FBTYPE="B5" D RPHP(IEN)
  1. . . I FBTYPE="B9" D CHP(IEN)
  1. . . ;
  1. . . S BCNT=BCNT+1
  1. . . S ^TMP($J,"FBBPG7Y",BCNT)=IEN_U_FNLZDT
  1. . . S DIK="^FBAA(161.7,",DA=IEN D ^DIK
  1. . ;
  1. ;
  1. D SNDBUL(PRGDT,BCNT)
  1. Q
  1. ;
  1. MEDP(BIEN) ;outpatient
  1. ;
  1. N PIEN,K,L,M
  1. S PIEN=0
  1. F S PIEN=$O(^FBAAC("AC",BIEN,PIEN)) Q:'PIEN D
  1. . S K=0
  1. . F S K=$O(^FBAAC("AC",BIEN,PIEN,K)) Q:'K D
  1. . . S L=0
  1. . . F S L=$O(^FBAAC("AC",BIEN,PIEN,K,L)) Q:'L D
  1. . . . S M=0
  1. . . . F S M=$O(^FBAAC("AC",BIEN,PIEN,K,L,M)) Q:'M D
  1. . . . . I $D(^FBAAC(PIEN,1,K,1,L,1,M,0)) D
  1. . . . . . S ^TMP($J,"FBBPG7Y",BCNT,"MEDP",K,L,M)=PIEN
  1. . . . . . S $P(^(0),U,8)=""
  1. K ^FBAAC("AC",BIEN)
  1. Q
  1. ;
  1. TRAVP(BIEN) ;travel
  1. ;
  1. N PIEN,K
  1. S PIEN=0
  1. F S PIEN=$O(^FBAAC("AD",BIEN,PIEN)) Q:'PIEN D
  1. . S K=0
  1. . F S K=$O(^FBAAC("AD",BIEN,PIEN,K)) Q:'K D
  1. . . I $D(^FBAAC(PIEN,3,K,0)) D
  1. . . . S ^TMP($J,"FBBPG7Y",BCNT,"TRAVP",K)=PIEN
  1. . . . S $P(^(0),U,2)=""
  1. K ^FBAAC("AD",BIEN)
  1. Q
  1. ;
  1. RPHP(BIEN) ;Rx
  1. ;
  1. N PIEN,K
  1. S PIEN=0
  1. F S PIEN=$O(^FBAA(162.1,"AE",BIEN,PIEN)) Q:'PIEN D
  1. . S K=0
  1. . F S K=$O(^FBAA(162.1,"AE",BIEN,PIEN,K)) Q:'K D
  1. . . I $D(^FBAA(162.1,PIEN,"RX",K,0)) D
  1. . . . S ^TMP($J,"FBBPG7Y",BCNT,"RPHP",K)=PIEN
  1. . . . S $P(^(0),U,17)=""
  1. K ^FBAA(162.1,"AE",BIEN),^FBAA(162.1,"AJ",BIEN)
  1. Q
  1. ;
  1. CHP(BIEN) ;inpatient
  1. ;
  1. N IIEN
  1. S IIEN=0
  1. F S IIEN=$O(^FBAAI("AC",BIEN,IIEN)) Q:'IIEN D
  1. . I $D(^FBAAI(IIEN,0)) D
  1. . . S ^TMP($J,"FBBPG7Y",BCNT,"CHP")=IIEN
  1. . . S $P(^FBAAI(IIEN,0),U,17)=""
  1. K ^FBAAI("AC",BIEN),^FBAAI("AE",BIEN)
  1. Q
  1. ;
  1. SNDBUL(PRGDT,BCNT) ;send a bulletin to a mail group
  1. ;
  1. N XMB,FBPGDT,Y,XMY
  1. S XMB(1)=$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"Unknown User")
  1. S Y=DT D PDF^FBAAUTL S FBPGDT=Y,XMB(2)=FBPGDT
  1. S Y=PRGDT D PDF^FBAAUTL S XMB(3)=Y
  1. S XMB(4)=BCNT
  1. S XMB="FBAA BATCH PURGE"
  1. ;debug
  1. S XMY=DUZ
  1. ;
  1. D ^XMB
  1. Q
  1. ;