DGPPOHUT ;SLC/RM - PRESUMPTIVE PSYCHOSIS OTHER THAN HONORABLE UTILITY ; February 25, 2021@1:00 pm
;;5.3;Registration;**1035**;Aug 13, 1993;Build 14
;
;Global References Supported by ICR# Type
;----------------- ----------------- ----------
; ^TMP($J SACC 2.3.2.5.1
;
;External References
;-------------------
; PSS^PSO59 4827 Supported
Q
;
REFILL(LIST) ;extract rx refill for this patient
N JJ,DGRFFILDT,DGDIV,DGSTA,DGSTANAME,DGLSTUSR,RXNCOPAY
I +$P(^TMP($J,LIST,DGDFN,DGRXIEN,"RF",0),U)>0 D
. F JJ=1:1:+$P(^TMP($J,LIST,DGDFN,DGRXIEN,"RF",0),U) D
. . ;only include Rx record that do not have charges in file #350. This is to avoid duplicates.
. . I +$G(^TMP($J,LIST,DGDFN,DGRXIEN,"IB",0))>0 D Q:'RXNCOPAY ;this is already handled by IBEFMSUT routine. No need to include this record here and to avoid duplicate record.
. . . S RXNCOPAY=0
. . . I $G(^TMP($J,LIST,DGDFN,DGRXIEN,"IB",JJ,9))="" S RXNCOPAY=1 ;include those rx refill not handled by IBEFSMUT. These are the rx with no copay.
. . S DGRFFILDT=^TMP($J,LIST,DGDFN,DGRXIEN,"RF",JJ,17) ;rx refill released date
. . I +DGRFFILDT<1,+$P(^TMP($J,LIST,DGDFN,DGRXIEN,"RF",JJ,14),U)>1 S DGRFFILDT=$P(^TMP($J,LIST,DGDFN,DGRXIEN,"RF",JJ,14),U) ;extract the RETURN TO STOCK date release date/time
. . I $G(DGPPFLGRPT)=1 S DGOTHREGDT=DGSORT("DGBEG"),DGELGDTV=DGSORT("DGEND") ;this for PP multiple report processing
. . ;check if the rx refill date is within the date range patient became OTH and when PE is verified
. . Q:'$$CHKDATE^DGOTHFSM(+DGRFFILDT\1,DGOTHREGDT,DGELGDTV)
. . S DGDIV=$P(^TMP($J,LIST,DGDFN,DGRXIEN,"RF",JJ,8),U) ;division ien
. . K ^TMP($J,"PSOSITERF") D PSS^PSO59(DGDIV,,"PSOSITERF") S DGSTA=$G(^TMP($J,"PSOSITERF",DGDIV,.06)) ;station number
. . S DGSTANAME=$P(^TMP($J,LIST,DGDFN,DGRXIEN,"RF",JJ,8),U,2) ;division name
. . S DGLSTUSR=$P(^TMP($J,LIST,DGDFN,DGRXIEN,"RF",JJ,4),U,2) ;pharmacist entered this rx
. . S DGLSTUSR=$S(DGLSTUSR="":"UNKNOWN",1:DGLSTUSR)
. . S DGENCNT=DGENCNT+1
. . S @RECORD@(+DGRFFILDT\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
K ^TMP($J,"PSOSITERF")
Q
;
PARTIAL(LIST) ;Extract Rx Partial Refill
N JJJ,DGPRTLRELDT,DGPRTLDIV,DGPRTLSTA,DGPRTLSTN,DGPRTLUSR,DGNUMOFREF,DGPRTLDSRF,DGCPTIER,DGPRTLFLDT,DATA1,DATA2,PTSTATUS
I $G(PPIBRX)!($G(OTHIBRX)) S JJJ=$P(RESULT,":",5) D PARTIAL1 Q
I DGPRTLTOT>0 D
. F JJJ=1:1:DGPRTLTOT D
. . I $G(DGPPFLGPRTL)=1,$D(^TMP($J,"DGPPDRX52","B",DGRXNUM,DGRXIEN,JJJ_"P")) Q
. . I $G(DGOTHFLGPRTL)=1,$D(^TMP($J,"OTHFSMR2","B",DGRXNUM,DGRXIEN,JJJ_"P")) Q
. . D PARTIAL1
Q
;
PARTIAL1 ;
S DGPRTLRELDT=$P($G(^TMP($J,LIST,DFN,DGRXIEN,"P",+JJJ,8)),U) ;Rx partial fill released date
I +DGPRTLRELDT<1,+$P(^TMP($J,LIST,DFN,DGRXIEN,"P",+JJJ,5),U)>1 S DGPRTLRELDT=$P(^TMP($J,LIST,DGDFN,DGRXIEN,"P",+JJJ,5),U)_"R" ;extract the Rx Partial Fill RETURN TO STOCK date
Q:'$$CHKDATE^DGOTHFSM(+DGPRTLRELDT\1,DGSORT("DGBEG"),DGSORT("DGEND"))
S DGPRTLDIV=+$P(^TMP($J,LIST,DFN,DGRXIEN,"P",+JJJ,.09),U) ;rx partial fill division ien
K ^TMP($J,"PSOSITERF") D PSS^PSO59(DGPRTLDIV,,"PSOSITERF") S DGPRTLSTA=$G(^TMP($J,"PSOSITERF",DGPRTLDIV,.06)) ;station number
I $G(DGOTHFLGPRTL)=1 D CPTIER^DGOTHFS3 ;extract the copay tier
I $G(DGPPFLGPRTL)=1 D CPTIER^DGPPDRP1 ;extract the copay tier
S DGNUMOFREF=$P(^TMP($J,LIST,DFN,DGRXIEN,9),U) ;# of refills
S DGPRTLDSRF=$P(^TMP($J,LIST,DFN,DGRXIEN,"P",+JJJ,.041),U) ;rx partial fill days supply
S DGPRTLSTN=$P(^TMP($J,LIST,DFN,DGRXIEN,"P",+JJJ,.09),U,2) ;rx partial fill division name
S DGPRTLUSR=$P(^TMP($J,LIST,DFN,DGRXIEN,"P",+JJJ,.05),U,2) ;pharmacist entered this rx partial fill
S DGPRTLFLDT=$P(^TMP($J,LIST,DFN,DGRXIEN,"P",+JJJ,.01),U) ;rx partial fill date
S DGPRTLUSR=$S(DGPRTLUSR="":"UNKNOWN",1:DGPRTLUSR)
I $G(DGPPFLGPRTL)=1 S PTSTATUS=$P(^TMP($J,"DGPPDRX52",DFN,DGRXIEN,3),U,2) ;Patient status
S DATA1=DGRXNUM_"("_+JJJ_")"_U_DGCPTIER_U_DGNUMOFREF_U_DGPRTLDSRF_U_DGPRTLSTA_U_DGPRTLFLDT_U_DGPRTLRELDT_"P"
I $G(OTHIBRX) D IBSTAT^DGOTHFS3 ;Extract the IB Status in File #350/File #399
I $G(PPIBRX) D IBSTAT^DGPPDRX
I $G(DGOTHFLGPRTL)=1 D ;for OTH partial rx recording
. I $P(DGSORT("SORTRXBY"),U)=1 S CNTR=CNTR+1,^TMP($J,"OTHFSMRX",+DGPRTLRELDT\1,DGPRTLSTA,DFN,DGRXNUM,CNTR)=DATA1_$S($G(OTHIBRX):U_DATA2,1:"")
. E S CNTR=CNTR+1,^TMP($J,"OTHFSMRX",DGPRTLSTA,+DGPRTLRELDT\1,DFN,DGRXNUM,CNTR)=DATA1_$S($G(OTHIBRX):U_DATA2,1:"")
. S DGPRTLRXFL=1,^TMP($J,"OTHFSMR2","B",DGRXNUM,DGRXIEN,+JJJ_"P")=""
I $G(DGPPFLGPRTL)=1 D ;for PP partial rx recording
. I $P(DGSORT("SORTRXBY"),U)=1 S CNTR=CNTR+1,^TMP($J,"DGALLPPDRX",DGRXNUM,+DGPRTLRELDT\1,DGPRTLSTA,DFN,CNTR)=DATA1_$S($G(PPIBRX):U_DATA2,1:"^^^^")_U_PTSTATUS
. E S CNTR=CNTR+1,^TMP($J,"DGALLPPDRX",DGRXNUM,DGPRTLSTA,+DGPRTLRELDT\1,DFN,CNTR)=DATA1_$S($G(PPIBRX):U_DATA2,1:"^^^^")_U_PTSTATUS
. S DGPPRXPRTLFL=1,^TMP($J,"DGPPDRX52","B",DGRXNUM,DGRXIEN,+JJJ_"P")=""
K ^TMP($J,"PSOSITERF")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPPOHUT 5069 printed Apr 09, 2024@21:49:20 Page 2
DGPPOHUT ;SLC/RM - PRESUMPTIVE PSYCHOSIS OTHER THAN HONORABLE UTILITY ; February 25, 2021@1:00 pm
+1 ;;5.3;Registration;**1035**;Aug 13, 1993;Build 14
+2 ;
+3 ;Global References Supported by ICR# Type
+4 ;----------------- ----------------- ----------
+5 ; ^TMP($J SACC 2.3.2.5.1
+6 ;
+7 ;External References
+8 ;-------------------
+9 ; PSS^PSO59 4827 Supported
+10 QUIT
+11 ;
REFILL(LIST) ;extract rx refill for this patient
+1 NEW JJ,DGRFFILDT,DGDIV,DGSTA,DGSTANAME,DGLSTUSR,RXNCOPAY
+2 IF +$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"RF",0),U)>0
Begin DoDot:1
+3 FOR JJ=1:1:+$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"RF",0),U)
Begin DoDot:2
+4 ;only include Rx record that do not have charges in file #350. This is to avoid duplicates.
+5 ;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,"IB",0))>0
Begin DoDot:3
+6 SET RXNCOPAY=0
+7 ;include those rx refill not handled by IBEFSMUT. These are the rx with no copay.
IF $GET(^TMP($JOB,LIST,DGDFN,DGRXIEN,"IB",JJ,9))=""
SET RXNCOPAY=1
End DoDot:3
if 'RXNCOPAY
QUIT
+8 ;rx refill released date
SET DGRFFILDT=^TMP($JOB,LIST,DGDFN,DGRXIEN,"RF",JJ,17)
+9 ;extract the RETURN TO STOCK date release date/time
IF +DGRFFILDT<1
IF +$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"RF",JJ,14),U)>1
SET DGRFFILDT=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"RF",JJ,14),U)
+10 ;this for PP multiple report processing
IF $GET(DGPPFLGRPT)=1
SET DGOTHREGDT=DGSORT("DGBEG")
SET DGELGDTV=DGSORT("DGEND")
+11 ;check if the rx refill date is within the date range patient became OTH and when PE is verified
+12 if '$$CHKDATE^DGOTHFSM(+DGRFFILDT\1,DGOTHREGDT,DGELGDTV)
QUIT
+13 ;division ien
SET DGDIV=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"RF",JJ,8),U)
+14 ;station number
KILL ^TMP($JOB,"PSOSITERF")
DO PSS^PSO59(DGDIV,,"PSOSITERF")
SET DGSTA=$GET(^TMP($JOB,"PSOSITERF",DGDIV,.06))
+15 ;division name
SET DGSTANAME=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"RF",JJ,8),U,2)
+16 ;pharmacist entered this rx
SET DGLSTUSR=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"RF",JJ,4),U,2)
+17 SET DGLSTUSR=$SELECT(DGLSTUSR="":"UNKNOWN",1:DGLSTUSR)
+18 SET DGENCNT=DGENCNT+1
+19 SET @RECORD@(+DGRFFILDT\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
End DoDot:2
End DoDot:1
+20 KILL ^TMP($JOB,"PSOSITERF")
+21 QUIT
+22 ;
PARTIAL(LIST) ;Extract Rx Partial Refill
+1 NEW JJJ,DGPRTLRELDT,DGPRTLDIV,DGPRTLSTA,DGPRTLSTN,DGPRTLUSR,DGNUMOFREF,DGPRTLDSRF,DGCPTIER,DGPRTLFLDT,DATA1,DATA2,PTSTATUS
+2 IF $GET(PPIBRX)!($GET(OTHIBRX))
SET JJJ=$PIECE(RESULT,":",5)
DO PARTIAL1
QUIT
+3 IF DGPRTLTOT>0
Begin DoDot:1
+4 FOR JJJ=1:1:DGPRTLTOT
Begin DoDot:2
+5 IF $GET(DGPPFLGPRTL)=1
IF $DATA(^TMP($JOB,"DGPPDRX52","B",DGRXNUM,DGRXIEN,JJJ_"P"))
QUIT
+6 IF $GET(DGOTHFLGPRTL)=1
IF $DATA(^TMP($JOB,"OTHFSMR2","B",DGRXNUM,DGRXIEN,JJJ_"P"))
QUIT
+7 DO PARTIAL1
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
PARTIAL1 ;
+1 ;Rx partial fill released date
SET DGPRTLRELDT=$PIECE($GET(^TMP($JOB,LIST,DFN,DGRXIEN,"P",+JJJ,8)),U)
+2 ;extract the Rx Partial Fill RETURN TO STOCK date
IF +DGPRTLRELDT<1
IF +$PIECE(^TMP($JOB,LIST,DFN,DGRXIEN,"P",+JJJ,5),U)>1
SET DGPRTLRELDT=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"P",+JJJ,5),U)_"R"
+3 if '$$CHKDATE^DGOTHFSM(+DGPRTLRELDT\1,DGSORT("DGBEG"),DGSORT("DGEND"))
QUIT
+4 ;rx partial fill division ien
SET DGPRTLDIV=+$PIECE(^TMP($JOB,LIST,DFN,DGRXIEN,"P",+JJJ,.09),U)
+5 ;station number
KILL ^TMP($JOB,"PSOSITERF")
DO PSS^PSO59(DGPRTLDIV,,"PSOSITERF")
SET DGPRTLSTA=$GET(^TMP($JOB,"PSOSITERF",DGPRTLDIV,.06))
+6 ;extract the copay tier
IF $GET(DGOTHFLGPRTL)=1
DO CPTIER^DGOTHFS3
+7 ;extract the copay tier
IF $GET(DGPPFLGPRTL)=1
DO CPTIER^DGPPDRP1
+8 ;# of refills
SET DGNUMOFREF=$PIECE(^TMP($JOB,LIST,DFN,DGRXIEN,9),U)
+9 ;rx partial fill days supply
SET DGPRTLDSRF=$PIECE(^TMP($JOB,LIST,DFN,DGRXIEN,"P",+JJJ,.041),U)
+10 ;rx partial fill division name
SET DGPRTLSTN=$PIECE(^TMP($JOB,LIST,DFN,DGRXIEN,"P",+JJJ,.09),U,2)
+11 ;pharmacist entered this rx partial fill
SET DGPRTLUSR=$PIECE(^TMP($JOB,LIST,DFN,DGRXIEN,"P",+JJJ,.05),U,2)
+12 ;rx partial fill date
SET DGPRTLFLDT=$PIECE(^TMP($JOB,LIST,DFN,DGRXIEN,"P",+JJJ,.01),U)
+13 SET DGPRTLUSR=$SELECT(DGPRTLUSR="":"UNKNOWN",1:DGPRTLUSR)
+14 ;Patient status
IF $GET(DGPPFLGPRTL)=1
SET PTSTATUS=$PIECE(^TMP($JOB,"DGPPDRX52",DFN,DGRXIEN,3),U,2)
+15 SET DATA1=DGRXNUM_"("_+JJJ_")"_U_DGCPTIER_U_DGNUMOFREF_U_DGPRTLDSRF_U_DGPRTLSTA_U_DGPRTLFLDT_U_DGPRTLRELDT_"P"
+16 ;Extract the IB Status in File #350/File #399
IF $GET(OTHIBRX)
DO IBSTAT^DGOTHFS3
+17 IF $GET(PPIBRX)
DO IBSTAT^DGPPDRX
+18 ;for OTH partial rx recording
IF $GET(DGOTHFLGPRTL)=1
Begin DoDot:1
+19 IF $PIECE(DGSORT("SORTRXBY"),U)=1
SET CNTR=CNTR+1
SET ^TMP($JOB,"OTHFSMRX",+DGPRTLRELDT\1,DGPRTLSTA,DFN,DGRXNUM,CNTR)=DATA1_$SELECT($GET(OTHIBRX):U_DATA2,1:"")
+20 IF '$TEST
SET CNTR=CNTR+1
SET ^TMP($JOB,"OTHFSMRX",DGPRTLSTA,+DGPRTLRELDT\1,DFN,DGRXNUM,CNTR)=DATA1_$SELECT($GET(OTHIBRX):U_DATA2,1:"")
+21 SET DGPRTLRXFL=1
SET ^TMP($JOB,"OTHFSMR2","B",DGRXNUM,DGRXIEN,+JJJ_"P")=""
End DoDot:1
+22 ;for PP partial rx recording
IF $GET(DGPPFLGPRTL)=1
Begin DoDot:1
+23 IF $PIECE(DGSORT("SORTRXBY"),U)=1
SET CNTR=CNTR+1
SET ^TMP($JOB,"DGALLPPDRX",DGRXNUM,+DGPRTLRELDT\1,DGPRTLSTA,DFN,CNTR)=DATA1_$SELECT($GET(PPIBRX):U_DATA2,1:"^^^^")_U_PTSTATUS
+24 IF '$TEST
SET CNTR=CNTR+1
SET ^TMP($JOB,"DGALLPPDRX",DGRXNUM,DGPRTLSTA,+DGPRTLRELDT\1,DFN,CNTR)=DATA1_$SELECT($GET(PPIBRX):U_DATA2,1:"^^^^")_U_PTSTATUS
+25 SET DGPPRXPRTLFL=1
SET ^TMP($JOB,"DGPPDRX52","B",DGRXNUM,DGRXIEN,+JJJ_"P")=""
End DoDot:1
+26 KILL ^TMP($JOB,"PSOSITERF")
+27 QUIT
+28 ;
