Routine: IBCNSC01

IBCNSC01	;ALB/NLR - INSURANCE COMPANY EDIT -  ; 21-OCT-1993

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

PARAM	; -- Insurance company parameters region

	N OFFSET,START,IBCNS0,IBCNS03,IBCNS06,IBCNS08,IBCNS13

	S IBCNS0=$G(^DIC(36,+IBCNS,0))

	S IBCNS03=$P(IBCNS0,"^",3),IBCNS06=$P(IBCNS0,"^",6),IBCNS08=$P(IBCNS0,"^",8)

	S IBCNS13=$G(^DIC(36,+IBCNS,.13))

	S START=1,OFFSET=2

	D SET^IBCNSP(START,OFFSET+25," Billing Parameters ",IORVON,IORVOFF)

	D SET^IBCNSP(START+1,OFFSET," Signature Required?: "_$S(+IBCNS03:"YES",1:"NO"))

	D SET^IBCNSP(START+2,OFFSET,"          Reimburse?: "_$E($$EXPAND^IBTRE(36,1,$P(IBCNS0,"^",2)),1,21))

	D SET^IBCNSP(START+3,OFFSET,"   Mult. Bedsections: "_$S(+IBCNS06:"YES",1:"NO"))

	D SET^IBCNSP(START+4,OFFSET,"    Diff. Rev. Codes: "_$P(IBCNS0,"^",7))

	D SET^IBCNSP(START+5,OFFSET,"      One Opt. Visit: "_$S(+IBCNS08:"YES",1:"NO"))

	D SET^IBCNSP(START+6,OFFSET," Amb. Sur. Rev. Code: "_$P(IBCNS0,"^",9))

	D SET^IBCNSP(START+7,OFFSET," Rx Refill Rev. Code: "_$P(IBCNS0,"^",15))

	D SET^IBCNSP(START+8,OFFSET,"   Filing Time Frame: "_$P(IBCNS0,"^",12))

	N START,OFFSET

	S START=2,OFFSET=45

	D SET^IBCNSP(START,OFFSET,"  Attending Phys. ID: "_$E($P(IBCNS0,"^",10),1,22))

	D SET^IBCNSP(START+1,OFFSET,"  Hosp. Provider No.: "_$E($P(IBCNS0,"^",11),1,15))

	D SET^IBCNSP(START+2,OFFSET,"   Primary Form Type: "_$$EXPAND^IBTRE(36,.14,$P(IBCNS0,"^",14)))

	D SET^IBCNSP(START+3,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2))

	D SET^IBCNSP(START+4,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4))

	D SET^IBCNSP(START+5,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1))

	D SET^IBCNSP(START+6,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))

PHONE(IBCNS13)	; -- Compute precert company phone

	N IBX,IBSAVE,IBCNT S IBX=""

	I '$P(IBCNS13,"^",9) S IBX=$P(IBCNS13,"^",3) G PHONEQ

REDOX	S IBSAVE=+$P(IBCNS13,"^",9)

	S IBCNT=$G(IBCNT)+1

	; -- if you process the same co. more than once you are in an infinite loop

	I $D(IBCNT(IBCNS)) G PHONEQ

	S IBCNT(IBCNS)=""

	S IBCNS13=$G(^DIC(36,+$P(IBCNS13,"^",9),.13))

	S IBX=$P(IBCNS13,"^") S:$L($P(IBCNS13,"^",3)) IBX=$P(IBCNS13,"^",3)

	; -- if process the same co. more than once you are in an infinite loop

	I $P(IBCNS13,"^",9),$P(IBCNS13,"^",9)'=IBSAVE G REDOX

PHONEQ	Q IBX

MAIN	; -- Insurance company main address

	N OFFSET,START,IBCNS11,IBADD

	S IBCNS11=$G(^DIC(36,+IBCNS,.11))

	S IBCNS13=$G(^DIC(36,+IBCNS,.13))

	S START=14,OFFSET=25

	D SET^IBCNSP(START,OFFSET," Main Mailing Address ",IORVON,IORVOFF)

	N OFFSET S OFFSET=2

	D SET^IBCNSP(START+1,OFFSET,"       Street: "_$P(IBCNS11,"^",1)) S IBADD=1

	D SET^IBCNSP(START+2,OFFSET,"     Street 2: "_$P(IBCNS11,"^",2)) S IBADD=2

	D SET^IBCNSP(START+3,OFFSET,"     Street 3: "_$P(IBCNS11,"^",3)) S IBADD=3

	N OFFSET S OFFSET=45

	D SET^IBCNSP(START+1,OFFSET,"   City/State: "_$E($P(IBCNS11,"^",4),1,15)_$S($P(IBCNS11,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS11,"^",5),0)),"^",2)_" "_$E($P(IBCNS11,"^",6),1,5))

	D SET^IBCNSP(START+2,OFFSET,"        Phone: "_$P(IBCNS13,"^",1))

	D SET^IBCNSP(START+3,OFFSET,"          Fax: "_$P(IBCNS11,"^",9))

