- 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 Jan 18, 2025@03:14:39 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