Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IB20P132

IB20P132.m

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