VIABRPC ;AAC/JMC - VIA RPCs ;04/05/2016
;;1.0;VISTA INTEGRATION ADAPTER;**7,8,9,12,22,21**;06-FEB-2014;Build 1
;Per VA Directive 6402, this routine should not be modified.
; ICR 10090 INSTITUTION FILE (supported)
; ICR 10048 PACKAGE FILE (#9.4) (supported)
; ICR 10141 XPDUTL (supported)
; ICR 3213 XQALSURO (Supported)
; ICR 2533 DBIA2533 (Controlled)
; ICR 3119 Consult Default Reason for Request [GETDEF^GMRCDRFR & $$REAF^GMRCDRFR]
; ICR 2968 Direct access to file 34
; ICR 2664 OBSERVATION API [$$PT^DGPMOBS] (supported)
; ICR 1365 DBIA1365 [DSELECT^GMPLENFM] (controlled)
; ICR 4075 OR CALL TO TIUSRVP [VSTRBLD^TIUSRVP] (private)
; ICR 3121 Consult Ordering Utilities [$$PROVDX^GMRCUTL1]
; ICR 1894 DBIA1889-F [GETENC^PXAPI](controlled)
; ICR 3540 TIUSRVP, Entry Point: FILE [FILE^TIUSRVP] (controlled)
; ICR 142 DBIA142-A [File #31, field #.01] (controlled)
; ICR 649 DBIA186-I [File 391, field .02] (controlled)
; ICR 2348 SERVICE CONNECTED CONDITIONS [SCCOND^PXUTLSCC] (controlled)
; ICR 1296 DBIA 1296 GETLST~IBDF18A [GETLST^IBDF18A] (Controlled)
; ICR 6473 ICR6473 - PROSTHETICS SERVICE [Read field #131 of File #123.5] (private)
; ICR 6663 PXVIMM IMM SHORT LIST [IMMSHORT^PXVRPC4] (controlled)
; ICR 2429 USE OF LR7OV4 CALLS [SHOW^LR7OV4] (controlled)
; ICR 3167 3167 [STARTSTP^PSJORPOE]
; ICR 3771 XUDHGUI [DEVICE^XUDHGUI] (supported)
; ICR 3540 TIUSRVP, Entry Point: FILE [FILE^TIUSRVP] (controlled)
; ICR 6478 NOTEVSTR (TIU DOCUMENT File #8925)(private)
; ICR 4807 API FOR RATED DISABILITIES [RDIS^DGRPDB] (supported)
; ICR 1995 CPT Code APIs [CODM^ICPTCOD] (supported)
; ICR 5679 LEXU (ICD-10 UPDATE) [IMPDATE^LEXU] (supported)
; ICR 2378 DBIA3278 [DSUP^PSOSIGDS] (private)
; ICR 1889 ADD/EDIT/DELETE PCE DATA SILENTLY [DATA2PCE^PXAPI]
; ICR 2533 DBIA2533 [DIV4^DIV4^XUSER] (controlled)
; ICR 5408 CPT/HCPCS Procedure File 81 (supported)
; ICR 1995 CPT Code APIs - $$CPTD^ICPTCOD (supported)
;
GETSURR(RESULT,USER) ; surrogate info.
;RPC VIAB GETSURR
; get user's surrogate info
I $G(USER)="" S RESULT="" Q
S RESULT=$$GETSURO^XQALSURO(USER) ;ICR(DBIA) #3213
I +RESULT<1 S RESULT=""
Q
SNAME(RET,SID) ; get station/site name
;RPC VIAB SITENAME
N SIEN
I $G(SID)="" S RET="-1^Missing Station Number or Site ID" Q
S SIEN=$O(^DIC(4,"D",SID,0)) I 'SIEN S RET="-1^No site found for this Station Number or Site ID" Q
; ICR(DBIA) #10090 (SUPPORTED)
S RET=$$GET1^DIQ(4,SIEN,.01,"E")
Q
USERDIV(RESULT,VIADUZ) ; station IEN^station number^station name^default division
;RPC GET USER DIVISIONS
K RESULT
N VIADX,VIADR,VIADC
S VIADC=0
D DIV4^XUSER(.VIADR,VIADUZ)
S VIADX=0
F S VIADX=$O(VIADR(VIADX)) Q:'VIADX!($D(RESULT(1))) D
.I VIADR(VIADX)=1 S VIADC=VIADC+1,RESULT(VIADC)=VIADX_"^"_$$GET1^DIQ(4,+VIADX,99)_"^"_$$GET1^DIQ(4,+VIADX,.01,)_"^1" K VIADR(VIADX)
S VIADX=0
F S VIADX=$O(VIADR(VIADX)) Q:'VIADX D
.S VIADC=VIADC+1
.S RESULT(VIADC)=VIADX_"^"_$$GET1^DIQ(4,+VIADX,99)_"^"_$$GET1^DIQ(4,+VIADX,.01)_"^0"
Q
;
DEFRFREQ(RESULT,VIAIEN,VIADFN,RESOLVE) ;Return default reason for request for service - ICR #3119
;RPC VIAB DEFAULT REQUEST REASON
; VIAIEN=pointer to file 123.5
; VIADFN=patient, if RESOLVE=1
; RESOLVE=1 to resolve boilerplate, 0 to not resolve
Q:+$G(VIAIEN)=0
I +RESOLVE,(+$G(VIADFN)=0) Q
S RESULT=$NA(^TMP("VIABREQ",$J))
S:$G(RESOLVE)="" RESOLVE=0
D GETDEF^GMRCDRFR(.RESULT,VIAIEN,VIADFN,RESOLVE)
K @RESULT@(0)
Q
;
EDITDRFR(RESULT,VIAIEN) ; Allow editing of reason for request? - ICR #3119
;RPC VIAB EDIT DEFAULT REASON
S RESULT=$$REAF^GMRCDRFR(VIAIEN)
Q
;
RADSRC(RESULT,SRCTYPE) ; return list of available contract/sharing/research sources - ICR #2968
;RPC VIAB RADSRC
N VIAX
S VIAX=0
F I=1:1 S VIAX=$O(^DIC(34,VIAX)) Q:+VIAX=0 D
. Q:($P(^DIC(34,VIAX,0),U,2)'=SRCTYPE)
. I $D(^DIC(34,VIAX,"I")),(^DIC(34,VIAX,"I")<$$NOW^XLFDT) Q
. S RESULT(I)=VIAX_U_$P(^DIC(34,VIAX,0),U,1)
Q
;
CURSPE(RESULT,PTDFN) ; Return current treating specialty - ICR #2664
;RPC VIAB CURSPE
Q:'PTDFN
N SPEC S SPEC=$$PT^DGPMOBS(PTDFN),RESULT=""
I SPEC'<0 S RESULT=$P(SPEC,U,3)_U_$P(SPEC,U,2)_U_$P(SPEC,U) ;name^ien^obs flag
Q
;
CPTMODS(RESULT,VIACPTCOD,VIADATE) ;Return CPT Modifiers for a CPT Code - ICR #1995
;RPC VIAB CPTMODS
N VIAM,VIAIDX,VIAI,MODNAME
S:'+$G(VIADATE) VIADATE=DT
I +($$CODM^ICPTCOD(VIACPTCOD,$NA(VIAM),0,VIADATE)),+$D(VIAM) D
. S VIAIDX="",VIAI=0
. F S VIAIDX=$O(VIAM(VIAIDX)) Q:(VIAIDX="") D
. . S VIAI=VIAI+1,MODNAME=$P(VIAM(VIAIDX),U,1)
. . S RESULT(MODNAME_VIAI)=$P(VIAM(VIAIDX),U,2)_U_MODNAME_U_VIAIDX
Q
;
ACTPROB(RESULT,DFN,VIADATE) ;get list of patient's active problems - ICR #1365
;RPC VIAB ACTPROB
N VIAPROB,VIAPROBIX,VIAPRCNT,GMPINDT,VIAIMPDT
K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
S:'+$G(VIADATE) VIADATE=DT
S GMPINDT=VIADATE,VIAIMPDT=$$IMPDATE^LEXU("10D")
D DSELECT^GMPLENFM ;DBIA 1365
S VIAPRCNT=0
S VIAPROBIX=0
F S VIAPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX)) Q:'VIAPROBIX D ;DBIA 1365
. I (VIADATE<VIAIMPDT)&($P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX),"^",14)="10D") K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX) Q
. S VIAPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX),"^",2,3)
. I $L(VIAPROB)>255 S $P(VIAPROB,U)=$E($P(VIAPROB,U),1,245)
. I $E(VIAPROB,1)="$" S VIAPROB=$E(VIAPROB,2,255)
. I '$D(VIAPROB(VIAPROB)) D
.. S VIAPROB(VIAPROB)=""
.. S VIAPRCNT=VIAPRCNT+1
.. S $P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX),"^",2,3)=VIAPROB
. E K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX)
S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=VIAPRCNT
S RESULT=$NA(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS"))
Q
;
NOTEVSTR(RESULT,IEN) ; return the VSTR^AUTHOR for a note -; ICR#4075
;RPC VIAB NOTEVSTR
N X0,X12,VISIT
S X0=$G(^TIU(8925,+IEN,0)),X12=$G(^(12)),VISIT=$P(X12,U,7)
I +VISIT S RESULT=$$VSTRBLD^TIUSRVP(VISIT) I 1
E S RESULT=$P(X12,U,11)_";"_$P(X0,U,7)_";"_$P(X0,U,13)
Q
;
PROVDX(RESULT,VIAIEN) ;Return provisional dx prompting info for service; ICR#3121
;This RPC is a similar to ORQQCN PROVDX
;RPC VIAB PROVDX
S RESULT=$$PROVDX^GMRCUTL1($G(VIAIEN))
Q
;
ISPROSVC(RESULT,GMRCIEN) ; Is this service part of the consults-prosthetics interface? ICR #6473
;RPC VIAB ISPROSVC
;This RPC is a similar to ORQQCN ISPROSVC
;GMRCIEN - IEN of selected service
I $$GET1^DIQ(123.5,+$G(GMRCIEN),131,"I")=1 S RESULT=1
Q
;
SECVST(RESULT,NOTEIEN,VIADFN,VIAENCDT,VIAHLOC) ; save secondary visit in TIU, if inpatient; ICR#1894,#3540
;RPC VIAB TIU SECVST
N VIAVST
S RESULT=0
I +$G(NOTEIEN),+$G(VIADFN),+$G(VIAENCDT),$G(VIAHLOC)'="" D ; NOTEIEN only set on inpatient encounters
. S VIAVST=$$GETENC^PXAPI(VIADFN,VIAENCDT,VIAHLOC)
. I +VIAVST>0 D
. . ;I $$GET1^DIQ(8925,NOTEIEN,.03,"I")=VIAVST Q
. . N VIAOK,VIAX
. . S VIAX(1207)=VIAVST
. . D FILE^TIUSRVP(.VIAOK,NOTEIEN,.VIAX,1)
. . M RESULT=VIAOK
Q
;
SCDIS(RESULT,DFN) ; Return service connected % and rated disabilities; ICR#10061,#649,#4807,#142
;RPC VIAB SCDIS
;This RPC is a similar to ORWPCE SCDIS
N VAEL,VAERR,VIARR,I,ILST,DIS,SC,X
D ELIG^VADPT
S RESULT(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
I 'VAEL(4),'$$GET1^DIQ(391,+VAEL(6),.02,"I") S RESULT(2)="NOT A VETERAN." Q
D RDIS^DGRPDB(DFN,.VIARR)
S I=0,ILST=1 F S I=$O(VIARR(I)) Q:'I S X=VIARR(I) D
. S DIS=$$GET1^DIQ(31,+X,.01,"I") Q:DIS=""
. S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
. S ILST=ILST+1,RESULT(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
I ILST=1 S RESULT(2)="Rated Disabilities: NONE STATED"
Q
;
SCSEL(RESULT,DFN,APPDT,HLOC,VST) ; return SC conditions that maRESULT be selected; ICR#2348
;RPC VIAB SCSEL
;This RPC is a similar to ORWPCE SCSEL
; RESULT=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt;
; MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt;SHADAllow^SHADDflt
N VIAB,S
S S=";"
D SCCOND^PXUTLSCC(DFN,APPDT,HLOC,$G(VST),.VIAB)
S RESULT=$G(VIAB("SC"))_S_$G(VIAB("AO"))_S_$G(VIAB("IR"))_S_$G(VIAB("EC"))_S_$G(VIAB("MST"))_S_$G(VIAB("HNC"))_S_$G(VIAB("CV"))_S_$G(VIAB("SHAD"))
Q
;
VISIT(RESULT,CLINIC,VIADATE) ; get list of visit types for clinic; ICR#1296
;RPC VIAB VISIT
;This RPC is a similar to ORWPCE VISIT
S:'+$G(VIADATE) VIADATE=DT
D GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","RESULT",,,,VIADATE)
Q
;
IMMTYPE(RESULT,VIACVXS) ;get the list of active immunizations; ICR#6663
;RPC VIAB GET IMMUNIZATION TYPE
;Check for CVX codes passed
I $G(VIACVXS) D IMMTYPE2(.RESULT,VIACVXS) Q
;If no CVX codes, then return full list
N CNT,X,Y,VIARES,VIARY
S CNT=0
D IMMSHORT^PXVRPC4(.VIARES,"A")
S X="" F S X=$O(VIARES(X)) Q:X="" S Y=VIARES(X) I $P(Y,"^")="IMM" S VIARY($P(Y,"^",3)_"^"_$P(Y,"^",2))=""
S X="" F S X=$O(VIARY(X)) Q:X="" S CNT=CNT+1,RESULT(CNT)=$P(X,"^",2)_"^"_$P(X,"^")
Q
;
IMMTYPE2(RESULT,VIACVXS) ;get one or more active immunizations by CVX code; ICR#6663
;RPC VIAB GET IMMUNIZATION TYPE
N A,I,II,JJ,CNT,CPTS,X,XX,Y,YY,VIARES,VIARY,VIACVX,VIACPT,ZXX,ZYY,ZZZ,PATH,ZCPT,VIAFND,CPTNAM,DATA,ZCPT2,CPT2,DIWL,DIWR
S CNT=0,X=""
;just in case, if no CVX code then return list
I '$G(VIACVXS) D IMMTYPE2(.RESULT) Q
F I=1:1:$L(VIACVXS,";") S X=$P(VIACVXS,";",I) D
.Q:X="" ;in case of leading or ending commas
.S VIACVX(X)=""
D IMMSHORT^PXVRPC4(.VIARES,"A")
S XX="" F S XX=$O(VIARES(XX)) Q:XX="" S YY=VIARES(XX) I $P(YY,"^")="IMM",$D(VIACVX($P(YY,"^",4))) D
.K VIACPT
.D GETS^DIQ(9999999.14,$P(YY,"^",2),"3*","I","VIACPT")
.S (VIAFND,JJ,ZZZ,ZYY,ZXX,PATH,ZCPT,ZCPT2,CPTNAM)=""
.;get the first CPT despite what the multiple within the multiple IEN may be
.F S ZXX=$O(VIACPT(9999999.143,ZXX)) Q:ZXX="" F S ZYY=$O(VIACPT(9999999.143,ZXX,ZYY)) Q:ZYY="" D
..I $G(VIACPT(9999999.143,ZXX,ZYY,"I"))="CPT" S CPT2(ZXX)=""
.K ZCPT S ZCPT=""
.F II=1:1 S PATH=$O(VIACPT(9999999.1431,II_","_PATH)) Q:PATH="" I $D(CPT2($P(PATH,",",2,3)_",")) D
..I $G(VIACPT(9999999.1431,PATH,.01,"I")) S ZCPT2=VIACPT(9999999.1431,PATH,.01,"I") D
...;get the CPT description and combine multiple lines into one
...K DATA S A=$$CPTD^ICPTCOD(ZCPT2,"DATA")
...; using DIWR=220 to give room for other fields in 256 length
...S DIWL=1,DIWR=220,ZCPT="" K ^UTILITY($J,"W") F S JJ=$O(DATA(JJ)) Q:JJ="" S X=DATA(JJ) D ^DIWP
...S J=0 F S J=$O(^UTILITY($J,"W",DIWL,J)) Q:J="" S ZCPT=ZCPT_" "_^UTILITY($J,"W",DIWL,J,0)
...S ZCPT(ZCPT2)=$E(ZCPT,2,999)
..K CPTS S (CPTS,ZCPT2)=""
.S (CPTS,ZCPT2)="" F S ZCPT2=$O(ZCPT(ZCPT2)) Q:ZCPT2="" S CPTS=CPTS_";"_ZCPT2_"|"_ZCPT(ZCPT2)
.S VIARY($P(YY,"^",3)_"^"_$P(YY,"^",4)_"^"_$P(YY,"^",2))=$E(CPTS,2,9999)
S X="" F S X=$O(VIARY(X)) Q:X="" S CNT=CNT+1,RESULT(CNT)=$P(X,"^",3)_"^"_$P(X,"^")_"^"_$P(X,"^",2)_"^"_VIARY(X)
K ^UTILITY($J,"W")
Q
;
IMMCOLL(RESULT) ; Return help screen showing immediate collect times;ICR#-2429
;RPC VIAB IMMED COLLECT
;This RPC is a similar to ORWDLR32 IMMED COLLECT
I $G(DUZ(2))="" Q
D SHOW^LR7OV4(DUZ(2),.RESULT)
Q
;
ADMIN(RESULT,DFN,SCH,OI,LOC,ADMIN) ; return administration time info;ICR-#2843,10040,10035,3167
;RPC VIAB ADMIN
;This RPC is a similar to ORWDPS2 ADMIN
; RESULT: StartText^StartTime^Duration^FirstAdmin
I ($G(OI)="")!($G(LOC)="") Q
S OI=+$$GET1^DIQ(101.43,+OI,2,"I")
S LOC=+$$GET1^DIQ(44,+LOC,42,"I"),RESULT=""
I $L($G(^DPT(DFN,.1))) S RESULT=$$FIRST(DFN,LOC,OI,$G(SCH),"",$G(ADMIN))
Q
;
FIRST(DFN,WARD,OI,DATA,ORDER,ADMIN) ; -- Return expected first admin time of order;ICR-#3167
N CNT,ORCNT,ORI,J,ORZ,Y,SCH,ORX,TNUM
I '$G(DFN)!'$G(OI) Q ""
S ORCNT=0 F ORI=1:1:$L(DATA,"^") S ORZ=$P(DATA,U,ORI) D Q:$E(ORZ)="T"
.S TNUM=$$NUMCHAR(ORZ,";") Q:TNUM=0
.F CNT=1:1:TNUM D
.. S SCH=$P(ORZ,";",CNT+1) Q:'$L(SCH) S ORCNT=ORCNT+1
.. I ORCNT>1 S ADMIN=""
.. S ORX(ORCNT)=$$STARTSTP^PSJORPOE(DFN,SCH,OI,WARD,$G(ORDER),$G(ADMIN))
S Y=9999999,J=0
F ORI=1:1:ORCNT S ORZ=$P(ORX(ORI),U,4) I ORZ<Y S Y=ORZ,J=ORI ;earliest
S Y=$S(J:ORX(J),1:"")
Q Y
;
NUMCHAR(STRING,SUB) ;
N CNT,RESULT
S RESULT=0
F CNT=1:1:$L(STRING) I $E(STRING,CNT)=SUB S RESULT=RESULT+1
Q RESULT
;
DFLTSPLY(RESULT,UPD,SCH,PAT,DRG,OI) ; return days supply given quantity;ICR-#2843,3278
;RPC VIAB DFLTSPLY
;This RPC is a similar to ORWDPS1 DFLTSPLY
; RESULT: default days supply
N VIABX,I,PSOI,TPKG
S VIABX("PATIENT")=$G(PAT)
I $G(DRG) S VIABX("DRUG")=DRG
I $D(OI) D
. S TPKG=$$GET1^DIQ(101.43,+$G(OI),2,"I") Q:TPKG'["PS"
. S PSOI=+TPKG Q:PSOI'>0
. S VIABX("OI")=PSOI
F I=1:1:$L($G(UPD),U)-1 D
. S VIABX("DOSE ORDERED",I)=$P($G(UPD),U,I)
. S VIABX("SCHEDULE",I)=$P($G(SCH),U,I)
D DSUP^PSOSIGDS(.VIABX)
S RESULT=$G(VIABX("DAYS SUPPLY"))
Q
;
DEVICE(RESULT,FROM,DIR,MARGIN) ; Return a subset of printer entries from the Device file;ICR-#3771
;RPC VIAB DEVICE
; -- Return up to 20 entries from the Device file based on Input criteria
; INPUT
; FROM : List all printers start from (text to $O from)
; B (all device with name start *WITH* B)
; B* (all device with name start *FROM* B)
; DIR : Ascending order (1) or Descending order (-1) ($O direction)
; MARGIN - Right margin (e.g, 80, 132 or "80-132")
;
; OUTPUT
; RESULT : By reference local array contains VistA printers based on input criteria
; RESULT(1..n)=IEN^Name^DisplayName^Location^RMar^PLen
;
K RESULT
S FROM=$G(FROM)
S DIR=$G(DIR,1)
S MARGIN=$G(MARGIN)
D DEVICE^XUDHGUI(.RESULT,FROM,DIR,MARGIN)
Q
;
SAVE(OK,PCELIST,NOTEIEN,VIALOC) ; save PCE information
;INPUTS:
; PCELIST - LIST OF ENCOUNTER DATA
; NOTEIEN - TIU NOTE INTERNAL ENTRY NUMBER [Optional]
; VIALOC - INPATIENT STATION [Optional]
;OUTPUT:
; ARRAY with success or error code followed by problems encountered on data elements
; The array may contain the following values:
;
; 1 Indicates success - no errors and processed completely.
;
; -1 An error occurred. Data may or may not have been processed depending on nature of data.
;
; -2 Indicates that the routine PXAI found an issue with the visit.
;
; -3 Indicates that the input parameters were not properly defined.
;
; -4 If cannot get a lock on the encounter
;
; -5 If there were only warnings
;
; Subsequent values will vary depending on findings from DATA2PCE^PXAPI.
; the following is an example:
;
;Example:
; OK(0)="-1^Missing Required Fields"
; OK(1)="AO^No error"
; OK(2)="CV^NULL"
; OK(3)="EC^No error"
; OK(4)="HNC"^No error"
; OK(5)="IR^No error"
; OK(6)="MST"^No error"
; OK(7)="SC^Value must be NULL"
; OK(8)="SHAD^1"
;
S:$G(VIALOC)="" VIALOC="VISTA INTEGRATION ADAPTER"
N VSTR,GMPLUSER,VOK ;*21 added VOK
N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
S VSTR=$P(PCELIST(1),U,4) K ^TMP("VIAPCE",$J,VSTR)
M ^TMP("VIAPCE",$J,VSTR)=PCELIST
S GMPLUSER=$$CLINUSER(DUZ),NOTEIEN=+$G(NOTEIEN)
D DQSAVE^VIABRPC7
M OK=VOK ;*21 changed return to array
Q
;
CLINUSER(VIADUZ) ;is this a clinical user?
N VIAUSER
S VIAUSER=0
I $D(^XUSEC("ORES",VIADUZ)) S VIAUSER=1
I $D(^XUSEC("ORELSE",VIADUZ)) S VIAUSER=1
I $D(^XUSEC("PROVIDER",VIADUZ)) S VIAUSER=1
Q VIAUSER
;
GETVSIT(VSTR,DFN) ; lookup a visit
N PKG,SRC,VIAPXAPI,OK,VIAVISIT
S PKG=$O(^DIC(9.4,"B","VISTA INTEGRATION ADAPTER",0))
S SRC="TEXT INTEGRATION UTILITIES"
S VIAPXAPI("ENCOUNTER",1,"ENC D/T")=$P(VSTR,";",2)
S VIAPXAPI("ENCOUNTER",1,"PATIENT")=DFN
S VIAPXAPI("ENCOUNTER",1,"HOS LOC")=+VSTR
S VIAPXAPI("ENCOUNTER",1,"SERVICE CATEGORY")=$P(VSTR,";",3)
S VIAPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
S OK=$$DATA2PCE^PXAPI("VIAPXAPI",PKG,SRC,.VIAVISIT)
Q VIAVISIT
;
PATCH(VAL,X) ; Return 1 if patch X is installed *22
S VAL=$$PATCH^XPDUTL(X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVIABRPC 16209 printed Apr 09, 2024@21:47:29 Page 2
VIABRPC ;AAC/JMC - VIA RPCs ;04/05/2016
+1 ;;1.0;VISTA INTEGRATION ADAPTER;**7,8,9,12,22,21**;06-FEB-2014;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ; ICR 10090 INSTITUTION FILE (supported)
+4 ; ICR 10048 PACKAGE FILE (#9.4) (supported)
+5 ; ICR 10141 XPDUTL (supported)
+6 ; ICR 3213 XQALSURO (Supported)
+7 ; ICR 2533 DBIA2533 (Controlled)
+8 ; ICR 3119 Consult Default Reason for Request [GETDEF^GMRCDRFR & $$REAF^GMRCDRFR]
+9 ; ICR 2968 Direct access to file 34
+10 ; ICR 2664 OBSERVATION API [$$PT^DGPMOBS] (supported)
+11 ; ICR 1365 DBIA1365 [DSELECT^GMPLENFM] (controlled)
+12 ; ICR 4075 OR CALL TO TIUSRVP [VSTRBLD^TIUSRVP] (private)
+13 ; ICR 3121 Consult Ordering Utilities [$$PROVDX^GMRCUTL1]
+14 ; ICR 1894 DBIA1889-F [GETENC^PXAPI](controlled)
+15 ; ICR 3540 TIUSRVP, Entry Point: FILE [FILE^TIUSRVP] (controlled)
+16 ; ICR 142 DBIA142-A [File #31, field #.01] (controlled)
+17 ; ICR 649 DBIA186-I [File 391, field .02] (controlled)
+18 ; ICR 2348 SERVICE CONNECTED CONDITIONS [SCCOND^PXUTLSCC] (controlled)
+19 ; ICR 1296 DBIA 1296 GETLST~IBDF18A [GETLST^IBDF18A] (Controlled)
+20 ; ICR 6473 ICR6473 - PROSTHETICS SERVICE [Read field #131 of File #123.5] (private)
+21 ; ICR 6663 PXVIMM IMM SHORT LIST [IMMSHORT^PXVRPC4] (controlled)
+22 ; ICR 2429 USE OF LR7OV4 CALLS [SHOW^LR7OV4] (controlled)
+23 ; ICR 3167 3167 [STARTSTP^PSJORPOE]
+24 ; ICR 3771 XUDHGUI [DEVICE^XUDHGUI] (supported)
+25 ; ICR 3540 TIUSRVP, Entry Point: FILE [FILE^TIUSRVP] (controlled)
+26 ; ICR 6478 NOTEVSTR (TIU DOCUMENT File #8925)(private)
+27 ; ICR 4807 API FOR RATED DISABILITIES [RDIS^DGRPDB] (supported)
+28 ; ICR 1995 CPT Code APIs [CODM^ICPTCOD] (supported)
+29 ; ICR 5679 LEXU (ICD-10 UPDATE) [IMPDATE^LEXU] (supported)
+30 ; ICR 2378 DBIA3278 [DSUP^PSOSIGDS] (private)
+31 ; ICR 1889 ADD/EDIT/DELETE PCE DATA SILENTLY [DATA2PCE^PXAPI]
+32 ; ICR 2533 DBIA2533 [DIV4^DIV4^XUSER] (controlled)
+33 ; ICR 5408 CPT/HCPCS Procedure File 81 (supported)
+34 ; ICR 1995 CPT Code APIs - $$CPTD^ICPTCOD (supported)
+35 ;
GETSURR(RESULT,USER) ; surrogate info.
+1 ;RPC VIAB GETSURR
+2 ; get user's surrogate info
+3 IF $GET(USER)=""
SET RESULT=""
QUIT
+4 ;ICR(DBIA) #3213
SET RESULT=$$GETSURO^XQALSURO(USER)
+5 IF +RESULT<1
SET RESULT=""
+6 QUIT
SNAME(RET,SID) ; get station/site name
+1 ;RPC VIAB SITENAME
+2 NEW SIEN
+3 IF $GET(SID)=""
SET RET="-1^Missing Station Number or Site ID"
QUIT
+4 SET SIEN=$ORDER(^DIC(4,"D",SID,0))
IF 'SIEN
SET RET="-1^No site found for this Station Number or Site ID"
QUIT
+5 ; ICR(DBIA) #10090 (SUPPORTED)
+6 SET RET=$$GET1^DIQ(4,SIEN,.01,"E")
+7 QUIT
USERDIV(RESULT,VIADUZ) ; station IEN^station number^station name^default division
+1 ;RPC GET USER DIVISIONS
+2 KILL RESULT
+3 NEW VIADX,VIADR,VIADC
+4 SET VIADC=0
+5 DO DIV4^XUSER(.VIADR,VIADUZ)
+6 SET VIADX=0
+7 FOR
SET VIADX=$ORDER(VIADR(VIADX))
if 'VIADX!($DATA(RESULT(1)))
QUIT
Begin DoDot:1
+8 IF VIADR(VIADX)=1
SET VIADC=VIADC+1
SET RESULT(VIADC)=VIADX_"^"_$$GET1^DIQ(4,+VIADX,99)_"^"_$$GET1^DIQ(4,+VIADX,.01,)_"^1"
KILL VIADR(VIADX)
End DoDot:1
+9 SET VIADX=0
+10 FOR
SET VIADX=$ORDER(VIADR(VIADX))
if 'VIADX
QUIT
Begin DoDot:1
+11 SET VIADC=VIADC+1
+12 SET RESULT(VIADC)=VIADX_"^"_$$GET1^DIQ(4,+VIADX,99)_"^"_$$GET1^DIQ(4,+VIADX,.01)_"^0"
End DoDot:1
+13 QUIT
+14 ;
DEFRFREQ(RESULT,VIAIEN,VIADFN,RESOLVE) ;Return default reason for request for service - ICR #3119
+1 ;RPC VIAB DEFAULT REQUEST REASON
+2 ; VIAIEN=pointer to file 123.5
+3 ; VIADFN=patient, if RESOLVE=1
+4 ; RESOLVE=1 to resolve boilerplate, 0 to not resolve
+5 if +$GET(VIAIEN)=0
QUIT
+6 IF +RESOLVE
IF (+$GET(VIADFN)=0)
QUIT
+7 SET RESULT=$NAME(^TMP("VIABREQ",$JOB))
+8 if $GET(RESOLVE)=""
SET RESOLVE=0
+9 DO GETDEF^GMRCDRFR(.RESULT,VIAIEN,VIADFN,RESOLVE)
+10 KILL @RESULT@(0)
+11 QUIT
+12 ;
EDITDRFR(RESULT,VIAIEN) ; Allow editing of reason for request? - ICR #3119
+1 ;RPC VIAB EDIT DEFAULT REASON
+2 SET RESULT=$$REAF^GMRCDRFR(VIAIEN)
+3 QUIT
+4 ;
RADSRC(RESULT,SRCTYPE) ; return list of available contract/sharing/research sources - ICR #2968
+1 ;RPC VIAB RADSRC
+2 NEW VIAX
+3 SET VIAX=0
+4 FOR I=1:1
SET VIAX=$ORDER(^DIC(34,VIAX))
if +VIAX=0
QUIT
Begin DoDot:1
+5 if ($PIECE(^DIC(34,VIAX,0),U,2)'=SRCTYPE)
QUIT
+6 IF $DATA(^DIC(34,VIAX,"I"))
IF (^DIC(34,VIAX,"I")<$$NOW^XLFDT)
QUIT
+7 SET RESULT(I)=VIAX_U_$PIECE(^DIC(34,VIAX,0),U,1)
End DoDot:1
+8 QUIT
+9 ;
CURSPE(RESULT,PTDFN) ; Return current treating specialty - ICR #2664
+1 ;RPC VIAB CURSPE
+2 if 'PTDFN
QUIT
+3 NEW SPEC
SET SPEC=$$PT^DGPMOBS(PTDFN)
SET RESULT=""
+4 ;name^ien^obs flag
IF SPEC'<0
SET RESULT=$PIECE(SPEC,U,3)_U_$PIECE(SPEC,U,2)_U_$PIECE(SPEC,U)
+5 QUIT
+6 ;
CPTMODS(RESULT,VIACPTCOD,VIADATE) ;Return CPT Modifiers for a CPT Code - ICR #1995
+1 ;RPC VIAB CPTMODS
+2 NEW VIAM,VIAIDX,VIAI,MODNAME
+3 if '+$GET(VIADATE)
SET VIADATE=DT
+4 IF +($$CODM^ICPTCOD(VIACPTCOD,$NAME(VIAM),0,VIADATE))
IF +$DATA(VIAM)
Begin DoDot:1
+5 SET VIAIDX=""
SET VIAI=0
+6 FOR
SET VIAIDX=$ORDER(VIAM(VIAIDX))
if (VIAIDX="")
QUIT
Begin DoDot:2
+7 SET VIAI=VIAI+1
SET MODNAME=$PIECE(VIAM(VIAIDX),U,1)
+8 SET RESULT(MODNAME_VIAI)=$PIECE(VIAM(VIAIDX),U,2)_U_MODNAME_U_VIAIDX
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
ACTPROB(RESULT,DFN,VIADATE) ;get list of patient's active problems - ICR #1365
+1 ;RPC VIAB ACTPROB
+2 NEW VIAPROB,VIAPROBIX,VIAPRCNT,GMPINDT,VIAIMPDT
+3 KILL ^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
+4 if '+$GET(VIADATE)
SET VIADATE=DT
+5 SET GMPINDT=VIADATE
SET VIAIMPDT=$$IMPDATE^LEXU("10D")
+6 ;DBIA 1365
DO DSELECT^GMPLENFM
+7 SET VIAPRCNT=0
+8 SET VIAPROBIX=0
+9 ;DBIA 1365
FOR
SET VIAPROBIX=$ORDER(^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX))
if 'VIAPROBIX
QUIT
Begin DoDot:1
+10 IF (VIADATE<VIAIMPDT)&($PIECE(^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX),"^",14)="10D")
KILL ^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX)
QUIT
+11 SET VIAPROB=$PIECE(^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX),"^",2,3)
+12 IF $LENGTH(VIAPROB)>255
SET $PIECE(VIAPROB,U)=$EXTRACT($PIECE(VIAPROB,U),1,245)
+13 IF $EXTRACT(VIAPROB,1)="$"
SET VIAPROB=$EXTRACT(VIAPROB,2,255)
+14 IF '$DATA(VIAPROB(VIAPROB))
Begin DoDot:2
+15 SET VIAPROB(VIAPROB)=""
+16 SET VIAPRCNT=VIAPRCNT+1
+17 SET $PIECE(^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX),"^",2,3)=VIAPROB
End DoDot:2
+18 IF '$TEST
KILL ^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBIX)
End DoDot:1
+19 SET ^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=VIAPRCNT
+20 SET RESULT=$NAME(^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS"))
+21 QUIT
+22 ;
NOTEVSTR(RESULT,IEN) ; return the VSTR^AUTHOR for a note -; ICR#4075
+1 ;RPC VIAB NOTEVSTR
+2 NEW X0,X12,VISIT
+3 SET X0=$GET(^TIU(8925,+IEN,0))
SET X12=$GET(^(12))
SET VISIT=$PIECE(X12,U,7)
+4 IF +VISIT
SET RESULT=$$VSTRBLD^TIUSRVP(VISIT)
IF 1
+5 IF '$TEST
SET RESULT=$PIECE(X12,U,11)_";"_$PIECE(X0,U,7)_";"_$PIECE(X0,U,13)
+6 QUIT
+7 ;
PROVDX(RESULT,VIAIEN) ;Return provisional dx prompting info for service; ICR#3121
+1 ;This RPC is a similar to ORQQCN PROVDX
+2 ;RPC VIAB PROVDX
+3 SET RESULT=$$PROVDX^GMRCUTL1($GET(VIAIEN))
+4 QUIT
+5 ;
ISPROSVC(RESULT,GMRCIEN) ; Is this service part of the consults-prosthetics interface? ICR #6473
+1 ;RPC VIAB ISPROSVC
+2 ;This RPC is a similar to ORQQCN ISPROSVC
+3 ;GMRCIEN - IEN of selected service
+4 IF $$GET1^DIQ(123.5,+$GET(GMRCIEN),131,"I")=1
SET RESULT=1
+5 QUIT
+6 ;
SECVST(RESULT,NOTEIEN,VIADFN,VIAENCDT,VIAHLOC) ; save secondary visit in TIU, if inpatient; ICR#1894,#3540
+1 ;RPC VIAB TIU SECVST
+2 NEW VIAVST
+3 SET RESULT=0
+4 ; NOTEIEN only set on inpatient encounters
IF +$GET(NOTEIEN)
IF +$GET(VIADFN)
IF +$GET(VIAENCDT)
IF $GET(VIAHLOC)'=""
Begin DoDot:1
+5 SET VIAVST=$$GETENC^PXAPI(VIADFN,VIAENCDT,VIAHLOC)
+6 IF +VIAVST>0
Begin DoDot:2
+7 ;I $$GET1^DIQ(8925,NOTEIEN,.03,"I")=VIAVST Q
+8 NEW VIAOK,VIAX
+9 SET VIAX(1207)=VIAVST
+10 DO FILE^TIUSRVP(.VIAOK,NOTEIEN,.VIAX,1)
+11 MERGE RESULT=VIAOK
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
SCDIS(RESULT,DFN) ; Return service connected % and rated disabilities; ICR#10061,#649,#4807,#142
+1 ;RPC VIAB SCDIS
+2 ;This RPC is a similar to ORWPCE SCDIS
+3 NEW VAEL,VAERR,VIARR,I,ILST,DIS,SC,X
+4 DO ELIG^VADPT
+5 SET RESULT(1)="Service Connected: "_$SELECT(+VAEL(3):$PIECE(VAEL(3),U,2)_"%",1:"NO")
+6 IF 'VAEL(4)
IF '$$GET1^DIQ(391,+VAEL(6),.02,"I")
SET RESULT(2)="NOT A VETERAN."
QUIT
+7 DO RDIS^DGRPDB(DFN,.VIARR)
+8 SET I=0
SET ILST=1
FOR
SET I=$ORDER(VIARR(I))
if 'I
QUIT
SET X=VIARR(I)
Begin DoDot:1
+9 SET DIS=$$GET1^DIQ(31,+X,.01,"I")
if DIS=""
QUIT
+10 SET SC=$SELECT($PIECE(X,U,3):"SC",$PIECE(X,U,3)']"":"not specified",1:"NSC")
+11 SET ILST=ILST+1
SET RESULT(ILST)=DIS_" ("_$PIECE(X,U,2)_"% "_SC_")"
End DoDot:1
+12 IF ILST=1
SET RESULT(2)="Rated Disabilities: NONE STATED"
+13 QUIT
+14 ;
SCSEL(RESULT,DFN,APPDT,HLOC,VST) ; return SC conditions that maRESULT be selected; ICR#2348
+1 ;RPC VIAB SCSEL
+2 ;This RPC is a similar to ORWPCE SCSEL
+3 ; RESULT=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt;
+4 ; MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt;SHADAllow^SHADDflt
+5 NEW VIAB,S
+6 SET S=";"
+7 DO SCCOND^PXUTLSCC(DFN,APPDT,HLOC,$GET(VST),.VIAB)
+8 SET RESULT=$GET(VIAB("SC"))_S_$GET(VIAB("AO"))_S_$GET(VIAB("IR"))_S_$GET(VIAB("EC"))_S_$GET(VIAB("MST"))_S_$GET(VIAB("HNC"))_S_$GET(VIAB("CV"))_S_$GET(VIAB("SHAD"))
+9 QUIT
+10 ;
VISIT(RESULT,CLINIC,VIADATE) ; get list of visit types for clinic; ICR#1296
+1 ;RPC VIAB VISIT
+2 ;This RPC is a similar to ORWPCE VISIT
+3 if '+$GET(VIADATE)
SET VIADATE=DT
+4 DO GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","RESULT",,,,VIADATE)
+5 QUIT
+6 ;
IMMTYPE(RESULT,VIACVXS) ;get the list of active immunizations; ICR#6663
+1 ;RPC VIAB GET IMMUNIZATION TYPE
+2 ;Check for CVX codes passed
+3 IF $GET(VIACVXS)
DO IMMTYPE2(.RESULT,VIACVXS)
QUIT
+4 ;If no CVX codes, then return full list
+5 NEW CNT,X,Y,VIARES,VIARY
+6 SET CNT=0
+7 DO IMMSHORT^PXVRPC4(.VIARES,"A")
+8 SET X=""
FOR
SET X=$ORDER(VIARES(X))
if X=""
QUIT
SET Y=VIARES(X)
IF $PIECE(Y,"^")="IMM"
SET VIARY($PIECE(Y,"^",3)_"^"_$PIECE(Y,"^",2))=""
+9 SET X=""
FOR
SET X=$ORDER(VIARY(X))
if X=""
QUIT
SET CNT=CNT+1
SET RESULT(CNT)=$PIECE(X,"^",2)_"^"_$PIECE(X,"^")
+10 QUIT
+11 ;
IMMTYPE2(RESULT,VIACVXS) ;get one or more active immunizations by CVX code; ICR#6663
+1 ;RPC VIAB GET IMMUNIZATION TYPE
+2 NEW A,I,II,JJ,CNT,CPTS,X,XX,Y,YY,VIARES,VIARY,VIACVX,VIACPT,ZXX,ZYY,ZZZ,PATH,ZCPT,VIAFND,CPTNAM,DATA,ZCPT2,CPT2,DIWL,DIWR
+3 SET CNT=0
SET X=""
+4 ;just in case, if no CVX code then return list
+5 IF '$GET(VIACVXS)
DO IMMTYPE2(.RESULT)
QUIT
+6 FOR I=1:1:$LENGTH(VIACVXS,";")
SET X=$PIECE(VIACVXS,";",I)
Begin DoDot:1
+7 ;in case of leading or ending commas
if X=""
QUIT
+8 SET VIACVX(X)=""
End DoDot:1
+9 DO IMMSHORT^PXVRPC4(.VIARES,"A")
+10 SET XX=""
FOR
SET XX=$ORDER(VIARES(XX))
if XX=""
QUIT
SET YY=VIARES(XX)
IF $PIECE(YY,"^")="IMM"
IF $DATA(VIACVX($PIECE(YY,"^",4)))
Begin DoDot:1
+11 KILL VIACPT
+12 DO GETS^DIQ(9999999.14,$PIECE(YY,"^",2),"3*","I","VIACPT")
+13 SET (VIAFND,JJ,ZZZ,ZYY,ZXX,PATH,ZCPT,ZCPT2,CPTNAM)=""
+14 ;get the first CPT despite what the multiple within the multiple IEN may be
+15 FOR
SET ZXX=$ORDER(VIACPT(9999999.143,ZXX))
if ZXX=""
QUIT
FOR
SET ZYY=$ORDER(VIACPT(9999999.143,ZXX,ZYY))
if ZYY=""
QUIT
Begin DoDot:2
+16 IF $GET(VIACPT(9999999.143,ZXX,ZYY,"I"))="CPT"
SET CPT2(ZXX)=""
End DoDot:2
+17 KILL ZCPT
SET ZCPT=""
+18 FOR II=1:1
SET PATH=$ORDER(VIACPT(9999999.1431,II_","_PATH))
if PATH=""
QUIT
IF $DATA(CPT2($PIECE(PATH,",",2,3)_","))
Begin DoDot:2
+19 IF $GET(VIACPT(9999999.1431,PATH,.01,"I"))
SET ZCPT2=VIACPT(9999999.1431,PATH,.01,"I")
Begin DoDot:3
+20 ;get the CPT description and combine multiple lines into one
+21 KILL DATA
SET A=$$CPTD^ICPTCOD(ZCPT2,"DATA")
+22 ; using DIWR=220 to give room for other fields in 256 length
+23 SET DIWL=1
SET DIWR=220
SET ZCPT=""
KILL ^UTILITY($JOB,"W")
FOR
SET JJ=$ORDER(DATA(JJ))
if JJ=""
QUIT
SET X=DATA(JJ)
DO ^DIWP
+24 SET J=0
FOR
SET J=$ORDER(^UTILITY($JOB,"W",DIWL,J))
if J=""
QUIT
SET ZCPT=ZCPT_" "_^UTILITY($JOB,"W",DIWL,J,0)
+25 SET ZCPT(ZCPT2)=$EXTRACT(ZCPT,2,999)
End DoDot:3
+26 KILL CPTS
SET (CPTS,ZCPT2)=""
End DoDot:2
+27 SET (CPTS,ZCPT2)=""
FOR
SET ZCPT2=$ORDER(ZCPT(ZCPT2))
if ZCPT2=""
QUIT
SET CPTS=CPTS_";"_ZCPT2_"|"_ZCPT(ZCPT2)
+28 SET VIARY($PIECE(YY,"^",3)_"^"_$PIECE(YY,"^",4)_"^"_$PIECE(YY,"^",2))=$EXTRACT(CPTS,2,9999)
End DoDot:1
+29 SET X=""
FOR
SET X=$ORDER(VIARY(X))
if X=""
QUIT
SET CNT=CNT+1
SET RESULT(CNT)=$PIECE(X,"^",3)_"^"_$PIECE(X,"^")_"^"_$PIECE(X,"^",2)_"^"_VIARY(X)
+30 KILL ^UTILITY($JOB,"W")
+31 QUIT
+32 ;
IMMCOLL(RESULT) ; Return help screen showing immediate collect times;ICR#-2429
+1 ;RPC VIAB IMMED COLLECT
+2 ;This RPC is a similar to ORWDLR32 IMMED COLLECT
+3 IF $GET(DUZ(2))=""
QUIT
+4 DO SHOW^LR7OV4(DUZ(2),.RESULT)
+5 QUIT
+6 ;
ADMIN(RESULT,DFN,SCH,OI,LOC,ADMIN) ; return administration time info;ICR-#2843,10040,10035,3167
+1 ;RPC VIAB ADMIN
+2 ;This RPC is a similar to ORWDPS2 ADMIN
+3 ; RESULT: StartText^StartTime^Duration^FirstAdmin
+4 IF ($GET(OI)="")!($GET(LOC)="")
QUIT
+5 SET OI=+$$GET1^DIQ(101.43,+OI,2,"I")
+6 SET LOC=+$$GET1^DIQ(44,+LOC,42,"I")
SET RESULT=""
+7 IF $LENGTH($GET(^DPT(DFN,.1)))
SET RESULT=$$FIRST(DFN,LOC,OI,$GET(SCH),"",$GET(ADMIN))
+8 QUIT
+9 ;
FIRST(DFN,WARD,OI,DATA,ORDER,ADMIN) ; -- Return expected first admin time of order;ICR-#3167
+1 NEW CNT,ORCNT,ORI,J,ORZ,Y,SCH,ORX,TNUM
+2 IF '$GET(DFN)!'$GET(OI)
QUIT ""
+3 SET ORCNT=0
FOR ORI=1:1:$LENGTH(DATA,"^")
SET ORZ=$PIECE(DATA,U,ORI)
Begin DoDot:1
+4 SET TNUM=$$NUMCHAR(ORZ,";")
if TNUM=0
QUIT
+5 FOR CNT=1:1:TNUM
Begin DoDot:2
+6 SET SCH=$PIECE(ORZ,";",CNT+1)
if '$LENGTH(SCH)
QUIT
SET ORCNT=ORCNT+1
+7 IF ORCNT>1
SET ADMIN=""
+8 SET ORX(ORCNT)=$$STARTSTP^PSJORPOE(DFN,SCH,OI,WARD,$GET(ORDER),$GET(ADMIN))
End DoDot:2
End DoDot:1
if $EXTRACT(ORZ)="T"
QUIT
+9 SET Y=9999999
SET J=0
+10 ;earliest
FOR ORI=1:1:ORCNT
SET ORZ=$PIECE(ORX(ORI),U,4)
IF ORZ<Y
SET Y=ORZ
SET J=ORI
+11 SET Y=$SELECT(J:ORX(J),1:"")
+12 QUIT Y
+13 ;
NUMCHAR(STRING,SUB) ;
+1 NEW CNT,RESULT
+2 SET RESULT=0
+3 FOR CNT=1:1:$LENGTH(STRING)
IF $EXTRACT(STRING,CNT)=SUB
SET RESULT=RESULT+1
+4 QUIT RESULT
+5 ;
DFLTSPLY(RESULT,UPD,SCH,PAT,DRG,OI) ; return days supply given quantity;ICR-#2843,3278
+1 ;RPC VIAB DFLTSPLY
+2 ;This RPC is a similar to ORWDPS1 DFLTSPLY
+3 ; RESULT: default days supply
+4 NEW VIABX,I,PSOI,TPKG
+5 SET VIABX("PATIENT")=$GET(PAT)
+6 IF $GET(DRG)
SET VIABX("DRUG")=DRG
+7 IF $DATA(OI)
Begin DoDot:1
+8 SET TPKG=$$GET1^DIQ(101.43,+$GET(OI),2,"I")
if TPKG'["PS"
QUIT
+9 SET PSOI=+TPKG
if PSOI'>0
QUIT
+10 SET VIABX("OI")=PSOI
End DoDot:1
+11 FOR I=1:1:$LENGTH($GET(UPD),U)-1
Begin DoDot:1
+12 SET VIABX("DOSE ORDERED",I)=$PIECE($GET(UPD),U,I)
+13 SET VIABX("SCHEDULE",I)=$PIECE($GET(SCH),U,I)
End DoDot:1
+14 DO DSUP^PSOSIGDS(.VIABX)
+15 SET RESULT=$GET(VIABX("DAYS SUPPLY"))
+16 QUIT
+17 ;
DEVICE(RESULT,FROM,DIR,MARGIN) ; Return a subset of printer entries from the Device file;ICR-#3771
+1 ;RPC VIAB DEVICE
+2 ; -- Return up to 20 entries from the Device file based on Input criteria
+3 ; INPUT
+4 ; FROM : List all printers start from (text to $O from)
+5 ; B (all device with name start *WITH* B)
+6 ; B* (all device with name start *FROM* B)
+7 ; DIR : Ascending order (1) or Descending order (-1) ($O direction)
+8 ; MARGIN - Right margin (e.g, 80, 132 or "80-132")
+9 ;
+10 ; OUTPUT
+11 ; RESULT : By reference local array contains VistA printers based on input criteria
+12 ; RESULT(1..n)=IEN^Name^DisplayName^Location^RMar^PLen
+13 ;
+14 KILL RESULT
+15 SET FROM=$GET(FROM)
+16 SET DIR=$GET(DIR,1)
+17 SET MARGIN=$GET(MARGIN)
+18 DO DEVICE^XUDHGUI(.RESULT,FROM,DIR,MARGIN)
+19 QUIT
+20 ;
SAVE(OK,PCELIST,NOTEIEN,VIALOC) ; save PCE information
+1 ;INPUTS:
+2 ; PCELIST - LIST OF ENCOUNTER DATA
+3 ; NOTEIEN - TIU NOTE INTERNAL ENTRY NUMBER [Optional]
+4 ; VIALOC - INPATIENT STATION [Optional]
+5 ;OUTPUT:
+6 ; ARRAY with success or error code followed by problems encountered on data elements
+7 ; The array may contain the following values:
+8 ;
+9 ; 1 Indicates success - no errors and processed completely.
+10 ;
+11 ; -1 An error occurred. Data may or may not have been processed depending on nature of data.
+12 ;
+13 ; -2 Indicates that the routine PXAI found an issue with the visit.
+14 ;
+15 ; -3 Indicates that the input parameters were not properly defined.
+16 ;
+17 ; -4 If cannot get a lock on the encounter
+18 ;
+19 ; -5 If there were only warnings
+20 ;
+21 ; Subsequent values will vary depending on findings from DATA2PCE^PXAPI.
+22 ; the following is an example:
+23 ;
+24 ;Example:
+25 ; OK(0)="-1^Missing Required Fields"
+26 ; OK(1)="AO^No error"
+27 ; OK(2)="CV^NULL"
+28 ; OK(3)="EC^No error"
+29 ; OK(4)="HNC"^No error"
+30 ; OK(5)="IR^No error"
+31 ; OK(6)="MST"^No error"
+32 ; OK(7)="SC^Value must be NULL"
+33 ; OK(8)="SHAD^1"
+34 ;
+35 if $GET(VIALOC)=""
SET VIALOC="VISTA INTEGRATION ADAPTER"
+36 ;*21 added VOK
NEW VSTR,GMPLUSER,VOK
+37 NEW ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
+38 SET VSTR=$PIECE(PCELIST(1),U,4)
KILL ^TMP("VIAPCE",$JOB,VSTR)
+39 MERGE ^TMP("VIAPCE",$JOB,VSTR)=PCELIST
+40 SET GMPLUSER=$$CLINUSER(DUZ)
SET NOTEIEN=+$GET(NOTEIEN)
+41 DO DQSAVE^VIABRPC7
+42 ;*21 changed return to array
MERGE OK=VOK
+43 QUIT
+44 ;
CLINUSER(VIADUZ) ;is this a clinical user?
+1 NEW VIAUSER
+2 SET VIAUSER=0
+3 IF $DATA(^XUSEC("ORES",VIADUZ))
SET VIAUSER=1
+4 IF $DATA(^XUSEC("ORELSE",VIADUZ))
SET VIAUSER=1
+5 IF $DATA(^XUSEC("PROVIDER",VIADUZ))
SET VIAUSER=1
+6 QUIT VIAUSER
+7 ;
GETVSIT(VSTR,DFN) ; lookup a visit
+1 NEW PKG,SRC,VIAPXAPI,OK,VIAVISIT
+2 SET PKG=$ORDER(^DIC(9.4,"B","VISTA INTEGRATION ADAPTER",0))
+3 SET SRC="TEXT INTEGRATION UTILITIES"
+4 SET VIAPXAPI("ENCOUNTER",1,"ENC D/T")=$PIECE(VSTR,";",2)
+5 SET VIAPXAPI("ENCOUNTER",1,"PATIENT")=DFN
+6 SET VIAPXAPI("ENCOUNTER",1,"HOS LOC")=+VSTR
+7 SET VIAPXAPI("ENCOUNTER",1,"SERVICE CATEGORY")=$PIECE(VSTR,";",3)
+8 SET VIAPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
+9 SET OK=$$DATA2PCE^PXAPI("VIAPXAPI",PKG,SRC,.VIAVISIT)
+10 QUIT VIAVISIT
+11 ;
PATCH(VAL,X) ; Return 1 if patch X is installed *22
+1 SET VAL=$$PATCH^XPDUTL(X)
+2 QUIT
