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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARIPST 1553 printed Nov 22, 2024@17:23:04 Page 2
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
