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