AGMPHLU ; IHS/SD/TPF - MPI HLO MSG UTILITIES ; 12/15/2007
;;7.2;IHS PATIENT REGISTRATION;**1,3,5,6**;MAY 20, 2010;Build 23
Q
;
DIRCON ;EP - SEND A DIRECT CONNECT VQQ-Q02
; 09/06/2017 - GCD - CR 7693 - Disabled VQQ messages because they are buggy and not needed.
W !!,"THIS OPTION HAS BEEN DISABLED" Q
W !!,"ENTER PATIENT YOU WISH TO QUERY THE MPI FOR:"
W !
D PTLK^AG
Q:'$D(DFN)
I $$DEMOPAT(DFN) W !!,"Demo patients may not be uploaded to the MPI." G DIRCON ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
D CREATMSG^AGMPIHLO(DFN,"VTQ",,.SUCCESS)
I SUCCESS D Q
.W !!,"Query message "_$G(SUCCESS)_" has been sent to the MPI"
W !,"Unable to query patient "_$P(^DPT(DFN,0),U)_" on MPI"
Q
;
A28 ;EP - SEND A A28 ADD A PATIENT
W !!,"ENTER PATIENT YOU WISH TO ADD TO THE MPI:"
D PTLK^AG
Q:'$D(DFN)
I $$DEMOPAT(DFN) W !!,"Demo patients may not be uploaded to the MPI." G A28 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
D CREATMSG^AGMPIHLO(DFN,"A28",,.SUCCESS)
I SUCCESS D Q
.W !!,"A28 Message "_SUCCESS_" has been sent to add patient "_$P(^DPT(DFN,0),U)_" to the MPI." H 2
.;05/29/2013 - KJH - TFS8109 - This was causing an extra message to be sent to EDR.
.;S X="AG REGISTER A PATIENT",DIC=101,INDA=DFN
.;D EN^XQOR
W !,"Unable to create A28 to add patient "_$P(^DPT(DFN,0),U)_" to MPI"
Q
;
A08 ;EP - SEND AN A08 UPDATE
W !!,"EXAMPLE OF AN A08 UPDATE"
D PTLK^AG
Q:'$D(DFN)
I $$DEMOPAT(DFN) W !!,"Demo patients may not be uploaded to the MPI." G A08 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
D CREATMSG^AGMPIHLO(DFN,"A08","",.SUCCESS)
I SUCCESS D Q
.W !!,"A08 Message "_SUCCESS_" has been sent to update patient "_$P(^DPT(DFN,0),U)_" on the MPI." H 2
.;05/29/2013 - KJH - TFS8109 - This was causing an extra message to be sent to EDR.
.;S X="AG UPDATE A PATIENT",DIC=101,INDA=DFN
.;D EN^XQOR
W !,"Unable to create A08 to update patient "_$P(^DPT(DFN,0),U)_" on MPI"
Q
;
VISITMSG ;EP - CREATE A NEW A01 OR A03
W !!,"CREATE A VISIT HL7 MESSAGE"
D PTLK^AG
Q:'$D(DFN)
I $$DEMOPAT(DFN) W !!,"Demo patients may not be uploaded to the MPI." G VISITMSG ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
K DIR
S DIR(0)="SO^A:ADMISSION;D:DISCHARGE;CIN:CHECK-IN;COUT:CHECK-OUT"
D ^DIR
Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)!(Y="")
;CHECK IN - CHECK OUT
I Y="CIN"!(Y="COUT") D Q Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)!(Y="")
.S EVENT=$S(Y="CIN":4,1:5)
.K DIR
.S DIR(0)="D^::RE"
.S DIR("A")="ENTER CHECK-"_$S(Y="CIN":"IN",1:"OUT")_" DATE"
.D ^DIR
.D NOW^%DTC S NOW=%
.Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)!(Y="")
.S DATE=Y
.D CREATE^AGMPHL01(EVENT,DFN,DATE,.SUCCESS)
.I SUCCESS D Q
..W !!,$S(EVENT=1:"A01",1:"A03")_" Message IEN "_SUCCESS_" has been sent to update patient"
..W !,$P(^DPT(DFN,0),U)_" last treated date on the MPI." H 2
.W !,"Unable to create "_$S(EVENT=1:"A01",1:"A03")_" to update patient "_$P(^DPT(DFN,0),U)_" on MPI"
;
;ADMISSION - DISCHARGE
S TYPE=$S(Y="A":1,1:3)
K DIR
S DIR(0)="D^::RE"
S DIR("A")="ENTER MOVEMENT DATE"
D ^DIR
D NOW^%DTC S NOW=%
Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)!(Y="")
S DATETIME="T"_Y
D CREATE^AGMPHL03(DFN,TYPE,DATETIME,.SUCCESS)
I SUCCESS D Q
.W !!,$S(TYPE=1:"A01",1:"A03")_" Message IEN "_SUCCESS_" has been sent to update patient"
.W !,$P(^DPT(DFN,0),U)_" last treated date on the MPI." H 2
W !,"Unable to create "_$S(TYPE=1:"A01",1:"A03")_" to update patient "_$P(^DPT(DFN,0),U)_" on MPI"
Q
;
A40 ;EP - SEND A40 MERGE FROM/TO
N DFN1,DFN2,MRGDIR,NAME1,NAME2
PT1 ;ASK FOR FROM PATIENT
; AG*7.2*5/CR 7718 - Overhauled this entire section because normal patient lookups don't work on merged patients.
W !,"ENTER PATIENT TO KEEP:"
S DIC="^VA(15,",DIC(0)="AEMQ",DIC("A")="Select PATIENT NAME: " D ^DIC
Q:Y=-1
S IEN=$P(Y,"^")
S MRGDIR=$$GET1^DIQ(15,IEN_",",.04,"I") ; 1=.01->.02, 2=.02->.01
S DFN1=$P($$GET1^DIQ(15,IEN_",",$S(MRGDIR=1:.01,1:.02),"I"),";") ; From patient
S DFN2=$P($$GET1^DIQ(15,IEN_",",$S(MRGDIR=1:.02,1:.01),"I"),";") ; To patient
I $$DEMOPAT(DFN1)!$$DEMOPAT(DFN2) W !!,"Demo patients may not be uploaded to the MPI." G PT1 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
I $G(^DPT(DFN1,-9))'=DFN2 D G PT1 ; AG*7.2*5/CR 7718 - Corrected condition -- now checks that patient was merged into DFN2.
.W !,"THIS PATIENT HAS NOT BEEN MERGED TO FIRST PATIENT SUCCESSFULLY!"
.K DIR
.S DIR(0)="E"
.D ^DIR
S NAME1=$P($G(^DPT(DFN1,0)),U) ; ^DIQ doesn't work on merged patients
S NAME2=$$GET1^DIQ(2,DFN2_",",.01,"I")
W !
K DIR
S DIR(0)="Y",DIR("A")="Send A40 for "_NAME1_" merged into "_NAME2,DIR("B")="Yes"
D ^DIR
I Y="^" Q
I 'Y W ! G PT1
D CREATMSG^AGMPIHLO(DFN2,"A40",DFN1,.SUCCESS)
I SUCCESS D Q
.W !!,"A40 Message "_SUCCESS_" has been sent to merge patient"
.W !,$P(^DPT(DFN1,0),U)_" to patient "_$P(^DPT(DFN2,0),U) H 2
W !,"Unable to merge "_$P(^DPT(DFN1,0),U)_" to patient "_$P(^DPT(DFN2,0),U)_" on MPI" H 2
Q
;
MFNMFK ;EP - PROCESS MFN MESSAGE AND CREATE A MFK RESPONSE
K DIR,DIC,DA,DIE,DIR
W !!
S DIC(0)="AQEM"
S DIC("S")="I $G(^HLB(Y,2))[""MFN"""
S DIC="^HLB("
D ^DIC
Q:Y<0
D PROC^AGMPHMFN(+Y,.SUCCESS)
K DIR,DIC,DA,DIE,DIR
I SUCCESS D Q
.W !!,"MFK Message "_SUCCESS_" has been sent to the MPI" H 2
W !,"Unable to create MFK message." H 2
Q
;
RESEND ;EP - RESEND MESSAGE(S)
RSAGAIN ;EP
N FRMSGIEN,TOMSGIEN,DIC,DT,NEWIEN,ERROR,Y
N MPIDIREC,TOTEVENT,GRDTOTAL,ERRORS
FROM ;EP - ASK FROM
S (MPIDIREC,TOTEVENT,GRDTOTAL,ERRORS)=0
W !!
S DIC=778
S DIC(0)="AEQM"
S DIC("A")="SELECT FROM MESSAGE: "
;S DIC("W")="W $P(^(0),U,20)_""**""_$P($G(^HLA($P(^(0),U,2),0)),U,4)"
S DIC("W")="W $P($G(^(0)),U,5)_""**""_$P($G(^HLA($P(^(0),U,2),0)),U,4)"
S DIC("S")="I $P($G(^(0)),U,4)=""O"",($P($G(^(0)),U,20)'=""SU""),($P($G(^(0)),U,5)=""MPI"")"
D ^DIC
Q:Y<0
S FRMSGIEN=+Y
TO ;EP - ASK TO
S DIC=778
S DIC(0)="AEQM"
S DIC("A")="SELECT TO MESSAGE: "
S DIC("B")=FRMSGIEN
;S DIC("W")="W $P(^(0),U,20)_""**""_$P($G(^HLA($P(^(0),U,2),0)),U,4)"
S DIC("W")="W $P($G(^(0)),U,5)_""**""_$P($G(^HLA($P(^(0),U,2),0)),U,4)"
S DIC("S")="I $P($G(^(0)),U,4)=""O"",($P($G(^(0)),U,20)'=""SU""),$P($G(^(0)),U,5)=""MPI"""
D ^DIC
Q:Y<0
S TOMSGIEN=+Y
I FRMSGIEN>TOMSGIEN D G FROM
.W !,"FROM MSG ID CAN NOT BE GREATER THAN THE TO MSG ID" H 2
S MSGIEN=FRMSGIEN-.01
F S MSGIEN=$O(^HLB(MSGIEN)) Q:MSGIEN>TOMSGIEN D
.S LINK=$P($G(^HLB(MSGIEN,0)),U,5)
.Q:LINK'="MPI"
.S DIREC=$P($G(^HLB(MSGIEN,0)),U,4)
.Q:DIREC'="O"
.S COMSTAT=$P($G(^HLB(MSGIEN,0)),U,20)
.Q:COMSTAT="SU"
.;B "S+"
.S EVENT=$P($P($G(^HLB(MSGIEN,2)),U,4),"~",2)
.; 05/24/2013 - KJH - TFS8008 - Remove extraneous locks on the HLO globals.
.S NEWIEN=$$RESEND^HLOAPI3(MSGIEN,.ERROR)
.;B "S+"
.D PARSE^AGMPIACK(.DATA,NEWIEN,.HLMSTATE)
.S DFN=$G(DATA(2,4,3,1,1))
.S GRDTOTAL=GRDTOTAL+1
.I '$D(ERROR) D
..W !,"MESSAGE RESENT, NEW NUMBER: "_NEWIEN
..W !?17,"OLD NUMBER: ",MSGIEN
..D NOW^%DTC S Y=% X ^DD("DD") W !,"SENT AT ",Y
..S TOTEVENT(EVENT)=$G(TOTEVENT(EVENT))+1
.E D Q
..S ERRORS(ERROR)=$G(ERRORS(ERROR))+1
;.05/29/2013 - KJH - TFS8109 - Since this is a 'resend', we do not need to kick off these protocols again.
;.IF NO ERROR KICK PROTOCOL OFF
;.I EVENT="A28" D Q
;..S X="AG REGISTER A PATIENT",DIC=101,INDA=DFN
;..D EN^XQOR
;.I EVENT="A08" D
;..S X="AG UPDATE A PATIENT",DIC=101,INDA=DFN
;..D EN^XQOR
W !!,"TOTAL MESSAGES PROCESSED: ",GRDTOTAL
S ERROR=""
F S ERROR=$O(ERRORS(ERROR)) Q:ERROR="" D
.W !,ERRORS(ERROR)," ",ERROR
S EVENT=""
F S EVENT=$O(TOTEVENT(EVENT)) Q:EVENT="" D
.W !,TOTEVENT(EVENT)," ",EVENT
G RSAGAIN
Q
;
CONDT(DATE) ;EP - CONVERT FM DATE INTO 2009-04-14 00:00:00
N NEWDATE,TIME
S TIME=$P(DATE,".",2)
S DATE=$P(DATE,".")
S TIME="."_$$FILLSTR^AGMPIHL1(TIME,6,"L",0)
S DATE=DATE_TIME
S NEWDATE=(1700+$E(DATE,1,3))
S DATE=$TR(DATE,"."," ") S DATE=$E(DATE,4,14),NEWDATE=NEWDATE_DATE
S NEWDATE=$E(NEWDATE,1,4)_"-"_$E(NEWDATE,5,6)_"-"_$E(NEWDATE,7,8)_" "_$E(NEWDATE,10,11)_":"_$E(NEWDATE,12,13)_":"_$E(NEWDATE,14,15)
Q NEWDATE
;
DEMOPAT(DFN) ;EP - Check whether a patient is a demo patient and we are in a production environment.
; This is a demo patient if any one of the following criteria is true:
; a) TEST PATIENT INDICATOR (file 2, field 0.6) is set
; b) First five digits of the SSN are 0
; c) Patient's name matches 1"DEMO,PAT".E
; d) Patient's name matches 1"DEMO,GIMC".E
Q:$G(DFN)="" 0
Q:'$$PROD^XUPROD() 0 ; We only care about demo patients in production environments.
N NODE,NAME
S NODE=$G(^DPT(DFN,0))
I $P(NODE,U,21) Q 1
I $E($P(NODE,U,9),1,5)="00000" Q 1
S NAME=$P(NODE,U)
I NAME?1"DEMO,PAT".E Q 1
I NAME?1"DEMO,GIMC".E Q 1
Q 0
AGMPHLU ; IHS/SD/TPF - MPI HLO MSG UTILITIES ; 12/15/2007
+1 ;;7.2;IHS PATIENT REGISTRATION;**1,3,5,6**;MAY 20, 2010;Build 23
+2 QUIT
+3 ;
DIRCON ;EP - SEND A DIRECT CONNECT VQQ-Q02
+1 ; 09/06/2017 - GCD - CR 7693 - Disabled VQQ messages because they are buggy and not needed.
+2 WRITE !!,"THIS OPTION HAS BEEN DISABLED"
QUIT
+3 WRITE !!,"ENTER PATIENT YOU WISH TO QUERY THE MPI FOR:"
+4 WRITE !
+5 DO PTLK^AG
+6 IF '$DATA(DFN)
QUIT
+7 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
IF $$DEMOPAT(DFN)
WRITE !!,"Demo patients may not be uploaded to the MPI."
GOTO DIRCON
+8 DO CREATMSG^AGMPIHLO(DFN,"VTQ",,.SUCCESS)
+9 IF SUCCESS
Begin DoDot:1
+10 WRITE !!,"Query message "_$GET(SUCCESS)_" has been sent to the MPI"
End DoDot:1
QUIT
+11 WRITE !,"Unable to query patient "_$PIECE(^DPT(DFN,0),U)_" on MPI"
+12 QUIT
+13 ;
A28 ;EP - SEND A A28 ADD A PATIENT
+1 WRITE !!,"ENTER PATIENT YOU WISH TO ADD TO THE MPI:"
+2 DO PTLK^AG
+3 IF '$DATA(DFN)
QUIT
+4 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
IF $$DEMOPAT(DFN)
WRITE !!,"Demo patients may not be uploaded to the MPI."
GOTO A28
+5 DO CREATMSG^AGMPIHLO(DFN,"A28",,.SUCCESS)
+6 IF SUCCESS
Begin DoDot:1
+7 WRITE !!,"A28 Message "_SUCCESS_" has been sent to add patient "_$PIECE(^DPT(DFN,0),U)_" to the MPI."
HANG 2
+8 ;05/29/2013 - KJH - TFS8109 - This was causing an extra message to be sent to EDR.
+9 ;S X="AG REGISTER A PATIENT",DIC=101,INDA=DFN
+10 ;D EN^XQOR
End DoDot:1
QUIT
+11 WRITE !,"Unable to create A28 to add patient "_$PIECE(^DPT(DFN,0),U)_" to MPI"
+12 QUIT
+13 ;
A08 ;EP - SEND AN A08 UPDATE
+1 WRITE !!,"EXAMPLE OF AN A08 UPDATE"
+2 DO PTLK^AG
+3 IF '$DATA(DFN)
QUIT
+4 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
IF $$DEMOPAT(DFN)
WRITE !!,"Demo patients may not be uploaded to the MPI."
GOTO A08
+5 DO CREATMSG^AGMPIHLO(DFN,"A08","",.SUCCESS)
+6 IF SUCCESS
Begin DoDot:1
+7 WRITE !!,"A08 Message "_SUCCESS_" has been sent to update patient "_$PIECE(^DPT(DFN,0),U)_" on the MPI."
HANG 2
+8 ;05/29/2013 - KJH - TFS8109 - This was causing an extra message to be sent to EDR.
+9 ;S X="AG UPDATE A PATIENT",DIC=101,INDA=DFN
+10 ;D EN^XQOR
End DoDot:1
QUIT
+11 WRITE !,"Unable to create A08 to update patient "_$PIECE(^DPT(DFN,0),U)_" on MPI"
+12 QUIT
+13 ;
VISITMSG ;EP - CREATE A NEW A01 OR A03
+1 WRITE !!,"CREATE A VISIT HL7 MESSAGE"
+2 DO PTLK^AG
+3 IF '$DATA(DFN)
QUIT
+4 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
IF $$DEMOPAT(DFN)
WRITE !!,"Demo patients may not be uploaded to the MPI."
GOTO VISITMSG
+5 KILL DIR
+6 SET DIR(0)="SO^A:ADMISSION;D:DISCHARGE;CIN:CHECK-IN;COUT:CHECK-OUT"
+7 DO ^DIR
+8 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!(Y="")
QUIT
+9 ;CHECK IN - CHECK OUT
+10 IF Y="CIN"!(Y="COUT")
Begin DoDot:1
+11 SET EVENT=$SELECT(Y="CIN":4,1:5)
+12 KILL DIR
+13 SET DIR(0)="D^::RE"
+14 SET DIR("A")="ENTER CHECK-"_$SELECT(Y="CIN":"IN",1:"OUT")_" DATE"
+15 DO ^DIR
+16 DO NOW^%DTC
SET NOW=%
+17 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!(Y="")
QUIT
+18 SET DATE=Y
+19 DO CREATE^AGMPHL01(EVENT,DFN,DATE,.SUCCESS)
+20 IF SUCCESS
Begin DoDot:2
+21 WRITE !!,$SELECT(EVENT=1:"A01",1:"A03")_" Message IEN "_SUCCESS_" has been sent to update patient"
+22 WRITE !,$PIECE(^DPT(DFN,0),U)_" last treated date on the MPI."
HANG 2
End DoDot:2
QUIT
+23 WRITE !,"Unable to create "_$SELECT(EVENT=1:"A01",1:"A03")_" to update patient "_$PIECE(^DPT(DFN,0),U)_" on MPI"
End DoDot:1
QUIT
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!(Y="")
QUIT
+24 ;
+25 ;ADMISSION - DISCHARGE
+26 SET TYPE=$SELECT(Y="A":1,1:3)
+27 KILL DIR
+28 SET DIR(0)="D^::RE"
+29 SET DIR("A")="ENTER MOVEMENT DATE"
+30 DO ^DIR
+31 DO NOW^%DTC
SET NOW=%
+32 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!(Y="")
QUIT
+33 SET DATETIME="T"_Y
+34 DO CREATE^AGMPHL03(DFN,TYPE,DATETIME,.SUCCESS)
+35 IF SUCCESS
Begin DoDot:1
+36 WRITE !!,$SELECT(TYPE=1:"A01",1:"A03")_" Message IEN "_SUCCESS_" has been sent to update patient"
+37 WRITE !,$PIECE(^DPT(DFN,0),U)_" last treated date on the MPI."
HANG 2
End DoDot:1
QUIT
+38 WRITE !,"Unable to create "_$SELECT(TYPE=1:"A01",1:"A03")_" to update patient "_$PIECE(^DPT(DFN,0),U)_" on MPI"
+39 QUIT
+40 ;
A40 ;EP - SEND A40 MERGE FROM/TO
+1 NEW DFN1,DFN2,MRGDIR,NAME1,NAME2
PT1 ;ASK FOR FROM PATIENT
+1 ; AG*7.2*5/CR 7718 - Overhauled this entire section because normal patient lookups don't work on merged patients.
+2 WRITE !,"ENTER PATIENT TO KEEP:"
+3 SET DIC="^VA(15,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select PATIENT NAME: "
DO ^DIC
+4 IF Y=-1
QUIT
+5 SET IEN=$PIECE(Y,"^")
+6 ; 1=.01->.02, 2=.02->.01
SET MRGDIR=$$GET1^DIQ(15,IEN_",",.04,"I")
+7 ; From patient
SET DFN1=$PIECE($$GET1^DIQ(15,IEN_",",$SELECT(MRGDIR=1:.01,1:.02),"I"),";")
+8 ; To patient
SET DFN2=$PIECE($$GET1^DIQ(15,IEN_",",$SELECT(MRGDIR=1:.02,1:.01),"I"),";")
+9 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
IF $$DEMOPAT(DFN1)!$$DEMOPAT(DFN2)
WRITE !!,"Demo patients may not be uploaded to the MPI."
GOTO PT1
+10 ; AG*7.2*5/CR 7718 - Corrected condition -- now checks that patient was merged into DFN2.
IF $GET(^DPT(DFN1,-9))'=DFN2
Begin DoDot:1
+11 WRITE !,"THIS PATIENT HAS NOT BEEN MERGED TO FIRST PATIENT SUCCESSFULLY!"
+12 KILL DIR
+13 SET DIR(0)="E"
+14 DO ^DIR
End DoDot:1
GOTO PT1
+15 ; ^DIQ doesn't work on merged patients
SET NAME1=$PIECE($GET(^DPT(DFN1,0)),U)
+16 SET NAME2=$$GET1^DIQ(2,DFN2_",",.01,"I")
+17 WRITE !
+18 KILL DIR
+19 SET DIR(0)="Y"
SET DIR("A")="Send A40 for "_NAME1_" merged into "_NAME2
SET DIR("B")="Yes"
+20 DO ^DIR
+21 IF Y="^"
QUIT
+22 IF 'Y
WRITE !
GOTO PT1
+23 DO CREATMSG^AGMPIHLO(DFN2,"A40",DFN1,.SUCCESS)
+24 IF SUCCESS
Begin DoDot:1
+25 WRITE !!,"A40 Message "_SUCCESS_" has been sent to merge patient"
+26 WRITE !,$PIECE(^DPT(DFN1,0),U)_" to patient "_$PIECE(^DPT(DFN2,0),U)
HANG 2
End DoDot:1
QUIT
+27 WRITE !,"Unable to merge "_$PIECE(^DPT(DFN1,0),U)_" to patient "_$PIECE(^DPT(DFN2,0),U)_" on MPI"
HANG 2
+28 QUIT
+29 ;
MFNMFK ;EP - PROCESS MFN MESSAGE AND CREATE A MFK RESPONSE
+1 KILL DIR,DIC,DA,DIE,DIR
+2 WRITE !!
+3 SET DIC(0)="AQEM"
+4 SET DIC("S")="I $G(^HLB(Y,2))[""MFN"""
+5 SET DIC="^HLB("
+6 DO ^DIC
+7 IF Y<0
QUIT
+8 DO PROC^AGMPHMFN(+Y,.SUCCESS)
+9 KILL DIR,DIC,DA,DIE,DIR
+10 IF SUCCESS
Begin DoDot:1
+11 WRITE !!,"MFK Message "_SUCCESS_" has been sent to the MPI"
HANG 2
End DoDot:1
QUIT
+12 WRITE !,"Unable to create MFK message."
HANG 2
+13 QUIT
+14 ;
RESEND ;EP - RESEND MESSAGE(S)
RSAGAIN ;EP
+1 NEW FRMSGIEN,TOMSGIEN,DIC,DT,NEWIEN,ERROR,Y
+2 NEW MPIDIREC,TOTEVENT,GRDTOTAL,ERRORS
FROM ;EP - ASK FROM
+1 SET (MPIDIREC,TOTEVENT,GRDTOTAL,ERRORS)=0
+2 WRITE !!
+3 SET DIC=778
+4 SET DIC(0)="AEQM"
+5 SET DIC("A")="SELECT FROM MESSAGE: "
+6 ;S DIC("W")="W $P(^(0),U,20)_""**""_$P($G(^HLA($P(^(0),U,2),0)),U,4)"
+7 SET DIC("W")="W $P($G(^(0)),U,5)_""**""_$P($G(^HLA($P(^(0),U,2),0)),U,4)"
+8 SET DIC("S")="I $P($G(^(0)),U,4)=""O"",($P($G(^(0)),U,20)'=""SU""),($P($G(^(0)),U,5)=""MPI"")"
+9 DO ^DIC
+10 IF Y<0
QUIT
+11 SET FRMSGIEN=+Y
TO ;EP - ASK TO
+1 SET DIC=778
+2 SET DIC(0)="AEQM"
+3 SET DIC("A")="SELECT TO MESSAGE: "
+4 SET DIC("B")=FRMSGIEN
+5 ;S DIC("W")="W $P(^(0),U,20)_""**""_$P($G(^HLA($P(^(0),U,2),0)),U,4)"
+6 SET DIC("W")="W $P($G(^(0)),U,5)_""**""_$P($G(^HLA($P(^(0),U,2),0)),U,4)"
+7 SET DIC("S")="I $P($G(^(0)),U,4)=""O"",($P($G(^(0)),U,20)'=""SU""),$P($G(^(0)),U,5)=""MPI"""
+8 DO ^DIC
+9 IF Y<0
QUIT
+10 SET TOMSGIEN=+Y
+11 IF FRMSGIEN>TOMSGIEN
Begin DoDot:1
+12 WRITE !,"FROM MSG ID CAN NOT BE GREATER THAN THE TO MSG ID"
HANG 2
End DoDot:1
GOTO FROM
+13 SET MSGIEN=FRMSGIEN-.01
+14 FOR
SET MSGIEN=$ORDER(^HLB(MSGIEN))
IF MSGIEN>TOMSGIEN
QUIT
Begin DoDot:1
+15 SET LINK=$PIECE($GET(^HLB(MSGIEN,0)),U,5)
+16 IF LINK'="MPI"
QUIT
+17 SET DIREC=$PIECE($GET(^HLB(MSGIEN,0)),U,4)
+18 IF DIREC'="O"
QUIT
+19 SET COMSTAT=$PIECE($GET(^HLB(MSGIEN,0)),U,20)
+20 IF COMSTAT="SU"
QUIT
+21 ;B "S+"
+22 SET EVENT=$PIECE($PIECE($GET(^HLB(MSGIEN,2)),U,4),"~",2)
+23 ; 05/24/2013 - KJH - TFS8008 - Remove extraneous locks on the HLO globals.
+24 SET NEWIEN=$$RESEND^HLOAPI3(MSGIEN,.ERROR)
+25 ;B "S+"
+26 DO PARSE^AGMPIACK(.DATA,NEWIEN,.HLMSTATE)
+27 SET DFN=$GET(DATA(2,4,3,1,1))
+28 SET GRDTOTAL=GRDTOTAL+1
+29 IF '$DATA(ERROR)
Begin DoDot:2
+30 WRITE !,"MESSAGE RESENT, NEW NUMBER: "_NEWIEN
+31 WRITE !?17,"OLD NUMBER: ",MSGIEN
+32 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE !,"SENT AT ",Y
+33 SET TOTEVENT(EVENT)=$GET(TOTEVENT(EVENT))+1
End DoDot:2
+34 IF '$TEST
Begin DoDot:2
+35 SET ERRORS(ERROR)=$GET(ERRORS(ERROR))+1
End DoDot:2
QUIT
End DoDot:1
+36 ;.05/29/2013 - KJH - TFS8109 - Since this is a 'resend', we do not need to kick off these protocols again.
+37 ;.IF NO ERROR KICK PROTOCOL OFF
+38 ;.I EVENT="A28" D Q
+39 ;..S X="AG REGISTER A PATIENT",DIC=101,INDA=DFN
+40 ;..D EN^XQOR
+41 ;.I EVENT="A08" D
+42 ;..S X="AG UPDATE A PATIENT",DIC=101,INDA=DFN
+43 ;..D EN^XQOR
+44 WRITE !!,"TOTAL MESSAGES PROCESSED: ",GRDTOTAL
+45 SET ERROR=""
+46 FOR
SET ERROR=$ORDER(ERRORS(ERROR))
IF ERROR=""
QUIT
Begin DoDot:1
+47 WRITE !,ERRORS(ERROR)," ",ERROR
End DoDot:1
+48 SET EVENT=""
+49 FOR
SET EVENT=$ORDER(TOTEVENT(EVENT))
IF EVENT=""
QUIT
Begin DoDot:1
+50 WRITE !,TOTEVENT(EVENT)," ",EVENT
End DoDot:1
+51 GOTO RSAGAIN
+52 QUIT
+53 ;
CONDT(DATE) ;EP - CONVERT FM DATE INTO 2009-04-14 00:00:00
+1 NEW NEWDATE,TIME
+2 SET TIME=$PIECE(DATE,".",2)
+3 SET DATE=$PIECE(DATE,".")
+4 SET TIME="."_$$FILLSTR^AGMPIHL1(TIME,6,"L",0)
+5 SET DATE=DATE_TIME
+6 SET NEWDATE=(1700+$EXTRACT(DATE,1,3))
+7 SET DATE=$TRANSLATE(DATE,"."," ")
SET DATE=$EXTRACT(DATE,4,14)
SET NEWDATE=NEWDATE_DATE
+8 SET NEWDATE=$EXTRACT(NEWDATE,1,4)_"-"_$EXTRACT(NEWDATE,5,6)_"-"_$EXTRACT(NEWDATE,7,8)_" "_$EXTRACT(NEWDATE,10,11)_":"_$EXTRACT(NEWDATE,12,13)_":"_$EXTRACT(NEWDATE,14,15)
+9 QUIT NEWDATE
+10 ;
DEMOPAT(DFN) ;EP - Check whether a patient is a demo patient and we are in a production environment.
+1 ; This is a demo patient if any one of the following criteria is true:
+2 ; a) TEST PATIENT INDICATOR (file 2, field 0.6) is set
+3 ; b) First five digits of the SSN are 0
+4 ; c) Patient's name matches 1"DEMO,PAT".E
+5 ; d) Patient's name matches 1"DEMO,GIMC".E
+6 IF $GET(DFN)=""
QUIT 0
+7 ; We only care about demo patients in production environments.
IF '$$PROD^XUPROD()
QUIT 0
+8 NEW NODE,NAME
+9 SET NODE=$GET(^DPT(DFN,0))
+10 IF $PIECE(NODE,U,21)
QUIT 1
+11 IF $EXTRACT($PIECE(NODE,U,9),1,5)="00000"
QUIT 1
+12 SET NAME=$PIECE(NODE,U)
+13 IF NAME?1"DEMO,PAT".E
QUIT 1
+14 IF NAME?1"DEMO,GIMC".E
QUIT 1
+15 QUIT 0
