- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLRS1 9224 printed Feb 19, 2025@00:01:52 Page 2
- 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