DG53P951 ;SHRPE/YMG - Post Install for DG patch 951 ;03-May-2018
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; entry point
N XPDIDTOT,XPDIDVT
S XPDIDTOT=2,XPDIDVT=0
D USR(1) ; 1. create non-human user for PRF interface
D EN1(2) ;entry point for HL7 CHECK POST INSTALLATION REPORT
Q
;
USR(DGXPD) ; create non-human user for PRF interface
N UIEN
I '$D(ZTQUEUED) D ;if not background
.D BMES^XPDUTL(" STEP "_DGXPD_" of "_XPDIDTOT)
.D MES^XPDUTL("-------------")
.D MES^XPDUTL("Creating non-human user for PRF interface ... ")
.Q
;
; either in taskmode or not
; ICR #4677.
S UIEN=$$CREATE^XUSAP("DGPRF,INTERFACE","")
I '$D(ZTQUEUED) D
.I +UIEN=0 D BMES^XPDUTL(" Already exists.")
.I +UIEN>0 D BMES^XPDUTL(" Successfully added.")
.I +UIEN<0 D BMES^XPDUTL(" ERROR: user NOT added.")
.D UPDATE^XPDID(DGXPD)
.Q
Q
;
; This subroutine is the post installation for patch DG*5.3*951
; that will generate HL7 CHECK POST INSTALLATION REPORT.
;
; The generation of report is required as there is a risk about being
; out of synchronization when flags are being transferred from one site
; to another, however, one of the sites has not installed the patch yet.
; This will produce errors in HL7.
;
;ICR# TYPE DESCRIPTION
;----- ---- ---------------------
;10103 Sup ^XLFDT: $$FMADD,$$DT,$$HL7TFM
;2056 Sup ^DIQ: $$GET1,GETS
;10070 Sup ^XMD
;2171 Sup ^XUAF4: $$IEN,$$NAME
;2172 Sup UPDATE^XPDID
;2701 Sup $$GETDFN^MPIF001
;10000 Sup NOW^%DTC
;10003 Sup DD^%DT
;3099 Sup $$MSG^HLCSUTL
;4669 Private DG has approval for direct global read of "B" index of FILE #773; Fileman read of field #2
;10035 Sup Fileman read of FILE #2 ;field #.01
;2052 Sup $$GET1^DID
;10141 Sup ^XPDUTL:BMES, MES
;10063 Sup %ZTLOAD
;
;
EN1(DGXPD) ;Queue the HL7 CHECK POST INSTALLATION REPORT to Taskman
I $D(ZTQUEUED) D EN3 Q ;queued to Taskman
N X,MES,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTREQ,ZTSK,ZTSAVE
S MES(1)=" "
S MES(2)=" STEP "_DGXPD_" of "_XPDIDTOT
S MES(3)="-------------"
S MES(4)=" "
S MES(5)="You will now be prompted for Requested Start Time to generate"
S MES(6)="the HL7 CHECK POST INSTALLATION REPORT"
S MES(7)=" "
S MES(8)="If you do not enter a time, then this report will be queued to run NOW."
S MES(9)=" "
D MES^XPDUTL(.MES)
S ZTDESC="DGPF HL7 CHECK POST INSTALLATION REPORT GENERATION"
S ZTRTN="EN3^DG53P951"
S ZTIO=""
D ^%ZTLOAD
I $D(ZTSK) S X="Queued to Task #"_$G(ZTSK) D BMES^XPDUTL(X)
I '$D(ZTSK) D
. K MES
. S MES(1)=" "
. S MES(2)="******************************************"
. S MES(3)="Since you did not enter a time to run the report"
. S MES(4)="Running Post Installation Report NOW."
. S MES(5)=" "
. S MES(6)="Depending upon the size of your database, this report could take"
. S MES(7)="sometime to run."
. S MES(8)=" "
. S MES(9)="There will be no further screen display while running this report."
. S MES(10)="******************************************"
. S MES(11)=" "
. D MES^XPDUTL(.MES)
. S ZTDESC="DGPF HL7 CHECK POST INSTALLATION REPORT GENERATION"
. S ZTRTN="EN3^DG53P951"
. S ZTIO=""
. S ZTDTH=$H
. D ^%ZTLOAD
. S X="Queued to Task #"_$G(ZTSK) D BMES^XPDUTL(X)
. Q
D UPDATE^XPDID(DGXPD)
Q
;
EN3 ;
N DGLIST ;temp global name used for report list
N DGSORT ;array or report parameters
N ACTNARY ;array that contain all the PRF ACTIONs
N LN ;subscript line
N DGRCPNT
N SNDMAIL
S DGLIST=$NA(^TMP("DG951PST",$J))
K @DGLIST
;
D BLDARR ;build PRF ACTION array
S SNDMAIL=0
;beginning and ending date
S DGSORT("DGBEG")=$$FMADD^XLFDT(DT,-4)
S DGSORT("DGEND")=$$DT^XLFDT
D LOOP1(DGLIST)
D PRINT1(DGLIST)
D RECPIENT
D MAIL1
K @DGLIST
S ZTREQ="@"
Q
;
BLDARR ;
;build PRF ACTION Array
N I,X,DGERR,Y
S X=$$GET1^DID(26.14,.03,,"SET OF CODES",,"DGERR")
Q:$D(DGERR)
F I=1:1:$L(X,";") S Y=$P(X,";",I) Q:Y="" S ACTNARY($P(Y,":",2))=""
Q
;
LOOP1(DGLIST) ;
;loop variable pointer flag x-ref file to run report
N DG772,DG773,DGPROCDT,DGMSGTYP,DGREF,DGEVNTYP,DGPTICN
N DGSTANUM,DGSTNAME,DGACTN,DGPTNAME,DGSSN
S DGREF=$NA(^TMP("DG53951P1",$J))
S DG772="" F S DG772=$O(^HLMA("B",DG772),-1) Q:DG772="" D
. S DG773="" F S DG773=$O(^HLMA("B",DG772,DG773),-1) Q:DG773="" D
. . K @DGREF,DGPROCDT,DGMSGTYP,DGEVNTYP,DGPTICN
. . K DGSTANUM,DGSTNAME,DGACTN,DGPTNAME,DGSSN
. . Q:$$MSG^HLCSUTL($$GET1^DIQ(773,DG773_",",2,"I"),$NA(@DGREF@(1)))<1
. . D PARSE(DGREF)
K @DGREF
Q
;
PARSE(DGREF) ;
N SUB1,SUB2,DGSGMENT,DGBEHAV,DFN,DGOUT
S (SUB1,SUB2,DGSGMENT(0))=""
S DGOUT=0
F S SUB1=$O(@DGREF@(SUB1)) Q:SUB1=""!DGOUT D
. N DGBEHAV,DFN
. S DGBEHAV=0
. F S SUB2=$O(@DGREF@(SUB1,SUB2)) Q:SUB2=""!DGOUT D
. . S DGSGMENT(0)=$P(@DGREF@(SUB1,SUB2),U)
. . I (",MSH,PID,QRD,OBR,OBX,")[(","_DGSGMENT(0)_",") D @DGSGMENT(0)
Q
;
MSH ;Parse MSH segment
;Processing date/time check...
S DGPROCDT=$$HL7TFM^XLFDT($P($P(@DGREF@(SUB1,SUB2),U,7),"-"))
I DGPROCDT'>0 S DGOUT=1 Q
;check if date is within the date range TODAY-4 and TODAY
I ($P(DGPROCDT,".")<DGSORT("DGBEG"))!($P(DGPROCDT,".")>DGSORT("DGEND")) S DGOUT=1 Q
;extract the message and event type
S DGMSGTYP=$P($P(@DGREF@(SUB1,SUB2),U,9),"~")
S DGEVNTYP=$P($P(@DGREF@(SUB1,SUB2),U,9),"~",2)
I ((DGMSGTYP["ORU")&(DGEVNTYP["R01"))!((DGMSGTYP["ORF")&(DGEVNTYP["R04")) D
. S DGSTANUM=$P($P(@DGREF@(SUB1,SUB2),U,4),"~")
. I DGSTANUM'="" S DGSTNAME=$$NAME^XUAF4($$IEN^XUAF4(DGSTANUM))
E S DGOUT=1
Q
;
PID ;Parse PID segment
S DGPTICN=$P($P(@DGREF@(SUB1,SUB2),U,4),"~")
S DFN=$$GETDFN^MPIF001(DGPTICN)
Q:+DFN'>0
S DGPTNAME=$$GET1^DIQ(2,DFN,.01)
D SSN
Q
;
QRD ;Parse QRD segment
S DGPTICN=$P($P(@DGREF@(SUB1,SUB2),U,9),"~")
S DFN=$$GETDFN^MPIF001(DGPTICN)
Q:+DFN'>0
S DGPTNAME=$$GET1^DIQ(2,DFN,.01)
D SSN
Q
;
OBR ;Parse OBR segment
;only check "BEHAVIORAL"
I $P($P(@DGREF@(SUB1,SUB2),U,5),"~",2)="BEHAVIORAL" S DGBEHAV=1
Q
;
OBX ;Parse OBX segment
;check the OBX segment if it contains the new DBRS DATA
Q:DGBEHAV<1
I $P(@DGREF@(SUB1,SUB2),U,3)="ST" S DGACTN=$P(@DGREF@(SUB1,SUB2),U,6)
I $G(DGACTN)'="",$D(ACTNARY($G(DGACTN))),$P($P(@DGREF@(SUB1,SUB2),U,4),"~")="D" D BLDLST1(DGLIST)
Q
;
SSN ;extract patient's SSN4
D GETS^DIQ(2,DFN_",",.0905,"ER","DGSSN")
S DGSSN=DGSSN(2,DFN_",","1U4N","E")
Q
;
BLDLST1(DGLIST) ;
;Build the list to be printed later
I DGPTNAME=""!DGSTANUM="" Q
S @DGLIST@(DGPTNAME,DGSTANUM)=DGSSN_U_DGPTICN_U_DGSTANUM_U_DGSTNAME_U_DG772_U_DG773
Q
;
PRINT1(DGLIST) ;
;
N DDASH,DGSITE,DGPTNAME,DGCNT
S DDASH="",$P(DDASH,"-",81)=""
I $O(@DGLIST@(""))="" D Q
. S @DGLIST@(1,0)=" "
. S @DGLIST@(2,0)=">>> No incoming ""BEHAVIORAL"" PRF HL7 transaction messages found"
. S @DGLIST@(3,0)=" for the last 4 days "
. S @DGLIST@(4,0)=" "
. S @DGLIST@(5,0)=" NO REPORT GENERATED"
S (DGSITE,DGPTNAME)="",DGCNT=0
F S DGPTNAME=$O(@DGLIST@(DGPTNAME)) Q:DGPTNAME="" D
. N DGDATA,TEXT
. D:'DGCNT HEAD1(DGLIST)
. F S DGSITE=$O(@DGLIST@(DGPTNAME,DGSITE)) Q:DGSITE="" D
. . S DGDATA=@DGLIST@(DGPTNAME,DGSITE)
. . S TEXT=DGSITE_"/"_$E($P(DGDATA,U,4),1,25)
. . S TEXT=$$BLDSTR(DGSITE_"/"_$E($P(DGDATA,U,4),1,25),TEXT,1,30)
. . S TEXT=$$BLDSTR($E(DGPTNAME,1,20),TEXT,33,20)
. . S TEXT=$$BLDSTR($P(DGDATA,U,2),TEXT,55,17)
. . S TEXT=$$BLDSTR($P(DGDATA,U),TEXT,75,5)
. . S LN=LN+1
. . S @DGLIST@(LN,0)=TEXT
Q
;
HEAD1(DGLIST) ;
;Display user instruction
N DDASH,TEXT
S LN=1
S @DGLIST@(LN,0)=""
S DDASH="",$P(DDASH,"=",80)=""
S LN=LN+1
S @DGLIST@(LN,0)="The list of PRF BEHAVIORAL flags that will be reported to the help desk"
S LN=LN+1
S @DGLIST@(LN,0)="are contained below."
S LN=LN+1
S @DGLIST@(LN,0)="These flags need to be re-sent after the DG*5.3*951 compliance date by"
S LN=LN+1
S @DGLIST@(LN,0)="using the REFRESH option for the sites and patients listed below:"
S LN=LN+1
S @DGLIST@(LN,0)=""
S TEXT="SENDING SITE#/NAME"
S TEXT=$$BLDSTR("SENDING SITE#/NAME",TEXT,1,30)
S TEXT=$$BLDSTR("PATIENT NAME",TEXT,33,20)
S TEXT=$$BLDSTR("ICN #",TEXT,55,17)
S TEXT=$$BLDSTR("SSN4",TEXT,75,5)
S LN=LN+1
S @DGLIST@(LN,0)=TEXT
S LN=LN+1
S @DGLIST@(LN,0)=DDASH
S LN=LN+1
S @DGLIST@(LN,0)=""
S DGCNT=1
Q
;
BLDSTR(NSTR,STR,COL,NSL) ;build a string
Q $E(STR_$J("",COL-1),1,COL-1)_$E(NSTR_$J("",NSL),1,NSL)_$E(STR,COL+NSL,999)
;
RECPIENT ;
;mail recipient
S DGRCPNT(1)="G.DGPF BEHAVIORAL FLAG REVIEW"
S DGRCPNT(2)="G.IRM"
Q
;
MAIL1 ;Send mailman message to user with results
;
N DIFROM,XMDUZ,XMSUB,XMTEXT,XMY
S (XMDUZ,XMSUB)="HL7 CHECK POST-INSTALL REPORT"
S XMTEXT="^TMP(""DG951PST"",$J,"
S (XMY(DUZ),XMY(.5))=""
S DGRCPNT="" F S DGRCPNT=$O(DGRCPNT(DGRCPNT)) Q:DGRCPNT="" S XMY(DGRCPNT(DGRCPNT))=""
D NOW^%DTC S Y=% D DD^%DT
D ^XMD
S SNDMAIL=1
Q
;
; This subroutine is the post installation for patch DG*5.3*951
; that will generate IOC SITE DBRS PATIENTS POST-RELEASE REPORT
;
; The "IOC SITE DBRS PATIENTS POST-RELEASE REPORT" will be developed to determine patients
; in the IOC site that meet the following criteria:
; - have DBRS numbers in their behavioral flag in database by the end
; of National Release period,
; - are registered in other sites
; HL7 messages for these patients need to be re-sent to other site to
; ensure synchronization of DBRS data
;
; ICR# TYPE DESCRIPTION
;----- ---- ---------------------
;10112 Sup $$SITE^VASITE
;2056 Sup ^DIQ: $$GET1,GETS
;10070 Sup ^XMD
;10000 Sup NOW^%DTC
;10003 Sup DD^%DT
;2171 Sup ^XUAF4: $$STA
;2990 Sup TFL^VAFCTFU1
;
EN2 ;
;entry point for IOC SITE DBRS PATIENTS POST-RELEASE REPORT
N DGLIST ;temp global name used for report list
N LN ;subscript line
N SNDMAIL
N DGRCPNT
S DGLIST=$NA(^TMP("DG53951P2",$J))
K @DGLIST
W @IOF
W !,"DG*5.3*951 IOC SITE DBRS PATIENTS POST-RELEASE REPORT",!
;
;user description message
D MSG2
W !
S SNDMAIL=0
D LOOP2(DGLIST)
D PRINT2(DGLIST)
Q:$O(@DGLIST@(""))=""
D RECPIENT
D MAIL2
K @DGLIST
I $G(SNDMAIL) D
. W !!,"SUCCESSFULLY SENT EMAIL : IOC SITE DBRS PATIENTS POST-RELEASE REPORT",!!
. W "To the following recipient:",!
. W ?3,"POSTMASTER"
. S DGRCPNT="" F S DGRCPNT=$O(DGRCPNT(DGRCPNT)) Q:DGRCPNT="" W !,?3,$G(DGRCPNT(DGRCPNT))
W !!
Q
;
MSG2 ;
W !,"This post install routine will check all patients with DBRS data in the local"
W !,"PRF ASSIGNMENT FILE (#26.13) and verify if patients are registered in other VA"
W !,"sites."
;
W !!,"HL7 transaction messages for these patients need to be re-sent to other site to"
W !,"ensure synchronization of DBRS data.",!
Q
;
LOOP2(DGLIST) ;
;loop variable pointer flag x-ref file to run report
N DGDFN,DGIEN,DGINST,DGOWN,IOC
I '$D(ZTQUEUED) S IOC=0 W "Working..."
S DGDFN="" F S DGDFN=$O(^DGPF(26.13,"B",DGDFN)) Q:DGDFN="" D
. S IOC=IOC+1
. I '$D(ZTQUEUED),'(IOC#15) W "."
. s DGIEN="" F S DGIEN=$O(^DGPF(26.13,"B",DGDFN,DGIEN)) Q:DGIEN="" D
. . N DGFLDS,DGERR,DGRESULT,DGSITE,DGPTNAME,DGSSN4,DGOWN,DGCURNT
. . D GETS^DIQ(26.13,DGIEN_",","**","IE","DGFLDS","DGERR")
. . Q:$D(DGERR)
. . ;check if BEHAVIORAL and contain DBRS data
. . ;if true, check if patient is registered to other VA site
. . I DGFLDS(26.13,DGIEN_",",.02,"E")="BEHAVIORAL",$D(DGFLDS(26.131)) D TFL^VAFCTFU1(.DGRESULT,DGDFN)
. . Q:'$D(DGRESULT)
. . Q:DGRESULT(1)'>0
. . S DGPTNAME=DGFLDS(26.13,DGIEN_",",.01,"E") ;patient name
. . ;extract the patient SSN terminal digits
. . D GETS^DIQ(2,DGDFN_",",.0905,"ER","DGSSN4")
. . S DGSSN4=DGSSN4(2,DGDFN_",","1U4N","E")
. . ;PRF owned by this site?
. . S DGSITE=DGFLDS(26.13,DGIEN_",",.04,"I")
. . S DGOWN=$S($G(DGSITE)=$P($$SITE^VASITE,U):1,1:0)
. . S DGCURNT=$$STA^XUAF4(DGSITE)
. . D BLDLST2(DGLIST)
Q
;
BLDLST2(DGLIST) ;
;build list
S @DGLIST@(DGSITE,DGIEN,DGPTNAME)=DGSSN4_U_$S(DGOWN:"YES",1:"NO")_U_DGCURNT
Q
;
PRINT2(DGLIST) ;
;print the list
N DDASH,DGIEN,DGSITE,DGPTNAME,DGCNT
S DDASH="",$P(DDASH,"-",81)=""
I $O(@DGLIST@(""))="" D Q
. W !!," >>> No IOC SITE DBRS PATIENTS record have been found."
. W !!," NO EMAIL GENERATED.",!
S (DGSITE,DGPTNAME,DGIEN)="",DGCNT=0
F S DGSITE=$O(@DGLIST@(DGSITE)) Q:DGSITE="" D
. N DGDATA,TEXT
. D:'DGCNT HEAD2(DGLIST)
. F S DGIEN=$O(@DGLIST@(DGSITE,DGIEN)) Q:DGIEN="" D
. . F S DGPTNAME=$O(@DGLIST@(DGSITE,DGIEN,DGPTNAME)) Q:DGPTNAME="" D
. . . S DGDATA=@DGLIST@(DGSITE,DGIEN,DGPTNAME)
. . . S TEXT=$E(DGPTNAME,1,30)
. . . S TEXT=$$BLDSTR($E(DGPTNAME,1,30),TEXT,1,25)
. . . S TEXT=$$BLDSTR($P(DGDATA,U),TEXT,28,5)
. . . S TEXT=$$BLDSTR($P(DGDATA,U,2),TEXT,37,24)
. . . S TEXT=$$BLDSTR($P(DGDATA,U,3),TEXT,62,18)
. . . S LN=LN+1
. . . S @DGLIST@(LN,0)=TEXT
Q
;
HEAD2(DGLIST) ;
;Display user instruction
N DDASH,TEXT
S LN=1
S @DGLIST@(LN,0)=""
S DDASH="",$P(DDASH,"=",80)=""
S LN=LN+1
S @DGLIST@(LN,0)="The list of IOC SITE DBRS PATIENTS whose HL7 transaction messages needs to be"
S LN=LN+1
S @DGLIST@(LN,0)="re-sent using the REFRESH option to other site to ensure synchronization"
S LN=LN+1
S @DGLIST@(LN,0)="of DBRS data are listed below:"
S LN=LN+1
S @DGLIST@(LN,0)=""
S TEXT="PATIENT NAME"
S TEXT=$$BLDSTR("PATIENT NAME",TEXT,1,25)
S TEXT=$$BLDSTR("SSN4",TEXT,28,5)
S TEXT=$$BLDSTR("PRF OWNED BY THIS SITE?",TEXT,37,23)
S TEXT=$$BLDSTR("CURRENT SITE OWNER",TEXT,62,18)
S LN=LN+1
S @DGLIST@(LN,0)=TEXT
S LN=LN+1
S @DGLIST@(LN,0)=DDASH
S LN=LN+1
S @DGLIST@(LN,0)=""
S DGCNT=1
Q
;
MAIL2 ;Send mailman message to user will results
;
N DIFROM,%,XMDUZ,XMSUB,XMTEXT,XMY
S (XMDUZ,XMSUB)="IOC SITE DBRS PATIENTS REPORT"
S XMTEXT="^TMP(""DG53951P2"",$J,"
S (XMY(DUZ),XMY(.5))=""
S DGRCPNT="" F S DGRCPNT=$O(DGRCPNT(DGRCPNT)) Q:DGRCPNT="" S XMY(DGRCPNT(DGRCPNT))=""
D NOW^%DTC S Y=% D DD^%DT
D ^XMD
S SNDMAIL=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53P951 14266 printed Dec 13, 2024@02:40:26 Page 2
DG53P951 ;SHRPE/YMG - Post Install for DG patch 951 ;03-May-2018
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; entry point
+1 NEW XPDIDTOT,XPDIDVT
+2 SET XPDIDTOT=2
SET XPDIDVT=0
+3 ; 1. create non-human user for PRF interface
DO USR(1)
+4 ;entry point for HL7 CHECK POST INSTALLATION REPORT
DO EN1(2)
+5 QUIT
+6 ;
USR(DGXPD) ; create non-human user for PRF interface
+1 NEW UIEN
+2 ;if not background
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+3 DO BMES^XPDUTL(" STEP "_DGXPD_" of "_XPDIDTOT)
+4 DO MES^XPDUTL("-------------")
+5 DO MES^XPDUTL("Creating non-human user for PRF interface ... ")
+6 QUIT
End DoDot:1
+7 ;
+8 ; either in taskmode or not
+9 ; ICR #4677.
+10 SET UIEN=$$CREATE^XUSAP("DGPRF,INTERFACE","")
+11 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+12 IF +UIEN=0
DO BMES^XPDUTL(" Already exists.")
+13 IF +UIEN>0
DO BMES^XPDUTL(" Successfully added.")
+14 IF +UIEN<0
DO BMES^XPDUTL(" ERROR: user NOT added.")
+15 DO UPDATE^XPDID(DGXPD)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
+19 ; This subroutine is the post installation for patch DG*5.3*951
+20 ; that will generate HL7 CHECK POST INSTALLATION REPORT.
+21 ;
+22 ; The generation of report is required as there is a risk about being
+23 ; out of synchronization when flags are being transferred from one site
+24 ; to another, however, one of the sites has not installed the patch yet.
+25 ; This will produce errors in HL7.
+26 ;
+27 ;ICR# TYPE DESCRIPTION
+28 ;----- ---- ---------------------
+29 ;10103 Sup ^XLFDT: $$FMADD,$$DT,$$HL7TFM
+30 ;2056 Sup ^DIQ: $$GET1,GETS
+31 ;10070 Sup ^XMD
+32 ;2171 Sup ^XUAF4: $$IEN,$$NAME
+33 ;2172 Sup UPDATE^XPDID
+34 ;2701 Sup $$GETDFN^MPIF001
+35 ;10000 Sup NOW^%DTC
+36 ;10003 Sup DD^%DT
+37 ;3099 Sup $$MSG^HLCSUTL
+38 ;4669 Private DG has approval for direct global read of "B" index of FILE #773; Fileman read of field #2
+39 ;10035 Sup Fileman read of FILE #2 ;field #.01
+40 ;2052 Sup $$GET1^DID
+41 ;10141 Sup ^XPDUTL:BMES, MES
+42 ;10063 Sup %ZTLOAD
+43 ;
+44 ;
EN1(DGXPD) ;Queue the HL7 CHECK POST INSTALLATION REPORT to Taskman
+1 ;queued to Taskman
IF $DATA(ZTQUEUED)
DO EN3
QUIT
+2 NEW X,MES,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTREQ,ZTSK,ZTSAVE
+3 SET MES(1)=" "
+4 SET MES(2)=" STEP "_DGXPD_" of "_XPDIDTOT
+5 SET MES(3)="-------------"
+6 SET MES(4)=" "
+7 SET MES(5)="You will now be prompted for Requested Start Time to generate"
+8 SET MES(6)="the HL7 CHECK POST INSTALLATION REPORT"
+9 SET MES(7)=" "
+10 SET MES(8)="If you do not enter a time, then this report will be queued to run NOW."
+11 SET MES(9)=" "
+12 DO MES^XPDUTL(.MES)
+13 SET ZTDESC="DGPF HL7 CHECK POST INSTALLATION REPORT GENERATION"
+14 SET ZTRTN="EN3^DG53P951"
+15 SET ZTIO=""
+16 DO ^%ZTLOAD
+17 IF $DATA(ZTSK)
SET X="Queued to Task #"_$GET(ZTSK)
DO BMES^XPDUTL(X)
+18 IF '$DATA(ZTSK)
Begin DoDot:1
+19 KILL MES
+20 SET MES(1)=" "
+21 SET MES(2)="******************************************"
+22 SET MES(3)="Since you did not enter a time to run the report"
+23 SET MES(4)="Running Post Installation Report NOW."
+24 SET MES(5)=" "
+25 SET MES(6)="Depending upon the size of your database, this report could take"
+26 SET MES(7)="sometime to run."
+27 SET MES(8)=" "
+28 SET MES(9)="There will be no further screen display while running this report."
+29 SET MES(10)="******************************************"
+30 SET MES(11)=" "
+31 DO MES^XPDUTL(.MES)
+32 SET ZTDESC="DGPF HL7 CHECK POST INSTALLATION REPORT GENERATION"
+33 SET ZTRTN="EN3^DG53P951"
+34 SET ZTIO=""
+35 SET ZTDTH=$HOROLOG
+36 DO ^%ZTLOAD
+37 SET X="Queued to Task #"_$GET(ZTSK)
DO BMES^XPDUTL(X)
+38 QUIT
End DoDot:1
+39 DO UPDATE^XPDID(DGXPD)
+40 QUIT
+41 ;
EN3 ;
+1 ;temp global name used for report list
NEW DGLIST
+2 ;array or report parameters
NEW DGSORT
+3 ;array that contain all the PRF ACTIONs
NEW ACTNARY
+4 ;subscript line
NEW LN
+5 NEW DGRCPNT
+6 NEW SNDMAIL
+7 SET DGLIST=$NAME(^TMP("DG951PST",$JOB))
+8 KILL @DGLIST
+9 ;
+10 ;build PRF ACTION array
DO BLDARR
+11 SET SNDMAIL=0
+12 ;beginning and ending date
+13 SET DGSORT("DGBEG")=$$FMADD^XLFDT(DT,-4)
+14 SET DGSORT("DGEND")=$$DT^XLFDT
+15 DO LOOP1(DGLIST)
+16 DO PRINT1(DGLIST)
+17 DO RECPIENT
+18 DO MAIL1
+19 KILL @DGLIST
+20 SET ZTREQ="@"
+21 QUIT
+22 ;
BLDARR ;
+1 ;build PRF ACTION Array
+2 NEW I,X,DGERR,Y
+3 SET X=$$GET1^DID(26.14,.03,,"SET OF CODES",,"DGERR")
+4 if $DATA(DGERR)
QUIT
+5 FOR I=1:1:$LENGTH(X,";")
SET Y=$PIECE(X,";",I)
if Y=""
QUIT
SET ACTNARY($PIECE(Y,":",2))=""
+6 QUIT
+7 ;
LOOP1(DGLIST) ;
+1 ;loop variable pointer flag x-ref file to run report
+2 NEW DG772,DG773,DGPROCDT,DGMSGTYP,DGREF,DGEVNTYP,DGPTICN
+3 NEW DGSTANUM,DGSTNAME,DGACTN,DGPTNAME,DGSSN
+4 SET DGREF=$NAME(^TMP("DG53951P1",$JOB))
+5 SET DG772=""
FOR
SET DG772=$ORDER(^HLMA("B",DG772),-1)
if DG772=""
QUIT
Begin DoDot:1
+6 SET DG773=""
FOR
SET DG773=$ORDER(^HLMA("B",DG772,DG773),-1)
if DG773=""
QUIT
Begin DoDot:2
+7 KILL @DGREF,DGPROCDT,DGMSGTYP,DGEVNTYP,DGPTICN
+8 KILL DGSTANUM,DGSTNAME,DGACTN,DGPTNAME,DGSSN
+9 if $$MSG^HLCSUTL($$GET1^DIQ(773,DG773_",",2,"I"),$NAME(@DGREF@(1)))<1
QUIT
+10 DO PARSE(DGREF)
End DoDot:2
End DoDot:1
+11 KILL @DGREF
+12 QUIT
+13 ;
PARSE(DGREF) ;
+1 NEW SUB1,SUB2,DGSGMENT,DGBEHAV,DFN,DGOUT
+2 SET (SUB1,SUB2,DGSGMENT(0))=""
+3 SET DGOUT=0
+4 FOR
SET SUB1=$ORDER(@DGREF@(SUB1))
if SUB1=""!DGOUT
QUIT
Begin DoDot:1
+5 NEW DGBEHAV,DFN
+6 SET DGBEHAV=0
+7 FOR
SET SUB2=$ORDER(@DGREF@(SUB1,SUB2))
if SUB2=""!DGOUT
QUIT
Begin DoDot:2
+8 SET DGSGMENT(0)=$PIECE(@DGREF@(SUB1,SUB2),U)
+9 IF (",MSH,PID,QRD,OBR,OBX,")[(","_DGSGMENT(0)_",")
DO @DGSGMENT(0)
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
MSH ;Parse MSH segment
+1 ;Processing date/time check...
+2 SET DGPROCDT=$$HL7TFM^XLFDT($PIECE($PIECE(@DGREF@(SUB1,SUB2),U,7),"-"))
+3 IF DGPROCDT'>0
SET DGOUT=1
QUIT
+4 ;check if date is within the date range TODAY-4 and TODAY
+5 IF ($PIECE(DGPROCDT,".")<DGSORT("DGBEG"))!($PIECE(DGPROCDT,".")>DGSORT("DGEND"))
SET DGOUT=1
QUIT
+6 ;extract the message and event type
+7 SET DGMSGTYP=$PIECE($PIECE(@DGREF@(SUB1,SUB2),U,9),"~")
+8 SET DGEVNTYP=$PIECE($PIECE(@DGREF@(SUB1,SUB2),U,9),"~",2)
+9 IF ((DGMSGTYP["ORU")&(DGEVNTYP["R01"))!((DGMSGTYP["ORF")&(DGEVNTYP["R04"))
Begin DoDot:1
+10 SET DGSTANUM=$PIECE($PIECE(@DGREF@(SUB1,SUB2),U,4),"~")
+11 IF DGSTANUM'=""
SET DGSTNAME=$$NAME^XUAF4($$IEN^XUAF4(DGSTANUM))
End DoDot:1
+12 IF '$TEST
SET DGOUT=1
+13 QUIT
+14 ;
PID ;Parse PID segment
+1 SET DGPTICN=$PIECE($PIECE(@DGREF@(SUB1,SUB2),U,4),"~")
+2 SET DFN=$$GETDFN^MPIF001(DGPTICN)
+3 if +DFN'>0
QUIT
+4 SET DGPTNAME=$$GET1^DIQ(2,DFN,.01)
+5 DO SSN
+6 QUIT
+7 ;
QRD ;Parse QRD segment
+1 SET DGPTICN=$PIECE($PIECE(@DGREF@(SUB1,SUB2),U,9),"~")
+2 SET DFN=$$GETDFN^MPIF001(DGPTICN)
+3 if +DFN'>0
QUIT
+4 SET DGPTNAME=$$GET1^DIQ(2,DFN,.01)
+5 DO SSN
+6 QUIT
+7 ;
OBR ;Parse OBR segment
+1 ;only check "BEHAVIORAL"
+2 IF $PIECE($PIECE(@DGREF@(SUB1,SUB2),U,5),"~",2)="BEHAVIORAL"
SET DGBEHAV=1
+3 QUIT
+4 ;
OBX ;Parse OBX segment
+1 ;check the OBX segment if it contains the new DBRS DATA
+2 if DGBEHAV<1
QUIT
+3 IF $PIECE(@DGREF@(SUB1,SUB2),U,3)="ST"
SET DGACTN=$PIECE(@DGREF@(SUB1,SUB2),U,6)
+4 IF $GET(DGACTN)'=""
IF $DATA(ACTNARY($GET(DGACTN)))
IF $PIECE($PIECE(@DGREF@(SUB1,SUB2),U,4),"~")="D"
DO BLDLST1(DGLIST)
+5 QUIT
+6 ;
SSN ;extract patient's SSN4
+1 DO GETS^DIQ(2,DFN_",",.0905,"ER","DGSSN")
+2 SET DGSSN=DGSSN(2,DFN_",","1U4N","E")
+3 QUIT
+4 ;
BLDLST1(DGLIST) ;
+1 ;Build the list to be printed later
+2 IF DGPTNAME=""!DGSTANUM=""
QUIT
+3 SET @DGLIST@(DGPTNAME,DGSTANUM)=DGSSN_U_DGPTICN_U_DGSTANUM_U_DGSTNAME_U_DG772_U_DG773
+4 QUIT
+5 ;
PRINT1(DGLIST) ;
+1 ;
+2 NEW DDASH,DGSITE,DGPTNAME,DGCNT
+3 SET DDASH=""
SET $PIECE(DDASH,"-",81)=""
+4 IF $ORDER(@DGLIST@(""))=""
Begin DoDot:1
+5 SET @DGLIST@(1,0)=" "
+6 SET @DGLIST@(2,0)=">>> No incoming ""BEHAVIORAL"" PRF HL7 transaction messages found"
+7 SET @DGLIST@(3,0)=" for the last 4 days "
+8 SET @DGLIST@(4,0)=" "
+9 SET @DGLIST@(5,0)=" NO REPORT GENERATED"
End DoDot:1
QUIT
+10 SET (DGSITE,DGPTNAME)=""
SET DGCNT=0
+11 FOR
SET DGPTNAME=$ORDER(@DGLIST@(DGPTNAME))
if DGPTNAME=""
QUIT
Begin DoDot:1
+12 NEW DGDATA,TEXT
+13 if 'DGCNT
DO HEAD1(DGLIST)
+14 FOR
SET DGSITE=$ORDER(@DGLIST@(DGPTNAME,DGSITE))
if DGSITE=""
QUIT
Begin DoDot:2
+15 SET DGDATA=@DGLIST@(DGPTNAME,DGSITE)
+16 SET TEXT=DGSITE_"/"_$EXTRACT($PIECE(DGDATA,U,4),1,25)
+17 SET TEXT=$$BLDSTR(DGSITE_"/"_$EXTRACT($PIECE(DGDATA,U,4),1,25),TEXT,1,30)
+18 SET TEXT=$$BLDSTR($EXTRACT(DGPTNAME,1,20),TEXT,33,20)
+19 SET TEXT=$$BLDSTR($PIECE(DGDATA,U,2),TEXT,55,17)
+20 SET TEXT=$$BLDSTR($PIECE(DGDATA,U),TEXT,75,5)
+21 SET LN=LN+1
+22 SET @DGLIST@(LN,0)=TEXT
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
HEAD1(DGLIST) ;
+1 ;Display user instruction
+2 NEW DDASH,TEXT
+3 SET LN=1
+4 SET @DGLIST@(LN,0)=""
+5 SET DDASH=""
SET $PIECE(DDASH,"=",80)=""
+6 SET LN=LN+1
+7 SET @DGLIST@(LN,0)="The list of PRF BEHAVIORAL flags that will be reported to the help desk"
+8 SET LN=LN+1
+9 SET @DGLIST@(LN,0)="are contained below."
+10 SET LN=LN+1
+11 SET @DGLIST@(LN,0)="These flags need to be re-sent after the DG*5.3*951 compliance date by"
+12 SET LN=LN+1
+13 SET @DGLIST@(LN,0)="using the REFRESH option for the sites and patients listed below:"
+14 SET LN=LN+1
+15 SET @DGLIST@(LN,0)=""
+16 SET TEXT="SENDING SITE#/NAME"
+17 SET TEXT=$$BLDSTR("SENDING SITE#/NAME",TEXT,1,30)
+18 SET TEXT=$$BLDSTR("PATIENT NAME",TEXT,33,20)
+19 SET TEXT=$$BLDSTR("ICN #",TEXT,55,17)
+20 SET TEXT=$$BLDSTR("SSN4",TEXT,75,5)
+21 SET LN=LN+1
+22 SET @DGLIST@(LN,0)=TEXT
+23 SET LN=LN+1
+24 SET @DGLIST@(LN,0)=DDASH
+25 SET LN=LN+1
+26 SET @DGLIST@(LN,0)=""
+27 SET DGCNT=1
+28 QUIT
+29 ;
BLDSTR(NSTR,STR,COL,NSL) ;build a string
+1 QUIT $EXTRACT(STR_$JUSTIFY("",COL-1),1,COL-1)_$EXTRACT(NSTR_$JUSTIFY("",NSL),1,NSL)_$EXTRACT(STR,COL+NSL,999)
+2 ;
RECPIENT ;
+1 ;mail recipient
+2 SET DGRCPNT(1)="G.DGPF BEHAVIORAL FLAG REVIEW"
+3 SET DGRCPNT(2)="G.IRM"
+4 QUIT
+5 ;
MAIL1 ;Send mailman message to user with results
+1 ;
+2 NEW DIFROM,XMDUZ,XMSUB,XMTEXT,XMY
+3 SET (XMDUZ,XMSUB)="HL7 CHECK POST-INSTALL REPORT"
+4 SET XMTEXT="^TMP(""DG951PST"",$J,"
+5 SET (XMY(DUZ),XMY(.5))=""
+6 SET DGRCPNT=""
FOR
SET DGRCPNT=$ORDER(DGRCPNT(DGRCPNT))
if DGRCPNT=""
QUIT
SET XMY(DGRCPNT(DGRCPNT))=""
+7 DO NOW^%DTC
SET Y=%
DO DD^%DT
+8 DO ^XMD
+9 SET SNDMAIL=1
+10 QUIT
+11 ;
+12 ; This subroutine is the post installation for patch DG*5.3*951
+13 ; that will generate IOC SITE DBRS PATIENTS POST-RELEASE REPORT
+14 ;
+15 ; The "IOC SITE DBRS PATIENTS POST-RELEASE REPORT" will be developed to determine patients
+16 ; in the IOC site that meet the following criteria:
+17 ; - have DBRS numbers in their behavioral flag in database by the end
+18 ; of National Release period,
+19 ; - are registered in other sites
+20 ; HL7 messages for these patients need to be re-sent to other site to
+21 ; ensure synchronization of DBRS data
+22 ;
+23 ; ICR# TYPE DESCRIPTION
+24 ;----- ---- ---------------------
+25 ;10112 Sup $$SITE^VASITE
+26 ;2056 Sup ^DIQ: $$GET1,GETS
+27 ;10070 Sup ^XMD
+28 ;10000 Sup NOW^%DTC
+29 ;10003 Sup DD^%DT
+30 ;2171 Sup ^XUAF4: $$STA
+31 ;2990 Sup TFL^VAFCTFU1
+32 ;
EN2 ;
+1 ;entry point for IOC SITE DBRS PATIENTS POST-RELEASE REPORT
+2 ;temp global name used for report list
NEW DGLIST
+3 ;subscript line
NEW LN
+4 NEW SNDMAIL
+5 NEW DGRCPNT
+6 SET DGLIST=$NAME(^TMP("DG53951P2",$JOB))
+7 KILL @DGLIST
+8 WRITE @IOF
+9 WRITE !,"DG*5.3*951 IOC SITE DBRS PATIENTS POST-RELEASE REPORT",!
+10 ;
+11 ;user description message
+12 DO MSG2
+13 WRITE !
+14 SET SNDMAIL=0
+15 DO LOOP2(DGLIST)
+16 DO PRINT2(DGLIST)
+17 if $ORDER(@DGLIST@(""))=""
QUIT
+18 DO RECPIENT
+19 DO MAIL2
+20 KILL @DGLIST
+21 IF $GET(SNDMAIL)
Begin DoDot:1
+22 WRITE !!,"SUCCESSFULLY SENT EMAIL : IOC SITE DBRS PATIENTS POST-RELEASE REPORT",!!
+23 WRITE "To the following recipient:",!
+24 WRITE ?3,"POSTMASTER"
+25 SET DGRCPNT=""
FOR
SET DGRCPNT=$ORDER(DGRCPNT(DGRCPNT))
if DGRCPNT=""
QUIT
WRITE !,?3,$GET(DGRCPNT(DGRCPNT))
End DoDot:1
+26 WRITE !!
+27 QUIT
+28 ;
MSG2 ;
+1 WRITE !,"This post install routine will check all patients with DBRS data in the local"
+2 WRITE !,"PRF ASSIGNMENT FILE (#26.13) and verify if patients are registered in other VA"
+3 WRITE !,"sites."
+4 ;
+5 WRITE !!,"HL7 transaction messages for these patients need to be re-sent to other site to"
+6 WRITE !,"ensure synchronization of DBRS data.",!
+7 QUIT
+8 ;
LOOP2(DGLIST) ;
+1 ;loop variable pointer flag x-ref file to run report
+2 NEW DGDFN,DGIEN,DGINST,DGOWN,IOC
+3 IF '$DATA(ZTQUEUED)
SET IOC=0
WRITE "Working..."
+4 SET DGDFN=""
FOR
SET DGDFN=$ORDER(^DGPF(26.13,"B",DGDFN))
if DGDFN=""
QUIT
Begin DoDot:1
+5 SET IOC=IOC+1
+6 IF '$DATA(ZTQUEUED)
IF '(IOC#15)
WRITE "."
+7 SET DGIEN=""
FOR
SET DGIEN=$ORDER(^DGPF(26.13,"B",DGDFN,DGIEN))
if DGIEN=""
QUIT
Begin DoDot:2
+8 NEW DGFLDS,DGERR,DGRESULT,DGSITE,DGPTNAME,DGSSN4,DGOWN,DGCURNT
+9 DO GETS^DIQ(26.13,DGIEN_",","**","IE","DGFLDS","DGERR")
+10 if $DATA(DGERR)
QUIT
+11 ;check if BEHAVIORAL and contain DBRS data
+12 ;if true, check if patient is registered to other VA site
+13 IF DGFLDS(26.13,DGIEN_",",.02,"E")="BEHAVIORAL"
IF $DATA(DGFLDS(26.131))
DO TFL^VAFCTFU1(.DGRESULT,DGDFN)
+14 if '$DATA(DGRESULT)
QUIT
+15 if DGRESULT(1)'>0
QUIT
+16 ;patient name
SET DGPTNAME=DGFLDS(26.13,DGIEN_",",.01,"E")
+17 ;extract the patient SSN terminal digits
+18 DO GETS^DIQ(2,DGDFN_",",.0905,"ER","DGSSN4")
+19 SET DGSSN4=DGSSN4(2,DGDFN_",","1U4N","E")
+20 ;PRF owned by this site?
+21 SET DGSITE=DGFLDS(26.13,DGIEN_",",.04,"I")
+22 SET DGOWN=$SELECT($GET(DGSITE)=$PIECE($$SITE^VASITE,U):1,1:0)
+23 SET DGCURNT=$$STA^XUAF4(DGSITE)
+24 DO BLDLST2(DGLIST)
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
BLDLST2(DGLIST) ;
+1 ;build list
+2 SET @DGLIST@(DGSITE,DGIEN,DGPTNAME)=DGSSN4_U_$SELECT(DGOWN:"YES",1:"NO")_U_DGCURNT
+3 QUIT
+4 ;
PRINT2(DGLIST) ;
+1 ;print the list
+2 NEW DDASH,DGIEN,DGSITE,DGPTNAME,DGCNT
+3 SET DDASH=""
SET $PIECE(DDASH,"-",81)=""
+4 IF $ORDER(@DGLIST@(""))=""
Begin DoDot:1
+5 WRITE !!," >>> No IOC SITE DBRS PATIENTS record have been found."
+6 WRITE !!," NO EMAIL GENERATED.",!
End DoDot:1
QUIT
+7 SET (DGSITE,DGPTNAME,DGIEN)=""
SET DGCNT=0
+8 FOR
SET DGSITE=$ORDER(@DGLIST@(DGSITE))
if DGSITE=""
QUIT
Begin DoDot:1
+9 NEW DGDATA,TEXT
+10 if 'DGCNT
DO HEAD2(DGLIST)
+11 FOR
SET DGIEN=$ORDER(@DGLIST@(DGSITE,DGIEN))
if DGIEN=""
QUIT
Begin DoDot:2
+12 FOR
SET DGPTNAME=$ORDER(@DGLIST@(DGSITE,DGIEN,DGPTNAME))
if DGPTNAME=""
QUIT
Begin DoDot:3
+13 SET DGDATA=@DGLIST@(DGSITE,DGIEN,DGPTNAME)
+14 SET TEXT=$EXTRACT(DGPTNAME,1,30)
+15 SET TEXT=$$BLDSTR($EXTRACT(DGPTNAME,1,30),TEXT,1,25)
+16 SET TEXT=$$BLDSTR($PIECE(DGDATA,U),TEXT,28,5)
+17 SET TEXT=$$BLDSTR($PIECE(DGDATA,U,2),TEXT,37,24)
+18 SET TEXT=$$BLDSTR($PIECE(DGDATA,U,3),TEXT,62,18)
+19 SET LN=LN+1
+20 SET @DGLIST@(LN,0)=TEXT
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
HEAD2(DGLIST) ;
+1 ;Display user instruction
+2 NEW DDASH,TEXT
+3 SET LN=1
+4 SET @DGLIST@(LN,0)=""
+5 SET DDASH=""
SET $PIECE(DDASH,"=",80)=""
+6 SET LN=LN+1
+7 SET @DGLIST@(LN,0)="The list of IOC SITE DBRS PATIENTS whose HL7 transaction messages needs to be"
+8 SET LN=LN+1
+9 SET @DGLIST@(LN,0)="re-sent using the REFRESH option to other site to ensure synchronization"
+10 SET LN=LN+1
+11 SET @DGLIST@(LN,0)="of DBRS data are listed below:"
+12 SET LN=LN+1
+13 SET @DGLIST@(LN,0)=""
+14 SET TEXT="PATIENT NAME"
+15 SET TEXT=$$BLDSTR("PATIENT NAME",TEXT,1,25)
+16 SET TEXT=$$BLDSTR("SSN4",TEXT,28,5)
+17 SET TEXT=$$BLDSTR("PRF OWNED BY THIS SITE?",TEXT,37,23)
+18 SET TEXT=$$BLDSTR("CURRENT SITE OWNER",TEXT,62,18)
+19 SET LN=LN+1
+20 SET @DGLIST@(LN,0)=TEXT
+21 SET LN=LN+1
+22 SET @DGLIST@(LN,0)=DDASH
+23 SET LN=LN+1
+24 SET @DGLIST@(LN,0)=""
+25 SET DGCNT=1
+26 QUIT
+27 ;
MAIL2 ;Send mailman message to user will results
+1 ;
+2 NEW DIFROM,%,XMDUZ,XMSUB,XMTEXT,XMY
+3 SET (XMDUZ,XMSUB)="IOC SITE DBRS PATIENTS REPORT"
+4 SET XMTEXT="^TMP(""DG53951P2"",$J,"
+5 SET (XMY(DUZ),XMY(.5))=""
+6 SET DGRCPNT=""
FOR
SET DGRCPNT=$ORDER(DGRCPNT(DGRCPNT))
if DGRCPNT=""
QUIT
SET XMY(DGRCPNT(DGRCPNT))=""
+7 DO NOW^%DTC
SET Y=%
DO DD^%DT
+8 DO ^XMD
+9 SET SNDMAIL=1
+10 QUIT
+11 ;
