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

BEHOCCD.m

Go to the documentation of this file. 
  1. BEHOCCD ;IHS/MSC/MGH - CCD calls ;31-Mar-2014 17:45;PLS
  1.  ;;1.1;BEH COMPONENTS;**067001**;March 12, 2008;Build 1
  1.  ;=================================================================
  1. PHR(RET,DFN) ;Returns if pt has an active PHR
  1.  N PHN,PHNDT
  1.  S RET=0
  1.  S PHNDT="" S PHNDT=$O(^AUPNPAT(DFN,88,"ACT",$C(0)),-1) Q:PHNDT=""  D
  1.  .S PHN=""  S PHN=$O(^AUPNPAT(DFN,88,"ACT",PHNDT,PHN)) Q:PHN=""  D
  1.  ..S RET=PHN_U_$$FMTDATE^BGOUTL(PHNDT)
  1.  Q
  1.  ;========================================
  1.  ;Input
  1.  ;DFN= IEN of patient
  1.  ;VIEN=Array of visit IENs
  1.  ;TYPE  P=PHR,F=Fax,E=E-mail,N=Print,R=Refusal
  1.  ;CCDT  T=Transition of care,C=Clinical Summary
  1.  ;RRIEN Referral IEN if its a TOC doc
  1.  ;DOCID Document ID
  1. STORESN(RET,DFN,VIEN,TYPE,CCDT,RRIEN,DOCID) ;Store SNOMED medication
  1.  N EDU,SUB,SUBTYP,TOPIEN,X,VST,LIST
  1.  S RET=0
  1.  I '+DFN  Q "-1^Patient not defined"
  1.  S TYPE=$G(TYPE),CCDT=$G(CCDT),DOCID=$G(DOCID),RRIEN=$G(RRIEN)
  1.  I CCDT="T" D TOC(.RET,DFN,.VIEN,TYPE,RRIEN,DOCID) Q
  1.  I TYPE="R" D REFUSAL(.RET,DFN) Q
  1.  I TYPE="P" D
  1.  .;Store education
  1.  .S I="" F  S I=$O(VIEN(I)) Q:I=""  D
  1.  ..S VST=$G(VIEN(I))
  1.  ..S EDU=422735006,SUB="HOME MANAGEMENT"
  1.  ..D EDU(.RET,EDU,SUB,VST)
  1.  I TYPE="N" D
  1.  .;Store education
  1.  .S I="" F  S I=$O(VIEN(I)) Q:I=""  D
  1.  ..S VST=$G(VIEN(I))
  1.  ..S LIST(I+1)=VIEN(I)_U_DOCID
  1.  ..S EDU=422735006,SUB="LITERATURE"
  1.  ..D EDU(.RET,EDU,SUB,VST)
  1.  .S X=$$DL^APCCUTL(.LIST,$$NOW^XLFDT(),DUZ,1,"P")
  1.  .S RET=RET_U_X
  1.  Q
  1. EDU(RET,TOP,SUB,VST) ;Store education
  1.  N DATA,INP
  1.  S DATA=""
  1.  S SUBTYP=$O(^APCDEDCV("B",SUB,""))
  1.  D SETDXTOP^BGOVPED(.TOPIEN,EDU_U_SUBTYP,2)
  1.  Q:TOPIEN=""
  1.  S INP=U_$P(TOPIEN,U,1)_U_DFN_U_VST_U_DUZ
  1.  D SET^BGOVPED(.DATA,INP)
  1.  I DATA="" S RET=1
  1.  E  S RET=DATA
  1.  Q
  1. REFUSAL(RET,DFN) ;Enter the refusal item
  1.  ;  INP = Refusal IEN [1] ^ Refusal Type [2] ^ Item IEN [3] ^ Patient IEN [4] ^
  1.  ;        Refusal Date [5] ^ Comment [6] ^ Provider IEN [7] ^ Reason [8]
  1.  N TYPE,DTDONE
  1.  S TYPE="SNOMED"
  1.  S EDU=422735006
  1.  S DTDONE="TODAY",DTDONE=$$DT^CIAU(DTDONE)
  1.  S INP=U_TYPE_U_EDU_U_DFN_U_DTDONE_U_U_DUZ_U_23
  1.  D SET^BGOREF(.RET,INP)
  1.  I RET="" S RET=1
  1.  Q
  1. TOC(RET,DFN,VIEN,TYPE,RRIEN,DOCID) ;Transition of care document
  1.  N X,RR,I,DOCTYP,LIST,LTYPE
  1.  S LTYPE=$S(TYPE="N":"P",1:TYPE)
  1.  ;S DOCTYP=$S(TYPE="N":"CP",TYPE="F":"CF",1:"CT")
  1.  S DOCTYP=$S(TYPE="E":"CT",1:"CP")
  1.  S I="" F  S I=$O(VIEN(I)) Q:I=""  D
  1.  .S LIST(I+1)=VIEN(I)_U_DOCID
  1.  I +RRIEN=0 D
  1.  .S X=$$DL^APCCUTL(.LIST,$$NOW^XLFDT(),DUZ,2,LTYPE)
  1.  E  D
  1.  .S X=$$DL^APCCUTL(.LIST,$$NOW^XLFDT(),DUZ,2,LTYPE)
  1.  .;S RR="" S RR=$O(^BMCREF("C",RRIEN,RR))
  1.  .;Q:'+RR
  1.  .D CRENTOCD^BMCAPIS(.RET,RRIEN,$$NOW^XLFDT(),DUZ,DOCTYP,DOCID)
  1.  .S RET=RET_U_X
  1.  Q
  1. GETREF(RSLT,VISITS) ;EP get referrals for visits
  1.  ;Input parameter is array as per following format
  1.  ;S VISITS(1)="3707743"
  1.  ;S VISITS(2)="3601325"
  1.  ;Output array
  1.  ;"VISIT^RCIS REFERRAL IEN^PATIENT IEN^RCIS REFERRAL PURPOSE^RCIS REFERRAL STATUS^RCIS REFERRAL#^VENDOR FAX^VENDOR EMAIL PARTICIPANT YES NO^VENDOR EMAIL ADDRESS"
  1.  N CNT,ARRAY
  1.  S CNT="" F  S CNT=$O(VISITS(CNT)) Q:CNT=""  D
  1.  .S ARRAY(CNT+1)=$G(VISITS(CNT))
  1.  D GETREFFV^BMCAPIS(.RSLT,.ARRAY)
  1.  Q
  1.  ;
  1.  ;Return access/verify codes for a user
  1.  ; Input: IEN - DUZ of user
  1.  ;        OPT - 0: default
  1.  ;              1: returns encrypted (ENCRYP^XUSRB1) form of access_$C(9)_verify code string cached in BEHOCCD A_V CODES parameter
  1. ACCESS(RET,IEN,OPT) ;EP
  1.  N ACCESS,VERIFY
  1.  S RET=""
  1.  S OPT=$G(OPT,0)
  1.  I 'OPT D
  1.  .Q:IEN=""
  1.  .I +IEN'=IEN S IEN=$O(^VA(200,"B",IEN,""))
  1.  .Q:'IEN
  1.  .S ACCESS=$$GET1^DIQ(200,IEN,2,"I")
  1.  .S VERIFY=$$GET1^DIQ(200,IEN,11,"I")
  1.  .S RET=ACCESS_$C(9)_VERIFY
  1.  E  D
  1.  .S RET=$$GET^XPAR("SYS","BEHOCCD MAG A_V CODES")
  1.  Q
  1.  ;Input
  1.  ;Path and name of image
  1.  ;IMAGES(1)=?\\image server\image share\filename.ext^image description?
  1.  ;if image descrption is not sent in it will default to CCDS document
  1. IMPORT(RET,DFN,IMAGE,VSTR,CRDT) ;Import an image to VI
  1.  Q
  1.  N MAGRY,IMAGES,MAGIX
  1.  K RET
  1.  S RET(0)=""
  1.  I $P(IMAGE,U,2)="" S $P(IMAGE,U,2)="CCDS Document"
  1.  S VIEN=$P(VSTR,";",4)
  1.  I VIEN="" S RET="Error: Visit not sent"
  1.  S IMAGES(1)=IMAGE
  1.  S MAGIX("ACQD")="NETWORK COMPUTER"
  1.  S MAGIX("ACQL")=$P(VSTR,";",1)
  1.  S MAGIX("IDFN")=DFN
  1.  S MAGIX("IXTYPE")="CCD-SUMMARY"
  1.  S MAGIX("ITYPE")="XML"
  1.  S MAGIX("ACQS")=DUZ(2)
  1.  S MAGIX("STSCB")="CALLBK^BEHOCCD"
  1.  S MAGIX("TRKID")="CCD;"_DFN_VIEN_CRDT
  1.  D IMPORT^MAGGSIUI(.MAGRY,.IMAGES,.MAGIX)
  1.  I +MAGRY(0) D
  1.  .S RET(0)=$G(MAGRY(0))_U_MAGIX("TRKID")
  1.  E  D
  1.  .S X="" F  S X=$O(MAGRY(X)) Q:X=""  D
  1.  ..S RET(X)=$G(MAGRY(X))
  1.  Q
  1. CALLBK(RESULT) ;call back for storage
  1.  Q
  1.  ;N X,STAT,TRACK,QUEUE
  1.  ;S STAT=$P($G(RESULT(0)),U,1)
  1.  ;Q:STAT=1  ;success
  1.  ;I STAT=0!(STAT=2) D
  1.  ;.S TRACK=$G(RESULT(1))
  1.  ;.S QUEUE=$G(RESULT(2))
  1.  ;.S X=$$STATUS^MAGQBUT3(QUEUE)
  1.  ;.S XQA(DUZ)=""
  1.  ;.S XQAMSG=X
  1.  ;.S XQAID="BEHOCD"_","_DFN_","_99005
  1.  ;.S XQADATA=
  1.  ;.D SETUP^XQALERT
  1.  ;Q
  1.  ;Input parameters
  1.  ;DFN=patient
  1.  ;VENDOR=who the document is to go to
  1.  ;FAX=Fax number of vendor
  1. SNDALRT(RET,DFN,VENDOR,FAX) ;EP
  1.  N MSG,XQAMSG,XQADATA,XQAID,XQATEXT,XQA,PRV,PT
  1.  S RET=""
  1.  S XQAMSG="CCDA ready for Fax"
  1.  S XQAID="BEHOCD"_","_DFN_","_99005
  1.  S XQADATA="DFN="_DFN
  1.  S PT=$$GET1^DIQ(2,DFN,.01)
  1.  S PRV=$$GET1^DIQ(200,DUZ,.01)
  1.  S MSG="A CCDA has been stored today in Vista Imaging by "_PRV_" for "_PT_" to be sent to "_VENDOR_" at "_FAX
  1.  S XQATEXT=MSG
  1.  S XQA("G.BEHOCCD HIMS TOC")=""
  1.  S RET=$$SETUP1^XQALERT
  1.  Q
  1.  ;
  1.  ;
  1. MAGAV ;support for capture and storage of a/v codes
  1.  N AC,VC,USR,AE,VE,AH,VH,AEVE
  1.  ;Select user for comparison
  1.  S USR=$$GETIEN1(200,"Select CCDA VistA Imaging user: ",-1,"B")
  1.  Q:USR<0
  1.  ;Prompt for access/verify codes
  1.  S AC=$$PROMPT("Access Code: ")
  1.  Q:AC[U
  1.  S AH=$$EN^XUSHSH($$UP^XLFSTR(AC))
  1.  I AH'=$P($G(^VA(200,USR,0)),U,3) D  Q
  1.  .W !,"Entered access code does not match selected user."
  1.  S VC=$$PROMPT("Verify Code: ")
  1.  Q:VC[U
  1.  ; Compare a/v codes to selected user
  1.  S VH=$$EN^XUSHSH($$UP^XLFSTR(VC))
  1.  I VH'=$P($G(^VA(200,USR,.1)),U,2) D  Q
  1.  .W !,"Entered verified code does not match selected user."
  1.  S AEVE=$$ENCRYP^XUSRB1(AC)_$C(9)_$$ENCRYP^XUSRB1(VC)
  1.  ;Store string in parameter
  1.  W !,"Storing value..."
  1.  D PUT^XPAR("SYS","BEHOCCD MAG A_V CODES",,AEVE,.ERR)
  1.  Q
  1.  ;
  1. PROMPT(LABEL) ;
  1.  N VAL
  1.  X ^%ZOSF("EOFF")
  1.  W !,LABEL S VAL=$$ACCEPT^XUS()
  1.  X ^%ZOSF("EON")
  1.  Q VAL
  1.  ;
  1.  ; Prompt for entry from file
  1.  ; BEHOFILE = File #
  1.  ; BEHOPMPT = Prompt
  1.  ; BEHODFLD = Field whose value is to be used for default value
  1.  ;          Set to -1 for no default value
  1.  ; D - x-ref (C^D)
  1.  ; BEHOSCRN = DIC("S") SCREEN LOGIC
  1.  ; BEHODFLT = Default value set in DIC("B") - not used if BEHODFLD is >0
  1. GETIEN1(BEHOFILE,BEHOPMPT,BEHODFLD,D,BEHOSCRN,BEHODFLT) ; EP
  1.  N DIC,BEHOD,Y
  1.  S D=$G(D,"B")
  1.  S:'$L(D) D="B"
  1.  S BEHODFLD=$G(BEHODFLD,.01)
  1.  S BEHOD=""
  1.  S DIC("S")=$G(BEHOSCRN)
  1.  S:BEHODFLD>0 BEHOD=$$GET1^DIQ(BEHOFILE,$$FIND1^DIC(BEHOFILE,,," ",.D,DIC("S")),BEHODFLD)
  1.  I BEHODFLD<0,$L($G(BEHODFLT)) S BEHOD=BEHODFLT
  1.  S DIC=BEHOFILE,DIC(0)="AE",DIC("A")=$G(BEHOPMPT),DIC("B")=BEHOD
  1.  I $L(D,U)>1,DIC(0)'["M" S DIC(0)=DIC(0)_"M"
  1.  D MIX^DIC1
  1.  I $D(DUOUT)!($D(DTOUT)) S BEHOPOP=-1
  1.  E  I Y'>0 S BEHOPOP=1,$P(BEHOPOP,U,2)=X="@"
  1.  Q +Y
  1.  ;
  1.  ;Set prohibit editing field of parameter
  1. LOCK(PARAM,VAL) ;EP-
  1.  N IEN
  1.  S IEN=$O(^XTV(8989.51,"B",PARAM,0))
  1.  Q:'IEN
  1.  S $P(^XTV(8989.51,IEN,0),U,6)=VAL
  1.  Q