RMPORPT.m

RMPORPT ;(NG)/DG/CAP /HINES CIOFO/HNC - Home Oxygen Primary Item Report ;7/24/98

 ;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996

SITE ;Set up site variables.

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

 ;

LI ;List the sought patient.

 N PBREAK,NBREAK S (PBREAK,NBREAK)=""

 S DIC="^RMPR(665,"

 S BY(0)="^TMP($J,",L(0)=3

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

 S L=0,FR="",(PAGE,RMEND,RMPORPT)=0

 S $P(SPACE," ",80)="",COUNT=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^RMPORPT"

 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="S:$G(Y)[U RMEND=1 I '$G(RMEND) S COUNT=$E(""      "",1,(6-$L(COUNT)))_COUNT W !!,?50,""Total Patients: "",COUNT"

 S FLDS="D PBREAK^RMPORPT,.01;C1;L18;""PATIENT"",D SSN^RMPORPT W X;C20;R4;""SSN"",D IT^RMPORPT W X;C27;L30;"""""

 S FLDS(1)="D QTY^RMPORPT W X;C60;L2;""QTY"",D UCOST^RMPORPT W X;C63;""UNIT COST"",D TCOST^RMPORPT W X;C72;""TOTAL COST"""

 D SORT

 D EN1^DIP

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

EXIT ;

 ;K SPACE,RB,COUNT,PAGE,RMPOF,RPTDT,^TMP($J,"RMPORPT")

 ;K FRMDT,TODT,Y,VA,VADM,DFN,RCOST,RNAM,XIOSL,UCOST

 K ^TMP($J) N RMPR,RMPRSITE D KILL^XUSCLEAN

 Q

CNT ;COUNT NAMES

 I X'="" S COUNT=COUNT+1

 Q

PBREAK ;Print the break of primary items.

 D IT^RMPORPT

 I PBREAK'=NBREAK W !,"Primary Item: ",PBREAK,! S NBREAK=PBREAK

 Q

 ;

SSN ;GET SSN

 S X=""

 K VA,VADM S DFN=D0 D ^VADPT

 S RNAM=$E(VADM(1),1,22)_"^"_$P(VA("PID"),"-",3)

 S X=$P(VA("PID"),"-",3)

 D CNT

 Q

IT ;Get the primary Item.

 S (X,UCOST,QTY)="" 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)

 . S UCOST=$P(^RMPR(665,D0,"RMPOC",RA,0),U,4)

 . S QTY=$P(^RMPR(665,D0,"RMPOC",RA,0),U,3)

 . ;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)

 . S PBREAK=X

 Q

 ;

QTY ;Get the quntity of the primary item.

 S X=""

 S X=QTY

 Q

 ;

UCOST ;Get the unit cost of the primary item.

 S X=""

 S X=$J(UCOST,7,2)

 Q

 ;

TCOST ;Calculate the total cost of the primary item.

 S X=""

 S X=QTY*UCOST,X=$J(X,8,2)

 Q

 ;

ZPAGE(RY)  ;Print page.

 I ($Y+RY)<IOSL Q

 S RKO="ZL DIO2 X ^TMP($J,1) ZL RMPORPT" X RKO K RKO

 Q

 ;

RPTHDR ;Report header.

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

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

 W !?23,"Primary Item Report",!

 W !?64,"Unit",?73,"Total"

 W !,"Patient",?20,"SSN",?26,"Primary Item",?58,"Qty"

 W ?64,"Cost",?74,"Cost"

 W !,"=================",?19,"====",?26,"=============================="

 W ?58,"===",?64,"======",?73,"======"

 W !

 Q

 ;

SORT ;Sort patient by primary item and patient name.

 N D0,X,Y,UCOST,QTY,PBREAK

 S (X,Y,UCOST,QTY,PBREAK)=""

 S D2=0

ST F  S D2=$O(^RMPR(665,"AHO",D2)) Q:D2=""  D

 .S D0="" F  S D0=$O(^RMPR(665,"AHO",D2,D0)) Q:D0=""  D

 ..S DFN=$P($G(^RMPR(665,D0,0)),U,1)

 ..K VADM D ^VADPT S Y=VADM(1)

 ..D IT S:X'="" ^TMP($J,X,Y,D0)=""

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPORPT   3261     printed  Apr 23, 2025@18:46:03                                                                                                                                                                                                     Page 2

RMPORPT   ;(NG)/DG/CAP /HINES CIOFO/HNC - Home Oxygen Primary Item Report ;7/24/98

 +1       ;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996

SITE      ;Set up site variables.

 +1        DO HOSITE^RMPOUTL0

           IF '$DATA(RMPOXITE)

               QUIT 

 +2       ;

