RMPORLP ;(NG)/DG/CAP /HINES-CIOFO/HNC- HOME OXY PTS ;7/24/98
;;3.0;PROSTHETICS;**29,179**;Feb 09, 1996;Build 7
;
;RMPR*3.0*179 Flag a deceased patient by adding an '*'
; in front of SSN.
;
SITE ;Set up site variables.
D HOSITE^RMPOUTL0 I '$D(RMPOXITE) Q
;
LI ;List the sought patient. ;DW
S DIC="^RMPR(665,",BY="[RMPO-RPT-HOPATIENTLIST]",L=0,FR=""
S PAGE=0,RMPRDCNT=0
S DIS(0)="S Z=$G(^RMPR(665,D0,""RMPOA"")) I ($P(Z,U,7)=RMPOXITE),$P(Z,U,3)="""""
;S DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE",PAGE=0
S $P(SPACE," ",80)="",$P(DASH,"-",79)="",(COUNT,RMEND,RMPORPT)=0
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^RMPORLP"
;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"
S DIOEND="I $G(Y)'[U D DIOEND^RMPORLP S RMEND=1 S:IOST[""P-"" RMPORPT=1" ;RMPR*3.0*179
S FLDS=".01;C1;L22;""PATIENT"",D SSN^RMPORLP W X;C24;L5;""SSN"",D GET^RMPORLP W X;C30;L30;""PRIMARY ITEM"""
S FLDS(2)="D SDT^RMPORLP W X;C61;L8;""START"",D EDT^RMPORLP W X;C70;""EXPIRE"""
D EN1^DIP
I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
EXIT ;
K ^TMP($J)
N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
DIOEND ;
S COUNT=$E(" ",1,(6-$L(COUNT)))_COUNT
W !!,?47,"Total Patients: ",COUNT
S RMPRDCNT=$E(" ",1,(6-$L(RMPRDCNT)))_RMPRDCNT ;RMPR*3.0*179
W !,?38,"Total Deceased Patients: ",RMPRDCNT ;RMPR*3.0*179
Q
CNT ;COUNT NAMES
I X'="" S COUNT=COUNT+1
Q
GET ;Get the primary item. ;DW
S X="" N RR,RA S (RR,RA)=0
F S RA=$O(^RMPR(665,D0,"RMPOC",RA)) Q:RA="" I $P($G(^RMPR(665,D0,"RMPOC",RA,0)),U,11)="Y" D Q
. ; PROSTHETICS PATIENT FILE
. S RR=$P(^RMPR(665,D0,"RMPOC",RA,0),U)
. ;PROS ITEM FILE
. S RR=$P(^RMPR(661,RR,0),U)
. ; ITEM MASTER FILE
. S RR=$P(^PRC(441,RR,0),"^",2)
. S X=$E(RR,1,30)
Q
;
SSN ;GET SSN
N RMPOEXP
S X="",RMPOEXP=" " ;RMPR*3.0*179
I +$G(^DPT(D0,.35)) S RMPOEXP="*",RMPRDCNT=RMPRDCNT+1 ;RMPR*3.0*179 Flag a deceased patient by attaching an '*' to SSN. ^DPT(D0,.35) direct read supported by ICR #10035
K VA,VADM S DFN=D0 D ^VADPT
S X=RMPOEXP_$P(VA("PID"),"-",3) ;RMPR*3.0*179
D CNT
Q
SDT ;GET START DATE (USE INITIAL OXYGEN RX DATE)
S X="" N RA
S RA=$P($G(^RMPR(665,D0,"RMPOA")),U,2)
I RA S X=$E(RA,4,5)_"/"_$E(RA,6,7)_"/"_$E(RA,2,3)
Q
EDT ;Expiration Date of current Rx.
N J,D,Y,RA S (J,Y,X,D,RA)=""
F S D=$O(^RMPR(665,D0,"RMPOB","B",D)) Q:D="" D
. S J="",J=$O(^RMPR(665,D0,"RMPOB","B",D,J)) Q:J="" S:(J>RA) RA=J
;I J="" Q
I RA="" Q
S Y=$P($G(^RMPR(665,D0,"RMPOB",RA,0)),U,3)
I Y S X=X_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)
Q
EDTX ;Rx Expiration Date.
;Get the expiration dates for all active Rx.
N J,D,EDT,C,TD S (J,D,EDT,C,X)=""
; Get today's date.
D NOW^%DTC S TD=X,X=""
; Get the active Rx.
F S D=$O(^RMPR(665,D0,"RMPOB","B",D)) Q:D="" S C=C+1 D
.F S J=$O(^RMPR(665,D0,"RMPOB","B",D,J)) Q:J="" D
.. S EDT=$P($G(^RMPR(665,D0,"RMPOB",J,0)),U,3)
.. I EDT S X=X_$E(EDT,4,5)_"/"_$E(EDT,6,7)_"/"_($E(EDT,1,3)+1700)_" "
; Define the other dates.
I C="" S X="N/A" Q
Q
RPTHDR ;Report header
N RA S RA=RMPO("NAME"),PAGE=PAGE+1
W RPTDT,?(40-($L(RA)/2)),RA,?68,"Page: "_PAGE
W !," '*' denotes deceased patient by SSN"
W !?22,"Alphabetical List Home Oxygen Patients",!?68,"Date Current",!?68,"Prescription"
W !,"Patient",?25,"SSN",?29,"Primary Item",?61,"Active",?70,"Expires"
W !,"=======================",?24,"====",?29,"==============================",?60,"======== ==========",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPORLP 3639 printed Dec 13, 2024@02:31:29 Page 2
RMPORLP ;(NG)/DG/CAP /HINES-CIOFO/HNC- HOME OXY PTS ;7/24/98
+1 ;;3.0;PROSTHETICS;**29,179**;Feb 09, 1996;Build 7
+2 ;
+3 ;RMPR*3.0*179 Flag a deceased patient by adding an '*'
+4 ; in front of SSN.
+5 ;
SITE ;Set up site variables.
+1 DO HOSITE^RMPOUTL0
IF '$DATA(RMPOXITE)
QUIT
+2 ;
LI ;List the sought patient. ;DW
+1 SET DIC="^RMPR(665,"
SET BY="[RMPO-RPT-HOPATIENTLIST]"
SET L=0
SET FR=""
+2 SET PAGE=0
SET RMPRDCNT=0
+3 SET DIS(0)="S Z=$G(^RMPR(665,D0,""RMPOA"")) I ($P(Z,U,7)=RMPOXITE),$P(Z,U,3)="""""
+4 ;S DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE",PAGE=0
+5 SET $PIECE(SPACE," ",80)=""
SET $PIECE(DASH,"-",79)=""
SET (COUNT,RMEND,RMPORPT)=0
+6 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+7 SET RPTDT=$PIECE(Y,"@",1)_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
+8 SET DHD="W ?0 D RPTHDR^RMPORLP"
+9 ;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"
+10 ;RMPR*3.0*179
SET DIOEND="I $G(Y)'[U D DIOEND^RMPORLP S RMEND=1 S:IOST[""P-"" RMPORPT=1"
+11 SET FLDS=".01;C1;L22;""PATIENT"",D SSN^RMPORLP W X;C24;L5;""SSN"",D GET^RMPORLP W X;C30;L30;""PRIMARY ITEM"""
+12 SET FLDS(2)="D SDT^RMPORLP W X;C61;L8;""START"",D EDT^RMPORLP W X;C70;""EXPIRE"""
+13 DO EN1^DIP
+14 IF RMPORPT=0
IF $GET(RMEND)
KILL DIR
SET DIR(0)="E"
DO ^DIR
EXIT ;
+1 KILL ^TMP($JOB)
+2 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+3 QUIT
DIOEND ;
+1 SET COUNT=$EXTRACT(" ",1,(6-$LENGTH(COUNT)))_COUNT
+2 WRITE !!,?47,"Total Patients: ",COUNT
+3 ;RMPR*3.0*179
SET RMPRDCNT=$EXTRACT(" ",1,(6-$LENGTH(RMPRDCNT)))_RMPRDCNT
+4 ;RMPR*3.0*179
WRITE !,?38,"Total Deceased Patients: ",RMPRDCNT
+5 QUIT
CNT ;COUNT NAMES
+1 IF X'=""
SET COUNT=COUNT+1
+2 QUIT
GET ;Get the primary item. ;DW
+1 SET X=""
NEW RR,RA
SET (RR,RA)=0
+2 FOR
SET RA=$ORDER(^RMPR(665,D0,"RMPOC",RA))
if RA=""
QUIT
IF $PIECE($GET(^RMPR(665,D0,"RMPOC",RA,0)),U,11)="Y"
Begin DoDot:1
+3 ; PROSTHETICS PATIENT FILE
+4 SET RR=$PIECE(^RMPR(665,D0,"RMPOC",RA,0),U)
+5 ;PROS ITEM FILE
+6 SET RR=$PIECE(^RMPR(661,RR,0),U)
+7 ; ITEM MASTER FILE
+8 SET RR=$PIECE(^PRC(441,RR,0),"^",2)
+9 SET X=$EXTRACT(RR,1,30)
End DoDot:1
QUIT
+10 QUIT
+11 ;
SSN ;GET SSN
+1 NEW RMPOEXP
+2 ;RMPR*3.0*179
SET X=""
SET RMPOEXP=" "
+3 ;RMPR*3.0*179 Flag a deceased patient by attaching an '*' to SSN. ^DPT(D0,.35) direct read supported by ICR #10035
IF +$GET(^DPT(D0,.35))
SET RMPOEXP="*"
SET RMPRDCNT=RMPRDCNT+1
+4 KILL VA,VADM
SET DFN=D0
DO ^VADPT
+5 ;RMPR*3.0*179
SET X=RMPOEXP_$PIECE(VA("PID"),"-",3)
+6 DO CNT
+7 QUIT
SDT ;GET START DATE (USE INITIAL OXYGEN RX DATE)
+1 SET X=""
NEW RA
+2 SET RA=$PIECE($GET(^RMPR(665,D0,"RMPOA")),U,2)
+3 IF RA
SET X=$EXTRACT(RA,4,5)_"/"_$EXTRACT(RA,6,7)_"/"_$EXTRACT(RA,2,3)
+4 QUIT
EDT ;Expiration Date of current Rx.
+1 NEW J,D,Y,RA
SET (J,Y,X,D,RA)=""
+2 FOR
SET D=$ORDER(^RMPR(665,D0,"RMPOB","B",D))
if D=""
QUIT
Begin DoDot:1
+3 SET J=""
SET J=$ORDER(^RMPR(665,D0,"RMPOB","B",D,J))
if J=""
QUIT
if (J>RA)
SET RA=J
End DoDot:1
+4 ;I J="" Q
+5 IF RA=""
QUIT
+6 SET Y=$PIECE($GET(^RMPR(665,D0,"RMPOB",RA,0)),U,3)
+7 IF Y
SET X=X_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)
+8 QUIT
EDTX ;Rx Expiration Date.
+1 ;Get the expiration dates for all active Rx.
+2 NEW J,D,EDT,C,TD
SET (J,D,EDT,C,X)=""
+3 ; Get today's date.
+4 DO NOW^%DTC
SET TD=X
SET X=""
+5 ; Get the active Rx.
+6 FOR
SET D=$ORDER(^RMPR(665,D0,"RMPOB","B",D))
if D=""
QUIT
SET C=C+1
Begin DoDot:1
+7 FOR
SET J=$ORDER(^RMPR(665,D0,"RMPOB","B",D,J))
if J=""
QUIT
Begin DoDot:2
+8 SET EDT=$PIECE($GET(^RMPR(665,D0,"RMPOB",J,0)),U,3)
+9 IF EDT
SET X=X_$EXTRACT(EDT,4,5)_"/"_$EXTRACT(EDT,6,7)_"/"_($EXTRACT(EDT,1,3)+1700)_" "
End DoDot:2
End DoDot:1
+10 ; Define the other dates.
+11 IF C=""
SET X="N/A"
QUIT
+12 QUIT
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 WRITE !," '*' denotes deceased patient by SSN"
+4 WRITE !?22,"Alphabetical List Home Oxygen Patients",!?68,"Date Current",!?68,"Prescription"
+5 WRITE !,"Patient",?25,"SSN",?29,"Primary Item",?61,"Active",?70,"Expires"
+6 WRITE !,"=======================",?24,"====",?29,"==============================",?60,"======== ==========",!
+7 QUIT
