RMPFET8 ;DDC/KAW-ADJUST AN ORDER [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**17**;06/06/01
;;input : RMPFX,DFN,RMPFTYP,RMPFHAT,RMPFTP
;;output: None
Q:'$D(RMPFX) Q:'$D(DFN) Q:'DFN
W @IOF,!!,"ORDER ADJUSTMENTS"
W !!?32,"*** WARNING ***"
W !!,"This module is used to make adjustments to an order that has already been"
W !!,"sent to the DDC. Orders may be adjusted up to 60 working days after aids"
W !!,"are issued. If an adjustment is made after issue, the DDC will update the"
W !!,"the order with the status 'CERTIFICATION PENDING'. Certification will again"
W !!,"be required before the vendor will be paid."
D CONT^RMPFET G END:$D(RMPFOUT)
EN1 S S0=^RMPF(791810,RMPFX,0) K RMPFADJ
I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFTYPP=$P(^(0),U,1)
I RMPFTYP=""!(RMPFHAT="") W $C(7),!!,"ERROR IN ORDER TYPE" G END
K RMPFSEL1
EDIT D PAT^RMPFUTL,HEAD,^RMPFDT2
S (X,CT)=0 F I=1:1 S X=$O(RMPFO(X)) Q:'X S CT=CT+1
D SEL G END:$D(RMPFOUT),EDIT:$D(RMPFQUT),END:RMPFSEL1="",EDIT
END K RMPFTYPP,CT,X,RMPFOUT,RMPFQUT,RMPFSEL1,RMPFADJ,RMPFDOD
K RMPFDOB,RMPFNAM,RMPFMD,RMPFO,RMPFSSN,CM,CX,DI,DIC,I,Y,RMPFRE Q
SEL ;;Select adjustment action
;; input: RMPFX,CT,RMPFMD
;;output: RMPFSEL1
S RMPFODAT=$P(^RMPF(791810,RMPFX,0),"^",9)
I RMPFODAT>3010630 D
.W !!!,"Enter <C>hange Model, <H>istory or <RETURN> to continue: " D READ
I RMPFODAT<3010701 D
.W !!!,"Enter <C>hange Model, <R>emove Component, <A>dd Component,"
.W " <H>istory or <RETURN> to continue: " D READ
G SELE:$D(RMPFOUT)
SEL1 I $D(RMPFQUT) D MSG G SELE:$D(RMPFOUT) S RMPFQUT="" G SELE
S RMPFSEL1=$E(Y,1) G SELE:RMPFSEL1=""
I RMPFODAT>3010630 I "CcHh"'[RMPFSEL1 S RMPFQUT="" G SEL1
I RMPFODAT<3010701 I "CcRrAaHh"'[RMPFSEL1 S RMPFQUT="" G SEL1
I "Hh"[RMPFSEL1 D ^RMPFDT7 G SELE
I CT=1,$P(^RMPF(791810,RMPFX,101,RMPFMD(1),0),U,15)'="C" S RMPFY=RMPFMD(1) G DO
NUM S Z=$E(Y,2,99) G ITEM:'Z
I $D(RMPFMD(Z)),$P(^RMPF(791810,RMPFX,101,RMPFMD(Z),0),U,15)'="C" S RMPFY=RMPFMD(Z) G DO
ITEM W !!,"Select number of item to adjust: " D READ G SELE:$D(RMPFOUT)
ITEM1 I $D(RMPFQUT) W !!,"Enter the number to the left of the item that you wish to adjust." G ITEM
G SELE:Y="" I '$D(RMPFMD(Y)) S RMPFQUT="" G ITEM1
S RMPFY=RMPFMD(Y)
I $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,15)="C" W $C(7),!!,"*** THIS ORDER HAS BEEN CANCELED ***" S RMPFQUT="" G ITEM1
DO S X=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18) G SELE:'X,SELE:'$D(^RMPF(791810.2,X,0)) S X=$P(^(0),U,2) G SELE:X="" I "SECF"'[X W !!,$C(7),"*** LINE ITEMS WITH THIS STATUS CANNOT BE ADJUSTED ***" H 2 G SELE
I "Cc"[RMPFSEL1 D CHANGEM^RMPFET81 G END:$D(RMPFOUT)!'$D(RMPFY) D CERTIFY G END:$D(RMPFOUT),SELE
I RMPFODAT<3010701 I "Rr"[RMPFSEL1 D REMOVEC^RMPFET81 G END:$D(RMPFOUT)!'$D(RMPFY) D CERTIFY G END:$D(RMPFOUT),SELE
I RMPFODAT<3010701 I "Aa"[RMPFSEL1 D ADDC^RMPFET81 G END:$D(RMPFOUT)!'$D(RMPFY) D CERTIFY G END:$D(RMPFOUT),SELE
SELE K X,Y,Z,RMPFMD,RMPFY 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
HEAD W @IOF,!?27,"ACTIVE ORDER INFORMATION"
W !,"Station: ",RMPFSTAP,?68,RMPFDAT
W !,"Patient: ",$E(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
W ! F I=1:1:80 W "-"
Q
CERTIFY S S0=^RMPF(791810,RMPFX,101,RMPFY,0)
Q:'$P(S0,U,20) Q:$P(S0,U,19)'["A"
Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,90)) F I=8:1:11 S $P(^(90),U,I)=""
W !!,"*** THIS LINE ITEM MUST BE CERTIFIED ***"
S BX=1 D ^RMPFET85
Q
MSG W !!,"Enter <C> to change a hearing aid model"
W:RMPFODAT<3010701 !?6,"<R> to remove a component from the order"
W:RMPFODAT<3010701 !?6,"<A> to add a component to the order"
W !?6,"<H> to view the history of the order actions"
W !?6,"<RETURN> to continue."
W !!,"If the order consists of more than one model, the number of the model needing to",!,"be adjusted may be entered after the letter from the command line (i.g., 'C2')."
W !!,"Enter <RETURN> to continue." D READ Q
DELETE ;;Delete old model when changing models
;; input: RMPFX,RMPFY,RMPFRE,RMPFMSG,RMPFY1
;;output: None
S S0=^RMPF(791810,RMPFX,101,RMPFY1,0),IT=$P(S0,U,1)
S LR=$P(S0,U,4),CX=$P(S0,U,14),X="NOW",%DT="T" D ^%DT S TD=Y
S DIC="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DLAYGO=791810
S DIC(0)="L",X=""_IT_""
S DIC("DR")=".04////"_LR_";.14////"_CX_";.15////DC;.16////"_RMPFY1_";.18///APPROVED;90.01////"_DUZ_";90.02////"_TD_";90.03////"_RMPFRE_";90.04////"_RMPFMESG W "."
K DD,DO D FILE^DICN S RMPFY3=+Y
I Y=-1 W $C(7),!!,"*** MODEL NOT DELETED ***" H 2 Q
S RMPFY=RMPFY1 D ARRAY2^RMPFDT2
S RMPFZ=0 F IX=1:1 S RMPFZ=$O(RMPFC(RMPFZ)) Q:'RMPFZ W "." D
.S IT=$P(RMPFC(RMPFZ),U,1),CX=$P(RMPFC(RMPFZ),U,2)
.I '$D(^RMPF(791810,RMPFX,101,RMPFY3,102,0)) S ^RMPF(791810,RMPFX,101,RMPFY3,102,0)="^791810.101102P"
.S DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY3_",102,",X=""_IT_""
.S DA(2)=RMPFX,DA(1)=RMPFY3,DLAYGO=791810,DIC(0)="L"
.S DIC("DR")=".03////D;.05////"_DUZ_";.06////"_TD_";.07////"_RMPFRE
.K DO,DD D FILE^DICN I Y=-1 W $C(7),!!,"*** COMPONENT NOT DELETED ***" Q
.S $P(^RMPF(791810,RMPFX,101,RMPFY3,102,+Y,0),U,4)=+Y,$P(^(0),U,2)=CX Q
K X,Y,RMPFOUT,RMPFQUT,DIC,RMPFZ,RMPFC,IT,CX,DA,ZZ,ZY,RMPFRE,RMPFY3,TD
K LR,IX,%,%DT,D0,DI,DIE,DLAYGO,DQ,DR Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET8 5282 printed Dec 13, 2024@02:36:25 Page 2
RMPFET8 ;DDC/KAW-ADJUST AN ORDER [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**17**;06/06/01
+2 ;;input : RMPFX,DFN,RMPFTYP,RMPFHAT,RMPFTP
+3 ;;output: None
+4 if '$DATA(RMPFX)
QUIT
if '$DATA(DFN)
QUIT
if 'DFN
QUIT
+5 WRITE @IOF,!!,"ORDER ADJUSTMENTS"
+6 WRITE !!?32,"*** WARNING ***"
+7 WRITE !!,"This module is used to make adjustments to an order that has already been"
+8 WRITE !!,"sent to the DDC. Orders may be adjusted up to 60 working days after aids"
+9 WRITE !!,"are issued. If an adjustment is made after issue, the DDC will update the"
+10 WRITE !!,"the order with the status 'CERTIFICATION PENDING'. Certification will again"
+11 WRITE !!,"be required before the vendor will be paid."
+12 DO CONT^RMPFET
if $DATA(RMPFOUT)
GOTO END
EN1 SET S0=^RMPF(791810,RMPFX,0)
KILL RMPFADJ
+1 IF RMPFTYP
IF $DATA(^RMPF(791810.1,RMPFTYP,0))
SET RMPFTYPP=$PIECE(^(0),U,1)
+2 IF RMPFTYP=""!(RMPFHAT="")
WRITE $CHAR(7),!!,"ERROR IN ORDER TYPE"
GOTO END
+3 KILL RMPFSEL1
EDIT DO PAT^RMPFUTL
DO HEAD
DO ^RMPFDT2
+1 SET (X,CT)=0
FOR I=1:1
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
SET CT=CT+1
+2 DO SEL
if $DATA(RMPFOUT)
GOTO END
if $DATA(RMPFQUT)
GOTO EDIT
if RMPFSEL1=""
GOTO END
GOTO EDIT
END KILL RMPFTYPP,CT,X,RMPFOUT,RMPFQUT,RMPFSEL1,RMPFADJ,RMPFDOD
+1 KILL RMPFDOB,RMPFNAM,RMPFMD,RMPFO,RMPFSSN,CM,CX,DI,DIC,I,Y,RMPFRE
QUIT
SEL ;;Select adjustment action
+1 ;; input: RMPFX,CT,RMPFMD
+2 ;;output: RMPFSEL1
+3 SET RMPFODAT=$PIECE(^RMPF(791810,RMPFX,0),"^",9)
+4 IF RMPFODAT>3010630
Begin DoDot:1
+5 WRITE !!!,"Enter <C>hange Model, <H>istory or <RETURN> to continue: "
DO READ
End DoDot:1
+6 IF RMPFODAT<3010701
Begin DoDot:1
+7 WRITE !!!,"Enter <C>hange Model, <R>emove Component, <A>dd Component,"
+8 WRITE " <H>istory or <RETURN> to continue: "
DO READ
End DoDot:1
+9 if $DATA(RMPFOUT)
GOTO SELE
SEL1 IF $DATA(RMPFQUT)
DO MSG
if $DATA(RMPFOUT)
GOTO SELE
SET RMPFQUT=""
GOTO SELE
+1 SET RMPFSEL1=$EXTRACT(Y,1)
if RMPFSEL1=""
GOTO SELE
+2 IF RMPFODAT>3010630
IF "CcHh"'[RMPFSEL1
SET RMPFQUT=""
GOTO SEL1
+3 IF RMPFODAT<3010701
IF "CcRrAaHh"'[RMPFSEL1
SET RMPFQUT=""
GOTO SEL1
+4 IF "Hh"[RMPFSEL1
DO ^RMPFDT7
GOTO SELE
+5 IF CT=1
IF $PIECE(^RMPF(791810,RMPFX,101,RMPFMD(1),0),U,15)'="C"
SET RMPFY=RMPFMD(1)
GOTO DO
NUM SET Z=$EXTRACT(Y,2,99)
if 'Z
GOTO ITEM
+1 IF $DATA(RMPFMD(Z))
IF $PIECE(^RMPF(791810,RMPFX,101,RMPFMD(Z),0),U,15)'="C"
SET RMPFY=RMPFMD(Z)
GOTO DO
ITEM WRITE !!,"Select number of item to adjust: "
DO READ
if $DATA(RMPFOUT)
GOTO SELE
ITEM1 IF $DATA(RMPFQUT)
WRITE !!,"Enter the number to the left of the item that you wish to adjust."
GOTO ITEM
+1 if Y=""
GOTO SELE
IF '$DATA(RMPFMD(Y))
SET RMPFQUT=""
GOTO ITEM1
+2 SET RMPFY=RMPFMD(Y)
+3 IF $PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,15)="C"
WRITE $CHAR(7),!!,"*** THIS ORDER HAS BEEN CANCELED ***"
SET RMPFQUT=""
GOTO ITEM1
DO SET X=$PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,18)
if 'X
GOTO SELE
if '$DATA(^RMPF(791810.2,X,0))
GOTO SELE
SET X=$PIECE(^(0),U,2)
if X=""
GOTO SELE
IF "SECF"'[X
WRITE !!,$CHAR(7),"*** LINE ITEMS WITH THIS STATUS CANNOT BE ADJUSTED ***"
HANG 2
GOTO SELE
+1 IF "Cc"[RMPFSEL1
DO CHANGEM^RMPFET81
if $DATA(RMPFOUT)!'$DATA(RMPFY)
GOTO END
DO CERTIFY
if $DATA(RMPFOUT)
GOTO END
GOTO SELE
+2 IF RMPFODAT<3010701
IF "Rr"[RMPFSEL1
DO REMOVEC^RMPFET81
if $DATA(RMPFOUT)!'$DATA(RMPFY)
GOTO END
DO CERTIFY
if $DATA(RMPFOUT)
GOTO END
GOTO SELE
+3 IF RMPFODAT<3010701
IF "Aa"[RMPFSEL1
DO ADDC^RMPFET81
if $DATA(RMPFOUT)!'$DATA(RMPFY)
GOTO END
DO CERTIFY
if $DATA(RMPFOUT)
GOTO END
GOTO SELE
SELE KILL X,Y,Z,RMPFMD,RMPFY
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
HEAD WRITE @IOF,!?27,"ACTIVE ORDER INFORMATION"
+1 WRITE !,"Station: ",RMPFSTAP,?68,RMPFDAT
+2 WRITE !,"Patient: ",$EXTRACT(RMPFNAM,1,25),?40,"SSN: ",RMPFSSN,?62,"DOB: ",RMPFDOB
+3 WRITE !
FOR I=1:1:80
WRITE "-"
+4 QUIT
CERTIFY SET S0=^RMPF(791810,RMPFX,101,RMPFY,0)
+1 if '$PIECE(S0,U,20)
QUIT
if $PIECE(S0,U,19)'["A"
QUIT
+2 if '$DATA(^RMPF(791810,RMPFX,101,RMPFY,90))
QUIT
FOR I=8:1:11
SET $PIECE(^(90),U,I)=""
+3 WRITE !!,"*** THIS LINE ITEM MUST BE CERTIFIED ***"
+4 SET BX=1
DO ^RMPFET85
+5 QUIT
MSG WRITE !!,"Enter <C> to change a hearing aid model"
+1 if RMPFODAT<3010701
WRITE !?6,"<R> to remove a component from the order"
+2 if RMPFODAT<3010701
WRITE !?6,"<A> to add a component to the order"
+3 WRITE !?6,"<H> to view the history of the order actions"
+4 WRITE !?6,"<RETURN> to continue."
+5 WRITE !!,"If the order consists of more than one model, the number of the model needing to",!,"be adjusted may be entered after the letter from the command line (i.g., 'C2')."
+6 WRITE !!,"Enter <RETURN> to continue."
DO READ
QUIT
DELETE ;;Delete old model when changing models
+1 ;; input: RMPFX,RMPFY,RMPFRE,RMPFMSG,RMPFY1
+2 ;;output: None
+3 SET S0=^RMPF(791810,RMPFX,101,RMPFY1,0)
SET IT=$PIECE(S0,U,1)
+4 SET LR=$PIECE(S0,U,4)
SET CX=$PIECE(S0,U,14)
SET X="NOW"
SET %DT="T"
DO ^%DT
SET TD=Y
+5 SET DIC="^RMPF(791810,"_RMPFX_",101,"
SET DA(1)=RMPFX
SET DLAYGO=791810
+6 SET DIC(0)="L"
SET X=""_IT_""
+7 SET DIC("DR")=".04////"_LR_";.14////"_CX_";.15////DC;.16////"_RMPFY1_";.18///APPROVED;90.01////"_DUZ_";90.02////"_TD_";90.03////"_RMPFRE_";90.04////"_RMPFMESG
WRITE "."
+8 KILL DD,DO
DO FILE^DICN
SET RMPFY3=+Y
+9 IF Y=-1
WRITE $CHAR(7),!!,"*** MODEL NOT DELETED ***"
HANG 2
QUIT
+10 SET RMPFY=RMPFY1
DO ARRAY2^RMPFDT2
+11 SET RMPFZ=0
FOR IX=1:1
SET RMPFZ=$ORDER(RMPFC(RMPFZ))
if 'RMPFZ
QUIT
WRITE "."
Begin DoDot:1
+12 SET IT=$PIECE(RMPFC(RMPFZ),U,1)
SET CX=$PIECE(RMPFC(RMPFZ),U,2)
+13 IF '$DATA(^RMPF(791810,RMPFX,101,RMPFY3,102,0))
SET ^RMPF(791810,RMPFX,101,RMPFY3,102,0)="^791810.101102P"
+14 SET DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY3_",102,"
SET X=""_IT_""
+15 SET DA(2)=RMPFX
SET DA(1)=RMPFY3
SET DLAYGO=791810
SET DIC(0)="L"
+16 SET DIC("DR")=".03////D;.05////"_DUZ_";.06////"_TD_";.07////"_RMPFRE
+17 KILL DO,DD
DO FILE^DICN
IF Y=-1
WRITE $CHAR(7),!!,"*** COMPONENT NOT DELETED ***"
QUIT
+18 SET $PIECE(^RMPF(791810,RMPFX,101,RMPFY3,102,+Y,0),U,4)=+Y
SET $PIECE(^(0),U,2)=CX
QUIT
End DoDot:1
+19 KILL X,Y,RMPFOUT,RMPFQUT,DIC,RMPFZ,RMPFC,IT,CX,DA,ZZ,ZY,RMPFRE,RMPFY3,TD
+20 KILL LR,IX,%,%DT,D0,DI,DIE,DLAYGO,DQ,DR
QUIT
