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