Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPORLP

RMPORLP.m

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