IVMLDEM8 ;ALB/SEK - IVM DEMOGRAPHIC DELETE FIELDS (CON'T) ; 04-APR-96
;;2.0;INCOME VERIFICATION MATCH;**5,10**; 21-OCT-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; - called by IVMLDEM4 for non-uploadable demographic fields
;
; list manager returned entry # of field to be deleted (fifth
; subscript of tmp global - ivment4)
; since primary eligibility code could have >1 entry
; and line # will not be the same as entry #
; must get line # (fourth subscript of tmp global - ivmlinen)
;
DF N IVMAR,IVMARC,IVMEND,IVMEGC,IVMLINEN
S (IVMEND,IVMEGC,IVMLINEN)=0
F S IVMLINEN=$O(^TMP(IVMARRAY,$J,"IDX",IVMLINEN)) Q:'IVMLINEN D Q:IVMEND
.S IVMINDEX=$G(^TMP(IVMARRAY,$J,"IDX",IVMLINEN,IVMENT4)) Q:IVMINDEX']""
.I $P(IVMINDEX,"^",7)'=.361 S IVMEND=1 Q ; not primary elig code
.S IVMEGC=IVMEGC+1,IVMAR(IVMEGC)=IVMINDEX
;
; - primary eligibility code field
I IVMEGC D Q
.S $P(IVMINDEX,"^",8)="PRIMARY ELIGIBILITY CODE"
.D SURE Q:IVMOUT!('IVMSURE)
.F IVMARC=1:1:IVMEGC S IVMINDEX=IVMAR(IVMARC) D
..D DEL
.W "completed."
;
; - check to see if selection is an address field
S IVMADDR=$$ADDR^IVMLDEM7(+IVMINDEX,$P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4),IVMPPICK)
Q:IVMADDR
;
; - not address or primary eligibility code field
;
D SURE Q:IVMOUT!('IVMSURE)
D DEL
W "completed."
Q
;
SURE ; - ask user if they are sure they want to delete field
D RUSURE^IVMLDEMU($P(IVMINDEX,"^",8),"delete") Q:IVMOUT!('IVMSURE)
;
W !,"Deleting "_$P(IVMINDEX,"^",8)_" field from the list... "
Q
;
DEL ;- remove entry from file (#301.5)
D DELENT^IVMLDEMU($P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMLDEM8 1728 printed Dec 13, 2024@02:01:49 Page 2
IVMLDEM8 ;ALB/SEK - IVM DEMOGRAPHIC DELETE FIELDS (CON'T) ; 04-APR-96
+1 ;;2.0;INCOME VERIFICATION MATCH;**5,10**; 21-OCT-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; - called by IVMLDEM4 for non-uploadable demographic fields
+5 ;
+6 ; list manager returned entry # of field to be deleted (fifth
+7 ; subscript of tmp global - ivment4)
+8 ; since primary eligibility code could have >1 entry
+9 ; and line # will not be the same as entry #
+10 ; must get line # (fourth subscript of tmp global - ivmlinen)
+11 ;
DF NEW IVMAR,IVMARC,IVMEND,IVMEGC,IVMLINEN
+1 SET (IVMEND,IVMEGC,IVMLINEN)=0
+2 FOR
SET IVMLINEN=$ORDER(^TMP(IVMARRAY,$JOB,"IDX",IVMLINEN))
if 'IVMLINEN
QUIT
Begin DoDot:1
+3 SET IVMINDEX=$GET(^TMP(IVMARRAY,$JOB,"IDX",IVMLINEN,IVMENT4))
if IVMINDEX']""
QUIT
+4 ; not primary elig code
IF $PIECE(IVMINDEX,"^",7)'=.361
SET IVMEND=1
QUIT
+5 SET IVMEGC=IVMEGC+1
SET IVMAR(IVMEGC)=IVMINDEX
End DoDot:1
if IVMEND
QUIT
+6 ;
+7 ; - primary eligibility code field
+8 IF IVMEGC
Begin DoDot:1
+9 SET $PIECE(IVMINDEX,"^",8)="PRIMARY ELIGIBILITY CODE"
+10 DO SURE
if IVMOUT!('IVMSURE)
QUIT
+11 FOR IVMARC=1:1:IVMEGC
SET IVMINDEX=IVMAR(IVMARC)
Begin DoDot:2
+12 DO DEL
End DoDot:2
+13 WRITE "completed."
End DoDot:1
QUIT
+14 ;
+15 ; - check to see if selection is an address field
+16 SET IVMADDR=$$ADDR^IVMLDEM7(+IVMINDEX,$PIECE(IVMINDEX,"^",2),$PIECE(IVMINDEX,"^",3),$PIECE(IVMINDEX,"^",4),IVMPPICK)
+17 if IVMADDR
QUIT
+18 ;
+19 ; - not address or primary eligibility code field
+20 ;
+21 DO SURE
if IVMOUT!('IVMSURE)
QUIT
+22 DO DEL
+23 WRITE "completed."
+24 QUIT
+25 ;
SURE ; - ask user if they are sure they want to delete field
+1 DO RUSURE^IVMLDEMU($PIECE(IVMINDEX,"^",8),"delete")
if IVMOUT!('IVMSURE)
QUIT
+2 ;
+3 WRITE !,"Deleting "_$PIECE(IVMINDEX,"^",8)_" field from the list... "
+4 QUIT
+5 ;
DEL ;- remove entry from file (#301.5)
+1 DO DELENT^IVMLDEMU($PIECE(IVMINDEX,"^",2),$PIECE(IVMINDEX,"^",3),$PIECE(IVMINDEX,"^",4))
+2 QUIT
