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