TIUFHA6 ; SLC/MAM - Templates A H J C D X Action TRY ;12/4/97
;;1.0;TEXT INTEGRATION UTILITIES;**5,12**;Jun 20, 1997
;IHS/ITSC/LJF 6/12/2003 - Changed "TRY" action to use visits already created
;
CHECKDEF ; Templates A, C, H, D, X, J Action Try
N INFO,FILEDA,MSG,TIUFXNOD,SUCCESS,NODE0,CLASSFDA,ANCEST,TIUFI,PFILEDA
N SUBS,DTOUT,DIRUT,DIROUT,DETAILS,DODOCMT
S VALMBCK="",TIUFXNOD=$G(XQORNOD(0))
I $P(TIUFXNOD,U,3)="TR" W "Try",! S $P(TIUFXNOD,U,4)="TR="_$P($P(TIUFXNOD,U,4),"==",2)
I $P(TIUFXNOD,U,3)="TRY" W "Try",! S $P(TIUFXNOD,U,4)="TRY="_$P($P(TIUFXNOD,U,4),"==",2)
I $G(TIUFSTMP)="T" W !!,"Action Try not available on items screen.",! H 2 Q
I '$D(TIUFSTMP) D EN^VALM2(TIUFXNOD,"SO") G:'$O(VALMY(0)) CHECX S INFO=$G(^TMP("TIUF1IDX",$J,$O(VALMY(0)))),FILEDA=$P(INFO,U,2) I 'INFO W !!,"Missing List Manager Data; See IRM",! D PAUSE^TIUFXHLX S VALMBCK="Q" G CHECX
I $D(TIUFSTMP) S FILEDA=$P(TIUFINFO,U,2)
S PFILEDA=+$O(^TIU(8925.1,"AD",FILEDA,0)),DETAILS=1
N TIUFCK D CHECK^TIUFLF3(FILEDA,PFILEDA,DETAILS,.TIUFCK)
G:$D(DTOUT) CHECX
; If all OK, Try on Document if Title, and quit:
I TIUFCK W !! D D PAUSE^TIUFXHLX Q:$D(DIRUT) D:$D(^TIU(8925.1,"AT","DOC",FILEDA)) DOCMT(FILEDA) Q
. I $G(TIUFSTMP)="X" W "Boilerplate Text looks OK; no bad/inactive Objects.",! Q
. W $S($D(^TIU(8925.1,"AT","O",FILEDA)):"Object",1:"Entry")," looks OK; no problems found.",!
; If not all OK, write out nonobject problems:
K DIRUT
; If NOT in subtemplate X:
I $G(TIUFSTMP)'="X" F SUBS="F","I","T","C","B","O","S","M","U","A","E","R","V","D","H","N","G","P","DESC" D G:$D(DIRUT) CHECX
. I $D(TIUFCK(SUBS)) S MSG=$S(SUBS="P":"Entry is an ",$D(^TIU(8925.1,"AT","O",FILEDA)):"Faulty Object: ",1:"Faulty Entry: ")_TIUFCK(SUBS) W !!!,MSG,! D PAUSE^TIUFXHLX
; If not all OK, is Object, write out object problems and quit:
I $D(^TIU(8925.1,"AT","O",FILEDA)) D Q
. F SUBS="J","JN","JA","JP" I $D(TIUFCK(SUBS)) S MSG="Faulty Object: "_TIUFCK(SUBS) W !!!,MSG,! D PAUSE^TIUFXHLX Q:$D(DIRUT)
; If not all OK, has Btext problem, then write Btext problem:
; If NOT in subtemplate X or D:
I '$D(TIUFSTMP),$D(TIUFCK("OBJ"))!$D(TIUFCK("OBJINACT")) D
. W !!!,$S($D(TIUFCK("OBJ")):"Faulty Entry: Bad",1:"Inactive")," Object in Boilerplate Text. For details, select",!,"Action BOILERPLATE TEXT, then Action TRY.",! D PAUSE^TIUFXHLX ;template A or H or C
; If in subtemplate X or D:
I $D(TIUFCK("OBJ"))!$D(TIUFCK("OBJINACT")),$G(TIUFSTMP)'="","XD"[$G(TIUFSTMP) D
. K DIRUT N TIUFCK D XCHECK^TIUFLX(FILEDA,0,1,.TIUFCK) Q:$D(DIRUT) D DCHECK^TIUFLX(FILEDA,0,1,.TIUFCK) ; 0 for NOT Silent. XCHECK writes out specific problems for each bad object in Btext.
; If not all OK, no Btext problem, in subtemplate X, then write Btext OK:
I $G(TIUFSTMP)="X",'$D(TIUFCK("OBJ")),'$D(TIUFCK("OBJINACT")) W !!!,"Boilerplate Text looks OK; no bad/inactive Objects",! D PAUSE^TIUFXHLX Q:$D(DIRUT)
; If not all OK, non Btext problem, in subtemplate X, then write Entry itself is faulty:
K TIUFCK("OBJINACT") S DODOCMT=$S($D(TIUFCK)'>9:1,1:0) K TIUFCK("OBJ")
I $G(TIUFSTMP)="X",$D(TIUFCK)>9 W !!!,"Title/Component itself is faulty. For details, exit out of BOILERPLATE TEXT",!,"and TRY entry.",! D PAUSE^TIUFXHLX Q:$D(DIRUT)
; If is Title and inactive object in Btext is the only problem,
; then try on document:
I $D(^TIU(8925.1,"AT","DOC",FILEDA)) I DODOCMT D DOCMT(FILEDA)
CHECX I $D(DTOUT) S VALMBCK="Q"
Q
;
DOCMT(FILEDA) ; Try entry on a document
I $D(DIRUT) Q
D FULL^VALM1
W !!,"Checking Title on a document. You will not be permitted to sign the document,",!,"and the document will be deleted at the end of the check.",!
W !,"Be sure to select a TEST PATIENT since the document will show up on Unsigned",!,"lists while you are editing it.",!
S NODE0=^TIU(8925.1,FILEDA,0) D ANCESTOR^TIUFLF4(FILEDA,NODE0,.ANCEST,0)
S TIUFI=$O(ANCEST(100),-1) S CLASSFDA=$G(ANCEST(TIUFI-1)) I 'CLASSFDA W !!,"Ancestry ERROR; See IRM" D PAUSE^TIUFXHLX
;I CLASSFDA N FPRI,INDEX,TIUASK,VALUE D MAIN^TIUEDIT(CLASSFDA,.SUCCESS,"",FILEDA,1,1) H 1 Q:$D(DTOUT) ;IHS/ITSC/LJF 6/12/2003
I CLASSFDA N FPRI,INDEX,TIUASK,VALUE D MAIN^TIUEDIT(CLASSFDA,.SUCCESS,"",FILEDA,0,1) H 1 Q:$D(DTOUT) ;IHS/ITSC/LJF 6/12/2003
S VALMSG=$$VMSG^TIUFL D RE^VALM4,RESET^TIUFXHLX
Q
;
TIUFHA6 ; SLC/MAM - Templates A H J C D X Action TRY ;12/4/97
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**5,12**;Jun 20, 1997
+2 ;IHS/ITSC/LJF 6/12/2003 - Changed "TRY" action to use visits already created
+3 ;
CHECKDEF ; Templates A, C, H, D, X, J Action Try
+1 NEW INFO,FILEDA,MSG,TIUFXNOD,SUCCESS,NODE0,CLASSFDA,ANCEST,TIUFI,PFILEDA
+2 NEW SUBS,DTOUT,DIRUT,DIROUT,DETAILS,DODOCMT
+3 SET VALMBCK=""
SET TIUFXNOD=$GET(XQORNOD(0))
+4 IF $PIECE(TIUFXNOD,U,3)="TR"
WRITE "Try",!
SET $PIECE(TIUFXNOD,U,4)="TR="_$PIECE($PIECE(TIUFXNOD,U,4),"==",2)
+5 IF $PIECE(TIUFXNOD,U,3)="TRY"
WRITE "Try",!
SET $PIECE(TIUFXNOD,U,4)="TRY="_$PIECE($PIECE(TIUFXNOD,U,4),"==",2)
+6 IF $GET(TIUFSTMP)="T"
WRITE !!,"Action Try not available on items screen.",!
HANG 2
QUIT
+7 IF '$DATA(TIUFSTMP)
DO EN^VALM2(TIUFXNOD,"SO")
IF '$ORDER(VALMY(0))
GOTO CHECX
SET INFO=$GET(^TMP("TIUF1IDX",$JOB,$ORDER(VALMY(0))))
SET FILEDA=$PIECE(INFO,U,2)
IF 'INFO
WRITE !!,"Missing List Manager Data; See IRM",!
DO PAUSE^TIUFXHLX
SET VALMBCK="Q"
GOTO CHECX
+8 IF $DATA(TIUFSTMP)
SET FILEDA=$PIECE(TIUFINFO,U,2)
+9 SET PFILEDA=+$ORDER(^TIU(8925.1,"AD",FILEDA,0))
SET DETAILS=1
+10 NEW TIUFCK
DO CHECK^TIUFLF3(FILEDA,PFILEDA,DETAILS,.TIUFCK)
+11 IF $DATA(DTOUT)
GOTO CHECX
+12 ; If all OK, Try on Document if Title, and quit:
+13 IF TIUFCK
WRITE !!
Begin DoDot:1
+14 IF $GET(TIUFSTMP)="X"
WRITE "Boilerplate Text looks OK; no bad/inactive Objects.",!
QUIT
+15 WRITE $SELECT($DATA(^TIU(8925.1,"AT","O",FILEDA)):"Object",1:"Entry")," looks OK; no problems found.",!
End DoDot:1
DO PAUSE^TIUFXHLX
IF $DATA(DIRUT)
QUIT
IF $DATA(^TIU(8925.1,"AT","DOC",FILEDA))
DO DOCMT(FILEDA)
QUIT
+16 ; If not all OK, write out nonobject problems:
+17 KILL DIRUT
+18 ; If NOT in subtemplate X:
+19 IF $GET(TIUFSTMP)'="X"
FOR SUBS="F","I","T","C","B","O","S","M","U","A","E","R","V","D","H","N","G","P","DESC"
Begin DoDot:1
+20 IF $DATA(TIUFCK(SUBS))
SET MSG=$SELECT(SUBS="P":"Entry is an ",$DATA(^TIU(8925.1,"AT","O",FILEDA)):"Faulty Object: ",1:"Faulty Entry: ")_TIUFCK(SUBS)
WRITE !!!,MSG,!
DO PAUSE^TIUFXHLX
End DoDot:1
IF $DATA(DIRUT)
GOTO CHECX
+21 ; If not all OK, is Object, write out object problems and quit:
+22 IF $DATA(^TIU(8925.1,"AT","O",FILEDA))
Begin DoDot:1
+23 FOR SUBS="J","JN","JA","JP"
IF $DATA(TIUFCK(SUBS))
SET MSG="Faulty Object: "_TIUFCK(SUBS)
WRITE !!!,MSG,!
DO PAUSE^TIUFXHLX
IF $DATA(DIRUT)
QUIT
End DoDot:1
QUIT
+24 ; If not all OK, has Btext problem, then write Btext problem:
+25 ; If NOT in subtemplate X or D:
+26 IF '$DATA(TIUFSTMP)
IF $DATA(TIUFCK("OBJ"))!$DATA(TIUFCK("OBJINACT"))
Begin DoDot:1
+27 ;template A or H or C
WRITE !!!,$SELECT($DATA(TIUFCK("OBJ")):"Faulty Entry: Bad",1:"Inactive")," Object in Boilerplate Text. For details, select",!,"Action BOILERPLATE TEXT, then Action TRY.",!
DO PAUSE^TIUFXHLX
End DoDot:1
+28 ; If in subtemplate X or D:
+29 IF $DATA(TIUFCK("OBJ"))!$DATA(TIUFCK("OBJINACT"))
IF $GET(TIUFSTMP)'=""
IF "XD"[$GET(TIUFSTMP)
Begin DoDot:1
+30 ; 0 for NOT Silent. XCHECK writes out specific problems for each bad object in Btext.
KILL DIRUT
NEW TIUFCK
DO XCHECK^TIUFLX(FILEDA,0,1,.TIUFCK)
IF $DATA(DIRUT)
QUIT
DO DCHECK^TIUFLX(FILEDA,0,1,.TIUFCK)
End DoDot:1
+31 ; If not all OK, no Btext problem, in subtemplate X, then write Btext OK:
+32 IF $GET(TIUFSTMP)="X"
IF '$DATA(TIUFCK("OBJ"))
IF '$DATA(TIUFCK("OBJINACT"))
WRITE !!!,"Boilerplate Text looks OK; no bad/inactive Objects",!
DO PAUSE^TIUFXHLX
IF $DATA(DIRUT)
QUIT
+33 ; If not all OK, non Btext problem, in subtemplate X, then write Entry itself is faulty:
+34 KILL TIUFCK("OBJINACT")
SET DODOCMT=$SELECT($DATA(TIUFCK)'>9:1,1:0)
KILL TIUFCK("OBJ")
+35 IF $GET(TIUFSTMP)="X"
IF $DATA(TIUFCK)>9
WRITE !!!,"Title/Component itself is faulty. For details, exit out of BOILERPLATE TEXT",!,"and TRY entry.",!
DO PAUSE^TIUFXHLX
IF $DATA(DIRUT)
QUIT
+36 ; If is Title and inactive object in Btext is the only problem,
+37 ; then try on document:
+38 IF $DATA(^TIU(8925.1,"AT","DOC",FILEDA))
IF DODOCMT
DO DOCMT(FILEDA)
CHECX IF $DATA(DTOUT)
SET VALMBCK="Q"
+1 QUIT
+2 ;
DOCMT(FILEDA) ; Try entry on a document
+1 IF $DATA(DIRUT)
QUIT
+2 DO FULL^VALM1
+3 WRITE !!,"Checking Title on a document. You will not be permitted to sign the document,",!,"and the document will be deleted at the end of the check.",!
+4 WRITE !,"Be sure to select a TEST PATIENT since the document will show up on Unsigned",!,"lists while you are editing it.",!
+5 SET NODE0=^TIU(8925.1,FILEDA,0)
DO ANCESTOR^TIUFLF4(FILEDA,NODE0,.ANCEST,0)
+6 SET TIUFI=$ORDER(ANCEST(100),-1)
SET CLASSFDA=$GET(ANCEST(TIUFI-1))
IF 'CLASSFDA
WRITE !!,"Ancestry ERROR; See IRM"
DO PAUSE^TIUFXHLX
+7 ;I CLASSFDA N FPRI,INDEX,TIUASK,VALUE D MAIN^TIUEDIT(CLASSFDA,.SUCCESS,"",FILEDA,1,1) H 1 Q:$D(DTOUT) ;IHS/ITSC/LJF 6/12/2003
+8 ;IHS/ITSC/LJF 6/12/2003
IF CLASSFDA
NEW FPRI,INDEX,TIUASK,VALUE
DO MAIN^TIUEDIT(CLASSFDA,.SUCCESS,"",FILEDA,0,1)
HANG 1
IF $DATA(DTOUT)
QUIT
+9 SET VALMSG=$$VMSG^TIUFL
DO RE^VALM4
DO RESET^TIUFXHLX
+10 QUIT
+11 ;
