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