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

IB20PT31.m

Go to the documentation of this file. 
  1. IB20PT31	;ALB/CPM - IB V2.0 POST INIT, RESOLVE TABLE POINTERS ; 02-SEP-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;
  1. 	;
  1. NEWAT	; Add new IB Action Types into file #350.1
  1. 	W !!,">>> 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)) W !," >> '",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. 	.W !," >> '",$P(IBCR,"^"),"' has been filed..."
  1. 	K DA,DIC,DIE,DR,IBI,IBCR,X,Y
  1. 	Q
  1. 	;
  1. NAT	; Action Types to add into file #350.1
  1. 	;;CHAMPVA SUBSISTENCE LIMIT^CVA LIM^^^82^^^CHAMPVA LIMIT
  1. 	;;DG CHAMPVA PER DIEM NEW^CVA PD^^^1^^^CHAMPVA SUBSISTENCE^^^6
  1. 	;;DG CHAMPVA PER DIEM CANCEL^CAN CPD^^^2
  1. 	;;DG CHAMPVA PER DIEM UPDATE^UPD CPD^^^3
  1. 	;;QUIT
  1. 	;
  1. NEWAC	; Add new IB Action Charges into file #350.2
  1. 	W !!,">>> Adding new IB Action Charges into file #350.2..."
  1. 	F IBI=1:1 S IBCR=$P($T(NAC+IBI),";;",2) Q:IBCR="QUIT"  D
  1. 	.S X=$P(IBCR,"^"),IBF=$O(^IBE(350.2,"B",X,0))
  1. 	.I IBF S IBT=0 D  Q:IBT
  1. 	..S IBG=0 F  S IBG=$O(^IBE(350.2,"B",X,IBG)) Q:'IBG  D  Q:IBT
  1. 	...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
  1. 	.;
  1. 	.K DD,DO S DIC="^IBE(350.2,",DIC(0)="" D FILE^DICN Q:Y<0
  1. 	.S DIE=DIC,DA=+Y,DR=".02////"_$P(IBCR,"^",2)_";.04////"_$P(IBCR,"^",4) D ^DIE
  1. 	.W !," >> '",$P(IBCR,"^"),"' has been filed..."
  1. 	K DA,DIC,DIE,DR,IBF,IBG,IBI,IBCR,IBT,X,Y
  1. 	Q
  1. 	;
  1. NAC	; Action Charges to add into file #350.2
  1. 	;;CHAMPVA SUBSISTENCE LIMIT^2911001^^25
  1. 	;;CHAMPVA PER DIEM^2911001^^8.95
  1. 	;;CHAMPVA PER DIEM^2921001^^9.30
  1. 	;;QUIT
  1. 	;
  1. ATAC	; Resolve pointers to #350.1 from #350.2
  1. 	W !!,">>> Updating pointers to file #350.1 from file #350.2 ... "
  1. 	F IBI=1:1 S IBX=$P($T(CHG+IBI),";;",2,99) Q:IBX=""  D
  1. 	.S IBATYP=$O(^IBE(350.1,"B",$P(IBX,"^",2),0))
  1. 	.S IBJ=0 F  S IBJ=$O(^IBE(350.2,"B",$P(IBX,"^"),IBJ)) Q:'IBJ  D
  1. 	..S DIE="^IBE(350.2,",DA=IBJ,DR=".03////"_IBATYP
  1. 	..D ^DIE K DA,DR,DIE W "."
  1. 	K DA,DR,DIE,IBATYP,IBI,IBJ,IBX
  1. 	Q
  1. 	;
  1. 	;
  1. CHG	;Action Charge (#350.2)^Action Type (#350.1)
  1. 	;;CHAMPVA SUBSISTENCE LIMIT^CHAMPVA SUBSISTENCE LIMIT
  1. 	;;CHAMPVA PER DIEM^DG CHAMPVA PER DIEM NEW
  1. 	;
  1. 	; - others that may need to be updated
  1. 	;
  1. 	;;RX1^PSO NSC RX COPAY NEW
  1. 	;;RX2^PSO SC RX COPAY NEW
  1. 	;;RX3^PSO NSC RX COPAY CANCEL
  1. 	;;RX4^PSO NSC RX COPAY UPDATE
  1. 	;;RX5^PSO SC RX COPAY CANCEL
  1. 	;;RX6^PSO SC RX COPAY UPDATE
  1. 	;;MEDICARE 1^IB OPT MEDICARE RATE 1
  1. 	;;MEDICARE 2^IB OPT MEDICARE RATE 2
  1. 	;;MEDICARE 3^IB OPT MEDICARE RATE 3
  1. 	;;MEDICARE 4^IB OPT MEDICARE RATE 4
  1. 	;;MEDICARE 5^IB OPT MEDICARE RATE 5
  1. 	;;MEDICARE 6^IB OPT MEDICARE RATE 6
  1. 	;;MEDICARE 7^IB OPT MEDICARE RATE 7
  1. 	;;MEDICARE 8^IB OPT MEDICARE RATE 8
  1. 	;;MEDICARE 9^IB OPT MEDICARE RATE 9
  1. 	;;INPT PER DIEM^DG INPT PER DIEM NEW
  1. 	;;NHCU PER DIEM^DG NHCU PER DIEM NEW
  1. 	;;MEDICARE DEDUCTIBLE^MEDICARE DEDUCTIBLE
  1. 	;
  1. 	;
  1. ATUT	; Resolve pointers to #350.1 from #399.1
  1. 	W !!,">>> 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 IBPD=$O(^IBE(350.1,"B",$P(IBX,"^",3),0))
  1. 	.S DIE="^DGCR(399.1,",DA=IBUTL,DR=".14////"_IBCP_";.15////"_IBPD
  1. 	.D ^DIE K DA,DR,DIE W "."
  1. 	;
  1. 	; - repoint outpatient copay pointer
  1. 	S DA=$O(^DGCR(399.1,"B","OUTPATIENT VISIT",0))
  1. 	S IBCP=$O(^IBE(350.1,"B","DG OPT COPAY NEW",0))
  1. 	I DA,IBCP S DIE="^DGCR(399.1,",DR=".14////"_IBCP D ^DIE W "."
  1. 	K DA,DR,DIE,IBI,IBX,IBUTL,IBCP,IBPD
  1. 	Q
  1. 	;
  1. 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
  1. 	;;BLIND REHABILITATION^DG INPT COPAY (BLI) NEW^DG INPT PER DIEM NEW
  1. 	;;GENERAL MEDICAL CARE^DG INPT COPAY (MED) NEW^DG INPT PER DIEM NEW
  1. 	;;INTERMEDIATE CARE^DG INPT COPAY (INT) NEW^DG INPT PER DIEM NEW
  1. 	;;NEUROLOGY^DG INPT COPAY (NEU) NEW^DG INPT PER DIEM NEW
  1. 	;;NURSING HOME CARE^DG NHCU COPAY NEW^DG NHCU PER DIEM NEW
  1. 	;;PSYCHIATRIC CARE^DG INPT COPAY (PSY) NEW^DG INPT PER DIEM NEW
  1. 	;;REHABILITATION MEDICINE^DG INPT COPAY (REH) NEW^DG INPT PER DIEM NEW
  1. 	;;SPINAL CORD INJURY CARE^DG INPT COPAY (SPI) NEW^DG INPT PER DIEM NEW
  1. 	;;SURGICAL CARE^DG INPT COPAY (SUR) NEW^DG INPT PER DIEM NEW
  1. 	;