- DGFSMOUT ;SLC/RM - FORMER OTH PP PATIENT UTILITY ; November 9, 2020@3:51 pm
- ;;5.3;Registration;**1034,1035**;Aug 13, 1993;Build 14
- ;
- ;Global References Supported by ICR# Type
- ;----------------- ----------------- ---------
- ; ^DGPT("AAD" 418 (DG is the Custodial Package) Cont. Sub
- ; ^SCE( 402 Cont. Sub
- ; ^SCE("ADFN" 402 Cont. Sub.
- ; ^TMP($J SACC 2.3.2.5.1
- ; ^TMP("PXKENC" SACC 2.3.2.5.1
- ;
- ;External References
- ;-------------------
- ; $$GET1^DIQ 2056 Supported
- ; $$GET1^DIQ(40.8 417 (DG is the Custodial Package) Cont. Sub.
- ; $$GET1^DIQ(45 418 (DG is the Custodial Package) Cont. Sub.
- ; $$GET1^DIQ(44 10040 Supported
- ; GETS^DIQ 2056 Supported
- ; GETS^DIQ(409.68 402 Cont. Sub
- ; GETS^DIQ(405 419 (DG is the Custodial Package) Cont. Sub.
- ; GETS^DIQ(42 10039 (DG is the Custodial Package) Supported
- ; EN^IBEFSMUT 7202 (DG has permission to access) Private
- ; RX^PSO52API 4820 Supported
- ; PSS^PSO59 4827 Supported
- ; GETENC^PXAPI 1894 Supported
- ; GETGEN^SDOE 2546 Supported
- ; $$STA^XUAF4 2171 Supported
- ;No direct call
- Q
- ;Check if patient should be included in report, using OUTPATIENT ENCOUNTER file #409.68
- CHKTREAT(DFN,DGDTF,DGDTT,ARRDIV,FLAG) ;
- ;Input:
- ; DFN=IEN in file #2
- ; DGDTF='From' date entered by user
- ; DGDTT='To' date entered by user
- ; ARRDIV is in the format output by utility VAUTOMA
- ; FLAG 0 Outpatient, 1 Inpatient
- ;Output:
- ; RET(DIVISION#,DATE OF ENCOUNTER)=Name of division^Station #^Clinic Name^Clinic Stop Code^Edited Last By^DivisionIEN^OEIEN^PrimaryDx^OriginatingProcess
- N DGCO,DGDIV,DGDT,DGIEN,DGOUT,DGSTPCODE,DGCLNCNME,DGSTA,DGLSTEDTBY,TRUE
- N PRIMDX,DXNAME,SCCNT,SDOEDATA,DGAPPTDT,DGAPTERR,DGVSTIEN,DGOLDIEN
- S (SCCNT,DGOLDIEN)=0
- S DGDT="" F S DGDT=$O(^SCE("ADFN",DFN,DGDT),-1) Q:'DGDT!(DGDT<DGDTF) D:(DGDT\1'<DGDTF)&((DGDT\1)'>DGDTT)
- . S DGIEN=0 F S DGIEN=$O(^SCE("ADFN",DFN,DGDT,DGIEN)) Q:'DGIEN D
- . . K DGOUT D GETS^DIQ(409.68,DGIEN_",",".03;.08;.11;.12","IE","DGOUT")
- . . I 'FLAG,$G(DGOUT(409.68,DGIEN_",",.12,"E"))'="CHECKED OUT" Q ;outpatient check
- . . I FLAG S TRUE=0 D Q:TRUE ;inpatient check
- . . . I $G(DGOUT(409.68,DGIEN_",",.12,"E"))'="INPATIENT APPOINTMENT" S TRUE=1 Q
- . . . I +$P($G(^SCE(DGIEN,0)),U,7)<1 S TRUE=1 Q ;inpatient outpatient appointment not checked out
- . . S DGDIV=$G(DGOUT(409.68,DGIEN_",",.11,"I")) Q:DGDIV=""
- . . S DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIV_",",.07,"I")) ;($$GET1^DIQ(40.8 - ICR#417)
- . . I DGSTA="" S DGSTA="N/A"
- . . S DGSTPCODE=$G(DGOUT(409.68,DGIEN_",",.03,"E"))
- . . K SDOEDATA D GETGEN^SDOE(DGIEN,"SDOEDATA") ;this is to extract the location of the encounter
- . . S DGCLNCNME=$$GET1^DIQ(44,$P(SDOEDATA(0),U,4)_",",.01,"E") ;clinic name
- . . K DGAPPTDT,DGAPTERR D GETS^DIQ(2,DFN_",","1900*","IE","DGAPPTDT","DGAPTERR") ;this is to extract the clinic name or location
- . . Q:$D(DGAPTERR)
- . . S DGLSTEDTBY=$G(DGAPPTDT(2.98,DGDT_","_DFN_",",19,"E")) ;last user entered by
- . . I $G(DGLSTEDTBY)="" D
- . . . K ^TMP("PXKENC",$J) D GETENC^PXAPI(DFN,DGDT,$P(SDOEDATA(0),U,4)) ;this is to extract last user edited by if not found in the patient file
- . . . S DGVSTIEN=$O(^TMP("PXKENC",$J,""))
- . . . S DGLSTEDTBY=$$GET1^DIQ(200,$P(^TMP("PXKENC",$J,DGVSTIEN,"VST",DGVSTIEN,0),U,23)_",",.01)
- . . . K ^TMP("PXKENC",$J)
- . . D GETPDX^DGOTHFS4(DGIEN) ;extract the primary diagnosis for this outpatient encounter
- . . I $G(ARRDIV)=1 D CHKTRSET Q
- . . D:$D(ARRDIV(DGDIV)) CHKTRSET
- I SCCNT>0 S DGENCNT=DGENCNT-SCCNT
- K DGAPPTDT,DGAPTERR
- Q
- ;
- CHKTRSET ;
- N TMPDATA,ORGPRCTYP
- S ORGPRCTYP=$G(DGOUT(409.68,DGIEN_",",.08,"I")) ;if originating process type is not equal to 1, it means that it is not a real appointment
- I ORGPRCTYP'=1 D
- . I $G(DGAPPTDT(2.98,DGDT_","_DFN_",",.001,"I")) S SCCNT=SCCNT+1 ;regardless if the clinic contains primary or secondary, always count is as 1 DOS
- . E D
- . . I DGOLDIEN=$P(SDOEDATA(0),U,6) Q ;this is to force to display STANDALONE encounters not related to an appointment. Example: Originating Process Type= STOP CODE ADDITION, CREDIT STOP CODE, etc.
- . . S ORGPRCTYP=1
- S TMPDATA=DGOUT(409.68,DGIEN_",",.11,"E")_U_DGSTA_U_DGCLNCNME_U_DGSTPCODE_U_DGLSTEDTBY_U_DGDIV_U_DGIEN_U_""_U_PRIMDX_U_+ORGPRCTYP
- S DGENCNT=DGENCNT+1
- I 'FLAG D
- . S @RECORD@(DGDT,DGSTA,409.68,DGENCNT)=TMPDATA ;sort by date of service
- . I SORTENCBY=2 S @RECORD1@(DGSTA,DGDT,409.68,DGENCNT)=TMPDATA ;sort by division
- E D
- . S @RECORD@(DGDT,DGSTA,405,DGENCNT)=TMPDATA
- . I SORTENCBY=2 S @RECORD1@(DGSTA,DGDT,405,DGENCNT)=TMPDATA
- S DGOLDIEN=DGIEN ;contains the OE IEN primary - this is to determine between the primary and secondary stop code
- Q
- ;
- CHECKPTF(DGDFN,DGOTHREGDT,DGELGDTV,LIST) ;check and extract inpatient stay for a patient in File #45
- ;Input:
- ; DGDFN=IEN in file #2
- ; DGOTHREGDT='From' date
- ; DGELGDTV='To' date
- ;Output:
- ; ^TMP($J,LIST,DOS,STATION#,FILENO,RECNT)=Name of division^Station #^Ward Location^Treating Facility^Edited Last By^Division^IEN
- N ADMDT,DGOUT,DGOUTERR,DIVINPT,PTFIEN,WRDLOC,WRDIEN,LSTUSR,TRTFCLTY,DGDIV,DGDIVNME,DGSTA,TMPDATA,DSCHRGDT
- ;find all admissions for a patient.
- I $D(^DGPT("AAD",DGDFN)) D
- . S ADMDT="" F S ADMDT=$O(^DGPT("AAD",DGDFN,ADMDT)) Q:'+ADMDT D
- . . S PTFIEN=0 F S PTFIEN=$O(^DGPT("AAD",DGDFN,ADMDT,PTFIEN)) Q:'PTFIEN D
- . . . K TMPDATA
- . . . S DSCHRGDT=0
- . . . ;check if the admission date is before the patient become OTH. If true, check if the patient has been discharged. If patient still not discharged when they become
- . . . ;OTH and then VERIFIED, include that patient. If patient is discharged after receiving VBA adjudication but the admission date is before they become OTH, then include that patient
- . . . ;otherwise, the record will be skipped.
- . . . S DSCHRGDT=$$GET1^DIQ(45,PTFIEN_",",70,"I") ;discharge date
- . . . I (ADMDT\1)<DGOTHREGDT D Q ;the admission date is before the patient become OTH
- . . . . I +DSCHRGDT<1 D PTFDATA^DGOTHFSM Q ;no discharge date, patient is still inpatient/admitted in the hospital
- . . . . I ADMDT\1<=DGELGDTV,$$CHKDATE^DGOTHFSM(+DSCHRGDT\1,DGOTHREGDT,DGELGDTV) D Q ;patient is discharged on or after adjudication but the admission date is before they become OTH, then include that patient
- . . . . . I +$G(DGPPFLGRPT)>0,'$$CHKDATE^DGOTHFSM(+DSCHRGDT\1,DGOTHREGDT,DGELGDTV) Q ;check if the PP inpatient discharged date is within the date range.
- . . . . . D PTFDATA^DGOTHFSM
- . . . . . D EN^IBEFSMUT(DGDFN,(ADMDT\1),(ADMDT\1),LIST)
- . . . . . K @IBOTHSTAT@(350)
- . . . . . I $D(@IBOTHSTAT@(399,DGDFN)) D DOS399^DGOTHFS4(399)
- . . . . Q:'$$CHKDATE^DGOTHFSM(+DSCHRGDT\1,DGOTHREGDT,DGELGDTV)
- . . . . D PTFDATA^DGOTHFSM
- . . . I ((ADMDT\1)'<DGOTHREGDT)&((ADMDT\1)'>DGELGDTV) D ;admission date and discharge date is within the date range
- . . . . I +DSCHRGDT<1 D PTFDATA^DGOTHFSM Q ;patient is still inpatient not discharge
- . . . . D PTFDATA^DGOTHFSM
- ;after checking if there are any inpatient stay for this patient, check if this patient had any inpatient outpatient encounter. if there is and date is within the date range include the data in the report
- D CHKTREAT(DGDFN,DGOTHREGDT,DGELGDTV,.VAUTD,1) ;1 is a flag to determine to process inpatient
- Q
- ;
- CHECKIB(LIST,DGOTHREGDT,DGELGDTV) ;check if patient had charges stored in file #350 and #399
- N OTHIBDT,OTHIBREC,FILENO,DGDIVIEN,DGDT,DGSTA,DGSTANAME,DGLSTUSR,DGIBSTPCODE,IBOTHSTAT,ACCTYP,TMPDATA,TMPDATA1
- D EN^IBEFSMUT(DGDFN,DGOTHREGDT,DGELGDTV,LIST) ;extract the IB STATUS in both file #350 and file #399
- I '$G(IBOTHSTAT) S IBOTHSTAT=$NA(^TMP($J,LIST))
- F FILENO=350,399 D ;check if patient has entry in file #350 and file #399
- . I +$G(@IBOTHSTAT@(FILENO,DGDFN,0))>0 D
- . . S OTHIBDT="" F S OTHIBDT=$O(@IBOTHSTAT@(FILENO,OTHIBDT)) Q:OTHIBDT="" D
- . . . S OTHIBREC="" F S OTHIBREC=$O(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC)) Q:OTHIBREC="" D
- . . . . Q:'$$CHKDATE^DGOTHFSM(OTHIBDT,DGOTHREGDT,DGELGDTV) ;check if the date bill from is within the date range patient became OTH and when PE is verified
- . . . . ;otherwise, capture the record for this patient
- . . . . S DGDT=OTHIBDT
- . . . . K TMPDATA,TMPDATA1
- . . . . S TMPDATA1=$G(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC))
- . . . . I FILENO=350 D
- . . . . . S ACCTYP=$P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U)
- . . . . . S DGSTA=$P($P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,8),"-") ;station number (eg. 442)
- . . . . . S DGSTANAME=$P($P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,8),"-",2) ;station name (eg. CHEYENNE VA MEDICAL)
- . . . . . S DGIBSTPCODE=$P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,9) ;stop code
- . . . . . S DGLSTUSR=$P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,10) ;user entered/edit the record
- . . . . . S TMPDATA=DGSTANAME_U_DGSTA_U_"NON-VA"_U_$S(DGIBSTPCODE'="":DGIBSTPCODE,1:"N/A")_U_DGLSTUSR_U_DGSTA_U_TMPDATA1
- . . . . . S DGENCNT=DGENCNT+1
- . . . . . S @RECORD@(DGDT,DGSTA,350,DGENCNT)=TMPDATA ;sort by date of service
- . . . . . I SORTENCBY=2 S @RECORD1@(DGSTA,DGDT,350,DGENCNT)=TMPDATA ;sort by division
- . . . . I FILENO=399 D
- . . . . . S ACCTYP=$P($P($P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,5),";"),":",2)
- . . . . . S DGDIVIEN=$P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,8),DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIVIEN_",",.07,"I")) ;station number (eg. 442)
- . . . . . S DGSTANAME=$$GET1^DIQ(40.8,DGDIVIEN_",",.01,"E") ;station name (eg. CHEYENNE VA MEDICAL)
- . . . . . S DGLSTUSR=$P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,9) ;user entered/edit the record
- . . . . . S TMPDATA=DGSTANAME_U_DGSTA_U_"NON-VA"_U_"N/A"_U_DGLSTUSR_U_DGDIVIEN_U_ACCTYP_U_TMPDATA1
- . . . . . S DGENCNT=DGENCNT+1
- . . . . . S @RECORD@(DGDT,DGSTA,399,DGENCNT)=TMPDATA ;sort by date of service
- . . . . . I SORTENCBY=2 S @RECORD1@(DGSTA,DGDT,399,DGENCNT)=TMPDATA ;sort by division
- Q
- ;
- CHECKRX(LIST) ;check and extract rx data for this patient
- N DGRXNUM,DGRXIEN,DGRELDT,DGDIV,DGSTA,DGSTANAME,DGCLNC,DGLSTUSR
- K ^TMP($J,LIST) D RX^PSO52API(DGDFN,LIST,,,"2,R,I,P",DGSORT("DGBEG"),$$FMADD^XLFDT(DGSORT("DGEND"),366)) ;get the medication profile of a patient from PRESCRIPTION file (#52)
- I +^TMP($J,LIST,DGDFN,0)<1 K ^TMP($J,LIST) Q
- S DGRXNUM="" F S DGRXNUM=$O(^TMP($J,LIST,"B",DGRXNUM)) Q:DGRXNUM="" D
- . S DGRXIEN="" F S DGRXIEN=$O(^TMP($J,LIST,"B",DGRXNUM,DGRXIEN)) Q:DGRXIEN="" D
- . . ;check if the release date is within the date range
- . . S DGRELDT=$P(^TMP($J,LIST,DGDFN,DGRXIEN,31),U) ;original fill released date
- . . I +DGRELDT<1,+$P(^TMP($J,LIST,DGDFN,DGRXIEN,32.1),U)>1 S DGRELDT=$P(^TMP($J,LIST,DGDFN,DGRXIEN,32.1),U) ;extract the RETURN TO STOCK date release date/time if the original fill date is missing
- . . I $G(DGPPFLGRPT)=1 S DGOTHREGDT=DGSORT("DGBEG"),DGELGDTV=DGSORT("DGEND") ;this for PP multiple report processing
- . . S DGCLNC=$P(^TMP($J,LIST,DGDFN,DGRXIEN,5),U,2) ;clinic
- . . ;check if the release date is within the date range patient became OTH and when PE is verified
- . . I '$$CHKDATE^DGOTHFSM(+DGRELDT\1,DGOTHREGDT,DGELGDTV) D REFILL^DGPPOHUT(LIST),PARTIAL^DGPPDRP1(LIST) Q
- . . ;check if the original fill released date is before the patient become OTH, if true, check if the refill is within the date range
- . . I +DGRELDT\1<DGOTHREGDT D REFILL^DGPPOHUT(LIST),PARTIAL^DGPPDRP1(LIST) Q
- . . I $G(^TMP($J,LIST,DGDFN,DGRXIEN,106))'="" Q ;;this is already handled by IBEFMSUT routine. No need to include this record here and to avoid duplicate record.
- . . S DGDIV=$P(^TMP($J,LIST,DGDFN,DGRXIEN,20),U) ;division ien
- . . K ^TMP($J,"PSOSITE") D PSS^PSO59(DGDIV,,"PSOSITE") S DGSTA=$G(^TMP($J,"PSOSITE",DGDIV,.06)) ;station/site number
- . . S DGSTANAME=$P(^TMP($J,LIST,DGDFN,DGRXIEN,20),U,2) ;division name
- . . S DGLSTUSR=$P(^TMP($J,LIST,DGDFN,DGRXIEN,23),U,2) ;pharmacist entered this rx
- . . S DGENCNT=DGENCNT+1
- . . S @RECORD@(+DGRELDT\1,DGSTA,52,DGENCNT)=DGSTANAME_U_DGSTA_U_$S(DGCLNC'="":DGCLNC,1:"NON-VA")_U_"N/A"_U_DGLSTUSR_U_DGDIV_U_"RX - "_DGRXNUM_":"_DGRXIEN
- . . D REFILL^DGPPOHUT(LIST),PARTIAL^DGPPDRP1(LIST)
- K ^TMP($J,LIST),^TMP($J,"PSOSITE")
- Q
- ;
- IBSTATUS(IBFILENO,DATE) ;extract records from file #350 or file #399
- N DGRXDATE,IBCNT,BILLGRP,RSLTFRM,BILCLS,IBRFNUM,IBDIV,ACTYP
- N BILCLS,IBRFNUM,IBDIV,RECNUM,DFN399,IBIEN399,TMPDATA,IBIEN409,DGIEN399,DGIEN409
- S RECNUM=0
- S IBCNT="" F S IBCNT=$O(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT)) Q:IBCNT="" D
- . I IBFILENO=350 D Q
- . . ;Outpatient and inpatient events
- . . S (BILLGRP,ACTYP,RSLTFRM,IBDIV,TMPDATA)=""
- . . S ACTYP=$P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U) ;action type
- . . I ACTYP["RX" S ACTYP="" Q ;quit if rx
- . . S BILLGRP=$P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,2) ;billing group
- . . S RSLTFRM=$P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,5) ;result from
- . . I $P(RSLTFRM,":",1)=44 K @RECORD@(SUB1,SUB2,FILENO,RECNT) Q ;we are not including any file #44 records as of the moment
- . . S IBDIV=$P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,8) ;division
- . . I $P(DGSORT("SORTENCBY"),U)=1 S RECNUM=+$O(@RECORD@(ENCDT\1,+STATNUM,IBFILENO,RECNUM)) ;sort by date of service
- . . I $P(DGSORT("SORTENCBY"),U)=2 S RECNUM=+$O(@RECORD@(+STATNUM,ENCDT\1,IBFILENO,RECNUM)) ;sort by division
- . . I ($P(RSLTFRM,":",1)=405)!($P(RSLTFRM,":",1)=409.68)!($P(RSLTFRM,":",1)=45) D
- . . . I $P(RSLTFRM,":",1)=45 S DFN405=$P($P(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,8),";",2) ;reset DFN405 to extract the IEN for file #45
- . . . I DFN405=$P(RSLTFRM,":",2)!(DFN409=$P(RSLTFRM,":",2)) D ;DFN405 and DFN409 is set in ENCTRIB^DGOTHFS3
- . . . . S CHRGCNT=CHRGCNT+1
- . . . . S TMPDATA=@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT)
- . . . . I $P(DGSORT("SORTENCBY"),U)=1 D ;sort by date of service
- . . . . . S @RECORD@(ENCDT,STATNUM,FILENO,RECNT,CHRGCNT)=TMPDATA
- . . . . . S TMPDATA=$P($P(@RECORD@(ENCDT,STATNUM,FILENO,RECNT,CHRGCNT),U,4),"-",2)
- . . . . . S $P(@RECORD@(ENCDT,STATNUM,FILENO,RECNT,CHRGCNT),U,4)=TMPDATA
- . . . . . K @RECORD@(ENCDT\1,+STATNUM,IBFILENO,RECNUM) ;remove the record from ^TMP if it already exist in either file 405 or 409.68
- . . . . I $P(DGSORT("SORTENCBY"),U)=2 D ;sort by division
- . . . . . S @RECORD@(STATNUM,ENCDT,FILENO,RECNT,CHRGCNT)=TMPDATA
- . . . . . S TMPDATA=$P($P(@RECORD@(STATNUM,ENCDT,FILENO,RECNT,CHRGCNT),U,4),"-",2)
- . . . . . S $P(@RECORD@(STATNUM,ENCDT,FILENO,RECNT,CHRGCNT),U,4)=TMPDATA
- . . . . . K @RECORD@(+STATNUM,ENCDT\1,IBFILENO,RECNUM) ;remove the record from ^TMP if it already exist in either file 405 or 409.68
- . I IBFILENO=399 D
- . . ;Outpatient and inpatient events
- . . S (BILLGRP,RSLTFRM,BILCLS,IBDIV,TMPDATA,IBIEN399,IBIEN409,DGIEN399,DGIEN409)=""
- . . Q:$P($P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,5),":")=3 ;quit if rx
- . . I +DFN405>0,$P($P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,5),":")'=1 Q ;quit if we are no longer dealing with the inpatient record currently
- . . S BILCLS=$P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U) ;bill classification
- . . S BILLGRP=$P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,2) ;rate type
- . . S IBIEN399=$P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,3) ;file #399 ien
- . . S IBIEN409=$P(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,10) ;this can contain either ien from file #409.68 or file #45
- . . I $P(DGSORT("SORTENCBY"),U)=1 D ;sort by date of service
- . . . I $D(@RECORD@(DATE\1,STATNUM,IBFILENO)) D
- . . . . I DFN405=IBIEN409!(DFN409=IBIEN409) D
- . . . . . S RECNUM=$O(@RECORD@(DATE\1,STATNUM,IBFILENO,""))
- . . . . . S DGIEN399=$P(@RECORD@(DATE\1,STATNUM,IBFILENO,RECNUM),U,10) ;file #399 ien
- . . . . . S DGIEN409=$P(@RECORD@(DATE\1,STATNUM,IBFILENO,RECNUM),U,17) ;this can contain either ien from file #409.68 or file #45
- . . . . . I DGIEN409=IBIEN409!(DGIEN399=IBIEN399) D
- . . . . . . I $D(@RECORD@(DATE\1,STATNUM,IBFILENO,RECNUM)) K @RECORD@(DATE\1,STATNUM,IBFILENO,RECNUM) ;remove the record from ^TMP if it already exist in either file 405 or 409.68
- . . . . . . S CHRGCNT=CHRGCNT+1
- . . . . . . S TMPDATA=@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT)
- . . . . . . S @RECORD@(ENCDT,STATNUM,FILENO,RECNT,CHRGCNT)=TMPDATA
- . . I $P(DGSORT("SORTENCBY"),U)=2 D ;sort by division
- . . . I $D(@RECORD@(STATNUM,DATE\1,IBFILENO)) D
- . . . . I DFN405=IBIEN409!(DFN409=IBIEN409) D
- . . . . . S RECNUM=$O(@RECORD@(STATNUM,DATE\1,IBFILENO,""))
- . . . . . S DGIEN399=$P(@RECORD@(STATNUM,DATE\1,IBFILENO,RECNUM),U,10) ;file #399 ien
- . . . . . S DGIEN409=$P(@RECORD@(STATNUM,DATE\1,IBFILENO,RECNUM),U,17) ;file #409 ien
- . . . . . I DGIEN409=IBIEN409!(DGIEN399=IBIEN399) D
- . . . . . . I $D(@RECORD@(STATNUM,DATE\1,IBFILENO,RECNUM)) K @RECORD@(STATNUM,DATE\1,IBFILENO,RECNUM) ;remove the record from ^TMP if it already exist in either file 405 or 409.68
- . . . . . . S CHRGCNT=CHRGCNT+1
- . . . . . . S TMPDATA=@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT)
- . . . . . . S @RECORD@(STATNUM,ENCDT,FILENO,RECNT,CHRGCNT)=TMPDATA
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGFSMOUT 17436 printed Jan 18, 2025@03:44:17 Page 2
- DGFSMOUT ;SLC/RM - FORMER OTH PP PATIENT UTILITY ; November 9, 2020@3:51 pm
- +1 ;;5.3;Registration;**1034,1035**;Aug 13, 1993;Build 14
- +2 ;
- +3 ;Global References Supported by ICR# Type
- +4 ;----------------- ----------------- ---------
- +5 ; ^DGPT("AAD" 418 (DG is the Custodial Package) Cont. Sub
- +6 ; ^SCE( 402 Cont. Sub
- +7 ; ^SCE("ADFN" 402 Cont. Sub.
- +8 ; ^TMP($J SACC 2.3.2.5.1
- +9 ; ^TMP("PXKENC" SACC 2.3.2.5.1
- +10 ;
- +11 ;External References
- +12 ;-------------------
- +13 ; $$GET1^DIQ 2056 Supported
- +14 ; $$GET1^DIQ(40.8 417 (DG is the Custodial Package) Cont. Sub.
- +15 ; $$GET1^DIQ(45 418 (DG is the Custodial Package) Cont. Sub.
- +16 ; $$GET1^DIQ(44 10040 Supported
- +17 ; GETS^DIQ 2056 Supported
- +18 ; GETS^DIQ(409.68 402 Cont. Sub
- +19 ; GETS^DIQ(405 419 (DG is the Custodial Package) Cont. Sub.
- +20 ; GETS^DIQ(42 10039 (DG is the Custodial Package) Supported
- +21 ; EN^IBEFSMUT 7202 (DG has permission to access) Private
- +22 ; RX^PSO52API 4820 Supported
- +23 ; PSS^PSO59 4827 Supported
- +24 ; GETENC^PXAPI 1894 Supported
- +25 ; GETGEN^SDOE 2546 Supported
- +26 ; $$STA^XUAF4 2171 Supported
- +27 ;No direct call
- +28 QUIT
- +29 ;Check if patient should be included in report, using OUTPATIENT ENCOUNTER file #409.68
- CHKTREAT(DFN,DGDTF,DGDTT,ARRDIV,FLAG) ;
- +1 ;Input:
- +2 ; DFN=IEN in file #2
- +3 ; DGDTF='From' date entered by user
- +4 ; DGDTT='To' date entered by user
- +5 ; ARRDIV is in the format output by utility VAUTOMA
- +6 ; FLAG 0 Outpatient, 1 Inpatient
- +7 ;Output:
- +8 ; RET(DIVISION#,DATE OF ENCOUNTER)=Name of division^Station #^Clinic Name^Clinic Stop Code^Edited Last By^DivisionIEN^OEIEN^PrimaryDx^OriginatingProcess
- +9 NEW DGCO,DGDIV,DGDT,DGIEN,DGOUT,DGSTPCODE,DGCLNCNME,DGSTA,DGLSTEDTBY,TRUE
- +10 NEW PRIMDX,DXNAME,SCCNT,SDOEDATA,DGAPPTDT,DGAPTERR,DGVSTIEN,DGOLDIEN
- +11 SET (SCCNT,DGOLDIEN)=0
- +12 SET DGDT=""
- FOR
- SET DGDT=$ORDER(^SCE("ADFN",DFN,DGDT),-1)
- if 'DGDT!(DGDT<DGDTF)
- QUIT
- if (DGDT\1'<DGDTF)&((DGDT\1)'>DGDTT)
- Begin DoDot:1
- +13 SET DGIEN=0
- FOR
- SET DGIEN=$ORDER(^SCE("ADFN",DFN,DGDT,DGIEN))
- if 'DGIEN
- QUIT
- Begin DoDot:2
- +14 KILL DGOUT
- DO GETS^DIQ(409.68,DGIEN_",",".03;.08;.11;.12","IE","DGOUT")
- +15 ;outpatient check
- IF 'FLAG
- IF $GET(DGOUT(409.68,DGIEN_",",.12,"E"))'="CHECKED OUT"
- QUIT
- +16 ;inpatient check
- IF FLAG
- SET TRUE=0
- Begin DoDot:3
- +17 IF $GET(DGOUT(409.68,DGIEN_",",.12,"E"))'="INPATIENT APPOINTMENT"
- SET TRUE=1
- QUIT
- +18 ;inpatient outpatient appointment not checked out
- IF +$PIECE($GET(^SCE(DGIEN,0)),U,7)<1
- SET TRUE=1
- QUIT
- End DoDot:3
- if TRUE
- QUIT
- +19 SET DGDIV=$GET(DGOUT(409.68,DGIEN_",",.11,"I"))
- if DGDIV=""
- QUIT
- +20 ;($$GET1^DIQ(40.8 - ICR#417)
- SET DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIV_",",.07,"I"))
- +21 IF DGSTA=""
- SET DGSTA="N/A"
- +22 SET DGSTPCODE=$GET(DGOUT(409.68,DGIEN_",",.03,"E"))
- +23 ;this is to extract the location of the encounter
- KILL SDOEDATA
- DO GETGEN^SDOE(DGIEN,"SDOEDATA")
- +24 ;clinic name
- SET DGCLNCNME=$$GET1^DIQ(44,$PIECE(SDOEDATA(0),U,4)_",",.01,"E")
- +25 ;this is to extract the clinic name or location
- KILL DGAPPTDT,DGAPTERR
- DO GETS^DIQ(2,DFN_",","1900*","IE","DGAPPTDT","DGAPTERR")
- +26 if $DATA(DGAPTERR)
- QUIT
- +27 ;last user entered by
- SET DGLSTEDTBY=$GET(DGAPPTDT(2.98,DGDT_","_DFN_",",19,"E"))
- +28 IF $GET(DGLSTEDTBY)=""
- Begin DoDot:3
- +29 ;this is to extract last user edited by if not found in the patient file
- KILL ^TMP("PXKENC",$JOB)
- DO GETENC^PXAPI(DFN,DGDT,$PIECE(SDOEDATA(0),U,4))
- +30 SET DGVSTIEN=$ORDER(^TMP("PXKENC",$JOB,""))
- +31 SET DGLSTEDTBY=$$GET1^DIQ(200,$PIECE(^TMP("PXKENC",$JOB,DGVSTIEN,"VST",DGVSTIEN,0),U,23)_",",.01)
- +32 KILL ^TMP("PXKENC",$JOB)
- End DoDot:3
- +33 ;extract the primary diagnosis for this outpatient encounter
- DO GETPDX^DGOTHFS4(DGIEN)
- +34 IF $GET(ARRDIV)=1
- DO CHKTRSET
- QUIT
- +35 if $DATA(ARRDIV(DGDIV))
- DO CHKTRSET
- End DoDot:2
- End DoDot:1
- +36 IF SCCNT>0
- SET DGENCNT=DGENCNT-SCCNT
- +37 KILL DGAPPTDT,DGAPTERR
- +38 QUIT
- +39 ;
- CHKTRSET ;
- +1 NEW TMPDATA,ORGPRCTYP
- +2 ;if originating process type is not equal to 1, it means that it is not a real appointment
- SET ORGPRCTYP=$GET(DGOUT(409.68,DGIEN_",",.08,"I"))
- +3 IF ORGPRCTYP'=1
- Begin DoDot:1
- +4 ;regardless if the clinic contains primary or secondary, always count is as 1 DOS
- IF $GET(DGAPPTDT(2.98,DGDT_","_DFN_",",.001,"I"))
- SET SCCNT=SCCNT+1
- +5 IF '$TEST
- Begin DoDot:2
- +6 ;this is to force to display STANDALONE encounters not related to an appointment. Example: Originating Process Type= STOP CODE ADDITION, CREDIT STOP CODE, etc.
- IF DGOLDIEN=$PIECE(SDOEDATA(0),U,6)
- QUIT
- +7 SET ORGPRCTYP=1
- End DoDot:2
- End DoDot:1
- +8 SET TMPDATA=DGOUT(409.68,DGIEN_",",.11,"E")_U_DGSTA_U_DGCLNCNME_U_DGSTPCODE_U_DGLSTEDTBY_U_DGDIV_U_DGIEN_U_""_U_PRIMDX_U_+ORGPRCTYP
- +9 SET DGENCNT=DGENCNT+1
- +10 IF 'FLAG
- Begin DoDot:1
- +11 ;sort by date of service
- SET @RECORD@(DGDT,DGSTA,409.68,DGENCNT)=TMPDATA
- +12 ;sort by division
- IF SORTENCBY=2
- SET @RECORD1@(DGSTA,DGDT,409.68,DGENCNT)=TMPDATA
- End DoDot:1
- +13 IF '$TEST
- Begin DoDot:1
- +14 SET @RECORD@(DGDT,DGSTA,405,DGENCNT)=TMPDATA
- +15 IF SORTENCBY=2
- SET @RECORD1@(DGSTA,DGDT,405,DGENCNT)=TMPDATA
- End DoDot:1
- +16 ;contains the OE IEN primary - this is to determine between the primary and secondary stop code
- SET DGOLDIEN=DGIEN
- +17 QUIT
- +18 ;
- CHECKPTF(DGDFN,DGOTHREGDT,DGELGDTV,LIST) ;check and extract inpatient stay for a patient in File #45
- +1 ;Input:
- +2 ; DGDFN=IEN in file #2
- +3 ; DGOTHREGDT='From' date
- +4 ; DGELGDTV='To' date
- +5 ;Output:
- +6 ; ^TMP($J,LIST,DOS,STATION#,FILENO,RECNT)=Name of division^Station #^Ward Location^Treating Facility^Edited Last By^Division^IEN
- +7 NEW ADMDT,DGOUT,DGOUTERR,DIVINPT,PTFIEN,WRDLOC,WRDIEN,LSTUSR,TRTFCLTY,DGDIV,DGDIVNME,DGSTA,TMPDATA,DSCHRGDT
- +8 ;find all admissions for a patient.
- +9 IF $DATA(^DGPT("AAD",DGDFN))
- Begin DoDot:1
- +10 SET ADMDT=""
- FOR
- SET ADMDT=$ORDER(^DGPT("AAD",DGDFN,ADMDT))
- if '+ADMDT
- QUIT
- Begin DoDot:2
- +11 SET PTFIEN=0
- FOR
- SET PTFIEN=$ORDER(^DGPT("AAD",DGDFN,ADMDT,PTFIEN))
- if 'PTFIEN
- QUIT
- Begin DoDot:3
- +12 KILL TMPDATA
- +13 SET DSCHRGDT=0
- +14 ;check if the admission date is before the patient become OTH. If true, check if the patient has been discharged. If patient still not discharged when they become
- +15 ;OTH and then VERIFIED, include that patient. If patient is discharged after receiving VBA adjudication but the admission date is before they become OTH, then include that patient
- +16 ;otherwise, the record will be skipped.
- +17 ;discharge date
- SET DSCHRGDT=$$GET1^DIQ(45,PTFIEN_",",70,"I")
- +18 ;the admission date is before the patient become OTH
- IF (ADMDT\1)<DGOTHREGDT
- Begin DoDot:4
- +19 ;no discharge date, patient is still inpatient/admitted in the hospital
- IF +DSCHRGDT<1
- DO PTFDATA^DGOTHFSM
- QUIT
- +20 ;patient is discharged on or after adjudication but the admission date is before they become OTH, then include that patient
- IF ADMDT\1<=DGELGDTV
- IF $$CHKDATE^DGOTHFSM(+DSCHRGDT\1,DGOTHREGDT,DGELGDTV)
- Begin DoDot:5
- +21 ;check if the PP inpatient discharged date is within the date range.
- IF +$GET(DGPPFLGRPT)>0
- IF '$$CHKDATE^DGOTHFSM(+DSCHRGDT\1,DGOTHREGDT,DGELGDTV)
- QUIT
- +22 DO PTFDATA^DGOTHFSM
- +23 DO EN^IBEFSMUT(DGDFN,(ADMDT\1),(ADMDT\1),LIST)
- +24 KILL @IBOTHSTAT@(350)
- +25 IF $DATA(@IBOTHSTAT@(399,DGDFN))
- DO DOS399^DGOTHFS4(399)
- End DoDot:5
- QUIT
- +26 if '$$CHKDATE^DGOTHFSM(+DSCHRGDT\1,DGOTHREGDT,DGELGDTV)
- QUIT
- +27 DO PTFDATA^DGOTHFSM
- End DoDot:4
- QUIT
- +28 ;admission date and discharge date is within the date range
- IF ((ADMDT\1)'<DGOTHREGDT)&((ADMDT\1)'>DGELGDTV)
- Begin DoDot:4
- +29 ;patient is still inpatient not discharge
- IF +DSCHRGDT<1
- DO PTFDATA^DGOTHFSM
- QUIT
- +30 DO PTFDATA^DGOTHFSM
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +31 ;after checking if there are any inpatient stay for this patient, check if this patient had any inpatient outpatient encounter. if there is and date is within the date range include the data in the report
- +32 ;1 is a flag to determine to process inpatient
- DO CHKTREAT(DGDFN,DGOTHREGDT,DGELGDTV,.VAUTD,1)
- +33 QUIT
- +34 ;
- CHECKIB(LIST,DGOTHREGDT,DGELGDTV) ;check if patient had charges stored in file #350 and #399
- +1 NEW OTHIBDT,OTHIBREC,FILENO,DGDIVIEN,DGDT,DGSTA,DGSTANAME,DGLSTUSR,DGIBSTPCODE,IBOTHSTAT,ACCTYP,TMPDATA,TMPDATA1
- +2 ;extract the IB STATUS in both file #350 and file #399
- DO EN^IBEFSMUT(DGDFN,DGOTHREGDT,DGELGDTV,LIST)
- +3 IF '$GET(IBOTHSTAT)
- SET IBOTHSTAT=$NAME(^TMP($JOB,LIST))
- +4 ;check if patient has entry in file #350 and file #399
- FOR FILENO=350,399
- Begin DoDot:1
- +5 IF +$GET(@IBOTHSTAT@(FILENO,DGDFN,0))>0
- Begin DoDot:2
- +6 SET OTHIBDT=""
- FOR
- SET OTHIBDT=$ORDER(@IBOTHSTAT@(FILENO,OTHIBDT))
- if OTHIBDT=""
- QUIT
- Begin DoDot:3
- +7 SET OTHIBREC=""
- FOR
- SET OTHIBREC=$ORDER(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC))
- if OTHIBREC=""
- QUIT
- Begin DoDot:4
- +8 ;check if the date bill from is within the date range patient became OTH and when PE is verified
- if '$$CHKDATE^DGOTHFSM(OTHIBDT,DGOTHREGDT,DGELGDTV)
- QUIT
- +9 ;otherwise, capture the record for this patient
- +10 SET DGDT=OTHIBDT
- +11 KILL TMPDATA,TMPDATA1
- +12 SET TMPDATA1=$GET(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC))
- +13 IF FILENO=350
- Begin DoDot:5
- +14 SET ACCTYP=$PIECE(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U)
- +15 ;station number (eg. 442)
- SET DGSTA=$PIECE($PIECE(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,8),"-")
- +16 ;station name (eg. CHEYENNE VA MEDICAL)
- SET DGSTANAME=$PIECE($PIECE(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,8),"-",2)
- +17 ;stop code
- SET DGIBSTPCODE=$PIECE(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,9)
- +18 ;user entered/edit the record
- SET DGLSTUSR=$PIECE(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,10)
- +19 SET TMPDATA=DGSTANAME_U_DGSTA_U_"NON-VA"_U_$SELECT(DGIBSTPCODE'="":DGIBSTPCODE,1:"N/A")_U_DGLSTUSR_U_DGSTA_U_TMPDATA1
- +20 SET DGENCNT=DGENCNT+1
- +21 ;sort by date of service
- SET @RECORD@(DGDT,DGSTA,350,DGENCNT)=TMPDATA
- +22 ;sort by division
- IF SORTENCBY=2
- SET @RECORD1@(DGSTA,DGDT,350,DGENCNT)=TMPDATA
- End DoDot:5
- +23 IF FILENO=399
- Begin DoDot:5
- +24 SET ACCTYP=$PIECE($PIECE($PIECE(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,5),";"),":",2)
- +25 ;station number (eg. 442)
- SET DGDIVIEN=$PIECE(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,8)
- SET DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIVIEN_",",.07,"I"))
- +26 ;station name (eg. CHEYENNE VA MEDICAL)
- SET DGSTANAME=$$GET1^DIQ(40.8,DGDIVIEN_",",.01,"E")
- +27 ;user entered/edit the record
- SET DGLSTUSR=$PIECE(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,9)
- +28 SET TMPDATA=DGSTANAME_U_DGSTA_U_"NON-VA"_U_"N/A"_U_DGLSTUSR_U_DGDIVIEN_U_ACCTYP_U_TMPDATA1
- +29 SET DGENCNT=DGENCNT+1
- +30 ;sort by date of service
- SET @RECORD@(DGDT,DGSTA,399,DGENCNT)=TMPDATA
- +31 ;sort by division
- IF SORTENCBY=2
- SET @RECORD1@(DGSTA,DGDT,399,DGENCNT)=TMPDATA
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +32 QUIT
- +33 ;
- CHECKRX(LIST) ;check and extract rx data for this patient
- +1 NEW DGRXNUM,DGRXIEN,DGRELDT,DGDIV,DGSTA,DGSTANAME,DGCLNC,DGLSTUSR
- +2 ;get the medication profile of a patient from PRESCRIPTION file (#52)
- KILL ^TMP($JOB,LIST)
- DO RX^PSO52API(DGDFN,LIST,,,"2,R,I,P",DGSORT("DGBEG"),$$FMADD^XLFDT(DGSORT("DGEND"),366))
- +3 IF +^TMP($JOB,LIST,DGDFN,0)<1
- KILL ^TMP($JOB,LIST)
- QUIT
- +4 SET DGRXNUM=""
- FOR
- SET DGRXNUM=$ORDER(^TMP($JOB,LIST,"B",DGRXNUM))
- if DGRXNUM=""
- QUIT
- Begin DoDot:1
- +5 SET DGRXIEN=""
- FOR
- SET DGRXIEN=$ORDER(^TMP($JOB,LIST,"B",DGRXNUM,DGRXIEN))
- if DGRXIEN=""
- QUIT
- Begin DoDot:2
- +6 ;check if the release date is within the date range
- +7 ;original fill released date
- SET DGRELDT=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,31),U)
- +8 ;extract the RETURN TO STOCK date release date/time if the original fill date is missing
- IF +DGRELDT<1
- IF +$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,32.1),U)>1
- SET DGRELDT=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,32.1),U)
- +9 ;this for PP multiple report processing
- IF $GET(DGPPFLGRPT)=1
- SET DGOTHREGDT=DGSORT("DGBEG")
- SET DGELGDTV=DGSORT("DGEND")
- +10 ;clinic
- SET DGCLNC=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,5),U,2)
- +11 ;check if the release date is within the date range patient became OTH and when PE is verified
- +12 IF '$$CHKDATE^DGOTHFSM(+DGRELDT\1,DGOTHREGDT,DGELGDTV)
- DO REFILL^DGPPOHUT(LIST)
- DO PARTIAL^DGPPDRP1(LIST)
- QUIT
- +13 ;check if the original fill released date is before the patient become OTH, if true, check if the refill is within the date range
- +14 IF +DGRELDT\1<DGOTHREGDT
- DO REFILL^DGPPOHUT(LIST)
- DO PARTIAL^DGPPDRP1(LIST)
- QUIT
- +15 ;;this is already handled by IBEFMSUT routine. No need to include this record here and to avoid duplicate record.
- IF $GET(^TMP($JOB,LIST,DGDFN,DGRXIEN,106))'=""
- QUIT
- +16 ;division ien
- SET DGDIV=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,20),U)
- +17 ;station/site number
- KILL ^TMP($JOB,"PSOSITE")
- DO PSS^PSO59(DGDIV,,"PSOSITE")
- SET DGSTA=$GET(^TMP($JOB,"PSOSITE",DGDIV,.06))
- +18 ;division name
- SET DGSTANAME=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,20),U,2)
- +19 ;pharmacist entered this rx
- SET DGLSTUSR=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,23),U,2)
- +20 SET DGENCNT=DGENCNT+1
- +21 SET @RECORD@(+DGRELDT\1,DGSTA,52,DGENCNT)=DGSTANAME_U_DGSTA_U_$SELECT(DGCLNC'="":DGCLNC,1:"NON-VA")_U_"N/A"_U_DGLSTUSR_U_DGDIV_U_"RX - "_DGRXNUM_":"_DGRXIEN
- +22 DO REFILL^DGPPOHUT(LIST)
- DO PARTIAL^DGPPDRP1(LIST)
- End DoDot:2
- End DoDot:1
- +23 KILL ^TMP($JOB,LIST),^TMP($JOB,"PSOSITE")
- +24 QUIT
- +25 ;
- IBSTATUS(IBFILENO,DATE) ;extract records from file #350 or file #399
- +1 NEW DGRXDATE,IBCNT,BILLGRP,RSLTFRM,BILCLS,IBRFNUM,IBDIV,ACTYP
- +2 NEW BILCLS,IBRFNUM,IBDIV,RECNUM,DFN399,IBIEN399,TMPDATA,IBIEN409,DGIEN399,DGIEN409
- +3 SET RECNUM=0
- +4 SET IBCNT=""
- FOR
- SET IBCNT=$ORDER(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT))
- if IBCNT=""
- QUIT
- Begin DoDot:1
- +5 IF IBFILENO=350
- Begin DoDot:2
- +6 ;Outpatient and inpatient events
- +7 SET (BILLGRP,ACTYP,RSLTFRM,IBDIV,TMPDATA)=""
- +8 ;action type
- SET ACTYP=$PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U)
- +9 ;quit if rx
- IF ACTYP["RX"
- SET ACTYP=""
- QUIT
- +10 ;billing group
- SET BILLGRP=$PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,2)
- +11 ;result from
- SET RSLTFRM=$PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,5)
- +12 ;we are not including any file #44 records as of the moment
- IF $PIECE(RSLTFRM,":",1)=44
- KILL @RECORD@(SUB1,SUB2,FILENO,RECNT)
- QUIT
- +13 ;division
- SET IBDIV=$PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,8)
- +14 ;sort by date of service
- IF $PIECE(DGSORT("SORTENCBY"),U)=1
- SET RECNUM=+$ORDER(@RECORD@(ENCDT\1,+STATNUM,IBFILENO,RECNUM))
- +15 ;sort by division
- IF $PIECE(DGSORT("SORTENCBY"),U)=2
- SET RECNUM=+$ORDER(@RECORD@(+STATNUM,ENCDT\1,IBFILENO,RECNUM))
- +16 IF ($PIECE(RSLTFRM,":",1)=405)!($PIECE(RSLTFRM,":",1)=409.68)!($PIECE(RSLTFRM,":",1)=45)
- Begin DoDot:3
- +17 ;reset DFN405 to extract the IEN for file #45
- IF $PIECE(RSLTFRM,":",1)=45
- SET DFN405=$PIECE($PIECE(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,8),";",2)
- +18 ;DFN405 and DFN409 is set in ENCTRIB^DGOTHFS3
- IF DFN405=$PIECE(RSLTFRM,":",2)!(DFN409=$PIECE(RSLTFRM,":",2))
- Begin DoDot:4
- +19 SET CHRGCNT=CHRGCNT+1
- +20 SET TMPDATA=@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT)
- +21 ;sort by date of service
- IF $PIECE(DGSORT("SORTENCBY"),U)=1
- Begin DoDot:5
- +22 SET @RECORD@(ENCDT,STATNUM,FILENO,RECNT,CHRGCNT)=TMPDATA
- +23 SET TMPDATA=$PIECE($PIECE(@RECORD@(ENCDT,STATNUM,FILENO,RECNT,CHRGCNT),U,4),"-",2)
- +24 SET $PIECE(@RECORD@(ENCDT,STATNUM,FILENO,RECNT,CHRGCNT),U,4)=TMPDATA
- +25 ;remove the record from ^TMP if it already exist in either file 405 or 409.68
- KILL @RECORD@(ENCDT\1,+STATNUM,IBFILENO,RECNUM)
- End DoDot:5
- +26 ;sort by division
- IF $PIECE(DGSORT("SORTENCBY"),U)=2
- Begin DoDot:5
- +27 SET @RECORD@(STATNUM,ENCDT,FILENO,RECNT,CHRGCNT)=TMPDATA
- +28 SET TMPDATA=$PIECE($PIECE(@RECORD@(STATNUM,ENCDT,FILENO,RECNT,CHRGCNT),U,4),"-",2)
- +29 SET $PIECE(@RECORD@(STATNUM,ENCDT,FILENO,RECNT,CHRGCNT),U,4)=TMPDATA
- +30 ;remove the record from ^TMP if it already exist in either file 405 or 409.68
- KILL @RECORD@(+STATNUM,ENCDT\1,IBFILENO,RECNUM)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- QUIT
- +31 IF IBFILENO=399
- Begin DoDot:2
- +32 ;Outpatient and inpatient events
- +33 SET (BILLGRP,RSLTFRM,BILCLS,IBDIV,TMPDATA,IBIEN399,IBIEN409,DGIEN399,DGIEN409)=""
- +34 ;quit if rx
- if $PIECE($PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,5),"
- QUIT
- +35 ;quit if we are no longer dealing with the inpatient record currently
- IF +DFN405>0
- IF $PIECE($PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,5),":")'=1
- QUIT
- +36 ;bill classification
- SET BILCLS=$PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U)
- +37 ;rate type
- SET BILLGRP=$PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,2)
- +38 ;file #399 ien
- SET IBIEN399=$PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,3)
- +39 ;this can contain either ien from file #409.68 or file #45
- SET IBIEN409=$PIECE(@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT),U,10)
- +40 ;sort by date of service
- IF $PIECE(DGSORT("SORTENCBY"),U)=1
- Begin DoDot:3
- +41 IF $DATA(@RECORD@(DATE\1,STATNUM,IBFILENO))
- Begin DoDot:4
- +42 IF DFN405=IBIEN409!(DFN409=IBIEN409)
- Begin DoDot:5
- +43 SET RECNUM=$ORDER(@RECORD@(DATE\1,STATNUM,IBFILENO,""))
- +44 ;file #399 ien
- SET DGIEN399=$PIECE(@RECORD@(DATE\1,STATNUM,IBFILENO,RECNUM),U,10)
- +45 ;this can contain either ien from file #409.68 or file #45
- SET DGIEN409=$PIECE(@RECORD@(DATE\1,STATNUM,IBFILENO,RECNUM),U,17)
- +46 IF DGIEN409=IBIEN409!(DGIEN399=IBIEN399)
- Begin DoDot:6
- +47 ;remove the record from ^TMP if it already exist in either file 405 or 409.68
- IF $DATA(@RECORD@(DATE\1,STATNUM,IBFILENO,RECNUM))
- KILL @RECORD@(DATE\1,STATNUM,IBFILENO,RECNUM)
- +48 SET CHRGCNT=CHRGCNT+1
- +49 SET TMPDATA=@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT)
- +50 SET @RECORD@(ENCDT,STATNUM,FILENO,RECNT,CHRGCNT)=TMPDATA
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- +51 ;sort by division
- IF $PIECE(DGSORT("SORTENCBY"),U)=2
- Begin DoDot:3
- +52 IF $DATA(@RECORD@(STATNUM,DATE\1,IBFILENO))
- Begin DoDot:4
- +53 IF DFN405=IBIEN409!(DFN409=IBIEN409)
- Begin DoDot:5
- +54 SET RECNUM=$ORDER(@RECORD@(STATNUM,DATE\1,IBFILENO,""))
- +55 ;file #399 ien
- SET DGIEN399=$PIECE(@RECORD@(STATNUM,DATE\1,IBFILENO,RECNUM),U,10)
- +56 ;file #409 ien
- SET DGIEN409=$PIECE(@RECORD@(STATNUM,DATE\1,IBFILENO,RECNUM),U,17)
- +57 IF DGIEN409=IBIEN409!(DGIEN399=IBIEN399)
- Begin DoDot:6
- +58 ;remove the record from ^TMP if it already exist in either file 405 or 409.68
- IF $DATA(@RECORD@(STATNUM,DATE\1,IBFILENO,RECNUM))
- KILL @RECORD@(STATNUM,DATE\1,IBFILENO,RECNUM)
- +59 SET CHRGCNT=CHRGCNT+1
- +60 SET TMPDATA=@IBOTHSTAT@(IBFILENO,DATE\1,DFN,IBCNT)
- +61 SET @RECORD@(STATNUM,ENCDT,FILENO,RECNT,CHRGCNT)=TMPDATA
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +62 QUIT
- +63 ;