MCPOS06 ;HIRMFO/DAD-FIX SUBDD NUMBER IN DATA NODES ;4/25/96 10:55
;;2.3;Medicine;;09/13/1996
;
; Change subDD number to 699.501
N MCD0,MCDATA,MCSUBDD
S MCDATA(1)=""
S MCDATA(2)="Checking the sub-DD numbers in the Generalized"
S MCDATA(3)="Procedure/Consult file (#699.5)."
D MES^XPDUTL(.MCDATA)
;
S MCD0=0
F S MCD0=$O(^MCAR(699.5,MCD0)) Q:MCD0'>0 D
. S MCDATA=$G(^MCAR(699.5,MCD0,2,0))
. I MCDATA="",$O(^MCAR(699.5,MCD0,2,0))'>0 Q
. S MCSUBDD=$P(MCDATA,U,2)
. I +MCSUBDD'=699.501 D
.. S $P(MCDATA,U,2)="699.501"_$TR(MCSUBDD,"1234567890.")
.. S ^MCAR(699.5,MCD0,2,0)=MCDATA
.. Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS06 628 printed Oct 16, 2024@18:17:04 Page 2
MCPOS06 ;HIRMFO/DAD-FIX SUBDD NUMBER IN DATA NODES ;4/25/96 10:55
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 ; Change subDD number to 699.501
+4 NEW MCD0,MCDATA,MCSUBDD
+5 SET MCDATA(1)=""
+6 SET MCDATA(2)="Checking the sub-DD numbers in the Generalized"
+7 SET MCDATA(3)="Procedure/Consult file (#699.5)."
+8 DO MES^XPDUTL(.MCDATA)
+9 ;
+10 SET MCD0=0
+11 FOR
SET MCD0=$ORDER(^MCAR(699.5,MCD0))
if MCD0'>0
QUIT
Begin DoDot:1
+12 SET MCDATA=$GET(^MCAR(699.5,MCD0,2,0))
+13 IF MCDATA=""
IF $ORDER(^MCAR(699.5,MCD0,2,0))'>0
QUIT
+14 SET MCSUBDD=$PIECE(MCDATA,U,2)
+15 IF +MCSUBDD'=699.501
Begin DoDot:2
+16 SET $PIECE(MCDATA,U,2)="699.501"_$TRANSLATE(MCSUBDD,"1234567890.")
+17 SET ^MCAR(699.5,MCD0,2,0)=MCDATA
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
