MAGTLRD ;WOIFO/CD - RPC MAG TELER UPDATES ; 20 Jul, 2023@14:36:03
;;3.0;IMAGING;**356**;Mar 19, 2002;Build 8
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
;
; RPC: MAG TELER UPDATES
;
; Return the latest updates to IFC consults. Used by the VAEC-based TeleReader Proxy
; Service to scope and QA its description of TeleHealth IFCs.
;
; Input Values
; ============
; [FROM] Date to start from in FileMan format.
; Maximum is 90 days back from NOW.
; Default is 90 days back from NOW.
; [SRVCS] Filter of relevant services.
; 0 or more IENs of entries from file 123.5, delimited with ;
; Default is no filtering.
; [MAX] Maximum number of entries to return.
; Default and maximum is 1000.
;
; Return Value
; ============
; REPLY(1) holds information about the reply:
; Count^Count SRVCS Filtered^Count Action Filtered^FROM^Last Date Seen^MORE
; where MORE is 1 if there are more entries available after Last Date Seen.
;
; REPLY(2...N) each hold an update for a particular consult.
;
CNSLTS(REPLY,FROM,SRVCS,MAX) ;RPC [MAG TELER UPDATES]
N DT90,DTD,FLDS,SCRN,ACTDT,ACQSNO,ACQID,SIEN,ACTTYP,ACTSTS,CNT,RCNT,SKIP1,SKIP2,MORE,X,Y,IN,OUT,ERR,IEN
S DT90=$$FMADD^XLFDT($$NOW^XLFDT,-90,0,0,0)
S FROM=$G(FROM,DT90)
S DTD=$$FMDIFF^XLFDT($$NOW^XLFDT,FROM,1)
S:DTD>90 FROM=DT90
S SRVCS=$G(SRVCS,"")
S MAX=$G(MAX,1000)
S:MAX>1000 MAX=1000
S FLDS="IXI;.06;.07I;1I"
S SCRN="I ($P($G(^(12)),U,5)=""F"")"
D LIST^DIC("123",,FLDS,,$S(SRVCS:"",1:MAX),FROM,,"ASTATUS",.SCRN,,"OUT","ERR")
S ACTDT=""
S CNT=0
S RCNT=1
S SKIP1=0
S SKIP2=0
S MORE=0
F X=1:1 S Y=$P(SRVCS,",",X) Q:Y="" S SRVCS(Y)=""
N IN S IN="" F S IN=$O(OUT("DILIST",2,IN)) Q:IN=""!(CNT=MAX) D
. S ACTDT=OUT("DILIST","ID",IN,0,1)
. S ACQSNO=$P($G(^DIC(4,OUT("DILIST","ID",IN,.07),99)),U)
. S SIEN=OUT("DILIST","ID",IN,1)
. S CNT=CNT+1
. I SRVCS,'$D(SRVCS(SIEN)) S SKIP1=SKIP1+1 Q
. S IEN=OUT("DILIST",2,IN)
. S ACQID=OUT("DILIST","ID",IN,.06)
. S ACTTYP=OUT("DILIST","ID",IN,0,2)
. I ACTTYP="REMOTE REQUEST RECEIVED" S RCNT=RCNT+1 S REPLY(RCNT)=$$RECREQ(IEN,ACTDT,ACQSNO,ACQID)
. E D
. . S ACTSTS=$S(ACTTYP="DISCONTINUED":"DISCONTINUED",ACTTYP="COMPLETE/UPDATE":"COMPLETE",ACTTYP="CANCELLED":"CANCELLED",ACTTYP="RECEIVED":"ACTIVE",1:"")
. . I ACTSTS="" S SKIP2=SKIP2+1 Q
. . S RCNT=RCNT+1 S REPLY(RCNT)=$$OTHACT(IEN,ACTDT,ACQSNO,ACQID,ACTSTS,SIEN)
S REPLY(1)=CNT_U_SKIP1_U_SKIP2_U_FROM_U_ACTDT_U_$S(CNT=MAX:1,1:0)
Q
;
; Receive Request - NEW includes patient information and core of consult
;
RECREQ(IEN,ACTDT,ACQSNO,ACQID) ;Receive Request
;
; Note: 507 has SECID of Remote Provider for Cerner Providers not yet taken as not
; available from vista to vista
;
N FLDS,OUT,CNS,PIEN,PAT,PICN,TZ,NACTS,SRL,URG
S FLDS=".02;.126;1;3;5"
D GETS^DIQ(123,IEN_",",FLDS,"IE","OUT")
M CNS=OUT(123,IEN_",")
Q:$G(CNS(.02,"I"))="" "PENDING"
K OUT
S FLDS=".01;.09"
D GETS^DIQ(2,CNS(.02,"I")_",",FLDS,"E","OUT")
M PAT=OUT(2,CNS(.02,"I")_",")
S PICN=$$GETICN^MPIF001(CNS(.02,"I"))
K OUT
D GETS^DIQ(123.02,"1,"_IEN_",",".23","E","OUT")
S TZ=OUT(123.02,"1,"_IEN_",",.23,"E")
S NACTS=$P($G(^GMR(123,IEN,40,0)),U,4)
S URG=$P($G(CNS(5,"E")),"GMRCURGENCY - ",2)
S SRL="PENDING^"_IEN_U_ACTDT_U_NACTS_"^REMOTE^"_$G(PAT(.01,"E"))_"|"_$G(PAT(.09,"E"))_"|"_PICN_"|"_CNS(.02,"I")
S SRL=SRL_U_ACQID_U_ACQSNO_U_$G(CNS(.126,"I"))_U_$G(CNS(1,"E"))_"|"_$G(CNS(1,"I"))_U_$G(CNS(3,"I"))_"|"_TZ
S SRL=SRL_U_URG
Q SRL
;
OTHACT(IEN,ACTDT,ACQSNO,ACQID,STS,SIEN) ;All other than RECEIVE REQUEST
N MIEN,AIEN,FLDS,OUT,ACT,NACTS,SNAME,SRL
S MIEN=$O(^GMR(123,IEN,40,"B",ACTDT,0))
S AIEN=MIEN_","_IEN ; should be 1,IEN
S FLDS=".22;.23;2;3"
D GETS^DIQ(123.02,AIEN_",",FLDS,"IE","OUT")
M ACT=OUT(123.02,AIEN_",")
S NACTS=$P($G(^GMR(123,IEN,40,0)),U,4)
S SNAME=$P($G(^GMR(123.5,SIEN,0)),U)
S SRL=STS_U_IEN_U_ACTDT_U_NACTS
S SRL=SRL_U_$S($L(ACT(3,"I")):"LOCAL"_U_ACT(3,"E")_"|"_$P($G(^VA(200,ACT(3,"I"),205)),U)_"|"_ACT(3,"I"),1:"REMOTE"_U_ACT(.22,"I"))
S SRL=SRL_U_SNAME_U_ACQID_U_ACQSNO
Q SRL
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGTLRD 5102 printed Dec 13, 2024@02:08:37 Page 2
MAGTLRD ;WOIFO/CD - RPC MAG TELER UPDATES ; 20 Jul, 2023@14:36:03
+1 ;;3.0;IMAGING;**356**;Mar 19, 2002;Build 8
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 QUIT
+18 ;
+19 ; RPC: MAG TELER UPDATES
+20 ;
+21 ; Return the latest updates to IFC consults. Used by the VAEC-based TeleReader Proxy
+22 ; Service to scope and QA its description of TeleHealth IFCs.
+23 ;
+24 ; Input Values
+25 ; ============
+26 ; [FROM] Date to start from in FileMan format.
+27 ; Maximum is 90 days back from NOW.
+28 ; Default is 90 days back from NOW.
+29 ; [SRVCS] Filter of relevant services.
+30 ; 0 or more IENs of entries from file 123.5, delimited with ;
+31 ; Default is no filtering.
+32 ; [MAX] Maximum number of entries to return.
+33 ; Default and maximum is 1000.
+34 ;
+35 ; Return Value
+36 ; ============
+37 ; REPLY(1) holds information about the reply:
+38 ; Count^Count SRVCS Filtered^Count Action Filtered^FROM^Last Date Seen^MORE
+39 ; where MORE is 1 if there are more entries available after Last Date Seen.
+40 ;
+41 ; REPLY(2...N) each hold an update for a particular consult.
+42 ;
CNSLTS(REPLY,FROM,SRVCS,MAX) ;RPC [MAG TELER UPDATES]
+1 NEW DT90,DTD,FLDS,SCRN,ACTDT,ACQSNO,ACQID,SIEN,ACTTYP,ACTSTS,CNT,RCNT,SKIP1,SKIP2,MORE,X,Y,IN,OUT,ERR,IEN
+2 SET DT90=$$FMADD^XLFDT($$NOW^XLFDT,-90,0,0,0)
+3 SET FROM=$GET(FROM,DT90)
+4 SET DTD=$$FMDIFF^XLFDT($$NOW^XLFDT,FROM,1)
+5 if DTD>90
SET FROM=DT90
+6 SET SRVCS=$GET(SRVCS,"")
+7 SET MAX=$GET(MAX,1000)
+8 if MAX>1000
SET MAX=1000
+9 SET FLDS="IXI;.06;.07I;1I"
+10 SET SCRN="I ($P($G(^(12)),U,5)=""F"")"
+11 DO LIST^DIC("123",,FLDS,,$SELECT(SRVCS:"",1:MAX),FROM,,"ASTATUS",.SCRN,,"OUT","ERR")
+12 SET ACTDT=""
+13 SET CNT=0
+14 SET RCNT=1
+15 SET SKIP1=0
+16 SET SKIP2=0
+17 SET MORE=0
+18 FOR X=1:1
SET Y=$PIECE(SRVCS,",",X)
if Y=""
QUIT
SET SRVCS(Y)=""
+19 NEW IN
SET IN=""
FOR
SET IN=$ORDER(OUT("DILIST",2,IN))
if IN=""!(CNT=MAX)
QUIT
Begin DoDot:1
+20 SET ACTDT=OUT("DILIST","ID",IN,0,1)
+21 SET ACQSNO=$PIECE($GET(^DIC(4,OUT("DILIST","ID",IN,.07),99)),U)
+22 SET SIEN=OUT("DILIST","ID",IN,1)
+23 SET CNT=CNT+1
+24 IF SRVCS
IF '$DATA(SRVCS(SIEN))
SET SKIP1=SKIP1+1
QUIT
+25 SET IEN=OUT("DILIST",2,IN)
+26 SET ACQID=OUT("DILIST","ID",IN,.06)
+27 SET ACTTYP=OUT("DILIST","ID",IN,0,2)
+28 IF ACTTYP="REMOTE REQUEST RECEIVED"
SET RCNT=RCNT+1
SET REPLY(RCNT)=$$RECREQ(IEN,ACTDT,ACQSNO,ACQID)
+29 IF '$TEST
Begin DoDot:2
+30 SET ACTSTS=$SELECT(ACTTYP="DISCONTINUED":"DISCONTINUED",ACTTYP="COMPLETE/UPDATE":"COMPLETE",ACTTYP="CANCELLED":"CANCELLED",ACTTYP="RECEIVED":"ACTIVE",1:"")
+31 IF ACTSTS=""
SET SKIP2=SKIP2+1
QUIT
+32 SET RCNT=RCNT+1
SET REPLY(RCNT)=$$OTHACT(IEN,ACTDT,ACQSNO,ACQID,ACTSTS,SIEN)
End DoDot:2
End DoDot:1
+33 SET REPLY(1)=CNT_U_SKIP1_U_SKIP2_U_FROM_U_ACTDT_U_$SELECT(CNT=MAX:1,1:0)
+34 QUIT
+35 ;
+36 ; Receive Request - NEW includes patient information and core of consult
+37 ;
RECREQ(IEN,ACTDT,ACQSNO,ACQID) ;Receive Request
+1 ;
+2 ; Note: 507 has SECID of Remote Provider for Cerner Providers not yet taken as not
+3 ; available from vista to vista
+4 ;
+5 NEW FLDS,OUT,CNS,PIEN,PAT,PICN,TZ,NACTS,SRL,URG
+6 SET FLDS=".02;.126;1;3;5"
+7 DO GETS^DIQ(123,IEN_",",FLDS,"IE","OUT")
+8 MERGE CNS=OUT(123,IEN_",")
+9 if $GET(CNS(.02,"I"))=""
QUIT "PENDING"
+10 KILL OUT
+11 SET FLDS=".01;.09"
+12 DO GETS^DIQ(2,CNS(.02,"I")_",",FLDS,"E","OUT")
+13 MERGE PAT=OUT(2,CNS(.02,"I")_",")
+14 SET PICN=$$GETICN^MPIF001(CNS(.02,"I"))
+15 KILL OUT
+16 DO GETS^DIQ(123.02,"1,"_IEN_",",".23","E","OUT")
+17 SET TZ=OUT(123.02,"1,"_IEN_",",.23,"E")
+18 SET NACTS=$PIECE($GET(^GMR(123,IEN,40,0)),U,4)
+19 SET URG=$PIECE($GET(CNS(5,"E")),"GMRCURGENCY - ",2)
+20 SET SRL="PENDING^"_IEN_U_ACTDT_U_NACTS_"^REMOTE^"_$GET(PAT(.01,"E"))_"|"_$GET(PAT(.09,"E"))_"|"_PICN_"|"_CNS(.02,"I")
+21 SET SRL=SRL_U_ACQID_U_ACQSNO_U_$GET(CNS(.126,"I"))_U_$GET(CNS(1,"E"))_"|"_$GET(CNS(1,"I"))_U_$GET(CNS(3,"I"))_"|"_TZ
+22 SET SRL=SRL_U_URG
+23 QUIT SRL
+24 ;
OTHACT(IEN,ACTDT,ACQSNO,ACQID,STS,SIEN) ;All other than RECEIVE REQUEST
+1 NEW MIEN,AIEN,FLDS,OUT,ACT,NACTS,SNAME,SRL
+2 SET MIEN=$ORDER(^GMR(123,IEN,40,"B",ACTDT,0))
+3 ; should be 1,IEN
SET AIEN=MIEN_","_IEN
+4 SET FLDS=".22;.23;2;3"
+5 DO GETS^DIQ(123.02,AIEN_",",FLDS,"IE","OUT")
+6 MERGE ACT=OUT(123.02,AIEN_",")
+7 SET NACTS=$PIECE($GET(^GMR(123,IEN,40,0)),U,4)
+8 SET SNAME=$PIECE($GET(^GMR(123.5,SIEN,0)),U)
+9 SET SRL=STS_U_IEN_U_ACTDT_U_NACTS
+10 SET SRL=SRL_U_$SELECT($LENGTH(ACT(3,"I")):"LOCAL"_U_ACT(3,"E")_"|"_$PIECE($GET(^VA(200,ACT(3,"I"),205)),U)_"|"_ACT(3,"I"),1:"REMOTE"_U_ACT(.22,"I"))
+11 SET SRL=SRL_U_SNAME_U_ACQID_U_ACQSNO
+12 QUIT SRL
+13 ;
