- 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 Feb 18, 2025@23:29:01 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