- 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 Jan 18, 2025@03:32:41 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