- DVBAB1 ;ALB/SPH - CAPRI UTILITIES ; MAY 27, 2022@11:31am
- ;;2.7;AMIE;**35,37,50,42,53,57,73,104,109,137,146,143,179,238**;Apr 10, 1995;Build 16
- ;
- VERSION(ZMSG,DVBGUIV) ;
- ;
- ; --rpc: DVBAB VERSION
- ;
- ; Must have a letter at the end of the Version for Delphi compatibility.
- ; 1st piece is version description
- ; 2nd piece can be YESOLD or NOOLD
- ; YESOLD --> Allow old GUI to run with new KID
- ; NOOLD --> Do not allow old GUI to run with newer version
- ;
- ; Ex: "CAPRI GUI V2.7*123*0*A^NOOLD"
- ;
- ; Sets variables DVBABVR* so that the error trap will display what
- ; version of the client software the user was utilizing if CAPRI bombs.
- ; Patch 238 adds two N variables and the checking GUI version against minimum and previous versions
- ;
- N DVBVERS
- N DVBOLD
- N DVBPREV
- N DVBGUIC
- N DVBABVR1,DVBABVR2,DVBABVR3
- ;
- ;obtain version parameters and build version string result
- S DVBVERS=$$GET^XPAR("PKG","DVBAB CAPRI MINIMUM VERSION",1,"Q")
- S DVBOLD=$$GET^XPAR("PKG","DVBAB CAPRI ALLOW OLD VERSION",1,"Q")
- S ZMSG=DVBVERS_"^"_$S(DVBOLD=1:"YESOLD",1:"NOOLD")
- ;
- ;238-Checking GUI version against minimum and previous versions
- ;Strip preceding zero from minor build number and setting date to prevent other gui's
- I $G(DVBGUIV)'="" S DVBGUIC=DVBGUIV,$P(DVBGUIC,".",3)=+$P(DVBGUIC,".",3) D
- .I $P(ZMSG,"*",2)'=$P(DVBGUIC,"*",3) D
- ..S DVBPREV=$$GET^XPAR("PKG","DVBAB CAPRI PREVIOUS VERSION",1,"Q")
- ..I DVBPREV'="",($P(DVBGUIC,"*",3)'=$P(DVBPREV,"*",3)) D
- ...S $P(ZMSG,"*",5)=2800101
- ;
- ;set DVBABVR* vars for error trap
- S DVBABVR1="CAPRI Server Version: "_ZMSG
- S DVBABVR2="CAPRI GUI Version: "_$S($G(DVBGUIV)]"":DVBGUIV,1:"UNKNOWN")
- S DVBABVR3=$P(^VA(200,DUZ,0),"^",1)
- Q
- ;
- REQUESTS(Y,TYPE) ;
- ; TYPE is the internal value of field 17 in file 396.3
- ; This relates to which status of request should be returned
- N DVBABCNT,DVBABIEN
- S DVBABCNT=0,DVBABIEN=0
- F S DVBABIEN=$O(^DVB(396.3,DVBABIEN)) Q:'DVBABIEN D
- .S DVBABST=$P($G(^DVB(396.3,DVBABIEN,0)),"^",18)
- .I DVBABST=TYPE D
- ..S DVBABNM=$P($G(^DVB(396.3,DVBABIEN,0)),"^",1)
- ..S DVBABPT=DVBABNM
- ..I DVBABNM'="" S DVBABNM=$P($G(^DPT(DVBABNM,0)),"^",1)
- ..S DVBABDT=$$FMTE^XLFDT($P($G(^DVB(396.3,DVBABIEN,0)),"^",2),"2D")
- ..S DVBABWHO=$P($G(^DVB(396.3,DVBABIEN,0)),"^",4)
- ..I DVBABWHO'="" S DVBABWHO=$P($G(^VA(200,DVBABWHO,0)),"^",1)
- ..E S DVBABWHO="UNKNOWN"
- ..S DVBABRO=$P($G(^DVB(396.3,DVBABIEN,0)),"^",3)
- ..I DVBABRO'="" S DVBABRO=$P($G(^DIC(4,DVBABRO,0)),"^",1)
- ..E S DVBABRO="UNKNOWN"
- ..S ^TMP("DVBAREQ",DUZ,DVBABCNT)=DVBABST_"^"_DVBABPT_"^"_DVBABNM_"^"_DVBABDT_"^"_DVBABWHO_"^"_DVBABRO_"^"_DVBABIEN_$C(13),DVBABCNT=DVBABCNT+1
- S Y=$NA(^TMP("DVBAREQ",DUZ))
- K DVBABCNT,DVBABIEN,TYPE,DVBABNM,DVBABDT,DVBABST,DVBABWHO,DVBABPT
- Q
- TEAMPTS(DVBORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM
- ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
- ; global root string passed in ORY, and builds the returned
- ; list in that global instead of to a memory array.
- N DOTMP,NEWTMP,DVBSSN,DVBORI,DVBORPT,I
- K ^TMP("DVBATMPT",DUZ)
- S (I,DOTMP,DVBORI)=0
- I $G(TMPFLAG) D ; Was value passed?
- .I TMPFLAG S DOTMP=1 ; Is value TRUE?
- I +$G(TEAM)<1 D
- .I DOTMP S NEWTMP=DVBORY_1_")",@NEWTMP="^No team identified"
- .E S DVBORY(1)="^No team identified"
- F S DVBORI=$O(^OR(100.21,+TEAM,10,DVBORI)) Q:DVBORI<1 D
- .S DVBORPT=^OR(100.21,+TEAM,10,DVBORI,0)
- .I DOTMP D
- ..S I=I+1,NEWTMP=DVBORY_+I_")"
- ..S @NEWTMP=+DVBORPT_U_$P(^DPT(+DVBORPT,0),U)
- .S DVBSSN=$P($G(^DPT($P(DVBORPT,";",1),0)),U,9)
- .E S I=I+1,^TMP("DVBATMPT",DUZ,I)=+DVBORPT_U_$P(^DPT(+DVBORPT,0),U)_U_DVBSSN_$C(13)
- I DOTMP S:I<1 NEWTMP=DVBORY_1_")",@NEWTMP="^No patients found."
- E S:I<1 ^TMP("DVBATMPT",DUZ,1)="^No patients found."
- S DVBORY=$NA(^TMP("DVBATMPT",DUZ))
- Q
- DIVISION(Y) ; Returns Name for an Institution
- N DVBARR,DVBERR,DVBATP
- S Y=""
- Q:$G(DUZ(2))=""
- D GETS^DIQ(4,DUZ(2)_",0",".01","I","DVBARR","DVBERR")
- Q:$D(DVBERR)
- S Y=$G(DVBARR(4,DUZ(2)_",0,",.01,"I"))
- D GETS^DIQ(4,DUZ(2)_",0",13,"I","DVBARR","DVBERR")
- S DVBATP=$G(DVBARR(4,DUZ(2)_",0,",13,"I"))
- I DVBATP'="" S DVBATP=$P($G(^DIC(4.1,DVBATP,0)),"^",1)
- S Y=Y_"-"_DVBATP
- Q
- ;
- DT(Y,X1,X2) ; Returns date X1 minus X2 days
- ; change the '00:00' that could be passed so Fileman doesn't reject
- ;C^%DTC(X1,X2)
- ;S %DT=$G(%DT,"TS") D ^%DT
- ;K %DT,X1,X2
- ;Q
- DTTM(Y) ;
- S Y=$$HTE^XLFDT($H,"P")
- Q
- CHKCRED(Y) ;KLB
- S Y="[OK]"
- I '$D(DUZ(2)) S Y="Your division number is missing." Q
- I $D(DUZ)#2=0 S Y="Your user number is invalid." Q
- I +DUZ(2)<1 S Y="Invalid division."
- Q
- PTINQ(REF,DFN) ; Return formatted pt inquiry report
- K ^TMP("ORDATA",$J,1)
- ; DVBA*2.7*109 - Added $D to next line
- I ($D(^DPT(DFN,0))) D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)")
- S REF=$NA(^TMP("ORDATA",$J,1))
- Q
- TEMPLATE(Y) ; Returns list of CAPRI exam templates
- N DVBABCNT,DVBABIEN,DVBABNM,DVBABAD,DVBABDD,DVBABSL,DVBABOC
- K Y,^TMP("DVBALAB1",DUZ)
- S DVBABCNT=0,DVBABIEN=0
- F S DVBABIEN=$O(^DVB(396.18,DVBABIEN)) Q:'DVBABIEN D
- .S DVBABNM=$P($G(^DVB(396.18,DVBABIEN,0)),"^",1)
- .S DVBABAD=$P($G(^DVB(396.18,DVBABIEN,2)),"^",1)
- .S DVBABDD=$P($G(^DVB(396.18,DVBABIEN,2)),"^",2)
- .S DVBABSL=$P($G(^DVB(396.18,DVBABIEN,6)),"^",1)
- .S DVBABOC=$P($G(^DVB(396.18,DVBABIEN,6)),"^",2)
- .S ^TMP("DVBATMPL",DUZ,DVBABCNT)=DVBABNM_"^"_DVBABAD_"^"_DVBABDD_"^"_DVBABSL_"^"_DVBABOC_"^"_DVBABIEN_$C(13),DVBABCNT=DVBABCNT+1
- S Y=$NA(^TMP("DVBATMPL",DUZ))
- Q
- ;
- LABLIST(Y) ; Returns list of LAB TEST NAMES
- N DVBABCNT,DVBABIEN,DVBABLNM
- K Y,^TMP("DVBALAB1",DUZ)
- S DVBABCNT=0,DVBABIEN=0
- F S DVBABIEN=$O(^LAB(60,DVBABIEN)) Q:'DVBABIEN D
- .S DVBABLNM=$P($G(^LAB(60,DVBABIEN,0)),"^",1)
- .S ^TMP("DVBALAB1",DUZ,DVBABCNT)=DVBABLNM_"^"_DVBABIEN_$C(13),DVBABCNT=DVBABCNT+1
- S Y=$NA(^TMP("DVBALAB1",DUZ))
- Q
- ;
- INSTLIST(Y) ; Returns full list of Institutions
- N DVBABCNT,DVBABIEN,DVBABNM,DVBABSTN,DVBABST,DVBABDS,DVBARR,DVBERR,DVBATP
- K Y,^TMP("DVBAINST",$J,DUZ)
- S (DVBABCNT,DVBABIEN)=0
- F S DVBABIEN=$O(^DIC(4,DVBABIEN)) Q:'DVBABIEN D
- . K DVBARR,DVBERR
- . D GETS^DIQ(4,DVBABIEN_",0",".01:.02:.03:","I","DVBARR","DVBERR")
- . Q:$D(DVBERR)
- . S DVBABNM=$G(DVBARR(4,DVBABIEN_",0,",.01,"I"))
- . Q:DVBABNM=""
- . S DVBABSTN=$G(DVBARR(4,DVBABIEN_",0,",.02,"I"))
- . Q:DVBABSTN=""
- . S DVBABDS=$G(DVBARR(4,DVBABIEN_",0,",.03,"I"))
- . K DVBARR,DVBERR
- . D GETS^DIQ(5,DVBABSTN_",0",.01,"I","DVBARR","DVBERR")
- . Q:$D(DVBERR)
- . S DVBABST=$G(DVBARR(5,DVBABSTN_",0,",.01,"I"))
- . K DVBARR,DVBERR
- . D GETS^DIQ(4,DVBABIEN_",0",13,"I","DVBARR","DVBERR")
- . S DVBATP=$G(DVBARR(4,DVBABIEN_",0,",13,"I"))
- . I DVBATP'="" D
- .. S DVBATP=$P($G(^DIC(4.1,DVBATP,0)),"^",1)
- . S ^TMP("DVBAINST",$J,DUZ,DVBABCNT)=DVBABNM_"-"_DVBATP_"^"_DVBABST_"^"_DVBABDS_"^"_DVBABIEN_$C(13)
- . S DVBABCNT=DVBABCNT+1
- S Y=$NA(^TMP("DVBAINST",$J,DUZ))
- Q
- ;
- INCEXAM(ZMSG) ;Increased exam # in file and passes back the # to user
- S ZMSG=+$G(^DVB(396.1,1,5))+1
- S ^DVB(396.1,1,5)=ZMSG
- Q
- ;
- MSG(ERR,DUZ,XMSUB,XMTEXT,MGN,ID) ;Generate mail message;KLB
- ; --rpc: DVBAB SEND MSG
- ;
- ; This remote procedure is used to generate bulletins for specific CAPRI actions, such as cancellation of 2507 exams.
- ;
- ; Supported References:
- ; DBIA #10111: Allows FM read access of ^XMB(3.8,D0,0) using DIC.
- K ^TMP($J,"AMIE")
- S XMB="",XMDUZ=DUZ
- I '$D(DUZ) S ERR="MISSING DUZ" Q
- I '$D(XMSUB) S ERR="MISSING SUBJECT" Q
- I '$D(XMTEXT) S ERR="MISSING TEXT" Q
- I '$D(MGN) S ERR="MISSING MAIL GROUP NAME" Q
- ;IF MGN=DVBA C 2507 EXAM READY NO BULLETIN NECESSARY, BUILD THE EMAIL AND QUIT
- I MGN="DVBA C 2507 EXAM READY" D SENDMSG Q
- S J=0
- F S J=$O(XMTEXT(J)) Q:'J S ^TMP($J,"AMIE",J)=$G(XMTEXT(J))
- S XMTEXT="^TMP($J,""AMIE"","
- S DIC="^XMB(3.8,",DIC(0)="QM",X=MGN D ^DIC
- I +Y<0 S ERR="INVALID MAIL GROUP NAME" Q
- I '$$GOTLOCAL^XMXAPIG(MGN) S ERR="NO ACTIVE LOCAL MEMBERS IN MAIL GROUP" K ^TMP("XMERR",$J) Q
- I MGN="DVBA C NEW C&P VETERAN" S XMB="DVBA CAPRI NEW C&P VETERAN"
- I MGN="DVBA C 2507 CANCELLATION" S XMB="DVBA CAPRI 2507 CANCELLATION"
- I XMB="" S ERR="UNABLE TO SET BULLETIN" Q
- D ^XMB
- ;XMB = -1 if bulletin not found in file (#3.6)
- S ERR=$S(XMB=-1:"BULLETIN NOT FOUND",1:"MESSAGE SENT")
- ;before we quit, send a message to the requestor if the message is a cancellation
- I MGN="DVBA C 2507 CANCELLATION" D SENDMSG
- K XMSUB,XMTEXT,MGN,DIC,DIC(0),J,Y,XMDUZ,XMB
- Q
- FINDEXAM(ZMSG,ZIEN) ;Returns list of exams in 396.4 that are linked to ZIEN in 396.3
- N DVBABCNT,DVBABIEN
- S DVBABCNT=0,DVBABIEN=0
- F S DVBABIEN=$O(^DVB(396.4,"C",ZIEN,DVBABIEN)) Q:'DVBABIEN D
- .S DVBABD1=$P($G(^DVB(396.4,DVBABIEN,0)),"^",2)
- .S DVBABD2=$P($G(^DVB(396.6,+$P($G(^DVB(396.4,DVBABIEN,0)),"^",3),0)),"^",1) ;Name of Exam
- .S DVBABD3=$P($G(^DVB(396.4,DVBABIEN,0)),"^",4)
- .I DVBABD3="O" S DVBABD3="[OPEN]"
- .I DVBABD3="C" S DVBABD3="[COMPLETE]"
- .I DVBABD3="X" S DVBABD3="[CANCELED BY MAS]"
- .I DVBABD3="RX" S DVBABD3="[CANCELED BY RO]"
- .I DVBABD3="T" S DVBABD3="[TRANSFERRED OUT]"
- .I ZIEN=DVBABD1 D
- ..S ZMSG(DVBABCNT)=DVBABIEN_"^"_DVBABD2_" "_DVBABD3
- ..S DVBABCNT=DVBABCNT+1
- K DVBABCNT,DVBABIEN,ZIEN,DVBABD1,DVBABD2,DVBABD3
- Q
- SENDMSG ;SET UP TO SEND EMAIL/NOTIFICATION TO REQUESTOR OF 2507
- N DVBA0,DVBAREQ,DVBAEA,DVBAC,DVBAQUIT,DVBADFN,DVBASITE,DVBADT,DUZ
- N MSG,MERR,CTR,RIEN
- ;SINCE MAILMAN DOES NOT ALLOW MESSAGES TO BE SENT FROM USERS WITHOUT ACCESS CODES OR MAILBOXES
- ;WHICH CAPRI REMOTE USER DO NOT HAVE, WE HAVE TO NEW DUZ AND CHANGE XMDUZ TO THE NAME OF THE USER
- ;AS A STRING SO THE PROCESS IS STILL LINKED TO THE USER SENDING/TRIGGERING THE MESSAGE
- I $G(ID)="" Q
- S XMDUZ=$P(^VA(200,XMDUZ,0),"^",1)_" CAPRI"
- S DVBA0=$G(^DVB(396.3,ID,0))
- S DVBADFN=$P(DVBA0,"^",1),DVBAREQ=$P(DVBA0,"^",4),DVBADT=$$FMTE^XLFDT($P(DVBA0,"^",2))
- ;following call supported by IA 3858
- S DVBAEA=$P($G(^VA(200,DVBAREQ,.15)),"^",1)
- I DVBAEA'="" D
- . S XMY(DVBAEA)="",DVBASITE=$$SITE^VASITE
- . I MGN="DVBA C 2507 CANCELLATION" D CNCLMSG Q
- . I MGN="DVBA C 2507 EXAM READY" D RDYMSG Q
- Q
- CNCLMSG ;SEND CANCEL MESSAGE TO REQUESTOR OF THE 2507 EXAM
- ;need to loop through previously built text to make sure all PII is removed
- S J=0,DVBAQUIT=0
- F S J=$O(^TMP($J,"AMIE",J)) Q:'J!(DVBAQUIT) D
- .I $G(^TMP($J,"AMIE",J))["Name" S ^TMP($J,"AMIE",J)="DFN: `"_DVBADFN_" SITE: "_$P($G(DVBASITE),"^",2)_" Request Date: "_DVBADT
- .I $G(^TMP($J,"AMIE",J))["Additional Comments" D Q
- ..S ^TMP($J,"AMIE1",J)="**NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI"
- ..S ^TMP($J,"AMIE1",J+1)="Patient Selector 'Patient ID' field to find the patient. Be sure to include"
- ..S ^TMP($J,"AMIE1",J+2)="the ` (backward-apostrophe) character."
- ..S ^TMP($J,"AMIE1",J+3)=""
- ..S ^TMP($J,"AMIE1",J+4)=""
- ..S ^TMP($J,"AMIE1",J+4)=""
- ..S ^TMP($J,"AMIE1",J+5)="*****This is an auto-generated email. Do not respond to this email address.*****"
- ..S DVBAQUIT=1 Q
- .S ^TMP($J,"AMIE1",J)=$G(^TMP($J,"AMIE",J))
- S XMTEXT="^TMP($J,""AMIE1"","
- D ^XMD
- K ^TMP($J,"AMIE1")
- Q
- RDYMSG ;SEND EXAM COMPLETE MESSAGE TO REQUESTOR OF 2507
- ;no text/body is passed in so we have to build the message from scratch
- S ^TMP($J,"AMIE1",1)="A 2507 request as described below has been completed and released to the regional office , and is now available in CAPRI."
- S ^TMP($J,"AMIE1",2)=""
- S ^TMP($J,"AMIE1",3)=""
- S ^TMP($J,"AMIE1",4)=" DFN: `"_DVBADFN
- S ^TMP($J,"AMIE1",5)=" Vista Site: "_$P($G(DVBASITE),"^",2)
- S ^TMP($J,"AMIE1",6)=" Request Date: "_DVBADT
- S ^TMP($J,"AMIE1",7)=""
- S ^TMP($J,"AMIE1",8)=""
- S ^TMP($J,"AMIE1",9)="**NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI"
- S ^TMP($J,"AMIE1",10)="Patient Selector 'Patient ID' field to find the patient. Be sure to include"
- S ^TMP($J,"AMIE1",11)="the ` (backward-apostrophe) character."
- S ^TMP($J,"AMIE1",12)=""
- S ^TMP($J,"AMIE1",13)=""
- S ^TMP($J,"AMIE1",14)=""
- S ^TMP($J,"AMIE1",15)="*****This is an auto-generated email. Do not respond to this email address.*****"
- S XMTEXT="^TMP($J,""AMIE1"","
- D ^XMD
- K ^TMP($J,"AMIE1")
- K XMSUB,XMTEXT,MGN,XMDUZ
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB1 12256 printed Feb 18, 2025@23:06:41 Page 2
- DVBAB1 ;ALB/SPH - CAPRI UTILITIES ; MAY 27, 2022@11:31am
- +1 ;;2.7;AMIE;**35,37,50,42,53,57,73,104,109,137,146,143,179,238**;Apr 10, 1995;Build 16
- +2 ;
- VERSION(ZMSG,DVBGUIV) ;
- +1 ;
- +2 ; --rpc: DVBAB VERSION
- +3 ;
- +4 ; Must have a letter at the end of the Version for Delphi compatibility.
- +5 ; 1st piece is version description
- +6 ; 2nd piece can be YESOLD or NOOLD
- +7 ; YESOLD --> Allow old GUI to run with new KID
- +8 ; NOOLD --> Do not allow old GUI to run with newer version
- +9 ;
- +10 ; Ex: "CAPRI GUI V2.7*123*0*A^NOOLD"
- +11 ;
- +12 ; Sets variables DVBABVR* so that the error trap will display what
- +13 ; version of the client software the user was utilizing if CAPRI bombs.
- +14 ; Patch 238 adds two N variables and the checking GUI version against minimum and previous versions
- +15 ;
- +16 NEW DVBVERS
- +17 NEW DVBOLD
- +18 NEW DVBPREV
- +19 NEW DVBGUIC
- +20 NEW DVBABVR1,DVBABVR2,DVBABVR3
- +21 ;
- +22 ;obtain version parameters and build version string result
- +23 SET DVBVERS=$$GET^XPAR("PKG","DVBAB CAPRI MINIMUM VERSION",1,"Q")
- +24 SET DVBOLD=$$GET^XPAR("PKG","DVBAB CAPRI ALLOW OLD VERSION",1,"Q")
- +25 SET ZMSG=DVBVERS_"^"_$SELECT(DVBOLD=1:"YESOLD",1:"NOOLD")
- +26 ;
- +27 ;238-Checking GUI version against minimum and previous versions
- +28 ;Strip preceding zero from minor build number and setting date to prevent other gui's
- +29 IF $GET(DVBGUIV)'=""
- SET DVBGUIC=DVBGUIV
- SET $PIECE(DVBGUIC,".",3)=+$PIECE(DVBGUIC,".",3)
- Begin DoDot:1
- +30 IF $PIECE(ZMSG,"*",2)'=$PIECE(DVBGUIC,"*",3)
- Begin DoDot:2
- +31 SET DVBPREV=$$GET^XPAR("PKG","DVBAB CAPRI PREVIOUS VERSION",1,"Q")
- +32 IF DVBPREV'=""
- IF ($PIECE(DVBGUIC,"*",3)'=$PIECE(DVBPREV,"*",3))
- Begin DoDot:3
- +33 SET $PIECE(ZMSG,"*",5)=2800101
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +34 ;
- +35 ;set DVBABVR* vars for error trap
- +36 SET DVBABVR1="CAPRI Server Version: "_ZMSG
- +37 SET DVBABVR2="CAPRI GUI Version: "_$SELECT($GET(DVBGUIV)]"":DVBGUIV,1:"UNKNOWN")
- +38 SET DVBABVR3=$PIECE(^VA(200,DUZ,0),"^",1)
- +39 QUIT
- +40 ;
- REQUESTS(Y,TYPE) ;
- +1 ; TYPE is the internal value of field 17 in file 396.3
- +2 ; This relates to which status of request should be returned
- +3 NEW DVBABCNT,DVBABIEN
- +4 SET DVBABCNT=0
- SET DVBABIEN=0
- +5 FOR
- SET DVBABIEN=$ORDER(^DVB(396.3,DVBABIEN))
- if 'DVBABIEN
- QUIT
- Begin DoDot:1
- +6 SET DVBABST=$PIECE($GET(^DVB(396.3,DVBABIEN,0)),"^",18)
- +7 IF DVBABST=TYPE
- Begin DoDot:2
- +8 SET DVBABNM=$PIECE($GET(^DVB(396.3,DVBABIEN,0)),"^",1)
- +9 SET DVBABPT=DVBABNM
- +10 IF DVBABNM'=""
- SET DVBABNM=$PIECE($GET(^DPT(DVBABNM,0)),"^",1)
- +11 SET DVBABDT=$$FMTE^XLFDT($PIECE($GET(^DVB(396.3,DVBABIEN,0)),"^",2),"2D")
- +12 SET DVBABWHO=$PIECE($GET(^DVB(396.3,DVBABIEN,0)),"^",4)
- +13 IF DVBABWHO'=""
- SET DVBABWHO=$PIECE($GET(^VA(200,DVBABWHO,0)),"^",1)
- +14 IF '$TEST
- SET DVBABWHO="UNKNOWN"
- +15 SET DVBABRO=$PIECE($GET(^DVB(396.3,DVBABIEN,0)),"^",3)
- +16 IF DVBABRO'=""
- SET DVBABRO=$PIECE($GET(^DIC(4,DVBABRO,0)),"^",1)
- +17 IF '$TEST
- SET DVBABRO="UNKNOWN"
- +18 SET ^TMP("DVBAREQ",DUZ,DVBABCNT)=DVBABST_"^"_DVBABPT_"^"_DVBABNM_"^"_DVBABDT_"^"_DVBABWHO_"^"_DVBABRO_"^"_DVBABIEN_$CHAR(13)
- SET DVBABCNT=DVBABCNT+1
- End DoDot:2
- End DoDot:1
- +19 SET Y=$NAME(^TMP("DVBAREQ",DUZ))
- +20 KILL DVBABCNT,DVBABIEN,TYPE,DVBABNM,DVBABDT,DVBABST,DVBABWHO,DVBABPT
- +21 QUIT
- TEAMPTS(DVBORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM
- +1 ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx"
- +2 ; global root string passed in ORY, and builds the returned
- +3 ; list in that global instead of to a memory array.
- +4 NEW DOTMP,NEWTMP,DVBSSN,DVBORI,DVBORPT,I
- +5 KILL ^TMP("DVBATMPT",DUZ)
- +6 SET (I,DOTMP,DVBORI)=0
- +7 ; Was value passed?
- IF $GET(TMPFLAG)
- Begin DoDot:1
- +8 ; Is value TRUE?
- IF TMPFLAG
- SET DOTMP=1
- End DoDot:1
- +9 IF +$GET(TEAM)<1
- Begin DoDot:1
- +10 IF DOTMP
- SET NEWTMP=DVBORY_1_")"
- SET @NEWTMP="^No team identified"
- +11 IF '$TEST
- SET DVBORY(1)="^No team identified"
- End DoDot:1
- +12 FOR
- SET DVBORI=$ORDER(^OR(100.21,+TEAM,10,DVBORI))
- if DVBORI<1
- QUIT
- Begin DoDot:1
- +13 SET DVBORPT=^OR(100.21,+TEAM,10,DVBORI,0)
- +14 IF DOTMP
- Begin DoDot:2
- +15 SET I=I+1
- SET NEWTMP=DVBORY_+I_")"
- +16 SET @NEWTMP=+DVBORPT_U_$PIECE(^DPT(+DVBORPT,0),U)
- End DoDot:2
- +17 SET DVBSSN=$PIECE($GET(^DPT($PIECE(DVBORPT,";",1),0)),U,9)
- +18 IF '$TEST
- SET I=I+1
- SET ^TMP("DVBATMPT",DUZ,I)=+DVBORPT_U_$PIECE(^DPT(+DVBORPT,0),U)_U_DVBSSN_$CHAR(13)
- End DoDot:1
- +19 IF DOTMP
- if I<1
- SET NEWTMP=DVBORY_1_")"
- SET @NEWTMP="^No patients found."
- +20 IF '$TEST
- if I<1
- SET ^TMP("DVBATMPT",DUZ,1)="^No patients found."
- +21 SET DVBORY=$NAME(^TMP("DVBATMPT",DUZ))
- +22 QUIT
- DIVISION(Y) ; Returns Name for an Institution
- +1 NEW DVBARR,DVBERR,DVBATP
- +2 SET Y=""
- +3 if $GET(DUZ(2))=""
- QUIT
- +4 DO GETS^DIQ(4,DUZ(2)_",0",".01","I","DVBARR","DVBERR")
- +5 if $DATA(DVBERR)
- QUIT
- +6 SET Y=$GET(DVBARR(4,DUZ(2)_",0,",.01,"I"))
- +7 DO GETS^DIQ(4,DUZ(2)_",0",13,"I","DVBARR","DVBERR")
- +8 SET DVBATP=$GET(DVBARR(4,DUZ(2)_",0,",13,"I"))
- +9 IF DVBATP'=""
- SET DVBATP=$PIECE($GET(^DIC(4.1,DVBATP,0)),"^",1)
- +10 SET Y=Y_"-"_DVBATP
- +11 QUIT
- +12 ;
- DT(Y,X1,X2) ; Returns date X1 minus X2 days
- +1 ; change the '00:00' that could be passed so Fileman doesn't reject
- +2 ;C^%DTC(X1,X2)
- +3 ;S %DT=$G(%DT,"TS") D ^%DT
- +4 ;K %DT,X1,X2
- +5 ;Q
- DTTM(Y) ;
- +1 SET Y=$$HTE^XLFDT($HOROLOG,"P")
- +2 QUIT
- CHKCRED(Y) ;KLB
- +1 SET Y="[OK]"
- +2 IF '$DATA(DUZ(2))
- SET Y="Your division number is missing."
- QUIT
- +3 IF $DATA(DUZ)#2=0
- SET Y="Your user number is invalid."
- QUIT
- +4 IF +DUZ(2)<1
- SET Y="Invalid division."
- +5 QUIT
- PTINQ(REF,DFN) ; Return formatted pt inquiry report
- +1 KILL ^TMP("ORDATA",$JOB,1)
- +2 ; DVBA*2.7*109 - Added $D to next line
- +3 IF ($DATA(^DPT(DFN,0)))
- DO START^ORWRP(80,"DGINQB^ORCXPND1(DFN)")
- +4 SET REF=$NAME(^TMP("ORDATA",$JOB,1))
- +5 QUIT
- TEMPLATE(Y) ; Returns list of CAPRI exam templates
- +1 NEW DVBABCNT,DVBABIEN,DVBABNM,DVBABAD,DVBABDD,DVBABSL,DVBABOC
- +2 KILL Y,^TMP("DVBALAB1",DUZ)
- +3 SET DVBABCNT=0
- SET DVBABIEN=0
- +4 FOR
- SET DVBABIEN=$ORDER(^DVB(396.18,DVBABIEN))
- if 'DVBABIEN
- QUIT
- Begin DoDot:1
- +5 SET DVBABNM=$PIECE($GET(^DVB(396.18,DVBABIEN,0)),"^",1)
- +6 SET DVBABAD=$PIECE($GET(^DVB(396.18,DVBABIEN,2)),"^",1)
- +7 SET DVBABDD=$PIECE($GET(^DVB(396.18,DVBABIEN,2)),"^",2)
- +8 SET DVBABSL=$PIECE($GET(^DVB(396.18,DVBABIEN,6)),"^",1)
- +9 SET DVBABOC=$PIECE($GET(^DVB(396.18,DVBABIEN,6)),"^",2)
- +10 SET ^TMP("DVBATMPL",DUZ,DVBABCNT)=DVBABNM_"^"_DVBABAD_"^"_DVBABDD_"^"_DVBABSL_"^"_DVBABOC_"^"_DVBABIEN_$CHAR(13)
- SET DVBABCNT=DVBABCNT+1
- End DoDot:1
- +11 SET Y=$NAME(^TMP("DVBATMPL",DUZ))
- +12 QUIT
- +13 ;
- LABLIST(Y) ; Returns list of LAB TEST NAMES
- +1 NEW DVBABCNT,DVBABIEN,DVBABLNM
- +2 KILL Y,^TMP("DVBALAB1",DUZ)
- +3 SET DVBABCNT=0
- SET DVBABIEN=0
- +4 FOR
- SET DVBABIEN=$ORDER(^LAB(60,DVBABIEN))
- if 'DVBABIEN
- QUIT
- Begin DoDot:1
- +5 SET DVBABLNM=$PIECE($GET(^LAB(60,DVBABIEN,0)),"^",1)
- +6 SET ^TMP("DVBALAB1",DUZ,DVBABCNT)=DVBABLNM_"^"_DVBABIEN_$CHAR(13)
- SET DVBABCNT=DVBABCNT+1
- End DoDot:1
- +7 SET Y=$NAME(^TMP("DVBALAB1",DUZ))
- +8 QUIT
- +9 ;
- INSTLIST(Y) ; Returns full list of Institutions
- +1 NEW DVBABCNT,DVBABIEN,DVBABNM,DVBABSTN,DVBABST,DVBABDS,DVBARR,DVBERR,DVBATP
- +2 KILL Y,^TMP("DVBAINST",$JOB,DUZ)
- +3 SET (DVBABCNT,DVBABIEN)=0
- +4 FOR
- SET DVBABIEN=$ORDER(^DIC(4,DVBABIEN))
- if 'DVBABIEN
- QUIT
- Begin DoDot:1
- +5 KILL DVBARR,DVBERR
- +6 DO GETS^DIQ(4,DVBABIEN_",0",".01:.02:.03:","I","DVBARR","DVBERR")
- +7 if $DATA(DVBERR)
- QUIT
- +8 SET DVBABNM=$GET(DVBARR(4,DVBABIEN_",0,",.01,"I"))
- +9 if DVBABNM=""
- QUIT
- +10 SET DVBABSTN=$GET(DVBARR(4,DVBABIEN_",0,",.02,"I"))
- +11 if DVBABSTN=""
- QUIT
- +12 SET DVBABDS=$GET(DVBARR(4,DVBABIEN_",0,",.03,"I"))
- +13 KILL DVBARR,DVBERR
- +14 DO GETS^DIQ(5,DVBABSTN_",0",.01,"I","DVBARR","DVBERR")
- +15 if $DATA(DVBERR)
- QUIT
- +16 SET DVBABST=$GET(DVBARR(5,DVBABSTN_",0,",.01,"I"))
- +17 KILL DVBARR,DVBERR
- +18 DO GETS^DIQ(4,DVBABIEN_",0",13,"I","DVBARR","DVBERR")
- +19 SET DVBATP=$GET(DVBARR(4,DVBABIEN_",0,",13,"I"))
- +20 IF DVBATP'=""
- Begin DoDot:2
- +21 SET DVBATP=$PIECE($GET(^DIC(4.1,DVBATP,0)),"^",1)
- End DoDot:2
- +22 SET ^TMP("DVBAINST",$JOB,DUZ,DVBABCNT)=DVBABNM_"-"_DVBATP_"^"_DVBABST_"^"_DVBABDS_"^"_DVBABIEN_$CHAR(13)
- +23 SET DVBABCNT=DVBABCNT+1
- End DoDot:1
- +24 SET Y=$NAME(^TMP("DVBAINST",$JOB,DUZ))
- +25 QUIT
- +26 ;
- INCEXAM(ZMSG) ;Increased exam # in file and passes back the # to user
- +1 SET ZMSG=+$GET(^DVB(396.1,1,5))+1
- +2 SET ^DVB(396.1,1,5)=ZMSG
- +3 QUIT
- +4 ;
- MSG(ERR,DUZ,XMSUB,XMTEXT,MGN,ID) ;Generate mail message;KLB
- +1 ; --rpc: DVBAB SEND MSG
- +2 ;
- +3 ; This remote procedure is used to generate bulletins for specific CAPRI actions, such as cancellation of 2507 exams.
- +4 ;
- +5 ; Supported References:
- +6 ; DBIA #10111: Allows FM read access of ^XMB(3.8,D0,0) using DIC.
- +7 KILL ^TMP($JOB,"AMIE")
- +8 SET XMB=""
- SET XMDUZ=DUZ
- +9 IF '$DATA(DUZ)
- SET ERR="MISSING DUZ"
- QUIT
- +10 IF '$DATA(XMSUB)
- SET ERR="MISSING SUBJECT"
- QUIT
- +11 IF '$DATA(XMTEXT)
- SET ERR="MISSING TEXT"
- QUIT
- +12 IF '$DATA(MGN)
- SET ERR="MISSING MAIL GROUP NAME"
- QUIT
- +13 ;IF MGN=DVBA C 2507 EXAM READY NO BULLETIN NECESSARY, BUILD THE EMAIL AND QUIT
- +14 IF MGN="DVBA C 2507 EXAM READY"
- DO SENDMSG
- QUIT
- +15 SET J=0
- +16 FOR
- SET J=$ORDER(XMTEXT(J))
- if 'J
- QUIT
- SET ^TMP($JOB,"AMIE",J)=$GET(XMTEXT(J))
- +17 SET XMTEXT="^TMP($J,""AMIE"","
- +18 SET DIC="^XMB(3.8,"
- SET DIC(0)="QM"
- SET X=MGN
- DO ^DIC
- +19 IF +Y<0
- SET ERR="INVALID MAIL GROUP NAME"
- QUIT
- +20 IF '$$GOTLOCAL^XMXAPIG(MGN)
- SET ERR="NO ACTIVE LOCAL MEMBERS IN MAIL GROUP"
- KILL ^TMP("XMERR",$JOB)
- QUIT
- +21 IF MGN="DVBA C NEW C&P VETERAN"
- SET XMB="DVBA CAPRI NEW C&P VETERAN"
- +22 IF MGN="DVBA C 2507 CANCELLATION"
- SET XMB="DVBA CAPRI 2507 CANCELLATION"
- +23 IF XMB=""
- SET ERR="UNABLE TO SET BULLETIN"
- QUIT
- +24 DO ^XMB
- +25 ;XMB = -1 if bulletin not found in file (#3.6)
- +26 SET ERR=$SELECT(XMB=-1:"BULLETIN NOT FOUND",1:"MESSAGE SENT")
- +27 ;before we quit, send a message to the requestor if the message is a cancellation
- +28 IF MGN="DVBA C 2507 CANCELLATION"
- DO SENDMSG
- +29 KILL XMSUB,XMTEXT,MGN,DIC,DIC(0),J,Y,XMDUZ,XMB
- +30 QUIT
- FINDEXAM(ZMSG,ZIEN) ;Returns list of exams in 396.4 that are linked to ZIEN in 396.3
- +1 NEW DVBABCNT,DVBABIEN
- +2 SET DVBABCNT=0
- SET DVBABIEN=0
- +3 FOR
- SET DVBABIEN=$ORDER(^DVB(396.4,"C",ZIEN,DVBABIEN))
- if 'DVBABIEN
- QUIT
- Begin DoDot:1
- +4 SET DVBABD1=$PIECE($GET(^DVB(396.4,DVBABIEN,0)),"^",2)
- +5 ;Name of Exam
- SET DVBABD2=$PIECE($GET(^DVB(396.6,+$PIECE($GET(^DVB(396.4,DVBABIEN,0)),"^",3),0)),"^",1)
- +6 SET DVBABD3=$PIECE($GET(^DVB(396.4,DVBABIEN,0)),"^",4)
- +7 IF DVBABD3="O"
- SET DVBABD3="[OPEN]"
- +8 IF DVBABD3="C"
- SET DVBABD3="[COMPLETE]"
- +9 IF DVBABD3="X"
- SET DVBABD3="[CANCELED BY MAS]"
- +10 IF DVBABD3="RX"
- SET DVBABD3="[CANCELED BY RO]"
- +11 IF DVBABD3="T"
- SET DVBABD3="[TRANSFERRED OUT]"
- +12 IF ZIEN=DVBABD1
- Begin DoDot:2
- +13 SET ZMSG(DVBABCNT)=DVBABIEN_"^"_DVBABD2_" "_DVBABD3
- +14 SET DVBABCNT=DVBABCNT+1
- End DoDot:2
- End DoDot:1
- +15 KILL DVBABCNT,DVBABIEN,ZIEN,DVBABD1,DVBABD2,DVBABD3
- +16 QUIT
- SENDMSG ;SET UP TO SEND EMAIL/NOTIFICATION TO REQUESTOR OF 2507
- +1 NEW DVBA0,DVBAREQ,DVBAEA,DVBAC,DVBAQUIT,DVBADFN,DVBASITE,DVBADT,DUZ
- +2 NEW MSG,MERR,CTR,RIEN
- +3 ;SINCE MAILMAN DOES NOT ALLOW MESSAGES TO BE SENT FROM USERS WITHOUT ACCESS CODES OR MAILBOXES
- +4 ;WHICH CAPRI REMOTE USER DO NOT HAVE, WE HAVE TO NEW DUZ AND CHANGE XMDUZ TO THE NAME OF THE USER
- +5 ;AS A STRING SO THE PROCESS IS STILL LINKED TO THE USER SENDING/TRIGGERING THE MESSAGE
- +6 IF $GET(ID)=""
- QUIT
- +7 SET XMDUZ=$PIECE(^VA(200,XMDUZ,0),"^",1)_" CAPRI"
- +8 SET DVBA0=$GET(^DVB(396.3,ID,0))
- +9 SET DVBADFN=$PIECE(DVBA0,"^",1)
- SET DVBAREQ=$PIECE(DVBA0,"^",4)
- SET DVBADT=$$FMTE^XLFDT($PIECE(DVBA0,"^",2))
- +10 ;following call supported by IA 3858
- +11 SET DVBAEA=$PIECE($GET(^VA(200,DVBAREQ,.15)),"^",1)
- +12 IF DVBAEA'=""
- Begin DoDot:1
- +13 SET XMY(DVBAEA)=""
- SET DVBASITE=$$SITE^VASITE
- +14 IF MGN="DVBA C 2507 CANCELLATION"
- DO CNCLMSG
- QUIT
- +15 IF MGN="DVBA C 2507 EXAM READY"
- DO RDYMSG
- QUIT
- End DoDot:1
- +16 QUIT
- CNCLMSG ;SEND CANCEL MESSAGE TO REQUESTOR OF THE 2507 EXAM
- +1 ;need to loop through previously built text to make sure all PII is removed
- +2 SET J=0
- SET DVBAQUIT=0
- +3 FOR
- SET J=$ORDER(^TMP($JOB,"AMIE",J))
- if 'J!(DVBAQUIT)
- QUIT
- Begin DoDot:1
- +4 IF $GET(^TMP($JOB,"AMIE",J))["Name"
- SET ^TMP($JOB,"AMIE",J)="DFN: `"_DVBADFN_" SITE: "_$PIECE($GET(DVBASITE),"^",2)_" Request Date: "_DVBADT
- +5 IF $GET(^TMP($JOB,"AMIE",J))["Additional Comments"
- Begin DoDot:2
- +6 SET ^TMP($JOB,"AMIE1",J)="**NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI"
- +7 SET ^TMP($JOB,"AMIE1",J+1)="Patient Selector 'Patient ID' field to find the patient. Be sure to include"
- +8 SET ^TMP($JOB,"AMIE1",J+2)="the ` (backward-apostrophe) character."
- +9 SET ^TMP($JOB,"AMIE1",J+3)=""
- +10 SET ^TMP($JOB,"AMIE1",J+4)=""
- +11 SET ^TMP($JOB,"AMIE1",J+4)=""
- +12 SET ^TMP($JOB,"AMIE1",J+5)="*****This is an auto-generated email. Do not respond to this email address.*****"
- +13 SET DVBAQUIT=1
- QUIT
- End DoDot:2
- QUIT
- +14 SET ^TMP($JOB,"AMIE1",J)=$GET(^TMP($JOB,"AMIE",J))
- End DoDot:1
- +15 SET XMTEXT="^TMP($J,""AMIE1"","
- +16 DO ^XMD
- +17 KILL ^TMP($JOB,"AMIE1")
- +18 QUIT
- RDYMSG ;SEND EXAM COMPLETE MESSAGE TO REQUESTOR OF 2507
- +1 ;no text/body is passed in so we have to build the message from scratch
- +2 SET ^TMP($JOB,"AMIE1",1)="A 2507 request as described below has been completed and released to the regional office , and is now available in CAPRI."
- +3 SET ^TMP($JOB,"AMIE1",2)=""
- +4 SET ^TMP($JOB,"AMIE1",3)=""
- +5 SET ^TMP($JOB,"AMIE1",4)=" DFN: `"_DVBADFN
- +6 SET ^TMP($JOB,"AMIE1",5)=" Vista Site: "_$PIECE($GET(DVBASITE),"^",2)
- +7 SET ^TMP($JOB,"AMIE1",6)=" Request Date: "_DVBADT
- +8 SET ^TMP($JOB,"AMIE1",7)=""
- +9 SET ^TMP($JOB,"AMIE1",8)=""
- +10 SET ^TMP($JOB,"AMIE1",9)="**NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI"
- +11 SET ^TMP($JOB,"AMIE1",10)="Patient Selector 'Patient ID' field to find the patient. Be sure to include"
- +12 SET ^TMP($JOB,"AMIE1",11)="the ` (backward-apostrophe) character."
- +13 SET ^TMP($JOB,"AMIE1",12)=""
- +14 SET ^TMP($JOB,"AMIE1",13)=""
- +15 SET ^TMP($JOB,"AMIE1",14)=""
- +16 SET ^TMP($JOB,"AMIE1",15)="*****This is an auto-generated email. Do not respond to this email address.*****"
- +17 SET XMTEXT="^TMP($J,""AMIE1"","
- +18 DO ^XMD
- +19 KILL ^TMP($JOB,"AMIE1")
- +20 KILL XMSUB,XMTEXT,MGN,XMDUZ
- +21 QUIT