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

TIUPS96.m

Go to the documentation of this file. 
  1. TIUPS96 ; SLC/JER - Post-Install for TIU*1*96 ; 3-MAY-2001 11:21
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**96**;Jun 20, 1997'
  1. MAIN ; Control unit
  1.  I +$O(^GMR(121,0)),'$D(^XTMP("TIUFIXCS","T1")) D FIXCS
  1.  I +$G(XPDQUES("POS001")) D DELPNDB
  1.  I +$G(XPDQUES("POS002")) D DELDSDB
  1.  D DELFUNC
  1.  Q
  1.  ;
  1. FIXCS ; -- Find/fix Cosigner's Comments
  1.  N GMRDA,XPDIDTOT S GMRDA=+$G(^XTMP("TIUFIXCS","CHKPT"))
  1.  D BMES^XPDUTL("** FIND CONVERTED NOTES WITH COSIGNER'S COMMENTS **")
  1.  S XPDIDTOT=+$P($G(^GMR(121,0)),U,4),XPDIDVT=$G(XPDIDVT,0)
  1.  D UPDATE^XPDID(0)
  1.  ; Initialize ^XTMP("TIUFIXCS"
  1.  S ^XTMP("TIUFIXCS",0)=$$FMADD^XLFDT(DT,90)_U_DT
  1.  S ^XTMP("TIUFIXCS","T0")=$$NOW^XLFDT
  1.  F  S GMRDA=$O(^GMR(121,GMRDA)) Q:+GMRDA'>0  D
  1.  . N GMRLI,GMRLINE,TIUDA,TIULI S GMRLI=0
  1.  . F  S GMRLI=+$O(^GMR(121,GMRDA,8,GMRLI)) Q:GMRLI'>0!($G(GMRLINE)]"")  D
  1.  . . N GMRLN
  1.  . . S GMRLINE=$G(^GMR(121,GMRDA,8,GMRLI,0))
  1.  . . S GMRLN=$$STRIP^TIULS(GMRLINE)
  1.  . . I GMRLN']"" S GMRLINE=""
  1.  . Q:$G(GMRLINE)']""
  1.  . S TIUDA=+$G(^GMR(121,"CNV",GMRDA)) Q:TIUDA'>0
  1.  . S TIULI=$$FIND(TIUDA,GMRLINE) Q:+TIULI'>0
  1.  . D INSERT(TIUDA,TIULI),REGISTER(TIUDA,GMRDA)
  1.  S ^XTMP("TIUFIXCS","T1")=$$NOW^XLFDT
  1.  Q
  1.  ;
  1. FIND(TIUDA,GMRLINE) ; -- Locate the Cosigner's Comments in converted note
  1.  N TIULI,TIUHIT S (TIUHIT,TIULI)=0
  1.  F  S TIULI=$O(^TIU(8925,TIUDA,"TEXT",TIULI)) Q:+TIULI'>0  D  Q:+TIUHIT
  1.  . I $G(^TIU(8925,TIUDA,"TEXT",TIULI,0))=GMRLINE S TIUHIT=1
  1.  Q TIULI
  1.  ;
  1. INSERT(TIUDA,TIULI) ; -- Insert the tag for the Cosigner's Comment
  1.  N TIULJ,TIUSBLK S TIULJ=""
  1.  ; First, preserve the /es/-blocks
  1.  D ESGET(TIUDA,.TIUSBLK)
  1.  ; Next, move the cosigner's comments out of the way
  1.  F  S TIULJ=$O(^TIU(8925,TIUDA,"TEXT",TIULJ),-1) Q:+TIULJ'>0!(TIULJ<TIULI)  D
  1.  . N TIULINE S TIULINE=$G(^TIU(8925,TIUDA,"TEXT",TIULJ,0))
  1.  . S ^TIU(8925,TIUDA,"TEXT",TIULJ+3,0)=TIULINE
  1.  ; Now insert the COSIGNER'S COMMENT: tag
  1.  S ^TIU(8925,TIUDA,"TEXT",TIULI,0)=" "
  1.  S ^TIU(8925,TIUDA,"TEXT",TIULI+1,0)="COSIGNER'S COMMENT:"
  1.  S ^TIU(8925,TIUDA,"TEXT",TIULI+2,0)="==================="
  1.  ; Reset the root of the "TEXT" node
  1.  D SETXT0(TIUDA)
  1.  ; Finally, re-file the /es/-blocks
  1.  D ESPUT(TIUDA,.TIUSBLK)
  1.  Q
  1.  ;
  1. REGISTER(TIUDA,GMRDA) ; -- Register activity in the ^XTMP("TIUFIXCS", array
  1.  N TIUCNT
  1.  S (TIUCNT,^XTMP("TIUFIXCS","COUNT"))=+$G(^XTMP("TIUFIXCS","COUNT"))+1
  1.  S ^XTMP("TIUFIXCS","CHKPT")=GMRDA
  1.  S ^XTMP("TIUFIXCS","GMR->TIU",GMRDA)=TIUDA
  1.  D UPDATE^XPDID(TIUCNT)
  1.  Q
  1.  ;
  1. ESGET(TIUDA,TIUSBLK) ; Get the decrypted /es/-blocks
  1.  N TIUD15,TIUCHK
  1.  S TIUD15=$G(^TIU(8925,TIUDA,15))
  1.  S TIUCHK=$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")
  1.  I $L($P(TIUD15,U,3)) D
  1.  . S $P(TIUSBLK(1),U,1)=$$DECRYPT^TIULC1($P(TIUD15,U,3),1,TIUCHK)
  1.  . S $P(TIUSBLK(1),U,2)=$$DECRYPT^TIULC1($P(TIUD15,U,4),1,TIUCHK)
  1.  I $L($P(TIUD15,U,9)) D
  1.  . S $P(TIUSBLK(2),U,1)=$$DECRYPT^TIULC1($P(TIUD15,U,9),1,TIUCHK)
  1.  . S $P(TIUSBLK(2),U,2)=$$DECRYPT^TIULC1($P(TIUD15,U,10),1,TIUCHK)
  1.  Q
  1.  ;
  1. SETXT0(TIUDA) ; Set the root node of the "TEXT" WP-field
  1.  N TIUC,TIUI S (TIUC,TIUI)=0
  1.  F  S TIUI=$O(^TIU(8925,TIUDA,"TEXT",TIUI)) Q:+TIUI'>0  D
  1.  . S:$D(^TIU(8925,TIUDA,"TEXT",TIUI,0)) TIUC=TIUC+1
  1.  S ^TIU(8925,TIUDA,"TEXT",0)="^^"_TIUC_U_TIUC_U_DT_"^^"
  1.  Q
  1.  ;
  1. ESPUT(DA,TIUSBLK) ; Re-file the /es/-blocks
  1.  N DIE,DR
  1.  S DIE=8925
  1.  ; If the author's signature block exists, file it
  1.  I $D(TIUSBLK(1)) D
  1.  . S DR="1503///^S X=$P(TIUSBLK(1),U);1504///^S X=$P(TIUSBLK(1),U,2)"
  1.  . D ^DIE
  1.  ; If the cosigner's signature block exists, file it
  1.  I $D(TIUSBLK(2)) D
  1.  . S DR="1509///^S X=$P(TIUSBLK(2),U);1510///^S X=$P(TIUSBLK(2),U,2)"
  1.  . D ^DIE
  1.  Q
  1.  ;
  1. DELPNDB ; -- Remove Progress Notes Globals, DD's, and File of File Entries
  1.  N TIUS1,TIUCNT,XPDIDTOT S TIUCNT=0,XPDIDVT=+$G(XPDIDVT)
  1.  D BMES^XPDUTL("** REMOVING PROGRESS NOTES v2.5 DB & DD's **")
  1.  S XPDIDTOT=5 D UPDATE^XPDID(0)
  1.  F TIUS1=121,121.1,121.2,121.3,121.99 D
  1.  . N DIU
  1.  . S DIU="^GMR("_TIUS1_",",DIU(0)="D" D EN^DIU2
  1.  . S TIUCNT=TIUCNT+1 D UPDATE^XPDID(TIUCNT)
  1.  Q
  1.  ;
  1. DELDSDB ; -- Remove Discharge Summary Globals, DD's, and File of File Entries
  1.  N TIUS1,TIUCNT,XPDIDTOT S TIUCNT=0,XPDIDVT=+$G(XPDIDVT)
  1.  D BMES^XPDUTL("** REMOVING DISCHARGE SUMMARY v1.0 DB & DD's **")
  1.  S XPDIDTOT=6 D UPDATE^XPDID(0)
  1.  F TIUS1=128,128.1,128.2,128.3,128.4,128.99 D
  1.  . N DIU
  1.  . S DIU="^GMR("_TIUS1_",",DIU(0)="D" D EN^DIU2
  1.  . S TIUCNT=TIUCNT+1 D UPDATE^XPDID(TIUCNT)
  1.  Q
  1. DELFUNC ; -- Remove Discharge Summary FileMan Functions
  1.  N TIUS1,TIUCNT,XPDIDTOT S TIUCNT=0,XPDIDVT=+$G(XPDIDVT)
  1.  D BMES^XPDUTL("** REMOVING DISCHARGE SUMMARY v1.0 FILEMAN FUNCTIONS **")
  1.  D MES^XPDUTL(" ")
  1.  S XPDIDTOT=3 D UPDATE^XPDID(0)
  1.  F TIUS1="GMRD ISADDENDUM","GMRD NAME FORMAT","GMRD TREAT SPEC NAME" D
  1.  . N DIC,X,Y,DIK,DA,DIDEL
  1.  . S DIC=.5,DIC(0)="X",X=TIUS1 D ^DIC Q:+Y'>0
  1.  . D MES^XPDUTL("Deleting: "_$P(Y,U,2))
  1.  . S (DIDEL,DIK)=DIC,DA=+Y D ^DIK
  1.  . S TIUCNT=TIUCNT+1 D UPDATE^XPDID(TIUCNT)
  1.  Q