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

IBMHPMPY3.m

Go to the documentation of this file. 
  1. IBMHPMPY3 ;EDE/WCJ-Multi-site maintain IB MH VISIT TRACKING FILE (#351.83) - (aka PushMi-PullYu); 22-OCT-23
  1.  ;;2.0;INTEGRATED BILLING;**779**;21-MAR-94;Build 7
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;; DBIA#1621 %ZTER (ERROR RECORDING)
  1.  ;; DBIA#2729 MESSAGE ACTION API
  1.  ;; DBIA#4678 VAFCTFU GET TREATING LIST
  1.  ;; DBIA#3144 DIRECT RPC CALLS
  1.  ;; DBIA#3149 XWBDRPC
  1.  ; 
  1.  G AWAY
  1.  ;
  1. AWAY Q  ;thought I was being figurative??? Haha, Guess again!
  1.  ;
  1. PULL ; This will be called from a menu option.
  1.  ; ask the patient and if selected, initiate the pull
  1.  ;
  1.  N IBDFN,IBPULLRESULTS
  1.  ;
  1. AGAIN Q:'$$GETPAT(.IBDFN)
  1.  ;
  1.  D PATIENTPULL(IBDFN,.IBPULLRESULTS)
  1.  ;
  1.  D DISPLAYRES(IBDFN,.IBPULLRESULTS)
  1.  ;
  1.  K IBDFN,IBPULLRESULTS
  1.  G AGAIN   ; I know, I know, it's a goto - please don't judge me
  1.  ;
  1. GETPAT(IBDFN) ; Select a patient.
  1.  ; Return 0 - no patient selected
  1.  ; Return 1 - patient selected
  1.  ; IBDFN will be the patient's IEN in file 2
  1.  ;
  1.  N DIC,X,Y
  1.  N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
  1.  S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC S IBDFN=+Y
  1.  Q Y>0
  1.  ;
  1. PATIENTPULL(IBDFN,IBERR) ; This does a lot of the same stuff the push does only for a specific veteran.
  1.  ; IBDFN - which patient
  1.  ; IBERR - return array of results
  1.  ;
  1.  K ^TMP("IBMHPMPY",$J)  ; start fresh
  1.  ;
  1.  N IBSITE,IBFAC,IBTFL,IBT,IBICN,IBH,IBX,IBR,IBHERE,IBC,IBZ
  1.  S IBERR=0
  1.  ;
  1.  D SITE^IBAUTL   ; returns IBSITE (external#) and IBFAC (internal#) based on IB SITE PARAMETERS for this site
  1.  S IBICN=$$ICN^IBARXMU(IBDFN)
  1.  I 'IBICN S IBERR=IBERR+1,IBERR(IBERR)="-1^Failed local ICN lookup." Q  ; no ICN - leave in the index and try again tomorrow since people eventually get ICNs according the MPI documentation
  1.  S IBT=$$TFL^IBMHPMPY1(IBDFN,IBSITE,.IBTFL)
  1.  I 'IBT S IBERR=IBERR+1,IBERR(IBERR)="-1^No record of Veteran being seen at other treating facilities (file #391.91)" Q   ; not seen at other treating facilites so no where to send - done with entry
  1.  ;
  1.  ; send off calls to other treating facilities that this veteran has been seen at
  1.  ; the calls fire off the RPC (stored procedure) at each site
  1.  S IBX=0 F  S IBX=$O(IBTFL(IBX)) Q:IBX<1  D
  1.  . W !,"Now sending query to ",$P(IBTFL(IBX),"^",2)," ..."
  1.  . N IBH
  1.  . D EN1^XWB2HL7(.IBH,+IBTFL(IBX),"IBMH COPAY SYNCH","",IBICN,IBSITE)  ; push a request for all records for a patient (used when playing catch up - possibly adding a treating facility)
  1.  . ; check for handle
  1.  . I $G(IBH(0))="" D  Q
  1.  .. S IBTFL(IBX,"ERR")="-1^No handle returned from RPC"
  1.  .. S IBERR=IBERR+1,IBERR(IBERR)="-1^No handle returned from RPC by site "_$P(IBTFL(IBX),"^",2)
  1.  . S $P(IBTFL(IBX),"^",3)=IBH(0) ; save handle for later.
  1.  ;
  1.  ; now lets look for the remote data
  1.  S IBX=0 F  S IBX=$O(IBTFL(IBX)) Q:IBX<1  I '$D(IBTFL(IBX,"ERR")) D
  1.  . ;
  1.  . ; try up to 10 times for 2 seconds each (at each site)
  1.  . N IBR
  1.  . F IBC=1:1:10 D RPCCHK^XWB2HL7(.IBR,$P(IBTFL(IBX),U,3)) Q:$G(IBR(0))["Done"  H 2
  1.  . ;
  1.  . ; If not done at one (or more) facility set a flag so it does not get removed from the index 
  1.  . I $G(IBR(0))'["Done" S IBERR=IBERR+1,IBERR(IBERR)="-1^No reply from site "_+IBTFL(IBX)_"."
  1.  . ; if done get data.
  1.  . I $G(IBR(0))["Done" D
  1.  .. K IBR,IBHERE
  1.  .. W !,"Query to site "_+IBTFL(IBX)_" completed."
  1.  .. D RTNDATA^XWBDRPC(.IBHERE,$P(IBTFL(IBX),"^",3))
  1.  .. I $D(IBHERE)>10 D   ; not sure if was success or failure so save for now
  1.  ... S IBERR=IBERR+1
  1.  ... M IBERR(IBERR,+IBTFL(IBX),"REC")=IBHERE
  1.  .. E  D
  1.  ... S IBERR=IBERR+1
  1.  ... M IBERR(IBERR,+IBTFL(IBX),"ERR")=^TMP($J,"XWB")
  1.  ... K ^TMP($J,"XWB")
  1.  .. D CLEAR^XWBDRPC(.IBZ,$P(IBTFL(IBX),"^",3))
  1.  ; 
  1.  Q
  1.  ;
  1. PARSEPULL(IBPD,IBDFN,ERR) ; parse the record being pulled from the originating site
  1.  ; IBPD is a packed data array
  1.  ; "IEN^.01I^.01^C2^.03I^.04I^.05^.06I^.07I^1.01I^C9"
  1.  ; "ien at originating site^dfn at originating site^patient name^originating site^event date^status^bill #^reason^unique id^update^full icn"
  1.  ; "2^7229593^LASTNAME,FIRSTNAME MIDDLE^529^3190814^2^442-K902Z6L^^^99999999999v999999"
  1.  ; IBDFN is the patient that we asked for
  1.  ; ERR is returned even if it's not an ERROR so kind of a misnomer.
  1.  ;
  1.  ; and then add it, update it, or punt.
  1.  ;
  1.  N IBUID,IBOS,IBIEN,IBRETURN
  1.  ;WCJ;IB696;date added variable
  1.  ;N IBICN,IBED,IBST,IBRS,IBBN,IBEG,IBADDED,IBUPDATED
  1.  N IBICN,IBED,IBST,IBRS,IBBN,IBEG,IBADDED,IBUPDATED,IBDADDRS,IBDADDHERE
  1.  ;
  1.  ; get the patient from their ICN and compare for grins - probably unneeded code but kind of fun - don't ya think
  1.  S IBICN=$P(IBPD,U,11) ; ICN
  1.  I IBDFN'=+$$DFN^IBARXMU($G(IBICN)) S ERR(1)="-1^Something went horribly wrong." Q
  1.  ;
  1.  ; get unique identifier and if not there, make one.
  1.  S IBUID=$P(IBPD,U,9)  ; unique ID
  1.  I IBUID="" D
  1.  . S IBOS=$P(IBPD,U,4)  ; originating site
  1.  . S IBIEN=$P(IBPD,U)  ; 351.83 IEN at originating site
  1.  . S IBUID=IBOS_"_"_IBIEN
  1.  ;
  1.  I IBUID="" S ERR(1)="-1^No UNIQUE ID - this can't actually happen so not sure why I am coding for it." Q
  1.  ;
  1.  S IBED=$P(IBPD,U,5)  ; event date
  1.  S IBST=$P(IBPD,U,6)  ; status
  1.  S IBBN=$P(IBPD,U,7)  ; bill number
  1.  S IBRS=$P(IBPD,U,8)  ; reason
  1.  S IBEG=$P(IBPD,U,12)  ; eligibilty group
  1.  D
  1.  . N X
  1.  . S X=$P(IBPD,U,13)
  1.  . D ^%DT
  1.  . S IBDADDRS=$S(+Y:Y,1:"")   ;date added to patient file at the Remote System
  1.  S IBDADDHERE=$$GET1^DIQ(2,IBDFN,.097,"I")  ; date patient added to this system aka HERE.
  1.  ;
  1.  ; see if the record is already here.
  1.  D FIND^DIC(351.83,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I","QEPX",IBUID,"","AUID")
  1.  ;
  1.  ; found 1 so attempt to edit it
  1.  I +$G(^TMP("DILIST",$J,0))=1 D  Q
  1.  . N IBDATA,IBIEN351P82
  1.  . S IBDATA=$G(^TMP("DILIST",$J,1,0))
  1.  . S IBIEN351P82=+IBDATA
  1.  . I $P(IBDATA,U,6)=IBST,$P(IBDATA,U,7)=IBBN,$P(IBDATA,U,8)=IBRS S ERR(1)="0^No changes requested" Q
  1.  . S IBUPDATED=$$UPDATE^IBMHPMPY2(IBIEN351P82,IBST,IBBN,IBRS,0,.IBRETURN)
  1.  . I 'IBUPDATED D  Q
  1.  .. N Y
  1.  .. S Y=IBED X ^DD("DD")
  1.  .. S ERR(1)="-1^Unable to ADD record from Originating site# "_$P(IBUID,"_")_" and date: "_Y
  1.  .. S:IBRETURN["MAX free" ERR(2)=-1_U_IBRETURN
  1.  . S ERR(1)="1^successfully updated" Q
  1.  . Q
  1.  ;
  1.  ; found "many" (could be two or a jillion).  Should not happen now that we add a unique identifier (KEYWORDS: should + not + unique)
  1.  I +$G(^TMP("DILIST",$J,0))>1 D  Q
  1.  . S ERR(1)="-1^Could not uniquely identify entry being updated - more than one match.  Originating site# "_$P(IBUID,"_")_" and IEN:"_$P(IBUID,"_",2)
  1.  ;
  1.  ; no matches, feel free to add one
  1.  I '$G(^TMP("DILIST",$J,0)) D  Q
  1.  . S IBADDED=$$ADD^IBMHPMPY2(IBDFN,IBOS,IBED,IBST,IBBN,IBRS,0,IBUID,.IBRETURN)
  1.  . I 'IBADDED D  Q
  1.  .. N Y
  1.  .. S Y=IBED X ^DD("DD")
  1.  .. S ERR(1)="-1^Unable to ADD record from Originating site# "_$P(IBUID,"_")_" and date: "_Y
  1.  .. S:IBRETURN["MAX free" ERR(2)=-1_U_IBRETURN
  1.  . S ERR(1)="1^successfully added" Q
  1.  . Q
  1.  Q
  1.  ;
  1. DISPLAYRES(IBDFN,IBPULLRESULTS) ; display results
  1.  N ARR,IBDATA,IBCNT,IBMAX,IBOUT
  1.  S ARR="IBPULLRESULTS",IBCNT=1,IBMAX=10,IBOUT=0
  1.  F  S ARR=$Q(@ARR) Q:ARR=""  D  Q:IBOUT
  1.  . I ARR["REC" D  Q
  1.  .. I ARR["""REC"")" Q
  1.  .. I ARR[",0)" Q   ; don't need 0 node, info only - IBPULLRESULTS(1,529,"REC",0)="23^*^0^"
  1.  .. I ARR[",1)" Q   ; don't need 1 node, info only - IBPULLRESULTS(1,529,"REC",1)="IEN^.01I^.01^C2^.03I^.04I^.05^.06I^.07I^1.01I^.08"
  1.  .. N IBPULLDATA,IBERR
  1.  .. S IBPULLDATA=$G(@ARR)
  1.  .. D PARSEPULL(IBPULLDATA,IBDFN,.IBERR)  ; parse data coming back - IBPULLRESULTS(1,529,"REC",2)="2^7229593^LASTNAME,FIRSTNAME MIDDLE^529^3190814^2^442-K902Z6L^^^0^1234567890V123456^8"
  1.  .. I $P($G(IBERR(1)),U)<0 D
  1.  ... N I S I=0 F  S I=$O(IBERR(I)) Q:'I  S IBOUT=$$WRITE($P(IBERR(I),U,2,999),.IBCNT) Q:+IBOUT 
  1.  . S IBDATA=$G(@ARR)
  1.  . S:IBDATA[U IBDATA=$P(IBDATA,U,2,999)
  1.  . I IBDATA]"" S IBOUT=$$WRITE(IBDATA,.IBCNT)
  1.  W !!
  1.  Q
  1.  ;
  1. WRITE(DATA,CNT) ;
  1.  N DIRUT,DIROUT
  1.  W !,DATA
  1.  I '(CNT#20) D PAUSE^VALM1
  1.  S CNT=$G(CNT)+1
  1.  Q $G(DIRUT)