IBJDF8I ;ALB/RRG-ADD/EDIT IB DM WORKLOAD PARAMETERS ;11/06/00
;;2.0;INTEGRATED BILLING;**123,604**;21-MAR-94;Build 11
;;Per VA Directive 6402, this routine should not be modified.
;
START D BEG G EXIT:IBQUIT I IBPRONLY G START
D ASSIGN G START:IBQUIT
I IBJOB="A" D ADD G START:IBQUIT
I IBJOB="E" D EDIT^IBJDF8I1 G START:IBQUIT
I IBJOB="D" D DELETE G START:IBQUIT
L -^IBE(351.73,IBCL)
G START
Q
;
BEG ;Start editing workload paramters
N DIC,IBDELFLG S (IBQUIT,IBPRONLY)=0 S (IBDA0,IBCL)="",IBDELFLG=1
;S DIC="^IBE(351.73,",DIC(0)="QEAML",DLAYGO=351.73,DIC("A")="Select Clerk: " ; IB*2.0*604 - original code
S DIC="^VA(200,",DIC(0)="QEAMV",DIC("A")="Select Clerk: " ; *604-Search NEW PERSON (#200) file for clerk
D ^DIC I ($D(DTOUT))!($D(DUOUT))!(Y'>0) S IBQUIT=1 Q
; *604-Use IEN of entry found in file #200 to search file #351.73
; If no match is found in #351.73, allow a new entry to be made using the existing entry in #200
S X=+Y,DIC="^IBE(351.73,",DIC(0)="QELUX",DLAYGO=351.73 ; *604
D ^DIC I ($D(DTOUT))!($D(DUOUT))!(Y'>0) S IBQUIT=1 Q ; *604
S IBCL=+Y W !
L +^IBE(351.73,IBCL):2 I '$T W !?3,"Another user is editing this entry." G BEG
I $P(^IBE(351.73,IBCL,0),"^",3)="" D
. S DIE=DIC,DR=".03////"_DUZ,DA=IBCL D ^DIE K DIE,DR,DA
PRONLY S DIR(0)="351.73,.02",DA=IBCL,IBDELFLG=1
D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) L -^IBE(351.73,IBCL) G BEG
S IBPRONLY=Y K DIROUT,DTOUT,DUOUT
I 'IBPRONLY S $P(^IBE(351.73,IBCL,0),"^",2)=0 Q
I IBPRONLY D Q:IBQUIT I 'IBDELFLG G PRONLY
. I $O(^IBE(351.73,IBCL,1,0)) D
. . S DIR(0)="Y",DIR("B")="NO"
. . S DIR("A",1)="There are existing assignments for this clerk."
. . S DIR("A",2)="Those assignments must be deleted before the 'Productivity Report Only'"
. . S DIR("A",3)=" flag can be changed to 'Yes'."
. . S DIR("A")="Do you want to delete the existing assignments now"
. . D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) L -^IBE(351.73,IBCL) S IBQUIT=1 Q
. . K DIROUT,DTOUT,DUOUT I 'Y S IBDELFLG=0
. . ; Delete all assignments and change 'Prod Rpt only' flag to YES
. . I Y S IBASNUM=0 F S IBASNUM=$O(^IBE(351.73,IBCL,1,IBASNUM)) Q:'IBASNUM D S $P(^IBE(351.73,IBCL,0),"^",2)=1 W !?3,"Productivity Report Only? changed to 'YES'..." L -^IBE(351.73,IBCL)
. . . S DA(1)=IBCL,DA=IBASNUM,DIK="^IBE(351.73,"_DA(1)_",1," D ^DIK
. . . K DA,DIK
. . . W !?3,"Assignment # "_IBASNUM_" deleted..."
Q
ASSIGN ; Start editing assignments
;
; - Build assignment array for display
S IBASNUM=0,IBNEWASN=1 K IBPRONLY,IBAS
N IBBCAT,IBMBAL,IBSUP,IBFOTP,IBLBY,IBERC
F S IBASNUM=$O(^IBE(351.73,IBCL,1,IBASNUM)) Q:'IBASNUM D
. S IBASDA0=$G(^IBE(351.73,IBCL,1,IBASNUM,0)),IBBCAT=$P(IBASDA0,"^",2)
. S IBMBAL=$P(IBASDA0,"^",3),IBSUP=$P(IBASDA0,"^",4)
. S IBERC=$P(IBASDA0,"^",5)
. S IBFOTP=$$CATTYP^IBJD1(IBBCAT)
. I IBFOTP="F" S IBASDA1=$G(^IBE(351.73,IBCL,1,IBASNUM,1)) D
. . S IBLBY=$S($P(IBASDA1,"^",1)'="":"LAST PMT",1:"")
. . S IBLBY=IBLBY_$S(($P(IBASDA1,"^",2)="")&($P(IBASDA1,"^",3)=""):"",IBLBY="":"NAME",1:"/NAME")
. . S IBLBY=IBLBY_$S(($P(IBASDA1,"^",4)="")&($P(IBASDA1,"^",5)=""):"",IBLBY="":"SSN",1:"/SSN")
. I IBFOTP="T" S IBASDA2=$G(^IBE(351.73,IBCL,1,IBASNUM,2)) D
. . S IBLBY=$S($P(IBASDA2,"^",1)'="":"LAST TRX",1:"")
. . S IBLBY=IBLBY_$S($P(IBASDA2,"^",8)="":"",IBLBY="":"REC.TYPE",1:"/REC.TYPE")
. . S IBLBY=IBLBY_$S(($P(IBASDA2,"^",2)="")&($P(IBASDA2,"^",3)=""):"",IBLBY="":"CARRIER",1:"/CARRIER")
. . S IBLBY=IBLBY_$S(($P(IBASDA2,"^",4)="")&($P(IBASDA2,"^",5)=""):"",IBLBY="":"NAME",1:"/NAME")
. . S IBLBY=IBLBY_$S(($P(IBASDA2,"^",6)="")&($P(IBASDA2,"^",7)=""):"",IBLBY="":"SSN",1:"/SSN")
. S IBAS(IBASNUM)=$P($G(^PRCA(430.2,IBBCAT,0)),"^",1)_"^"
. S IBAS(IBASNUM)=IBAS(IBASNUM)_IBMBAL_"^"_$P($G(^VA(200,+IBSUP,0)),"^",1)_"^"
. S IBAS(IBASNUM)=IBAS(IBASNUM)_IBLBY_"^"_IBERC
;
; - Display assignment array
S IBJOB="" N IBASDAT
I '$D(IBAS) S IBJOB="A" Q
S IBASNUM=0
W !,?38,"EXCLUDE REFER"
W !,"ASSIGNMENT",?12,"CATEGORY",?26,"MIN BALANCE",?38,"TO REG COUNSEL"
W ?53,"LIMITED BY CARRIER/NAME/SSN"
F S IBASNUM=$O(IBAS(IBASNUM)) Q:'IBASNUM D
. S IBASDAT=IBAS(IBASNUM) W !,?4,IBASNUM,?12,$E($P(IBASDAT,"^",1),1,13)
. W ?26,$J($FN($P(IBASDAT,"^",2),",",2),10)
. W ?43,$S($P(IBASDAT,"^",5)=0:"NO",1:"YES")
. W ?53,$E($P(IBASDAT,"^",4),1,26)
. S IBNEWASN=IBASNUM+1
W !
S DIR("A")="(A)dd, (E)dit, or (D)elete Assignment"
S DIR(0)="SB^A:ADD;E:EDIT;D:DELETE" D ^DIR K DIR
I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 L -^IBE(351.73,IBCL) Q
K DIROUT,DTOUT,DUOUT,DIRUN
S IBJOB=Y
;
Q
;
ADD ; - Add new assignments to clerk
;
N IBBCAT,IBFOTP
W !?3,"Adding new assignment - # "_IBNEWASN_" - for "_$P(^VA(200,IBCL,0),"^",1)
S DA(1)=IBCL,DIC="^IBE(351.73,"_DA(1)_",1,",DIC(0)="EML",DLAYGO=351.731
S (DA,DINUM,X)=IBNEWASN
D FILE^DICN I Y=-1 K DIC,DA Q
K DLAYGO,DINUM,DIC(0)
S DIC(0)="QEAM",DIC="^PRCA(430.2,"
S DIC("S")="I $$CATTYP^IBJD1(+Y)]"""""
D ^DIC K DIC I ($D(DTOUT))!($D(DUOUT))!(Y'>0) D S IBQUIT=1 Q
. S DA(1)=IBCL,DA=IBNEWASN,DIK="^IBE(351.73,"_DA(1)_",1,"
. D ^DIK K DIK,DA,DTOUT,DUOUT,Y
. L -^IBE(351.73,IBCL)
S DA(1)=IBCL,DIE="^IBE(351.73,"_DA(1)_",1,"
S (DA,IBASNNUM)=IBNEWASN
S DR=".02////"_+Y_";.04////"_DUZ D ^DIE K DIE,DA,DR
S IBBCAT=$P($G(^IBE(351.73,IBCL,1,IBNEWASN,0)),"^",2)
S IBFOTP=$$CATTYP^IBJD1(IBBCAT)
G EDIT1^IBJDF8I1
;
Q
;
DELETE ; - Delete assignment
;
N DIR
S DIR("A")="Choose a valid Assignment Number to delete",DIR(0)="N"
D ^DIR K DIR
I ($D(DTOUT))!($D(DUOUT)) L -^IBE(351.73,IBCL) S IBQUIT=1 K DTOUT,DUOUT Q
I '$D(^IBE(351.73,IBCL,1,Y)) W !?3,"Not a valid assignment number" G DELETE
S IBASNNUM=+Y
S DA(1)=IBCL,DA=IBASNNUM,DIK="^IBE(351.73,"_DA(1)_",1,"
D ^DIK K DA,DIK
W !,?3,"Assignment #"_IBASNNUM_" deleted..."
I '$O(^IBE(351.73,IBCL,1,0)) D
. S $P(^IBE(351.73,IBCL,0),"^",2)=1
. W !,?3,"No more valid assignments on file for this clerk. Changing the 'Productivity Report Only' flag to Yes."
Q
;
EXIT ; - Exit routine
I IBCL L -^IBE(351.73,IBCL)
K IBPRONLY,IBQUIT,IBCL,IBASNUM,IBNEWASN,IBASDA0,IBBCAT,IBMBAL,IBSUP
K IBFOTP,IBASDA1,IBASDA2,IBLBY,IBAS,IBJOB,IBASDAT,IBASNNUM,IBSNF,IBSNL
K IBSN,IBFPDATA,IBTPDATA,IBSDEF,IBTDEF,IBOFF,IBBTYP,IBCATDA0,IBDA0
K IBRTDEF
K DIE,DA,DIR,DR,DUOUT,DTOUT,Y,X,DIK,DINUM,DLAYGO,DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF8I 6341 printed Oct 16, 2024@18:23:49 Page 2
IBJDF8I ;ALB/RRG-ADD/EDIT IB DM WORKLOAD PARAMETERS ;11/06/00
+1 ;;2.0;INTEGRATED BILLING;**123,604**;21-MAR-94;Build 11
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
START DO BEG
if IBQUIT
GOTO EXIT
IF IBPRONLY
GOTO START
+1 DO ASSIGN
if IBQUIT
GOTO START
+2 IF IBJOB="A"
DO ADD
if IBQUIT
GOTO START
+3 IF IBJOB="E"
DO EDIT^IBJDF8I1
if IBQUIT
GOTO START
+4 IF IBJOB="D"
DO DELETE
if IBQUIT
GOTO START
+5 LOCK -^IBE(351.73,IBCL)
+6 GOTO START
+7 QUIT
+8 ;
BEG ;Start editing workload paramters
+1 NEW DIC,IBDELFLG
SET (IBQUIT,IBPRONLY)=0
SET (IBDA0,IBCL)=""
SET IBDELFLG=1
+2 ;S DIC="^IBE(351.73,",DIC(0)="QEAML",DLAYGO=351.73,DIC("A")="Select Clerk: " ; IB*2.0*604 - original code
+3 ; *604-Search NEW PERSON (#200) file for clerk
SET DIC="^VA(200,"
SET DIC(0)="QEAMV"
SET DIC("A")="Select Clerk: "
+4 DO ^DIC
IF ($DATA(DTOUT))!($DATA(DUOUT))!(Y'>0)
SET IBQUIT=1
QUIT
+5 ; *604-Use IEN of entry found in file #200 to search file #351.73
+6 ; If no match is found in #351.73, allow a new entry to be made using the existing entry in #200
+7 ; *604
SET X=+Y
SET DIC="^IBE(351.73,"
SET DIC(0)="QELUX"
SET DLAYGO=351.73
+8 ; *604
DO ^DIC
IF ($DATA(DTOUT))!($DATA(DUOUT))!(Y'>0)
SET IBQUIT=1
QUIT
+9 SET IBCL=+Y
WRITE !
+10 LOCK +^IBE(351.73,IBCL):2
IF '$TEST
WRITE !?3,"Another user is editing this entry."
GOTO BEG
+11 IF $PIECE(^IBE(351.73,IBCL,0),"^",3)=""
Begin DoDot:1
+12 SET DIE=DIC
SET DR=".03////"_DUZ
SET DA=IBCL
DO ^DIE
KILL DIE,DR,DA
End DoDot:1
PRONLY SET DIR(0)="351.73,.02"
SET DA=IBCL
SET IBDELFLG=1
+1 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
LOCK -^IBE(351.73,IBCL)
GOTO BEG
+2 SET IBPRONLY=Y
KILL DIROUT,DTOUT,DUOUT
+3 IF 'IBPRONLY
SET $PIECE(^IBE(351.73,IBCL,0),"^",2)=0
QUIT
+4 IF IBPRONLY
Begin DoDot:1
+5 IF $ORDER(^IBE(351.73,IBCL,1,0))
Begin DoDot:2
+6 SET DIR(0)="Y"
SET DIR("B")="NO"
+7 SET DIR("A",1)="There are existing assignments for this clerk."
+8 SET DIR("A",2)="Those assignments must be deleted before the 'Productivity Report Only'"
+9 SET DIR("A",3)=" flag can be changed to 'Yes'."
+10 SET DIR("A")="Do you want to delete the existing assignments now"
+11 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
LOCK -^IBE(351.73,IBCL)
SET IBQUIT=1
QUIT
+12 KILL DIROUT,DTOUT,DUOUT
IF 'Y
SET IBDELFLG=0
+13 ; Delete all assignments and change 'Prod Rpt only' flag to YES
+14 IF Y
SET IBASNUM=0
FOR
SET IBASNUM=$ORDER(^IBE(351.73,IBCL,1,IBASNUM))
if 'IBASNUM
QUIT
Begin DoDot:3
+15 SET DA(1)=IBCL
SET DA=IBASNUM
SET DIK="^IBE(351.73,"_DA(1)_",1,"
DO ^DIK
+16 KILL DA,DIK
+17 WRITE !?3,"Assignment # "_IBASNUM_" deleted..."
End DoDot:3
SET $PIECE(^IBE(351.73,IBCL,0),"^",2)=1
WRITE !?3,"Productivity Report Only? changed to 'YES'..."
LOCK -^IBE(351.73,IBCL)
End DoDot:2
End DoDot:1
if IBQUIT
QUIT
IF 'IBDELFLG
GOTO PRONLY
+18 QUIT
ASSIGN ; Start editing assignments
+1 ;
+2 ; - Build assignment array for display
+3 SET IBASNUM=0
SET IBNEWASN=1
KILL IBPRONLY,IBAS
+4 NEW IBBCAT,IBMBAL,IBSUP,IBFOTP,IBLBY,IBERC
+5 FOR
SET IBASNUM=$ORDER(^IBE(351.73,IBCL,1,IBASNUM))
if 'IBASNUM
QUIT
Begin DoDot:1
+6 SET IBASDA0=$GET(^IBE(351.73,IBCL,1,IBASNUM,0))
SET IBBCAT=$PIECE(IBASDA0,"^",2)
+7 SET IBMBAL=$PIECE(IBASDA0,"^",3)
SET IBSUP=$PIECE(IBASDA0,"^",4)
+8 SET IBERC=$PIECE(IBASDA0,"^",5)
+9 SET IBFOTP=$$CATTYP^IBJD1(IBBCAT)
+10 IF IBFOTP="F"
SET IBASDA1=$GET(^IBE(351.73,IBCL,1,IBASNUM,1))
Begin DoDot:2
+11 SET IBLBY=$SELECT($PIECE(IBASDA1,"^",1)'="":"LAST PMT",1:"")
+12 SET IBLBY=IBLBY_$SELECT(($PIECE(IBASDA1,"^",2)="")&($PIECE(IBASDA1,"^",3)=""):"",IBLBY="":"NAME",1:"/NAME")
+13 SET IBLBY=IBLBY_$SELECT(($PIECE(IBASDA1,"^",4)="")&($PIECE(IBASDA1,"^",5)=""):"",IBLBY="":"SSN",1:"/SSN")
End DoDot:2
+14 IF IBFOTP="T"
SET IBASDA2=$GET(^IBE(351.73,IBCL,1,IBASNUM,2))
Begin DoDot:2
+15 SET IBLBY=$SELECT($PIECE(IBASDA2,"^",1)'="":"LAST TRX",1:"")
+16 SET IBLBY=IBLBY_$SELECT($PIECE(IBASDA2,"^",8)="":"",IBLBY="":"REC.TYPE",1:"/REC.TYPE")
+17 SET IBLBY=IBLBY_$SELECT(($PIECE(IBASDA2,"^",2)="")&($PIECE(IBASDA2,"^",3)=""):"",IBLBY="":"CARRIER",1:"/CARRIER")
+18 SET IBLBY=IBLBY_$SELECT(($PIECE(IBASDA2,"^",4)="")&($PIECE(IBASDA2,"^",5)=""):"",IBLBY="":"NAME",1:"/NAME")
+19 SET IBLBY=IBLBY_$SELECT(($PIECE(IBASDA2,"^",6)="")&($PIECE(IBASDA2,"^",7)=""):"",IBLBY="":"SSN",1:"/SSN")
End DoDot:2
+20 SET IBAS(IBASNUM)=$PIECE($GET(^PRCA(430.2,IBBCAT,0)),"^",1)_"^"
+21 SET IBAS(IBASNUM)=IBAS(IBASNUM)_IBMBAL_"^"_$PIECE($GET(^VA(200,+IBSUP,0)),"^",1)_"^"
+22 SET IBAS(IBASNUM)=IBAS(IBASNUM)_IBLBY_"^"_IBERC
End DoDot:1
+23 ;
+24 ; - Display assignment array
+25 SET IBJOB=""
NEW IBASDAT
+26 IF '$DATA(IBAS)
SET IBJOB="A"
QUIT
+27 SET IBASNUM=0
+28 WRITE !,?38,"EXCLUDE REFER"
+29 WRITE !,"ASSIGNMENT",?12,"CATEGORY",?26,"MIN BALANCE",?38,"TO REG COUNSEL"
+30 WRITE ?53,"LIMITED BY CARRIER/NAME/SSN"
+31 FOR
SET IBASNUM=$ORDER(IBAS(IBASNUM))
if 'IBASNUM
QUIT
Begin DoDot:1
+32 SET IBASDAT=IBAS(IBASNUM)
WRITE !,?4,IBASNUM,?12,$EXTRACT($PIECE(IBASDAT,"^",1),1,13)
+33 WRITE ?26,$JUSTIFY($FNUMBER($PIECE(IBASDAT,"^",2),",",2),10)
+34 WRITE ?43,$SELECT($PIECE(IBASDAT,"^",5)=0:"NO",1:"YES")
+35 WRITE ?53,$EXTRACT($PIECE(IBASDAT,"^",4),1,26)
+36 SET IBNEWASN=IBASNUM+1
End DoDot:1
+37 WRITE !
+38 SET DIR("A")="(A)dd, (E)dit, or (D)elete Assignment"
+39 SET DIR(0)="SB^A:ADD;E:EDIT;D:DELETE"
DO ^DIR
KILL DIR
+40 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
LOCK -^IBE(351.73,IBCL)
QUIT
+41 KILL DIROUT,DTOUT,DUOUT,DIRUN
+42 SET IBJOB=Y
+43 ;
+44 QUIT
+45 ;
ADD ; - Add new assignments to clerk
+1 ;
+2 NEW IBBCAT,IBFOTP
+3 WRITE !?3,"Adding new assignment - # "_IBNEWASN_" - for "_$PIECE(^VA(200,IBCL,0),"^",1)
+4 SET DA(1)=IBCL
SET DIC="^IBE(351.73,"_DA(1)_",1,"
SET DIC(0)="EML"
SET DLAYGO=351.731
+5 SET (DA,DINUM,X)=IBNEWASN
+6 DO FILE^DICN
IF Y=-1
KILL DIC,DA
QUIT
+7 KILL DLAYGO,DINUM,DIC(0)
+8 SET DIC(0)="QEAM"
SET DIC="^PRCA(430.2,"
+9 SET DIC("S")="I $$CATTYP^IBJD1(+Y)]"""""
+10 DO ^DIC
KILL DIC
IF ($DATA(DTOUT))!($DATA(DUOUT))!(Y'>0)
Begin DoDot:1
+11 SET DA(1)=IBCL
SET DA=IBNEWASN
SET DIK="^IBE(351.73,"_DA(1)_",1,"
+12 DO ^DIK
KILL DIK,DA,DTOUT,DUOUT,Y
+13 LOCK -^IBE(351.73,IBCL)
End DoDot:1
SET IBQUIT=1
QUIT
+14 SET DA(1)=IBCL
SET DIE="^IBE(351.73,"_DA(1)_",1,"
+15 SET (DA,IBASNNUM)=IBNEWASN
+16 SET DR=".02////"_+Y_";.04////"_DUZ
DO ^DIE
KILL DIE,DA,DR
+17 SET IBBCAT=$PIECE($GET(^IBE(351.73,IBCL,1,IBNEWASN,0)),"^",2)
+18 SET IBFOTP=$$CATTYP^IBJD1(IBBCAT)
+19 GOTO EDIT1^IBJDF8I1
+20 ;
+21 QUIT
+22 ;
DELETE ; - Delete assignment
+1 ;
+2 NEW DIR
+3 SET DIR("A")="Choose a valid Assignment Number to delete"
SET DIR(0)="N"
+4 DO ^DIR
KILL DIR
+5 IF ($DATA(DTOUT))!($DATA(DUOUT))
LOCK -^IBE(351.73,IBCL)
SET IBQUIT=1
KILL DTOUT,DUOUT
QUIT
+6 IF '$DATA(^IBE(351.73,IBCL,1,Y))
WRITE !?3,"Not a valid assignment number"
GOTO DELETE
+7 SET IBASNNUM=+Y
+8 SET DA(1)=IBCL
SET DA=IBASNNUM
SET DIK="^IBE(351.73,"_DA(1)_",1,"
+9 DO ^DIK
KILL DA,DIK
+10 WRITE !,?3,"Assignment #"_IBASNNUM_" deleted..."
+11 IF '$ORDER(^IBE(351.73,IBCL,1,0))
Begin DoDot:1
+12 SET $PIECE(^IBE(351.73,IBCL,0),"^",2)=1
+13 WRITE !,?3,"No more valid assignments on file for this clerk. Changing the 'Productivity Report Only' flag to Yes."
End DoDot:1
+14 QUIT
+15 ;
EXIT ; - Exit routine
+1 IF IBCL
LOCK -^IBE(351.73,IBCL)
+2 KILL IBPRONLY,IBQUIT,IBCL,IBASNUM,IBNEWASN,IBASDA0,IBBCAT,IBMBAL,IBSUP
+3 KILL IBFOTP,IBASDA1,IBASDA2,IBLBY,IBAS,IBJOB,IBASDAT,IBASNNUM,IBSNF,IBSNL
+4 KILL IBSN,IBFPDATA,IBTPDATA,IBSDEF,IBTDEF,IBOFF,IBBTYP,IBCATDA0,IBDA0
+5 KILL IBRTDEF
+6 KILL DIE,DA,DIR,DR,DUOUT,DTOUT,Y,X,DIK,DINUM,DLAYGO,DIC
+7 QUIT
