BPXRM202 ; IHS/MSC/MGH - Version 2.0 Patch 2 post routine. ;19-Aug-2013 16:59;DU
;;2.0;CLINICAL REMINDERS;**1002**;Feb 04, 2005;Build 15
;
ENV ;EP environment check
N IN,INSTDA,STAT
;Check for the installation of Reminders 2.0
S IN="CLINICAL REMINDERS 2.0",INSTDA=""
I '$D(^XPD(9.7,"B",IN)) D Q
.W !,"You must first install CLINICAL REMINDERS 2.0 before this patch" S XPDQUIT=2
S INSTDA=$O(^XPD(9.7,"B",IN,INSTDA),-1)
S STAT=+$P($G(^XPD(9.7,INSTDA,0)),U,9)
I STAT'=3 D Q
.W !,"CLINICAL REMINDERS 2.0 must be completely installed before installing this patch." S XPDQUIT=2
S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
;Check for the installation of other patches
S PATCH="PXRM*2.0*1001"
I '$$PATCH(PATCH) D Q
. W !,"You must first install "_PATCH_"." S XPDQUIT=2
Q
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn
;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb
Q:X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N 0
NEW NUM,I,J
S I=$O(^DIC(9.4,"C",$P(X,"*"),0)) Q:'I 0
S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0
;check if patch is just a number
Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1
S NUM=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
Q (X=+NUM)
;===============================================================
PRE ;EP pre-init
Q
;===============================================================
POST ;Post-install
D TERMS
D DIALOG
D INACT
D CNAK
Q
;================================================================
TERMS ;Resequence the reminder finding types prompts to use the new prompts
N MSG,TYP,PARRAY
D PROMPTS
S TYP=$$FIND1^DIC(801.45,,,"IM",,,"MSG")
I $D(MSG) D Q
. W !!,"The following error message was returned:",!!
. S MSG="" F S MSG=$O(MSG("DIERR",1,"TEXT",MSG)) Q:MSG="" W MSG("DIERR",1,"TEXT",MSG),!
. W !!,"Unable to find the Immunization FINDING TYPE"
I '$D(MSG) D IMM
Q
PROMPTS ;
S PARRAY("PXRM LOT NUMBER")=$O(^PXRMD(801.41,"B","PXRM LOT NUMBER",""))
S PARRAY("PXRM IMM SITE")=$O(^PXRMD(801.41,"B","PXRM IMM SITE",""))
S PARRAY("PXRM VOLUME")=$O(^PXRMD(801.41,"B","PXRM VOLUME",""))
S PARRAY("PXRM IMM VIS DATE")=$O(^PXRMD(801.41,"B","PXRM IMM VIS DATE",""))
S PARRAY("PXRM SERIES")=$O(^PXRMD(801.41,"B","PXRM SERIES",""))
S PARRAY("PXRM CONTRAINDICATED")=$O(^PXRMD(801.41,"B","PXRM CONTRAINDICATED",""))
S PARRAY("PXRM REACTION")=$O(^PXRMD(801.41,"B","PXRM REACTION",""))
S PARRAY("PXRM IMM ELIG")=$O(^PXRMD(801.41,"B","PXRM IMM ELIG",""))
S PARRAY("PXRM ADMIN NOTES")=$O(^PXRMD(801.41,"B","PXRM ADMIN NOTES",""))
Q
IMM ;Find the prompts for the Immunizations
N STA,IENS
S IENS=","_TYP_","
S STA=$$FIND1^DIC(801.451,IENS,,"DONE AT ENCOUNTER",,,.MSG)
I $D(MSG) D Q
. W !!,"The following error message was returned:",!!
. S MSG="" F S MSG=$O(MSG("DIERR",1,"TEXT",MSG)) Q:MSG="" W MSG("DIERR",1,"TEXT",MSG),!
.W !!,"Unable to find DONE AT ENCOUNTER for Immunization FINDING TYPE"
I '$D(MSG) D IMMGIV
Q
IMMGIV ; Replace prompts for Immunization given at encounter
N IENS,FDA,MSG
D DELETE
;Add the lot number prompt
S IENS="+1,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM LOT NUMBER"))
S FDA(801.4515,IENS,1)=1
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
;Add the Site prompt
S IENS="+2,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM IMM SITE"))
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
;Add the Volume prompt
S IENS="+3,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM VOLUME"))
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
;Add the Vis DATE prompt
S IENS="+4,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM IMM VIS DATE"))
S FDA(801.4515,IENS,1)=1
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
;Add the elig prompt
S IENS="+5,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM IMM ELIG"))
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
; Add the series
S IENS="+6,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM SERIES"))
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
;Add the reaction prompt
S IENS="+7,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM REACTION"))
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
;Add the contraindicated prompt
S IENS="+8,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM CONTRAINDICATED"))
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
;Add the admin notes prompt
S IENS="+9,"_STA_","_TYP_","
S FDA(801.4515,IENS,.01)=$G(PARRAY("PXRM ADMIN NOTES"))
S FDA(801.4515,IENS,5)=1
D UPDATE^DIE("","FDA","IENS","MSG")
I $D(MSG) D MSG
Q
DELETE ;Delete the subnodes
N PMT,DA,DIK
S PMT=0 F S PMT=$O(^PXRMD(801.45,TYP,1,STA,5,PMT)) Q:PMT="" D
.S DA(2)=TYP,DA(1)=STA,DA=PMT
.S DIK="^PXRMD(801.45,"_TYP_",1,"_STA_",5,"
.D ^DIK
Q
MSG ;Print out the message
W !!,"The following error message was returned:",!!
S MSG="" F S MSG=$O(MSG("DIERR",1,"TEXT",MSG)) Q:MSG="" W MSG("DIERR",1,"TEXT",MSG),!
W !!,"Unable to add a prompt to FINDING NUMBER "_TYP_" Prompt may have to be added manually."
N MSG
Q
DIALOG ;Update the dialog prompt
N IEN,GUI,FDA,IENS,MSG
S IEN=0,GUI=0
S IEN=$O(^PXRMD(801.41,"B","PXRM IMM ELIG",IEN)) Q:'+IEN D
.S GUI=$O(^PXRMD(801.42,"B","IMM_ELIG",GUI)) Q:'+GUI D
..S IENS=IEN_","
..S FDA(801.41,IENS,46)=GUI
..D UPDATE^DIE("","FDA","IENS","MSG")
..I $D(MSG) D MSG2
K FDA,IENS,MSG
S IEN=0,GUI=0
S IEN=$O(^PXRMD(801.41,"B","PXRM ADMIN NOTES",IEN)) Q:'+IEN D
.S GUI=$O(^PXRMD(801.42,"B","IMM_NTS",GUI)) Q:'+GUI D
..S IENS=IEN_","
..S FDA(801.41,IENS,46)=GUI
..D UPDATE^DIE("","FDA","IENS","MSG")
..I $D(MSG) D MSG2
K FDA,IENS,MSG
Q
MSG2 ;Print out the message
W !!,"The following error message was returned:",!!
S MSG="" F S MSG=$O(MSG("DIERR",1,"TEXT",MSG)) Q:MSG="" W MSG("DIERR",1,"TEXT",MSG),!
W !!,"Unable to add a GUI PROCESS to FINDING NUMBER "_IEN_" GUI process may have to be added manually."
Q
;
INACT ;Inactivate items
N IEN,I,IENS
F I="IHS-ANTICOAG CBC 2011","IHS-ANTICOAG OCCULT BLOOD 2011","IHS-ANTICOAG UA 2011","IHS-PPD 2012" D
.S IEN="" S IEN=$O(^PXD(811.9,"B",I,IEN)) Q:IEN="" D
..N FDA,ERR
..S IENS=IEN_","
..S FDA(811.9,IENS,1.6)=1
..D FILE^DIE("","FDA","ERR")
Q
;===============================================================
CNAK ;Make sure all "NAK" characters are converted back to "^" in
;the Exchange File.
N IEN,TEXT
D BMES^XPDUTL("Clean up Exchange File entries")
S IEN=0
F S IEN=+$O(^PXD(811.8,IEN)) Q:IEN=0 D
. D POSTKIDS^PXRMEXU5(IEN)
Q
;
;===============================================================
DELEI ;If the Exchange File entry already exists delete it.
N ARRAY,IC,IND,LIST,LUVALUE,NUM
S IC=0
F S IC=$O(ARRAY(IC)) Q:'IC D
.S LUVALUE(1)=ARRAY(IC,1)
.D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
.I '$D(LIST) Q
.S NUM=$P(LIST("DILIST",0),U,1)
.I NUM'=0 D
..F IND=1:1:NUM D
... N DA,DIK
... S DIK="^PXD(811.8,"
... S DA=LIST("DILIST",2,IND)
... D ^DIK
Q
;
BPXRM202 ; IHS/MSC/MGH - Version 2.0 Patch 2 post routine. ;19-Aug-2013 16:59;DU
+1 ;;2.0;CLINICAL REMINDERS;**1002**;Feb 04, 2005;Build 15
+2 ;
ENV ;EP environment check
+1 NEW IN,INSTDA,STAT
+2 ;Check for the installation of Reminders 2.0
+3 SET IN="CLINICAL REMINDERS 2.0"
SET INSTDA=""
+4 IF '$DATA(^XPD(9.7,"B",IN))
Begin DoDot:1
+5 WRITE !,"You must first install CLINICAL REMINDERS 2.0 before this patch"
SET XPDQUIT=2
End DoDot:1
QUIT
+6 SET INSTDA=$ORDER(^XPD(9.7,"B",IN,INSTDA),-1)
+7 SET STAT=+$PIECE($GET(^XPD(9.7,INSTDA,0)),U,9)
+8 IF STAT'=3
Begin DoDot:1
+9 WRITE !,"CLINICAL REMINDERS 2.0 must be completely installed before installing this patch."
SET XPDQUIT=2
End DoDot:1
QUIT
+10 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+11 ;Check for the installation of other patches
+12 SET PATCH="PXRM*2.0*1001"
+13 IF '$$PATCH(PATCH)
Begin DoDot:1
+14 WRITE !,"You must first install "_PATCH_"."
SET XPDQUIT=2
End DoDot:1
QUIT
+15 QUIT
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn
+1 ;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb
+2 IF X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N
QUIT 0
+3 NEW NUM,I,J
+4 SET I=$ORDER(^DIC(9.4,"C",$PIECE(X,"*"),0))
IF 'I
QUIT 0
+5 SET J=$ORDER(^DIC(9.4,I,22,"B",$PIECE(X,"*",2),0))
SET X=$PIECE(X,"*",3)
IF 'J
QUIT 0
+6 ;check if patch is just a number
+7 IF $ORDER(^DIC(9.4,I,22,J,"PAH","B",X,0))
QUIT 1
+8 SET NUM=$ORDER(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
+9 QUIT (X=+NUM)
+10 ;===============================================================
PRE ;EP pre-init
+1 QUIT
+2 ;===============================================================
POST ;Post-install
+1 DO TERMS
+2 DO DIALOG
+3 DO INACT
+4 DO CNAK
+5 QUIT
+6 ;================================================================
TERMS ;Resequence the reminder finding types prompts to use the new prompts
+1 NEW MSG,TYP,PARRAY
+2 DO PROMPTS
+3 SET TYP=$$FIND1^DIC(801.45,,,"IM",,,"MSG")
+4 IF $DATA(MSG)
Begin DoDot:1
+5 WRITE !!,"The following error message was returned:",!!
+6 SET MSG=""
FOR
SET MSG=$ORDER(MSG("DIERR",1,"TEXT",MSG))
IF MSG=""
QUIT
WRITE MSG("DIERR",1,"TEXT",MSG),!
+7 WRITE !!,"Unable to find the Immunization FINDING TYPE"
End DoDot:1
QUIT
+8 IF '$DATA(MSG)
DO IMM
+9 QUIT
PROMPTS ;
+1 SET PARRAY("PXRM LOT NUMBER")=$ORDER(^PXRMD(801.41,"B","PXRM LOT NUMBER",""))
+2 SET PARRAY("PXRM IMM SITE")=$ORDER(^PXRMD(801.41,"B","PXRM IMM SITE",""))
+3 SET PARRAY("PXRM VOLUME")=$ORDER(^PXRMD(801.41,"B","PXRM VOLUME",""))
+4 SET PARRAY("PXRM IMM VIS DATE")=$ORDER(^PXRMD(801.41,"B","PXRM IMM VIS DATE",""))
+5 SET PARRAY("PXRM SERIES")=$ORDER(^PXRMD(801.41,"B","PXRM SERIES",""))
+6 SET PARRAY("PXRM CONTRAINDICATED")=$ORDER(^PXRMD(801.41,"B","PXRM CONTRAINDICATED",""))
+7 SET PARRAY("PXRM REACTION")=$ORDER(^PXRMD(801.41,"B","PXRM REACTION",""))
+8 SET PARRAY("PXRM IMM ELIG")=$ORDER(^PXRMD(801.41,"B","PXRM IMM ELIG",""))
+9 SET PARRAY("PXRM ADMIN NOTES")=$ORDER(^PXRMD(801.41,"B","PXRM ADMIN NOTES",""))
+10 QUIT
IMM ;Find the prompts for the Immunizations
+1 NEW STA,IENS
+2 SET IENS=","_TYP_","
+3 SET STA=$$FIND1^DIC(801.451,IENS,,"DONE AT ENCOUNTER",,,.MSG)
+4 IF $DATA(MSG)
Begin DoDot:1
+5 WRITE !!,"The following error message was returned:",!!
+6 SET MSG=""
FOR
SET MSG=$ORDER(MSG("DIERR",1,"TEXT",MSG))
IF MSG=""
QUIT
WRITE MSG("DIERR",1,"TEXT",MSG),!
+7 WRITE !!,"Unable to find DONE AT ENCOUNTER for Immunization FINDING TYPE"
End DoDot:1
QUIT
+8 IF '$DATA(MSG)
DO IMMGIV
+9 QUIT
IMMGIV ; Replace prompts for Immunization given at encounter
+1 NEW IENS,FDA,MSG
+2 DO DELETE
+3 ;Add the lot number prompt
+4 SET IENS="+1,"_STA_","_TYP_","
+5 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM LOT NUMBER"))
+6 SET FDA(801.4515,IENS,1)=1
+7 SET FDA(801.4515,IENS,5)=1
+8 DO UPDATE^DIE("","FDA","IENS","MSG")
+9 IF $DATA(MSG)
DO MSG
+10 ;Add the Site prompt
+11 SET IENS="+2,"_STA_","_TYP_","
+12 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM IMM SITE"))
+13 SET FDA(801.4515,IENS,5)=1
+14 DO UPDATE^DIE("","FDA","IENS","MSG")
+15 IF $DATA(MSG)
DO MSG
+16 ;Add the Volume prompt
+17 SET IENS="+3,"_STA_","_TYP_","
+18 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM VOLUME"))
+19 SET FDA(801.4515,IENS,5)=1
+20 DO UPDATE^DIE("","FDA","IENS","MSG")
+21 IF $DATA(MSG)
DO MSG
+22 ;Add the Vis DATE prompt
+23 SET IENS="+4,"_STA_","_TYP_","
+24 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM IMM VIS DATE"))
+25 SET FDA(801.4515,IENS,1)=1
+26 SET FDA(801.4515,IENS,5)=1
+27 DO UPDATE^DIE("","FDA","IENS","MSG")
+28 IF $DATA(MSG)
DO MSG
+29 ;Add the elig prompt
+30 SET IENS="+5,"_STA_","_TYP_","
+31 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM IMM ELIG"))
+32 SET FDA(801.4515,IENS,5)=1
+33 DO UPDATE^DIE("","FDA","IENS","MSG")
+34 IF $DATA(MSG)
DO MSG
+35 ; Add the series
+36 SET IENS="+6,"_STA_","_TYP_","
+37 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM SERIES"))
+38 SET FDA(801.4515,IENS,5)=1
+39 DO UPDATE^DIE("","FDA","IENS","MSG")
+40 IF $DATA(MSG)
DO MSG
+41 ;Add the reaction prompt
+42 SET IENS="+7,"_STA_","_TYP_","
+43 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM REACTION"))
+44 SET FDA(801.4515,IENS,5)=1
+45 DO UPDATE^DIE("","FDA","IENS","MSG")
+46 IF $DATA(MSG)
DO MSG
+47 ;Add the contraindicated prompt
+48 SET IENS="+8,"_STA_","_TYP_","
+49 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM CONTRAINDICATED"))
+50 SET FDA(801.4515,IENS,5)=1
+51 DO UPDATE^DIE("","FDA","IENS","MSG")
+52 IF $DATA(MSG)
DO MSG
+53 ;Add the admin notes prompt
+54 SET IENS="+9,"_STA_","_TYP_","
+55 SET FDA(801.4515,IENS,.01)=$GET(PARRAY("PXRM ADMIN NOTES"))
+56 SET FDA(801.4515,IENS,5)=1
+57 DO UPDATE^DIE("","FDA","IENS","MSG")
+58 IF $DATA(MSG)
DO MSG
+59 QUIT
DELETE ;Delete the subnodes
+1 NEW PMT,DA,DIK
+2 SET PMT=0
FOR
SET PMT=$ORDER(^PXRMD(801.45,TYP,1,STA,5,PMT))
IF PMT=""
QUIT
Begin DoDot:1
+3 SET DA(2)=TYP
SET DA(1)=STA
SET DA=PMT
+4 SET DIK="^PXRMD(801.45,"_TYP_",1,"_STA_",5,"
+5 DO ^DIK
End DoDot:1
+6 QUIT
MSG ;Print out the message
+1 WRITE !!,"The following error message was returned:",!!
+2 SET MSG=""
FOR
SET MSG=$ORDER(MSG("DIERR",1,"TEXT",MSG))
IF MSG=""
QUIT
WRITE MSG("DIERR",1,"TEXT",MSG),!
+3 WRITE !!,"Unable to add a prompt to FINDING NUMBER "_TYP_" Prompt may have to be added manually."
+4 NEW MSG
+5 QUIT
DIALOG ;Update the dialog prompt
+1 NEW IEN,GUI,FDA,IENS,MSG
+2 SET IEN=0
SET GUI=0
+3 SET IEN=$ORDER(^PXRMD(801.41,"B","PXRM IMM ELIG",IEN))
IF '+IEN
QUIT
Begin DoDot:1
+4 SET GUI=$ORDER(^PXRMD(801.42,"B","IMM_ELIG",GUI))
IF '+GUI
QUIT
Begin DoDot:2
+5 SET IENS=IEN_","
+6 SET FDA(801.41,IENS,46)=GUI
+7 DO UPDATE^DIE("","FDA","IENS","MSG")
+8 IF $DATA(MSG)
DO MSG2
End DoDot:2
End DoDot:1
+9 KILL FDA,IENS,MSG
+10 SET IEN=0
SET GUI=0
+11 SET IEN=$ORDER(^PXRMD(801.41,"B","PXRM ADMIN NOTES",IEN))
IF '+IEN
QUIT
Begin DoDot:1
+12 SET GUI=$ORDER(^PXRMD(801.42,"B","IMM_NTS",GUI))
IF '+GUI
QUIT
Begin DoDot:2
+13 SET IENS=IEN_","
+14 SET FDA(801.41,IENS,46)=GUI
+15 DO UPDATE^DIE("","FDA","IENS","MSG")
+16 IF $DATA(MSG)
DO MSG2
End DoDot:2
End DoDot:1
+17 KILL FDA,IENS,MSG
+18 QUIT
MSG2 ;Print out the message
+1 WRITE !!,"The following error message was returned:",!!
+2 SET MSG=""
FOR
SET MSG=$ORDER(MSG("DIERR",1,"TEXT",MSG))
IF MSG=""
QUIT
WRITE MSG("DIERR",1,"TEXT",MSG),!
+3 WRITE !!,"Unable to add a GUI PROCESS to FINDING NUMBER "_IEN_" GUI process may have to be added manually."
+4 QUIT
+5 ;
INACT ;Inactivate items
+1 NEW IEN,I,IENS
+2 FOR I="IHS-ANTICOAG CBC 2011","IHS-ANTICOAG OCCULT BLOOD 2011","IHS-ANTICOAG UA 2011","IHS-PPD 2012"
Begin DoDot:1
+3 SET IEN=""
SET IEN=$ORDER(^PXD(811.9,"B",I,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+4 NEW FDA,ERR
+5 SET IENS=IEN_","
+6 SET FDA(811.9,IENS,1.6)=1
+7 DO FILE^DIE("","FDA","ERR")
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;===============================================================
CNAK ;Make sure all "NAK" characters are converted back to "^" in
+1 ;the Exchange File.
+2 NEW IEN,TEXT
+3 DO BMES^XPDUTL("Clean up Exchange File entries")
+4 SET IEN=0
+5 FOR
SET IEN=+$ORDER(^PXD(811.8,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+6 DO POSTKIDS^PXRMEXU5(IEN)
End DoDot:1
+7 QUIT
+8 ;
+9 ;===============================================================
DELEI ;If the Exchange File entry already exists delete it.
+1 NEW ARRAY,IC,IND,LIST,LUVALUE,NUM
+2 SET IC=0
+3 FOR
SET IC=$ORDER(ARRAY(IC))
IF 'IC
QUIT
Begin DoDot:1
+4 SET LUVALUE(1)=ARRAY(IC,1)
+5 DO FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
+6 IF '$DATA(LIST)
QUIT
+7 SET NUM=$PIECE(LIST("DILIST",0),U,1)
+8 IF NUM'=0
Begin DoDot:2
+9 FOR IND=1:1:NUM
Begin DoDot:3
+10 NEW DA,DIK
+11 SET DIK="^PXD(811.8,"
+12 SET DA=LIST("DILIST",2,IND)
+13 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
