TIULA3 ; SLC/JER - Still more interactive functions ;1/31/08
;;1.0;TEXT INTEGRATION UTILITIES;**50,79,98,219**;Jun 20, 1997;Build 11
TITLE ; Title Look-up
N TIUI,TYPE,TIUCLASS S TIUI=0
S TIUTYP=$NA(^TMP("TIUTYP",$J))
K @TIUTYP
I +$G(TIUPICT)'>0 Q
I $P($G(TIUPICT(1)),U,4)="ALL" D
. S TIUCLASS=+$O(^TIU(8925.1,"AD",+$P(TIUPICT(1),U,2),0))
. K TIUPICT
. S TIUPICT=1,TIUPICT(1)="1^"_TIUCLASS_U_$$PNAME^TIULC1(TIUCLASS)
F S TIUI=$O(TIUPICT(TIUI)) Q:+TIUI'>0 D
. S TIUCLASS=$P(TIUPICT(TIUI),U,2)
. W !!,"For ",$$UP^XLFSTR($$PNAME^TIULC1(TIUCLASS)),": "
. D TITLPICK(.TYPE,TIUCLASS)
M @TIUTYP=TYPE
S Y="ANY"
Q
TITLPICK(TIUTYP,CLASS) ; Select multiple titles
N TIUI,TYPE,TIUPRMT S TIUI=0
W !!,"Please Select the ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS))
W " TITLES to search for:",!
F D Q:+$G(TYPE)'>0
. K TYPE
. S TIUI=TIUI+1,TIUPRMT=$J(TIUI,3)_") "
. D DOCSPICK^TIULA2(.TYPE,CLASS,"A",0,TIUPRMT)
. I +TYPE>0 S TIUTYP=+$G(TIUTYP)+1,TIUTYP(TIUTYP)=$G(TYPE(1))
. I I $P(TYPE(1),U,4)="SINGLE ITEM" D
. . W !,"There is only one TITLE under ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS))
. . S TYPE=0
. I $S($D(DTOUT):1,$D(DUOUT):1,(+TYPE'>0&'$D(TIUTYP)):1,1:0) S TIUQUIT=1
W !
Q
ASKTITLE(CLASS,TIUTTL) ; Ask for a different title, same class
N TIUY,TIUTYP,DFLT,SCREEN,X,Y
S DFLT=$$RSLVTITL(TIUTTL)
S SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",($P(^(0),U)'[""ADDENDUM""),+$$ISA^TIULX(+Y,CLASS),+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)"
S TIUY=+$$ASKTYP^TIULA2(+CLASS,DFLT,SCREEN,"TITLE: ")
I +$G(TIUY)'>0 S TIUY=TIUTTL
Q TIUY
RSLVTITL(TIUTTL) ; Resolve pointers to titles
Q $P($G(^TIU(8925.1,+TIUTTL,0)),U)
ASKSEQ(TIUDFLT) ; Ask preferred sort sequence
N TIUPRMT,TIUSET,TIUY S TIUDFLT=$G(TIUDFLT,"D")
S TIUPRMT="Please Specify Sort Order: "
S TIUSET="A:ascending (OLDEST FIRST);D:descending (NEWEST FIRST)"
S TIUY=$$READ^TIUU("SA^"_TIUSET,TIUPRMT,$S(TIUDFLT="A":"ascending",1:"descending"))
Q TIUY
DATENOTE(X) ; Ask for date/time of note
N %DT,Y
;S TIUPRMT="DATE/TIME OF NOTE"
;S TIUY=$$READ^TIUU("D^:NOW:RS",TIUPRMT,$G(DFLT,"NOW"),TIUHLP)
;I +TIUY W " ",$P(TIUY,U,2)
S %DT="RSX",%DT(0)="-NOW" D ^%DT
I +Y'>0 D
. W !,$C(7),"Enter DATE AND TIME of the note [TIME REQUIRED] (future dates prohibited)."
Q +$G(Y)
SCRCSNR(TIUDA,Y) ; Evaluate whether a person may be selected to cosign
N TIUI,TIUY,TIUD0,TIUD12 S TIUY=1 ; most people may be selected
S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^TIU(8925,+TIUDA,12))
; If he requires cosignature for this document a user may NOT select
; himself
I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+$G(DUZ)),(Y=+$G(DUZ)) S TIUY=0 G SCREENX
; A TERMINATED User may NOT be selected
I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX
; A non-PROVIDER may NOT be selected
I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX
; Author may NOT be selected
I Y=+$P(TIUD12,U,2) S TIUY=0 G SCREENX
; Expected Signer may NOT be selected
I Y=+$P(TIUD12,U,4) S TIUY=0 G SCREENX
; Others who require Cosignature may NOT be selected
I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+Y) S TIUY=0
SCREENX Q +$G(TIUY)
;
SCRATT(TIUDA,PERSON) ; Can a person be an Attending for a given docmt?
N TIUD0,TIUTYP,CANSEL,DICTDT,TIUISDS,TIUPRNT,TIUPTYP,TIUPD0,TIUISAD
S PERSON=+PERSON,TIUDA=+TIUDA,CANSEL=1
S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUPRNT=+$P(TIUD0,U,6)
S DICTDT=+$P($G(^TIU(8925,+TIUDA,13)),U,7)
I DICTDT>0 S DICTDT=$P(DICTDT,".")
; Is Docmt an Addendum, a DS?
S TIUTYP=+TIUD0,(TIUPTYP,TIUISAD)=0
I TIUPRNT>0 S TIUPTYP=+$G(^TIU(8925,TIUPRNT,0))
I TIUPTYP>0,$P($G(^TIU(8925.1,TIUTYP,0)),U)["ADDENDUM" S TIUISAD=1
S TIUISDS=+$S('TIUISAD:$$ISDS^TIULX(TIUTYP),1:$$ISDS^TIULX(TIUPTYP))
; A TERMINATED (as of NOW) User may NOT be selected:
I $$ISTERM^USRLM(PERSON) S CANSEL=0 G SCRATTX
; If not DS, is person an active provider?
I 'TIUISDS S:'$$PROVIDER^TIUPXAP1(PERSON,DT) CANSEL=0 G SCRATTX
; TIUDA is a DS:
; Attendings must be in USR Class PROVIDER NOW:
I '$$ISA^USRLM(+PERSON,"PROVIDER") S CANSEL=0 G SCRATTX
; Persons who require Cosignature on Dictation Dt may NOT be selected:
I +$$REQCOSIG^TIULP(TIUTYP,+TIUDA,PERSON,DICTDT) S CANSEL=0
SCRATTX Q +$G(CANSEL)
;
SCRDFCS(USER,Y) ; Screen Default Cosigner selection for USER
N TIUY S TIUY=1
S USER=$G(USER,DUZ)
; A user may NOT select himself
I Y=USER S TIUY=0 G SCRDFX
; A TERMINATED User may NOT be selected
I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX
; A non-PROVIDER may NOT be selected
I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX
SCRDFX Q TIUY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULA3 4576 printed Apr 09, 2024@21:44:50 Page 2
TIULA3 ; SLC/JER - Still more interactive functions ;1/31/08
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**50,79,98,219**;Jun 20, 1997;Build 11
TITLE ; Title Look-up
+1 NEW TIUI,TYPE,TIUCLASS
SET TIUI=0
+2 SET TIUTYP=$NAME(^TMP("TIUTYP",$JOB))
+3 KILL @TIUTYP
+4 IF +$GET(TIUPICT)'>0
QUIT
+5 IF $PIECE($GET(TIUPICT(1)),U,4)="ALL"
Begin DoDot:1
+6 SET TIUCLASS=+$ORDER(^TIU(8925.1,"AD",+$PIECE(TIUPICT(1),U,2),0))
+7 KILL TIUPICT
+8 SET TIUPICT=1
SET TIUPICT(1)="1^"_TIUCLASS_U_$$PNAME^TIULC1(TIUCLASS)
End DoDot:1
+9 FOR
SET TIUI=$ORDER(TIUPICT(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+10 SET TIUCLASS=$PIECE(TIUPICT(TIUI),U,2)
+11 WRITE !!,"For ",$$UP^XLFSTR($$PNAME^TIULC1(TIUCLASS)),": "
+12 DO TITLPICK(.TYPE,TIUCLASS)
End DoDot:1
+13 MERGE @TIUTYP=TYPE
+14 SET Y="ANY"
+15 QUIT
TITLPICK(TIUTYP,CLASS) ; Select multiple titles
+1 NEW TIUI,TYPE,TIUPRMT
SET TIUI=0
+2 WRITE !!,"Please Select the ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS))
+3 WRITE " TITLES to search for:",!
+4 FOR
Begin DoDot:1
+5 KILL TYPE
+6 SET TIUI=TIUI+1
SET TIUPRMT=$JUSTIFY(TIUI,3)_") "
+7 DO DOCSPICK^TIULA2(.TYPE,CLASS,"A",0,TIUPRMT)
+8 IF +TYPE>0
SET TIUTYP=+$GET(TIUTYP)+1
SET TIUTYP(TIUTYP)=$GET(TYPE(1))
+9 IF $TEST
IF $PIECE(TYPE(1),U,4)="SINGLE ITEM"
Begin DoDot:2
+10 WRITE !,"There is only one TITLE under ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS))
+11 SET TYPE=0
End DoDot:2
+12 IF $SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,(+TYPE'>0&'$DATA(TIUTYP)):1,1:0)
SET TIUQUIT=1
End DoDot:1
if +$GET(TYPE)'>0
QUIT
+13 WRITE !
+14 QUIT
ASKTITLE(CLASS,TIUTTL) ; Ask for a different title, same class
+1 NEW TIUY,TIUTYP,DFLT,SCREEN,X,Y
+2 SET DFLT=$$RSLVTITL(TIUTTL)
+3 SET SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",($P(^(0),U)'[""ADDENDUM""),+$$ISA^TIULX(+Y,CLASS),+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)"
+4 SET TIUY=+$$ASKTYP^TIULA2(+CLASS,DFLT,SCREEN,"TITLE: ")
+5 IF +$GET(TIUY)'>0
SET TIUY=TIUTTL
+6 QUIT TIUY
RSLVTITL(TIUTTL) ; Resolve pointers to titles
+1 QUIT $PIECE($GET(^TIU(8925.1,+TIUTTL,0)),U)
ASKSEQ(TIUDFLT) ; Ask preferred sort sequence
+1 NEW TIUPRMT,TIUSET,TIUY
SET TIUDFLT=$GET(TIUDFLT,"D")
+2 SET TIUPRMT="Please Specify Sort Order: "
+3 SET TIUSET="A:ascending (OLDEST FIRST);D:descending (NEWEST FIRST)"
+4 SET TIUY=$$READ^TIUU("SA^"_TIUSET,TIUPRMT,$SELECT(TIUDFLT="A":"ascending",1:"descending"))
+5 QUIT TIUY
DATENOTE(X) ; Ask for date/time of note
+1 NEW %DT,Y
+2 ;S TIUPRMT="DATE/TIME OF NOTE"
+3 ;S TIUY=$$READ^TIUU("D^:NOW:RS",TIUPRMT,$G(DFLT,"NOW"),TIUHLP)
+4 ;I +TIUY W " ",$P(TIUY,U,2)
+5 SET %DT="RSX"
SET %DT(0)="-NOW"
DO ^%DT
+6 IF +Y'>0
Begin DoDot:1
+7 WRITE !,$CHAR(7),"Enter DATE AND TIME of the note [TIME REQUIRED] (future dates prohibited)."
End DoDot:1
+8 QUIT +$GET(Y)
SCRCSNR(TIUDA,Y) ; Evaluate whether a person may be selected to cosign
+1 ; most people may be selected
NEW TIUI,TIUY,TIUD0,TIUD12
SET TIUY=1
+2 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
SET TIUD12=$GET(^TIU(8925,+TIUDA,12))
+3 ; If he requires cosignature for this document a user may NOT select
+4 ; himself
+5 IF +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+$GET(DUZ))
IF (Y=+$GET(DUZ))
SET TIUY=0
GOTO SCREENX
+6 ; A TERMINATED User may NOT be selected
+7 IF +$$ACTIVE^XUSER(+Y)'>0
SET TIUY=0
GOTO SCREENX
+8 ; A non-PROVIDER may NOT be selected
+9 IF +$$PROVIDER^TIUPXAP1(+Y,DT)'>0
SET TIUY=0
GOTO SCREENX
+10 ; Author may NOT be selected
+11 IF Y=+$PIECE(TIUD12,U,2)
SET TIUY=0
GOTO SCREENX
+12 ; Expected Signer may NOT be selected
+13 IF Y=+$PIECE(TIUD12,U,4)
SET TIUY=0
GOTO SCREENX
+14 ; Others who require Cosignature may NOT be selected
+15 IF +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+Y)
SET TIUY=0
SCREENX QUIT +$GET(TIUY)
+1 ;
SCRATT(TIUDA,PERSON) ; Can a person be an Attending for a given docmt?
+1 NEW TIUD0,TIUTYP,CANSEL,DICTDT,TIUISDS,TIUPRNT,TIUPTYP,TIUPD0,TIUISAD
+2 SET PERSON=+PERSON
SET TIUDA=+TIUDA
SET CANSEL=1
+3 SET TIUD0=$GET(^TIU(8925,TIUDA,0))
SET TIUPRNT=+$PIECE(TIUD0,U,6)
+4 SET DICTDT=+$PIECE($GET(^TIU(8925,+TIUDA,13)),U,7)
+5 IF DICTDT>0
SET DICTDT=$PIECE(DICTDT,".")
+6 ; Is Docmt an Addendum, a DS?
+7 SET TIUTYP=+TIUD0
SET (TIUPTYP,TIUISAD)=0
+8 IF TIUPRNT>0
SET TIUPTYP=+$GET(^TIU(8925,TIUPRNT,0))
+9 IF TIUPTYP>0
IF $PIECE($GET(^TIU(8925.1,TIUTYP,0)),U)["ADDENDUM"
SET TIUISAD=1
+10 SET TIUISDS=+$SELECT('TIUISAD:$$ISDS^TIULX(TIUTYP),1:$$ISDS^TIULX(TIUPTYP))
+11 ; A TERMINATED (as of NOW) User may NOT be selected:
+12 IF $$ISTERM^USRLM(PERSON)
SET CANSEL=0
GOTO SCRATTX
+13 ; If not DS, is person an active provider?
+14 IF 'TIUISDS
if '$$PROVIDER^TIUPXAP1(PERSON,DT)
SET CANSEL=0
GOTO SCRATTX
+15 ; TIUDA is a DS:
+16 ; Attendings must be in USR Class PROVIDER NOW:
+17 IF '$$ISA^USRLM(+PERSON,"PROVIDER")
SET CANSEL=0
GOTO SCRATTX
+18 ; Persons who require Cosignature on Dictation Dt may NOT be selected:
+19 IF +$$REQCOSIG^TIULP(TIUTYP,+TIUDA,PERSON,DICTDT)
SET CANSEL=0
SCRATTX QUIT +$GET(CANSEL)
+1 ;
SCRDFCS(USER,Y) ; Screen Default Cosigner selection for USER
+1 NEW TIUY
SET TIUY=1
+2 SET USER=$GET(USER,DUZ)
+3 ; A user may NOT select himself
+4 IF Y=USER
SET TIUY=0
GOTO SCRDFX
+5 ; A TERMINATED User may NOT be selected
+6 IF +$$ACTIVE^XUSER(+Y)'>0
SET TIUY=0
GOTO SCREENX
+7 ; A non-PROVIDER may NOT be selected
+8 IF +$$PROVIDER^TIUPXAP1(+Y,DT)'>0
SET TIUY=0
GOTO SCREENX
SCRDFX QUIT TIUY
