- TIULAPIC ; SLC/JER,KER - Extract selected classes from TIU ; 9/19/07 2:38pm
- ;;1.0;TEXT INTEGRATION UTILITIES;**83,100,121,211,227**;Jun 20, 1997;Build 15
- MAIN(DFN,TIUDOC,TIME1,TIME2,OCCLIM,TEXT) ; Control branching
- ; Notes for Health Summaries, by Reference Date
- ; For comments, see rtn TIULAPIS
- N TIUDA,TIUDT,TIUPRM0,TIUPRM1,TIUPRM3,COUNT,TIUSI,TIUS,TIUTI,TYPES
- N CANDO,CKCANVW,ORIGCHLD
- K ^TMP("TIUREPLACE",$J)
- D SETPARM^TIULE S:+$G(OCCLIM)'>0 OCCLIM=999 S:+$G(TIME1)'>0 TIME1=6666666 S:+$G(TIME2)'>0 TIME2=9999999 K ^TMP("TIU",$J) I '$D(TIUPRM0) D SETPARM^TIULE
- S TIUDT=TIME1 F S TIUDT=$O(^TIU(8925,"APTCL",DFN,TIUDOC,TIUDT)) Q:+TIUDT'>0!(TIUDT>TIME2)!(+$G(COUNT)'<OCCLIM) D
- . S TIUDA=0 F S TIUDA=$O(^TIU(8925,"APTCL",DFN,TIUDOC,TIUDT,TIUDA)) Q:+TIUDA'>0 D
- . . I +$$ISADDNDM^TIULC1(TIUDA),+TEXT Q
- . . S CKCANVW=$S($E(IOST,1)="C":1,1:0)
- . . I $E(IOST,1)'="C" S CANDO=+$$CANDO^TIULP(TIUDA,"PRINT RECORD") Q:'CANDO ;TIU*1*91
- . . D REPLACE^TIUPRPN3(TIUDA,TIUDT,1301,CKCANVW)
- . . S COUNT=^TMP("TIUREPLACE",$J)
- S TIUDA=0
- F S TIUDA=$O(^TMP("TIUREPLACE",$J,TIUDA)) Q:'TIUDA D
- . Q:^TMP("TIUREPLACE",$J,TIUDA)=0 ;not viewable
- . S TIUDT=^TMP("TIUREPLACE",$J,TIUDA,"DT")
- . S ORIGCHLD=+$P(^TMP("TIUREPLACE",$J,TIUDA),U,2)
- . ;VMP/RJT - *227
- . D EXTRACT^TIULQ(TIUDA,"^TMP(""TIU"",$J,"_TIUDT_")",.TIUERR,".01;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1601;1701;89261","",1,"IE",CKCANVW,ORIGCHLD)
- K ^TMP("TIUREPLACE",$J)
- Q
- ;
- VISIT(DFN,TIUDOC,TIME1,TIME2,OCCLIM,TEXT) ; Control branching
- ; Visit Date
- N TIUDA,TIUDT,TIUPRM0,TIUPRM1,TIUPRM3,COUNT,TIUSI,TIUS,TIUTI,TIUVD,TYPES
- N CANDO,CKCANVW,ORIGCHLD
- K ^TMP("TIUREPLACE",$J)
- D SETPARM^TIULE S:+$G(OCCLIM)'>0 OCCLIM=999 S:+$G(TIME1)'>0 TIME1=6666666 S:+$G(TIME2)'>0 TIME2=9999999 K ^TMP("TIU",$J) I '$D(TIUPRM0) D SETPARM^TIULE
- S TIUDT=TIME1 F S TIUDT=$O(^TIU(8925,"AE",DFN,TIUDT)) Q:+TIUDT'>0!(TIUDT>TIME2)!(+$G(COUNT)'<OCCLIM) D
- . S TIUVD=0 F S TIUVD=$O(^TIU(8925,"AE",DFN,TIUDT,TIUVD)) Q:+TIUVD'>0 D
- . . S TIUDA=0 F S TIUDA=$O(^TIU(8925,"AE",DFN,TIUDT,TIUVD,TIUDA)) Q:+TIUDA'>0 D
- . . . N TIUIVD,TIUIRD S TIUIVD=(9999999-TIUDT),TIUIRD=+($P($G(^TIU(8925,+TIUDA,13)),"^",1))
- . . . Q:'$D(^TIU(8925,"APTCL",DFN,TIUDOC,(9999999-TIUIRD)))
- . . . I +$$ISADDNDM^TIULC1(TIUDA),+TEXT Q
- . . . S CKCANVW=$S($E(IOST,1)="C":1,1:0)
- . . . I $E(IOST,1)'="C" S CANDO=+$$CANDO^TIULP(TIUDA,"PRINT RECORD") Q:'CANDO ;TIU*1*91
- . . . D REPLACE^TIUPRPN3(TIUDA,TIUDT,1301,CKCANVW)
- . . . S COUNT=^TMP("TIUREPLACE",$J)
- S TIUDA=0
- F S TIUDA=$O(^TMP("TIUREPLACE",$J,TIUDA)) Q:'TIUDA D
- . Q:^TMP("TIUREPLACE",$J,TIUDA)=0
- . S TIUDT=^TMP("TIUREPLACE",$J,TIUDA,"DT")
- . S ORIGCHLD=+$P(^TMP("TIUREPLACE",$J,TIUDA),U,2)
- . ;VMP/RJT - *227
- . D EXTRACT^TIULQ(TIUDA,"^TMP(""TIU"",$J,"_(TIUDT)_")",.TIUERR,".01;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1601;1701;89261","",1,"IE",CKCANVW,ORIGCHLD)
- K ^TMP("TIUREPLACE",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULAPIC 2989 printed Feb 19, 2025@00:08:34 Page 2
- TIULAPIC ; SLC/JER,KER - Extract selected classes from TIU ; 9/19/07 2:38pm
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**83,100,121,211,227**;Jun 20, 1997;Build 15
- MAIN(DFN,TIUDOC,TIME1,TIME2,OCCLIM,TEXT) ; Control branching
- +1 ; Notes for Health Summaries, by Reference Date
- +2 ; For comments, see rtn TIULAPIS
- +3 NEW TIUDA,TIUDT,TIUPRM0,TIUPRM1,TIUPRM3,COUNT,TIUSI,TIUS,TIUTI,TYPES
- +4 NEW CANDO,CKCANVW,ORIGCHLD
- +5 KILL ^TMP("TIUREPLACE",$JOB)
- +6 DO SETPARM^TIULE
- if +$GET(OCCLIM)'>0
- SET OCCLIM=999
- if +$GET(TIME1)'>0
- SET TIME1=6666666
- if +$GET(TIME2)'>0
- SET TIME2=9999999
- KILL ^TMP("TIU",$JOB)
- IF '$DATA(TIUPRM0)
- DO SETPARM^TIULE
- +7 SET TIUDT=TIME1
- FOR
- SET TIUDT=$ORDER(^TIU(8925,"APTCL",DFN,TIUDOC,TIUDT))
- if +TIUDT'>0!(TIUDT>TIME2)!(+$GET(COUNT)'<OCCLIM)
- QUIT
- Begin DoDot:1
- +8 SET TIUDA=0
- FOR
- SET TIUDA=$ORDER(^TIU(8925,"APTCL",DFN,TIUDOC,TIUDT,TIUDA))
- if +TIUDA'>0
- QUIT
- Begin DoDot:2
- +9 IF +$$ISADDNDM^TIULC1(TIUDA)
- IF +TEXT
- QUIT
- +10 SET CKCANVW=$SELECT($EXTRACT(IOST,1)="C":1,1:0)
- +11 ;TIU*1*91
- IF $EXTRACT(IOST,1)'="C"
- SET CANDO=+$$CANDO^TIULP(TIUDA,"PRINT RECORD")
- if 'CANDO
- QUIT
- +12 DO REPLACE^TIUPRPN3(TIUDA,TIUDT,1301,CKCANVW)
- +13 SET COUNT=^TMP("TIUREPLACE",$JOB)
- End DoDot:2
- End DoDot:1
- +14 SET TIUDA=0
- +15 FOR
- SET TIUDA=$ORDER(^TMP("TIUREPLACE",$JOB,TIUDA))
- if 'TIUDA
- QUIT
- Begin DoDot:1
- +16 ;not viewable
- if ^TMP("TIUREPLACE",$JOB,TIUDA)=0
- QUIT
- +17 SET TIUDT=^TMP("TIUREPLACE",$JOB,TIUDA,"DT")
- +18 SET ORIGCHLD=+$PIECE(^TMP("TIUREPLACE",$JOB,TIUDA),U,2)
- +19 ;VMP/RJT - *227
- +20 DO EXTRACT^TIULQ(TIUDA,"^TMP(""TIU"",$J,"_TIUDT_")",.TIUERR,".01;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1601;1701;89261","",1,"IE",CKCANVW,ORIGCHLD)
- End DoDot:1
- +21 KILL ^TMP("TIUREPLACE",$JOB)
- +22 QUIT
- +23 ;
- VISIT(DFN,TIUDOC,TIME1,TIME2,OCCLIM,TEXT) ; Control branching
- +1 ; Visit Date
- +2 NEW TIUDA,TIUDT,TIUPRM0,TIUPRM1,TIUPRM3,COUNT,TIUSI,TIUS,TIUTI,TIUVD,TYPES
- +3 NEW CANDO,CKCANVW,ORIGCHLD
- +4 KILL ^TMP("TIUREPLACE",$JOB)
- +5 DO SETPARM^TIULE
- if +$GET(OCCLIM)'>0
- SET OCCLIM=999
- if +$GET(TIME1)'>0
- SET TIME1=6666666
- if +$GET(TIME2)'>0
- SET TIME2=9999999
- KILL ^TMP("TIU",$JOB)
- IF '$DATA(TIUPRM0)
- DO SETPARM^TIULE
- +6 SET TIUDT=TIME1
- FOR
- SET TIUDT=$ORDER(^TIU(8925,"AE",DFN,TIUDT))
- if +TIUDT'>0!(TIUDT>TIME2)!(+$GET(COUNT)'<OCCLIM)
- QUIT
- Begin DoDot:1
- +7 SET TIUVD=0
- FOR
- SET TIUVD=$ORDER(^TIU(8925,"AE",DFN,TIUDT,TIUVD))
- if +TIUVD'>0
- QUIT
- Begin DoDot:2
- +8 SET TIUDA=0
- FOR
- SET TIUDA=$ORDER(^TIU(8925,"AE",DFN,TIUDT,TIUVD,TIUDA))
- if +TIUDA'>0
- QUIT
- Begin DoDot:3
- +9 NEW TIUIVD,TIUIRD
- SET TIUIVD=(9999999-TIUDT)
- SET TIUIRD=+($PIECE($GET(^TIU(8925,+TIUDA,13)),"^",1))
- +10 if '$DATA(^TIU(8925,"APTCL",DFN,TIUDOC,(9999999-TIUIRD)))
- QUIT
- +11 IF +$$ISADDNDM^TIULC1(TIUDA)
- IF +TEXT
- QUIT
- +12 SET CKCANVW=$SELECT($EXTRACT(IOST,1)="C":1,1:0)
- +13 ;TIU*1*91
- IF $EXTRACT(IOST,1)'="C"
- SET CANDO=+$$CANDO^TIULP(TIUDA,"PRINT RECORD")
- if 'CANDO
- QUIT
- +14 DO REPLACE^TIUPRPN3(TIUDA,TIUDT,1301,CKCANVW)
- +15 SET COUNT=^TMP("TIUREPLACE",$JOB)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 SET TIUDA=0
- +17 FOR
- SET TIUDA=$ORDER(^TMP("TIUREPLACE",$JOB,TIUDA))
- if 'TIUDA
- QUIT
- Begin DoDot:1
- +18 if ^TMP("TIUREPLACE",$JOB,TIUDA)=0
- QUIT
- +19 SET TIUDT=^TMP("TIUREPLACE",$JOB,TIUDA,"DT")
- +20 SET ORIGCHLD=+$PIECE(^TMP("TIUREPLACE",$JOB,TIUDA),U,2)
- +21 ;VMP/RJT - *227
- +22 DO EXTRACT^TIULQ(TIUDA,"^TMP(""TIU"",$J,"_(TIUDT)_")",.TIUERR,".01;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1601;1701;89261","",1,"IE",CKCANVW,ORIGCHLD)
- End DoDot:1
- +23 KILL ^TMP("TIUREPLACE",$JOB)
- +24 QUIT
