Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VIABRPC7

VIABRPC7.m

Go to the documentation of this file. 
  1. VIABRPC7 ;AAC/JMC - VIA RPCs ;04/05/2016
  1.  ;;1.0;VISTA INTEGRATION ADAPTER;**7,8,9,12,21**;06-FEB-2014;Build 1
  1.  ;
  1.  ; ICR 1365    DSELECT^GMPLENFM   ^TMP("IB",$J)
  1.  ; ICR 2467    ^ORX8 (Controlled)
  1.  ; ICR 10141   PATCH^XPDUTL (Supported)
  1.  ; ICR 3459    PSBMLHS (Supported)
  1.  ; ICR 3889    PSBO (Controlled)
  1.  ; ICR 5771    100 (Controlled)
  1.  ; ICR 6484    100.98 (Controlled)
  1.  ; ICR 10048   DIC(9.4 (Supported)
  1.  ; ICR 1889    $$DATA2PCE^PXAPI
  1.  ; ICR 3540    FILE^TIUSRVP (Controlled)
  1.  ; ICR 5680    $$EXP^LEXCODE (Supported) 
  1.  ; ICR 5699    $$ICDDATA^ICDXCODE (Supported)
  1.  ; ICR 1995    $$CODEN^ICPTCOD (Supported)
  1.  ; ICR 5679    $$IMPDATE^LEXU (Supported)
  1.  ;
  1.  Q
  1.  ;
  1. DQSAVE ; Background Call to DATA2PCE
  1.  N PKG,SRC,TYP,CODE,IEN,OK,I,X,VIAPXAPI,VIAPXDEL
  1.  N CAT,NARR,ROOT,ROOT2,VIAAVST,VIAENCDT,IMPLDT,PXERRORS,PXPROBS
  1.  N PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS
  1.  N COM,COMMENT,COMMENTS,SVCAT
  1.  N DFN,PROBLEMS,PXAPREDT,VIACPTDE,PXERRZ,VIASAVV
  1.  S IMPLDT=$$IMPDATE^LEXU("10D")
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  S PKG=$O(^DIC(9.4,"B","VISTA INTEGRATION ADAPTER",0))
  1.  ;S SRC=$TR(VIALOC,",./;'<>?:`~!@#$%^&*()-=_+[]{}\|","                                    ") ;*21
  1.  S SRC="TEXT INTEGRATION UTILITIES" ;*21
  1.  S PXAPREDT=0 ;*21
  1.  S (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0
  1.  S I="" F  S I=$O(PCELIST(I)) Q:'I  S X=PCELIST(I) D
  1.  . S TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4)
  1.  . I $E(TYP,1,3)="PRV" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . S PRV=PRV+1
  1.  . . S ROOT="VIAPXAPI(""PROVIDER"","_PRV_")"
  1.  . . S ROOT2="VIAPXDEL(""PROVIDER"","_PRV_")"
  1.  . . I $E(TYP,4)'="-" D
  1.  . . . S @ROOT@("NAME")=CODE
  1.  . . . S @ROOT@("PRIMARY")=$P(X,U,6)
  1.  . . S @ROOT2@("NAME")=CODE
  1.  . . S @ROOT2@("DELETE")=1
  1.  . . S PXAPREDT=1 ;Allow edit of primary flag
  1.  . I TYP="VST" D  Q
  1.  . . S ROOT="VIAPXAPI(""ENCOUNTER"",1)"
  1.  . . I CODE="DT" S (VIAENCDT,@ROOT@("ENC D/T"))=$P(X,U,3) Q
  1.  . . I CODE="PT" S @ROOT@("PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q
  1.  . . I CODE="HL" S @ROOT@("HOS LOC")=$P(X,U,3) Q
  1.  . . I CODE="PR" S @ROOT@("PARENT")=$P(X,U,3) Q
  1.  . . ;prevents checkout!
  1.  . . I CODE="VC" S (SVCAT,@ROOT@("SERVICE CATEGORY"))=$P(X,U,3) Q
  1.  . . I CODE="SC" S @ROOT@("SC")=$P(X,U,3) Q
  1.  . . I CODE="AO" S @ROOT@("AO")=$P(X,U,3) Q
  1.  . . I CODE="IR" S @ROOT@("IR")=$P(X,U,3) Q
  1.  . . I CODE="EC" S @ROOT@("EC")=$P(X,U,3) Q
  1.  . . I CODE="MST" S @ROOT@("MST")=$P(X,U,3) Q
  1.  . . I CODE="HNC" S @ROOT@("HNC")=$P(X,U,3) Q
  1.  . . I CODE="CV" S @ROOT@("CV")=$P(X,U,3) Q
  1.  . . I CODE="SHD" S @ROOT@("SHAD")=$P(X,U,3) Q
  1.  . . I CODE="OL" D  Q
  1.  . . . I +$P(X,U,3) S @ROOT@("INSTITUTION")=$P(X,U,3)
  1.  . . . E  I $P(X,U,4)'="",$P(X,U,4)'="0" D
  1.  . . . . I $$PATCH^XPDUTL("PX*1.0*96") S @ROOT@("OUTSIDE LOCATION")=$P(X,U,4)
  1.  . . . . E  S @ROOT@("COMMENT")="OUTSIDE LOCATION:  "_$P(X,U,4)
  1.  . I $E(TYP,1,3)="CPT" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . S CPT=CPT+1,ROOT="VIAPXAPI(""PROCEDURE"","_CPT_")"
  1.  . . S IEN=$$CODEN^ICPTCOD(CODE) ;ICR #1995
  1.  . . S @ROOT@("PROCEDURE")=IEN
  1.  . . I +$P(X,U,9) D
  1.  . . . S MODS=$P(X,U,9),MODCNT=+MODS
  1.  . . . F MODIDX=1:1:MODCNT D
  1.  . . . . S MOD=$P($P(MODS,";",MODIDX+1),"/")
  1.  . . . . S @ROOT@("MODIFIERS",MOD)=""
  1.  . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
  1.  . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
  1.  . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5)
  1.  . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
  1.  . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT
  1.  . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0,VIACPTDE=CPT
  1.  . I $E(TYP,1,3)="POV" D  Q
  1.  . . N VIADXI,VIADX
  1.  . . Q:'$L(CODE)
  1.  . . F VIADXI=1:1:$L(CODE,"/") D
  1.  . . . N CSYS,CDT,IEN,LEXIEN
  1.  . . . S VIADX=$P(CODE,"/",VIADXI)
  1.  . . . S ICD=ICD+1,ROOT="VIAPXAPI(""DX/PL"","_ICD_")"
  1.  . . . I (VIADX]""),(VIADX'[".") S VIADX=VIADX_"."
  1.  . . . S IEN=$P($$CODEN^ICDEX(VIADX,80),"~",1) ;*21  S IEN=+$$ICDDATA^ICDXCODE(CSYS,VIADX,CDT,"E")
  1.  . . . I IEN'>0 Q
  1.  . . . S @ROOT@("DIAGNOSIS")=IEN
  1.  . . . S @ROOT@("PRIMARY")=$S(VIADXI=1:$P(X,U,5),1:0)
  1.  . . . S CDT=$S($G(SVCAT)="E":DT,1:VIAENCDT) ;*21 move 2 lines
  1.  . . . S CSYS=$$CSI^ICDEX(80,IEN) ;*21   S CSYS=$S(CDT'<IMPLDT:"10D",1:"ICD")
  1.  . . . S LEXIEN=$P($$EXP^LEXCODE(VIADX,CSYS,CDT),U),@ROOT@("LEXICON TERM")=$S(LEXIEN>0:LEXIEN,1:"")
  1.  . . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
  1.  . . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
  1.  . . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
  1.  . . . 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
  1.  . . . S:$L($P(X,U,10))>0&(VIADXI=1) COMMENT($P(X,U,10))="DX/PL^"_ICD
  1.  . . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
  1.  . I $E(TYP,1,3)="IMM" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . S IMM=IMM+1,ROOT="VIAPXAPI(""IMMUNIZATION"","_IMM_")"
  1.  . . S @ROOT@("IMMUN")=CODE
  1.  . . S:$L($P(X,U,5)) @ROOT@("SERIES")=$P(X,U,5)
  1.  . . S:$L($P(X,U,5)) @ROOT@("REACTION")=$P(X,U,7)
  1.  . . S:$L($P(X,U,8)) @ROOT@("CONTRAINDICATED")=$P(X,U,8)
  1.  . . S:$L($P(X,U,9)) @ROOT@("REFUSED")=$P(X,U,9)
  1.  . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
  1.  . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM
  1.  . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
  1.  . I $E(TYP,1,2)="SK" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . S SK=SK+1,ROOT="VIAPXAPI(""SKIN TEST"","_SK_")"
  1.  . . S @ROOT@("TEST")=CODE
  1.  . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5)
  1.  . . S:$L($P(X,U,7)) @ROOT@("READING")=$P(X,U,7)
  1.  . . S:$L($P(X,U,8)) @ROOT@("D/T READ")=$P(X,U,8)
  1.  . . S:$L($P(X,U,9)) @ROOT@("EVENT D/T")=$P(X,U,9)
  1.  . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
  1.  . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK
  1.  . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1
  1.  . I $E(TYP,1,3)="PED" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . S PED=PED+1,ROOT="VIAPXAPI(""PATIENT ED"","_PED_")"
  1.  . . S @ROOT@("TOPIC")=CODE
  1.  . . S:$L($P(X,U,5)) @ROOT@("UNDERSTANDING")=$P(X,U,5)
  1.  . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
  1.  . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED
  1.  . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
  1.  . I $E(TYP,1,2)="HF" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . S HF=HF+1,ROOT="VIAPXAPI(""HEALTH FACTOR"","_HF_")"
  1.  . . S @ROOT@("HEALTH FACTOR")=CODE
  1.  . . S:$L($P(X,U,5)) @ROOT@("LEVEL/SEVERITY")=$P(X,U,5)
  1.  . . S:$P(X,U,6)'>0 $P(X,U,6)=$G(VIAPXAPI("PROVIDER",1,"NAME"))
  1.  . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
  1.  . . S:$L($P(X,U,11)) @ROOT@("EVENT D/T")=$P($P(X,U,11),";",1)
  1.  . . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2)
  1.  . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF
  1.  . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1
  1.  . I $E(TYP,1,3)="XAM" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . S XAM=XAM+1,ROOT="VIAPXAPI(""EXAM"","_XAM_")"
  1.  . . S @ROOT@("EXAM")=CODE
  1.  . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5)
  1.  . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
  1.  . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM
  1.  . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1
  1.  . I $E(TYP,1,3)="TRT" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . S TRT=TRT+1,ROOT="VIAPXAPI(""TREATMENT"","_TRT_")"
  1.  . . S @ROOT@("IMMUN")=CODE
  1.  . . S:$L(CAT) @ROOT@("CATEGORY")=CAT
  1.  . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR
  1.  . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5)
  1.  . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6)
  1.  . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT
  1.  . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0
  1.  . I $E(TYP,1,3)="COM" D  Q
  1.  . . Q:'$L(CODE)
  1.  . . Q:'$L(CAT)
  1.  . . S COMMENTS(CODE)=$P(X,U,3,999)
  1.  ;Store the comments
  1.  S COM=""
  1.  F  S COM=$O(COMMENT(COM)) Q:COM=""  S:$D(COMMENTS(COM)) VIAPXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
  1.  ;
  1.  ;Remove any problems to add that the patient already has as active problems
  1.  I $D(PROBLEMS),$D(DFN) D
  1.  . N VIAWPROB,VIAPROBI
  1.  . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
  1.  . D DSELECT^GMPLENFM  ;DBIA 1365
  1.  . S VIAPROBI=0
  1.  . F  S VIAPROBI=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBI)) Q:'VIAPROBI  D  ;DBIA 1365
  1.  .. S VIAWPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",VIAPROBI),"^",2,3)
  1.  .. S VIAWPROB($S($E(VIAWPROB,1)="$":$E(VIAWPROB,2,255),1:VIAWPROB))=""
  1.  . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
  1.  . Q:'$D(VIAWPROB)
  1.  . S VIAPROBI=""
  1.  . F  S VIAPROBI=$O(PROBLEMS(VIAPROBI)) Q:'VIAPROBI  D
  1.  .. S:$D(VIAWPROB(PROBLEMS(VIAPROBI))) VIAPXAPI("DX/PL",VIAPROBI,"PL ADD")=0
  1.  ;
  1.  I $$MDS(.VIAPXAPI,$G(VIALOC)) D  ;*21
  1.  .N VIATIME ;*21
  1.  .S VIATIME=$$NOW^XLFDT ;*21
  1.  .S VIATIME=+($P(VIATIME,".")_"."_$E($P(VIATIME,".",2),1,4)) ;*21
  1.  .S VIAPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=VIATIME ;*21
  1.  S VIAPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
  1. DATA2PCE ;
  1.  ;N VSTR ;*21
  1.  ;S VSTR=$P(PCELIST(1),U,4) K ^TMP("VIAPCE",$J,VSTR) ;*21
  1.  ;S (VIASAVV,VIAAVST)=$$GETVSIT^VIABRPC(VSTR,DFN) ;*21
  1.  I $G(PXAPREDT)!($G(VIACPTDE)) D
  1.  . M VIAPXDEL("ENCOUNTER")=VIAPXAPI("ENCOUNTER")
  1.  . I $G(VIACPTDE) M VIAPXDEL("PROCEDURE",VIACPTDE)=VIAPXAPI("PROCEDURE",VIACPTDE)
  1.  . ;S OK=$$DATA2PCE^PXAPI("VIAPXDEL",PKG,SRC,.VIAAVST) ;*21
  1.  . 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
  1.  ;S VIAAVST=VIASAVV,PXERRZ="" ;*21
  1.  ;S OK=$$DATA2PCE^PXAPI("VIAPXAPI",PKG,SRC,.VIAAVST,,1,.PXERRORS,1,.PXPROBS) ;*21
  1.  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
  1.  I $S(OK[1:OK,OK[-1:1,OK[-5:1,1:0),+NOTEIEN,+VIAAVST D  ; NOTEIEN only set on inpatient encounters
  1.  .N VIAOK,VIAX
  1.  .S VIAX(1207)=VIAAVST
  1.  .D FILE^TIUSRVP(.VIAOK,NOTEIEN,.VIAX,1)
  1.  S ZTSTAT=0  ; clear sync flag
  1.  M TARR=PXPROBS($J),TARR=PXERRORS D MKSGLAR(.VOK,.TARR) ;*21
  1.  S VOK(0)=$G(OK)_"^"_$G(PXPROBS) ;*21
  1.  K NOTEIEN,PCELIST,TARR
  1.  Q
  1.  ;
  1. MDS(X,VIALOC) ; return TRUE if checkout is needed ; *21
  1.  I $$CHKOUT(VIALOC) Q 1
  1.  N I,VIAAUTO,VIAOK
  1.  S (VIAOK,I)=0
  1.  F  S I=$O(X("DX/PL",I)) Q:'I  D  Q:VIAOK
  1.  . I $G(X("DX/PL",I,"DIAGNOSIS")) S VIAOK=1
  1.  I 'VIAOK D
  1.  .S I=0 F  S I=$O(X("PROCEDURE",I)) Q:'I  D  Q:VIAOK
  1.  .. I $G(X("PROCEDURE",I,"PROCEDURE")) S VIAOK=1
  1.  I $D(X("PROVIDER",1,"NAME")) S VIAOK=1
  1.  Q VIAOK
  1.  ;
  1. DOCHKOUT(VIAY,LOC) ; Returns TRUE if automatic selection of Visit Type ;*21
  1.  N SRV
  1.  S SRV=$P($G(^VA(200,DUZ,5)),U)
  1.  S VIAY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","VIABRPC DISABLE AUTO CHECKOUT",1,"Q")
  1.  I +VIAY S VIAY=1
  1.  S VIAY='VIAY
  1.  Q
  1.  ;
  1. CHKOUT(LOC) ; Returns TRUE if automatic selection of Visit Type ;*21
  1.  N VIAY
  1.  D DOCHKOUT(.VIAY,LOC)
  1.  Q VIAY
  1.  ;
  1. MKSGLAR(RTN,ARR) ; *21 Make single dimensional array from multi-dimensional array 
  1.  N I,J,CT
  1.  S I=$NA(ARR),CT=0
  1.  F  S I=$Q(@I) Q:I=""  D
  1.  . S CT=CT+1
  1.  . S J=$QL(I)
  1.  . S RTN(CT)=$P(I,",",J),RTN(CT)=$P(RTN(CT),"""",2)_"^"_@I
  1.  .Q
  1.  Q
  1.  ;
  1. MEDHIST(RESULT,DFN,VIAIFN) ; -- show admin history for a med  (RV)
  1.  ; ICR#2467,#10141,#3459,#3889,#6479,#6484
  1.  ;RPC VIAB MEDHIST
  1.  ;This RPC is a similar to ORWPS MEDHIST
  1.  N VIAPSID,HPIV,ISIV,CKPKG,VIAPHMID
  1.  N CLIVDISP,DGP
  1.  S VIAPSID=+$P($$OI^ORX8(VIAIFN),U,3),ISIV=0,HPIV=0
  1.  S RESULT=$NA(^TMP("VIAHIST",$J)) K @RESULT
  1.  S VIAPHMID=$$GET1^DIQ(100,+VIAIFN,4,"I")  ;Pharmacy order number
  1.  S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV))
  1.  S HPIV=$O(^ORD(100.98,"B","TPN",HPIV))
  1.  S CLIVDISP=$O(^ORD(100.98,"B","CI RX",""))
  1.  S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
  1.  ;if the order is pending or the order has no pharmacy #
  1.  ;or the order is not in the Display Group IV MEDICATION
  1.  ; then use the Orderable item number to get the MAH.
  1.  I (VIAPHMID["P")!(VIAPHMID="") D  Q
  1.  . I '$L($T(HISTORY^PSBMLHS)) D  Q
  1.  . . S @RESULT@(0)="This report is only available using BCMA version 2.0."
  1.  . D HISTORY^PSBMLHS(.RESULT,DFN,VIAPSID)  ; DBIA #3459 for BCMA v2.0
  1.  ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
  1.  S DGP=$$GET1^DIQ(100,+VIAIFN,23,"I")
  1.  I (DGP=ISIV)!(DGP=HPIV)!(DGP=CLIVDISP) D  Q
  1.  . I 'CKPKG S @RESULT@(0)="Medication Administration History is not available at this time for IV fluids."
  1.  . I CKPKG D
  1.  . . D RPC^PSBO(.RESULT,"PM",DFN,"","","","","","","","","",VIAPHMID)  ;DBIA #3889
  1.  . . I '$D(@RESULT) S @RESULT@(0)="No Medication Administration History found for the IV order."
  1.  I '$L($T(HISTORY^PSBMLHS)) D  Q
  1.  . S @RESULT@(0)="This report is only available using BCMA version 2.0."
  1.  D HISTORY^PSBMLHS(.RESULT,DFN,VIAPSID)  ; DBIA #3459 for BCMA v2.0
  1.  Q
  1.  ;