VIABRPC7 ;AAC/JMC - VIA RPCs ;04/05/2016
;;1.0;VISTA INTEGRATION ADAPTER;**7,8,9,12,21**;06-FEB-2014;Build 1
;
; ICR 1365 DSELECT^GMPLENFM ^TMP("IB",$J)
; ICR 2467 ^ORX8 (Controlled)
; ICR 10141 PATCH^XPDUTL (Supported)
; ICR 3459 PSBMLHS (Supported)
; ICR 3889 PSBO (Controlled)
; ICR 5771 100 (Controlled)
; ICR 6484 100.98 (Controlled)
; ICR 10048 DIC(9.4 (Supported)
; ICR 1889 $$DATA2PCE^PXAPI
; ICR 3540 FILE^TIUSRVP (Controlled)
; ICR 5680 $$EXP^LEXCODE (Supported)
; ICR 5699 $$ICDDATA^ICDXCODE (Supported)
; ICR 1995 $$CODEN^ICPTCOD (Supported)
; ICR 5679 $$IMPDATE^LEXU (Supported)
;
Q
;
DQSAVE ; Background Call to DATA2PCE
N PKG,SRC,TYP,CODE,IEN,OK,I,X,VIAPXAPI,VIAPXDEL
N CAT,NARR,ROOT,ROOT2,VIAAVST,VIAENCDT,IMPLDT,PXERRORS,PXPROBS
N PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS
N COM,COMMENT,COMMENTS,SVCAT
N DFN,PROBLEMS,PXAPREDT,VIACPTDE,PXERRZ,VIASAVV
S IMPLDT=$$IMPDATE^LEXU("10D")
I $D(ZTQUEUED) S ZTREQ="@"
S PKG=$O(^DIC(9.4,"B","VISTA INTEGRATION ADAPTER",0))
;S SRC=$TR(VIALOC,",./;'<>?:`~!@#$%^&*()-=_+[]{}\|"," ") ;*21
S SRC="TEXT INTEGRATION UTILITIES" ;*21
S PXAPREDT=0 ;*21
S (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0
S I="" F S I=$O(PCELIST(I)) Q:'I S X=PCELIST(I) D
. S TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4)
. I $E(TYP,1,3)="PRV" D Q
. . Q:'$L(CODE)
. . S PRV=PRV+1
. . S ROOT="VIAPXAPI(""PROVIDER"","_PRV_")"
. . S ROOT2="VIAPXDEL(""PROVIDER"","_PRV_")"
. . I $E(TYP,4)'="-" D
. . . S @ROOT@("NAME")=CODE
. . . S @ROOT@("PRIMARY")=$P(X,U,6)
. . S @ROOT2@("NAME")=CODE
. . S @ROOT2@("DELETE")=1
. . S PXAPREDT=1 ;Allow edit of primary flag
. I TYP="VST" D Q
. . S ROOT="VIAPXAPI(""ENCOUNTER"",1)"
. . I CODE="DT" S (VIAENCDT,@ROOT@("ENC D/T"))=$P(X,U,3) Q
. . I CODE="PT" S @ROOT@("PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q
. . I CODE="HL" S @ROOT@("HOS LOC")=$P(X,U,3) Q
. . I CODE="PR" S @ROOT@("PARENT")=$P(X,U,3) Q
. . ;prevents checkout!
. . I CODE="VC" S (SVCAT,@ROOT@("SERVICE CATEGORY"))=$P(X,U,3) Q
. . I CODE="SC" S @ROOT@("SC")=$P(X,U,3) Q
. . I CODE="AO" S @ROOT@("AO")=$P(X,U,3) Q
. . I CODE="IR" S @ROOT@("IR")=$P(X,U,3) Q
. . I CODE="EC" S @ROOT@("EC")=$P(X,U,3) Q
. . I CODE="MST" S @ROOT@("MST")=$P(X,U,3) Q
. . I CODE="HNC" S @ROOT@("HNC")=$P(X,U,3) Q
. . I CODE="CV" S @ROOT@("CV")=$P(X,U,3) Q
. . I CODE="SHD" S @ROOT@("SHAD")=$P(X,U,3) Q
. . I CODE="OL" D Q
. . . I +$P(X,U,3) S @ROOT@("INSTITUTION")=$P(X,U,3)
. . . E I $P(X,U,4)'="",$P(X,U,4)'="0" D
. . . . I $$PATCH^XPDUTL("PX*1.0*96") S @ROOT@("OUTSIDE LOCATION")=$P(X,U,4)
. . . . E S @ROOT@("COMMENT")="OUTSIDE LOCATION: "_$P(X,U,4)
. I $E(TYP,1,3)="CPT" D Q
. . Q:'$L(CODE)
. . S CPT=CPT+1,ROOT="VIAPXAPI(""PROCEDURE"","_CPT_")"
. . S IEN=$$CODEN^ICPTCOD(CODE) ;ICR #1995
. . S @ROOT@("PROCEDURE")=IEN
. . I +$P(X,U,9) D
. . . S MODS=$P(X,U,9),MODCNT=+MODS
. . . F MODIDX=1:1:MODCNT D
. . . . S MOD=$P($P(MODS,";",MODIDX+1),"/")
. . . . S @ROOT@("MODIFIERS",MOD)=""
. . S:$L(CAT) @ROOT@("CATEGORY")=CAT
. . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
. . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5)
. . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT
. . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0,VIACPTDE=CPT
. I $E(TYP,1,3)="POV" D Q
. . N VIADXI,VIADX
. . Q:'$L(CODE)
. . F VIADXI=1:1:$L(CODE,"/") D
. . . N CSYS,CDT,IEN,LEXIEN
. . . S VIADX=$P(CODE,"/",VIADXI)
. . . S ICD=ICD+1,ROOT="VIAPXAPI(""DX/PL"","_ICD_")"
. . . I (VIADX]""),(VIADX'[".") S VIADX=VIADX_"."
. . . S IEN=$P($$CODEN^ICDEX(VIADX,80),"~",1) ;*21 S IEN=+$$ICDDATA^ICDXCODE(CSYS,VIADX,CDT,"E")
. . . I IEN'>0 Q
. . . S @ROOT@("DIAGNOSIS")=IEN
. . . S @ROOT@("PRIMARY")=$S(VIADXI=1:$P(X,U,5),1:0)
. . . S CDT=$S($G(SVCAT)="E":DT,1:VIAENCDT) ;*21 move 2 lines
. . . S CSYS=$$CSI^ICDEX(80,IEN) ;*21 S CSYS=$S(CDT'<IMPLDT:"10D",1:"ICD")
. . . S LEXIEN=$P($$EXP^LEXCODE(VIADX,CSYS,CDT),U),@ROOT@("LEXICON TERM")=$S(LEXIEN>0:LEXIEN,1:"")
. . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
. . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
. . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
. . . I $L($P(X,U,7)),($P(X,U,7)=1),(VIADXI=1) S @ROOT@("PL ADD")=$P(X,U,7),PROBLEMS(ICD)=NARR_U_CODE
. . . S:$L($P(X,U,10))>0&(VIADXI=1) COMMENT($P(X,U,10))="DX/PL^"_ICD
. . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
. I $E(TYP,1,3)="IMM" D Q
. . Q:'$L(CODE)
. . S IMM=IMM+1,ROOT="VIAPXAPI(""IMMUNIZATION"","_IMM_")"
. . S @ROOT@("IMMUN")=CODE
. . S:$L($P(X,U,5)) @ROOT@("SERIES")=$P(X,U,5)
. . S:$L($P(X,U,5)) @ROOT@("REACTION")=$P(X,U,7)
. . S:$L($P(X,U,8)) @ROOT@("CONTRAINDICATED")=$P(X,U,8)
. . S:$L($P(X,U,9)) @ROOT@("REFUSED")=$P(X,U,9)
. . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM
. . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
. I $E(TYP,1,2)="SK" D Q
. . Q:'$L(CODE)
. . S SK=SK+1,ROOT="VIAPXAPI(""SKIN TEST"","_SK_")"
. . S @ROOT@("TEST")=CODE
. . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5)
. . S:$L($P(X,U,7)) @ROOT@("READING")=$P(X,U,7)
. . S:$L($P(X,U,8)) @ROOT@("D/T READ")=$P(X,U,8)
. . S:$L($P(X,U,9)) @ROOT@("EVENT D/T")=$P(X,U,9)
. . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK
. . I $E(TYP,3)="-" S @ROOT@("DELETE")=1
. I $E(TYP,1,3)="PED" D Q
. . Q:'$L(CODE)
. . S PED=PED+1,ROOT="VIAPXAPI(""PATIENT ED"","_PED_")"
. . S @ROOT@("TOPIC")=CODE
. . S:$L($P(X,U,5)) @ROOT@("UNDERSTANDING")=$P(X,U,5)
. . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED
. . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
. I $E(TYP,1,2)="HF" D Q
. . Q:'$L(CODE)
. . S HF=HF+1,ROOT="VIAPXAPI(""HEALTH FACTOR"","_HF_")"
. . S @ROOT@("HEALTH FACTOR")=CODE
. . S:$L($P(X,U,5)) @ROOT@("LEVEL/SEVERITY")=$P(X,U,5)
. . S:$P(X,U,6)'>0 $P(X,U,6)=$G(VIAPXAPI("PROVIDER",1,"NAME"))
. . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,11)) @ROOT@("EVENT D/T")=$P($P(X,U,11),";",1)
. . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF
. . I $E(TYP,3)="-" S @ROOT@("DELETE")=1
. I $E(TYP,1,3)="XAM" D Q
. . Q:'$L(CODE)
. . S XAM=XAM+1,ROOT="VIAPXAPI(""EXAM"","_XAM_")"
. . S @ROOT@("EXAM")=CODE
. . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5)
. . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM
. . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
. I $E(TYP,1,3)="TRT" D Q
. . Q:'$L(CODE)
. . S TRT=TRT+1,ROOT="VIAPXAPI(""TREATMENT"","_TRT_")"
. . S @ROOT@("IMMUN")=CODE
. . S:$L(CAT) @ROOT@("CATEGORY")=CAT
. . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
. . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5)
. . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT
. . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0
. I $E(TYP,1,3)="COM" D Q
. . Q:'$L(CODE)
. . Q:'$L(CAT)
. . S COMMENTS(CODE)=$P(X,U,3,999)
;Store the comments
S COM=""
F S COM=$O(COMMENT(COM)) Q:COM="" S:$D(COMMENTS(COM)) VIAPXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
;
;Remove any problems to add that the patient already has as active problems
I $D(PROBLEMS),$D(DFN) D
. N VIAWPROB,VIAPROBI
. K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
. D DSELECT^GMPLENFM ;DBIA 1365
. S VIAPROBI=0
. F S VIAPROBI=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBI)) Q:'VIAPROBI D ;DBIA 1365
.. S VIAWPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBI),"^",2,3)
.. S VIAWPROB($S($E(VIAWPROB,1)="$":$E(VIAWPROB,2,255),1:VIAWPROB))=""
. K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
. Q:'$D(VIAWPROB)
. S VIAPROBI=""
. F S VIAPROBI=$O(PROBLEMS(VIAPROBI)) Q:'VIAPROBI D
.. S:$D(VIAWPROB(PROBLEMS(VIAPROBI))) VIAPXAPI("DX/PL",VIAPROBI,"PL ADD")=0
;
I $$MDS(.VIAPXAPI,$G(VIALOC)) D ;*21
.N VIATIME ;*21
.S VIATIME=$$NOW^XLFDT ;*21
.S VIATIME=+($P(VIATIME,".")_"."_$E($P(VIATIME,".",2),1,4)) ;*21
.S VIAPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=VIATIME ;*21
S VIAPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
DATA2PCE ;
;N VSTR ;*21
;S VSTR=$P(PCELIST(1),U,4) K ^TMP("VIAPCE",$J,VSTR) ;*21
;S (VIASAVV,VIAAVST)=$$GETVSIT^VIABRPC(VSTR,DFN) ;*21
I $G(PXAPREDT)!($G(VIACPTDE)) D
. M VIAPXDEL("ENCOUNTER")=VIAPXAPI("ENCOUNTER")
. I $G(VIACPTDE) M VIAPXDEL("PROCEDURE",VIACPTDE)=VIAPXAPI("PROCEDURE",VIACPTDE)
. ;S OK=$$DATA2PCE^PXAPI("VIAPXDEL",PKG,SRC,.VIAAVST) ;*21
. S OK=$$DATA2PCE^PXAPI("VIAPXDEL",PKG,SRC,.VIAAVST,,$G(DISPLAY,0),.PXERRORS,PXAPREDT,.PXPROBS) ;*21 Display:1=write to screen(debug only),0=don't
;S VIAAVST=VIASAVV,PXERRZ="" ;*21
;S OK=$$DATA2PCE^PXAPI("VIAPXAPI",PKG,SRC,.VIAAVST,,1,.PXERRORS,1,.PXPROBS) ;*21
S OK=$$DATA2PCE^PXAPI("VIAPXAPI",PKG,SRC,.VIAAVST,,$G(DISPLAY,0),.PXERRORS,PXAPREDT,.PXPROBS) ;*21 Display:1=write to screen(debug only),0=don't
I $S(OK[1:OK,OK[-1:1,OK[-5:1,1:0),+NOTEIEN,+VIAAVST D ; NOTEIEN only set on inpatient encounters
.N VIAOK,VIAX
.S VIAX(1207)=VIAAVST
.D FILE^TIUSRVP(.VIAOK,NOTEIEN,.VIAX,1)
S ZTSTAT=0 ; clear sync flag
M TARR=PXPROBS($J),TARR=PXERRORS D MKSGLAR(.VOK,.TARR) ;*21
S VOK(0)=$G(OK)_"^"_$G(PXPROBS) ;*21
K NOTEIEN,PCELIST,TARR
Q
;
MDS(X,VIALOC) ; return TRUE if checkout is needed ; *21
I $$CHKOUT(VIALOC) Q 1
N I,VIAAUTO,VIAOK
S (VIAOK,I)=0
F S I=$O(X("DX/PL",I)) Q:'I D Q:VIAOK
. I $G(X("DX/PL",I,"DIAGNOSIS")) S VIAOK=1
I 'VIAOK D
.S I=0 F S I=$O(X("PROCEDURE",I)) Q:'I D Q:VIAOK
.. I $G(X("PROCEDURE",I,"PROCEDURE")) S VIAOK=1
I $D(X("PROVIDER",1,"NAME")) S VIAOK=1
Q VIAOK
;
DOCHKOUT(VIAY,LOC) ; Returns TRUE if automatic selection of Visit Type ;*21
N SRV
S SRV=$P($G(^VA(200,DUZ,5)),U)
S VIAY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","VIABRPC DISABLE AUTO CHECKOUT",1,"Q")
I +VIAY S VIAY=1
S VIAY='VIAY
Q
;
CHKOUT(LOC) ; Returns TRUE if automatic selection of Visit Type ;*21
N VIAY
D DOCHKOUT(.VIAY,LOC)
Q VIAY
;
MKSGLAR(RTN,ARR) ; *21 Make single dimensional array from multi-dimensional array
N I,J,CT
S I=$NA(ARR),CT=0
F S I=$Q(@I) Q:I="" D
. S CT=CT+1
. S J=$QL(I)
. S RTN(CT)=$P(I,",",J),RTN(CT)=$P(RTN(CT),"""",2)_"^"_@I
.Q
Q
;
MEDHIST(RESULT,DFN,VIAIFN) ; -- show admin history for a med (RV)
; ICR#2467,#10141,#3459,#3889,#6479,#6484
;RPC VIAB MEDHIST
;This RPC is a similar to ORWPS MEDHIST
N VIAPSID,HPIV,ISIV,CKPKG,VIAPHMID
N CLIVDISP,DGP
S VIAPSID=+$P($$OI^ORX8(VIAIFN),U,3),ISIV=0,HPIV=0
S RESULT=$NA(^TMP("VIAHIST",$J)) K @RESULT
S VIAPHMID=$$GET1^DIQ(100,+VIAIFN,4,"I") ;Pharmacy order number
S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV))
S HPIV=$O(^ORD(100.98,"B","TPN",HPIV))
S CLIVDISP=$O(^ORD(100.98,"B","CI RX",""))
S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
;if the order is pending or the order has no pharmacy #
;or the order is not in the Display Group IV MEDICATION
; then use the Orderable item number to get the MAH.
I (VIAPHMID["P")!(VIAPHMID="") D Q
. I '$L($T(HISTORY^PSBMLHS)) D Q
. . S @RESULT@(0)="This report is only available using BCMA version 2.0."
. D HISTORY^PSBMLHS(.RESULT,DFN,VIAPSID) ; DBIA #3459 for BCMA v2.0
; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
S DGP=$$GET1^DIQ(100,+VIAIFN,23,"I")
I (DGP=ISIV)!(DGP=HPIV)!(DGP=CLIVDISP) D Q
. I 'CKPKG S @RESULT@(0)="Medication Administration History is not available at this time for IV fluids."
. I CKPKG D
. . D RPC^PSBO(.RESULT,"PM",DFN,"","","","","","","","","",VIAPHMID) ;DBIA #3889
. . I '$D(@RESULT) S @RESULT@(0)="No Medication Administration History found for the IV order."
I '$L($T(HISTORY^PSBMLHS)) D Q
. S @RESULT@(0)="This report is only available using BCMA version 2.0."
D HISTORY^PSBMLHS(.RESULT,DFN,VIAPSID) ; DBIA #3459 for BCMA v2.0
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVIABRPC7 12281 printed Dec 13, 2024@02:45:26 Page 2
VIABRPC7 ;AAC/JMC - VIA RPCs ;04/05/2016
+1 ;;1.0;VISTA INTEGRATION ADAPTER;**7,8,9,12,21**;06-FEB-2014;Build 1
+2 ;
+3 ; ICR 1365 DSELECT^GMPLENFM ^TMP("IB",$J)
+4 ; ICR 2467 ^ORX8 (Controlled)
+5 ; ICR 10141 PATCH^XPDUTL (Supported)
+6 ; ICR 3459 PSBMLHS (Supported)
+7 ; ICR 3889 PSBO (Controlled)
+8 ; ICR 5771 100 (Controlled)
+9 ; ICR 6484 100.98 (Controlled)
+10 ; ICR 10048 DIC(9.4 (Supported)
+11 ; ICR 1889 $$DATA2PCE^PXAPI
+12 ; ICR 3540 FILE^TIUSRVP (Controlled)
+13 ; ICR 5680 $$EXP^LEXCODE (Supported)
+14 ; ICR 5699 $$ICDDATA^ICDXCODE (Supported)
+15 ; ICR 1995 $$CODEN^ICPTCOD (Supported)
+16 ; ICR 5679 $$IMPDATE^LEXU (Supported)
+17 ;
+18 QUIT
+19 ;
DQSAVE ; Background Call to DATA2PCE
+1 NEW PKG,SRC,TYP,CODE,IEN,OK,I,X,VIAPXAPI,VIAPXDEL
+2 NEW CAT,NARR,ROOT,ROOT2,VIAAVST,VIAENCDT,IMPLDT,PXERRORS,PXPROBS
+3 NEW PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS
+4 NEW COM,COMMENT,COMMENTS,SVCAT
+5 NEW DFN,PROBLEMS,PXAPREDT,VIACPTDE,PXERRZ,VIASAVV
+6 SET IMPLDT=$$IMPDATE^LEXU("10D")
+7 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 SET PKG=$ORDER(^DIC(9.4,"B","VISTA INTEGRATION ADAPTER",0))
+9 ;S SRC=$TR(VIALOC,",./;'<>?:`~!@#$%^&*()-=_+[]{}\|"," ") ;*21
+10 ;*21
SET SRC="TEXT INTEGRATION UTILITIES"
+11 ;*21
SET PXAPREDT=0
+12 SET (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0
+13 SET I=""
FOR
SET I=$ORDER(PCELIST(I))
if 'I
QUIT
SET X=PCELIST(I)
Begin DoDot:1
+14 SET TYP=$PIECE(X,U)
SET CODE=$PIECE(X,U,2)
SET CAT=$PIECE(X,U,3)
SET NARR=$PIECE(X,U,4)
+15 IF $EXTRACT(TYP,1,3)="PRV"
Begin DoDot:2
+16 if '$LENGTH(CODE)
QUIT
+17 SET PRV=PRV+1
+18 SET ROOT="VIAPXAPI(""PROVIDER"","_PRV_")"
+19 SET ROOT2="VIAPXDEL(""PROVIDER"","_PRV_")"
+20 IF $EXTRACT(TYP,4)'="-"
Begin DoDot:3
+21 SET @ROOT@("NAME")=CODE
+22 SET @ROOT@("PRIMARY")=$PIECE(X,U,6)
End DoDot:3
+23 SET @ROOT2@("NAME")=CODE
+24 SET @ROOT2@("DELETE")=1
+25 ;Allow edit of primary flag
SET PXAPREDT=1
End DoDot:2
QUIT
+26 IF TYP="VST"
Begin DoDot:2
+27 SET ROOT="VIAPXAPI(""ENCOUNTER"",1)"
+28 IF CODE="DT"
SET (VIAENCDT,@ROOT@("ENC D/T"))=$PIECE(X,U,3)
QUIT
+29 IF CODE="PT"
SET @ROOT@("PATIENT")=$PIECE(X,U,3)
SET DFN=$PIECE(X,U,3)
QUIT
+30 IF CODE="HL"
SET @ROOT@("HOS LOC")=$PIECE(X,U,3)
QUIT
+31 IF CODE="PR"
SET @ROOT@("PARENT")=$PIECE(X,U,3)
QUIT
+32 ;prevents checkout!
+33 IF CODE="VC"
SET (SVCAT,@ROOT@("SERVICE CATEGORY"))=$PIECE(X,U,3)
QUIT
+34 IF CODE="SC"
SET @ROOT@("SC")=$PIECE(X,U,3)
QUIT
+35 IF CODE="AO"
SET @ROOT@("AO")=$PIECE(X,U,3)
QUIT
+36 IF CODE="IR"
SET @ROOT@("IR")=$PIECE(X,U,3)
QUIT
+37 IF CODE="EC"
SET @ROOT@("EC")=$PIECE(X,U,3)
QUIT
+38 IF CODE="MST"
SET @ROOT@("MST")=$PIECE(X,U,3)
QUIT
+39 IF CODE="HNC"
SET @ROOT@("HNC")=$PIECE(X,U,3)
QUIT
+40 IF CODE="CV"
SET @ROOT@("CV")=$PIECE(X,U,3)
QUIT
+41 IF CODE="SHD"
SET @ROOT@("SHAD")=$PIECE(X,U,3)
QUIT
+42 IF CODE="OL"
Begin DoDot:3
+43 IF +$PIECE(X,U,3)
SET @ROOT@("INSTITUTION")=$PIECE(X,U,3)
+44 IF '$TEST
IF $PIECE(X,U,4)'=""
IF $PIECE(X,U,4)'="0"
Begin DoDot:4
+45 IF $$PATCH^XPDUTL("PX*1.0*96")
SET @ROOT@("OUTSIDE LOCATION")=$PIECE(X,U,4)
+46 IF '$TEST
SET @ROOT@("COMMENT")="OUTSIDE LOCATION: "_$PIECE(X,U,4)
End DoDot:4
End DoDot:3
QUIT
End DoDot:2
QUIT
+47 IF $EXTRACT(TYP,1,3)="CPT"
Begin DoDot:2
+48 if '$LENGTH(CODE)
QUIT
+49 SET CPT=CPT+1
SET ROOT="VIAPXAPI(""PROCEDURE"","_CPT_")"
+50 ;ICR #1995
SET IEN=$$CODEN^ICPTCOD(CODE)
+51 SET @ROOT@("PROCEDURE")=IEN
+52 IF +$PIECE(X,U,9)
Begin DoDot:3
+53 SET MODS=$PIECE(X,U,9)
SET MODCNT=+MODS
+54 FOR MODIDX=1:1:MODCNT
Begin DoDot:4
+55 SET MOD=$PIECE($PIECE(MODS,";",MODIDX+1),"/")
+56 SET @ROOT@("MODIFIERS",MOD)=""
End DoDot:4
End DoDot:3
+57 if $LENGTH(CAT)
SET @ROOT@("CATEGORY")=CAT
+58 if $LENGTH(NARR)
SET @ROOT@("NARRATIVE")=NARR
+59 if $LENGTH($PIECE(X,U,5))
SET @ROOT@("QTY")=$PIECE(X,U,5)
+60 if $PIECE(X,U,6)>0
SET @ROOT@("ENC PROVIDER")=$PIECE(X,U,6)
+61 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="PROCEDURE^"_CPT
+62 IF $EXTRACT(TYP,4)="-"
SET @ROOT@("DELETE")=1
SET @ROOT@("QTY")=0
SET VIACPTDE=CPT
End DoDot:2
QUIT
+63 IF $EXTRACT(TYP,1,3)="POV"
Begin DoDot:2
+64 NEW VIADXI,VIADX
+65 if '$LENGTH(CODE)
QUIT
+66 FOR VIADXI=1:1:$LENGTH(CODE,"/")
Begin DoDot:3
+67 NEW CSYS,CDT,IEN,LEXIEN
+68 SET VIADX=$PIECE(CODE,"/",VIADXI)
+69 SET ICD=ICD+1
SET ROOT="VIAPXAPI(""DX/PL"","_ICD_")"
+70 IF (VIADX]"")
IF (VIADX'[".")
SET VIADX=VIADX_"."
+71 ;*21 S IEN=+$$ICDDATA^ICDXCODE(CSYS,VIADX,CDT,"E")
SET IEN=$PIECE($$CODEN^ICDEX(VIADX,80),"~",1)
+72 IF IEN'>0
QUIT
+73 SET @ROOT@("DIAGNOSIS")=IEN
+74 SET @ROOT@("PRIMARY")=$SELECT(VIADXI=1:$PIECE(X,U,5),1:0)
+75 ;*21 move 2 lines
SET CDT=$SELECT($GET(SVCAT)="E":DT,1:VIAENCDT)
+76 ;*21 S CSYS=$S(CDT'<IMPLDT:"10D",1:"ICD")
SET CSYS=$$CSI^ICDEX(80,IEN)
+77 SET LEXIEN=$PIECE($$EXP^LEXCODE(VIADX,CSYS,CDT),U)
SET @ROOT@("LEXICON TERM")=$SELECT(LEXIEN>0:LEXIEN,1:"")
+78 if $LENGTH(CAT)
SET @ROOT@("CATEGORY")=CAT
+79 if $LENGTH(NARR)
SET @ROOT@("NARRATIVE")=NARR
+80 if $PIECE(X,U,6)>0
SET @ROOT@("ENC PROVIDER")=$PIECE(X,U,6)
+81 IF $LENGTH($PIECE(X,U,7))
IF ($PIECE(X,U,7)=1)
IF (VIADXI=1)
SET @ROOT@("PL ADD")=$PIECE(X,U,7)
SET PROBLEMS(ICD)=NARR_U_CODE
+82 if $LENGTH($PIECE(X,U,10))>0&(VIADXI=1)
SET COMMENT($PIECE(X,U,10))="DX/PL^"_ICD
+83 IF $EXTRACT(TYP,4)="-"
SET @ROOT@("DELETE")=1
End DoDot:3
End DoDot:2
QUIT
+84 IF $EXTRACT(TYP,1,3)="IMM"
Begin DoDot:2
+85 if '$LENGTH(CODE)
QUIT
+86 SET IMM=IMM+1
SET ROOT="VIAPXAPI(""IMMUNIZATION"","_IMM_")"
+87 SET @ROOT@("IMMUN")=CODE
+88 if $LENGTH($PIECE(X,U,5))
SET @ROOT@("SERIES")=$PIECE(X,U,5)
+89 if $LENGTH($PIECE(X,U,5))
SET @ROOT@("REACTION")=$PIECE(X,U,7)
+90 if $LENGTH($PIECE(X,U,8))
SET @ROOT@("CONTRAINDICATED")=$PIECE(X,U,8)
+91 if $LENGTH($PIECE(X,U,9))
SET @ROOT@("REFUSED")=$PIECE(X,U,9)
+92 if $PIECE(X,U,6)>0
SET @ROOT@("ENC PROVIDER")=$PIECE(X,U,6)
+93 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="IMMUNIZATION^"_IMM
+94 IF $EXTRACT(TYP,4)="-"
SET @ROOT@("DELETE")=1
End DoDot:2
QUIT
+95 IF $EXTRACT(TYP,1,2)="SK"
Begin DoDot:2
+96 if '$LENGTH(CODE)
QUIT
+97 SET SK=SK+1
SET ROOT="VIAPXAPI(""SKIN TEST"","_SK_")"
+98 SET @ROOT@("TEST")=CODE
+99 if $LENGTH($PIECE(X,U,5))
SET @ROOT@("RESULT")=$PIECE(X,U,5)
+100 if $LENGTH($PIECE(X,U,7))
SET @ROOT@("READING")=$PIECE(X,U,7)
+101 if $LENGTH($PIECE(X,U,8))
SET @ROOT@("D/T READ")=$PIECE(X,U,8)
+102 if $LENGTH($PIECE(X,U,9))
SET @ROOT@("EVENT D/T")=$PIECE(X,U,9)
+103 if $PIECE(X,U,6)>0
SET @ROOT@("ENC PROVIDER")=$PIECE(X,U,6)
+104 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="SKIN TEST^"_SK
+105 IF $EXTRACT(TYP,3)="-"
SET @ROOT@("DELETE")=1
End DoDot:2
QUIT
+106 IF $EXTRACT(TYP,1,3)="PED"
Begin DoDot:2
+107 if '$LENGTH(CODE)
QUIT
+108 SET PED=PED+1
SET ROOT="VIAPXAPI(""PATIENT ED"","_PED_")"
+109 SET @ROOT@("TOPIC")=CODE
+110 if $LENGTH($PIECE(X,U,5))
SET @ROOT@("UNDERSTANDING")=$PIECE(X,U,5)
+111 if $PIECE(X,U,6)>0
SET @ROOT@("ENC PROVIDER")=$PIECE(X,U,6)
+112 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="PATIENT ED^"_PED
+113 IF $EXTRACT(TYP,4)="-"
SET @ROOT@("DELETE")=1
End DoDot:2
QUIT
+114 IF $EXTRACT(TYP,1,2)="HF"
Begin DoDot:2
+115 if '$LENGTH(CODE)
QUIT
+116 SET HF=HF+1
SET ROOT="VIAPXAPI(""HEALTH FACTOR"","_HF_")"
+117 SET @ROOT@("HEALTH FACTOR")=CODE
+118 if $LENGTH($PIECE(X,U,5))
SET @ROOT@("LEVEL/SEVERITY")=$PIECE(X,U,5)
+119 if $PIECE(X,U,6)'>0
SET $PIECE(X,U,6)=$GET(VIAPXAPI("PROVIDER",1,"NAME"))
+120 if $PIECE(X,U,6)>0
SET @ROOT@("ENC PROVIDER")=$PIECE(X,U,6)
+121 if $LENGTH($PIECE(X,U,11))
SET @ROOT@("EVENT D/T")=$PIECE($PIECE(X,U,11),";",1)
+122 if $LENGTH($PIECE(X,U,11))
SET SRC=$PIECE($PIECE(X,U,11),";",2)
+123 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="HEALTH FACTOR^"_HF
+124 IF $EXTRACT(TYP,3)="-"
SET @ROOT@("DELETE")=1
End DoDot:2
QUIT
+125 IF $EXTRACT(TYP,1,3)="XAM"
Begin DoDot:2
+126 if '$LENGTH(CODE)
QUIT
+127 SET XAM=XAM+1
SET ROOT="VIAPXAPI(""EXAM"","_XAM_")"
+128 SET @ROOT@("EXAM")=CODE
+129 if $LENGTH($PIECE(X,U,5))
SET @ROOT@("RESULT")=$PIECE(X,U,5)
+130 if $PIECE(X,U,6)>0
SET @ROOT@("ENC PROVIDER")=$PIECE(X,U,6)
+131 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="EXAM^"_XAM
+132 IF $EXTRACT(TYP,4)="-"
SET @ROOT@("DELETE")=1
End DoDot:2
QUIT
+133 IF $EXTRACT(TYP,1,3)="TRT"
Begin DoDot:2
+134 if '$LENGTH(CODE)
QUIT
+135 SET TRT=TRT+1
SET ROOT="VIAPXAPI(""TREATMENT"","_TRT_")"
+136 SET @ROOT@("IMMUN")=CODE
+137 if $LENGTH(CAT)
SET @ROOT@("CATEGORY")=CAT
+138 if $LENGTH(NARR)
SET @ROOT@("NARRATIVE")=NARR
+139 if $LENGTH($PIECE(X,U,5))
SET @ROOT@("QTY")=$PIECE(X,U,5)
+140 if $PIECE(X,U,6)>0
SET @ROOT@("ENC PROVIDER")=$PIECE(X,U,6)
+141 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="TREATMENT^"_TRT
+142 IF $EXTRACT(TYP,4)="-"
SET @ROOT@("DELETE")=1
SET @ROOT@("QTY")=0
End DoDot:2
QUIT
+143 IF $EXTRACT(TYP,1,3)="COM"
Begin DoDot:2
+144 if '$LENGTH(CODE)
QUIT
+145 if '$LENGTH(CAT)
QUIT
+146 SET COMMENTS(CODE)=$PIECE(X,U,3,999)
End DoDot:2
QUIT
End DoDot:1
+147 ;Store the comments
+148 SET COM=""
+149 FOR
SET COM=$ORDER(COMMENT(COM))
if COM=""
QUIT
if $DATA(COMMENTS(COM))
SET VIAPXAPI($PIECE(COMMENT(COM),"^",1),$PIECE(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
+150 ;
+151 ;Remove any problems to add that the patient already has as active problems
+152 IF $DATA(PROBLEMS)
IF $DATA(DFN)
Begin DoDot:1
+153 NEW VIAWPROB,VIAPROBI
+154 KILL ^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
+155 ;DBIA 1365
DO DSELECT^GMPLENFM
+156 SET VIAPROBI=0
+157 ;DBIA 1365
FOR
SET VIAPROBI=$ORDER(^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBI))
if 'VIAPROBI
QUIT
Begin DoDot:2
+158 SET VIAWPROB=$PIECE(^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBI),"^",2,3)
+159 SET VIAWPROB($SELECT($EXTRACT(VIAWPROB,1)="$":$EXTRACT(VIAWPROB,2,255),1:VIAWPROB))=""
End DoDot:2
+160 KILL ^TMP("IB",$JOB,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
+161 if '$DATA(VIAWPROB)
QUIT
+162 SET VIAPROBI=""
+163 FOR
SET VIAPROBI=$ORDER(PROBLEMS(VIAPROBI))
if 'VIAPROBI
QUIT
Begin DoDot:2
+164 if $DATA(VIAWPROB(PROBLEMS(VIAPROBI)))
SET VIAPXAPI("DX/PL",VIAPROBI,"PL ADD")=0
End DoDot:2
End DoDot:1
+165 ;
+166 ;*21
IF $$MDS(.VIAPXAPI,$GET(VIALOC))
Begin DoDot:1
+167 ;*21
NEW VIATIME
+168 ;*21
SET VIATIME=$$NOW^XLFDT
+169 ;*21
SET VIATIME=+($PIECE(VIATIME,".")_"."_$EXTRACT($PIECE(VIATIME,".",2),1,4))
+170 ;*21
SET VIAPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=VIATIME
End DoDot:1
+171 SET VIAPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
DATA2PCE ;
+1 ;N VSTR ;*21
+2 ;S VSTR=$P(PCELIST(1),U,4) K ^TMP("VIAPCE",$J,VSTR) ;*21
+3 ;S (VIASAVV,VIAAVST)=$$GETVSIT^VIABRPC(VSTR,DFN) ;*21
+4 IF $GET(PXAPREDT)!($GET(VIACPTDE))
Begin DoDot:1
+5 MERGE VIAPXDEL("ENCOUNTER")=VIAPXAPI("ENCOUNTER")
+6 IF $GET(VIACPTDE)
MERGE VIAPXDEL("PROCEDURE",VIACPTDE)=VIAPXAPI("PROCEDURE",VIACPTDE)
+7 ;S OK=$$DATA2PCE^PXAPI("VIAPXDEL",PKG,SRC,.VIAAVST) ;*21
+8 ;*21 Display:1=write to screen(debug only),0=don't
SET OK=$$DATA2PCE^PXAPI("VIAPXDEL",PKG,SRC,.VIAAVST,,$GET(DISPLAY,0),.PXERRORS,PXAPREDT,.PXPROBS)
End DoDot:1
+9 ;S VIAAVST=VIASAVV,PXERRZ="" ;*21
+10 ;S OK=$$DATA2PCE^PXAPI("VIAPXAPI",PKG,SRC,.VIAAVST,,1,.PXERRORS,1,.PXPROBS) ;*21
+11 ;*21 Display:1=write to screen(debug only),0=don't
SET OK=$$DATA2PCE^PXAPI("VIAPXAPI",PKG,SRC,.VIAAVST,,$GET(DISPLAY,0),.PXERRORS,PXAPREDT,.PXPROBS)
+12 ; NOTEIEN only set on inpatient encounters
IF $SELECT(OK[1:OK,OK[-1:1,OK[-5:1,1:0)
IF +NOTEIEN
IF +VIAAVST
Begin DoDot:1
+13 NEW VIAOK,VIAX
+14 SET VIAX(1207)=VIAAVST
+15 DO FILE^TIUSRVP(.VIAOK,NOTEIEN,.VIAX,1)
End DoDot:1
+16 ; clear sync flag
SET ZTSTAT=0
+17 ;*21
MERGE TARR=PXPROBS($JOB),TARR=PXERRORS
DO MKSGLAR(.VOK,.TARR)
+18 ;*21
SET VOK(0)=$GET(OK)_"^"_$GET(PXPROBS)
+19 KILL NOTEIEN,PCELIST,TARR
+20 QUIT
+21 ;
MDS(X,VIALOC) ; return TRUE if checkout is needed ; *21
+1 IF $$CHKOUT(VIALOC)
QUIT 1
+2 NEW I,VIAAUTO,VIAOK
+3 SET (VIAOK,I)=0
+4 FOR
SET I=$ORDER(X("DX/PL",I))
if 'I
QUIT
Begin DoDot:1
+5 IF $GET(X("DX/PL",I,"DIAGNOSIS"))
SET VIAOK=1
End DoDot:1
if VIAOK
QUIT
+6 IF 'VIAOK
Begin DoDot:1
+7 SET I=0
FOR
SET I=$ORDER(X("PROCEDURE",I))
if 'I
QUIT
Begin DoDot:2
+8 IF $GET(X("PROCEDURE",I,"PROCEDURE"))
SET VIAOK=1
End DoDot:2
if VIAOK
QUIT
End DoDot:1
+9 IF $DATA(X("PROVIDER",1,"NAME"))
SET VIAOK=1
+10 QUIT VIAOK
+11 ;
DOCHKOUT(VIAY,LOC) ; Returns TRUE if automatic selection of Visit Type ;*21
+1 NEW SRV
+2 SET SRV=$PIECE($GET(^VA(200,DUZ,5)),U)
+3 SET VIAY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$GET(LOC)_"^SRV.`"_+$GET(SRV)_"^DIV^SYS","VIABRPC DISABLE AUTO CHECKOUT",1,"Q")
+4 IF +VIAY
SET VIAY=1
+5 SET VIAY='VIAY
+6 QUIT
+7 ;
CHKOUT(LOC) ; Returns TRUE if automatic selection of Visit Type ;*21
+1 NEW VIAY
+2 DO DOCHKOUT(.VIAY,LOC)
+3 QUIT VIAY
+4 ;
MKSGLAR(RTN,ARR) ; *21 Make single dimensional array from multi-dimensional array
+1 NEW I,J,CT
+2 SET I=$NAME(ARR)
SET CT=0
+3 FOR
SET I=$QUERY(@I)
if I=""
QUIT
Begin DoDot:1
+4 SET CT=CT+1
+5 SET J=$QLENGTH(I)
+6 SET RTN(CT)=$PIECE(I,",",J)
SET RTN(CT)=$PIECE(RTN(CT),"""",2)_"^"_@I
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
MEDHIST(RESULT,DFN,VIAIFN) ; -- show admin history for a med (RV)
+1 ; ICR#2467,#10141,#3459,#3889,#6479,#6484
+2 ;RPC VIAB MEDHIST
+3 ;This RPC is a similar to ORWPS MEDHIST
+4 NEW VIAPSID,HPIV,ISIV,CKPKG,VIAPHMID
+5 NEW CLIVDISP,DGP
+6 SET VIAPSID=+$PIECE($$OI^ORX8(VIAIFN),U,3)
SET ISIV=0
SET HPIV=0
+7 SET RESULT=$NAME(^TMP("VIAHIST",$JOB))
KILL @RESULT
+8 ;Pharmacy order number
SET VIAPHMID=$$GET1^DIQ(100,+VIAIFN,4,"I")
+9 SET ISIV=$ORDER(^ORD(100.98,"B","IV RX",ISIV))
+10 SET HPIV=$ORDER(^ORD(100.98,"B","TPN",HPIV))
+11 SET CLIVDISP=$ORDER(^ORD(100.98,"B","CI RX",""))
+12 SET CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
+13 ;if the order is pending or the order has no pharmacy #
+14 ;or the order is not in the Display Group IV MEDICATION
+15 ; then use the Orderable item number to get the MAH.
+16 IF (VIAPHMID["P")!(VIAPHMID="")
Begin DoDot:1
+17 IF '$LENGTH($TEXT(HISTORY^PSBMLHS))
Begin DoDot:2
+18 SET @RESULT@(0)="This report is only available using BCMA version 2.0."
End DoDot:2
QUIT
+19 ; DBIA #3459 for BCMA v2.0
DO HISTORY^PSBMLHS(.RESULT,DFN,VIAPSID)
End DoDot:1
QUIT
+20 ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
+21 SET DGP=$$GET1^DIQ(100,+VIAIFN,23,"I")
+22 IF (DGP=ISIV)!(DGP=HPIV)!(DGP=CLIVDISP)
Begin DoDot:1
+23 IF 'CKPKG
SET @RESULT@(0)="Medication Administration History is not available at this time for IV fluids."
+24 IF CKPKG
Begin DoDot:2
+25 ;DBIA #3889
DO RPC^PSBO(.RESULT,"PM",DFN,"","","","","","","","","",VIAPHMID)
+26 IF '$DATA(@RESULT)
SET @RESULT@(0)="No Medication Administration History found for the IV order."
End DoDot:2
End DoDot:1
QUIT
+27 IF '$LENGTH($TEXT(HISTORY^PSBMLHS))
Begin DoDot:1
+28 SET @RESULT@(0)="This report is only available using BCMA version 2.0."
End DoDot:1
QUIT
+29 ; DBIA #3459 for BCMA v2.0
DO HISTORY^PSBMLHS(.RESULT,DFN,VIAPSID)
+30 QUIT
+31 ;
