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

IB20P405.m

Go to the documentation of this file.
  1. IB20P405 ;OAK/ELZ - IB*2*405 POST-INIT TO POPULATE 362.4; 9/2/08
  1. ;;2.0;INTEGRATED BILLING;**405**;21-MAR-94;Build 4
  1. ;;Per VHA Directive 10-93-142 this routine should not be modified.
  1. ;
  1. POST ;
  1. D BMES^XPDUTL("Queuing Post-init to populate 362.4...")
  1. N ZTDESC,ZTSAVE,ZTIO,ZTDTH,ZTRTN,ZTSK
  1. S ZTDTH=$$NOW^XLFDT,ZTIO="",ZTDESC="IB*2*405 POST INSTALL"
  1. S ZTRTN="DQ^IB20P405"
  1. D ^%ZTLOAD
  1. D BMES^XPDUTL("Post install queued task #"_ZTSK)
  1. Q
  1. ;
  1. DQ ; queued entry point
  1. N IBX,IBDATA,IBCT,IBRX,IBDT,DFN,IBLIST,IBY,IBMSG,XMDUZ,XMTEXT,XMSUB,XMY,XMZ,IBRXN
  1. ;
  1. S (IBCT,IBX)=0,IBLIST="IB20P405"
  1. ;
  1. ; loop through all 362.4 entries and try to populate the new .1 field
  1. ; if it is not already populated.
  1. F S IBX=$O(^IBA(362.4,IBX)) Q:'IBX D
  1. . S IBDATA=$G(^IBA(362.4,IBX,0))
  1. . I '$L(IBDATA)!($L($P(IBDATA,"^",10))) Q
  1. . S DFN=$P($G(^DGCR(399,+$P(IBDATA,"^",2),0)),"^",2) Q:'DFN
  1. . S IBDT=$P(IBDATA,"^",3) Q:'IBDT
  1. . S IBRXN=$P(IBDATA,"^")
  1. . S IBRX=$P(IBDATA,"^",5)
  1. . I '$L(IBRXN),'IBRX Q
  1. . K ^TMP($J,IBLIST)
  1. . D
  1. .. I IBRX D RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R") Q
  1. .. D RX^PSO52API(DFN,IBLIST,,IBRXN,"0,2,R")
  1. .. S IBRX=$O(^TMP($J,IBLIST,DFN,0))
  1. . Q:'IBRX
  1. . ; matches original fill (old way)
  1. . I IBDT=+$G(^TMP($J,IBLIST,DFN,IBRX,22)) D SET(IBX,0,.IBCT) Q
  1. . ; look for match on refill (old way)
  1. . S IBRF=0
  1. . S IBY=0 F S IBY=$O(^TMP($J,IBLIST,DFN,IBRX,"RF",IBY)) Q:'IBY I IBDT=+$G(^TMP($J,IBLIST,DFN,IBRX,"RF",IBY,.01)) S IBRF=IBY Q
  1. . I IBRF D SET(IBX,IBRF,.IBCT) Q
  1. . ; look for original fill for Released Date, Dispense Date, Issue Date
  1. . I IBDT=+$P($G(^TMP($J,IBLIST,DFN,IBRX,1)),".") D SET(IBX,0,.IBCT) Q
  1. . I IBDT=+$P($G(^TMP($J,IBLIST,DFN,IBRX,25)),".") D SET(IBX,0,.IBCT) Q
  1. . I IBDT=+$P($G(^TMP($J,IBLIST,DFN,IBRX,31)),".") D SET(IBX,0,.IBCT) Q
  1. . ; look for refills based on Release Date or Dispense Date
  1. . S IBY=0 F S IBY=$O(^TMP($J,IBLIST,DFN,IBRX,"RF",IBY)) Q:'IBY I IBDT=+$P($G(^TMP($J,IBLIST,DFN,IBRX,"RF",IBY,17)),".")!(IBDT=+$P($G(^(10.1)),".")) S IBRF=IBY Q
  1. . I IBRF D SET(IBX,IBRF,.IBCT) Q
  1. K ^TMP($J,IBLIST)
  1. ;
  1. S IBMSG(1)=""
  1. S IBMSG(2)="The post-install for IB*2*405 finished. "_IBCT_" records in 362.4 were"
  1. S IBMSG(3)="populated with fill/refill data."
  1. S XMSUB="IB*1*405 Post-Install Completed"
  1. S XMDUZ="INTEGRATED BILLING PACKAGE"
  1. S XMTEXT="IBMSG("
  1. S XMY(DUZ)=""
  1. D ^XMD
  1. Q
  1. ;
  1. SET(DA,IBRF,IBCT) ;
  1. S IBCT=IBCT+1
  1. S $P(^IBA(362.4,DA,0),"^",10)=IBRF
  1. Q