RMPR29B.m

RMPR29B ;PHX/JLT-EDIT JOB SECTION[ 09/30/94  11:52 AM ]

 ;;3.0;PROSTHETICS;;Feb 09, 1996

 ;Per VHA Directive 10-93-142, this routine should not be modified.

MU ;ENTER DATEE

 D DISP^RMPR29J I '$D(RMPRWO) G END

TCH ;TECHNICIAN DATE

 ;see internal notes

 K DIR,DIC,DA,Y

 S DIR(0)="664.3,.01O",DIR("A")="Select DATE"

 S DIR("?")="^D LBR^RMPR29B" D ^DIR

 G:$D(DTOUT) CDT G:$D(DIRUT) CHK

 D SLK^RMPR29M,^DIC K DLAYGO,DIC

 G:+Y'>0 TCH S RDA=Y

 ;verify new entry

 I $P(Y,U,3) K DIR W $C(7),?5 S DIR(0)="Y",DIR("A")="ARE YOU ADDING A NEW DATE FOR THIS JOB" D ^DIR G:$D(DTOUT)!(X="^") CHK I +Y=0 S DA=+RDA,DIK="^RMPR(664.3," D ^DIK G TCH

 ;

 S DA=+RDA,DIE="^RMPR(664.3,"

 S DR=$S($P(RDA,U,3):"1////^S X=DA660;2////^S X=RMPR(""STA"");.01",1:".01")

 D ^DIE I '$D(DA) G TCH

 K DIC,Y,DA S DA(1)=+RDA,DLAYGO=664.3,DIC(0)="AEQLM"

 S DIC="^RMPR(664.3,"_DA(1)_",1,",DIC("P")="664.33PA"

 S DIC("B")=$$EMP^RMPR31U(DUZ) D ^DIC K DLAYGO

 ;

 I +Y>0 S DIE=DIC,DA(1)=+RDA,DA=+Y,DR=".01;1" D ^DIE I $D(DA) S EMP=+$P($G(^RMPR(664.3,DA(1),1,DA,0)),U) S:'$P(^RMPR(664.3,DA(1),1,DA,0),U,3) $P(^RMPR(664.3,DA(1),1,DA,0),U,3)=$$PAID^RMPR29U(EMP) S DIE=DIC,DR="2R" D ^DIE

 G TCH

 ;

LBR ;Help for DIR

 D SLK^RMPR29M S X="?" D ^DIC K DIC,DLAYGO

 Q

CHKN ;verify new entry

 K DIR W $C(7),?5

 S DIR(0)="Y",DIR("A")="ARE YOU ADDING A NEW DATE FOR THIS JOB"

 D ^DIR

 I +Y=0 S DA=+RDA,DIK="^RMPR(664.3," D ^DIK G TCH

CHK ;Check to see if GIP is on

 I $P(^RMPR(669.9,RMPRSITE,0),U,3) K DIC,PRCP G INV

JB ;process job data

 K DIC S DIC="^RMPR(664.2,"_RMPRWO_",1,",DIC("P")="664.22PA"

 S DA(1)=RMPRWO,DIC(0)="AEQMZL"

 S DIC("W")="S RR=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RR)"

 S DIC("S")="I '$P(^(0),U,11)&'$P(^(0),U,13)",DLAYGO=664.2

 W ! D ^DIC K DLAYGO

 I +Y'>0 G CDT

 S DA=+Y,ITM=$$ITM1^RMPR31U($P(Y,U,2)),VDR=$P($G(^PRC(440,+$P(Y(0),U,6),0)),U),COST=$P(Y(0),U,3) D:VDR="" ITV^RMPR29U(VDR,ITM) D:'COST ITC^RMPR29U(VDR,ITM)

EDT K DR S DIE="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO,DR=".01R;3R;5R//^S X=$G(VDR);I $P(^RMPR(664.2,DA(1),1,DA,0),U,4)=""V"" S $P(^(0),U,3)=0,Y=""@1"";2R//^S X=$J($G(COST),0,2);@1;1R;6R;7" D ^DIE G:$D(DTOUT) END

 I $D(DA) I $P(^RMPR(664.2,RMPRWO,1,DA,0),U,1)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="") S DIK=DIE,DA(1)=RMPRWO D ^DIK W !!,?5,$C(7),"Deleted..."

 G JB

INV ;INVENTORY POINT

 I '$D(^PRCP(445,"AD",DUZ)) W !!,?5,$C(7),"You are not an Inventory User" G CDT

 W ! S DIC="^PRCP(445,",DIC(0)="AEQMZ",DIC("A")="Select INVENTORY POINT: ",DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))",PRCPPRIV=1 D ^DIC G:+Y'>0 CDT S (RMPRINV,PRCP("I"))=+Y

