RAHLRS1 ;HIRMFO/ROB/PAVEL/GJC - Resend HL7 messages for selected Timeframe ; 10/27/08 11:01
;;5.0;Radiology/Nuclear Medicine;**80,84,95,47**;Mar 16, 1998;Build 21
; Utility to RESEND HL7 messages for selected Timeframe
;
;Integration Agreements
;----------------------
;^%DT(10003); C^%DTC(10000); H^%DTC(10000); ^%ZISC(10089); ^%ZTLOAD(10063); $$GET1^DIQ(2056)
;^DIR(10026); ^XMD(10070)
;all access to ^ORD(101 to maintain application specific protocols(872)
;read w/FileMan HL7 APPLICATION PARAMETER(10136)
;
N RACNI,RADFN,RADTI,RARPT,X,RAED,RABD,RASHBD,RASHED,RASHTD,RASHTM,DIC,DA,XX,YY
N RALOCK,RASSS,RASSSX,RASSSL,I,X S RALOCK=0
CHECK ;
D SETVARS Q:$G(RAIMGTY)=""
W !!,"This option re-sends HL7 messages for a date range and for designated Recipients.",!
W !,"It is strongly recommended you task this to run off hours.",!!
S:'$D(U) U="^" S:'$D(DTIME) DTIME=9999
1 W ! K %DT S %DT="AEX",%DT("A")="Beginning Date: " D ^%DT
G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP
S RABD=Y
X ^DD("DD") S RASHBD=Y
S X1=RABD,X2=-1 D C^%DTC S RABD=X
S RABD=RABD_"."_9999
;
W ! K %DT S %DT="AEX",%DT("A")="Ending Date: ",%DT("B")="NOW" D ^%DT
G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP
S RAED=Y
X ^DD("DD") S RASHED=Y
S RAED=RAED_"."_9999
K XX G:'$$GETAP(.XX) STOP
W !!,"*** Pick the application in which to send the radiology data ***",!!
F I=1:1 Q:'$D(XX(I)) W !," #",I," ",$O(XX(I,""))
2 ;user selects the application
S DIR(0)="N^1:"_(I-1)
W ! S DIR("?")="Please select an available application from the list."
D ^DIR Q:$D(DIRUT)
W !!,"The: ",$O(XX(+X,""))," will be the recipient"
W !!,"Reviewing exams for selected time period... (This may take a few minutes)... "
S Y=$$GETSUM(RABD,RAED)
I 'Y W !!,"No exams exist for selected period, change the time frame !!!" H 3 W ! G 1
W !!,"During this period of time ",Y," Exams were performed and app Run time= ",Y\5000," Hours."
S RAPICK=$O(XX(+X,"")) ;appl. recipient name, RA*5*95
S RASSS(XX(X,$O(XX(+X,""))))="" D GETSUB(.RASSS,.RASSSX,.RASSSL)
K ZTSAVE
S ZTSAVE("RAOPT(")="" ;RAOPT("RESEND DT") set/killed in entry/exit action fields on option p47
S ZTSAVE("RAPICK")="" ;include appl. recipient name in task, RA*5*95
S ZTSAVE("RASSSX(")="",ZTSAVE("RASSSL(")="",ZTSAVE("RABD")="",ZTSAVE("RAED")="",ZTSAVE("RADFN")=""
S ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RASHBD")="",ZTSAVE("RASHED")="",ZTIO=""
S ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="TM^RAHLRS1"
W ! K %DT S %DT="AEXT",%DT("A")="Scheduled time to run: ",%DT("B")="TODAY@23:59" D ^%DT
G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP
S X=Y,YY=Y D H^%DTC S ZTDTH=$G(%H)_","_$G(%T)
S Y=YY X ^DD("DD") S RASHTM=Y
D ^%ZTLOAD
W !,"Task ",$S('$D(ZTSK):" Has Not been Tasked !!!",1:"#:"_ZTSK_" Has been Tasked")
D:$D(ZTSK)
.N RAX,RAMPG,XMSUB,XMY,XMTEXT
.S RAX(1)="Task #"_$G(ZTSK)_" is scheduled to run the option: "
.S RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<"
.S RAX(3)=" Scheduled time to run: "_RASHTM
.S RAX(4)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED)
.S XMSUB="TASKMAN SCHEDULE NOTIFICATION/INFO"
.S RAMPG="G.RAD HL7 MESSAGES"
.S XMY(RAMPG)="",XMDUZ=.5
.S XMTEXT="RAX("
.D ^XMD
Q
;
TM ;Taskman Entry...
N RASTIME,RASUM7,RASUM7R,RASUM7E
S RASTIME=$H,(RASUM7,RASUM7R,RASUM7E)=0
F S RABD=$O(^RADPT("AR",RABD)) Q:'RABD!(RABD>RAED) D
.S RADFN=0 F S RADFN=$O(^RADPT("AR",RABD,RADFN)) Q:'RADFN D
..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D
...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D RESEND(RADFN,RADTI,RACNI)
K RAX S RAX(1)="Task #"_$G(ZTSK)_" successfully completed the option: "
S RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<"
S RAX(3)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED)
S RAX(4)="# Of RAD Reports transferred: "_$G(RASUM7R)
S RAX(5)="# Of Exams transferred: "_$G(RASUM7)
S:$G(RASUM7E) X(6)="# Of Exams not transferred because of ""BAD DATA"": "_$G(RASUM7E)
S XMSUB="TASKMAN ""RESEND HL7 OPTION"" COMPLETED/INFO"
S RAMPG="G.RAD HL7 MESSAGES"
S XMY(RAMPG)="",XMDUZ=.5
S XMTEXT="RAX("
D ^XMD
G STOP
Q
;
RESEND(RADFN,RADTI,RACNI) ; re-send exam message(s) to HL7 subscribers
; for every 10 messages sent, make sure queue is not clogged... $$HANG
N RAXAMP80 S RAXAMP80=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
I '(+$P(RAXAMP80,U))!'($P(RAXAMP80,U,2)) S RASUM7E=RASUM7E+1 Q
N RABD,RAEDP80,QUIT,RARPST ;added RARPST, RA*5*95
;
I '$D(DT) D ^%DT S DT=Y
;
S RAEDP80=$$RAED(RADFN,RADTI,RACNI)
I '$L(RAEDP80) S RASUM7E=RASUM7E+1 Q
D:RAEDP80[",REG,"
.D CHSUM N RASUM7,RASUM7R,RASUM7E D REG^RAHLRPC
D:RAEDP80[",CANCEL,"
.D CHSUM N RASUM7,RASUM7R,RASUM7E D CANCEL^RAHLRPC
D:RAEDP80[",EXAM,"
.D CHSUM
.S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",30)="" ;Reset sent flag
.N RASUM7,RAEXMDUN,RASUM7R,RASUM7E D 1^RAHLRPC
;if EF report and recipient is VR, then don't re-send, RA*5*95
I RARPST="EF",((RAPICK["RA-TALK")!(RAPICK["RA-PSCRIBE")!(RAPICK["RA-SCIMAGE")!(RAPICK["RA-RADWHERE")) Q
D:RAEDP80[",RPT,"
.D CHSUM N RASUM7,RANOSEND,RASUM7R,RASUM7E,RARPT D RPT^RAHLRPC
Q
;
RAED(RADFN,RADTI,RACNI) ; identify correct ^RAHLRPC entry point(s)
;
N RASTAT,RAIMTYP,RAORD,RETURN,RARPT
S RASTAT=""
;
S RETURN=",REG,"
;
S RASTAT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,3,"I")
S RARPT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,17,"I")
;
S RAIMTYP=$$GET1^DIQ(72,+RASTAT,7) Q:'$L(RAIMTYP) ""
S RAORD=$$GET1^DIQ(72,+RASTAT,3)
;
S:RAORD=0 RETURN=RETURN_"CANCEL,"
;
S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," ; Generate Examined HL7 Message
;
D:RETURN'[",EXAM,"
.; also check previous statuses for 'Generate Examined HL7 Message'
.F S RAORD=$O(^RA(72,"AA",RAIMTYP,RAORD),-1) Q:+RAORD<1 D Q:RETURN[",EXAM,"
..S RASTAT=$O(^RA(72,"AA",RAIMTYP,RAORD,0))
..S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM,"
;
; Check if Verified or Elec. Filed report exists ;RA*5*95
S RARPST=$$GET1^DIQ(74,RARPT_",",5,"I")
I RARPT]"",("^V^EF^"[("^"_RARPST_"^")) S RETURN=RETURN_"RPT,",RASUM7R=RASUM7R+1
;
Q RETURN
;
SETVARS ; Setup key Rad/Nuc Med variables
;
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0)
Q:'($D(RACCESS(DUZ))\10) ; user does not have location access
I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) K:$G(RAIMGTY)="" XQUIT
Q
STOP ;
D ^%ZISC
Q
;
GETAP(XX) ;
;Get list of Applications in XX
N XXX,X11,X1,X2,X3,Z,Z1,J
F X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D
.S X1=$E(X11,1,$L(X11)-1)_$C($A($E(X11,$L(X11)))-1)
.F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D
..K Z S X3=0 F S X3=$O(^ORD(101,X2,775,X3)) Q:'X3 S Z(+^(X3,0))=""
..Q:'$D(Z) K Z1 S X3=0 F S X3=$O(Z(X3)) Q:'X3 D
...S Z1=$G(^ORD(101,X3,770)) S:+$P(Z1,U,2) XXX(+$P(Z1,U,2))=""
S X1=0 F J=1:1 S X1=$O(XXX(X1)) Q:'X1 D
.N DIERR,RAERR,Y
.S Y=$$GET1^DIQ(771,X1,.01,"","","RAERR")
.Q:Y=""!($D(RAERR)#2) S XX(J,Y)=X1
.Q
Q $S($D(XXX):1,1:0)
;
GETSUB(APL,SUB,LINK) ;Get all subscribers (not associated with application)... To be excluded as recipients..
; Get all logical links to be in business, so we can control flow of messages
;Set up SUB() of 4 Radiology protocol IENS in file #101 that
;are NOT associated with applications defined in APL()
;
;INPUT:
;APL(IEN) = Application #771 IENs
;
;OUTPUT:
;SUB(Event Driver #101 IEN,Subscriber #101 IEN)=.01 in file #101
;LINK(IEN of logical link #870)
;
N XX,X11,X1,X2,X3
Q:'$O(APL(0))
F X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D
.S X1=$E(X11,1,$L(X11)-1)_$C($A($E(X11,$L(X11)))-1)
.F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D
..S X3=0 F S X3=$O(^ORD(101,X2,775,X3)) Q:'X3 S XX=+^(X3,0) D
...I '$D(APL(+$P($G(^ORD(101,XX,770)),U,2))) S SUB(X2,XX)=X1 Q
...S XX=+$P($G(^ORD(101,XX,770)),U,7) S:XX LINK(XX)=""
Q
GETHLP(RAEID,HLP,ADR) ; Get excluded subcribers set into HLP array
N I,J,XX,AA S J=$O(HLP("EXCLUDE SUBSCRIBER",99999999),-1)
;XX Set the list of already excluded subscribers, so be sure we don't set it second time
S AA=ADR_"("_RAEID_",I)"
S I=0 F I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I S XX(HLP("EXCLUDE SUBSCRIBER",I))=""
S I=0 F S I=$O(@AA) Q:'I S:'$D(XX(I)) J=J+1,HLP("EXCLUDE SUBSCRIBER",J)=I
Q
CHSUM ;CHECKSUM
S RASUM7=RASUM7+1 I '(RASUM7#50) F Q:'$$HANG H 15
Q
HANG() ; scan all logical links to see if queue is bigger than 100
N I,S,L,QUIT
S (QUIT,L)=0
F S L=$O(RASSSL(L)) Q:'L S (S,I)=0 D Q:QUIT
.F S I=$O(^HLMA("AC","O",L,I)) Q:'I S S=S+1 I S>100 S QUIT=1 Q ;Quit if more than 100 messages waiting in outgoing queue for link...
Q QUIT
GETSUM(RABD,RAED) ; Get number of exams for period called from RAHLR RAHLR1 RAHLRPT RAHLRPT1
N RADFN,RADTI,RACNI,RASUM7
S RASUM7=0
F S RABD=$O(^RADPT("AR",RABD)) Q:'RABD!(RABD>RAED) D
.S RADFN=0 F S RADFN=$O(^RADPT("AR",RABD,RADFN)) Q:'RADFN D
..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D
...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI S:^(RACNI,0) RASUM7=RASUM7+1
Q RASUM7
Q
RAHLRS1 ;HIRMFO/ROB/PAVEL/GJC - Resend HL7 messages for selected Timeframe ; 10/27/08 11:01
+1 ;;5.0;Radiology/Nuclear Medicine;**80,84,95,47**;Mar 16, 1998;Build 21
+2 ; Utility to RESEND HL7 messages for selected Timeframe
+3 ;
+4 ;Integration Agreements
+5 ;----------------------
+6 ;^%DT(10003); C^%DTC(10000); H^%DTC(10000); ^%ZISC(10089); ^%ZTLOAD(10063); $$GET1^DIQ(2056)
+7 ;^DIR(10026); ^XMD(10070)
+8 ;all access to ^ORD(101 to maintain application specific protocols(872)
+9 ;read w/FileMan HL7 APPLICATION PARAMETER(10136)
+10 ;
+11 NEW RACNI,RADFN,RADTI,RARPT,X,RAED,RABD,RASHBD,RASHED,RASHTD,RASHTM,DIC,DA,XX,YY
+12 NEW RALOCK,RASSS,RASSSX,RASSSL,I,X
SET RALOCK=0
CHECK ;
+1 DO SETVARS
IF $GET(RAIMGTY)=""
QUIT
+2 WRITE !!,"This option re-sends HL7 messages for a date range and for designated Recipients.",!
+3 WRITE !,"It is strongly recommended you task this to run off hours.",!!
+4 IF '$DATA(U)
SET U="^"
IF '$DATA(DTIME)
SET DTIME=9999
1 WRITE !
KILL %DT
SET %DT="AEX"
SET %DT("A")="Beginning Date: "
DO ^%DT
+1 IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO STOP
+2 SET RABD=Y
+3 XECUTE ^DD("DD")
SET RASHBD=Y
+4 SET X1=RABD
SET X2=-1
DO C^%DTC
SET RABD=X
+5 SET RABD=RABD_"."_9999
+6 ;
+7 WRITE !
KILL %DT
SET %DT="AEX"
SET %DT("A")="Ending Date: "
SET %DT("B")="NOW"
DO ^%DT
+8 IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO STOP
+9 SET RAED=Y
+10 XECUTE ^DD("DD")
SET RASHED=Y
+11 SET RAED=RAED_"."_9999
+12 KILL XX
IF '$$GETAP(.XX)
GOTO STOP
+13 WRITE !!,"*** Pick the application in which to send the radiology data ***",!!
+14 FOR I=1:1
IF '$DATA(XX(I))
QUIT
WRITE !," #",I," ",$ORDER(XX(I,""))
2 ;user selects the application
+1 SET DIR(0)="N^1:"_(I-1)
+2 WRITE !
SET DIR("?")="Please select an available application from the list."
+3 DO ^DIR
IF $DATA(DIRUT)
QUIT
+4 WRITE !!,"The: ",$ORDER(XX(+X,""))," will be the recipient"
+5 WRITE !!,"Reviewing exams for selected time period... (This may take a few minutes)... "
+6 SET Y=$$GETSUM(RABD,RAED)
+7 IF 'Y
WRITE !!,"No exams exist for selected period, change the time frame !!!"
HANG 3
WRITE !
GOTO 1
+8 WRITE !!,"During this period of time ",Y," Exams were performed and app Run time= ",Y\5000," Hours."
+9 ;appl. recipient name, RA*5*95
SET RAPICK=$ORDER(XX(+X,""))
+10 SET RASSS(XX(X,$ORDER(XX(+X,""))))=""
DO GETSUB(.RASSS,.RASSSX,.RASSSL)
+11 KILL ZTSAVE
+12 ;RAOPT("RESEND DT") set/killed in entry/exit action fields on option p47
SET ZTSAVE("RAOPT(")=""
+13 ;include appl. recipient name in task, RA*5*95
SET ZTSAVE("RAPICK")=""
+14 SET ZTSAVE("RASSSX(")=""
SET ZTSAVE("RASSSL(")=""
SET ZTSAVE("RABD")=""
SET ZTSAVE("RAED")=""
SET ZTSAVE("RADFN")=""
+15 SET ZTSAVE("RADTI")=""
SET ZTSAVE("RACNI")=""
SET ZTSAVE("RASHBD")=""
SET ZTSAVE("RASHED")=""
SET ZTIO=""
+16 SET ZTDESC="Rad/Nuc Med Compiling HL7 Common Order"
SET ZTRTN="TM^RAHLRS1"
+17 WRITE !
KILL %DT
SET %DT="AEXT"
SET %DT("A")="Scheduled time to run: "
SET %DT("B")="TODAY@23:59"
DO ^%DT
+18 IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO STOP
+19 SET X=Y
SET YY=Y
DO H^%DTC
SET ZTDTH=$GET(%H)_","_$GET(%T)
+20 SET Y=YY
XECUTE ^DD("DD")
SET RASHTM=Y
+21 DO ^%ZTLOAD
+22 WRITE !,"Task ",$SELECT('$DATA(ZTSK):" Has Not been Tasked !!!",1:"#:"_ZTSK_" Has been Tasked")
+23 IF $DATA(ZTSK)
Begin DoDot:1
+24 NEW RAX,RAMPG,XMSUB,XMY,XMTEXT
+25 SET RAX(1)="Task #"_$GET(ZTSK)_" is scheduled to run the option: "
+26 SET RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<"
+27 SET RAX(3)=" Scheduled time to run: "_RASHTM
+28 SET RAX(4)="Date range from: "_$GET(RASHBD)_" to: "_$GET(RASHED)
+29 SET XMSUB="TASKMAN SCHEDULE NOTIFICATION/INFO"
+30 SET RAMPG="G.RAD HL7 MESSAGES"
+31 SET XMY(RAMPG)=""
SET XMDUZ=.5
+32 SET XMTEXT="RAX("
+33 DO ^XMD
End DoDot:1
+34 QUIT
+35 ;
TM ;Taskman Entry...
+1 NEW RASTIME,RASUM7,RASUM7R,RASUM7E
+2 SET RASTIME=$HOROLOG
SET (RASUM7,RASUM7R,RASUM7E)=0
+3 FOR
SET RABD=$ORDER(^RADPT("AR",RABD))
IF 'RABD!(RABD>RAED)
QUIT
Begin DoDot:1
+4 SET RADFN=0
FOR
SET RADFN=$ORDER(^RADPT("AR",RABD,RADFN))
IF 'RADFN
QUIT
Begin DoDot:2
+5 SET RADTI=0
FOR
SET RADTI=$ORDER(^RADPT("AR",RABD,RADFN,RADTI))
IF 'RADTI
QUIT
Begin DoDot:3
+6 SET RACNI=0
FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF 'RACNI
QUIT
DO RESEND(RADFN,RADTI,RACNI)
End DoDot:3
End DoDot:2
End DoDot:1
+7 KILL RAX
SET RAX(1)="Task #"_$GET(ZTSK)_" successfully completed the option: "
+8 SET RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<"
+9 SET RAX(3)="Date range from: "_$GET(RASHBD)_" to: "_$GET(RASHED)
+10 SET RAX(4)="# Of RAD Reports transferred: "_$GET(RASUM7R)
+11 SET RAX(5)="# Of Exams transferred: "_$GET(RASUM7)
+12 IF $GET(RASUM7E)
SET X(6)="# Of Exams not transferred because of ""BAD DATA"": "_$GET(RASUM7E)
+13 SET XMSUB="TASKMAN ""RESEND HL7 OPTION"" COMPLETED/INFO"
+14 SET RAMPG="G.RAD HL7 MESSAGES"
+15 SET XMY(RAMPG)=""
SET XMDUZ=.5
+16 SET XMTEXT="RAX("
+17 DO ^XMD
+18 GOTO STOP
+19 QUIT
+20 ;
RESEND(RADFN,RADTI,RACNI) ; re-send exam message(s) to HL7 subscribers
+1 ; for every 10 messages sent, make sure queue is not clogged... $$HANG
+2 NEW RAXAMP80
SET RAXAMP80=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+3 IF '(+$PIECE(RAXAMP80,U))!'($PIECE(RAXAMP80,U,2))
SET RASUM7E=RASUM7E+1
QUIT
+4 ;added RARPST, RA*5*95
NEW RABD,RAEDP80,QUIT,RARPST
+5 ;
+6 IF '$DATA(DT)
DO ^%DT
SET DT=Y
+7 ;
+8 SET RAEDP80=$$RAED(RADFN,RADTI,RACNI)
+9 IF '$LENGTH(RAEDP80)
SET RASUM7E=RASUM7E+1
QUIT
+10 IF RAEDP80[",REG,"
Begin DoDot:1
+11 DO CHSUM
NEW RASUM7,RASUM7R,RASUM7E
DO REG^RAHLRPC
End DoDot:1
+12 IF RAEDP80[",CANCEL,"
Begin DoDot:1
+13 DO CHSUM
NEW RASUM7,RASUM7R,RASUM7E
DO CANCEL^RAHLRPC
End DoDot:1
+14 IF RAEDP80[",EXAM,"
Begin DoDot:1
+15 DO CHSUM
+16 ;Reset sent flag
SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",30)=""
+17 NEW RASUM7,RAEXMDUN,RASUM7R,RASUM7E
DO 1^RAHLRPC
End DoDot:1
+18 ;if EF report and recipient is VR, then don't re-send, RA*5*95
+19 IF RARPST="EF"
IF ((RAPICK["RA-TALK")!(RAPICK["RA-PSCRIBE")!(RAPICK["RA-SCIMAGE")!(RAPICK["RA-RADWHERE"))
QUIT
+20 IF RAEDP80[",RPT,"
Begin DoDot:1
+21 DO CHSUM
NEW RASUM7,RANOSEND,RASUM7R,RASUM7E,RARPT
DO RPT^RAHLRPC
End DoDot:1
+22 QUIT
+23 ;
RAED(RADFN,RADTI,RACNI) ; identify correct ^RAHLRPC entry point(s)
+1 ;
+2 NEW RASTAT,RAIMTYP,RAORD,RETURN,RARPT
+3 SET RASTAT=""
+4 ;
+5 SET RETURN=",REG,"
+6 ;
+7 SET RASTAT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,3,"I")
+8 SET RARPT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,17,"I")
+9 ;
+10 SET RAIMTYP=$$GET1^DIQ(72,+RASTAT,7)
IF '$LENGTH(RAIMTYP)
QUIT ""
+11 SET RAORD=$$GET1^DIQ(72,+RASTAT,3)
+12 ;
+13 IF RAORD=0
SET RETURN=RETURN_"CANCEL,"
+14 ;
+15 ; Generate Examined HL7 Message
IF $$GET1^DIQ(72,+RASTAT,8)="YES"
SET RETURN=RETURN_"EXAM,"
+16 ;
+17 IF RETURN'[",EXAM,"
Begin DoDot:1
+18 ; also check previous statuses for 'Generate Examined HL7 Message'
+19 FOR
SET RAORD=$ORDER(^RA(72,"AA",RAIMTYP,RAORD),-1)
IF +RAORD<1
QUIT
Begin DoDot:2
+20 SET RASTAT=$ORDER(^RA(72,"AA",RAIMTYP,RAORD,0))
+21 IF $$GET1^DIQ(72,+RASTAT,8)="YES"
SET RETURN=RETURN_"EXAM,"
End DoDot:2
IF RETURN[",EXAM,"
QUIT
End DoDot:1
+22 ;
+23 ; Check if Verified or Elec. Filed report exists ;RA*5*95
+24 SET RARPST=$$GET1^DIQ(74,RARPT_",",5,"I")
+25 IF RARPT]""
IF ("^V^EF^"[("^"_RARPST_"^"))
SET RETURN=RETURN_"RPT,"
SET RASUM7R=RASUM7R+1
+26 ;
+27 QUIT RETURN
+28 ;
SETVARS ; Setup key Rad/Nuc Med variables
+1 ;
+2 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
+3 ; user does not have location access
IF '($DATA(RACCESS(DUZ))\10)
QUIT
+4 IF $GET(RAIMGTY)=""
DO SETVARS^RAPSET1(1)
IF $GET(RAIMGTY)=""
KILL XQUIT
+5 QUIT
STOP ;
+1 DO ^%ZISC
+2 QUIT
+3 ;
GETAP(XX) ;
+1 ;Get list of Applications in XX
+2 NEW XXX,X11,X1,X2,X3,Z,Z1,J
+3 FOR X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT"
Begin DoDot:1
+4 SET X1=$EXTRACT(X11,1,$LENGTH(X11)-1)_$CHAR($ASCII($EXTRACT(X11,$LENGTH(X11)))-1)
+5 FOR
SET X1=$ORDER(^ORD(101,"B",X1))
IF X1'[X11
QUIT
SET X2=$ORDER(^ORD(101,"B",X1,0))
IF 'X2
QUIT
Begin DoDot:2
+6 KILL Z
SET X3=0
FOR
SET X3=$ORDER(^ORD(101,X2,775,X3))
IF 'X3
QUIT
SET Z(+^(X3,0))=""
+7 IF '$DATA(Z)
QUIT
KILL Z1
SET X3=0
FOR
SET X3=$ORDER(Z(X3))
IF 'X3
QUIT
Begin DoDot:3
+8 SET Z1=$GET(^ORD(101,X3,770))
IF +$PIECE(Z1,U,2)
SET XXX(+$PIECE(Z1,U,2))=""
End DoDot:3
End DoDot:2
End DoDot:1
+9 SET X1=0
FOR J=1:1
SET X1=$ORDER(XXX(X1))
IF 'X1
QUIT
Begin DoDot:1
+10 NEW DIERR,RAERR,Y
+11 SET Y=$$GET1^DIQ(771,X1,.01,"","","RAERR")
+12 IF Y=""!($DATA(RAERR)#2)
QUIT
SET XX(J,Y)=X1
+13 QUIT
End DoDot:1
+14 QUIT $SELECT($DATA(XXX):1,1:0)
+15 ;
GETSUB(APL,SUB,LINK) ;Get all subscribers (not associated with application)... To be excluded as recipients..
+1 ; Get all logical links to be in business, so we can control flow of messages
+2 ;Set up SUB() of 4 Radiology protocol IENS in file #101 that
+3 ;are NOT associated with applications defined in APL()
+4 ;
+5 ;INPUT:
+6 ;APL(IEN) = Application #771 IENs
+7 ;
+8 ;OUTPUT:
+9 ;SUB(Event Driver #101 IEN,Subscriber #101 IEN)=.01 in file #101
+10 ;LINK(IEN of logical link #870)
+11 ;
+12 NEW XX,X11,X1,X2,X3
+13 IF '$ORDER(APL(0))
QUIT
+14 FOR X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT"
Begin DoDot:1
+15 SET X1=$EXTRACT(X11,1,$LENGTH(X11)-1)_$CHAR($ASCII($EXTRACT(X11,$LENGTH(X11)))-1)
+16 FOR
SET X1=$ORDER(^ORD(101,"B",X1))
IF X1'[X11
QUIT
SET X2=$ORDER(^ORD(101,"B",X1,0))
IF 'X2
QUIT
Begin DoDot:2
+17 SET X3=0
FOR
SET X3=$ORDER(^ORD(101,X2,775,X3))
IF 'X3
QUIT
SET XX=+^(X3,0)
Begin DoDot:3
+18 IF '$DATA(APL(+$PIECE($GET(^ORD(101,XX,770)),U,2)))
SET SUB(X2,XX)=X1
QUIT
+19 SET XX=+$PIECE($GET(^ORD(101,XX,770)),U,7)
IF XX
SET LINK(XX)=""
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
GETHLP(RAEID,HLP,ADR) ; Get excluded subcribers set into HLP array
+1 NEW I,J,XX,AA
SET J=$ORDER(HLP("EXCLUDE SUBSCRIBER",99999999),-1)
+2 ;XX Set the list of already excluded subscribers, so be sure we don't set it second time
+3 SET AA=ADR_"("_RAEID_",I)"
+4 SET I=0
FOR I=$ORDER(HLP("EXCLUDE SUBSCRIBER",I))
IF 'I
QUIT
SET XX(HLP("EXCLUDE SUBSCRIBER",I))=""
+5 SET I=0
FOR
SET I=$ORDER(@AA)
IF 'I
QUIT
IF '$DATA(XX(I))
SET J=J+1
SET HLP("EXCLUDE SUBSCRIBER",J)=I
+6 QUIT
CHSUM ;CHECKSUM
+1 SET RASUM7=RASUM7+1
IF '(RASUM7#50)
FOR
IF '$$HANG
QUIT
HANG 15
+2 QUIT
HANG() ; scan all logical links to see if queue is bigger than 100
+1 NEW I,S,L,QUIT
+2 SET (QUIT,L)=0
+3 FOR
SET L=$ORDER(RASSSL(L))
IF 'L
QUIT
SET (S,I)=0
Begin DoDot:1
+4 ;Quit if more than 100 messages waiting in outgoing queue for link...
FOR
SET I=$ORDER(^HLMA("AC","O",L,I))
IF 'I
QUIT
SET S=S+1
IF S>100
SET QUIT=1
QUIT
End DoDot:1
IF QUIT
QUIT
+5 QUIT QUIT
GETSUM(RABD,RAED) ; Get number of exams for period called from RAHLR RAHLR1 RAHLRPT RAHLRPT1
+1 NEW RADFN,RADTI,RACNI,RASUM7
+2 SET RASUM7=0
+3 FOR
SET RABD=$ORDER(^RADPT("AR",RABD))
IF 'RABD!(RABD>RAED)
QUIT
Begin DoDot:1
+4 SET RADFN=0
FOR
SET RADFN=$ORDER(^RADPT("AR",RABD,RADFN))
IF 'RADFN
QUIT
Begin DoDot:2
+5 SET RADTI=0
FOR
SET RADTI=$ORDER(^RADPT("AR",RABD,RADFN,RADTI))
IF 'RADTI
QUIT
Begin DoDot:3
+6 SET RACNI=0
FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
IF 'RACNI
QUIT
IF ^(RACNI,0)
SET RASUM7=RASUM7+1
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT RASUM7
+8 QUIT
