source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPS96.m@ 1582

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