MCARIPST.m

MCARIPST ; HISC/NCA - Pre-Init Conversions of Study Types ;2/24/95  09:36

 ;;2.3;Medicine;**2**;09/13/1996

 S MCARTIT=";"_$P(^DD(691.48,.01,0),"^",3)

 S MCARX1=$F(MCARTIT,";"_6_":") G:MCARX1 NXT

 F MCARLP=0:0 S MCARLP=$O(^MCAR(691,MCARLP)) Q:MCARLP<1  D P1

NXT ; Convert the abrev name to spelled out name in file 697.5

 F MCARLP=0:0 S MCARLP=$O(^MCAR(697.5,MCARLP)) Q:MCARLP<1  S MCARX=$G(^(MCARLP,0)) D P3

 K ^MCAR(697.5,"B"),^MCAR(697.5,"C"),^MCAR(697.5,"D"),^MCAR(697.5,"E"),^MCAR(697.5,"F"),^MCAR(697.5,"G"),^MCAR(697.5,"H"),^MCAR(697.5,"I")

 S DIK="^MCAR(697.5," D IXALL^DIK

 W *7,!!,"Pre-init Conversion Done!",!

 G KIL

P1 ; Process conversion and reset the Cross Reference

 K MP F MCAP0=0:0 S MCAP0=$O(^MCAR(691,MCARLP,16,MCAP0)) Q:MCAP0<1  S MCARX=$G(^(MCAP0,0)) D P2

 K ^MCAR(691,MCARLP,16) S (CT,ZT)=0

 F MCAP0=0:0 S MCAP0=$O(MP(MCAP0)) Q:MCAP0<1  S ^MCAR(691,MCARLP,16,MCAP0,0)=$G(MP(MCAP0)),^MCAR(691,MCARLP,16,"B",$G(MP(MCAP0)),MCAP0)="",CT=CT+1,ZT=MCAP0

 I CT S ^MCAR(691,MCARLP,16,0)="^691.48SA^"_ZT_"^"_CT

 Q

P2 ; Convert the Study Types

 S:MCARX MP(MCAP0)=$S(MCARX=2:3,MCARX=3:4,MCARX=4:5,MCARX=5:6,1:1)

 Q

P3 ; Convert the name field of file 697.5 and spelled out the abrev.

 S MCARNAM=$P(MCARX,"^",1),MCARC=$E(MCARNAM,($L(MCARNAM)-4),$L(MCARNAM))

 S MCARY=$S(MCARC=": MIN":"IMAL",MCARC=": MOD":"ERATE",MCARC=": SEV":"ERE",1:"")

 I MCARY'="" S MCARNAM=MCARNAM_MCARY,$P(^MCAR(697.5,MCARLP,0),"^",1)=MCARNAM

 Q

KIL ; Kill Variables

 K CT,DA,DIK,MP,MCARC,MCARNAM,MCARTIT,MCARLP,MCAP0,MCARX,MCARX1,MCARY,ZT

 Q

MCARIPST  ; HISC/NCA - Pre-Init Conversions of Study Types ;2/24/95  09:36

 +1       ;;2.3;Medicine;**2**;09/13/1996

 +2        SET MCARTIT=";"_$PIECE(^DD(691.48,.01,0),"^",3)

 +3        SET MCARX1=$FIND(MCARTIT,";"_6_":")

           IF MCARX1

               GOTO NXT

 +4        FOR MCARLP=0:0

               SET MCARLP=$ORDER(^MCAR(691,MCARLP))

               IF MCARLP<1

                   QUIT 

               DO P1

NXT       ; Convert the abrev name to spelled out name in file 697.5

 +1        FOR MCARLP=0:0

               SET MCARLP=$ORDER(^MCAR(697.5,MCARLP))

               IF MCARLP<1

                   QUIT 

               SET MCARX=$GET(^(MCARLP,0))

               DO P3

 +2        KILL ^MCAR(697.5,"B"),^MCAR(697.5,"C"),^MCAR(697.5,"D"),^MCAR(697.5,"E"),^MCAR(697.5,"F"),^MCAR(697.5,"G"),^MCAR(697.5,"H"),^MCAR(697.5,"I")

 +3        SET DIK="^MCAR(697.5,"

           DO IXALL^DIK

 +4        WRITE *7,!!,"Pre-init Conversion Done!",!

 +5        GOTO KIL

P1        ; Process conversion and reset the Cross Reference

 +1        KILL MP

           FOR MCAP0=0:0

               SET MCAP0=$ORDER(^MCAR(691,MCARLP,16,MCAP0))

               IF MCAP0<1

                   QUIT 

               SET MCARX=$GET(^(MCAP0,0))

               DO P2

 +2        KILL ^MCAR(691,MCARLP,16)

           SET (CT,ZT)=0

 +3        FOR MCAP0=0:0

               SET MCAP0=$ORDER(MP(MCAP0))

               IF MCAP0<1

                   QUIT 

               SET ^MCAR(691,MCARLP,16,MCAP0,0)=$GET(MP(MCAP0))

               SET ^MCAR(691,MCARLP,16,"B",$GET(MP(MCAP0)),MCAP0)=""

               SET CT=CT+1

               SET ZT=MCAP0

 +4        IF CT

               SET ^MCAR(691,MCARLP,16,0)="^691.48SA^"_ZT_"^"_CT

 +5        QUIT 

P2        ; Convert the Study Types

 +1        IF MCARX

               SET MP(MCAP0)=$SELECT(MCARX=2:3,MCARX=3:4,MCARX=4:5,MCARX=5:6,1:1)

 +2        QUIT 

P3        ; Convert the name field of file 697.5 and spelled out the abrev.

 +1        SET MCARNAM=$PIECE(MCARX,"^",1)

           SET MCARC=$EXTRACT(MCARNAM,($LENGTH(MCARNAM)-4),$LENGTH(MCARNAM))

 +2        SET MCARY=$SELECT(MCARC=": MIN":"IMAL",MCARC=": MOD":"ERATE",MCARC=": SEV":"ERE",1:"")

 +3        IF MCARY'=""

               SET MCARNAM=MCARNAM_MCARY

               SET $PIECE(^MCAR(697.5,MCARLP,0),"^",1)=MCARNAM

 +4        QUIT 

KIL       ; Kill Variables

 +1        KILL CT,DA,DIK,MP,MCARC,MCARNAM,MCARTIT,MCARLP,MCAP0,MCARX,MCARX1,MCARY,ZT

 +2        QUIT