source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM3.m@ 1397

IVMLDEM3 ;ALB/KCL - IVM DEMOGRAPHIC NON-UPLOADABLE FIELDS ; 15-APR-94
 ;;Version 2.0 ; INCOME VERIFICATION MATCH ;**5**; 21-OCT-94
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;
EN ; - main entry point for IVM DEMOGRAPHIC NON-UPLOADABLE
 D EN^VALM("IVM DEMOGRAPHIC NON-UPLOADABLE")
 Q
 ;
 ;
HDR ; - header code for list manager display
 S IVMBLNK="",$P(IVMBLNK," ",45)=""
 ;
 ; - header line 1
 S VALMHDR(1)="Patient: "_$E($E($P(^DPT(DFN,0),"^"),1,20)_" "_"("_$E($P(^DPT(DFN,0),"^",9),6,9)_")"_IVMBLNK,1,35)_" "_"Non-uploadable Demographic Fields"
 ;
 ; - header line 2
 S VALMHDR(2)=" "
 Q
 ;
 ;
INIT ; - init variables and list array
 ;
 ;  Input:  IVMDA2  --  Pointer to case record in file #301.5
 ;          IVMDA1  --  Pointer to PID msg in sub-file #301.501
 ;             DFN  --  Pointer to patient in file #2
 ;
 ;
 ; - flag used for delete demographic field action (DF)
 S IVMWHERE="NON"
 S IVMSTAT2=""
 K ^TMP("IVMNONUP",$J)
 S IVMBL="",$P(IVMBL," ",58)="",IVMCNTR=0,IVM27=0
 D DEM^VADPT,ADD^VADPT S IVMSTATE=$P(VAPA(5),"^")
 F IVMDA=0:0 S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA)) Q:'IVMDA  D
 .;
 .; - grab node with IVM-supplied data
 .S IVMDEMO=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)) I IVMDEMO="" Q
 .;
 .; - quit if data element is uploadable
 .S IVMTABLE=$G(^IVM(301.92,+$P(IVMDEMO,"^"),0))
 .Q:$P(IVMTABLE,"^",3)=1
 .;
 .; - if ivm state data then set IVMSTAT2 for decoding county code
 .I $P(IVMTABLE,"^")["STATE" S IVMSTAT2=$P(IVMDEMO,"^",2)
 .;
 .S IVMCNTR=IVMCNTR+1
 .;
 .; - primary eligibility code
 .S:$P(IVMDEMO,"^")=27 IVM27=IVM27+1
 .;
 .; - extract DHCP value in displayable format
 .S IVMDHCP="" X:$D(^IVM(301.92,$P(IVMDEMO,"^"),2)) ^(2) S IVMDHCP=Y
 .;
 .; - build index record to use for processing as
 .;   ctr is line # and ctr1 is entry #
 .;    ^tmp("ivmnonup",$j,"idx",ctr,ctr1)=dfn^da(2)^da(1)^da^ivm data^pointer to file (#1)^dhcp field number^dhcp field name
 .;
 .S IVMCNTR1=$S(IVM27<2:IVMCNTR,1:IVMCNTR-IVM27+1)
 .S ^TMP("IVMNONUP",$J,"IDX",IVMCNTR,IVMCNTR1)=DFN_"^"_IVMDA2_"^"_IVMDA1_"^"_IVMDA_"^"_$P(IVMDEMO,"^",2)_"^"_$P(IVMTABLE,"^",4)_"^"_$P(IVMTABLE,"^",5)_"^"_$P(IVMTABLE,"^")
 .;
 .; - build list manager display line
 .D WRITLINE($P(IVMTABLE,"^")_"^"_IVMDHCP_"^"_$P(IVMDEMO,"^",2),IVMCNTR)
 ;
 ;
 I '$O(@VALMAR@(0)) D
 .;
 .; - check for uploadable fields, if no fields do DELETE
 .I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D DELETE^IVMLDEM5(IVMDA2,IVMDA1,IVMNAME)
 .;
 .; - if uploadable fields set array field from 'YES' to 'NO' for list manager display
 .I $$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) S $P(^TMP("IVMDUPL",$J,IVMNAME,IVMDA2,IVMDA1),"^",5)="NO"
 .;
 .; - display msg to user that no uploadable data to view
 .D KILL^VALM10(1)
 .D KILL^VALM10(2)
 .S @VALMAR@(1,0)=" "
 .S @VALMAR@(2,0)="There is no non-uploadable demographic information to view."
 .S IVMCNTR=2
 ;
 ; - list manager variable as number of lines in the list
 S VALMCNT=IVMCNTR
 ;
 ;
INITQ ; - clean up variables
 D KVA^VADPT ; kill all variables defined by VADPT routine
 K IVMBL,IVMBLNK,IVMCNTR,IVMCNTR1,IVMDA,IVMDEMO,IVMDHCP,IVMFIELD
 K IVMSTAT2,IVMSTATE,IVMTABLE,IVM27
 Q
 ;
 ;
WRITLINE(IVMLINE,IVMNUM) ; - write line out for list manager display
 ;
 ;  Input:  IVMLINE  --  as the line for display:
 ;                       dhcp field name^dhcp field value^ivm field value
 ;           IVMNUM  --  as the line number
 ; Output:  None
 ;
 N IVMLN,IVMOUT1,IVMOUT2,IVMNUM1
 S IVMOUT1=$P(IVMLINE,"^",2)
 I $P(IVMTABLE,"^",7) S IVMOUT1=$$OUTTR^IVMUFNC(IVMOUT1,IVMTABLE,IVMSTATE)
 S:IVMOUT1="" IVMOUT1="(* NONE ON FILE *)"
 S IVMOUT2=$$OUTTR^IVMUFNC($P(IVMLINE,"^",3),IVMTABLE,IVMSTAT2)
 S IVMLN=$E($P(IVMLINE,"^",1)_IVMBL,1,30)_"  "_$E(IVMOUT1_IVMBL,1,20)_"  "_$E(IVMOUT2_IVMBL,1,20)
 ;
 ; - highlight IVM field value
 D CNTRL^VALM10(IVMNUM,58,22,IOINHI,IOINORM)
 I $P(IVMDEMO,"^")=27,IVM27>1 S @VALMAR@(IVMNUM,0)=IVMBL_$E(IVMOUT2_IVMBL,1,20) Q
 S IVMNUM1=$S(IVM27>1:IVMNUM-IVM27+1,1:IVMNUM)
 S @VALMAR@(IVMNUM,0)=$E(IVMNUM1_"   ",1,3)_IVMLN
 Q
 ;
 ;
HELP ; - help code
 S X="?" D DISP^XQORM1 W !!
 Q
 ;
EXIT ; - exit code
 K ^TMP("IVMNONUP",$J)
 Q