TIUPUTD ; SLC/JER - Document filer - delimited header ;5/18/94 10:21
;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
MAIN ; Controls branching
N TIUDA,TIUBGN,TIUI,TIUHSIG,TIULIM,TIULCNT,TIULINE,TIUREC
I '$D(TIUPRM0)!'$D(TIUPRM1) D SETPARM^TIULE
S TIUHSIG=$P(TIUPRM0,U,10),TIUBGN=$P(TIUPRM0,U,12)
I TIUHSIG']"" D MAIN^TIUPEVNT(DA,1) Q
S TIULIM=$P(TIUPRM0,U,13)
I TIULIM']"" D MAIN^TIUPEVNT(DA,2) Q
S TIUI=0 F S TIUI=$O(^TIU(8925.2,+DA,"TEXT",TIUI)) Q:+TIUI'>0 D
. N TIUFRST
. S TIULINE=$G(^TIU(8925.2,+DA,"TEXT",TIUI,0))
. I TIULINE[TIUHSIG D
. . S TIUFRST=TIUI
. . I +$G(TIULCNT),$D(TIUREC("TROOT")),$D(@(TIUREC("TROOT")_"0)")) D
. . . D SETROOT(TIULCNT,.TIUREC)
. . . D:$G(TIUREC("FILE"))=8925 RELEASE^TIUT(TIUREC("#"),1),UPDTIRT^TIUDIRT(.TIU,TIUREC("#"))
. . K TIUREC,TIU D GETREC(TIULINE,.TIUREC)
. . I +$G(TIUREC("#"))'>0!($G(TIUREC("ROOT"))']"") Q
. . D STUFREC(TIULINE,.TIUREC)
. . S TIUREC("TROOT")=TIUREC("ROOT")_TIUREC("#")_","_TIUREC("TEXT")_","
. . S:'$D(@(TIUREC("TROOT")_"0)")) @(TIUREC("TROOT")_"0)")="^^^^^"
. . S TIULCNT=+$P(@(TIUREC("TROOT")_"0)"),U,4)
. . K ^TIU(8925.2,+DA,"TEXT",TIUI,0) ; Delete header line once filed
. I TIULINE'[TIUHSIG,(TIULINE'[TIUBGN),$D(TIUREC("TROOT")),$D(@(TIUREC("TROOT")_"0)")) D
. . S TIULCNT=+$G(TIULCNT)+1,@(TIUREC("TROOT")_TIULCNT_",0)")=TIULINE
. . K ^TIU(8925.2,+DA,"TEXT",TIUI,0) ; Delete buffer line once xferred
. I TIULINE'[TIUHSIG,(TIULINE'[TIUBGN),'$D(TIUREC("TROOT")),($G(TIUREC("#"))'=-1) K ^TIU(8925.2,+DA,"TEXT",TIUI,0) ; Remove leading garbage
. I TIULINE[TIUBGN K ^TIU(8925.2,+DA,"TEXT",TIUI,0)
I +$G(TIULCNT),$D(TIUREC("TROOT")),$D(@(TIUREC("TROOT")_"0)")) D
. D SETROOT(TIULCNT,.TIUREC)
. D:$G(TIUREC("FILE"))=8925 RELEASE^TIUT(TIUREC("#"),1),UPDTIRT^TIUDIRT(.TIU,TIUREC("#"))
I '+$O(^TIU(8925.2,+DA,"TEXT",0)) D BUFPURGE(DA)
Q
GETREC(HEADER,RECORD) ; Look-up or create record (if LAYGO allowed)
N DIC,DLAYGO,TIUKEY,X,Y,TIUFPRIV S TIUFPRIV=1
S X=$P(HEADER,TIULIM,2),DIC=8925.1,DIC(0)="MZ" D ^DIC
I +Y'>0 D MAIN^TIUPEVNT(DA,3) Q
S RECORD("TYPE")=+Y,RECORD("FILE")=$P(Y(0),U,5)
I RECORD("FILE")']"" D MAIN^TIUPEVNT(DA,4) Q
S RECORD("ROOT")=$G(^DIC(+RECORD("FILE"),0,"GL"))
I $P(Y(0),U,6)']"" D MAIN^TIUPEVNT(DA,5) Q
I $P(Y(0),U,6)]"" D
. S RECORD("TEXT")=$P($P(Y(0),U,6),";",2) ; Subscript of TEXT field
. I RECORD("TEXT")]"",'+RECORD("TEXT") S RECORD("TEXT")=""""_RECORD("TEXT")_""""
S:+$P(Y(0),U,3) DLAYGO=RECORD("FILE")
; If a LOOKUP ROUTINE is defined for a given report type, then call it
I $P(Y(0),U,8)]"" D Q
. N TIUI,TIUVAR,TIUVPC S TIUVAR=""
. F S TIUVAR=$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","E",TIUVAR)) Q:TIUVAR="" D
. . S TIUI=+$G(TIUI)+1,TIUVAR(TIUI)=TIUVAR
. . S TIUVPC=$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","E",TIUVAR,0))
. . S @TIUVAR=$P(HEADER,TIULIM,TIUVPC)
. D @$P(Y(0),U,7,8) S RECORD("#")=Y I +Y'>0 D MAIN^TIUPEVNT(DA,6)
. S TIUI=0 F S TIUI=$O(TIUVAR(TIUI)) Q:+TIUI'>0 K @TIUVAR(TIUI)
; Otherwise set-up for ^DIC call
S DIC=RECORD("FILE"),DIC(0)="MX"
S:+$P(Y(0),U,3) DIC(0)=DIC(0)_"L"
S TIUKEY=+$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",.001,0))
S:TIUKEY DIC(0)=DIC(0)_"N"
S:'TIUKEY TIUKEY=+$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",.01,0))
S X=$S(DIC(0)["N":"`",1:"")_$P(HEADER,TIULIM,TIUKEY) D ^DIC
S RECORD("#")=+Y I +Y'>0 D MAIN^TIUPEVNT(DA,6)
Q
STUFREC(HEADER,RECORD) ; Stuffs record with known fixed fields
N D0,DA,DR,DIE,TIUI,TIUPC
S DIE=+RECORD("FILE"),DA=+RECORD("#")
; Set up DR-string
S TIUI=0
F S TIUI=$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",TIUI)) Q:+TIUI'>0 D
. S TIUPC=$O(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",TIUI,0)) Q:+TIUPC'>0
. S:TIUI'=.001 DR=$G(DR)_$S($L($G(DR)):";",1:"")_TIUI_"///"_$P(HEADER,TIULIM,TIUPC)
D ^DIE
Q
SETROOT(LINECNT,RECORD) ; Sets root of WP field
S @(RECORD("TROOT")_"0)")="^^"_LINECNT_"^"_LINECNT_"^"_DT_"^^"
Q
BUFPURGE(DA) ; Call ^DIK to purge buffer record when all's well
N DIK S DIK="^TIU(8925.2," D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPUTD 4006 printed Dec 13, 2024@02:44:38 Page 2
TIUPUTD ; SLC/JER - Document filer - delimited header ;5/18/94 10:21
+1 ;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
MAIN ; Controls branching
+1 NEW TIUDA,TIUBGN,TIUI,TIUHSIG,TIULIM,TIULCNT,TIULINE,TIUREC
+2 IF '$DATA(TIUPRM0)!'$DATA(TIUPRM1)
DO SETPARM^TIULE
+3 SET TIUHSIG=$PIECE(TIUPRM0,U,10)
SET TIUBGN=$PIECE(TIUPRM0,U,12)
+4 IF TIUHSIG']""
DO MAIN^TIUPEVNT(DA,1)
QUIT
+5 SET TIULIM=$PIECE(TIUPRM0,U,13)
+6 IF TIULIM']""
DO MAIN^TIUPEVNT(DA,2)
QUIT
+7 SET TIUI=0
FOR
SET TIUI=$ORDER(^TIU(8925.2,+DA,"TEXT",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+8 NEW TIUFRST
+9 SET TIULINE=$GET(^TIU(8925.2,+DA,"TEXT",TIUI,0))
+10 IF TIULINE[TIUHSIG
Begin DoDot:2
+11 SET TIUFRST=TIUI
+12 IF +$GET(TIULCNT)
IF $DATA(TIUREC("TROOT"))
IF $DATA(@(TIUREC("TROOT")_"0)"))
Begin DoDot:3
+13 DO SETROOT(TIULCNT,.TIUREC)
+14 if $GET(TIUREC("FILE"))=8925
DO RELEASE^TIUT(TIUREC("#"),1)
DO UPDTIRT^TIUDIRT(.TIU,TIUREC("#"))
End DoDot:3
+15 KILL TIUREC,TIU
DO GETREC(TIULINE,.TIUREC)
+16 IF +$GET(TIUREC("#"))'>0!($GET(TIUREC("ROOT"))']"")
QUIT
+17 DO STUFREC(TIULINE,.TIUREC)
+18 SET TIUREC("TROOT")=TIUREC("ROOT")_TIUREC("#")_","_TIUREC("TEXT")_","
+19 if '$DATA(@(TIUREC("TROOT")_"0)"))
SET @(TIUREC("TROOT")_"0)")="^^^^^"
+20 SET TIULCNT=+$PIECE(@(TIUREC("TROOT")_"0)"),U,4)
+21 ; Delete header line once filed
KILL ^TIU(8925.2,+DA,"TEXT",TIUI,0)
End DoDot:2
+22 IF TIULINE'[TIUHSIG
IF (TIULINE'[TIUBGN)
IF $DATA(TIUREC("TROOT"))
IF $DATA(@(TIUREC("TROOT")_"0)"))
Begin DoDot:2
+23 SET TIULCNT=+$GET(TIULCNT)+1
SET @(TIUREC("TROOT")_TIULCNT_",0)")=TIULINE
+24 ; Delete buffer line once xferred
KILL ^TIU(8925.2,+DA,"TEXT",TIUI,0)
End DoDot:2
+25 ; Remove leading garbage
IF TIULINE'[TIUHSIG
IF (TIULINE'[TIUBGN)
IF '$DATA(TIUREC("TROOT"))
IF ($GET(TIUREC("#"))'=-1)
KILL ^TIU(8925.2,+DA,"TEXT",TIUI,0)
+26 IF TIULINE[TIUBGN
KILL ^TIU(8925.2,+DA,"TEXT",TIUI,0)
End DoDot:1
+27 IF +$GET(TIULCNT)
IF $DATA(TIUREC("TROOT"))
IF $DATA(@(TIUREC("TROOT")_"0)"))
Begin DoDot:1
+28 DO SETROOT(TIULCNT,.TIUREC)
+29 if $GET(TIUREC("FILE"))=8925
DO RELEASE^TIUT(TIUREC("#"),1)
DO UPDTIRT^TIUDIRT(.TIU,TIUREC("#"))
End DoDot:1
+30 IF '+$ORDER(^TIU(8925.2,+DA,"TEXT",0))
DO BUFPURGE(DA)
+31 QUIT
GETREC(HEADER,RECORD) ; Look-up or create record (if LAYGO allowed)
+1 NEW DIC,DLAYGO,TIUKEY,X,Y,TIUFPRIV
SET TIUFPRIV=1
+2 SET X=$PIECE(HEADER,TIULIM,2)
SET DIC=8925.1
SET DIC(0)="MZ"
DO ^DIC
+3 IF +Y'>0
DO MAIN^TIUPEVNT(DA,3)
QUIT
+4 SET RECORD("TYPE")=+Y
SET RECORD("FILE")=$PIECE(Y(0),U,5)
+5 IF RECORD("FILE")']""
DO MAIN^TIUPEVNT(DA,4)
QUIT
+6 SET RECORD("ROOT")=$GET(^DIC(+RECORD("FILE"),0,"GL"))
+7 IF $PIECE(Y(0),U,6)']""
DO MAIN^TIUPEVNT(DA,5)
QUIT
+8 IF $PIECE(Y(0),U,6)]""
Begin DoDot:1
+9 ; Subscript of TEXT field
SET RECORD("TEXT")=$PIECE($PIECE(Y(0),U,6),";",2)
+10 IF RECORD("TEXT")]""
IF '+RECORD("TEXT")
SET RECORD("TEXT")=""""_RECORD("TEXT")_""""
End DoDot:1
+11 if +$PIECE(Y(0),U,3)
SET DLAYGO=RECORD("FILE")
+12 ; If a LOOKUP ROUTINE is defined for a given report type, then call it
+13 IF $PIECE(Y(0),U,8)]""
Begin DoDot:1
+14 NEW TIUI,TIUVAR,TIUVPC
SET TIUVAR=""
+15 FOR
SET TIUVAR=$ORDER(^TIU(8925.1,+RECORD("TYPE"),"ITEM","E",TIUVAR))
if TIUVAR=""
QUIT
Begin DoDot:2
+16 SET TIUI=+$GET(TIUI)+1
SET TIUVAR(TIUI)=TIUVAR
+17 SET TIUVPC=$ORDER(^TIU(8925.1,+RECORD("TYPE"),"ITEM","E",TIUVAR,0))
+18 SET @TIUVAR=$PIECE(HEADER,TIULIM,TIUVPC)
End DoDot:2
+19 DO @$PIECE(Y(0),U,7,8)
SET RECORD("#")=Y
IF +Y'>0
DO MAIN^TIUPEVNT(DA,6)
+20 SET TIUI=0
FOR
SET TIUI=$ORDER(TIUVAR(TIUI))
if +TIUI'>0
QUIT
KILL @TIUVAR(TIUI)
End DoDot:1
QUIT
+21 ; Otherwise set-up for ^DIC call
+22 SET DIC=RECORD("FILE")
SET DIC(0)="MX"
+23 if +$PIECE(Y(0),U,3)
SET DIC(0)=DIC(0)_"L"
+24 SET TIUKEY=+$ORDER(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",.001,0))
+25 if TIUKEY
SET DIC(0)=DIC(0)_"N"
+26 if 'TIUKEY
SET TIUKEY=+$ORDER(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",.01,0))
+27 SET X=$SELECT(DIC(0)["N":"`",1:"")_$PIECE(HEADER,TIULIM,TIUKEY)
DO ^DIC
+28 SET RECORD("#")=+Y
IF +Y'>0
DO MAIN^TIUPEVNT(DA,6)
+29 QUIT
STUFREC(HEADER,RECORD) ; Stuffs record with known fixed fields
+1 NEW D0,DA,DR,DIE,TIUI,TIUPC
+2 SET DIE=+RECORD("FILE")
SET DA=+RECORD("#")
+3 ; Set up DR-string
+4 SET TIUI=0
+5 FOR
SET TIUI=$ORDER(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+6 SET TIUPC=$ORDER(^TIU(8925.1,+RECORD("TYPE"),"ITEM","D",TIUI,0))
if +TIUPC'>0
QUIT
+7 if TIUI'=.001
SET DR=$GET(DR)_$SELECT($LENGTH($GET(DR)):";",1:"")_TIUI_"///"_$PIECE(HEADER,TIULIM,TIUPC)
End DoDot:1
+8 DO ^DIE
+9 QUIT
SETROOT(LINECNT,RECORD) ; Sets root of WP field
+1 SET @(RECORD("TROOT")_"0)")="^^"_LINECNT_"^"_LINECNT_"^"_DT_"^^"
+2 QUIT
BUFPURGE(DA) ; Call ^DIK to purge buffer record when all's well
+1 NEW DIK
SET DIK="^TIU(8925.2,"
DO ^DIK
+2 QUIT
