- IBCIWK ;DSI/JSR - WORKSHEET UTILITY ;6-MAR-2001
- ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;; ** Program Description **
- ; This is the main routine that calls a ListManager template.
- ; Prior to calling the LM template, data for a specific IBIFN is
- ; extracted and formatted for LM to display.
- ; This routine is the main routine called when the user is in
- ; the bill edit screen. Irrespective of security access IBCIMG is
- ; always called either directly or in-directly.
- ; Parameters
- ; Call = (0 or 1) This is a flag that determines which ListManager
- ; Template to call.
- ; 0 indicates that the browse only template should be invoked
- ; 1 indicates that either a Manager or Clerk template will be invoked
- ; based on security key access.
- ;
- EN(CALL) ;enter set up data
- ;
- ;
- N DFN,DISYS,IBA2,IBAC,IBAC1,IBAD,IBADD1,IBBNO,IBDT
- N IBCSCPP,IBLINE,IBMO,IBPOPOUT,IBPREV,IBSCNN,IBSR,IBSR1,IBV
- N IBV1,IBVI,IBVO,IBVV,IBX,IBXERR,TYPE
- N IBCIASI,IBCIASN,IBCIBII,IBCIBIL,IBCIBIR,IBCICAR,IBCICLNO,IBCICM1
- N IBCICM2,IBCICMP,IBCICNM,IBCICOD,IBCIDAT,IBCIDOB,IBCIDPT,IBCIERL,IBCIERT,IBCIEVEN,IBCIEVV,IBCIINS
- N IBCILD1,IBCILD2,IBCILEV,IBCINAM,IBCIPAD,IBCIPTI,IBCISER,IBCISEX,IBCISRR,IBCIYYY
- N IBCIZZZ,IBCSCPP,LMBDATE,LMCHARG,LMCPT,LMEDATE,LMLINE,LMMOD,LMPOS,LMTOS,LMUNIT
- N QUITDP,I,X,Y,Z,YARR,DATA,VAERR,XMDUM,XMZ,IB,IBCCCC,IBCIPRV,IBCI345,IBCISSN
- ;
- S QUITDP=1
- F D LOOP Q:QUITDP=0
- G XIT
- Q
- LOOP ;
- K ^TMP("IBCILM",$J)
- S IBCI345=0 ;JSR 6/22/01 Flag to determine when to kill 3,4,5 node
- I CALL=0 D
- . I '$P($G(^IBA(351.9,IBIFN,3)),U,1) S IBCI345=1 D UPDT^IBCIADD1
- . I $G(IBCISNT)=3 M ^TMP("IBCILM",$J)=^TMP("IBCITST",$J)
- . E M ^TMP("IBCILM",$J)=^IBA(351.9,IBIFN,1)
- . D GDATA
- . D EN^VALM("IBCI CLAIMSMANAGER WK BROWSE")
- I CALL=1 D
- . I '$P($G(^IBA(351.9,IBIFN,3)),U,1) S IBCI345=1 D UPDT^IBCIADD1
- . I '$D(IBCISNT)!($G(IBCISNT)'=3) M ^TMP("IBCILM",$J)=^IBA(351.9,IBIFN,1)
- . D GDATA
- . I '$D(^XUSEC("IBCI CLAIMSMANAGER OVERRIDE",DUZ)) D EN^VALM("IBCI CLAIMSMANAGER CLERK WK")
- . I $D(^XUSEC("IBCI CLAIMSMANAGER OVERRIDE",DUZ)) D EN^VALM("IBCI CLAIMSMANAGER MGR WK")
- I IBCI345 D DELTI^IBCIUT4 ; JSR 6/22/01
- Q
- GDATA ; sets
- NEW X,X1,X2,X3,X4,Y
- K IBCIPAD S $P(IBCIPAD," ",79)=""
- S IBCIDAT=$G(^DGCR(399,IBIFN,0))
- S IBCICLNO=$P(IBCIDAT,U,1)_IBCIPAD
- S IBCIPTI=$P(IBCIDAT,U,2)
- I IBCIPTI S IBCIDPT=$G(^DPT(IBCIPTI,0))
- S IBCIDOB=$P(IBCIDPT,U,3)
- S IBCISSN=$P(IBCIDPT,U,9) ;JSR 6/25/2001
- S Y=IBCIDOB X ^DD("DD")
- S IBCIBIR=Y_IBCIPAD
- S IBCISEX=$P(IBCIDPT,U,2)_IBCIPAD
- S IBCINAM=$P(IBCIDPT,U,1)
- S X=$E(IBCINAM,1,19)_" ("_$E(IBCISSN,6,9)_")",X1=27
- S IBCINAM=$$FILL^IBCIUT2 ; ESG 7/13/01
- S IBCIEVEN=$P(IBCIDAT,U,3)
- S Y=IBCIEVEN X ^DD("DD")
- S IBCIEVV=$E(Y,1,11)
- S IBCIEVV=$TR(IBCIEVV,"@","")
- S IBCIPRV=$P($$RPHY^IBCIUT1(IBIFN),U,1)_IBCIPAD
- S IBCICOD=$$CODER^IBCIUT5(IBIFN)
- S IBCICNM=$P(IBCICOD,U,3)
- S IBCICNM=IBCICNM_IBCIPAD
- S IBCISER=$P(IBCICOD,U,1)
- S IBCISRR=$S(IBCISER="O":"OP",IBCISER="I":"IP",1:"UK")
- S IBCIBII=$$BILLER^IBCIUT5(IBIFN)
- S IBCIBIL=$P(IBCIBII,U,2)
- S IBCIBIL=IBCIBIL_IBCIPAD
- S IBCIASI=$P($G(^IBA(351.9,IBIFN,0)),U,12)
- I IBCIASI S IBCIASN=$P($G(^VA(200,IBCIASI,0)),U,1)
- E S IBCIASN=IBCIPAD
- S IBCIINS=$$FINDINS^IBCEF1(IBIFN)
- S IBCICAR=""
- S:IBCIINS IBCICAR=$P($G(^DIC(36,IBCIINS,0)),U,1)
- S IBCICAR=IBCICAR_IBCIPAD
- Q
- XIT ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCIWK 3475 printed Jan 18, 2025@03:14:46 Page 2
- IBCIWK ;DSI/JSR - WORKSHEET UTILITY ;6-MAR-2001
- +1 ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;; ** Program Description **
- +4 ; This is the main routine that calls a ListManager template.
- +5 ; Prior to calling the LM template, data for a specific IBIFN is
- +6 ; extracted and formatted for LM to display.
- +7 ; This routine is the main routine called when the user is in
- +8 ; the bill edit screen. Irrespective of security access IBCIMG is
- +9 ; always called either directly or in-directly.
- +10 ; Parameters
- +11 ; Call = (0 or 1) This is a flag that determines which ListManager
- +12 ; Template to call.
- +13 ; 0 indicates that the browse only template should be invoked
- +14 ; 1 indicates that either a Manager or Clerk template will be invoked
- +15 ; based on security key access.
- +16 ;
- EN(CALL) ;enter set up data
- +1 ;
- +2 ;
- +3 NEW DFN,DISYS,IBA2,IBAC,IBAC1,IBAD,IBADD1,IBBNO,IBDT
- +4 NEW IBCSCPP,IBLINE,IBMO,IBPOPOUT,IBPREV,IBSCNN,IBSR,IBSR1,IBV
- +5 NEW IBV1,IBVI,IBVO,IBVV,IBX,IBXERR,TYPE
- +6 NEW IBCIASI,IBCIASN,IBCIBII,IBCIBIL,IBCIBIR,IBCICAR,IBCICLNO,IBCICM1
- +7 NEW IBCICM2,IBCICMP,IBCICNM,IBCICOD,IBCIDAT,IBCIDOB,IBCIDPT,IBCIERL,IBCIERT,IBCIEVEN,IBCIEVV,IBCIINS
- +8 NEW IBCILD1,IBCILD2,IBCILEV,IBCINAM,IBCIPAD,IBCIPTI,IBCISER,IBCISEX,IBCISRR,IBCIYYY
- +9 NEW IBCIZZZ,IBCSCPP,LMBDATE,LMCHARG,LMCPT,LMEDATE,LMLINE,LMMOD,LMPOS,LMTOS,LMUNIT
- +10 NEW QUITDP,I,X,Y,Z,YARR,DATA,VAERR,XMDUM,XMZ,IB,IBCCCC,IBCIPRV,IBCI345,IBCISSN
- +11 ;
- +12 SET QUITDP=1
- +13 FOR
- DO LOOP
- if QUITDP=0
- QUIT
- +14 GOTO XIT
- +15 QUIT
- LOOP ;
- +1 KILL ^TMP("IBCILM",$JOB)
- +2 ;JSR 6/22/01 Flag to determine when to kill 3,4,5 node
- SET IBCI345=0
- +3 IF CALL=0
- Begin DoDot:1
- +4 IF '$PIECE($GET(^IBA(351.9,IBIFN,3)),U,1)
- SET IBCI345=1
- DO UPDT^IBCIADD1
- +5 IF $GET(IBCISNT)=3
- MERGE ^TMP("IBCILM",$JOB)=^TMP("IBCITST",$JOB)
- +6 IF '$TEST
- MERGE ^TMP("IBCILM",$JOB)=^IBA(351.9,IBIFN,1)
- +7 DO GDATA
- +8 DO EN^VALM("IBCI CLAIMSMANAGER WK BROWSE")
- End DoDot:1
- +9 IF CALL=1
- Begin DoDot:1
- +10 IF '$PIECE($GET(^IBA(351.9,IBIFN,3)),U,1)
- SET IBCI345=1
- DO UPDT^IBCIADD1
- +11 IF '$DATA(IBCISNT)!($GET(IBCISNT)'=3)
- MERGE ^TMP("IBCILM",$JOB)=^IBA(351.9,IBIFN,1)
- +12 DO GDATA
- +13 IF '$DATA(^XUSEC("IBCI CLAIMSMANAGER OVERRIDE",DUZ))
- DO EN^VALM("IBCI CLAIMSMANAGER CLERK WK")
- +14 IF $DATA(^XUSEC("IBCI CLAIMSMANAGER OVERRIDE",DUZ))
- DO EN^VALM("IBCI CLAIMSMANAGER MGR WK")
- End DoDot:1
- +15 ; JSR 6/22/01
- IF IBCI345
- DO DELTI^IBCIUT4
- +16 QUIT
- GDATA ; sets
- +1 NEW X,X1,X2,X3,X4,Y
- +2 KILL IBCIPAD
- SET $PIECE(IBCIPAD," ",79)=""
- +3 SET IBCIDAT=$GET(^DGCR(399,IBIFN,0))
- +4 SET IBCICLNO=$PIECE(IBCIDAT,U,1)_IBCIPAD
- +5 SET IBCIPTI=$PIECE(IBCIDAT,U,2)
- +6 IF IBCIPTI
- SET IBCIDPT=$GET(^DPT(IBCIPTI,0))
- +7 SET IBCIDOB=$PIECE(IBCIDPT,U,3)
- +8 ;JSR 6/25/2001
- SET IBCISSN=$PIECE(IBCIDPT,U,9)
- +9 SET Y=IBCIDOB
- XECUTE ^DD("DD")
- +10 SET IBCIBIR=Y_IBCIPAD
- +11 SET IBCISEX=$PIECE(IBCIDPT,U,2)_IBCIPAD
- +12 SET IBCINAM=$PIECE(IBCIDPT,U,1)
- +13 SET X=$EXTRACT(IBCINAM,1,19)_" ("_$EXTRACT(IBCISSN,6,9)_")"
- SET X1=27
- +14 ; ESG 7/13/01
- SET IBCINAM=$$FILL^IBCIUT2
- +15 SET IBCIEVEN=$PIECE(IBCIDAT,U,3)
- +16 SET Y=IBCIEVEN
- XECUTE ^DD("DD")
- +17 SET IBCIEVV=$EXTRACT(Y,1,11)
- +18 SET IBCIEVV=$TRANSLATE(IBCIEVV,"@","")
- +19 SET IBCIPRV=$PIECE($$RPHY^IBCIUT1(IBIFN),U,1)_IBCIPAD
- +20 SET IBCICOD=$$CODER^IBCIUT5(IBIFN)
- +21 SET IBCICNM=$PIECE(IBCICOD,U,3)
- +22 SET IBCICNM=IBCICNM_IBCIPAD
- +23 SET IBCISER=$PIECE(IBCICOD,U,1)
- +24 SET IBCISRR=$SELECT(IBCISER="O":"OP",IBCISER="I":"IP",1:"UK")
- +25 SET IBCIBII=$$BILLER^IBCIUT5(IBIFN)
- +26 SET IBCIBIL=$PIECE(IBCIBII,U,2)
- +27 SET IBCIBIL=IBCIBIL_IBCIPAD
- +28 SET IBCIASI=$PIECE($GET(^IBA(351.9,IBIFN,0)),U,12)
- +29 IF IBCIASI
- SET IBCIASN=$PIECE($GET(^VA(200,IBCIASI,0)),U,1)
- +30 IF '$TEST
- SET IBCIASN=IBCIPAD
- +31 SET IBCIINS=$$FINDINS^IBCEF1(IBIFN)
- +32 SET IBCICAR=""
- +33 if IBCIINS
- SET IBCICAR=$PIECE($GET(^DIC(36,IBCIINS,0)),U,1)
- +34 SET IBCICAR=IBCICAR_IBCIPAD
- +35 QUIT
- XIT ;
- +1 QUIT