IBCNSC2 ;ALB/NLR - INACTIVATE AND REPOINT INS STUFF ; 20-APR-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
MAIN ; -- main flow control
;
N IBQUIT,DFN
S IBQUIT=0
D START D:'IBQUIT AP I ('IBQUIT),(+IBV=1) D RPTASK^IBCNSC3
G EXIT
;
START ; -- activate or inactivate insurance co. if necessary
;
S IBV=$P(^DIC(36,IBCNS,0),U,5),IBV1=IBV,IBN=$P(^DIC(36,IBCNS,0),U)
S IBA="ACTIVE",IBB="ACTIVATE",IBVER=0 I IBV S IBA="IN"_IBA
I 'IBV S IBB="IN"_IBB
S DIR("B")="No"
S DIR(0)="YO",DIR("A")=""_IBN_" IS CURRENTLY "_IBA_". DO YOU WISH TO "_IBB_" IT"
S DIR("?",1)="Company should be INACTIVE if it is no longer"
S DIR("?",2)="active in your area. This will disallow users"
S DIR("?")="from selecting this insurance company entry."
D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 G R1Q
I 'IBV,Y D VERIFY^IBCNSC3 G:IBQUIT R1Q S IBVER=1
I 'IBVER,IBV,Y S IBV=0
;
RESET ; -- change global if ins. co. activated or inactivated
;
S:IBV1'=IBV $P(^DIC(36,IBCNS,0),U,5)=IBV
;
;
UPDATE ; -- update patient file
;
;I +IBV=0 S IBQUIT=1 G R1Q
S DFN=0,IBC=0 F S DFN=$O(^DPT("AB",IBCNS,DFN)) Q:'DFN!(IBC>20) S IBC=IBC+1
W !!,"THERE "_$S(IBC=0:"ARE NO PATIENTS",IBC=1:"IS ONE PATIENT",IBC>20:"ARE MORE THAN 20 PATIENTS",1:"ARE "_IBC_" PATIENTS")_" COVERED BY THIS "_$S(+IBV=0:"(ACTIVE)",+IBV=1:"(INACTIVE)")_" INSURANCE COMPANY...." I 'IBC D PAUSE^VALM1 S IBQUIT=1
;
R1Q Q
;
AP ; -- ask if user wishes to print patients with inactivated insurance
;
S DIR(0)="YO",DIR("A")="DO YOU WISH TO PRINT "_$S(IBC=1:"THE NAME OF THIS PATIENT",1:"A LIST OF ALL OF THE PATIENTS"),DIR("B")="No"
W !
D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 G R2Q
G:'Y R2Q
W !!,"*** You will need a 132 column printer for this report. ***",!
;
DEV ; -- ask for device
;
S %ZIS="QM" D ^%ZIS I POP S IBQUIT=1 G R2Q
I $D(IO("Q")) K IO("Q") S ZTRTN="PRINT^IBCNSC2",ZTSAVE("IB*")="",ZTDESC="PATIENTS WITH INACTIVATED INSURANCE" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
U IO
;
PRINT ; -- print list of patients covered by inactivated insurance company
;
D BUILD^IBCNSC3
D HDR^IBCNSC3
S IBNA="" F S IBNA=$O(^TMP($J,"IBCNSC2",IBNA)) Q:IBNA=""!(IBQUIT) S DFN=0 F S DFN=$O(^TMP($J,"IBCNSC2",IBNA,DFN)) Q:'DFN!(IBQUIT) S IBD=0 F S IBD=$O(^TMP($J,"IBCNSC2",IBNA,DFN,IBD)) Q:'IBD!(IBQUIT) D
.S IBST=^TMP($J,"IBCNSC2",IBNA,DFN,IBD)
.I $Y>(IOSL-5) D PAUSE^IBOUTL D HDR^IBCNSC3
.W !,?1,$E(IBNA,1,28),?31,$P(IBST,"^",1),?52,$$DAT1^IBOUTL($P(IBST,"^",2)),?63,$$DAT1^IBOUTL($P(IBST,"^",3)),?74,$P(IBST,"^",4),?95,$$EXPAND^IBTRE(2.312,6,$P(IBST,"^",5)),?106,$E($P(IBST,"^",6),1,24)
I $E(IOST,1,2)["C-",('($G(IBV))) D PAUSE^VALM1
;
R2Q I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
Q
;
EXIT ; -- kill variables -- IBCNS used by IBCNSC so don't want to kill here
;
K ^TMP($J,"IBCNSC2")
K DIRUT,IBA,IBB,IBC,IBD,IBIND,IBNA,IBNO,IBPAG,IBR,IBST,IBV,IBVER,IBV1,IBCO,IBEF,IBEX,IBN,IBQUIT,X,Y
Q
IBCNSC2 ;ALB/NLR - INACTIVATE AND REPOINT INS STUFF ; 20-APR-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
MAIN ; -- main flow control
+1 ;
+2 NEW IBQUIT,DFN
+3 SET IBQUIT=0
+4 DO START
IF 'IBQUIT
DO AP
IF ('IBQUIT)
IF (+IBV=1)
DO RPTASK^IBCNSC3
+5 GOTO EXIT
+6 ;
START ; -- activate or inactivate insurance co. if necessary
+1 ;
+2 SET IBV=$PIECE(^DIC(36,IBCNS,0),U,5)
SET IBV1=IBV
SET IBN=$PIECE(^DIC(36,IBCNS,0),U)
+3 SET IBA="ACTIVE"
SET IBB="ACTIVATE"
SET IBVER=0
IF IBV
SET IBA="IN"_IBA
+4 IF 'IBV
SET IBB="IN"_IBB
+5 SET DIR("B")="No"
+6 SET DIR(0)="YO"
SET DIR("A")=""_IBN_" IS CURRENTLY "_IBA_". DO YOU WISH TO "_IBB_" IT"
+7 SET DIR("?",1)="Company should be INACTIVE if it is no longer"
+8 SET DIR("?",2)="active in your area. This will disallow users"
+9 SET DIR("?")="from selecting this insurance company entry."
+10 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQUIT=1
GOTO R1Q
+11 IF 'IBV
IF Y
DO VERIFY^IBCNSC3
IF IBQUIT
GOTO R1Q
SET IBVER=1
+12 IF 'IBVER
IF IBV
IF Y
SET IBV=0
+13 ;
RESET ; -- change global if ins. co. activated or inactivated
+1 ;
+2 IF IBV1'=IBV
SET $PIECE(^DIC(36,IBCNS,0),U,5)=IBV
+3 ;
+4 ;
UPDATE ; -- update patient file
+1 ;
+2 ;I +IBV=0 S IBQUIT=1 G R1Q
+3 SET DFN=0
SET IBC=0
FOR
SET DFN=$ORDER(^DPT("AB",IBCNS,DFN))
IF 'DFN!(IBC>20)
QUIT
SET IBC=IBC+1
+4 WRITE !!,"THERE "_$SELECT(IBC=0:"ARE NO PATIENTS",IBC=1:"IS ONE PATIENT",IBC>20:"ARE MORE THAN 20 PATIENTS",1:"ARE "_IBC_" PATIENTS")_" COVERED BY THIS "_$SELECT(+IBV=0:"(ACTIVE)",+IBV=1:"(INACTIVE)")_" INSURANCE COMPANY...."
IF 'IBC
DO PAUSE^VALM1
SET IBQUIT=1
+5 ;
R1Q QUIT
+1 ;
AP ; -- ask if user wishes to print patients with inactivated insurance
+1 ;
+2 SET DIR(0)="YO"
SET DIR("A")="DO YOU WISH TO PRINT "_$SELECT(IBC=1:"THE NAME OF THIS PATIENT",1:"A LIST OF ALL OF THE PATIENTS")
SET DIR("B")="No"
+3 WRITE !
+4 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQUIT=1
GOTO R2Q
+5 IF 'Y
GOTO R2Q
+6 WRITE !!,"*** You will need a 132 column printer for this report. ***",!
+7 ;
DEV ; -- ask for device
+1 ;
+2 SET %ZIS="QM"
DO ^%ZIS
IF POP
SET IBQUIT=1
GOTO R2Q
+3 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="PRINT^IBCNSC2"
SET ZTSAVE("IB*")=""
SET ZTDESC="PATIENTS WITH INACTIVATED INSURANCE"
DO ^%ZTLOAD
KILL ZTSK
DO HOME^%ZIS
QUIT
+4 USE IO
+5 ;
PRINT ; -- print list of patients covered by inactivated insurance company
+1 ;
+2 DO BUILD^IBCNSC3
+3 DO HDR^IBCNSC3
+4 SET IBNA=""
FOR
SET IBNA=$ORDER(^TMP($JOB,"IBCNSC2",IBNA))
IF IBNA=""!(IBQUIT)
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNSC2",IBNA,DFN))
IF 'DFN!(IBQUIT)
QUIT
SET IBD=0
FOR
SET IBD=$ORDER(^TMP($JOB,"IBCNSC2",IBNA,DFN,IBD))
IF 'IBD!(IBQUIT)
QUIT
Begin DoDot:1
+5 SET IBST=^TMP($JOB,"IBCNSC2",IBNA,DFN,IBD)
+6 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
DO HDR^IBCNSC3
+7 WRITE !,?1,$EXTRACT(IBNA,1,28),?31,$PIECE(IBST,"^",1),?52,$$DAT1^IBOUTL($PIECE(IBST,"^",2)),?63,$$DAT1^IBOUTL($PIECE(IBST,"^",3)),?74,$PIECE(IBST,"^",4),?95,$$EXPAND^IBTRE(2.312,6,$PIECE(IBST,"^",5)),?106,$EXTRACT($PIECE(IBST,"^
",6),1,24)
End DoDot:1
+8 IF $EXTRACT(IOST,1,2)["C-"
IF ('($GET(IBV)))
DO PAUSE^VALM1
+9 ;
R2Q IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+1 DO ^%ZISC
+2 QUIT
+3 ;
EXIT ; -- kill variables -- IBCNS used by IBCNSC so don't want to kill here
+1 ;
+2 KILL ^TMP($JOB,"IBCNSC2")
+3 KILL DIRUT,IBA,IBB,IBC,IBD,IBIND,IBNA,IBNO,IBPAG,IBR,IBST,IBV,IBVER,IBV1,IBCO,IBEF,IBEX,IBN,IBQUIT,X,Y
+4 QUIT
