DG17201 ;BHM/RGY,ALS-Find and save all files pointing to religion and marital status files ;FEB 20,1998
;;5.3;Registration;**172**;Aug 13, 1993
CF ;
NEW FILE,FIELD,CONV
K ^TMP("DG11N13",$J)
F CONV=11,13 F FILE=0:0 S FILE=$O(^DD(CONV,0,"PT",FILE)) Q:FILE="" F FIELD=0:0 S FIELD=$O(^DD(CONV,0,"PT",FILE,FIELD)) Q:FIELD="" D ADD(FILE,FIELD,CONV)
D:$D(^TMP("DG11N13",$J)) CONVMSG
K ^TMP("DG11N13",$J)
Q
ADD(FILE,FIELD,TYPE) ;
NEW PIECE,NODE,GLOB,GLLOC
I FILE=""!(FIELD="") Q
I FILE=390.2 Q
D FIELD^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION","GLLOC")
S PIECE=$P($G(GLLOC("GLOBAL SUBSCRIPT LOCATION")),";",2)
I PIECE="" D CONVF(FILE,FIELD,"Unknown/Invalid pointer, DD("_CONV_",0,""PT"","_FILE_","_FIELD_").") Q
S NODE=$P($G(GLLOC("GLOBAL SUBSCRIPT LOCATION")),";")
I NODE="" D CONVF(FILE,FIELD,"Unknown/Invalid pointer, DD("_CONV_",0,""PT"","_FILE_","_FIELD_").") Q
S GLOB=$P($$GET1^DID(FILE,"","","GLOBAL NAME"),U,2) I GLOB="" D NOCONV(FILE,FIELD) Q
S EN=$$ADD^DG17202(390.1)
S DIE="^XTMP(""DGTMP"",390.1,",DR="[DG172 NEW ENTRY]",DA=EN D ^DIE
K DIE,DR,DA,EN,X
K ^TMP("DIERR",$J)
Q
NOCONV(FILE,FIELD) ;CONVERTING FILE 11 AND 13 NON-STANDARD ENTRIES
N SUBX,SUB,PIECE,GLLOC,SUBFILE
S SUB(0)=FILE_"^"_FIELD
I '$D(^DD(FILE,0,"UP")) D CONVF(FILE,FIELD,"Unknown/Invalid pointer, DD("_CONV_",0,""PT"","_FILE_","_FIELD_").") Q
I $D(^DD(FILE,0,"UP")) S SUB=1,SUBFILE=FILE F S:$D(^DD(SUBFILE,0,"UP")) SUB(SUB)=^DD(SUBFILE,0,"UP"),SUBFILE=SUB(SUB),SUB=SUB+1 Q:'$D(^DD(SUBFILE,0,"UP"))
S SUBX=$O(SUB(" "),-1) I SUBX>0 D CONVF(FILE,FIELD,"Cannot convert the "_$P(^DD(FILE,0),U)_" in the "_$$GET1^DID(SUB(SUBX),"","","NAME")_" File.",.SUB)
Q
CONVF(FILE,FIELD,TXT,SUB) ;
N X,LAST
S ^TMP("DG11N13",$J,CONV,$O(^TMP("DG11N13",$J,CONV," "),-1)+1)=FILE_"^"_FIELD_"^"_TXT_"^"
S LAST=$O(^TMP("DG11N13",$J,CONV," "),-1)
I '$D(SUB) S ^TMP("DG11N13",$J,CONV,LAST)=^TMP("DG11N13",$J,CONV,LAST)_FILE
I $D(SUB) S X=0,LAST=$O(^TMP("DG11N13",$J,CONV," "),-1) F X=$O(SUB(" "),-1):-1:0 S ^TMP("DG11N13",$J,CONV,LAST)=^TMP("DG11N13",$J,CONV,LAST)_$P(SUB(X),U)_"/"
Q
CONVMSG ;send file 11 and 13 conversion problem message
N HDR,DGX,SPACE,DGY,STRG,CONV
S SPACE=""
S DGY=1
S STRG=" File 11 and 13 Conversion Problem list" D STRING(STRG,.DGY)
S STRG=" " F X=1:1:2 D STRING(STRG,.DGY)
F CONV=11,13 D
.S STRG=$S(CONV=11:"MARITAL STATUS (#11) File Conversion Problems:",CONV=13:"RELIGION (#13) File Converion Problems:",1:"") D STRING(STRG,.DGY)
.S STRG=" " F X=1:1:2 D STRING(STRG,.DGY)
.I '$D(^TMP("DG11N13",$J,CONV)) S STRG="No problems" D STRING(STRG,.DGY) Q
.D CONVHDR
.S DGX=0 F S DGX=$O(^TMP("DG11N13",$J,CONV,DGX)) Q:'DGX D
..S STRG="",SPACE=""
..F X=1:1 S STRG=$S(X>1:SPACE,1:"")_$P($P(^TMP("DG11N13",$J,CONV,DGX),U,4),"/",X) Q:X=$L($P(^TMP("DG11N13",$J,CONV,DGX),U,4),"/") D
...I X<$L($P(^TMP("DG11N13",$J,CONV,DGX),U,4),"/") D STRING(STRG,.DGY)
...S SPACE=SPACE_" "
..S SPACE="",STRG=STRG_"^"_$P(^TMP("DG11N13",$J,CONV,DGX),U,2)_"^"_$P(^TMP("DG11N13",$J,CONV,DGX),U,3) D STRING(STRG,.DGY)
.S STRG=" " F X=1:1:2 D STRING(STRG,.DGY)
D MAILMSG
Q
CONVHDR ;
S STRG="Pointer File/Subfile^Field^Problem Description" D STRING(STRG,.DGY)
S STRG="-------------------------------------------------------------------" D STRING(STRG,.DGY)
Q
STRING(STR,DGY) ;convert string into column display
N RST ;result
N X
S RST=$P(STR,U)
I $P($G(STR),U,2)="" S DGY(DGY)=RST,DGY=DGY+1 Q
F X=$L(RST):1:25 S RST=RST_" "
;format field start column at 25
S RST=RST_$P(STR,U,2)
I $P($G(STR),U,3)="" S DGY(DGY)=RST,DGY=DGY+1 Q
F X=$L(RST):1:35 S RST=RST_" "
;format problem description start each line at 35
F Q:($L(RST)+$L($P(STR,U,3)))<78 D
.S RST=RST_$P(STR,U,3)
.S STR="",$P(STR,U,3)=$E(RST,79,120)
.S RST=$E(RST,1,78) S DGY(DGY)=RST,DGY=DGY+1
.S RST="" F X=1:1:35 S RST=RST_" "
.S RST=RST_$P(STR,U,3),$P(STR,U,3)=""
S DGY(DGY)=RST,DGY=DGY+1
Q
MAILMSG ;send problem message to user that started task
S XMDUZ="DG*5.3*172",XMTEXT="DGY(",XMY(DUZ)="",XMSUB="File 11 and 13 Conversion Problems"
N DIFROM D ^XMD K XMTEXT,XMY,XMSUB,XMDUZ,XMZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG17201 4155 printed Sep 23, 2025@20:11:04 Page 2
DG17201 ;BHM/RGY,ALS-Find and save all files pointing to religion and marital status files ;FEB 20,1998
+1 ;;5.3;Registration;**172**;Aug 13, 1993
CF ;
+1 NEW FILE,FIELD,CONV
+2 KILL ^TMP("DG11N13",$JOB)
+3 FOR CONV=11,13
FOR FILE=0:0
SET FILE=$ORDER(^DD(CONV,0,"PT",FILE))
if FILE=""
QUIT
FOR FIELD=0:0
SET FIELD=$ORDER(^DD(CONV,0,"PT",FILE,FIELD))
if FIELD=""
QUIT
DO ADD(FILE,FIELD,CONV)
+4 if $DATA(^TMP("DG11N13",$JOB))
DO CONVMSG
+5 KILL ^TMP("DG11N13",$JOB)
+6 QUIT
ADD(FILE,FIELD,TYPE) ;
+1 NEW PIECE,NODE,GLOB,GLLOC
+2 IF FILE=""!(FIELD="")
QUIT
+3 IF FILE=390.2
QUIT
+4 DO FIELD^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION","GLLOC")
+5 SET PIECE=$PIECE($GET(GLLOC("GLOBAL SUBSCRIPT LOCATION")),";",2)
+6 IF PIECE=""
DO CONVF(FILE,FIELD,"Unknown/Invalid pointer, DD("_CONV_",0,""PT"","_FILE_","_FIELD_").")
QUIT
+7 SET NODE=$PIECE($GET(GLLOC("GLOBAL SUBSCRIPT LOCATION")),";")
+8 IF NODE=""
DO CONVF(FILE,FIELD,"Unknown/Invalid pointer, DD("_CONV_",0,""PT"","_FILE_","_FIELD_").")
QUIT
+9 SET GLOB=$PIECE($$GET1^DID(FILE,"","","GLOBAL NAME"),U,2)
IF GLOB=""
DO NOCONV(FILE,FIELD)
QUIT
+10 SET EN=$$ADD^DG17202(390.1)
+11 SET DIE="^XTMP(""DGTMP"",390.1,"
SET DR="[DG172 NEW ENTRY]"
SET DA=EN
DO ^DIE
+12 KILL DIE,DR,DA,EN,X
+13 KILL ^TMP("DIERR",$JOB)
+14 QUIT
NOCONV(FILE,FIELD) ;CONVERTING FILE 11 AND 13 NON-STANDARD ENTRIES
+1 NEW SUBX,SUB,PIECE,GLLOC,SUBFILE
+2 SET SUB(0)=FILE_"^"_FIELD
+3 IF '$DATA(^DD(FILE,0,"UP"))
DO CONVF(FILE,FIELD,"Unknown/Invalid pointer, DD("_CONV_",0,""PT"","_FILE_","_FIELD_").")
QUIT
+4 IF $DATA(^DD(FILE,0,"UP"))
SET SUB=1
SET SUBFILE=FILE
FOR
if $DATA(^DD(SUBFILE,0,"UP"))
SET SUB(SUB)=^DD(SUBFILE,0,"UP")
SET SUBFILE=SUB(SUB)
SET SUB=SUB+1
if '$DATA(^DD(SUBFILE,0,"UP"))
QUIT
+5 SET SUBX=$ORDER(SUB(" "),-1)
IF SUBX>0
DO CONVF(FILE,FIELD,"Cannot convert the "_$PIECE(^DD(FILE,0),U)_" in the "_$$GET1^DID(SUB(SUBX),"","","NAME")_" File.",.SUB)
+6 QUIT
CONVF(FILE,FIELD,TXT,SUB) ;
+1 NEW X,LAST
+2 SET ^TMP("DG11N13",$JOB,CONV,$ORDER(^TMP("DG11N13",$JOB,CONV," "),-1)+1)=FILE_"^"_FIELD_"^"_TXT_"^"
+3 SET LAST=$ORDER(^TMP("DG11N13",$JOB,CONV," "),-1)
+4 IF '$DATA(SUB)
SET ^TMP("DG11N13",$JOB,CONV,LAST)=^TMP("DG11N13",$JOB,CONV,LAST)_FILE
+5 IF $DATA(SUB)
SET X=0
SET LAST=$ORDER(^TMP("DG11N13",$JOB,CONV," "),-1)
FOR X=$ORDER(SUB(" "),-1):-1:0
SET ^TMP("DG11N13",$JOB,CONV,LAST)=^TMP("DG11N13",$JOB,CONV,LAST)_$PIECE(SUB(X),U)_"/"
+6 QUIT
CONVMSG ;send file 11 and 13 conversion problem message
+1 NEW HDR,DGX,SPACE,DGY,STRG,CONV
+2 SET SPACE=""
+3 SET DGY=1
+4 SET STRG=" File 11 and 13 Conversion Problem list"
DO STRING(STRG,.DGY)
+5 SET STRG=" "
FOR X=1:1:2
DO STRING(STRG,.DGY)
+6 FOR CONV=11,13
Begin DoDot:1
+7 SET STRG=$SELECT(CONV=11:"MARITAL STATUS (#11) File Conversion Problems:",CONV=13:"RELIGION (#13) File Converion Problems:",1:"")
DO STRING(STRG,.DGY)
+8 SET STRG=" "
FOR X=1:1:2
DO STRING(STRG,.DGY)
+9 IF '$DATA(^TMP("DG11N13",$JOB,CONV))
SET STRG="No problems"
DO STRING(STRG,.DGY)
QUIT
+10 DO CONVHDR
+11 SET DGX=0
FOR
SET DGX=$ORDER(^TMP("DG11N13",$JOB,CONV,DGX))
if 'DGX
QUIT
Begin DoDot:2
+12 SET STRG=""
SET SPACE=""
+13 FOR X=1:1
SET STRG=$SELECT(X>1:SPACE,1:"")_$PIECE($PIECE(^TMP("DG11N13",$JOB,CONV,DGX),U,4),"/",X)
if X=$LENGTH($PIECE(^TMP("DG11N13",$JOB,CONV,DGX),U,4),"/")
QUIT
Begin DoDot:3
+14 IF X<$LENGTH($PIECE(^TMP("DG11N13",$JOB,CONV,DGX),U,4),"/")
DO STRING(STRG,.DGY)
+15 SET SPACE=SPACE_" "
End DoDot:3
+16 SET SPACE=""
SET STRG=STRG_"^"_$PIECE(^TMP("DG11N13",$JOB,CONV,DGX),U,2)_"^"_$PIECE(^TMP("DG11N13",$JOB,CONV,DGX),U,3)
DO STRING(STRG,.DGY)
End DoDot:2
+17 SET STRG=" "
FOR X=1:1:2
DO STRING(STRG,.DGY)
End DoDot:1
+18 DO MAILMSG
+19 QUIT
CONVHDR ;
+1 SET STRG="Pointer File/Subfile^Field^Problem Description"
DO STRING(STRG,.DGY)
+2 SET STRG="-------------------------------------------------------------------"
DO STRING(STRG,.DGY)
+3 QUIT
STRING(STR,DGY) ;convert string into column display
+1 ;result
NEW RST
+2 NEW X
+3 SET RST=$PIECE(STR,U)
+4 IF $PIECE($GET(STR),U,2)=""
SET DGY(DGY)=RST
SET DGY=DGY+1
QUIT
+5 FOR X=$LENGTH(RST):1:25
SET RST=RST_" "
+6 ;format field start column at 25
+7 SET RST=RST_$PIECE(STR,U,2)
+8 IF $PIECE($GET(STR),U,3)=""
SET DGY(DGY)=RST
SET DGY=DGY+1
QUIT
+9 FOR X=$LENGTH(RST):1:35
SET RST=RST_" "
+10 ;format problem description start each line at 35
+11 FOR
if ($LENGTH(RST)+$LENGTH($PIECE(STR,U,3)))<78
QUIT
Begin DoDot:1
+12 SET RST=RST_$PIECE(STR,U,3)
+13 SET STR=""
SET $PIECE(STR,U,3)=$EXTRACT(RST,79,120)
+14 SET RST=$EXTRACT(RST,1,78)
SET DGY(DGY)=RST
SET DGY=DGY+1
+15 SET RST=""
FOR X=1:1:35
SET RST=RST_" "
+16 SET RST=RST_$PIECE(STR,U,3)
SET $PIECE(STR,U,3)=""
End DoDot:1
+17 SET DGY(DGY)=RST
SET DGY=DGY+1
+18 QUIT
MAILMSG ;send problem message to user that started task
+1 SET XMDUZ="DG*5.3*172"
SET XMTEXT="DGY("
SET XMY(DUZ)=""
SET XMSUB="File 11 and 13 Conversion Problems"
+2 NEW DIFROM
DO ^XMD
KILL XMTEXT,XMY,XMSUB,XMDUZ,XMZ
+3 QUIT
