IB20P405 ;OAK/ELZ - IB*2*405 POST-INIT TO POPULATE 362.4; 9/2/08
;;2.0;INTEGRATED BILLING;**405**;21-MAR-94;Build 4
;;Per VHA Directive 10-93-142 this routine should not be modified.
;
POST ;
D BMES^XPDUTL("Queuing Post-init to populate 362.4...")
N ZTDESC,ZTSAVE,ZTIO,ZTDTH,ZTRTN,ZTSK
S ZTDTH=$$NOW^XLFDT,ZTIO="",ZTDESC="IB*2*405 POST INSTALL"
S ZTRTN="DQ^IB20P405"
D ^%ZTLOAD
D BMES^XPDUTL("Post install queued task #"_ZTSK)
Q
;
DQ ; queued entry point
N IBX,IBDATA,IBCT,IBRX,IBDT,DFN,IBLIST,IBY,IBMSG,XMDUZ,XMTEXT,XMSUB,XMY,XMZ,IBRXN
;
S (IBCT,IBX)=0,IBLIST="IB20P405"
;
; loop through all 362.4 entries and try to populate the new .1 field
; if it is not already populated.
F S IBX=$O(^IBA(362.4,IBX)) Q:'IBX D
. S IBDATA=$G(^IBA(362.4,IBX,0))
. I '$L(IBDATA)!($L($P(IBDATA,"^",10))) Q
. S DFN=$P($G(^DGCR(399,+$P(IBDATA,"^",2),0)),"^",2) Q:'DFN
. S IBDT=$P(IBDATA,"^",3) Q:'IBDT
. S IBRXN=$P(IBDATA,"^")
. S IBRX=$P(IBDATA,"^",5)
. I '$L(IBRXN),'IBRX Q
. K ^TMP($J,IBLIST)
. D
.. I IBRX D RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R") Q
.. D RX^PSO52API(DFN,IBLIST,,IBRXN,"0,2,R")
.. S IBRX=$O(^TMP($J,IBLIST,DFN,0))
. Q:'IBRX
. ; matches original fill (old way)
. I IBDT=+$G(^TMP($J,IBLIST,DFN,IBRX,22)) D SET(IBX,0,.IBCT) Q
. ; look for match on refill (old way)
. S IBRF=0
. 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
. I IBRF D SET(IBX,IBRF,.IBCT) Q
. ; look for original fill for Released Date, Dispense Date, Issue Date
. I IBDT=+$P($G(^TMP($J,IBLIST,DFN,IBRX,1)),".") D SET(IBX,0,.IBCT) Q
. I IBDT=+$P($G(^TMP($J,IBLIST,DFN,IBRX,25)),".") D SET(IBX,0,.IBCT) Q
. I IBDT=+$P($G(^TMP($J,IBLIST,DFN,IBRX,31)),".") D SET(IBX,0,.IBCT) Q
. ; look for refills based on Release Date or Dispense Date
. 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
. I IBRF D SET(IBX,IBRF,.IBCT) Q
K ^TMP($J,IBLIST)
;
S IBMSG(1)=""
S IBMSG(2)="The post-install for IB*2*405 finished. "_IBCT_" records in 362.4 were"
S IBMSG(3)="populated with fill/refill data."
S XMSUB="IB*1*405 Post-Install Completed"
S XMDUZ="INTEGRATED BILLING PACKAGE"
S XMTEXT="IBMSG("
S XMY(DUZ)=""
D ^XMD
Q
;
SET(DA,IBRF,IBCT) ;
S IBCT=IBCT+1
S $P(^IBA(362.4,DA,0),"^",10)=IBRF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P405 2456 printed Apr 09, 2024@21:26:50 Page 2
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
+2 ;;Per VHA Directive 10-93-142 this routine should not be modified.
+3 ;
POST ;
+1 DO BMES^XPDUTL("Queuing Post-init to populate 362.4...")
+2 NEW ZTDESC,ZTSAVE,ZTIO,ZTDTH,ZTRTN,ZTSK
+3 SET ZTDTH=$$NOW^XLFDT
SET ZTIO=""
SET ZTDESC="IB*2*405 POST INSTALL"
+4 SET ZTRTN="DQ^IB20P405"
+5 DO ^%ZTLOAD
+6 DO BMES^XPDUTL("Post install queued task #"_ZTSK)
+7 QUIT
+8 ;
DQ ; queued entry point
+1 NEW IBX,IBDATA,IBCT,IBRX,IBDT,DFN,IBLIST,IBY,IBMSG,XMDUZ,XMTEXT,XMSUB,XMY,XMZ,IBRXN
+2 ;
+3 SET (IBCT,IBX)=0
SET IBLIST="IB20P405"
+4 ;
+5 ; loop through all 362.4 entries and try to populate the new .1 field
+6 ; if it is not already populated.
+7 FOR
SET IBX=$ORDER(^IBA(362.4,IBX))
if 'IBX
QUIT
Begin DoDot:1
+8 SET IBDATA=$GET(^IBA(362.4,IBX,0))
+9 IF '$LENGTH(IBDATA)!($LENGTH($PIECE(IBDATA,"^",10)))
QUIT
+10 SET DFN=$PIECE($GET(^DGCR(399,+$PIECE(IBDATA,"^",2),0)),"^",2)
if 'DFN
QUIT
+11 SET IBDT=$PIECE(IBDATA,"^",3)
if 'IBDT
QUIT
+12 SET IBRXN=$PIECE(IBDATA,"^")
+13 SET IBRX=$PIECE(IBDATA,"^",5)
+14 IF '$LENGTH(IBRXN)
IF 'IBRX
QUIT
+15 KILL ^TMP($JOB,IBLIST)
+16 Begin DoDot:2
+17 IF IBRX
DO RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R")
QUIT
+18 DO RX^PSO52API(DFN,IBLIST,,IBRXN,"0,2,R")
+19 SET IBRX=$ORDER(^TMP($JOB,IBLIST,DFN,0))
End DoDot:2
+20 if 'IBRX
QUIT
+21 ; matches original fill (old way)
+22 IF IBDT=+$GET(^TMP($JOB,IBLIST,DFN,IBRX,22))
DO SET(IBX,0,.IBCT)
QUIT
+23 ; look for match on refill (old way)
+24 SET IBRF=0
+25 SET IBY=0
FOR
SET IBY=$ORDER(^TMP($JOB,IBLIST,DFN,IBRX,"RF",IBY))
if 'IBY
QUIT
IF IBDT=+$GET(^TMP($JOB,IBLIST,DFN,IBRX,"RF",IBY,.01))
SET IBRF=IBY
QUIT
+26 IF IBRF
DO SET(IBX,IBRF,.IBCT)
QUIT
+27 ; look for original fill for Released Date, Dispense Date, Issue Date
+28 IF IBDT=+$PIECE($GET(^TMP($JOB,IBLIST,DFN,IBRX,1)),".")
DO SET(IBX,0,.IBCT)
QUIT
+29 IF IBDT=+$PIECE($GET(^TMP($JOB,IBLIST,DFN,IBRX,25)),".")
DO SET(IBX,0,.IBCT)
QUIT
+30 IF IBDT=+$PIECE($GET(^TMP($JOB,IBLIST,DFN,IBRX,31)),".")
DO SET(IBX,0,.IBCT)
QUIT
+31 ; look for refills based on Release Date or Dispense Date
+32 SET IBY=0
FOR
SET IBY=$ORDER(^TMP($JOB,IBLIST,DFN,IBRX,"RF",IBY))
if 'IBY
QUIT
IF IBDT=+$PIECE($GET(^TMP($JOB,IBLIST,DFN,IBRX,"RF",IBY,17)),".")!(IBDT=+$PIECE($GET(^(10.1)),"."))
SET IBRF=IBY
QUIT
+33 IF IBRF
DO SET(IBX,IBRF,.IBCT)
QUIT
End DoDot:1
+34 KILL ^TMP($JOB,IBLIST)
+35 ;
+36 SET IBMSG(1)=""
+37 SET IBMSG(2)="The post-install for IB*2*405 finished. "_IBCT_" records in 362.4 were"
+38 SET IBMSG(3)="populated with fill/refill data."
+39 SET XMSUB="IB*1*405 Post-Install Completed"
+40 SET XMDUZ="INTEGRATED BILLING PACKAGE"
+41 SET XMTEXT="IBMSG("
+42 SET XMY(DUZ)=""
+43 DO ^XMD
+44 QUIT
+45 ;
SET(DA,IBRF,IBCT) ;
+1 SET IBCT=IBCT+1
+2 SET $PIECE(^IBA(362.4,DA,0),"^",10)=IBRF
+3 QUIT