IMU W ! K DIR,VEN

 S DIR(0)="FO",DIR("A")="MATERIALS USED"

 S DIR("?")="^S ZFL=1 D ZDSP^RMPR29R"

 D ^DIR G:$D(DTOUT) END G:$D(DIRUT) INV

 K DIC S DIC=661,DIC(0)="EQMZ"

 S DIC("S")="S RA=$P(^(0),U,1) I $D(^PRCP(445,""AE"",RA,PRCP(""I"")))"

 D ^DIC G:+Y'>0 IMU S HY=+Y,ITM=$P(Y,U,2)

 I $D(^RMPR(664.2,RMPRWO,1,"B",+Y)) S DA=$O(^RMPR(664.2,RMPRWO,1,"B",+Y,0)) W:$P(^RMPR(664.2,RMPRWO,1,DA,0),U,11) $C(7) G:$P(^(0),U,11) IMU S VEN=$P($G(^PRC(440,+$P(^(0),U,6),0)),U) G IEDT

 I '$D(^RMPR(664.2,RMPRWO,1,0)) S ^RMPR(664.2,RMPRWO,1,0)="^664.22PA^0^0"

 S DIC="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO,DIC(0)="LZ",X=HY D FILE^DICN G:+Y'>0 END S DA=+Y

IEDT S COST=$P(^RMPR(664.2,RMPRWO,1,DA,0),U,3)

 I 'COST D INVD^RMPR29U(PRCP("I"),ITM)

 S RDA=^RMPR(664.2,RMPRWO,1,DA,0)

 S DIE="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO,DR=".01;3R;4////^S X=RMPRINV;5//^S X=VEN;2///^S X=+$J($G(COST),0,2);I $P(^RMPR(664.2,DA(1),1,DA,0),U,4)=""V"" S $P(^RMPR(664.2,DA(1),1,DA,0),U,3)=0,Y=""@1"";2R;@1;1R;6R;7"

 D ^DIE G:$D(DTOUT) END

 I $D(DA) I $P(^RMPR(664.2,RMPRWO,1,DA,0),U,1)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="") S DIK=DIE,DA(1)=RMPRWO D ^DIK W !!,?5,$C(7),"Deleted..." G IMU

 I $D(PRCP) S RMPRINV=PRCP("I") D PINV S PRCP("I")=RMPRINV

 G IMU

PINV G:'$D(DA) REP S RNW=^RMPR(664.2,RMPRWO,1,DA,0) I +RNW=+RDA,$P(RNW,U,2)=$P(RDA,U,2),$P(RNW,U,5)=$P(RDA,U,5) Q

 W !!,$C(7),"POSTING TO INVENTORY",$P(^PRCP(445,RMPRINV,0),U,1)

REP I $P(RDA,U,5),$P(RDA,U,1),$P(RDA,U,2) S PRCP("QTY")=$P(RDA,U,2),PRCP("ITEM")=$P(^RMPR(661,$P(RDA,U,1),0),U,1),PRCP("TYP")="A" D

 .I $D(^PRCP(445,PRCP("I"),0)),$P(^(0),U,2)="Y" W:'$D(DA) $C(7),!!,?5,"UPDATING INVENTORY" D ^PRCPUSA D:$D(PRCP) ERR K RDA,RNW

 Q:'$D(DA)  S PRCP("I")=$P(^RMPR(664.2,RMPRWO,1,DA,0),U,5),PRCP("QTY")=$P(^(0),U,2)*-1,PRCP("ITEM")=$P(^RMPR(661,$P(^(0),U,1),0),U,1),PRCP("TYP")="R" D ^PRCPUSA K RDA,RNW I $D(PRCP) D ERR

 Q

END G DISP^RMPR29D

ERR W !!,$C(7),"ITEM DID NOT POST TO G.I.P." Q

CDT S DIE="^RMPR(664.2,",DR="12;10",DA=RMPRWO D ^DIE G:$D(Y) POST

 K RSTOP F RDA=0:0 S RDA=$O(^RMPR(664.2,RMPRWO,1,RDA)) Q:RDA'>0  I $D(^(RDA,0)) S RRA=^(0) D  I $D(RSTOP) H 3 Q

 .I $D(^RMPR(664,+$P(RRA,U,11),0)),'$P(^(0),U,8) W !!,$C(7),?5,"Work Order has a 2421 Request that has not been Delivered",!,?5,"This job cannot be completed" S RSTOP=1

 .I $D(^RMPR(664.1,+$P(RRA,U,13),0)),'$P(^(0),U,26) W !!,$C(7),?5,"Work Order has a 2529-3 Request that has not been Delivered",!,?5,"This job cannot be completed" S RSTOP=1

 I '$D(^RMPR(664.3,"C",DA660))&'$O(^RMPR(664.2,RMPRWO,1,0)) G POST

 I RDA G POST

 S:'$P(^RMPR(664.2,RMPRWO,0),U,11) $P(^(0),U,11)=DUZ S DIE="^RMPR(664.2,",DA=RMPRWO,DR="11;8" D ^DIE S DR=$S($P(^RMPR(664.2,RMPRWO,0),U,10):"9R",1:"9///@")

 D ^DIE

