Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUPS139

TIUPS139.m

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