- 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 Mar 13, 2025@21:41:31 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