LI        ;List the sought patient.

 +1        NEW PBREAK,NBREAK

           SET (PBREAK,NBREAK)=""

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

 +3        SET BY(0)="^TMP($J,"

           SET L(0)=3

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

 +5        SET L=0

           SET FR=""

           SET (PAGE,RMEND,RMPORPT)=0

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

           SET COUNT=0

 +7        DO NOW^%DTC

 +8        SET Y=%

           XECUTE ^DD("DD")

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

 +9        SET DHD="W ?0 D RPTHDR^RMPORPT"

 +10       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"

 +11      ;S DIOEND="S:$G(Y)[U RMEND=1 I '$G(RMEND) S COUNT=$E(""      "",1,(6-$L(COUNT)))_COUNT W !!,?50,""Total Patients: "",COUNT"

 +12       SET FLDS="D PBREAK^RMPORPT,.01;C1;L18;""PATIENT"",D SSN^RMPORPT W X;C20;R4;""SSN"",D IT^RMPORPT W X;C27;L30;"""""

 +13       SET FLDS(1)="D QTY^RMPORPT W X;C60;L2;""QTY"",D UCOST^RMPORPT W X;C63;""UNIT COST"",D TCOST^RMPORPT W X;C72;""TOTAL COST"""

 +14       DO SORT

 +15       DO EN1^DIP

 +16       IF RMPORPT=0

               IF $GET(RMEND)

                   KILL DIR

                   SET DIR(0)="E"

                   DO ^DIR

EXIT      ;

 +1       ;K SPACE,RB,COUNT,PAGE,RMPOF,RPTDT,^TMP($J,"RMPORPT")

 +2       ;K FRMDT,TODT,Y,VA,VADM,DFN,RCOST,RNAM,XIOSL,UCOST

 +3        KILL ^TMP($JOB)

           NEW RMPR,RMPRSITE

           DO KILL^XUSCLEAN

 +4        QUIT 

CNT       ;COUNT NAMES

 +1        IF X'=""

               SET COUNT=COUNT+1

 +2        QUIT 

PBREAK    ;Print the break of primary items.

 +1        DO IT^RMPORPT

 +2        IF PBREAK'=NBREAK

               WRITE !,"Primary Item: ",PBREAK,!

               SET NBREAK=PBREAK

 +3        QUIT 

 +4       ;

SSN       ;GET SSN

 +1        SET X=""

 +2        KILL VA,VADM

           SET DFN=D0

           DO ^VADPT

 +3        SET RNAM=$EXTRACT(VADM(1),1,22)_"^"_$PIECE(VA("PID"),"-",3)

 +4        SET X=$PIECE(VA("PID"),"-",3)

 +5        DO CNT

 +6        QUIT 

IT        ;Get the primary Item.

 +1        SET (X,UCOST,QTY)=""

           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                    SET UCOST=$PIECE(^RMPR(665,D0,"RMPOC",RA,0),U,4)

 +6                    SET QTY=$PIECE(^RMPR(665,D0,"RMPOC",RA,0),U,3)

 +7       ;PROS ITEM FILE

 +8                    SET RR=$PIECE(^RMPR(661,RR,0),U)

 +9       ; ITEM MASTER FILE

 +10                   SET RR=$PIECE(^PRC(441,RR,0),"^",2)

 +11                   SET X=$EXTRACT(RR,1,30)

 +12                   SET PBREAK=X

                   End DoDot:1

                   QUIT 

 +13       QUIT 

 +14      ;

QTY       ;Get the quntity of the primary item.

 +1        SET X=""

 +2        SET X=QTY

 +3        QUIT 

 +4       ;

UCOST     ;Get the unit cost of the primary item.

 +1        SET X=""

 +2        SET X=$JUSTIFY(UCOST,7,2)

 +3        QUIT 

 +4       ;

TCOST     ;Calculate the total cost of the primary item.

 +1        SET X=""

 +2        SET X=QTY*UCOST

           SET X=$JUSTIFY(X,8,2)

 +3        QUIT 

 +4       ;

ZPAGE(RY) ;Print page.

 +1        IF ($Y+RY)<IOSL

               QUIT 

 +2        SET RKO="ZL DIO2 X ^TMP($J,1) ZL RMPORPT"

           XECUTE RKO

           KILL RKO

 +3        QUIT 

 +4       ;

RPTHDR    ;Report header.

 +1        NEW RA

           SET RA=RMPO("NAME")

           SET PAGE=PAGE+1

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

 +3        WRITE !?23,"Primary Item Report",!

 +4        WRITE !?64,"Unit",?73,"Total"

 +5        WRITE !,"Patient",?20,"SSN",?26,"Primary Item",?58,"Qty"

 +6        WRITE ?64,"Cost",?74,"Cost"

 +7        WRITE !,"=================",?19,"====",?26,"=============================="

 +8        WRITE ?58,"===",?64,"======",?73,"======"

 +9        WRITE !

 +10       QUIT 

 +11      ;

SORT      ;Sort patient by primary item and patient name.

 +1        NEW D0,X,Y,UCOST,QTY,PBREAK

 +2        SET (X,Y,UCOST,QTY,PBREAK)=""

 +3        SET D2=0

ST         FOR 

               SET D2=$ORDER(^RMPR(665,"AHO",D2))

               if D2=""

                   QUIT 

               Begin DoDot:1

 +1                SET D0=""

                   FOR 

                       SET D0=$ORDER(^RMPR(665,"AHO",D2,D0))

                       if D0=""

                           QUIT 

                       Begin DoDot:2

 +2                        SET DFN=$PIECE($GET(^RMPR(665,D0,0)),U,1)

 +3                        KILL VADM

                           DO ^VADPT

                           SET Y=VADM(1)

 +4                        DO IT

                           if X'=""

                               SET ^TMP($JOB,X,Y,D0)=""

                       End DoDot:2

               End DoDot:1

 +5        QUIT 

 +6       ;