SDPMHLS ;BPFO/JRC - Build ROU-R01 HL7 message for 'SD ENC PERF MON' application ;4/2/04
;;5.3;Scheduling;**313,371,416,640**;AUG 13, 1993;Build 8
;
QUE ;Queue retroactive XMIT job
;SD*640 Stop running Performance Monitor Retransmit Report (AAC) job.
Q
;
;Declare variables
S (STDT,EDT,Y,X)=""
;Prompt user for month and year
S %DT("A")="Please select MONTH and YEAR for TIU's National Rollup to transmit: "
S %DT="AEMX"
;Set %DT not to allow current and future months
S %DT(0)=-($$FMADD^XLFDT($$NOW^XLFDT(),-32))
D ^%DT
;Check date input if (-1) quit else continue
I Y<0 Q
;Set STDT = user selected month and year and add 1 day
S STDT=Y+01
;Add 32 days to STDT
S X=$$FMADD^XLFDT(STDT,32)
;Subtract number of days that overlap into the following month
S EDT=$$FMADD^XLFDT(X,-($E(X,6,7)))
;Set task variables
S ZTIO=""
S ZTDESC="Performance Indicator National Rollup"
S ZTRTN="EN^SDPMHLS"
S ZTSAVE("STDT")=""
S ZTSAVE("EDT")=""
D ^%ZTLOAD W:$D(ZTSK) " (Task: ",ZTSK,")"
K STDT,EDT,X,Y,%DT,%DT("A"),%DT(0)
Q
EN ;Entry point
;Note: Retroactive reports use variables STDT and EDT to pass dates
; STDT - start date, first day of the month for selected month
; EDT - ending date, last day of the month for selected month
;
;SD*640 Stop scheduling APM Performance Monitor Task job.
Q
;
;Declare variables
N STDATE,ENDDATE
N XMTARRY,SCRNARR,SORTARR,OUTARR,X,RDATE
S SCRNARR="^TMP(""SCRPW"",$J,""SCRNARR"")"
S SORTARR="^TMP(""SCRPW"",$J,""SORTARR"")"
S OUTARR="^TMP(""SCRPW"",$J,""OUTARR"")"
S XMTARRY="^TMP(""HLS"","_$J_")"
S (STDATE,ENDDATE)=""
;Set national screen/sort
D ROLLUP^SCRPW303(SCRNARR,SORTARR)
;Call module to build scratch global
D GETINFO
;Build HL7 Message
D BLDMSG(OUTARR,XMTARRY)
;Send HL7 Message
I +$O(@XMTARRY@(""))>0 D
.S J=$$SENDMSG(.XMTARRY)
;Send XMIT notifications
D MSG
;Cleanup an quit
D EXIT
Q
BLDMSG(OUTARR,XMTARRY) ;Build OBR segment
;Input : OUTARR - Ouptut array
;Output: XMTARRY - HL7 temporary array
;Declare variables
N HL,HLFS,HLECH,HLQ,SNODE,PNODE,DIVHL,TYPE,COUNT
D INIT^HLFNC2("SD ENC PERF MON ORU-R01 SERVER",.HL)
Q:$O(HL(""))=""
N VAFEVN,VAFSTR,CNT,MAKE,VAFOBR,VAFOBX,I,XCNT,INFO,DIV,DIVHL
S CNT=1,XCNT=0
S MAKE(1)="1"
S MAKE(4,1,1)="01"
S MAKE(4,1,2)="VA ENC PERF MONITOR"
S MAKE(7)=$$HLDATE^HLFNC(RDATE)
S MAKE(25)="F"
S MAKE(27,1,4)=$$HLDATE^HLFNC(STDATE,"DT")
S MAKE(27,1,5)=$$HLDATE^HLFNC(ENDDATE,"DT")
K VAFOBR
D MAKEIT^VAFHLU("OBR",.MAKE,.VAFOBR,.VAFOBR)
M @XMTARRY@(CNT)=VAFOBR
S XCNT=XCNT+1,CNT=CNT+1
;Build OBX segment for facility
S SNODE=$G(@OUTARR@("SUMMARY"))
S PNODE=$G(@OUTARR@("SUMMARY","PI"))
S DIVHL=$P($$SITE^VASITE,"^",3)
D MAKEOBX
;Build OBX segment for division(s)
S DIV="" F S DIV=$O(@OUTARR@("SUBTOTAL",DIV)) Q:DIV="" D
.N SNODE,PNODE
.S SNODE=$G(@OUTARR@("SUBTOTAL",DIV))
.S PNODE=$G(@OUTARR@("SUBTOTAL",DIV,"PI"))
.S DIVHL=$P(DIV,"^",2)
.D MAKEOBX
.Q
Q
MAKEOBX ;Set type and count for total encounters to bld OBX
;Input : SNODE - Temporary counter node for summary
; PNODE - Temporary counter node for PI
; DIVHL - Division and Suffix
; CNT - Temporary array subscript count
; XCNT - OBX segment counter
; XMTARRY - Temporary HL array ^TMP("HLS",$J)
S TYPE="CD",COUNT=$P($G(SNODE),U,1),OBID=1 D BLDOBX
;Set type and count for counters for ET in days F0 - F10 to bld OBX
F M4=0:1:10 D
.S OBID=2
.S TYPE="F"_M4
.S COUNT=$P($G(PNODE),U,(M4+1))
.D BLDOBX
;Set type and count for scanned notes and Uniques to bld OBX
S TYPE="FSPN",OBID=2,COUNT=$P($G(SNODE),U,7) D BLDOBX
S TYPE="FEP",OBID=2,COUNT=$P($G(SNODE),U,4) D BLDOBX
S TYPE="FDSS",OBID=2,COUNT=$P($G(SNODE),U,5) D BLDOBX
;Set types and count for encounters w/o progress notes and
;encounters w/progress notes pending signatures
S TYPE="FNPN",OBID=2,COUNT=+$P(SNODE,U,1)-(+($P(SNODE,U,2)))-(+($P(SNODE,U,9)))-(+($P(SNODE,U,7)))-(+($P(PNODE,U,11))) D BLDOBX
S TYPE="FNPS",OBID=2,COUNT=$P($G(SNODE),U,9) D BLDOBX
Q
BLDOBX ;Build OBX
;Ouput : @XMTARRY = Temporary HL array
;Set variables
N MAKE,VAFOBX
S MAKE(1)=XCNT
S MAKE(2)="NM"
S MAKE(3,1,1)=OBID
S MAKE(3,1,4)=TYPE
S MAKE(5)=COUNT
S MAKE(11)="F"
S MAKE(15)=DIVHL
K VAFOBX
D MAKEIT^VAFHLU("OBX",.MAKE,.VAFOBX,.VAFOBX)
M @XMTARRY@(CNT)=VAFOBX
S XCNT=XCNT+1,CNT=CNT+1
Q
SENDMSG(XMTARRY) ;Send HL7 message
;Input - @XMTARRY
;Output - ARRY4HL7
N ARRY4HL7,KILLARRY,HL,HLRESLT,HLFS,HLECH,HLQ,HLP
S XMTARRY=$G(XMTARRY)
S:'(XMTARRY]"") XMTARRY="^TMP(""HLS"","_$J_")"
Q:($O(@XMTARRY@(""))="") "-1^Can not send empty message"
S ARRY4HL7="TMP(""HLS"","_$J_")"
;Initialize HL7 variables
D INIT^HLFNC2("SD ENC PERF MON ORU-R01 SERVER",.HL)
Q:($O(HL(""))="") "-1^Unable to initialize HL7 variables"
;Check if XMTARRY is ^TMP("HLS",$J)
S KILLARRY=0
I $NA(@XMTARRY)'=$NA(@ARRY4HL7) D
.K @ARRY4HL7
.M @ARRY4HL7=@XMTARRY
.S KILLARRY=1
;Broadcast message
D GENERATE^HLMA("SD ENC PERF MON ORU-R01 SERVER","GM",1,.HLRESLT,"",.HLP)
S:('HLRESLT) HLRESLT=$P(HLRESLT,"^",2,3)
;Delete ^TMP("HLS",$J) if XMTARRY was different
K:(KILLARRY) @ARRY4HL7
Q $G(HLRESLT)
GETINFO ;Get performance monitor data
;Input:
; @SCRNARR - Screen array full global reference
; @SORTARR - Sort array full global reference
;Output:
; @OUTARR - Ouput array full global reference
;Remember starting time
S RDATE=$$NOW^XLFDT()
;Check STDT and EDT, if 1 set STDATE and ENDDATE
I $D(STDT)&$D(EDT) S STDATE=STDT,ENDDATE=EDT
I STDATE="" D
.;Set start date = 1st day of previous month
.N X,X1,X2
.S X1=$$DT^XLFDT(),X2=-30 S:$E(X1,6,7)=31 X2=-31
.D C^%DTC
.S STDATE=$E(X,1,5)_"01"
.;Set end date = start date + 32 minus number of days into next month
.S X=$$FMADD^XLFDT(STDATE,32)
.S ENDDATE=$$FMADD^XLFDT(X,-($E(X,6,7)))
.Q
;Set date range in screen array
S @SCRNARR@("RANGE")=STDATE_"^"_ENDDATE
;Get data
D GETDATA^SDPMUT1(SCRNARR,SORTARR,OUTARR)
Q
MSG ;Build bulletin and send
;Input:
; RDATE - report starting time
;Output:
; Notificaion bulletin to SD ENC PERF MON mail group
N MSGTEXT,XMTEXT,XMSUB,XMY,XMCHAN,XMZ,XMDUZ
S MSGTEXT(1)=" "
S MSGTEXT(2)="Performance Indicator National Rollup was started on "_$$FMTE^XLFDT(RDATE,1)
S MSGTEXT(3)="Encounter date range: "_$$FMTE^XLFDT(STDATE,1)_" to "_$$FMTE^XLFDT(ENDDATE,1)
S MSGTEXT(3)="Extraction of data and sending of data completed "_$$FMTE^XLFDT($$NOW^XLFDT(),1)
S MSGTEXT(4)=" "
;Send completion bulletin to current user
S XMSUB="Performance Indicator National Rollup"
S XMTEXT="MSGTEXT("
S XMY("G.SD PM NOTIFICATION TIU")=""
S XMCHAN=1
S XMDUZ="Performance Indicator"
D ^XMD
Q
EXIT ;Done
K @SCRNARR,@SORTARR,@OUTARR,@XMTARRY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDPMHLS 6854 printed Sep 23, 2025@20:36:24 Page 2
SDPMHLS ;BPFO/JRC - Build ROU-R01 HL7 message for 'SD ENC PERF MON' application ;4/2/04
+1 ;;5.3;Scheduling;**313,371,416,640**;AUG 13, 1993;Build 8
+2 ;
QUE ;Queue retroactive XMIT job
+1 ;SD*640 Stop running Performance Monitor Retransmit Report (AAC) job.
+2 QUIT
+3 ;
+4 ;Declare variables
+5 SET (STDT,EDT,Y,X)=""
+6 ;Prompt user for month and year
+7 SET %DT("A")="Please select MONTH and YEAR for TIU's National Rollup to transmit: "
+8 SET %DT="AEMX"
+9 ;Set %DT not to allow current and future months
+10 SET %DT(0)=-($$FMADD^XLFDT($$NOW^XLFDT(),-32))
+11 DO ^%DT
+12 ;Check date input if (-1) quit else continue
+13 IF Y<0
QUIT
+14 ;Set STDT = user selected month and year and add 1 day
+15 SET STDT=Y+01
+16 ;Add 32 days to STDT
+17 SET X=$$FMADD^XLFDT(STDT,32)
+18 ;Subtract number of days that overlap into the following month
+19 SET EDT=$$FMADD^XLFDT(X,-($EXTRACT(X,6,7)))
+20 ;Set task variables
+21 SET ZTIO=""
+22 SET ZTDESC="Performance Indicator National Rollup"
+23 SET ZTRTN="EN^SDPMHLS"
+24 SET ZTSAVE("STDT")=""
+25 SET ZTSAVE("EDT")=""
+26 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE " (Task: ",ZTSK,")"
+27 KILL STDT,EDT,X,Y,%DT,%DT("A"),%DT(0)
+28 QUIT
EN ;Entry point
+1 ;Note: Retroactive reports use variables STDT and EDT to pass dates
+2 ; STDT - start date, first day of the month for selected month
+3 ; EDT - ending date, last day of the month for selected month
+4 ;
+5 ;SD*640 Stop scheduling APM Performance Monitor Task job.
+6 QUIT
+7 ;
+8 ;Declare variables
+9 NEW STDATE,ENDDATE
+10 NEW XMTARRY,SCRNARR,SORTARR,OUTARR,X,RDATE
+11 SET SCRNARR="^TMP(""SCRPW"",$J,""SCRNARR"")"
+12 SET SORTARR="^TMP(""SCRPW"",$J,""SORTARR"")"
+13 SET OUTARR="^TMP(""SCRPW"",$J,""OUTARR"")"
+14 SET XMTARRY="^TMP(""HLS"","_$JOB_")"
+15 SET (STDATE,ENDDATE)=""
+16 ;Set national screen/sort
+17 DO ROLLUP^SCRPW303(SCRNARR,SORTARR)
+18 ;Call module to build scratch global
+19 DO GETINFO
+20 ;Build HL7 Message
+21 DO BLDMSG(OUTARR,XMTARRY)
+22 ;Send HL7 Message
+23 IF +$ORDER(@XMTARRY@(""))>0
Begin DoDot:1
+24 SET J=$$SENDMSG(.XMTARRY)
End DoDot:1
+25 ;Send XMIT notifications
+26 DO MSG
+27 ;Cleanup an quit
+28 DO EXIT
+29 QUIT
BLDMSG(OUTARR,XMTARRY) ;Build OBR segment
+1 ;Input : OUTARR - Ouptut array
+2 ;Output: XMTARRY - HL7 temporary array
+3 ;Declare variables
+4 NEW HL,HLFS,HLECH,HLQ,SNODE,PNODE,DIVHL,TYPE,COUNT
+5 DO INIT^HLFNC2("SD ENC PERF MON ORU-R01 SERVER",.HL)
+6 if $ORDER(HL(""))=""
QUIT
+7 NEW VAFEVN,VAFSTR,CNT,MAKE,VAFOBR,VAFOBX,I,XCNT,INFO,DIV,DIVHL
+8 SET CNT=1
SET XCNT=0
+9 SET MAKE(1)="1"
+10 SET MAKE(4,1,1)="01"
+11 SET MAKE(4,1,2)="VA ENC PERF MONITOR"
+12 SET MAKE(7)=$$HLDATE^HLFNC(RDATE)
+13 SET MAKE(25)="F"
+14 SET MAKE(27,1,4)=$$HLDATE^HLFNC(STDATE,"DT")
+15 SET MAKE(27,1,5)=$$HLDATE^HLFNC(ENDDATE,"DT")
+16 KILL VAFOBR
+17 DO MAKEIT^VAFHLU("OBR",.MAKE,.VAFOBR,.VAFOBR)
+18 MERGE @XMTARRY@(CNT)=VAFOBR
+19 SET XCNT=XCNT+1
SET CNT=CNT+1
+20 ;Build OBX segment for facility
+21 SET SNODE=$GET(@OUTARR@("SUMMARY"))
+22 SET PNODE=$GET(@OUTARR@("SUMMARY","PI"))
+23 SET DIVHL=$PIECE($$SITE^VASITE,"^",3)
+24 DO MAKEOBX
+25 ;Build OBX segment for division(s)
+26 SET DIV=""
FOR
SET DIV=$ORDER(@OUTARR@("SUBTOTAL",DIV))
if DIV=""
QUIT
Begin DoDot:1
+27 NEW SNODE,PNODE
+28 SET SNODE=$GET(@OUTARR@("SUBTOTAL",DIV))
+29 SET PNODE=$GET(@OUTARR@("SUBTOTAL",DIV,"PI"))
+30 SET DIVHL=$PIECE(DIV,"^",2)
+31 DO MAKEOBX
+32 QUIT
End DoDot:1
+33 QUIT
MAKEOBX ;Set type and count for total encounters to bld OBX
+1 ;Input : SNODE - Temporary counter node for summary
+2 ; PNODE - Temporary counter node for PI
+3 ; DIVHL - Division and Suffix
+4 ; CNT - Temporary array subscript count
+5 ; XCNT - OBX segment counter
+6 ; XMTARRY - Temporary HL array ^TMP("HLS",$J)
+7 SET TYPE="CD"
SET COUNT=$PIECE($GET(SNODE),U,1)
SET OBID=1
DO BLDOBX
+8 ;Set type and count for counters for ET in days F0 - F10 to bld OBX
+9 FOR M4=0:1:10
Begin DoDot:1
+10 SET OBID=2
+11 SET TYPE="F"_M4
+12 SET COUNT=$PIECE($GET(PNODE),U,(M4+1))
+13 DO BLDOBX
End DoDot:1
+14 ;Set type and count for scanned notes and Uniques to bld OBX
+15 SET TYPE="FSPN"
SET OBID=2
SET COUNT=$PIECE($GET(SNODE),U,7)
DO BLDOBX
+16 SET TYPE="FEP"
SET OBID=2
SET COUNT=$PIECE($GET(SNODE),U,4)
DO BLDOBX
+17 SET TYPE="FDSS"
SET OBID=2
SET COUNT=$PIECE($GET(SNODE),U,5)
DO BLDOBX
+18 ;Set types and count for encounters w/o progress notes and
+19 ;encounters w/progress notes pending signatures
+20 SET TYPE="FNPN"
SET OBID=2
SET COUNT=+$PIECE(SNODE,U,1)-(+($PIECE(SNODE,U,2)))-(+($PIECE(SNODE,U,9)))-(+($PIECE(SNODE,U,7)))-(+($PIECE(PNODE,U,11)))
DO BLDOBX
+21 SET TYPE="FNPS"
SET OBID=2
SET COUNT=$PIECE($GET(SNODE),U,9)
DO BLDOBX
+22 QUIT
BLDOBX ;Build OBX
+1 ;Ouput : @XMTARRY = Temporary HL array
+2 ;Set variables
+3 NEW MAKE,VAFOBX
+4 SET MAKE(1)=XCNT
+5 SET MAKE(2)="NM"
+6 SET MAKE(3,1,1)=OBID
+7 SET MAKE(3,1,4)=TYPE
+8 SET MAKE(5)=COUNT
+9 SET MAKE(11)="F"
+10 SET MAKE(15)=DIVHL
+11 KILL VAFOBX
+12 DO MAKEIT^VAFHLU("OBX",.MAKE,.VAFOBX,.VAFOBX)
+13 MERGE @XMTARRY@(CNT)=VAFOBX
+14 SET XCNT=XCNT+1
SET CNT=CNT+1
+15 QUIT
SENDMSG(XMTARRY) ;Send HL7 message
+1 ;Input - @XMTARRY
+2 ;Output - ARRY4HL7
+3 NEW ARRY4HL7,KILLARRY,HL,HLRESLT,HLFS,HLECH,HLQ,HLP
+4 SET XMTARRY=$GET(XMTARRY)
+5 if '(XMTARRY]"")
SET XMTARRY="^TMP(""HLS"","_$JOB_")"
+6 if ($ORDER(@XMTARRY@(""))="")
QUIT "-1^Can not send empty message"
+7 SET ARRY4HL7="TMP(""HLS"","_$JOB_")"
+8 ;Initialize HL7 variables
+9 DO INIT^HLFNC2("SD ENC PERF MON ORU-R01 SERVER",.HL)
+10 if ($ORDER(HL(""))="")
QUIT "-1^Unable to initialize HL7 variables"
+11 ;Check if XMTARRY is ^TMP("HLS",$J)
+12 SET KILLARRY=0
+13 IF $NAME(@XMTARRY)'=$NAME(@ARRY4HL7)
Begin DoDot:1
+14 KILL @ARRY4HL7
+15 MERGE @ARRY4HL7=@XMTARRY
+16 SET KILLARRY=1
End DoDot:1
+17 ;Broadcast message
+18 DO GENERATE^HLMA("SD ENC PERF MON ORU-R01 SERVER","GM",1,.HLRESLT,"",.HLP)
+19 if ('HLRESLT)
SET HLRESLT=$PIECE(HLRESLT,"^",2,3)
+20 ;Delete ^TMP("HLS",$J) if XMTARRY was different
+21 if (KILLARRY)
KILL @ARRY4HL7
+22 QUIT $GET(HLRESLT)
GETINFO ;Get performance monitor data
+1 ;Input:
+2 ; @SCRNARR - Screen array full global reference
+3 ; @SORTARR - Sort array full global reference
+4 ;Output:
+5 ; @OUTARR - Ouput array full global reference
+6 ;Remember starting time
+7 SET RDATE=$$NOW^XLFDT()
+8 ;Check STDT and EDT, if 1 set STDATE and ENDDATE
+9 IF $DATA(STDT)&$DATA(EDT)
SET STDATE=STDT
SET ENDDATE=EDT
+10 IF STDATE=""
Begin DoDot:1
+11 ;Set start date = 1st day of previous month
+12 NEW X,X1,X2
+13 SET X1=$$DT^XLFDT()
SET X2=-30
if $EXTRACT(X1,6,7)=31
SET X2=-31
+14 DO C^%DTC
+15 SET STDATE=$EXTRACT(X,1,5)_"01"
+16 ;Set end date = start date + 32 minus number of days into next month
+17 SET X=$$FMADD^XLFDT(STDATE,32)
+18 SET ENDDATE=$$FMADD^XLFDT(X,-($EXTRACT(X,6,7)))
+19 QUIT
End DoDot:1
+20 ;Set date range in screen array
+21 SET @SCRNARR@("RANGE")=STDATE_"^"_ENDDATE
+22 ;Get data
+23 DO GETDATA^SDPMUT1(SCRNARR,SORTARR,OUTARR)
+24 QUIT
MSG ;Build bulletin and send
+1 ;Input:
+2 ; RDATE - report starting time
+3 ;Output:
+4 ; Notificaion bulletin to SD ENC PERF MON mail group
+5 NEW MSGTEXT,XMTEXT,XMSUB,XMY,XMCHAN,XMZ,XMDUZ
+6 SET MSGTEXT(1)=" "
+7 SET MSGTEXT(2)="Performance Indicator National Rollup was started on "_$$FMTE^XLFDT(RDATE,1)
+8 SET MSGTEXT(3)="Encounter date range: "_$$FMTE^XLFDT(STDATE,1)_" to "_$$FMTE^XLFDT(ENDDATE,1)
+9 SET MSGTEXT(3)="Extraction of data and sending of data completed "_$$FMTE^XLFDT($$NOW^XLFDT(),1)
+10 SET MSGTEXT(4)=" "
+11 ;Send completion bulletin to current user
+12 SET XMSUB="Performance Indicator National Rollup"
+13 SET XMTEXT="MSGTEXT("
+14 SET XMY("G.SD PM NOTIFICATION TIU")=""
+15 SET XMCHAN=1
+16 SET XMDUZ="Performance Indicator"
+17 DO ^XMD
+18 QUIT
EXIT ;Done
+1 KILL @SCRNARR,@SORTARR,@OUTARR,@XMTARRY
+2 QUIT
