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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC2 1407 printed Dec 13, 2024@02:20:10 Page 2
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
