RMPR29P.m

RMPR29P ;PHX/JLT-INITIATE AND PURCHASE LAB ITEMS [ 09/16/94  8:57 AM ]

 ;;3.0;PROSTHETICS;**20**;Feb 09, 1996

 ;CALLED FROM RMPR29T

 ;VARIABLES REQUIRED: RMPRDA - ENTRY  NUMBER IN FILE 664.1

PCH ;initiate purchasing forms from the lab module

 K DIR,Y D HOME^%ZIS

 S DIR(0)="S^2421:FORM 2421 PURCHASE;2529:FORM 2529-3 REMOTE REQUEST"

 S DIR("A")="Select Procurement Form type"

 D ^DIR

 I $D(DIRUT)!($D(DUOUT))!(+Y=0) K RMPRF G DISP^RMPR29D

JB ;SET FORM TYPE IF NOT TIMED OUT OR UP-ARROW OUT

 S RMPRF=$S(+Y[2421:2,1:4)

 G DISP^RMPR29J

 ;exit this routine

 ;

STR ;INITIATE 2421 PURCHASE

 ;CALLED FROM RMPR29J

 ;VARIABLES REQUIRED: RMPRDA - ENTRY IN FILE 664.1

 K DIC,DR,DA,DIE

 ;ask what type of 2421

 ;

 S DIR(0)="S^1:PURCHASE CARD 2421;2:IFCAP (1358) 2421"

 S DIR("A")="Select Type of 2421"

 W !

 D ^DIR

 I $D(DIRUT)!($D(DUOUT))!(+Y=0) K RMPRF G DISP^RMPR29D

 S RMPRF=+Y

 ;create initial record in 664

 S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2)

 S X=DT,DIC="^RMPR(664,",DIC(0)="LZ" D FILE^DICN Q:+Y'>0

 S (RMPRK,RMPRA)=+Y

 S $P(^RMPR(664,RMPRA,0),U,2)=DFN,$P(^(0),U,14)=RMPR("STA"),$P(^(0),U,15)=RMPRWO,$P(^(0),U,16)=DUZ,$P(^(0),U,17)=RMPRDA

 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK

 ;

 ;if visa rmprf=1

 I RMPRF=1 D 2529^RMPR421 K RMPRF G DISP^RMPR29D

 ;if 1358 rmprf=2

OBL ;Check IFCAP access to fund control point

 ;SEE DBA #282 ;CUSTODIAL PKG - IFCAP  ;GRANTED 9/20/93

 ;CUSTODIAL ISC - WASHINGTON

 ;

 S RMPRF=8,PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58

 G:Y=-1 END

 ;display 1358 balance

 S RMPROB=$P(Y,U,2) D BAL^RMPRPSC

 S RMPRR="",(RMPRCT,R1,RMPRQT,RMPRTO,RMPRDS,RMPRIS,B2)=0,B1=1

 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2),VAPA("P")=1,VAHOW=2

 D ALL^VADPT S RMPRNAM=^UTILITY("VADM",$J,1)

 S RMPRDOB=$P(^UTILITY("VADM",$J,3),U)

 S RMPRSSN=$P(^UTILITY("VADM",$J,2),U)

 I $D(^UTILITY("VADM",$J,6)) I $P(^UTILITY("VADM",$J,6),U,2)'="" W !!,$C(7),"PATIENT IS DECEASED.  DATE OF DEATH WAS ",$P(^UTILITY("VADM",$J,6),U,2)

 I $D(^UTILITY("VADM",$J,6)) I $P(^UTILITY("VADM",$J,6),U,2)'="" S DIR(0)="Y",DIR("A")="Would you Like to continue Processing this Patient",DIR("B")="NO" D ^DIR K DIR I +Y=0 G END

 D KVAR^VADPT S RMPRF=2 D VIEW^RMPR21 D:$D(RMPRA) KILL^RMPR21

END ;exit point

 ;see internal notes

 G DISP^RMPR29D

 ;

