RMPORPD ;(NG)/DG/CAP/HINES CIOFO/HNC -PRESCRIPTION EXPIRE DATE ACTIVE PATIENTS ; 5/19/00 9:12am
;;3.0;PROSTHETICS;**29,46,49,179,207**;Feb 09, 1996;Build 15
;
;RMPR*3.0*179 Check for deceased patients. Add to report by
; displaying asterisk (*) if patient deceased.
;RMPR*3.0*207 Ensure the script expiration displays correct
; dates even though script edit/add could be back dated.
;
SITE ; Set up the site variables.
D HOSITE^RMPOUTL0 Q:'$D(RMPOXITE)
;
LI ; List the sought patient.
N WHO S WHO=0,RMPODCNT=0
S (RMEND,RMPORPT,PAGE,COUNT)=0
D NOW^%DTC S Y=% X ^DD("DD")
S RPTDT=$P(Y,"@",1)_" "_$P($P(Y,"@",2),":",1,2)
;
S DIC="^RMPR(665,"
S BY(0)="^TMP(""RMPO"",$J,",L(0)=3,L=0,FR=""
S DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,D0,""RMPOA"")),U,2)'="""",$P($G(^RMPR(665,D0,""RMPOA"")),U,3)="""""
S DHIT="D CNT^RMPORPD"
S DHD="W ?0 D RPTHDR^RMPORPD"
S DIOEND="I $G(Y)'[U D DIOEND^RMPORPD S RMEND=1 S:IOST[""P-"" RMPORPT=1"
S FLDS="W $$RXDT^RMPORPD();C1;L11"
S FLDS(1)=".01;C12;L22"
S FLDS(2)="W $$SSN^RMPORPD();C36;L4"
S FLDS(3)="W $$PITEM^RMPORPD();C41;L30"
S FLDS(4)="W $$ACTDT^RMPORPD();C73;L8"
D PRESORT,EN1^DIP
I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
;
EXIT ;
K ^TMP("RMPO",$J) N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
;
ACTDT() ;*** ACTIVATION DATE
S X=$P($G(^RMPR(665,D0,"RMPOA")),U,2)
S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
Q X
;
CNT ;*** COUNT NAMES
I WHO'=D0 S COUNT=COUNT+1
S WHO=D0
Q
;
;*** CONVERT DATE FROM FILEMAN FORMAT TO MM/DD/YYYY
DATE(FMD) ; RMPR*3.0*179 Flag a deceased patient by attaching an '*' to SSN. ^PT(D0,.35) direct read supported by ICR #10035
N RMPOEXP S RMPOEXP=" " I +$G(^DPT(D0,.35)) S RMPOEXP="*",RMPODCNT=RMPODCNT+1
Q $E(FMD,4,5)_"/"_$E(FMD,6,7)_"/"_($E(FMD,1,3)+1700)_RMPOEXP
;
PITEM() ;*** GET PRIMARY ITEM AND ACTIVATION DATE
N PITM,E
S (E,PITM)=0,X=""
F S PITM=$O(^RMPR(665,D0,"RMPOC",PITM)) Q:'PITM D Q:E
. S PDT=^RMPR(665,D0,"RMPOC",PITM,0)
. Q:$P(PDT,U,11)'="Y"
. S X=$P(PDT,U),X=$P(^RMPR(661,X,0),U)
. S X=$P($G(^PRC(441,X,0)),U,2)
. S X=$E(X,1,30),E=1
Q X
;
PRESORT ;*** SORT BY EXPIRATION DATE
N D0,D2,DFN
K ^TMP("RMPO",$J)
S D2=0
F S D2=$O(^RMPR(665,"AHO",D2)) Q:'D2 S D0="" D
. F S D0=$O(^RMPR(665,"AHO",D2,D0)) Q:D0="" D
. . K VAPA,VADM S DFN=D0 D ^VADPT
. . S ^TMP("RMPO",$J,$$RXDT(1),VADM(1),D0)=""
Q
;
RPTHDR ;*** REPORT HEADER
N RA S RA=RMPO("NAME"),PAGE=PAGE+1
W RPTDT,?(40-($L(RA)/2)),RA,?68,"Page: "_PAGE
W !?20,"Prescription Expiration Date",!,"Date Current",?55,"'*' patient is deceased",!,"Prescription" ;RMPR*3.0*179
W !?1,"Expires",?11,"Name",?35,"SSN",?41,"Primary Item",?73,"Active"
W !,"==========",?11,"=======================",?35,"====",?41,"==============================",?72,"========",!
Q
;
;*** EXPIRATION DATE OF CURRENT RX
; MODE Date format: 0 - MM/DD/YYYY or "N/A" (default)
; 1 - YYYMMDD or "N/A"
RXDT(MODE) ;Rewrite latest expiration date determination RMPR*3.0*207
N RMPRDA,RMPRDT,RMPRDAT S (RMPRDA,RMPRDT)=0
F S RMPRDA=$O(^RMPR(665,D0,"RMPOB",RMPRDA)) Q:'RMPRDA D
. S RMPRDAT=$P(^RMPR(665,D0,"RMPOB",RMPRDA,0),U,3) I RMPRDAT>RMPRDT S RMPRDT=RMPRDAT
S X=$S('RMPRDT:"N/A",'$G(MODE):$$DATE(RMPRDT),1:RMPRDT)
Q X
;
SSN() ;*** SOCIAL SECURITY NUMBER
K VA,VADM
S DFN=D0 D ^VADPT
S X=$P(VA("PID"),"-",3)
Q X
DIOEND ;TOTAL PRINT
S COUNT=$E(" ",1,(6-$L(COUNT)))_COUNT
W !!,?47,"Total Patients: ",COUNT
S RMPODCNT=$E(" ",1,(6-$L(RMPODCNT)))_RMPODCNT ;RMPR*3.0*179
W !,?38,"Total Deceased Patients: ",RMPODCNT ;RMPR*3.0*179
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPORPD 3719 printed Nov 22, 2024@17:41:32 Page 2
RMPORPD ;(NG)/DG/CAP/HINES CIOFO/HNC -PRESCRIPTION EXPIRE DATE ACTIVE PATIENTS ; 5/19/00 9:12am
+1 ;;3.0;PROSTHETICS;**29,46,49,179,207**;Feb 09, 1996;Build 15
+2 ;
+3 ;RMPR*3.0*179 Check for deceased patients. Add to report by
+4 ; displaying asterisk (*) if patient deceased.
+5 ;RMPR*3.0*207 Ensure the script expiration displays correct
+6 ; dates even though script edit/add could be back dated.
+7 ;
SITE ; Set up the site variables.
+1 DO HOSITE^RMPOUTL0
if '$DATA(RMPOXITE)
QUIT
+2 ;
LI ; List the sought patient.
+1 NEW WHO
SET WHO=0
SET RMPODCNT=0
+2 SET (RMEND,RMPORPT,PAGE,COUNT)=0
+3 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+4 SET RPTDT=$PIECE(Y,"@",1)_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
+5 ;
+6 SET DIC="^RMPR(665,"
+7 SET BY(0)="^TMP(""RMPO"",$J,"
SET L(0)=3
SET L=0
SET FR=""
+8 SET DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,D0,""RMPOA"")),U,2)'="""",$P($G(^RMPR(665,D0,""RMPOA"")),U,3)="""""
+9 SET DHIT="D CNT^RMPORPD"
+10 SET DHD="W ?0 D RPTHDR^RMPORPD"
+11 SET DIOEND="I $G(Y)'[U D DIOEND^RMPORPD S RMEND=1 S:IOST[""P-"" RMPORPT=1"
+12 SET FLDS="W $$RXDT^RMPORPD();C1;L11"
+13 SET FLDS(1)=".01;C12;L22"
+14 SET FLDS(2)="W $$SSN^RMPORPD();C36;L4"
+15 SET FLDS(3)="W $$PITEM^RMPORPD();C41;L30"
+16 SET FLDS(4)="W $$ACTDT^RMPORPD();C73;L8"
+17 DO PRESORT
DO EN1^DIP
+18 IF RMPORPT=0
IF $GET(RMEND)
KILL DIR
SET DIR(0)="E"
DO ^DIR
+19 ;
EXIT ;
+1 KILL ^TMP("RMPO",$JOB)
NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 QUIT
+3 ;
ACTDT() ;*** ACTIVATION DATE
+1 SET X=$PIECE($GET(^RMPR(665,D0,"RMPOA")),U,2)
+2 if X
SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+3 QUIT X
+4 ;
CNT ;*** COUNT NAMES
+1 IF WHO'=D0
SET COUNT=COUNT+1
+2 SET WHO=D0
+3 QUIT
+4 ;
+5 ;*** CONVERT DATE FROM FILEMAN FORMAT TO MM/DD/YYYY
DATE(FMD) ; RMPR*3.0*179 Flag a deceased patient by attaching an '*' to SSN. ^PT(D0,.35) direct read supported by ICR #10035
+1 NEW RMPOEXP
SET RMPOEXP=" "
IF +$GET(^DPT(D0,.35))
SET RMPOEXP="*"
SET RMPODCNT=RMPODCNT+1
+2 QUIT $EXTRACT(FMD,4,5)_"/"_$EXTRACT(FMD,6,7)_"/"_($EXTRACT(FMD,1,3)+1700)_RMPOEXP
+3 ;
PITEM() ;*** GET PRIMARY ITEM AND ACTIVATION DATE
+1 NEW PITM,E
+2 SET (E,PITM)=0
SET X=""
+3 FOR
SET PITM=$ORDER(^RMPR(665,D0,"RMPOC",PITM))
if 'PITM
QUIT
Begin DoDot:1
+4 SET PDT=^RMPR(665,D0,"RMPOC",PITM,0)
+5 if $PIECE(PDT,U,11)'="Y"
QUIT
+6 SET X=$PIECE(PDT,U)
SET X=$PIECE(^RMPR(661,X,0),U)
+7 SET X=$PIECE($GET(^PRC(441,X,0)),U,2)
+8 SET X=$EXTRACT(X,1,30)
SET E=1
End DoDot:1
if E
QUIT
+9 QUIT X
+10 ;
PRESORT ;*** SORT BY EXPIRATION DATE
+1 NEW D0,D2,DFN
+2 KILL ^TMP("RMPO",$JOB)
+3 SET D2=0
+4 FOR
SET D2=$ORDER(^RMPR(665,"AHO",D2))
if 'D2
QUIT
SET D0=""
Begin DoDot:1
+5 FOR
SET D0=$ORDER(^RMPR(665,"AHO",D2,D0))
if D0=""
QUIT
Begin DoDot:2
+6 KILL VAPA,VADM
SET DFN=D0
DO ^VADPT
+7 SET ^TMP("RMPO",$JOB,$$RXDT(1),VADM(1),D0)=""
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
RPTHDR ;*** REPORT HEADER
+1 NEW RA
SET RA=RMPO("NAME")
SET PAGE=PAGE+1
+2 WRITE RPTDT,?(40-($LENGTH(RA)/2)),RA,?68,"Page: "_PAGE
+3 ;RMPR*3.0*179
WRITE !?20,"Prescription Expiration Date",!,"Date Current",?55,"'*' patient is deceased",!,"Prescription"
+4 WRITE !?1,"Expires",?11,"Name",?35,"SSN",?41,"Primary Item",?73,"Active"
+5 WRITE !,"==========",?11,"=======================",?35,"====",?41,"==============================",?72,"========",!
+6 QUIT
+7 ;
+8 ;*** EXPIRATION DATE OF CURRENT RX
+9 ; MODE Date format: 0 - MM/DD/YYYY or "N/A" (default)
+10 ; 1 - YYYMMDD or "N/A"
RXDT(MODE) ;Rewrite latest expiration date determination RMPR*3.0*207
+1 NEW RMPRDA,RMPRDT,RMPRDAT
SET (RMPRDA,RMPRDT)=0
+2 FOR
SET RMPRDA=$ORDER(^RMPR(665,D0,"RMPOB",RMPRDA))
if 'RMPRDA
QUIT
Begin DoDot:1
+3 SET RMPRDAT=$PIECE(^RMPR(665,D0,"RMPOB",RMPRDA,0),U,3)
IF RMPRDAT>RMPRDT
SET RMPRDT=RMPRDAT
End DoDot:1
+4 SET X=$SELECT('RMPRDT:"N/A",'$GET(MODE):$$DATE(RMPRDT),1:RMPRDT)
+5 QUIT X
+6 ;
SSN() ;*** SOCIAL SECURITY NUMBER
+1 KILL VA,VADM
+2 SET DFN=D0
DO ^VADPT
+3 SET X=$PIECE(VA("PID"),"-",3)
+4 QUIT X
DIOEND ;TOTAL PRINT
+1 SET COUNT=$EXTRACT(" ",1,(6-$LENGTH(COUNT)))_COUNT
+2 WRITE !!,?47,"Total Patients: ",COUNT
+3 ;RMPR*3.0*179
SET RMPODCNT=$EXTRACT(" ",1,(6-$LENGTH(RMPODCNT)))_RMPODCNT
+4 ;RMPR*3.0*179
WRITE !,?38,"Total Deceased Patients: ",RMPODCNT
+5 QUIT
