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 Oct 16, 2024@18:14:13 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
