BQIVFDEF ;PRXM/HC/ALA - PCC V-file definition ; 22 Mar 2007 2:55 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
Q
;
EN(DATA,VFILE,TYPE) ;EP -- BQI GET VFILE DISPLAY
;
;Input
; VFILE - The vfile number or name
;
NEW UID,II,IEN,VFIL,VALUE,ORD,VDATA,VDATA1,VDATA2,BJ,CLEAR,CLRFLD,CN
NEW HELP,VDATA3,VFILN,VHELP,BN,BQIHELP,BQIHELPW,VFLD,VDATA9
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFDEF",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFDEF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S VFIEN=$G(VFILE,""),TYPE=$G(TYPE,"V")
;
S HDR="T00030VFILE_NAME^T00015VFILE_NUMBER^T00030DISPLAY_RPC^T00045DISPLAY_RPC_PARAM^T00030EDIT_RPC^T00045EDIT_RPC_PARAM^T00030INIT_TRIGGER_RPC^"
S HDR=HDR_"T00045INIT_TRIG_PARAM^T00030DELETE_RPC^T00045DELETE_RPC_PARAM^T00001FILTER^T00030VALID_RPC^"
S HDR=HDR_"T00030DISPLAY_COLUMN^T00030INTERNAL_COLUMN^I00003SIZE^T00001COL_TYPE_PEND^T00001COL_TYPE_VIEW^T00008CODE^T00001GROUP^T00001CODE_TYPE^T00030UPPER^T00030LOWER^"
S HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00001UNIQUE_VAL^T00003BATCH^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
;S HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
S HDR=HDR_"T00001TRIGGER^T00030TRIG_RPC^T00045TRIG_CODES^T00001TABLE_PRELOAD^T00001TABLE_LOOKUP_TYPE^T00003DEC_PLACES^T00030ALT_DISPLAY^T00030MULT_REF^T00045GROUP_NAME^I00003GRID_ORDER^"
S HDR=HDR_"T00030LINK_DATA_COL^T00045LINK_RPC^T00030LINK_PARAM^T00250CLEAR_FIELDS^T01024HELP_TEXT"_$C(30)
S @DATA@(II)=HDR
;
I VFIEN="" D G DONE
. S VFIL=0
. F S VFIL=$O(^BQI(90506.3,"D",TYPE,VFIL)) Q:'VFIL D
.. ; If it is a subdefinition for a multiple, it is retrieved from the
.. ; Master definition so don't need to retrieve data fields
.. I $$GET1^DIQ(90506.3,VFIL_",",.07,"I") Q
.. D VF(VFIL)
;
; If someone passes the name
I VFIEN'?.N S VFIEN=$$FIND1^DIC(90506.3,"","MX",VFILE,"","","ERROR")
; If someone passes the file number
I $L(VFIEN)>6 S VFIEN=$$FIND1^DIC(90506.3,"","MX",VFILE,"","","ERROR")
;
I VFIEN=0 S BMXSEC="Passed in file "_VFILE_" is not correct" Q
;
D VF(VFIEN)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
VF(VFIL) ;EP
; Parameters
; VFILN - File Number
; ORD - Display Order number
;
NEW VFDATA,VFSDATA,MULTR,SFIL,VFSDATA2,FILTER,VALID,LINK,LRPC,LINP
NEW BQN,BQP,BQPARM,VFDATA2,PRMND,PNAM,PTYP,PORD
;
S VFDATA=^BQI(90506.3,VFIL,0)
S VFDATA2=$G(^BQI(90506.3,VFIL,2))
S FILTER=$S($D(^BQI(90506.3,VFIL,7)):"Y",1:"N")
S VALID=$P($G(^BQI(90506.3,VFIL,8)),U,1)
I $P(VFDATA,U,6)="D" Q
;
D PRMS(VFIL)
;
S VFILN=$P(VFDATA,U,2)
S VALUE=$P(VFDATA,U,1)_U_VFILN_U_$P(VFDATA,U,4)_U_BQPARM(3)_U_$P(VFDATA,U,12)_U_BQPARM(4)_U_$P(VFDATA,U,13)_U_BQPARM(5)_U_$P(VFDATA2,U)_U_BQPARM(6)_U_FILTER_U_VALID
S ORD=""
F S ORD=$O(^BQI(90506.3,VFIL,10,"C",ORD)) Q:ORD="" D
. S IEN=""
. F S IEN=$O(^BQI(90506.3,VFIL,10,"C",ORD,IEN)) Q:IEN="" D
.. D RET(VFIL,IEN)
;
;Check for subdefinitions
S SFIL=""
F S SFIL=$O(^BQI(90506.3,"ASUB",VFIL,SFIL)) Q:SFIL="" D
. ;S VFILN=$$GET1^DIQ(90506.3,SFIL_",",.02,"E")
. ;S VALUE=$$GET1^DIQ(90506.3,SFIL_",",.01,"E")_U_VFILN
. S VFSDATA=^BQI(90506.3,SFIL,0)
. I $P(VFSDATA,U,3)=1 Q
. S VFSDATA2=$G(^BQI(90506.3,VFIL,2))
. S FILTER=$S($D(^BQI(90506.3,VFIL,7)):"Y",1:"N")
. S VALID=$P($G(^BQI(90506.3,VFIL,8)),U,1)
. S VFILN=$P(VFSDATA,U,2)
. D PRMS(SFIL)
. ;S VALUE=$P(VFSDATA,U,1)_U_VFILN_U_$P(VFSDATA,U,4)_U_$P(VFSDATA,U,12)_U_$P(VFSDATA,U,13)
. S VALUE=$P(VFSDATA,U,1)_U_VFILN_U_$P(VFSDATA,U,4)_U_BQPARM(3)_U_$P(VFSDATA,U,12)_U_BQPARM(4)_U_$P(VFSDATA,U,13)_U_BQPARM(5)_U_$P(VFSDATA2,U)_U_BQPARM(6)_U_FILTER_U_VALID
. S ORD=""
. F S ORD=$O(^BQI(90506.3,SFIL,10,"C",ORD)) Q:ORD="" D
.. S IEN=""
.. F S IEN=$O(^BQI(90506.3,SFIL,10,"C",ORD,IEN)) Q:IEN="" D RET(SFIL,IEN)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
RET(VFIL,IEN) ; Retrieve data
S VDATA=^BQI(90506.3,VFIL,10,IEN,0)
I $P(VDATA,U,11)=1 Q
S VDATA1=$G(^BQI(90506.3,VFIL,10,IEN,1))
S VDATA2=$G(^BQI(90506.3,VFIL,10,IEN,2))
S VDATA3=$G(^BQI(90506.3,VFIL,10,IEN,3))
S VDATA9=$G(^BQI(90506.3,VFIL,10,IEN,9))
NEW DA,IENS
S DA(1)=VFIL,DA=IEN,IENS=$$IENS^DILF(.DA)
S MULTR=$$GET1^DIQ(90506.31,IENS,1.08,"E")
;
; Check for batch editable flag in 90506.1
NEW CODE,LIEN,BATCH,LINK,LRPC,LINP
S CODE=$P(VDATA,U,7),BATCH="NO",LINK=$P(VDATA1,U,10)
S LRPC=$P(VDATA9,U,1),LINP=$P(VDATA9,U,2)
S LIEN=$O(^BQI(90506.1,"B",CODE,""))
I LIEN'="" D
. S BATCH=+$$GET1^DIQ(90506.1,LIEN_",",.17,"I")
. S BATCH=$S(BATCH=1:"YES",1:"NO")
;
;Check default field for API - $P(VDATA1,U,4)
S DEF=$P(VDATA1,U,4)
I DEF["$$" D
. NEW DVAL
. I DEF["~" S DEF=$TR(DEF,"~","^")
. X DEF
. S $P(VDATA1,U,4)=DVAL
;
; Check for patch requirement
NEW PATCH,CHNG
S PATCH=$P(VDATA2,U,10),CHNG=$P(VDATA2,U,11)
I PATCH'="" D
. I '$$PATCH^XPDUTL(PATCH) Q
. I CHNG["~" S CHNG=$TR(CHNG,"~","^")
. X CHNG
; Set the clear fields
S CLEAR="",CN=0,CLRFLD=""
F S CN=$O(^BQI(90506.3,VFIL,10,IEN,10,CN)) Q:'CN D
. S CLEAR=CLEAR_$P(^BQI(90506.3,VFIL,10,IEN,10,CN,0),"^",1)_";"
. S CLRFLD=$$TKO^BQIUL1(CLEAR,";")
;
; Set up the data fields
S II=II+1,@DATA@(II)=VALUE_U_$P(VDATA,U,1,4)_U_$P(VDATA,U,12)_U_$P(VDATA,U,7)_U_$P(VDATA,U,14)_U
F BJ=1:1:7,9 S @DATA@(II)=@DATA@(II)_$P(VDATA1,U,BJ)_U
S @DATA@(II)=@DATA@(II)_BATCH_U
F BJ=1:1:5 S @DATA@(II)=@DATA@(II)_$P(VDATA2,U,BJ)_U
S @DATA@(II)=@DATA@(II)_$G(^BQI(90506.3,VFIL,10,IEN,6))_U_$P(VDATA,U,8)_U
S @DATA@(II)=@DATA@(II)_$P(VDATA,U,9)_U_$P(VDATA,U,10)_U_$P(VDATA2,U,6)_U_$P(VDATA2,U,9)_U
S @DATA@(II)=@DATA@(II)_$P(VDATA2,U,7)_U_$P(VDATA2,U,8)_U_MULTR_U_$P(VDATA3,U,4)_U
S @DATA@(II)=@DATA@(II)_$P(VDATA3,U,5)_U_LINK_U_LRPC_U_LINP_U_CLRFLD_U
;
;Check for HELP text
K BQIHELPW,BQIHELP
S VFLD=$P(VDATA3,U,1),VHELP=""
I VFLD'="" D
. D FIELD^DID(VFILN,VFLD,"","HELP-PROMPT","BQIHELP")
. S VHELP=$G(BQIHELP("HELP-PROMPT"))
. I VHELP="" D
.. D FIELD^DID(VFILN,VFLD,"Z","DESCRIPTION","BQIHELPW")
.. I $G(BQIHELPW("DESCRIPTION"))="" Q
.. S BN=0,VHELP=""
.. F S BN=$O(BQIHELPW("DESCRIPTION",BN)) Q:BN="" D
... S VHELP=VHELP_BQIHELPW("DESCRIPTION",BN,0)_$C(10)
I $P(VDATA3,U,6)'="" S VHELP=$P(VDATA3,U,6)
S @DATA@(II)=@DATA@(II)_VHELP_$C(30)
Q
;
VST() ;EP - Get default visit type
NEW VAL
I $G(DUZ(2))="" Q "IHS"
;S VAL=$$GET1^DIQ(9001001.2,DUZ(2)_",",.17,"E")
S VAL=$$GET1^DIQ(9001001.2,DUZ(2)_",",.17,"I")
S VAL=$$STC^BQIUL2(9000010,.03,VAL)
I VAL="" Q "IHS"
Q VAL
;
HSD() ; EP - Get Health Summary Default
NEW VAL,AVAL
S AVAL=$$FIND1^DIC(9001015,,"X","ADULT REGULAR")
I $G(DUZ(2))="" Q AVAL
S VAL=$$GET1^DIQ(9001000,DUZ(2)_",",.03,"I")
I VAL="" Q AVAL
Q VAL
;
PWHD() ; EP - Get Patient Wellness Handout Default
NEW VAL,AVAL
I $$VERSION^XPDUTL("BJPC")<2.0 Q ""
S AVAL=$$FIND1^DIC(9001026,,"X","ADULT REGULAR")
I $G(DUZ(2))="" Q AVAL
S VAL=$$GET1^DIQ(9001000,DUZ(2)_",",.16,"I")
I VAL="" Q AVAL
Q VAL
;
NMBR(PBLIEN) ; EP - Get default problem notes number
; Input
; PBLIEN - Problem IEN
; Assumes DUZ(2) for the facility
NEW FACN
I PBLIEN="" Q 1
S FACN=$O(^AUPNPROB(PBLIEN,11,"B",DUZ(2),""))
I FACN="" Q 1
Q $O(^AUPNPROB(PBLIEN,11,FACN,11,"B",""),-1)+1
;
HPRV(BKMDFN) ; EP - Get the default HIV Provider
NEW VAL,BKMIEN,BKMHIV,BKMIENS,ARRAY
S BKMHIV=$$HIVIEN^BKMIXX3()
S BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN)
S BKMIENS=BKMHIV_","_BKMIEN_","
S VAL=""
I BKMIEN="" D
. D ALLDP^BDPAPI(BKMDFN,"HIV PROVIDER",.ARRAY)
. I ARRAY="" S VAL="" Q
. S VAL=$P(ARRAY,U,2)
;
I BKMIEN'="" D
. S VAL=$$GET1^DIQ(90451.01,BKMIENS,6,"I")
Q VAL
;
HCSM(BKMDFN) ; EP - Get the default HIV Case Manager
NEW VAL,BKMIEN,BKMHIV,BKMIENS,ARRAY
S BKMHIV=$$HIVIEN^BKMIXX3()
S BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN)
S BKMIENS=BKMHIV_","_BKMIEN_","
S VAL=""
I BKMIEN="" D
. D ALLDP^BDPAPI(BKMDFN,"HIV CASE MANAGER",.ARRAY)
. I ARRAY="" S VAL="" Q
. S VAL=$P(ARRAY,U,2)
;
I BKMIEN'="" D
. S VAL=$$GET1^DIQ(90451.01,BKMIENS,6.5,"I")
Q VAL
;
USR() ;EP - Get the default user
Q DUZ_$C(28)_$P($G(^VA(200,DUZ,0)),U,1)
;
STAT() ;EP = Get the CMET status
Q "T"_$C(28)_"TRACKED"
;
TBL(FILE,VALUE) ; EP - Get a default for a specific table value
NEW IEN
S IEN=$$FIND1^DIC(FILE,"","MX",VALUE,"","","ERROR")
Q IEN_$C(28)_VALUE
;
CLNCR() ; EP - Get the default for Chart Review
NEW IEN
S IEN=$$FIND1^DIC(40.7,"","MX","CHART REV/REC MOD","","","ERROR")
Q $$GET1^DIQ(40.7,IEN_",",1,"E")_$C(28)_"CHART REV/REC MOD"
;
PRMS(VFIL) ;EP - Pull RPC parameters
F BQN=3:1:6 D
.S BQPARM(BQN)=""
.N IDT,PRM,TIDT,TPRM
.S BQP=0 F S BQP=$O(^BQI(90506.3,VFIL,BQN,BQP)) Q:'BQP D
..S PRMND=$G(^BQI(90506.3,VFIL,BQN,BQP,0))
..S PNAM=$P(PRMND,U)
..S PTYP=$P(PRMND,U,2) S:PTYP="" PTYP=$S(PNAM["=":"P",1:"I")
..S PORD=$P(PRMND,U,3) S:PORD="" PORD=BQP_PNAM
..;
..;Temp Store of Unique Identifiers
..I PTYP="I" D
...S TIDT(PORD)=PRMND
..;
..;Temp Store of Regular Parameters
..I PTYP="P" D
...S TPRM(PORD)=PRMND
.;
.;Form Parameter String
.S IDT="",BQP="" F S BQP=$O(TIDT(BQP)) Q:BQP="" S IDT=IDT_$S(IDT]"":";",1:"")_$P(TIDT(BQP),U)
.S PRM="",BQP="" F S BQP=$O(TPRM(BQP)) Q:BQP="" S PRM=PRM_$S(PRM]"":$C(28),1:"")_$P(TPRM(BQP),U)
.S BQPARM(BQN)=IDT_$S(IDT]"":";",1:"")_PRM
.S BQPARM(BQN)=$$TKO^BQIUL1(BQPARM(BQN),";")
Q
;
EVT(EVIEN,POS) ;EP - Event Default
NEW EVTYPE,EVVALUE,IVALIEN,EIEN,TY
S EVTYPE="",EVVALUE="",IVALIEN="",EIEN=""
I $G(EVIEN)="" Q ""
S TY=$$GET1^DIQ(90621,EVIEN_",",.12,"I")
I TY'="" S EVTYPE=$$GET1^DIQ(90621.1,TY_",",.09,"E")
I TY'="" S EIEN=$O(^BTPW(90621,EVIEN,1,"C",TY,""))
I $G(EIEN)'="" D
. S EVVALUE=$P(^BTPW(90621,EVIEN,1,EIEN,0),"^",5),IVALIEN=$P(^(0),"^",6),TAXIEN=$P(^(0),U,2)
I POS=1 Q $G(EVTYPE)
I POS=2 Q $G(EVVALUE)
I POS=3 Q $G(IVALIEN)
I POS=4 Q $G(TAXIEN)
BQIVFDEF ;PRXM/HC/ALA - PCC V-file definition ; 22 Mar 2007 2:55 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 QUIT
+3 ;
EN(DATA,VFILE,TYPE) ;EP -- BQI GET VFILE DISPLAY
+1 ;
+2 ;Input
+3 ; VFILE - The vfile number or name
+4 ;
+5 NEW UID,II,IEN,VFIL,VALUE,ORD,VDATA,VDATA1,VDATA2,BJ,CLEAR,CLRFLD,CN
+6 NEW HELP,VDATA3,VFILN,VHELP,BN,BQIHELP,BQIHELPW,VFLD,VDATA9
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BQIVFDEF",UID))
+9 KILL @DATA
+10 SET II=0
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFDEF D UNWIND^%ZTER"
+12 ;
+13 SET VFIEN=$GET(VFILE,"")
SET TYPE=$GET(TYPE,"V")
+14 ;
+15 SET HDR="T00030VFILE_NAME^T00015VFILE_NUMBER^T00030DISPLAY_RPC^T00045DISPLAY_RPC_PARAM^T00030EDIT_RPC^T00045EDIT_RPC_PARAM^T00030INIT_TRIGGER_RPC^"
+16 SET HDR=HDR_"T00045INIT_TRIG_PARAM^T00030DELETE_RPC^T00045DELETE_RPC_PARAM^T00001FILTER^T00030VALID_RPC^"
+17 SET HDR=HDR_"T00030DISPLAY_COLUMN^T00030INTERNAL_COLUMN^I00003SIZE^T00001COL_TYPE_PEND^T00001COL_TYPE_VIEW^T00008CODE^T00001GROUP^T00001CODE_TYPE^T00030UPPER^T00030LOWER^"
+18 SET HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00001UNIQUE_VAL^T00003BATCH^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
+19 ;S HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
+20 SET HDR=HDR_"T00001TRIGGER^T00030TRIG_RPC^T00045TRIG_CODES^T00001TABLE_PRELOAD^T00001TABLE_LOOKUP_TYPE^T00003DEC_PLACES^T00030ALT_DISPLAY^T00030MULT_REF^T00045GROUP_NAME^I00003GRID_ORDER^"
+21 SET HDR=HDR_"T00030LINK_DATA_COL^T00045LINK_RPC^T00030LINK_PARAM^T00250CLEAR_FIELDS^T01024HELP_TEXT"_$CHAR(30)
+22 SET @DATA@(II)=HDR
+23 ;
+24 IF VFIEN=""
Begin DoDot:1
+25 SET VFIL=0
+26 FOR
SET VFIL=$ORDER(^BQI(90506.3,"D",TYPE,VFIL))
IF 'VFIL
QUIT
Begin DoDot:2
+27 ; If it is a subdefinition for a multiple, it is retrieved from the
+28 ; Master definition so don't need to retrieve data fields
+29 IF $$GET1^DIQ(90506.3,VFIL_",",.07,"I")
QUIT
+30 DO VF(VFIL)
End DoDot:2
End DoDot:1
GOTO DONE
+31 ;
+32 ; If someone passes the name
+33 IF VFIEN'?.N
SET VFIEN=$$FIND1^DIC(90506.3,"","MX",VFILE,"","","ERROR")
+34 ; If someone passes the file number
+35 IF $LENGTH(VFIEN)>6
SET VFIEN=$$FIND1^DIC(90506.3,"","MX",VFILE,"","","ERROR")
+36 ;
+37 IF VFIEN=0
SET BMXSEC="Passed in file "_VFILE_" is not correct"
QUIT
+38 ;
+39 DO VF(VFIEN)
+40 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
VF(VFIL) ;EP
+1 ; Parameters
+2 ; VFILN - File Number
+3 ; ORD - Display Order number
+4 ;
+5 NEW VFDATA,VFSDATA,MULTR,SFIL,VFSDATA2,FILTER,VALID,LINK,LRPC,LINP
+6 NEW BQN,BQP,BQPARM,VFDATA2,PRMND,PNAM,PTYP,PORD
+7 ;
+8 SET VFDATA=^BQI(90506.3,VFIL,0)
+9 SET VFDATA2=$GET(^BQI(90506.3,VFIL,2))
+10 SET FILTER=$SELECT($DATA(^BQI(90506.3,VFIL,7)):"Y",1:"N")
+11 SET VALID=$PIECE($GET(^BQI(90506.3,VFIL,8)),U,1)
+12 IF $PIECE(VFDATA,U,6)="D"
QUIT
+13 ;
+14 DO PRMS(VFIL)
+15 ;
+16 SET VFILN=$PIECE(VFDATA,U,2)
+17 SET VALUE=$PIECE(VFDATA,U,1)_U_VFILN_U_$PIECE(VFDATA,U,4)_U_BQPARM(3)_U_$PIECE(VFDATA,U,12)_U_BQPARM(4)_U_$PIECE(VFDATA,U,13)_U_BQPARM(5)_U_$PIECE(VFDATA2,U)_U_BQPARM(6)_U_FILTER_U_VALID
+18 SET ORD=""
+19 FOR
SET ORD=$ORDER(^BQI(90506.3,VFIL,10,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+20 SET IEN=""
+21 FOR
SET IEN=$ORDER(^BQI(90506.3,VFIL,10,"C",ORD,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+22 DO RET(VFIL,IEN)
End DoDot:2
End DoDot:1
+23 ;
+24 ;Check for subdefinitions
+25 SET SFIL=""
+26 FOR
SET SFIL=$ORDER(^BQI(90506.3,"ASUB",VFIL,SFIL))
IF SFIL=""
QUIT
Begin DoDot:1
+27 ;S VFILN=$$GET1^DIQ(90506.3,SFIL_",",.02,"E")
+28 ;S VALUE=$$GET1^DIQ(90506.3,SFIL_",",.01,"E")_U_VFILN
+29 SET VFSDATA=^BQI(90506.3,SFIL,0)
+30 IF $PIECE(VFSDATA,U,3)=1
QUIT
+31 SET VFSDATA2=$GET(^BQI(90506.3,VFIL,2))
+32 SET FILTER=$SELECT($DATA(^BQI(90506.3,VFIL,7)):"Y",1:"N")
+33 SET VALID=$PIECE($GET(^BQI(90506.3,VFIL,8)),U,1)
+34 SET VFILN=$PIECE(VFSDATA,U,2)
+35 DO PRMS(SFIL)
+36 ;S VALUE=$P(VFSDATA,U,1)_U_VFILN_U_$P(VFSDATA,U,4)_U_$P(VFSDATA,U,12)_U_$P(VFSDATA,U,13)
+37 SET VALUE=$PIECE(VFSDATA,U,1)_U_VFILN_U_$PIECE(VFSDATA,U,4)_U_BQPARM(3)_U_$PIECE(VFSDATA,U,12)_U_BQPARM(4)_U_$PIECE(VFSDATA,U,13)_U_BQPARM(5)_U_$PIECE(VFSDATA2,U)_U_BQPARM(6)_U_FILTER_U_VALID
+38 SET ORD=""
+39 FOR
SET ORD=$ORDER(^BQI(90506.3,SFIL,10,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:2
+40 SET IEN=""
+41 FOR
SET IEN=$ORDER(^BQI(90506.3,SFIL,10,"C",ORD,IEN))
IF IEN=""
QUIT
DO RET(SFIL,IEN)
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
RET(VFIL,IEN) ; Retrieve data
+1 SET VDATA=^BQI(90506.3,VFIL,10,IEN,0)
+2 IF $PIECE(VDATA,U,11)=1
QUIT
+3 SET VDATA1=$GET(^BQI(90506.3,VFIL,10,IEN,1))
+4 SET VDATA2=$GET(^BQI(90506.3,VFIL,10,IEN,2))
+5 SET VDATA3=$GET(^BQI(90506.3,VFIL,10,IEN,3))
+6 SET VDATA9=$GET(^BQI(90506.3,VFIL,10,IEN,9))
+7 NEW DA,IENS
+8 SET DA(1)=VFIL
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+9 SET MULTR=$$GET1^DIQ(90506.31,IENS,1.08,"E")
+10 ;
+11 ; Check for batch editable flag in 90506.1
+12 NEW CODE,LIEN,BATCH,LINK,LRPC,LINP
+13 SET CODE=$PIECE(VDATA,U,7)
SET BATCH="NO"
SET LINK=$PIECE(VDATA1,U,10)
+14 SET LRPC=$PIECE(VDATA9,U,1)
SET LINP=$PIECE(VDATA9,U,2)
+15 SET LIEN=$ORDER(^BQI(90506.1,"B",CODE,""))
+16 IF LIEN'=""
Begin DoDot:1
+17 SET BATCH=+$$GET1^DIQ(90506.1,LIEN_",",.17,"I")
+18 SET BATCH=$SELECT(BATCH=1:"YES",1:"NO")
End DoDot:1
+19 ;
+20 ;Check default field for API - $P(VDATA1,U,4)
+21 SET DEF=$PIECE(VDATA1,U,4)
+22 IF DEF["$$"
Begin DoDot:1
+23 NEW DVAL
+24 IF DEF["~"
SET DEF=$TRANSLATE(DEF,"~","^")
+25 XECUTE DEF
+26 SET $PIECE(VDATA1,U,4)=DVAL
End DoDot:1
+27 ;
+28 ; Check for patch requirement
+29 NEW PATCH,CHNG
+30 SET PATCH=$PIECE(VDATA2,U,10)
SET CHNG=$PIECE(VDATA2,U,11)
+31 IF PATCH'=""
Begin DoDot:1
+32 IF '$$PATCH^XPDUTL(PATCH)
QUIT
+33 IF CHNG["~"
SET CHNG=$TRANSLATE(CHNG,"~","^")
+34 XECUTE CHNG
End DoDot:1
+35 ; Set the clear fields
+36 SET CLEAR=""
SET CN=0
SET CLRFLD=""
+37 FOR
SET CN=$ORDER(^BQI(90506.3,VFIL,10,IEN,10,CN))
IF 'CN
QUIT
Begin DoDot:1
+38 SET CLEAR=CLEAR_$PIECE(^BQI(90506.3,VFIL,10,IEN,10,CN,0),"^",1)_";"
+39 SET CLRFLD=$$TKO^BQIUL1(CLEAR,";")
End DoDot:1
+40 ;
+41 ; Set up the data fields
+42 SET II=II+1
SET @DATA@(II)=VALUE_U_$PIECE(VDATA,U,1,4)_U_$PIECE(VDATA,U,12)_U_$PIECE(VDATA,U,7)_U_$PIECE(VDATA,U,14)_U
+43 FOR BJ=1:1:7,9
SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA1,U,BJ)_U
+44 SET @DATA@(II)=@DATA@(II)_BATCH_U
+45 FOR BJ=1:1:5
SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA2,U,BJ)_U
+46 SET @DATA@(II)=@DATA@(II)_$GET(^BQI(90506.3,VFIL,10,IEN,6))_U_$PIECE(VDATA,U,8)_U
+47 SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA,U,9)_U_$PIECE(VDATA,U,10)_U_$PIECE(VDATA2,U,6)_U_$PIECE(VDATA2,U,9)_U
+48 SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA2,U,7)_U_$PIECE(VDATA2,U,8)_U_MULTR_U_$PIECE(VDATA3,U,4)_U
+49 SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA3,U,5)_U_LINK_U_LRPC_U_LINP_U_CLRFLD_U
+50 ;
+51 ;Check for HELP text
+52 KILL BQIHELPW,BQIHELP
+53 SET VFLD=$PIECE(VDATA3,U,1)
SET VHELP=""
+54 IF VFLD'=""
Begin DoDot:1
+55 DO FIELD^DID(VFILN,VFLD,"","HELP-PROMPT","BQIHELP")
+56 SET VHELP=$GET(BQIHELP("HELP-PROMPT"))
+57 IF VHELP=""
Begin DoDot:2
+58 DO FIELD^DID(VFILN,VFLD,"Z","DESCRIPTION","BQIHELPW")
+59 IF $GET(BQIHELPW("DESCRIPTION"))=""
QUIT
+60 SET BN=0
SET VHELP=""
+61 FOR
SET BN=$ORDER(BQIHELPW("DESCRIPTION",BN))
IF BN=""
QUIT
Begin DoDot:3
+62 SET VHELP=VHELP_BQIHELPW("DESCRIPTION",BN,0)_$CHAR(10)
End DoDot:3
End DoDot:2
End DoDot:1
+63 IF $PIECE(VDATA3,U,6)'=""
SET VHELP=$PIECE(VDATA3,U,6)
+64 SET @DATA@(II)=@DATA@(II)_VHELP_$CHAR(30)
+65 QUIT
+66 ;
VST() ;EP - Get default visit type
+1 NEW VAL
+2 IF $GET(DUZ(2))=""
QUIT "IHS"
+3 ;S VAL=$$GET1^DIQ(9001001.2,DUZ(2)_",",.17,"E")
+4 SET VAL=$$GET1^DIQ(9001001.2,DUZ(2)_",",.17,"I")
+5 SET VAL=$$STC^BQIUL2(9000010,.03,VAL)
+6 IF VAL=""
QUIT "IHS"
+7 QUIT VAL
+8 ;
HSD() ; EP - Get Health Summary Default
+1 NEW VAL,AVAL
+2 SET AVAL=$$FIND1^DIC(9001015,,"X","ADULT REGULAR")
+3 IF $GET(DUZ(2))=""
QUIT AVAL
+4 SET VAL=$$GET1^DIQ(9001000,DUZ(2)_",",.03,"I")
+5 IF VAL=""
QUIT AVAL
+6 QUIT VAL
+7 ;
PWHD() ; EP - Get Patient Wellness Handout Default
+1 NEW VAL,AVAL
+2 IF $$VERSION^XPDUTL("BJPC")<2.0
QUIT ""
+3 SET AVAL=$$FIND1^DIC(9001026,,"X","ADULT REGULAR")
+4 IF $GET(DUZ(2))=""
QUIT AVAL
+5 SET VAL=$$GET1^DIQ(9001000,DUZ(2)_",",.16,"I")
+6 IF VAL=""
QUIT AVAL
+7 QUIT VAL
+8 ;
NMBR(PBLIEN) ; EP - Get default problem notes number
+1 ; Input
+2 ; PBLIEN - Problem IEN
+3 ; Assumes DUZ(2) for the facility
+4 NEW FACN
+5 IF PBLIEN=""
QUIT 1
+6 SET FACN=$ORDER(^AUPNPROB(PBLIEN,11,"B",DUZ(2),""))
+7 IF FACN=""
QUIT 1
+8 QUIT $ORDER(^AUPNPROB(PBLIEN,11,FACN,11,"B",""),-1)+1
+9 ;
HPRV(BKMDFN) ; EP - Get the default HIV Provider
+1 NEW VAL,BKMIEN,BKMHIV,BKMIENS,ARRAY
+2 SET BKMHIV=$$HIVIEN^BKMIXX3()
+3 SET BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN)
+4 SET BKMIENS=BKMHIV_","_BKMIEN_","
+5 SET VAL=""
+6 IF BKMIEN=""
Begin DoDot:1
+7 DO ALLDP^BDPAPI(BKMDFN,"HIV PROVIDER",.ARRAY)
+8 IF ARRAY=""
SET VAL=""
QUIT
+9 SET VAL=$PIECE(ARRAY,U,2)
End DoDot:1
+10 ;
+11 IF BKMIEN'=""
Begin DoDot:1
+12 SET VAL=$$GET1^DIQ(90451.01,BKMIENS,6,"I")
End DoDot:1
+13 QUIT VAL
+14 ;
HCSM(BKMDFN) ; EP - Get the default HIV Case Manager
+1 NEW VAL,BKMIEN,BKMHIV,BKMIENS,ARRAY
+2 SET BKMHIV=$$HIVIEN^BKMIXX3()
+3 SET BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN)
+4 SET BKMIENS=BKMHIV_","_BKMIEN_","
+5 SET VAL=""
+6 IF BKMIEN=""
Begin DoDot:1
+7 DO ALLDP^BDPAPI(BKMDFN,"HIV CASE MANAGER",.ARRAY)
+8 IF ARRAY=""
SET VAL=""
QUIT
+9 SET VAL=$PIECE(ARRAY,U,2)
End DoDot:1
+10 ;
+11 IF BKMIEN'=""
Begin DoDot:1
+12 SET VAL=$$GET1^DIQ(90451.01,BKMIENS,6.5,"I")
End DoDot:1
+13 QUIT VAL
+14 ;
USR() ;EP - Get the default user
+1 QUIT DUZ_$CHAR(28)_$PIECE($GET(^VA(200,DUZ,0)),U,1)
+2 ;
STAT() ;EP = Get the CMET status
+1 QUIT "T"_$CHAR(28)_"TRACKED"
+2 ;
TBL(FILE,VALUE) ; EP - Get a default for a specific table value
+1 NEW IEN
+2 SET IEN=$$FIND1^DIC(FILE,"","MX",VALUE,"","","ERROR")
+3 QUIT IEN_$CHAR(28)_VALUE
+4 ;
CLNCR() ; EP - Get the default for Chart Review
+1 NEW IEN
+2 SET IEN=$$FIND1^DIC(40.7,"","MX","CHART REV/REC MOD","","","ERROR")
+3 QUIT $$GET1^DIQ(40.7,IEN_",",1,"E")_$CHAR(28)_"CHART REV/REC MOD"
+4 ;
PRMS(VFIL) ;EP - Pull RPC parameters
+1 FOR BQN=3:1:6
Begin DoDot:1
+2 SET BQPARM(BQN)=""
+3 NEW IDT,PRM,TIDT,TPRM
+4 SET BQP=0
FOR
SET BQP=$ORDER(^BQI(90506.3,VFIL,BQN,BQP))
IF 'BQP
QUIT
Begin DoDot:2
+5 SET PRMND=$GET(^BQI(90506.3,VFIL,BQN,BQP,0))
+6 SET PNAM=$PIECE(PRMND,U)
+7 SET PTYP=$PIECE(PRMND,U,2)
IF PTYP=""
SET PTYP=$SELECT(PNAM["=":"P",1:"I")
+8 SET PORD=$PIECE(PRMND,U,3)
IF PORD=""
SET PORD=BQP_PNAM
+9 ;
+10 ;Temp Store of Unique Identifiers
+11 IF PTYP="I"
Begin DoDot:3
+12 SET TIDT(PORD)=PRMND
End DoDot:3
+13 ;
+14 ;Temp Store of Regular Parameters
+15 IF PTYP="P"
Begin DoDot:3
+16 SET TPRM(PORD)=PRMND
End DoDot:3
End DoDot:2
+17 ;
+18 ;Form Parameter String
+19 SET IDT=""
SET BQP=""
FOR
SET BQP=$ORDER(TIDT(BQP))
IF BQP=""
QUIT
SET IDT=IDT_$SELECT(IDT]"":";",1:"")_$PIECE(TIDT(BQP),U)
+20 SET PRM=""
SET BQP=""
FOR
SET BQP=$ORDER(TPRM(BQP))
IF BQP=""
QUIT
SET PRM=PRM_$SELECT(PRM]"":$CHAR(28),1:"")_$PIECE(TPRM(BQP),U)
+21 SET BQPARM(BQN)=IDT_$SELECT(IDT]"":";",1:"")_PRM
+22 SET BQPARM(BQN)=$$TKO^BQIUL1(BQPARM(BQN),";")
End DoDot:1
+23 QUIT
+24 ;
EVT(EVIEN,POS) ;EP - Event Default
+1 NEW EVTYPE,EVVALUE,IVALIEN,EIEN,TY
+2 SET EVTYPE=""
SET EVVALUE=""
SET IVALIEN=""
SET EIEN=""
+3 IF $GET(EVIEN)=""
QUIT ""
+4 SET TY=$$GET1^DIQ(90621,EVIEN_",",.12,"I")
+5 IF TY'=""
SET EVTYPE=$$GET1^DIQ(90621.1,TY_",",.09,"E")
+6 IF TY'=""
SET EIEN=$ORDER(^BTPW(90621,EVIEN,1,"C",TY,""))
+7 IF $GET(EIEN)'=""
Begin DoDot:1
+8 SET EVVALUE=$PIECE(^BTPW(90621,EVIEN,1,EIEN,0),"^",5)
SET IVALIEN=$PIECE(^(0),"^",6)
SET TAXIEN=$PIECE(^(0),U,2)
End DoDot:1
+9 IF POS=1
QUIT $GET(EVTYPE)
+10 IF POS=2
QUIT $GET(EVVALUE)
+11 IF POS=3
QUIT $GET(IVALIEN)
+12 IF POS=4
QUIT $GET(TAXIEN)
