RMPFUTL ;DDC/KAW-REMOTE ORDER/ENTRY UTILITIES; [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
;; input: RMPFMENU
;;output: RMPFSYS,RMPFDAT,RMPFSTAN,RMPFSTAP
K RMPFDAT,RMPFSYS,RMPFSTAN S Y=DT D DD^%DT S RMPFDAT=Y
S X=$O(^RMPF(791813,0)) G P2:'X
G P2:'$D(^RMPF(791813,X,RMPFMENU)),P1:$P(^(RMPFMENU),U,5)
S RMPFSTAN=X,RMPFSTAP=$S($D(^DIC(4,RMPFSTAN,99)):$P(^(99),U,1),1:"")
S:RMPFSTAP'="" RMPFSTAP=RMPFSTAP_" - "
S RMPFSTAP=RMPFSTAP_$P(^(0),U,1)
S:RMPFSTAP="" RMPFSTAP="UNKNOWN"
D PARAM G P2
P1 S DIC=791813,DIC(0)="AEQN" D ^DIC K DIC I Y=-1 K RMPFSTAN,RMPFSYS G P2
S RMPFSTAN=+Y,RMPFSTAP=$S($D(^DIC(4,RMPFSTAN,99)):$P(^(99),U,1),1:"") S:RMPFSTAP'="" RMPFSTAP=RMPFSTAP_" - " S RMPFSTAP=RMPFSTAP_$P(^(0),U,1) D PARAM
P2 I $D(RMPFSTAN),RMPFSTAN,$D(^RMPF(791813,RMPFSTAN,0)),$D(RMPFSYS)
E W $C(7),!!,"*** REMOTE ORDER/ENTRY PARAMETERS HAVE NOT BEEN DEFINED ***"
K DIC,%X,CT,C,Q,I,%,%Y,X,Y Q
PARAM K RMPFSYS Q:'$D(^RMPF(791813,RMPFSTAN,RMPFMENU))
S RMPFSYS=^RMPF(791813,RMPFSTAN,RMPFMENU)
S RMPFSYS(1)=$G(^RMPF(791813,RMPFSTAN,RMPFMENU+1)) Q
PAT ;;input: DFN
;;output: RMPFNAM,RMPFSSN,RMPFDOB
Q:'$D(DFN) D DEM^VADPT
S RMPFNAM=VADM(1),RMPFSSN=$P(VADM(2),U,2),Y=$P(VADM(3),U,1)
D DD^%DT S RMPFDOB=Y,RMPFDOD=$P(VADM(6),U,1)
I RMPFDOD S Y=RMPFDOD D DD^%DT S RMPFDOD=Y
K VADM,VA,VAERR,Y Q
COST ;;input: X
;;output: X
Q:'$D(X) S Z1=$P(^RMPF(791810,DA(2),101,DA(1),0),U,1)
I 'Z1 K X G COSTE
I '$D(^RMPF(791811,Z1,101,"B",X)) K X G COSTE
S Z2=$O(^RMPF(791811,Z1,101,"B",X,0)) I 'Z2 K X G COSTE
I '$D(^RMPF(791811,Z1,101,Z2,0)) K X G COSTE
I '$D(^RMPF(791811,Z1,0)) K X G COSTE
S M=$P(^RMPF(791811,Z1,0),U,6)
S Z3=$P(^RMPF(791811,Z1,101,Z2,0),U,2)*$S(M:1+(M/100),1:1)
S $P(^RMPF(791810,DA(2),101,DA(1),102,DA,0),U,2)=Z3
COSTE K Z1,Z2,Z3,M Q
COSTKILL S $P(^RMPF(791810,DA(2),101,DA(1),102,DA,0),U,2)="" Q
END Q
;;output: RMPFMENU
S DIC="^RMPF(791810.5,",DIC(0)="AEMQ"
S DIC("A")="Select ROES Menu Name: " D ^DIC G MENUE:Y=-1
S RMPFMENU=$P(^RMPF(791810.5,+Y,0),U,2) I RMPFMENU="" K RMPFMENU
DISABLE ;; input: RMPFMENU
;;output: RMPFL
K RMPFL S X=0
F I=1:1 S X=$O(^RMPF(791810.3,X)) Q:'X I $D(^(X,0)) S S0=^RMPF(791810.3,X,0),Y=$P(S0,U,1),Z=0 F J=1:1 S Z=$O(^DIC(31,"C",Y,Z)) Q:'Z S RMPFL(Z)=""
K X,Y,Z,I,J,S0 Q
READ K RMPFOUT,RMPFQUT
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
I Y?1"^".E S (RMPFOUT,Y)="" Q
S:Y?1"?".E (RMPFQUT,Y)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFUTL 2506 printed Oct 16, 2024@18:37:45 Page 2
RMPFUTL ;DDC/KAW-REMOTE ORDER/ENTRY UTILITIES; [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 ;; input: RMPFMENU
+3 ;;output: RMPFSYS,RMPFDAT,RMPFSTAN,RMPFSTAP
+4 KILL RMPFDAT,RMPFSYS,RMPFSTAN
SET Y=DT
DO DD^%DT
SET RMPFDAT=Y
+5 SET X=$ORDER(^RMPF(791813,0))
if 'X
GOTO P2
+6 if '$DATA(^RMPF(791813,X,RMPFMENU))
GOTO P2
if $PIECE(^(RMPFMENU),U,5)
GOTO P1
+7 SET RMPFSTAN=X
SET RMPFSTAP=$SELECT($DATA(^DIC(4,RMPFSTAN,99)):$PIECE(^(99),U,1),1:"")
+8 if RMPFSTAP'=""
SET RMPFSTAP=RMPFSTAP_" - "
+9 SET RMPFSTAP=RMPFSTAP_$PIECE(^(0),U,1)
+10 if RMPFSTAP=""
SET RMPFSTAP="UNKNOWN"
+11 DO PARAM
GOTO P2
P1 SET DIC=791813
SET DIC(0)="AEQN"
DO ^DIC
KILL DIC
IF Y=-1
KILL RMPFSTAN,RMPFSYS
GOTO P2
+1 SET RMPFSTAN=+Y
SET RMPFSTAP=$SELECT($DATA(^DIC(4,RMPFSTAN,99)):$PIECE(^(99),U,1),1:"")
if RMPFSTAP'=""
SET RMPFSTAP=RMPFSTAP_" - "
SET RMPFSTAP=RMPFSTAP_$PIECE(^(0),U,1)
DO PARAM
P2 IF $DATA(RMPFSTAN)
IF RMPFSTAN
IF $DATA(^RMPF(791813,RMPFSTAN,0))
IF $DATA(RMPFSYS)
+1 IF '$TEST
WRITE $CHAR(7),!!,"*** REMOTE ORDER/ENTRY PARAMETERS HAVE NOT BEEN DEFINED ***"
+2 KILL DIC,%X,CT,C,Q,I,%,%Y,X,Y
QUIT
PARAM KILL RMPFSYS
if '$DATA(^RMPF(791813,RMPFSTAN,RMPFMENU))
QUIT
+1 SET RMPFSYS=^RMPF(791813,RMPFSTAN,RMPFMENU)
+2 SET RMPFSYS(1)=$GET(^RMPF(791813,RMPFSTAN,RMPFMENU+1))
QUIT
PAT ;;input: DFN
+1 ;;output: RMPFNAM,RMPFSSN,RMPFDOB
+2 if '$DATA(DFN)
QUIT
DO DEM^VADPT
+3 SET RMPFNAM=VADM(1)
SET RMPFSSN=$PIECE(VADM(2),U,2)
SET Y=$PIECE(VADM(3),U,1)
+4 DO DD^%DT
SET RMPFDOB=Y
SET RMPFDOD=$PIECE(VADM(6),U,1)
+5 IF RMPFDOD
SET Y=RMPFDOD
DO DD^%DT
SET RMPFDOD=Y
+6 KILL VADM,VA,VAERR,Y
QUIT
COST ;;input: X
+1 ;;output: X
+2 if '$DATA(X)
QUIT
SET Z1=$PIECE(^RMPF(791810,DA(2),101,DA(1),0),U,1)
+3 IF 'Z1
KILL X
GOTO COSTE
+4 IF '$DATA(^RMPF(791811,Z1,101,"B",X))
KILL X
GOTO COSTE
+5 SET Z2=$ORDER(^RMPF(791811,Z1,101,"B",X,0))
IF 'Z2
KILL X
GOTO COSTE
+6 IF '$DATA(^RMPF(791811,Z1,101,Z2,0))
KILL X
GOTO COSTE
+7 IF '$DATA(^RMPF(791811,Z1,0))
KILL X
GOTO COSTE
+8 SET M=$PIECE(^RMPF(791811,Z1,0),U,6)
+9 SET Z3=$PIECE(^RMPF(791811,Z1,101,Z2,0),U,2)*$SELECT(M:1+(M/100),1:1)
+10 SET $PIECE(^RMPF(791810,DA(2),101,DA(1),102,DA,0),U,2)=Z3
COSTE KILL Z1,Z2,Z3,M
QUIT
COSTKILL SET $PIECE(^RMPF(791810,DA(2),101,DA(1),102,DA,0),U,2)=""
QUIT
END QUIT
+1 ;;output: RMPFMENU
+2 SET DIC="^RMPF(791810.5,"
SET DIC(0)="AEMQ"
+3 SET DIC("A")="Select ROES Menu Name: "
DO ^DIC
if Y=-1
GOTO MENUE
+4 SET RMPFMENU=$PIECE(^RMPF(791810.5,+Y,0),U,2)
IF RMPFMENU=""
KILL RMPFMENU
QUIT
DISABLE ;; input: RMPFMENU
+1 ;;output: RMPFL
+2 KILL RMPFL
SET X=0
+3 FOR I=1:1
SET X=$ORDER(^RMPF(791810.3,X))
if 'X
QUIT
IF $DATA(^(X,0))
SET S0=^RMPF(791810.3,X,0)
SET Y=$PIECE(S0,U,1)
SET Z=0
FOR J=1:1
SET Z=$ORDER(^DIC(31,"C",Y,Z))
if 'Z
QUIT
SET RMPFL(Z)=""
+4 KILL X,Y,Z,I,J,S0
QUIT
READ KILL RMPFOUT,RMPFQUT
+1 READ Y:DTIME
IF '$TEST
WRITE $CHAR(7)
READ Y:5
if Y="."
GOTO READ
if '$TEST
SET Y=U
+2 IF Y?1"^".E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
