RMPRDIS ;PHX/JLT-DISPLAY/EDIT DISABILITY CODES
;;3.0;PROSTHETICS;;Feb 09, 1996
D GETPAT^RMPRUTIL Q:'$D(RMPRDFN)
EN ;ADD DISABILITY CODE, CALLED FROM RMPRAP
N DIC,DIR
I $D(RMPRDIR7) S DIR(0)="Y",DIR("A")="Would you like to ADD/EDIT a Disability Code to the Patient's 2319",DIR("B")="YES",DIR("?")="Enter 'Y' to Edit a Disability Code, 'N' or '^' to continue."
I D ^DIR G:$D(DIRUT)!($D(DUOUT)) END G:+Y=0 DEA
I $G(RMPRDA) S DFN=$P($G(^RMPR(660.5,RMPRDA,0)),U,2) I +DFN,'$D(^RMPR(665,+DFN)) S ^RMPR(665,DFN,0)=DFN_U_RMPR("STA") S DA=DFN,DIK="^RMPR(665," D IX1^DIK
I '$D(^RMPR(665,RMPRDFN,1)) S ^RMPR(665,RMPRDFN,1,0)="^665.01PI^0^0"
D:'$D(RMPRBACK) LP L +^RMPR(665,RMPRDFN,1):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry" G END
AMP W ! S DA(1)=RMPRDFN,DIC="^RMPR(665,"_DA(1)_",1,",DIC(0)="AEQMZL",DLAYGO=665,DIC("W")="S RA=^(0) D DSP^RMPRDIS" D ^DIC K DLAYGO G:+Y'>0 DEND S RMPRY=Y,RMPRX=$P(Y,U,2)
I $P(^RMPR(665,RMPRDFN,1,+Y,0),U,10) S DIR(0)="Y",DIR("A",1)="DISABILITY CODE HAS BEEN MARKED AS DELETED.",DIR("A")="WOULD YOU LIKE TO RE-ACTIVATED THIS CODE",DIR("B")="NO",DIR("?")="Enter 'Y' to re-activate code."
I D ^DIR G:$D(DIRUT)!($D(DUOUT)) DEND K DIR I +Y=1 S DA=+RMPRY,DIE=DIC,DR="10///@" D ^DIE
S RC=0 F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,"B",RMPRX,RI)) Q:RI'>0 S RC=RC+1
I RC'>1 K DIRUT D DIR G:$D(DIRUT) AMP
EDIT K DIR S DIE="^RMPR(665,RMPRDFN,1,",DA(1)=RMPRDFN,DA=+RMPRY D SDR
D ^DIE I $D(DA),$P(^RMPR(665,DA(1),1,DA,0),U,4)'=4 S $P(^(0),U,5)=""
I $D(DA) I '$P(^RMPR(665,RMPRDFN,1,DA,0),U,3)!'$P(^(0),U,4) S DA(1)=RMPRDFN,DIK="^RMPR(665,RMPRDFN,1,",DA(1)=RMPRDFN D ^DIK W !,?5,$C(7),"Deleted..."
G AMP
DEND L -^RMPR(665,RMPRDFN,1) K RMPRX,RMPRY,RT,RI,RA,RMPRT,RCC
I '$D(RMPRBACK) K DIC,Y,RMPRD,DIE,DR Q
DEA ;DEACTIVATE PATIENT PROSTHETICS DISABILITY CODES
;I $G(RMPRDFN)'>0 Q
Q:$D(RMPRDIR3) I '$D(RMPRBACK) K RMPRDFN D GETPAT^RMPRUTIL G:'$D(RMPRDFN) END
Q:$G(RMPRDFN)'>0
I '$D(^RMPR(665,RMPRDFN,1))!($O(^RMPR(665,RMPRDFN,1,0))'>0) W !!,"Patient has no Prosthetics Disability codes",$C(7) G END
W !,$P(^DPT(RMPRDFN,0),U,1)," HAS THE FOLLOWING DISABILITY CODES:",! F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,RI)) Q:RI'>0 S RA=^(RI,0) W !,?5,$P(^RMPR(662,$P(RA,U,1),0),U,1) D DSP
I $D(RMPRDIR7) W !! S DIR(0)="Y",DIR("A")="Would you like to Mark a Disability Code as Deleted",DIR("B")="NO",DIR("?")="Enter 'Y' to Mark a Disability Code as Deleted" D ^DIR G:$D(DIRUT)!($D(DUOUT))!(+Y=0) END
S RA=0 F RI=0:1 S RA=$O(^RMPR(665,RMPRDFN,1,RA)) Q:RA'>0
I RI'>1 G SEL
K DIR W !! S DIR(0)="Y"
S DIR("A")="Would you like to Mark all of the Patient's Disability Codes as Deleted",DIR("B")="NO",DIR("?")="Enter 'Y' to Mark all of the Patients Disability Codes as Deleted, 'N' to select a Disability Code."
D ^DIR G:$D(DIRUT)!($D(DUOUT)) END I +Y=0 G SEL
L +^RMPR(665,RMPRDFN,1):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry!" G END
F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,RI)) Q:RI'>0 I $D(^(RI,0)) S DA=RI,DIE="^RMPR(665,"_RMPRDFN_",1,",DR="5///^S X=2;10///^S X=DT",DA(1)=RMPRDFN D ^DIE
L -^RMPR(665,RMPRDFN,1)
END K RMPRX,RMPRY,RA,RI,RT,RC,RMPRT I $D(RMPRDIR3) Q
I $D(RMPRDIR7) K RMPRDIR7 G ASK1^RMPRPAT
Q:$D(RMPRBACK) K RMPRDFN,RMPRSSN,RMPRNAM,RMPRDOB,RMPRD,DIE,DIR,DR,DIRUT,DIC,DIK,DA Q
SEL W ! S DIC="^RMPR(665,"_RMPRDFN_",1,"
S DIC(0)="AEQMZ",DIC("W")="S RA=^(0) D DSP^RMPRDIS"
D ^DIC G:+Y'>0&('$D(RMPRBACK)) DEA G:+Y'>0 END
L +^RMPR(665,RMPRDFN,1):1 I $T=0 W !,$C(7),?5,"Someone else is Editing this entry!" G END
S DA=+Y,DA(1)=RMPRDFN,DIE=DIC,DR="5///^S X=2;10///^S X=DT" D ^DIE L -^RMPR(665,RMPRDFN,1) W !,?5,"**CODE MARKED AS DELETED**" W ! G SEL
LP ;DISPLAY DISABILITY CODES
K RMPRD F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,RI)) Q:RI'>0 I $D(^(RI,0)) S RMPRD(RI)=^(0)
W ! I $D(RMPRD) W !,$P(^DPT(RMPRDFN,0),U)," HAS THE FOLLOWING CODES:",! F RI=0:0 S RI=$O(RMPRD(RI)) Q:RI'>0 S RA=RMPRD(RI) W !,?5,$P(^RMPR(662,$P(RA,U),0),U) D DSP
Q
DIR K DIR I '$P(RMPRY,U,3) S DIR(0)="S^E:EDIT DISABILITY CODE;A:ADD DUPLICATE DISABILITY CODE",DIR("B")="EDIT" D ^DIR Q:$D(DIRUT) I Y["A" D FILE
Q
FILE K DD,DO,D0 S DIC="^RMPR(665,"_RMPRDFN_",1,",DIC(0)="EQML",DLAYGO=665 S X=RMPRX D FILE^DICN K DLAYGO S DA(1)=RMPRDFN,RMPRY=+Y Q
DSP I +$P(RA,U,3) W ?15 W $S($P(RA,U,3)=1:"SC ",1:"NSC ")
I +$P(RA,U,4) S RT=$P(^DD(665.01,3,0),U,3) W ?21,$P($P(RT,":",$P(RA,U,4)+1),";",1)_" "
I +$P(RA,U,5) S RT=$P(^DD(665.01,4,0),U,3) W ?41,$P($P(RT,":",$P(RA,U,5)+1),";",1)
I +$P(RA,U,10) W ?65,"Deleted..."
Q
SDR S DR=".01;5///1;2;3;S $P(^RMPR(665,DA(1),1,DA,0),U,8)=DUZ;1///^S X=DT;10///@;I $P(^RMPR(665,DA(1),1,DA,0),U,4)'=4 S Y="""";4" Q
CHK S RDA=$P(^RMPR(665,DA(1),1,DA,0),U) D K RDA
.F RI=0:0 S RI=$O(^RMPR(665,DA(1),1,"B",RDA,RI)) Q:RI'>0 S RV=$P(^RMPR(665,DA(1),1,RI,0),U,3) I (X=RV),(DA'=RI) K X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRDIS 4808 printed Dec 13, 2024@02:34:10 Page 2
RMPRDIS ;PHX/JLT-DISPLAY/EDIT DISABILITY CODES
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
+2 DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
QUIT
EN ;ADD DISABILITY CODE, CALLED FROM RMPRAP
+1 NEW DIC,DIR
+2 IF $DATA(RMPRDIR7)
SET DIR(0)="Y"
SET DIR("A")="Would you like to ADD/EDIT a Disability Code to the Patient's 2319"
SET DIR("B")="YES"
SET DIR("?")="Enter 'Y' to Edit a Disability Code, 'N' or '^' to continue."
+3 IF $TEST
DO ^DIR
if $DATA(DIRUT)!($DATA(DUOUT))
GOTO END
if +Y=0
GOTO DEA
+4 IF $GET(RMPRDA)
SET DFN=$PIECE($GET(^RMPR(660.5,RMPRDA,0)),U,2)
IF +DFN
IF '$DATA(^RMPR(665,+DFN))
SET ^RMPR(665,DFN,0)=DFN_U_RMPR("STA")
SET DA=DFN
SET DIK="^RMPR(665,"
DO IX1^DIK
+5 IF '$DATA(^RMPR(665,RMPRDFN,1))
SET ^RMPR(665,RMPRDFN,1,0)="^665.01PI^0^0"
+6 if '$DATA(RMPRBACK)
DO LP
LOCK +^RMPR(665,RMPRDFN,1):1
IF $TEST=0
WRITE !,$CHAR(7),?5,"Someone else is Editing this entry"
GOTO END
AMP WRITE !
SET DA(1)=RMPRDFN
SET DIC="^RMPR(665,"_DA(1)_",1,"
SET DIC(0)="AEQMZL"
SET DLAYGO=665
SET DIC("W")="S RA=^(0) D DSP^RMPRDIS"
DO ^DIC
KILL DLAYGO
if +Y'>0
GOTO DEND
SET RMPRY=Y
SET RMPRX=$PIECE(Y,U,2)
+1 IF $PIECE(^RMPR(665,RMPRDFN,1,+Y,0),U,10)
SET DIR(0)="Y"
SET DIR("A",1)="DISABILITY CODE HAS BEEN MARKED AS DELETED."
SET DIR("A")="WOULD YOU LIKE TO RE-ACTIVATED THIS CODE"
SET DIR("B")="NO"
SET DIR("?")="Enter 'Y' to re-activate code."
+2 IF $TEST
DO ^DIR
if $DATA(DIRUT)!($DATA(DUOUT))
GOTO DEND
KILL DIR
IF +Y=1
SET DA=+RMPRY
SET DIE=DIC
SET DR="10///@"
DO ^DIE
+3 SET RC=0
FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RMPRDFN,1,"B",RMPRX,RI))
if RI'>0
QUIT
SET RC=RC+1
+4 IF RC'>1
KILL DIRUT
DO DIR
if $DATA(DIRUT)
GOTO AMP
EDIT KILL DIR
SET DIE="^RMPR(665,RMPRDFN,1,"
SET DA(1)=RMPRDFN
SET DA=+RMPRY
DO SDR
+1 DO ^DIE
IF $DATA(DA)
IF $PIECE(^RMPR(665,DA(1),1,DA,0),U,4)'=4
SET $PIECE(^(0),U,5)=""
+2 IF $DATA(DA)
IF '$PIECE(^RMPR(665,RMPRDFN,1,DA,0),U,3)!'$PIECE(^(0),U,4)
SET DA(1)=RMPRDFN
SET DIK="^RMPR(665,RMPRDFN,1,"
SET DA(1)=RMPRDFN
DO ^DIK
WRITE !,?5,$CHAR(7),"Deleted..."
+3 GOTO AMP
DEND LOCK -^RMPR(665,RMPRDFN,1)
KILL RMPRX,RMPRY,RT,RI,RA,RMPRT,RCC
+1 IF '$DATA(RMPRBACK)
KILL DIC,Y,RMPRD,DIE,DR
QUIT
DEA ;DEACTIVATE PATIENT PROSTHETICS DISABILITY CODES
+1 ;I $G(RMPRDFN)'>0 Q
+2 if $DATA(RMPRDIR3)
QUIT
IF '$DATA(RMPRBACK)
KILL RMPRDFN
DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
GOTO END
+3 if $GET(RMPRDFN)'>0
QUIT
+4 IF '$DATA(^RMPR(665,RMPRDFN,1))!($ORDER(^RMPR(665,RMPRDFN,1,0))'>0)
WRITE !!,"Patient has no Prosthetics Disability codes",$CHAR(7)
GOTO END
+5 WRITE !,$PIECE(^DPT(RMPRDFN,0),U,1)," HAS THE FOLLOWING DISABILITY CODES:",!
FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RMPRDFN,1,RI))
if RI'>0
QUIT
SET RA=^(RI,0)
WRITE !,?5,$PIECE(^RMPR(662,$PIECE(RA,U,1),0),U,1)
DO DSP
+6 IF $DATA(RMPRDIR7)
WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Would you like to Mark a Disability Code as Deleted"
SET DIR("B")="NO"
SET DIR("?")="Enter 'Y' to Mark a Disability Code as Deleted"
DO ^DIR
if $DATA(DIRUT)!($DATA(DUOUT))!(+Y=0)
GOTO END
+7 SET RA=0
FOR RI=0:1
SET RA=$ORDER(^RMPR(665,RMPRDFN,1,RA))
if RA'>0
QUIT
+8 IF RI'>1
GOTO SEL
+9 KILL DIR
WRITE !!
SET DIR(0)="Y"
+10 SET DIR("A")="Would you like to Mark all of the Patient's Disability Codes as Deleted"
SET DIR("B")="NO"
SET DIR("?")="Enter 'Y' to Mark all of the Patients Disability Codes as Deleted, 'N' to select a Disability Code."
+11 DO ^DIR
if $DATA(DIRUT)!($DATA(DUOUT))
GOTO END
IF +Y=0
GOTO SEL
+12 LOCK +^RMPR(665,RMPRDFN,1):1
IF $TEST=0
WRITE !,$CHAR(7),?5,"Someone else is Editing this entry!"
GOTO END
+13 FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RMPRDFN,1,RI))
if RI'>0
QUIT
IF $DATA(^(RI,0))
SET DA=RI
SET DIE="^RMPR(665,"_RMPRDFN_",1,"
SET DR="5///^S X=2;10///^S X=DT"
SET DA(1)=RMPRDFN
DO ^DIE
+14 LOCK -^RMPR(665,RMPRDFN,1)
END KILL RMPRX,RMPRY,RA,RI,RT,RC,RMPRT
IF $DATA(RMPRDIR3)
QUIT
+1 IF $DATA(RMPRDIR7)
KILL RMPRDIR7
GOTO ASK1^RMPRPAT
+2 if $DATA(RMPRBACK)
QUIT
KILL RMPRDFN,RMPRSSN,RMPRNAM,RMPRDOB,RMPRD,DIE,DIR,DR,DIRUT,DIC,DIK,DA
QUIT
SEL WRITE !
SET DIC="^RMPR(665,"_RMPRDFN_",1,"
+1 SET DIC(0)="AEQMZ"
SET DIC("W")="S RA=^(0) D DSP^RMPRDIS"
+2 DO ^DIC
if +Y'>0&('$DATA(RMPRBACK))
GOTO DEA
if +Y'>0
GOTO END
+3 LOCK +^RMPR(665,RMPRDFN,1):1
IF $TEST=0
WRITE !,$CHAR(7),?5,"Someone else is Editing this entry!"
GOTO END
+4 SET DA=+Y
SET DA(1)=RMPRDFN
SET DIE=DIC
SET DR="5///^S X=2;10///^S X=DT"
DO ^DIE
LOCK -^RMPR(665,RMPRDFN,1)
WRITE !,?5,"**CODE MARKED AS DELETED**"
WRITE !
GOTO SEL
LP ;DISPLAY DISABILITY CODES
+1 KILL RMPRD
FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RMPRDFN,1,RI))
if RI'>0
QUIT
IF $DATA(^(RI,0))
SET RMPRD(RI)=^(0)
+2 WRITE !
IF $DATA(RMPRD)
WRITE !,$PIECE(^DPT(RMPRDFN,0),U)," HAS THE FOLLOWING CODES:",!
FOR RI=0:0
SET RI=$ORDER(RMPRD(RI))
if RI'>0
QUIT
SET RA=RMPRD(RI)
WRITE !,?5,$PIECE(^RMPR(662,$PIECE(RA,U),0),U)
DO DSP
+3 QUIT
DIR KILL DIR
IF '$PIECE(RMPRY,U,3)
SET DIR(0)="S^E:EDIT DISABILITY CODE;A:ADD DUPLICATE DISABILITY CODE"
SET DIR("B")="EDIT"
DO ^DIR
if $DATA(DIRUT)
QUIT
IF Y["A"
DO FILE
+1 QUIT
FILE KILL DD,DO,D0
SET DIC="^RMPR(665,"_RMPRDFN_",1,"
SET DIC(0)="EQML"
SET DLAYGO=665
SET X=RMPRX
DO FILE^DICN
KILL DLAYGO
SET DA(1)=RMPRDFN
SET RMPRY=+Y
QUIT
DSP IF +$PIECE(RA,U,3)
WRITE ?15
WRITE $SELECT($PIECE(RA,U,3)=1:"SC ",1:"NSC ")
+1 IF +$PIECE(RA,U,4)
SET RT=$PIECE(^DD(665.01,3,0),U,3)
WRITE ?21,$PIECE($PIECE(RT,":",$PIECE(RA,U,4)+1),";",1)_" "
+2 IF +$PIECE(RA,U,5)
SET RT=$PIECE(^DD(665.01,4,0),U,3)
WRITE ?41,$PIECE($PIECE(RT,":",$PIECE(RA,U,5)+1),";",1)
+3 IF +$PIECE(RA,U,10)
WRITE ?65,"Deleted..."
+4 QUIT
SDR SET DR=".01;5///1;2;3;S $P(^RMPR(665,DA(1),1,DA,0),U,8)=DUZ;1///^S X=DT;10///@;I $P(^RMPR(665,DA(1),1,DA,0),U,4)'=4 S Y="""";4"
QUIT
CHK SET RDA=$PIECE(^RMPR(665,DA(1),1,DA,0),U)
Begin DoDot:1
+1 FOR RI=0:0
SET RI=$ORDER(^RMPR(665,DA(1),1,"B",RDA,RI))
if RI'>0
QUIT
SET RV=$PIECE(^RMPR(665,DA(1),1,RI,0),U,3)
IF (X=RV)
IF (DA'=RI)
KILL X
QUIT
End DoDot:1
KILL RDA
