- TIULA ; SLC/JER - Interactive Library functions ;04/23/10 09:00
- ;;1.0;TEXT INTEGRATION UTILITIES;**79,113,250**;Jun 20, 1997;Build 14
- ;
- ; ICR #10142 - EN^DDIOL Routine
- ; #10006 - DIC Routine & DIC, X, & Y local vars
- ; #10026 - DIR Routine & DIR, X, & Y local vars
- ; #10112 - $$PRIM^VASITE, $$SITE^VASITE Routines
- ; #664 - DIVISION^VAUTOMA Routine & VAUTD local var
- ; #10140 - XQORM, EN^XQORM Routine & XQORM local var
- ;
- PATIENT(TIUSSN) ; Select a patient
- N X,DIC,Y S:$G(TIUSSN)]"" X=TIUSSN
- S DIC=2,DIC(0)=$S($G(TIUSSN)']"":"AEMQ",1:"MX") D ^DIC
- Q Y
- SELDIV ; Get document division(s)
- ;
- ; Output - SELDIV -1= user ^ at prompt if multidivisional
- ; 0= institution file pointer missing for
- ; division entry
- ; 1= successful division selection
- ; BADDIV = comma-delimited list of bad divisions (if any)
- ; TIUDI( undefined= user <cr> for all divisions or ^ at prompt
- ; if multidivisional
- ; defined= user selected one or more divisions if
- ; multidivisional, or pre-selection of
- ; division file entry if not multidivisional;
- ; i.e.: TIUDI(file #40.8 ien)= Institution
- ; file pointer for file #40.8 entry
- N TIUI,VAUTD,Y
- K SELDIV,TIUDI,BADDIV
- ; -- Determine if facility is multidivisional
- I $P($G(^DG(43,1,"GL")),U,2) D
- . D DIVISION^VAUTOMA
- . I Y<0 S SELDIV=-1 Q
- . I VAUTD=1 S SELDIV=1 Q
- . S TIUI=0 F S TIUI=$O(VAUTD(TIUI)) Q:'TIUI D ONE(TIUI,.VAUTD)
- E D
- . S TIUI=$$PRIM^VASITE D ONE(TIUI,.VAUTD)
- Q
- ONE(TIUI,VAUTD) ; Input - TIUI Medical Center Division file (#40.8) IEN
- N TIUIFP
- S TIUIFP=$P($$SITE^VASITE(,TIUI),U) I TIUIFP>0 D
- . S TIUDI(TIUI)=TIUIFP,SELDIV=1
- E D
- . S SELDIV=0,BADDIV=$G(BADDIV)_$S($L($G(BADDIV)):", ",1:"")_$G(VAUTD(TIUI))
- Q
- ;
- SELSVC(TIUSVCS) ;Select Services
- ; Input -- None
- ; Output -- 1=Successful and 0=Failure
- ; TIUSVCS Service Selection Array
- N TIUCNT,TIUSVCI,Y
- S TIUCNT=0
- F Q:'$$ASKSVC(.TIUSVCS,TIUCNT,.TIUSVCI) D
- . S TIUSVCS(+TIUSVCI)=""
- . S TIUCNT=TIUCNT+1
- . S TIUSVCI=""
- I $G(TIUSVCI)=-1 S Y=0 G SELSVCQ
- I $G(TIUSVCI)="ALL" S TIUSVCS="ALL"
- S Y=1
- SELSVCQ Q +$G(Y)
- ;
- ASKSVC(TIUSVCS,TIUCNT,TIUSVCI) ;Ask Service
- ; Input -- TIUSVCS Service Selection Array
- ; TIUCNT Number of Services Selected
- ; Output -- 1=Successful and 0=Failure
- ; TIUSVCI Service/Section file (#49) IEN
- N DIR,DTOUT,DUOUT,X,Y
- S DIR(0)="PAO^49:AEMQ^K:'$$CHKSVC^TIULA(.TIUSVCS,+Y) X"
- S DIR("PRE")="I X="""",'$G(TIUCNT),'$D(DTOUT) S TIUSVCI=""ALL"""
- S DIR("A")="Select "_$S($G(TIUCNT):"another ",1:"")_"service: "_$S('$G(TIUCNT):"ALL// ",1:"")
- I '$G(TIUCNT) S DIR("?")=" OR enter Return for ALL services." W !
- D ^DIR
- I Y>0 S TIUSVCI=+Y
- I $D(DTOUT)!($D(DUOUT)) S TIUSVCI=-1
- Q $S($G(TIUSVCI)>0:1,1:0)
- ;
- CHKSVC(TIUSVCS,TIUSVCI) ;Check Selected Service
- ; Input -- TIUSVCS Service Selection Array
- ; TIUSVCI Service file (#49) IEN
- ; Output -- 1=Successful and 0=Failure
- N Y
- S Y=1
- ;Check if Service has already been selected
- I $D(TIUSVCS(TIUSVCI)) D EN^DDIOL("This Service has already been selected.","","!?5") S Y=0
- Q +$G(Y)
- ;
- SELSTAT(Y,PARM,DEF) ; Select Signature status
- N I,XQORM,X,TIUY
- S XQORM=+$O(^ORD(101,"B","TIU STATUS MENU",0))_";ORD(101,"
- I +XQORM'>0 W !,"Status selection unavailable." S TIUY=-1 G STATX
- S XQORM(0)=$G(PARM),XQORM("A")="Select Status: "
- I $S(PARM="F":1,PARM="R":1,1:0) S X=DEF
- S XQORM("B")=DEF D ^XQORM
- S TIUY=$G(Y)
- I +$G(Y)=1,(+$G(Y(1))=7) S Y=2,Y(2)="8^4843^amended^8"
- STATX Q TIUY
- SELSCRN(DEF) ; Select Review Screen
- N DIC,XQORM,X,Y
- S DIC=101,DIC(0)="X",X="TIU REVIEW SCREEN MENU" D ^DIC
- I +Y>0 D
- . S XQORM=+Y_";ORD(101,",XQORM(0)="1A",XQORM("A")="Select Category: "
- . S XQORM("S")="I 1 X:$D(^ORD(101,+$P(^ORD(101,DA(1),10,DA,0),U),24)) ^(24)"
- . S XQORM("B")=DEF D ^XQORM
- . I +Y,($D(Y)>9) D
- . . S Y=$S(Y(1)["Author":"AAU",Y(1)["Patient":"APT",Y(1)["Spec":"ATS",Y(1)["Transcrip":"ATC",Y(1)["All":"ALL",Y(1)["Subject":"ASUB",Y(1)["Service":"ASVC",Y(1)["Location":"ALOC",1:"")
- . . I +$G(Y(1))'>0,(X'="^^"),(X'="^") D Q
- . . . W !,"^^-jumps not allowed from this prompt." S Y=-1
- . . S:Y'="ALL" Y=Y_U_$$SELPAR(Y)
- . . S:Y="ALL" Y=Y_U_"ANY"
- Q Y
- SELPAR(DEF) ; Select an author or patient or...
- N DIC,X,Y
- I DEF="ASUB" S Y=$$ASKSUBJ^TIULA1 G SELPARX
- S DIC=$S(DEF="APT":2,DEF="ATS":45.7,DEF="ASVC":123.5,1:200)
- S DIC(0)="AEMQ"
- S DIC("A")="Select "_$S(DEF="APT":"PATIENT",DEF="AAU":"AUTHOR",DEF="ATS":"TREATING SPECIALTY",DEF="ATC":"TRANSCRIPTIONIST",DEF="ASVC":"SERVICE",1:"ATTENDING PHYSICIAN")_": "
- I DEF="ARP" S DIC("S")="I $$ISA^USRLA(+$G(Y),""PROVIDER"")"
- D ^DIC K DIC("S") I +Y>0 D
- . I $S(DEF="APT"&'$D(^TIU(8925,"C",+Y)):1,DEF="AAU"&'$D(^TIU(8925,"CA",+Y)):1,DEF="ARP"&'$D(^TIU(8925,"CR",+Y)):1,1:0) W !,"No entries for ",$P(Y,U,2) S Y=0
- SELPARX Q Y
- EDATE(PRMPT,STATUS,DFLT) ; Get early date
- N X,Y,TIUPRMT,TIUDFLT
- I $G(STATUS)=4 S Y=1 Q Y
- S TIUPRMT=" Start "_$S($L($G(PRMPT)):PRMPT_" ",1:"")_"Date [Time]: "
- S TIUDFLT=$S($L($G(DFLT)):DFLT,1:"T-30")
- S Y=$$READ^TIUU("DOA^::AET",TIUPRMT,TIUDFLT)
- Q Y
- LDATE(PRMPT,STATUS,DFLT) ; Get late date
- N X,Y,TIUPRMT,TIUDFLT
- I $G(STATUS)=4 S Y=9999999 Q Y
- S TIUPRMT="Ending "_$S($L($G(PRMPT)):PRMPT_" ",1:"")_"Date [Time]: "
- S TIUDFLT=$S($L($G(DFLT)):DFLT,1:"NOW")
- S Y=$$READ^TIUU("DOA^::AET",TIUPRMT,TIUDFLT)
- Q Y
- CATEGORY() ; Select Service Category
- N DIR,X,Y
- S DIR(0)="9000010,.07",DIR("A")="Select SERVICE CATEGORY"
- D ^DIR
- Q Y_U_Y(0)
- SELTYP(DA,RETURN,PARM,DFLT,TYPE,MODE,DCLASS,PICK) ; Select Document Types
- N I,J,X,XQORM,CURTYP,Y
- I '$D(RETURN) S RETURN=$NA(^TMP("TIUTYP",$J)) K @RETURN
- ; TIUK is STATIC
- ;I +MODE D DOCLIST^TIULA1(DA,.RETURN,PARM,DFLT) Q:+RETURN'<0
- ; *** ADD CALL TO PERSONAL DOCUMENT LISTER HERE
- N:'$D(TIUK) TIUK S TIUK=+$G(TIUK)
- I $G(DFLT)="LAST" D
- . S DFLT=$O(^DISV(DUZ,"XQORM",DA_";TIU(8925.1,",0))
- . S DFLT=$S(+DFLT:$G(^DISV(DUZ,"XQORM",DA_";TIU(8925.1,",DFLT)),1:"")
- I $G(TYPE)']"" S TYPE="DOC"
- I $G(MODE)']"" S MODE=1 ; Default is ASK
- S XQORM=DA_";TIU(8925.1,",XQORM(0)=$S(+$P($G(^TIU(8925.1,+DA,10,0)),U,3)=1:"F",1:$G(PARM,"AD"))
- I XQORM(0)["D" S XQORM("H")="W !!,$$CENTER^TIULS(""--- ""_$P(^TIU(8925.1,+DA,0),U,3)_"" ---""),!"
- I $S(XQORM(0)="F":1,XQORM(0)="R":1,1:0) S X=$S(DFLT]"":DFLT,1:"ALL")
- S:$G(DFLT)]"" XQORM("B")=DFLT
- S XQORM("A")="Select "_$S(XQORM(0)["D":"Document",1:$P(^TIU(8925.1,+DA,0),U,3))_$S($P(^TIU(8925.1,+DA,0),U,4)="DOC":" Component",1:" Type")_$S(+XQORM(0)'=1:"(s)",1:"")_": "
- ; If screening inactive titles proves to be correct, remove comment
- ; from the line below:
- ; S XQORM("S")="I +$$CANPICK^TIULP(+$G(^TIU(8925.1,+DA(1),10,+DA,0)))>0"
- D EN^XQORM
- I +Y'>0,($D(@RETURN)'>9) S @RETURN=Y Q
- I (PARM["A"),(+$G(@RETURN)'>0) M PICK=Y
- S I=0 F S I=$O(Y(I)) Q:+I'>0 D
- . N TYPMATCH
- . S J=+$P(Y(I),U,2),CURTYP=$P($G(^TIU(8925.1,+J,0)),U,4)
- . I CURTYP="DC" S DCLASS=+$G(DCLASS)+1,DCLASS(DCLASS)=J
- . I I TYPE="DOC",(PARM["A"),(+$O(^TIU(8925.1,+J,10,0))'>0) W !!,"The Document Class ",$P(^TIU(8925.1,+J,0),U)," has no active titles at present..."
- . S TYPMATCH=$$TYPMATCH^TIULA1(TYPE,CURTYP)
- . I +TYPMATCH>0 D
- . . S TIUK=+$G(TIUK)+1,@RETURN@(TIUK)=Y(I),@RETURN=TIUK
- . I $S('+$G(TYPMATCH):1,CURTYP="CL":1,1:0),+$O(^TIU(8925.1,+J,10,0))>0 D SELTYP(+J,.RETURN,$S(MODE=1:$G(PARM),1:"F"),$S(MODE=1:"LAST",1:"ALL"),TYPE,MODE,.DCLASS,.PICK)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULA 7668 printed Jan 18, 2025@03:43:07 Page 2
- TIULA ; SLC/JER - Interactive Library functions ;04/23/10 09:00
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**79,113,250**;Jun 20, 1997;Build 14
- +2 ;
- +3 ; ICR #10142 - EN^DDIOL Routine
- +4 ; #10006 - DIC Routine & DIC, X, & Y local vars
- +5 ; #10026 - DIR Routine & DIR, X, & Y local vars
- +6 ; #10112 - $$PRIM^VASITE, $$SITE^VASITE Routines
- +7 ; #664 - DIVISION^VAUTOMA Routine & VAUTD local var
- +8 ; #10140 - XQORM, EN^XQORM Routine & XQORM local var
- +9 ;
- PATIENT(TIUSSN) ; Select a patient
- +1 NEW X,DIC,Y
- if $GET(TIUSSN)]""
- SET X=TIUSSN
- +2 SET DIC=2
- SET DIC(0)=$SELECT($GET(TIUSSN)']"":"AEMQ",1:"MX")
- DO ^DIC
- +3 QUIT Y
- SELDIV ; Get document division(s)
- +1 ;
- +2 ; Output - SELDIV -1= user ^ at prompt if multidivisional
- +3 ; 0= institution file pointer missing for
- +4 ; division entry
- +5 ; 1= successful division selection
- +6 ; BADDIV = comma-delimited list of bad divisions (if any)
- +7 ; TIUDI( undefined= user <cr> for all divisions or ^ at prompt
- +8 ; if multidivisional
- +9 ; defined= user selected one or more divisions if
- +10 ; multidivisional, or pre-selection of
- +11 ; division file entry if not multidivisional;
- +12 ; i.e.: TIUDI(file #40.8 ien)= Institution
- +13 ; file pointer for file #40.8 entry
- +14 NEW TIUI,VAUTD,Y
- +15 KILL SELDIV,TIUDI,BADDIV
- +16 ; -- Determine if facility is multidivisional
- +17 IF $PIECE($GET(^DG(43,1,"GL")),U,2)
- Begin DoDot:1
- +18 DO DIVISION^VAUTOMA
- +19 IF Y<0
- SET SELDIV=-1
- QUIT
- +20 IF VAUTD=1
- SET SELDIV=1
- QUIT
- +21 SET TIUI=0
- FOR
- SET TIUI=$ORDER(VAUTD(TIUI))
- if 'TIUI
- QUIT
- DO ONE(TIUI,.VAUTD)
- End DoDot:1
- +22 IF '$TEST
- Begin DoDot:1
- +23 SET TIUI=$$PRIM^VASITE
- DO ONE(TIUI,.VAUTD)
- End DoDot:1
- +24 QUIT
- ONE(TIUI,VAUTD) ; Input - TIUI Medical Center Division file (#40.8) IEN
- +1 NEW TIUIFP
- +2 SET TIUIFP=$PIECE($$SITE^VASITE(,TIUI),U)
- IF TIUIFP>0
- Begin DoDot:1
- +3 SET TIUDI(TIUI)=TIUIFP
- SET SELDIV=1
- End DoDot:1
- +4 IF '$TEST
- Begin DoDot:1
- +5 SET SELDIV=0
- SET BADDIV=$GET(BADDIV)_$SELECT($LENGTH($GET(BADDIV)):", ",1:"")_$GET(VAUTD(TIUI))
- End DoDot:1
- +6 QUIT
- +7 ;
- SELSVC(TIUSVCS) ;Select Services
- +1 ; Input -- None
- +2 ; Output -- 1=Successful and 0=Failure
- +3 ; TIUSVCS Service Selection Array
- +4 NEW TIUCNT,TIUSVCI,Y
- +5 SET TIUCNT=0
- +6 FOR
- if '$$ASKSVC(.TIUSVCS,TIUCNT,.TIUSVCI)
- QUIT
- Begin DoDot:1
- +7 SET TIUSVCS(+TIUSVCI)=""
- +8 SET TIUCNT=TIUCNT+1
- +9 SET TIUSVCI=""
- End DoDot:1
- +10 IF $GET(TIUSVCI)=-1
- SET Y=0
- GOTO SELSVCQ
- +11 IF $GET(TIUSVCI)="ALL"
- SET TIUSVCS="ALL"
- +12 SET Y=1
- SELSVCQ QUIT +$GET(Y)
- +1 ;
- ASKSVC(TIUSVCS,TIUCNT,TIUSVCI) ;Ask Service
- +1 ; Input -- TIUSVCS Service Selection Array
- +2 ; TIUCNT Number of Services Selected
- +3 ; Output -- 1=Successful and 0=Failure
- +4 ; TIUSVCI Service/Section file (#49) IEN
- +5 NEW DIR,DTOUT,DUOUT,X,Y
- +6 SET DIR(0)="PAO^49:AEMQ^K:'$$CHKSVC^TIULA(.TIUSVCS,+Y) X"
- +7 SET DIR("PRE")="I X="""",'$G(TIUCNT),'$D(DTOUT) S TIUSVCI=""ALL"""
- +8 SET DIR("A")="Select "_$SELECT($GET(TIUCNT):"another ",1:"")_"service: "_$SELECT('$GET(TIUCNT):"ALL// ",1:"")
- +9 IF '$GET(TIUCNT)
- SET DIR("?")=" OR enter Return for ALL services."
- WRITE !
- +10 DO ^DIR
- +11 IF Y>0
- SET TIUSVCI=+Y
- +12 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET TIUSVCI=-1
- +13 QUIT $SELECT($GET(TIUSVCI)>0:1,1:0)
- +14 ;
- CHKSVC(TIUSVCS,TIUSVCI) ;Check Selected Service
- +1 ; Input -- TIUSVCS Service Selection Array
- +2 ; TIUSVCI Service file (#49) IEN
- +3 ; Output -- 1=Successful and 0=Failure
- +4 NEW Y
- +5 SET Y=1
- +6 ;Check if Service has already been selected
- +7 IF $DATA(TIUSVCS(TIUSVCI))
- DO EN^DDIOL("This Service has already been selected.","","!?5")
- SET Y=0
- +8 QUIT +$GET(Y)
- +9 ;
- SELSTAT(Y,PARM,DEF) ; Select Signature status
- +1 NEW I,XQORM,X,TIUY
- +2 SET XQORM=+$ORDER(^ORD(101,"B","TIU STATUS MENU",0))_";ORD(101,"
- +3 IF +XQORM'>0
- WRITE !,"Status selection unavailable."
- SET TIUY=-1
- GOTO STATX
- +4 SET XQORM(0)=$GET(PARM)
- SET XQORM("A")="Select Status: "
- +5 IF $SELECT(PARM="F":1,PARM="R":1,1:0)
- SET X=DEF
- +6 SET XQORM("B")=DEF
- DO ^XQORM
- +7 SET TIUY=$GET(Y)
- +8 IF +$GET(Y)=1
- IF (+$GET(Y(1))=7)
- SET Y=2
- SET Y(2)="8^4843^amended^8"
- STATX QUIT TIUY
- SELSCRN(DEF) ; Select Review Screen
- +1 NEW DIC,XQORM,X,Y
- +2 SET DIC=101
- SET DIC(0)="X"
- SET X="TIU REVIEW SCREEN MENU"
- DO ^DIC
- +3 IF +Y>0
- Begin DoDot:1
- +4 SET XQORM=+Y_";ORD(101,"
- SET XQORM(0)="1A"
- SET XQORM("A")="Select Category: "
- +5 SET XQORM("S")="I 1 X:$D(^ORD(101,+$P(^ORD(101,DA(1),10,DA,0),U),24)) ^(24)"
- +6 SET XQORM("B")=DEF
- DO ^XQORM
- +7 IF +Y
- IF ($DATA(Y)>9)
- Begin DoDot:2
- +8 SET Y=$SELECT(Y(1)["Author":"AAU",Y(1)["Patient":"APT",Y(1)["Spec":"ATS",Y(1)["Transcrip":"ATC",Y(1)["All":"ALL",Y(1)["Subject":"ASUB",Y(1)["Service":"ASVC",Y(1)["Location":"ALOC",1:"")
- +9 IF +$GET(Y(1))'>0
- IF (X'="^^")
- IF (X'="^")
- Begin DoDot:3
- +10 WRITE !,"^^-jumps not allowed from this prompt."
- SET Y=-1
- End DoDot:3
- QUIT
- +11 if Y'="ALL"
- SET Y=Y_U_$$SELPAR(Y)
- +12 if Y="ALL"
- SET Y=Y_U_"ANY"
- End DoDot:2
- End DoDot:1
- +13 QUIT Y
- SELPAR(DEF) ; Select an author or patient or...
- +1 NEW DIC,X,Y
- +2 IF DEF="ASUB"
- SET Y=$$ASKSUBJ^TIULA1
- GOTO SELPARX
- +3 SET DIC=$SELECT(DEF="APT":2,DEF="ATS":45.7,DEF="ASVC":123.5,1:200)
- +4 SET DIC(0)="AEMQ"
- +5 SET DIC("A")="Select "_$SELECT(DEF="APT":"PATIENT",DEF="AAU":"AUTHOR",DEF="ATS":"TREATING SPECIALTY",DEF="ATC":"TRANSCRIPTIONIST",DEF="ASVC":"SERVICE",1:"ATTENDING PHYSICIAN")_": "
- +6 IF DEF="ARP"
- SET DIC("S")="I $$ISA^USRLA(+$G(Y),""PROVIDER"")"
- +7 DO ^DIC
- KILL DIC("S")
- IF +Y>0
- Begin DoDot:1
- +8 IF $SELECT(DEF="APT"&'$DATA(^TIU(8925,"C",+Y)):1,DEF="AAU"&'$DATA(^TIU(8925,"CA",+Y)):1,DEF="ARP"&'$DATA(^TIU(8925,"CR",+Y)):1,1:0)
- WRITE !,"No entries for ",$PIECE(Y,U,2)
- SET Y=0
- End DoDot:1
- SELPARX QUIT Y
- EDATE(PRMPT,STATUS,DFLT) ; Get early date
- +1 NEW X,Y,TIUPRMT,TIUDFLT
- +2 IF $GET(STATUS)=4
- SET Y=1
- QUIT Y
- +3 SET TIUPRMT=" Start "_$SELECT($LENGTH($GET(PRMPT)):PRMPT_" ",1:"")_"Date [Time]: "
- +4 SET TIUDFLT=$SELECT($LENGTH($GET(DFLT)):DFLT,1:"T-30")
- +5 SET Y=$$READ^TIUU("DOA^::AET",TIUPRMT,TIUDFLT)
- +6 QUIT Y
- LDATE(PRMPT,STATUS,DFLT) ; Get late date
- +1 NEW X,Y,TIUPRMT,TIUDFLT
- +2 IF $GET(STATUS)=4
- SET Y=9999999
- QUIT Y
- +3 SET TIUPRMT="Ending "_$SELECT($LENGTH($GET(PRMPT)):PRMPT_" ",1:"")_"Date [Time]: "
- +4 SET TIUDFLT=$SELECT($LENGTH($GET(DFLT)):DFLT,1:"NOW")
- +5 SET Y=$$READ^TIUU("DOA^::AET",TIUPRMT,TIUDFLT)
- +6 QUIT Y
- CATEGORY() ; Select Service Category
- +1 NEW DIR,X,Y
- +2 SET DIR(0)="9000010,.07"
- SET DIR("A")="Select SERVICE CATEGORY"
- +3 DO ^DIR
- +4 QUIT Y_U_Y(0)
- SELTYP(DA,RETURN,PARM,DFLT,TYPE,MODE,DCLASS,PICK) ; Select Document Types
- +1 NEW I,J,X,XQORM,CURTYP,Y
- +2 IF '$DATA(RETURN)
- SET RETURN=$NAME(^TMP("TIUTYP",$JOB))
- KILL @RETURN
- +3 ; TIUK is STATIC
- +4 ;I +MODE D DOCLIST^TIULA1(DA,.RETURN,PARM,DFLT) Q:+RETURN'<0
- +5 ; *** ADD CALL TO PERSONAL DOCUMENT LISTER HERE
- +6 if '$DATA(TIUK)
- NEW TIUK
- SET TIUK=+$GET(TIUK)
- +7 IF $GET(DFLT)="LAST"
- Begin DoDot:1
- +8 SET DFLT=$ORDER(^DISV(DUZ,"XQORM",DA_";TIU(8925.1,",0))
- +9 SET DFLT=$SELECT(+DFLT:$GET(^DISV(DUZ,"XQORM",DA_";TIU(8925.1,",DFLT)),1:"")
- End DoDot:1
- +10 IF $GET(TYPE)']""
- SET TYPE="DOC"
- +11 ; Default is ASK
- IF $GET(MODE)']""
- SET MODE=1
- +12 SET XQORM=DA_";TIU(8925.1,"
- SET XQORM(0)=$SELECT(+$PIECE($GET(^TIU(8925.1,+DA,10,0)),U,3)=1:"F",1:$GET(PARM,"AD"))
- +13 IF XQORM(0)["D"
- SET XQORM("H")="W !!,$$CENTER^TIULS(""--- ""_$P(^TIU(8925.1,+DA,0),U,3)_"" ---""),!"
- +14 IF $SELECT(XQORM(0)="F":1,XQORM(0)="R":1,1:0)
- SET X=$SELECT(DFLT]"":DFLT,1:"ALL")
- +15 if $GET(DFLT)]""
- SET XQORM("B")=DFLT
- +16 SET XQORM("A")="Select "_$SELECT(XQORM(0)["D":"Document",1:$PIECE(^TIU(8925.1,+DA,0),U,3))_$SELECT($PIECE(^TIU(8925.1,+DA,0),U,4)="DOC":" Component",1:" Type")_$SELECT(+XQORM(0)'=1:"(s)",1:"")_": "
- +17 ; If screening inactive titles proves to be correct, remove comment
- +18 ; from the line below:
- +19 ; S XQORM("S")="I +$$CANPICK^TIULP(+$G(^TIU(8925.1,+DA(1),10,+DA,0)))>0"
- +20 DO EN^XQORM
- +21 IF +Y'>0
- IF ($DATA(@RETURN)'>9)
- SET @RETURN=Y
- QUIT
- +22 IF (PARM["A")
- IF (+$GET(@RETURN)'>0)
- MERGE PICK=Y
- +23 SET I=0
- FOR
- SET I=$ORDER(Y(I))
- if +I'>0
- QUIT
- Begin DoDot:1
- +24 NEW TYPMATCH
- +25 SET J=+$PIECE(Y(I),U,2)
- SET CURTYP=$PIECE($GET(^TIU(8925.1,+J,0)),U,4)
- +26 IF CURTYP="DC"
- SET DCLASS=+$GET(DCLASS)+1
- SET DCLASS(DCLASS)=J
- +27 IF $TEST
- IF TYPE="DOC"
- IF (PARM["A")
- IF (+$ORDER(^TIU(8925.1,+J,10,0))'>0)
- WRITE !!,"The Document Class ",$PIECE(^TIU(8925.1,+J,0),U)," has no active titles at present..."
- +28 SET TYPMATCH=$$TYPMATCH^TIULA1(TYPE,CURTYP)
- +29 IF +TYPMATCH>0
- Begin DoDot:2
- +30 SET TIUK=+$GET(TIUK)+1
- SET @RETURN@(TIUK)=Y(I)
- SET @RETURN=TIUK
- End DoDot:2
- +31 IF $SELECT('+$GET(TYPMATCH):1,CURTYP="CL":1,1:0)
- IF +$ORDER(^TIU(8925.1,+J,10,0))>0
- DO SELTYP(+J,.RETURN,$SELECT(MODE=1:$GET(PARM),1:"F"),$SELECT(MODE=1:"LAST",1:"ALL"),TYPE,MODE,.DCLASS,.PICK)
- End DoDot:1
- +32 QUIT