Routine: RMPORNQ

RMPORNQ ;(VA-EDS)PAK/HINES CIOFO/HNC - NEW PATIENT REPORT ;7/24/98

 ;;3.0;PROSTHETICS;**29,77,180**;Feb 09, 1996;Build 12

 ;RVD patch #77 - insure that a dangling 'AC' x-ref will not cause

 ;                an undefined error.

 ;RMPR*3.0*180 Insure variable RMPODCNT is initialized for call to

 ;             SSN^RMPORPR for deceased patient check/totals.

START ;

 ;Set up site variables.

 D HOSITE^RMPOUTL0 I '$D(RMPOXITE) Q

 ;Ask starting date

 S %DT="AEX",%DT("A")="Enter the start date: "

 S %DT(0)=-DT

 S %DT("B")=$E(DT,4,5)_"/01"_"/"_$E(DT,2,3)

 D ^%DT Q:'Y!$D(DTOUT)

 S FRMDT=$P(Y,".")  ; extract ONLY date

 ;List the sought patient.

 S DIC="^RMPR(665,",L=0

 S DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE"

 S BY=".01,19.2",FR(1)="",FR(2)=FRMDT,TO(1)="",TO(2)=""

 S (RMEND,RMPORPT,PAGE,RMPODCNT)=0    ;RMPR*3.0*180

 S SPACE="",$P(SPACE," ",80)="",COUNT=0,DASH="",$P(DASH,"-",79)=""

 D NOW^%DTC S Y=% X ^DD("DD") S RPTDT=$P(Y,"@",1)_"  "_$P($P(Y,"@",2),":",1,2)

 S DHD="W ?0 D RPTHDR^RMPORNQ"

 S FLDS=".01;C1;L22;""PATIENT"",W $$SSN^RMPORPR;C25;R4;""SSN"",W $$PRI^RMPORNQ;31;L32;""PRIMARY ITEM"",19.2;C65;L10;""START"""

 S DIOEND="I $G(Y)'[U S COUNT=$E(""      "",1,(6-$L(COUNT)))_COUNT W !!,?50,""TOTAL PATIENTS: "",COUNT S RMEND=1 S:IOST[""P-"" RMPORPT=1"

 D EN1^DIP

 I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR

EXIT ;

 N RMPR,RMPRSITE D KILL^XUSCLEAN

SDT ;Activation date.

 S X=$P($G(^RMPR(665,D0,"RMPOA")),U,2)

 I X S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)

PRI() ;Get primary item.

 N ITMN

 S RMPOITM=$O(^RMPR(665,"AC","Y",D0,"")) Q:RMPOITM="" ""

 ; get item name from ITEM MASTER file as pointer field is DINUMed

 I '$D(^RMPR(665,D0,"RMPOC",RMPOITM,0)) Q ""

 S ITMN=$P(^RMPR(665,D0,"RMPOC",RMPOITM,0),U)

 S ITMN=$P(^RMPR(661,ITMN,0),U)

 S ITMN=$P(^PRC(441,ITMN,0),U,2)

 Q $E(ITMN,1,32)

RPTHDR ;Report header

 N RA S RA=RMPO("NAME"),PAGE=PAGE+1

 W RPTDT,?(40-($L(RA)/2)),RA,?65,"Page: "_PAGE

 W !?24,"New Patient Report",!

 W !,?4,"Patient",?24,"SSN",?39,"Primary Item",?64,"Activation Date"

 W !,"=====================",?24,"====",?30,"================================"

 W ?64,"===============",!

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPORNQ   2226     printed  Mar 13, 2025@21:36:17                                                                                                                                                                                                     Page 2

RMPORNQ   ;(VA-EDS)PAK/HINES CIOFO/HNC - NEW PATIENT REPORT ;7/24/98

 +1       ;;3.0;PROSTHETICS;**29,77,180**;Feb 09, 1996;Build 12

 +2       ;

 +3       ;RVD patch #77 - insure that a dangling 'AC' x-ref will not cause

 +4       ;                an undefined error.

 +5       ;

 +6       ;RMPR*3.0*180 Insure variable RMPODCNT is initialized for call to

 +7       ;             SSN^RMPORPR for deceased patient check/totals.

 +8       ;

