DIAXM1 ;SFISC/DCM-PROCESS MAPPING INFORMATION (CONT) ;7/11/95 06:33
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
EN D @DIAXFTY Q:DIAXFR Q:$D(DIAXMSG)
I DIAXFR("TYP")'=DIAXTO("TYP"),'$D(DIAXEXT) S DIAXEXT=1
D:'$D(DIAR) DJ
Q
;
F Q:DIAXFR!($D(DIAXMSG)) I DIAXFR("TY")["C" D CF^DIAXM2 Q
I "FSP"[DIAXFR("TYP"),+DIAXFR("LO"),DIAXFR("LO")<DIAXTO("LO") S DIAXE2=DIAXFR("LO") D E1,E3
I "FSP"[DIAXFR("TYP"),DIAXFR("HI")>DIAXTO("HI") S DIAXE2=DIAXFR("HI") D E2
I DIAXFR("TY")["N",DIAXFR("LE")<DIAXTO("LO") S DIAXE2=DIAXFR("LE") D E1,E3
I DIAXFR("TY")["N",DIAXFR("LE")>DIAXTO("HI") S DIAXE2=DIAXFR("LE") D E2
I DIAXFR("TY")["D",DIAXTO("LO")>14 S DIAXE2=14 D E1,E3
I DIAXFR("TY")["D",DIAXTO("HI")<14 S DIAXE2=14 D E2
Q
;
N G N^DIAXM3
;
D G D^DIAXM3
;
P D XT I DIAXEXT D P^DIAXM2 Q:$D(DIAXMSG)!DIAXFR
D HL^DIAXM(15,1)
Q
;
V D XT I DIAXEXT D V^DIAXM2 Q:$D(DIAXMSG)!DIAXFR
D HL^DIAXM(30,3)
Q
;
C G C^DIAXM2
;
S I DIAXTO W:'$D(DIAR) !?DIAXTAB,$C(7),"Make sure the SET OF CODES are identical as the extract field." Q
D XT D S^DIAXM2
Q
;
W Q:DIAXFR
I DIAXFR("TY")["L",DIAXTO("TY")'["L" D E3 S DIAXEM=DIAXEM_"be in 'L'ine mode." D X
Q
;
K Q
;
E1 S DIAXE1="minimum" Q
E2 S DIAXE1="maximum"
E3 S DIAXEM=DIAXTO("NM")_" field in "_DIAXEF_$S($D(DIAXSB):" subfile",1:" file")_" should " Q:DIAXFTY["W"
S DIAXEM=DIAXEM_"have a "_DIAXE1_" length of at least "_DIAXE2_" characters."
X D ERR^DIAXERR(DIAXEM)
K DIAXE1,DIAXE2
Q
;
DJ S DIAXDJ=DIAXDJ+1
S ^UTILITY("DIFG",$J,DIAXC,DIAXDJ)=DIAXS_U_U_+Y_U_$P(Y(0),U,4)_U_$G(DIAXEXT)
S S=DIAXS,DJ=DIAXDJ,C=DIAXC
Q
;
XT S DIAXEXT=+$G(DIAXEXT) I '$D(DIAR),$D(DC(DC)) S DIAXEXT=+$P(DC(DC),U,5) Q:'DINS
Q:$D(DIAR)
K DIR N Y S DIR(0)="Y",DIR("A")="Move EXTERNAL form of the data to the extract field",DIR("B")="Yes",DIR("?")="Answer YES if the RESOLVED value of data should be moved"
D ^DIR K DIR Q:'Y
S DIAXEXT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIAXM1 2189 printed Oct 16, 2024@18:45:39 Page 2
DIAXM1 ;SFISC/DCM-PROCESS MAPPING INFORMATION (CONT) ;7/11/95 06:33
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
EN DO @DIAXFTY
if DIAXFR
QUIT
if $DATA(DIAXMSG)
QUIT
+1 IF DIAXFR("TYP")'=DIAXTO("TYP")
IF '$DATA(DIAXEXT)
SET DIAXEXT=1
+2 if '$DATA(DIAR)
DO DJ
+3 QUIT
+4 ;
F if DIAXFR!($DATA(DIAXMSG))
QUIT
IF DIAXFR("TY")["C"
DO CF^DIAXM2
QUIT
+1 IF "FSP"[DIAXFR("TYP")
IF +DIAXFR("LO")
IF DIAXFR("LO")<DIAXTO("LO")
SET DIAXE2=DIAXFR("LO")
DO E1
DO E3
+2 IF "FSP"[DIAXFR("TYP")
IF DIAXFR("HI")>DIAXTO("HI")
SET DIAXE2=DIAXFR("HI")
DO E2
+3 IF DIAXFR("TY")["N"
IF DIAXFR("LE")<DIAXTO("LO")
SET DIAXE2=DIAXFR("LE")
DO E1
DO E3
+4 IF DIAXFR("TY")["N"
IF DIAXFR("LE")>DIAXTO("HI")
SET DIAXE2=DIAXFR("LE")
DO E2
+5 IF DIAXFR("TY")["D"
IF DIAXTO("LO")>14
SET DIAXE2=14
DO E1
DO E3
+6 IF DIAXFR("TY")["D"
IF DIAXTO("HI")<14
SET DIAXE2=14
DO E2
+7 QUIT
+8 ;
N GOTO N^DIAXM3
+1 ;
D GOTO D^DIAXM3
+1 ;
P DO XT
IF DIAXEXT
DO P^DIAXM2
if $DATA(DIAXMSG)!DIAXFR
QUIT
+1 DO HL^DIAXM(15,1)
+2 QUIT
+3 ;
V DO XT
IF DIAXEXT
DO V^DIAXM2
if $DATA(DIAXMSG)!DIAXFR
QUIT
+1 DO HL^DIAXM(30,3)
+2 QUIT
+3 ;
C GOTO C^DIAXM2
+1 ;
S IF DIAXTO
if '$DATA(DIAR)
WRITE !?DIAXTAB,$CHAR(7),"Make sure the SET OF CODES are identical as the extract field."
QUIT
+1 DO XT
DO S^DIAXM2
+2 QUIT
+3 ;
W if DIAXFR
QUIT
+1 IF DIAXFR("TY")["L"
IF DIAXTO("TY")'["L"
DO E3
SET DIAXEM=DIAXEM_"be in 'L'ine mode."
DO X
+2 QUIT
+3 ;
K QUIT
+1 ;
E1 SET DIAXE1="minimum"
QUIT
E2 SET DIAXE1="maximum"
E3 SET DIAXEM=DIAXTO("NM")_" field in "_DIAXEF_$SELECT($DATA(DIAXSB):" subfile",1:" file")_" should "
if DIAXFTY["W"
QUIT
+1 SET DIAXEM=DIAXEM_"have a "_DIAXE1_" length of at least "_DIAXE2_" characters."
X DO ERR^DIAXERR(DIAXEM)
+1 KILL DIAXE1,DIAXE2
+2 QUIT
+3 ;
DJ SET DIAXDJ=DIAXDJ+1
+1 SET ^UTILITY("DIFG",$JOB,DIAXC,DIAXDJ)=DIAXS_U_U_+Y_U_$PIECE(Y(0),U,4)_U_$GET(DIAXEXT)
+2 SET S=DIAXS
SET DJ=DIAXDJ
SET C=DIAXC
+3 QUIT
+4 ;
XT SET DIAXEXT=+$GET(DIAXEXT)
IF '$DATA(DIAR)
IF $DATA(DC(DC))
SET DIAXEXT=+$PIECE(DC(DC),U,5)
if 'DINS
QUIT
+1 if $DATA(DIAR)
QUIT
+2 KILL DIR
NEW Y
SET DIR(0)="Y"
SET DIR("A")="Move EXTERNAL form of the data to the extract field"
SET DIR("B")="Yes"
SET DIR("?")="Answer YES if the RESOLVED value of data should be moved"
+3 DO ^DIR
KILL DIR
if 'Y
QUIT
+4 SET DIAXEXT=1
+5 QUIT
