- 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 Feb 19, 2025@00:03 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