REMARKS	;

	N OFFSET,START,IBCNS0

	S START=53,OFFSET=2

	D SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF)

	S (IBLCNT,IBI)=0 F  S IBI=$O(^DIC(36,+IBCNS,11,IBI)) Q:IBI<1  D

	.S IBLCNT=IBLCNT+1

	.D SET^IBCNSP(START+IBLCNT,OFFSET,"  "_$E($G(^DIC(36,+IBCNS,11,IBI,0)),1,80))

	;. S VALMCNT=VALMCNT+1

	;S IBCNS0=$G(^DIC(36,+IBCNS,0))

	;D SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF)

	;D SET^IBCNSP(START+1,OFFSET,"  "_$P(IBCNS0,"^",12))

SYN	;

	N OFFSET,START,IBSN,SYN

	S START=57+$G(IBLCNT),OFFSET=2

	;F I=START:1:START+8 D BLANK^IBCNSC(.I)

	D SET^IBCNSP(START,OFFSET," Synonyms ",IORVON,IORVOFF)

	S SYN="" F I=1:1:8 S SYN=$O(^DIC(36,+IBCNS,10,"B",SYN)) Q:SYN=""  D SET^IBCNSP(START+I,OFFSET,$S(I>7:"  ...edit to see more...",1:"  "_SYN)) S IBLCNT=IBLCNT+1

	;S IBSN=0 F I=1:1:8 S IBSN=+$O(^DIC(36,+IBCNS,10,IBSN)) Q:'IBSN  S SYN=^DIC(36,+IBCNS,10,IBSN,0) D SET^IBCNSP(START+I,OFFSET,$S(I>7:"  ...edit to see more...",1:"  "_SYN))

IBCNSC01  ;ALB/NLR - INSURANCE COMPANY EDIT -  ; 21-OCT-1993

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

PARAM     ; -- Insurance company parameters region

 +1        NEW OFFSET,START,IBCNS0,IBCNS03,IBCNS06,IBCNS08,IBCNS13

 +2        SET IBCNS0=$GET(^DIC(36,+IBCNS,0))

 +3        SET IBCNS03=$PIECE(IBCNS0,"^",3)

           SET IBCNS06=$PIECE(IBCNS0,"^",6)

           SET IBCNS08=$PIECE(IBCNS0,"^",8)

 +4        SET IBCNS13=$GET(^DIC(36,+IBCNS,.13))

 +5        SET START=1

           SET OFFSET=2

 +6        DO SET^IBCNSP(START,OFFSET+25," Billing Parameters ",IORVON,IORVOFF)

 +7        DO SET^IBCNSP(START+1,OFFSET," Signature Required?: "_$SELECT(+IBCNS03:"YES",1:"NO"))

 +8        DO SET^IBCNSP(START+2,OFFSET,"          Reimburse?: "_$EXTRACT($$EXPAND^IBTRE(36,1,$PIECE(IBCNS0,"^",2)),1,21))

 +9        DO SET^IBCNSP(START+3,OFFSET,"   Mult. Bedsections: "_$SELECT(+IBCNS06:"YES",1:"NO"))

 +10       DO SET^IBCNSP(START+4,OFFSET,"    Diff. Rev. Codes: "_$PIECE(IBCNS0,"^",7))

 +11       DO SET^IBCNSP(START+5,OFFSET,"      One Opt. Visit: "_$SELECT(+IBCNS08:"YES",1:"NO"))

 +12       DO SET^IBCNSP(START+6,OFFSET," Amb. Sur. Rev. Code: "_$PIECE(IBCNS0,"^",9))

 +13       DO SET^IBCNSP(START+7,OFFSET," Rx Refill Rev. Code: "_$PIECE(IBCNS0,"^",15))

 +14       DO SET^IBCNSP(START+8,OFFSET,"   Filing Time Frame: "_$PIECE(IBCNS0,"^",12))

 +15       NEW START,OFFSET

 +16       SET START=2

           SET OFFSET=45

 +17       DO SET^IBCNSP(START,OFFSET,"  Attending Phys. ID: "_$EXTRACT($PIECE(IBCNS0,"^",10),1,22))

 +18       DO SET^IBCNSP(START+1,OFFSET,"  Hosp. Provider No.: "_$EXTRACT($PIECE(IBCNS0,"^",11),1,15))

 +19       DO SET^IBCNSP(START+2,OFFSET,"   Primary Form Type: "_$$EXPAND^IBTRE(36,.14,$PIECE(IBCNS0,"^",14)))

 +20       DO SET^IBCNSP(START+3,OFFSET+7,"Billing Phone: "_$PIECE(IBCNS13,"^",2))

 +21       DO SET^IBCNSP(START+4,OFFSET+2,"Verification Phone: "_$PIECE(IBCNS13,"^",4))

 +22       DO SET^IBCNSP(START+5,OFFSET+2,"Precert Comp. Name: "_$PIECE($GET(^DIC(36,+$PIECE(IBCNS13,"^",9),0)),"^",1))

 +23       DO SET^IBCNSP(START+6,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))

 +24       QUIT

 +25      ;

