ENXLFIX ;WISC/SAB-FIX POINTERS TO ENG SPACE FILE ;1-24-94
;;7.0;ENGINEERING;**1**;Aug 17, 1993
EN S DIR(0)="S^EQ:EQUIPMENT FILE;WO:WORK ORDER FILE;"
S DIR("A")=$S(ENCVTM:"Convert",1:"Report of")_" location fields in which file"
S DIR("?")="Enter EQ or WO to select the desired file."
S DIR("?",1)="You must choose which file to process. The LOCATION"
S DIR("?",2)="field of the selected file will be checked and"
I ENCVTM D
.S DIR("?",3)="any free-text values which match an entry in the space"
.S DIR("?",4)="file will be converted to pointers. Any unconverted"
.S DIR("?",5)="free-text values will be identified by a leading '*'"
E D
.S DIR("?",3)="the number and type of free-text entries in this"
.S DIR("?",4)="pointer field will be reported."
S DIR("?",9)=" "
D ^DIR K DIR I $D(DIRUT) G EXIT
S ENFL=Y
S ENDETAIL=1
I ENCVTM D D ^DIR K DIR S ENDETAIL=Y I $D(DIRUT) G EXIT
.S DIR(0)="Y",DIR("A")="Should locations be listed on output? Y/N"
.S DIR("?")="Enter Y or N"
.S DIR("?",1)="If you answer yes a line will be printed for each"
.S DIR("?",2)="unique free-text location. The line will contain"
.S DIR("?",3)="the location, the number of entries with that location,"
.S DIR("?",4)="and if the location was converted to a pointer."
S %ZIS="QM" D ^%ZIS G EXIT:POP
I $D(IO("Q")) D G EXIT
.S ZTRTN="DQ^ENXLFIX"
.S ZTSAVE("ENCVTM")="",ZTSAVE("ENFL")="",ZTSAVE("ENDETAIL")=""
.S ZTDESC=$S(ENCVTM:"Convert",1:"Report of")_" Locations in "_$S(ENFL="EQ":"EQUIP",1:"W.O.")_" file"
.D ^%ZTLOAD D HOME^%ZIS K IO("Q")
DQ ; queued entry
S Y=DT D DD^%DT S ENDATE=Y
S (END,ENPG,ENT("LOC"),ENT("REC"),ENT("LOC_CVT"),ENT("REC_CVT"))=0
S ENFLNM=$S(ENFL="EQ":"Equipment File",1:"Work Order File")
S ENXRF=$S(ENFL="EQ":"^ENG(6914,""D"",",1:"^ENG(6920,""C"",")
S ENODE=$S(ENFL="EQ":"^ENG(6914,ENDA,3)",1:"^ENG(6920,ENDA,0)")
S ENPIECE=$S(ENFL="EQ":5,1:4)
U IO D HDR
I 'ENDETAIL W !," Locations not listed by user request",!
; loop thru free-text locations
S ENLOC=" " F S ENLOC=$O(@(ENXRF_"ENLOC)")) Q:ENLOC=""!END D LOCAT
I 'END D
.I ENCVTM,$Y+6+$S(ENT("REC"):6,1:2)+$S(ENT("REC_CVT"):3,1:0)>IOSL D HDR
.I 'ENCVTM,$Y+6+$S(ENT("REC"):7,1:2)+$S(ENT("REC_CVT"):6,1:0)>IOSL D HDR
I END W !,"HALTED BY USER REQUEST",!
E D RFTR^ENXLFIX0
D ^%ZISC
EXIT I $D(ZTQUEUED),'$D(ZTSTOP) S ZTREQ="Q"
K %ZIS,DA,DIE,DIRUT,DR
K ENCVTM,ENCVTS,END,ENDA,ENDATE,ENDETAIL,ENFL,ENFLNM,ENLOC,ENODE
K ENPG,ENPIECE,ENSPDA,ENSPLOC,ENT,ENXRF,POP,X,Y
Q
LOCAT ; process location
I ENCVTM,$E(ENLOC,1)=" " D SPACES^ENXLFIX0 Q ; handle leading spaces
S ENCVTS=0,ENT("LOC")=ENT("LOC")+1
; strip * for match
S ENSPLOC=$E(ENLOC,$S($E(ENLOC,1)="*":2,1:1),$L(ENLOC))
I ENSPLOC']"" S ENSPLOC=ENLOC
; match space .01?
S ENSPDA=$O(^ENG("SP","B",ENSPLOC,""))
; if not match and has lowercase, uppercase match .01?
I 'ENSPDA,ENSPLOC?.E1L.E D
.S X=ENSPLOC X ^%ZOSF("UPPERCASE")
.S ENSPDA=$O(^ENG("SP","B",Y,""))
; if we found a match to .01 (either method)
I ENSPDA S ENCVTS=1,ENT("LOC_CVT")=ENT("LOC_CVT")+1
; if not match, match space synonym?
I 'ENSPDA S ENSPDA=$O(^ENG("SP","F",ENSPLOC,"")) D:ENSPDA
.I $O(^ENG("SP","F",ENSPLOC,ENSPDA)) S ENCVTS="M"
.E S ENCVTS=2,ENT("LOC_CVT")=ENT("LOC_CVT")+1
; if still no match and free-text location has *, match synonym?
I 'ENSPDA,ENSPLOC'=ENLOC S ENSPDA=$O(^ENG("SP","F",ENLOC,"")) D:ENSPDA
.I $O(^ENG("SP","F",ENLOC,ENSPDA)) S ENCVTS="M"
.E S ENCVTS=2,ENT("LOC_CVT")=ENT("LOC_CVT")+1
; loop thru records within location
S ENT("REC_IN_LOC")=0,ENDA=""
F S ENDA=$O(@(ENXRF_"ENLOC,ENDA)")) Q:'ENDA D
.I '$D(@ENODE) K @(ENXRF_"ENLOC,ENDA)") Q ; invalid x-ref node
.S ENT("REC_IN_LOC")=ENT("REC_IN_LOC")+1
.I ENCVTM,ENCVTS D ; convert to pointer
..I ENFL="EQ",ENLOC["E" K ^ENG(6914,"D",ENLOC,ENDA) S $P(^ENG(6914,ENDA,3),U,5)=""
..S DIE=$S(ENFL="EQ":"^ENG(6914,",1:"^ENG(6920,"),DA=ENDA
..S DR=$S(ENFL="EQ":"24",1:"3")_"////"_ENSPDA D ^DIE
.I ENCVTM,'ENCVTS,$E(ENLOC,1)'="*" D ; add leading *
..S $P(@ENODE,U,ENPIECE)="*"_$P(@ENODE,U,ENPIECE)
..K @(ENXRF_"ENLOC,ENDA)") ; old x-ref
..S @(ENXRF_"""*"_ENLOC_""","_ENDA_")")="" ; new x-ref
S ENT("REC")=ENT("REC")+ENT("REC_IN_LOC")
I ENCVTS S ENT("REC_CVT")=ENT("REC_CVT")+ENT("REC_IN_LOC")
W:ENDETAIL ?5,ENLOC,?30,ENT("REC_IN_LOC"),?40,$S($E(ENLOC,1)=" ":"?? (leading spaces)",ENCVTS=1:"YES, by room number",ENCVTS=2:"YES, by synonym",ENCVTS="M":"NO, multiple synonyms",1:"NO"),!
I $Y+4>IOSL D HDR
Q
HDR ; page header
I $$S^%ZTLOAD S (END,ZTSTOP)=1 Q
I ENPG,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S END='Y Q:END
W:'($E(IOST,1,2)'="C-"&'ENPG) @IOF
S ENPG=ENPG+1
W ?5,"Free-Text Values in ",ENFLNM," LOCATION Fields"
W ?60,ENDATE,?73,"page ",ENPG,!!
W ?5,"Free-Text Location",?30,"Count"
W ?40,"Convert"_$S(ENCVTM:"ed?",1:"ible?"),!
W ?5,"------------------",?30,"-----",?40,"------------",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENXLFIX 4942 printed Dec 13, 2024@01:56:57 Page 2
ENXLFIX ;WISC/SAB-FIX POINTERS TO ENG SPACE FILE ;1-24-94
+1 ;;7.0;ENGINEERING;**1**;Aug 17, 1993
EN SET DIR(0)="S^EQ:EQUIPMENT FILE;WO:WORK ORDER FILE;"
+1 SET DIR("A")=$SELECT(ENCVTM:"Convert",1:"Report of")_" location fields in which file"
+2 SET DIR("?")="Enter EQ or WO to select the desired file."
+3 SET DIR("?",1)="You must choose which file to process. The LOCATION"
+4 SET DIR("?",2)="field of the selected file will be checked and"
+5 IF ENCVTM
Begin DoDot:1
+6 SET DIR("?",3)="any free-text values which match an entry in the space"
+7 SET DIR("?",4)="file will be converted to pointers. Any unconverted"
+8 SET DIR("?",5)="free-text values will be identified by a leading '*'"
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET DIR("?",3)="the number and type of free-text entries in this"
+11 SET DIR("?",4)="pointer field will be reported."
End DoDot:1
+12 SET DIR("?",9)=" "
+13 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO EXIT
+14 SET ENFL=Y
+15 SET ENDETAIL=1
+16 IF ENCVTM
Begin DoDot:1
+17 SET DIR(0)="Y"
SET DIR("A")="Should locations be listed on output? Y/N"
+18 SET DIR("?")="Enter Y or N"
+19 SET DIR("?",1)="If you answer yes a line will be printed for each"
+20 SET DIR("?",2)="unique free-text location. The line will contain"
+21 SET DIR("?",3)="the location, the number of entries with that location,"
+22 SET DIR("?",4)="and if the location was converted to a pointer."
End DoDot:1
DO ^DIR
KILL DIR
SET ENDETAIL=Y
IF $DATA(DIRUT)
GOTO EXIT
+23 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
+24 IF $DATA(IO("Q"))
Begin DoDot:1
+25 SET ZTRTN="DQ^ENXLFIX"
+26 SET ZTSAVE("ENCVTM")=""
SET ZTSAVE("ENFL")=""
SET ZTSAVE("ENDETAIL")=""
+27 SET ZTDESC=$SELECT(ENCVTM:"Convert",1:"Report of")_" Locations in "_$SELECT(ENFL="EQ":"EQUIP",1:"W.O.")_" file"
+28 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
End DoDot:1
GOTO EXIT
DQ ; queued entry
+1 SET Y=DT
DO DD^%DT
SET ENDATE=Y
+2 SET (END,ENPG,ENT("LOC"),ENT("REC"),ENT("LOC_CVT"),ENT("REC_CVT"))=0
+3 SET ENFLNM=$SELECT(ENFL="EQ":"Equipment File",1:"Work Order File")
+4 SET ENXRF=$SELECT(ENFL="EQ":"^ENG(6914,""D"",",1:"^ENG(6920,""C"",")
+5 SET ENODE=$SELECT(ENFL="EQ":"^ENG(6914,ENDA,3)",1:"^ENG(6920,ENDA,0)")
+6 SET ENPIECE=$SELECT(ENFL="EQ":5,1:4)
+7 USE IO
DO HDR
+8 IF 'ENDETAIL
WRITE !," Locations not listed by user request",!
+9 ; loop thru free-text locations
+10 SET ENLOC=" "
FOR
SET ENLOC=$ORDER(@(ENXRF_"ENLOC)"))
if ENLOC=""!END
QUIT
DO LOCAT
+11 IF 'END
Begin DoDot:1
+12 IF ENCVTM
IF $Y+6+$SELECT(ENT("REC"):6,1:2)+$SELECT(ENT("REC_CVT"):3,1:0)>IOSL
DO HDR
+13 IF 'ENCVTM
IF $Y+6+$SELECT(ENT("REC"):7,1:2)+$SELECT(ENT("REC_CVT"):6,1:0)>IOSL
DO HDR
End DoDot:1
+14 IF END
WRITE !,"HALTED BY USER REQUEST",!
+15 IF '$TEST
DO RFTR^ENXLFIX0
+16 DO ^%ZISC
EXIT IF $DATA(ZTQUEUED)
IF '$DATA(ZTSTOP)
SET ZTREQ="Q"
+1 KILL %ZIS,DA,DIE,DIRUT,DR
+2 KILL ENCVTM,ENCVTS,END,ENDA,ENDATE,ENDETAIL,ENFL,ENFLNM,ENLOC,ENODE
+3 KILL ENPG,ENPIECE,ENSPDA,ENSPLOC,ENT,ENXRF,POP,X,Y
+4 QUIT
LOCAT ; process location
+1 ; handle leading spaces
IF ENCVTM
IF $EXTRACT(ENLOC,1)=" "
DO SPACES^ENXLFIX0
QUIT
+2 SET ENCVTS=0
SET ENT("LOC")=ENT("LOC")+1
+3 ; strip * for match
+4 SET ENSPLOC=$EXTRACT(ENLOC,$SELECT($EXTRACT(ENLOC,1)="*":2,1:1),$LENGTH(ENLOC))
+5 IF ENSPLOC']""
SET ENSPLOC=ENLOC
+6 ; match space .01?
+7 SET ENSPDA=$ORDER(^ENG("SP","B",ENSPLOC,""))
+8 ; if not match and has lowercase, uppercase match .01?
+9 IF 'ENSPDA
IF ENSPLOC?.E1L.E
Begin DoDot:1
+10 SET X=ENSPLOC
XECUTE ^%ZOSF("UPPERCASE")
+11 SET ENSPDA=$ORDER(^ENG("SP","B",Y,""))
End DoDot:1
+12 ; if we found a match to .01 (either method)
+13 IF ENSPDA
SET ENCVTS=1
SET ENT("LOC_CVT")=ENT("LOC_CVT")+1
+14 ; if not match, match space synonym?
+15 IF 'ENSPDA
SET ENSPDA=$ORDER(^ENG("SP","F",ENSPLOC,""))
if ENSPDA
Begin DoDot:1
+16 IF $ORDER(^ENG("SP","F",ENSPLOC,ENSPDA))
SET ENCVTS="M"
+17 IF '$TEST
SET ENCVTS=2
SET ENT("LOC_CVT")=ENT("LOC_CVT")+1
End DoDot:1
+18 ; if still no match and free-text location has *, match synonym?
+19 IF 'ENSPDA
IF ENSPLOC'=ENLOC
SET ENSPDA=$ORDER(^ENG("SP","F",ENLOC,""))
if ENSPDA
Begin DoDot:1
+20 IF $ORDER(^ENG("SP","F",ENLOC,ENSPDA))
SET ENCVTS="M"
+21 IF '$TEST
SET ENCVTS=2
SET ENT("LOC_CVT")=ENT("LOC_CVT")+1
End DoDot:1
+22 ; loop thru records within location
+23 SET ENT("REC_IN_LOC")=0
SET ENDA=""
+24 FOR
SET ENDA=$ORDER(@(ENXRF_"ENLOC,ENDA)"))
if 'ENDA
QUIT
Begin DoDot:1
+25 ; invalid x-ref node
IF '$DATA(@ENODE)
KILL @(ENXRF_"ENLOC,ENDA)")
QUIT
+26 SET ENT("REC_IN_LOC")=ENT("REC_IN_LOC")+1
+27 ; convert to pointer
IF ENCVTM
IF ENCVTS
Begin DoDot:2
+28 IF ENFL="EQ"
IF ENLOC["E"
KILL ^ENG(6914,"D",ENLOC,ENDA)
SET $PIECE(^ENG(6914,ENDA,3),U,5)=""
+29 SET DIE=$SELECT(ENFL="EQ":"^ENG(6914,",1:"^ENG(6920,")
SET DA=ENDA
+30 SET DR=$SELECT(ENFL="EQ":"24",1:"3")_"////"_ENSPDA
DO ^DIE
End DoDot:2
+31 ; add leading *
IF ENCVTM
IF 'ENCVTS
IF $EXTRACT(ENLOC,1)'="*"
Begin DoDot:2
+32 SET $PIECE(@ENODE,U,ENPIECE)="*"_$PIECE(@ENODE,U,ENPIECE)
+33 ; old x-ref
KILL @(ENXRF_"ENLOC,ENDA)")
+34 ; new x-ref
SET @(ENXRF_"""*"_ENLOC_""","_ENDA_")")=""
End DoDot:2
End DoDot:1
+35 SET ENT("REC")=ENT("REC")+ENT("REC_IN_LOC")
+36 IF ENCVTS
SET ENT("REC_CVT")=ENT("REC_CVT")+ENT("REC_IN_LOC")
+37 if ENDETAIL
WRITE ?5,ENLOC,?30,ENT("REC_IN_LOC"),?40,$SELECT($EXTRACT(ENLOC,1)=" ":"?? (leading spaces)",ENCVTS=1:"YES, by room number",ENCVTS=2:"YES, by synonym",ENCVTS="M":"NO, multiple synonyms",1:"NO"),!
+38 IF $Y+4>IOSL
DO HDR
+39 QUIT
HDR ; page header
+1 IF $$S^%ZTLOAD
SET (END,ZTSTOP)=1
QUIT
+2 IF ENPG
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET END='Y
if END
QUIT
+3 if '($EXTRACT(IOST,1,2)'="C-"&'ENPG)
WRITE @IOF
+4 SET ENPG=ENPG+1
+5 WRITE ?5,"Free-Text Values in ",ENFLNM," LOCATION Fields"
+6 WRITE ?60,ENDATE,?73,"page ",ENPG,!!
+7 WRITE ?5,"Free-Text Location",?30,"Count"
+8 WRITE ?40,"Convert"_$SELECT(ENCVTM:"ed?",1:"ible?"),!
+9 WRITE ?5,"------------------",?30,"-----",?40,"------------",!!
+10 QUIT
