IBCNSC2.m

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