RMPR29LS ;HIN/RVD-LAB STOCK ISSUE SET UTILITY ;11/05/98
;;3.0;PROSTHETICS;**33,37**;Feb 09,1996
ST ;set data in 2529-3 file
S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),DA=RMPRDA,DIE="^RMPR(664.1,"
S DR=".03////^S X=$G(RMPR(""STA""));.04////^S X=$G(RMPR(""STA""));.09///^S X=$G(DT);2///O;.11////^S X=$G(RMPR(""STA""))"
D ^DIE D:$D(Y)!($D(DTOUT)) CHK^RMPR29LU
Q
SG ;set 2529-3 global
S $P(^RMPR(664.1,RMPRDA,0),U,13)=$G(RMPRWO)
S $P(^RMPR(664.1,RMPRDA,0),U,5)=DUZ,$P(^(0),U,18)=DT D ^RMPR29LA
I $G(RMPRWO)'="" W !!,?5,"Assigned Work Order Number: ",RMPRWO D
.S RMWO=$O(^RMPR(664.2,"B",RMPRWO,0))
.F I=0:0 S I=$O(^RMPR(664.1,RMPRDA,2,I)) Q:I'>0 S RM0=$G(^RMPR(664.1,RMPRDA,2,I,0)) D
..S RMITEM=$P(RM0,U,1),RMQTY=$P(RM0,U,2),RMCO=$P(RM0,U,4),RMUNI=$P(RM0,U,3)
..S RM660=$P(RM0,U,5)
..Q:'RMWO S DA(1)=RMWO,DIC="^RMPR(664.2,"_DA(1)_",1,",X=RMITEM,DIC("P")="664.22PA"
..K DD,DO I '$D(^RMPR(664.2,RMWO,1,"B",RMITEM)) S DIC(0)="L",DLAYGO=664.2 D FILE^DICN
..S RMIDA=$O(^RMPR(664.2,RMWO,1,"B",RMITEM,0))
..S ^RMPR(664.2,RMWO,1,RMIDA,0)=RMITEM_"^"_RMQTY_"^"_RMCO_"^^^"_RMUNI_"^^^^^^"_RM660_"^"_RMPRDA
..S DA=RMIDA,DIK=DIC D IX1^DIK K DA,DD,DO
S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///S" D ^DIE
Q
;
GD ;Display work order
D DIS^RMPR29W(RMPRDFN,RMPRDA) I Y'>0 S RMFLG=1 Q
K DR,DA,DIC,DIE S DIC="^RMPR(664.1,"_RMPRDA_",1,"
S DIC("P")="664.15PA",DA(1)=RMPRDA
S DIC(0)="EQMZL",X=Y(0,0),ELG=$P(Y(0),U,3) D ^DIC Q:+Y'>0
S DIE=DIC,DA(1)=RMPRDA,DA=+Y K DIC
S DR="1///^S X=ELG;.01;1" D ^DIE D:$D(DTOUT)!($D(Y)) CHK^RMPR29LU
K DR,DIE
Q
;
INV S DIC="^PRCP(445,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" S:$D(RMGIP) DIC("B")=RMGIP
D ^DIC I Y<0!$D(DTOUT)!$D(DUOUT) S RMEXIT=1 Q
S (PRCP("I"),RMGIP)=+Y,PRCP("ITEM")=RMITEMS
S PRCP("TYP")="R"
INVITEM I $D(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)) G GIP
W !!,"*** ITEM IS NOT IN GIP, UNABLE TO ISSUE THIS ITEM ......."
S DA(1)=RMPRDA,DA=RMIDA,DIK="^RMPR(664.1,"_DA(1)_",2," D ^DIK
K ^RMPR(664.1,RMPRDA,2,RMIDA)
S RDEL=1 Q
GIP ;gip on
S RMINVF="GIP"
V I +$P($G(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,12),$D(^PRC(440,+$P(^(0),U,12),0)) S DIC("B")=+$P($G(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,12)
Q
;
SET S DIE(0)="AEQM",DA(1)=RMPRDA,DA=RMIDA,DIE="^RMPR(664.1,"_RMPRDA_",2,"
S DR="2///^S X=$G(RMQTYS);4///^S X=$G(RMCOS);12///^S X=$G(RMSER);8///^S X=$G(RMTYPS);9///^S X=$G(RMCATS);10///^S X=$G(RMSPES);16///^S X=$G(RMIT);14///^S X=$G(RMSOR);13///^S X=$G(RMHS)"
D ^DIE G:$D(DTOUT)!$D(DUOUT) EXIT
;S RM0=$G(^RMPR(664.1,RMPRDA,2,DA,0)),RMQTY=$P(RM0,U,2),RMCO=$P(RM0,U,4)
S:$G(RMQTY) RMTOCO=RMQTY*RMCOS,DR="11///^S X=$G(RMTOCO)" D ^DIE
S:$G(RMLOC) $P(^RMPR(664.1,RMPRDA,2,DA,3),U,4)=$G(RMLOC),$P(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=""
S:$G(RMGIP) $P(^RMPR(664.1,RMPRDA,2,DA,3),U,4)="",$P(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=RMGIP
S:$G(RMVEN) $P(^RMPR(664.1,RMPRDA,2,DA,3),U,2)=$G(RMVEN)
Q
;
EXIT ;common exit
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29LS 2957 printed Dec 13, 2024@02:32:20 Page 2
RMPR29LS ;HIN/RVD-LAB STOCK ISSUE SET UTILITY ;11/05/98
+1 ;;3.0;PROSTHETICS;**33,37**;Feb 09,1996
ST ;set data in 2529-3 file
+1 SET RMPRDFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
SET DA=RMPRDA
SET DIE="^RMPR(664.1,"
+2 SET DR=".03////^S X=$G(RMPR(""STA""));.04////^S X=$G(RMPR(""STA""));.09///^S X=$G(DT);2///O;.11////^S X=$G(RMPR(""STA""))"
+3 DO ^DIE
if $DATA(Y)!($DATA(DTOUT))
DO CHK^RMPR29LU
+4 QUIT
SG ;set 2529-3 global
+1 SET $PIECE(^RMPR(664.1,RMPRDA,0),U,13)=$GET(RMPRWO)
+2 SET $PIECE(^RMPR(664.1,RMPRDA,0),U,5)=DUZ
SET $PIECE(^(0),U,18)=DT
DO ^RMPR29LA
+3 IF $GET(RMPRWO)'=""
WRITE !!,?5,"Assigned Work Order Number: ",RMPRWO
Begin DoDot:1
+4 SET RMWO=$ORDER(^RMPR(664.2,"B",RMPRWO,0))
+5 FOR I=0:0
SET I=$ORDER(^RMPR(664.1,RMPRDA,2,I))
if I'>0
QUIT
SET RM0=$GET(^RMPR(664.1,RMPRDA,2,I,0))
Begin DoDot:2
+6 SET RMITEM=$PIECE(RM0,U,1)
SET RMQTY=$PIECE(RM0,U,2)
SET RMCO=$PIECE(RM0,U,4)
SET RMUNI=$PIECE(RM0,U,3)
+7 SET RM660=$PIECE(RM0,U,5)
+8 if 'RMWO
QUIT
SET DA(1)=RMWO
SET DIC="^RMPR(664.2,"_DA(1)_",1,"
SET X=RMITEM
SET DIC("P")="664.22PA"
+9 KILL DD,DO
IF '$DATA(^RMPR(664.2,RMWO,1,"B",RMITEM))
SET DIC(0)="L"
SET DLAYGO=664.2
DO FILE^DICN
+10 SET RMIDA=$ORDER(^RMPR(664.2,RMWO,1,"B",RMITEM,0))
+11 SET ^RMPR(664.2,RMWO,1,RMIDA,0)=RMITEM_"^"_RMQTY_"^"_RMCO_"^^^"_RMUNI_"^^^^^^"_RM660_"^"_RMPRDA
+12 SET DA=RMIDA
SET DIK=DIC
DO IX1^DIK
KILL DA,DD,DO
End DoDot:2
End DoDot:1
+13 SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="16///S"
DO ^DIE
+14 QUIT
+15 ;
GD ;Display work order
+1 DO DIS^RMPR29W(RMPRDFN,RMPRDA)
IF Y'>0
SET RMFLG=1
QUIT
+2 KILL DR,DA,DIC,DIE
SET DIC="^RMPR(664.1,"_RMPRDA_",1,"
+3 SET DIC("P")="664.15PA"
SET DA(1)=RMPRDA
+4 SET DIC(0)="EQMZL"
SET X=Y(0,0)
SET ELG=$PIECE(Y(0),U,3)
DO ^DIC
if +Y'>0
QUIT
+5 SET DIE=DIC
SET DA(1)=RMPRDA
SET DA=+Y
KILL DIC
+6 SET DR="1///^S X=ELG;.01;1"
DO ^DIE
if $DATA(DTOUT)!($DATA(Y))
DO CHK^RMPR29LU
+7 KILL DR,DIE
+8 QUIT
+9 ;
INV SET DIC="^PRCP(445,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))"
if $DATA(RMGIP)
SET DIC("B")=RMGIP
+1 DO ^DIC
IF Y<0!$DATA(DTOUT)!$DATA(DUOUT)
SET RMEXIT=1
QUIT
+2 SET (PRCP("I"),RMGIP)=+Y
SET PRCP("ITEM")=RMITEMS
+3 SET PRCP("TYP")="R"
INVITEM IF $DATA(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0))
GOTO GIP
+1 WRITE !!,"*** ITEM IS NOT IN GIP, UNABLE TO ISSUE THIS ITEM ......."
+2 SET DA(1)=RMPRDA
SET DA=RMIDA
SET DIK="^RMPR(664.1,"_DA(1)_",2,"
DO ^DIK
+3 KILL ^RMPR(664.1,RMPRDA,2,RMIDA)
+4 SET RDEL=1
QUIT
GIP ;gip on
+1 SET RMINVF="GIP"
V IF +$PIECE($GET(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,12)
IF $DATA(^PRC(440,+$PIECE(^(0),U,12),0))
SET DIC("B")=+$PIECE($GET(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,12)
+1 QUIT
+2 ;
SET SET DIE(0)="AEQM"
SET DA(1)=RMPRDA
SET DA=RMIDA
SET DIE="^RMPR(664.1,"_RMPRDA_",2,"
+1 SET DR="2///^S X=$G(RMQTYS);4///^S X=$G(RMCOS);12///^S X=$G(RMSER);8///^S X=$G(RMTYPS);9///^S X=$G(RMCATS);10///^S X=$G(RMSPES);16///^S X=$G(RMIT);14///^S X=$G(RMSOR);13///^S X=$G(RMHS)"
+2 DO ^DIE
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+3 ;S RM0=$G(^RMPR(664.1,RMPRDA,2,DA,0)),RMQTY=$P(RM0,U,2),RMCO=$P(RM0,U,4)
+4 if $GET(RMQTY)
SET RMTOCO=RMQTY*RMCOS
SET DR="11///^S X=$G(RMTOCO)"
DO ^DIE
+5 if $GET(RMLOC)
SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,3),U,4)=$GET(RMLOC)
SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=""
+6 if $GET(RMGIP)
SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,3),U,4)=""
SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=RMGIP
+7 if $GET(RMVEN)
SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,3),U,2)=$GET(RMVEN)
+8 QUIT
+9 ;
EXIT ;common exit
+1 QUIT
