67 lines
3.4 KiB
Mathematica
67 lines
3.4 KiB
Mathematica
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
|