Routine: DGPPDRP1

DGPPDRP1 ;SLC/RM - PRESUMPTIVE PSYCHOSIS DETAIL REPORT CONTINUATION ; Dec 21, 2020@10:00 am

 ;;5.3;Registration;**1035**;Aug 13, 1993;Build 14

 ;External References    Supported by ICR#    Type

 ;-------------------    -----------------    ---------

 ; $$GET1^DIQ             2056                Supported

 ; ^DIR                  10026                Supported

 ; $$CPTIER^PSNAPIS       2531                Supported

 ; PSS^PSO59              4827                Supported

 ; NDF^PSS50              4533                Supported

 ; 2^VADPT               10061                Supported

 ; $$FMTE^XLFDT          10103                Supported

PRNTENC(TMPDATA,ENCDT) ;continuation of ENCTR tag found in DGOTHFS2

 N RECNUM,RSLTFRMOE,TRUE,AMOUNT

 S TRUE=0

 I $Y>(IOSL-4) W ! D PAUSE(.DGQ) Q:DGQ  D PTHDR,LINE(0),ENCHDR(1),ENCTRCOL,LINE(1)

 I FILENO=350!(FILENO=399) D

 . S AMOUNT=0

 . I OLDBILL'=NWBILL S TRUE=1 D DSPLAY

 . I OLDBILL=NWBILL,OLDOEDT'=DGPPDOS S TRUE=1 D DSPLAY

 . I 'TRUE  W !

 . I FILENO=350 D

 . . W ?73,$E($P(TMPDATA,U,7),1,15) ;charge type

 . . W ?89,$S(NWBILL=0:"",1:NWBILL) ;bill no

 . . S AMOUNT=$$DOLLAR^DGPPRRPT($TR($P(TMPDATA,U,12),"$(),","")) ;format the charge amount

 . . W ?102,$J($TR(AMOUNT,"$()",""),14) ;charge amount

 . . W ?116,$E($P(TMPDATA,U,13),1,15) ;IB status

 . I FILENO=399 D

 . . W ?73,$E($P(TMPDATA,U,9),1,15) ;rate type

 . . W ?89,$S(NWBILL=0:"",1:NWBILL) ;bill no

 . . S AMOUNT=$$DOLLAR^DGPPRRPT($P(TMPDATA,U,13)) ;format the charge amount

 . . W ?102,$J($TR(AMOUNT,"$()",""),14) ;charge amount

 . . W ?116,$E($P(TMPDATA,U,14),1,15) ;IB status

 E  D

 . D DSPLAY

 . S TRUE=0

 . I $O(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,""))'="" D

 . . S RECNUM="" F  S RECNUM=$O(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM)) Q:RECNUM=""  D

 . . . I TRUE W !

 . . . S AMOUNT=0

 . . . S RSLTFRMOE=$P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,5)

 . . . I $P(RSLTFRMOE,":")=405!($P(RSLTFRMOE,":")=409.68)!($P(RSLTFRMOE,":")=45) W ?73,$E($P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U),1,15) ;charge type from file #350

 . . . E  W ?73,$E($P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,2),1,15) ;rate type from file #399

 . . . W ?89,$P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,4) ;bill no

 . . . S AMOUNT=$$DOLLAR^DGPPRRPT($TR($P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,6),"$(),","")) ;format the charge amount

 . . . W ?102,$J($TR(AMOUNT,"$()",""),14) ;copay amount

 . . . W ?116,$E($P(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,7),1,15) ;IB status

 . . . I $D(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT+1)),'PRNTSEC D  Q  ;this means the record has secondary stop code

 . . . . S TMPDATA=@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT+1)

 . . . . W !,?20,$E($P(TMPDATA,U,4),1,18) S TRUE=0,PRNTSEC=1 ;display the secondary stop code first before displaying the other statuses

 . . . S TRUE=1 ;this flag determine when to write a new line

