- 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 Jan 18, 2025@03:46: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