- RMPR4FSH ;PHX/HNB- MISC UTILITY PURCHASE CARD MODULE ;March 11, 1996
- ;;3.0;PROSTHETICS;**3**;Feb 09, 1996
- EN1 ;RESET 664 ITEMS AFTER CLOSE OUT
- F RI=0:0 S RI=$O(^TMP($J,1,RI)) Q:RI'>0 I '$D(^RMPR(664,RMPRA,1,RI,0)) D LPC
- K %X,%Y,RI Q
- EN2 ;REST 664 ITEMS IF NOT CLOSED OUT
- F RI=0:0 S RI=$O(^TMP($J,1,RI)) Q:RI'>0 I '$D(^RMPR(664,RMPRA,1,RI,0)) D LP
- I '$D(RMX) F RI=0:0 S RI=$O(^TMP($J,1,RI)) Q:RI'>0 S %X="^TMP($J,1,RI,",%Y="^RMPR(664,RMPRA,1,RI," D %XY^%RCR S DA(1)=RMPRA,DA=RI,DIK="^RMPR(664,"_RMPRA_",1," D IX^DIK
- K RMX,%Y,%X,RI S $P(^RMPR(664,RMPRA,2),U,6)="" Q
- LP ;SET DATA
- I $D(^TMP($J,1,RI,0)) S RA=$P(^(0),U,13),RT=^TMP($J,RA,0) S X=$P(RT,U,1) K DD,DO S DIC="^RMPR(660,",DIC(0)="MLZ",DLAYGO=660 D FILE^DICN K DLAYGO
- S RDA=+Y,%X="^TMP($J,RA,",%Y="^RMPR(660,RDA," D %XY^%RCR S DA=RDA,DIK="^RMPR(660," D IX^DIK
- I $D(^TMP($J,1,RI,0)) S $P(^(0),U,13)=+RDA,%X="^TMP($J,1,RI,",%Y="^RMPR(664,RMPRA,1,RI," D %XY^%RCR S DA(1)=RMPRA,DA=RI,DIK="^RMPR(664,"_RMPRA_",1," D IX^DIK S RMX=1
- Q
- LPC I $D(^TMP($J,1,RI,0)) S RT=$P(^TMP($J,1,RI,0),U,13) I $D(^TMP($J,+RT,0)) S RT=$P(^TMP($J,+RT,0),U,13),$P(^TMP($J,1,RI,0),U,2)="NOT DELIVERED/ACCEPTED",$P(^(0),U,13)=""
- S %X="^TMP($J,1,RI,",%Y="^RMPR(664,RMPRA,1,RI," D %XY^%RCR S DA(1)=RMPRA,DA=RI,DIK="^RMPR(664,"_RMPRA_",1," D IX^DIK I $D(RMPRP) S $P(^RMPR(664,RMPRA,2),U,4)=RMPRP
- Q
- GET ;SET TMP GLOBAL WITH PURCHASING TRANSACTION BEFORE CHANGES
- S %X="^RMPR(664,RMPRA,1,",%Y="^TMP($J,1," D %XY^%RCR F RI=0:0 S RI=$O(^TMP($J,1,RI)) Q:RI'>0 I $D(^(RI,0)) S RA=$P(^(0),U,13) I $D(^RMPR(660,+RA,0)) S RMPRP=$P(^(0),U,13),%X="^RMPR(660,+RA,",%Y="^TMP($J,"_RA_"," D %XY^%RCR
- I S RMPRP="2421PC" I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,5)'="" S RMPRPSC=$P(^(2),U,5) D PSCAMT^RMPR4M
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4FSH 1749 printed Apr 23, 2025@18:47:18 Page 2
- RMPR4FSH ;PHX/HNB- MISC UTILITY PURCHASE CARD MODULE ;March 11, 1996
- +1 ;;3.0;PROSTHETICS;**3**;Feb 09, 1996
- EN1 ;RESET 664 ITEMS AFTER CLOSE OUT
- +1 FOR RI=0:0
- SET RI=$ORDER(^TMP($JOB,1,RI))
- if RI'>0
- QUIT
- IF '$DATA(^RMPR(664,RMPRA,1,RI,0))
- DO LPC
- +2 KILL %X,%Y,RI
- QUIT
- EN2 ;REST 664 ITEMS IF NOT CLOSED OUT
- +1 FOR RI=0:0
- SET RI=$ORDER(^TMP($JOB,1,RI))
- if RI'>0
- QUIT
- IF '$DATA(^RMPR(664,RMPRA,1,RI,0))
- DO LP
- +2 IF '$DATA(RMX)
- FOR RI=0:0
- SET RI=$ORDER(^TMP($JOB,1,RI))
- if RI'>0
- QUIT
- SET %X="^TMP($J,1,RI,"
- SET %Y="^RMPR(664,RMPRA,1,RI,"
- DO %XY^%RCR
- SET DA(1)=RMPRA
- SET DA=RI
- SET DIK="^RMPR(664,"_RMPRA_",1,"
- DO IX^DIK
- +3 KILL RMX,%Y,%X,RI
- SET $PIECE(^RMPR(664,RMPRA,2),U,6)=""
- QUIT
- LP ;SET DATA
- +1 IF $DATA(^TMP($JOB,1,RI,0))
- SET RA=$PIECE(^(0),U,13)
- SET RT=^TMP($JOB,RA,0)
- SET X=$PIECE(RT,U,1)
- KILL DD,DO
- SET DIC="^RMPR(660,"
- SET DIC(0)="MLZ"
- SET DLAYGO=660
- DO FILE^DICN
- KILL DLAYGO
- +2 SET RDA=+Y
- SET %X="^TMP($J,RA,"
- SET %Y="^RMPR(660,RDA,"
- DO %XY^%RCR
- SET DA=RDA
- SET DIK="^RMPR(660,"
- DO IX^DIK
- +3 IF $DATA(^TMP($JOB,1,RI,0))
- SET $PIECE(^(0),U,13)=+RDA
- SET %X="^TMP($J,1,RI,"
- SET %Y="^RMPR(664,RMPRA,1,RI,"
- DO %XY^%RCR
- SET DA(1)=RMPRA
- SET DA=RI
- SET DIK="^RMPR(664,"_RMPRA_",1,"
- DO IX^DIK
- SET RMX=1
- +4 QUIT
- LPC IF $DATA(^TMP($JOB,1,RI,0))
- SET RT=$PIECE(^TMP($JOB,1,RI,0),U,13)
- IF $DATA(^TMP($JOB,+RT,0))
- SET RT=$PIECE(^TMP($JOB,+RT,0),U,13)
- SET $PIECE(^TMP($JOB,1,RI,0),U,2)="NOT DELIVERED/ACCEPTED"
- SET $PIECE(^(0),U,13)=""
- +1 SET %X="^TMP($J,1,RI,"
- SET %Y="^RMPR(664,RMPRA,1,RI,"
- DO %XY^%RCR
- SET DA(1)=RMPRA
- SET DA=RI
- SET DIK="^RMPR(664,"_RMPRA_",1,"
- DO IX^DIK
- IF $DATA(RMPRP)
- SET $PIECE(^RMPR(664,RMPRA,2),U,4)=RMPRP
- +2 QUIT
- GET ;SET TMP GLOBAL WITH PURCHASING TRANSACTION BEFORE CHANGES
- +1 SET %X="^RMPR(664,RMPRA,1,"
- SET %Y="^TMP($J,1,"
- DO %XY^%RCR
- FOR RI=0:0
- SET RI=$ORDER(^TMP($JOB,1,RI))
- if RI'>0
- QUIT
- IF $DATA(^(RI,0))
- SET RA=$PIECE(^(0),U,13)
- IF $DATA(^RMPR(660,+RA,0))
- SET RMPRP=$PIECE(^(0),U,13)
- SET %X="^RMPR(660,+RA,"
- SET %Y="^TMP($J,"_RA_","
- DO %XY^%RCR
- +2 IF $TEST
- SET RMPRP="2421PC"
- IF $DATA(^RMPR(664,RMPRA,2))
- IF $PIECE(^(2),U,5)'=""
- SET RMPRPSC=$PIECE(^(2),U,5)
- DO PSCAMT^RMPR4M
- +3 QUIT
