MCOREX ;WISC/TJK-OERR/MEDICINE DATA EXTRACT UTILITY ;2/17/98 14:48
;;2.3;Medicine;**17**;09/13/1996
SET S MCK=MCK+1,^TMP("MC",$J,MCC,MCK)=MCM_U_MCHEAD Q
POINT Q:'$D(^MCAR(MCFILE,MCARGDA,MCNODE))
S MCM=$P($G(^MCAR(MCFILE,MCARGDA,MCNODE)),U,MCPIECE)
Q:'MCM S MCM=$P($G(^MCAR(MCFILE1,MCM,0)),U) Q:MCM=""
D SET
Q
MPOINT Q:'$D(^MCAR(MCFILE,MCARGDA,MCNODE))
F I=0:0 S I=$O(^MCAR(MCFILE,MCARGDA,MCNODE,I)) Q:I'?1N.N D
.S J=$P(^MCAR(MCFILE,MCARGDA,MCNODE,I,0),U,MCPIECE)
.Q:'J S MCM=$P($G(^MCAR(MCFILE1,J,0)),U)
.Q:MCM="" D SET
Q
FREE Q:'$D(^MCAR(MCFILE,MCARGDA,MCNODE))
S MCM=$P(^MCAR(MCFILE,MCARGDA,MCNODE),U,MCPIECE) D SET Q
MFREE Q:'$D(^MCAR(MCFILE,MCARGDA,MCNODE))
F I=0:0 S I=$O(^MCAR(MCFILE,MCARGDA,MCNODE,I)) Q:I'?1N.N D
.S MCM=$P(^MCAR(MCFILE,MCARGDA,MCNODE,I,0),U,MCPIECE)
.Q:MCM="" D SET
Q
SETS Q:'$D(^MCAR(MCFILE,MCARGDA,MCNODE))
S J=$P(^MCAR(MCFILE,MCARGDA,MCNODE),U,MCPIECE) Q:J=""
;S MCM=$P($G(^DD(MCFILE,MCFILE1,0)),U,3) Q:MCM=""
S MCM=$$GET1^DID(MCFILE,MCFILE1,"","SPECIFIER") Q:MCM=""
F K=1:1 S L=$P(MCM,";",K) Q:L="" I $P(L,":",1)=J S MCM=$P(L,":",2) D SET Q
Q
MSET Q:'$D(^MCAR(MCFILE,MCARGDA,MCNODE))
F I=0:0 S I=$O(^MCAR(MCFILE,MCARGDA,MCNODE,I)) Q:I'?1N.N D
.S J=$P(^MCAR(MCFILE,MCARGDA,MCNODE,I,0),U,MCPIECE)
.;Q:J="" S MCM=$P($G(^DD(MCFILE1,.01,0)),U,3)
.Q:J="" S MCM=$$GET1^DID(MCFILE1,.01,"","SPECIFIER")
.F K=1:1 S L=$P(MCM,";",K) Q:L="" I $P(K,":",1)=J S MCM=$P(K,":",2) D SET Q
Q
;
WP ; word-processing field
S $P(MCHEAD,";",2)="W" ; indicate to OE/RR that this is WP
S MCMUP=^DD(MCM,0,"UP")
S MCMFLD=$O(^DD(MCMUP,"SB",MCM,""))
;S MCNODE=+$P(^DD(MCMUP,MCMFLD,0),"^",4)
S MCNODE=$P($$GET1^DID(MCMUP,MCMFLD,"","GLOBAL SUBSCRIPT LOCATION"),";")
F I=0:0 S I=$O(^MCAR(MCMUP,MCARGDA,MCNODE,I)) Q:I'?1N.N D
.S MCM=^MCAR(MCFILE,MCARGDA,MCNODE,I,0)
.I MCM'="" D SET
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCOREX 1910 printed Oct 16, 2024@18:16:27 Page 2
MCOREX ;WISC/TJK-OERR/MEDICINE DATA EXTRACT UTILITY ;2/17/98 14:48
+1 ;;2.3;Medicine;**17**;09/13/1996
SET SET MCK=MCK+1
SET ^TMP("MC",$JOB,MCC,MCK)=MCM_U_MCHEAD
QUIT
POINT if '$DATA(^MCAR(MCFILE,MCARGDA,MCNODE))
QUIT
+1 SET MCM=$PIECE($GET(^MCAR(MCFILE,MCARGDA,MCNODE)),U,MCPIECE)
+2 if 'MCM
QUIT
SET MCM=$PIECE($GET(^MCAR(MCFILE1,MCM,0)),U)
if MCM=""
QUIT
+3 DO SET
+4 QUIT
MPOINT if '$DATA(^MCAR(MCFILE,MCARGDA,MCNODE))
QUIT
+1 FOR I=0:0
SET I=$ORDER(^MCAR(MCFILE,MCARGDA,MCNODE,I))
if I'?1N.N
QUIT
Begin DoDot:1
+2 SET J=$PIECE(^MCAR(MCFILE,MCARGDA,MCNODE,I,0),U,MCPIECE)
+3 if 'J
QUIT
SET MCM=$PIECE($GET(^MCAR(MCFILE1,J,0)),U)
+4 if MCM=""
QUIT
DO SET
End DoDot:1
+5 QUIT
FREE if '$DATA(^MCAR(MCFILE,MCARGDA,MCNODE))
QUIT
+1 SET MCM=$PIECE(^MCAR(MCFILE,MCARGDA,MCNODE),U,MCPIECE)
DO SET
QUIT
MFREE if '$DATA(^MCAR(MCFILE,MCARGDA,MCNODE))
QUIT
+1 FOR I=0:0
SET I=$ORDER(^MCAR(MCFILE,MCARGDA,MCNODE,I))
if I'?1N.N
QUIT
Begin DoDot:1
+2 SET MCM=$PIECE(^MCAR(MCFILE,MCARGDA,MCNODE,I,0),U,MCPIECE)
+3 if MCM=""
QUIT
DO SET
End DoDot:1
+4 QUIT
SETS if '$DATA(^MCAR(MCFILE,MCARGDA,MCNODE))
QUIT
+1 SET J=$PIECE(^MCAR(MCFILE,MCARGDA,MCNODE),U,MCPIECE)
if J=""
QUIT
+2 ;S MCM=$P($G(^DD(MCFILE,MCFILE1,0)),U,3) Q:MCM=""
+3 SET MCM=$$GET1^DID(MCFILE,MCFILE1,"","SPECIFIER")
if MCM=""
QUIT
+4 FOR K=1:1
SET L=$PIECE(MCM,";",K)
if L=""
QUIT
IF $PIECE(L,":",1)=J
SET MCM=$PIECE(L,":",2)
DO SET
QUIT
+5 QUIT
MSET if '$DATA(^MCAR(MCFILE,MCARGDA,MCNODE))
QUIT
+1 FOR I=0:0
SET I=$ORDER(^MCAR(MCFILE,MCARGDA,MCNODE,I))
if I'?1N.N
QUIT
Begin DoDot:1
+2 SET J=$PIECE(^MCAR(MCFILE,MCARGDA,MCNODE,I,0),U,MCPIECE)
+3 ;Q:J="" S MCM=$P($G(^DD(MCFILE1,.01,0)),U,3)
+4 if J=""
QUIT
SET MCM=$$GET1^DID(MCFILE1,.01,"","SPECIFIER")
+5 FOR K=1:1
SET L=$PIECE(MCM,";",K)
if L=""
QUIT
IF $PIECE(K,":",1)=J
SET MCM=$PIECE(K,":",2)
DO SET
QUIT
End DoDot:1
+6 QUIT
+7 ;
WP ; word-processing field
+1 ; indicate to OE/RR that this is WP
SET $PIECE(MCHEAD,";",2)="W"
+2 SET MCMUP=^DD(MCM,0,"UP")
+3 SET MCMFLD=$ORDER(^DD(MCMUP,"SB",MCM,""))
+4 ;S MCNODE=+$P(^DD(MCMUP,MCMFLD,0),"^",4)
+5 SET MCNODE=$PIECE($$GET1^DID(MCMUP,MCMFLD,"","GLOBAL SUBSCRIPT LOCATION"),";")
+6 FOR I=0:0
SET I=$ORDER(^MCAR(MCMUP,MCARGDA,MCNODE,I))
if I'?1N.N
QUIT
Begin DoDot:1
+7 SET MCM=^MCAR(MCFILE,MCARGDA,MCNODE,I,0)
+8 IF MCM'=""
DO SET
End DoDot:1
+9 QUIT
