- 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 Mar 13, 2025@21:21:25 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