POST D POST^RMPR29U G MU

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPR29B   5322     printed  Feb 18, 2025@23:58:32                                                                                                                                                                                                     Page 2

RMPR29B   ;PHX/JLT-EDIT JOB SECTION[ 09/30/94  11:52 AM ]

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

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

MU        ;ENTER DATEE

 +1        DO DISP^RMPR29J

           IF '$DATA(RMPRWO)

               GOTO END

TCH       ;TECHNICIAN DATE

 +1       ;see internal notes

 +2        KILL DIR,DIC,DA,Y

 +3        SET DIR(0)="664.3,.01O"

           SET DIR("A")="Select DATE"

 +4        SET DIR("?")="^D LBR^RMPR29B"

           DO ^DIR

 +5        if $DATA(DTOUT)

               GOTO CDT

           if $DATA(DIRUT)

               GOTO CHK

 +6        DO SLK^RMPR29M

           DO ^DIC

           KILL DLAYGO,DIC

 +7        if +Y'>0

               GOTO TCH

           SET RDA=Y

 +8       ;verify new entry

 +9        IF $PIECE(Y,U,3)

               KILL DIR

               WRITE $CHAR(7),?5

               SET DIR(0)="Y"

               SET DIR("A")="ARE YOU ADDING A NEW DATE FOR THIS JOB"

               DO ^DIR

               if $DATA(DTOUT)!(X="^")

                   GOTO CHK

               IF +Y=0

                   SET DA=+RDA

                   SET DIK="^RMPR(664.3,"

                   DO ^DIK

                   GOTO TCH

 +10      ;

 +11       SET DA=+RDA

           SET DIE="^RMPR(664.3,"

 +12       SET DR=$SELECT($PIECE(RDA,U,3):"1////^S X=DA660;2////^S X=RMPR(""STA"");.01",1:".01")

 +13       DO ^DIE

           IF '$DATA(DA)

               GOTO TCH

 +14       KILL DIC,Y,DA

           SET DA(1)=+RDA

           SET DLAYGO=664.3

           SET DIC(0)="AEQLM"

 +15       SET DIC="^RMPR(664.3,"_DA(1)_",1,"

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

 +16       SET DIC("B")=$$EMP^RMPR31U(DUZ)

           DO ^DIC

           KILL DLAYGO

 +17      ;

 +18       IF +Y>0

               SET DIE=DIC

               SET DA(1)=+RDA

               SET DA=+Y

               SET DR=".01;1"

               DO ^DIE

               IF $DATA(DA)

                   SET EMP=+$PIECE($GET(^RMPR(664.3,DA(1),1,DA,0)),U)

                   if '$PIECE(^RMPR(664.3,DA(1),1,DA,0),U,3)

                       SET $PIECE(^RMPR(664.3,DA(1),1,DA,0),U,3)=$$PAID^RMPR29U(EMP)

                   SET DIE=DIC

                   SET DR="2R"

                   DO ^DIE

 +19       GOTO TCH

 +20      ;

LBR       ;Help for DIR

 +1        DO SLK^RMPR29M

           SET X="?"

           DO ^DIC

           KILL DIC,DLAYGO

 +2        QUIT 

CHKN      ;verify new entry

 +1        KILL DIR

           WRITE $CHAR(7),?5

 +2        SET DIR(0)="Y"

           SET DIR("A")="ARE YOU ADDING A NEW DATE FOR THIS JOB"

 +3        DO ^DIR

 +4        IF +Y=0

               SET DA=+RDA

               SET DIK="^RMPR(664.3,"

               DO ^DIK

               GOTO TCH

CHK       ;Check to see if GIP is on

 +1        IF $PIECE(^RMPR(669.9,RMPRSITE,0),U,3)

               KILL DIC,PRCP

               GOTO INV