DSPLAY ;display episode of care data

 N DGAPPTYP,DGEOIEN

 I FILENO=409.68,$P(TMPDATA,U,10)'=1 D  Q  ;this means that the record belongs to a secondary stop code, as per business owner, only display the stop code name and leave out the rest

 . I 'PRNTSEC D

 . . I $D(OUTPATARY($P(TMPDATA,U,3),ENCDT\1)) W !,?20,$E($P(TMPDATA,U,4),1,18) Q

 . . D DSPLAY1

 . S PRNTSEC=0

 I FILENO=405,$P(TMPDATA,U,10)>1 D  Q   ;this means that the record belongs to a secondary stop code (inpatient outpatient encounter)

 . I $O(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,""))="" W !,?20,$E($P(TMPDATA,U,4),1,18)

 D DSPLAY1

 S DGTOTENC=DGTOTENC+1

DSPLAY1 ;

 W !,$E($P(TMPDATA,U,3),1,18) ;clinic name/Location of care

 W ?20,$E($P(TMPDATA,U,4),1,18) ;clinic stop code/treating specialty

 I FILENO=350!(FILENO=399) W ?40,"N/A" ;Primary/Principal diagnosis

 I FILENO=409.68 W ?40,$P(TMPDATA,U,9) ;Primary/Principal diagnosis

 I FILENO=405 W ?40,$S($P(TMPDATA,U,9)'="":$P(TMPDATA,U,9),1:$P(TMPDATA,U,8)) ;Primary/Principal diagnosis

 W ?50,$$FMTE^XLFDT(ENCDT\1,"5ZF") ;Appt. Date/Time or Date of Service

 S DGEOIEN=$P(TMPDATA,U,7)

 S DGAPPTYP=$$GET1^DIQ(409.68,DGEOIEN_",",.1,"E")

 S DGAPPTYP=$S(DGAPPTYP'="":DGAPPTYP,1:"N/A")

 ;Appointment type

 I DGAPPTYP="COMPENSATION & PENSION" S DGAPPTYP="COMP & PEN"

 I DGAPPTYP="CLASS II DENTAL" S DGAPPTYP="CLASS II"

 I DGAPPTYP="ORGAN DONORS" S DGAPPTYP="ORGAN DONOR"

 I DGAPPTYP="SHARING AGREEMENT" S DGAPPTYP="SHARING AG"

 I DGAPPTYP="COLLATERAL OF VET." S DGAPPTYP="COLLATERAL"

 I DGAPPTYP="COMPUTER GENERATED" S DGAPPTYP="COMPUTER"

 I DGAPPTYP="SERVICE CONNECTED" S DGAPPTYP="SERVICE CON"

 W ?61,$E(DGAPPTYP,1,10) ;appointment type

 S OUTPATARY($P(TMPDATA,U,3),ENCDT\1)=""

LINE(FLAG) ;prints double dash line

 N LINE

 I FLAG<1 F LINE=1:1:132 W "="

 E  F LINE=1:1:132 W "-"

PTHDR(TITLE) ;patient name and DOB header

 S TITLE=$G(TITLE)

 I $G(TRM)!('$G(TRM)&DGPAGE) W @IOF

 I $L(TITLE) W ?132-$L(TITLE)\2,TITLE W !

 S DGPAGE=$G(DGPAGE)+1

 I '$D(VADM) D 2^VADPT

 W "Patient Name:  ",DGPTNM_"  ("_DGPID_")",?112,"DOB:  ",$P(VADM(3),U,2),!

ENCTRCOL ;display encounter column name

 W !,"Location of",?20,"Stop Code Name/",?40,"Primary",?50,"Date of",?61,"Appt. Type",?73,"Charge Type/",?89,"Bill #",?102,"Charge Amount",?116,"IB Status"

 W !,"Care",?20,"Treating Specialty",?40,"DX",?50,"Service",?73,"Rate Type",!

ENCHDR(FLAG) ;Encounter Header

 N TITLE

 S TITLE="PATIENT'S EPISODE OF CARE"_$S(FLAG:" - Continuation",1:"")

 W !,?132-$L(TITLE)\2,TITLE,!

 D DTRANGE

 D LINE(1)

DTRANGE ;display date range

 N DTRANGE

 S DTRANGE="Date Range: "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" - "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")

 W ?132-$L(DTRANGE)\2,DTRANGE,!

PAUSE(DGQ) ; pause screen display

N J

 I $Y<(IOSL-4) D

 . F J=1:1 Q:($Y>(24-4))  W !

 I $G(DGPAGE)>0,TRM,$$E("Press <Enter> to continue or '^' to exit:")<1 S DGQ=1

E(MSG) ; ----- ask user to press enter to continue

 ;  Return: -2:Time-out; -1:'^'-out  1:anything else

 S MSG=$G(MSG)

 N X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT

 S DIR(0)="EA"

 I $L(MSG) S DIR("A")=MSG

 D ^DIR

 S X=$S($D(DTOUT):-2,$D(DUOUT):-1,1:1)

Q X

PARTIAL(LIST) ;extract rx partial fill for this patient

 N JJJ,DGPRTLDT,DGPRTLDIV,DGPRTLSTA,DGPRTLSTN,DGPRTLUSR,DGPRTLTOT

 S DGPRTLTOT=$P(^TMP($J,LIST,DGDFN,DGRXIEN,"P",0),U) ;total rx partial fill entry/record

 I DGPRTLTOT>0 D

 . F JJJ=1:1:DGPRTLTOT D

 . . S DGPRTLDT=$P($G(^TMP($J,LIST,DGDFN,DGRXIEN,"P",JJJ,8)),U) ;Rx partial fill released date

 . . I +DGPRTLDT<1,+$P(^TMP($J,LIST,DGDFN,DGRXIEN,"P",JJJ,5),U)>1 S DGPRTLDT=+$P(^TMP($J,LIST,DGDFN,DGRXIEN,"P",JJJ,5),U) ;extract the Rx Partial Fill RETURN TO STOCK date

 . . Q:'$$CHKDATE^DGOTHFSM(+DGPRTLDT\1,DGOTHREGDT,DGELGDTV)

 . . S DGPRTLDIV=+$P(^TMP($J,LIST,DGDFN,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

 . . S DGPRTLSTN=$P(^TMP($J,LIST,DGDFN,DGRXIEN,"P",JJJ,.09),U,2) ;rx partial fill division name

 . . S DGPRTLUSR=$P(^TMP($J,LIST,DGDFN,DGRXIEN,"P",JJJ,.05),U,2) ;pharmacist entered this rx partial fill

 . . S DGPRTLUSR=$S(DGPRTLUSR="":"UNKNOWN",1:DGPRTLUSR)

 . . S DGENCNT=DGENCNT+1

 . . S @RECORD@(+DGPRTLDT\1,DGPRTLSTA,52,DGENCNT)=DGPRTLSTN_U_DGPRTLSTA_U_$S(DGCLNC'="":DGCLNC,1:"NON-VA")_U_"N/A"_U_DGPRTLUSR_U_DGPRTLDIV_U_"RX - "_DGRXNUM_":"_DGRXIEN

 K ^TMP($J,"PSOSITERF")

CPTIER ;extract Rx Copay Tier

 N DGDRUGIEN

 K ^TMP($J,"OTHCPTIER"),DGCPTIER

 S DGDRUGIEN=$P(^TMP($J,"DGPPDRX52",DFN,DGRXIEN,6),U)

 D NDF^PSS50(DGDRUGIEN,"","","","","OTHCPTIER")

 ;look up the tier of the prescription

 ;returns the tier level of the specified prescription

 ;default tier is always 2

 S DGCPTIER=$P(^TMP($J,"OTHCPTIER",DGDRUGIEN,20),U)

 S DGCPTIER=$S(DGCPTIER:$P($$CPTIER^PSNAPIS(DGCPTIER,DT,DGDRUGIEN,1),U),1:2)

 K ^TMP($J,"OTHCPTIER")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPPDRP1   7942     printed  Mar 13, 2025@21:55:32                                                                                                                                                                                                    Page 2

DGPPDRP1  ;SLC/RM - PRESUMPTIVE PSYCHOSIS DETAIL REPORT CONTINUATION ; Dec 21, 2020@10:00 am

 +1       ;;5.3;Registration;**1035**;Aug 13, 1993;Build 14

 +2       ;

 +3       ;External References    Supported by ICR#    Type

 +4       ;-------------------    -----------------    ---------

 +5       ; $$GET1^DIQ             2056                Supported

 +6       ; ^DIR                  10026                Supported

 +7       ; $$CPTIER^PSNAPIS       2531                Supported

 +8       ; PSS^PSO59              4827                Supported

 +9       ; NDF^PSS50              4533                Supported

 +10      ; 2^VADPT               10061                Supported

 +11      ; $$FMTE^XLFDT          10103                Supported

 +12       QUIT

 +13      ;

PRNTENC(TMPDATA,ENCDT) ;continuation of ENCTR tag found in DGOTHFS2

 +1        NEW RECNUM,RSLTFRMOE,TRUE,AMOUNT

 +2        SET TRUE=0

 +3        IF $Y>(IOSL-4)

               WRITE !

               DO PAUSE(.DGQ)

               if DGQ

                   QUIT

               DO PTHDR

               DO LINE(0)

               DO ENCHDR(1)

               DO ENCTRCOL

               DO LINE(1)

 +4        IF FILENO=350!(FILENO=399)

               Begin DoDot:1

 +5                SET AMOUNT=0

 +6                IF OLDBILL'=NWBILL

                       SET TRUE=1

                       DO DSPLAY

 +7                IF OLDBILL=NWBILL

                       IF OLDOEDT'=DGPPDOS

                           SET TRUE=1

                           DO DSPLAY

 +8                IF 'TRUE

                       WRITE !

 +9                IF FILENO=350

                       Begin DoDot:2

 +10      ;charge type

                           WRITE ?73,$EXTRACT($PIECE(TMPDATA,U,7),1,15)

 +11      ;bill no

                           WRITE ?89,$SELECT(NWBILL=0:"",1:NWBILL)

 +12      ;format the charge amount

                           SET AMOUNT=$$DOLLAR^DGPPRRPT($TRANSLATE($PIECE(TMPDATA,U,12),"$(),",""))

 +13      ;charge amount

                           WRITE ?102,$JUSTIFY($TRANSLATE(AMOUNT,"$()",""),14)

 +14      ;IB status

                           WRITE ?116,$EXTRACT($PIECE(TMPDATA,U,13),1,15)

                       End DoDot:2

 +15               IF FILENO=399

                       Begin DoDot:2

 +16      ;rate type

                           WRITE ?73,$EXTRACT($PIECE(TMPDATA,U,9),1,15)

 +17      ;bill no

                           WRITE ?89,$SELECT(NWBILL=0:"",1:NWBILL)

 +18      ;format the charge amount

                           SET AMOUNT=$$DOLLAR^DGPPRRPT($PIECE(TMPDATA,U,13))

 +19      ;charge amount

                           WRITE ?102,$JUSTIFY($TRANSLATE(AMOUNT,"$()",""),14)

 +20      ;IB status

                           WRITE ?116,$EXTRACT($PIECE(TMPDATA,U,14),1,15)

                       End DoDot:2

               End DoDot:1

 +21      IF '$TEST

               Begin DoDot:1

 +22               DO DSPLAY

 +23               SET TRUE=0

 +24               IF $ORDER(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,""))'=""

                       Begin DoDot:2

 +25                       SET RECNUM=""

FOR

                               SET RECNUM=$ORDER(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM))

                               if RECNUM=""

                                   QUIT

                               Begin DoDot:3

 +26                               IF TRUE

                                       WRITE !

 +27                               SET AMOUNT=0

 +28                               SET RSLTFRMOE=$PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,5)

 +29      ;charge type from file #350

                                   IF $PIECE(RSLTFRMOE,":")=405!($PIECE(RSLTFRMOE,":")=409.68)!($PIECE(RSLTFRMOE,":")=45)

                                       WRITE ?73,$EXTRACT($PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U),1,15)

 +30      ;rate type from file #399

                                  IF '$TEST

                                       WRITE ?73,$EXTRACT($PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,2),1,15)

 +31      ;bill no

                                   WRITE ?89,$PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,4)

 +32      ;format the charge amount

                                   SET AMOUNT=$$DOLLAR^DGPPRRPT($TRANSLATE($PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,6),"$(),",""))

 +33      ;copay amount

                                   WRITE ?102,$JUSTIFY($TRANSLATE(AMOUNT,"$()",""),14)

 +34      ;IB status

                                   WRITE ?116,$EXTRACT($PIECE(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,RECNUM),U,7),1,15)

 +35      ;this means the record has secondary stop code

                                   IF $DATA(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT+1))

                                       IF 'PRNTSEC

                                           Begin DoDot:4

 +36                                           SET TMPDATA=@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT+1)

 +37      ;display the secondary stop code first before displaying the other statuses

                                               WRITE !,?20,$EXTRACT($PIECE(TMPDATA,U,4),1,18)

                                               SET TRUE=0

                                               SET PRNTSEC=1

                                           End DoDot:4

                                           QUIT

 +38      ;this flag determine when to write a new line

                                   SET TRUE=1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +39       QUIT

 +40      ;