START     ;

 +1       ;Set up site variables.

 +2        DO HOSITE^RMPOUTL0

           IF '$DATA(RMPOXITE)

               QUIT

 +3       ;

 +4       ;Ask starting date

 +5        SET %DT="AEX"

           SET %DT("A")="Enter the start date: "

 +6        SET %DT(0)=-DT

 +7        SET %DT("B")=$EXTRACT(DT,4,5)_"/01"_"/"_$EXTRACT(DT,2,3)

 +8        DO ^%DT

           if 'Y!$DATA(DTOUT)

               QUIT

 +9       ; extract ONLY date

           SET FRMDT=$PIECE(Y,".")

 +10      ;

 +11      ;List the sought patient.

 +12       SET DIC="^RMPR(665,"

           SET L=0

 +13       SET DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE"

 +14       SET BY=".01,19.2"

           SET FR(1)=""

           SET FR(2)=FRMDT

           SET TO(1)=""

           SET TO(2)=""

 +15      ;RMPR*3.0*180

           SET (RMEND,RMPORPT,PAGE,RMPODCNT)=0

 +16       SET SPACE=""

           SET $PIECE(SPACE," ",80)=""

           SET COUNT=0

           SET DASH=""

           SET $PIECE(DASH,"-",79)=""

 +17       DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

           SET RPTDT=$PIECE(Y,"@",1)_"  "_$PIECE($PIECE(Y,"@",2),":",1,2)

 +18       SET DHD="W ?0 D RPTHDR^RMPORNQ"

 +19       SET FLDS=".01;C1;L22;""PATIENT"",W $$SSN^RMPORPR;C25;R4;""SSN"",W $$PRI^RMPORNQ;31;L32;""PRIMARY ITEM"",19.2;C65;L10;""START"""

 +20       SET DIOEND="I $G(Y)'[U S COUNT=$E(""      "",1,(6-$L(COUNT)))_COUNT W !!,?50,""TOTAL PATIENTS: "",COUNT S RMEND=1 S:IOST[""P-"" RMPORPT=1"

 +21       DO EN1^DIP

 +22       IF RMPORPT=0

               IF $GET(RMEND)

                   KILL DIR

                   SET DIR(0)="E"

                   DO ^DIR

EXIT      ;

 +1       ;

 +2        NEW RMPR,RMPRSITE

           DO KILL^XUSCLEAN

 +3        QUIT

SDT       ;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,1,3)+1700)

 +3        QUIT

 +4       ;

PRI()     ;Get primary item.

 +1        NEW ITMN

 +2       ;

 +3        SET RMPOITM=$ORDER(^RMPR(665,"AC","Y",D0,""))

           if RMPOITM=""

               QUIT ""

 +4       ; get item name from ITEM MASTER file as pointer field is DINUMed

 +5        IF '$DATA(^RMPR(665,D0,"RMPOC",RMPOITM,0))

               QUIT ""

 +6        SET ITMN=$PIECE(^RMPR(665,D0,"RMPOC",RMPOITM,0),U)

 +7        SET ITMN=$PIECE(^RMPR(661,ITMN,0),U)

 +8        SET ITMN=$PIECE(^PRC(441,ITMN,0),U,2)

 +9        QUIT $EXTRACT(ITMN,1,32)

 +10      ;

RPTHDR    ;Report header

 +1        NEW RA

           SET RA=RMPO("NAME")

           SET PAGE=PAGE+1

 +2        WRITE RPTDT,?(40-($LENGTH(RA)/2)),RA,?65,"Page: "_PAGE

 +3        WRITE !?24,"New Patient Report",!

 +4        WRITE !,?4,"Patient",?24,"SSN",?39,"Primary Item",?64,"Activation Date"

 +5        WRITE !,"=====================",?24,"====",?30,"================================"

 +6        WRITE ?64,"===============",!

 +7        QUIT

RMPORNQ.m