RMPFET84 ;DDC/KAW-CERTIFY A CUSTOM HEARING AID RECEIPT [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
S RMPFHAT="I",RMPFTP="P",RMPFTYP=5
D MSG G END:$D(RMPFOUT) S NB=11 D AUTH^RMPFET71 G END:$D(RMPFOUT)
PAT W @IOF,!,"CERTIFY CUSTOM HEARING AIDS"
W ! S DIC=2,DIC(0)="AEQM" D ^DIC G END:Y=-1 S DFN=+Y K RMPFX
S (C,X)=0 F S X=$O(^RMPF(791810,"C",DFN,X)) Q:'X D
.S Y=0 F S Y=$O(^RMPF(791810,X,101,Y)) Q:'Y S S0=^(Y,0),X1=$P(S0,U,18) S:X1 X1=$P($G(^RMPF(791810.2,X1,0)),U,2) I "EDSF"[X1!($P(S0,U,19)["R"&$P(S0,U,20)) S RMPFX=X,C=C+1 Q
I '$D(RMPFX) W !!,"*** THERE ARE NO ORDERS TO BE CERTIFIED FOR THIS PATIENT ***" D CONT^RMPFEI G PAT
G PAT:'$D(RMPFX)
S X=$P(^RMPF(791810,RMPFX,0),U,3)
MG1 I X="" W !!,"*** ERROR IN ORDER ***" G END
S X=$P($G(^RMPF(791810.2,X,0)),U,2) G MG1:X=""
I "DESPF"'[X W !!,"*** THE STATUS OF THIS ORDER DOES NOT PERMIT CERTIFICATION ***" D CONT^RMPFET G END:$D(RMPFOUT),PAT
D DISP0 G END:$D(RMPFOUT) D APPROV1^RMPFEA2 G END:$D(RMPFOUT),PAT
DISP S NB=11 D AUTH^RMPFET71 Q:$D(RMPFOUT)
DISP0 ;; input: RMPFX,DFN,RMPFHAT,RMPFTYP
;;output: None
DISP1 W @IOF,!?20,"CERTIFY RECEIPT OF A CUSTOM HEARING AID"
D PAT^RMPFUTL,HEADP1^RMPFDT1
W !! D ^RMPFDT2 K RMPFY D SEL G END:$D(RMPFOUT)
I RMPFSEL="" D ^RMPFET3 G END
I "Aa"[RMPFSEL D EN1^RMPFET8 G DISP1
S (A,BX)=0 F S A=$O(RMPFMD(A)) Q:'A I $D(^RMPF(791810,RMPFX,101,RMPFMD(A),0)) S S0=^(0),X=$P(S0,U,18) I X,$D(^RMPF(791810.2,X,0)),"DESPF"[$P(^(0),U,2)!($P(S0,U,19)["R"&$P(S0,U,20)) S BX=BX+1,MD=A
I 'BX W !!,"*** THERE ARE NO LINE ITEMS TO CERTIFY ***" H 2 G DISP1
I BX=1 S (FY,RMPFY)=RMPFMD(MD),PT=MD D ^RMPFET85 Q:$D(RMPFOUT) G DISP1:RMPFHAT="X" D ISSUE Q:$D(RMPFOUT)!('$D(Y)) S CK=BX D:"Yy"[Y ^RMPFET71 G DISP1
ASK W !!,"Certify ",BX," orders? YES// " D READ G DISP1:$D(RMPFOUT)
ASK1 I $D(RMPFQUT) W !!,"Enter a <Y> or <RETURN> to certify all orders in the status 'ISSUE DATE PENDING'",!?5,"an <N> to select a line item to certify." G ASK
S:Y="" Y="Y" S Y=$E(Y,1) I "NnYy"'[Y S RMPFQUT="" G ASK1
G CHOOSE:"Nn"[Y S MD=0
LOOP S MD=$O(RMPFMD(MD)) G LOOP1:'MD S RMPFY=RMPFMD(MD)
G LOOP:'$D(^RMPF(791810,RMPFX,101,RMPFY,0)) S X=$P(^(0),U,18) G LOOP:'X,LOOP:'$D(^RMPF(791810.2,X,0)),LOOP:"DESPF"'[$P(^(0),U,2)
D ^RMPFET85 G LOOPE:$D(RMPFOUT),LOOP
LOOP1 G LOOPE:RMPFHAT="X" D ISSUE G LOOPE:'$D(Y),LOOPE:"Yy"'[Y S MD=0
LOOP2 S MD=$O(RMPFMD(MD)) G LOOPE:'MD S (FY,RMPFY)=RMPFMD(MD),PT=MD,CK=BX D ^RMPFET71 G LOOP2
LOOPE K MD G DISP1
CHOOSE W !!,"Select the number of the line item to certify: " D READ
Q:$D(RMPFOUT)
CH1 I $D(RMPFQUT) W !!,"Enter the number to the left of the line item you wish to certify or <RETURN> to exit." G CHOOSE
Q:Y="" I '$D(RMPFMD(Y)) S RMPFQUT="" G CH1
S RMPFY=RMPFMD(Y),MD=Y D ^RMPFET85 G END:$D(RMPFOUT)
D ISSUE G END:$D(RMPFOUT),DISP1:'$D(Y),DISP1:"Yy"'[Y
S FY=RMPFY,PT=MD,CK=BX D ^RMPFET71 G END:$D(RMPFOUT),DISP1
END K SX,X1,FL,SG,RMPFY1,Y,CX,BX,RMPFDOB,RMPFSSN,RMPFDOD,RMPFNAM,RMPFMD
K RMPFO,RMPFSEL,RMPFST,RMPFOUT,RMPFQUT,FX,NB,PT Q
ISSUE S X=$G(^RMPF(791810,RMPFX,101,RMPFY,90)) Q:'$P(X,U,8)!('$P(X,U,9))
Q:$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,5)=""
W !!,"Do you wish to enter the issue information? NO// " D READ
Q:$D(RMPFOUT)
I1 I $D(RMPFQUT) W !!,"Enter a <Y> to edit the issue information",!?5,"an <N> to exit." G ISSUE
S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G I1
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
SEL ;; input: RMPFO,RMPFMD,RMPFX
;;output: RMPFSEL
S (X,FL)=0,FX="" F S X=$O(RMPFO(X)) Q:'X D Q:FL
.I '$P($G(^RMPF(791810,RMPFX,101,X,90)),U,9) S FL=1 Q
.S X1=$P(^RMPF(791810,RMPFX,101,X,0),U,18) I X1,$D(^RMPF(791810.2,X1,0)) S X1=$P(^(0),U,2) I "DEF"[X1 S FL=1 Q
.I $P(^RMPF(791810,RMPFX,101,X,0),U,19)["R"&$P(^(0),U,20) S FL=1
W !!,"Enter "
I FL W "<A>djust, <C>ertify or " S FX="CcAa"
W "<RETURN> to exit: " D READ Q:$D(RMPFOUT)
SEL1 I $D(RMPFQUT) D MSG1 G SEL
S RMPFSEL=Y Q:RMPFSEL="" S RMPFSEL=$E(RMPFSEL,1)
I FX'="",FX'[RMPFSEL S RMPFQUT="" G SEL1
S X=$E(Y,2) I X,$D(RMPFMD(X)) S RMPFY=RMPFMD(X)
K X,Y,FL,FX Q
MSG W @IOF,!!?21,"CUSTOM HEARING AID ORDER CERTIFICATION"
W !!!,"When you certify a custom hearing aid order please be absolutely sure that the"
W !,"ROES order exactly matches the aid and components that you received from"
W !,"the vendor. You are authorizing the DDC to pay for the order as it appears on"
W !,"your screen."
W !!,"If necessary you may use the adjustment procedure to adjust the order prior to",!,"certification."
D CONT^RMPFET
Q
MSG1 W !!,"Enter an <A> to adjust the order (MUST BE DONE PRIOR TO CERTIFICATION)"
W !?7,"a <C> to certify the order"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET84 4770 printed Dec 13, 2024@02:36:29 Page 2
RMPFET84 ;DDC/KAW-CERTIFY A CUSTOM HEARING AID RECEIPT [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 SET RMPFHAT="I"
SET RMPFTP="P"
SET RMPFTYP=5
+3 DO MSG
if $DATA(RMPFOUT)
GOTO END
SET NB=11
DO AUTH^RMPFET71
if $DATA(RMPFOUT)
GOTO END
PAT WRITE @IOF,!,"CERTIFY CUSTOM HEARING AIDS"
+1 WRITE !
SET DIC=2
SET DIC(0)="AEQM"
DO ^DIC
if Y=-1
GOTO END
SET DFN=+Y
KILL RMPFX
+2 SET (C,X)=0
FOR
SET X=$ORDER(^RMPF(791810,"C",DFN,X))
if 'X
QUIT
Begin DoDot:1
+3 SET Y=0
FOR
SET Y=$ORDER(^RMPF(791810,X,101,Y))
if 'Y
QUIT
SET S0=^(Y,0)
SET X1=$PIECE(S0,U,18)
if X1
SET X1=$PIECE($GET(^RMPF(791810.2,X1,0)),U,2)
IF "EDSF"[X1!($PIECE(S0,U,19)["R"&$PIECE(S0,U,20))
SET RMPFX=X
SET C=C+1
QUIT
End DoDot:1
+4 IF '$DATA(RMPFX)
WRITE !!,"*** THERE ARE NO ORDERS TO BE CERTIFIED FOR THIS PATIENT ***"
DO CONT^RMPFEI
GOTO PAT
+5 if '$DATA(RMPFX)
GOTO PAT
+6 SET X=$PIECE(^RMPF(791810,RMPFX,0),U,3)
MG1 IF X=""
WRITE !!,"*** ERROR IN ORDER ***"
GOTO END
+1 SET X=$PIECE($GET(^RMPF(791810.2,X,0)),U,2)
if X=""
GOTO MG1
+2 IF "DESPF"'[X
WRITE !!,"*** THE STATUS OF THIS ORDER DOES NOT PERMIT CERTIFICATION ***"
DO CONT^RMPFET
if $DATA(RMPFOUT)
GOTO END
GOTO PAT
+3 DO DISP0
if $DATA(RMPFOUT)
GOTO END
DO APPROV1^RMPFEA2
if $DATA(RMPFOUT)
GOTO END
GOTO PAT
DISP SET NB=11
DO AUTH^RMPFET71
if $DATA(RMPFOUT)
QUIT
DISP0 ;; input: RMPFX,DFN,RMPFHAT,RMPFTYP
+1 ;;output: None
DISP1 WRITE @IOF,!?20,"CERTIFY RECEIPT OF A CUSTOM HEARING AID"
+1 DO PAT^RMPFUTL
DO HEADP1^RMPFDT1
+2 WRITE !!
DO ^RMPFDT2
KILL RMPFY
DO SEL
if $DATA(RMPFOUT)
GOTO END
+3 IF RMPFSEL=""
DO ^RMPFET3
GOTO END
+4 IF "Aa"[RMPFSEL
DO EN1^RMPFET8
GOTO DISP1
+5 SET (A,BX)=0
FOR
SET A=$ORDER(RMPFMD(A))
if 'A
QUIT
IF $DATA(^RMPF(791810,RMPFX,101,RMPFMD(A),0))
SET S0=^(0)
SET X=$PIECE(S0,U,18)
IF X
IF $DATA(^RMPF(791810.2,X,0))
IF "DESPF"[$PIECE(^(0),U,2)!($PIECE(S0,U,19)["R"&$PIECE(S0,U,20))
SET BX=BX+1
SET MD=A
+6 IF 'BX
WRITE !!,"*** THERE ARE NO LINE ITEMS TO CERTIFY ***"
HANG 2
GOTO DISP1
+7 IF BX=1
SET (FY,RMPFY)=RMPFMD(MD)
SET PT=MD
DO ^RMPFET85
if $DATA(RMPFOUT)
QUIT
if RMPFHAT="X"
GOTO DISP1
DO ISSUE
if $DATA(RMPFOUT)!('$DATA(Y))
QUIT
SET CK=BX
if "Yy"[Y
DO ^RMPFET71
GOTO DISP1
ASK WRITE !!,"Certify ",BX," orders? YES// "
DO READ
if $DATA(RMPFOUT)
GOTO DISP1
ASK1 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <Y> or <RETURN> to certify all orders in the status 'ISSUE DATE PENDING'",!?5,"an <N> to select a line item to certify."
GOTO ASK
+1 if Y=""
SET Y="Y"
SET Y=$EXTRACT(Y,1)
IF "NnYy"'[Y
SET RMPFQUT=""
GOTO ASK1
+2 if "Nn"[Y
GOTO CHOOSE
SET MD=0
LOOP SET MD=$ORDER(RMPFMD(MD))
if 'MD
GOTO LOOP1
SET RMPFY=RMPFMD(MD)
+1 if '$DATA(^RMPF(791810,RMPFX,101,RMPFY,0))
GOTO LOOP
SET X=$PIECE(^(0),U,18)
if 'X
GOTO LOOP
if '$DATA(^RMPF(791810.2,X,0))
GOTO LOOP
if "DESPF"'[$PIECE(^(0),U,2)
GOTO LOOP
+2 DO ^RMPFET85
if $DATA(RMPFOUT)
GOTO LOOPE
GOTO LOOP
LOOP1 if RMPFHAT="X"
GOTO LOOPE
DO ISSUE
if '$DATA(Y)
GOTO LOOPE
if "Yy"'[Y
GOTO LOOPE
SET MD=0
LOOP2 SET MD=$ORDER(RMPFMD(MD))
if 'MD
GOTO LOOPE
SET (FY,RMPFY)=RMPFMD(MD)
SET PT=MD
SET CK=BX
DO ^RMPFET71
GOTO LOOP2
LOOPE KILL MD
GOTO DISP1
CHOOSE WRITE !!,"Select the number of the line item to certify: "
DO READ
+1 if $DATA(RMPFOUT)
QUIT
CH1 IF $DATA(RMPFQUT)
WRITE !!,"Enter the number to the left of the line item you wish to certify or <RETURN> to exit."
GOTO CHOOSE
+1 if Y=""
QUIT
IF '$DATA(RMPFMD(Y))
SET RMPFQUT=""
GOTO CH1
+2 SET RMPFY=RMPFMD(Y)
SET MD=Y
DO ^RMPFET85
if $DATA(RMPFOUT)
GOTO END
+3 DO ISSUE
if $DATA(RMPFOUT)
GOTO END
if '$DATA(Y)
GOTO DISP1
if "Yy"'[Y
GOTO DISP1
+4 SET FY=RMPFY
SET PT=MD
SET CK=BX
DO ^RMPFET71
if $DATA(RMPFOUT)
GOTO END
GOTO DISP1
END KILL SX,X1,FL,SG,RMPFY1,Y,CX,BX,RMPFDOB,RMPFSSN,RMPFDOD,RMPFNAM,RMPFMD
+1 KILL RMPFO,RMPFSEL,RMPFST,RMPFOUT,RMPFQUT,FX,NB,PT
QUIT
ISSUE SET X=$GET(^RMPF(791810,RMPFX,101,RMPFY,90))
if '$PIECE(X,U,8)!('$PIECE(X,U,9))
QUIT
+1 if $PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,5)=""
QUIT
+2 WRITE !!,"Do you wish to enter the issue information? NO// "
DO READ
+3 if $DATA(RMPFOUT)
QUIT
I1 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <Y> to edit the issue information",!?5,"an <N> to exit."
GOTO ISSUE
+1 if Y=""
SET Y="N"
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO I1
+2 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
SEL ;; input: RMPFO,RMPFMD,RMPFX
+1 ;;output: RMPFSEL
+2 SET (X,FL)=0
SET FX=""
FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
Begin DoDot:1
+3 IF '$PIECE($GET(^RMPF(791810,RMPFX,101,X,90)),U,9)
SET FL=1
QUIT
+4 SET X1=$PIECE(^RMPF(791810,RMPFX,101,X,0),U,18)
IF X1
IF $DATA(^RMPF(791810.2,X1,0))
SET X1=$PIECE(^(0),U,2)
IF "DEF"[X1
SET FL=1
QUIT
+5 IF $PIECE(^RMPF(791810,RMPFX,101,X,0),U,19)["R"&$PIECE(^(0),U,20)
SET FL=1
End DoDot:1
if FL
QUIT
+6 WRITE !!,"Enter "
+7 IF FL
WRITE "<A>djust, <C>ertify or "
SET FX="CcAa"
+8 WRITE "<RETURN> to exit: "
DO READ
if $DATA(RMPFOUT)
QUIT
SEL1 IF $DATA(RMPFQUT)
DO MSG1
GOTO SEL
+1 SET RMPFSEL=Y
if RMPFSEL=""
QUIT
SET RMPFSEL=$EXTRACT(RMPFSEL,1)
+2 IF FX'=""
IF FX'[RMPFSEL
SET RMPFQUT=""
GOTO SEL1
+3 SET X=$EXTRACT(Y,2)
IF X
IF $DATA(RMPFMD(X))
SET RMPFY=RMPFMD(X)
+4 KILL X,Y,FL,FX
QUIT
MSG WRITE @IOF,!!?21,"CUSTOM HEARING AID ORDER CERTIFICATION"
+1 WRITE !!!,"When you certify a custom hearing aid order please be absolutely sure that the"
+2 WRITE !,"ROES order exactly matches the aid and components that you received from"
+3 WRITE !,"the vendor. You are authorizing the DDC to pay for the order as it appears on"
+4 WRITE !,"your screen."
+5 WRITE !!,"If necessary you may use the adjustment procedure to adjust the order prior to",!,"certification."
+6 DO CONT^RMPFET
+7 QUIT
MSG1 WRITE !!,"Enter an <A> to adjust the order (MUST BE DONE PRIOR TO CERTIFICATION)"
+1 WRITE !?7,"a <C> to certify the order"
+2 QUIT
