RMPFET1 ;DDC/KAW-ENTER/EDIT PATIENT ORDER [ 05/24/99 9:24 AM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**15,17**;06/06/01
I $D(RMPFX) D EXIST G ORDER
E D ADD
ORDER I $D(RMPFX),'$D(RMPFOUT) D END1,^RMPFET5
END K RMPFHAT,RMPFST,RMPFTYP,RMPFTE
END1 K %,%DT,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,DISYS,S0,S2 Q
ADD ;;Add a new order
;;input: RMPFTP,RMPFTE,DFN(opt.)
;;output: RMPFTYP,RMPFHAT,RMPFST,RMPFX
W !!,"Do you wish to add an order? NO// " D READ
G ADDE:$D(RMPFOUT)
ADD1 I $D(RMPFQUT) W !!,"Enter a <Y> to add an order, <N> or <RETURN> to exit." G ADD
S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G ADD1
I "Nn"[Y K RMPFX G ADDE
ADD2 S RMPFST=1 I RMPFTP="P"
TYP S DIC=791810.1,DIC(0)="AEQM",DIC("A")="Select Type of Order: "
S DIC("S")="I $P(^(0),U,3)=RMPFTP,'$P(^(0),U,7),$D(^RMPF(791810.1,Y,102,""B"",RMPFMENU))"
W ! D ^DIC K DIC G ADDE:Y=-1 S RMPFTYP=+Y
AUTO S RMPFHAT=$P(^RMPF(791810.1,RMPFTYP,0),U,2)
I $P($G(^RMPF(791810.1,RMPFTYP,0)),U,2)="X" D
.W @IOF,!!,"EXTRA COMPONENT ORDERS"
.W !!?32,"*** REMINDER ***"
.W !!,"This module is used to place extra component orders for hearing aids orginally"
.W !!,"ordered through the DDC. The purchase order number for the orginal hearing aid"
.W !!,"order is required to place an extra component order. If the hearing aid order"
.W !!,"was placed after 07/01/01 the extra component order will only be accepted after"
.W !!,"the trial period, which is 180 days from the date of shipment."
.D CONT^RMPFET G END:$D(RMPFOUT)
E D
.S X=$P(^RMPF(791810.1,RMPFTYP,0),U,5)
.I $L(X) S X="*** "_X_" ***" W $C(7),!!,?80-$L(X)\2,X
S X="NOW",%DT="T" D ^%DT S X=Y
F J=1:1 Q:'$D(^RMPF(791810,"B",X)) S X=X+.00001
S DIC="^RMPF(791810,",DIC(0)="L",DIC("DR")=".15///"_RMPFMENU
S DLAYGO=791810 K DD,DO D FILE^DICN K DIC G ADDE:Y=-1 S RMPFX=+Y
I RMPFTP="P" D ADD^RMPFETL I $D(RMPFOUT)!(RMPFTE=""&('$P($G(^RMPF(791810,RMPFX,2)),U,6))) D KILL G ADDE
I RMPFTP="P" S XX=$P(RMPFTE,U,1) I XX'="" S XX=$O(^RMPF(791810.4,"B",XX,0))
S DIE="^RMPF(791810,",DA=RMPFX,X="NOW",%DT="T" D ^%DT
S DR=".02////"_RMPFTYP_";.03////"_RMPFST_";.05////"_DUZ_";.06////"_Y_";901////"_RMPFSTAP_";10.05////R"
I RMPFTP="P" S DR=DR_";.04////"_DFN I RMPFTE'="" S DR=DR_";2.02///"_$P(RMPFTE,U,1)_";2.03////"_DUZ_";2.04////"_$P(RMPFTE,U,2)_";2.05////"_DT
D ^DIE
I RMPFTP="P" S RMSEN=$O(^DGSL(38.1,"B",DFN,0)) I RMSEN,$P($G(^DGSL(38.1,RMSEN,0)),U,2) S $P(^RMPF(791810,RMPFX,2),U,13)=1
ADDE K %,%DT,%Y,D,D0,DA,DI,DIC,DIE,DISYS,DQ,DR,J,X,XX,RMSEN Q
EXIST ;;Access and existing order
;; input: RMPFX,RMPFST,RMPFTYP,RMPFTP,RMPFHAT
;;(RMPFNAM,RMPFDOB,RMPFSSN,RMPFDOD) (if patient order)
;;output: None
I '$D(^RMPF(791810,RMPFX,0)) W $C(7),!!,"THIS ORDER DOES NOT EXIST - FILE ERROR" G EXISTE
S S2=$G(^RMPF(791810,RMPFX,2)) G EDIT:RMPFTP="S" S X=$P(S2,U,2)
I X,$D(^RMPF(791810.4,X,0)) G EDIT
D ADD^RMPFETL G EXISTE:$D(RMPFOUT)
I RMPFTE=""&('$P($G(^RMPF(791810,RMPFX,2)),U,6)) W !!,"*** MUST ENTER AN ELIGIBILITY ***" G EXIST
G EXISTE
EDIT I RMPFTP="P" S RMPFTE=$P(^RMPF(791810.4,$P(S2,U,2),0),U,1)_U_$P(S2,U,4) D EDIT^RMPFETL
EXISTE K S0,S1,S2,I,X Q
DELETE W !!,"Are you sure you want to delete this order? NO// " D READ
G DELETEE:$D(RMPFOUT)
DEL1 I $D(RMPFQUT) W !!,"If you enter a <Y> the order will be permanently deleted from this order.",!,"If you enter a <N> or <RETURN> the order will be retained on the order." G DELETE
S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G DEL1
G DELETEE:"Nn"[Y
KILL S DA=RMPFX,DIK="^RMPF(791810," D ^DIK,REMOV^RMPFET10 S RMPFTE=""
W !!,"*** ORDER DELETED ***" H 2
DELETEE K Y,DA,DIK,RMPFX,RMPFSEL 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[HRMPFET1 3777 printed Oct 16, 2024@18:36:58 Page 2
RMPFET1 ;DDC/KAW-ENTER/EDIT PATIENT ORDER [ 05/24/99 9:24 AM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**15,17**;06/06/01
+2 IF $DATA(RMPFX)
DO EXIST
GOTO ORDER
+3 IF '$TEST
DO ADD
ORDER IF $DATA(RMPFX)
IF '$DATA(RMPFOUT)
DO END1
DO ^RMPFET5
END KILL RMPFHAT,RMPFST,RMPFTYP,RMPFTE
END1 KILL %,%DT,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,DISYS,S0,S2
QUIT
ADD ;;Add a new order
+1 ;;input: RMPFTP,RMPFTE,DFN(opt.)
+2 ;;output: RMPFTYP,RMPFHAT,RMPFST,RMPFX
+3 WRITE !!,"Do you wish to add an order? NO// "
DO READ
+4 if $DATA(RMPFOUT)
GOTO ADDE
ADD1 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <Y> to add an order, <N> or <RETURN> to exit."
GOTO ADD
+1 if Y=""
SET Y="N"
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO ADD1
+2 IF "Nn"[Y
KILL RMPFX
GOTO ADDE
ADD2 SET RMPFST=1
IF RMPFTP="P"
TYP SET DIC=791810.1
SET DIC(0)="AEQM"
SET DIC("A")="Select Type of Order: "
+1 SET DIC("S")="I $P(^(0),U,3)=RMPFTP,'$P(^(0),U,7),$D(^RMPF(791810.1,Y,102,""B"",RMPFMENU))"
+2 WRITE !
DO ^DIC
KILL DIC
if Y=-1
GOTO ADDE
SET RMPFTYP=+Y
AUTO SET RMPFHAT=$PIECE(^RMPF(791810.1,RMPFTYP,0),U,2)
+1 IF $PIECE($GET(^RMPF(791810.1,RMPFTYP,0)),U,2)="X"
Begin DoDot:1
+2 WRITE @IOF,!!,"EXTRA COMPONENT ORDERS"
+3 WRITE !!?32,"*** REMINDER ***"
+4 WRITE !!,"This module is used to place extra component orders for hearing aids orginally"
+5 WRITE !!,"ordered through the DDC. The purchase order number for the orginal hearing aid"
+6 WRITE !!,"order is required to place an extra component order. If the hearing aid order"
+7 WRITE !!,"was placed after 07/01/01 the extra component order will only be accepted after"
+8 WRITE !!,"the trial period, which is 180 days from the date of shipment."
+9 DO CONT^RMPFET
if $DATA(RMPFOUT)
GOTO END
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET X=$PIECE(^RMPF(791810.1,RMPFTYP,0),U,5)
+12 IF $LENGTH(X)
SET X="*** "_X_" ***"
WRITE $CHAR(7),!!,?80-$LENGTH(X)\2,X
End DoDot:1
+13 SET X="NOW"
SET %DT="T"
DO ^%DT
SET X=Y
+14 FOR J=1:1
if '$DATA(^RMPF(791810,"B",X))
QUIT
SET X=X+.00001
+15 SET DIC="^RMPF(791810,"
SET DIC(0)="L"
SET DIC("DR")=".15///"_RMPFMENU
+16 SET DLAYGO=791810
KILL DD,DO
DO FILE^DICN
KILL DIC
if Y=-1
GOTO ADDE
SET RMPFX=+Y
+17 IF RMPFTP="P"
DO ADD^RMPFETL
IF $DATA(RMPFOUT)!(RMPFTE=""&('$PIECE($GET(^RMPF(791810,RMPFX,2)),U,6)))
DO KILL
GOTO ADDE
+18 IF RMPFTP="P"
SET XX=$PIECE(RMPFTE,U,1)
IF XX'=""
SET XX=$ORDER(^RMPF(791810.4,"B",XX,0))
+19 SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET X="NOW"
SET %DT="T"
DO ^%DT
+20 SET DR=".02////"_RMPFTYP_";.03////"_RMPFST_";.05////"_DUZ_";.06////"_Y_";901////"_RMPFSTAP_";10.05////R"
+21 IF RMPFTP="P"
SET DR=DR_";.04////"_DFN
IF RMPFTE'=""
SET DR=DR_";2.02///"_$PIECE(RMPFTE,U,1)_";2.03////"_DUZ_";2.04////"_$PIECE(RMPFTE,U,2)_";2.05////"_DT
+22 DO ^DIE
+23 IF RMPFTP="P"
SET RMSEN=$ORDER(^DGSL(38.1,"B",DFN,0))
IF RMSEN
IF $PIECE($GET(^DGSL(38.1,RMSEN,0)),U,2)
SET $PIECE(^RMPF(791810,RMPFX,2),U,13)=1
ADDE KILL %,%DT,%Y,D,D0,DA,DI,DIC,DIE,DISYS,DQ,DR,J,X,XX,RMSEN
QUIT
EXIST ;;Access and existing order
+1 ;; input: RMPFX,RMPFST,RMPFTYP,RMPFTP,RMPFHAT
+2 ;;(RMPFNAM,RMPFDOB,RMPFSSN,RMPFDOD) (if patient order)
+3 ;;output: None
+4 IF '$DATA(^RMPF(791810,RMPFX,0))
WRITE $CHAR(7),!!,"THIS ORDER DOES NOT EXIST - FILE ERROR"
GOTO EXISTE
+5 SET S2=$GET(^RMPF(791810,RMPFX,2))
if RMPFTP="S"
GOTO EDIT
SET X=$PIECE(S2,U,2)
+6 IF X
IF $DATA(^RMPF(791810.4,X,0))
GOTO EDIT
+7 DO ADD^RMPFETL
if $DATA(RMPFOUT)
GOTO EXISTE
+8 IF RMPFTE=""&('$PIECE($GET(^RMPF(791810,RMPFX,2)),U,6))
WRITE !!,"*** MUST ENTER AN ELIGIBILITY ***"
GOTO EXIST
+9 GOTO EXISTE
EDIT IF RMPFTP="P"
SET RMPFTE=$PIECE(^RMPF(791810.4,$PIECE(S2,U,2),0),U,1)_U_$PIECE(S2,U,4)
DO EDIT^RMPFETL
EXISTE KILL S0,S1,S2,I,X
QUIT
DELETE WRITE !!,"Are you sure you want to delete this order? NO// "
DO READ
+1 if $DATA(RMPFOUT)
GOTO DELETEE
DEL1 IF $DATA(RMPFQUT)
WRITE !!,"If you enter a <Y> the order will be permanently deleted from this order.",!,"If you enter a <N> or <RETURN> the order will be retained on the order."
GOTO DELETE
+1 if Y=""
SET Y="N"
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO DEL1
+2 if "Nn"[Y
GOTO DELETEE
KILL SET DA=RMPFX
SET DIK="^RMPF(791810,"
DO ^DIK
DO REMOV^RMPFET10
SET RMPFTE=""
+1 WRITE !!,"*** ORDER DELETED ***"
HANG 2
DELETEE KILL Y,DA,DIK,RMPFX,RMPFSEL
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
