TIUPS139 ; SLC/AJB - Cleanup for TIU*1*138 ; August 2, 2002
;;1.0;TEXT INTEGRATION UTILITIES;**139**;Jun 20, 1997
;
Q
CLEAN ; control segment
;
N ANS,HDR,RPT,RECS,TMP
;
W @IOF
;
D MKWSDEV Q:$G(ANS("EXIT"))="YES"
;
D ASKUSER(.ANS) Q:$G(ANS("EXIT"))="YES"
;
I ANS("PRINT")="YES" D Q
. K POP N POP,ZTDESC,ZTRTN
. S ZTDESC="TIUPS139 Cleanup Routine",ZTRTN="REPORT^TIUPS139",ZTSAVE("*")=""
. D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE)
;
W !,"Searching..."
D REPORT
W !!
D OUTPUT
EXIT ;
Q
REPORT ;
;
N DA,DR,DIE,ELAPSED,ENTRYDT,POP,SPACER,START,STOP,TIUDA,TIUDT
;
S (RECS("CHK"),RECS("FOUND"),RECS("SEARCHED"),RECS("TOTAL"))=0
;
S START=$$NOW^XLFDT,TIUDA="",TIUDT=ANS("BEGDT")
F S TIUDT=$O(^TIU(8925,"F",TIUDT)) Q:TIUDT=""!(TIUDT>ANS("ENDDT")) F S TIUDA=$O(^TIU(8925,"F",TIUDT,TIUDA)) Q:TIUDA="" S RECS("SEARCHED")=RECS("SEARCHED")+1 I $P($G(^TIU(8925,TIUDA,0)),U,5)=6,$P($G(^TIU(8925,TIUDA,12)),U,8)="" D
. S ENTRYDT=TIUDT
. I +$$REQCOSIG($P($G(^TIU(8925,TIUDA,0)),U),TIUDA,$P($G(^TIU(8925,TIUDA,12)),U,2))=1 D Q
.. S RECS("CHK")=RECS("CHK")+1 S:RECS("CHK")<10 RECS("CHK")="0"_RECS("CHK") S:RECS("CHK")<100 RECS("CHK")="0"_RECS("CHK")
.. S TMP(RECS("CHK")_"C",TIUDA)="",RECS("CHK")=+RECS("CHK")
. S RECS("FOUND")=RECS("FOUND")+1,TMP(RECS("FOUND"),TIUDA)=""
. S DA=TIUDA,DIE="^TIU(8925,",DR=".05////7;1506////0"
. I ANS("UPDATE")="YES" D ^DIE
S RECS("TOTAL")=RECS("FOUND")+RECS("CHK")
S STOP=$$NOW^XLFDT,ELAPSED=$FN($$FMDIFF^XLFDT(START,STOP,2)/60,"-")
;
S HDR(1)="Elapsed Time: "_(ELAPSED\1)_" minute(s) "_($FN((ELAPSED#1)*60,"-",0))_" second(s)"
S HDR(2)="# of Records: "_"Searched "_RECS("SEARCHED")
S SPACER="",$P(SPACER," ",(8-$L(RECS("TOTAL"))))=" "
S HDR(3)=" Found "_RECS("TOTAL")_SPACER_"(STATUS=UNCOSIGNED, EXPECTED COSIGNER="""")"
S SPACER="",$P(SPACER," ",(8-$L(RECS("FOUND"))))=" "
S:ANS("UPDATE")="YES" HDR(4)=" Corrected "_RECS("FOUND")_SPACER_"(COSIGNATURE REQUIRED=NO)"
S:ANS("UPDATE")="NO" HDR(4)=" Unchanged "_RECS("FOUND")_SPACER_"(COSIGNATURE REQUIRED=NO)"
S SPACER="",$P(SPACER," ",(8-$L(RECS("CHK"))))=" "
S:RECS("CHK")>0 HDR(5)=" Unchanged* "_RECS("CHK")_SPACER_"(COSIGNATURE REQUIRED=YES)"
S:RECS("CHK")>0 HDR(6)="",HDR(7)=" * co-signer requirement should be verified"
S HDR(8)=""
S HDR(9)=" Host File Path: "_ANS("PATH")_"TIUPS139.TXT"
S HDR(10)=""
S RPT(1)="Current User: "_($$GET1^DIQ(200,+DUZ,.01))
S RPT(2)="Current Date: "_($$HTE^XLFDT($H))
S RPT(3)="Date range searched: "_($$FMTE^XLFDT(ANS("BEGDT"),"D"))_" - "_($$FMTE^XLFDT(ANS("ENDDT"),"D"))
S RPT(4)=""
S RPT(5)="Count Entry Date/Time"
S RPT(6)="Doc # Title Author/Dictator"
S RPT(7)="----- ----- ---------------"
;
I RECS("TOTAL")=0 S RPT(8)="<NO RECORDS FOUND>",RPT(9)=""
;
N AUTHOR,CNT,NUM,TITLE
;
S CNT=7,RECS=0,(NUM,TIUDA)=""
F S NUM=$O(TMP(NUM)) Q:NUM="" F S TIUDA=$O(TMP(NUM,TIUDA)) Q:TIUDA="" D
. I RECS("FOUND")=0,NUM="001C" S CNT=CNT+1,RPT(CNT)="<NO RECORDS FOUND>",CNT=CNT+1,RPT(CNT)=""
. I NUM="001C" S CNT=CNT+1,RPT(CNT)="** The following records are STATUS=UNCOSIGNED COSIGNATURE REQUIRED=YES **",CNT=CNT+1,RPT(CNT)=""
. S CNT=CNT+1,RECS=RECS+1
. S SPACER="",$P(SPACER," ",(11-$L(RECS)))=" "
. S RPT(CNT)="#"_RECS_SPACER_$$FMTE^XLFDT($P(^TIU(8925,TIUDA,12),U))
. S CNT=CNT+1,TITLE=$E($$GET1^DIQ(8925,TIUDA_",",.01),1,36),AUTHOR=$E($$GET1^DIQ(8925,TIUDA_",",1202),1,28)
. S SPACER="",$P(SPACER," ",(11-$L(TIUDA)))=" "
. S:NUM["C" RPT(CNT)=TIUDA_"*"_SPACER_TITLE
. S:NUM'["C" RPT(CNT)=TIUDA_" "_SPACER_TITLE
. S SPACER="",$P(SPACER," ",(50-$L(RPT(CNT))))=" "
. S RPT(CNT)=RPT(CNT)_SPACER_AUTHOR,CNT=CNT+1,RPT(CNT)=""
;
D:ANS("PRINT")="YES" OUTPUT,^%ZISC
;
D OPEN^%ZISH("TIUPS139",ANS("PATH"),"TIUPS139.TXT","A") Q:POP>0
U IO D OUTPUT
D CLOSE^%ZISH("TIUPS139")
;
S XQA(DUZ)="",XQAMSG="TIUPS139 has finished."
D SETUP^XQALERT
Q
OUTPUT ;
N NUM
S NUM=""
F S NUM=$O(HDR(NUM)) Q:NUM="" W HDR(NUM),!
F S NUM=$O(RPT(NUM)) Q:NUM="" W RPT(NUM),!
S $P(NUM,"-",80)="-" W NUM
Q
;
ASKUSER(ANS) ;
;
N DIR,POP,X,Y
;
; delete the host file and quit?
;
N DELHFS
S DIR(0)="Y"
S DIR("A")="Delete the host file TIUPS139.TXT and QUIT"
S DIR("B")="NO"
S DIR("?")="Entering 'NO' will not delete the host file TIUPS139.TXT and continue."
S DIR("?",1)="Entering 'YES' will delete the host file TIUPS139.TXT and QUIT."
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S ANS("EXIT")="YES" Q
S ANS("DELHFS")=Y(0) W !
I ANS("DELHFS")="YES" D Q
. S DELHFS("TIUPS139.TXT")=""
. S Y=$$DEL^%ZISH(ANS("PATH"),$NA(DELHFS))
. W !,"TIUPS139.TXT has been deleted.",!
. S ANS("EXIT")="YES" ;
;
; date range?
;
N %DT,CNT
S %DT="AE"
F CNT=1:1:2 D
. S %DT("A")=$S(CNT=1:"START WITH REFERENCE DATE: ",CNT=2:" GO TO REFERENCE DATE: ")
. S %DT("B")=$S(CNT=1:"Jan 01, 2001",CNT=2:$P($$HTE^XLFDT($H),"@"))
. D ^%DT
. I Y=-1 S CNT=2,ANS("EXIT")="YES" Q
. I CNT=1 S ANS("BEGDT")=Y
. I CNT=2 S ANS("ENDDT")=Y_".24"
W !
Q:$G(ANS("EXIT"))="YES"
;
; update the documents?
;
S DIR(0)="Y"
S DIR("A")="Update the records at this time"
S DIR("B")="NO"
S DIR("?",1)="Entering 'YES' will find and update the records."
S DIR("?",2)="STATUS will be changed from 'UNCOSIGNED' to 'COMPLETED' and"
S DIR("?",3)="COSIGNATURE NEEDED will be changed to 'NO'."
S DIR("?",4)=""
S DIR("?")="Entering 'NO' will find and report the records without making any changes."
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S ANS("EXIT")="YES" Q
S ANS("UPDATE")=Y(0) W !
;
; print the results?
;
S DIR(0)="Y"
S DIR("A")="Would you like to print or queue the search"
S DIR("B")="YES"
S DIR("?",1)="Entering 'YES' will send the search results to the selected device."
S DIR("?",2)="It will also allow the search to be queued and run at a later time if desired."
S DIR("?",3)=""
S DIR("?",4)="Entering 'NO' will not allow printing or queuing of the search results."
S DIR("?")="The search results will be displayed on the current device."
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S ANS("EXIT")="YES" Q
S ANS("PRINT")=Y(0) W !
;
Q
;
REQCOSIG(TIUTYP,TIUDA,USER) ; Evaluate whether user requires cosignature
N TIUI,TIUY,TIUDPRM S USER=$S(+$G(USER):+$G(USER),1:+$G(DUZ))
D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$G(TIUDA))
I $G(TIUDPRM(5))="" G REQCOSX
F TIUI=1:1:$L(TIUDPRM(5),U) D Q:+TIUY>0
. S TIUY=+$$ISA(+USER,+$P(TIUDPRM(5),U,TIUI))
REQCOSX Q +$G(TIUY)
;
ISA(USER,CLASS,ERR) ; Boolean - Is USER a Member of CLASS?
N USRY,USRI
I $S(CLASS="USER":1,CLASS=+$O(^USR(8930,"B","USER",0)):1,1:0) S USRY=1 G ISAX
I '+USER S USER=+$O(^VA(200,"B",USER,0))
I +USER'>0 S ERR="INVALID USER" Q 0
I '+CLASS S CLASS=+$O(^USR(8930,"B",CLASS,0))
I +CLASS'>0 S ERR="INVALID USER CLASS" Q 0
; If USER is a member of CLASS return true
S USRY=0
I +$D(^USR(8930.3,"AUC",USER,CLASS)) D
. N USRMDA
. S USRMDA=0
. F S USRMDA=+$O(^USR(8930.3,"AUC",USER,CLASS,USRMDA)) Q:((+USRMDA'>0)!(USRY)) D
.. S USRY=+$$CURRENT(USRMDA)
I USRY Q USRY
; Otherwise, check to see if user is a member of any subclass of CLASS
S USRI=0
F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0!+$G(USRY) D
. N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
. S USRY=$$ISA(USER,USRSUB) ; Recurs to find members of subclass
ISAX Q +$G(USRY)
;
CURRENT(MEMBER) ; Boolean - Is Membership current?
N USRIN,USROUT,USRY
S USRIN=+$P($G(^USR(8930.3,+MEMBER,0)),U,3)
S USROUT=+$P($G(^USR(8930.3,+MEMBER,0)),U,4)
I USRIN'>ENTRYDT,$S(USROUT>0&(USROUT'<ENTRYDT):1,USROUT=0:1,1:0) S USRY=1
E S USRY=0
Q USRY
;
MKWSDEV ;
;
I +$$FIND1^DIC(3.5,"","MX","TIUPS139 WORKSTATION")>0 S ANS("PATH")=$$PWD^%ZISH Q
;
N FDA,FDAIEN,MSG
S FDA(3.5,"+1,",.01)="TIUPS139 WORKSTATION"
S FDA(3.5,"+1,",.02)="TIUPS139 Workstation HFS Device" ; location
S FDA(3.5,"+1,",1)="TIUPS139.DAT" ;$I
S FDA(3.5,"+1,",1.95)=0 ; sign-on/system device
S FDA(3.5,"+1,",2)="HFS" ; type
S FDA(3.5,"+1,",3)=$$FIND1^DIC(3.2,"","MX","P-OTHER") ; subtype
S FDA(3.5,"+1,",4)=0 ; ask device
S FDA(3.5,"+1,",5)=0 ; ask parameters
S FDA(3.5,"+1,",5.1)=0 ; ask host file
S FDA(3.5,"+1,",5.2)=0 ; ask hfs i/o operation
D UPDATE^DIE("","FDA","FDAIEN","MSG")
I $D(MSG) D Q
. W !,"Workstation device creation failed."
. S ANS("EXIT")="YES"
S ANS("PATH")=$$PWD^%ZISH
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPS139 8584 printed Apr 09, 2024@21:42:39 Page 2
TIUPS139 ; SLC/AJB - Cleanup for TIU*1*138 ; August 2, 2002
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**139**;Jun 20, 1997
+2 ;
+3 QUIT
CLEAN ; control segment
+1 ;
+2 NEW ANS,HDR,RPT,RECS,TMP
+3 ;
+4 WRITE @IOF
+5 ;
+6 DO MKWSDEV
if $GET(ANS("EXIT"))="YES"
QUIT
+7 ;
+8 DO ASKUSER(.ANS)
if $GET(ANS("EXIT"))="YES"
QUIT
+9 ;
+10 IF ANS("PRINT")="YES"
Begin DoDot:1
+11 KILL POP
NEW POP,ZTDESC,ZTRTN
+12 SET ZTDESC="TIUPS139 Cleanup Routine"
SET ZTRTN="REPORT^TIUPS139"
SET ZTSAVE("*")=""
+13 DO EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE)
End DoDot:1
QUIT
+14 ;
+15 WRITE !,"Searching..."
+16 DO REPORT
+17 WRITE !!
+18 DO OUTPUT
EXIT ;
+1 QUIT
REPORT ;
+1 ;
+2 NEW DA,DR,DIE,ELAPSED,ENTRYDT,POP,SPACER,START,STOP,TIUDA,TIUDT
+3 ;
+4 SET (RECS("CHK"),RECS("FOUND"),RECS("SEARCHED"),RECS("TOTAL"))=0
+5 ;
+6 SET START=$$NOW^XLFDT
SET TIUDA=""
SET TIUDT=ANS("BEGDT")
+7 FOR
SET TIUDT=$ORDER(^TIU(8925,"F",TIUDT))
if TIUDT=""!(TIUDT>ANS("ENDDT"))
QUIT
FOR
SET TIUDA=$ORDER(^TIU(8925,"F",TIUDT,TIUDA))
if TIUDA=""
QUIT
SET RECS("SEARCHED")=RECS("SEARCHED")+1
IF $PIECE($GET(^TIU(8925,TIUDA,0)),U,5)=6
IF $PIECE($GET(^TIU(8925,TIUDA,12)),U,8)=""
Begin DoDot:1
+8 SET ENTRYDT=TIUDT
+9 IF +$$REQCOSIG($PIECE($GET(^TIU(8925,TIUDA,0)),U),TIUDA,$PIECE($GET(^TIU(8925,TIUDA,12)),U,2))=1
Begin DoDot:2
+10 SET RECS("CHK")=RECS("CHK")+1
if RECS("CHK")<10
SET RECS("CHK")="0"_RECS("CHK")
if RECS("CHK")<100
SET RECS("CHK")="0"_RECS("CHK")
+11 SET TMP(RECS("CHK")_"C",TIUDA)=""
SET RECS("CHK")=+RECS("CHK")
End DoDot:2
QUIT
+12 SET RECS("FOUND")=RECS("FOUND")+1
SET TMP(RECS("FOUND"),TIUDA)=""
+13 SET DA=TIUDA
SET DIE="^TIU(8925,"
SET DR=".05////7;1506////0"
+14 IF ANS("UPDATE")="YES"
DO ^DIE
End DoDot:1
+15 SET RECS("TOTAL")=RECS("FOUND")+RECS("CHK")
+16 SET STOP=$$NOW^XLFDT
SET ELAPSED=$FNUMBER($$FMDIFF^XLFDT(START,STOP,2)/60,"-")
+17 ;
+18 SET HDR(1)="Elapsed Time: "_(ELAPSED\1)_" minute(s) "_($FNUMBER((ELAPSED#1)*60,"-",0))_" second(s)"
+19 SET HDR(2)="# of Records: "_"Searched "_RECS("SEARCHED")
+20 SET SPACER=""
SET $PIECE(SPACER," ",(8-$LENGTH(RECS("TOTAL"))))=" "
+21 SET HDR(3)=" Found "_RECS("TOTAL")_SPACER_"(STATUS=UNCOSIGNED, EXPECTED COSIGNER="""")"
+22 SET SPACER=""
SET $PIECE(SPACER," ",(8-$LENGTH(RECS("FOUND"))))=" "
+23 if ANS("UPDATE")="YES"
SET HDR(4)=" Corrected "_RECS("FOUND")_SPACER_"(COSIGNATURE REQUIRED=NO)"
+24 if ANS("UPDATE")="NO"
SET HDR(4)=" Unchanged "_RECS("FOUND")_SPACER_"(COSIGNATURE REQUIRED=NO)"
+25 SET SPACER=""
SET $PIECE(SPACER," ",(8-$LENGTH(RECS("CHK"))))=" "
+26 if RECS("CHK")>0
SET HDR(5)=" Unchanged* "_RECS("CHK")_SPACER_"(COSIGNATURE REQUIRED=YES)"
+27 if RECS("CHK")>0
SET HDR(6)=""
SET HDR(7)=" * co-signer requirement should be verified"
+28 SET HDR(8)=""
+29 SET HDR(9)=" Host File Path: "_ANS("PATH")_"TIUPS139.TXT"
+30 SET HDR(10)=""
+31 SET RPT(1)="Current User: "_($$GET1^DIQ(200,+DUZ,.01))
+32 SET RPT(2)="Current Date: "_($$HTE^XLFDT($HOROLOG))
+33 SET RPT(3)="Date range searched: "_($$FMTE^XLFDT(ANS("BEGDT"),"D"))_" - "_($$FMTE^XLFDT(ANS("ENDDT"),"D"))
+34 SET RPT(4)=""
+35 SET RPT(5)="Count Entry Date/Time"
+36 SET RPT(6)="Doc # Title Author/Dictator"
+37 SET RPT(7)="----- ----- ---------------"
+38 ;
+39 IF RECS("TOTAL")=0
SET RPT(8)="<NO RECORDS FOUND>"
SET RPT(9)=""
+40 ;
+41 NEW AUTHOR,CNT,NUM,TITLE
+42 ;
+43 SET CNT=7
SET RECS=0
SET (NUM,TIUDA)=""
+44 FOR
SET NUM=$ORDER(TMP(NUM))
if NUM=""
QUIT
FOR
SET TIUDA=$ORDER(TMP(NUM,TIUDA))
if TIUDA=""
QUIT
Begin DoDot:1
+45 IF RECS("FOUND")=0
IF NUM="001C"
SET CNT=CNT+1
SET RPT(CNT)="<NO RECORDS FOUND>"
SET CNT=CNT+1
SET RPT(CNT)=""
+46 IF NUM="001C"
SET CNT=CNT+1
SET RPT(CNT)="** The following records are STATUS=UNCOSIGNED COSIGNATURE REQUIRED=YES **"
SET CNT=CNT+1
SET RPT(CNT)=""
+47 SET CNT=CNT+1
SET RECS=RECS+1
+48 SET SPACER=""
SET $PIECE(SPACER," ",(11-$LENGTH(RECS)))=" "
+49 SET RPT(CNT)="#"_RECS_SPACER_$$FMTE^XLFDT($PIECE(^TIU(8925,TIUDA,12),U))
+50 SET CNT=CNT+1
SET TITLE=$EXTRACT($$GET1^DIQ(8925,TIUDA_",",.01),1,36)
SET AUTHOR=$EXTRACT($$GET1^DIQ(8925,TIUDA_",",1202),1,28)
+51 SET SPACER=""
SET $PIECE(SPACER," ",(11-$LENGTH(TIUDA)))=" "
+52 if NUM["C"
SET RPT(CNT)=TIUDA_"*"_SPACER_TITLE
+53 if NUM'["C"
SET RPT(CNT)=TIUDA_" "_SPACER_TITLE
+54 SET SPACER=""
SET $PIECE(SPACER," ",(50-$LENGTH(RPT(CNT))))=" "
+55 SET RPT(CNT)=RPT(CNT)_SPACER_AUTHOR
SET CNT=CNT+1
SET RPT(CNT)=""
End DoDot:1
+56 ;
+57 if ANS("PRINT")="YES"
DO OUTPUT
DO ^%ZISC
+58 ;
+59 DO OPEN^%ZISH("TIUPS139",ANS("PATH"),"TIUPS139.TXT","A")
if POP>0
QUIT
+60 USE IO
DO OUTPUT
+61 DO CLOSE^%ZISH("TIUPS139")
+62 ;
+63 SET XQA(DUZ)=""
SET XQAMSG="TIUPS139 has finished."
+64 DO SETUP^XQALERT
+65 QUIT
OUTPUT ;
+1 NEW NUM
+2 SET NUM=""
+3 FOR
SET NUM=$ORDER(HDR(NUM))
if NUM=""
QUIT
WRITE HDR(NUM),!
+4 FOR
SET NUM=$ORDER(RPT(NUM))
if NUM=""
QUIT
WRITE RPT(NUM),!
+5 SET $PIECE(NUM,"-",80)="-"
WRITE NUM
+6 QUIT
+7 ;
ASKUSER(ANS) ;
+1 ;
+2 NEW DIR,POP,X,Y
+3 ;
+4 ; delete the host file and quit?
+5 ;
+6 NEW DELHFS
+7 SET DIR(0)="Y"
+8 SET DIR("A")="Delete the host file TIUPS139.TXT and QUIT"
+9 SET DIR("B")="NO"
+10 SET DIR("?")="Entering 'NO' will not delete the host file TIUPS139.TXT and continue."
+11 SET DIR("?",1)="Entering 'YES' will delete the host file TIUPS139.TXT and QUIT."
+12 DO ^DIR
+13 IF $DATA(DUOUT)!($DATA(DTOUT))
SET ANS("EXIT")="YES"
QUIT
+14 SET ANS("DELHFS")=Y(0)
WRITE !
+15 IF ANS("DELHFS")="YES"
Begin DoDot:1
+16 SET DELHFS("TIUPS139.TXT")=""
+17 SET Y=$$DEL^%ZISH(ANS("PATH"),$NAME(DELHFS))
+18 WRITE !,"TIUPS139.TXT has been deleted.",!
+19 ;
SET ANS("EXIT")="YES"
End DoDot:1
QUIT
+20 ;
+21 ; date range?
+22 ;
+23 NEW %DT,CNT
+24 SET %DT="AE"
+25 FOR CNT=1:1:2
Begin DoDot:1
+26 SET %DT("A")=$SELECT(CNT=1:"START WITH REFERENCE DATE: ",CNT=2:" GO TO REFERENCE DATE: ")
+27 SET %DT("B")=$SELECT(CNT=1:"Jan 01, 2001",CNT=2:$PIECE($$HTE^XLFDT($HOROLOG),"@"))
+28 DO ^%DT
+29 IF Y=-1
SET CNT=2
SET ANS("EXIT")="YES"
QUIT
+30 IF CNT=1
SET ANS("BEGDT")=Y
+31 IF CNT=2
SET ANS("ENDDT")=Y_".24"
End DoDot:1
+32 WRITE !
+33 if $GET(ANS("EXIT"))="YES"
QUIT
+34 ;
+35 ; update the documents?
+36 ;
+37 SET DIR(0)="Y"
+38 SET DIR("A")="Update the records at this time"
+39 SET DIR("B")="NO"
+40 SET DIR("?",1)="Entering 'YES' will find and update the records."
+41 SET DIR("?",2)="STATUS will be changed from 'UNCOSIGNED' to 'COMPLETED' and"
+42 SET DIR("?",3)="COSIGNATURE NEEDED will be changed to 'NO'."
+43 SET DIR("?",4)=""
+44 SET DIR("?")="Entering 'NO' will find and report the records without making any changes."
+45 DO ^DIR
+46 IF $DATA(DUOUT)!($DATA(DTOUT))
SET ANS("EXIT")="YES"
QUIT
+47 SET ANS("UPDATE")=Y(0)
WRITE !
+48 ;
+49 ; print the results?
+50 ;
+51 SET DIR(0)="Y"
+52 SET DIR("A")="Would you like to print or queue the search"
+53 SET DIR("B")="YES"
+54 SET DIR("?",1)="Entering 'YES' will send the search results to the selected device."
+55 SET DIR("?",2)="It will also allow the search to be queued and run at a later time if desired."
+56 SET DIR("?",3)=""
+57 SET DIR("?",4)="Entering 'NO' will not allow printing or queuing of the search results."
+58 SET DIR("?")="The search results will be displayed on the current device."
+59 DO ^DIR
+60 IF $DATA(DUOUT)!($DATA(DTOUT))
SET ANS("EXIT")="YES"
QUIT
+61 SET ANS("PRINT")=Y(0)
WRITE !
+62 ;
+63 QUIT
+64 ;
REQCOSIG(TIUTYP,TIUDA,USER) ; Evaluate whether user requires cosignature
+1 NEW TIUI,TIUY,TIUDPRM
SET USER=$SELECT(+$GET(USER):+$GET(USER),1:+$GET(DUZ))
+2 DO DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$GET(TIUDA))
+3 IF $GET(TIUDPRM(5))=""
GOTO REQCOSX
+4 FOR TIUI=1:1:$LENGTH(TIUDPRM(5),U)
Begin DoDot:1
+5 SET TIUY=+$$ISA(+USER,+$PIECE(TIUDPRM(5),U,TIUI))
End DoDot:1
if +TIUY>0
QUIT
REQCOSX QUIT +$GET(TIUY)
+1 ;
ISA(USER,CLASS,ERR) ; Boolean - Is USER a Member of CLASS?
+1 NEW USRY,USRI
+2 IF $SELECT(CLASS="USER":1,CLASS=+$ORDER(^USR(8930,"B","USER",0)):1,1:0)
SET USRY=1
GOTO ISAX
+3 IF '+USER
SET USER=+$ORDER(^VA(200,"B",USER,0))
+4 IF +USER'>0
SET ERR="INVALID USER"
QUIT 0
+5 IF '+CLASS
SET CLASS=+$ORDER(^USR(8930,"B",CLASS,0))
+6 IF +CLASS'>0
SET ERR="INVALID USER CLASS"
QUIT 0
+7 ; If USER is a member of CLASS return true
+8 SET USRY=0
+9 IF +$DATA(^USR(8930.3,"AUC",USER,CLASS))
Begin DoDot:1
+10 NEW USRMDA
+11 SET USRMDA=0
+12 FOR
SET USRMDA=+$ORDER(^USR(8930.3,"AUC",USER,CLASS,USRMDA))
if ((+USRMDA'>0)!(USRY))
QUIT
Begin DoDot:2
+13 SET USRY=+$$CURRENT(USRMDA)
End DoDot:2
End DoDot:1
+14 IF USRY
QUIT USRY
+15 ; Otherwise, check to see if user is a member of any subclass of CLASS
+16 SET USRI=0
+17 FOR
SET USRI=$ORDER(^USR(8930,+CLASS,1,USRI))
if +USRI'>0!+$GET(USRY)
QUIT
Begin DoDot:1
+18 NEW USRSUB
SET USRSUB=+$GET(^USR(8930,+CLASS,1,USRI,0))
if +USRSUB'>0
QUIT
+19 ; Recurs to find members of subclass
SET USRY=$$ISA(USER,USRSUB)
End DoDot:1
ISAX QUIT +$GET(USRY)
+1 ;
CURRENT(MEMBER) ; Boolean - Is Membership current?
+1 NEW USRIN,USROUT,USRY
+2 SET USRIN=+$PIECE($GET(^USR(8930.3,+MEMBER,0)),U,3)
+3 SET USROUT=+$PIECE($GET(^USR(8930.3,+MEMBER,0)),U,4)
+4 IF USRIN'>ENTRYDT
IF $SELECT(USROUT>0&(USROUT'<ENTRYDT):1,USROUT=0:1,1:0)
SET USRY=1
+5 IF '$TEST
SET USRY=0
+6 QUIT USRY
+7 ;
MKWSDEV ;
+1 ;
+2 IF +$$FIND1^DIC(3.5,"","MX","TIUPS139 WORKSTATION")>0
SET ANS("PATH")=$$PWD^%ZISH
QUIT
+3 ;
+4 NEW FDA,FDAIEN,MSG
+5 SET FDA(3.5,"+1,",.01)="TIUPS139 WORKSTATION"
+6 ; location
SET FDA(3.5,"+1,",.02)="TIUPS139 Workstation HFS Device"
+7 ;$I
SET FDA(3.5,"+1,",1)="TIUPS139.DAT"
+8 ; sign-on/system device
SET FDA(3.5,"+1,",1.95)=0
+9 ; type
SET FDA(3.5,"+1,",2)="HFS"
+10 ; subtype
SET FDA(3.5,"+1,",3)=$$FIND1^DIC(3.2,"","MX","P-OTHER")
+11 ; ask device
SET FDA(3.5,"+1,",4)=0
+12 ; ask parameters
SET FDA(3.5,"+1,",5)=0
+13 ; ask host file
SET FDA(3.5,"+1,",5.1)=0
+14 ; ask hfs i/o operation
SET FDA(3.5,"+1,",5.2)=0
+15 DO UPDATE^DIE("","FDA","FDAIEN","MSG")
+16 IF $DATA(MSG)
Begin DoDot:1
+17 WRITE !,"Workstation device creation failed."
+18 SET ANS("EXIT")="YES"
End DoDot:1
QUIT
+19 SET ANS("PATH")=$$PWD^%ZISH
+20 QUIT
