IBMHPMPY2 ;EDE/WCJ-Multi-site maintain IB MH VISIT TRACKING FILE (#351.83) - (aka PushMi-PullYu); 22-OCT-23
;;2.0;INTEGRATED BILLING;**779**;21-MAR-94;Build 7
;;Per VA Directive 6402, this routine should not be modified.
;; DBIA#1621 %ZTER (ERROR RECORDING)
;; DBIA#10053 grab field .097 from file 2
G AWAY
;
AWAY Q ;thought I was being figurative??? Haha, Guess again!
;
; RPC endpoint
; this is where the RPC is actually called at the remote facility.
RETURN(IBR,IBICN,IBOSITEEX,IBVISDT,IBSTAT,IBBILL,IBCOMM,IBUNIQ) ;
;
; INPUT:
; IBR - Results go here
; IBICN - Patients ICN so that we can find the patient across sites
; IBOSITEEX - external site number
; IBVISDT - Visit date
; IBSTAT - Status
; IBBILL - Bill number or possibly free text description such as 'ONHOLD'
; IBCOMM - Cancel reason
; IBUPDATE - 1 if this is the originating site and data should be pushed out to other treating facilities, otherwise 0
; IBUNIQ - Unique ID consiting of external site number underscor ien of file 351.83 on originating site ex. 442_1234567
; OUTPUT:
; results are returned in the results array as described in INPUT section
; "-1^Error message"
; "-2^Error message" if patent eligibility group mismatch IB*2.0*761
; "-3^Error message" if no remaining Free Days. IB*2.0*761
; "0^No action taken (nor needed) message"
; "1^Success message"
;
; ADDITIONAL OUTPUT on PULL - all records for a patient in file 351.83 that were created at this facility
;
; 1) check if the entry is already there based on the unique ID (external originating site and their IEN from file 351.83) passed in.
; 2) if it's already there, see if anything changed (might be an update).
; a) if already there and no changes, don't do anything with it but also don't return an error message. Any cheerful, uplifting response would do and then gracefully exit.
; b) if already there but allowable fields being updated, then do so, let them know, and quitely ride off into the sunset.
; 3) If you got this far, add it to the file.
; 4) return something to let them know how you did
;
;D APPERROR^%ZTER("Bill's Intentional Error #1 - AKA got here")
I '$D(IBR) S IBR=$NA(^TMP("IBMHPMPY1",$J)) ; didn't think I would need, but...
;
N IBDFN,IBSCREEN,IBIEN4,IBDATA,IBIEN351P82,IBADDED,IBUPDATED,IBRETURN,IBMISS,IBFAC,IBSITE
D SITE^IBAUTL ; returns IBSITE (external) and IBFAC (internal may not be VAMC)
;
; see if it's a pull for specific patient. It will only have the patient's ICN and the site it's pulling to
I '$D(IBVISDT),'$D(IBSTAT),'$D(IBBILL),'$D(IBCOMM),'$D(IBUNIQ),$G(IBICN),$G(IBOSITEEX) D Q
. D PULL(.IBR,IBFAC,IBSITE,IBICN,IBOSITEEX)
. Q
;
; Make sure everything needed is here. Better doublecheck on what is needed.
S IBMISS=$S('$D(IBICN):1,'$D(IBOSITEEX):2,'$D(IBVISDT):3,'$D(IBSTAT):4,'$D(IBBILL):5,'$D(IBCOMM):6,'$D(IBUNIQ):7,1:0)
I IBMISS S @IBR@(1)="-1^Missing required input parameter: "_$P("IBICN.IBOSITEEX.IBVISDT.IBSTAT.IBBILL.IBCOMM.IBUNIQ",".",IBMISS) Q
;
I IBOSITEEX=IBSITE S @IBR@(1)="0^No action performed. Current site# "_IBSITE_" equals originating site# "_IBOSITEEX Q
;
S IBIEN4=$$FIND1^DIC(4,,"X",IBOSITEEX,"D") ; get the internal site number (File 4 IEN) - should be the same across sites but then again shouldn't have to.
I 'IBIEN4 S @IBR@(1)="-1^Site# "_IBOSITEEX_" not found in INSTITUTION (#4) file lookup" Q
;
; make sure the patient is identifiable from this ICN
; if not, not much I can do
S IBDFN=+$$DFN^IBARXMU($G(IBICN))
I 'IBDFN S @IBR@(1)="-1^Patient ICN: "_IBICN_" not found at site# "_IBSITE Q
;
;D FIND^DIC(file[,iens][,fields][,flags],[.]value[,number][,[.]indexes][,[.]screen][,identifier][,target_root][,msg_root]) ; this line is just for reference
;
; this sets the screen for the FIND call.
; FIND is by IBUNIQ (the unique ID consisting of the external site # and the the IEN to file 351.83 at that site.
; It if finds one, it's a potential edit and we will deal with that.
; If it finds more than one, not much I can do except throw my hands in the air. Since adding the unique ID, that really shouldn't happen.
;
D FIND^DIC(351.83,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I","QEPX",IBUNIQ,"","AUID")
;
; found one - see if anything changed and update if needed
; now what can really change - IBSTAT, IBBILL, IBCOMM are only fields allowed to change
I +$G(^TMP("DILIST",$J,0))=1 D Q
. S IBDATA=$G(^TMP("DILIST",$J,1,0))
. S IBIEN351P82=+IBDATA
. I $P(IBDATA,U,6)=IBSTAT,$P(IBDATA,U,7)=IBBILL,$P(IBDATA,U,8)=IBCOMM S @IBR@(1)="0^No changes requested" Q
. S IBUPDATED=$$UPDATE(IBIEN351P82,IBSTAT,IBBILL,IBCOMM,1,.IBRETURN)
. I 'IBUPDATED D Q
.. S @IBR@(1)="-1^Unable to UPDATE record at site# "_IBSITE_"."
.. S:IBRETURN["MAX free" @IBR@(2)=-1_U_IBRETURN
. S @IBR@(1)="1^successfully updated" Q
. Q
;
; found "many" (could be two or a jillion). Should not happen now that we add a unique identifier (KEYWORDS: should + not + unique)
I +$G(^TMP("DILIST",$J,0))>1 D Q
. S @IBR@(1)="-1^Could not uniquely identify entry being updated - more than one match. Originating site# "_$P(IBUNIQ,"_")_" and IEN:"_$P(IBUNIQ,"_",2) Q
;
; no matches, feel free to add one
I '$G(^TMP("DILIST",$J,0)) D Q
. S IBADDED=$$ADD(IBDFN,IBOSITEEX,IBVISDT,IBSTAT,IBBILL,IBCOMM,0,IBUNIQ,.IBRETURN)
. I 'IBADDED D Q
. . ;IB*2.0*761 updated return code for no free visits left
.. S @IBR@(1)="-1^Unable to ADD record at site# "_IBSITE_"."
.. S:IBRETURN["MAX free" @IBR@(2)=-3_U_IBRETURN ;IB*2.0*761
. S @IBR@(1)="1^successfully added" Q
. Q
Q
;
ADD(IBDFN,IBSITE,IBVISDT,IBSTAT,IBBILL,IBCOMM,IBUPDATE,IBUNIQ,RETURN) ; Add an entry to the file
; INPUT:
; IBDFN - Pointer to the patient number
; IBSITE - external site number
; IBVISDT - Visit date
; IBSTAT - Status
; IBBILL - Bill number or possibly free text description such as 'ONHOLD'
; IBCOMM - Cancel reason
; IBUPDATE - 1 if this is the originating site and data should be pushed out to other treating facilities, otherwise 0
; IBUNIQ - Unique ID consiting of external site number underscor ien of file 351.83 on originating site ex. 442_1234567
; OUTPUT:
; RETURN - This is any information returned by FileMan if update was unsuccessful
;
; Function call returns 0 or 1 if successful.
; data must be all internal or all external - no mashup of the two allowed
; I vote internal and since I am coding...
; the incoming parameters were all internal except site #.
; NOTE to self: internal data is filed without validation so be sure it's cool
;
N IBCTS
S IBCTS=$$NUMVSTCK^IBECEAMH(IBDFN,IBVISDT)
I $G(IBSTAT)=1,'IBCTS D Q 0
. N Y
. S Y=IBVISDT X ^DD("DD")
. S RETURN="Exceeds MAX free visits in a calendar year. Can't add "_Y_"."
;
N FDA,IENS
S IENS="+1,"
S FDA(351.83,IENS,.01)=IBDFN
S FDA(351.83,IENS,.02)=$$FIND1^DIC(4,,"X",IBSITE,"D") ; turn external site # into internal one
S FDA(351.83,IENS,.03)=IBVISDT
S FDA(351.83,IENS,.04)=$G(IBSTAT)
S FDA(351.83,IENS,.05)=$G(IBBILL)
S FDA(351.83,IENS,.06)=$G(IBCOMM)
S FDA(351.83,IENS,.07)=$G(IBUNIQ)
S FDA(351.83,IENS,1.01)=$G(IBUPDATE) ; While technically being added, this is not the originating site so don't mark as such. The flag is used to determine which entries to push.
;
; first parameter is currently "" so internal it is for now
D UPDATE^DIE("","FDA","","RETURN")
;
; if RETURN is defined then BAD else GOOD
Q $S($D(RETURN):0,1:1)
;
UPDATE(IBIEN,IBSTAT,IBBILL,IBCOMM,IBUPDATE,RETURN) ; update an entry to the file
; INPUT:
; IBIEN - internal entry number into 351.83 that is being edited
; IBSTAT - Status
; IBBILL - Bill number or possibly free text description such as 'ONHOLD'
; IBCOMM - Cancel reason
; IBUPDATE - 1 if this is the originating site and data should be pushed out to other treating facilities, otherwise 0
; OUTPUT:
; RETURN - This is any information returned by FileMan if update was unsuccessful
;
; Function call returns 0 or 1 if successful.
;
; limiting edits to a few fields
; data must be all internal or all external - no mashup of the two allowed
; I still vote internal and since I am still coding...
; the incoming parameters were all internal
; NOTE to self: internal data is filed without validation so be sure it's cool
;
; returns 1 if added sucessfully
; returns 0 otherwise
;
N IBCTS,IBDFN,IBVISDT
S IBDFN=$$GET1^DIQ(351.83,IBIEN,.01,"I")
S IBVISDT=$$GET1^DIQ(351.83,IBIEN,.03,"I")
S IBCTS=$$NUMVSTCK^IBECEAMH(IBDFN,IBVISDT)
I $G(IBSTAT)=1,'IBCTS D Q 0
. N Y
. S Y=IBVISDT X ^DD("DD")
. S RETURN="Exceeds MAX free visits in a calendar year. Can't update "_Y_"."
;
N FDA,IENS
S IENS=IBIEN_","
S FDA(351.83,IENS,.04)=$G(IBSTAT)
S FDA(351.83,IENS,.05)=$G(IBBILL)
S FDA(351.83,IENS,.06)=$G(IBCOMM)
S FDA(351.83,IENS,1.01)=$G(IBUPDATE,0)
;
; first parameter is currently "" so internal it is for now
D FILE^DIE("","FDA","RETURN")
;
; if RETURN is defined then BAD else GOOD
Q $S($D(RETURN):0,1:1)
;
PULL(RETURN,IBFAC,IBSITE,IBICN,IBOSITEEX) ; Pull all records that originated at this site for this patient
; RETURN - array
; IBFAC - this site internal
; IBSITE - this site external
; IBICN - Patient being pulled
; IBOSITEEX - Requesting site
;
N IBIEN4,IBDFN,IBSCREEN,IBDATA,IBLOOP,IBADD,IBRESULTS
S IBIEN4=$$FIND1^DIC(4,,"X",IBOSITEEX,"D") ; get the internal site number (File 4 IEN) - should be the same across sites but then again shouldn't have to.
I 'IBIEN4 S @RETURN@(1)="-1^Site# "_IBOSITEEX_" not found in INSTITUTION (#4) file lookup at site# "_IBSITE Q
;
; make sure the patient is identifiable from this ICN
; if not, not much I can do
S IBDFN=+$$DFN^IBARXMU($G(IBICN))
I 'IBDFN S @RETURN@(1)="-1^Patient ICN: "_IBICN_" not found at site# "_IBSITE Q
;
; Get all/only the records for the patient which originated at this site.
;WCJ;IB696
;S IBSCREEN="I $P(^(0),U,2)=IBFAC"
S IBSCREEN="I $P(^(0),U,2)="_$$IEN^XUAF4(IBSITE)
;
;WCJ;IB696;add the date patient added to the patient file
;DBIA#10053-allows IB to read this field in patient File with FileMan
;D FIND^DIC(351.83,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I;.01:991.1;.08","QEP",IBDFN,"","B",IBSCREEN)
D FIND^DIC(351.83,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I;.01:991.1;.08;.01:.097","QEP",IBDFN,"","B",IBSCREEN)
;
I '+$G(^TMP("DILIST",$J,0)) D Q
. N IBLN,IBL4
. S IBLN=$P($$GET1^DIQ(2,IBDFN,.01),",",1) ; last name
. S IBL4=$$GET1^DIQ(2,IBDFN,.09),IBL4=$E(IBL4,$L(IBL4)-3,9999) ; last 4
. S @RETURN@(1)="0^No records to pull for patient "_IBLN_" ("_IBL4_") at site# "_IBSITE
;
; sent all the records for this patient created by this facility
M @RETURN=^TMP("DILIST",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBMHPMPY2 11073 printed Aug 26, 2025@22:40:26 Page 2
IBMHPMPY2 ;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
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;; DBIA#1621 %ZTER (ERROR RECORDING)
+4 ;; DBIA#10053 grab field .097 from file 2
+5 GOTO AWAY
+6 ;
AWAY ;thought I was being figurative??? Haha, Guess again!
QUIT
+1 ;
+2 ; RPC endpoint
+3 ; this is where the RPC is actually called at the remote facility.
RETURN(IBR,IBICN,IBOSITEEX,IBVISDT,IBSTAT,IBBILL,IBCOMM,IBUNIQ) ;
+1 ;
+2 ; INPUT:
+3 ; IBR - Results go here
+4 ; IBICN - Patients ICN so that we can find the patient across sites
+5 ; IBOSITEEX - external site number
+6 ; IBVISDT - Visit date
+7 ; IBSTAT - Status
+8 ; IBBILL - Bill number or possibly free text description such as 'ONHOLD'
+9 ; IBCOMM - Cancel reason
+10 ; IBUPDATE - 1 if this is the originating site and data should be pushed out to other treating facilities, otherwise 0
+11 ; IBUNIQ - Unique ID consiting of external site number underscor ien of file 351.83 on originating site ex. 442_1234567
+12 ; OUTPUT:
+13 ; results are returned in the results array as described in INPUT section
+14 ; "-1^Error message"
+15 ; "-2^Error message" if patent eligibility group mismatch IB*2.0*761
+16 ; "-3^Error message" if no remaining Free Days. IB*2.0*761
+17 ; "0^No action taken (nor needed) message"
+18 ; "1^Success message"
+19 ;
+20 ; ADDITIONAL OUTPUT on PULL - all records for a patient in file 351.83 that were created at this facility
+21 ;
+22 ; 1) check if the entry is already there based on the unique ID (external originating site and their IEN from file 351.83) passed in.
+23 ; 2) if it's already there, see if anything changed (might be an update).
+24 ; a) if already there and no changes, don't do anything with it but also don't return an error message. Any cheerful, uplifting response would do and then gracefully exit.
+25 ; b) if already there but allowable fields being updated, then do so, let them know, and quitely ride off into the sunset.
+26 ; 3) If you got this far, add it to the file.
+27 ; 4) return something to let them know how you did
+28 ;
+29 ;D APPERROR^%ZTER("Bill's Intentional Error #1 - AKA got here")
+30 ; didn't think I would need, but...
IF '$DATA(IBR)
SET IBR=$NAME(^TMP("IBMHPMPY1",$JOB))
+31 ;
+32 NEW IBDFN,IBSCREEN,IBIEN4,IBDATA,IBIEN351P82,IBADDED,IBUPDATED,IBRETURN,IBMISS,IBFAC,IBSITE
+33 ; returns IBSITE (external) and IBFAC (internal may not be VAMC)
DO SITE^IBAUTL
+34 ;
+35 ; see if it's a pull for specific patient. It will only have the patient's ICN and the site it's pulling to
+36 IF '$DATA(IBVISDT)
IF '$DATA(IBSTAT)
IF '$DATA(IBBILL)
IF '$DATA(IBCOMM)
IF '$DATA(IBUNIQ)
IF $GET(IBICN)
IF $GET(IBOSITEEX)
Begin DoDot:1
+37 DO PULL(.IBR,IBFAC,IBSITE,IBICN,IBOSITEEX)
+38 QUIT
End DoDot:1
QUIT
+39 ;
+40 ; Make sure everything needed is here. Better doublecheck on what is needed.
+41 SET IBMISS=$SELECT('$DATA(IBICN):1,'$DATA(IBOSITEEX):2,'$DATA(IBVISDT):3,'$DATA(IBSTAT):4,'$DATA(IBBILL):5,'$DATA(IBCOMM):6,'$DATA(IBUNIQ):7,1:0)
+42 IF IBMISS
SET @IBR@(1)="-1^Missing required input parameter: "_$PIECE("IBICN.IBOSITEEX.IBVISDT.IBSTAT.IBBILL.IBCOMM.IBUNIQ",".",IBMISS)
QUIT
+43 ;
+44 IF IBOSITEEX=IBSITE
SET @IBR@(1)="0^No action performed. Current site# "_IBSITE_" equals originating site# "_IBOSITEEX
QUIT
+45 ;
+46 ; get the internal site number (File 4 IEN) - should be the same across sites but then again shouldn't have to.
SET IBIEN4=$$FIND1^DIC(4,,"X",IBOSITEEX,"D")
+47 IF 'IBIEN4
SET @IBR@(1)="-1^Site# "_IBOSITEEX_" not found in INSTITUTION (#4) file lookup"
QUIT
+48 ;
+49 ; make sure the patient is identifiable from this ICN
+50 ; if not, not much I can do
+51 SET IBDFN=+$$DFN^IBARXMU($GET(IBICN))
+52 IF 'IBDFN
SET @IBR@(1)="-1^Patient ICN: "_IBICN_" not found at site# "_IBSITE
QUIT
+53 ;
+54 ;D FIND^DIC(file[,iens][,fields][,flags],[.]value[,number][,[.]indexes][,[.]screen][,identifier][,target_root][,msg_root]) ; this line is just for reference
+55 ;
+56 ; this sets the screen for the FIND call.
+57 ; FIND is by IBUNIQ (the unique ID consisting of the external site # and the the IEN to file 351.83 at that site.
+58 ; It if finds one, it's a potential edit and we will deal with that.
+59 ; If it finds more than one, not much I can do except throw my hands in the air. Since adding the unique ID, that really shouldn't happen.
+60 ;
+61 DO FIND^DIC(351.83,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I","QEPX",IBUNIQ,"","AUID")
+62 ;
+63 ; found one - see if anything changed and update if needed
+64 ; now what can really change - IBSTAT, IBBILL, IBCOMM are only fields allowed to change
+65 IF +$GET(^TMP("DILIST",$JOB,0))=1
Begin DoDot:1
+66 SET IBDATA=$GET(^TMP("DILIST",$JOB,1,0))
+67 SET IBIEN351P82=+IBDATA
+68 IF $PIECE(IBDATA,U,6)=IBSTAT
IF $PIECE(IBDATA,U,7)=IBBILL
IF $PIECE(IBDATA,U,8)=IBCOMM
SET @IBR@(1)="0^No changes requested"
QUIT
+69 SET IBUPDATED=$$UPDATE(IBIEN351P82,IBSTAT,IBBILL,IBCOMM,1,.IBRETURN)
+70 IF 'IBUPDATED
Begin DoDot:2
+71 SET @IBR@(1)="-1^Unable to UPDATE record at site# "_IBSITE_"."
+72 if IBRETURN["MAX free"
SET @IBR@(2)=-1_U_IBRETURN
End DoDot:2
QUIT
+73 SET @IBR@(1)="1^successfully updated"
QUIT
+74 QUIT
End DoDot:1
QUIT
+75 ;
+76 ; found "many" (could be two or a jillion). Should not happen now that we add a unique identifier (KEYWORDS: should + not + unique)
+77 IF +$GET(^TMP("DILIST",$JOB,0))>1
Begin DoDot:1
+78 SET @IBR@(1)="-1^Could not uniquely identify entry being updated - more than one match. Originating site# "_$PIECE(IBUNIQ,"_")_" and IEN:"_$PIECE(IBUNIQ,"_",2)
QUIT
End DoDot:1
QUIT
+79 ;
+80 ; no matches, feel free to add one
+81 IF '$GET(^TMP("DILIST",$JOB,0))
Begin DoDot:1
+82 SET IBADDED=$$ADD(IBDFN,IBOSITEEX,IBVISDT,IBSTAT,IBBILL,IBCOMM,0,IBUNIQ,.IBRETURN)
+83 IF 'IBADDED
Begin DoDot:2
+84 ;IB*2.0*761 updated return code for no free visits left
+85 SET @IBR@(1)="-1^Unable to ADD record at site# "_IBSITE_"."
+86 ;IB*2.0*761
if IBRETURN["MAX free"
SET @IBR@(2)=-3_U_IBRETURN
End DoDot:2
QUIT
+87 SET @IBR@(1)="1^successfully added"
QUIT
+88 QUIT
End DoDot:1
QUIT
+89 QUIT
+90 ;
ADD(IBDFN,IBSITE,IBVISDT,IBSTAT,IBBILL,IBCOMM,IBUPDATE,IBUNIQ,RETURN) ; Add an entry to the file
+1 ; INPUT:
+2 ; IBDFN - Pointer to the patient number
+3 ; IBSITE - external site number
+4 ; IBVISDT - Visit date
+5 ; IBSTAT - Status
+6 ; IBBILL - Bill number or possibly free text description such as 'ONHOLD'
+7 ; IBCOMM - Cancel reason
+8 ; IBUPDATE - 1 if this is the originating site and data should be pushed out to other treating facilities, otherwise 0
+9 ; IBUNIQ - Unique ID consiting of external site number underscor ien of file 351.83 on originating site ex. 442_1234567
+10 ; OUTPUT:
+11 ; RETURN - This is any information returned by FileMan if update was unsuccessful
+12 ;
+13 ; Function call returns 0 or 1 if successful.
+14 ; data must be all internal or all external - no mashup of the two allowed
+15 ; I vote internal and since I am coding...
+16 ; the incoming parameters were all internal except site #.
+17 ; NOTE to self: internal data is filed without validation so be sure it's cool
+18 ;
+19 NEW IBCTS
+20 SET IBCTS=$$NUMVSTCK^IBECEAMH(IBDFN,IBVISDT)
+21 IF $GET(IBSTAT)=1
IF 'IBCTS
Begin DoDot:1
+22 NEW Y
+23 SET Y=IBVISDT
XECUTE ^DD("DD")
+24 SET RETURN="Exceeds MAX free visits in a calendar year. Can't add "_Y_"."
End DoDot:1
QUIT 0
+25 ;
+26 NEW FDA,IENS
+27 SET IENS="+1,"
+28 SET FDA(351.83,IENS,.01)=IBDFN
+29 ; turn external site # into internal one
SET FDA(351.83,IENS,.02)=$$FIND1^DIC(4,,"X",IBSITE,"D")
+30 SET FDA(351.83,IENS,.03)=IBVISDT
+31 SET FDA(351.83,IENS,.04)=$GET(IBSTAT)
+32 SET FDA(351.83,IENS,.05)=$GET(IBBILL)
+33 SET FDA(351.83,IENS,.06)=$GET(IBCOMM)
+34 SET FDA(351.83,IENS,.07)=$GET(IBUNIQ)
+35 ; While technically being added, this is not the originating site so don't mark as such. The flag is used to determine which entries to push.
SET FDA(351.83,IENS,1.01)=$GET(IBUPDATE)
+36 ;
+37 ; first parameter is currently "" so internal it is for now
+38 DO UPDATE^DIE("","FDA","","RETURN")
+39 ;
+40 ; if RETURN is defined then BAD else GOOD
+41 QUIT $SELECT($DATA(RETURN):0,1:1)
+42 ;
UPDATE(IBIEN,IBSTAT,IBBILL,IBCOMM,IBUPDATE,RETURN) ; update an entry to the file
+1 ; INPUT:
+2 ; IBIEN - internal entry number into 351.83 that is being edited
+3 ; IBSTAT - Status
+4 ; IBBILL - Bill number or possibly free text description such as 'ONHOLD'
+5 ; IBCOMM - Cancel reason
+6 ; IBUPDATE - 1 if this is the originating site and data should be pushed out to other treating facilities, otherwise 0
+7 ; OUTPUT:
+8 ; RETURN - This is any information returned by FileMan if update was unsuccessful
+9 ;
+10 ; Function call returns 0 or 1 if successful.
+11 ;
+12 ; limiting edits to a few fields
+13 ; data must be all internal or all external - no mashup of the two allowed
+14 ; I still vote internal and since I am still coding...
+15 ; the incoming parameters were all internal
+16 ; NOTE to self: internal data is filed without validation so be sure it's cool
+17 ;
+18 ; returns 1 if added sucessfully
+19 ; returns 0 otherwise
+20 ;
+21 NEW IBCTS,IBDFN,IBVISDT
+22 SET IBDFN=$$GET1^DIQ(351.83,IBIEN,.01,"I")
+23 SET IBVISDT=$$GET1^DIQ(351.83,IBIEN,.03,"I")
+24 SET IBCTS=$$NUMVSTCK^IBECEAMH(IBDFN,IBVISDT)
+25 IF $GET(IBSTAT)=1
IF 'IBCTS
Begin DoDot:1
+26 NEW Y
+27 SET Y=IBVISDT
XECUTE ^DD("DD")
+28 SET RETURN="Exceeds MAX free visits in a calendar year. Can't update "_Y_"."
End DoDot:1
QUIT 0
+29 ;
+30 NEW FDA,IENS
+31 SET IENS=IBIEN_","
+32 SET FDA(351.83,IENS,.04)=$GET(IBSTAT)
+33 SET FDA(351.83,IENS,.05)=$GET(IBBILL)
+34 SET FDA(351.83,IENS,.06)=$GET(IBCOMM)
+35 SET FDA(351.83,IENS,1.01)=$GET(IBUPDATE,0)
+36 ;
+37 ; first parameter is currently "" so internal it is for now
+38 DO FILE^DIE("","FDA","RETURN")
+39 ;
+40 ; if RETURN is defined then BAD else GOOD
+41 QUIT $SELECT($DATA(RETURN):0,1:1)
+42 ;
PULL(RETURN,IBFAC,IBSITE,IBICN,IBOSITEEX) ; Pull all records that originated at this site for this patient
+1 ; RETURN - array
+2 ; IBFAC - this site internal
+3 ; IBSITE - this site external
+4 ; IBICN - Patient being pulled
+5 ; IBOSITEEX - Requesting site
+6 ;
+7 NEW IBIEN4,IBDFN,IBSCREEN,IBDATA,IBLOOP,IBADD,IBRESULTS
+8 ; get the internal site number (File 4 IEN) - should be the same across sites but then again shouldn't have to.
SET IBIEN4=$$FIND1^DIC(4,,"X",IBOSITEEX,"D")
+9 IF 'IBIEN4
SET @RETURN@(1)="-1^Site# "_IBOSITEEX_" not found in INSTITUTION (#4) file lookup at site# "_IBSITE
QUIT
+10 ;
+11 ; make sure the patient is identifiable from this ICN
+12 ; if not, not much I can do
+13 SET IBDFN=+$$DFN^IBARXMU($GET(IBICN))
+14 IF 'IBDFN
SET @RETURN@(1)="-1^Patient ICN: "_IBICN_" not found at site# "_IBSITE
QUIT
+15 ;
+16 ; Get all/only the records for the patient which originated at this site.
+17 ;WCJ;IB696
+18 ;S IBSCREEN="I $P(^(0),U,2)=IBFAC"
+19 SET IBSCREEN="I $P(^(0),U,2)="_$$IEN^XUAF4(IBSITE)
+20 ;
+21 ;WCJ;IB696;add the date patient added to the patient file
+22 ;DBIA#10053-allows IB to read this field in patient File with FileMan
+23 ;D FIND^DIC(351.83,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I;.01:991.1;.08","QEP",IBDFN,"","B",IBSCREEN)
+24 DO FIND^DIC(351.83,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I;.01:991.1;.08;.01:.097","QEP",IBDFN,"","B",IBSCREEN)
+25 ;
+26 IF '+$GET(^TMP("DILIST",$JOB,0))
Begin DoDot:1
+27 NEW IBLN,IBL4
+28 ; last name
SET IBLN=$PIECE($$GET1^DIQ(2,IBDFN,.01),",",1)
+29 ; last 4
SET IBL4=$$GET1^DIQ(2,IBDFN,.09)
SET IBL4=$EXTRACT(IBL4,$LENGTH(IBL4)-3,9999)
+30 SET @RETURN@(1)="0^No records to pull for patient "_IBLN_" ("_IBL4_") at site# "_IBSITE
End DoDot:1
QUIT
+31 ;
+32 ; sent all the records for this patient created by this facility
+33 MERGE @RETURN=^TMP("DILIST",$JOB)
+34 QUIT
