RMPFQM1 ;DDC/KAW-CONTINUATION OF RMPFQM [ 03/27/98 2:00 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8,10,16**;MAY 30, 1995
LOAD S SX=XMRG,NM=$P(SX,U,1) S ST="" F IK=1:1:78 S ST=ST_" "
Q:NM'?3N.E7N.E K RMPFX D Q:'$D(RMPFX)
.S RMPFX=$P(SX,U,2) I 'RMPFX K RMPFX Q
.I '$D(^RMPF(791810,RMPFX,0)) K RMPFX Q
.I '$D(^RMPF(791810,RMPFX,201,0)) S ^RMPF(791810,RMPFX,201,0)="^791810.0201"
.S X="NOW",%DT="T" D ^%DT S TD=Y
.S DIC="^RMPF(791810,"_RMPFX_",201,",DIC(0)="L",DLAYGO=791810
.S X=MD,DA(1)=RMPFX K DD,DO D FILE^DICN I Y=-1 K RMPFX Q
.S FY=+Y,$P(^RMPF(791810,RMPFX,201,FY,0),U,2)=XMZ
.D BLANK
.S SM=^RMPF(791810,RMPFX,0),X=$P(SM,U,2)
.I X,$D(^RMPF(791810.1,X,0)) S RMPFTYP=$E(($P(^(0),U,8)_" "),1,6),RMPFHAT=$P(^(0),U,2)
.S X=$P(SM,U,4) I X S DFN=X D DEM^VADPT S Y=$E($P(VADM(2),U,1),1,15),RMPFNAM=$E(($P(VADM(1),U,1)_" "),1,15)_"-"_$E((Y_" "),6,9)
LINEI F IX=1:1 X XMREC Q:XMER=-1 S SX=XMRG,X=$P(SX,U,1) D Q:'$D(RMPFX)
.I X?3N.E D:X=301 AUTH S XMPOS=XMPOS-1 K RMPFX Q
.I '$D(^RMPF(791810,RMPFX,201,FY,101,0)) S ^RMPF(791810,RMPFX,201,FY,101,0)="^791810.201101^^"
.S DIC="^RMPF(791810,"_RMPFX_",201,"_FY_",101,",DA(2)=RMPFX
.S DA(1)=FY,DIC(0)="L",DLAYGO=791810,X=$P(SX,U,1)
.K DD,DO D FILE^DICN
.Q:Y=-1
.S X=$P(SX,U,9) I X'="" S $P(^RMPF(791810,RMPFX,0),U,7)=X,^RMPF(791810,"D",X,RMPFX)=""
.S $P(^RMPF(791810,RMPFX,201,FY,101,+Y,0),U,2,99)=$P(SX,U,2,99),$P(^(0),U,7)=""
.S X=$P(SX,U,1) I X["STATUS COMPLETE"!(X["ORDER PLACED")!(X["CANCELED")!(X["CERTIFICATION PROCESSED") S $P(^RMPF(791810,RMPFX,201,FY,101,+Y,0),U,6)=1
.S RMPFST=$P(SX,U,4),RMPFY=$P(SX,U,8)
.I RMPFY,RMPFHAT="I",$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,10),$P(^(0),U,8) S RMPFST=$O(^RMPF(791810.2,"B","COMPLETE",0))
.I RMPFST D
..I $D(^RMPF(791810.2,RMPFST,0)) S RMPFSTP=$E(($P(^(0),U,4)_" "),1,6)
..S Y=$P(SX,U,10)
..I Y?7N S RMPFSB=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
..I RMPFY S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY,DR=".18////"_RMPFST_";.17////"_TD S:RMPFST=11 DR=DR_";.15////C" D ^DIE
..I RMPFST=6!(RMPFST=10),'RMPFY S DA=0 F S DA=$O(^RMPF(791810,RMPFX,101,DA)) Q:'DA S DIE="^RMPF(791810,"_RMPFX_",101,",DR=".18////"_RMPFST_";.2////1" D ^DIE
..I RMPFST=6!(RMPFST=10) D REMOV^RMPFET10
..I RMPFST=17,RMPFHAT="C" S DIE="^RMPF(791810,",DA=RMPFX,DR=".02////5" D ^DIE
..S SC=$P($G(^RMPF(791810.2,RMPFST,0)),U,5) S:SC="" SC="E"
..I SC="E" D SETORD Q
..D ARRAY^RMPFDT2 S (E,P,X)=0
..F S X=$O(RMPFO(X)) Q:'X D
...S Y=RMPFO(X) Q:'Y Q:'$D(^RMPF(791810.2,Y,0)) S SC=$P(^(0),U,5) Q:SC=""
...I SC="E" S E=Y Q
...I SC="P" S P=Y
..I E>0 S RMPFST=E D SETORD Q
..I P>0 S RMPFST=P
..D SETORD
.I $D(RMPFY),RMPFY,$D(^RMPF(791810,RMPFX,101,RMPFY,0)) S S0=^(0) D
..S IT=$P(S0,U,1) Q:'IT
..I IT=1 S RMPFITP=$P($G(^RMPF(791810,RMPFX,101,RMPFY,2)),U,2)
..E S RMPFITP=$P($G(^RMPF(791811,IT,0)),U,1)
..S RMPFITP=$E(RMPFITP_" ",1,30)
.S CT=CT+1,XQSTXT(CT)=RMPFNAM_" "_RMPFTYP_" "_RMPFSTP_" "_RMPFITP_" "_RMPFSB
.D BLANK Q
Q
AUTH K ^RMPF(791810,RMPFX,301)
S ^RMPF(791810,RMPFX,301,0)="^791810.0301",CY=1,XMPOS=XMPOS-1
F IY=1:1 X XMREC Q:XMER=-1 S X=$P(XMRG,U,1),SX=$P(XMRG,U,2,99) D Q:X'=301
.I X'=301 S XMPOS=XMPOS-1 Q
.S ^RMPF(791810,RMPFX,301,CY,0)=SX
.S ^RMPF(791810,RMPFX,301,"B",$P(SX,U,1),CY)="",CY=CY+1
Q
SETORD S DIE="^RMPF(791810,",DA=RMPFX,DR=".03////"_RMPFST D ^DIE Q
BLANK S RMPFNAM=" "
S (RMPFSTP,RMPFTYP)=" "
S RMPFITP=" "
S RMPFSB=" "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFQM1 3579 printed Dec 13, 2024@02:36:48 Page 2
RMPFQM1 ;DDC/KAW-CONTINUATION OF RMPFQM [ 03/27/98 2:00 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8,10,16**;MAY 30, 1995
LOAD SET SX=XMRG
SET NM=$PIECE(SX,U,1)
SET ST=""
FOR IK=1:1:78
SET ST=ST_" "
+1 if NM'?3N.E7N.E
QUIT
KILL RMPFX
Begin DoDot:1
+2 SET RMPFX=$PIECE(SX,U,2)
IF 'RMPFX
KILL RMPFX
QUIT
+3 IF '$DATA(^RMPF(791810,RMPFX,0))
KILL RMPFX
QUIT
+4 IF '$DATA(^RMPF(791810,RMPFX,201,0))
SET ^RMPF(791810,RMPFX,201,0)="^791810.0201"
+5 SET X="NOW"
SET %DT="T"
DO ^%DT
SET TD=Y
+6 SET DIC="^RMPF(791810,"_RMPFX_",201,"
SET DIC(0)="L"
SET DLAYGO=791810
+7 SET X=MD
SET DA(1)=RMPFX
KILL DD,DO
DO FILE^DICN
IF Y=-1
KILL RMPFX
QUIT
+8 SET FY=+Y
SET $PIECE(^RMPF(791810,RMPFX,201,FY,0),U,2)=XMZ
+9 DO BLANK
+10 SET SM=^RMPF(791810,RMPFX,0)
SET X=$PIECE(SM,U,2)
+11 IF X
IF $DATA(^RMPF(791810.1,X,0))
SET RMPFTYP=$EXTRACT(($PIECE(^(0),U,8)_" "),1,6)
SET RMPFHAT=$PIECE(^(0),U,2)
+12 SET X=$PIECE(SM,U,4)
IF X
SET DFN=X
DO DEM^VADPT
SET Y=$EXTRACT($PIECE(VADM(2),U,1),1,15)
SET RMPFNAM=$EXTRACT(($PIECE(VADM(1),U,1)_" "),1,15)_"-"_$EXTRACT((Y_" "),6,9)
End DoDot:1
if '$DATA(RMPFX)
QUIT
LINEI FOR IX=1:1
XECUTE XMREC
if XMER=-1
QUIT
SET SX=XMRG
SET X=$PIECE(SX,U,1)
Begin DoDot:1
+1 IF X?3N.E
if X=301
DO AUTH
SET XMPOS=XMPOS-1
KILL RMPFX
QUIT
+2 IF '$DATA(^RMPF(791810,RMPFX,201,FY,101,0))
SET ^RMPF(791810,RMPFX,201,FY,101,0)="^791810.201101^^"
+3 SET DIC="^RMPF(791810,"_RMPFX_",201,"_FY_",101,"
SET DA(2)=RMPFX
+4 SET DA(1)=FY
SET DIC(0)="L"
SET DLAYGO=791810
SET X=$PIECE(SX,U,1)
+5 KILL DD,DO
DO FILE^DICN
+6 if Y=-1
QUIT
+7 SET X=$PIECE(SX,U,9)
IF X'=""
SET $PIECE(^RMPF(791810,RMPFX,0),U,7)=X
SET ^RMPF(791810,"D",X,RMPFX)=""
+8 SET $PIECE(^RMPF(791810,RMPFX,201,FY,101,+Y,0),U,2,99)=$PIECE(SX,U,2,99)
SET $PIECE(^(0),U,7)=""
+9 SET X=$PIECE(SX,U,1)
IF X["STATUS COMPLETE"!(X["ORDER PLACED")!(X["CANCELED")!(X["CERTIFICATION PROCESSED")
SET $PIECE(^RMPF(791810,RMPFX,201,FY,101,+Y,0),U,6)=1
+10 SET RMPFST=$PIECE(SX,U,4)
SET RMPFY=$PIECE(SX,U,8)
+11 IF RMPFY
IF RMPFHAT="I"
IF $PIECE($GET(^RMPF(791810,RMPFX,101,RMPFY,90)),U,10)
IF $PIECE(^(0),U,8)
SET RMPFST=$ORDER(^RMPF(791810.2,"B","COMPLETE",0))
+12 IF RMPFST
Begin DoDot:2
+13 IF $DATA(^RMPF(791810.2,RMPFST,0))
SET RMPFSTP=$EXTRACT(($PIECE(^(0),U,4)_" "),1,6)
+14 SET Y=$PIECE(SX,U,10)
+15 IF Y?7N
SET RMPFSB=$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,7)_"-"_($EXTRACT(Y,1,3)+1700)
+16 IF RMPFY
SET DIE="^RMPF(791810,"_RMPFX_",101,"
SET DA(1)=RMPFX
SET DA=RMPFY
SET DR=".18////"_RMPFST_";.17////"_TD
if RMPFST=11
SET DR=DR_";.15////C"
DO ^DIE
+17 IF RMPFST=6!(RMPFST=10)
IF 'RMPFY
SET DA=0
FOR
SET DA=$ORDER(^RMPF(791810,RMPFX,101,DA))
if 'DA
QUIT
SET DIE="^RMPF(791810,"_RMPFX_",101,"
SET DR=".18////"_RMPFST_";.2////1"
DO ^DIE
+18 IF RMPFST=6!(RMPFST=10)
DO REMOV^RMPFET10
+19 IF RMPFST=17
IF RMPFHAT="C"
SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET DR=".02////5"
DO ^DIE
+20 SET SC=$PIECE($GET(^RMPF(791810.2,RMPFST,0)),U,5)
if SC=""
SET SC="E"
+21 IF SC="E"
DO SETORD
QUIT
+22 DO ARRAY^RMPFDT2
SET (E,P,X)=0
+23 FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
Begin DoDot:3
+24 SET Y=RMPFO(X)
if 'Y
QUIT
if '$DATA(^RMPF(791810.2,Y,0))
QUIT
SET SC=$PIECE(^(0),U,5)
if SC=""
QUIT
+25 IF SC="E"
SET E=Y
QUIT
+26 IF SC="P"
SET P=Y
End DoDot:3
+27 IF E>0
SET RMPFST=E
DO SETORD
QUIT
+28 IF P>0
SET RMPFST=P
+29 DO SETORD
End DoDot:2
+30 IF $DATA(RMPFY)
IF RMPFY
IF $DATA(^RMPF(791810,RMPFX,101,RMPFY,0))
SET S0=^(0)
Begin DoDot:2
+31 SET IT=$PIECE(S0,U,1)
if 'IT
QUIT
+32 IF IT=1
SET RMPFITP=$PIECE($GET(^RMPF(791810,RMPFX,101,RMPFY,2)),U,2)
+33 IF '$TEST
SET RMPFITP=$PIECE($GET(^RMPF(791811,IT,0)),U,1)
+34 SET RMPFITP=$EXTRACT(RMPFITP_" ",1,30)
End DoDot:2
+35 SET CT=CT+1
SET XQSTXT(CT)=RMPFNAM_" "_RMPFTYP_" "_RMPFSTP_" "_RMPFITP_" "_RMPFSB
+36 DO BLANK
QUIT
End DoDot:1
if '$DATA(RMPFX)
QUIT
+37 QUIT
AUTH KILL ^RMPF(791810,RMPFX,301)
+1 SET ^RMPF(791810,RMPFX,301,0)="^791810.0301"
SET CY=1
SET XMPOS=XMPOS-1
+2 FOR IY=1:1
XECUTE XMREC
if XMER=-1
QUIT
SET X=$PIECE(XMRG,U,1)
SET SX=$PIECE(XMRG,U,2,99)
Begin DoDot:1
+3 IF X'=301
SET XMPOS=XMPOS-1
QUIT
+4 SET ^RMPF(791810,RMPFX,301,CY,0)=SX
+5 SET ^RMPF(791810,RMPFX,301,"B",$PIECE(SX,U,1),CY)=""
SET CY=CY+1
End DoDot:1
if X'=301
QUIT
+6 QUIT
SETORD SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET DR=".03////"_RMPFST
DO ^DIE
QUIT
BLANK SET RMPFNAM=" "
+1 SET (RMPFSTP,RMPFTYP)=" "
+2 SET RMPFITP=" "
+3 SET RMPFSB=" "
+4 QUIT