DSPLAY    ;display episode of care data

 +1        NEW DGAPPTYP,DGEOIEN

 +2       ;this means that the record belongs to a secondary stop code, as per business owner, only display the stop code name and leave out the rest

           IF FILENO=409.68

               IF $PIECE(TMPDATA,U,10)'=1

                   Begin DoDot:1

 +3                    IF 'PRNTSEC

                           Begin DoDot:2

 +4                            IF $DATA(OUTPATARY($PIECE(TMPDATA,U,3),ENCDT\1))

                                   WRITE !,?20,$EXTRACT($PIECE(TMPDATA,U,4),1,18)

                                   QUIT

 +5                            DO DSPLAY1

                           End DoDot:2

 +6                    SET PRNTSEC=0

                   End DoDot:1

                   QUIT

 +7       ;this means that the record belongs to a secondary stop code (inpatient outpatient encounter)

           IF FILENO=405

               IF $PIECE(TMPDATA,U,10)>1

                   Begin DoDot:1

 +8                    IF $ORDER(@RECORD@(DGPPDOS,DGPPDIV,FILENO,RECNT,""))=""

                           WRITE !,?20,$EXTRACT($PIECE(TMPDATA,U,4),1,18)

                   End DoDot:1

                   QUIT

 +9        DO DSPLAY1

 +10       SET DGTOTENC=DGTOTENC+1

 +11       QUIT

 +12      ;

