Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: WIIACT4

WIIACT4.m

Go to the documentation of this file.
  1. WIIACT4 ;VISN20/WDE/WHN/WII Admission & Discharges or OIE-OEF PTS TO VISN CONTACT
  1. ;;1.0;Wounded Injured and Ill Warriors;**1**;06/12/2008;Build 28
  1. ;-------------------------------------------------------------------------------------------------
  1. ;
  1. ;This routine goes through admissions and discharges based on a date range and collects
  1. ;Patients that have particular eligibilites.
  1. ;When entries are found they are stored in file 987.5 for review at the local site
  1. ;Before this routine finishes a message is sent to the WII ADT REVIEWER mail group alerting the site that data needs to be reviewed.
  1. ;A second message is sent to the national collection site that provides the site number needing to conduct the review, the date the
  1. ;report was run and the date range of the report.
  1. ;Line labels DATE, DATE2 and RESET Can't be called from any option.
  1. ;They will be used if the GWOT or national support needs to seed a site or reset the site entries.
  1. ;DBI used in this routine:
  1. ; 419 NAME: DBIA419 (405/ .06 Direct Global Read & w/Fileman)
  1. ; Particular ^DGPM('AMV1',and ^DGPM('AMV3'
  1. ; 4938 (2/"MPI" to get ICN with a direct read)
  1. ; 417 DBIA417 (40.8 / 1 Direct Global Read & w/Fileman)
  1. ; 2440 DBIA2440 (42 /15 Direct Global Read & w/Fileman)
  1. ;API's used in this routine:
  1. ; use of VADPT API documented in PIMS ver 5.3 technical manual
  1. ; # can also use DBIA # 10061 - VADPT
  1. ; ELIG^VADPT
  1. ; SVC^VADPT
  1. ; DEM^VADPT
  1. ;to send mail out we use the xmb API listed below
  1. ;http://www.domain.ext/vdl/documents/Infrastructure/Mailman/xm_8_0_developerguide.pdf
  1. ;-------------------------------------------------------------------------------------------------
  1. EN ; set a default past 7 days time frame
  1. D NOW^%DTC S WIIENDT=X_".2359" S X1=X,X2=-7 D C^%DTC S WIISTRT=X K X1,X2,X
  1. D NOW^%DTC S DT=X K X,Y,%
  1. ;clean up symbol table
  1. JUMP ;
  1. D KVAR^VADPT
  1. ; Patient Movement File X-Ref as described in the file attributes
  1. ; TT=Transaction type where selections are
  1. ; 1=admission
  1. ; 3=discharge
  1. ; wiistrt = start date / dfn = patients dfn / wiient = ien of the movement / wiimodt = movement date / wiienddt = end date
  1. ; USE OF DBIA419 CUSTODIAL PACKAGE: REGISTRATION TO GO THROUGH "AMV1" AND "AMV3"
  1. F WIIACT="AMV1","AMV3" S WIIMODT=WIISTRT F S WIIMODT=$O(^DGPM(WIIACT,WIIMODT)) Q:(WIIMODT="")!(WIIMODT>WIIENDT) D ;
  1. . S DFN="" F S DFN=$O(^DGPM(WIIACT,WIIMODT,DFN)) Q:DFN="" S WIIENT="" S WIIENT=$O(^DGPM(WIIACT,WIIMODT,DFN,WIIENT)) Q:WIIMODT="" D ;
  1. . . S WIIVALD=0 D VERPAT1(DFN)
  1. D XMD
  1. K WIIACT,WIIMODT,WIIENT,WIIENDT,WIISTRT,WIIENDT,WIITST,WIIVALD
  1. K XMDUZ,XMSUB,XMTEXT,XMY,Y,WIICNT
  1. K VADM,VAEL
  1. K WIITMP
  1. K WIIACT,WIIMODT,DFN,WIIENT,WIIACT
  1. D KVAR^VADPT
  1. D CLEAN
  1. Q
  1. VERPAT1(DFN) ;
  1. ;VADPT API documented in PIMS ver 5.3 technical manual
  1. Q:$$TESTPAT^VADPT(DFN) ; screen out test patient records
  1. S WIITST=0
  1. ELIG ;
  1. ;VADPT API documented in PIMS ver 5.3 technical manual
  1. D KVAR^VADPT
  1. D ELIG^VADPT
  1. K WII1,WIISORC,WIITRAN
  1. S WII1=$P($G(VAEL(1)),U,2) D
  1. .I WII1="SHARING AGREEMENT" S WIITST=1,WIIELG=WII1 Q ;PRIMARY ELIG
  1. .I WII1="TRICARE" S WIITST=1,WIIELG=WII1 Q
  1. .I WII1="OTHER FEDERAL AGENCY" S WIITST=1,WIIELG=WII1 Q
  1. ;now go through other eligibility
  1. I WIITST=0 S WII1=0 F S WII1=$O(VAEL(1,WII1)) Q:(WII1="")!('+WII1) D
  1. .I $P($G(VAEL(1,WII1)),U,2)="TRICARE" S WIITST=1,WIIELG=$P($G(VAEL(1,WII1)),U,2) Q
  1. .I $P($G(VAEL(1,WII1)),U,2)="SHARING AGREEMENT" S WIITST=1,WIIELG=$P($G(VAEL(1,WII1)),U,2) Q ;SHARING AGREEMENT
  1. .I $P($G(VAEL(1,WII1)),U,2)="OTHER FEDERAL AGENCY" S WIITST=1,WIIELG=$P($G(VAEL(1,WII1)),U,2) Q
  1. I WIITST=0 D CLEAN Q ;failed the eligibility no need to go futher
  1. D KVAR^VADPT
  1. FORCE2 ;this tag can be called with the wiient
  1. ;in the case this is a discharge we want the admission number
  1. ;in the case of a admission we are good.
  1. S WIIADM=$$GET1^DIQ(405,WIIENT,.14,"I") ;admission ien
  1. ;in the case that this movement is a discharge and the record in 987.5 has not been sent off
  1. ;then we don't need to collect it as the admission has the data in it.
  1. I WIIACT="AMV3" I $P($G(^WII(987.5,WIIADM,0)),U,9)=1 D REMOVE ;
  1. ;GET WARD LOCATION TO GET DIVISION TO COVER INTEGRATED FACILITIES
  1. ;dbia'S 419 (405/ .06) DBIA2440 (42/.015) DBIA417 (40.8/1)
  1. S WIIDIV=$$GET1^DIQ(405,WIIADM,.06,"I")
  1. S WIIDIV=$$GET1^DIQ(42,WIIDIV,.015,"I") ;THIS POINTS TO 40.8
  1. S WIIDIV=$$GET1^DIQ(40.8,WIIDIV,.07,"I") ;THIS POINTS TO THE INSTU FILE AT LAST
  1. S WIIDIV=$$GET1^DIQ(4,WIIDIV,99,"E") ;THE NAME
  1. S WII1A=$$GET1^DIQ(405,WIIADM,.01,"I"),WII1A=$$FMTE^XLFDT(WII1A,"5MZ")
  1. S WII3=$$GET1^DIQ(405,WIIADM,.17,"I") D
  1. .I WII3="" S WII3A="" Q
  1. .S WII3A=$$GET1^DIQ(405,WII3,.01,"I") S WII3A=$$FMTE^XLFDT(WII3A,"5MZ")
  1. D DEM^VADPT
  1. S WIINAM=$G(VADM(1)),WIISSN=$P($G(VADM(2)),U,2),WIIADAT=$$GET1^DIQ(405,WIIENT,.14)
  1. S WIIDOB=$P($G(VADM(3)),U,2) ;Date of birth
  1. S WIISEX=$P($G(VADM(5)),U,2) ;SEX
  1. S VAPA("P")="" D ADD^VADPT S WIIZIP=$G(VAPA(6)) ;The P forces the permanent address be returned
  1. ;DBIA 4938 for the ICN read below
  1. S WWICN=$P($G(^DPT(DFN,"MPI")),U,1)
  1. S WWISSN=$P($G(VADM(2)),U,1)
  1. ADD ; ADD ENTRY INTO FILE ;
  1. S DIC="^WII(987.5,"
  1. S DIC(0)=""
  1. S X=WIIENT,DINUM=WIIENT
  1. D FILE^DICN
  1. I Y>0 D
  1. .S DIE=DIC
  1. .S DR="1///"_$G(VADM(1))_";2///"_$P($G(VADM(2)),U,1)_";3///"_WIIMODT_";4///"_WIIDIV_";5///"_WII1A_";6///"_WII3A_";7///"_WWICN_";8///1;9///"_DT_";10///"_DUZ
  1. .S DR=DR_";13///"_WIIZIP_";14///"_WIIDOB_";15///"_WIISEX_";16///"_WIIELG_";18///"_DFN
  1. .D ^DIE
  1. CLEAN ;
  1. K WIITRAN,WIISTS,WIISORC,WIIMVT,WIIDIV,WIIAZ,DIC,DIE,DA,DR,WWISSN,WWICN,WIIADAT
  1. K WII3A,WIIDIV,WII1A,WII3A,WWICN,WIIANS,A,DINUM,DIRUT
  1. K WII3,WIINAM,WIIREV,WIISSN,WIIADM,WIICNT
  1. K WIIELG,WIIDOB,WIISEX,WIIZIP,WIICOMP
  1. K VAPA
  1. D KVAR^VADPT
  1. Q
  1. REMOVE ;---------------------------------------------------------------------------------------------------
  1. ;If the movement is a discharge AND the admission movement is marked with a status of 1 pending approval
  1. ;then we want to remove the admission from the file. If this is not done the data file will contain two entries one for the
  1. ;admission and one for the discharge.
  1. I $P($G(^WII(987.5,WIIADM,0)),U,9)=1 D
  1. .S DIK="^WII(987.5,",DA=WIIADM
  1. .D ^DIK
  1. .K DA,DIK
  1. Q
  1. FORCE(DFN,WIIENT) ;WIIENT SHOULD BE THE IEN IN THE PATIENT MOVEMENT FILE
  1. S WIIACT=$$GET1^DIQ(405,WIIENT,.02,"I") S WIIACT=$S(WIIACT=1:"AMV1",WIIACT=3:"AMV3",1:"")
  1. S WIIMODT=$$GET1^DIQ(405,WIIENT,.01,"I")
  1. D ELIG^VADPT
  1. S WIIELG=$P($G(VAEL(1)),U,2)
  1. D FORCE2
  1. D CLEAN
  1. Q
  1. XMD ; send out message using XMD API
  1. ; XMY..........RECIPIENTS OF MSG
  1. ; XMDUZ........MESSAGE SENDER
  1. ; XMSUB........MESSAGE SUBJECT
  1. ; XMTEXT.......MESSAGE TEXT
  1. ; The XMB API listed below is used to send mail out
  1. S (WIIENT,WIICNT)=0 F S WIIENT=$O(^WII(987.5,"C",1,WIIENT)) Q:(WIIENT="")!('+WIIENT) S WIICNT=WIICNT+1
  1. S WIITMP("GWOT",1,0)="Active duty admission report ran from "_$$FMTE^XLFDT(WIISTRT,"2")_" to "_$$FMTE^XLFDT(WIIENDT,"2")
  1. I WIICNT=0 S WIITMP("GWOT",2,0)="There are No Active Duty Admissions / Discharges that need to be reviewed."
  1. I WIICNT>0 S WIITMP("GWOT",3,0)="There are ["_WIICNT_"]"_" Active Duty Admissions/Discharge entries that need reviewing." D
  1. . S WIITMP("GWOT",2,0)="You can review these entries with the WII REVIEW ADT EVENTS option."
  1. S WIITMP("GWOT",4,0)="-------------------------------------------------------------------------------"
  1. S WIITMP("GWOT",5,0)="Station ID :"_$G(^DD("SITE")) ;"GET FACILITY OR INST DBIA OR API FOR THIS DATA"
  1. S WIITMP("GWOT",6,0)="Count Pending review: ["_WIICNT_"]"
  1. S WIITMP("GWOT",7,0)="Date ran :"_$$FMTE^XLFDT(DT,"2")
  1. S WIITMP("GWOT",8,0)="Reporting Period :"_$$FMTE^XLFDT(WIISTRT,"2")_" to "_$$FMTE^XLFDT(WIIENDT,"2")
  1. S WIIREV=$$GET1^DIQ(987.6,1,.01,"E") ;LOCAL REVIEWER MAIL GROUP
  1. S WIIREV="G."_WIIREV ;LOCAL REVIEWER GROUP
  1. S XMY(WIIREV)=""
  1. S XMDUZ=.5,XMSUB=^DD("SITE")_" - Admissions/Discharges",XMTEXT="WIITMP(""GWOT""," D ^XMD,KILL^XM
  1. ;send status message to repository site to track that the option and that the job is running
  1. K WIITMP
  1. ;SITE ^ COUNT ^ DATE RAN ^ Start of reporting period ^ End of REPORTING PERIOD
  1. S WIITMP("GWOT",1,0)="987.8 DATA^"_$G(^DD("SITE",1))_"^"_WIICNT_"^"_DT_"^"_WIISTRT_"^"_WIIENDT
  1. S WIIREV=$$GET1^DIQ(987.6,1,1,"I") ;MAIL SERVER
  1. S XMY(WIIREV)=""
  1. S XMDUZ=.5,XMSUB=^DD("SITE",1)_" - Admissions/Discharges",XMTEXT="WIITMP(""GWOT""," D ^XMD,KILL^XM
  1. D CLEAN
  1. Q
  1. ; All of the code below can ONLY be called from the programmer prompt.
  1. ; The date tag can be used to generate data for a missing period.
  1. ; For example the weekly tasked job failed to get restarted after a system shutdown.
  1. ; The reset tag can be used in the case that all collected entries in 987.5 need to reset for review.
  1. DATE ;
  1. K DIR S DIR(0)="DO^::EX",DIR("A")="From date" D ^DIR K DIR Q:$D(DIRUT)
  1. S WIISTRT=+Y
  1. ;end date
  1. DATE2 ;
  1. K DIR S DIR(0)="DO^::EX",DIR("A")=" To date" D ^DIR K DIR Q:$D(DIRUT)
  1. I +Y<WIISTRT W !!,"To Date must follow From Date",!! D DATE2
  1. S WIIENDT=+Y_.2359
  1. Q:$D(DIRUT)
  1. W ! D JUMP
  1. Q
  1. RESET ;
  1. ; Enter 1 for PENDING 2 for READY TO SEND and 3 DO NOT SEND
  1. R !,"SET ALL ENTRIES TO :",WIIANS:60
  1. S WIIENT=0 F S WIIENT=$O(^WII(987.5,WIIENT)) Q:(WIIENT="")!('+WIIENT) D
  1. .S DIE="^WII(987.5,",DA=WIIENT
  1. .S DR="8///"_WIIANS
  1. .D ^DIE
  1. .K DIE,DA,DR