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
Q
;
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
Q
;
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
Q
;
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)=""
Q
;
LINE(FLAG) ;prints double dash line
N LINE
I FLAG<1 F LINE=1:1:132 W "="
E F LINE=1:1:132 W "-"
Q
;
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),!
Q
;
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",!
Q
;
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)
Q
;
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,!
Q
;
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
Q
;
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")
Q
;
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")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPPDRP1 7942 printed Dec 13, 2024@02:50:48 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 ;
