Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAHLRS1

RAHLRS1.m

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