JB        ;process job data

 +1        KILL DIC

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

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

 +2        SET DA(1)=RMPRWO

           SET DIC(0)="AEQMZL"

 +3        SET DIC("W")="S RR=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RR)"

 +4        SET DIC("S")="I '$P(^(0),U,11)&'$P(^(0),U,13)"

           SET DLAYGO=664.2

 +5        WRITE !

           DO ^DIC

           KILL DLAYGO

 +6        IF +Y'>0

               GOTO CDT

 +7        SET DA=+Y

           SET ITM=$$ITM1^RMPR31U($PIECE(Y,U,2))

           SET VDR=$PIECE($GET(^PRC(440,+$PIECE(Y(0),U,6),0)),U)

           SET COST=$PIECE(Y(0),U,3)

           if VDR=""

               DO ITV^RMPR29U(VDR,ITM)

           if 'COST

               DO ITC^RMPR29U(VDR,ITM)

EDT        KILL DR

           SET DIE="^RMPR(664.2,"_RMPRWO_",1,"

           SET DA(1)=RMPRWO

           SET DR=".01R;3R;5R//^S X=$G(VDR);I $P(^RMPR(664.2,DA(1),1,DA,0),U,4)=""V"" S $P(^(0),U,3)=0,Y=""@1"";2R//^S X=$J($G(COST),0,2);@1;1R;6R;7"

           DO ^DIE

           if $DATA(DTOUT)

               GOTO END

 +1        IF $DATA(DA)

               IF $PIECE(^RMPR(664.2,RMPRWO,1,DA,0),U,1)=""!($PIECE(^(0),U,2)="")!($PIECE(^(0),U,3)="")

                   SET DIK=DIE

                   SET DA(1)=RMPRWO

                   DO ^DIK

                   WRITE !!,?5,$CHAR(7),"Deleted..."

 +2        GOTO JB

INV       ;INVENTORY POINT

 +1        IF '$DATA(^PRCP(445,"AD",DUZ))

               WRITE !!,?5,$CHAR(7),"You are not an Inventory User"

               GOTO CDT

 +2        WRITE !

           SET DIC="^PRCP(445,"

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select INVENTORY POINT: "

           SET DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))"

           SET PRCPPRIV=1

           DO ^DIC

           if +Y'>0

               GOTO CDT

           SET (RMPRINV,PRCP("I"))=+Y

IMU        WRITE !

           KILL DIR,VEN

 +1        SET DIR(0)="FO"

           SET DIR("A")="MATERIALS USED"

 +2        SET DIR("?")="^S ZFL=1 D ZDSP^RMPR29R"

 +3        DO ^DIR

           if $DATA(DTOUT)

               GOTO END

           if $DATA(DIRUT)

               GOTO INV

 +4        KILL DIC

           SET DIC=661

           SET DIC(0)="EQMZ"

 +5        SET DIC("S")="S RA=$P(^(0),U,1) I $D(^PRCP(445,""AE"",RA,PRCP(""I"")))"

 +6        DO ^DIC

           if +Y'>0

               GOTO IMU

           SET HY=+Y

           SET ITM=$PIECE(Y,U,2)

 +7        IF $DATA(^RMPR(664.2,RMPRWO,1,"B",+Y))

               SET DA=$ORDER(^RMPR(664.2,RMPRWO,1,"B",+Y,0))

               if $PIECE(^RMPR(664.2,RMPRWO,1,DA,0),U,11)

                   WRITE $CHAR(7)

               if $PIECE(^(0),U,11)

                   GOTO IMU

               SET VEN=$PIECE($GET(^PRC(440,+$PIECE(^(0),U,6),0)),U)

               GOTO IEDT

 +8        IF '$DATA(^RMPR(664.2,RMPRWO,1,0))

               SET ^RMPR(664.2,RMPRWO,1,0)="^664.22PA^0^0"

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

           SET DA(1)=RMPRWO

           SET DIC(0)="LZ"

           SET X=HY

           DO FILE^DICN

           if +Y'>0

               GOTO END

           SET DA=+Y

IEDT       SET COST=$PIECE(^RMPR(664.2,RMPRWO,1,DA,0),U,3)

 +1        IF 'COST

               DO INVD^RMPR29U(PRCP("I"),ITM)

 +2        SET RDA=^RMPR(664.2,RMPRWO,1,DA,0)

 +3        SET DIE="^RMPR(664.2,"_RMPRWO_",1,"

           SET DA(1)=RMPRWO

           SET DR=".01;3R;4////^S X=RMPRINV;5//^S X=VEN;2///^S X=+$J($G(COST),0,2);I $P(^RMPR(664.2,DA(1),1,DA,0),U,4)=""V"" S $P(^RMPR(664.2,DA(1),1,DA,0),U,3)=0,Y=""@1"";2R;@1;1R;6R;7"

 +4        DO ^DIE

           if $DATA(DTOUT)

               GOTO END

 +5        IF $DATA(DA)

               IF $PIECE(^RMPR(664.2,RMPRWO,1,DA,0),U,1)=""!($PIECE(^(0),U,2)="")!($PIECE(^(0),U,3)="")

                   SET DIK=DIE

                   SET DA(1)=RMPRWO

                   DO ^DIK

                   WRITE !!,?5,$CHAR(7),"Deleted..."

                   GOTO IMU

 +6        IF $DATA(PRCP)

               SET RMPRINV=PRCP("I")

               DO PINV

               SET PRCP("I")=RMPRINV

 +7        GOTO IMU

