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 ---[H[J[2J[HRMPR29B 5322 printed Dec 13, 2024@02:32:03 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
