ACMFIX.m

ACMFIX ;Fix Dt of Onset - Pat Lundgren - IHS Diabetes Register [ 03/16/01  2:47 PM ]

 ;This routine $O thru ACM(41 CMS REGISTER finds only IHS Diabetes

 ;Entries - Sets the HXDT to field 20 Date of Onset & stuffs this

 ;date in the ACM(44 CMS Diagnosis for the Client, if missing

 ;the Date of onset

 ;

START ;$O ^ACM(41,"B",3 - IHS DIABETES REGISTER ONLY

 S REG="" F  S REG=$O(^ACM(41,"B",REG)) Q:REG'=+REG  D

 . Q:REG'=3879

 . S REGIEN="" F  S REGIEN=$O(^ACM(41,"B",REG,REGIEN)) Q:REGIEN'=+REGIEN  D

 .. S HXDT=$P($G(^ACM(41,REGIEN,"CH")),U,1)

 .. S HXPT=$P($G(^ACM(41,REGIEN,0)),U,2)

 .. Q:HXPT=""

 .. Q:HXDT=""

 .. ;Q:$P(^ACM(44,DXIEN,0)U,1)'=3  D

 .. S DXIEN=$O(^ACM(44,"C",+HXPT,0)) I 'DXIEN Q

 .. S DXDT=$P($G(^ACM(44,DXIEN,"SV")),U,2)

 .. I DXDT="" S DIE="^ACM(44,",DA=DXIEN,DR="2////"_HXDT D ^DIE K DIE,DR,DA

 ;

 ;

ACMFIX    ;Fix Dt of Onset - Pat Lundgren - IHS Diabetes Register [ 03/16/01  2:47 PM ]

 +1       ;This routine $O thru ACM(41 CMS REGISTER finds only IHS Diabetes

 +2       ;Entries - Sets the HXDT to field 20 Date of Onset & stuffs this

 +3       ;date in the ACM(44 CMS Diagnosis for the Client, if missing

 +4       ;the Date of onset

 +5       ;

START     ;$O ^ACM(41,"B",3 - IHS DIABETES REGISTER ONLY

 +1        SET REG=""

           FOR 

               SET REG=$ORDER(^ACM(41,"B",REG))

               IF REG'=+REG

                   QUIT 

               Begin DoDot:1

 +2                IF REG'=3879

                       QUIT 

 +3                SET REGIEN=""

                   FOR 

                       SET REGIEN=$ORDER(^ACM(41,"B",REG,REGIEN))

                       IF REGIEN'=+REGIEN

                           QUIT 

                       Begin DoDot:2

 +4                        SET HXDT=$PIECE($GET(^ACM(41,REGIEN,"CH")),U,1)

 +5                        SET HXPT=$PIECE($GET(^ACM(41,REGIEN,0)),U,2)

 +6                        IF HXPT=""

                               QUIT 

 +7                        IF HXDT=""

                               QUIT 

 +8       ;Q:$P(^ACM(44,DXIEN,0)U,1)'=3  D

 +9                        SET DXIEN=$ORDER(^ACM(44,"C",+HXPT,0))

                           IF 'DXIEN

                               QUIT 

 +10                       SET DXDT=$PIECE($GET(^ACM(44,DXIEN,"SV")),U,2)

 +11                       IF DXDT=""

                               SET DIE="^ACM(44,"

                               SET DA=DXIEN

                               SET DR="2////"_HXDT

                               DO ^DIE

                               KILL DIE,DR,DA

                       End DoDot:2

               End DoDot:1

 +12      ;

 +13      ;