source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPUTD.m@ 1704

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