- 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 Jan 18, 2025@03:02:51 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