RMPFET83 ;DDC/KAW-CONTINUATION OF RMPFET82 [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
;;Get cancel reason and change status of line item for CHA order
;; input: RMPFX,RMPFY,RMPFHAT,RMPFTYP,RMPFST,DFN,RMPFCAN
;;output: None
Q:'$D(RMPFCAN)
S RMPFX1=RMPFX,RMPFHAT1=RMPFHAT,RMPFTYP1=RMPFTYP,RMPFST1=RMPFST
S RMPFTYP=9,RMPFHAT="U",X=$G(^RMPF(791810,RMPFX,2))
S RMPFTE=$P(X,U,2)_U_$P(X,U,4),RMPFST=2
NEW D AUTO^RMPFET1
S (C,PP)=0 F S PP=$O(RMPFCAN(PP)) Q:'PP D
.S C=C+1
.I '$D(^RMPF(791810,RMPFX,101,0)) S ^RMPF(791810,RMPFX,101,0)="^791810.0101P"
.S ^RMPF(791810,RMPFX,101,PP,0)=$P(^RMPF(791810,RMPFX1,101,PP,0),U,1,14)
.S %DT="T",X="NOW" D ^%DT S TD=Y
.S DIK="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=PP D IX1^DIK
.S RMPFIT=$P(^RMPF(791810,RMPFX,101,PP,0),U,1),RMPFQTY=$P(^(0),U,6)
.I RMPFIT,$D(^RMPF(791811,RMPFIT,0)) S RMPFIT=$P(^(0),U,1)
.W !!,"Item # ",C,": ",RMPFIT,?$X+5,RMPFQTY,!
.S DIE=DIK,DR=".15////O;.16////"_PP_";.17////"_TD_";.18////3;.19////O;.2////1;90.13////"_DUZ
.I $D(RMPFRE) S DR=DR_";90.05////"_RMPFRE_";90.06////"_RMPFRTC
.D ^DIE
.I RMPFHAT1="I" D
..S RMPFSN=$P(^RMPF(791810,RMPFX,101,PP,0),U,5)
..I RMPFSN'="" W !,"Serial Number: ",RMPFSN
..S DR="90.05;90.06" I RMPFSN="" S DR=".05;"_DR
..D ^DIE
.S S9=$G(^RMPF(791810,RMPFX,101,PP,90))
.S RMPFRE=$P(S9,U,5),RMPFRTC=$P(S9,U,6)
.S DIE="^RMPF(791810,"_RMPFX1_",101,",DA(1)=RMPFX1,DA=PP
.S DR=".15////C;.17////"_TD_";.18////11;.19////C;.2////1;.14///0;90.13///"_DUZ
.I "CI"[RMPFHAT1 S DR=DR_";90.05////"_RMPFRE_";90.06////"_RMPFRTC
.D ^DIE
S $P(^RMPF(791810,RMPFX,101,0),U,3)=PP,$P(^(0),U,4)=C
S PO=$P(^RMPF(791810,RMPFX1,0),U,7)
S DIE="^RMPF(791810,",DA=RMPFX W !
S DR=".08////"_DUZ_";.09////"_DT_";.07////"_PO_";10.01" D ^DIE
W !!,"Item",$S(C=1:"",1:"(s)")," CANCELED",!!
S RMPFHAT="U",X=$P(^RMPF(791810,RMPFX,0),U,2)
I X,$D(^RMPF(791810.1,X,0)) S RMPFHAT=$P(^(0),U,2)
D APPROV1^RMPFEA2
S Y=$O(^RMPF(791810.2,"C","APPROVED",0)) G EXIT:'Y
D ARRAY^RMPFDT2 S X=0
F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,0)),$P(^(0),U,18)=Y S DIE="^RMPF(791810,",DA=RMPFX,DR=".03///APPROVED" D ^DIE Q
EXIT S RMPFX=RMPFX1,RMPFHAT=RMPFHAT1,RMPFST=RMPFST1,RMPFTYP=RMPFTYP1
CANCELE K DIE,DR,DA,X,D,D0,DI,DIC,DQ,%DT,RX,TD,ZY,ZZ,RMPFX1,RMPFY,RMPFSSN
K C,RMPFHAT1,PP,PO,RMPFSN,S9,RMPFRTC,RMPFRE,RMPFQTY,RMPFIT,RMPFCAN
K RMPFST1,RMPFTYP1,RMPFTE,ST,Y Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET83 2428 printed Apr 09, 2024@21:39:31 Page 2
RMPFET83 ;DDC/KAW-CONTINUATION OF RMPFET82 [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 ;;Get cancel reason and change status of line item for CHA order
+3 ;; input: RMPFX,RMPFY,RMPFHAT,RMPFTYP,RMPFST,DFN,RMPFCAN
+4 ;;output: None
+5 if '$DATA(RMPFCAN)
QUIT
+6 SET RMPFX1=RMPFX
SET RMPFHAT1=RMPFHAT
SET RMPFTYP1=RMPFTYP
SET RMPFST1=RMPFST
+7 SET RMPFTYP=9
SET RMPFHAT="U"
SET X=$GET(^RMPF(791810,RMPFX,2))
+8 SET RMPFTE=$PIECE(X,U,2)_U_$PIECE(X,U,4)
SET RMPFST=2
NEW DO AUTO^RMPFET1
+1 SET (C,PP)=0
FOR
SET PP=$ORDER(RMPFCAN(PP))
if 'PP
QUIT
Begin DoDot:1
+2 SET C=C+1
+3 IF '$DATA(^RMPF(791810,RMPFX,101,0))
SET ^RMPF(791810,RMPFX,101,0)="^791810.0101P"
+4 SET ^RMPF(791810,RMPFX,101,PP,0)=$PIECE(^RMPF(791810,RMPFX1,101,PP,0),U,1,14)
+5 SET %DT="T"
SET X="NOW"
DO ^%DT
SET TD=Y
+6 SET DIK="^RMPF(791810,"_RMPFX_",101,"
SET DA(1)=RMPFX
SET DA=PP
DO IX1^DIK
+7 SET RMPFIT=$PIECE(^RMPF(791810,RMPFX,101,PP,0),U,1)
SET RMPFQTY=$PIECE(^(0),U,6)
+8 IF RMPFIT
IF $DATA(^RMPF(791811,RMPFIT,0))
SET RMPFIT=$PIECE(^(0),U,1)
+9 WRITE !!,"Item # ",C,": ",RMPFIT,?$X+5,RMPFQTY,!
+10 SET DIE=DIK
SET DR=".15////O;.16////"_PP_";.17////"_TD_";.18////3;.19////O;.2////1;90.13////"_DUZ
+11 IF $DATA(RMPFRE)
SET DR=DR_";90.05////"_RMPFRE_";90.06////"_RMPFRTC
+12 DO ^DIE
+13 IF RMPFHAT1="I"
Begin DoDot:2
+14 SET RMPFSN=$PIECE(^RMPF(791810,RMPFX,101,PP,0),U,5)
+15 IF RMPFSN'=""
WRITE !,"Serial Number: ",RMPFSN
+16 SET DR="90.05;90.06"
IF RMPFSN=""
SET DR=".05;"_DR
+17 DO ^DIE
End DoDot:2
+18 SET S9=$GET(^RMPF(791810,RMPFX,101,PP,90))
+19 SET RMPFRE=$PIECE(S9,U,5)
SET RMPFRTC=$PIECE(S9,U,6)
+20 SET DIE="^RMPF(791810,"_RMPFX1_",101,"
SET DA(1)=RMPFX1
SET DA=PP
+21 SET DR=".15////C;.17////"_TD_";.18////11;.19////C;.2////1;.14///0;90.13///"_DUZ
+22 IF "CI"[RMPFHAT1
SET DR=DR_";90.05////"_RMPFRE_";90.06////"_RMPFRTC
+23 DO ^DIE
End DoDot:1
+24 SET $PIECE(^RMPF(791810,RMPFX,101,0),U,3)=PP
SET $PIECE(^(0),U,4)=C
+25 SET PO=$PIECE(^RMPF(791810,RMPFX1,0),U,7)
+26 SET DIE="^RMPF(791810,"
SET DA=RMPFX
WRITE !
+27 SET DR=".08////"_DUZ_";.09////"_DT_";.07////"_PO_";10.01"
DO ^DIE
+28 WRITE !!,"Item",$SELECT(C=1:"",1:"(s)")," CANCELED",!!
+29 SET RMPFHAT="U"
SET X=$PIECE(^RMPF(791810,RMPFX,0),U,2)
+30 IF X
IF $DATA(^RMPF(791810.1,X,0))
SET RMPFHAT=$PIECE(^(0),U,2)
+31 DO APPROV1^RMPFEA2
+32 SET Y=$ORDER(^RMPF(791810.2,"C","APPROVED",0))
if 'Y
GOTO EXIT
+33 DO ARRAY^RMPFDT2
SET X=0
+34 FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
IF $DATA(^RMPF(791810,RMPFX,101,X,0))
IF $PIECE(^(0),U,18)=Y
SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET DR=".03///APPROVED"
DO ^DIE
QUIT
EXIT SET RMPFX=RMPFX1
SET RMPFHAT=RMPFHAT1
SET RMPFST=RMPFST1
SET RMPFTYP=RMPFTYP1
CANCELE KILL DIE,DR,DA,X,D,D0,DI,DIC,DQ,%DT,RX,TD,ZY,ZZ,RMPFX1,RMPFY,RMPFSSN
+1 KILL C,RMPFHAT1,PP,PO,RMPFSN,S9,RMPFRTC,RMPFRE,RMPFQTY,RMPFIT,RMPFCAN
+2 KILL RMPFST1,RMPFTYP1,RMPFTE,ST,Y
QUIT
