- 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 Mar 13, 2025@21:42:07 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