PHONE(IBCNS13) ; -- Compute precert company phone

 +1        NEW IBX,IBSAVE,IBCNT

           SET IBX=""

 +2        IF '$PIECE(IBCNS13,"^",9)

               SET IBX=$PIECE(IBCNS13,"^",3)

               GOTO PHONEQ

REDOX      SET IBSAVE=+$PIECE(IBCNS13,"^",9)

 +1        SET IBCNT=$GET(IBCNT)+1

 +2       ; -- if you process the same co. more than once you are in an infinite loop

 +3        IF $DATA(IBCNT(IBCNS))

               GOTO PHONEQ

 +4        SET IBCNT(IBCNS)=""

 +5        SET IBCNS13=$GET(^DIC(36,+$PIECE(IBCNS13,"^",9),.13))

 +6        SET IBX=$PIECE(IBCNS13,"^")

           IF $LENGTH($PIECE(IBCNS13,"^",3))

               SET IBX=$PIECE(IBCNS13,"^",3)

 +7       ; -- if process the same co. more than once you are in an infinite loop

 +8        IF $PIECE(IBCNS13,"^",9)

               IF $PIECE(IBCNS13,"^",9)'=IBSAVE

                   GOTO REDOX

PHONEQ     QUIT IBX

 +1       ;

MAIN      ; -- Insurance company main address

 +1        NEW OFFSET,START,IBCNS11,IBADD

 +2        SET IBCNS11=$GET(^DIC(36,+IBCNS,.11))

 +3        SET IBCNS13=$GET(^DIC(36,+IBCNS,.13))

 +4        SET START=14

           SET OFFSET=25

 +5        DO SET^IBCNSP(START,OFFSET," Main Mailing Address ",IORVON,IORVOFF)

 +6        NEW OFFSET

           SET OFFSET=2

 +7        DO SET^IBCNSP(START+1,OFFSET,"       Street: "_$PIECE(IBCNS11,"^",1))

           SET IBADD=1

 +8        DO SET^IBCNSP(START+2,OFFSET,"     Street 2: "_$PIECE(IBCNS11,"^",2))

           SET IBADD=2

 +9        DO SET^IBCNSP(START+3,OFFSET,"     Street 3: "_$PIECE(IBCNS11,"^",3))

           SET IBADD=3

 +10       NEW OFFSET

           SET OFFSET=45

 +11       DO SET^IBCNSP(START+1,OFFSET,"   City/State: "_$EXTRACT($PIECE(IBCNS11,"^",4),1,15)_$SELECT($PIECE(IBCNS11,"^",4)="":"",1:", ")_$PIECE($GET(^DIC(5,+$PIECE(IBCNS11,"^",5),0)),"^",2)_" "_$EXTRACT($PIECE(IBCNS11,"^",6),1,5))

 +12       DO SET^IBCNSP(START+2,OFFSET,"        Phone: "_$PIECE(IBCNS13,"^",1))

 +13       DO SET^IBCNSP(START+3,OFFSET,"          Fax: "_$PIECE(IBCNS11,"^",9))

 +14       QUIT

 +15      ;

REMARKS   ;

 +1       ;

 +2        NEW OFFSET,START,IBCNS0

 +3        SET START=53

           SET OFFSET=2

 +4       ;

 +5        DO SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF)

 +6        SET (IBLCNT,IBI)=0

FOR

               SET IBI=$ORDER(^DIC(36,+IBCNS,11,IBI))

               IF IBI<1

                   QUIT

               Begin DoDot:1

 +7                SET IBLCNT=IBLCNT+1

 +8                DO SET^IBCNSP(START+IBLCNT,OFFSET,"  "_$EXTRACT($GET(^DIC(36,+IBCNS,11,IBI,0)),1,80))

               End DoDot:1

 +9       ;. S VALMCNT=VALMCNT+1

 +10      ;

 +11      ;S IBCNS0=$G(^DIC(36,+IBCNS,0))

 +12      ;D SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF)

 +13      ;D SET^IBCNSP(START+1,OFFSET,"  "_$P(IBCNS0,"^",12))

 +14       QUIT

 +15      ;

SYN       ;

 +1        NEW OFFSET,START,IBSN,SYN

 +2        SET START=57+$GET(IBLCNT)

           SET OFFSET=2

 +3       ;F I=START:1:START+8 D BLANK^IBCNSC(.I)

 +4        DO SET^IBCNSP(START,OFFSET," Synonyms ",IORVON,IORVOFF)

 +5        SET SYN=""

           FOR I=1:1:8

               SET SYN=$ORDER(^DIC(36,+IBCNS,10,"B",SYN))

               IF SYN=""

                   QUIT

               DO SET^IBCNSP(START+I,OFFSET,$SELECT(I>7:"  ...edit to see more...",1:"  "_SYN))

               SET IBLCNT=IBLCNT+1

 +6       ;S IBSN=0 F I=1:1:8 S IBSN=+$O(^DIC(36,+IBCNS,10,IBSN)) Q:'IBSN  S SYN=^DIC(36,+IBCNS,10,IBSN,0) D SET^IBCNSP(START+I,OFFSET,$S(I>7:"  ...edit to see more...",1:"  "_SYN))

 +7        QUIT

IBCNSC01.m