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 Nov 22, 2024@17:56:50 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 ;