2529 ;CREATE 2529-3 RECORD

 ; CALLED BY RMPR29J

 ; RMPRDA - ien 664.1

 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),RMPR25=1 D VIEW^RMPR29

 K RMPRF

 G:'$D(RMPRRDA) DISP^RMPR29D

 S $P(^RMPR(664.1,RMPRRDA,0),U,12)=RMPRWO

 D DEL(RMPRRDA),PST(RMPRRDA) G DISP^RMPR29D

DEL(RMPRRDA) ;DELETE 2529-3 REQUEST FOR WORK ORDER

 ; CALLED FROM RMPR29C,RMPR29T

 ; RMPRDA - ien FILE 664.1

 F RA=0:0 S RA=$O(^RMPR(664.1,RMPRRDA,2,RA)) Q:RA'>0  S RWO=$P($G(^RMPR(664.1,RMPRRDA,2,RA,0)),U,6) I $D(^RMPR(664.2,"AR3",+RWO,RMPRRDA)) D

 .F DA=0:0 S DA=$O(^RMPR(664.2,"AR3",RWO,RMPRRDA,DA)) Q:DA'>0  S DA(1)=RWO,DIK="^RMPR(664.2,"_DA(1)_",1," D ^DIK

 Q

PST(RMPRRDA) ;Post 2529-3 record to the 2319 patient master record.

 ; CALLED BYRMPR29T

 ; RMPRDA - ien FILE 664.1

 S RMPR("REF")=$P(^RMPR(664.1,RMPRDA,0),U,13),RMPRWO=$P(^(0),U,12)

 F RDA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0  I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),SER=$P(^(0),U,12),$P(^(0),U,6)=RMPRWO D

 .I $D(^RMPR(660,+RDA,0)) S DA=+RDA,DIE="^RMPR(660,",DR="23///^S X=RMPR(""REF"")" D ^DIE S DA=+RDA,DIK="^RMPR(660," D IX^DIK K DD,D0,DO

 .S DIC="^RMPR(664.2,"_RMPRWO_",1,",DIC("P")="664.22PA",DA(1)=RMPRWO,DIC(0)="LZ",X=IT D FILE^DICN I +Y>0 D

 ..S $P(^RMPR(664.2,RMPRWO,1,+Y,0),U,2)=QTY,$P(^(0),U,3)="0.00",$P(^(0),U,4)="V",$P(^(0),U,7)=UN,$P(^(0),U,8)=SER,$P(^(0),U,10)=RMPR("REF"),$P(^(0),U,12)=RDA,$P(^(0),U,13)=RMPRRDA S DIK=DIC,DA(1)=RMPRWO,DA=+Y D IX1^DIK

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPR29P   3744     printed  Feb 18, 2025@23:58:53                                                                                                                                                                                                     Page 2

RMPR29P   ;PHX/JLT-INITIATE AND PURCHASE LAB ITEMS [ 09/16/94  8:57 AM ]

 +1       ;;3.0;PROSTHETICS;**20**;Feb 09, 1996

 +2       ;CALLED FROM RMPR29T

 +3       ;VARIABLES REQUIRED: RMPRDA - ENTRY  NUMBER IN FILE 664.1

PCH       ;initiate purchasing forms from the lab module

 +1        KILL DIR,Y

           DO HOME^%ZIS

 +2        SET DIR(0)="S^2421:FORM 2421 PURCHASE;2529:FORM 2529-3 REMOTE REQUEST"

 +3        SET DIR("A")="Select Procurement Form type"

 +4        DO ^DIR

 +5        IF $DATA(DIRUT)!($DATA(DUOUT))!(+Y=0)

               KILL RMPRF

               GOTO DISP^RMPR29D

