IVM2101C ;ALB/CKN,GTS - FILED BY IVM FLAG CLEANUP ; 2/17/05 4:52pm
;;2.0;INCOME VERIFICATION MATCH;**101**; 21-OCT-94;Build 5
Q
TEST ; Test Mode
S MODE=0
;
EP ;
N TXT
;Create bulletin message in install file.
;Quit if initial check fails.
Q:$$CHECK()
;Queue task
D QUETASK
Q
NMSPC() ;
Q "IVM*2*101"
;
CHECK() ;Initial Checking
; Output : 0 - Conversion not running or completed
; 1 - Task is running or completed
;
N DONE,STAT,TASKNUM,NAMESPC
S DONE=0
S NAMESPC=$$NMSPC()
I '$D(^XTMP(NAMESPC)) Q DONE
I $G(^XTMP(NAMESPC,"CONFIG","COMPLETED"))=1 D Q DONE
. D DONEMSG
. S DONE=1
S TASKNUM=$G(^XTMP(NAMESPC,"CONFIG","TASK"))
I TASKNUM'="" D
. S STAT=$$ACTIVE(TASKNUM)
. I STAT>0 D RUNMSG S DONE=1
Q DONE
ACTIVE(TASK) ;Checks if task is running or not
; input -- The taskman ID
; output -- 1=The task is running
; 0=The task is not running
;
N ZTSK,STAT,Y
S STAT=0,ZTSK=+TASK
D STAT^%ZTLOAD
S Y=ZTSK(1)
I Y=0 S STAT=-1
I ",1,2,"[(","_Y_",") S STAT=1
I ",3,5,"[(","_Y_",") S STAT=0
Q STAT
;
QUETASK ;Queue the Task
N TXT,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,NAMESPC
S NAMESPC=$$NMSPC()
S ZTRTN="EP1^IVM2101C",ZTIO="",ZTDTH=$$NOW^XLFDT()
S ZTDESC=NAMESPC_" - FILED BY IVM FLAG CLEANUP"
; Create XTMP array
S X1=DT,X2=120 D C^%DTC
S ^XTMP(NAMESPC,0)=X_"^"_$$DT^XLFDT_"^"_NAMESPC_" FIX FILED BY IVM ERROR"
D ^%ZTLOAD S ^XTMP(NAMESPC,"CONFIG","TASK")=ZTSK
S TXT(1)="Task: "_ZTSK_" Queued."
D BMES^XPDUTL(.TXT)
Q
EP1 ;Entry Point
N XIEN,XIYR,EIEN,XRELIEN,XDGMT,AMTIEN,SOURCE,FIVM,NAMESPC
N X,X1,X2,TOT,CNT,ZTSTOP
S ZTSTOP=0
S NAMESPC=$$NMSPC()
S XIEN=+$G(^XTMP(NAMESPC,"CONFIG","CURRENT IEN"))
; Update XTMP array 0 node purge date.
S X1=DT,X2=120 D C^%DTC
S ^XTMP(NAMESPC,0)=X_"^"_$$DT^XLFDT_"^"_NAMESPC_" FIX FILED BY IVM ERROR"
;Store start date
I '$D(^XTMP(NAMESPC,"CONFIG","START DATE")) S ^XTMP(NAMESPC,"CONFIG","START DATE")=$$FMTE^XLFDT($$NOW^XLFDT(),"5P")
S TOT=+$G(^XTMP(NAMESPC,"CONFIG","TOTAL PROCESSED"))
S CNT=+$G(^XTMP(NAMESPC,"CONFIG","TOTAL FOUND"))
;Loop through 408.12 file - get Veteran IEN
F S XIEN=$O(^DGPR(408.12,"B",XIEN)) Q:+XIEN=0!(ZTSTOP) D
. S TOT=TOT+1 ;Processed records counter
. S ^XTMP(NAMESPC,"CONFIG","TOTAL PROCESSED")=TOT
. S ^XTMP(NAMESPC,"CONFIG","CURRENT IEN")=XIEN
. I (TOT#1000=0),$$S^%ZTLOAD S ZTSTOP=1 ;Check for stop request
. S XRELIEN=0
. ;Get 408.12 iens for each Veteran
. F S XRELIEN=$O(^DGPR(408.12,"B",XIEN,XRELIEN)) Q:XRELIEN="" D
. . S EIEN=0
. . F S EIEN=$O(^DGPR(408.12,XRELIEN,"E",EIEN)) Q:EIEN="" D
. . . ;Get Filed By IVM flag
. . . S FIVM=$P($G(^DGPR(408.12,XRELIEN,"E",EIEN,0)),"^",3)
. . . I FIVM="" Q ;Quit if flag is not set
. . . ; Get Annual Means test ien for FILED BY IVM flag
. . . S AMTIEN=$P($G(^DGPR(408.12,XRELIEN,"E",EIEN,0)),"^",4)
. . . Q:AMTIEN="" ;Quit if Annual MT IEN is not set.
. . . S XIYR=$P($G(^DGMT(408.31,AMTIEN,0)),"^") ;Income Year
. . . I XIYR<3040000 Q ;Quit if income year is less than 2004
. . . ;Get source of MT
. . . S SOURCE=$P($G(^DGMT(408.31,AMTIEN,0)),"^",23)
. . . ;If SOURCE OF INCOME TEST is VAMC or OTHER FACILITY
. . . I (FIVM=1),((SOURCE=1)!(SOURCE=4)) D
. . . . S SOURCE=SOURCE_"^"_$P($G(^DG(408.34,SOURCE,0)),"^",1)
. . . . S CNT=CNT+1,^XTMP(NAMESPC,"CONFIG","TOTAL FOUND")=CNT
. . . . S ^XTMP(NAMESPC,CNT,"PATIENT IEN")=XIEN
. . . . S ^XTMP(NAMESPC,CNT,"ANNUAL MT IEN")=AMTIEN
. . . . S ^XTMP(NAMESPC,CNT,"PATIENT RELATION IEN")=XRELIEN
. . . . S ^XTMP(NAMESPC,CNT,"SOURCE OF INCOME TEST")=SOURCE
. . . . S ^XTMP(NAMESPC,CNT,"PREVIOUS FILED BY IVM")=FIVM_"^YES"
. . . . ;Reset FILED BY IVM field to NULL
. . . . S $P(^DGPR(408.12,XRELIEN,"E",EIEN,0),"^",3)=""
S ^XTMP(NAMESPC,"CONFIG","STOP DATE")=$$FMTE^XLFDT($$NOW^XLFDT(),"5P")
I ZTSTOP D Q
. D ABORTMSG
S ^XTMP(NAMESPC,"CONFIG","COMPLETED")=1
D COMPMSG
Q
;
DONEMSG ;Send message that process is already Completed.
N MSG,XMDUZ,XMSUB,XMTEXT,XMY
S XMSUB=NAMESPC_" - FILED BY IVM FLAG CLEANUP already completed"
S XMDUZ=NAMESPC_" INSTALLATION PROCESS"
S (XMY(.5),XMY(DUZ))="",XMTEXT="MSG("
S MSG(1)="FILED BY IVM FLAG CLEANUP process was completed in previous run."
D ^XMD
D BMES^XPDUTL(.MSG)
Q
RUNMSG ;Send message that process is currently running.
N NAMESPC,MSG,XMDUZ,XMSUB,XMTEXT,XMY
S NAMESPC=$$NMSPC()
S XMSUB=NAMESPC_" - FILED BY IVM FLAG CLEANUP running"
S XMDUZ=NAMESPC_" INSTALLATION PROCESS"
S (XMY(.5),XMY(DUZ))="",XMTEXT="MSG("
S MSG(1)="TASK: "_TASKNUM_" is currently running FILED BY IVM FLAG CLEANUP"
S MSG(2)="process. Duplicate process cannot be started."
D ^XMD
D BMES^XPDUTL(.MSG)
Q
ABORTMSG ;Send message for stop request.
N MSG,XMDUX,XMSUB,XMTEXT,XMY
S XMSUB=NAMESPC_" - FILED BY IVM FLAG CLEANUP stopped"
S XMDUZ=NAMESPC_" INSTALLATION PROCESS"
S (XMY(.5),XMY(DUZ))="",XMTEXT="MSG("
S MSG(1)="TASK: "_$G(^XTMP(NAMESPC,"CONFIG","TASK"))_" FILED BY IVM FLAG CLEANUP"
S MSG(2)=""
S MSG(3)="FILED BY IVM error cleanup process was requested to stop"
S MSG(4)="by the user. Please restart the process by using the following"
S MSG(5)="command at the programmer prompt:"
S MSG(6)="D EP^IVM2101C"
D ^XMD
Q
COMPMSG ;Send message for completed Task.
N MSG,XMDUX,XMSUB,XMTEXT,XMY
S XMSUB=NAMESPC_" - FILED BY IVM FLAG CLEANUP completed"
S XMDUZ=NAMESPC_" INSTALLATION PROCESS"
S (XMY(.5),XMY(DUZ))="",XMTEXT="MSG("
S MSG(1)="TASK: "_$G(^XTMP(NAMESPC,"CONFIG","TASK"))_" FILED BY IVM FLAG CLEANUP"
S MSG(2)=""
S MSG(3)="FILED BY IVM error cleanup process has completed. Review the"
S MSG(4)="following ^XTMP global for details on the Patient Relation file (408.12)"
S MSG(5)="records converted: ^XTMP("""_NAMESPC_""","
S MSG(6)=""
S MSG(7)="This global will be deleted in no more than 120 days from the date"
S MSG(8)="of this message."
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVM2101C 5951 printed Dec 13, 2024@02:00:46 Page 2
IVM2101C ;ALB/CKN,GTS - FILED BY IVM FLAG CLEANUP ; 2/17/05 4:52pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**101**; 21-OCT-94;Build 5
+2 QUIT
TEST ; Test Mode
+1 SET MODE=0
+2 ;
EP ;
+1 NEW TXT
+2 ;Create bulletin message in install file.
+3 ;Quit if initial check fails.
+4 if $$CHECK()
QUIT
+5 ;Queue task
+6 DO QUETASK
+7 QUIT
NMSPC() ;
+1 QUIT "IVM*2*101"
+2 ;
CHECK() ;Initial Checking
+1 ; Output : 0 - Conversion not running or completed
+2 ; 1 - Task is running or completed
+3 ;
+4 NEW DONE,STAT,TASKNUM,NAMESPC
+5 SET DONE=0
+6 SET NAMESPC=$$NMSPC()
+7 IF '$DATA(^XTMP(NAMESPC))
QUIT DONE
+8 IF $GET(^XTMP(NAMESPC,"CONFIG","COMPLETED"))=1
Begin DoDot:1
+9 DO DONEMSG
+10 SET DONE=1
End DoDot:1
QUIT DONE
+11 SET TASKNUM=$GET(^XTMP(NAMESPC,"CONFIG","TASK"))
+12 IF TASKNUM'=""
Begin DoDot:1
+13 SET STAT=$$ACTIVE(TASKNUM)
+14 IF STAT>0
DO RUNMSG
SET DONE=1
End DoDot:1
+15 QUIT DONE
ACTIVE(TASK) ;Checks if task is running or not
+1 ; input -- The taskman ID
+2 ; output -- 1=The task is running
+3 ; 0=The task is not running
+4 ;
+5 NEW ZTSK,STAT,Y
+6 SET STAT=0
SET ZTSK=+TASK
+7 DO STAT^%ZTLOAD
+8 SET Y=ZTSK(1)
+9 IF Y=0
SET STAT=-1
+10 IF ",1,2,"[(","_Y_",")
SET STAT=1
+11 IF ",3,5,"[(","_Y_",")
SET STAT=0
+12 QUIT STAT
+13 ;
QUETASK ;Queue the Task
+1 NEW TXT,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,NAMESPC
+2 SET NAMESPC=$$NMSPC()
+3 SET ZTRTN="EP1^IVM2101C"
SET ZTIO=""
SET ZTDTH=$$NOW^XLFDT()
+4 SET ZTDESC=NAMESPC_" - FILED BY IVM FLAG CLEANUP"
+5 ; Create XTMP array
+6 SET X1=DT
SET X2=120
DO C^%DTC
+7 SET ^XTMP(NAMESPC,0)=X_"^"_$$DT^XLFDT_"^"_NAMESPC_" FIX FILED BY IVM ERROR"
+8 DO ^%ZTLOAD
SET ^XTMP(NAMESPC,"CONFIG","TASK")=ZTSK
+9 SET TXT(1)="Task: "_ZTSK_" Queued."
+10 DO BMES^XPDUTL(.TXT)
+11 QUIT
EP1 ;Entry Point
+1 NEW XIEN,XIYR,EIEN,XRELIEN,XDGMT,AMTIEN,SOURCE,FIVM,NAMESPC
+2 NEW X,X1,X2,TOT,CNT,ZTSTOP
+3 SET ZTSTOP=0
+4 SET NAMESPC=$$NMSPC()
+5 SET XIEN=+$GET(^XTMP(NAMESPC,"CONFIG","CURRENT IEN"))
+6 ; Update XTMP array 0 node purge date.
+7 SET X1=DT
SET X2=120
DO C^%DTC
+8 SET ^XTMP(NAMESPC,0)=X_"^"_$$DT^XLFDT_"^"_NAMESPC_" FIX FILED BY IVM ERROR"
+9 ;Store start date
+10 IF '$DATA(^XTMP(NAMESPC,"CONFIG","START DATE"))
SET ^XTMP(NAMESPC,"CONFIG","START DATE")=$$FMTE^XLFDT($$NOW^XLFDT(),"5P")
+11 SET TOT=+$GET(^XTMP(NAMESPC,"CONFIG","TOTAL PROCESSED"))
+12 SET CNT=+$GET(^XTMP(NAMESPC,"CONFIG","TOTAL FOUND"))
+13 ;Loop through 408.12 file - get Veteran IEN
+14 FOR
SET XIEN=$ORDER(^DGPR(408.12,"B",XIEN))
if +XIEN=0!(ZTSTOP)
QUIT
Begin DoDot:1
+15 ;Processed records counter
SET TOT=TOT+1
+16 SET ^XTMP(NAMESPC,"CONFIG","TOTAL PROCESSED")=TOT
+17 SET ^XTMP(NAMESPC,"CONFIG","CURRENT IEN")=XIEN
+18 ;Check for stop request
IF (TOT#1000=0)
IF $$S^%ZTLOAD
SET ZTSTOP=1
+19 SET XRELIEN=0
+20 ;Get 408.12 iens for each Veteran
+21 FOR
SET XRELIEN=$ORDER(^DGPR(408.12,"B",XIEN,XRELIEN))
if XRELIEN=""
QUIT
Begin DoDot:2
+22 SET EIEN=0
+23 FOR
SET EIEN=$ORDER(^DGPR(408.12,XRELIEN,"E",EIEN))
if EIEN=""
QUIT
Begin DoDot:3
+24 ;Get Filed By IVM flag
+25 SET FIVM=$PIECE($GET(^DGPR(408.12,XRELIEN,"E",EIEN,0)),"^",3)
+26 ;Quit if flag is not set
IF FIVM=""
QUIT
+27 ; Get Annual Means test ien for FILED BY IVM flag
+28 SET AMTIEN=$PIECE($GET(^DGPR(408.12,XRELIEN,"E",EIEN,0)),"^",4)
+29 ;Quit if Annual MT IEN is not set.
if AMTIEN=""
QUIT
+30 ;Income Year
SET XIYR=$PIECE($GET(^DGMT(408.31,AMTIEN,0)),"^")
+31 ;Quit if income year is less than 2004
IF XIYR<3040000
QUIT
+32 ;Get source of MT
+33 SET SOURCE=$PIECE($GET(^DGMT(408.31,AMTIEN,0)),"^",23)
+34 ;If SOURCE OF INCOME TEST is VAMC or OTHER FACILITY
+35 IF (FIVM=1)
IF ((SOURCE=1)!(SOURCE=4))
Begin DoDot:4
+36 SET SOURCE=SOURCE_"^"_$PIECE($GET(^DG(408.34,SOURCE,0)),"^",1)
+37 SET CNT=CNT+1
SET ^XTMP(NAMESPC,"CONFIG","TOTAL FOUND")=CNT
+38 SET ^XTMP(NAMESPC,CNT,"PATIENT IEN")=XIEN
+39 SET ^XTMP(NAMESPC,CNT,"ANNUAL MT IEN")=AMTIEN
+40 SET ^XTMP(NAMESPC,CNT,"PATIENT RELATION IEN")=XRELIEN
+41 SET ^XTMP(NAMESPC,CNT,"SOURCE OF INCOME TEST")=SOURCE
+42 SET ^XTMP(NAMESPC,CNT,"PREVIOUS FILED BY IVM")=FIVM_"^YES"
+43 ;Reset FILED BY IVM field to NULL
+44 SET $PIECE(^DGPR(408.12,XRELIEN,"E",EIEN,0),"^",3)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+45 SET ^XTMP(NAMESPC,"CONFIG","STOP DATE")=$$FMTE^XLFDT($$NOW^XLFDT(),"5P")
+46 IF ZTSTOP
Begin DoDot:1
+47 DO ABORTMSG
End DoDot:1
QUIT
+48 SET ^XTMP(NAMESPC,"CONFIG","COMPLETED")=1
+49 DO COMPMSG
+50 QUIT
+51 ;
DONEMSG ;Send message that process is already Completed.
+1 NEW MSG,XMDUZ,XMSUB,XMTEXT,XMY
+2 SET XMSUB=NAMESPC_" - FILED BY IVM FLAG CLEANUP already completed"
+3 SET XMDUZ=NAMESPC_" INSTALLATION PROCESS"
+4 SET (XMY(.5),XMY(DUZ))=""
SET XMTEXT="MSG("
+5 SET MSG(1)="FILED BY IVM FLAG CLEANUP process was completed in previous run."
+6 DO ^XMD
+7 DO BMES^XPDUTL(.MSG)
+8 QUIT
RUNMSG ;Send message that process is currently running.
+1 NEW NAMESPC,MSG,XMDUZ,XMSUB,XMTEXT,XMY
+2 SET NAMESPC=$$NMSPC()
+3 SET XMSUB=NAMESPC_" - FILED BY IVM FLAG CLEANUP running"
+4 SET XMDUZ=NAMESPC_" INSTALLATION PROCESS"
+5 SET (XMY(.5),XMY(DUZ))=""
SET XMTEXT="MSG("
+6 SET MSG(1)="TASK: "_TASKNUM_" is currently running FILED BY IVM FLAG CLEANUP"
+7 SET MSG(2)="process. Duplicate process cannot be started."
+8 DO ^XMD
+9 DO BMES^XPDUTL(.MSG)
+10 QUIT
ABORTMSG ;Send message for stop request.
+1 NEW MSG,XMDUX,XMSUB,XMTEXT,XMY
+2 SET XMSUB=NAMESPC_" - FILED BY IVM FLAG CLEANUP stopped"
+3 SET XMDUZ=NAMESPC_" INSTALLATION PROCESS"
+4 SET (XMY(.5),XMY(DUZ))=""
SET XMTEXT="MSG("
+5 SET MSG(1)="TASK: "_$GET(^XTMP(NAMESPC,"CONFIG","TASK"))_" FILED BY IVM FLAG CLEANUP"
+6 SET MSG(2)=""
+7 SET MSG(3)="FILED BY IVM error cleanup process was requested to stop"
+8 SET MSG(4)="by the user. Please restart the process by using the following"
+9 SET MSG(5)="command at the programmer prompt:"
+10 SET MSG(6)="D EP^IVM2101C"
+11 DO ^XMD
+12 QUIT
COMPMSG ;Send message for completed Task.
+1 NEW MSG,XMDUX,XMSUB,XMTEXT,XMY
+2 SET XMSUB=NAMESPC_" - FILED BY IVM FLAG CLEANUP completed"
+3 SET XMDUZ=NAMESPC_" INSTALLATION PROCESS"
+4 SET (XMY(.5),XMY(DUZ))=""
SET XMTEXT="MSG("
+5 SET MSG(1)="TASK: "_$GET(^XTMP(NAMESPC,"CONFIG","TASK"))_" FILED BY IVM FLAG CLEANUP"
+6 SET MSG(2)=""
+7 SET MSG(3)="FILED BY IVM error cleanup process has completed. Review the"
+8 SET MSG(4)="following ^XTMP global for details on the Patient Relation file (408.12)"
+9 SET MSG(5)="records converted: ^XTMP("""_NAMESPC_""","
+10 SET MSG(6)=""
+11 SET MSG(7)="This global will be deleted in no more than 120 days from the date"
+12 SET MSG(8)="of this message."
+13 DO ^XMD
+14 QUIT
