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
Q
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)
Q
;
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,"===============",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPORNQ 2226 printed Apr 09, 2024@21:36:27 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
