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