RGMTHLDB ;BIR/CML-MPI/PD HL7 ACTIVITY BY PATIENT/SINGLE PROTOCOL ;11/05/01
;;1.0;CLINICAL INFO RESOURCE NETWORK;**21**;30 Apr 99
;
;Reference to ^ORD(101 supported by IA #2596
;Reference to ^HL(772 supported by IA #3464
;Reference to ^DPT(DFN,"MPI" supported by IA #2070
;
S QFLG=1
CHK ;
I '$D(^XTMP("RGMT","HL")) D G QUIT
.W !!,$C(7),"The option ""Compile MPI/PD HL7 Data"" must have"
.W !,"run to completion before this report can be printed!"
;
I '$D(^XTMP("RGMT","HL","@@@@","STOPPED")) D G QUIT
.W !!,$C(7),"The option ""Compile MPI/PD HL7 Data"" is currently running."
.W !,"This report cannot be generated until the compile has run to completion."
.W !!,"Please try again later.",!
;
W @IOF
I $D(^XTMP("RGMT","HL","@@@@","RANGE")) D
.W !!,"Data has been compiled for ",^XTMP("RGMT","HL","@@@@","RANGE"),"."
.W !,"Use the ""Compile MPI/PD HL7 Data"" option if this range is not sufficient."
;
BEGIN ;
W !!,"This option allows you to search for activity related to a specific protocol in"
W !,"the HL7 MESSAGE TEXT (#772) file for a patient during a selected period of time."
W !,"This search is accomplished using data set into a temporary global built by the"
W !,"option ""Compile MPI/PD HL7 Data""."
;
ASK1 ;Ask for Protocol
W !
S DIC="^ORD(101,",DIC(0)="QEAM"
S DIC("S")="S ORD=$P(^(0),""^"") I $D(^XTMP(""RGMT"",""HL"",ORD))"
D ^DIC K DIC G:Y<0 QUIT S PROT=$P(Y,"^",2)
;
ASK2 ;Ask for Date Range
W !
K DIR,DIRUT,DTOUT,DUOUT
S DIR(0)="DAO^:DT:EPX",DIR("A")="Beginning Date: "
D ^DIR K DIR G:$D(DIRUT) QUIT
;
S RGBDT=Y,DIR(0)="DAO^"_RGBDT_":DT:EPX",DIR("A")="Ending Date: "
D ^DIR K DIR G:$D(DIRUT) QUIT S RGEDT=Y
;
ASK3 ;Ask for TYPE
W !
S DIR(0)="SB^I:INCOMING;O:OUTGOING",DIR("A")="Select TYPE"
D ^DIR K DIR G:$D(DIRUT) QUIT S TYPE=Y
;
ASK4 ;Ask for PATIENT
W !!!,"Patient lookup can be done by (P)atient Name/SSN or by (I)CN.",!
S DIR(0)="SB^I:ICN;P:PATIENT NAME/SSN",DIR("A")="Select LOOKUP",DIR("B")="P"
D ^DIR K DIR G:$D(DIRUT) QUIT S LOOKUP=Y
I LOOKUP="P" D LOOKUP1 G:'$D(DFN) ASK4
I LOOKUP="I" D LOOKUP2 G:'$D(DFN) ASK4
;
DEV ;
W !!,"The right margin for this print is 80.",!!
S ZTSAVE("RGBDT")="",ZTSAVE("RGEDT")="",ZTSAVE("PROT")=""
S ZTSAVE("TYPE")="",ZTSAVE("DFN")="",ZTSAVE("ICN")=""
D EN^XUTMDEVQ("START^RGMTHLDB","MPI/PD - Print HL7 Message Data for Patient/Single Protocol") I 'POP Q
W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
G QUIT
START ;
G:'$D(^XTMP("RGMT","HL")) QUIT
S (PG,QFLG,GOTDATA)=0,U="^",$P(LN,"-",81)="",SITE=$P($$SITE^VASITE(),U,2)
S PRGBDT=$$FMTE^XLFDT(RGBDT),PRGEDT=$$FMTE^XLFDT(RGEDT)
D NOW^%DTC S HDT=$$FMTE^XLFDT($E(%,1,12))
D HDR
;
LOOP ;Loop on ^XTMP("RGMT","HLICN" & ^XTMP("RGMT","HLDFN"
I '$D(^XTMP("RGMT","HLICN"))&'($D(^XTMP("RGMT","HLDFN"))) G QUIT
S STOPDT=RGEDT_".9"
F SUB1="HLICN","HLDFN" S SUB2=$S(SUB1="HLICN":ICN,1:DFN) Q:QFLG D
.S RGDT=RGBDT-.1
.F S RGDT=$O(^XTMP("RGMT",SUB1,SUB2,RGDT)) Q:'RGDT Q:RGDT>STOPDT Q:QFLG D
..S STAT="" F S STAT=$O(^XTMP("RGMT",SUB1,SUB2,RGDT,PROT,TYPE,STAT)) Q:STAT="" Q:QFLG D
...S IEN=0 F S IEN=$O(^XTMP("RGMT",SUB1,SUB2,RGDT,PROT,TYPE,STAT,IEN)) Q:'IEN Q:QFLG D
....I ^XTMP("RGMT",SUB1,SUB2,RGDT,PROT,TYPE,STAT,IEN)]"" D BATCHPRT Q
....I $O(^HL(772,IEN,"IN",0)) S GOT=0 D Q:QFLG
.....S TXT=0 F S TXT=$O(^HL(772,IEN,"IN",TXT)) Q:'TXT Q:QFLG D Q:GOT Q:QFLG
......I $P(^HL(772,IEN,"IN",TXT,0),U)="PID",+$P(^(0),U,3)=ICN D PROC Q
......I $P(^HL(772,IEN,"IN",TXT,0),U)="MFE",$P(^(0),U,2)="MAD",+$P($P(^(0),U,5),"~",4)=ICN D PROC Q
......I $P(^HL(772,IEN,"IN",TXT,0),U)="MFE",$P(^(0),U,2)="MUP",+$P(^(0),U,5)=ICN D PROC Q
......I $P(^HL(772,IEN,"IN",TXT,0),U)="QAK",+$P(^(0),U,2)=DFN D PROC
I 'GOTDATA W !,"No data found for this patient."
;
QUIT ;
I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR
.S SS=22-$Y F JJ=1:1:SS W !
K %,BATCHIEN,CNT,DFN,GOT,GOTDATA,HDT,ICN,IEN,JJ,LIM,LINE,LN,LOOKUP,NODE,NUM,PG,PRGBDT
K PRGEDT,PROT,QFLG,RGBDT,RGDT,RGEDT,SITE,SS,STAT,STOPDT,SUB1,SUB2,TXT,TYPE,Y,ZTSK
W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
;
HDR ;HEADER
I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
S PG=PG+1 W:$Y!($E(IOST)="C") @IOF I $E(IOST)'="C"!($E(IOST)="C"&(PG=1)) D
.W !,"HL7 TRANSMISSION DATA at ",SITE," on ",HDT,?72,"Page: ",PG
.W !!,"Patient: ",$P(^DPT(DFN,0),U)
.W !,"Protocol: ",PROT
.W !,"Date Range: ",PRGBDT," to ",PRGEDT,?45,"Type: ",$S(TYPE="I":"INCOMING",1:"OUTGOING"),!
W !,"File #772 IEN",?19,"Date",?39,"Status",!?4,"""IN"" Subfield",!,LN
Q
;
BATCHPRT ;
S GOTDATA=1
D:$Y+4>IOSL HDR Q:QFLG
S BATCHIEN=+$P(^XTMP("RGMT",SUB1,SUB2,RGDT,PROT,TYPE,STAT,IEN),",""IN"",",2)
W !,"Batch Msg #",IEN," - Line #",BATCHIEN
W !?19,$$FMTE^XLFDT($E(RGDT,1,12)),?39,STAT,!
S NODE=^HL(772,IEN,"IN",BATCHIEN,0)
I $L(NODE)>75 D BREAK Q
W !?4,NODE
Q
;
PROC ;Print data
S GOT=1,GOTDATA=1
W !,IEN,?19,$$FMTE^XLFDT($E(RGDT,1,12)),?39,STAT,!
S NUM=0 F S NUM=$O(^HL(772,IEN,"IN",NUM)) Q:'NUM Q:QFLG S NODE=^HL(772,IEN,"IN",NUM,0) D
.I $L(NODE)>75 D BREAK Q
.D:$Y+3>IOSL HDR Q:QFLG W !?4,NODE
Q
;
BREAK ;Break up text lines greater than 75
S CNT=1,LIM=$L(NODE)/75 I LIM["." S LIM=$P(LIM,".")+1
F LINE=1:1:LIM D:$Y+3>IOSL HDR Q:QFLG W !?4,$E(NODE,CNT,CNT+74) S CNT=CNT+75
Q
;
LOOKUP1 ;Lookup by patient name/ssn
W ! K DFN,ICN
S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " D ^DIC K DIC
Q:Y<0
S DFN=+Y
S ICN=+$P($G(^DPT(DFN,"MPI")),U) I 'ICN W !!,"This patient does not have an ICN!" K DFN,ICN
Q
;
LOOKUP2 ;Lookup by ICN
W ! K DFN,ICN
S DIR(0)="N:1:999999999999:0",DIR("A")="Select ICN" D ^DIR K DIR Q:$D(DIRUT)
S ICN=Y S DFN=$$GETDFN^MPIF001(ICN)
I +DFN<0 W !!,"No patient match can be found for this ICN!" K DFN,ICN Q
W " ",$P(^DPT(DFN,0),"^")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGMTHLDB 5914 printed Dec 13, 2024@01:42:21 Page 2
RGMTHLDB ;BIR/CML-MPI/PD HL7 ACTIVITY BY PATIENT/SINGLE PROTOCOL ;11/05/01
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**21**;30 Apr 99
+2 ;
+3 ;Reference to ^ORD(101 supported by IA #2596
+4 ;Reference to ^HL(772 supported by IA #3464
+5 ;Reference to ^DPT(DFN,"MPI" supported by IA #2070
+6 ;
+7 SET QFLG=1
CHK ;
+1 IF '$DATA(^XTMP("RGMT","HL"))
Begin DoDot:1
+2 WRITE !!,$CHAR(7),"The option ""Compile MPI/PD HL7 Data"" must have"
+3 WRITE !,"run to completion before this report can be printed!"
End DoDot:1
GOTO QUIT
+4 ;
+5 IF '$DATA(^XTMP("RGMT","HL","@@@@","STOPPED"))
Begin DoDot:1
+6 WRITE !!,$CHAR(7),"The option ""Compile MPI/PD HL7 Data"" is currently running."
+7 WRITE !,"This report cannot be generated until the compile has run to completion."
+8 WRITE !!,"Please try again later.",!
End DoDot:1
GOTO QUIT
+9 ;
+10 WRITE @IOF
+11 IF $DATA(^XTMP("RGMT","HL","@@@@","RANGE"))
Begin DoDot:1
+12 WRITE !!,"Data has been compiled for ",^XTMP("RGMT","HL","@@@@","RANGE"),"."
+13 WRITE !,"Use the ""Compile MPI/PD HL7 Data"" option if this range is not sufficient."
End DoDot:1
+14 ;
BEGIN ;
+1 WRITE !!,"This option allows you to search for activity related to a specific protocol in"
+2 WRITE !,"the HL7 MESSAGE TEXT (#772) file for a patient during a selected period of time."
+3 WRITE !,"This search is accomplished using data set into a temporary global built by the"
+4 WRITE !,"option ""Compile MPI/PD HL7 Data""."
+5 ;
ASK1 ;Ask for Protocol
+1 WRITE !
+2 SET DIC="^ORD(101,"
SET DIC(0)="QEAM"
+3 SET DIC("S")="S ORD=$P(^(0),""^"") I $D(^XTMP(""RGMT"",""HL"",ORD))"
+4 DO ^DIC
KILL DIC
if Y<0
GOTO QUIT
SET PROT=$PIECE(Y,"^",2)
+5 ;
ASK2 ;Ask for Date Range
+1 WRITE !
+2 KILL DIR,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="DAO^:DT:EPX"
SET DIR("A")="Beginning Date: "
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
+5 ;
+6 SET RGBDT=Y
SET DIR(0)="DAO^"_RGBDT_":DT:EPX"
SET DIR("A")="Ending Date: "
+7 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
SET RGEDT=Y
+8 ;
ASK3 ;Ask for TYPE
+1 WRITE !
+2 SET DIR(0)="SB^I:INCOMING;O:OUTGOING"
SET DIR("A")="Select TYPE"
+3 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
SET TYPE=Y
+4 ;
ASK4 ;Ask for PATIENT
+1 WRITE !!!,"Patient lookup can be done by (P)atient Name/SSN or by (I)CN.",!
+2 SET DIR(0)="SB^I:ICN;P:PATIENT NAME/SSN"
SET DIR("A")="Select LOOKUP"
SET DIR("B")="P"
+3 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
SET LOOKUP=Y
+4 IF LOOKUP="P"
DO LOOKUP1
if '$DATA(DFN)
GOTO ASK4
+5 IF LOOKUP="I"
DO LOOKUP2
if '$DATA(DFN)
GOTO ASK4
+6 ;
DEV ;
+1 WRITE !!,"The right margin for this print is 80.",!!
+2 SET ZTSAVE("RGBDT")=""
SET ZTSAVE("RGEDT")=""
SET ZTSAVE("PROT")=""
+3 SET ZTSAVE("TYPE")=""
SET ZTSAVE("DFN")=""
SET ZTSAVE("ICN")=""
+4 DO EN^XUTMDEVQ("START^RGMTHLDB","MPI/PD - Print HL7 Message Data for Patient/Single Protocol")
IF 'POP
QUIT
+5 WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
+6 GOTO QUIT
START ;
+1 if '$DATA(^XTMP("RGMT","HL"))
GOTO QUIT
+2 SET (PG,QFLG,GOTDATA)=0
SET U="^"
SET $PIECE(LN,"-",81)=""
SET SITE=$PIECE($$SITE^VASITE(),U,2)
+3 SET PRGBDT=$$FMTE^XLFDT(RGBDT)
SET PRGEDT=$$FMTE^XLFDT(RGEDT)
+4 DO NOW^%DTC
SET HDT=$$FMTE^XLFDT($EXTRACT(%,1,12))
+5 DO HDR
+6 ;
LOOP ;Loop on ^XTMP("RGMT","HLICN" & ^XTMP("RGMT","HLDFN"
+1 IF '$DATA(^XTMP("RGMT","HLICN"))&'($DATA(^XTMP("RGMT","HLDFN")))
GOTO QUIT
+2 SET STOPDT=RGEDT_".9"
+3 FOR SUB1="HLICN","HLDFN"
SET SUB2=$SELECT(SUB1="HLICN":ICN,1:DFN)
if QFLG
QUIT
Begin DoDot:1
+4 SET RGDT=RGBDT-.1
+5 FOR
SET RGDT=$ORDER(^XTMP("RGMT",SUB1,SUB2,RGDT))
if 'RGDT
QUIT
if RGDT>STOPDT
QUIT
if QFLG
QUIT
Begin DoDot:2
+6 SET STAT=""
FOR
SET STAT=$ORDER(^XTMP("RGMT",SUB1,SUB2,RGDT,PROT,TYPE,STAT))
if STAT=""
QUIT
if QFLG
QUIT
Begin DoDot:3
+7 SET IEN=0
FOR
SET IEN=$ORDER(^XTMP("RGMT",SUB1,SUB2,RGDT,PROT,TYPE,STAT,IEN))
if 'IEN
QUIT
if QFLG
QUIT
Begin DoDot:4
+8 IF ^XTMP("RGMT",SUB1,SUB2,RGDT,PROT,TYPE,STAT,IEN)]""
DO BATCHPRT
QUIT
+9 IF $ORDER(^HL(772,IEN,"IN",0))
SET GOT=0
Begin DoDot:5
+10 SET TXT=0
FOR
SET TXT=$ORDER(^HL(772,IEN,"IN",TXT))
if 'TXT
QUIT
if QFLG
QUIT
Begin DoDot:6
+11 IF $PIECE(^HL(772,IEN,"IN",TXT,0),U)="PID"
IF +$PIECE(^(0),U,3)=ICN
DO PROC
QUIT
+12 IF $PIECE(^HL(772,IEN,"IN",TXT,0),U)="MFE"
IF $PIECE(^(0),U,2)="MAD"
IF +$PIECE($PIECE(^(0),U,5),"~",4)=ICN
DO PROC
QUIT
+13 IF $PIECE(^HL(772,IEN,"IN",TXT,0),U)="MFE"
IF $PIECE(^(0),U,2)="MUP"
IF +$PIECE(^(0),U,5)=ICN
DO PROC
QUIT
+14 IF $PIECE(^HL(772,IEN,"IN",TXT,0),U)="QAK"
IF +$PIECE(^(0),U,2)=DFN
DO PROC
End DoDot:6
if GOT
QUIT
if QFLG
QUIT
End DoDot:5
if QFLG
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF 'GOTDATA
WRITE !,"No data found for this patient."
+16 ;
QUIT ;
+1 IF $EXTRACT(IOST)="C"&('QFLG)
SET DIR(0)="E"
Begin DoDot:1
+2 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
End DoDot:1
DO ^DIR
KILL DIR
+3 KILL %,BATCHIEN,CNT,DFN,GOT,GOTDATA,HDT,ICN,IEN,JJ,LIM,LINE,LN,LOOKUP,NODE,NUM,PG,PRGBDT
+4 KILL PRGEDT,PROT,QFLG,RGBDT,RGDT,RGEDT,SITE,SS,STAT,STOPDT,SUB1,SUB2,TXT,TYPE,Y,ZTSK
+5 if $EXTRACT(IOST)'="C"
WRITE @IOF
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+6 ;
HDR ;HEADER
+1 IF $EXTRACT(IOST)="C"
SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+2 IF $EXTRACT(IOST)="C"
IF PG>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
QUIT
+3 SET PG=PG+1
if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
IF $EXTRACT(IOST)'="C"!($EXTRACT(IOST)="C"&(PG=1))
Begin DoDot:1
+4 WRITE !,"HL7 TRANSMISSION DATA at ",SITE," on ",HDT,?72,"Page: ",PG
+5 WRITE !!,"Patient: ",$PIECE(^DPT(DFN,0),U)
+6 WRITE !,"Protocol: ",PROT
+7 WRITE !,"Date Range: ",PRGBDT," to ",PRGEDT,?45,"Type: ",$SELECT(TYPE="I":"INCOMING",1:"OUTGOING"),!
End DoDot:1
+8 WRITE !,"File #772 IEN",?19,"Date",?39,"Status",!?4,"""IN"" Subfield",!,LN
+9 QUIT
+10 ;
BATCHPRT ;
+1 SET GOTDATA=1
+2 if $Y+4>IOSL
DO HDR
if QFLG
QUIT
+3 SET BATCHIEN=+$PIECE(^XTMP("RGMT",SUB1,SUB2,RGDT,PROT,TYPE,STAT,IEN),",""IN"",",2)
+4 WRITE !,"Batch Msg #",IEN," - Line #",BATCHIEN
+5 WRITE !?19,$$FMTE^XLFDT($EXTRACT(RGDT,1,12)),?39,STAT,!
+6 SET NODE=^HL(772,IEN,"IN",BATCHIEN,0)
+7 IF $LENGTH(NODE)>75
DO BREAK
QUIT
+8 WRITE !?4,NODE
+9 QUIT
+10 ;
PROC ;Print data
+1 SET GOT=1
SET GOTDATA=1
+2 WRITE !,IEN,?19,$$FMTE^XLFDT($EXTRACT(RGDT,1,12)),?39,STAT,!
+3 SET NUM=0
FOR
SET NUM=$ORDER(^HL(772,IEN,"IN",NUM))
if 'NUM
QUIT
if QFLG
QUIT
SET NODE=^HL(772,IEN,"IN",NUM,0)
Begin DoDot:1
+4 IF $LENGTH(NODE)>75
DO BREAK
QUIT
+5 if $Y+3>IOSL
DO HDR
if QFLG
QUIT
WRITE !?4,NODE
End DoDot:1
+6 QUIT
+7 ;
BREAK ;Break up text lines greater than 75
+1 SET CNT=1
SET LIM=$LENGTH(NODE)/75
IF LIM["."
SET LIM=$PIECE(LIM,".")+1
+2 FOR LINE=1:1:LIM
if $Y+3>IOSL
DO HDR
if QFLG
QUIT
WRITE !?4,$EXTRACT(NODE,CNT,CNT+74)
SET CNT=CNT+75
+3 QUIT
+4 ;
LOOKUP1 ;Lookup by patient name/ssn
+1 WRITE !
KILL DFN,ICN
+2 SET DIC="^DPT("
SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
DO ^DIC
KILL DIC
+3 if Y<0
QUIT
+4 SET DFN=+Y
+5 SET ICN=+$PIECE($GET(^DPT(DFN,"MPI")),U)
IF 'ICN
WRITE !!,"This patient does not have an ICN!"
KILL DFN,ICN
+6 QUIT
+7 ;
LOOKUP2 ;Lookup by ICN
+1 WRITE !
KILL DFN,ICN
+2 SET DIR(0)="N:1:999999999999:0"
SET DIR("A")="Select ICN"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+3 SET ICN=Y
SET DFN=$$GETDFN^MPIF001(ICN)
+4 IF +DFN<0
WRITE !!,"No patient match can be found for this ICN!"
KILL DFN,ICN
QUIT
+5 WRITE " ",$PIECE(^DPT(DFN,0),"^")
+6 QUIT
