IB20P132 ;ALB/BGA - IB V2.0 POST INIT, RESOLVE POINTERS ; 08-15-2000
;;2.0;INTEGRATED BILLING;**132**; 21-MAR-94
;
; 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*.
;
; Resolve Pointer-- Control Logic
D NEWAT ; Added new entries to 350.1
D ATSE ; Resolve ptrs to #49 from #350.1
D ATAT ; Resolve ptrs to #350.1 from #350.1
D ATUT ; Resolve ptrs to #350.1 from #399.1
D ARNB ; Added new MST entry to #356.8
D LAST ; End task
Q
;
;
NEWAT ; Add new IB Action Types into file #350.1
D BMES^XPDUTL(">>> Adding new IB Action Types into file #350.1")
F IBI=1:1 S IBCR=$P($T(NAT+IBI),";;",2) Q:IBCR="QUIT" D
.S X=$P(IBCR,"^")
.I $O(^IBE(350.1,"B",X,0)) D BMES^XPDUTL(" >> '"_X_"' is already on file.") Q
.K DD,DO S DIC="^IBE(350.1,",DIC(0)="" D FILE^DICN Q:Y<0
.S ^(0)=^IBE(350.1,+Y,0)_"^"_$P(IBCR,"^",2,11) S DIK=DIC,DA=+Y D IX1^DIK
.D BMES^XPDUTL(" >> '"_$P(IBCR,"^")_"' has been filed.")
.I $P(IBCR,"^",12)'="" S ^IBE(350.1,+DA,20)=$P(IBCR,"^",12)
; set the description for FEE OUTPATIENT node 20
I $O(^IBE(350.1,"B","DG FEE SERVICE (OPT) NEW",0)) S Z=$O(^(0)) D
. S ^IBE(350.1,+Z,20)="S IBDESC=""FEE OPT COPAYMENT"""
K DA,DIC,DIE,DIK,DR,IBI,IBCR,X,Y,Z
Q
;
;
NAT ; Action Types to add into file #350.1
;;DG OBSERVATION COPAY NEW^OBS CO^^^1^^^OBSERVATION CARE COPAY^^1^4^S IBDESC="OBS DISCHARGE COPAY"
;;DG OBSERVATION COPAY CANCEL^CAN OBS^^^2
;;DG OBSERVATION COPAY UPDATE^UPD OBS^^^3^^^^^1^4
;;QUIT
;
;
ATSE ; Resolve pointers to file #49 from file #350.1
D BMES^XPDUTL(">>> Updating pointers to file #49 from file #350.1.")
S IBSERV=$P($G(^IBE(350.9,1,1)),"^",14)
I 'IBSERV D G ATSEQ
.D BMES^XPDUTL("You must define MAS as a service in your IB Site Parameter file before you")
.D BMES^XPDUTL("can update the IB Action Type file! Please perform this action after")
.D BMES^XPDUTL("installing this software.")
;
; - update both service and AR category
F IBI=1:1 S IBX=$P($T(DATA+IBI),";;",2,99) Q:IBX="" D
.S IBATYP=$O(^IBE(350.1,"B",$P(IBX,"^"),0)) Q:'IBATYP
.S IBARTYP=$O(^PRCA(430.2,"B",$P(IBX,"^",3),0)) Q:'IBARTYP
.S $P(^IBE(350.1,IBATYP,0),"^",3)=IBARTYP
.S DIE="^IBE(350.1,",DA=IBATYP,DR=".04////"_IBSERV
.D ^DIE K DIC,DIE,DA,DR
;
;
ATSEQ K IBI,IBX,IBATYP,IBARTYP,IBSERV
Q
;
;
DATA ;Action Type (#350.1)^ <null> ^AR Category (#430.2)
;;DG OBSERVATION COPAY NEW^ ^OUTPATIENT CARE(NSC)
;;DG OBSERVATION COPAY CANCEL^ ^OUTPATIENT CARE(NSC)
;;DG OBSERVATION COPAY UPDATE^ ^OUTPATIENT CARE(NSC)
;
ATAT ; Resolve pointers to file #350.1 from file #350.1
D BMES^XPDUTL(">>> Updating pointers to file #350.1 from file #350.1.")
F IBI=1:1 S IBX=$P($T(ACT+IBI),";;",2,99) Q:IBX="" D
.S IBNEW=$O(^IBE(350.1,"B",$P(IBX,"^"),0))
.S IBCAN=$O(^IBE(350.1,"B",$P(IBX,"^",2),0))
.S IBUPD=$O(^IBE(350.1,"B",$P(IBX,"^",3),0))
.F IBJ=IBNEW,IBCAN,IBUPD D
..S DIE="^IBE(350.1,",DA=IBJ
..S DR=".06////"_IBCAN_";.07////"_IBUPD_";.09////"_IBNEW
..D ^DIE K DA,DR,DIE
;
K IBI,IBX,IBNEW,IBCAN,IBUPD,IBJ
Q
;
;
ACT ;New Action (#350.1)^Cancel Action (#350.1)^Update Action (#350.1)
;;DG OBSERVATION COPAY NEW^DG OBSERVATION COPAY CANCEL^DG OBSERVATION COPAY UPDATE
;
;
ATUT ; Resolve pointers to #350.1 from #399.1
D BMES^XPDUTL(">>> Updating pointers to file #350.1 from file #399.1.")
F IBI=1:1 S IBX=$P($T(UTL+IBI),";;",2,99) Q:IBX="" D
.S IBUTL=$O(^DGCR(399.1,"B",$P(IBX,"^"),0))
.S IBCP=$O(^IBE(350.1,"B",$P(IBX,"^",2),0))
.S DIE="^DGCR(399.1,",DA=IBUTL,DR=".14////"_IBCP
.D ^DIE K DA,DR,DIE
;
K DA,DR,DIE,IBI,IBX,IBUTL,IBCP
Q
;
;
UTL ;Utility (#399.1)^Copay Action (#350.1)^Per Diem Action (#350.1)
;;OBSERVATION CARE^DG OBSERVATION COPAY NEW
;
ARNB ;
; Adds an entry to file 356.8 for MST if no entry found.
N IBNEXT,IBNAME,DO,DIC,DD,IBNEXT,IB0,Y,DINUM,DLAYGO,X
S IBNAME="MILITARY SEXUAL TRAUMA"
I $D(^IBE(356.8,"B",IBNAME)) D BMES^XPDUTL("***> Entry IN FILE #356.8 for "_IBNAME_" already EXISTS") Q
I '$D(^IBE(356.8,0)) D BMES^XPDUTL("***> Could not find ^IBE(356.8,0 Please contact your IRM ... MST Entry not ADDED") Q
L +^IBE(356.8,0):10 I '$T D BMES^XPDUTL("***> Could not Lock file #356.8 NODE 0 NO MST entry ADDED") Q
S IB0=$G(^IBE(356.8,0))
;
; In the case where we have a file containing a gap in the order of the iens
; ie ^IBE(356.8,0)="CLAIMS TRK NBR^356.8^999^29
; We will loop the file to find the next available Sequential IEN
; The sites reserve IEN's above 999 for custom use.
;
D IBNEXT
I IBNEXT<1 D BMES^XPDUTL("***>Could not find the NEXT available IEN ...NO MST entry added.") Q
L -^IBE(356.8,0)
I $D(^IBE(356.8,IBNEXT,0)) D Q
. D BMES^XPDUTL("***> The SELECTED NEW IEN "_IBNEXT_" already exists. File #356.8 is out of SEQUENTIAL order Please contact your IRM.")
. D BMES^XPDUTL("***> No MST entry ADDED to File #356.8.")
L +^IBE(356.8,IBNEXT):5 I '$T D BMES^XPDUTL("***> Could not Lock file #356.8 NODE "_IBNEXT_" NO MST entry ADDED") Q
S DIC="^IBE(356.8,",DIC(0)="L",DLAYGO=356.8,DINUM=IBNEXT,X=IBNAME
D FILE^DICN L -^IBE(356.8,IBNEXT)
I +Y<1 D BMES^XPDUTL("***> Could not ADD entry "_IBNEXT_" to FILE #356.8 FILE^DICN FAILED.") Q
D BMES^XPDUTL("***> MST Entry ADDED to file #356.8 at IEN "_IBNEXT_".")
Q
;
IBNEXT ;
; Find the next IEN in sequential order in file 356.8
N IBCNT,IBSTOP,IBI,IBJ
S (IBCNT,IBI)=0
F IBJ=1:1 S IBI=$O(^IBE(356.8,IBI)) Q:'IBI!($D(IBNEXT)) D
. S IBCNT=IBCNT+1
. I IBCNT<IBI S IBNEXT=IBCNT ; case entries out of sequence
I '$D(IBNEXT) S IBNEXT=$P(IB0,U,3)+1 ; entries in sequence
Q
;
LAST ;
D BMES^XPDUTL(">>> All POST-INIT Activities have been completed. <<<")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P132 5848 printed Apr 09, 2024@21:26:19 Page 2
IB20P132 ;ALB/BGA - IB V2.0 POST INIT, RESOLVE POINTERS ; 08-15-2000
+1 ;;2.0;INTEGRATED BILLING;**132**; 21-MAR-94
+2 ;
+3 ; Post Init Description: This init will resolve the pointer issues
+4 ; for the new entries required in 350.2 and the update need in
+5 ; file 399.1. This post init is associated with path *132*.
+6 ;
+7 ; Resolve Pointer-- Control Logic
+8 ; Added new entries to 350.1
DO NEWAT
+9 ; Resolve ptrs to #49 from #350.1
DO ATSE
+10 ; Resolve ptrs to #350.1 from #350.1
DO ATAT
+11 ; Resolve ptrs to #350.1 from #399.1
DO ATUT
+12 ; Added new MST entry to #356.8
DO ARNB
+13 ; End task
DO LAST
+14 QUIT
+15 ;
+16 ;
NEWAT ; Add new IB Action Types into file #350.1
+1 DO BMES^XPDUTL(">>> Adding new IB Action Types into file #350.1")
+2 FOR IBI=1:1
SET IBCR=$PIECE($TEXT(NAT+IBI),";;",2)
if IBCR="QUIT"
QUIT
Begin DoDot:1
+3 SET X=$PIECE(IBCR,"^")
+4 IF $ORDER(^IBE(350.1,"B",X,0))
DO BMES^XPDUTL(" >> '"_X_"' is already on file.")
QUIT
+5 KILL DD,DO
SET DIC="^IBE(350.1,"
SET DIC(0)=""
DO FILE^DICN
if Y<0
QUIT
+6 SET ^(0)=^IBE(350.1,+Y,0)_"^"_$PIECE(IBCR,"^",2,11)
SET DIK=DIC
SET DA=+Y
DO IX1^DIK
+7 DO BMES^XPDUTL(" >> '"_$PIECE(IBCR,"^")_"' has been filed.")
+8 IF $PIECE(IBCR,"^",12)'=""
SET ^IBE(350.1,+DA,20)=$PIECE(IBCR,"^",12)
End DoDot:1
+9 ; set the description for FEE OUTPATIENT node 20
+10 IF $ORDER(^IBE(350.1,"B","DG FEE SERVICE (OPT) NEW",0))
SET Z=$ORDER(^(0))
Begin DoDot:1
+11 SET ^IBE(350.1,+Z,20)="S IBDESC=""FEE OPT COPAYMENT"""
End DoDot:1
+12 KILL DA,DIC,DIE,DIK,DR,IBI,IBCR,X,Y,Z
+13 QUIT
+14 ;
+15 ;
NAT ; Action Types to add into file #350.1
+1 ;;DG OBSERVATION COPAY NEW^OBS CO^^^1^^^OBSERVATION CARE COPAY^^1^4^S IBDESC="OBS DISCHARGE COPAY"
+2 ;;DG OBSERVATION COPAY CANCEL^CAN OBS^^^2
+3 ;;DG OBSERVATION COPAY UPDATE^UPD OBS^^^3^^^^^1^4
+4 ;;QUIT
+5 ;
+6 ;
ATSE ; Resolve pointers to file #49 from file #350.1
+1 DO BMES^XPDUTL(">>> Updating pointers to file #49 from file #350.1.")
+2 SET IBSERV=$PIECE($GET(^IBE(350.9,1,1)),"^",14)
+3 IF 'IBSERV
Begin DoDot:1
+4 DO BMES^XPDUTL("You must define MAS as a service in your IB Site Parameter file before you")
+5 DO BMES^XPDUTL("can update the IB Action Type file! Please perform this action after")
+6 DO BMES^XPDUTL("installing this software.")
End DoDot:1
GOTO ATSEQ
+7 ;
+8 ; - update both service and AR category
+9 FOR IBI=1:1
SET IBX=$PIECE($TEXT(DATA+IBI),";;",2,99)
if IBX=""
QUIT
Begin DoDot:1
+10 SET IBATYP=$ORDER(^IBE(350.1,"B",$PIECE(IBX,"^"),0))
if 'IBATYP
QUIT
+11 SET IBARTYP=$ORDER(^PRCA(430.2,"B",$PIECE(IBX,"^",3),0))
if 'IBARTYP
QUIT
+12 SET $PIECE(^IBE(350.1,IBATYP,0),"^",3)=IBARTYP
+13 SET DIE="^IBE(350.1,"
SET DA=IBATYP
SET DR=".04////"_IBSERV
+14 DO ^DIE
KILL DIC,DIE,DA,DR
End DoDot:1
+15 ;
+16 ;
ATSEQ KILL IBI,IBX,IBATYP,IBARTYP,IBSERV
+1 QUIT
+2 ;
+3 ;
DATA ;Action Type (#350.1)^ <null> ^AR Category (#430.2)
+1 ;;DG OBSERVATION COPAY NEW^ ^OUTPATIENT CARE(NSC)
+2 ;;DG OBSERVATION COPAY CANCEL^ ^OUTPATIENT CARE(NSC)
+3 ;;DG OBSERVATION COPAY UPDATE^ ^OUTPATIENT CARE(NSC)
+4 ;
ATAT ; Resolve pointers to file #350.1 from file #350.1
+1 DO BMES^XPDUTL(">>> Updating pointers to file #350.1 from file #350.1.")
+2 FOR IBI=1:1
SET IBX=$PIECE($TEXT(ACT+IBI),";;",2,99)
if IBX=""
QUIT
Begin DoDot:1
+3 SET IBNEW=$ORDER(^IBE(350.1,"B",$PIECE(IBX,"^"),0))
+4 SET IBCAN=$ORDER(^IBE(350.1,"B",$PIECE(IBX,"^",2),0))
+5 SET IBUPD=$ORDER(^IBE(350.1,"B",$PIECE(IBX,"^",3),0))
+6 FOR IBJ=IBNEW,IBCAN,IBUPD
Begin DoDot:2
+7 SET DIE="^IBE(350.1,"
SET DA=IBJ
+8 SET DR=".06////"_IBCAN_";.07////"_IBUPD_";.09////"_IBNEW
+9 DO ^DIE
KILL DA,DR,DIE
End DoDot:2
End DoDot:1
+10 ;
+11 KILL IBI,IBX,IBNEW,IBCAN,IBUPD,IBJ
+12 QUIT
+13 ;
+14 ;
ACT ;New Action (#350.1)^Cancel Action (#350.1)^Update Action (#350.1)
+1 ;;DG OBSERVATION COPAY NEW^DG OBSERVATION COPAY CANCEL^DG OBSERVATION COPAY UPDATE
+2 ;
+3 ;
ATUT ; Resolve pointers to #350.1 from #399.1
+1 DO BMES^XPDUTL(">>> Updating pointers to file #350.1 from file #399.1.")
+2 FOR IBI=1:1
SET IBX=$PIECE($TEXT(UTL+IBI),";;",2,99)
if IBX=""
QUIT
Begin DoDot:1
+3 SET IBUTL=$ORDER(^DGCR(399.1,"B",$PIECE(IBX,"^"),0))
+4 SET IBCP=$ORDER(^IBE(350.1,"B",$PIECE(IBX,"^",2),0))
+5 SET DIE="^DGCR(399.1,"
SET DA=IBUTL
SET DR=".14////"_IBCP
+6 DO ^DIE
KILL DA,DR,DIE
End DoDot:1
+7 ;
+8 KILL DA,DR,DIE,IBI,IBX,IBUTL,IBCP
+9 QUIT
+10 ;
+11 ;
UTL ;Utility (#399.1)^Copay Action (#350.1)^Per Diem Action (#350.1)
+1 ;;OBSERVATION CARE^DG OBSERVATION COPAY NEW
+2 ;
ARNB ;
+1 ; Adds an entry to file 356.8 for MST if no entry found.
+2 NEW IBNEXT,IBNAME,DO,DIC,DD,IBNEXT,IB0,Y,DINUM,DLAYGO,X
+3 SET IBNAME="MILITARY SEXUAL TRAUMA"
+4 IF $DATA(^IBE(356.8,"B",IBNAME))
DO BMES^XPDUTL("***> Entry IN FILE #356.8 for "_IBNAME_" already EXISTS")
QUIT
+5 IF '$DATA(^IBE(356.8,0))
DO BMES^XPDUTL("***> Could not find ^IBE(356.8,0 Please contact your IRM ... MST Entry not ADDED")
QUIT
+6 LOCK +^IBE(356.8,0):10
IF '$TEST
DO BMES^XPDUTL("***> Could not Lock file #356.8 NODE 0 NO MST entry ADDED")
QUIT
+7 SET IB0=$GET(^IBE(356.8,0))
+8 ;
+9 ; In the case where we have a file containing a gap in the order of the iens
+10 ; ie ^IBE(356.8,0)="CLAIMS TRK NBR^356.8^999^29
+11 ; We will loop the file to find the next available Sequential IEN
+12 ; The sites reserve IEN's above 999 for custom use.
+13 ;
+14 DO IBNEXT
+15 IF IBNEXT<1
DO BMES^XPDUTL("***>Could not find the NEXT available IEN ...NO MST entry added.")
QUIT
+16 LOCK -^IBE(356.8,0)
+17 IF $DATA(^IBE(356.8,IBNEXT,0))
Begin DoDot:1
+18 DO BMES^XPDUTL("***> The SELECTED NEW IEN "_IBNEXT_" already exists. File #356.8 is out of SEQUENTIAL order Please contact your IRM.")
+19 DO BMES^XPDUTL("***> No MST entry ADDED to File #356.8.")
End DoDot:1
QUIT
+20 LOCK +^IBE(356.8,IBNEXT):5
IF '$TEST
DO BMES^XPDUTL("***> Could not Lock file #356.8 NODE "_IBNEXT_" NO MST entry ADDED")
QUIT
+21 SET DIC="^IBE(356.8,"
SET DIC(0)="L"
SET DLAYGO=356.8
SET DINUM=IBNEXT
SET X=IBNAME
+22 DO FILE^DICN
LOCK -^IBE(356.8,IBNEXT)
+23 IF +Y<1
DO BMES^XPDUTL("***> Could not ADD entry "_IBNEXT_" to FILE #356.8 FILE^DICN FAILED.")
QUIT
+24 DO BMES^XPDUTL("***> MST Entry ADDED to file #356.8 at IEN "_IBNEXT_".")
+25 QUIT
+26 ;
IBNEXT ;
+1 ; Find the next IEN in sequential order in file 356.8
+2 NEW IBCNT,IBSTOP,IBI,IBJ
+3 SET (IBCNT,IBI)=0
+4 FOR IBJ=1:1
SET IBI=$ORDER(^IBE(356.8,IBI))
if 'IBI!($DATA(IBNEXT))
QUIT
Begin DoDot:1
+5 SET IBCNT=IBCNT+1
+6 ; case entries out of sequence
IF IBCNT<IBI
SET IBNEXT=IBCNT
End DoDot:1
+7 ; entries in sequence
IF '$DATA(IBNEXT)
SET IBNEXT=$PIECE(IB0,U,3)+1
+8 QUIT
+9 ;
LAST ;
+1 DO BMES^XPDUTL(">>> All POST-INIT Activities have been completed. <<<")
+2 QUIT