DSPLAY1   ;

 +1       ;clinic name/Location of care

           WRITE !,$EXTRACT($PIECE(TMPDATA,U,3),1,18)

 +2       ;clinic stop code/treating specialty

           WRITE ?20,$EXTRACT($PIECE(TMPDATA,U,4),1,18)

 +3       ;Primary/Principal diagnosis

           IF FILENO=350!(FILENO=399)

               WRITE ?40,"N/A"

 +4       ;Primary/Principal diagnosis

           IF FILENO=409.68

               WRITE ?40,$PIECE(TMPDATA,U,9)

 +5       ;Primary/Principal diagnosis

           IF FILENO=405

               WRITE ?40,$SELECT($PIECE(TMPDATA,U,9)'="":$PIECE(TMPDATA,U,9),1:$PIECE(TMPDATA,U,8))

 +6       ;Appt. Date/Time or Date of Service

           WRITE ?50,$$FMTE^XLFDT(ENCDT\1,"5ZF")

 +7        SET DGEOIEN=$PIECE(TMPDATA,U,7)

 +8        SET DGAPPTYP=$$GET1^DIQ(409.68,DGEOIEN_",",.1,"E")

 +9        SET DGAPPTYP=$SELECT(DGAPPTYP'="":DGAPPTYP,1:"N/A")

 +10      ;Appointment type

 +11       IF DGAPPTYP="COMPENSATION & PENSION"

               SET DGAPPTYP="COMP & PEN"

 +12       IF DGAPPTYP="CLASS II DENTAL"

               SET DGAPPTYP="CLASS II"

 +13       IF DGAPPTYP="ORGAN DONORS"

               SET DGAPPTYP="ORGAN DONOR"

 +14       IF DGAPPTYP="SHARING AGREEMENT"

               SET DGAPPTYP="SHARING AG"

 +15       IF DGAPPTYP="COLLATERAL OF VET."

               SET DGAPPTYP="COLLATERAL"

 +16       IF DGAPPTYP="COMPUTER GENERATED"

               SET DGAPPTYP="COMPUTER"

 +17       IF DGAPPTYP="SERVICE CONNECTED"

               SET DGAPPTYP="SERVICE CON"

 +18      ;appointment type

           WRITE ?61,$EXTRACT(DGAPPTYP,1,10)

 +19       SET OUTPATARY($PIECE(TMPDATA,U,3),ENCDT\1)=""

 +20       QUIT

 +21      ;

LINE(FLAG) ;prints double dash line

 +1        NEW LINE

 +2        IF FLAG<1

               FOR LINE=1:1:132

                   WRITE "="

 +3       IF '$TEST

               FOR LINE=1:1:132

                   WRITE "-"

 +4        QUIT

 +5       ;

PTHDR(TITLE) ;patient name and DOB header

 +1        SET TITLE=$GET(TITLE)

 +2        IF $GET(TRM)!('$GET(TRM)&DGPAGE)

               WRITE @IOF

 +3        IF $LENGTH(TITLE)

               WRITE ?132-$LENGTH(TITLE)\2,TITLE

               WRITE !

 +4        SET DGPAGE=$GET(DGPAGE)+1

 +5        IF '$DATA(VADM)

               DO 2^VADPT

 +6        WRITE "Patient Name:  ",DGPTNM_"  ("_DGPID_")",?112,"DOB:  ",$PIECE(VADM(3),U,2),!

 +7        QUIT

 +8       ;

ENCTRCOL  ;display encounter column name

 +1        WRITE !,"Location of",?20,"Stop Code Name/",?40,"Primary",?50,"Date of",?61,"Appt. Type",?73,"Charge Type/",?89,"Bill #",?102,"Charge Amount",?116,"IB Status"

 +2        WRITE !,"Care",?20,"Treating Specialty",?40,"DX",?50,"Service",?73,"Rate Type",!

 +3        QUIT

 +4       ;

ENCHDR(FLAG) ;Encounter Header

 +1        NEW TITLE

 +2        SET TITLE="PATIENT'S EPISODE OF CARE"_$SELECT(FLAG:" - Continuation",1:"")

 +3        WRITE !,?132-$LENGTH(TITLE)\2,TITLE,!

 +4        DO DTRANGE

 +5        DO LINE(1)

 +6        QUIT

 +7       ;

DTRANGE   ;display date range

 +1        NEW DTRANGE

 +2        SET DTRANGE="Date Range: "_$$FMTE^XLFDT(DGSORT("DGBEG"),"5ZF")_" - "_$$FMTE^XLFDT(DGSORT("DGEND"),"5ZF")

 +3        WRITE ?132-$LENGTH(DTRANGE)\2,DTRANGE,!

 +4        QUIT

 +5       ;

PAUSE(DGQ) ; pause screen display

 +1        NEW J

 +2        IF $Y<(IOSL-4)

               Begin DoDot:1

 +3                FOR J=1:1

                       if ($Y>(24-4))

                           QUIT

                       WRITE !

               End DoDot:1

 +4        IF $GET(DGPAGE)>0

               IF TRM

                   IF $$E("Press <Enter> to continue or '^' to exit:")<1

                       SET DGQ=1

 +5        QUIT

 +6       ;

E(MSG)    ; ----- ask user to press enter to continue

 +1       ;  Return: -2:Time-out; -1:'^'-out  1:anything else

 +2        SET MSG=$GET(MSG)

 +3        NEW X,Y,Z,DIR,DIROUT,DIRUT,DTOUT,DUOUT

 +4        SET DIR(0)="EA"

 +5        IF $LENGTH(MSG)

               SET DIR("A")=MSG

 +6        DO ^DIR

 +7        SET X=$SELECT($DATA(DTOUT):-2,$DATA(DUOUT):-1,1:1)

 +8        QUIT X

 +9       ;

PARTIAL(LIST) ;extract rx partial fill for this patient

 +1        NEW JJJ,DGPRTLDT,DGPRTLDIV,DGPRTLSTA,DGPRTLSTN,DGPRTLUSR,DGPRTLTOT

 +2       ;total rx partial fill entry/record

           SET DGPRTLTOT=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"P",0),U)

 +3        IF DGPRTLTOT>0

               Begin DoDot:1

 +4                FOR JJJ=1:1:DGPRTLTOT

                       Begin DoDot:2

 +5       ;Rx partial fill released date

                           SET DGPRTLDT=$PIECE($GET(^TMP($JOB,LIST,DGDFN,DGRXIEN,"P",JJJ,8)),U)

 +6       ;extract the Rx Partial Fill RETURN TO STOCK date

                           IF +DGPRTLDT<1

                               IF +$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"P",JJJ,5),U)>1

                                   SET DGPRTLDT=+$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"P",JJJ,5),U)

 +7                        if '$$CHKDATE^DGOTHFSM(+DGPRTLDT\1,DGOTHREGDT,DGELGDTV)

                               QUIT

 +8       ;rx partial fill division ien

                           SET DGPRTLDIV=+$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"P",JJJ,.09),U)

 +9       ;station number

                           KILL ^TMP($JOB,"PSOSITERF")

                           DO PSS^PSO59(DGPRTLDIV,,"PSOSITERF")

                           SET DGPRTLSTA=$GET(^TMP($JOB,"PSOSITERF",DGPRTLDIV,.06))

 +10      ;rx partial fill division name

                           SET DGPRTLSTN=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"P",JJJ,.09),U,2)

 +11      ;pharmacist entered this rx partial fill

                           SET DGPRTLUSR=$PIECE(^TMP($JOB,LIST,DGDFN,DGRXIEN,"P",JJJ,.05),U,2)

 +12                       SET DGPRTLUSR=$SELECT(DGPRTLUSR="":"UNKNOWN",1:DGPRTLUSR)

 +13                       SET DGENCNT=DGENCNT+1

 +14                       SET @RECORD@(+DGPRTLDT\1,DGPRTLSTA,52,DGENCNT)=DGPRTLSTN_U_DGPRTLSTA_U_$SELECT(DGCLNC'="":DGCLNC,1:"NON-VA")_U_"N/A"_U_DGPRTLUSR_U_DGPRTLDIV_U_"RX - "_DGRXNUM_":"_DGRXIEN

                       End DoDot:2

               End DoDot:1

 +15       KILL ^TMP($JOB,"PSOSITERF")

 +16       QUIT

 +17      ;

CPTIER    ;extract Rx Copay Tier

 +1        NEW DGDRUGIEN

 +2        KILL ^TMP($JOB,"OTHCPTIER"),DGCPTIER

 +3        SET DGDRUGIEN=$PIECE(^TMP($JOB,"DGPPDRX52",DFN,DGRXIEN,6),U)

 +4        DO NDF^PSS50(DGDRUGIEN,"","","","","OTHCPTIER")

 +5       ;look up the tier of the prescription

 +6       ;returns the tier level of the specified prescription

 +7       ;default tier is always 2

 +8        SET DGCPTIER=$PIECE(^TMP($JOB,"OTHCPTIER",DGDRUGIEN,20),U)

 +9        SET DGCPTIER=$SELECT(DGCPTIER:$PIECE($$CPTIER^PSNAPIS(DGCPTIER,DT,DGDRUGIEN,1),U),1:2)

 +10       KILL ^TMP($JOB,"OTHCPTIER")

 +11       QUIT

 +12      ;

DGPPDRP1.m