PINV       if '$DATA(DA)

               GOTO REP

           SET RNW=^RMPR(664.2,RMPRWO,1,DA,0)

           IF +RNW=+RDA

               IF $PIECE(RNW,U,2)=$PIECE(RDA,U,2)

                   IF $PIECE(RNW,U,5)=$PIECE(RDA,U,5)

                       QUIT 

 +1        WRITE !!,$CHAR(7),"POSTING TO INVENTORY",$PIECE(^PRCP(445,RMPRINV,0),U,1)

REP        IF $PIECE(RDA,U,5)

               IF $PIECE(RDA,U,1)

                   IF $PIECE(RDA,U,2)

                       SET PRCP("QTY")=$PIECE(RDA,U,2)

                       SET PRCP("ITEM")=$PIECE(^RMPR(661,$PIECE(RDA,U,1),0),U,1)

                       SET PRCP("TYP")="A"

                       Begin DoDot:1

 +1                        IF $DATA(^PRCP(445,PRCP("I"),0))

                               IF $PIECE(^(0),U,2)="Y"

                                   if '$DATA(DA)

                                       WRITE $CHAR(7),!!,?5,"UPDATING INVENTORY"

                                   DO ^PRCPUSA

                                   if $DATA(PRCP)

                                       DO ERR

                                   KILL RDA,RNW

                       End DoDot:1

 +2        if '$DATA(DA)

               QUIT 

           SET PRCP("I")=$PIECE(^RMPR(664.2,RMPRWO,1,DA,0),U,5)

           SET PRCP("QTY")=$PIECE(^(0),U,2)*-1

           SET PRCP("ITEM")=$PIECE(^RMPR(661,$PIECE(^(0),U,1),0),U,1)

           SET PRCP("TYP")="R"

           DO ^PRCPUSA

           KILL RDA,RNW

           IF $DATA(PRCP)

               DO ERR

 +3        QUIT 

END        GOTO DISP^RMPR29D

ERR        WRITE !!,$CHAR(7),"ITEM DID NOT POST TO G.I.P."

           QUIT 

CDT        SET DIE="^RMPR(664.2,"

           SET DR="12;10"

           SET DA=RMPRWO

           DO ^DIE

           if $DATA(Y)

               GOTO POST

 +1        KILL RSTOP

           FOR RDA=0:0

               SET RDA=$ORDER(^RMPR(664.2,RMPRWO,1,RDA))

               if RDA'>0

                   QUIT 

               IF $DATA(^(RDA,0))

                   SET RRA=^(0)

                   Begin DoDot:1

 +2                    IF $DATA(^RMPR(664,+$PIECE(RRA,U,11),0))

                           IF '$PIECE(^(0),U,8)

                               WRITE !!,$CHAR(7),?5,"Work Order has a 2421 Request that has not been Delivered",!,?5,"This job cannot be completed"

                               SET RSTOP=1

 +3                    IF $DATA(^RMPR(664.1,+$PIECE(RRA,U,13),0))

                           IF '$PIECE(^(0),U,26)

                               WRITE !!,$CHAR(7),?5,"Work Order has a 2529-3 Request that has not been Delivered",!,?5,"This job cannot be completed"

                               SET RSTOP=1

                   End DoDot:1

                   IF $DATA(RSTOP)

                       HANG 3

                       QUIT 

 +4        IF '$DATA(^RMPR(664.3,"C",DA660))&'$ORDER(^RMPR(664.2,RMPRWO,1,0))

               GOTO POST

 +5        IF RDA

               GOTO POST

 +6        if '$PIECE(^RMPR(664.2,RMPRWO,0),U,11)

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

           SET DIE="^RMPR(664.2,"

           SET DA=RMPRWO

           SET DR="11;8"

           DO ^DIE

           SET DR=$SELECT($PIECE(^RMPR(664.2,RMPRWO,0),U,10):"9R",1:"9///@")

 +7        DO ^DIE

POST       DO POST^RMPR29U

           GOTO MU