JB        ;SET FORM TYPE IF NOT TIMED OUT OR UP-ARROW OUT

 +1        SET RMPRF=$SELECT(+Y[2421:2,1:4)

 +2        GOTO DISP^RMPR29J

 +3       ;exit this routine

 +4       ;

STR       ;INITIATE 2421 PURCHASE

 +1       ;CALLED FROM RMPR29J

 +2       ;VARIABLES REQUIRED: RMPRDA - ENTRY IN FILE 664.1

 +3        KILL DIC,DR,DA,DIE

 +4       ;ask what type of 2421

 +5       ;

 +6        SET DIR(0)="S^1:PURCHASE CARD 2421;2:IFCAP (1358) 2421"

 +7        SET DIR("A")="Select Type of 2421"

 +8        WRITE !

 +9        DO ^DIR

 +10       IF $DATA(DIRUT)!($DATA(DUOUT))!(+Y=0)

               KILL RMPRF

               GOTO DISP^RMPR29D

 +11       SET RMPRF=+Y

 +12      ;create initial record in 664

 +13       SET DFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)

 +14       SET X=DT

           SET DIC="^RMPR(664,"

           SET DIC(0)="LZ"

           DO FILE^DICN

           if +Y'>0

               QUIT 

 +15       SET (RMPRK,RMPRA)=+Y

 +16       SET $PIECE(^RMPR(664,RMPRA,0),U,2)=DFN

           SET $PIECE(^(0),U,14)=RMPR("STA")

           SET $PIECE(^(0),U,15)=RMPRWO

           SET $PIECE(^(0),U,16)=DUZ

           SET $PIECE(^(0),U,17)=RMPRDA

 +17       SET DA=RMPRA

           SET DIK="^RMPR(664,"

           DO IX1^DIK

 +18      ;

 +19      ;if visa rmprf=1

 +20       IF RMPRF=1

               DO 2529^RMPR421

               KILL RMPRF

               GOTO DISP^RMPR29D

 +21      ;if 1358 rmprf=2

OBL       ;Check IFCAP access to fund control point

 +1       ;SEE DBA #282 ;CUSTODIAL PKG - IFCAP  ;GRANTED 9/20/93

 +2       ;CUSTODIAL ISC - WASHINGTON

 +3       ;

 +4        SET RMPRF=8

           SET PRCS("A")="Select OBLIGATION NUMBER: "

           DO EN1^PRCS58

 +5        if Y=-1

               GOTO END

 +6       ;display 1358 balance

 +7        SET RMPROB=$PIECE(Y,U,2)

           DO BAL^RMPRPSC

 +8        SET RMPRR=""

           SET (RMPRCT,R1,RMPRQT,RMPRTO,RMPRDS,RMPRIS,B2)=0

           SET B1=1

 +9        SET RMPRDFN=$PIECE(^RMPR(664,RMPRA,0),U,2)

           SET VAPA("P")=1

           SET VAHOW=2

 +10       DO ALL^VADPT

           SET RMPRNAM=^UTILITY("VADM",$JOB,1)

 +11       SET RMPRDOB=$PIECE(^UTILITY("VADM",$JOB,3),U)

 +12       SET RMPRSSN=$PIECE(^UTILITY("VADM",$JOB,2),U)

 +13       IF $DATA(^UTILITY("VADM",$JOB,6))

               IF $PIECE(^UTILITY("VADM",$JOB,6),U,2)'=""

                   WRITE !!,$CHAR(7),"PATIENT IS DECEASED.  DATE OF DEATH WAS ",$PIECE(^UTILITY("VADM",$JOB,6),U,2)

 +14       IF $DATA(^UTILITY("VADM",$JOB,6))

               IF $PIECE(^UTILITY("VADM",$JOB,6),U,2)'=""

                   SET DIR(0)="Y"

                   SET DIR("A")="Would you Like to continue Processing this Patient"

                   SET DIR("B")="NO"

                   DO ^DIR

                   KILL DIR

                   IF +Y=0

                       GOTO END

 +15       DO KVAR^VADPT

           SET RMPRF=2

           DO VIEW^RMPR21

           if $DATA(RMPRA)

               DO KILL^RMPR21

END       ;exit point

 +1       ;see internal notes

 +2        GOTO DISP^RMPR29D

 +3       ;

