- 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 Jan 18, 2025@03:35:20 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