PXRMSEDT ; SLC/PJH - Edit a reminder resolution status ;05/11/2000
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;Called from PXRMGEDT
;
;Edit/Delete resolution status
;-----------------------------
EDIT(ROOT,DA) ;
N DIC,DIE,DR,LIEN,TAX,NATIONAL,DIDEL
S DIE=ROOT,LIEN=DA
;
;Check if this is a restricted edit status (i.e. national status)
S NATIONAL=+$P($G(^PXRMD(801.9,DA,0)),U,6)
;
;If national status only allow entry of sub-status or inactive
I NATIONAL S DR="10;.04"
;
;Otherwise do not allow entry of restricted edit or sub-status
I 'NATIONAL S DR=".01;1;.02;.03;.04;.05///"_DUZ S DIDEL=801.9
;
D ^DIE Q:$D(Y) I '$D(DA) S VALMBCK="Q" Q
;
;If a local status - warning if not allocated to a national status
Q:NATIONAL Q:$D(^PXRMD(801.9,"AC",DA))
;Select National code
W !!,"This resolution status must be linked to a national status",!
N DA,DIC
S DIC="^PXRMD(801.9,"
S DIC(0)="AEMQ"
S DIC("S")="I $P(^(0),U,6)=1"
S DIC("A")="SELECT NATIONAL RESOLUTION STATUS: "
;Get the next name.
D ^DIC
S:Y=-1 DUOUT=1 Q:$D(DUOUT)!$D(DTOUT)
;Update sub-status field in national status
N FDA,FDAIEN,MSG
S FDA(801.9001,"+2,"_+Y_",",.01)=LIEN
D UPDATE^DIE("S","FDA","FDAIEN","MSG")
I $D(MSG) D ERR
Q
;
;Error Messages from UPDATE^DIE
;------------------------------
ERR N IC,ERROR,REF
;Move MSG into ERROR
S REF="MSG",ERROR(1)="Error in UPDATE^DIE, needs further investigation"
F IC=2:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
;Screen message
D BMES^XPDUTL(.ERROR)
Q
;
KILLAC ;This only applies if deleting a sub-status
I '$D(^PXRMD(801.9,DA)) Q
;
N SUB,NAT
;Get the national status for this sub status, quit if none
S NAT=""
F S NAT=$O(^PXRMD(801.9,"AC",DA,NAT)) Q:NAT="" D
.;Get sub status position in the national code, quit if none
.S SUB=$O(^PXRMD(801.9,"AC",DA,NAT,"")) Q:SUB=""
.;Kill the sub-status on the national code
.N DIC,DIK,DA S DIK="^PXRMD(801.9,NAT,10,",DA(1)=NAT,DA=SUB D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMSEDT 2015 printed Oct 16, 2024@17:49:54 Page 2
PXRMSEDT ; SLC/PJH - Edit a reminder resolution status ;05/11/2000
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;
+3 ;Called from PXRMGEDT
+4 ;
+5 ;Edit/Delete resolution status
+6 ;-----------------------------
EDIT(ROOT,DA) ;
+1 NEW DIC,DIE,DR,LIEN,TAX,NATIONAL,DIDEL
+2 SET DIE=ROOT
SET LIEN=DA
+3 ;
+4 ;Check if this is a restricted edit status (i.e. national status)
+5 SET NATIONAL=+$PIECE($GET(^PXRMD(801.9,DA,0)),U,6)
+6 ;
+7 ;If national status only allow entry of sub-status or inactive
+8 IF NATIONAL
SET DR="10;.04"
+9 ;
+10 ;Otherwise do not allow entry of restricted edit or sub-status
+11 IF 'NATIONAL
SET DR=".01;1;.02;.03;.04;.05///"_DUZ
SET DIDEL=801.9
+12 ;
+13 DO ^DIE
if $DATA(Y)
QUIT
IF '$DATA(DA)
SET VALMBCK="Q"
QUIT
+14 ;
+15 ;If a local status - warning if not allocated to a national status
+16 if NATIONAL
QUIT
if $DATA(^PXRMD(801.9,"AC",DA))
QUIT
+17 ;Select National code
+18 WRITE !!,"This resolution status must be linked to a national status",!
+19 NEW DA,DIC
+20 SET DIC="^PXRMD(801.9,"
+21 SET DIC(0)="AEMQ"
+22 SET DIC("S")="I $P(^(0),U,6)=1"
+23 SET DIC("A")="SELECT NATIONAL RESOLUTION STATUS: "
+24 ;Get the next name.
+25 DO ^DIC
+26 if Y=-1
SET DUOUT=1
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+27 ;Update sub-status field in national status
+28 NEW FDA,FDAIEN,MSG
+29 SET FDA(801.9001,"+2,"_+Y_",",.01)=LIEN
+30 DO UPDATE^DIE("S","FDA","FDAIEN","MSG")
+31 IF $DATA(MSG)
DO ERR
+32 QUIT
+33 ;
+34 ;Error Messages from UPDATE^DIE
+35 ;------------------------------
ERR NEW IC,ERROR,REF
+1 ;Move MSG into ERROR
+2 SET REF="MSG"
SET ERROR(1)="Error in UPDATE^DIE, needs further investigation"
+3 FOR IC=2:1
SET REF=$QUERY(@REF)
if REF=""
QUIT
SET ERROR(IC)=REF_"="_@REF
+4 ;Screen message
+5 DO BMES^XPDUTL(.ERROR)
+6 QUIT
+7 ;
KILLAC ;This only applies if deleting a sub-status
+1 IF '$DATA(^PXRMD(801.9,DA))
QUIT
+2 ;
+3 NEW SUB,NAT
+4 ;Get the national status for this sub status, quit if none
+5 SET NAT=""
+6 FOR
SET NAT=$ORDER(^PXRMD(801.9,"AC",DA,NAT))
if NAT=""
QUIT
Begin DoDot:1
+7 ;Get sub status position in the national code, quit if none
+8 SET SUB=$ORDER(^PXRMD(801.9,"AC",DA,NAT,""))
if SUB=""
QUIT
+9 ;Kill the sub-status on the national code
+10 NEW DIC,DIK,DA
SET DIK="^PXRMD(801.9,NAT,10,"
SET DA(1)=NAT
SET DA=SUB
DO ^DIK
End DoDot:1
+11 QUIT
