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

GMRCDST.m

Go to the documentation of this file.
  1. GMRCDST ;ABV/BL - Retrieve Decision from DST server;May 21, 2020@07:06:12
  1. ;;3.0;CONSULT/REQUEST TRACKING;**124,139,152,145,177**;DEC 27, 1997;Build 4
  1. ;
  1. ;SAC EXEMPTION 20200131-01 : GMRC use of vendor specific code
  1. ;IA6173
  1. ;IA6171
  1. ;
  1. PROT(MSG) ;GMRC SIGNED CONSULT DST-PROTOCOL ENTRY POINT
  1. ;
  1. ;Extract Order Number FROM THE ORC SEGMENT
  1. N GMRCMSG,GMRCPKG,MSH,ORC,IEN123,SIGN,ORA,X,SIGNED,DUP
  1. S GMRCMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@GMRCMSG@(0))
  1. S MSH=0 F S MSH=$O(@GMRCMSG@(MSH)) Q:MSH'>0 Q:$E(@GMRCMSG@(MSH),1,3)="MSH"
  1. Q:'MSH Q:'$L($G(@GMRCMSG@(MSH)))
  1. ;
  1. S ORC=MSH F S ORC=$O(@GMRCMSG@(+ORC)) Q:ORC'>0 I $E(@GMRCMSG@(ORC),1,3)="ORC" D
  1. . S ORC=ORC_U_@GMRCMSG@(ORC)
  1. . S ORIFN=+$P($P(ORC,"|",3),";")
  1. ;GET THE CONSULT IEN FROM THE ORDER
  1. S IEN123=0,X=$G(^OR(100,ORIFN,4)) I $P(X,";",2)="GMRC" S IEN123=+X
  1. I IEN123="" Q "-1^No Consult found"
  1. ;QUIT IF ORDER IS NOT SIGNED
  1. S ORA=0,SIGN=0,SIGNED=0
  1. F S ORA=$O(^OR(100,ORIFN,8,ORA)) Q:+ORA'=ORA!(SIGNED) D
  1. . S SIGN=$P(^OR(100,ORIFN,8,ORA,0),"^",6)
  1. . I SIGN>0 S SIGNED=1
  1. Q:SIGNED=0 "-1^ORDER NOT SIGNED"
  1. ;
  1. ;Need the DUZ of user from Order file for Autoforward
  1. K GMRCORNP
  1. S GMRCORNP=$$GET1^DIQ(100,ORIFN,3,"I")
  1. S ID=$$FINDIDO(ORIFN)
  1. I ID="" Q "-1^NO DST ID FOUND"
  1. I $P(ID,"^")="-1" Q "-1^NO DST DATA FOUND"
  1. ;Check if this DST Note has been added to the consult already
  1. ;is there an existing comment on the consult, check for duplicate ID
  1. S DUP=0
  1. I $D(^GMR(123,IEN123,40,0)) S DUP=$$DUPID(IEN123,ID)
  1. I DUP Q "-1^DST NOTE ALREADY ADDED TO CONSULT"
  1. ;
  1. Q $$GETDST(IEN123,ID)
  1. ;
  1. DUPID(IEN123,ID) ;Check to see if this ID has already been entered into the consult
  1. ;
  1. N CNODE,CINC,DUP,NOTEID,EDATA
  1. S DUP=0,CNODE=0,EDATA=0
  1. I IEN123="" Q DUP
  1. F S CNODE=$O(^GMR(123,IEN123,40,CNODE)) Q:+CNODE'=CNODE!(DUP) D
  1. . S CINC=0
  1. . F S CINC=$O(^GMR(123,IEN123,40,CNODE,1,CINC)) Q:CINC=""!(DUP) D
  1. . . I ^GMR(123,IEN123,40,CNODE,1,CINC,0)["CSC-Consult primary stop code:" S EDATA=1
  1. . . I ^GMR(123,IEN123,40,CNODE,1,CINC,0)["DST ID:" D
  1. . . . S NOTEID=""
  1. . . . S NOTEID=$P(^GMR(123,IEN123,40,CNODE,1,CINC,0),"DST ID:",2)
  1. . . . I NOTEID[ID S DUP=1
  1. ;Check if we have already loaded DST data
  1. ;If DUP is positive but EDATA=0 no data is actually loaded, set DUP to 0
  1. I 'EDATA S DUP=0
  1. Q DUP
  1. ;
  1. GETDST(IEN123,ID) ;
  1. ;This API retrieves the decision data from the DST database using ID
  1. ;Input:
  1. ; IEN123 The IEN of file #123
  1. ; ID The DST ID
  1. ;Output:
  1. ; If decision data not found: -1^No decision data found
  1. ; If decision data found: 1
  1. ;
  1. ;Autoforwarding variables added
  1. ; AFOR: Indicator of Autoforward value = DAF-DST Forwarding:
  1. ; APAY: Name of consult service from file 123.5 to forward to
  1. ;
  1. N A,B,CAPTIONS,COM,COMCT,DATA,I,SERVER,SERVICE,RESOURCE,REQUEST,RESPONSE,RESULT,RET,X,ERRFLG
  1. K NUMERR
  1. S ERRFLG=0,NUMERR=0
  1. S SERVER="DST GET ID SERVER"
  1. S SERVICE="DST GET ID SERVICE"
  1. I ID=0 Q "-1^NO VALID ID SUBMITTED"
  1. S RESOURCE="/"_ID
  1. ; Get an instance of the REST request object.
  1. S REQUEST=$$GETREST^XOBWLIB(SERVICE,SERVER)
  1. S REQUEST.Timeout=60
  1. S REQUEST.OpenTimeout=30
  1. ;
  1. TRYAG ; Execute the HTTP Get method.
  1. K XUERR,RESPJSON,AFOR,APAY,GMRCSS
  1. K COM ; WCJ;GMRC*3.0*177
  1. S ERRFLG=0 ; WCJ;GMRC*3.0*177
  1. S AFOR=0,APAY="" ;Set variable to check for AutoForward
  1. S RESULT=$$GET^XOBWLIB(REQUEST,RESOURCE,.XUERR,0)
  1. I 'RESULT D
  1. . S COM(1)="DVE-DST Error from VistA:" ;NEED TO WRITE ERROR TO 123 FILE
  1. . S COM(2)=XUERR.code
  1. . I XUERR["Http" S COM(3)=XUERR.statusLine
  1. . I XUERR["ObjectError" S COM(3)=XUERR.domain,COM(4)=XUERR.errorType
  1. . S ERRFLG=1,NUMERR=NUMERR+1
  1. ;If the ERRFLG then store the error in the consult
  1. I ERRFLG&(NUMERR<10) H 2 G TRYAG
  1. I ERRFLG D CMT^GMRCGUIB(IEN123,.COM,"",DT,DUZ) Q 0
  1. ; Process the response.
  1. S RESPONSE=REQUEST.HttpResponse
  1. S DATA=RESPONSE.Data
  1. ;code is not really in JSON format, not changing variable names
  1. S RESPJSON=""
  1. F Q:DATA.AtEnd Set RESPJSON=RESPJSON_DATA.ReadLine()
  1. S RESPJSON=$TR(RESPJSON,$C(10),"")
  1. ;current data is blob of text with ^ delimited fields. Put each field on its own line
  1. F I=1:1:$L(RESPJSON,"^") D
  1. . S COM(I)=$P(RESPJSON,"^",I)
  1. . I COM(I)="" K COM(I) Q ;BL;152 need to quit before checking for Autoforward
  1. . ;check for autoforwarding GMRC*3.0*139
  1. . I COM(I)["DAF-DST Forwarding:" D
  1. . . I $P(COM(I),":",2)["YES" S AFOR=1
  1. . I COM(I)["AFD-DST Forward to" D
  1. . . S APAY=$P(COM(I),":",2)
  1. . . I $E(APAY,1)=" " S APAY=$E(APAY,2,$L(APAY)) ;REMOVE LEADING SPACE FOR FORWARDED CONSULT
  1. ;If we have data in the COM array store in the Note, other wise quit with an error
  1. I $D(COM) D
  1. . ;COM ARRAY IS EXPECTED TO BE SERIALLY NUMBERED
  1. . N TCOM,COMNUM,I
  1. . S COMNUM="",I=0
  1. . F S COMNUM=$O(COM(COMNUM)) Q:COMNUM="" D
  1. . . S I=I+1
  1. . . S TCOM(I)=COM(COMNUM)
  1. . ;Add autoforward message to data stream
  1. . I AFOR S TCOM(I+1)="Consult forwarded by DST"
  1. . ;
  1. . K COM
  1. . M COM=TCOM
  1. . K TCOM
  1. ;Need to make sure the Autoforward Service exists
  1. I AFOR D
  1. . ;Check for APAY being populated if not change AFOR and log an error
  1. . I APAY="" D Q
  1. . . S AFOR=0
  1. . . S COM(I+1)="DVE-DST Error from VistA: No Autoforward Target"
  1. . ;Get Forwarding Service
  1. . S GMRCSS="" S GMRCSS=$O(^GMR(123.5,"B",APAY,GMRCSS))
  1. . Q:GMRCSS'=""
  1. . ;The forwarding service did not exist. Log error in msg, stop autoforward
  1. . S AFOR=0
  1. . S I="A" S I=$O(COM(I),-1)
  1. . S COM(I+1)="DVE-DST Error from VistA: Autoforward target not found"
  1. I $D(COM) D Q 1
  1. . I 'AFOR D CMT^GMRCGUIB(IEN123,.COM,"",DT,DUZ) Q
  1. . I AFOR D AFORT(IEN123,APAY,.COM,GMRCSS,GMRCORNP) Q
  1. I '$D(COM) S COM(1)="DVE-DST ID ISSUE: No Content sent from DST"
  1. D CMT^GMRCGUIB(IEN123,.COM,"",DT,DUZ) Q 1
  1. Q
  1. ;
  1. FINDIDO(ORIFN) ;
  1. ;1. Find IEN of consult record
  1. ;2. See if DST ID is in new field added by CPRS in GMRC*3.0*145 (file (#123), field (#85))
  1. ;3. If DST ID not found in 2. call $$FINDID45 to retrieve DST ID from the #100,#4.5 (RESPONSES multiple)
  1. ;4. If DST ID not found in 3. call $$FINDIDC to retrieve DST ID from #123,#20 (REASON FOR REQUEST)
  1. ;5. Call $$GETDST to retrieve Decision data from DST database and save it as a comment
  1. ;
  1. ;Input: ORIFN=IEN of file #100
  1. ;Output:
  1. ; 1=DST ID found, decision data retrieved, and comment created in the consult record
  1. ; -1^No Decision data found
  1. ;
  1. N ID,IEN123,X
  1. S IEN123=0,X=$G(^OR(100,ORIFN,4)) I $P(X,";",2)="GMRC" S IEN123=+X
  1. Q:'IEN123 "-1^No Decision data found"
  1. ;
  1. ;WCJ;GMRC*3.0*145;check if CPRS put it in the new field(#85) in the consult file(#123)
  1. N ERROR ; just for kicks - don't really need returned error.
  1. S ID=$TR($$GET1^DIQ(123,IEN123_",",85,,,"ERROR")," ","")
  1. ;
  1. I ID="" S ID=$$FINDID45(ORIFN) ;Next search for the DST ID in field #100,#4.5 (RESPONSES)
  1. ;Having not found the ID in the #100,#4.5 field, now look for it in the consult
  1. I ID="" S ID=$$FINDIDC(IEN123)
  1. ;remove space
  1. S ID=$TR(ID," ","")
  1. I ID="" Q "-1^No Decision data found"
  1. Q ID
  1. ;Q $$GETDST(IEN123,ID)
  1. ;
  1. FINDID45(ORIFN) ;
  1. ;This API searches through the #4.5 (RESPONSES) multiple in file #100 for the DST ID
  1. ;Input: ORIFN=IEN in file #100
  1. ;Output: DST ID or ""
  1. ;
  1. N I,ID,IENS,N,N1,N2,OUT,STR,X,Y
  1. S ID="",IENS=ORIFN_","
  1. K OUT D GETS^DIQ(100,IENS,"4.5*","","OUT")
  1. S N="" F S N=$O(OUT(100.045,N)) Q:N="" S (N1,STR)="" D
  1. . F S N1=$O(OUT(100.045,N,N1)) Q:N1="" S STR=STR_OUT(100.045,N,N1) D
  1. .. S N2="" F S N2=$O(OUT(100.045,N,N1,N2)) Q:N2="" S STR=STR_OUT(100.045,N,N1,N2)
  1. . I STR["DST ID:" D
  1. . . S STR=$P(STR,"DST ID:",2)
  1. . . S STR=$P(STR,"--",1) ;After refactoring str includes dashes at the end
  1. . . F I=1:1:$L(STR) S Y=$E(STR,I) Q:Y="#" S ID=ID_Y
  1. Q ID
  1. ;
  1. FINDIDC(IEN123) ;
  1. ;This API searches FILE #123, FIELD #20 (REASON FOR REQUEST)looking for a
  1. ;"DST ID:" tag and, if found, will extract the DST ID and call API
  1. ;$$GETDST to retrieve the decision data from the DST database and create
  1. ;a comment in the consult containing the decision data
  1. ;
  1. ;Input: IEN123 IEN of file #123
  1. ;Output: DST ID or ""
  1. ;
  1. N I,ID,IENS,N,OUT,X,Y
  1. S ID="",IENS=IEN123_","
  1. K OUT D GETS^DIQ(123,IENS,"20","","OUT")
  1. S N="" F S N=$O(OUT(123,IENS,20,N)) Q:N="" S X=OUT(123,IENS,20,N) D:X["DST ID:"
  1. .S X=$P(X,"DST ID:",2) F I=1:1:$L(X) S Y=$E(X,I) Q:Y="#" S ID=ID_Y
  1. Q ID
  1. ;
  1. ;
  1. ;Post Install to add DST web server/service
  1. EN ;
  1. N FDA ; -- FileMan Data Array
  1. N WEBVICE ; -- Web Service Internal Entry Number
  1. N WEBVER ; -- Web Server Internal Entry Number
  1. N MULTIEN ; -- Web Service Multiple Internal Entry Number
  1. N WSTAT ; -- Web Service Status
  1. N IENROOT,MSGROOT,IENROOT1,VICEIEN
  1. ;
  1. K FDA
  1. S WEBVICE=$O(^XOB(18.02,"B","DST GET ID SERVICE",0))
  1. S WEBVICE=$S(WEBVICE:WEBVICE,1:"+1")
  1. S FDA(18.02,WEBVICE_",",.01)="DST GET ID SERVICE" ; NAME
  1. S FDA(18.02,WEBVICE_",",.02)="REST" ; TYPE
  1. S FDA(18.02,WEBVICE_",",200)="vs/v1/consultFactor" ; CONTEXT ROOT
  1. D UPDATE^DIE("E","FDA","IENROOT","MSGROOT")
  1. K IENROOT,MSGROOT,FDA
  1. ;
  1. S WEBVER=$O(^XOB(18.12,"B","DST GET ID SERVER",0))
  1. S WEBVER=$S(WEBVER:WEBVER,1:"+1")
  1. S FDA(18.12,WEBVER_",",.01)="DST GET ID SERVER" ; NAME
  1. S FDA(18.12,WEBVER_",",.03)="443" ; PORT
  1. S FDA(18.12,WEBVER_",",.04)="dst-dev.domain.ext" ; SERVER
  1. S FDA(18.12,WEBVER_",",.06)="ENABLED" ; STATUS 1-ENABLED / 0-DISABLED
  1. S FDA(18.12,WEBVER_",",.07)=60 ; DEFAULT HTTP TIMEOUT
  1. S FDA(18.12,WEBVER_",",1.01)="NO" ; LOGIN REQUIRED
  1. S FDA(18.12,WEBVER_",",3.01)="FALSE" ; SSL ENABLED
  1. ;Need to determine if we are creating a new file, or updating an existing one
  1. N NEW
  1. S NEW=1
  1. I $D(^XOB(18.12,WEBVER,0)) S NEW=0
  1. I NEW=1 D
  1. . D UPDATE^DIE("E","FDA","IENROOT","MSGROOT")
  1. I NEW=0 D
  1. . D FILE^DIE("E","FDA","MSGROOT")
  1. ;
  1. ;
  1. S IENROOT1=$G(IENROOT(1)),MULTIEN=0
  1. ;
  1. S WEBVER=$S(IENROOT1:IENROOT1,1:WEBVER)
  1. K IENROOT,MSGROOT,FDA
  1. S VICEIEN=0 F S VICEIEN=$O(^XOB(18.12,WEBVER,100,"B",VICEIEN)) Q:'VICEIEN I $$GET1^DIQ(18.02,VICEIEN,.01)="DST GET ID SERVICE" S MULTIEN=VICEIEN Q
  1. S MULTIEN=$S(MULTIEN:MULTIEN,1:"+1")
  1. S FDA(18.121,MULTIEN_","_WEBVER_",",.01)="DST GET ID SERVICE" ; WEB SERVICE
  1. S FDA(18.121,MULTIEN_","_WEBVER_",",.06)="ENABLED" ; STATUS 1-ENABLED / 0-DISABLED
  1. D UPDATE^DIE("E","FDA","IENROOT","MSGROOT")
  1. ;
  1. SPROT ;Set protocol GMRC SIGNED CONSULT DST as an item on GMRC EVSEND OR
  1. ;
  1. N GMRDGIEN,GMRERR,GMREXIT,GMRFDA,GMRIEN,GMRRTCL,J,PRTCLITM,V,X,Y
  1. ;
  1. D MES^XPDUTL($T(+0)_" post-init routine started "_$$HTE^XLFDT($H))
  1. S V=$$SVDATA D MES^XPDUTL("Old data saved in "_V)
  1. S GMRRTCL="GMRC SIGNED CONSULT DST",GMRIEN=$O(^ORD(101,"B",GMRRTCL,0))
  1. ; protocol missing, write message and exit
  1. I '(GMRIEN>0) D MES^XPDUTL(GMRRTCL_" protocol not found. It must be installed to proceed.") Q
  1. ;
  1. S Y="GMRC EVSEND OR",GMRDGIEN=$O(^ORD(101,"B",Y,0))
  1. ; protocol missing, write message and exit
  1. I '(GMRDGIEN>0) D MES^XPDUTL(Y_" protocol not found. No ITEM update performed.") Q
  1. ; make GMRC EVSEND OR an extended action
  1. S GMRFDA(101,GMRDGIEN_",",4)="X"
  1. D UPDATE^DIE("","GMRFDA","","GMRERR")
  1. I $D(GMRERR) D Q ; something went wrong
  1. .D MES^XPDUTL("FileMan error when editing GMRC EVSEND OR protocol")
  1. .N V S V="GMRERR" F S V=$Q(@V) Q:V="" D MES^XPDUTL(V_" = "_@V)
  1. ;
  1. ; is protocol already an item?
  1. S GMREXIT=$O(^ORD(101,GMRDGIEN,10,"B",GMRIEN,0))
  1. I GMREXIT D MES^XPDUTL(GMRRTCL_" already an ITEM in "_Y_". No update needed.") Q
  1. ;
  1. ; add protocol as ITEM
  1. K GMRFDA,GMRERR
  1. S GMRFDA(101.01,"+1,"_GMRDGIEN_",",.01)=GMRIEN
  1. D UPDATE^DIE("","GMRFDA","PRTCLITM","GMRERR")
  1. I $D(GMRERR) D Q ; something went wrong
  1. .D MES^XPDUTL("FileMan error when adding ITEM to GMRC EVSEND OR protocol")
  1. .N V S V="GMRERR" F S V=$Q(@V) Q:V="" D MES^XPDUTL(V_" = "_@V)
  1. ; new ITEM sub-file IEN will be in PRTCLITM(1)
  1. D MES^XPDUTL(GMRRTCL_" protocol update finished "_$$HTE^XLFDT($H))
  1. ;
  1. Q
  1. ;
  1. SVDATA() ; extrinsic variable, save original FileMan data, returns storage node
  1. ;
  1. D DT^DICRW
  1. N FMERRCNT,GMRXTMP,GMRIEN,LN,NTRY,TXT,V,X,Y
  1. ;S Y=$$NOW^XLFDT,GMRXTMP=$NA(^XTMP("GMR INSTALL LOG",Y)) ; XTMP storage location
  1. S Y=$$NOW^XLFDT,GMRXTMP=$NA(^XTMP("GMR INSTALL LOG "_Y)) ; XTMP storage location
  1. ; ^XTMP log data expires in 90 days
  1. S X=$G(@GMRXTMP@(0)) S:X="" @GMRXTMP@(0)=$$FMADD^XLFDT(DT,90)_U_Y_"^GMR installation "_$$FMTE^XLFDT(Y)
  1. ;
  1. S FMERRCNT=0 ; FileMan error counter
  1. ; save entries in FileMan items list
  1. F LN=1:1 S TXT=$P($T(FMITMS+LN),";;",2,99) Q:TXT="" D
  1. .N FLNO,FMARRY,FMERR ; file #, FileMan returned value and error message arrays
  1. .S FLNO=+$P(TXT,U),X=$P(TXT,U,2,99) ; file number and target entry
  1. .Q:'(FLNO>1)!(X="") ; file and entry required
  1. .S GMRIEN=$$FIND1^DIC(FLNO,"","",X,"","","FMERR") ; lookup value in X is external format
  1. .I $D(FMERR) D Q ; log error message and quit
  1. ..S V="FMERR",FMERRCNT=FMERRCNT+1 F S V=$Q(@V) Q:V="" S @GMRXTMP@("FM LOOKUP ERROR",FMERRCNT,V)=@V
  1. .;
  1. .S:'(GMRIEN>0) FMERRCNT=FMERRCNT+1,@GMRXTMP@("FM ENTRY NOT FOUND",FMERRCNT)=TXT ; entry
  1. .S:GMRIEN>0 @GMRXTMP@("ENTRY",FLNO,GMRIEN)="entry found"
  1. .K FMERR ; just in case
  1. .D GETS^DIQ(FLNO,GMRIEN_",","**","EN","FMARRY","FMERR") ; data including sub-files, ignore null values
  1. .I $D(FMERR) D ; log error message
  1. ..S V="FMERR",FMERRCNT=FMERRCNT+1 F S V=$Q(@V) Q:V="" S @GMRXTMP@("FM DATA ERROR",FMERRCNT,V)=@V
  1. .; save the data
  1. .M @GMRXTMP@("ENTRY")=FMARRY
  1. ;
  1. Q GMRXTMP ; return ^XTMP storage location
  1. ;
  1. FMITMS ; list of FileMan entries: "file # ^ .01 field value"
  1. ;;101^GMRC EVSEND OR
  1. ;
  1. Q
  1. AFORT(IEN123,APAY,COM,GMRCSS,GMRCORNP) ; Entry point for AutoForwarding of a consult
  1. ;requires the Name of the consult we are forwarding too
  1. ;IEN123 - IEN of consult from File 123
  1. ;GMRCSS - Service to which consult is being forwarded
  1. ;GMRCATTN - Provider whose attention consult is sent to. Can be "" or pointer to File 200
  1. ;GMRCURGI - Urgency of the request from the 123 file pointing to the 101 file
  1. ;GMRCORNP - Person who is responsible for forwarding the consult
  1. ;COM is the comments array explaining the forwarding action from DST
  1. ; passed in as COM(1)="Xxxx Xxxxx...",COM(2)="Xxxx Xx Xxx...", COM(3)="Xxxxx Xxx Xx...", etc.
  1. K GMRCATTN,ORDATE,GMRCURGI
  1. S GMRCATTN="",ORDATE=""
  1. S GMRCURGI=$P(^GMR(123,IEN123,0),"^",9)
  1. S Y=$$FR^GMRCGUIA(IEN123,GMRCSS,GMRCORNP,GMRCATTN,GMRCURGI,.COM,ORDATE)
  1. Q