source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURA3.m@ 613

Last change on this file since 613 was 613, checked in by George Lilly, 14 years ago

initial load of WorldVistAEHR
File size: 6.2 KB
Line 
1TIURA3 ; SLC/JER - Review screen actions ; 11/21/07
2 ;;1.0;TEXT INTEGRATION UTILITIES;**220,234**;Jun 20, 1997;Build 6
3 ; Call to ISA^USRLM supported by DBIA 2324
4 ; Call to ISTERM^USRLM supported by DBIA 2712
5EDITCOS ; Edit Expected Cosigner
6 N TIUDA,TIUDATA,TIUCHNG,TIUI,DIROUT,TIUDAARY
7 N TIULST,MSGVERB,TIUXNOD
8 S TIUXNOD=$G(XQORNOD(0))
9 I $P(TIUXNOD,U,3)="EC" W "Edit Cosigner",! S $P(TIUXNOD,U,4)="EC="_$P($P(TIUXNOD,U,4),"==",2)
10 S TIUI=0
11 I '$D(VALMY) D EN^VALM2(TIUXNOD)
12 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT)
13 . N RSTRCTD
14 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI))
15 . D CLEAR^VALM1 W !!,"Editing #",+TIUDATA
16 . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA)
17 . I RSTRCTD D Q
18 . . W !!,$C(7),"Ok, no harm done...",!
19 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause
20 . S TIUDAARY(TIUI)=TIUDA
21 . S TIUCHNG=0
22 . I +$D(^TIU(8925,+TIUDA,0)) D EDITCOS1
23 . I +$G(TIUCHNG) D
24 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI
25 ; -- Update or Rebuild list, restore video: --
26 S TIUCHNG("UPDATE")=1
27 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY
28 S VALMBCK="R"
29 S MSGVERB="edited"
30 D VMSG^TIURS1($G(TIULST),.TIUDAARY,MSGVERB)
31 Q
32EDITCOS1 ; Edit expected cosigner/attending for single record
33 ; Receives TIUDA
34 I '+$G(TIUDA) W !,"No Documents selected." H 2 Q
35 ; Evaluate edit privilege
36 N NODE0,STATUS,OK2CHNG,NODE12,REQCOSIG
37 N ECSIGNER,ESIGNER,OKCLASS,TIUISDS,DA,DR,DIE,X
38 N ALTNODE0,ALTTIUDA,NESIGNR,NECSIGNR,ATTEND,NATTEND,CHKSUM,LNO,MSGNO
39 N CANDO,TIUISCP,TIUISCST,TIUISPN,MSG
40 ; NECSIGNER,NATTEND etc,(N for new) means post-edit. It may not differ
41 ;from the original. It may be null if the original was null.
42 S NODE0=^TIU(8925,TIUDA,0),STATUS=$P(NODE0,U,5),(OK2CHNG,OKCLASS)=1
43 S ALTNODE0=NODE0,ALTTIUDA=TIUDA,NODE12=$G(^TIU(8925,TIUDA,12))
44 I $$ISADDNDM^TIULC1(TIUDA) D
45 . S ALTTIUDA=$P(NODE0,U,6)
46 . S ALTNODE0=^TIU(8925,ALTTIUDA,0)
47 S TIUISDS=$$ISDS^TIULX(+ALTNODE0),TIUISPN=$$ISPN^TIULX(+ALTNODE0)
48 S TIUISCST=$$ISA^TIULX(+ALTNODE0,$$CLASS^TIUCNSLT())
49 S TIUISCP=$$ISA^TIULX(+ALTNODE0,$$CLASS^TIUCP())
50 I 'TIUISDS,'TIUISPN,'TIUISCST,'TIUISCP D G COS1X
51 . S MSG(1,1)=" This action is permitted only for Progress Notes, Discharge"
52 . S MSG(1,2)="Summaries, Clinical Procedures and Consults."
53 I STATUS>6 S MSG(2,1)=" This document has already been Completed!" G COS1X
54 I STATUS<5 S MSG(3,1)=" This document still needs Release or Verification!" G COS1X
55 ; Status = 5 unsigned or 6 uncosigned:
56 ; Try rules for EDIT COSIGNER:
57 S CANDO=$$CANDO^TIULP(TIUDA,"EDIT COSIGNER")
58 I 'CANDO S MSG(4,1)=" "_$P(CANDO,U,2) G:STATUS=6 COS1X
59 ; If docmt is unsigned and EDIT COSIGNER rules failed,
60 ; try EDIT RECORD rules:
61 I STATUS=5,'CANDO D G:'CANDO COS1X
62 . S CANDO=$$CANDO^TIULP(TIUDA,"EDIT RECORD")
63 . I CANDO K MSG(4) Q
64 . S MSG(5,1)=" You are not authorized to edit any aspect of this document."
65 ; User authorized to change Expected Cosigner/attending:
66 S DA=TIUDA,DIE=8925
67 ;
68 ; **Docmt is PN, CP or Consult**
69 I 'TIUISDS D G COS1X
70 . S ESIGNER=$P(NODE12,U,4)
71 . S ECSIGNER=$P(NODE12,U,8)
72 . I ESIGNER'>0 S MSG(6,1)=" This document has no Expected Signer!" Q
73 . S REQCOSIG=$$REQCOSIG^TIULP(+NODE0,+TIUDA,ESIGNER)
74 . ;
75 . ; **Cosig NOT REQUIRED:**
76 . I 'REQCOSIG D Q
77 . . ; Status Uncosigned - Do not permit completion of notes:
78 . . I STATUS=6 D Q
79 . . . S MSG(7,1)=" Cosignature is not currently required. This option cannot be"
80 . . . S MSG(7,2)="used to change document status to COMPLETED. It looks like the author's"
81 . . . S MSG(7,3)="requirement has changed since this document was written."
82 . . . S MSG(7,4)="Please contact your CAC and/or HIMS for assistance."
83 . . ; Unsigned, Has no EC:
84 . . I ECSIGNER']"" S MSG(8,1)=" ?? Cosignature not required." Q
85 . . ; Unsigned, Has EC:
86 . . S MSG(8,1)=" Cosignature not required. Expected Cosigner deleted."
87 . . S DR="1208///@;1506///@" D ^DIE S TIUCHNG=1
88 . . ;
89 . ; **Cosig REQUIRED:**
90 . W !!," You may edit the Expected Cosigner:"
91 . S DR="1208R//;1506////1" D ^DIE
92 . S NECSIGNR=$P(^TIU(8925,TIUDA,12),U,8)
93 . I NECSIGNR']"" D Q
94 . . S MSG(9,1)=" Cosignature is required! Expected Cosigners cannot be alerted "
95 . . S MSG(9,2)="until they are designated. "
96 . . I STATUS=6 S MSG(9,3)="Please designate an Expected Cosigner as soon as possible!!"
97 . I NECSIGNR=ECSIGNER D Q
98 . . W !!," Expected Cosigner not changed." H 1
99 . W !!," Expected Cosigner edited." H 1 S TIUCHNG=1 Q
100 ;
101 ; **Docmt is a Discharge Summary. Attending required: **
102 S ATTEND=$P($G(^TIU(8925,TIUDA,12)),U,9)
103 W !!,"You may edit the Attending Physician:"
104 S DR="1209R//" D ^DIE
105 S NATTEND=$P(^TIU(8925,TIUDA,12),U,9)
106 S MSG("ALERT")=" Attendings cannot be alerted until designated!"
107 I NATTEND']0 S MSG(1,1)=" Attending is Required!",MSG(1,2)=MSG("ALERT") G COS1X
108 ; NATTEND is not null. Does it pass screen from TIU*1*219?
109 ; (Needed even after 219 for ^ or Return with no Attending)
110 ; Overwrite most likely msgs with least likely:
111 I +$$REQCOSIG^TIULP(+NODE0,+TIUDA,NATTEND) S MSG(2,1)=" This person requires a cosignature. Please select a different Attending.",MSG(2,2)=MSG("ALERT")
112 I '$$ISA^USRLM(NATTEND,"PROVIDER") D
113 . K MSG(2)
114 . S MSG(2,1)=" This person is not in User Class PROVIDER. Please check User "
115 . S MSG(2,2)="Class or select a different Attending."
116 . S MSG(2,3)=MSG("ALERT")
117 I $$ISTERM^USRLM(NATTEND) K MSG(2) S MSG(2,1)=" This person is terminated! Please select a different Attending.",MSG(2,2)=MSG("ALERT")
118 ; Att fails. Restore old att:
119 I $D(MSG(2)) D G COS1X
120 . S X=$S((STATUS=5)&(ATTEND']""):"@",1:ATTEND),DR="1209////" D ^DIE
121 ; Attending exists and is good:
122 S NESIGNR=$$WHOSIGNS^TIULC1(DA),NECSIGNR=$$WHOCOSIG^TIULC1(DA)
123 S DR="1204////^S X=NESIGNR"
124 S DR=DR_";1208////^S X=NECSIGNR"
125 S DR=DR_";1506////^S X=$S(+NESIGNR=+NATTEND:0,1:1)"
126 D ^DIE
127 I NATTEND=ATTEND D G COS1X
128 . W !!," Attending Physician not changed." H 1
129 ; New Attend Changed - Go on to audit
130 W !!," Attending Physician edited." S TIUCHNG=1 H 1
131COS1X ;
132 I $G(TIUCHNG) D
133 . D SEND^TIUALRT(TIUDA)
134 . Q:$G(STATUS)'=6 D ; Audit uncosigned docmts only
135 . S CHKSUM=+$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")")
136 . D AUDIT^TIUEDI1(TIUDA,CHKSUM,CHKSUM)
137 I $D(MSG) W ! F MSGNO=1:1:9 D
138 . F LNO=1:1:10 Q:'$D(MSG(MSGNO,LNO)) W !,MSG(MSGNO,LNO)
139 I $D(MSG),$$READ^TIUU("EA","RETURN to continue...")
140 Q
Note: See TracBrowser for help on using the repository browser.