IVMLDEM3 ;ALB/KCL,JAM - IVM DEMOGRAPHIC NON-UPLOADABLE FIELDS ;15-APR-94
;;2.0;INCOME VERIFICATION MATCH;**5,193**;21-OCT-94;Build 37
;;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
.; Patch IVM*2.0*193; JAM; If Y is not defined, quit
.S IVMDHCP="" X:$D(^IVM(301.92,$P(IVMDEMO,"^"),2)) ^(2) Q:$G(Y)="" 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMLDEM3 4304 printed Sep 23, 2025@19:37:05 Page 2
IVMLDEM3 ;ALB/KCL,JAM - IVM DEMOGRAPHIC NON-UPLOADABLE FIELDS ;15-APR-94
+1 ;;2.0;INCOME VERIFICATION MATCH;**5,193**;21-OCT-94;Build 37
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
EN ; - main entry point for IVM DEMOGRAPHIC NON-UPLOADABLE
+1 DO EN^VALM("IVM DEMOGRAPHIC NON-UPLOADABLE")
+2 QUIT
+3 ;
+4 ;
HDR ; - header code for list manager display
+1 SET IVMBLNK=""
SET $PIECE(IVMBLNK," ",45)=""
+2 ;
+3 ; - header line 1
+4 SET VALMHDR(1)="Patient: "_$EXTRACT($EXTRACT($PIECE(^DPT(DFN,0),"^"),1,20)_" "_"("_$EXTRACT($PIECE(^DPT(DFN,0),"^",9),6,9)_")"_IVMBLNK,1,35)_" "_"Non-uploadable Demographic Fields"
+5 ;
+6 ; - header line 2
+7 SET VALMHDR(2)=" "
+8 QUIT
+9 ;
+10 ;
INIT ; - init variables and list array
+1 ;
+2 ; Input: IVMDA2 -- Pointer to case record in file #301.5
+3 ; IVMDA1 -- Pointer to PID msg in sub-file #301.501
+4 ; DFN -- Pointer to patient in file #2
+5 ;
+6 ;
+7 ; - flag used for delete demographic field action (DF)
+8 SET IVMWHERE="NON"
+9 SET IVMSTAT2=""
+10 KILL ^TMP("IVMNONUP",$JOB)
+11 SET IVMBL=""
SET $PIECE(IVMBL," ",58)=""
SET IVMCNTR=0
SET IVM27=0
+12 DO DEM^VADPT
DO ADD^VADPT
SET IVMSTATE=$PIECE(VAPA(5),"^")
+13 FOR IVMDA=0:0
SET IVMDA=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA))
if 'IVMDA
QUIT
Begin DoDot:1
+14 ;
+15 ; - grab node with IVM-supplied data
+16 SET IVMDEMO=$GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0))
IF IVMDEMO=""
QUIT
+17 ;
+18 ; - quit if data element is uploadable
+19 SET IVMTABLE=$GET(^IVM(301.92,+$PIECE(IVMDEMO,"^"),0))
+20 if $PIECE(IVMTABLE,"^",3)=1
QUIT
+21 ;
+22 ; - if ivm state data then set IVMSTAT2 for decoding county code
+23 IF $PIECE(IVMTABLE,"^")["STATE"
SET IVMSTAT2=$PIECE(IVMDEMO,"^",2)
+24 ;
+25 SET IVMCNTR=IVMCNTR+1
+26 ;
+27 ; - primary eligibility code
+28 if $PIECE(IVMDEMO,"^")=27
SET IVM27=IVM27+1
+29 ;
+30 ; - extract DHCP value in displayable format
+31 ; Patch IVM*2.0*193; JAM; If Y is not defined, quit
+32 SET IVMDHCP=""
if $DATA(^IVM(301.92,$PIECE(IVMDEMO,"^"),2))
XECUTE ^(2)
if $GET(Y)=""
QUIT
SET IVMDHCP=Y
+33 ;
+34 ; - build index record to use for processing as
+35 ; ctr is line # and ctr1 is entry #
+36 ; ^tmp("ivmnonup",$j,"idx",ctr,ctr1)=dfn^da(2)^da(1)^da^ivm data^pointer to file (#1)^dhcp field number^dhcp field name
+37 ;
+38 SET IVMCNTR1=$SELECT(IVM27<2:IVMCNTR,1:IVMCNTR-IVM27+1)
+39 SET ^TMP("IVMNONUP",$JOB,"IDX",IVMCNTR,IVMCNTR1)=DFN_"^"_IVMDA2_"^"_IVMDA1_"^"_IVMDA_"^"_$PIECE(IVMDEMO,"^",2)_"^"_$PIECE(IVMTABLE,"^",4)_"^"_$PIECE(IVMTABLE,"^",5)_"^"_$PIECE(IVMTABLE,"^")
+40 ;
+41 ; - build list manager display line
+42 DO WRITLINE($PIECE(IVMTABLE,"^")_"^"_IVMDHCP_"^"_$PIECE(IVMDEMO,"^",2),IVMCNTR)
End DoDot:1
+43 ;
+44 ;
+45 IF '$ORDER(@VALMAR@(0))
Begin DoDot:1
+46 ;
+47 ; - check for uploadable fields, if no fields do DELETE
+48 IF '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)
DO DELETE^IVMLDEM5(IVMDA2,IVMDA1,IVMNAME)
+49 ;
+50 ; - if uploadable fields set array field from 'YES' to 'NO' for list manager display
+51 IF $$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)
SET $PIECE(^TMP("IVMDUPL",$JOB,IVMNAME,IVMDA2,IVMDA1),"^",5)="NO"
+52 ;
+53 ; - display msg to user that no uploadable data to view
+54 DO KILL^VALM10(1)
+55 DO KILL^VALM10(2)
+56 SET @VALMAR@(1,0)=" "
+57 SET @VALMAR@(2,0)="There is no non-uploadable demographic information to view."
+58 SET IVMCNTR=2
End DoDot:1
+59 ;
+60 ; - list manager variable as number of lines in the list
+61 SET VALMCNT=IVMCNTR
+62 ;
+63 ;
INITQ ; - clean up variables
+1 ; kill all variables defined by VADPT routine
DO KVA^VADPT
+2 KILL IVMBL,IVMBLNK,IVMCNTR,IVMCNTR1,IVMDA,IVMDEMO,IVMDHCP,IVMFIELD
+3 KILL IVMSTAT2,IVMSTATE,IVMTABLE,IVM27
+4 QUIT
+5 ;
+6 ;
WRITLINE(IVMLINE,IVMNUM) ; - write line out for list manager display
+1 ;
+2 ; Input: IVMLINE -- as the line for display:
+3 ; dhcp field name^dhcp field value^ivm field value
+4 ; IVMNUM -- as the line number
+5 ; Output: None
+6 ;
+7 NEW IVMLN,IVMOUT1,IVMOUT2,IVMNUM1
+8 SET IVMOUT1=$PIECE(IVMLINE,"^",2)
+9 IF $PIECE(IVMTABLE,"^",7)
SET IVMOUT1=$$OUTTR^IVMUFNC(IVMOUT1,IVMTABLE,IVMSTATE)
+10 if IVMOUT1=""
SET IVMOUT1="(* NONE ON FILE *)"
+11 SET IVMOUT2=$$OUTTR^IVMUFNC($PIECE(IVMLINE,"^",3),IVMTABLE,IVMSTAT2)
+12 SET IVMLN=$EXTRACT($PIECE(IVMLINE,"^",1)_IVMBL,1,30)_" "_$EXTRACT(IVMOUT1_IVMBL,1,20)_" "_$EXTRACT(IVMOUT2_IVMBL,1,20)
+13 ;
+14 ; - highlight IVM field value
+15 DO CNTRL^VALM10(IVMNUM,58,22,IOINHI,IOINORM)
+16 IF $PIECE(IVMDEMO,"^")=27
IF IVM27>1
SET @VALMAR@(IVMNUM,0)=IVMBL_$EXTRACT(IVMOUT2_IVMBL,1,20)
QUIT
+17 SET IVMNUM1=$SELECT(IVM27>1:IVMNUM-IVM27+1,1:IVMNUM)
+18 SET @VALMAR@(IVMNUM,0)=$EXTRACT(IVMNUM1_" ",1,3)_IVMLN
+19 QUIT
+20 ;
+21 ;
HELP ; - help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; - exit code
+1 KILL ^TMP("IVMNONUP",$JOB)
+2 QUIT
