IBYAPT ;ALB/CPM - PATCH IB*2*28 POST-INITIALIZATION ; 25-JAN-95
;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
;
EN ; Patch IB*2*28 post initialization.
;
D DEL ; delete IBCNS QUIT as an item of IBCNSC INSURANCE CO
D ^IBYAONIT ; install protocols
D BLD ; update ^XUTL("XQORM" for menu protocols
D TEM ; install list templates
D ADD ; add new option to the Ins Mgmt menu
D REF ; build x-refs
D BKG^IBYAPT1 ; queue off insurance clean-up
Q
;
;
DEL ; Delete IBCNS QUIT from the item multiple of IBCNSC INSURANCE CO.
S DIC(0)="F",DIC="^ORD(101,",X="IBCNSC INSURANCE CO"
D ^DIC K DIC Q:Y<0 S IBMENU=+Y
S DIC(0)="F",DIC="^ORD(101,"_IBMENU_",10,",DA(1)=IBMENU,X="IBCNS QUIT"
D ^DIC K DIC Q:Y<0 S IBITEM=+Y
W !!,">>> Deleting protocol IBCNS QUIT as an item of IBCNSC INSURANCE CO..."
W !," (It will be added back in momentarily)"
S DA(1)=IBMENU,DA=IBITEM,DIK="^ORD(101,"_IBMENU_",10," D ^DIK
K DA,DIK,IBITEM,IBMENU
Q
;
BLD ; Update ^XUTL("XQORM" for menu protocols.
W !
F IBX="IBCNSJ PLAN LOOKUP","IBCNSP POLICY MENU","IBCNSC INSURANCE CO" D
.S DIC="^ORD(101,",DIC(0)="F",X=IBX D ^DIC K DIC S IBY=+Y
.I IBY>0 D
..W !,">>> Rebuilding ^XUTL(""XQORM"" for protocol '",IBX,"' ..."
..S XQORM=IBY_";ORD(101," D XREF^XQORM
K IBX,IBY,ORULT,X,XQORM,Y
Q
;
TEM ; Install List Templates
W !!,">>> Installing List Templates..."
W !,"'IBCNS EXPANDED POLICY' List Template..."
S DA=$O(^SD(409.61,"B","IBCNS EXPANDED POLICY",0)),DIK="^SD(409.61," D ^DIK:DA
K DO,DD S DIC(0)="L",DIC="^SD(409.61,",X="IBCNS EXPANDED POLICY" D FILE^DICN S VALM=+Y
I VALM>0 D
.S ^SD(409.61,VALM,0)="IBCNS EXPANDED POLICY^1^^80^5^17^1^1^Policy^IBCNSP POLICY MENU^Patient Policy Information^1"
.S ^SD(409.61,VALM,1)="^VALM HIDDEN ACTIONS"
.S ^SD(409.61,VALM,"ARRAY")=" ^TMP(""IBCNSVP"",$J)"
.S ^SD(409.61,VALM,"COL",0)="^409.621^^0"
.S ^SD(409.61,VALM,"FNL")="D EXIT^IBCNSP"
.S ^SD(409.61,VALM,"HDR")="D HDR^IBCNSP"
.S ^SD(409.61,VALM,"HLP")="D HELP^IBCNSP"
.S ^SD(409.61,VALM,"INIT")="D INIT^IBCNSP"
.S DA=VALM,DIK="^SD(409.61," D IX1^DIK K DA,DIK
.W "Filed."
;
W !,"'IBCNS PLAN LOOKUP' List Template..."
S DA=$O(^SD(409.61,"B","IBCNS PLAN LOOKUP",0)),DIK="^SD(409.61," D ^DIK:DA
K DO,DD S DIC(0)="L",DIC="^SD(409.61,",X="IBCNS PLAN LOOKUP" D FILE^DICN S VALM=+Y
I VALM>0 D
.S ^SD(409.61,VALM,0)="IBCNS PLAN LOOKUP^1^^80^7^19^1^1^Plan^IBCNSJ PLAN LOOKUP^Insurance Plan Lookup^1^^1"
.S ^SD(409.61,VALM,1)="^VALM HIDDEN ACTIONS"
.S ^SD(409.61,VALM,"ARRAY")=" ^TMP(""IBCNSJ"",$J)"
.S ^SD(409.61,VALM,"COL",0)="^409.621^8^8"
.S ^SD(409.61,VALM,"COL",1,0)="NUMBER^1^4^"
.S ^SD(409.61,VALM,"COL",2,0)="GNAME^5^18^Group Name"
.S ^SD(409.61,VALM,"COL",3,0)="GNUM^25^17^Group Number"
.S ^SD(409.61,VALM,"COL",4,0)="TYPE^44^13^Type of Plan"
.S ^SD(409.61,VALM,"COL",5,0)="UR^59^3^UR?"
.S ^SD(409.61,VALM,"COL",6,0)="PREC^64^3^Ct?"
.S ^SD(409.61,VALM,"COL",7,0)="PREEX^70^4^ExC?"
.S ^SD(409.61,VALM,"COL",8,0)="BENAS^76^3^As?"
.S ^SD(409.61,VALM,"FNL")="D FNL^IBCNSU2"
.S ^SD(409.61,VALM,"HDR")="D HDR^IBCNSU2"
.S ^SD(409.61,VALM,"HLP")="S X=""?"" D DISP^XQORM1 W !!"
.S ^SD(409.61,VALM,"INIT")="D INIT^IBCNSU2"
.S DA=VALM,DIK="^SD(409.61," D IX1^DIK K DA,DIK
.W "Filed."
;
K DIC,DIK,VALM,X,DA Q
;
ADD ; Add the option List Plans by Insurance Company to the Ins Mgmt menu
S (IBUY,Y)=$O(^DIC(19,"B","IBCN INSURANCE MGMT MENU",0)) Q:Y=""
S X=$O(^DIC(19,"B","IBCN LIST PLANS BY INS CO",0)) Q:X=""
W !!,">>> Adding IBCN LIST PLANS BY INS CO option to the IBCN INSURANCE MGMT MENU..."
I '$D(^DIC(19,+Y,10,0)) S ^DIC(19,+Y,10,0)="^19.01IP^0^0"
S (DA,D0)=+Y,DIC="^DIC(19,"_+Y_",10,",DIC(0)="L",DA(1)=+Y,DLAYGO=19.01,X="IBCN LIST PLANS BY INS CO" D ^DIC
S DA=+Y,DIE="^DIC(19,"_DA(1)_",10,",DR="2///^S X=""LP""" D ^DIE
K DIC,DIE,DA,IBUY,DR,X,Y
Q
;
REF ; Build the ACCP, AGNA, and AGNU cross-references.
W !!,">>> Building the 'ACCP' cross-reference for file #355.3 ..."
W !," (I'll write a dot for every 100 entries processed)",!
S (IBCT,IBP)=0
F IB=1:1 S IBP=$O(^IBA(355.3,IBP)) Q:'IBP S IBPD=$G(^(IBP,0)) I IBPD D
.W:'(IB#100) "."
.S IBX=$P(IBPD,"^",3) I IBX]"" D
..S ^IBA(355.3,"AGNA",+IBPD,IBX,IBP)=""
..S Y=$$COMP^IBCNSJ(IBX) I Y]"" S ^IBA(355.3,"ACCP",+IBPD,Y,IBP)=""
.S IBX=$P(IBPD,"^",4) I IBX]"" D
..S ^IBA(355.3,"AGNU",+IBPD,IBX,IBP)=""
..S Y=$$COMP^IBCNSJ(IBX) I Y]"" S ^IBA(355.3,"ACCP",+IBPD,Y,IBP)=""
.I $P(IBPD,"^",2),$P(IBPD,"^",10) D
..S DIE="^IBA(355.3,",DA=IBP,DR=".1////@;1.05///NOW;1.06////"_DUZ
..D ^DIE K DIE,DA,DR S IBCT=IBCT+1
I IBCT W !?4,"Note that ",IBCT," group plan",$S(IBCT>1:"s",1:"")," had the individual policy pointer removed."
K IBCT,IBP,IB,IBPD,IBX,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYAPT 4794 printed Apr 09, 2024@21:37:36 Page 2
IBYAPT ;ALB/CPM - PATCH IB*2*28 POST-INITIALIZATION ; 25-JAN-95
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
+2 ;
EN ; Patch IB*2*28 post initialization.
+1 ;
+2 ; delete IBCNS QUIT as an item of IBCNSC INSURANCE CO
DO DEL
+3 ; install protocols
DO ^IBYAONIT
+4 ; update ^XUTL("XQORM" for menu protocols
DO BLD
+5 ; install list templates
DO TEM
+6 ; add new option to the Ins Mgmt menu
DO ADD
+7 ; build x-refs
DO REF
+8 ; queue off insurance clean-up
DO BKG^IBYAPT1
+9 QUIT
+10 ;
+11 ;
DEL ; Delete IBCNS QUIT from the item multiple of IBCNSC INSURANCE CO.
+1 SET DIC(0)="F"
SET DIC="^ORD(101,"
SET X="IBCNSC INSURANCE CO"
+2 DO ^DIC
KILL DIC
if Y<0
QUIT
SET IBMENU=+Y
+3 SET DIC(0)="F"
SET DIC="^ORD(101,"_IBMENU_",10,"
SET DA(1)=IBMENU
SET X="IBCNS QUIT"
+4 DO ^DIC
KILL DIC
if Y<0
QUIT
SET IBITEM=+Y
+5 WRITE !!,">>> Deleting protocol IBCNS QUIT as an item of IBCNSC INSURANCE CO..."
+6 WRITE !," (It will be added back in momentarily)"
+7 SET DA(1)=IBMENU
SET DA=IBITEM
SET DIK="^ORD(101,"_IBMENU_",10,"
DO ^DIK
+8 KILL DA,DIK,IBITEM,IBMENU
+9 QUIT
+10 ;
BLD ; Update ^XUTL("XQORM" for menu protocols.
+1 WRITE !
+2 FOR IBX="IBCNSJ PLAN LOOKUP","IBCNSP POLICY MENU","IBCNSC INSURANCE CO"
Begin DoDot:1
+3 SET DIC="^ORD(101,"
SET DIC(0)="F"
SET X=IBX
DO ^DIC
KILL DIC
SET IBY=+Y
+4 IF IBY>0
Begin DoDot:2
+5 WRITE !,">>> Rebuilding ^XUTL(""XQORM"" for protocol '",IBX,"' ..."
+6 SET XQORM=IBY_";ORD(101,"
DO XREF^XQORM
End DoDot:2
End DoDot:1
+7 KILL IBX,IBY,ORULT,X,XQORM,Y
+8 QUIT
+9 ;
TEM ; Install List Templates
+1 WRITE !!,">>> Installing List Templates..."
+2 WRITE !,"'IBCNS EXPANDED POLICY' List Template..."
+3 SET DA=$ORDER(^SD(409.61,"B","IBCNS EXPANDED POLICY",0))
SET DIK="^SD(409.61,"
if DA
DO ^DIK
+4 KILL DO,DD
SET DIC(0)="L"
SET DIC="^SD(409.61,"
SET X="IBCNS EXPANDED POLICY"
DO FILE^DICN
SET VALM=+Y
+5 IF VALM>0
Begin DoDot:1
+6 SET ^SD(409.61,VALM,0)="IBCNS EXPANDED POLICY^1^^80^5^17^1^1^Policy^IBCNSP POLICY MENU^Patient Policy Information^1"
+7 SET ^SD(409.61,VALM,1)="^VALM HIDDEN ACTIONS"
+8 SET ^SD(409.61,VALM,"ARRAY")=" ^TMP(""IBCNSVP"",$J)"
+9 SET ^SD(409.61,VALM,"COL",0)="^409.621^^0"
+10 SET ^SD(409.61,VALM,"FNL")="D EXIT^IBCNSP"
+11 SET ^SD(409.61,VALM,"HDR")="D HDR^IBCNSP"
+12 SET ^SD(409.61,VALM,"HLP")="D HELP^IBCNSP"
+13 SET ^SD(409.61,VALM,"INIT")="D INIT^IBCNSP"
+14 SET DA=VALM
SET DIK="^SD(409.61,"
DO IX1^DIK
KILL DA,DIK
+15 WRITE "Filed."
End DoDot:1
+16 ;
+17 WRITE !,"'IBCNS PLAN LOOKUP' List Template..."
+18 SET DA=$ORDER(^SD(409.61,"B","IBCNS PLAN LOOKUP",0))
SET DIK="^SD(409.61,"
if DA
DO ^DIK
+19 KILL DO,DD
SET DIC(0)="L"
SET DIC="^SD(409.61,"
SET X="IBCNS PLAN LOOKUP"
DO FILE^DICN
SET VALM=+Y
+20 IF VALM>0
Begin DoDot:1
+21 SET ^SD(409.61,VALM,0)="IBCNS PLAN LOOKUP^1^^80^7^19^1^1^Plan^IBCNSJ PLAN LOOKUP^Insurance Plan Lookup^1^^1"
+22 SET ^SD(409.61,VALM,1)="^VALM HIDDEN ACTIONS"
+23 SET ^SD(409.61,VALM,"ARRAY")=" ^TMP(""IBCNSJ"",$J)"
+24 SET ^SD(409.61,VALM,"COL",0)="^409.621^8^8"
+25 SET ^SD(409.61,VALM,"COL",1,0)="NUMBER^1^4^"
+26 SET ^SD(409.61,VALM,"COL",2,0)="GNAME^5^18^Group Name"
+27 SET ^SD(409.61,VALM,"COL",3,0)="GNUM^25^17^Group Number"
+28 SET ^SD(409.61,VALM,"COL",4,0)="TYPE^44^13^Type of Plan"
+29 SET ^SD(409.61,VALM,"COL",5,0)="UR^59^3^UR?"
+30 SET ^SD(409.61,VALM,"COL",6,0)="PREC^64^3^Ct?"
+31 SET ^SD(409.61,VALM,"COL",7,0)="PREEX^70^4^ExC?"
+32 SET ^SD(409.61,VALM,"COL",8,0)="BENAS^76^3^As?"
+33 SET ^SD(409.61,VALM,"FNL")="D FNL^IBCNSU2"
+34 SET ^SD(409.61,VALM,"HDR")="D HDR^IBCNSU2"
+35 SET ^SD(409.61,VALM,"HLP")="S X=""?"" D DISP^XQORM1 W !!"
+36 SET ^SD(409.61,VALM,"INIT")="D INIT^IBCNSU2"
+37 SET DA=VALM
SET DIK="^SD(409.61,"
DO IX1^DIK
KILL DA,DIK
+38 WRITE "Filed."
End DoDot:1
+39 ;
+40 KILL DIC,DIK,VALM,X,DA
QUIT
+41 ;
ADD ; Add the option List Plans by Insurance Company to the Ins Mgmt menu
+1 SET (IBUY,Y)=$ORDER(^DIC(19,"B","IBCN INSURANCE MGMT MENU",0))
if Y=""
QUIT
+2 SET X=$ORDER(^DIC(19,"B","IBCN LIST PLANS BY INS CO",0))
if X=""
QUIT
+3 WRITE !!,">>> Adding IBCN LIST PLANS BY INS CO option to the IBCN INSURANCE MGMT MENU..."
+4 IF '$DATA(^DIC(19,+Y,10,0))
SET ^DIC(19,+Y,10,0)="^19.01IP^0^0"
+5 SET (DA,D0)=+Y
SET DIC="^DIC(19,"_+Y_",10,"
SET DIC(0)="L"
SET DA(1)=+Y
SET DLAYGO=19.01
SET X="IBCN LIST PLANS BY INS CO"
DO ^DIC
+6 SET DA=+Y
SET DIE="^DIC(19,"_DA(1)_",10,"
SET DR="2///^S X=""LP"""
DO ^DIE
+7 KILL DIC,DIE,DA,IBUY,DR,X,Y
+8 QUIT
+9 ;
REF ; Build the ACCP, AGNA, and AGNU cross-references.
+1 WRITE !!,">>> Building the 'ACCP' cross-reference for file #355.3 ..."
+2 WRITE !," (I'll write a dot for every 100 entries processed)",!
+3 SET (IBCT,IBP)=0
+4 FOR IB=1:1
SET IBP=$ORDER(^IBA(355.3,IBP))
if 'IBP
QUIT
SET IBPD=$GET(^(IBP,0))
IF IBPD
Begin DoDot:1
+5 if '(IB#100)
WRITE "."
+6 SET IBX=$PIECE(IBPD,"^",3)
IF IBX]""
Begin DoDot:2
+7 SET ^IBA(355.3,"AGNA",+IBPD,IBX,IBP)=""
+8 SET Y=$$COMP^IBCNSJ(IBX)
IF Y]""
SET ^IBA(355.3,"ACCP",+IBPD,Y,IBP)=""
End DoDot:2
+9 SET IBX=$PIECE(IBPD,"^",4)
IF IBX]""
Begin DoDot:2
+10 SET ^IBA(355.3,"AGNU",+IBPD,IBX,IBP)=""
+11 SET Y=$$COMP^IBCNSJ(IBX)
IF Y]""
SET ^IBA(355.3,"ACCP",+IBPD,Y,IBP)=""
End DoDot:2
+12 IF $PIECE(IBPD,"^",2)
IF $PIECE(IBPD,"^",10)
Begin DoDot:2
+13 SET DIE="^IBA(355.3,"
SET DA=IBP
SET DR=".1////@;1.05///NOW;1.06////"_DUZ
+14 DO ^DIE
KILL DIE,DA,DR
SET IBCT=IBCT+1
End DoDot:2
End DoDot:1
+15 IF IBCT
WRITE !?4,"Note that ",IBCT," group plan",$SELECT(IBCT>1:"s",1:"")," had the individual policy pointer removed."
+16 KILL IBCT,IBP,IB,IBPD,IBX,Y
+17 QUIT
