XUSNPIXI ;OAK_BP/BEE - NPI EXTRACT REPORT INTERFACE ROUTINE ;01-OCT-06
;;8.0;KERNEL;**481**;Jul 10, 1995;Build 18
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Process incoming HL7 NPI Crosswalk Extract Schedule/Cancel Message
;
; Incoming Variables (Defined in HL7 Message Handler)
;
; HLNEXT -> Executable code to step through message
; HLMTIENS -> IEN of entry in Message Text file for subscriber application
; HLNODE -> Array containing current segment information
; HLQUIT -> Variable signifying last segment has been reached
;
EN ; Entry Point - Place message into a TMP global.
;
N ACK,CNT,%DT,EVENT,FS,FSHLI,IDT,ORDCTL,PROCID,SEGCNT,SEGMSH,SEGORC,STS,X,XDT,Y
;
; Load message into ^TMP global
;
K ^TMP($J,"XUSNPIXI")
F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
. S CNT=0,^TMP($J,"XUSNPIXI",SEGCNT,CNT)=HLNODE
. F S CNT=$O(HLNODE(CNT)) Q:'CNT D
.. S ^TMP($J,"XUSNPIXI",SEGCNT,CNT)=HLNODE(CNT)
;
; Check MSH Segment
;
S SEGMSH=$G(^TMP($J,"XUSNPIXI",1,0))
S (FS,FSHLI)=$E(SEGMSH,4)
;
;Make sure first message is MSH and check Process ID
S PROCID=$P(SEGMSH,FSHLI,11)
I ($E(SEGMSH,1,3)'="MSH")!(",T,P,"'[(","_PROCID_",")) D G ACK
. S STS="AE^Invalid Message Header - First segment found is not MSH or PROCESS ID is not 'T' or 'P'"
;
;Verify Correct Message Type
S EVENT=$P(SEGMSH,FSHLI,9)
I EVENT'="ORM^O01^ORM_O01" D G ACK
. S STS="AE^Invalid Message Type ("_EVENT_") - Expecting ORM^O01^ORM_O01"
;
;Save needed parameter
S HL("HLMTIENS")=$G(HLMTIENS)
;
; Process ORC Segment
;
;Pull next segment (should be an ORC)
S SEGORC=$G(^TMP($J,"XUSNPIXI",2,0))
;
;Check for ORC segment
I $E(SEGORC,1,3)'="ORC" D G ACK
. S STS="AE^Invalid Segment ("_$E(SEGORC,1,3)_") - Second segment should be an ORC segment"
;
;Pull Order Control Field
S ORDCTL=$P(SEGORC,FSHLI,2)
I ORDCTL'="NW",ORDCTL'="CA" D G ACK
. S STS="AE^Invalid Order Control Field Value ("_ORDCTL_") - Expected 'NW' or 'CA'"
;
;Check Date and Time
S X=$E($P(SEGORC,FSHLI,10),1,12)
S:X?8N X=X_"2100" ;Default to 9:00PM if no time
S:X?10N X=X_"00" ;Default minutes if not sent
S:X'?12N X=-1 ;Invalid date
S:X'=-1 X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4)_"@"_$E(X,9,12)
S %DT="R" D ^%DT I Y=-1 D G ACK
. S STS="AE^Invalid Run Date/Time - ("_$P(SEGORC,FSHLI,10)_")"
S IDT=Y,XDT=X
;
;Call Schedule (NW) or Cancel (CA) Tags
I ORDCTL="NW" D
. S STS=$$NW(IDT,XDT)
I ORDCTL="CA" D
. S STS=$$CA(IDT,XDT)
;
; Kick Off Application Acknowledgment
;
ACK S ACK("MSA",1)=$P(STS,U)
S ACK("MSA",2)=$G(HL("MID")) ;Message ID
S ACK("MSA",3)=$P(STS,U,2) ;Message Text
D APPACK(.HL,.ACK)
;
; Exit the process
;
EXIT K ACK,CNT,%DT,EVENT,FS,FSHLI,IDT,PROCID,SEGCNT,SEGMSH,SEGORC,STS,X,XDT,Y
K ^TMP($J,"XUSNPIXI"),HL,HLNEXT,HLNODE,HLQUIT
Q
;
; Schedule a New Run
;
NW(IDT,XDT) N TSK
;
;Check if task already scheduled for date/time
S TSK=$$GETTASK(IDT)
I TSK Q "AE^Task (#"_TSK_") already scheduled to run on "_XDT
;
;Schedule the task
S TSK=$$SCHED(IDT)
;
;Check for scheduling problem
I 'TSK Q "AE^Task Could Not Be Scheduled"
;
;Send successful schedule message
D MSG("CROSSWALK EXTRACT REPORT Scheduled "_XDT)
Q "AA^"
;
; Cancel a Scheduled Run
;
CA(IDT,XDT) N ZTSK
;
;Check if task has been scheduled for date/time
S ZTSK=$$GETTASK(IDT)
I 'ZTSK Q "AE^Task was not scheduled to run on "_XDT_"."
;
;Delete Task
D KILL^%ZTLOAD
;
;Check for problem with cancel request
I '$G(ZTSK(0)) Q "AE^Task (#"_ZTSK_") could not be killed."
;
;Send successful run cancel message
D MSG("CROSSWALK EXTRACT REPORT Cancelled "_XDT)
;
Q "AA^"
;
;Check To See If Task Is Scheduled for Date and Time/Locate Task
;
GETTASK(IDT) N TASK,TASKNO,TDT,XUSUCI,Y,ZTSK0
;
;Retrieve UCI
X ^%ZOSF("UCI") S XUSUCI=Y
;
S TASK=0,TASKNO=""
F S TASK=$O(^%ZTSK(TASK)) Q:'TASK D Q:TASKNO
.I $G(^%ZTSK(TASK,.03))["XUS NPI EXTRACT" D
..S ZTSK0=$G(^%ZTSK(TASK,0))
..;
..;Exclude tasks scheduled by TaskMan
..Q:ZTSK0["ZTSK^XQ1"
..;
..;Exclude tasks in other ucis
..Q:(($P(ZTSK0,U,11)_","_$P(ZTSK0,U,12))'=XUSUCI)
..;
..;Check for correct date and time
..S TDT=$$HTFM^XLFDT($P(ZTSK0,"^",6))
..I TDT=IDT S TASKNO=TASK
Q TASKNO
;
;Schedule Task
;
SCHED(ZTDTH) N ZTRTN,ZTDESC,ZTIO,ZTSK
S ZTRTN="TASKMAN^XUSNPIX1"
S ZTDESC="XUS NPI EXTRACT"
S ZTIO=""
D ^%ZTLOAD
Q ZTSK
;
;Send Application Acknowledgment
;
APPACK(HL,XUSACK) ;
N FS,HLA,XUSGENR
S FS=$G(HL("FS")) I FS="" S FS="|"
;
;Set up HL7
D INIT^HLFNC2("XUS NPI EXTRACT INPUT",.HL)
;
;MSA Segment
S HLA("HLA",1)="MSA"_FS_$G(XUSACK("MSA",1))_FS_$G(XUSACK("MSA",2))_FS_$G(XUSACK("MSA",3))
;
;Kick off Application Acknowledgment
D GENACK^HLMA1($G(HL("EID")),$G(HL("HLMTIENS")),$G(HL("EIDS")),"LM",1,.XUSGENR)
;
Q
;
;Send MailMan Status Message
;
MSG(XUSSUB) N XMSUB,XMTEXT,XMY,XUDT,XUSNPIMM,XMDUZ,XMZ,XMMG,DIFROM
;
;Set subject and text
S XMTEXT="XUSNPIMM("
S XUDT=$P($P(XUSSUB,"@")," ",$L(XUSSUB," "))
S XUSSUB=$P(XUSSUB," ",1,$L(XUSSUB," ")-1)_" "
S XUSSUB=XUSSUB_$E(XUDT,7,10)_$E(XUDT,1,2)_$E(XUDT,4,5)
S XMSUB=$$SUBJ()_XUSSUB
S XMDUZ="XUS NPI CROSSWALK EXTRACT SCHEDULER"
;
;Put subject in body as well so message will transmit
S XUSNPIMM(.0001)=XMSUB
;
;Set recipient
S XMY("G.NPI EXTRACT VERIFICATION")=""
;
;Send
D ^XMD
;
Q
;
; Define First Part of Message Subject
;
SUBJ() N PROD,SINFO,SITE,SUBJ
;
;Pull site info
S SINFO=$$SITE^VASITE
;
; Station Number
S SITE=$P(SINFO,U,3)
;
;Determine whether production or test
S PROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST")
;
Q "Station "_SITE_"("_PROD_") NPI "
XUSNPIXI ;OAK_BP/BEE - NPI EXTRACT REPORT INTERFACE ROUTINE ;01-OCT-06
+1 ;;8.0;KERNEL;**481**;Jul 10, 1995;Build 18
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Process incoming HL7 NPI Crosswalk Extract Schedule/Cancel Message
+5 ;
+6 ; Incoming Variables (Defined in HL7 Message Handler)
+7 ;
+8 ; HLNEXT -> Executable code to step through message
+9 ; HLMTIENS -> IEN of entry in Message Text file for subscriber application
+10 ; HLNODE -> Array containing current segment information
+11 ; HLQUIT -> Variable signifying last segment has been reached
+12 ;
EN ; Entry Point - Place message into a TMP global.
+1 ;
+2 NEW ACK,CNT,%DT,EVENT,FS,FSHLI,IDT,ORDCTL,PROCID,SEGCNT,SEGMSH,SEGORC,STS,X,XDT,Y
+3 ;
+4 ; Load message into ^TMP global
+5 ;
+6 KILL ^TMP($JOB,"XUSNPIXI")
+7 FOR SEGCNT=1:1
XECUTE HLNEXT
IF HLQUIT'>0
QUIT
Begin DoDot:1
+8 SET CNT=0
SET ^TMP($JOB,"XUSNPIXI",SEGCNT,CNT)=HLNODE
+9 FOR
SET CNT=$ORDER(HLNODE(CNT))
IF 'CNT
QUIT
Begin DoDot:2
+10 SET ^TMP($JOB,"XUSNPIXI",SEGCNT,CNT)=HLNODE(CNT)
End DoDot:2
End DoDot:1
+11 ;
+12 ; Check MSH Segment
+13 ;
+14 SET SEGMSH=$GET(^TMP($JOB,"XUSNPIXI",1,0))
+15 SET (FS,FSHLI)=$EXTRACT(SEGMSH,4)
+16 ;
+17 ;Make sure first message is MSH and check Process ID
+18 SET PROCID=$PIECE(SEGMSH,FSHLI,11)
+19 IF ($EXTRACT(SEGMSH,1,3)'="MSH")!(",T,P,"'[(","_PROCID_","))
Begin DoDot:1
+20 SET STS="AE^Invalid Message Header - First segment found is not MSH or PROCESS ID is not 'T' or 'P'"
End DoDot:1
GOTO ACK
+21 ;
+22 ;Verify Correct Message Type
+23 SET EVENT=$PIECE(SEGMSH,FSHLI,9)
+24 IF EVENT'="ORM^O01^ORM_O01"
Begin DoDot:1
+25 SET STS="AE^Invalid Message Type ("_EVENT_") - Expecting ORM^O01^ORM_O01"
End DoDot:1
GOTO ACK
+26 ;
+27 ;Save needed parameter
+28 SET HL("HLMTIENS")=$GET(HLMTIENS)
+29 ;
+30 ; Process ORC Segment
+31 ;
+32 ;Pull next segment (should be an ORC)
+33 SET SEGORC=$GET(^TMP($JOB,"XUSNPIXI",2,0))
+34 ;
+35 ;Check for ORC segment
+36 IF $EXTRACT(SEGORC,1,3)'="ORC"
Begin DoDot:1
+37 SET STS="AE^Invalid Segment ("_$EXTRACT(SEGORC,1,3)_") - Second segment should be an ORC segment"
End DoDot:1
GOTO ACK
+38 ;
+39 ;Pull Order Control Field
+40 SET ORDCTL=$PIECE(SEGORC,FSHLI,2)
+41 IF ORDCTL'="NW"
IF ORDCTL'="CA"
Begin DoDot:1
+42 SET STS="AE^Invalid Order Control Field Value ("_ORDCTL_") - Expected 'NW' or 'CA'"
End DoDot:1
GOTO ACK
+43 ;
+44 ;Check Date and Time
+45 SET X=$EXTRACT($PIECE(SEGORC,FSHLI,10),1,12)
+46 ;Default to 9:00PM if no time
IF X?8N
SET X=X_"2100"
+47 ;Default minutes if not sent
IF X?10N
SET X=X_"00"
+48 ;Invalid date
IF X'?12N
SET X=-1
+49 IF X'=-1
SET X=$EXTRACT(X,5,6)_"/"_$EXTRACT(X,7,8)_"/"_$EXTRACT(X,1,4)_"@"_$EXTRACT(X,9,12)
+50 SET %DT="R"
DO ^%DT
IF Y=-1
Begin DoDot:1
+51 SET STS="AE^Invalid Run Date/Time - ("_$PIECE(SEGORC,FSHLI,10)_")"
End DoDot:1
GOTO ACK
+52 SET IDT=Y
SET XDT=X
+53 ;
+54 ;Call Schedule (NW) or Cancel (CA) Tags
+55 IF ORDCTL="NW"
Begin DoDot:1
+56 SET STS=$$NW(IDT,XDT)
End DoDot:1
+57 IF ORDCTL="CA"
Begin DoDot:1
+58 SET STS=$$CA(IDT,XDT)
End DoDot:1
+59 ;
+60 ; Kick Off Application Acknowledgment
+61 ;
ACK SET ACK("MSA",1)=$PIECE(STS,U)
+1 ;Message ID
SET ACK("MSA",2)=$GET(HL("MID"))
+2 ;Message Text
SET ACK("MSA",3)=$PIECE(STS,U,2)
+3 DO APPACK(.HL,.ACK)
+4 ;
+5 ; Exit the process
+6 ;
EXIT KILL ACK,CNT,%DT,EVENT,FS,FSHLI,IDT,PROCID,SEGCNT,SEGMSH,SEGORC,STS,X,XDT,Y
+1 KILL ^TMP($JOB,"XUSNPIXI"),HL,HLNEXT,HLNODE,HLQUIT
+2 QUIT
+3 ;
+4 ; Schedule a New Run
+5 ;
NW(IDT,XDT) NEW TSK
+1 ;
+2 ;Check if task already scheduled for date/time
+3 SET TSK=$$GETTASK(IDT)
+4 IF TSK
QUIT "AE^Task (#"_TSK_") already scheduled to run on "_XDT
+5 ;
+6 ;Schedule the task
+7 SET TSK=$$SCHED(IDT)
+8 ;
+9 ;Check for scheduling problem
+10 IF 'TSK
QUIT "AE^Task Could Not Be Scheduled"
+11 ;
+12 ;Send successful schedule message
+13 DO MSG("CROSSWALK EXTRACT REPORT Scheduled "_XDT)
+14 QUIT "AA^"
+15 ;
+16 ; Cancel a Scheduled Run
+17 ;
CA(IDT,XDT) NEW ZTSK
+1 ;
+2 ;Check if task has been scheduled for date/time
+3 SET ZTSK=$$GETTASK(IDT)
+4 IF 'ZTSK
QUIT "AE^Task was not scheduled to run on "_XDT_"."
+5 ;
+6 ;Delete Task
+7 DO KILL^%ZTLOAD
+8 ;
+9 ;Check for problem with cancel request
+10 IF '$GET(ZTSK(0))
QUIT "AE^Task (#"_ZTSK_") could not be killed."
+11 ;
+12 ;Send successful run cancel message
+13 DO MSG("CROSSWALK EXTRACT REPORT Cancelled "_XDT)
+14 ;
+15 QUIT "AA^"
+16 ;
+17 ;Check To See If Task Is Scheduled for Date and Time/Locate Task
+18 ;
GETTASK(IDT) NEW TASK,TASKNO,TDT,XUSUCI,Y,ZTSK0
+1 ;
+2 ;Retrieve UCI
+3 XECUTE ^%ZOSF("UCI")
SET XUSUCI=Y
+4 ;
+5 SET TASK=0
SET TASKNO=""
+6 FOR
SET TASK=$ORDER(^%ZTSK(TASK))
IF 'TASK
QUIT
Begin DoDot:1
+7 IF $GET(^%ZTSK(TASK,.03))["XUS NPI EXTRACT"
Begin DoDot:2
+8 SET ZTSK0=$GET(^%ZTSK(TASK,0))
+9 ;
+10 ;Exclude tasks scheduled by TaskMan
+11 IF ZTSK0["ZTSK^XQ1"
QUIT
+12 ;
+13 ;Exclude tasks in other ucis
+14 IF (($PIECE(ZTSK0,U,11)_","_$PIECE(ZTSK0,U,12))'=XUSUCI)
QUIT
+15 ;
+16 ;Check for correct date and time
+17 SET TDT=$$HTFM^XLFDT($PIECE(ZTSK0,"^",6))
+18 IF TDT=IDT
SET TASKNO=TASK
End DoDot:2
End DoDot:1
IF TASKNO
QUIT
+19 QUIT TASKNO
+20 ;
+21 ;Schedule Task
+22 ;
SCHED(ZTDTH) NEW ZTRTN,ZTDESC,ZTIO,ZTSK
+1 SET ZTRTN="TASKMAN^XUSNPIX1"
+2 SET ZTDESC="XUS NPI EXTRACT"
+3 SET ZTIO=""
+4 DO ^%ZTLOAD
+5 QUIT ZTSK
+6 ;
+7 ;Send Application Acknowledgment
+8 ;
APPACK(HL,XUSACK) ;
+1 NEW FS,HLA,XUSGENR
+2 SET FS=$GET(HL("FS"))
IF FS=""
SET FS="|"
+3 ;
+4 ;Set up HL7
+5 DO INIT^HLFNC2("XUS NPI EXTRACT INPUT",.HL)
+6 ;
+7 ;MSA Segment
+8 SET HLA("HLA",1)="MSA"_FS_$GET(XUSACK("MSA",1))_FS_$GET(XUSACK("MSA",2))_FS_$GET(XUSACK("MSA",3))
+9 ;
+10 ;Kick off Application Acknowledgment
+11 DO GENACK^HLMA1($GET(HL("EID")),$GET(HL("HLMTIENS")),$GET(HL("EIDS")),"LM",1,.XUSGENR)
+12 ;
+13 QUIT
+14 ;
+15 ;Send MailMan Status Message
+16 ;
MSG(XUSSUB) NEW XMSUB,XMTEXT,XMY,XUDT,XUSNPIMM,XMDUZ,XMZ,XMMG,DIFROM
+1 ;
+2 ;Set subject and text
+3 SET XMTEXT="XUSNPIMM("
+4 SET XUDT=$PIECE($PIECE(XUSSUB,"@")," ",$LENGTH(XUSSUB," "))
+5 SET XUSSUB=$PIECE(XUSSUB," ",1,$LENGTH(XUSSUB," ")-1)_" "
+6 SET XUSSUB=XUSSUB_$EXTRACT(XUDT,7,10)_$EXTRACT(XUDT,1,2)_$EXTRACT(XUDT,4,5)
+7 SET XMSUB=$$SUBJ()_XUSSUB
+8 SET XMDUZ="XUS NPI CROSSWALK EXTRACT SCHEDULER"
+9 ;
+10 ;Put subject in body as well so message will transmit
+11 SET XUSNPIMM(.0001)=XMSUB
+12 ;
+13 ;Set recipient
+14 SET XMY("G.NPI EXTRACT VERIFICATION")=""
+15 ;
+16 ;Send
+17 DO ^XMD
+18 ;
+19 QUIT
+20 ;
+21 ; Define First Part of Message Subject
+22 ;
SUBJ() NEW PROD,SINFO,SITE,SUBJ
+1 ;
+2 ;Pull site info
+3 SET SINFO=$$SITE^VASITE
+4 ;
+5 ; Station Number
+6 SET SITE=$PIECE(SINFO,U,3)
+7 ;
+8 ;Determine whether production or test
+9 SET PROD=$SELECT($$PROD^XUPROD(1):"PROD",1:"TEST")
+10 ;
+11 QUIT "Station "_SITE_"("_PROD_") NPI "
