- 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 23, 2025@18:51 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