2529      ;CREATE 2529-3 RECORD

 +1       ; CALLED BY RMPR29J

 +2       ; RMPRDA - ien 664.1

 +3        SET RMPRDFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)

           SET RMPR25=1

           DO VIEW^RMPR29

 +4        KILL RMPRF

 +5        if '$DATA(RMPRRDA)

               GOTO DISP^RMPR29D

 +6        SET $PIECE(^RMPR(664.1,RMPRRDA,0),U,12)=RMPRWO

 +7        DO DEL(RMPRRDA)

           DO PST(RMPRRDA)

           GOTO DISP^RMPR29D

DEL(RMPRRDA) ;DELETE 2529-3 REQUEST FOR WORK ORDER

 +1       ; CALLED FROM RMPR29C,RMPR29T

 +2       ; RMPRDA - ien FILE 664.1

 +3        FOR RA=0:0

               SET RA=$ORDER(^RMPR(664.1,RMPRRDA,2,RA))

               if RA'>0

                   QUIT 

               SET RWO=$PIECE($GET(^RMPR(664.1,RMPRRDA,2,RA,0)),U,6)

               IF $DATA(^RMPR(664.2,"AR3",+RWO,RMPRRDA))

                   Begin DoDot:1

 +4                    FOR DA=0:0

                           SET DA=$ORDER(^RMPR(664.2,"AR3",RWO,RMPRRDA,DA))

                           if DA'>0

                               QUIT 

                           SET DA(1)=RWO

                           SET DIK="^RMPR(664.2,"_DA(1)_",1,"

                           DO ^DIK

                   End DoDot:1

 +5        QUIT 

PST(RMPRRDA) ;Post 2529-3 record to the 2319 patient master record.

 +1       ; CALLED BYRMPR29T

 +2       ; RMPRDA - ien FILE 664.1

 +3        SET RMPR("REF")=$PIECE(^RMPR(664.1,RMPRDA,0),U,13)

           SET RMPRWO=$PIECE(^(0),U,12)

 +4        FOR RDA=0:0

               SET RA=$ORDER(^RMPR(664.1,RMPRDA,2,RA))

               if RA'>0

                   QUIT 

               IF $DATA(^(RA,0))

                   SET IT=$PIECE(^(0),U,1)

                   SET QTY=$PIECE(^(0),U,2)

                   SET UN=$PIECE(^(0),U,3)

                   SET RDA=$PIECE(^(0),U,5)

                   SET SER=$PIECE(^(0),U,12)

                   SET $PIECE(^(0),U,6)=RMPRWO

                   Begin DoDot:1

 +5                    IF $DATA(^RMPR(660,+RDA,0))

                           SET DA=+RDA

                           SET DIE="^RMPR(660,"

                           SET DR="23///^S X=RMPR(""REF"")"

                           DO ^DIE

                           SET DA=+RDA

                           SET DIK="^RMPR(660,"

                           DO IX^DIK

                           KILL DD,D0,DO

 +6                    SET DIC="^RMPR(664.2,"_RMPRWO_",1,"

                       SET DIC("P")="664.22PA"

                       SET DA(1)=RMPRWO

                       SET DIC(0)="LZ"

                       SET X=IT

                       DO FILE^DICN

                       IF +Y>0

                           Begin DoDot:2

 +7                            SET $PIECE(^RMPR(664.2,RMPRWO,1,+Y,0),U,2)=QTY

                               SET $PIECE(^(0),U,3)="0.00"

                               SET $PIECE(^(0),U,4)="V"

                               SET $PIECE(^(0),U,7)=UN

                               SET $PIECE(^(0),U,8)=SER

                               SET $PIECE(^(0),U,10)=RMPR("REF")

                               SET $PIECE(^(0),U,12)=RDA

                               SET $PIECE(^(0),U,13)=RMPRRDA

                               SET DIK=DIC

                               SET DA(1)=RMPRWO

                               SET DA=+Y

                               DO IX1^DIK

                           End DoDot:2

                   End DoDot:1

 +8        QUIT