Routine: TIUPUTD

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)

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)

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

SETROOT(LINECNT,RECORD) ; Sets root of WP field

 S @(RECORD("TROOT")_"0)")="^^"_LINECNT_"^"_LINECNT_"^"_DT_"^^"

BUFPURGE(DA) ; Call ^DIK to purge buffer record when all's well

 N DIK S DIK="^TIU(8925.2," D ^DIK

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPUTD   4006     printed  Apr 23, 2025@18:59:09                                                                                                                                                                                                     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

TIUPUTD.m