IB20P276 ;DALOI/AAT - POST INIT ACTION ;24-JUN-2003
;;2.0;INTEGRATED BILLING;**276**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
; Post Init Description: This init will resolve the pointer issues
; for the new entries required in 350.2 and the update need in
; file 399.1. This post init is associated with path *132*.
;
Q
;
;
EN ;
D BMES^XPDUTL(">>> Adding/modifying CLAIMS TRACKING NON-BILLABLE REASONS in the file #356.8")
D NEWNBR
;
;Temporary:
D BMES^XPDUTL(">>> Correcting the BPS CLAIM file, field #900 'CLOSE REASON'")
D BPSFIX
D BMES^XPDUTL(">>> Correcting 'CLOSE REASON' in the temporary IB events log")
D LOGFIX
;
D BMES^XPDUTL(">>> Enable menu option 'IBCNR EDIT HIPAA NCPDP FLAG'")
D OPT
;
D BMES^XPDUTL(">>> Reviewing and correcting the PLAN file entries")
D ^IBCNRXI1
;
D BMES^XPDUTL(">>> All POST-INIT Activities have been completed. <<<")
Q
;
NEWNBR ; Add/Modify IB non-billable reasons #356.8
N IBI,IBY,IBMES
F IBI=1:1 S IBY=$P($T(REASONS+IBI),";;",2,255) Q:'IBY D
. N IBNAME,IBE02,IBE03,IBL,IBIEN
. S IBNAME=$P(IBY,U,2) Q:IBNAME=""
. S IBE02=$P(IBY,U,3)
. S IBE03=$P(IBY,U,4)
. S $E(IBL,33-$L(IBNAME))=" "
. S IBMES=" "_$J(IBI,2)_" "_IBNAME_IBL
. S IBIEN=$O(^IBE(356.8,"B",IBNAME,0))
. S:IBIEN="" IBIEN=0
. S:$G(^IBE(356.8,IBIEN,0))="" IBIEN=0
. I IBIEN S IBMES=IBMES_" Already on file"
. I 'IBIEN D
.. N IBRT,IBIEN,IBERR,IBCNT
.. S IBCNT=0
.. S IBRT(356.8,"+1,",.01)=IBNAME
.. S IBRT(356.8,"+1,",.02)=IBE02
.. S IBRT(356.8,"+1,",.03)=IBE03
.. D UPDATE^DIE("","IBRT","IBIEN","IBERR")
.. I $D(IBERR) D S IBCNT=IBCNT+1
... N Y S Y="" F S Y=$O(IBERR(Y)) Q:Y="" D
.... S IBMES=IBMES_" *** Error: "_$G(IBERR(Y,1,"TEXT",1))
. I IBIEN D
.. S $P(^IBE(356.8,IBIEN,0),U,2)=IBE02
.. S $P(^IBE(356.8,IBIEN,0),U,3)=IBE03
. D MES^XPDUTL(IBMES)
Q
;
;
OPT ; Enable the menu option "IBCNR EDIT HIPAA NCPDP FLAG"
N IEN,IBRT,IBERR
S IEN=$O(^DIC(19,"B","IBCNR EDIT HIPAA NCPDP FLAG",""))
I 'IEN D BMES^XPDUTL(" *** Error: option 'IBCNR EDIT HIPAA NCPDP FLAG' not found") Q
S IBRT(19,IEN_",",2)="@"
D FILE^DIE("E","IBRT","IBERR")
I $D(IBERR) D
. N Y S Y="" F S Y=$O(IBERR(Y)) Q:Y="" D
.. D BMES^XPDUTL(" *** Error: "_$G(IBERR(Y,1,"TEXT",1)))
Q
;
;
; *** Not implemented ***
ADDUSR ; Add the user to the New Person file (#200)
Q
N DIC,X,Y,DO,DD,DLAYGO,IBNAME
S IBNAME="E-PHARMACY"
S DIC(0)="",DIC="^VA(200,",X=IBNAME D ^DIC
I Y>0 D Q
. D BMES^XPDUTL("User "_IBNAME_" already exists in the NEW PERSON file - not added")
D BMES^XPDUTL("Adding new user, "_IBNAME_", to the NEW PERSON file")
S DLAYGO=200,DIC(0)="L",DIC="^VA(200,",DIC("DR")="1////MRA",X=IBNAME D FILE^DICN K DIC,DO,DD,DLAYGO
I Y'>0 D Q
. D BMES^XPDUTL("A problem was encountered trying to add user, "_IBNAME)
. D BMES^XPDUTL("The entry must be added manually to the NEW PERSON file")
;
D BMES^XPDUTL("User, "_IBNAME_", was successfully added to the NEW PERSON file")
Q
;
;Temporary Clean-up procedure to eliminate QTY-DAYS SUPPLY switching
VERIFY(IBIFN,IBRX,IBFIL) ;check and correct
N IBX,QTY,DSUPP,IBZ,IBRXZ
S IBRXZ=$G(^PSRX(IBRX,1,IBFIL,0)) Q:IBRXZ=""
S QTY=+$P(IBRXZ,U,4) Q:'QTY Q:QTY>999
S DSUPP=+$P(IBRXZ,U,10) Q:'DSUPP Q:DSUPP>90
;
S IBX=0 F S IBX=$O(^IBA(362.4,"C",IBIFN,IBX)) Q:'IBX D
. ;W !,IBIFN,?10," ",IBRX,?22," ",IBFIL
. S IBZ=$G(^IBA(362.4,IBX,0)) Q:IBZ=""
. I QTY=+$P(IBZ,U,7),DSUPP=+$P(IBZ,U,6) Q
. ;W " *** INCORRECT: QTY/DAYS=",+$P(IBZ,U,7),"/",+$P(IBZ,U,6),", MUST BE ",QTY,"/",DSUPP
. D SETQTY(IBX,QTY,DSUPP)
Q
SETQTY(IBX,QTY,DSUPP) ;
N IBRT,IBERR
S IBRT(362.4,IBX_",",.06)=DSUPP
S IBRT(362.4,IBX_",",.07)=QTY
D FILE^DIE("","IBRT","IBERR")
;I $D(IBERR) W ! ZW IBERR
Q
;
;
GETRX(IBIFN) ;Get Rx from 362.4
N IBX,IBRX,IBRXN
S IBRX=0
S IBX=+$O(^IBA(362.4,"C",+IBIFN,""))
S IBRXN=$P($G(^IBA(362.4,IBX,0)),U)
I IBRXN'="" S IBRX=+$O(^PSRX("B",IBRXN,0))
Q IBRX
;
BULL ; Generate a bulletin with modified bills.
N IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
;
S XMSUB="FIXING 'CANCELLATION' IN NCPDP ZERO BILLS"
S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP("_$J_",""IB20P276"","
S XMY(DUZ)=""
S XMY("G.PRCA ERROR")=""
D ^XMD
Q
;
;
SETSTA(IBIFN) ; set the status
N IBIENS,IBFDA,IBERR
S IBIENS=IBIFN_","
S IBFDA(430,IBIENS,8)="COLLECTED/CLOSED"
D FILE^DIE("E","IBFDA","IBERR")
Q '$D(IBERR)
;
BPSFIX ;CONVERT OLD BPS CODES
N I,IBZ,IBY,IBC,IBOTH,IBT,ZNODE
S ZNODE="BPSIB-CONVERT-9002313.02-904"
I $D(^XTMP(ZNODE,0)) D MES^XPDUTL("*** Already converted") Q
F I=1:1 S IBY=$P($T(REASONS+I),";;",2,255) Q:'IBY S IBC(+IBY)=$O(^IBE(356.8,"B",$P(IBY,U,2),0))
S IBOTH=$O(^IBE(356.8,"B","OTHER",0))
S I=0 F S I=$O(^BPSC(I)) Q:'I S IBZ=$G(^(I,0)) D:$P(IBZ,U,7)=""
. N IBOLD,IBNEW
. S IBOLD=$P($G(^BPSC(I,900)),U,4) Q:IBOLD=""
. S IBNEW=+$G(IBC(IBOLD)) S:'IBNEW IBNEW=IBOTH
. ;W !,"I=",I,?10,"CODE=",IBOLD,", NEW=",IBNEW
. S $P(^BPSC(I,900),U,4)=IBNEW
. S $P(^BPSC(I,0),U,7)=0 ; as a flag to avoid double conversion
S ^XTMP(ZNODE,0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"BPS CONVERSION FLAG"
Q
;
LOGFIX ;CONVERT CLOSE REASON IN THE IB LOG
N I,J,IBNODE,IBZ,IBY,IBC,IBOTH,IBT,IBDROP
F I=1:1 S IBY=$P($T(REASONS+I),";;",2,255) Q:'IBY S IBC(+IBY)=$O(^IBE(356.8,"B",$P(IBY,U,2),0))
S IBOTH=$O(^IBE(356.8,"B","OTHER",0))
;
S (I,IBNODE)="IBNCPDP-"
F S I=$O(^XTMP(I)) Q:I'[IBNODE D
. S J=0 F S J=$O(^XTMP(I,J)) Q:'J D
.. I '$D(^XTMP(I,J,"IBD","CLOSE REASON")) Q
.. I $D(^XTMP(I,J,"IBD","DROP TO PAPER")) Q ; Already converted
.. N IBOLD,IBNEW
.. S IBOLD=$G(^XTMP(I,J,"IBD","CLOSE REASON")) Q:IBOLD=""
.. S IBNEW=+$G(IBC(IBOLD)) S:'IBNEW IBNEW=IBOTH
.. ;W !,"I=",I,", J=",J,",",?15,"CODE=",IBOLD,", NEW=",IBNEW
.. S ^XTMP(I,J,"IBD","CLOSE REASON")=IBNEW
.. S ^XTMP(I,J,"IBD","DROP TO PAPER")=(IBOLD=1) ;flag to avoid double conversion
Q
;
REASONS ;CLOSE REASON to add/modify into file #356.8
;;2^NOT INSURED^1^0
;;3^SERVICE NOT COVERED^1^0
;;4^COVERAGE CANCELED^1^0
;;6^INVALID PRESCRIPTION ENTRY^1^0
;;7^PRESCRIPTION DELETED^1^0
;;8^PRESCRIPTION NOT RELEASED^1^0
;;5^DRUG NOT BILLABLE^1^0
;;10^90 DAY RX FILL NOT COVERED^1^1
;;11^NOT A CONTRACTED PROVIDER^1^1
;;12^INVALID MULTIPLES PER DAY SUPP^1^0
;;13^REFILL TOO SOON^1^0
;;9^INVALID NDC FROM CMOP^1^0
;;1^OTHER^1^1
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P276 6440 printed Dec 13, 2024@02:02:04 Page 2
IB20P276 ;DALOI/AAT - POST INIT ACTION ;24-JUN-2003
+1 ;;2.0;INTEGRATED BILLING;**276**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
+5 ; Post Init Description: This init will resolve the pointer issues
+6 ; for the new entries required in 350.2 and the update need in
+7 ; file 399.1. This post init is associated with path *132*.
+8 ;
+9 QUIT
+10 ;
+11 ;
EN ;
+1 DO BMES^XPDUTL(">>> Adding/modifying CLAIMS TRACKING NON-BILLABLE REASONS in the file #356.8")
+2 DO NEWNBR
+3 ;
+4 ;Temporary:
+5 DO BMES^XPDUTL(">>> Correcting the BPS CLAIM file, field #900 'CLOSE REASON'")
+6 DO BPSFIX
+7 DO BMES^XPDUTL(">>> Correcting 'CLOSE REASON' in the temporary IB events log")
+8 DO LOGFIX
+9 ;
+10 DO BMES^XPDUTL(">>> Enable menu option 'IBCNR EDIT HIPAA NCPDP FLAG'")
+11 DO OPT
+12 ;
+13 DO BMES^XPDUTL(">>> Reviewing and correcting the PLAN file entries")
+14 DO ^IBCNRXI1
+15 ;
+16 DO BMES^XPDUTL(">>> All POST-INIT Activities have been completed. <<<")
+17 QUIT
+18 ;
NEWNBR ; Add/Modify IB non-billable reasons #356.8
+1 NEW IBI,IBY,IBMES
+2 FOR IBI=1:1
SET IBY=$PIECE($TEXT(REASONS+IBI),";;",2,255)
if 'IBY
QUIT
Begin DoDot:1
+3 NEW IBNAME,IBE02,IBE03,IBL,IBIEN
+4 SET IBNAME=$PIECE(IBY,U,2)
if IBNAME=""
QUIT
+5 SET IBE02=$PIECE(IBY,U,3)
+6 SET IBE03=$PIECE(IBY,U,4)
+7 SET $EXTRACT(IBL,33-$LENGTH(IBNAME))=" "
+8 SET IBMES=" "_$JUSTIFY(IBI,2)_" "_IBNAME_IBL
+9 SET IBIEN=$ORDER(^IBE(356.8,"B",IBNAME,0))
+10 if IBIEN=""
SET IBIEN=0
+11 if $GET(^IBE(356.8,IBIEN,0))=""
SET IBIEN=0
+12 IF IBIEN
SET IBMES=IBMES_" Already on file"
+13 IF 'IBIEN
Begin DoDot:2
+14 NEW IBRT,IBIEN,IBERR,IBCNT
+15 SET IBCNT=0
+16 SET IBRT(356.8,"+1,",.01)=IBNAME
+17 SET IBRT(356.8,"+1,",.02)=IBE02
+18 SET IBRT(356.8,"+1,",.03)=IBE03
+19 DO UPDATE^DIE("","IBRT","IBIEN","IBERR")
+20 IF $DATA(IBERR)
Begin DoDot:3
+21 NEW Y
SET Y=""
FOR
SET Y=$ORDER(IBERR(Y))
if Y=""
QUIT
Begin DoDot:4
+22 SET IBMES=IBMES_" *** Error: "_$GET(IBERR(Y,1,"TEXT",1))
End DoDot:4
End DoDot:3
SET IBCNT=IBCNT+1
End DoDot:2
+23 IF IBIEN
Begin DoDot:2
+24 SET $PIECE(^IBE(356.8,IBIEN,0),U,2)=IBE02
+25 SET $PIECE(^IBE(356.8,IBIEN,0),U,3)=IBE03
End DoDot:2
+26 DO MES^XPDUTL(IBMES)
End DoDot:1
+27 QUIT
+28 ;
+29 ;
OPT ; Enable the menu option "IBCNR EDIT HIPAA NCPDP FLAG"
+1 NEW IEN,IBRT,IBERR
+2 SET IEN=$ORDER(^DIC(19,"B","IBCNR EDIT HIPAA NCPDP FLAG",""))
+3 IF 'IEN
DO BMES^XPDUTL(" *** Error: option 'IBCNR EDIT HIPAA NCPDP FLAG' not found")
QUIT
+4 SET IBRT(19,IEN_",",2)="@"
+5 DO FILE^DIE("E","IBRT","IBERR")
+6 IF $DATA(IBERR)
Begin DoDot:1
+7 NEW Y
SET Y=""
FOR
SET Y=$ORDER(IBERR(Y))
if Y=""
QUIT
Begin DoDot:2
+8 DO BMES^XPDUTL(" *** Error: "_$GET(IBERR(Y,1,"TEXT",1)))
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
+11 ;
+12 ; *** Not implemented ***
ADDUSR ; Add the user to the New Person file (#200)
+1 QUIT
+2 NEW DIC,X,Y,DO,DD,DLAYGO,IBNAME
+3 SET IBNAME="E-PHARMACY"
+4 SET DIC(0)=""
SET DIC="^VA(200,"
SET X=IBNAME
DO ^DIC
+5 IF Y>0
Begin DoDot:1
+6 DO BMES^XPDUTL("User "_IBNAME_" already exists in the NEW PERSON file - not added")
End DoDot:1
QUIT
+7 DO BMES^XPDUTL("Adding new user, "_IBNAME_", to the NEW PERSON file")
+8 SET DLAYGO=200
SET DIC(0)="L"
SET DIC="^VA(200,"
SET DIC("DR")="1////MRA"
SET X=IBNAME
DO FILE^DICN
KILL DIC,DO,DD,DLAYGO
+9 IF Y'>0
Begin DoDot:1
+10 DO BMES^XPDUTL("A problem was encountered trying to add user, "_IBNAME)
+11 DO BMES^XPDUTL("The entry must be added manually to the NEW PERSON file")
End DoDot:1
QUIT
+12 ;
+13 DO BMES^XPDUTL("User, "_IBNAME_", was successfully added to the NEW PERSON file")
+14 QUIT
+15 ;
+16 ;Temporary Clean-up procedure to eliminate QTY-DAYS SUPPLY switching
VERIFY(IBIFN,IBRX,IBFIL) ;check and correct
+1 NEW IBX,QTY,DSUPP,IBZ,IBRXZ
+2 SET IBRXZ=$GET(^PSRX(IBRX,1,IBFIL,0))
if IBRXZ=""
QUIT
+3 SET QTY=+$PIECE(IBRXZ,U,4)
if 'QTY
QUIT
if QTY>999
QUIT
+4 SET DSUPP=+$PIECE(IBRXZ,U,10)
if 'DSUPP
QUIT
if DSUPP>90
QUIT
+5 ;
+6 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(362.4,"C",IBIFN,IBX))
if 'IBX
QUIT
Begin DoDot:1
+7 ;W !,IBIFN,?10," ",IBRX,?22," ",IBFIL
+8 SET IBZ=$GET(^IBA(362.4,IBX,0))
if IBZ=""
QUIT
+9 IF QTY=+$PIECE(IBZ,U,7)
IF DSUPP=+$PIECE(IBZ,U,6)
QUIT
+10 ;W " *** INCORRECT: QTY/DAYS=",+$P(IBZ,U,7),"/",+$P(IBZ,U,6),", MUST BE ",QTY,"/",DSUPP
+11 DO SETQTY(IBX,QTY,DSUPP)
End DoDot:1
+12 QUIT
SETQTY(IBX,QTY,DSUPP) ;
+1 NEW IBRT,IBERR
+2 SET IBRT(362.4,IBX_",",.06)=DSUPP
+3 SET IBRT(362.4,IBX_",",.07)=QTY
+4 DO FILE^DIE("","IBRT","IBERR")
+5 ;I $D(IBERR) W ! ZW IBERR
+6 QUIT
+7 ;
+8 ;
GETRX(IBIFN) ;Get Rx from 362.4
+1 NEW IBX,IBRX,IBRXN
+2 SET IBRX=0
+3 SET IBX=+$ORDER(^IBA(362.4,"C",+IBIFN,""))
+4 SET IBRXN=$PIECE($GET(^IBA(362.4,IBX,0)),U)
+5 IF IBRXN'=""
SET IBRX=+$ORDER(^PSRX("B",IBRXN,0))
+6 QUIT IBRX
+7 ;
BULL ; Generate a bulletin with modified bills.
+1 NEW IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
+2 ;
+3 SET XMSUB="FIXING 'CANCELLATION' IN NCPDP ZERO BILLS"
+4 SET XMDUZ="INTEGRATED BILLING PACKAGE"
SET XMTEXT="^TMP("_$JOB_",""IB20P276"","
+5 SET XMY(DUZ)=""
+6 SET XMY("G.PRCA ERROR")=""
+7 DO ^XMD
+8 QUIT
+9 ;
+10 ;
SETSTA(IBIFN) ; set the status
+1 NEW IBIENS,IBFDA,IBERR
+2 SET IBIENS=IBIFN_","
+3 SET IBFDA(430,IBIENS,8)="COLLECTED/CLOSED"
+4 DO FILE^DIE("E","IBFDA","IBERR")
+5 QUIT '$DATA(IBERR)
+6 ;
BPSFIX ;CONVERT OLD BPS CODES
+1 NEW I,IBZ,IBY,IBC,IBOTH,IBT,ZNODE
+2 SET ZNODE="BPSIB-CONVERT-9002313.02-904"
+3 IF $DATA(^XTMP(ZNODE,0))
DO MES^XPDUTL("*** Already converted")
QUIT
+4 FOR I=1:1
SET IBY=$PIECE($TEXT(REASONS+I),";;",2,255)
if 'IBY
QUIT
SET IBC(+IBY)=$ORDER(^IBE(356.8,"B",$PIECE(IBY,U,2),0))
+5 SET IBOTH=$ORDER(^IBE(356.8,"B","OTHER",0))
+6 SET I=0
FOR
SET I=$ORDER(^BPSC(I))
if 'I
QUIT
SET IBZ=$GET(^(I,0))
if $PIECE(IBZ,U,7)=""
Begin DoDot:1
+7 NEW IBOLD,IBNEW
+8 SET IBOLD=$PIECE($GET(^BPSC(I,900)),U,4)
if IBOLD=""
QUIT
+9 SET IBNEW=+$GET(IBC(IBOLD))
if 'IBNEW
SET IBNEW=IBOTH
+10 ;W !,"I=",I,?10,"CODE=",IBOLD,", NEW=",IBNEW
+11 SET $PIECE(^BPSC(I,900),U,4)=IBNEW
+12 ; as a flag to avoid double conversion
SET $PIECE(^BPSC(I,0),U,7)=0
End DoDot:1
+13 SET ^XTMP(ZNODE,0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"BPS CONVERSION FLAG"
+14 QUIT
+15 ;
LOGFIX ;CONVERT CLOSE REASON IN THE IB LOG
+1 NEW I,J,IBNODE,IBZ,IBY,IBC,IBOTH,IBT,IBDROP
+2 FOR I=1:1
SET IBY=$PIECE($TEXT(REASONS+I),";;",2,255)
if 'IBY
QUIT
SET IBC(+IBY)=$ORDER(^IBE(356.8,"B",$PIECE(IBY,U,2),0))
+3 SET IBOTH=$ORDER(^IBE(356.8,"B","OTHER",0))
+4 ;
+5 SET (I,IBNODE)="IBNCPDP-"
+6 FOR
SET I=$ORDER(^XTMP(I))
if I'[IBNODE
QUIT
Begin DoDot:1
+7 SET J=0
FOR
SET J=$ORDER(^XTMP(I,J))
if 'J
QUIT
Begin DoDot:2
+8 IF '$DATA(^XTMP(I,J,"IBD","CLOSE REASON"))
QUIT
+9 ; Already converted
IF $DATA(^XTMP(I,J,"IBD","DROP TO PAPER"))
QUIT
+10 NEW IBOLD,IBNEW
+11 SET IBOLD=$GET(^XTMP(I,J,"IBD","CLOSE REASON"))
if IBOLD=""
QUIT
+12 SET IBNEW=+$GET(IBC(IBOLD))
if 'IBNEW
SET IBNEW=IBOTH
+13 ;W !,"I=",I,", J=",J,",",?15,"CODE=",IBOLD,", NEW=",IBNEW
+14 SET ^XTMP(I,J,"IBD","CLOSE REASON")=IBNEW
+15 ;flag to avoid double conversion
SET ^XTMP(I,J,"IBD","DROP TO PAPER")=(IBOLD=1)
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
REASONS ;CLOSE REASON to add/modify into file #356.8
+1 ;;2^NOT INSURED^1^0
+2 ;;3^SERVICE NOT COVERED^1^0
+3 ;;4^COVERAGE CANCELED^1^0
+4 ;;6^INVALID PRESCRIPTION ENTRY^1^0
+5 ;;7^PRESCRIPTION DELETED^1^0
+6 ;;8^PRESCRIPTION NOT RELEASED^1^0
+7 ;;5^DRUG NOT BILLABLE^1^0
+8 ;;10^90 DAY RX FILL NOT COVERED^1^1
+9 ;;11^NOT A CONTRACTED PROVIDER^1^1
+10 ;;12^INVALID MULTIPLES PER DAY SUPP^1^0
+11 ;;13^REFILL TOO SOON^1^0
+12 ;;9^INVALID NDC FROM CMOP^1^0
+13 ;;1^OTHER^1^1
+14 ;;
