IBCIUT1 ;DSI/SLM - MISC UTILITIES FOR CLAIMSMANAGER INTERFACE ;21-DEC-2000
;;2.0;INTEGRATED BILLING;**161,210**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
NOW ;get current (or specific) date/time and convert to ClaimsManager format
;
;Input variable
; x = date or date/time (for date/time other than now)
;Output variable
; y = date or date/time in claimsmanager format
; (yyyymmdd) or (yyyymmddhhmmss)
;
NEW YEAR,MON,DAY,HOUR,MIN,SEC
I '$G(X) S X=$$NOW^XLFDT
S YEAR=$E(X,1,3)+1700,MON=$E(X,4,5),DAY=$E(X,6,7)
I MON="00" S MON="01"
I DAY="00" S DAY="01"
I +$P(X,".",2) D
.S HOUR=$E($P(X,".",2),1,2),MIN=$E($P(X,".",2),3,4),SEC=$E($P(X,".",2),5,6)
.S Y=YEAR_MON_DAY_HOUR_MIN_SEC
E S Y=YEAR_MON_DAY
Q
NOW1(X) ;change date from mmddyyyy to yyyymmdd
N DATE,MM,DD,YY
S MM=$E(X,1,2),DD=$E(X,3,4),YY=$E(X,5,8)
S DATE=YY_MM_DD
Q DATE
NAMSP ;split name into three pieces LAST^FIRST^MIDDLE
;Input variable
; x = LAST,FIRST MIDDLE
;Output variable
; y = LAST^FIRST^MIDDLE
;
N NAME S Y=""
S NAME(1)=$P(X,","),NAME(2)=$P(X,",",2,999)
S NAME(3)=$P(NAME(2)," ",2,999)
S NAME(2)=$P(NAME(2)," ",1)
S Y=NAME(1)_"^"_NAME(2)_"^"_NAME(3)
Q
;
CM(IBIFN) ;
; ClaimsManager environment check for IB routines. Checks to make
; sure CM is running and that the bill is a HCFA 1500 form type bill.
; Any other condition will return false.
;
N Y
S Y=0
I $G(IBIFN),$$CK0(),'$$CK1(IBIFN) S Y=1
Q Y
;
CK0() ;checks to see if running ClaimsManager
;returns a 1 if running ClaimsManager
N Y
S Y=$S($P($G(^IBE(350.9,1,50)),U)=1:1,1:0)
Q Y
;
CK1(IBIFN) ;checks to see if it's a HCFA 1500 claim form
;returns 0 if HCFA 1500, returns 1 if any other form type
;
N IBX,IBY
S IBY=$P($G(^DGCR(399,IBIFN,0)),U,19)
S IBX=$S(IBY=2:0,1:1)
Q IBX
;
CK2() ;checks to see if ClaimsManager is working ok
;returns a 1 if running ok
;
N Y
S Y=$S($P($G(^IBE(350.9,1,50)),U,2)=1:1,1:0)
Q Y
;
ST(IBCIST) ;set status field to ibcist
;
;input variables
; ibifn
; ibcist
I '$D(IBIFN) Q
I '$D(IBCIST) Q
S IENS=IBIFN_",",FDA(351.9,IENS,.02)=IBCIST
D FILE^DIE("K","FDA")
K FDA,IENS
Q
;
STAT(IBIFN) ;return value of status field in 351.9
N IBCIST1
S IBCIST1=$P(^IBA(351.9,IBIFN,0),U,2)
Q IBCIST1
;
;
LITMS(IBIFN) ; Returns the number of line items
NEW IBXARRAY,IBXARRY,IBXDATA,IBXERR
KILL ^TMP("IBXSAVE",$J)
D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN)
Q +$O(IBXDATA(""),-1)
;
;
LSTA(IBCISNT) ; return the correct Ingenix line status based on the value
; of IBCISNT - where is the interface called from?
Q $S(IBCISNT=5:"P",IBCISNT=4:"D",IBCISNT=7:"D",1:"A")
;
RPHY(IBIFN) ; Attending/rendering physician information
;
; This function returns the physician information for bill# IBIFN.
; Data is returned in a pieced string:
;
; [1] Name
; for non-VA, this may be a facility (if no comma in Name)
; [2] ID#
; File 200 ien# for VA; "NVA"_ien# for non-VA
; [3] Department
; Service/Section file ien# for VA; "NVA" for non-VA
; [4] Specialty
;
NEW IBXDATA,IBXARRAY,IBXARRY,IBXERR,Y,IBPRV
S Y=""
D F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN)
S IBPRV=$P($G(IBXDATA),U,2)
I 'IBPRV G RPHYX
S $P(Y,U,1)=$P(IBXDATA,U,1)
S $P(Y,U,4)=$$BILLSPEC^IBCEU3(IBIFN,IBPRV)
;
; Check for VA provider first and then get out
I IBPRV'["IBA(355.93" D G RPHYX
. S $P(Y,U,2)=+IBPRV
. S $P(Y,U,3)=$P($G(^VA(200,+IBPRV,5)),U,1)
. Q
;
; Now we're dealing with a Non-VA provider
S $P(Y,U,2)="NVA"_+IBPRV
S $P(Y,U,3)="NVA"
RPHYX ;
Q Y
;
CKNER() ;check for no errors
;returns 1 if no errors, 0 if errors were found
N IBCIY,LSEG S LSEG=0,IBCIY=1
F S LSEG=$O(IBCIZ("RL",LSEG)) Q:'LSEG D
.I $P(IBCIZ("RL",LSEG,0),U,2)]"" S IBCIY=0
Q IBCIY
CKLI(IBIFN) ;check for line items
N LITEM
I '$P($G(^IBA(351.9,IBIFN,3)),U,1) D UPDT^IBCIADD1 ; build if not there
S LITEM=$S(+$P($G(^IBA(351.9,IBIFN,5,0)),U,4)>0:1,1:0)
Q LITEM
;
;
CKFT(IBIFN) ; Check for a form type change by the user
NEW D0,DA,DB,DC,DE,DH,DI,DIC,DIE,DIEL,DIFLD,DIG,DIH
NEW DIK,DIPA,DIV,DK,DL,DM,DP,DQ,DR,X,Y
NEW IBCISNT,IBCISTAT,IBCIREDT,IBCIERR
I '$$CK0() Q ; esg - 7/17/01 - bug fix
;
; If it's not there, but it is a hcfa 1500, then add it
I '$D(^IBA(351.9,IBIFN)),'$$CK1(IBIFN) D ST1^IBCIST G CKFTX
;
; If it's there, but no longer a hcfa 1500, then delete it.
; esg - 1/3/2002 - If it has been sent to CM previously, then
; we need to send it with new send type 7.
I $D(^IBA(351.9,IBIFN)),$$CK1(IBIFN) D
. I $P($G(^IBA(351.9,IBIFN,0)),U,15) S IBCISNT=7 D ST2^IBCIST
. S DIK="^IBA(351.9,",DA=IBIFN D ^DIK
. Q
CKFTX ;
Q
;
;
DIAG(IBIFN) ;return array of diagnosis codes for each line item
NEW IBXDATA,IBXARRAY,IBXARRY,IBXERR
NEW IBZDC1,SUB1,LITM,CODES,DNUM,DC,ICDIEN,CT
K ^TMP("IBXSAVE",$J,"DX")
S SUB1=$S($G(IBCIMSG)=1:"IBCIMSG",1:"DISPLAY")
K ^TMP(SUB1,$J,IBIFN,"ICD")
D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN)
D F^IBCEF("N-DIAGNOSES","IBZDC1",,IBIFN)
;
; if IBCIMSG is on, need to count up the line items for the set below
I $G(IBCIMSG) S (CT,LITM)=0 F S LITM=$O(IBXDATA(LITM)) Q:'LITM S CT=CT+1
S LITM=0 F S LITM=$O(IBXDATA(LITM)) Q:'LITM D
.S CODES=$P(IBXDATA(LITM),U,7)
.S DNUM=0 F S DNUM=DNUM+1 Q:$P(CODES,",",DNUM)="" D
..S DC(DNUM)=$P(CODES,",",DNUM)
..S ICDIEN=$P(IBZDC1(DC(DNUM)),U,1)
..S ^TMP(SUB1,$J,IBIFN,"ICD",LITM,DNUM)=$P($$ICD9^IBACSV(ICDIEN),U)
.I $G(IBCIMSG) S ^TMP(SUB1,$J,IBIFN,"ICD",LITM,0)=CT_U_(DNUM-1)
K ^TMP("IBXSAVE",$J,"DX")
Q
;
;
EDATP(IBIFN,COMMCHG) ;edit assigned to person (ATP)
;
; This procedure reads in the Assigned to person from the user and
; makes sure that some user gets assigned to the bill (IBIFN). The
; parameter COMMCHG indicates whether or not the current user
; modified the ClaimsManager comments in any way.
;
; This procedure also determines if a MailMan message should get
; sent to the new assigned to person and invokes the procedure if
; it should.
;
NEW D,D0,DA,DIC,DIE,DR,I,IBCIATPO,IBCIATPN,IBCIDEF,X,Y
NEW IBCIGRP,IBCIGRPN,GRPONLY,CONMSG
S IBCIATPO=$P($G(^IBA(351.9,IBIFN,0)),U,12) ; original ATP
W !!!,?2,"Please enter the person to whom this bill should be assigned.",!
S IBCIDEF=IBCIATPO ; default the current ATP, but ...
I 'IBCIDEF S IBCIDEF=DUZ ; if not there, default the current user
S DA=IBIFN,DIE="^IBA(351.9,"
S DR=".12ASSIGNED TO PERSON//"_$P($G(^VA(200,IBCIDEF,0)),U,1)
D ^DIE
;
; Make sure someone got assigned. Stuff in the current user if
; nobody got assigned. Set a variable indicating the new assigned
; to person.
;
I '$P($G(^IBA(351.9,IBIFN,0)),U,12) D
. S DIE="^IBA(351.9,",DA=IBIFN,DR=".12////"_DUZ D ^DIE
. Q
S IBCIATPN=$P($G(^IBA(351.9,IBIFN,0)),U,12) ; new ATP
;
; Display a confirmation message to the user
W !!!?2,"Claim ",$P($G(^DGCR(399,IBIFN,0)),U,1)," has been assigned to "
W $P($G(^VA(200,IBCIATPN,0)),U,1),"."
;
; Ask the user if they want to send the MailMan message to a specific
; mail group in addition to the new assigned to person.
; ESG - 9/4/01
;
W !!!?2,"If you want to send a MailMan message about this bill assignment"
W !?2,"to a specific Mail Group, then please choose that Mail Group here.",!
S DIC="^XMB(3.8,",DIC(0)="ABEQV",DIC("A")="MAIL GROUP: "
D ^DIC
S (IBCIGRP,IBCIGRPN)=""
I Y>0 S IBCIGRP=+Y,IBCIGRPN=$P(Y,U,2) ; group ien and name
;
; Now determine if a MailMan message should get sent out and send it.
; Don't send a MailMan message to yourself and don't send a message
; if the assignment has not changed. However, if the user chose a
; mail group at the above prompt, then always send a MailMan message
; to that mail group.
;
; The GRPONLY variable is true if the assigned to person is the
; current user OR if the assigned to person is the same as the original
; assigned to person.
;
S GRPONLY=(IBCIATPN=DUZ)!(IBCIATPN=IBCIATPO)
I 'IBCIGRP,GRPONLY G EDATPX ; No mailman in this case at all
;
; Call the procedure that creates the message
D CAT^IBCIUT6(IBIFN,DUZ,IBCIATPN,IBCIGRP,GRPONLY)
;
; The CONMSG array is the confirmation message array so the user
; knows to whom a message was sent.
I 'GRPONLY S CONMSG(1)=$P($G(^VA(200,IBCIATPN,0)),U,1)
I IBCIGRP S CONMSG(2)=IBCIGRPN
;
; Build and display the confirmation message
W !!?2,"A MailMan message has been sent to "
S X=0
F S X=$O(CONMSG(X)) Q:'X W CONMSG(X) I $O(CONMSG(X)) W !?30,"and to "
W "."
;
EDATPX ;
; Display a press return to continue message if coming in from
; the Listman screens
I $D(VALMHDR) W !! S DIR("A")="Press RETURN to continue",DIR(0)="E",DIR("T")=10 D ^DIR K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCIUT1 8910 printed Dec 13, 2024@02:13:26 Page 2
IBCIUT1 ;DSI/SLM - MISC UTILITIES FOR CLAIMSMANAGER INTERFACE ;21-DEC-2000
+1 ;;2.0;INTEGRATED BILLING;**161,210**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
NOW ;get current (or specific) date/time and convert to ClaimsManager format
+1 ;
+2 ;Input variable
+3 ; x = date or date/time (for date/time other than now)
+4 ;Output variable
+5 ; y = date or date/time in claimsmanager format
+6 ; (yyyymmdd) or (yyyymmddhhmmss)
+7 ;
+8 NEW YEAR,MON,DAY,HOUR,MIN,SEC
+9 IF '$GET(X)
SET X=$$NOW^XLFDT
+10 SET YEAR=$EXTRACT(X,1,3)+1700
SET MON=$EXTRACT(X,4,5)
SET DAY=$EXTRACT(X,6,7)
+11 IF MON="00"
SET MON="01"
+12 IF DAY="00"
SET DAY="01"
+13 IF +$PIECE(X,".",2)
Begin DoDot:1
+14 SET HOUR=$EXTRACT($PIECE(X,".",2),1,2)
SET MIN=$EXTRACT($PIECE(X,".",2),3,4)
SET SEC=$EXTRACT($PIECE(X,".",2),5,6)
+15 SET Y=YEAR_MON_DAY_HOUR_MIN_SEC
End DoDot:1
+16 IF '$TEST
SET Y=YEAR_MON_DAY
+17 QUIT
NOW1(X) ;change date from mmddyyyy to yyyymmdd
+1 NEW DATE,MM,DD,YY
+2 SET MM=$EXTRACT(X,1,2)
SET DD=$EXTRACT(X,3,4)
SET YY=$EXTRACT(X,5,8)
+3 SET DATE=YY_MM_DD
+4 QUIT DATE
NAMSP ;split name into three pieces LAST^FIRST^MIDDLE
+1 ;Input variable
+2 ; x = LAST,FIRST MIDDLE
+3 ;Output variable
+4 ; y = LAST^FIRST^MIDDLE
+5 ;
+6 NEW NAME
SET Y=""
+7 SET NAME(1)=$PIECE(X,",")
SET NAME(2)=$PIECE(X,",",2,999)
+8 SET NAME(3)=$PIECE(NAME(2)," ",2,999)
+9 SET NAME(2)=$PIECE(NAME(2)," ",1)
+10 SET Y=NAME(1)_"^"_NAME(2)_"^"_NAME(3)
+11 QUIT
+12 ;
CM(IBIFN) ;
+1 ; ClaimsManager environment check for IB routines. Checks to make
+2 ; sure CM is running and that the bill is a HCFA 1500 form type bill.
+3 ; Any other condition will return false.
+4 ;
+5 NEW Y
+6 SET Y=0
+7 IF $GET(IBIFN)
IF $$CK0()
IF '$$CK1(IBIFN)
SET Y=1
+8 QUIT Y
+9 ;
CK0() ;checks to see if running ClaimsManager
+1 ;returns a 1 if running ClaimsManager
+2 NEW Y
+3 SET Y=$SELECT($PIECE($GET(^IBE(350.9,1,50)),U)=1:1,1:0)
+4 QUIT Y
+5 ;
CK1(IBIFN) ;checks to see if it's a HCFA 1500 claim form
+1 ;returns 0 if HCFA 1500, returns 1 if any other form type
+2 ;
+3 NEW IBX,IBY
+4 SET IBY=$PIECE($GET(^DGCR(399,IBIFN,0)),U,19)
+5 SET IBX=$SELECT(IBY=2:0,1:1)
+6 QUIT IBX
+7 ;
CK2() ;checks to see if ClaimsManager is working ok
+1 ;returns a 1 if running ok
+2 ;
+3 NEW Y
+4 SET Y=$SELECT($PIECE($GET(^IBE(350.9,1,50)),U,2)=1:1,1:0)
+5 QUIT Y
+6 ;
ST(IBCIST) ;set status field to ibcist
+1 ;
+2 ;input variables
+3 ; ibifn
+4 ; ibcist
+5 IF '$DATA(IBIFN)
QUIT
+6 IF '$DATA(IBCIST)
QUIT
+7 SET IENS=IBIFN_","
SET FDA(351.9,IENS,.02)=IBCIST
+8 DO FILE^DIE("K","FDA")
+9 KILL FDA,IENS
+10 QUIT
+11 ;
STAT(IBIFN) ;return value of status field in 351.9
+1 NEW IBCIST1
+2 SET IBCIST1=$PIECE(^IBA(351.9,IBIFN,0),U,2)
+3 QUIT IBCIST1
+4 ;
+5 ;
LITMS(IBIFN) ; Returns the number of line items
+1 NEW IBXARRAY,IBXARRY,IBXDATA,IBXERR
+2 KILL ^TMP("IBXSAVE",$JOB)
+3 DO F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN)
+4 QUIT +$ORDER(IBXDATA(""),-1)
+5 ;
+6 ;
LSTA(IBCISNT) ; return the correct Ingenix line status based on the value
+1 ; of IBCISNT - where is the interface called from?
+2 QUIT $SELECT(IBCISNT=5:"P",IBCISNT=4:"D",IBCISNT=7:"D",1:"A")
+3 ;
RPHY(IBIFN) ; Attending/rendering physician information
+1 ;
+2 ; This function returns the physician information for bill# IBIFN.
+3 ; Data is returned in a pieced string:
+4 ;
+5 ; [1] Name
+6 ; for non-VA, this may be a facility (if no comma in Name)
+7 ; [2] ID#
+8 ; File 200 ien# for VA; "NVA"_ien# for non-VA
+9 ; [3] Department
+10 ; Service/Section file ien# for VA; "NVA" for non-VA
+11 ; [4] Specialty
+12 ;
+13 NEW IBXDATA,IBXARRAY,IBXARRY,IBXERR,Y,IBPRV
+14 SET Y=""
+15 DO F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN)
+16 SET IBPRV=$PIECE($GET(IBXDATA),U,2)
+17 IF 'IBPRV
GOTO RPHYX
+18 SET $PIECE(Y,U,1)=$PIECE(IBXDATA,U,1)
+19 SET $PIECE(Y,U,4)=$$BILLSPEC^IBCEU3(IBIFN,IBPRV)
+20 ;
+21 ; Check for VA provider first and then get out
+22 IF IBPRV'["IBA(355.93"
Begin DoDot:1
+23 SET $PIECE(Y,U,2)=+IBPRV
+24 SET $PIECE(Y,U,3)=$PIECE($GET(^VA(200,+IBPRV,5)),U,1)
+25 QUIT
End DoDot:1
GOTO RPHYX
+26 ;
+27 ; Now we're dealing with a Non-VA provider
+28 SET $PIECE(Y,U,2)="NVA"_+IBPRV
+29 SET $PIECE(Y,U,3)="NVA"
RPHYX ;
+1 QUIT Y
+2 ;
CKNER() ;check for no errors
+1 ;returns 1 if no errors, 0 if errors were found
+2 NEW IBCIY,LSEG
SET LSEG=0
SET IBCIY=1
+3 FOR
SET LSEG=$ORDER(IBCIZ("RL",LSEG))
if 'LSEG
QUIT
Begin DoDot:1
+4 IF $PIECE(IBCIZ("RL",LSEG,0),U,2)]""
SET IBCIY=0
End DoDot:1
+5 QUIT IBCIY
CKLI(IBIFN) ;check for line items
+1 NEW LITEM
+2 ; build if not there
IF '$PIECE($GET(^IBA(351.9,IBIFN,3)),U,1)
DO UPDT^IBCIADD1
+3 SET LITEM=$SELECT(+$PIECE($GET(^IBA(351.9,IBIFN,5,0)),U,4)>0:1,1:0)
+4 QUIT LITEM
+5 ;
+6 ;
CKFT(IBIFN) ; Check for a form type change by the user
+1 NEW D0,DA,DB,DC,DE,DH,DI,DIC,DIE,DIEL,DIFLD,DIG,DIH
+2 NEW DIK,DIPA,DIV,DK,DL,DM,DP,DQ,DR,X,Y
+3 NEW IBCISNT,IBCISTAT,IBCIREDT,IBCIERR
+4 ; esg - 7/17/01 - bug fix
IF '$$CK0()
QUIT
+5 ;
+6 ; If it's not there, but it is a hcfa 1500, then add it
+7 IF '$DATA(^IBA(351.9,IBIFN))
IF '$$CK1(IBIFN)
DO ST1^IBCIST
GOTO CKFTX
+8 ;
+9 ; If it's there, but no longer a hcfa 1500, then delete it.
+10 ; esg - 1/3/2002 - If it has been sent to CM previously, then
+11 ; we need to send it with new send type 7.
+12 IF $DATA(^IBA(351.9,IBIFN))
IF $$CK1(IBIFN)
Begin DoDot:1
+13 IF $PIECE($GET(^IBA(351.9,IBIFN,0)),U,15)
SET IBCISNT=7
DO ST2^IBCIST
+14 SET DIK="^IBA(351.9,"
SET DA=IBIFN
DO ^DIK
+15 QUIT
End DoDot:1
CKFTX ;
+1 QUIT
+2 ;
+3 ;
DIAG(IBIFN) ;return array of diagnosis codes for each line item
+1 NEW IBXDATA,IBXARRAY,IBXARRY,IBXERR
+2 NEW IBZDC1,SUB1,LITM,CODES,DNUM,DC,ICDIEN,CT
+3 KILL ^TMP("IBXSAVE",$JOB,"DX")
+4 SET SUB1=$SELECT($GET(IBCIMSG)=1:"IBCIMSG",1:"DISPLAY")
+5 KILL ^TMP(SUB1,$JOB,IBIFN,"ICD")
+6 DO F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN)
+7 DO F^IBCEF("N-DIAGNOSES","IBZDC1",,IBIFN)
+8 ;
+9 ; if IBCIMSG is on, need to count up the line items for the set below
+10 IF $GET(IBCIMSG)
SET (CT,LITM)=0
FOR
SET LITM=$ORDER(IBXDATA(LITM))
if 'LITM
QUIT
SET CT=CT+1
+11 SET LITM=0
FOR
SET LITM=$ORDER(IBXDATA(LITM))
if 'LITM
QUIT
Begin DoDot:1
+12 SET CODES=$PIECE(IBXDATA(LITM),U,7)
+13 SET DNUM=0
FOR
SET DNUM=DNUM+1
if $PIECE(CODES,",",DNUM)=""
QUIT
Begin DoDot:2
+14 SET DC(DNUM)=$PIECE(CODES,",",DNUM)
+15 SET ICDIEN=$PIECE(IBZDC1(DC(DNUM)),U,1)
+16 SET ^TMP(SUB1,$JOB,IBIFN,"ICD",LITM,DNUM)=$PIECE($$ICD9^IBACSV(ICDIEN),U)
End DoDot:2
+17 IF $GET(IBCIMSG)
SET ^TMP(SUB1,$JOB,IBIFN,"ICD",LITM,0)=CT_U_(DNUM-1)
End DoDot:1
+18 KILL ^TMP("IBXSAVE",$JOB,"DX")
+19 QUIT
+20 ;
+21 ;
EDATP(IBIFN,COMMCHG) ;edit assigned to person (ATP)
+1 ;
+2 ; This procedure reads in the Assigned to person from the user and
+3 ; makes sure that some user gets assigned to the bill (IBIFN). The
+4 ; parameter COMMCHG indicates whether or not the current user
+5 ; modified the ClaimsManager comments in any way.
+6 ;
+7 ; This procedure also determines if a MailMan message should get
+8 ; sent to the new assigned to person and invokes the procedure if
+9 ; it should.
+10 ;
+11 NEW D,D0,DA,DIC,DIE,DR,I,IBCIATPO,IBCIATPN,IBCIDEF,X,Y
+12 NEW IBCIGRP,IBCIGRPN,GRPONLY,CONMSG
+13 ; original ATP
SET IBCIATPO=$PIECE($GET(^IBA(351.9,IBIFN,0)),U,12)
+14 WRITE !!!,?2,"Please enter the person to whom this bill should be assigned.",!
+15 ; default the current ATP, but ...
SET IBCIDEF=IBCIATPO
+16 ; if not there, default the current user
IF 'IBCIDEF
SET IBCIDEF=DUZ
+17 SET DA=IBIFN
SET DIE="^IBA(351.9,"
+18 SET DR=".12ASSIGNED TO PERSON//"_$PIECE($GET(^VA(200,IBCIDEF,0)),U,1)
+19 DO ^DIE
+20 ;
+21 ; Make sure someone got assigned. Stuff in the current user if
+22 ; nobody got assigned. Set a variable indicating the new assigned
+23 ; to person.
+24 ;
+25 IF '$PIECE($GET(^IBA(351.9,IBIFN,0)),U,12)
Begin DoDot:1
+26 SET DIE="^IBA(351.9,"
SET DA=IBIFN
SET DR=".12////"_DUZ
DO ^DIE
+27 QUIT
End DoDot:1
+28 ; new ATP
SET IBCIATPN=$PIECE($GET(^IBA(351.9,IBIFN,0)),U,12)
+29 ;
+30 ; Display a confirmation message to the user
+31 WRITE !!!?2,"Claim ",$PIECE($GET(^DGCR(399,IBIFN,0)),U,1)," has been assigned to "
+32 WRITE $PIECE($GET(^VA(200,IBCIATPN,0)),U,1),"."
+33 ;
+34 ; Ask the user if they want to send the MailMan message to a specific
+35 ; mail group in addition to the new assigned to person.
+36 ; ESG - 9/4/01
+37 ;
+38 WRITE !!!?2,"If you want to send a MailMan message about this bill assignment"
+39 WRITE !?2,"to a specific Mail Group, then please choose that Mail Group here.",!
+40 SET DIC="^XMB(3.8,"
SET DIC(0)="ABEQV"
SET DIC("A")="MAIL GROUP: "
+41 DO ^DIC
+42 SET (IBCIGRP,IBCIGRPN)=""
+43 ; group ien and name
IF Y>0
SET IBCIGRP=+Y
SET IBCIGRPN=$PIECE(Y,U,2)
+44 ;
+45 ; Now determine if a MailMan message should get sent out and send it.
+46 ; Don't send a MailMan message to yourself and don't send a message
+47 ; if the assignment has not changed. However, if the user chose a
+48 ; mail group at the above prompt, then always send a MailMan message
+49 ; to that mail group.
+50 ;
+51 ; The GRPONLY variable is true if the assigned to person is the
+52 ; current user OR if the assigned to person is the same as the original
+53 ; assigned to person.
+54 ;
+55 SET GRPONLY=(IBCIATPN=DUZ)!(IBCIATPN=IBCIATPO)
+56 ; No mailman in this case at all
IF 'IBCIGRP
IF GRPONLY
GOTO EDATPX
+57 ;
+58 ; Call the procedure that creates the message
+59 DO CAT^IBCIUT6(IBIFN,DUZ,IBCIATPN,IBCIGRP,GRPONLY)
+60 ;
+61 ; The CONMSG array is the confirmation message array so the user
+62 ; knows to whom a message was sent.
+63 IF 'GRPONLY
SET CONMSG(1)=$PIECE($GET(^VA(200,IBCIATPN,0)),U,1)
+64 IF IBCIGRP
SET CONMSG(2)=IBCIGRPN
+65 ;
+66 ; Build and display the confirmation message
+67 WRITE !!?2,"A MailMan message has been sent to "
+68 SET X=0
+69 FOR
SET X=$ORDER(CONMSG(X))
if 'X
QUIT
WRITE CONMSG(X)
IF $ORDER(CONMSG(X))
WRITE !?30,"and to "
+70 WRITE "."
+71 ;
EDATPX ;
+1 ; Display a press return to continue message if coming in from
+2 ; the Listman screens
+3 IF $DATA(VALMHDR)
WRITE !!
SET DIR("A")="Press RETURN to continue"
SET DIR(0)="E"
SET DIR("T")=10
DO ^DIR
KILL DIR
+4 QUIT
