IB20PT31 ;ALB/CPM - IB V2.0 POST INIT, RESOLVE TABLE POINTERS ; 02-SEP-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
;
NEWAT ; Add new IB Action Types into file #350.1
W !!,">>> 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)) W !," >> '",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
.W !," >> '",$P(IBCR,"^"),"' has been filed..."
K DA,DIC,DIE,DR,IBI,IBCR,X,Y
Q
;
NAT ; Action Types to add into file #350.1
;;CHAMPVA SUBSISTENCE LIMIT^CVA LIM^^^82^^^CHAMPVA LIMIT
;;DG CHAMPVA PER DIEM NEW^CVA PD^^^1^^^CHAMPVA SUBSISTENCE^^^6
;;DG CHAMPVA PER DIEM CANCEL^CAN CPD^^^2
;;DG CHAMPVA PER DIEM UPDATE^UPD CPD^^^3
;;QUIT
;
NEWAC ; Add new IB Action Charges into file #350.2
W !!,">>> Adding new IB Action Charges into file #350.2..."
F IBI=1:1 S IBCR=$P($T(NAC+IBI),";;",2) Q:IBCR="QUIT" D
.S X=$P(IBCR,"^"),IBF=$O(^IBE(350.2,"B",X,0))
.I IBF S IBT=0 D Q:IBT
..S IBG=0 F S IBG=$O(^IBE(350.2,"B",X,IBG)) Q:'IBG D Q:IBT
...I $P($G(^IBE(350.2,IBG,0)),"^",2)=$P(IBCR,"^",2) S IBT=1 W !," >> '",X,"' for ",$$DAT1^IBOUTL($P(IBCR,"^",2))," is already on file..." Q
.;
.K DD,DO S DIC="^IBE(350.2,",DIC(0)="" D FILE^DICN Q:Y<0
.S DIE=DIC,DA=+Y,DR=".02////"_$P(IBCR,"^",2)_";.04////"_$P(IBCR,"^",4) D ^DIE
.W !," >> '",$P(IBCR,"^"),"' has been filed..."
K DA,DIC,DIE,DR,IBF,IBG,IBI,IBCR,IBT,X,Y
Q
;
NAC ; Action Charges to add into file #350.2
;;CHAMPVA SUBSISTENCE LIMIT^2911001^^25
;;CHAMPVA PER DIEM^2911001^^8.95
;;CHAMPVA PER DIEM^2921001^^9.30
;;QUIT
;
ATAC ; Resolve pointers to #350.1 from #350.2
W !!,">>> Updating pointers to file #350.1 from file #350.2 ... "
F IBI=1:1 S IBX=$P($T(CHG+IBI),";;",2,99) Q:IBX="" D
.S IBATYP=$O(^IBE(350.1,"B",$P(IBX,"^",2),0))
.S IBJ=0 F S IBJ=$O(^IBE(350.2,"B",$P(IBX,"^"),IBJ)) Q:'IBJ D
..S DIE="^IBE(350.2,",DA=IBJ,DR=".03////"_IBATYP
..D ^DIE K DA,DR,DIE W "."
K DA,DR,DIE,IBATYP,IBI,IBJ,IBX
Q
;
;
CHG ;Action Charge (#350.2)^Action Type (#350.1)
;;CHAMPVA SUBSISTENCE LIMIT^CHAMPVA SUBSISTENCE LIMIT
;;CHAMPVA PER DIEM^DG CHAMPVA PER DIEM NEW
;
; - others that may need to be updated
;
;;RX1^PSO NSC RX COPAY NEW
;;RX2^PSO SC RX COPAY NEW
;;RX3^PSO NSC RX COPAY CANCEL
;;RX4^PSO NSC RX COPAY UPDATE
;;RX5^PSO SC RX COPAY CANCEL
;;RX6^PSO SC RX COPAY UPDATE
;;MEDICARE 1^IB OPT MEDICARE RATE 1
;;MEDICARE 2^IB OPT MEDICARE RATE 2
;;MEDICARE 3^IB OPT MEDICARE RATE 3
;;MEDICARE 4^IB OPT MEDICARE RATE 4
;;MEDICARE 5^IB OPT MEDICARE RATE 5
;;MEDICARE 6^IB OPT MEDICARE RATE 6
;;MEDICARE 7^IB OPT MEDICARE RATE 7
;;MEDICARE 8^IB OPT MEDICARE RATE 8
;;MEDICARE 9^IB OPT MEDICARE RATE 9
;;INPT PER DIEM^DG INPT PER DIEM NEW
;;NHCU PER DIEM^DG NHCU PER DIEM NEW
;;MEDICARE DEDUCTIBLE^MEDICARE DEDUCTIBLE
;
;
ATUT ; Resolve pointers to #350.1 from #399.1
W !!,">>> 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 IBPD=$O(^IBE(350.1,"B",$P(IBX,"^",3),0))
.S DIE="^DGCR(399.1,",DA=IBUTL,DR=".14////"_IBCP_";.15////"_IBPD
.D ^DIE K DA,DR,DIE W "."
;
; - repoint outpatient copay pointer
S DA=$O(^DGCR(399.1,"B","OUTPATIENT VISIT",0))
S IBCP=$O(^IBE(350.1,"B","DG OPT COPAY NEW",0))
I DA,IBCP S DIE="^DGCR(399.1,",DR=".14////"_IBCP D ^DIE W "."
K DA,DR,DIE,IBI,IBX,IBUTL,IBCP,IBPD
Q
;
UTL ;Utility (#399.1)^Copay Action (#350.1)^Per Diem Action (#350.1)
;;ALCOHOL AND DRUG TREATMENT^DG INPT COPAY (ALC) NEW^DG INPT PER DIEM NEW
;;BLIND REHABILITATION^DG INPT COPAY (BLI) NEW^DG INPT PER DIEM NEW
;;GENERAL MEDICAL CARE^DG INPT COPAY (MED) NEW^DG INPT PER DIEM NEW
;;INTERMEDIATE CARE^DG INPT COPAY (INT) NEW^DG INPT PER DIEM NEW
;;NEUROLOGY^DG INPT COPAY (NEU) NEW^DG INPT PER DIEM NEW
;;NURSING HOME CARE^DG NHCU COPAY NEW^DG NHCU PER DIEM NEW
;;PSYCHIATRIC CARE^DG INPT COPAY (PSY) NEW^DG INPT PER DIEM NEW
;;REHABILITATION MEDICINE^DG INPT COPAY (REH) NEW^DG INPT PER DIEM NEW
;;SPINAL CORD INJURY CARE^DG INPT COPAY (SPI) NEW^DG INPT PER DIEM NEW
;;SURGICAL CARE^DG INPT COPAY (SUR) NEW^DG INPT PER DIEM NEW
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT31 4425 printed Apr 09, 2024@21:26:15 Page 2
IB20PT31 ;ALB/CPM - IB V2.0 POST INIT, RESOLVE TABLE POINTERS ; 02-SEP-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
+3 ;
NEWAT ; Add new IB Action Types into file #350.1
+1 WRITE !!,">>> 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))
WRITE !," >> '",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 WRITE !," >> '",$PIECE(IBCR,"^"),"' has been filed..."
End DoDot:1
+8 KILL DA,DIC,DIE,DR,IBI,IBCR,X,Y
+9 QUIT
+10 ;
NAT ; Action Types to add into file #350.1
+1 ;;CHAMPVA SUBSISTENCE LIMIT^CVA LIM^^^82^^^CHAMPVA LIMIT
+2 ;;DG CHAMPVA PER DIEM NEW^CVA PD^^^1^^^CHAMPVA SUBSISTENCE^^^6
+3 ;;DG CHAMPVA PER DIEM CANCEL^CAN CPD^^^2
+4 ;;DG CHAMPVA PER DIEM UPDATE^UPD CPD^^^3
+5 ;;QUIT
+6 ;
NEWAC ; Add new IB Action Charges into file #350.2
+1 WRITE !!,">>> Adding new IB Action Charges into file #350.2..."
+2 FOR IBI=1:1
SET IBCR=$PIECE($TEXT(NAC+IBI),";;",2)
if IBCR="QUIT"
QUIT
Begin DoDot:1
+3 SET X=$PIECE(IBCR,"^")
SET IBF=$ORDER(^IBE(350.2,"B",X,0))
+4 IF IBF
SET IBT=0
Begin DoDot:2
+5 SET IBG=0
FOR
SET IBG=$ORDER(^IBE(350.2,"B",X,IBG))
if 'IBG
QUIT
Begin DoDot:3
+6 IF $PIECE($GET(^IBE(350.2,IBG,0)),"^",2)=$PIECE(IBCR,"^",2)
SET IBT=1
WRITE !," >> '",X,"' for ",$$DAT1^IBOUTL($PIECE(IBCR,"^",2))," is already on file..."
QUIT
End DoDot:3
if IBT
QUIT
End DoDot:2
if IBT
QUIT
+7 ;
+8 KILL DD,DO
SET DIC="^IBE(350.2,"
SET DIC(0)=""
DO FILE^DICN
if Y<0
QUIT
+9 SET DIE=DIC
SET DA=+Y
SET DR=".02////"_$PIECE(IBCR,"^",2)_";.04////"_$PIECE(IBCR,"^",4)
DO ^DIE
+10 WRITE !," >> '",$PIECE(IBCR,"^"),"' has been filed..."
End DoDot:1
+11 KILL DA,DIC,DIE,DR,IBF,IBG,IBI,IBCR,IBT,X,Y
+12 QUIT
+13 ;
NAC ; Action Charges to add into file #350.2
+1 ;;CHAMPVA SUBSISTENCE LIMIT^2911001^^25
+2 ;;CHAMPVA PER DIEM^2911001^^8.95
+3 ;;CHAMPVA PER DIEM^2921001^^9.30
+4 ;;QUIT
+5 ;
ATAC ; Resolve pointers to #350.1 from #350.2
+1 WRITE !!,">>> Updating pointers to file #350.1 from file #350.2 ... "
+2 FOR IBI=1:1
SET IBX=$PIECE($TEXT(CHG+IBI),";;",2,99)
if IBX=""
QUIT
Begin DoDot:1
+3 SET IBATYP=$ORDER(^IBE(350.1,"B",$PIECE(IBX,"^",2),0))
+4 SET IBJ=0
FOR
SET IBJ=$ORDER(^IBE(350.2,"B",$PIECE(IBX,"^"),IBJ))
if 'IBJ
QUIT
Begin DoDot:2
+5 SET DIE="^IBE(350.2,"
SET DA=IBJ
SET DR=".03////"_IBATYP
+6 DO ^DIE
KILL DA,DR,DIE
WRITE "."
End DoDot:2
End DoDot:1
+7 KILL DA,DR,DIE,IBATYP,IBI,IBJ,IBX
+8 QUIT
+9 ;
+10 ;
CHG ;Action Charge (#350.2)^Action Type (#350.1)
+1 ;;CHAMPVA SUBSISTENCE LIMIT^CHAMPVA SUBSISTENCE LIMIT
+2 ;;CHAMPVA PER DIEM^DG CHAMPVA PER DIEM NEW
+3 ;
+4 ; - others that may need to be updated
+5 ;
+6 ;;RX1^PSO NSC RX COPAY NEW
+7 ;;RX2^PSO SC RX COPAY NEW
+8 ;;RX3^PSO NSC RX COPAY CANCEL
+9 ;;RX4^PSO NSC RX COPAY UPDATE
+10 ;;RX5^PSO SC RX COPAY CANCEL
+11 ;;RX6^PSO SC RX COPAY UPDATE
+12 ;;MEDICARE 1^IB OPT MEDICARE RATE 1
+13 ;;MEDICARE 2^IB OPT MEDICARE RATE 2
+14 ;;MEDICARE 3^IB OPT MEDICARE RATE 3
+15 ;;MEDICARE 4^IB OPT MEDICARE RATE 4
+16 ;;MEDICARE 5^IB OPT MEDICARE RATE 5
+17 ;;MEDICARE 6^IB OPT MEDICARE RATE 6
+18 ;;MEDICARE 7^IB OPT MEDICARE RATE 7
+19 ;;MEDICARE 8^IB OPT MEDICARE RATE 8
+20 ;;MEDICARE 9^IB OPT MEDICARE RATE 9
+21 ;;INPT PER DIEM^DG INPT PER DIEM NEW
+22 ;;NHCU PER DIEM^DG NHCU PER DIEM NEW
+23 ;;MEDICARE DEDUCTIBLE^MEDICARE DEDUCTIBLE
+24 ;
+25 ;
ATUT ; Resolve pointers to #350.1 from #399.1
+1 WRITE !!,">>> 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 IBPD=$ORDER(^IBE(350.1,"B",$PIECE(IBX,"^",3),0))
+6 SET DIE="^DGCR(399.1,"
SET DA=IBUTL
SET DR=".14////"_IBCP_";.15////"_IBPD
+7 DO ^DIE
KILL DA,DR,DIE
WRITE "."
End DoDot:1
+8 ;
+9 ; - repoint outpatient copay pointer
+10 SET DA=$ORDER(^DGCR(399.1,"B","OUTPATIENT VISIT",0))
+11 SET IBCP=$ORDER(^IBE(350.1,"B","DG OPT COPAY NEW",0))
+12 IF DA
IF IBCP
SET DIE="^DGCR(399.1,"
SET DR=".14////"_IBCP
DO ^DIE
WRITE "."
+13 KILL DA,DR,DIE,IBI,IBX,IBUTL,IBCP,IBPD
+14 QUIT
+15 ;
UTL ;Utility (#399.1)^Copay Action (#350.1)^Per Diem Action (#350.1)
+1 ;;ALCOHOL AND DRUG TREATMENT^DG INPT COPAY (ALC) NEW^DG INPT PER DIEM NEW
+2 ;;BLIND REHABILITATION^DG INPT COPAY (BLI) NEW^DG INPT PER DIEM NEW
+3 ;;GENERAL MEDICAL CARE^DG INPT COPAY (MED) NEW^DG INPT PER DIEM NEW
+4 ;;INTERMEDIATE CARE^DG INPT COPAY (INT) NEW^DG INPT PER DIEM NEW
+5 ;;NEUROLOGY^DG INPT COPAY (NEU) NEW^DG INPT PER DIEM NEW
+6 ;;NURSING HOME CARE^DG NHCU COPAY NEW^DG NHCU PER DIEM NEW
+7 ;;PSYCHIATRIC CARE^DG INPT COPAY (PSY) NEW^DG INPT PER DIEM NEW
+8 ;;REHABILITATION MEDICINE^DG INPT COPAY (REH) NEW^DG INPT PER DIEM NEW
+9 ;;SPINAL CORD INJURY CARE^DG INPT COPAY (SPI) NEW^DG INPT PER DIEM NEW
+10 ;;SURGICAL CARE^DG INPT COPAY (SUR) NEW^DG INPT PER DIEM NEW
+11 ;
