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

DGOTHFS4.m

Go to the documentation of this file.
  1. DGOTHFS4 ;SLC/RM - FORMER OTH PP PATIENT UTILITY ; January 20, 2021@9:15 am
  1. ;;5.3;Registration;**1034,1035,1047**;Aug 13, 1993;Build 13
  1. ;
  1. ;Global References Supported by ICR# Type
  1. ;----------------- ----------------- ----------
  1. ; ^TMP($J SACC 2.3.2.5.1
  1. ; ^DGPM("ATID1" 419 (DG is the Custodial Package) Cont. Sub.
  1. ;
  1. ;External References
  1. ;-------------------
  1. ; $$GET1^DIQ 2056 Supported
  1. ; $$FMTE^XLFDT 10103 Supported
  1. ; $$STA^XUAF4 2171 Supported
  1. ; $$GETPDX^SDOE 2546 Supported
  1. ; $$CODEC^ICDEX 5747 Cont. Sub.
  1. ; $$ICDDX^ICDEX 5747 Cont. Sub.
  1. Q
  1. ;
  1. GETPDX(OEIEN) ;extract the outpatient encounter primary diagnosis
  1. S (PRIMDX,DXNAME)=""
  1. S PRIMDX=$$GETPDX^SDOE(OEIEN)
  1. S PRIMDX=$$CODEC^ICDEX(80,PRIMDX)
  1. I $P(PRIMDX,U)=-1 S PRIMDX="NONE" Q
  1. S DXNAME=$$ICDDX^ICDEX(PRIMDX)
  1. Q
  1. ;
  1. FLTRENC ;determine whether to prompt the Encounter sorting or not
  1. N FILENO,SUB1,SUB2,RECNT,ACTYP,RESULT,RXARRAY,RXIBIEN,RXNAME,RXNUMFIL
  1. S RESULT=0
  1. S SUB1="" F S SUB1=$O(@RECORD@(SUB1)) Q:SUB1="" D
  1. . S SUB2="" F S SUB2=$O(@RECORD@(SUB1,SUB2)) Q:SUB2="" D
  1. . . S FILENO="" F S FILENO=$O(@RECORD@(SUB1,SUB2,FILENO)) Q:FILENO="" D
  1. . . . S RECNT="" F S RECNT=$O(@RECORD@(SUB1,SUB2,FILENO,RECNT)) Q:RECNT="" D
  1. . . . . S ACTYP=$P(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,7)
  1. . . . . I FILENO=350!(FILENO=399) D
  1. . . . . . I FILENO=350 S RESULT=$P($P($P(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,11),";"),":"),RXIBIEN=$P($P($P(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,11),":",2),";")
  1. . . . . . I FILENO=399 D
  1. . . . . . . S RXIBIEN=$P($P(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,12),":",3)
  1. . . . . . . S RXNAME=$P($P($P(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,12),":",4),"-")
  1. . . . . . . S RXNUMFIL=$P($P(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,12),":",5)
  1. . . . . . . I +RXIBIEN<1 S RXIBIEN=RXNAME_"("_RXNUMFIL_")"
  1. . . . . . I ACTYP["RX"!(ACTYP["PRESCRIPTION") D Q
  1. . . . . . . I RESULT=350,'$D(RXARRAY(SUB1,RXIBIEN)) S DGTOTALRX=DGTOTALRX+1 ;the patient had record only in file #350
  1. . . . . . . I FILENO=399,'$D(RXARRAY(SUB1,RXIBIEN)),+RXIBIEN<1 S DGTOTALRX=DGTOTALRX+1 ;the patient had record only in file #399
  1. . . . . . . I RESULT=52,+$P(^TMP($J,"OTHFSMR2",DGDFN,0),U)<1,'$D(RXARRAY(SUB1,RXIBIEN)) S DGTOTALRX=DGTOTALRX+1 ;has rx record charges in file #350 but those RX charges are not found in file #52
  1. . . . . . . K @RECORD@(SUB1,SUB2,FILENO,RECNT) ;sort by date of service
  1. . . . . . . I SORTENCBY=2 K @RECORD1@(SUB2,SUB1,FILENO,RECNT) ;sort by division
  1. . . . . . . S DGENCNT=DGENCNT-1 ;subtract the # of record of episode of care for this patient since this is rx
  1. . . . . . . S RXARRAY(SUB1,RXIBIEN)=""
  1. . . . . . I FILENO=350,RESULT'=350 S DGENCNT=DGENCNT-1 Q ;result from comes from 405 or 409.68
  1. . . . . . I FILENO=350,RESULT=350 Q ;result manually entered from file #350 is already counted
  1. . . . . . I FILENO=399,+$P(@RECORD@(SUB1,SUB2,FILENO,RECNT),U,17)>1 S DGENCNT=DGENCNT-1 ;file is 399
  1. K RXARRAY
  1. Q
  1. ;
  1. TOTRX ;determine whether to prompt the RX sorting or not
  1. N DGRXNUM,DGRXIEN,DGRELDATE,DGTOTRF,DGRFRELDT,JJ,RXORFLCNT
  1. S (DGTOTRX52,RXORFLCNT)=0
  1. S DGRXNUM="" F S DGRXNUM=$O(^TMP($J,"OTHFSMR2","B",DGRXNUM)) Q:DGRXNUM="" D
  1. . S DGRXIEN="" F S DGRXIEN=$O(^TMP($J,"OTHFSMR2","B",DGRXNUM,DGRXIEN)) Q:DGRXIEN="" D
  1. . . S RXORFLCNT=0
  1. . . S DGRELDATE=$P(^TMP($J,"OTHFSMR2",DGDFN,DGRXIEN,31),U)
  1. . . I +DGRELDATE<1,+$P(^TMP($J,"OTHFSMR2",DGDFN,DGRXIEN,32.1),U)>1 S DGRELDATE=$P(^TMP($J,"OTHFSMR2",DGDFN,DGRXIEN,32.1),U),DGRTNSTCK=1 ;extract the RETURN TO STOCK date release date/time if the original fill date is missing
  1. . . I $$CHKDATE^DGOTHFS2(DGRELDATE\1,.DGSORT) S DGTOTRX52=DGTOTRX52+1,RXORFLCNT=1 ;count total rx
  1. . . E D
  1. . . . ;check if the rx refill is within the date range by the time patient became OTH
  1. . . . S DGTOTRF=$P(^TMP($J,"OTHFSMR2",DGDFN,DGRXIEN,"RF",0),U)
  1. . . . I DGTOTRF>0 D
  1. . . . . F JJ=1:1:DGTOTRF D
  1. . . . . S DGRFRELDT=+$P(^TMP($J,"OTHFSMR2",DGDFN,DGRXIEN,"RF",JJ,17),U)
  1. . . . . I +DGRFRELDT<1,+$P(^TMP($J,"OTHFSMR2",DGDFN,DGRXIEN,"RF",JJ,14),U)>1 S DGRFRELDT=$P(^TMP($J,"OTHFSMR2",DGDFN,DGRXIEN,"RF",JJ,14),U),DGRTNSTCK=1 ;extract the RETURN TO STOCK date release date/time
  1. . . . . Q:$$CHKDATE^DGOTHFS2(DGRFRELDT\1,.DGSORT)
  1. . . . . I RXORFLCNT,DGRELDATE\1'=DGRFRELDT\1 S DGTOTRX52=DGTOTRX52+1
  1. Q
  1. ;
  1. PRINTRX ;display patient's released prescription
  1. ;display this piece of information to its own page so that the report will not look cluttered
  1. D RXHDR(0),RXCOL,LINE^DGOTHFS2(1)
  1. N DGRXNUM,DGRXCNT,SUB1,SUB2,DGNARX,DGCPYTIER,DGRXTOTCNT,DGTOTALRX
  1. N RXIBBILNO,PRNTDRX,RXNUMBER,RXRELDATE,RXPRVS
  1. S (DGTOTALRX,DGNARX,RXPRVS)=0
  1. I $O(^TMP($J,"OTHFSMRX",""))="" D Q
  1. . W !!,">> NO DATA FOUND FROM "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")_"."
  1. . W ! D LINE^DGOTHFS2(1) W !
  1. . S DGTOTALRX=0
  1. . W !,"Total Number of Rx: ",+DGTOTALRX,!!!
  1. ;otherwise, print patient's list of rx's
  1. S SUB1="" F S SUB1=$O(^TMP($J,"OTHFSMRX",SUB1)) Q:SUB1="" D Q:DGQ
  1. . S SUB2="" F S SUB2=$O(^TMP($J,"OTHFSMRX",SUB1,SUB2)) Q:SUB2="" D Q:DGQ
  1. . . S DGRXNUM="" F S DGRXNUM=$O(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM)) Q:DGRXNUM="" D Q:DGQ
  1. . . . S DGRXCNT="" F S DGRXCNT=$O(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT)) Q:DGRXCNT="" D Q:DGQ
  1. . . . . I $Y>(IOSL-4) W ! D PAUSE^DGOTHFS2(.DGQ) Q:DGQ D PTHDR^DGOTHFS2,LINE^DGOTHFS2(0),RXHDR(1),RXCOL,LINE^DGOTHFS2(1)
  1. . . . . W !
  1. . . . . S RXNUMBER=$P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U) ;Rx #
  1. . . . . S RXIBBILNO=$P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,8)
  1. . . . . I RXIBBILNO="" S RXIBBILNO="NON-VA"_DGRXCNT
  1. . . . . S RXRELDATE=$P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,7)\1
  1. . . . . I '$D(PRNTDRX(RXNUMBER,+RXRELDATE)) D PRINTRX1,PRINTRX2
  1. . . . . I $D(PRNTDRX(RXNUMBER,+RXRELDATE)) D
  1. . . . . . I RXNUMBER="NON-VA",$G(PRNTDRX(RXNUMBER,+RXRELDATE))'=RXIBBILNO D PRINTRX1,PRINTRX2 Q
  1. . . . . . I RXNUMBER["P",$G(PRNTDRX(RXNUMBER,+RXRELDATE))=1 Q ;already printed, do no print again
  1. . . . . . I $P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,7)["P",$P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,8)="" D Q ;if partial and no bill, display the fill and released date only
  1. . . . . . . I $G(PRNTDRX(RXNUMBER,+RXRELDATE))'=1,RXPRVS'=RXNUMBER D PRINTRX1,PRINTRX2 Q
  1. . . . . . . W ?49,$$FMTE^XLFDT($P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,6),"5Z") ;fill date
  1. . . . . . . D PRINTRX3
  1. . . . . . D PRINTRX2
  1. . . . . I RXNUMBER="NON-VA",$G(PRNTDRX(RXNUMBER,+RXRELDATE))'=RXIBBILNO S DGNARX=DGNARX+1
  1. . . . . S DGTOTALRX($P($P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U),"("))=""
  1. . . . . S PRNTDRX(RXNUMBER,+RXRELDATE)=$S(RXNUMBER="NON-VA":RXIBBILNO,RXNUMBER["P":1,1:"")
  1. . . . . S RXPRVS=RXNUMBER
  1. . . . Q:DGQ
  1. . . Q:DGQ
  1. . Q:DGQ
  1. ;if patient had Rx's but the released date is not within date range from the time patient became OTH to PE is verified
  1. ;those Rx's will not be included into the report
  1. Q:DGQ
  1. S DGRXTOTCNT="" F S DGRXTOTCNT=$O(DGTOTALRX(DGRXTOTCNT)) Q:DGRXTOTCNT="" D
  1. . I DGRXTOTCNT="NON-VA" Q
  1. . S DGTOTALRX=DGTOTALRX+1
  1. S DGTOTALRX=DGTOTALRX+DGNARX
  1. I DGTOTALRX<1,DGNARX<1 W !,">> NO DATA FOUND FROM "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" TO "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")_"."
  1. W ! D LINE^DGOTHFS2(1) W !
  1. W:DGTOTALRX>0 !,"Total Number of Rx: ",DGTOTALRX
  1. I DGTOTALRX<3 W !!!
  1. K PRNTDRX,DGTOTALRX
  1. Q
  1. ;
  1. PRINTRX1 ;
  1. N TMPRXRLDTE
  1. W RXNUMBER
  1. S DGCPYTIER=$P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,2)
  1. W ?15,$S(DGCPYTIER'="":DGCPYTIER,1:"N/A") ;copay tier
  1. W ?22,$J($P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,3),2) ;# of refills
  1. W ?31,$J($P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,4),2) ;days supply
  1. W ?39,$P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,5) ;division
  1. W ?49,$$FMTE^XLFDT($P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,6),"5Z") ;fill date
  1. D PRINTRX3
  1. Q
  1. ;
  1. PRINTRX3 ;
  1. S TMPRXRLDTE=$P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,7)
  1. W ?61,$$FMTE^XLFDT(+TMPRXRLDTE\1,"5Z") ;rx released date/time
  1. I TMPRXRLDTE["R" W "R" ;for return to stock
  1. I TMPRXRLDTE["P" W "P" S $P(RXNUMBER,")")=$P(RXNUMBER,")")_"P" ;for rx partial fill
  1. Q
  1. ;
  1. PRINTRX2 ;print the IB status for an RX
  1. W ?74,$P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,8) ;Bill no
  1. W ?89,$E($P($P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,9),";"),1,20) ;action type
  1. W ?111,$E($P(^TMP($J,"OTHFSMRX",SUB1,SUB2,DFN,DGRXNUM,DGRXCNT),U,10),1,20) ;rx IB STATUS
  1. Q
  1. ;
  1. RXCOL ;display Rx column name
  1. W !,"Rx #",?15,"Copay",?22,"# of",?31,"Days",?39,"Division",?49,"Fill Date",?61,"Rx Release",?74,"Bill #",?89,"Action Type/",?111,"IB Status"
  1. W !,?15,"Tier",?22,"Refills",?31,"Supply",?61,"Date",?89,"Rate Type",!
  1. Q
  1. ;
  1. RXHDR(FLAG) ;Released Prescription Header
  1. N TITLE
  1. S TITLE="PATIENT'S RELEASED PRESCRIPTION"_$S(FLAG:" - Continuation",1:"")
  1. W !,?132-$L(TITLE)\2,TITLE,!
  1. D DTRANGE^DGOTHFS2
  1. S TITLE="Sorted By: "_$E($P(DGSORT("SORTRXBY"),U,2),4,20)
  1. I $P(DGSORT("SORTRXBY"),U,2)'="" W ?132-$L(TITLE)\2,TITLE,!
  1. I $O(^TMP($J,"OTHFSMRX",""))'="" D
  1. . I $G(DGRTNSTCK)=1,$G(DGPRTLRXFL)=1 W ?39,"'R' = Return Medication To Stock 'P' = Partial Fill",!
  1. . I $G(DGRTNSTCK)=1,$G(DGPRTLRXFL)=0 W ?48,"'R' = Return Medication To Stock",!
  1. . I $G(DGRTNSTCK)=0,$G(DGPRTLRXFL)=1 W ?55,"'P' = Partial Fill",!
  1. D LINE^DGOTHFS2(1)
  1. Q
  1. ;
  1. SORTHLP(DGSEL) ;provide extended DIR("?") help test for Encounter and Rx report section
  1. ; Input: DGSEL - prompt var for help text word selection
  1. ; Output: none
  1. S DGSEL=$S(DGSEL=1:"Date of Service",1:"Rx Released Date")
  1. W !," Please Select:"
  1. W !," 1. "_DGSEL
  1. W !," If you want to sort the report by "_DGSEL_", then by Division",!
  1. W !," 2. Division"
  1. W !," If you want to sort the report by Division, then by "_DGSEL
  1. Q
  1. ;
  1. ATID1 ;extract the ward and the last user edited the record in file #405
  1. N ADMDT405,PTMOVIEN
  1. S PTFIEN405=0,(WRDIEN,LSTUSR,DGDIV,DGDIVNME,DGSTA)=""
  1. I $D(^DGPM("ATID1",DGDFN)) D
  1. . S ADMDT405="" F S ADMDT405=$O(^DGPM("ATID1",DGDFN,ADMDT405)) Q:'+ADMDT405 D
  1. . . S PTMOVIEN=0 F S PTMOVIEN=$O(^DGPM("ATID1",DGDFN,ADMDT405,PTMOVIEN)) Q:'PTMOVIEN D
  1. . . . I ADMDT=(9999999.9999999-ADMDT405) D
  1. . . . . K DGOUT,DGOUTERR D GETS^DIQ(405,PTMOVIEN_",",".01;.03;.06;.07;.09;.14;.16;.17;102","IE","DGOUT","DGOUTERR") ;DG is the custodial package for #405, no icr needed
  1. . . . . S WRDIEN=DGOUT(405,PTMOVIEN_",",.06,"I") ;ward ien points to file #42
  1. . . . . S LSTUSR=DGOUT(405,PTMOVIEN_",",102,"E") ;last user update the record
  1. . . . . I WRDIEN'="" D
  1. . . . . . K DIVINPT D GETS^DIQ(42,WRDIEN_",",".015;.017","IE","DIVINPT") ;extract division name,station number, and treating specialty
  1. . . . . . S DGDIV=DIVINPT(42,WRDIEN_",",.015,"I") ;division ien - DG is the custodial package for #42, no icr needed
  1. . . . . . S DGDIVNME=DIVINPT(42,WRDIEN_",",.015,"E") ;division name
  1. . . . . . S DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIV_",",.07,"I"))
  1. . . . . . I TRTFCLTY="" S TRTFCLTY=DIVINPT(42,WRDIEN_",",.017,"E") ;if treating facility is null get in file #45
  1. . . . . S PTFIEN405=PTMOVIEN
  1. Q
  1. ;
  1. DOS399(FILENO) ;
  1. N OTHIBDT,OTHIBREC,DGDIVIEN,DGDT,DGSTA,DGSTANAME,DGLSTUSR,DGIBSTPCODE,ACCTYP,TMPDATA,TMPDATA1
  1. S OTHIBDT="" F S OTHIBDT=$O(@IBOTHSTAT@(FILENO,OTHIBDT)) Q:OTHIBDT="" D
  1. . S OTHIBREC="" F S OTHIBREC=$O(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC)) Q:OTHIBREC="" D
  1. . . S TMPDATA1=$G(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC))
  1. . . S ACCTYP=$P($P($P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,5),";"),":",2)
  1. . . S DGDIVIEN=$P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,8),DGSTA=$$STA^XUAF4($$GET1^DIQ(40.8,DGDIVIEN_",",.07,"I")) ;station number (eg. 442)
  1. . . S DGSTANAME=$$GET1^DIQ(40.8,DGDIVIEN_",",.01,"E") ;station name (eg. CHEYENNE VA MEDICAL)
  1. . . S DGLSTUSR=$P(@IBOTHSTAT@(FILENO,OTHIBDT,DGDFN,OTHIBREC),U,9) ;user entered/edit the record
  1. . . S TMPDATA=DGSTANAME_U_DGSTA_U_"NON-VA"_U_"N/A"_U_DGLSTUSR_U_DGDIVIEN_U_ACCTYP_U_TMPDATA1
  1. . . S DGENCNT=DGENCNT+1
  1. . . S @RECORD@(OTHIBDT,DGSTA,399,DGENCNT)=TMPDATA ;sort by date of service
  1. . . I SORTENCBY=2 S @RECORD1@(DGSTA,OTHIBDT,399,DGENCNT)=TMPDATA ;sort by division
  1. Q
  1. ;