IBCSC2.m

IBCSC2	;ALB/MJB/AAS - MCCR SCREEN 2 (EMPLOYMENT) ;27 MAY 88 10:15

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

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

	;

	;MAP TO DGCRSC2

	;

EN	D ^IBCSCU S IBSR=2,IBSR1="" F I=0,.311,.25 S IB(I)=$S($D(^DPT(DFN,I)):^(I),1:"")

	D H^IBCSCU

	S IBV1="00" I $S('$D(^DIC(11,+$P(^DPT(DFN,0),U,5),0)):1,$P(^(0),U,1)="MARRIED":0,$P(^(0),U,1)="SEPARATED":0,1:1) S IBV1="01"

	S:IBV IBV1="11"

	;

	S IBAD=.311,IBA1=3,IBA2=1 D:$P(IB(.311),"^",1)]"" A^IBCSCU S IBAD=.25,(IBA1,IBA2)=2 D:$P(IB(.25),"^",1)]"" A^IBCSCU

	S Z=1,IBW=1 X IBWW W " Employer: " W $S($P(IB(.311),"^",1)]"":$E($P(IB(.311),"^",1),1,23),1:IBU),?40 S IBW=0,Z=2 X IBWW W " Spouse's: ",$S($P(IB(.25),"^",1)]"":$P(IB(.25),"^",1),1:IBU)

	S I=0 F J=0:0 S I=$O(IBA(I)) Q:'I  S Z=IBA(I) S:(I#2) Z="              "_Z W:(I#2)!($X>50) ! W:(I#2) Z I '(I#2) W ?54,Z

	W:$P(IB(.311),"^",1)]"" !?7,"Phone: ",$S($P(IB(.311),"^",9)]"":$P(IB(.311),"^",9),1:IBU)

	W:$P(IB(.311),"^",1)']"" ! W:$P(IB(.25),"^",1)]"" ?47,"Phone: ",$S($P(IB(.25),"^",8)]"":$P(IB(.25),"^",8),1:IBU) W:$P(IB(.311),"^",1)]"" !?2,"Occupation: ",$S($P(IB(0),"^",7)]"":$P(IB(0),"^",7),1:IBU)

	S X=$P(IB(.311),"^",15),X=$S(X']"":IBU,X=1:"EMPLOYED FULL TIME",X=2:"EMPLOYED PART TIME",X=3:"NOT EMPLOYED",X=4:"SELF EMPLOYED",X=5:"RETIRED",X=6:"ACTIVE MILITARY DUTY",1:IBU) W !?6,"Status: ",X

	;

REV	G ^IBCSCP

	;IBCSC2

IBCSC2    ;ALB/MJB/AAS - MCCR SCREEN 2 (EMPLOYMENT) ;27 MAY 88 10:15

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

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

 +3       ;

 +4       ;MAP TO DGCRSC2

 +5       ;

EN         DO ^IBCSCU

           SET IBSR=2

           SET IBSR1=""

           FOR I=0,.311,.25

               SET IB(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")

 +1        DO H^IBCSCU

 +2        SET IBV1="00"

           IF $SELECT('$DATA(^DIC(11,+$PIECE(^DPT(DFN,0),U,5),0)):1,$PIECE(^(0),U,1)="MARRIED":0,$PIECE(^(0),U,1)="SEPARATED":0,1:1)

               SET IBV1="01"

 +3        IF IBV

               SET IBV1="11"

 +4       ;

 +5        SET IBAD=.311

           SET IBA1=3

           SET IBA2=1

           IF $PIECE(IB(.311),"^",1)]""

               DO A^IBCSCU

           SET IBAD=.25

           SET (IBA1,IBA2)=2

           IF $PIECE(IB(.25),"^",1)]""

               DO A^IBCSCU

 +6        SET Z=1

           SET IBW=1

           XECUTE IBWW

           WRITE " Employer: "

           WRITE $SELECT($PIECE(IB(.311),"^",1)]"":$EXTRACT($PIECE(IB(.311),"^",1),1,23),1:IBU),?40

           SET IBW=0

           SET Z=2

           XECUTE IBWW

           WRITE " Spouse's: ",$SELECT($PIECE(IB(.25),"^",1)]"":$PIECE(IB(.25),"^",1),1:IBU)

 +7        SET I=0

           FOR J=0:0

               SET I=$ORDER(IBA(I))

               IF 'I

                   QUIT 

               SET Z=IBA(I)

               IF (I#2)

                   SET Z="              "_Z

               IF (I#2)!($X>50)

                   WRITE !

               IF (I#2)

                   WRITE Z

               IF '(I#2)

                   WRITE ?54,Z

 +8        IF $PIECE(IB(.311),"^",1)]""

               WRITE !?7,"Phone: ",$SELECT($PIECE(IB(.311),"^",9)]"":$PIECE(IB(.311),"^",9),1:IBU)

 +9        IF $PIECE(IB(.311),"^",1)']""

               WRITE !

           IF $PIECE(IB(.25),"^",1)]""

               WRITE ?47,"Phone: ",$SELECT($PIECE(IB(.25),"^",8)]"":$PIECE(IB(.25),"^",8),1:IBU)

           IF $PIECE(IB(.311),"^",1)]""

               WRITE !?2,"Occupation: ",$SELECT($PIECE(IB(0),"^",7)]"":$PIECE(IB(0),"^",7),1:IBU)

 +10       SET X=$PIECE(IB(.311),"^",15)

           SET X=$SELECT(X']"":IBU,X=1:"EMPLOYED FULL TIME",X=2:"EMPLOYED PART TIME",X=3:"NOT EMPLOYED",X=4:"SELF EMPLOYED",X=5:"RETIRED",X=6:"ACTIVE MILITARY DUTY",1:IBU)

           WRITE !?6,"Status: ",X

 +11      ;

REV        GOTO ^IBCSCP

 +1       ;IBCSC2