MCPOS07 ;HIRMFO/DAD-DELETE POINTERS TO LAB FILES ;8/2/96 10:32
;;2.3;Medicine;;09/13/1996
;
N DA,DIE,DR,MCD0,MCDATA,MCFIELD,MCFILE,MCOFFSET
S MCDATA(1)=""
S MCDATA(2)="Deleting pointers to Lab files."
D MES^XPDUTL(.MCDATA) K MCDATA
;
F MCOFFSET=1:1 S MCDATA=$P($T(FILEFLD+MCOFFSET),";",3) Q:MCDATA="" D
. S MCFILE=$P(MCDATA,U),MCFIELD=$P(MCDATA,U,2)
. S MCD0=0
. F S MCD0=$O(^MCAR(MCFILE,MCD0)) Q:MCD0'>0 D
.. S DIE="^MCAR("_MCFILE_",",DA=MCD0,DR=MCFIELD_"///@"
.. D ^DIE
.. Q
. Q
Q
;
FILEFLD ;; File # ^ Field #
;;693.5^1
;;695.3^1
;;695.5^1
;;695.9^1
;;696^2
;;696.2^1
;;697^2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS07 633 printed Nov 22, 2024@17:26:29 Page 2
MCPOS07 ;HIRMFO/DAD-DELETE POINTERS TO LAB FILES ;8/2/96 10:32
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 NEW DA,DIE,DR,MCD0,MCDATA,MCFIELD,MCFILE,MCOFFSET
+4 SET MCDATA(1)=""
+5 SET MCDATA(2)="Deleting pointers to Lab files."
+6 DO MES^XPDUTL(.MCDATA)
KILL MCDATA
+7 ;
+8 FOR MCOFFSET=1:1
SET MCDATA=$PIECE($TEXT(FILEFLD+MCOFFSET),";",3)
if MCDATA=""
QUIT
Begin DoDot:1
+9 SET MCFILE=$PIECE(MCDATA,U)
SET MCFIELD=$PIECE(MCDATA,U,2)
+10 SET MCD0=0
+11 FOR
SET MCD0=$ORDER(^MCAR(MCFILE,MCD0))
if MCD0'>0
QUIT
Begin DoDot:2
+12 SET DIE="^MCAR("_MCFILE_","
SET DA=MCD0
SET DR=MCFIELD_"///@"
+13 DO ^DIE
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
FILEFLD ;; File # ^ Field #
+1 ;;693.5^1
+2 ;;695.3^1
+3 ;;695.5^1
+4 ;;695.9^1
+5 ;;696^2
+6 ;;696.2^1
+7 ;;697^2
