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