Changeset 623 for WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- Location:
- WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU
- Files:
-
- 42 edited
-
TIUDD1.m (modified) (1 diff)
-
TIUEDS.m (modified) (5 diffs)
-
TIUEDS1.m (modified) (1 diff)
-
TIUEDS10.m (modified) (1 diff)
-
TIUEDS11.m (modified) (1 diff)
-
TIUEDS12.m (modified) (1 diff)
-
TIUEDS13.m (modified) (1 diff)
-
TIUEDS14.m (modified) (1 diff)
-
TIUEDS2.m (modified) (1 diff)
-
TIUEDS3.m (modified) (1 diff)
-
TIUEDS4.m (modified) (1 diff)
-
TIUEDS5.m (modified) (2 diffs)
-
TIUEDS6.m (modified) (1 diff)
-
TIUEDS7.m (modified) (1 diff)
-
TIUEDS8.m (modified) (1 diff)
-
TIUEDS9.m (modified) (1 diff)
-
TIUFLF4.m (modified) (1 diff)
-
TIUHL7.m (modified) (1 diff)
-
TIUHL7A.m (modified) (1 diff)
-
TIUHL7P1.m (modified) (1 diff)
-
TIUHL7P2.m (modified) (1 diff)
-
TIUHL7U1.m (modified) (1 diff)
-
TIULA3.m (modified) (1 diff)
-
TIULMED.m (modified) (1 diff)
-
TIULP.m (modified) (1 diff)
-
TIULX.m (modified) (1 diff)
-
TIUPREL.m (modified) (3 diffs)
-
TIUPRPN1.m (modified) (1 diff)
-
TIUPRPN8.m (modified) (1 diff)
-
TIUR.m (modified) (1 diff)
-
TIURA3.m (modified) (1 diff)
-
TIURB.m (modified) (1 diff)
-
TIURL.m (modified) (1 diff)
-
TIURM.m (modified) (1 diff)
-
TIUSRVA.m (modified) (1 diff)
-
TIUSRVP1.m (modified) (1 diff)
-
TIUSRVR2.m (modified) (1 diff)
-
TIUXRC.m (modified) (3 diffs)
-
TIUXRC1.m (modified) (2 diffs)
-
TIUXRC2.m (modified) (2 diffs)
-
TIUXRC3.m (modified) (1 diff)
-
TIUXRC4.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD1.m
r613 r623 1 TIUDD1 ; SLC/JER - XREFs for file 8925.1 ;19-OCT-2001 10:05:37 [7/28/04 9:08am] 2 ;;1.0;TEXT INTEGRATION UTILITIES;**7,51,115,163,224**;Jun 20, 1997;Build 7 3 SACL(X,FLD) ; Set logic for ACL cross-reference 4 ; Called from fields .01 (NAME), .07 (STATUS), .03 (PRINT NAME), 5 ; .02 (ABBREVIATION), and Subfield .01 of ITEM sub-file 6 N TIUCLASS,TIUSTTS,TIUTTL 7 I FLD=10.01 D 8 . ; Include only TITLES in the index 9 . I $P($G(^TIU(8925.1,+X,0)),U,4)'="DOC" Q 10 . S TIUSTTS=$P($G(^TIU(8925.1,+X,0)),U,7) 11 . ; Include only TEST or ACTIVE titles 12 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q 13 . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U) 14 . Q:TIUTTL']"" 15 . ; First build x-ref for Clinical Documents & Immediate descendents 16 . S TIUCLASS=+$$CLINDOC^TIULC1(+X) 17 . I TIUCLASS'>0 Q 18 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)="" 19 . S ^TIU(8925.1,"ACL",38,TIUTTL,+X)="" 20 . D SACLKWIC(TIUTTL,TIUCLASS,+X) 21 . ; Now build x-ref for document classes 22 . S TIUCLASS=+$$DOCCLASS^TIULC1(+X) 23 . I TIUCLASS'>0 Q 24 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)="" 25 . D SACLKWIC(TIUTTL,TIUCLASS,+X) 26 ; For Abbreviation and Print Name fields, just set the Synonym subscript 27 I $S(FLD=.02:1,FLD=.03:1,1:0) D Q 28 . N TIUDA 29 . Q:X']"" 30 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 31 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q 32 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) 33 . ;VMPELR P 224 allow the update of inactive titles 34 . ; Include only TEST or ACTIVE or INACTIVE TITLES 35 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q 36 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) 37 . Q:TIUTTL']"" 38 . S X=$$UP^XLFSTR(X) 39 . Q:X=TIUTTL 40 . S TIUTTL=X_" <"_TIUTTL_">" 41 . ; First build x-ref for Clinical Documents & Immediate descendents 42 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 43 . I TIUCLASS'>0 Q 44 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" 45 . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)="" 46 . ; Now build x-ref for document classes 47 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 48 . I TIUCLASS'>0 Q 49 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" 50 I FLD=.07 D Q 51 . N TIUDA 52 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 53 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q 54 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) 55 . ; Include only TEST or ACTIVE titles 56 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q 57 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) 58 . Q:TIUTTL']"" 59 . ; First build x-ref for Clinical Documents & Immediate descendents 60 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 61 . I TIUCLASS'>0 Q 62 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" 63 . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)="" 64 . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA) 65 . ; Now build x-ref for document classes 66 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 67 . I TIUCLASS'>0 Q 68 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" 69 . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA) 70 I FLD=.01 D 71 . N TIUDA 72 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 73 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q 74 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) 75 . ; Include only TEST or ACTIVE OR inactive titles 76 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q 77 . ; First build x-ref for Clinical Documents & Immediate descendents 78 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 79 . I TIUCLASS'>0 Q 80 . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)="" 81 . S ^TIU(8925.1,"ACL",38,X,+TIUDA)="" 82 . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2) 83 . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)="" 84 . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3) 85 . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)="" 86 . D SACLKWIC(X,TIUCLASS,+TIUDA) 87 . ; Now build x-ref for document classes 88 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 89 . I TIUCLASS'>0 Q 90 . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)="" 91 . ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES 92 . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2) 93 . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)="" 94 . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3) 95 . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)="" 96 . D SACLKWIC(X,TIUCLASS,+TIUDA) 97 Q 98 SACLKWIC(X,TIUCLASS,TIUDA) ; Set logic for KWIC analog 99 N TIUI,TIUJ,TIUC S TIUI=1 100 F TIUJ=1:1:$L(X)+1 D 101 . S TIUC=$E(X,TIUJ) 102 . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1 103 . I I $L(TIUC)>2,(^DD("KWIC")'[TIUC),(TIUC'=X) S (^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA))="" 104 Q 105 KACL(X,FLD) ; KILL Logic for ACL cross-reference 106 N TIUCLASS,TIUTTL,TIUDA 107 I FLD=10.01 D 108 . ; First remove x-ref for Clinical Documents & Immediate descendents 109 . S TIUCLASS=+$$CLINDOC^TIULC1(+X) 110 . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U) 111 . Q:TIUTTL']"" 112 . Q:X=TIUTTL 113 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X) 114 . K ^TIU(8925.1,"ACL",38,TIUTTL,+X) 115 . D KACLKWIC(TIUTTL,TIUCLASS,+X) 116 . ; Now remove x-ref for document classes 117 . S TIUCLASS=+$$DOCCLASS^TIULC1(+X) 118 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X) 119 . D KACLKWIC(TIUTTL,TIUCLASS,+X) 120 I $S(FLD=.02:1,FLD=.03:1,1:0) D Q 121 . N TIUDA 122 . Q:X']"" 123 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 124 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q 125 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) 126 . ; Include only TEST or ACTIVE or INACTIVE titles 127 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q 128 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) 129 . Q:TIUTTL']"" 130 . S TIUTTL=X_" <"_TIUTTL_">" 131 . ; First build x-ref for Clinical Documents & Immediate descendents 132 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 133 . I TIUCLASS'>0 Q 134 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) 135 . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA) 136 . ; Now build x-ref for document classes 137 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 138 . I TIUCLASS'>0 Q 139 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) 140 I FLD=.07 D 141 . N TIUDA 142 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 143 . ; First remove x-ref for Clinical Documents & Immediate descendents 144 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 145 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) 146 . Q:TIUTTL']"" 147 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) 148 . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA) 149 . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA) 150 . ; Now remove x-ref for document classes 151 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 152 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) 153 . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA) 154 I FLD=.01 D 155 . N TIUDA,TIUABV,TIUPN 156 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 157 . ; First remove x-ref for Clinical Documents & Immediate descendents 158 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 159 . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA) 160 . K ^TIU(8925.1,"ACL",38,X,+TIUDA) 161 . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2) 162 . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA),^TIU(8925.1,"ACL",38,TIUABV,+TIUDA) 163 . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3) 164 . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA),^TIU(8925.1,"ACL",38,TIUPN,+TIUDA) 165 . D KACLKWIC(X,TIUCLASS,+TIUDA) 166 . ; Now remove x-ref for document classes 167 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 168 . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA) 169 . ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES 170 . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2) 171 . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA) 172 . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3) 173 . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA) 174 . D KACLKWIC(X,TIUCLASS,+TIUDA) 175 Q 176 KACLKWIC(X,TIUCLASS,TIUDA) ; KILL Logic for KWIC analog 177 N TIUI,TIUJ,TIUC S TIUI=1 178 F TIUJ=1:1:$L(X)+1 D 179 . S TIUC=$E(X,TIUJ) 180 . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1 181 . I I $L(TIUC)>2 K ^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA) 182 Q 1 TIUDD1 ; SLC/JER - XREFs for file 8925.1 ;19-OCT-2001 10:05:37 [7/28/04 9:08am] 2 ;;1.0;TEXT INTEGRATION UTILITIES;**7,51,115,163**;Jun 20, 1997 3 SACL(X,FLD) ; Set logic for ACL cross-reference 4 ; Called from fields .01 (NAME), .07 (STATUS), .03 (PRINT NAME), 5 ; .02 (ABBREVIATION), and Subfield .01 of ITEM sub-file 6 N TIUCLASS,TIUSTTS,TIUTTL 7 I FLD=10.01 D 8 . ; Include only TITLES in the index 9 . I $P($G(^TIU(8925.1,+X,0)),U,4)'="DOC" Q 10 . S TIUSTTS=$P($G(^TIU(8925.1,+X,0)),U,7) 11 . ; Include only TEST or ACTIVE titles 12 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q 13 . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U) 14 . Q:TIUTTL']"" 15 . ; First build x-ref for Clinical Documents & Immediate descendents 16 . S TIUCLASS=+$$CLINDOC^TIULC1(+X) 17 . I TIUCLASS'>0 Q 18 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)="" 19 . S ^TIU(8925.1,"ACL",38,TIUTTL,+X)="" 20 . D SACLKWIC(TIUTTL,TIUCLASS,+X) 21 . ; Now build x-ref for document classes 22 . S TIUCLASS=+$$DOCCLASS^TIULC1(+X) 23 . I TIUCLASS'>0 Q 24 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)="" 25 . D SACLKWIC(TIUTTL,TIUCLASS,+X) 26 ; For Abbreviation and Print Name fields, just set the Synonym subscript 27 I $S(FLD=.02:1,FLD=.03:1,1:0) D Q 28 . N TIUDA 29 . Q:X']"" 30 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 31 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q 32 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) 33 . ; Include only TEST or ACTIVE titles 34 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q 35 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) 36 . Q:TIUTTL']"" 37 . S X=$$UP^XLFSTR(X) 38 . Q:X=TIUTTL 39 . S TIUTTL=X_" <"_TIUTTL_">" 40 . ; First build x-ref for Clinical Documents & Immediate descendents 41 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 42 . I TIUCLASS'>0 Q 43 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" 44 . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)="" 45 . ; Now build x-ref for document classes 46 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 47 . I TIUCLASS'>0 Q 48 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" 49 I FLD=.07 D Q 50 . N TIUDA 51 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 52 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q 53 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) 54 . ; Include only TEST or ACTIVE titles 55 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q 56 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) 57 . Q:TIUTTL']"" 58 . ; First build x-ref for Clinical Documents & Immediate descendents 59 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 60 . I TIUCLASS'>0 Q 61 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" 62 . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)="" 63 . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA) 64 . ; Now build x-ref for document classes 65 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 66 . I TIUCLASS'>0 Q 67 . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" 68 . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA) 69 I FLD=.01 D 70 . N TIUDA 71 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 72 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q 73 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) 74 . ; Include only TEST or ACTIVE titles 75 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q 76 . ; First build x-ref for Clinical Documents & Immediate descendents 77 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 78 . I TIUCLASS'>0 Q 79 . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)="" 80 . S ^TIU(8925.1,"ACL",38,X,+TIUDA)="" 81 . D SACLKWIC(X,TIUCLASS,+TIUDA) 82 . ; Now build x-ref for document classes 83 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 84 . I TIUCLASS'>0 Q 85 . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)="" 86 . D SACLKWIC(X,TIUCLASS,+TIUDA) 87 Q 88 SACLKWIC(X,TIUCLASS,TIUDA) ; Set logic for KWIC analog 89 N TIUI,TIUJ,TIUC S TIUI=1 90 F TIUJ=1:1:$L(X)+1 D 91 . S TIUC=$E(X,TIUJ) 92 . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1 93 . I I $L(TIUC)>2,(^DD("KWIC")'[TIUC),(TIUC'=X) S (^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA))="" 94 Q 95 KACL(X,FLD) ; KILL Logic for ACL cross-reference 96 N TIUCLASS,TIUTTL,TIUDA 97 I FLD=10.01 D 98 . ; First remove x-ref for Clinical Documents & Immediate descendents 99 . S TIUCLASS=+$$CLINDOC^TIULC1(+X) 100 . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U) 101 . Q:TIUTTL']"" 102 . Q:X=TIUTTL 103 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X) 104 . K ^TIU(8925.1,"ACL",38,TIUTTL,+X) 105 . D KACLKWIC(TIUTTL,TIUCLASS,+X) 106 . ; Now remove x-ref for document classes 107 . S TIUCLASS=+$$DOCCLASS^TIULC1(+X) 108 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X) 109 . D KACLKWIC(TIUTTL,TIUCLASS,+X) 110 I $S(FLD=.02:1,FLD=.03:1,1:0) D Q 111 . N TIUDA 112 . Q:X']"" 113 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 114 . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q 115 . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) 116 . ; Include only TEST or ACTIVE titles 117 . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q 118 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) 119 . Q:TIUTTL']"" 120 . S TIUTTL=X_" <"_TIUTTL_">" 121 . ; First build x-ref for Clinical Documents & Immediate descendents 122 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 123 . I TIUCLASS'>0 Q 124 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) 125 . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA) 126 . ; Now build x-ref for document classes 127 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 128 . I TIUCLASS'>0 Q 129 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) 130 I FLD=.07 D 131 . N TIUDA 132 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 133 . ; First remove x-ref for Clinical Documents & Immediate descendents 134 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 135 . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) 136 . Q:TIUTTL']"" 137 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) 138 . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA) 139 . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA) 140 . ; Now remove x-ref for document classes 141 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 142 . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) 143 . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA) 144 I FLD=.01 D 145 . N TIUDA 146 . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) 147 . ; First remove x-ref for Clinical Documents & Immediate descendents 148 . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) 149 . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA) 150 . K ^TIU(8925.1,"ACL",38,X,+TIUDA) 151 . D KACLKWIC(X,TIUCLASS,+TIUDA) 152 . ; Now remove x-ref for document classes 153 . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) 154 . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA) 155 . D KACLKWIC(X,TIUCLASS,+TIUDA) 156 Q 157 KACLKWIC(X,TIUCLASS,TIUDA) ; KILL Logic for KWIC analog 158 N TIUI,TIUJ,TIUC S TIUI=1 159 F TIUJ=1:1:$L(X)+1 D 160 . S TIUC=$E(X,TIUJ) 161 . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1 162 . I I $L(TIUC)>2 K ^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA) 163 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS.m
r613 r623 1 TIUEDS ; GENERATED FROM 'TIU ENTER/EDIT DS' INPUT TEMPLATE(#1491), FILE 8925; 11/08/091 TIUEDS ; GENERATED FROM 'TIU ENTER/EDIT DS' INPUT TEMPLATE(#1491), FILE 8925;03/29/06 2 2 D DE G BEGIN 3 3 DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" 4 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,7) S:%]"" DE(4)=% S %=$P(%Z,U,8) S:%]"" DE(7)=% S %=$P(%Z,U,9) S:%]"" DE(9)=% 5 I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,2) S:%]"" DE(12)=% ,DE(15)=%5 I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,2) S:%]"" DE(12)=% 6 6 K %Z Q 7 7 ; … … 91 91 D KAPTLD^TIUDD01(.02,X) 92 92 C1S S X="" G:DG(DQ)=X C1F1 K DB 93 S X=DG(DQ),DIC=DIE 94 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)="" 95 S X=DG(DQ),DIC=DIE 96 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 97 S X=DG(DQ),DIC=DIE 98 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)="" 99 S X=DG(DQ),DIC=DIE 100 S ^TIU(8925,"C",$E(X,1,30),DA)="" 101 S X=DG(DQ),DIC=DIE 102 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)="" 103 S X=DG(DQ),DIC=DIE 104 I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" 105 S X=DG(DQ),DIC=DIE 106 I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 107 S X=DG(DQ),DIC=DIE 108 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 109 S X=DG(DQ),DIC=DIE 110 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 111 S X=DG(DQ),DIC=DIE 112 D SACLPT^TIUDD0(.02,X) 113 S X=DG(DQ),DIC=DIE 114 D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X) 115 S X=DG(DQ),DIC=DIE 116 D SACLEC^TIUDD0(.02,X) 117 S X=DG(DQ),DIC=DIE 118 D SACLSB^TIUDD0(.02,X) 119 S X=DG(DQ),DIC=DIE 120 D SAPTLD^TIUDD0(.02,X) 93 D ^TIUEDS1 121 94 C1F1 Q 122 95 X1 Q … … 146 119 D KAPTLD^TIUDD01(.03,X) 147 120 C2S S X="" G:DG(DQ)=X C2F1 K DB 148 D ^TIUEDS 1121 D ^TIUEDS2 149 122 C2F1 Q 150 123 X2 Q … … 195 168 G Y 196 169 C12 G C12S:$D(DE(12))[0 K DB 197 D ^TIUEDS 2170 D ^TIUEDS3 198 171 C12S S X="" G:DG(DQ)=X C12F1 K DB 199 D ^TIUEDS 3172 D ^TIUEDS4 200 173 C12F1 Q 201 174 X12 S DIC("S")="I '+$$ISTERM^USRLM(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X … … 206 179 Q 207 180 14 S DQ=15 ;@8 208 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="12;2",DV="*P200'R",DU="",DLB="AUTHOR/DICTATOR",DIFLD=1202 209 S DE(DW)="C15^TIUEDS" 210 S DU="VA(200," 211 S X=$S($G(TIUAUTH):$$PERSNAME^TIULC1(TIUAUTH),1:"") 212 S Y=X 213 G Y 214 C15 G C15S:$D(DE(15))[0 K DB 215 D ^TIUEDS4 216 C15S S X="" G:DG(DQ)=X C15F1 K DB 217 D ^TIUEDS5 218 C15F1 Q 219 X15 S DIC("S")="I '+$$ISTERM^USRLM(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 220 Q 221 ; 222 16 S DQ=17 ;@3 223 17 D:$D(DG)>9 F^DIE17 G ^TIUEDS6 181 15 D:$D(DG)>9 F^DIE17 G ^TIUEDS5 -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS1.m
r613 r623 1 TIUEDS1 ; ; 11/08/091 TIUEDS1 ; ;03/29/06 2 2 S X=DG(DQ),DIC=DIE 3 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U, 2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)=""3 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)="" 4 4 S X=DG(DQ),DIC=DIE 5 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AE",+$P(^TIU(8925,+DA,0),U,2),(9999999-$P(+$G(^AUPNVSIT(+X,0)),".")),+^TIU(8925,+DA,0),+DA)=""5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 6 6 S X=DG(DQ),DIC=DIE 7 I $P($$DOCTYPE^TIULF(+DA),U)="DOC", +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,2) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,+DA)=""7 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)="" 8 8 S X=DG(DQ),DIC=DIE 9 D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT9 S ^TIU(8925,"C",$E(X,1,30),DA)="" 10 10 S X=DG(DQ),DIC=DIE 11 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)=""11 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)="" 12 12 S X=DG(DQ),DIC=DIE 13 S ^TIU(8925,"V",$E(X,1,30),DA)=""13 I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" 14 14 S X=DG(DQ),DIC=DIE 15 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^TIU(8925,D0,150)):^(150),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(8925,.03,1,7,1.1) X ^DD(8925,.03,1,7,1.4)15 I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 16 16 S X=DG(DQ),DIC=DIE 17 D SAPTLD^TIUDD0(.03,X) 17 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 18 S X=DG(DQ),DIC=DIE 19 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 20 S X=DG(DQ),DIC=DIE 21 D SACLPT^TIUDD0(.02,X) 22 S X=DG(DQ),DIC=DIE 23 D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X) 24 S X=DG(DQ),DIC=DIE 25 D SACLEC^TIUDD0(.02,X) 26 S X=DG(DQ),DIC=DIE 27 D SACLSB^TIUDD0(.02,X) 28 S X=DG(DQ),DIC=DIE 29 D SAPTLD^TIUDD0(.02,X) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS10.m
r613 r623 1 TIUEDS10 ; ;11/08/09 1 TIUEDS10 ; ;03/29/06 2 D DE G BEGIN 3 DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" 4 I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,4) S:%]"" DE(6)=% S %=$P(%Z,U,5) S:%]"" DE(12)=% S %=$P(%Z,U,8) S:%]"" DE(7)=% S %=$P(%Z,U,9) S:%]"" DE(1)=%,DE(4)=% S %=$P(%Z,U,12) S:%]"" DE(13)=% 5 I $D(^(14)) S %Z=^(14) S %=$P(%Z,U,1) S:%]"" DE(9)=% S %=$P(%Z,U,2) S:%]"" DE(10)=% S %=$P(%Z,U,4) S:%]"" DE(11)=% 6 I $D(^(15)) S %Z=^(15) S %=$P(%Z,U,6) S:%]"" DE(8)=% 7 K %Z Q 8 ; 9 W W !?DL+DL-2,DLB_": " 10 Q 11 O D W W Y W:$X>45 !?9 12 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 13 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 14 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 15 Q 16 A K DQ(DQ) S DQ=DQ+1 17 B G @DQ 18 RE G PR:$D(DE(DQ)) D W,TR 19 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 20 RD G QS:X?."?" I X["^" D D G ^DIE17 21 I X="@" D D G Z^DIE2 22 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 23 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 24 K DDER G X 25 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 26 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 27 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 28 V D @("X"_DQ) K YS 29 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 30 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 31 S X="?BAD" 32 QS S DZ=X D D,QQ^DIEQ G B 33 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 34 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 35 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 36 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 37 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 38 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 39 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 40 I I DV'["I",DV'["#" G RD 41 D E^DIE0 G RD:$D(X),PR 42 Q 43 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 44 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 45 D ^DIR I 'DDER S %=Y(0),X=Y 46 Q 47 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 48 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 49 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 50 Q 51 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 52 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 53 BEGIN S DNM="TIUEDS10",DQ=1 54 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="12;9",DV="*P200'R",DU="",DLB="ATTENDING PHYSICIAN",DIFLD=1209 55 S DU="VA(200," 56 G RE 57 X1 S DIC("S")="I '+$$ISTERM^USRLM(+Y),+$$PROVIDER^TIUPXAP1(+Y,DT)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 58 Q 59 ; 60 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 61 X2 S Y="@10" 62 Q 63 3 S DQ=4 ;@9 64 4 S DW="12;9",DV="*P200'",DU="",DLB="ATTENDING PHYSICIAN",DIFLD=1209 65 S DU="VA(200," 66 G RE 67 X4 S DIC("S")="I '+$$ISTERM^USRLM(+Y),+$$PROVIDER^TIUPXAP1(+Y,DT)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 68 Q 69 ; 70 5 S DQ=6 ;@10 71 6 S DW="12;4",DV="P200'O",DU="",DLB="EXPECTED SIGNER",DIFLD=1204 72 S DQ(6,2)="S Y(0)=Y S:+Y>0&$D(TIUSIG) Y=$S($L($P(^VA(200,+Y,20),U,2)):$P(^(20),U,2),1:$P(^VA(200,+Y,0),U)) S:+Y>0&'$D(TIUSIG) Y=$P(^VA(200,+Y,0),U)" 73 S DU="VA(200," 74 S X=$$WHOSIGNS^TIULC1(DA) 75 S Y=X 76 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 77 G RD:X="@",Z 78 X6 Q 79 7 S DW="12;8",DV="*P200'",DU="",DLB="EXPECTED COSIGNER",DIFLD=1208 80 S DE(DW)="C7^TIUEDS10" 81 S DU="VA(200," 82 S X=$$WHOCOSIG^TIULC1(DA) 83 S Y=X 84 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 85 G RD:X="@",Z 86 C7 G C7S:$D(DE(7))[0 K DB 87 S X=DE(7),DIC=DIE 88 K ^TIU(8925,"CS",$E(X,1,30),DA) 89 S X=DE(7),DIC=DIE 90 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 91 S X=DE(7),DIC=DIE 92 D KACLEC^TIUDD01(1208,X) 93 C7S S X="" G:DG(DQ)=X C7F1 K DB 94 S X=DG(DQ),DIC=DIE 95 S ^TIU(8925,"CS",$E(X,1,30),DA)="" 96 S X=DG(DQ),DIC=DIE 97 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 98 S X=DG(DQ),DIC=DIE 99 D SACLEC^TIUDD0(1208,X) 100 C7F1 Q 101 X7 Q 102 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="15;6",DV="S",DU="",DLB="COSIGNATURE NEEDED",DIFLD=1506 103 S DU="1:YES;0:NO;" 104 S X=$S(+$P($G(^TIU(8925,+DA,12)),U,4)=+$P($G(^TIU(8925,+DA,12)),U,9):0,1:1) 105 S Y=X 106 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 107 G RD:X="@",Z 108 X8 Q 109 9 S DW="14;1",DV="P405'",DU="",DLB="PATIENT MOVEMENT RECORD",DIFLD=1401 110 S DU="DGPM(" 111 S X=$G(TIU("AD#")) 112 S Y=X 113 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 114 G RD:X="@",Z 115 X9 Q 116 10 S DW="14;2",DV="P45.7'",DU="",DLB="TREATING SPECIALTY",DIFLD=1402 117 S DE(DW)="C10^TIUEDS10" 118 S DU="DIC(45.7," 119 S X=$P($G(TIU("TS")),U) 120 S Y=X 121 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 122 G RD:X="@",Z 123 C10 G C10S:$D(DE(10))[0 K DB 124 S X=DE(10),DIC=DIE 125 K ^TIU(8925,"TS",$E(X,1,30),DA) 126 S X=DE(10),DIC=DIE 127 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 128 C10S S X="" G:DG(DQ)=X C10F1 K DB 2 129 S X=DG(DQ),DIC=DIE 3 130 S ^TIU(8925,"TS",$E(X,1,30),DA)="" 4 131 S X=DG(DQ),DIC=DIE 5 132 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 133 C10F1 Q 134 X10 Q 135 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="14;4",DV="P49'",DU="",DLB="SERVICE",DIFLD=1404 136 S DE(DW)="C11^TIUEDS10" 137 S DU="DIC(49," 138 S X=$P($G(TIU("SVC")),U) 139 S Y=X 140 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 141 G RD:X="@",Z 142 C11 G C11S:$D(DE(11))[0 K DB 143 S X=DE(11),DIC=DIE 144 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 145 S X=DE(11),DIC=DIE 146 K ^TIU(8925,"SVC",$E(X,1,30),DA) 147 C11S S X="" G:DG(DQ)=X C11F1 K DB 148 S X=DG(DQ),DIC=DIE 149 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 150 S X=DG(DQ),DIC=DIE 151 S ^TIU(8925,"SVC",$E(X,1,30),DA)="" 152 C11F1 Q 153 X11 Q 154 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="12;5",DV="P44'",DU="",DLB="HOSPITAL LOCATION",DIFLD=1205 155 S DE(DW)="C12^TIUEDS10" 156 S DU="SC(" 157 S X=$P($G(TIU("LOC")),U) 158 S Y=X 159 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 160 G RD:X="@",Z 161 C12 G C12S:$D(DE(12))[0 K DB 162 D ^TIUEDS11 163 C12S S X="" G:DG(DQ)=X C12F1 K DB 164 D ^TIUEDS12 165 C12F1 Q 166 X12 Q 167 13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="12;12",DV="P4'",DU="",DLB="DIVISION",DIFLD=1212 168 S DE(DW)="C13^TIUEDS10",DE(DW,"INDEX")=1 169 S DU="DIC(4," 170 S X=$P($G(TIU("INST")),U) 171 S Y=X 172 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 173 G RD:X="@",Z 174 C13 G C13S:$D(DE(13))[0 K DB 175 C13S S X="" G:DG(DQ)=X C13F1 K DB 176 D ^TIUEDS13 177 C13F1 S DIEZRXR(8925,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) 178 F DIXR=247 S DIEZRXR(8925,DIXR)="" 179 Q 180 X13 Q 181 14 G 0^DIE17 -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS11.m
r613 r623 1 TIUEDS11 ; ; 11/08/092 S X=DE( 28),DIC=DIE3 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"A SVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)4 S X=DE( 28),DIC=DIE5 K ^TIU(8925,"SVC",$E(X,1,30),DA)1 TIUEDS11 ; ;03/29/06 2 S X=DE(12),DIC=DIE 3 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 4 S X=DE(12),DIC=DIE 5 I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS12.m
r613 r623 1 TIUEDS12 ; ; 11/08/091 TIUEDS12 ; ;03/29/06 2 2 S X=DG(DQ),DIC=DIE 3 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"A SVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""3 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 4 4 S X=DG(DQ),DIC=DIE 5 S ^TIU(8925,"SVC",$E(X,1,30),DA)=""5 I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS13.m
r613 r623 1 TIUEDS13 ; ;11/08/09 2 D DE G BEGIN 3 DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" 4 I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,5) S:%]"" DE(1)=% S %=$P(%Z,U,12) S:%]"" DE(2)=% 5 K %Z Q 6 ; 7 W W !?DL+DL-2,DLB_": " 8 Q 9 O D W W Y W:$X>45 !?9 10 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 11 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 12 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 13 Q 14 A K DQ(DQ) S DQ=DQ+1 15 B G @DQ 16 RE G PR:$D(DE(DQ)) D W,TR 17 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 18 RD G QS:X?."?" I X["^" D D G ^DIE17 19 I X="@" D D G Z^DIE2 20 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 21 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 22 K DDER G X 23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 24 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 25 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 26 V D @("X"_DQ) K YS 27 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 28 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 29 S X="?BAD" 30 QS S DZ=X D D,QQ^DIEQ G B 31 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 32 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 33 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 34 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 35 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 36 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 37 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 38 I I DV'["I",DV'["#" G RD 39 D E^DIE0 G RD:$D(X),PR 40 Q 41 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 42 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 43 D ^DIR I 'DDER S %=Y(0),X=Y 44 Q 45 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 46 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 47 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 48 Q 49 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 BEGIN S DNM="TIUEDS13",DQ=1 52 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="12;5",DV="P44'",DU="",DLB="HOSPITAL LOCATION",DIFLD=1205 53 S DE(DW)="C1^TIUEDS13" 54 S DU="SC(" 55 S X=$P($G(TIU("LOC")),U) 56 S Y=X 57 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 G RD:X="@",Z 59 C1 G C1S:$D(DE(1))[0 K DB 60 S X=DE(1),DIC=DIE 61 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 62 S X=DE(1),DIC=DIE 63 I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) 64 C1S S X="" G:DG(DQ)=X C1F1 K DB 65 S X=DG(DQ),DIC=DIE 66 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 67 S X=DG(DQ),DIC=DIE 68 I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" 69 C1F1 Q 70 X1 Q 71 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="12;12",DV="P4'",DU="",DLB="DIVISION",DIFLD=1212 72 S DE(DW)="C2^TIUEDS13",DE(DW,"INDEX")=1 73 S DU="DIC(4," 74 S X=$P($G(TIU("INST")),U) 75 S Y=X 76 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 77 G RD:X="@",Z 78 C2 G C2S:$D(DE(2))[0 K DB 79 C2S S X="" G:DG(DQ)=X C2F1 K DB 80 C2F1 S DIEZRXR(8925,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) 81 F DIXR=247 S DIEZRXR(8925,DIXR)="" 82 Q 83 X2 Q 84 3 G 0^DIE17 1 TIUEDS13 ; ;03/29/06 -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS14.m
r613 r623 1 TIUEDS14 ; ; 11/08/091 TIUEDS14 ; ;03/29/06 2 2 ;; 3 3 1 N X,X1,X2 S DIXR=247 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS2.m
r613 r623 1 TIUEDS2 ; ;11/08/09 2 S X=DE(12),DIC=DIE 3 K ^TIU(8925,"CA",$E(X,1,30),DA) 4 S X=DE(12),DIC=DIE 5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA) 6 S X=DE(12),DIC=DIE 7 I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) 8 S X=DE(12),DIC=DIE 9 D KACLAU^TIUDD01(1202,X) 10 S X=DE(12),DIC=DIE 11 ; 1 TIUEDS2 ; ;03/29/06 2 S X=DG(DQ),DIC=DIE 3 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)="" 4 S X=DG(DQ),DIC=DIE 5 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AE",+$P(^TIU(8925,+DA,0),U,2),(9999999-$P(+$G(^AUPNVSIT(+X,0)),".")),+^TIU(8925,+DA,0),+DA)="" 6 S X=DG(DQ),DIC=DIE 7 I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,2) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,+DA)="" 8 S X=DG(DQ),DIC=DIE 9 D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT 10 S X=DG(DQ),DIC=DIE 11 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 12 S X=DG(DQ),DIC=DIE 13 S ^TIU(8925,"V",$E(X,1,30),DA)="" 14 S X=DG(DQ),DIC=DIE 15 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^TIU(8925,D0,150)):^(150),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(8925,.03,1,7,1.1) X ^DD(8925,.03,1,7,1.4) 16 S X=DG(DQ),DIC=DIE 17 D SAPTLD^TIUDD0(.03,X) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS3.m
r613 r623 1 TIUEDS3 ; ; 11/08/092 S X=D G(DQ),DIC=DIE3 S ^TIU(8925,"CA",$E(X,1,30),DA)=""4 S X=D G(DQ),DIC=DIE5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)=""6 S X=D G(DQ),DIC=DIE7 I +$ $AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)=""8 S X=D G(DQ),DIC=DIE9 D SACLAU^TIUDD0(1202,X)10 S X=D G(DQ),DIC=DIE11 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4)1 TIUEDS3 ; ;03/29/06 2 S X=DE(12),DIC=DIE 3 K ^TIU(8925,"CA",$E(X,1,30),DA) 4 S X=DE(12),DIC=DIE 5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA) 6 S X=DE(12),DIC=DIE 7 I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) 8 S X=DE(12),DIC=DIE 9 D KACLAU^TIUDD01(1202,X) 10 S X=DE(12),DIC=DIE 11 ; -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS4.m
r613 r623 1 TIUEDS4 ; ; 11/08/092 S X=D E(15),DIC=DIE3 K ^TIU(8925,"CA",$E(X,1,30),DA)4 S X=D E(15),DIC=DIE5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)6 S X=D E(15),DIC=DIE7 I +$ P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)8 S X=D E(15),DIC=DIE9 D KACLAU^TIUDD01(1202,X)10 S X=D E(15),DIC=DIE11 ;1 TIUEDS4 ; ;03/29/06 2 S X=DG(DQ),DIC=DIE 3 S ^TIU(8925,"CA",$E(X,1,30),DA)="" 4 S X=DG(DQ),DIC=DIE 5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" 6 S X=DG(DQ),DIC=DIE 7 I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" 8 S X=DG(DQ),DIC=DIE 9 D SACLAU^TIUDD0(1202,X) 10 S X=DG(DQ),DIC=DIE 11 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS5.m
r613 r623 1 TIUEDS5 ; ;11/08/09 1 TIUEDS5 ; ;03/29/06 2 D DE G BEGIN 3 DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,12) S:%]"" DE(7)=% 5 I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,1) S:%]"" DE(17)=% S %=$P(%Z,U,2) S:%]"" DE(1)=% 6 I $D(^(13)) S %Z=^(13) S %=$P(%Z,U,1) S:%]"" DE(9)=% S %=$P(%Z,U,2) S:%]"" DE(11)=% S %=$P(%Z,U,3) S:%]"" DE(14)=% S %=$P(%Z,U,7) S:%]"" DE(3)=% 7 K %Z Q 8 ; 9 W W !?DL+DL-2,DLB_": " 10 Q 11 O D W W Y W:$X>45 !?9 12 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 13 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 14 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 15 Q 16 A K DQ(DQ) S DQ=DQ+1 17 B G @DQ 18 RE G PR:$D(DE(DQ)) D W,TR 19 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 20 RD G QS:X?."?" I X["^" D D G ^DIE17 21 I X="@" D D G Z^DIE2 22 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 23 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 24 K DDER G X 25 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 26 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 27 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 28 V D @("X"_DQ) K YS 29 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 30 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 31 S X="?BAD" 32 QS S DZ=X D D,QQ^DIEQ G B 33 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 34 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 35 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 36 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 37 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 38 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 39 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 40 I I DV'["I",DV'["#" G RD 41 D E^DIE0 G RD:$D(X),PR 42 Q 43 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 44 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 45 D ^DIR I 'DDER S %=Y(0),X=Y 46 Q 47 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 48 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 49 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 50 Q 51 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 52 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 53 BEGIN S DNM="TIUEDS5",DQ=1 54 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="12;2",DV="*P200'R",DU="",DLB="AUTHOR/DICTATOR",DIFLD=1202 55 S DE(DW)="C1^TIUEDS5" 56 S DU="VA(200," 57 S X=$S($G(TIUAUTH):$$PERSNAME^TIULC1(TIUAUTH),1:"") 58 S Y=X 59 G Y 60 C1 G C1S:$D(DE(1))[0 K DB 61 S X=DE(1),DIC=DIE 62 K ^TIU(8925,"CA",$E(X,1,30),DA) 63 S X=DE(1),DIC=DIE 64 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA) 65 S X=DE(1),DIC=DIE 66 I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) 67 S X=DE(1),DIC=DIE 68 D KACLAU^TIUDD01(1202,X) 69 S X=DE(1),DIC=DIE 70 ; 71 C1S S X="" G:DG(DQ)=X C1F1 K DB 2 72 S X=DG(DQ),DIC=DIE 3 73 S ^TIU(8925,"CA",$E(X,1,30),DA)="" … … 10 80 S X=DG(DQ),DIC=DIE 11 81 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4) 82 C1F1 Q 83 X1 S DIC("S")="I '+$$ISTERM^USRLM(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 84 Q 85 ; 86 2 S DQ=3 ;@3 87 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="13;7",DV="DR",DU="",DLB="DICTATION DATE",DIFLD=1307 88 G RE 89 X3 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 90 Q 91 ; 92 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 G A 93 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 94 X5 S TIUREFDT=$$REFDATE^TIULC1(.TIU,+X) 95 Q 96 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 97 X6 I +$P(TIUREFDT,U,2)'>0 S Y="@4" 98 Q 99 7 S DW="0;12",DV="S",DU="",DLB="MARK DISCH DT FOR CORRECTION",DIFLD=.12 100 S DE(DW)="C7^TIUEDS5" 101 S DU="1:YES;" 102 S X=1 103 S Y=X 104 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 105 G RD:X="@",Z 106 C7 G C7S:$D(DE(7))[0 K DB 107 S X=DE(7),DIC=DIE 108 K ^TIU(8925,"FIX",$E(X,1,30),DA) 109 C7S S X="" G:DG(DQ)=X C7F1 K DB 110 S X=DG(DQ),DIC=DIE 111 S ^TIU(8925,"FIX",$E(X,1,30),DA)="" 112 C7F1 Q 113 X7 Q 114 8 S DQ=9 ;@4 115 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="13;1",DV="D",DU="",DLB="REFERENCE DATE",DIFLD=1301 116 S DE(DW)="C9^TIUEDS5",DE(DW,"INDEX")=1 117 S X=$P(TIUREFDT,U) 118 S Y=X 119 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 120 G RD:X="@",Z 121 C9 G C9S:$D(DE(9))[0 K DB 122 D ^TIUEDS6 123 C9S S X="" G:DG(DQ)=X C9F1 K DB 124 D ^TIUEDS7 125 C9F1 S DIEZRXR(8925,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) 126 F DIXR=247 S DIEZRXR(8925,DIXR)="" 127 Q 128 X9 Q 129 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 130 X10 I +$P($G(^TIU(8925,+DA,13)),U,2) S Y="@5" 131 Q 132 11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="13;2",DV="P200'O",DU="",DLB="ENTERED BY",DIFLD=1302 133 S DQ(11,2)="S Y(0)=Y S Y=$S(+$G(TIUINI):$$LOWER^TIULS($P($G(^VA(200,+Y(0),0)),U,2)),1:$P($G(^VA(200,+Y(0),0)),U,2))" 134 S DE(DW)="C11^TIUEDS5" 135 S DU="VA(200," 136 S X=DUZ 137 S Y=X 138 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 139 G RD:X="@",Z 140 C11 G C11S:$D(DE(11))[0 K DB 141 S X=DE(11),DIC=DIE 142 K ^TIU(8925,"TC",$E(X,1,30),DA) 143 S X=DE(11),DIC=DIE 144 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 145 S X=DE(11),DIC=DIE 146 D KACLAU1^TIUDD01(1302,X) 147 C11S S X="" G:DG(DQ)=X C11F1 K DB 148 S X=DG(DQ),DIC=DIE 149 S ^TIU(8925,"TC",$E(X,1,30),DA)="" 150 S X=DG(DQ),DIC=DIE 151 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 152 S X=DG(DQ),DIC=DIE 153 D SACLAU1^TIUDD0(1302,X) 154 C11F1 Q 155 X11 Q 156 12 S DQ=13 ;@5 157 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 158 X13 I $P($G(^TIU(8925,+DA,13)),U,3)]"" S Y="@6" 159 Q 160 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW="13;3",DV="S",DU="",DLB="CAPTURE METHOD",DIFLD=1303 161 S DU="D:direct;U:upload;C:converted;R:remote procedure;O:copy;" 162 S X="D" 163 S Y=X 164 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 165 G RD:X="@",Z 166 X14 Q 167 15 S DQ=16 ;@6 168 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 169 X16 I +$P($G(^TIU(8925,+DA,12)),U) S Y="@7" 170 Q 171 17 S DW="12;1",DV="D",DU="",DLB="ENTRY DATE/TIME",DIFLD=1201 172 S DE(DW)="C17^TIUEDS5" 173 S X=$$NOW^TIULC 174 S Y=X 175 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 176 G RD:X="@",Z 177 C17 G C17S:$D(DE(17))[0 K DB 178 D ^TIUEDS8 179 C17S S X="" G:DG(DQ)=X C17F1 K DB 180 D ^TIUEDS9 181 C17F1 Q 182 X17 Q 183 18 S DQ=19 ;@7 184 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 185 X19 I +$$PROVIDER^TIUPXAP1(DUZ,DT)'>0 S Y="@9" 186 Q 187 20 D:$D(DG)>9 F^DIE17 G ^TIUEDS10 -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS6.m
r613 r623 1 TIUEDS6 ; ;11/08/09 2 D DE G BEGIN 3 DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,12) S:%]"" DE(5)=% 5 I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,1) S:%]"" DE(15)=% S %=$P(%Z,U,4) S:%]"" DE(23)=% S %=$P(%Z,U,8) S:%]"" DE(24)=% S %=$P(%Z,U,9) S:%]"" DE(18)=%,DE(21)=% 6 I $D(^(13)) S %Z=^(13) S %=$P(%Z,U,1) S:%]"" DE(7)=% S %=$P(%Z,U,2) S:%]"" DE(9)=% S %=$P(%Z,U,3) S:%]"" DE(12)=% S %=$P(%Z,U,7) S:%]"" DE(1)=% 7 I $D(^(14)) S %Z=^(14) S %=$P(%Z,U,1) S:%]"" DE(26)=% S %=$P(%Z,U,2) S:%]"" DE(27)=% S %=$P(%Z,U,4) S:%]"" DE(28)=% 8 I $D(^(15)) S %Z=^(15) S %=$P(%Z,U,6) S:%]"" DE(25)=% 9 K %Z Q 10 ; 11 W W !?DL+DL-2,DLB_": " 12 Q 13 O D W W Y W:$X>45 !?9 14 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 15 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 16 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 17 Q 18 A K DQ(DQ) S DQ=DQ+1 19 B G @DQ 20 RE G PR:$D(DE(DQ)) D W,TR 21 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 22 RD G QS:X?."?" I X["^" D D G ^DIE17 23 I X="@" D D G Z^DIE2 24 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 25 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 26 K DDER G X 27 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 28 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 29 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 30 V D @("X"_DQ) K YS 31 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 32 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 33 S X="?BAD" 34 QS S DZ=X D D,QQ^DIEQ G B 35 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 36 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 37 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 38 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 39 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 40 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 41 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 42 I I DV'["I",DV'["#" G RD 43 D E^DIE0 G RD:$D(X),PR 44 Q 45 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 46 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 47 D ^DIR I 'DDER S %=Y(0),X=Y 48 Q 49 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 50 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 51 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 52 Q 53 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 54 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 55 BEGIN S DNM="TIUEDS6",DQ=1 56 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="13;7",DV="DR",DU="",DLB="DICTATION DATE",DIFLD=1307 57 G RE 58 X1 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 59 Q 60 ; 61 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A 62 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 63 X3 S TIUREFDT=$$REFDATE^TIULC1(.TIU,+X) 64 Q 65 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 66 X4 I +$P(TIUREFDT,U,2)'>0 S Y="@4" 67 Q 68 5 S DW="0;12",DV="S",DU="",DLB="MARK DISCH DT FOR CORRECTION",DIFLD=.12 69 S DE(DW)="C5^TIUEDS6" 70 S DU="1:YES;" 71 S X=1 72 S Y=X 73 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 74 G RD:X="@",Z 75 C5 G C5S:$D(DE(5))[0 K DB 76 S X=DE(5),DIC=DIE 77 K ^TIU(8925,"FIX",$E(X,1,30),DA) 78 C5S S X="" G:DG(DQ)=X C5F1 K DB 79 S X=DG(DQ),DIC=DIE 80 S ^TIU(8925,"FIX",$E(X,1,30),DA)="" 81 C5F1 Q 82 X5 Q 83 6 S DQ=7 ;@4 84 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="13;1",DV="D",DU="",DLB="REFERENCE DATE",DIFLD=1301 85 S DE(DW)="C7^TIUEDS6",DE(DW,"INDEX")=1 86 S X=$P(TIUREFDT,U) 87 S Y=X 88 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 89 G RD:X="@",Z 90 C7 G C7S:$D(DE(7))[0 K DB 91 D ^TIUEDS7 92 C7S S X="" G:DG(DQ)=X C7F1 K DB 93 D ^TIUEDS8 94 C7F1 S DIEZRXR(8925,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) 95 F DIXR=247 S DIEZRXR(8925,DIXR)="" 96 Q 97 X7 Q 98 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 99 X8 I +$P($G(^TIU(8925,+DA,13)),U,2) S Y="@5" 100 Q 101 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="13;2",DV="P200'O",DU="",DLB="ENTERED BY",DIFLD=1302 102 S DQ(9,2)="S Y(0)=Y S Y=$S(+$G(TIUINI):$$LOWER^TIULS($P($G(^VA(200,+Y(0),0)),U,2)),1:$P($G(^VA(200,+Y(0),0)),U,2))" 103 S DE(DW)="C9^TIUEDS6" 104 S DU="VA(200," 105 S X=DUZ 106 S Y=X 107 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 108 G RD:X="@",Z 109 C9 G C9S:$D(DE(9))[0 K DB 1 TIUEDS6 ; ;03/29/06 110 2 S X=DE(9),DIC=DIE 111 K ^TIU(8925,"TC",$E(X,1,30),DA)3 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 112 4 S X=DE(9),DIC=DIE 113 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,1 3)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 114 6 S X=DE(9),DIC=DIE 115 D KACLAU1^TIUDD01(1302,X) 116 C9S S X="" G:DG(DQ)=X C9F1 K DB 117 S X=DG(DQ),DIC=DIE 118 S ^TIU(8925,"TC",$E(X,1,30),DA)="" 119 S X=DG(DQ),DIC=DIE 120 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 121 S X=DG(DQ),DIC=DIE 122 D SACLAU1^TIUDD0(1302,X) 123 C9F1 Q 124 X9 Q 125 10 S DQ=11 ;@5 126 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 127 X11 I $P($G(^TIU(8925,+DA,13)),U,3)]"" S Y="@6" 128 Q 129 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="13;3",DV="S",DU="",DLB="CAPTURE METHOD",DIFLD=1303 130 S DU="D:direct;U:upload;C:converted;R:remote procedure;O:copy;" 131 S X="D" 132 S Y=X 133 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 134 G RD:X="@",Z 135 X12 Q 136 13 S DQ=14 ;@6 137 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 138 X14 I +$P($G(^TIU(8925,+DA,12)),U) S Y="@7" 139 Q 140 15 S DW="12;1",DV="D",DU="",DLB="ENTRY DATE/TIME",DIFLD=1201 141 S DE(DW)="C15^TIUEDS6" 142 S X=$$NOW^TIULC 143 S Y=X 144 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 145 G RD:X="@",Z 146 C15 G C15S:$D(DE(15))[0 K DB 147 S X=DE(15),DIC=DIE 148 K ^TIU(8925,"F",$E(X,1,30),DA) 149 C15S S X="" G:DG(DQ)=X C15F1 K DB 150 S X=DG(DQ),DIC=DIE 151 S ^TIU(8925,"F",$E(X,1,30),DA)="" 152 C15F1 Q 153 X15 Q 154 16 S DQ=17 ;@7 155 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 156 X17 I +$$PROVIDER^TIUPXAP1(DUZ,DT)'>0 S Y="@9" 157 Q 158 18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="12;9",DV="*P200'XR",DU="",DLB="ATTENDING PHYSICIAN",DIFLD=1209 159 S DU="VA(200," 160 G RE 161 X18 S DIC("S")="I +$G(DA),+$$SCRATT^TIULA3(+DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 162 Q 163 ; 164 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 165 X19 S Y="@10" 166 Q 167 20 S DQ=21 ;@9 168 21 S DW="12;9",DV="*P200'X",DU="",DLB="ATTENDING PHYSICIAN",DIFLD=1209 169 S DU="VA(200," 170 G RE 171 X21 S DIC("S")="I +$G(DA),+$$SCRATT^TIULA3(+DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 172 Q 173 ; 174 22 S DQ=23 ;@10 175 23 S DW="12;4",DV="P200'O",DU="",DLB="EXPECTED SIGNER",DIFLD=1204 176 S DQ(23,2)="S Y(0)=Y S:+Y>0&$D(TIUSIG) Y=$S($L($P(^VA(200,+Y,20),U,2)):$P(^(20),U,2),1:$P(^VA(200,+Y,0),U)) S:+Y>0&'$D(TIUSIG) Y=$P(^VA(200,+Y,0),U)" 177 S DU="VA(200," 178 S X=$$WHOSIGNS^TIULC1(DA) 179 S Y=X 180 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 181 G RD:X="@",Z 182 X23 Q 183 24 S DW="12;8",DV="*P200'",DU="",DLB="EXPECTED COSIGNER",DIFLD=1208 184 S DE(DW)="C24^TIUEDS6" 185 S DU="VA(200," 186 S X=$$WHOCOSIG^TIULC1(DA) 187 S Y=X 188 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 189 G RD:X="@",Z 190 C24 G C24S:$D(DE(24))[0 K DB 191 S X=DE(24),DIC=DIE 192 K ^TIU(8925,"CS",$E(X,1,30),DA) 193 S X=DE(24),DIC=DIE 194 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 195 S X=DE(24),DIC=DIE 196 D KACLEC^TIUDD01(1208,X) 197 C24S S X="" G:DG(DQ)=X C24F1 K DB 198 S X=DG(DQ),DIC=DIE 199 S ^TIU(8925,"CS",$E(X,1,30),DA)="" 200 S X=DG(DQ),DIC=DIE 201 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 202 S X=DG(DQ),DIC=DIE 203 D SACLEC^TIUDD0(1208,X) 204 C24F1 Q 205 X24 Q 206 25 D:$D(DG)>9 F^DIE17,DE S DQ=25,DW="15;6",DV="S",DU="",DLB="COSIGNATURE NEEDED",DIFLD=1506 207 S DU="1:YES;0:NO;" 208 S X=$S(+$P($G(^TIU(8925,+DA,12)),U,4)=+$P($G(^TIU(8925,+DA,12)),U,9):0,1:1) 209 S Y=X 210 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 211 G RD:X="@",Z 212 X25 Q 213 26 S DW="14;1",DV="P405'",DU="",DLB="PATIENT MOVEMENT RECORD",DIFLD=1401 214 S DU="DGPM(" 215 S X=$G(TIU("AD#")) 216 S Y=X 217 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 218 G RD:X="@",Z 219 X26 Q 220 27 S DW="14;2",DV="P45.7'",DU="",DLB="TREATING SPECIALTY",DIFLD=1402 221 S DE(DW)="C27^TIUEDS6" 222 S DU="DIC(45.7," 223 S X=$P($G(TIU("TS")),U) 224 S Y=X 225 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 226 G RD:X="@",Z 227 C27 G C27S:$D(DE(27))[0 K DB 228 D ^TIUEDS9 229 C27S S X="" G:DG(DQ)=X C27F1 K DB 230 D ^TIUEDS10 231 C27F1 Q 232 X27 Q 233 28 D:$D(DG)>9 F^DIE17,DE S DQ=28,DW="14;4",DV="P49'",DU="",DLB="SERVICE",DIFLD=1404 234 S DE(DW)="C28^TIUEDS6" 235 S DU="DIC(49," 236 S X=$P($G(TIU("SVC")),U) 237 S Y=X 238 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 239 G RD:X="@",Z 240 C28 G C28S:$D(DE(28))[0 K DB 241 D ^TIUEDS11 242 C28S S X="" G:DG(DQ)=X C28F1 K DB 243 D ^TIUEDS12 244 C28F1 Q 245 X28 Q 246 29 D:$D(DG)>9 F^DIE17 G ^TIUEDS13 7 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 8 S X=DE(9),DIC=DIE 9 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 10 S X=DE(9),DIC=DIE 11 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 12 S X=DE(9),DIC=DIE 13 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 14 S X=DE(9),DIC=DIE 15 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 16 S X=DE(9),DIC=DIE 17 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 18 S X=DE(9),DIC=DIE 19 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 20 S X=DE(9),DIC=DIE 21 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) 22 S X=DE(9),DIC=DIE 23 I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) 24 S X=DE(9),DIC=DIE 25 K ^TIU(8925,"D",$E(X,1,30),DA) 26 S X=DE(9),DIC=DIE 27 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA) 28 S X=DE(9),DIC=DIE 29 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA) 30 S X=DE(9),DIC=DIE 31 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 32 S X=DE(9),DIC=DIE 33 D KACLPT^TIUDD01(1301,X) 34 S X=DE(9),DIC=DIE 35 D KACLAU^TIUDD01(1301,X),KACLAU1^TIUDD01(1301,X) 36 S X=DE(9),DIC=DIE 37 D KACLEC^TIUDD01(1301,X) 38 S X=DE(9),DIC=DIE 39 D KACLSB^TIUDD01(1301,X) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS7.m
r613 r623 1 TIUEDS7 ; ; 11/08/092 S X=D E(7),DIC=DIE3 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)4 S X=D E(7),DIC=DIE5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)6 S X=D E(7),DIC=DIE7 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)8 S X=D E(7),DIC=DIE9 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)10 S X=D E(7),DIC=DIE11 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)12 S X=D E(7),DIC=DIE13 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)14 S X=D E(7),DIC=DIE15 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUB K^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA)16 S X=D E(7),DIC=DIE17 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)18 S X=D E(7),DIC=DIE19 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRB K^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA)20 S X=D E(7),DIC=DIE21 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)22 S X=D E(7),DIC=DIE23 I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)24 S X=D E(7),DIC=DIE25 K ^TIU(8925,"D",$E(X,1,30),DA)26 S X=D E(7),DIC=DIE27 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)28 S X=D E(7),DIC=DIE29 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)30 S X=D E(7),DIC=DIE31 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)32 S X=D E(7),DIC=DIE33 D KACLPT^TIUDD01(1301,X)34 S X=D E(7),DIC=DIE35 D KACLAU^TIUDD01(1301,X),KACLAU1^TIUDD01(1301,X)36 S X=D E(7),DIC=DIE37 D KACLEC^TIUDD01(1301,X)38 S X=D E(7),DIC=DIE39 D KACLSB^TIUDD01(1301,X)1 TIUEDS7 ; ;03/29/06 2 S X=DG(DQ),DIC=DIE 3 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 4 S X=DG(DQ),DIC=DIE 5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 6 S X=DG(DQ),DIC=DIE 7 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 8 S X=DG(DQ),DIC=DIE 9 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 10 S X=DG(DQ),DIC=DIE 11 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 12 S X=DG(DQ),DIC=DIE 13 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 14 S X=DG(DQ),DIC=DIE 15 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 16 S X=DG(DQ),DIC=DIE 17 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 18 S X=DG(DQ),DIC=DIE 19 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 20 S X=DG(DQ),DIC=DIE 21 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" 22 S X=DG(DQ),DIC=DIE 23 I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" 24 S X=DG(DQ),DIC=DIE 25 S ^TIU(8925,"D",$E(X,1,30),DA)="" 26 S X=DG(DQ),DIC=DIE 27 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)="" 28 S X=DG(DQ),DIC=DIE 29 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)="" 30 S X=DG(DQ),DIC=DIE 31 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 32 S X=DG(DQ),DIC=DIE 33 D SACLPT^TIUDD0(1301,X) 34 S X=DG(DQ),DIC=DIE 35 D SACLAU^TIUDD0(1301,X),SACLAU1^TIUDD0(1301,X) 36 S X=DG(DQ),DIC=DIE 37 D SACLEC^TIUDD0(1301,X) 38 S X=DG(DQ),DIC=DIE 39 D SACLSB^TIUDD0(1301,X) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS8.m
r613 r623 1 TIUEDS8 ; ;11/08/09 2 S X=DG(DQ),DIC=DIE 3 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 4 S X=DG(DQ),DIC=DIE 5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 6 S X=DG(DQ),DIC=DIE 7 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 8 S X=DG(DQ),DIC=DIE 9 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 10 S X=DG(DQ),DIC=DIE 11 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 12 S X=DG(DQ),DIC=DIE 13 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 14 S X=DG(DQ),DIC=DIE 15 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 16 S X=DG(DQ),DIC=DIE 17 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 18 S X=DG(DQ),DIC=DIE 19 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 20 S X=DG(DQ),DIC=DIE 21 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" 22 S X=DG(DQ),DIC=DIE 23 I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" 24 S X=DG(DQ),DIC=DIE 25 S ^TIU(8925,"D",$E(X,1,30),DA)="" 26 S X=DG(DQ),DIC=DIE 27 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)="" 28 S X=DG(DQ),DIC=DIE 29 I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)="" 30 S X=DG(DQ),DIC=DIE 31 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 32 S X=DG(DQ),DIC=DIE 33 D SACLPT^TIUDD0(1301,X) 34 S X=DG(DQ),DIC=DIE 35 D SACLAU^TIUDD0(1301,X),SACLAU1^TIUDD0(1301,X) 36 S X=DG(DQ),DIC=DIE 37 D SACLEC^TIUDD0(1301,X) 38 S X=DG(DQ),DIC=DIE 39 D SACLSB^TIUDD0(1301,X) 1 TIUEDS8 ; ;03/29/06 2 S X=DE(17),DIC=DIE 3 K ^TIU(8925,"F",$E(X,1,30),DA) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS9.m
r613 r623 1 TIUEDS9 ; ;11/08/09 2 S X=DE(27),DIC=DIE 3 K ^TIU(8925,"TS",$E(X,1,30),DA) 4 S X=DE(27),DIC=DIE 5 I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 1 TIUEDS9 ; ;03/29/06 2 S X=DG(DQ),DIC=DIE 3 S ^TIU(8925,"F",$E(X,1,30),DA)="" -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF4.m
r613 r623 1 TIUFLF4 2 ;;1.0;TEXT INTEGRATION UTILITIES;**11,43,236**;Jun 20, 1997;Build 2 3 4 NUMITEMS(FILEDA) 5 6 7 8 NUMIX 9 10 MISSITEM(FILEDA) 11 12 13 14 15 16 17 18 19 ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG) 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 ANCEX 46 47 ORPHAN(FILEDA,NODE0,ANCESTOR) 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 ORPHX 63 64 STUFFLDS(FILEDA,PFILEDA) 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 STUFFX 92 93 ADDTEN(PFILEDA,FILEDA,NODE0,TENDA) 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 ADDTX 115 1 TIUFLF4 ; SLC/MAM - Lib; ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG), ORPHAN(FILEDA,NODE0,ANCESTOR), STUFFLDS(FILEDA,PFILEDA), ADDTEN(PFILEDA,FILEDA,NODE0,TENDA),NUMITEMS(FILEDA), MISSITEM(FILEDA) ;4/23/97 11:02 2 ;;1.0;TEXT INTEGRATION UTILITIES;**11,43**;Jun 20, 1997 3 ; 4 NUMITEMS(FILEDA) ; Function returns Number of Items of FILEDA; Possibly 0 5 N ITEMSANS,TIUFI 6 S (ITEMSANS,TIUFI)=0 7 F S TIUFI=$O(^TIU(8925.1,FILEDA,10,TIUFI)) G:'TIUFI NUMIX S ITEMSANS=ITEMSANS+1 8 NUMIX Q ITEMSANS 9 ; 10 MISSITEM(FILEDA) ; Function Checks FILEDA Items (doesn't check subitems etc.) for existence only. Returns IFN of first missing item it finds, else 0. 11 ; Requires FILEDA. 12 N TIUI,IFILEDA,MISSANS 13 S TIUI=0,MISSANS=0 14 F S TIUI=$O(^TIU(8925.1,FILEDA,10,TIUI)) Q:'TIUI!MISSANS D 15 . S IFILEDA=+^TIU(8925.1,FILEDA,10,TIUI,0) 16 . I '$D(^TIU(8925.1,IFILEDA,0)) S MISSANS=IFILEDA 17 Q MISSANS 18 ; 19 ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG) ; Module traces ancestors of FILEDA, 20 ;creates array ANCESTOR, 21 ; where ANCESTOR(0)=FILEDA, 22 ; where ANCESTOR(1)=Parent IFN of FILEDA, 23 ; ANCESTOR(2)=Parent IFN of ANCESTOR(1) 24 ; ... 25 ; ANCESTOR(last subscript)=IFN of oldest ancestor of FILEDA if 26 ; '$G(DOCFLAG) 27 ; OR 28 ; IFN of oldest ancestor of FILEDA NOT 29 ; OF TYPE DC OR CL if $G(DOCFLAG) 30 ; Don't stop the array for problems like bad type, no type, type object. 31 ; If DOCFLAG, DON'T GET DC or CL; don't want array to mistakenly 32 ;go all the way to CLinical Documents. 33 ; Array may not EXIST if DOCFLAG 34 ; Requires FILEDA, NODE0= 0 Node; 35 ; DOCFLAG optional, 0 or 1 36 N TIUI,QUIT,ANODE0 37 S DOCFLAG=+$G(DOCFLAG) 38 I DOCFLAG,($P(NODE0,U,4)="DC")!($P(NODE0,U,4)="CL") G ANCEX 39 S TIUI=0,ANCESTOR(0)=FILEDA 40 F D Q:$G(QUIT) 41 . S ANCESTOR(TIUI+1)=$O(^TIU(8925.1,"AD",ANCESTOR(TIUI),0)) 42 . I 'ANCESTOR(TIUI+1) K ANCESTOR(TIUI+1) S QUIT=1 Q 43 . I DOCFLAG S ANODE0=^TIU(8925.1,ANCESTOR(TIUI+1),0) I ($P(ANODE0,U,4)="DC")!($P(ANODE0,U,4)="CL") K ANCESTOR(TIUI+1) S QUIT=1 Q 44 . S TIUI=TIUI+1 45 ANCEX Q 46 ; 47 ORPHAN(FILEDA,NODE0,ANCESTOR) ; Function traces ancestors of FILEDA, 48 ; Returns NA if FILEDA is Object or Shared Component, 49 ; NO if NOT NA AND FILEDA belongs to Clinical Docmts Hierarchy, 50 ; YES if NOT NA, AND doesn't belong. 51 ; Requires FILEDA, NODE0= 0 Node; 52 N ORPHAN,LAST 53 I $P(NODE0,U,4)="O" S ORPHAN="NA" G ORPHX 54 I '$D(ANCESTOR) D ANCESTOR(FILEDA,NODE0,.ANCESTOR) 55 I '$D(^TMP("TIUF",$J,"CLINDOC")) D G:Y=-1 ORPHX 56 . N DIC,X,Y 57 . S DIC=8925.1,DIC(0)="X",X="CLINICAL DOCUMENTS" D ^DIC 58 . I Y=-1 S ORPHAN="UNKNOWN" Q 59 . S ^TMP("TIUF",$J,"CLINDOC")=+Y 60 S LAST=$O(ANCESTOR(100),-1) I ANCESTOR(LAST)=^TMP("TIUF",$J,"CLINDOC") S ORPHAN="NO" G ORPHX 61 S ORPHAN="YES" 62 ORPHX Q ORPHAN 63 ; 64 STUFFLDS(FILEDA,PFILEDA) ; Stuff fields .03, .04 (tries), .07, [.1] 65 ;for 8925.1 entry FILEDA. 66 ; Requires FILEDA. 67 ; Requires TIUFTLST as set in TYPELIST^TIUFLF7 68 ; Requires PFILEDA if entry has prospective (as in Create and Add Item) 69 ;or actual parent in order to try to stuff Type. 70 ; Stuffs .03 Print Name = First 60 chars of .01 Name if not from copy 71 ;action. 72 ; Stuffs .04 Type if only 1 possible type in TIUFTLST (because of parent 73 ;or duplicates or option e.g. create objects). 74 ; Stuffs .07 Status = Inactive. 75 ; If receives parent PFILEDA, parent is Shared, then 76 ;stuffs .1 Shared = 1 77 ; Should Lock FILEDA before calling STUFFLDS. 78 N DIE,DA,DR,Y,NAME,PRINTDR,TYPEDR,STATUSDR,SHAREDR 79 N NATL,NATLDR,NODE0,TYPE 80 I '$G(PFILEDA) S PFILEDA=0 81 S DIE=8925.1,DA=FILEDA 82 S NODE0=^TIU(8925.1,FILEDA,0),NAME=$P(NODE0,U),PRINTDR=".03///^S X=NAME" 83 I $L(TIUFTLST,U)=3 S TYPE=$P(TIUFTLST,U,2),TYPEDR=".04////^S X=TYPE" 84 S STATUSDR=".07///INACTIVE" 85 S SHAREDR=".1////1" 86 I $G(XQORNOD(0))'["Copy" S DR=PRINTDR 87 I $G(TYPEDR) S DR=$S($D(DR):DR_";"_TYPEDR,1:TYPEDR) 88 S DR=$S($D(DR):DR_";"_STATUSDR,1:STATUSDR) 89 I $P($G(^TIU(8925.1,PFILEDA,0)),U,10) S DR=DR_";"_SHAREDR 90 D ^DIE 91 STUFFX Q 92 ; 93 ADDTEN(PFILEDA,FILEDA,NODE0,TENDA) ; Add item FILEDA to 10 NODE of 94 ;File 8925.1 entry PFILEDA. Stuff item Menu Text 95 ; Requires PFILEDA = 8925.1 IFN of parent of FILEDA. 96 ; Requires FILEDA, Requires NODE0 = ^TIU(8925.1,FILEDA,0) 97 ; Returns TENDA = 10 node DA of new item. 98 ; Returns TENDA="" if fails lookup. Screen on fld 10, subfld .01 99 ;prevents lookup failure due to duplicate names by allowing only 100 ;FILEDA to pass screen. 101 ;Should Lock PFILEDA before calling ADDTEN. 102 N X,Y,DIE,DR,NAME,DA,DIC,DLAYGO,TIUFISCR,MSG,DUPITEM 103 S TENDA="" 104 I ('$G(PFILEDA))!('$G(FILEDA)) G ADDTX 105 S NAME=$P(NODE0,U) 106 I '$D(TIUFTLST) S DUPITEM=0,DUPITEM=$$DUPITEM^TIUFLF7(NAME,PFILEDA) I DUPITEM S MSG=" Can't add Item; Parent already has Item with the same Name" W !!,MSG,! G ADDTX ; possibly needed when called from TIU rather than from TIUF. 107 S X=""""_NAME_"""" 108 S DA(1)=PFILEDA,DLAYGO=8925.1 109 S TIUFISCR=FILEDA ; activates screen on fld 10, Subfld .01 in DD 110 S DIC="^TIU(8925.1,DA(1),10,",DIC(0)="L",DIC("P")=$P(^DD(8925.1,10,0),U,2) 111 D ^DIC S TENDA=+Y I Y=-1 S TENDA="" G ADDTX 112 K DIC 113 S DA=TENDA,DA(1)=PFILEDA D MTXTCHEC^TIUFT1(.DA,FILEDA,1) 114 ADDTX Q 115 ; -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7.m
r613 r623 1 TIUHL7 ; SLC/AJB - TIUHL7 Msg Mgr ; 10OCT05 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 3 Q 4 ACTION(ACT) ; 5 N TIUMSG,TIUSEL 6 D FULL^VALM1 7 I VALMCNT=0 W !,"No documents to select." H 3 Q 8 S TIUSEL=$P(XQORNOD(0),"=",2) 9 I TIUSEL="" D Q:'+TIUSEL 10 . I VALMLST=1 S TIUSEL=1 Q 11 . N DIR,X,Y 12 . S DIR("A")=$S(ACT="DELETE":"Select Message(s) to Delete",ACT="VIEW":"Select Message to View")_": (1-"_VALMLST_") " 13 . S DIR("?")=$S(ACT="DELETE":"Select one or more messages to be deleted",ACT="VIEW":"Select one message to view") 14 . S DIR(0)=$S(ACT="DELETE":"L",ACT="VIEW":"N")_"OA^1:"_VALMLST 15 . D ^DIR S TIUSEL=Y 16 I TIUSEL["," S TIUSEL=$E(TIUSEL,1,($L(TIUSEL)-1)) 17 F X=1:1:$L(TIUSEL,",") S TIUMSG($P(TIUSEL,",",X))=$O(@VALMAR@("IDX",$P(TIUSEL,",",X),"")) 18 I ACT="SELECT" S ACT=$S(+$L(TIUSEL,",")=1:"VIEW",1:"DELETE") 19 D @ACT 20 Q 21 DELETE ; 22 D FULL^VALM1 23 W @IOF,"Deleting the following message(s):",! 24 W !," Receiving Sending Message",! 25 W IOUON," Message ID Date/Time Processed Application Application Status ",!,IOUOFF 26 S TIUSEL="" F S TIUSEL=$O(TIUMSG(TIUSEL)) Q:'+TIUSEL W @VALMAR@(TIUSEL,0),! ; TIUSEL," ",TIUMSG(TIUSEL),! 27 I $$READ^TIUU("Y","Delete message(s)") D 28 . S TIUSEL="" F S TIUSEL=$O(TIUMSG(TIUSEL)) Q:'+TIUSEL K ^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U)) 29 . W !!,"Deleting...finished." 30 W ! I $$READ^TIUU("EA","Press <RETURN> to continue") 31 D CLEAN^VALM10,INIT,RE^VALM4 32 S VALMBG=1 33 Q 34 REFRESH ; 35 D CLEAN^VALM10,INIT,RE^VALM4 36 S VALMBG=1 37 Q 38 VIEW ; 39 D EN^TIUHL7A 40 D CLEAN^VALM10,INIT,RE^VALM4 41 S VALMBG=1 42 Q 43 EN ; main entry point for TIUHL7 MSG MGR 44 N POP 45 D EN^VALM("TIUHL7 MSG MGR") 46 Q 47 HDR ; header code 48 N HDR S HDR="TIUHL7 Received Messages" 49 S VALMHDR(1)=$$SETSTR^VALM1(HDR,"",(IOM-$L(HDR))/2,$L(HDR)) 50 S VALMHDR(2)="" 51 S VALMHDR(3)=" Receiving Sending Message" 52 D XQORM 53 Q 54 INIT ; init variables and list array 55 N TIU,TIUDISP,TIUDT,TIUFS,TIUMID 56 S TIU("CUOFF")=$C(27)_"[?25l",TIU("CUON")=$C(27)_"[?25h" ; cursor values 57 W TIU("CUOFF"),!!,"Searching for messages..." 58 S (TIUDT,VALMCNT)=0,(TIUDISP,TIUMID)="" 59 F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT F S TIUMID=$O(^XTMP("TIUHL7",TIUDT,TIUMID)) Q:'+TIUMID D 60 . S VALMCNT=VALMCNT+1 W:VALMCNT#3=0 "." 61 . S TIUFS=$E($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),4) 62 . S TIUDISP=$$SETSTR^VALM1(VALMCNT,"",1,8) 63 . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),TIUFS,3),TIUDISP,"Message ID") 64 . S TIUDISP=$$SETFLD^VALM1($$FMTE^XLFDT(TIUDT),TIUDISP,"Date/Time Processed") 65 . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),TIUFS,4),TIUDISP,"RecApp") 66 . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),TIUFS,5),TIUDISP,"SendApp") 67 . S TIU=$P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),TIUFS,2),TIU=$S(TIU="AR":"Rejected",TIU="AA":"Accepted",1:"Unknown") 68 . S TIUDISP=$$SETFLD^VALM1(TIU,TIUDISP,"Status") 69 . D SET^VALM10(VALMCNT,TIUDISP,TIUMID_U_TIUDT) 70 ; 71 I VALMCNT=0 D 72 . S TIU="No records found to satisfy search criteria." 73 . D SET^VALM10(2,$$SETSTR^VALM1(TIU,"",(IOM-$L(TIU))/2,$L(TIU)),0) 74 Q 75 HELP ; help code 76 I X="?" S POP=1 77 D FULL^VALM1 78 W !!,"The following actions are available:" 79 W !!,"View a Message - View a selected message" 80 W !,"Delete Message(s) - Delete selected message(s)" 81 W !,"Refresh Message List - Refresh display" 82 W !!,"If ONE message is selected, default action is VIEW" 83 W !,"If multiple messages are selected, default action is DELETE",! 84 I +$G(POP) I $$READ^TIUU("EA","Press <RETURN> to continue") 85 S VALMBCK="R",POP=0 86 Q 87 EXIT ; exit code 88 D XQORM 89 Q 90 EXPND ; expand code 91 Q 92 XQORM ; default action for list manager 93 S XQORM("#")=$O(^ORD(101,"B","TIUHL7 MSG MGR SELECT",0))_U_"1:"_VALMCNT 94 Q 1 TIUHL7 ; SLC/AJB - TIUHL7 Msg Mgr ; 10OCT05 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 3 Q 4 ACTION(ACT) ; 5 N TIUMSG,TIUSEL 6 D FULL^VALM1 7 I VALMCNT=0 W !,"No documents to select." H 3 Q 8 S TIUSEL=$P(XQORNOD(0),"=",2) 9 I TIUSEL="" D Q:'+TIUSEL 10 . I VALMLST=1 S TIUSEL=1 Q 11 . N DIR,X,Y 12 . S DIR("A")=$S(ACT="DELETE":"Select Message(s) to Delete",ACT="VIEW":"Select Message to View")_": (1-"_VALMLST_") " 13 . S DIR("?")=$S(ACT="DELETE":"Select one or more messages to be deleted",ACT="VIEW":"Select one message to view") 14 . S DIR(0)=$S(ACT="DELETE":"L",ACT="VIEW":"N")_"OA^1:"_VALMLST 15 . D ^DIR S TIUSEL=Y 16 I TIUSEL["," S TIUSEL=$E(TIUSEL,1,($L(TIUSEL)-1)) 17 F X=1:1:$L(TIUSEL,",") S TIUMSG($P(TIUSEL,",",X))=$O(@VALMAR@("IDX",$P(TIUSEL,",",X),"")) 18 I ACT="SELECT" S ACT=$S(+$L(TIUSEL,",")=1:"VIEW",1:"DELETE") 19 D @ACT 20 Q 21 DELETE ; 22 D FULL^VALM1 23 W @IOF,"Deleting the following message(s):",! 24 W !," Receiving Sending Message",! 25 W IOUON," Message ID Date/Time Processed Application Application Status ",!,IOUOFF 26 S TIUSEL="" F S TIUSEL=$O(TIUMSG(TIUSEL)) Q:'+TIUSEL W @VALMAR@(TIUSEL,0),! ; TIUSEL," ",TIUMSG(TIUSEL),! 27 I $$READ^TIUU("Y","Delete message(s)") D 28 . S TIUSEL="" F S TIUSEL=$O(TIUMSG(TIUSEL)) Q:'+TIUSEL K ^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U)) 29 . W !!,"Deleting...finished." 30 W ! I $$READ^TIUU("EA","Press <RETURN> to continue") 31 D CLEAN^VALM10,INIT,RE^VALM4 32 S VALMBG=1 33 Q 34 REFRESH ; 35 D CLEAN^VALM10,INIT,RE^VALM4 36 S VALMBG=1 37 Q 38 VIEW ; 39 D EN^TIUHL7A 40 D CLEAN^VALM10,INIT,RE^VALM4 41 S VALMBG=1 42 Q 43 EN ; main entry point for TIUHL7 MSG MGR 44 N POP 45 D EN^VALM("TIUHL7 MSG MGR") 46 Q 47 HDR ; header code 48 N HDR S HDR="TIUHL7 Received Messages" 49 S VALMHDR(1)=$$SETSTR^VALM1(HDR,"",(IOM-$L(HDR))/2,$L(HDR)) 50 S VALMHDR(2)="" 51 S VALMHDR(3)=" Receiving Sending Message" 52 D XQORM 53 Q 54 INIT ; init variables and list array 55 N TIU,TIUDISP,TIUDT,TIUMID 56 S TIU("CUOFF")=$C(27)_"[?25l",TIU("CUON")=$C(27)_"[?25h" ; cursor values 57 W TIU("CUOFF"),!!,"Searching for messages..." 58 S (TIUDT,VALMCNT)=0,(TIUDISP,TIUMID)="" 59 F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT F S TIUMID=$O(^XTMP("TIUHL7",TIUDT,TIUMID)) Q:'+TIUMID D 60 . S VALMCNT=VALMCNT+1 W:VALMCNT#3=0 "." 61 . S TIUDISP=$$SETSTR^VALM1(VALMCNT,"",1,8) 62 . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),U,3),TIUDISP,"Message ID") 63 . S TIUDISP=$$SETFLD^VALM1($$FMTE^XLFDT(TIUDT),TIUDISP,"Date/Time Processed") 64 . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),U,4),TIUDISP,"RecApp") 65 . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),U,5),TIUDISP,"SendApp") 66 . S TIU=$P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),U,2),TIU=$S(TIU="AR":"Rejected",TIU="AA":"Accepted",1:"Unknown") 67 . S TIUDISP=$$SETFLD^VALM1(TIU,TIUDISP,"Status") 68 . D SET^VALM10(VALMCNT,TIUDISP,TIUMID_U_TIUDT) 69 ; 70 I VALMCNT=0 D 71 . S TIU="No records found to satisfy search criteria." 72 . D SET^VALM10(2,$$SETSTR^VALM1(TIU,"",(IOM-$L(TIU))/2,$L(TIU)),0) 73 Q 74 HELP ; help code 75 I X="?" S POP=1 76 D FULL^VALM1 77 W !!,"The following actions are available:" 78 W !!,"View a Message - View a selected message" 79 W !,"Delete Message(s) - Delete selected message(s)" 80 W !,"Refresh Message List - Refresh display" 81 W !!,"If ONE message is selected, default action is VIEW" 82 W !,"If multiple messages are selected, default action is DELETE",! 83 I +$G(POP) I $$READ^TIUU("EA","Press <RETURN> to continue") 84 S VALMBCK="R",POP=0 85 Q 86 EXIT ; exit code 87 D XQORM 88 Q 89 EXPND ; expand code 90 Q 91 XQORM ; default action for list manager 92 S XQORM("#")=$O(^ORD(101,"B","TIUHL7 MSG MGR SELECT",0))_U_"1:"_VALMCNT 93 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7A.m
r613 r623 1 TIUHL7A 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 19973 4 DELETE 5 6 7 8 9 10 11 REPROC 12 13 14 15 16 17 18 19 EN 20 21 22 K ^TMP("VALMAR",$J,TIULVL)23 24 HDR 25 26 INIT 27 28 29 30 31 32 33 34 35 36 HELP 37 38 39 40 41 42 43 44 45 EXIT 46 47 EXPND 48 1 TIUHL7A ; SLC/AJB - TIUHL7 Msg Mgr ; 10OCT05 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 3 Q 4 DELETE ; 5 D FULL^VALM1 6 W ! I $$READ^TIUU("Y","Are you sure you wish to delete this message") D 7 . K ^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U)) 8 . W !!,"Message deleted." 9 W ! I $$READ^TIUU("EA","Press <RETURN> to continue") 10 Q 11 REPROC ; 12 N HL771RF,HL771SF,HLCS,HLDOM,HLINSTN,HLPARAM,HLPID,HLREC,HLRFREQ,HLSFREQ 13 D FULL^VALM1 14 W !!,"Reprocessing message..." 15 I '$$REPROC^HLUTIL($P(TIUMSG(TIUSEL),U),"PROCMSG^TIUHL7P1") W !,"finished.",! I $$READ^TIUU("EA","Press <RETURN> to continue") Q 16 W "ERROR. Unable to reprocess this message.",! 17 I $$READ^TIUU("EA","Press <RETURN> to continue") 18 Q 19 EN ; main entry point for TIUHL7 MSG VIEW 20 N TIULVL 21 D EN^VALM("TIUHL7 MSG VIEW") 22 K ^XTMP("VALMAR",$J,TIULVL) 23 Q 24 HDR ; 25 Q 26 INIT ; 27 N TIULINE,TIUX 28 S TIULVL=VALMEVL,VALMCNT=0 29 F TIUX="MSGRESULT","MSG" D 30 . N TIUCNT,TIUTEXT,TIUVAL S TIUVAL=80 ; TIUVAL is column width for display in LM - each line will be <=TIUVAL 31 . S TIULINE="" F S TIULINE=$O(^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U),TIUX,TIULINE)) Q:'+TIULINE D 32 . . S TIUTEXT=^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U),TIUX,TIULINE) 33 . . F TIUCNT=1:1:(($L(TIUTEXT)\TIUVAL)+1) S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT,$E(TIUTEXT,(TIUVAL*(TIUCNT-1)+1),(TIUVAL*TIUCNT))) 34 . S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT,"") 35 Q 36 HELP ; help code 37 I X="?" S POP=1 38 D FULL^VALM1 39 W !!,"The following actions are available:" 40 W !!,"Delete Message - Delete the current message" 41 W !,"Reprocess Message - Reprocess the current message",! 42 I +$G(POP) I $$READ^TIUU("EA","Press <RETURN> to continue") 43 S VALMBCK="R",POP=0 44 Q 45 EXIT ; exit code 46 Q 47 EXPND ; expand code 48 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P1.m
r613 r623 1 TIUHL7P1 ; SLC/AJB - TIUHL7 Msg Processing; January 6, 2006 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 3 Q 4 PROCMSG ; 5 N DFN,DUZ,TIU,TIUDA,TIUDPRM,TIUDT,TIUERR,TIUI,TIUJ,TIUMSG,TIUNAME,TIUTMP,TIUFS,TIUCS,TIURS,TIUES,TIUSS,TIUZ 6 ; 7 ; quit if HL7 Message IEN is not present 8 ;I '+$G(HLMTIENS) Q 9 ; 10 ; remove HL7 message entries 7 days or older 11 D CLEAN^TIUHL7U1 12 ; 13 ; sets field, component and repetition separators from HL7 Message 14 S TIUFS=$G(HL("FS")),TIUJ=0 F TIUI="TIUCS","TIURS","TIUES","TIUSS" S TIUJ=TIUJ+1 S @TIUI=$E(HL("ECH"),TIUJ,TIUJ) 15 ; 16 ; initializes variables and ^XTMP expiration 17 S TIU="TIU",(TIU("EC"),TIUDA)=0,TIUDT=+$$NOW^XLFDT,TIUNAME=$NA(^XTMP("TIUHL7",TIUDT,HLMTIENS)),^XTMP("TIUHL7",0)=$$FMADD^XLFDT(TIUDT,7)_U_TIUDT 18 ; 19 ; retrieves HL7 message and stores to temporary global 20 F TIUI=1:1 X HLNEXT Q:HLQUIT'>0 D 21 . S @TIUNAME@("MSG",TIUI)=HLNODE,TIUJ=0 22 . F S TIUJ=$O(HLNODE(TIUJ)) Q:'TIUJ S @TIUNAME@("MSG",TIUI)=@TIUNAME@("MSG",TIUI)_HLNODE(TIUJ) 23 ; 24 ; places temporary global in local meory & adds EOM flag 25 M TIUMSG=@TIUNAME@("MSG") 26 S TIU("XTMP")=TIUNAME,TIUNAME="TIUMSG",TIUI="",TIUI=$O(TIUMSG(TIUI),-1),TIUI=TIUI+1,TIUMSG(TIUI)="EOM" 27 ; 28 ; verify message format 29 S TIUI="" F S TIUI=$O(@TIUNAME@(TIUI)) Q:@TIUNAME@(TIUI)="EOM" D 30 . S TIUJ=$S(TIUI=1:"MSH",TIUI=2:"EVN",TIUI=3:"PID",TIUI=4:"PV1",TIUI=5:"TXA",TIUI=6:"OBX",1:"OBX") 31 . I $P(@TIUNAME@(TIUI),TIUFS)'=TIUJ D ERR^TIUHL7U1("MSG",1,"000.000","Improper/missing message format: "_TIUJ_" segment.") 32 ; 33 ; if message fails check, quit processing 34 I +TIU("EC") D ACK^TIUHL7U1("AR",TIUNAME,-1) Q 35 ; 36 ; get patient name [required] 37 S TIU("PTNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(3)),TIUFS,6),TIUCS,1,4),TIUCS)),TIU("PTNAME")=$$REMESC^TIUHL7U1(TIU("PTNAME")) 38 ; 39 ; get patient ICN/SSN/DFN - order may vary [conditionally required] 40 S (TIU("DFN"),TIU("ICN"),TIU("SSN"))="" F TIUI=1:1:$L($P($G(@TIUNAME@(3)),TIUFS,4),TIURS) S TIUJ=$P($P($G(@TIUNAME@(3)),TIUFS,4),TIURS,TIUI) I +TIUJ>0 D 41 . S TIUTMP=$S($P(TIUJ,TIUCS,5)="NI":"ICN",$P(TIUJ,TIUCS,5)="SS":"SSN",$P(TIUJ,TIUCS,5)="PI":"DFN",1:"UNK") 42 . S @TIU@(TIUTMP)=$$REMESC^TIUHL7U1($P(TIUJ,TIUCS)) I TIUTMP="ICN",@TIU@(TIUTMP)["V" S @TIU@(TIUTMP)=$P(@TIU@(TIUTMP),"V") 43 ; 44 ; get PATIENT DOB (optional) 45 S TIU("DOB")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(3)),TIUFS,8))) 46 ; 47 ; get DOCUMENT TITLE (#8925.1) [required] & set IEN 48 S TIU("TITLE")=$$UPPER^HLFNC($P($G(@TIUNAME@(5)),TIUFS,17)),TIU("TITLE")=$$REMESC^TIUHL7U1(TIU("TITLE")) 49 S TIU("TDA")=$$LU^TIUHL7U1(8925.1,TIU("TITLE"),"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""") I $L(TIU("TITLE"))'>0 S TIU("TITLE")="[UNKNOWN]" 50 ; 51 ; get DOCUMENT AVAILABILITY [optional] 52 S TIU("AVAIL")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,20)) 53 ; 54 ;gets DOCUMENT COMPLETION STATUS [optional] 55 S TIU("COMP")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,18)) 56 ; 57 ; get REFERENCE DATE [required] 58 S TIU("RFDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,5))) I TIU("RFDT")'>-1 D ERR^TIUHL7U1("TXA",4,"0000.00","Invalid HL7 date format for ACTIVITY DATE/TIME[REFERENCE DATE/TIME].") 59 I +$P(TIU("RFDT"),"."),'+$P(TIU("RFDT"),".",2) S $P(TIU("RFDT"),".",2)=$P($$NOW^XLFDT,".",2) 60 ; 61 ; get EPISODE BEGIN DT/TIME [conditionally required for DISCHARGE SUMMARIES] 62 S TIU("EPDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,45))) I TIU("EPDT")'>-1 D ERR^TIUHL7U1("PV1",44,"0000.00","Invalid HL7 date format for ADMIT DATE/TIME [EPISODE BEGIN DATE/TIME].") 63 I +$P(TIU("EPDT"),"."),'+$P(TIU("EPDT"),".",2) S $P(TIU("EPDT"),".",2)=$P($$NOW^XLFDT,".",2) 64 ; 65 ; get DICTATION DT/TIME [optional] 66 S TIU("DICDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,7))) I TIU("DICDT")'>-1 D ERR^TIUHL7U1("TXA",6,"0000.00","Invalid HL7 date format for TRANSCRIPTION DATE/TIME[DICTATION DATE/TIME].") 67 I +$P(TIU("DICDT"),"."),'+$P(TIU("DICDT"),".",2) S $P(TIU("DICDT"),".",2)=$P($$NOW^XLFDT,".",2) 68 ; 69 ; get VISIT # [optional] 70 S TIU("VNUM")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,20)) 71 ; 72 ; get HOSPITAL LOCATION [conditionally required for NEW VISITS] 73 S TIU("HLOC")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(4)),TIUFS,4),TIUCS)) I +$L(TIU("HLOC")) S TIU("HLOC")=+$$LU^TIUHL7U1(44,TIU("HLOC")) 74 ; 75 ; get AUTHOR/DICTATOR SSN or IEN [optional] & NAME [required] 76 S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS,9)'="USSSA":"AUDA",1:"AUSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS) 77 S TIU("AUNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS,2,4),TIUCS)),TIU("AUNAME")=$$REMESC^TIUHL7U1(TIU("AUNAME")) 78 ; 79 ; get EXPECTED COSIGNER SSN or IEN [optional] & NAME [conditionally required] 80 S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS,9)'="USSSA":"CSDA",1:"CSSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS) 81 S TIU("CSNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS,2,4),TIUCS)),TIU("CSNAME")=$$REMESC^TIUHL7U1(TIU("CSNAME")) 82 ; 83 ; get ENTERED BY SSN or IEN [optional] & NAME [optional] 84 S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS,9)'="USSSA":"EBDA",1:"EBSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS) 85 S TIU("EBNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS,2,4),TIUCS)),TIU("EBNAME")=$$REMESC^TIUHL7U1(TIU("EBNAME")) 86 ; 87 ; get SURGICAL CASE or CONSULT # [conditionally required for SURGICAL REPORTS or CONSULT titles] 88 S TIUTMP=$S($$MEMBEROF^TIUHL7U1(TIU("TITLE"),"CONSULTS"):"CNCN",1:"SRCN") S @TIU@(TIUTMP)=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,13),TIUCS)) 89 ; 90 ; gets SIGNATURE/COSIGNATURE DATE/TIME [optional] 91 S TIU("SIGNED")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,23),TIUCS,15)),TIU("CSIGNED")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,23),TIUCS,29)) 92 ; 93 ; get DOCUMENT TEXT [required] 94 S TIUTMP="" F S TIUTMP=$O(@TIUNAME@(TIUTMP)) Q:TIUTMP="" D:$P($G(@TIUNAME@(TIUTMP)),TIUFS)="OBX" 95 . I $P(@TIUNAME@(TIUTMP),TIUFS,2)=1,$L($G(TIU("SUB")))'>0 S TIU("SUB")=$P($P(@TIUNAME@(TIUTMP),TIUFS,4),TIUCS,2),TIU("SUB")=$$REMESC^TIUHL7U1(TIU("SUB")) 96 . F TIUI=1:1:$L($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS) S TIUZ("TEXT",TIUI,0)=$P($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS,TIUI),TIUZ("TEXT",TIUI,0)=$$STRIP^TIUHL7U2($$REMESC^TIUHL7U1(TIUZ("TEXT",TIUI,0))) 97 ; 98 ; begin data verification 99 ; PATIENT IDENTIFICATION 100 D 101 . N TIUI,TIUJ,TIUERR,TIUN,TIUOUT,TIUTMP,TIUQUIT 102 . I '+$L($G(TIU("PTNAME"))) D ERR^TIUHL7U1("PID",5,"0000.00","Missing PATIENT NAME.") 103 . ; verify there is at least one piece of numeric PATIENT ID 104 . S TIUJ=0 F TIUI="ICN","DFN","SSN" S:+$G(TIU(TIUI)) TIUJ=TIUJ+1 105 . I '+TIUJ D ERR^TIUHL7U1("PID",5,"0000.00","Missing numeric PATIENT ID data; at least one numeric identifier [ICN,SSN,DFN] must be sent.") Q 106 . I +TIUJ=1 D 107 . . I '+$L($P(TIU("PTNAME"),",",2)) D ERR^TIUHL7U1("PID",5,"0000.00","FIRST NAME/INITIAL missing with only one numeric identifier sent.") 108 . . S TIUN("PT")=$$PNAME^TIUHL7U1(TIU("PTNAME")),TIUTMP=1 109 . E S TIUN("PT")=$P(TIU("PTNAME"),",") 110 . S TIUJ=0 111 . ; check DFN if available 112 . I +$G(TIU("DFN")) S TIUJ=TIUJ+1,DFN(TIUJ)=TIU("DFN") D 113 . . I +$G(TIUTMP) S TIUN("DFN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,TIU("DFN"),.01)) 114 . . E S TIUN("DFN")=$P($$GET1^DIQ(2,TIU("DFN"),.01),",") 115 . . I '$$COMPARE^TIUHL7U1(TIUN("DFN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message DFN #"_TIU("DFN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") 116 . ; check ICN if available 117 . I +$G(TIU("ICN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("ICN"),"AICN") D 118 . . I +$G(TIUTMP) S TIUN("ICN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01)) 119 . . E S TIUN("ICN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",") 120 . . I '$$COMPARE^TIUHL7U1(TIUN("ICN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message ICN #"_TIU("ICN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") 121 . ; check SSN if available 122 . I +$G(TIU("SSN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("SSN"),"SSN") D 123 . . I +$G(TIUTMP) S TIUN("SSN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01)) 124 . . E S TIUN("SSN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",") 125 . . I '$$COMPARE^TIUHL7U1(TIUN("SSN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message SSN #"_TIU("SSN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") 126 . ; compare DFN lookup values 127 . I TIUJ>1 S (TIUI,TIUJ)=0 F S TIUI=$O(DFN(TIUI)) Q:'TIUI I TIUI>1 S TIUJ=TIUI-1 I DFN(TIUI)'=DFN(TIUJ) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT IEN discrepancies between the numeric lookups.") Q 128 . I TIU("EC") Q 129 . S DFN=DFN(1) 130 ; 131 D CONTINUE^TIUHL7P2 132 Q 1 TIUHL7P1 ; SLC/AJB - TIUHL7 Msg Processing; January 6, 2006 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 3 Q 4 PROCMSG ; 5 N DFN,DUZ,TIU,TIUDA,TIUDPRM,TIUDT,TIUERR,TIUI,TIUJ,TIUMSG,TIUNAME,TIUTMP,TIUFS,TIUCS,TIURS,TIUES,TIUSS,TIUZ 6 ; 7 ; quit if HL7 Message IEN is not present 8 I '+$G(HLMTIENS) Q 9 ; 10 ; remove HL7 message entries 7 days or older 11 D CLEAN^TIUHL7U1 12 ; 13 ; sets field, component and repetition separators from HL7 Message 14 S TIUFS=$G(HL("FS")),TIUJ=0 F TIUI="TIUCS","TIURS","TIUES","TIUSS" S TIUJ=TIUJ+1 S @TIUI=$E(HL("ECH"),TIUJ,TIUJ) 15 ; 16 ; initializes variables and ^XTMP expiration 17 S TIU="TIU",(TIU("EC"),TIUDA)=0,TIUDT=+$$NOW^XLFDT,TIUNAME=$NA(^XTMP("TIUHL7",TIUDT,HLMTIENS)),^XTMP("TIUHL7",0)=$$FMADD^XLFDT(TIUDT,7)_U_TIUDT 18 ; 19 ; retrieves HL7 message and stores to temporary global 20 F TIUI=1:1 X HLNEXT Q:HLQUIT'>0 D 21 . S @TIUNAME@("MSG",TIUI)=HLNODE,TIUJ=0 22 . F S TIUJ=$O(HLNODE(TIUJ)) Q:'TIUJ S @TIUNAME@("MSG",TIUI)=@TIUNAME@("MSG",TIUI)_HLNODE(TIUJ) 23 ; 24 ; places temporary global in local memory 25 S TIUI="" F S TIUI=$O(@TIUNAME@("MSG",TIUI)) Q:'+TIUI S TIUMSG(TIUI)=@TIUNAME@("MSG",TIUI) 26 S TIU("XTMP")=TIUNAME,TIUNAME="TIUMSG" 27 ; 28 ; verifies message format 29 S TIUI="" F S TIUI=$O(@TIUNAME@(TIUI)) Q:'+TIUI D 30 . S TIUI=0 F TIUJ="MSH","EVN","PID","PV1","TXA","OBX" S TIUI=TIUI+1 D 31 . . I $P(@TIUNAME@(TIUI),TIUFS)'=TIUJ D ERR^TIUHL7U1("MSG",1,"000.000","Improper message format: "_TIUJ_" segment.") 32 ; 33 ; parse message data 34 ; get patient name [required] 35 S TIU("PTNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(3)),TIUFS,6),TIUCS,1,4),TIUCS)),TIU("PTNAME")=$$REMESC^TIUHL7U1(TIU("PTNAME")) 36 ; 37 ; get patient ICN/SSN/DFN - order may vary [conditionally required] 38 S (TIU("DFN"),TIU("ICN"),TIU("SSN"))="" F TIUI=1:1:$L($P($G(@TIUNAME@(3)),TIUFS,4),TIURS) S TIUJ=$P($P($G(@TIUNAME@(3)),TIUFS,4),TIURS,TIUI) I +TIUJ>0 D 39 . S TIUTMP=$S($P(TIUJ,TIUCS,5)="NI":"ICN",$P(TIUJ,TIUCS,5)="SS":"SSN",$P(TIUJ,TIUCS,5)="PI":"DFN",1:"UNK") 40 . S @TIU@(TIUTMP)=$$REMESC^TIUHL7U1($P(TIUJ,TIUCS)) I TIUTMP="ICN",@TIU@(TIUTMP)["V" S @TIU@(TIUTMP)=$P(@TIU@(TIUTMP),"V") 41 ; 42 ; get PATIENT DOB (optional) 43 S TIU("DOB")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(3)),TIUFS,8))) 44 ; 45 ; get DOCUMENT TITLE (#8925.1) [required] & set IEN 46 S TIU("TITLE")=$$UPPER^HLFNC($P($G(@TIUNAME@(5)),TIUFS,17)),TIU("TITLE")=$$REMESC^TIUHL7U1(TIU("TITLE")) 47 S TIU("TDA")=$$LU^TIUHL7U1(8925.1,TIU("TITLE"),"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""") I $L(TIU("TITLE"))'>0 S TIU("TITLE")="[UNKNOWN]" 48 ; 49 ; get DOCUMENT AVAILABILITY [optional] 50 S TIU("AVAIL")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,20)) 51 ; 52 ;gets DOCUMENT COMPLETION STATUS [optional] 53 S TIU("COMP")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,18)) 54 ; 55 ; get REFERENCE DATE [required] 56 S TIU("RFDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,5))) I TIU("RFDT")'>-1 D ERR^TIUHL7U1("TXA",4,"0000.00","Invalid HL7 date format for ACTIVITY DATE/TIME[REFERENCE DATE/TIME].") 57 I +$P(TIU("RFDT"),"."),'+$P(TIU("RFDT"),".",2) S $P(TIU("RFDT"),".",2)=$P($$NOW^XLFDT,".",2) 58 ; 59 ; get EPISODE BEGIN DT/TIME [conditionally required for DISCHARGE SUMMARIES] 60 S TIU("EPDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,45))) I TIU("EPDT")'>-1 D ERR^TIUHL7U1("PV1",44,"0000.00","Invalid HL7 date format for ADMIT DATE/TIME [EPISODE BEGIN DATE/TIME].") 61 I +$P(TIU("EPDT"),"."),'+$P(TIU("EPDT"),".",2) S $P(TIU("EPDT"),".",2)=$P($$NOW^XLFDT,".",2) 62 ; 63 ; get DICTATION DT/TIME [optional] 64 S TIU("DICDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,7))) I TIU("DICDT")'>-1 D ERR^TIUHL7U1("TXA",6,"0000.00","Invalid HL7 date format for TRANSCRIPTION DATE/TIME[DICTATION DATE/TIME].") 65 I +$P(TIU("DICDT"),"."),'+$P(TIU("DICDT"),".",2) S $P(TIU("DICDT"),".",2)=$P($$NOW^XLFDT,".",2) 66 ; 67 ; get VISIT # [optional] 68 S TIU("VNUM")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,20)) 69 ; 70 ; get HOSPITAL LOCATION [conditionally required for NEW VISITS] 71 S TIU("HLOC")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(4)),TIUFS,4),TIUCS)) I +$L(TIU("HLOC")) S TIU("HLOC")=+$$LU^TIUHL7U1(44,TIU("HLOC")) 72 ; 73 ; get AUTHOR/DICTATOR SSN or IEN [optional] & NAME [required] 74 S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS,9)'="USSSA":"AUDA",1:"AUSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS) 75 S TIU("AUNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS,2,4),TIUCS)),TIU("AUNAME")=$$REMESC^TIUHL7U1(TIU("AUNAME")) 76 ; 77 ; get EXPECTED COSIGNER SSN or IEN [optional] & NAME [conditionally required] 78 S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS,9)'="USSSA":"CSDA",1:"CSSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS) 79 S TIU("CSNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS,2,4),TIUCS)),TIU("CSNAME")=$$REMESC^TIUHL7U1(TIU("CSNAME")) 80 ; 81 ; get ENTERED BY SSN or IEN [optional] & NAME [optional] 82 S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS,9)'="USSSA":"EBDA",1:"EBSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS) 83 S TIU("EBNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS,2,4),TIUCS)),TIU("EBNAME")=$$REMESC^TIUHL7U1(TIU("EBNAME")) 84 ; 85 ; get SURGICAL CASE or CONSULT # [conditionally required for SURGICAL REPORTS or CONSULT titles] 86 S TIUTMP=$S($$MEMBEROF^TIUHL7U1(TIU("TITLE"),"CONSULTS"):"CNCN",1:"SRCN") S @TIU@(TIUTMP)=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,13),TIUCS)) 87 ; 88 ; gets SIGNATURE/COSIGNATURE DATE/TIME [optional] 89 S TIU("SIGNED")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,23),TIUCS,15)),TIU("CSIGNED")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,23),TIUCS,29)) 90 ; 91 ; get DOCUMENT TEXT [required] 92 S TIUTMP="" F S TIUTMP=$O(@TIUNAME@(TIUTMP)) Q:TIUTMP="" D:$P($G(@TIUNAME@(TIUTMP)),TIUFS)="OBX" 93 . I $P(@TIUNAME@(TIUTMP),TIUFS,2)=1,$L($G(TIU("SUB")))'>0 S TIU("SUB")=$P($P(@TIUNAME@(TIUTMP),TIUFS,4),TIUCS,2),TIU("SUB")=$$REMESC^TIUHL7U1(TIU("SUB")) 94 . F TIUI=1:1:$L($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS) S TIUZ("TEXT",TIUI,0)=$P($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS,TIUI),TIUZ("TEXT",TIUI,0)=$$STRIP^TIUHL7U2($$REMESC^TIUHL7U1(TIUZ("TEXT",TIUI,0))) 95 ; 96 ; begin data verification 97 ; PATIENT IDENTIFICATION 98 D 99 . N TIUI,TIUJ,TIUERR,TIUN,TIUOUT,TIUTMP,TIUQUIT 100 . I '+$L($G(TIU("PTNAME"))) D ERR^TIUHL7U1("PID",5,"0000.00","Missing PATIENT NAME.") 101 . ; verify there is at least one piece of numeric PATIENT ID 102 . S TIUJ=0 F TIUI="ICN","DFN","SSN" S:+$G(TIU(TIUI)) TIUJ=TIUJ+1 103 . I '+TIUJ D ERR^TIUHL7U1("PID",5,"0000.00","Missing numeric PATIENT ID data; at least one numeric identifier [ICN,SSN,DFN] must be sent.") Q 104 . I +TIUJ=1 D 105 . . I '+$L($P(TIU("PTNAME"),",",2)) D ERR^TIUHL7U1("PID",5,"0000.00","FIRST NAME/INITIAL missing with only one numeric identifier sent.") 106 . . S TIUN("PT")=$$PNAME^TIUHL7U1(TIU("PTNAME")),TIUTMP=1 107 . E S TIUN("PT")=$P(TIU("PTNAME"),",") 108 . S TIUJ=0 109 . ; check DFN if available 110 . I +$G(TIU("DFN")) S TIUJ=TIUJ+1,DFN(TIUJ)=TIU("DFN") D 111 . . I +$G(TIUTMP) S TIUN("DFN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,TIU("DFN"),.01)) 112 . . E S TIUN("DFN")=$P($$GET1^DIQ(2,TIU("DFN"),.01),",") 113 . . I '$$COMPARE^TIUHL7U1(TIUN("DFN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message DFN #"_TIU("DFN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") 114 . ; check ICN if available 115 . I +$G(TIU("ICN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("ICN"),"AICN") D 116 . . I +$G(TIUTMP) S TIUN("ICN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01)) 117 . . E S TIUN("ICN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",") 118 . . I '$$COMPARE^TIUHL7U1(TIUN("ICN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message ICN #"_TIU("ICN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") 119 . ; check SSN if available 120 . I +$G(TIU("SSN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("SSN"),"SSN") D 121 . . I +$G(TIUTMP) S TIUN("SSN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01)) 122 . . E S TIUN("SSN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",") 123 . . I '$$COMPARE^TIUHL7U1(TIUN("SSN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message SSN #"_TIU("SSN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") 124 . ; compare DFN lookup values 125 . I TIUJ>1 S (TIUI,TIUJ)=0 F S TIUI=$O(DFN(TIUI)) Q:'TIUI I TIUI>1 S TIUJ=TIUI-1 I DFN(TIUI)'=DFN(TIUJ) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT IEN discrepancies between the numeric lookups.") Q 126 . I TIU("EC") Q 127 . S DFN=DFN(1) 128 ; 129 D CONTINUE^TIUHL7P2 130 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P2.m
r613 r623 1 TIUHL7P2 ; SLC/AJB - TIUHL7 Msg Processing; March 23, 2005 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 3 Q 4 CONTINUE ; data verification 5 ; 6 ; DOCUMENT TEXT 7 D 8 . N TIUI S TIUTMP=0 F S TIUTMP=$O(TIUZ("TEXT",TIUTMP)) Q:'TIUTMP I +$L(TIUZ("TEXT",TIUTMP,0)) S TIUI=1 9 . I '+$G(TIUI) D ERR^TIUHL7U1("OBX",1,"0000.00","Missing DOCUMENT TEXT.") 10 ; 11 ; DOCUMENT TITLE 12 I +TIU("TDA")'>0 D ERR^TIUHL7U1("TXA",16,"0000.00","Could not resolve the document title "_TIU("TITLE")_".") 13 I +$$GET1^DIQ(8925.1,TIU("TDA"),.07,"I")'=11 D ERR^TIUHL7U1("TXA",16,"0000.00","The document title "_TIU("TITLE")_" must be ACTIVE before use.") 14 ; 15 ; AUTHOR/DICTATOR 16 D 17 . I '+$L(TIU("AUNAME")) D ERR^TIUHL7U1("TXA",9,"0000.00","Missing AUTHOR/DICTATOR name from HL7 message.") Q 18 . I '+$G(TIU("AUDA")),'+$G(TIU("AUSSN")) S TIU("AUDA")=$$LU^TIUHL7U1(200,TIU("AUNAME"),"X") I '+TIU("AUDA") D ERR^TIUHL7U1("TXA",9,"0000.00","AUTHOR/DICTATOR name lookup failed for ["_TIU("AUNAME")_"].") Q 19 . I '+$G(TIU("AUDA")),+$G(TIU("AUSSN")) S TIU("AUDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("AUSSN")),"SSN") I '+TIU("AUDA") D ERR^TIUHL7U1("TXA",9,"0000.00","SSN ["_TIU("AUSSN")_"] lookup failed for AUTHOR/DICTATOR.") Q 20 . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("AUDA"),.01),TIU("AUNAME")) D 21 . . D ERR^TIUHL7U1("TXA",9,"0000.00","AUTHOR/DICTATOR name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("AUDA"),.01)_"]"_" & the HL7 message name ["_TIU("AUNAME")_"].") 22 ; 23 ; EXPECTED CO-SIGNER [ignored if AUTHOR/DICTATOR does not require] 24 I $$REQCOSIG^TIULP($G(TIU("TDA")),,$G(TIU("AUDA")),$G(TIU("RFDT"))) D 25 . N TIUTMP 26 . S TIUZ(1506)=1 27 . I +$L($G(TIU("CSNAME")))!(+$G(TIU("CSDA")))!(+$G(TIU("CSSSN"))) D 28 . . I '+$L($G(TIU("CSNAME"))) D ERR^TIUHL7U1("TXA",10,"0000.00","Missing EXPECTED COSIGNER name from HL7 message.") Q 29 . . I '+$G(TIU("CSDA")),'+$G(TIU("CSSSN")) S TIU("CSDA")=$$LU^TIUHL7U1(200,TIU("CSNAME"),"X") I '+TIU("CSDA") D ERR^TIUHL7U1("TXA",10,"0000.000","EXPECTED COSIGNER name lookup failed for ["_TIU("CSNAME")_"].") Q 30 . . I '+$G(TIU("CSDA")),+$G(TIU("CSSSN")) S TIU("CSDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("CSSSN")),"SSN") I '+TIU("CSDA") D ERR^TIUHL7U1("TXA",10,"0000.00","SSN ["_TIU("CSSSN")_"] lookup failed for EXPECTED COSIGNER.") Q 31 . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("CSDA"),.01),TIU("CSNAME")) D 32 . . . D ERR^TIUHL7U1("TXA",10,"0000.00","EXPECTED COSIGNER name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("CSDA"),.01)_"]"_" & HL7 message name ["_TIU("CSNAME")_"].") 33 . I '+$G(TIU("CSDA")) D ERR^TIUHL7U1("TXA",10,"0000.000","Unable to resolve EXPECTED COSIGNER; the AUTHOR/DICTATOR ["_TIU("AUNAME")_"] requires COSIGNATURE.") 34 ; 35 ; ENTERED BY [optional] 36 I +$L($G(TIU("EBNAME")))!(+$G(TIU("EBDA")))!(+$G(TIU("EBSSN"))) D 37 . I '+$L($G(TIU("EBNAME"))) D ERR^TIUHL7U1("TXA",11,"0000.00","Missing ENTERED BY name from HL7 message.") Q 38 . I '+$G(TIU("EBDA")),'+$G(TIU("EBSSN")) S TIU("EBDA")=$$LU^TIUHL7U1(200,TIU("EBNAME"),"X") I '+TIU("EBDA") D ERR^TIUHL7U1("TXA",11,"0000.000","ENTERED BY name lookup failed for ["_TIU("EBNAME")_"].") Q 39 . I '+$G(TIU("EBDA")),+$G(TIU("EBSSN")) S TIU("EBDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("EBSSN")),"SSN") I '+TIU("EBDA") D ERR^TIUHL7U1("TXA",11,"0000.00","SSN ["_TIU("EBSSN")_"] lookup failed for ENTERED BY.") Q 40 . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("EBDA"),.01),TIU("EBNAME")) D 41 . . D ERR^TIUHL7U1("TXA",11,"0000.00","ENTERED BY name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("EBDA"),.01)_"]"_" & HL7 message name ["_TIU("EBNAME")_"].") 42 ; 43 ; EPISODE BEGIN DATE/TIME for DISCHARGE SUMMARIES 44 I $$MEMBEROF^TIUHL7U1(TIU("TITLE"),"DISCHARGE SUMMARIES") D 45 . I '+$G(TIU("CSDA")) D ERR^TIUHL7U1("TXA",10,"0000.000","DISCHARGE SUMMARIES require an ATTENDING PHYSICIAN (EXPECTED COSIGNER).") 46 . S TIUZ(1209)=$G(TIU("CSDA")) 47 . I +TIU("VNUM") D Q 48 . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(9000010,TIU("VNUM"),.05),$S(+$G(DFN):$$GET1^DIQ(2,DFN,.01),1:TIU("PTNAME"))) D 49 . . . D ERR^TIUHL7U1("PV1",19,"0000.00","HL7 message PATIENT NAME ["_TIU("PTNAME")_"] does not match VISIT PATIENT NAME ["_$$GET1^DIQ(9000010,TIU("VNUM"),.05)_"].") Q 50 . . S TIU("EPDT")=$$GET1^DIQ(9000010,TIU("VNUM"),.01,"I"),TIU("VSTR")=$$VSTRBLD^TIUSRVP(TIU("VNUM")) 51 . I '+TIU("EPDT") D ERR^TIUHL7U1("PV1",44,"0000.000",TIU("TITLE")_" requires an EPISODE BEGIN DATE/TIME.") Q 52 . I '+$$GETADMIT^TIUHL7U1(+$G(DFN),TIU("EPDT")) D ERR^TIUHL7U1("PV1","44","0000.00","Could not resolve ADMISSION DT[TIME] for "_$$FMTE^XLFDT(TIUDT)_".") 53 ; 54 ; VISIT information for PROGRESS NOTES 55 I $$MEMBEROF^TIUHL7U1(TIU("TITLE"),"PROGRESS NOTES") D 56 . I TIU("VNUM")="NEW" D Q 57 . . N TYP 58 . . I '+TIU("HLOC"),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1",4,"0000.00","Missing/Invalid HOSPITAL LOCATION ('AV' not set); required for NEW visits.") Q 59 . . I +TIU("EPDT")'>0 S TIU("EPDT")=$$NOW^XLFDT 60 . . I $L(TIU("EPDT"),".")=1 S TIU("EPDT")=TIU("EPDT")_"."_$P($$NOW^XLFDT,".",2) 61 . . I +TIU("HLOC") I $$GET1^DIQ(44,TIU("HLOC"),2,"I")="W" S TYP="I" 62 . . I +TIU("HLOC")'>0 S TIU("HLOC")="" 63 . . S TIU("VSTR")=TIU("HLOC")_";"_TIU("EPDT")_";"_$S($G(TYP)="I":"I",TIU("AVAIL")="AV":"E",1:"A") 64 . I +TIU("VNUM") D Q 65 . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(9000010,TIU("VNUM"),.05),$S(+$G(DFN):$$GET1^DIQ(2,DFN,.01),1:TIU("PTNAME"))) D Q 66 . . . D ERR^TIUHL7U1("PV1",19,"0000.00","HL7 message PATIENT NAME ["_TIU("PTNAME")_"] does not match VISIT PATIENT NAME ["_$$GET1^DIQ(9000010,TIU("VNUM"),.05)_"].") 67 . . S TIU("EPDT")=$$GET1^DIQ(9000010,TIU("VNUM"),.01,"I"),TIU("VSTR")=$$VSTRBLD^TIUSRVP(TIU("VNUM")) 68 . I '+TIU("VNUM") D 69 . . I +TIU("EPDT") I '+$$GETADMIT^TIUHL7U1(+$G(DFN),TIU("EPDT")),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1","44","0000.00","Could not find a visit for "_$$FMTE^XLFDT(TIU("EPDT"))_".") Q 70 . . I '+$$GETVISIT^TIUHL7U1(+$G(DFN),TIU("RFDT")),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1","44","0000.00","Could not find a visit for "_$$FMTE^XLFDT(TIU("RFDT"))_".") Q 71 . . S TIU("VSTR")=TIU("HLOC")_";"_$$NOW^XLFDT_";E" 72 ; 73 D CONTINUE^TIUHL7P3 74 Q 1 TIUHL7P2 ; SLC/AJB - TIUHL7 Msg Processing; March 23, 2005 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 3 Q 4 CONTINUE ; data verification 5 ; 6 ; DOCUMENT TEXT 7 D 8 . N TIUI S TIUTMP=0 F S TIUTMP=$O(TIUZ("TEXT",TIUTMP)) Q:'TIUTMP I +$L(TIUZ("TEXT",TIUTMP,0)) S TIUI=1 9 . I '+$G(TIUI) D ERR^TIUHL7U1("OBX",1,"0000.00","Missing DOCUMENT TEXT.") 10 ; 11 ; DOCUMENT TITLE 12 I +TIU("TDA")'>0 D ERR^TIUHL7U1("TXA",16,"0000.00","Could not resolve the document title "_TIU("TITLE")_".") 13 I +$$GET1^DIQ(8925.1,TIU("TDA"),.07,"I")'=11 D ERR^TIUHL7U1("TXA",16,"0000.00","The document title "_TIU("TITLE")_" must be ACTIVE before use.") 14 ; 15 ; AUTHOR/DICTATOR 16 D 17 . I '+$L(TIU("AUNAME")) D ERR^TIUHL7U1("TXA",9,"0000.00","Missing AUTHOR/DICTATOR name from HL7 message.") Q 18 . I '+$G(TIU("AUDA")),'+$G(TIU("AUSSN")) S TIU("AUDA")=$$LU^TIUHL7U1(200,TIU("AUNAME"),"X") I '+TIU("AUDA") D ERR^TIUHL7U1("TXA",9,"0000.00","AUTHOR/DICTATOR name lookup failed for ["_TIU("AUNAME")_"].") Q 19 . I '+$G(TIU("AUDA")),+$G(TIU("AUSSN")) S TIU("AUDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("AUSSN")),"SSN") I '+TIU("AUDA") D ERR^TIUHL7U1("TXA",9,"0000.00","SSN ["_TIU("AUSSN")_"] lookup failed for AUTHOR/DICTATOR.") Q 20 . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("AUDA"),.01),TIU("AUNAME")) D 21 . . D ERR^TIUHL7U1("TXA",9,"0000.00","AUTHOR/DICTATOR name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("AUDA"),.01)_"]"_" & the HL7 message name ["_TIU("AUNAME")_"].") 22 ; 23 ; EXPECTED CO-SIGNER [ignored if AUTHOR/DICTATOR does not require] 24 I $$REQCOSIG^TIULP($G(TIU("TDA")),,$G(TIU("AUDA")),$G(TIU("RFDT"))) D 25 . N TIUTMP 26 . S TIUZ(1506)=1 27 . I +$L($G(TIU("CSNAME")))!(+$G(TIU("CSDA")))!(+$G(TIU("CSSSN"))) D 28 . . I '+$L($G(TIU("CSNAME"))) D ERR^TIUHL7U1("TXA",10,"0000.00","Missing EXPECTED COSIGNER name from HL7 message.") Q 29 . . I '+$G(TIU("CSDA")),'+$G(TIU("CSSSN")) S TIU("CSDA")=$$LU^TIUHL7U1(200,TIU("CSNAME"),"X") I '+TIU("CSDA") D ERR^TIUHL7U1("TXA",10,"0000.000","EXPECTED COSIGNER name lookup failed for ["_TIU("CSNAME")_"].") Q 30 . . I '+$G(TIU("CSDA")),+$G(TIU("CSSSN")) S TIU("CSDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("CSSSN")),"SSN") I '+TIU("CSDA") D ERR^TIUHL7U1("TXA",10,"0000.00","SSN ["_TIU("CSSSN")_"] lookup failed for EXPECTED COSIGNER.") Q 31 . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("CSDA"),.01),TIU("CSNAME")) D 32 . . . D ERR^TIUHL7U1("TXA",10,"0000.00","EXPECTED COSIGNER name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("CSDA"),.01)_"]"_" & HL7 message name ["_TIU("CSNAME")_"].") 33 . I '+$G(TIU("CSDA")) D ERR^TIUHL7U1("TXA",10,"0000.000","Unable to resolve EXPECTED COSIGNER; the AUTHOR/DICTATOR ["_TIU("AUNAME")_"] requires COSIGNATURE.") 34 ; 35 ; ENTERED BY [optional] 36 I +$L($G(TIU("EBNAME")))!(+$G(TIU("EBDA")))!(+$G(TIU("EBSSN"))) D 37 . I '+$L($G(TIU("EBNAME"))) D ERR^TIUHL7U1("TXA",11,"0000.00","Missing ENTERED BY name from HL7 message.") Q 38 . I '+$G(TIU("EBDA")),'+$G(TIU("EBSSN")) S TIU("EBDA")=$$LU^TIUHL7U1(200,TIU("EBNAME"),"X") I '+TIU("EBDA") D ERR^TIUHL7U1("TXA",11,"0000.000","ENTERED BY name lookup failed for ["_TIU("EBNAME")_"].") Q 39 . I '+$G(TIU("EBDA")),+$G(TIU("EBSSN")) S TIU("EBDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("EBSSN")),"SSN") I '+TIU("EBDA") D ERR^TIUHL7U1("TXA",11,"0000.00","SSN ["_TIU("EBSSN")_"] lookup failed for ENTERED BY.") Q 40 . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("EBDA"),.01),TIU("EBNAME")) D 41 . . D ERR^TIUHL7U1("TXA",11,"0000.00","ENTERED BY name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("EBDA"),.01)_"]"_" & HL7 message name ["_TIU("EBNAME")_"].") 42 ; 43 ; EPISODE BEGIN DATE/TIME for DISCHARGE SUMMARIES 44 I $$MEMBEROF^TIUHL7U1(TIU("TITLE"),"DISCHARGE SUMMARIES") D 45 . I '+$G(TIU("CSDA")) D ERR^TIUHL7U1("TXA",10,"0000.000","DISCHARGE SUMMARIES require an ATTENDING PHYSICIAN (EXPECTED COSIGNER).") 46 . S TIUZ(1209)=$G(TIU("CSDA")) 47 . I +TIU("VNUM") D Q 48 . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(9000010,TIU("VNUM"),.05),$S(+$G(DFN):$$GET1^DIQ(2,DFN,.01),1:TIU("PTNAME"))) D 49 . . . D ERR^TIUHL7U1("PV1",19,"0000.00","HL7 message PATIENT NAME ["_TIU("PTNAME")_"] does not match VISIT PATIENT NAME ["_$$GET1^DIQ(9000010,TIU("VNUM"),.05)_"].") Q 50 . . S TIU("EPDT")=$$GET1^DIQ(9000010,TIU("VNUM"),.01,"I"),TIU("VSTR")=$$VSTRBLD^TIUSRVP(TIU("VNUM")) 51 . I '+TIU("EPDT") D ERR^TIUHL7U1("PV1",44,"0000.000",TIU("TITLE")_" requires an EPISODE BEGIN DATE/TIME.") Q 52 . I '+$$GETADMIT^TIUHL7U1(+$G(DFN),TIU("EPDT")) D ERR^TIUHL7U1("PV1","44","0000.00","Could not resolve ADMISSION DT[TIME] for "_$$FMTE^XLFDT(TIUDT)_".") 53 ; 54 ; VISIT information for PROGRESS NOTES 55 I $$MEMBEROF^TIUHL7U1(TIU("TITLE"),"PROGRESS NOTES") D 56 . I TIU("VNUM")="NEW" D Q 57 . . N TYP 58 . . I '+TIU("HLOC"),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1",4,"0000.00","Missing/Invalid HOSPITAL LOCATION ('AV' not set); required for NEW visits.") Q 59 . . I +TIU("EPDT")'>0 S TIU("EPDT")=$$NOW^XLFDT 60 . . I $L(TIU("EPDT"),".")=1 S TIU("EPDT")=TIU("EPDT")_"."_$P($$NOW^XLFDT,".",2) 61 . . I +TIU("HLOC") I $$GET1^DIQ(44,TIU("HLOC"),2,"I")="W" S TYP="I" 62 . . S TIU("VSTR")=TIU("HLOC")_";"_TIU("EPDT")_";"_$S(+$D(TYP):"I",TIU("AVAIL")="AV":"E",1:"A") 63 . I +TIU("VNUM") D Q 64 . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(9000010,TIU("VNUM"),.05),$S(+$G(DFN):$$GET1^DIQ(2,DFN,.01),1:TIU("PTNAME"))) D Q 65 . . . D ERR^TIUHL7U1("PV1",19,"0000.00","HL7 message PATIENT NAME ["_TIU("PTNAME")_"] does not match VISIT PATIENT NAME ["_$$GET1^DIQ(9000010,TIU("VNUM"),.05)_"].") 66 . . S TIU("EPDT")=$$GET1^DIQ(9000010,TIU("VNUM"),.01,"I"),TIU("VSTR")=$$VSTRBLD^TIUSRVP(TIU("VNUM")) 67 . I '+TIU("VNUM") D 68 . . I +TIU("EPDT") I '+$$GETADMIT^TIUHL7U1(+$G(DFN),TIU("EPDT")),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1","44","0000.00","Could not find a visit for "_$$FMTE^XLFDT(TIU("EPDT"))_".") Q 69 . . I '+$$GETVISIT^TIUHL7U1(+$G(DFN),TIU("RFDT")),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1","44","0000.00","Could not find a visit for "_$$FMTE^XLFDT(TIU("RFDT"))_".") Q 70 . . S TIU("VSTR")=TIU("HLOC")_";"_$$NOW^XLFDT_";E" 71 ; 72 D CONTINUE^TIUHL7P3 73 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7U1.m
r613 r623 1 TIUHL7U1 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 3 Q 4 ACK(CODE,ERLOC,TIUDA) ; 5 N HLA,RESULT,TIUMID,TIUREC,TIUSND 6 S HLA("HLA",1)="MSA"_HL("FS")_CODE_HL("FS")_HL("MID")_HL("FS")_$G(HL("RAN"))_HL("FS")_$G(HL("SAN")) 7 S TIUMID=$G(HL("MID")),TIUREC=HL("RAN"),TIUSND=HL("SAN") 8 I CODE="AR" D 9 . N TIUCNT 10 . S TIUCNT=0 F S TIUCNT=$O(@ERLOC@("MSGERR",TIUCNT)) Q:'+TIUCNT S HLA("HLA",(TIUCNT+1))=@ERLOC@("MSGERR",TIUCNT) 11 . I +$E($G(TIU("SSN")),1,5) D SNDALRT("TIUHL7 rejected an incoming HL7 message from "_TIUSND_" (Msg ID "_TIUMID_".") 12 I CODE="AA" D 13 . S HLA("HLA",2)="ERR"_TIUFS_TIUFS_TIUFS_TIUFS_+$G(TIUDA)_TIUCS_"Document creation successful." 14 I HL("SAN")="HTAPPL" D M @TIU("XTMP")@("MSGRESULT")=HLA("HLS") Q 15 . N HL,HLL,HLP,TIUDNS,TIUEVT,TIUFAC,TIULLNK,TIUSUB 16 . M HLA("HLS")=HLA("HLA") K HLA("HLA") 17 . S TIUEVT="TIUHL7 HTAPPL ACK EVT",TIUSUB="TIUHL7 HTAPPL ACK SUB" 18 . I '+$$LU^TIUHL7U1(101,TIUEVT) D SNDALRT("Unable to resolve Event Protocol for ACK to "_TIUSND_".") 19 . I '+$$LU^TIUHL7U1(101,TIUSUB) D SNDALRT("Unable to resolve Subscriber Protocol for ACK to "_TIUSND_".") 20 . S TIUFAC=$P(TIUMSG(1),TIUFS,4),TIUDNS=$P(TIUFAC,TIUCS,2) ; set facility & DNS address 21 . S TIULLNK(1)=$$LU^TIUHL7U1(870,$$UP^XLFSTR(TIUDNS),,,"DNS"),TIULLNK(2)=$$LU^TIUHL7U1(870,$$LOW^XLFSTR(TIUDNS),,,"DNS") 22 . S TIULLNK=$S(+TIULLNK(1):TIULLNK(1),+TIULLNK(2):TIULLNK(2),1:0) I '+TIULLNK D SNDALRT("Unable to resolve DNS for ACK to "_TIUSND_".") 23 . S TIULLNK=$$GET1^DIQ(870,TIULLNK,.01) ; get logical link associated with DNS 24 . D INIT^HLFNC2(TIUEVT,.HL) I +$G(HL) Q 25 . S HLP("SUBSCRIBER")="^^^^"_TIUFAC 26 . S HLL("LINKS",1)=TIUSUB_U_TIULLNK 27 . D GENERATE^HLMA(TIUEVT,"LM",1,.TIURSLT,"",.HLP) 28 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.TIURSLT) 29 M @TIU("XTMP")@("MSGRESULT")=HLA("HLA") 30 Q 31 SNDALRT(MSG) ; 32 N XQA,XQAMSG 33 S MSG("RECEIVER")=$P($$GETAPP^HLCS2(TIUREC),U),MSG("SENDER")=$P($$GETAPP^HLCS2(TIUSND),U) 34 I '+$L(MSG("RECEIVER")),'+$L(MSG("SENDER")) Q 35 I +$L(MSG("RECEIVER")) S XQA("G."_MSG("RECEIVER"))="" 36 I +$L(MSG("SENDER")) S XQA("G."_MSG("SENDER"))="" 37 S XQAMSG=MSG 38 I $$SETUP1^XQALERT 39 Q 40 AUDIT(TIUDA,TIUCKSM0,TIUCKSM1) ; Update audit trail 41 N DA,DIC,DIE,DLAYGO,DR,X,Y 42 S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.5,DIC(0)="FLX" D ^DIC Q:+Y'>0 43 S DIE=DIC,DR=".02////"_$$NOW^TIULC_";.03////"_TIU("EBDA")_";.04////"_TIUCKSM0_";.05////"_TIUCKSM1 44 S DA=+Y D ^DIE 45 Q 46 CANEDIT(DA) ; check whether or not document is released 47 Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0) 48 CLASS(CLNAME) ; 49 N TIUY S TIUY=+$O(^TIU(8925.1,"B",CLNAME,0)) 50 I +TIUY>0,$S($P($G(^TIU(8925.1,+TIUY,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S TIUY=0 51 Q TIUY 52 CLEAN ; removes messages older than 7 days 53 N TIUDT 54 S TIUDT=0 55 F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT D 56 . I $$FMDIFF^XLFDT($$NOW^XLFDT,TIUDT)'<7 K ^XTMP("TIUHL7",TIUDT) 57 Q 58 COMPARE(NAME1,NAME2) ; compare first and last names only 59 N NAME,TIUX,TIUY 60 S TIUY=0 61 I $L(NAME1,",")=1,$L(NAME2,",")=1 S:NAME1=NAME2 TIUY=1 Q TIUY 62 S NAME("L1")=$P(NAME1,","),NAME("F1")=$P(NAME1,",",2),NAME("F1")=$P(NAME("F1")," ") 63 S NAME("L2")=$P(NAME2,","),NAME("F2")=$P(NAME2,",",2),NAME("F2")=$P(NAME("F2")," ") 64 I NAME("L1")=NAME("L2"),NAME("F1")=NAME("F2") S TIUY=1 65 Q TIUY 66 DELDOC(TIUDA) ; 67 N ERR 68 D DELETE^TIUSRVP(.ERR,TIUDA,"",1) 69 Q 70 ERR(TIUSEG,TIUP,TIUNUM,TIUTXT) ; 71 S TIU("EC")=TIU("EC")+1 72 S @TIUNAME@("MSGERR",TIU("EC"))="ERR"_TIUFS_TIUSEG_TIUFS_TIUP_TIUFS_TIUFS_TIUNUM_TIUCS_TIUTXT 73 Q 74 GETADMIT(DFN,TIUDT) ; 75 N TIUCNT,TIULIST,TIUY S (TIUCNT,TIUY)=0 76 I '+$G(TIUDT) Q TIUY 77 D:+$G(DFN) ADMITLST^ORWPT(.TIULIST,DFN) 78 I $D(TIULIST) D 79 . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST) 80 . I TIUCNT=0 D ERR("ERR","44","0000.00","ADMISSION not found for "_$$FMTE^XLFDT(TIUDT)_".") Q 81 . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P(TIULIST(TIULIST),U,2)_";"_$P(TIULIST(TIULIST),U)_";H",TIUY=1 Q 82 . I +TIU("HLOC") D 83 . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P(TIUCNT(TIULIST),U,2)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIUCNT(TIULIST),U)_";H",TIUY=1 84 Q TIUY 85 GETDIV(USER) ; 86 N TIUY 87 D DIV4^XUSER(.TIUY,USER) I +$D(TIUY) S TIUY="",TIUY=$O(TIUY(TIUY)) 88 I +$G(TIUY)'>0 S TIUY=$$GET1^DIQ(8989.3,1,217,"I") 89 Q TIUY 90 GETVISIT(DFN,TIUDT) ; 91 N TIUCNT,TIULIST,TIUY 92 S (TIUCNT,TIUY)=0 93 I '+$G(TIUDT) Q TIUY 94 D:+$G(DFN) VST1^ORWCV(.TIULIST,DFN,$P(TIUDT,"."),$$FMADD^XLFDT(TIUDT,1),1) 95 I $D(TIULIST) D 96 . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U,2),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST) 97 . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P($P(TIULIST(TIULIST),U),";",3)_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 Q 98 . I +TIU("HLOC") D 99 . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P($P(TIULIST(TIULIST),U),";",3)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 100 Q TIUY 101 LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ; 102 Q $$FIND1^DIC(FILE,"",$G(FLAGS),NAME,$G(INDEXES),$G(SCREEN),"TIUERR") 103 MEMBEROF(TITLE,CLASS) ; 104 N TIUY S TIUY=0 105 S CLASS=+$$CLASS(CLASS) Q:+CLASS'>0 TIUY 106 S TITLE=$$LU(8925.1,TITLE,"X","I $P(^(0),U,4)=""DOC""") Q:+TITLE'>0 TIUY 107 S TIUY=+$$ISA^TIULX(TITLE,CLASS) 108 Q TIUY 109 PNAME(NAME) ; 110 N LAST,FIRST 111 S LAST=$P(NAME,","),FIRST=$E($P(NAME,",",2),1) 112 Q LAST_","_FIRST 113 REMESC(TIUSTR) ; 114 ; Remove Escape Characters from HL7 Message Text 115 ; Escape Sequence codes: 116 ; F = field separator (TIUFS) 117 ; S = component separator (TIUCS) 118 ; R = repitition separator (TIURS) 119 ; E = escape character (TIUES) 120 ; T = subcomponent separator (TIUSS) 121 N I1,I2,J1,J2,K,TIUCHR,TIUREP,VALUE 122 F TIUCHR="F","S","R","E","T" S TIUREP(TIUES_TIUCHR_TIUES)=$S(TIUCHR="F":TIUFS,TIUCHR="S":TIUCS,TIUCHR="R":TIURS,TIUCHR="E":TIUES,TIUCHR="T":TIUSS) 123 S TIUSTR=$$REPLACE^XLFSTR(TIUSTR,.TIUREP) 124 F S I1=$P(TIUSTR,TIUES_"X") Q:$L(I1)=$L(TIUSTR) D 125 .S I2=$P(TIUSTR,TIUES_"X",2,99) 126 .S J1=$P(I2,TIUES) Q:'$L(J1) 127 .S J2=$P(I2,TIUES,2,99) 128 .S VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10) 129 .S K=$S(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$C(VALUE)) 130 .S TIUSTR=I1_K_J2 131 Q TIUSTR 132 SIGNDOC(TIUDA) ; 133 N TIUDEL 134 I $G(TIU("COMP"))="LA",'+TIU("EC") D 135 . I '+$G(TIU("SIGNED")),'+$G(TIU("CSIGNED")) D Q 136 . . I TIU("AVAIL")'="AV" D DELDOC(TIUDA),ERR("TIU","","2100.040","SIGNATURE DATE[TIME] missing from HL7 message & availability not 'AV'; document has been deleted.") 137 . I +TIU("SIGNED") D 138 . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="SIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("AUDA")) I '+TIUAUTH D 139 . . . D ERR("TIU","15","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q 140 . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") 141 . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("AUDA"),20.2)_U_$$GET1^DIQ(200,TIU("AUDA"),20.3) 142 . . I '+$G(TIUDEL) D ES^TIUHL7U2(TIUDA,TIUES,"",TIU("AUDA")) 143 . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT<6,TIU("AVAIL")'="AV" D 144 . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") 145 . I +TIU("CSIGNED") D 146 . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="COSIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("CSDA")) I '+TIUAUTH D 147 . . . D ERR("TIU","29","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q 148 . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") 149 . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("CSDA"),20.2)_U_$$GET1^DIQ(200,TIU("CSDA"),20.3) 150 . . I '+$G(TIUDEL) D ES^TIURS(TIUDA,TIUES,"",TIU("CSDA")) 151 . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT'=7,TIU("AVAIL")'="AV" D 152 . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") 153 I +$G(TIUDEL) D DELDOC(TIUDA) 154 Q 1 TIUHL7U1 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005 2 ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 3 Q 4 ACK(CODE,ERLOC,TIUDA) ; 5 N HLA,RESULT 6 S HLA("HLA",1)="MSA"_HL("FS")_CODE_HL("FS")_HL("MID")_HL("FS")_$G(HL("RAN"))_HL("FS")_$G(HL("SAN")) 7 I CODE="AR" D 8 . N TIUCNT 9 . S TIUCNT=0 F S TIUCNT=$O(@ERLOC@("MSGERR",TIUCNT)) Q:'+TIUCNT S HLA("HLA",(TIUCNT+1))=@ERLOC@("MSGERR",TIUCNT) 10 . D SNDALRT 11 I CODE="AA" D 12 . S HLA("HLA",2)=+$G(TIUDA)_TIUCS_"Document creation successful." 13 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.RESULT) 14 M @TIU("XTMP")@("MSGRESULT")=HLA("HLA") 15 Q 16 AUDIT(TIUDA,TIUCKSM0,TIUCKSM1) ; Update audit trail 17 N DIC,DIE,DA,DR,X,Y 18 S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.5,DIC(0)="FLX" D ^DIC Q:+Y'>0 19 S DIE=DIC,DR=".02////"_$$NOW^TIULC_";.03////"_TIU("EBDA")_";.04////"_TIUCKSM0_";.05////"_TIUCKSM1 20 S DA=+Y D ^DIE 21 Q 22 CANEDIT(DA) ; check whether or not document is released 23 Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0) 24 CLASS(CLNAME) ; 25 N TIUY S TIUY=+$O(^TIU(8925.1,"B",CLNAME,0)) 26 I +TIUY>0,$S($P($G(^TIU(8925.1,+TIUY,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S TIUY=0 27 Q TIUY 28 CLEAN ; removes messages older than 7 days 29 N TIUDT 30 S TIUDT=0 31 F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT D 32 . I $$FMDIFF^XLFDT($$NOW^XLFDT,TIUDT)'<7 K ^XTMP("TIUHL7",TIUDT) 33 Q 34 COMPARE(NAME1,NAME2) ; compare first and last names only 35 N NAME,TIUX,TIUY 36 S TIUY=0 37 I $L(NAME1,",")=1,$L(NAME2,",")=1 S:NAME1=NAME2 TIUY=1 Q TIUY 38 S NAME("L1")=$P(NAME1,","),NAME("F1")=$P(NAME1,",",2),NAME("F1")=$P(NAME("F1")," ") 39 S NAME("L2")=$P(NAME2,","),NAME("F2")=$P(NAME2,",",2),NAME("F2")=$P(NAME("F2")," ") 40 I NAME("L1")=NAME("L2"),NAME("F1")=NAME("F2") S TIUY=1 41 Q TIUY 42 DELDOC(TIUDA) ; 43 N ERR 44 D DELETE^TIUSRVP(.ERR,TIUDA,"",1) 45 Q 46 ERR(TIUSEG,TIUP,TIUNUM,TIUTXT) ; 47 S TIU("EC")=TIU("EC")+1 48 S @TIUNAME@("MSGERR",TIU("EC"))="ERR"_TIUFS_TIUSEG_TIUFS_TIUP_TIUFS_TIUFS_TIUNUM_TIUCS_TIUTXT 49 Q 50 GETADMIT(DFN,TIUDT) ; 51 N TIUCNT,TIULIST,TIUY S (TIUCNT,TIUY)=0 52 I '+$G(TIUDT) Q TIUY 53 D:+$G(DFN) ADMITLST^ORWPT(.TIULIST,DFN) 54 I $D(TIULIST) D 55 . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST) 56 . I TIUCNT=0 D ERR("ERR","44","0000.00","ADMISSION not found for "_$$FMTE^XLFDT(TIUDT)_".") Q 57 . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P(TIULIST(TIULIST),U,2)_";"_$P(TIULIST(TIULIST),U)_";H",TIUY=1 Q 58 . I +TIU("HLOC") D 59 . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P(TIUCNT(TIULIST),U,2)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIUCNT(TIULIST),U)_";H",TIUY=1 60 Q TIUY 61 GETDIV(USER) ; 62 N TIUY 63 D DIV4^XUSER(.TIUY,USER) I +$D(TIUY) S TIUY="",TIUY=$O(TIUY(TIUY)) 64 I +$G(TIUY)'>0 S TIUY=$$GET1^DIQ(8989.3,1,217,"I") 65 Q TIUY 66 GETVISIT(DFN,TIUDT) ; 67 N TIUCNT,TIULIST,TIUY 68 S (TIUCNT,TIUY)=0 69 I '+$G(TIUDT) Q TIUY 70 D:+$G(DFN) VST1^ORWCV(.TIULIST,DFN,$P(TIUDT,"."),$$FMADD^XLFDT(TIUDT,1),1) 71 I $D(TIULIST) D 72 . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U,2),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST) 73 . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P($P(TIULIST(TIULIST),U),";",3)_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 Q 74 . I +TIU("HLOC") D 75 . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P($P(TIULIST(TIULIST),U),";",3)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 76 Q TIUY 77 LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ; 78 Q $$FIND1^DIC(FILE,"",$G(FLAGS),NAME,$G(INDEXES),$G(SCREEN),"TIUERR") 79 MEMBEROF(TITLE,CLASS) ; 80 N TIUY S TIUY=0 81 S CLASS=+$$CLASS(CLASS) Q:+CLASS'>0 TIUY 82 S TITLE=$$LU(8925.1,TITLE,"X","I $P(^(0),U,4)=""DOC""") Q:+TITLE'>0 TIUY 83 S TIUY=+$$ISA^TIULX(TITLE,CLASS) 84 Q TIUY 85 PNAME(NAME) ; 86 N LAST,FIRST 87 S LAST=$P(NAME,","),FIRST=$E($P(NAME,",",2),1) 88 Q LAST_","_FIRST 89 REMESC(TIUSTR) ; 90 ; Remove Escape Characters from HL7 Message Text 91 ; Escape Sequence codes: 92 ; F = field separator (TIUFS) 93 ; S = component separator (TIUCS) 94 ; R = repitition separator (TIURS) 95 ; E = escape character (TIUES) 96 ; T = subcomponent separator (TIUSS) 97 N I1,I2,J1,J2,K,TIUCHR,TIUREP,VALUE 98 F TIUCHR="F","S","R","E","T" S TIUREP(TIUES_TIUCHR_TIUES)=$S(TIUCHR="F":TIUFS,TIUCHR="S":TIUCS,TIUCHR="R":TIURS,TIUCHR="E":TIUES,TIUCHR="T":TIUSS) 99 S TIUSTR=$$REPLACE^XLFSTR(TIUSTR,.TIUREP) 100 F S I1=$P(TIUSTR,TIUES_"X") Q:$L(I1)=$L(TIUSTR) D 101 .S I2=$P(TIUSTR,TIUES_"X",2,99) 102 .S J1=$P(I2,TIUES) Q:'$L(J1) 103 .S J2=$P(I2,TIUES,2,99) 104 .S VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10) 105 .S K=$S(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$C(VALUE)) 106 .S TIUSTR=I1_K_J2 107 Q TIUSTR 108 SIGNDOC(TIUDA) ; 109 N TIUDEL 110 I $G(TIU("COMP"))="LA",'+TIU("EC") D 111 . I '+$G(TIU("SIGNED")),'+$G(TIU("CSIGNED")) D Q 112 . . I TIU("AVAIL")'="AV" D DELDOC(TIUDA),ERR("TIU","","2100.040","SIGNATURE DATE[TIME] missing from HL7 message & availability not 'AV'; document has been deleted.") 113 . I +TIU("SIGNED") D 114 . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="SIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("AUDA")) I '+TIUAUTH D 115 . . . D ERR("TIU","15","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q 116 . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") 117 . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("AUDA"),20.2)_U_$$GET1^DIQ(200,TIU("AUDA"),20.3) 118 . . I '+$G(TIUDEL) D ES^TIUHL7U2(TIUDA,TIUES,"",TIU("AUDA")) 119 . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT<6,TIU("AVAIL")'="AV" D 120 . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") 121 . I +TIU("CSIGNED") D 122 . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="COSIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("CSDA")) I '+TIUAUTH D 123 . . . D ERR("TIU","29","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q 124 . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") 125 . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("CSDA"),20.2)_U_$$GET1^DIQ(200,TIU("CSDA"),20.3) 126 . . I '+$G(TIUDEL) D ES^TIURS(TIUDA,TIUES,"",TIU("CSDA")) 127 . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT'=7,TIU("AVAIL")'="AV" D 128 . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") 129 I +$G(TIUDEL) D DELDOC(TIUDA) 130 Q 131 SNDALRT ; 132 N TIUCNT,XQA,XQAMSG 133 I '+$G(TIUDPRM(4)) Q 134 F TIUCNT=1:1:$L(TIUDPRM(4),U) S:+$P(TIUDPRM(4),U,TIUCNT) XQA($P(TIUDPRM(4),U,TIUCNT))="" 135 S XQAMSG="TIUHL7 has encountered an error during message ["_HL("MID")_"] processing." 136 D SETUP^XQALERT 137 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULA3.m
r613 r623 1 TIULA3 ; SLC/JER - Still more interactive functions ;1/31/08 2 ;;1.0;TEXT INTEGRATION UTILITIES;**50,79,98,219**;Jun 20, 1997;Build 11 3 TITLE ; Title Look-up 4 N TIUI,TYPE,TIUCLASS S TIUI=0 5 S TIUTYP=$NA(^TMP("TIUTYP",$J)) 6 K @TIUTYP 7 I +$G(TIUPICT)'>0 Q 8 I $P($G(TIUPICT(1)),U,4)="ALL" D 9 . S TIUCLASS=+$O(^TIU(8925.1,"AD",+$P(TIUPICT(1),U,2),0)) 10 . K TIUPICT 11 . S TIUPICT=1,TIUPICT(1)="1^"_TIUCLASS_U_$$PNAME^TIULC1(TIUCLASS) 12 F S TIUI=$O(TIUPICT(TIUI)) Q:+TIUI'>0 D 13 . S TIUCLASS=$P(TIUPICT(TIUI),U,2) 14 . W !!,"For ",$$UP^XLFSTR($$PNAME^TIULC1(TIUCLASS)),": " 15 . D TITLPICK(.TYPE,TIUCLASS) 16 M @TIUTYP=TYPE 17 S Y="ANY" 18 Q 19 TITLPICK(TIUTYP,CLASS) ; Select multiple titles 20 N TIUI,TYPE,TIUPRMT S TIUI=0 21 W !!,"Please Select the ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS)) 22 W " TITLES to search for:",! 23 F D Q:+$G(TYPE)'>0 24 . K TYPE 25 . S TIUI=TIUI+1,TIUPRMT=$J(TIUI,3)_") " 26 . D DOCSPICK^TIULA2(.TYPE,CLASS,"A",0,TIUPRMT) 27 . I +TYPE>0 S TIUTYP=+$G(TIUTYP)+1,TIUTYP(TIUTYP)=$G(TYPE(1)) 28 . I I $P(TYPE(1),U,4)="SINGLE ITEM" D 29 . . W !,"There is only one TITLE under ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS)) 30 . . S TYPE=0 31 . I $S($D(DTOUT):1,$D(DUOUT):1,(+TYPE'>0&'$D(TIUTYP)):1,1:0) S TIUQUIT=1 32 W ! 33 Q 34 ASKTITLE(CLASS,TIUTTL) ; Ask for a different title, same class 35 N TIUY,TIUTYP,DFLT,SCREEN,X,Y 36 S DFLT=$$RSLVTITL(TIUTTL) 37 S SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",($P(^(0),U)'[""ADDENDUM""),+$$ISA^TIULX(+Y,CLASS),+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)" 38 S TIUY=+$$ASKTYP^TIULA2(+CLASS,DFLT,SCREEN,"TITLE: ") 39 I +$G(TIUY)'>0 S TIUY=TIUTTL 40 Q TIUY 41 RSLVTITL(TIUTTL) ; Resolve pointers to titles 42 Q $P($G(^TIU(8925.1,+TIUTTL,0)),U) 43 ASKSEQ(TIUDFLT) ; Ask preferred sort sequence 44 N TIUPRMT,TIUSET,TIUY S TIUDFLT=$G(TIUDFLT,"D") 45 S TIUPRMT="Please Specify Sort Order: " 46 S TIUSET="A:ascending (OLDEST FIRST);D:descending (NEWEST FIRST)" 47 S TIUY=$$READ^TIUU("SA^"_TIUSET,TIUPRMT,$S(TIUDFLT="A":"ascending",1:"descending")) 48 Q TIUY 49 DATENOTE(X) ; Ask for date/time of note 50 N %DT,Y 51 ;S TIUPRMT="DATE/TIME OF NOTE" 52 ;S TIUY=$$READ^TIUU("D^:NOW:RS",TIUPRMT,$G(DFLT,"NOW"),TIUHLP) 53 ;I +TIUY W " ",$P(TIUY,U,2) 54 S %DT="RSX",%DT(0)="-NOW" D ^%DT 55 I +Y'>0 D 56 . W !,$C(7),"Enter DATE AND TIME of the note [TIME REQUIRED] (future dates prohibited)." 57 Q +$G(Y) 58 SCRCSNR(TIUDA,Y) ; Evaluate whether a person may be selected to cosign 59 N TIUI,TIUY,TIUD0,TIUD12 S TIUY=1 ; most people may be selected 60 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^TIU(8925,+TIUDA,12)) 61 ; If he requires cosignature for this document a user may NOT select 62 ; himself 63 I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+$G(DUZ)),(Y=+$G(DUZ)) S TIUY=0 G SCREENX 64 ; A TERMINATED User may NOT be selected 65 I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX 66 ; A non-PROVIDER may NOT be selected 67 I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX 68 ; Author may NOT be selected 69 I Y=+$P(TIUD12,U,2) S TIUY=0 G SCREENX 70 ; Expected Signer may NOT be selected 71 I Y=+$P(TIUD12,U,4) S TIUY=0 G SCREENX 72 ; Others who require Cosignature may NOT be selected 73 I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+Y) S TIUY=0 74 SCREENX Q +$G(TIUY) 75 ; 76 SCRATT(TIUDA,PERSON) ; Can a person be an Attending for a given docmt? 77 N TIUD0,TIUTYP,CANSEL,DICTDT,TIUISDS,TIUPRNT,TIUPTYP,TIUPD0,TIUISAD 78 S PERSON=+PERSON,TIUDA=+TIUDA,CANSEL=1 79 S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUPRNT=+$P(TIUD0,U,6) 80 S DICTDT=+$P($G(^TIU(8925,+TIUDA,13)),U,7) 81 I DICTDT>0 S DICTDT=$P(DICTDT,".") 82 ; Is Docmt an Addendum, a DS? 83 S TIUTYP=+TIUD0,(TIUPTYP,TIUISAD)=0 84 I TIUPRNT>0 S TIUPTYP=+$G(^TIU(8925,TIUPRNT,0)) 85 I TIUPTYP>0,$P($G(^TIU(8925.1,TIUTYP,0)),U)["ADDENDUM" S TIUISAD=1 86 S TIUISDS=+$S('TIUISAD:$$ISDS^TIULX(TIUTYP),1:$$ISDS^TIULX(TIUPTYP)) 87 ; A TERMINATED (as of NOW) User may NOT be selected: 88 I $$ISTERM^USRLM(PERSON) S CANSEL=0 G SCRATTX 89 ; If not DS, is person an active provider? 90 I 'TIUISDS S:'$$PROVIDER^TIUPXAP1(PERSON,DT) CANSEL=0 G SCRATTX 91 ; TIUDA is a DS: 92 ; Attendings must be in USR Class PROVIDER NOW: 93 I '$$ISA^USRLM(+PERSON,"PROVIDER") S CANSEL=0 G SCRATTX 94 ; Persons who require Cosignature on Dictation Dt may NOT be selected: 95 I +$$REQCOSIG^TIULP(TIUTYP,+TIUDA,PERSON,DICTDT) S CANSEL=0 96 SCRATTX Q +$G(CANSEL) 97 ; 98 SCRDFCS(USER,Y) ; Screen Default Cosigner selection for USER 99 N TIUY S TIUY=1 100 S USER=$G(USER,DUZ) 101 ; A user may NOT select himself 102 I Y=USER S TIUY=0 G SCRDFX 103 ; A TERMINATED User may NOT be selected 104 I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX 105 ; A non-PROVIDER may NOT be selected 106 I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX 107 SCRDFX Q TIUY 1 TIULA3 ; SLC/JER - Still more interactive functions ;24-FEB-2000 12:22:04 2 ;;1.0;TEXT INTEGRATION UTILITIES;**50,79,98**;Jun 20, 1997 3 TITLE ; Title Look-up 4 N TIUI,TYPE,TIUCLASS S TIUI=0 5 S TIUTYP=$NA(^TMP("TIUTYP",$J)) 6 K @TIUTYP 7 I +$G(TIUPICT)'>0 Q 8 I $P($G(TIUPICT(1)),U,4)="ALL" D 9 . S TIUCLASS=+$O(^TIU(8925.1,"AD",+$P(TIUPICT(1),U,2),0)) 10 . K TIUPICT 11 . S TIUPICT=1,TIUPICT(1)="1^"_TIUCLASS_U_$$PNAME^TIULC1(TIUCLASS) 12 F S TIUI=$O(TIUPICT(TIUI)) Q:+TIUI'>0 D 13 . S TIUCLASS=$P(TIUPICT(TIUI),U,2) 14 . W !!,"For ",$$UP^XLFSTR($$PNAME^TIULC1(TIUCLASS)),": " 15 . D TITLPICK(.TYPE,TIUCLASS) 16 M @TIUTYP=TYPE 17 S Y="ANY" 18 Q 19 TITLPICK(TIUTYP,CLASS) ; Select multiple titles 20 N TIUI,TYPE,TIUPRMT S TIUI=0 21 W !!,"Please Select the ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS)) 22 W " TITLES to search for:",! 23 F D Q:+$G(TYPE)'>0 24 . K TYPE 25 . S TIUI=TIUI+1,TIUPRMT=$J(TIUI,3)_") " 26 . D DOCSPICK^TIULA2(.TYPE,CLASS,"A",0,TIUPRMT) 27 . I +TYPE>0 S TIUTYP=+$G(TIUTYP)+1,TIUTYP(TIUTYP)=$G(TYPE(1)) 28 . I I $P(TYPE(1),U,4)="SINGLE ITEM" D 29 . . W !,"There is only one TITLE under ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS)) 30 . . S TYPE=0 31 . I $S($D(DTOUT):1,$D(DUOUT):1,(+TYPE'>0&'$D(TIUTYP)):1,1:0) S TIUQUIT=1 32 W ! 33 Q 34 ASKTITLE(CLASS,TIUTTL) ; Ask for a different title, same class 35 N TIUY,TIUTYP,DFLT,SCREEN,X,Y 36 S DFLT=$$RSLVTITL(TIUTTL) 37 S SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",($P(^(0),U)'[""ADDENDUM""),+$$ISA^TIULX(+Y,CLASS),+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)" 38 S TIUY=+$$ASKTYP^TIULA2(+CLASS,DFLT,SCREEN,"TITLE: ") 39 I +$G(TIUY)'>0 S TIUY=TIUTTL 40 Q TIUY 41 RSLVTITL(TIUTTL) ; Resolve pointers to titles 42 Q $P($G(^TIU(8925.1,+TIUTTL,0)),U) 43 ASKSEQ(TIUDFLT) ; Ask preferred sort sequence 44 N TIUPRMT,TIUSET,TIUY S TIUDFLT=$G(TIUDFLT,"D") 45 S TIUPRMT="Please Specify Sort Order: " 46 S TIUSET="A:ascending (OLDEST FIRST);D:descending (NEWEST FIRST)" 47 S TIUY=$$READ^TIUU("SA^"_TIUSET,TIUPRMT,$S(TIUDFLT="A":"ascending",1:"descending")) 48 Q TIUY 49 DATENOTE(X) ; Ask for date/time of note 50 N %DT,Y 51 ;S TIUPRMT="DATE/TIME OF NOTE" 52 ;S TIUY=$$READ^TIUU("D^:NOW:RS",TIUPRMT,$G(DFLT,"NOW"),TIUHLP) 53 ;I +TIUY W " ",$P(TIUY,U,2) 54 S %DT="RSX",%DT(0)="-NOW" D ^%DT 55 I +Y'>0 D 56 . W !,$C(7),"Enter DATE AND TIME of the note [TIME REQUIRED] (future dates prohibited)." 57 Q +$G(Y) 58 SCRCSNR(TIUDA,Y) ; Evaluate whether a person may be selected to cosign 59 N TIUI,TIUY,TIUD0,TIUD12 S TIUY=1 ; most people may be selected 60 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^TIU(8925,+TIUDA,12)) 61 ; If he requires cosignature for this document a user may NOT select 62 ; himself 63 I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+$G(DUZ)),(Y=+$G(DUZ)) S TIUY=0 G SCREENX 64 ; A TERMINATED User may NOT be selected 65 I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX 66 ; A non-PROVIDER may NOT be selected 67 I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX 68 ; Author may NOT be selected 69 I Y=+$P(TIUD12,U,2) S TIUY=0 G SCREENX 70 ; Expected Signer may NOT be selected 71 I Y=+$P(TIUD12,U,4) S TIUY=0 G SCREENX 72 ; Others who require Cosignature may NOT be selected 73 I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+Y) S TIUY=0 74 SCREENX Q +$G(TIUY) 75 SCRDFCS(USER,Y) ; Screen Default Cosigner selection for USER 76 N TIUY S TIUY=1 77 S USER=$G(USER,DUZ) 78 ; A user may NOT select himself 79 I Y=USER S TIUY=0 G SCRDFX 80 ; A TERMINATED User may NOT be selected 81 I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX 82 ; A non-PROVIDER may NOT be selected 83 I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX 84 SCRDFX Q TIUY -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m
r613 r623 1 TIULMED ; SLC/JM,JH,AJB - Active/Recent Med Objects Routine ; 12/18/07 2 ;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213,238**;Jun 20, 1997;Build 6 3 Q 4 LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ; 5 ; This is the TIU Medication objects API. Optional parameters not 6 ; provided default to 0 (with the exception of SUPPLIES). 7 ;Required Parameters: 8 ; DFN Patient identifier 9 ; TARGET Where the medication data will be stored 10 ;Optional Parameters: 11 ; ACTVONLY 0 - Active and recently expired meds 12 ; 1 - Active meds only 13 ; 2 - Recently expired meds only 14 ; DETAILED 0 - One line per med only 15 ; 1 - Detailed information on each med 16 ; ALLMEDS 0 - Specifies Inpatient Meds if patient is an 17 ; Inpatient, or Outpatient Meds if patient 18 ; is an Outpatient 19 ; 1 - Specifies both Inpatient and Outpatient 20 ; 2 or "I" - Specifies Inpatient only 21 ; 3 or "O" - Specifies Outpatient only 22 ; ONELIST 0 - Separates Active, Pending and Inactive 23 ; medications into separate lists 24 ; 1 - Combines Active, Pending and Inactive 25 ; medications into the same list 26 ; CLASSORT 0 - Sort meds alphabetically 27 ; 1 - Sort meds by drug class, and within the 28 ; same drug class, sort alphabetically 29 ; 2 - Same as #1, but show drug class in header 30 ; SUPPLIES 0 - Supplies are excluded 31 ; 1 - Supplies are included (Default) 32 N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK 33 N STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,MED,IDATE,XSTR,LLEN 34 N SPACE60,DASH73,LINE,TAB,HEADER 35 N DRUGCLAS,DRUGIDX,UNKNOWNS 36 N NVATYPE,NVAMED,NVASTR,TIUXSTAT 37 N %,%H,STOP,LSTFD ;Clean up after external calls... 38 S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47 39 S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="=" 40 K @TARGET,^TMP("PS",$J) 41 ; Check for Pharmacy Package and required patches 42 I '$$PATCHSOK^TIULMED3 G LISTX ;P213 43 I '+$G(ACTVONLY) S ACTVONLY=0 44 I '+$G(DETAILED) S DETAILED=0 45 I +$D(ALLMEDS) D 46 .I ALLMEDS="I" S ALLMEDS=2 47 .E I ALLMEDS="O" S ALLMEDS=3 48 I '+$G(ALLMEDS) S ALLMEDS=0 49 I '+$G(ONELIST) S ONELIST=0 50 I '+$G(CLASSORT) S CLASSORT=0 51 I $G(SUPPLIES)'="0" S SUPPLIES=1 52 S (EMPTY,HEADER)=1 53 I ONELIST,'ALLMEDS,'DETAILED,'CLASSORT S HEADER=0 54 I 'DETAILED S LLEN=60 55 S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^" 56 S PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^" 57 S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient? IA 10035 58 I ISINP S INPTYPE=1,OUTPTYPE=2 59 E S INPTYPE=2,OUTPTYPE=1 60 S NVATYPE=3 61 D ADDTITLE^TIULMED1 62 ; 63 ; *** Scan medication data and skip unwanted meds *** 64 ; Changes for *238 required by PSO*7*294 65 D 66 . I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE) S TIUDATE=$$FMADD^XLFDT(DT,-$G(TIUDATE)) D OCL^PSOQ0496(DFN,TIUDATE,"") Q ; IA 2400 67 . D OCL^PSOORRL(DFN,"","") ; IA 2400 68 ; 69 S INDEX=0 70 F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D 71 .S NODE=$G(^TMP("PS",$J,INDEX,0)) 72 .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds 73 .I KEEPMED D 74 ..S STATUS=$P(NODE,U,9) 75 ..I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)" 76 ..I $F(ASTATS,"^"_STATUS_"^")>0 S STATIDX=1 77 ..E I ($F(PSTATS,"^"_STATUS_"^")>0) S STATIDX=2 78 ..E S STATIDX=3 79 ..S TIUXSTAT=STATUS 80 ..I ACTVONLY=1 S KEEPMED=(STATIDX<3) 81 ..I ACTVONLY=2 S KEEPMED=(STATIDX=3) 82 ..I +ONELIST S STATIDX=1 83 ..; Changes for *238 required by PSO*7*294 84 ..I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE),STATUS["DISCONTINUED" S KEEPMED=0 85 .I KEEPMED D 86 ..S TYPE=$P($P(NODE,U),";",2) 87 ..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"") 88 ..S NVAMED=$P($P(NODE,U),";") 89 ..S NVAMED=$E(NVAMED,$L(NVAMED)) 90 ..S KEEPMED=(TYPE'="") 91 .I KEEPMED D 92 ..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV" 93 ..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV" 94 ..I TYPE="OP" S MEDTYPE=OUTPTYPE 95 ..E S MEDTYPE=INPTYPE 96 ..I NVAMED="N" S MEDTYPE=NVATYPE 97 ..I ALLMEDS=0 D I 1 98 ...I MEDTYPE=INPTYPE S KEEPMED=ISINP 99 ...E S KEEPMED='ISINP 100 ..E I ALLMEDS=2 S KEEPMED=(MEDTYPE=INPTYPE) 101 ..E I ALLMEDS=3 S KEEPMED=(MEDTYPE=OUTPTYPE!(MEDTYPE=NVATYPE)) 102 .S DRUGCLAS=" " 103 .S MED=$P(NODE,U,2) 104 .I KEEPMED,(CLASSORT!('SUPPLIES)) D 105 ..S DRUGIDX=$$IENNAME^TIULMED2(MED) 106 ..D GETCLASS 107 .. ; If DRUGIDX="" (MED not in Drug File 50), get info 108 .. ; via Orderable Item instead. 109 ..I KEEPMED,+DRUGIDX=0 D 110 ...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY 111 ...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID)) 112 ...S (DRUGIDX,ORDIDX)=0 113 ...K ^TMP($J,"TIULMED") 114 ...; IDX is Order #; ID indicates what file. See IA 2400 115 ...; R;O MED will always be in Drug File (Unless Drug File entry was 116 ...; changed after ordering. 117 ...I ID="R;O" D ;R;O = prescription (file #52). P213 118 ....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820 119 ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6)) 120 ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI")) 121 ...; 122 ...I ID="P;O" D ;P;O = pending outpatient order (file #52.41). P213 123 ....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821 124 ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11)) 125 ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8)) 126 ...; 127 ...I ID="P;I" D ;P;I = pending inpatient order (file #53.1) 128 ....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D ; IA 2907 129 .....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX D 130 ......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U) 131 ....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U) 132 ...; 133 ...I ID="U;I" D ;U;I = unit dose order (file #55, subfile 55.06) P213 134 ....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826 135 ....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D 136 .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0 137 .....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01)) 138 .....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108)) 139 ...; 140 ...I ID="V;I" D ;V;I = IV order (file #55, subfile 55.01). P213 141 ....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826 142 ....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX 143 ....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130)) 144 ....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D 145 .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D 146 ......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01)) 147 ......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662 148 ...; 149 ...S DRUGCLAS="" 150 ...D GETCLASS 151 ...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D 152 ....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES 153 ....N LIST S LIST="TIULMED" K ^TMP($J,LIST) 154 ....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662 155 ....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE) 156 .....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX) 157 .....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX) 158 .....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS="" 159 .....I 'CDONE D 160 ......I DRUGCLAS="" S DRUGCLAS=TMPCLASS 161 ......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS="" 162 .....I 'SDONE D 163 ......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S")) 164 ......I 'ISSUPPLY S SDONE=1 165 ....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0 166 ..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" " 167 .; 168 .; *** Save wanted meds in "B" temp xref, removing duplicates *** 169 .; 170 .I KEEPMED D 171 ..D ADDMED^TIULMED1(1) ; Get XSTR to check for duplicates 172 ..;VMP OIFO BAY PINES;ELR;TIU*1.0*198;ADDED TIUXSTAT TO TMP GLOBAL 173 ..S IDATE=$P(NODE,U,15) 174 ..S OK='$D(@TARGET@("B",MED,XSTR,TIUXSTAT)) 175 ..I 'OK,(IDATE>@TARGET@("B",MED,XSTR,TIUXSTAT)) S OK=1 176 ..I OK D 177 ...S @TARGET@("B",MED,XSTR,TIUXSTAT)=IDATE_U_INDEX_U_MEDTYPE_STATIDX_U_TYPE_U_DRUGCLAS 178 ...S EMPTY=0 179 ...I DRUGCLAS=" " S UNKNOWNS=1 180 ; 181 D SORTSAVE^TIULMED3 K @TARGET@("B"),@TARGET@("C") ;P213 182 LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED"),TIUDATE ; K TIUDATE added for PSO*7*294 183 Q "~@"_$NA(@TARGET) 184 ; 185 GETCLASS ; 186 D GETCLASS^TIULMED3 187 Q 1 TIULMED ; SLC/JM,JH - Active/Recent Med Objects Routine ;1/23/07 2 ;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213**;Jun 20, 1997;Build 3 3 Q 4 LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ; 5 ; This is the TIU Medication objects API. Optional parameters not 6 ; provided default to 0 (with the exception of SUPPLIES). 7 ;Required Parameters: 8 ; DFN Patient identifier 9 ; TARGET Where the medication data will be stored 10 ;Optional Parameters: 11 ; ACTVONLY 0 - Active and recently expired meds 12 ; 1 - Active meds only 13 ; 2 - Recently expired meds only 14 ; DETAILED 0 - One line per med only 15 ; 1 - Detailed information on each med 16 ; ALLMEDS 0 - Specifies Inpatient Meds if patient is an 17 ; Inpatient, or Outpatient Meds if patient 18 ; is an Outpatient 19 ; 1 - Specifies both Inpatient and Outpatient 20 ; 2 or "I" - Specifies Inpatient only 21 ; 3 or "O" - Specifies Outpatient only 22 ; ONELIST 0 - Separates Active, Pending and Inactive 23 ; medications into separate lists 24 ; 1 - Combines Active, Pending and Inactive 25 ; medications into the same list 26 ; CLASSORT 0 - Sort meds alphabetically 27 ; 1 - Sort meds by drug class, and within the 28 ; same drug class, sort alphabetically 29 ; 2 - Same as #1, but show drug class in header 30 ; SUPPLIES 0 - Supplies are excluded 31 ; 1 - Supplies are included (Default) 32 N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK 33 N STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,MED,IDATE,XSTR,LLEN 34 N SPACE60,DASH73,LINE,TAB,HEADER 35 N DRUGCLAS,DRUGIDX,UNKNOWNS 36 N NVATYPE,NVAMED,NVASTR,TIUXSTAT 37 N %,%H,STOP,LSTFD ;Clean up after external calls... 38 S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47 39 S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="=" 40 K @TARGET,^TMP("PS",$J) 41 ; Check for Pharmacy Package and required patches 42 I '$$PATCHSOK^TIULMED3 G LISTX ;P213 43 I '+$G(ACTVONLY) S ACTVONLY=0 44 I '+$G(DETAILED) S DETAILED=0 45 I +$D(ALLMEDS) D 46 .I ALLMEDS="I" S ALLMEDS=2 47 .E I ALLMEDS="O" S ALLMEDS=3 48 I '+$G(ALLMEDS) S ALLMEDS=0 49 I '+$G(ONELIST) S ONELIST=0 50 I '+$G(CLASSORT) S CLASSORT=0 51 I $G(SUPPLIES)'="0" S SUPPLIES=1 52 S (EMPTY,HEADER)=1 53 I ONELIST,'ALLMEDS,'DETAILED,'CLASSORT S HEADER=0 54 I 'DETAILED S LLEN=60 55 S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^" 56 S PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^" 57 S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient? IA 10035 58 I ISINP S INPTYPE=1,OUTPTYPE=2 59 E S INPTYPE=2,OUTPTYPE=1 60 S NVATYPE=3 61 D ADDTITLE^TIULMED1 62 ; 63 ; *** Scan medication data and skip unwanted meds *** 64 ; 65 D OCL^PSOORRL(DFN,"","") ; IA 2400 66 S INDEX=0 67 F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D 68 .S NODE=$G(^TMP("PS",$J,INDEX,0)) 69 .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds 70 .I KEEPMED D 71 ..S STATUS=$P(NODE,U,9) 72 ..I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)" 73 ..I $F(ASTATS,"^"_STATUS_"^")>0 S STATIDX=1 74 ..E I ($F(PSTATS,"^"_STATUS_"^")>0) S STATIDX=2 75 ..E S STATIDX=3 76 ..S TIUXSTAT=STATUS 77 ..I ACTVONLY=1 S KEEPMED=(STATIDX<3) 78 ..I ACTVONLY=2 S KEEPMED=(STATIDX=3) 79 ..I +ONELIST S STATIDX=1 80 .I KEEPMED D 81 ..S TYPE=$P($P(NODE,U),";",2) 82 ..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"") 83 ..S NVAMED=$P($P(NODE,U),";") 84 ..S NVAMED=$E(NVAMED,$L(NVAMED)) 85 ..S KEEPMED=(TYPE'="") 86 .I KEEPMED D 87 ..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV" 88 ..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV" 89 ..I TYPE="OP" S MEDTYPE=OUTPTYPE 90 ..E S MEDTYPE=INPTYPE 91 ..I NVAMED="N" S MEDTYPE=NVATYPE 92 ..I ALLMEDS=0 D I 1 93 ...I MEDTYPE=INPTYPE S KEEPMED=ISINP 94 ...E S KEEPMED='ISINP 95 ..E I ALLMEDS=2 S KEEPMED=(MEDTYPE=INPTYPE) 96 ..E I ALLMEDS=3 S KEEPMED=(MEDTYPE=OUTPTYPE!(MEDTYPE=NVATYPE)) 97 .S DRUGCLAS=" " 98 .S MED=$P(NODE,U,2) 99 .I KEEPMED,(CLASSORT!('SUPPLIES)) D 100 ..S DRUGIDX=$$IENNAME^TIULMED2(MED) 101 ..D GETCLASS 102 .. ; If DRUGIDX="" (MED not in Drug File 50), get info 103 .. ; via Orderable Item instead. 104 ..I KEEPMED,+DRUGIDX=0 D 105 ...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY 106 ...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID)) 107 ...S (DRUGIDX,ORDIDX)=0 108 ...K ^TMP($J,"TIULMED") 109 ...; IDX is Order #; ID indicates what file. See IA 2400 110 ...; R;O MED will always be in Drug File (Unless Drug File entry was 111 ...; changed after ordering. 112 ...I ID="R;O" D ;R;O = prescription (file #52). P213 113 ....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820 114 ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6)) 115 ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI")) 116 ...; 117 ...I ID="P;O" D ;P;O = pending outpatient order (file #52.41). P213 118 ....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821 119 ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11)) 120 ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8)) 121 ...; 122 ...I ID="P;I" D ;P;I = pending inpatient order (file #53.1) 123 ....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D ; IA 2907 124 .....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX D 125 ......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U) 126 ....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U) 127 ...; 128 ...I ID="U;I" D ;U;I = unit dose order (file #55, subfile 55.06) P213 129 ....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826 130 ....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D 131 .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0 132 .....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01)) 133 .....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108)) 134 ...; 135 ...I ID="V;I" D ;V;I = IV order (file #55, subfile 55.01). P213 136 ....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826 137 ....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX 138 ....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130)) 139 ....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D 140 .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D 141 ......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01)) 142 ......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662 143 ...; 144 ...S DRUGCLAS="" 145 ...D GETCLASS 146 ...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D 147 ....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES 148 ....N LIST S LIST="TIULMED" K ^TMP($J,LIST) 149 ....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662 150 ....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE) 151 .....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX) 152 .....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX) 153 .....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS="" 154 .....I 'CDONE D 155 ......I DRUGCLAS="" S DRUGCLAS=TMPCLASS 156 ......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS="" 157 .....I 'SDONE D 158 ......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S")) 159 ......I 'ISSUPPLY S SDONE=1 160 ....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0 161 ..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" " 162 .; 163 .; *** Save wanted meds in "B" temp xref, removing duplicates *** 164 .; 165 .I KEEPMED D 166 ..D ADDMED^TIULMED1(1) ; Get XSTR to check for duplicates 167 ..;VMP OIFO BAY PINES;ELR;TIU*1.0*198;ADDED TIUXSTAT TO TMP GLOBAL 168 ..S IDATE=$P(NODE,U,15) 169 ..S OK='$D(@TARGET@("B",MED,XSTR,TIUXSTAT)) 170 ..I 'OK,(IDATE>@TARGET@("B",MED,XSTR,TIUXSTAT)) S OK=1 171 ..I OK D 172 ...S @TARGET@("B",MED,XSTR,TIUXSTAT)=IDATE_U_INDEX_U_MEDTYPE_STATIDX_U_TYPE_U_DRUGCLAS 173 ...S EMPTY=0 174 ...I DRUGCLAS=" " S UNKNOWNS=1 175 ; 176 D SORTSAVE^TIULMED3 K @TARGET@("B"),@TARGET@("C") ;P213 177 LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED") 178 Q "~@"_$NA(@TARGET) 179 ; 180 GETCLASS ; 181 D GETCLASS^TIULMED3 182 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m
r613 r623 1 TIULP ; SLC/JER - Functions determining privilege ;11/13/07 2 ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217,236,234**;Jun 20, 1997;Build 6 3 ; CANDO^USRLA: ICA 2325, ISA^USRLM: ICA 2324 4 ; 8930.1,2,8: IACS 3129,3128,3104 5 CANDO(TIUDA,TIUACT,PERSON) ; Can PERSON perform action now 6 ; Receives: TIUDA=Record number in file 8925 7 ; TIUACT=Name of user action in 8930.8 (USR ACTION) 8 ; PERSON=New Person file IFN. 9 ; Assumed to be DUZ if not received. 10 ; New **100** ID param, backward compatible. 11 ; Returns: TIUY=1:yes,0:no_"^"_why not message 12 N TIUI,TIUTYP,TIUROLE,STATUS,TIUY,TIUATYP,MSG,WHO,MODIFIER,TIUD0,TIUACTW 13 S TIUY=0 I '$G(PERSON) S PERSON=DUZ 14 S TIUD0=$G(^TIU(8925,+TIUDA,0)) I 'TIUD0 G CANDOX 15 I $$ISPRFDOC^TIUPRF(TIUDA),((TIUACT="ATTACH ID ENTRY")!(TIUACT="ATTACH TO ID NOTE")) S TIUY="0^Patient Record Flag notes may not be used as Interdisciplinary notes." G CANDOX 16 S TIUACTW=$G(TIUACT) 17 ;**100** was I +TIUACT'>0 S TIUACT etc. 18 S TIUACT=$$USREVNT(TIUACT) I +TIUACT'>0 G CANDOX 19 ; -- Historical Procedures - Prohibit actions detailed in 20 ; HPCAN^TIUCP: P182 21 N HPCAN I $$ISHISTCP^TIUCP(+TIUD0) S HPCAN=$$HPCAN^TIUCP(+TIUACT) I 'HPCAN S TIUY=HPCAN G CANDOX 22 ; **152 Get status 23 S STATUS=+$P(TIUD0,U,5) 24 ; **152[234] prevents editing or sending back a completed or uncosigned document. 25 I STATUS>5,(+TIUACT=9)!(+TIUACT=17) D G CANDOX 26 . ; **152[234] Displays message to user 27 . I +TIUACT=9 S TIUY="0^ You may not edit uncosigned or completed documents." 28 . I +TIUACT=17 S TIUY="0^You may not send back uncosigned or completed documents." 29 ; -- In case business rules have changed, & children already existed: 30 I +TIUACT=24,$D(^TIU(8925,"GDAD",TIUDA)) D G CANDOX 31 . S TIUY="0^ This note cannot be attached; it has its own children." 32 I +TIUACT=25,+$G(^TIU(8925,TIUDA,21)) D G CANDOX 33 . S TIUY="0^ This note cannot receive interdisciplinary children; it is itself a child." 34 I +TIUACT=4!(+TIUACT=5),+$$BLANK^TIULC(TIUDA) D G CANDOX ;Sets TIUPRM1 35 . S TIUY="0^ Contains blanks ("_$P(TIUPRM1,U,6)_") which must be filled before "_$P(TIUACT,U,2)_"ATURE." 36 S TIUROLE=$$USRROLE(TIUDA,PERSON) 37 S TIUTYP=+TIUD0 38 I $$ISADDNDM^TIULC1(+TIUDA) S TIUATYP=TIUTYP,TIUTYP=+$G(^TIU(8925,+$P(TIUD0,U,6),0)) 39 I TIUROLE']"" S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON) 40 F TIUI=1:1:($L(TIUROLE,U)-1) D Q:+$G(TIUY)>0 41 . S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON,$P(TIUROLE,U,TIUI)) 42 I +$G(TIUATYP) S TIUTYP=+$G(TIUATYP) 43 ;**100** update for PERSON param; update for verb modifier: 44 I +TIUY'>0 D G CANDOX 45 . S WHO=" You" 46 . ;I PERSON'=DUZ S WHO=$P(^VA(200,PERSON,0),U),WHO=$$NAME^TIULS(WHO,"FIRST LAST") 47 . I PERSON'=DUZ S WHO=$$NAME^TIULS($$GET1^DIQ(200,PERSON,.01),"FIRST LAST") ;P182 48 . S MODIFIER=$P(TIUACT,U,3) I $L(MODIFIER) S MODIFIER=" "_MODIFIER 49 . ;e.g. "You may not ATTACH this UNSIGNED TELEPHONE NOTE TO AN ID NOTE." 50 . S MSG=WHO_" may not "_$P(TIUACT,U,2)_" this "_$P($G(^TIU(8925.6,+STATUS,0)),U)_" "_$$PNAME^TIULC1(TIUTYP)_MODIFIER_"." 51 . S TIUY=TIUY_U_MSG 52 I +TIUACT=15,$$HASIMG^TIURB2(+TIUDA) D G CANDOX 53 . S TIUY="0^ This document contains linked images. You must ""delete"" the Images using the Imaging package before proceeding." 54 ;VMP/ELR P217. Do not allow deletion of a parent with child 55 I $G(TIUACTW)["DELETE RECORD",$$HASIDKID^TIUGBR(+TIUDA) D G CANDOX 56 . S TIUY="0^ "_$$EZBLD^DIALOG(89250013) 57 CANDOX Q TIUY 58 ; 59 CANLINK(TIUTYP) ; Can user (DUZ) link (attach) a document of a particular type 60 ;to an ID note. 61 ; For use in ADD NEW ID NOTE, where docmt is not entered yet. 62 ; Assume most favorable circumstances (user will complete 63 ;the note, so if user still can't attach, can tell them no, 64 ;when they first select title for the new entry. 65 ; Rule out if TIUTYP can be an ID parent, since ID parent 66 ;and ID kid function as mutually exclusive, (regardless of 67 ;business rules). 68 N TIUACT,STATUS,USRROLE,TIUY 69 S TIUACT=$$USREVNT("ATTACH TO ID NOTE"),STATUS=7 ; complete 70 S USRROLE=+$O(^USR(8930.2,"B","COMPLETER",0)) 71 S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE) 72 I '$G(TIUY) S TIUY="0^ You may not use this title for interdisciplinary child entries." Q TIUY 73 ; -- If user can attach a certain note, but note can also receive 74 ; ID entries, don't let user attach it. -- 75 I $$POSSPRNT^TIULP(TIUTYP) S TIUY="0^ This interdisciplinary PARENT title cannot be used for CHILD entries." 76 ; -- If selected type is a CWAD, don't let user attach it: -- 77 I $$ISCWAD^TIULX(TIUTYP) S TIUY="0^ CWAD titles cannot be used for interdisciplinary entries." 78 ; -- If selected type is a PRF, don't let user attach it: -- 79 I $$ISPFTTL^TIUPRFL(TIUTYP) S TIUY="0^ Patient Record Flag titles cannot be used for interdisciplinary entries." 80 ; -- If selected type is a consult, don't let user attach it: -- 81 I $$ISA^TIULX(TIUTYP,+$$CLASS^TIUCNSLT) S TIUY="0^ Consult titles cannot be used for interdisciplinary entries." 82 Q TIUY 83 ; 84 POSSPRNT(TIUTYP) ; Is a docmt intended as a possible ID parent? 85 ;Returns 1^WHYCAN'TATTACH if there are business rules permitting ANYONE 86 ;to attach ID entries to notes of type TIUTYP. 87 ;Else returns 0. 88 N TIUACT,STATUS,TIUY,DADTYP 89 S TIUY=0,TIUACT=+$$USREVNT("ATTACH ID ENTRY") 90 F STATUS=6,7,8 D G:TIUY POSSX 91 . I $O(^USR(8930.1,"AR",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 Q 92 . I $O(^USR(8930.1,"AC",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 93 ; -- If no rules for TIUTYP, try its parent: -- 94 S DADTYP=$O(^TIU(8925.1,"AD",TIUTYP,0)) G:DADTYP'>0 POSSX 95 S TIUY=$$POSSPRNT(DADTYP) 96 POSSX I TIUY S TIUY="1^ Interdisciplinary PARENT notes cannot be attached as CHILD entries." 97 Q TIUY 98 ; 99 CANENTR(TIUTYP) ; Evaluate privilege to enter a document of a particular type 100 N TIUACT,STATUS,USRROLE,TIUY 101 S TIUACT=$$USREVNT("ENTRY"),STATUS=2 ; untranscribed 102 S USRROLE=3 ; transcriber 103 S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE) 104 Q TIUY 105 USRROLE(TIUDA,PERSON) ; Identify the user's role with respect to the document 106 ; 3/20/00 **100** Added role COMPLETER 107 ; 3/20/00 **100** Added PERSON param 108 N TIU0,TIU12,TIU13,TIUY,TIU15,COMPLTR,STATUS 109 S PERSON=$G(PERSON,DUZ) 110 S TIU0=$G(^TIU(8925,+TIUDA,0)),STATUS=$P(TIU0,U,5) 111 S TIU12=$G(^TIU(8925,+TIUDA,12)) 112 S TIU13=$G(^TIU(8925,+TIUDA,13)),TIU15=$G(^TIU(8925,+TIUDA,15)) 113 I PERSON=+$P(TIU13,U,2) S TIUY=+$O(^USR(8930.2,"B","TRANSCRIBER",0))_U 114 I PERSON=+$P(TIU12,U,2) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","AUTHOR/DICTATOR",0))_U 115 I PERSON=+$P(TIU12,U,9) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ATTENDING PHYSICIAN",0))_U 116 I PERSON=+$P(TIU12,U,4) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED SIGNER",0))_U 117 I PERSON=+$P(TIU12,U,8) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED COSIGNER",0))_U 118 I $$ASURG^TIUADSIG(TIUDA) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U ;P157 119 ;Check if the person can be an Interpreter for this document via a Consult API 120 I $$CPINTERP^GMRCCP(+TIUDA,PERSON) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","INTERPRETER",0))_U 121 I STATUS>6 D I COMPLTR S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","COMPLETER",0))_U 122 . S COMPLTR=0 123 . I PERSON=+$P(TIU15,U,8) S COMPLTR=1 Q 124 . I '$P(TIU15,U,8),PERSON=+$P(TIU15,U,2) S COMPLTR=1 125 I +$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) D 126 . N TIUXTRA S TIUXTRA=+$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) 127 . I +$P($G(^TIU(8925.7,+TIUXTRA,0)),U,4) Q 128 . S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ADDITIONAL SIGNER",0))_U 129 Q $G(TIUY) 130 USREVNT(EVENT) ; Given event name, return: 131 ;EVENT = event pointer^user verb^verb modifier 132 ; **100** added verb modifier piece (.07) 133 N TIUY,TIUDA,NODE0 134 S TIUDA=+$O(^USR(8930.8,"B",EVENT,0)) 135 S NODE0=$G(^USR(8930.8,TIUDA,0)) 136 S TIUY=TIUDA_U_$P(NODE0,U,5)_U_$P(NODE0,U,7) 137 Q TIUY 138 CANPICK(TIUTYP) ; Screens selection of title by title status and 139 ;(for status TEST), by owner. 140 N TIUPOWN,TIUCOWN,TIUT0,TIUTSTAT,TIUY S TIUY=0 141 S TIUT0=$G(^TIU(8925.1,+TIUTYP,0)),TIUTSTAT=$P(TIUT0,U,7) 142 I TIUTSTAT']"" S TIUY=0 G CANPIX 143 I TIUTSTAT=13 S TIUY=0 G CANPIX 144 I TIUTSTAT=11 S TIUY=1 G CANPIX 145 S TIUPOWN=$P(TIUT0,U,5),TIUCOWN=+$P(TIUT0,U,6) 146 I TIUTSTAT=10 S TIUY=$S(TIUPOWN=DUZ:1,+$$ISA^USRLM(DUZ,TIUCOWN):1,1:0) 147 CANPIX Q +$G(TIUY) 148 REQCOSIG(TIUTYP,TIUDA,USER,TIUDT) ; Evaluate whether user requires cosignature 149 N TIUI,TIUY,TIUDPRM S USER=$S(+$G(USER):+$G(USER),1:+$G(DUZ)) 150 D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$G(TIUDA)) 151 I $G(TIUDPRM(5))="" G REQCOSX 152 I +$G(TIUDT)'>0 S TIUDT=+$P($P(+$G(^TIU(8925,+$G(TIUDA),13)),U),".") 153 F TIUI=1:1:$L(TIUDPRM(5),U) D Q:+TIUY>0 154 . S TIUY=+$$ISA^USRLM(+USER,+$P(TIUDPRM(5),U,TIUI),,+$G(TIUDT)) 155 REQCOSX Q +$G(TIUY) 156 ; 157 REQCPF(TIUCDA) ;Check if clinical procedure fields are required 158 ; Input -- TIUCDA Request/Consult File (#123) IEN 159 ; Output -- 1=Required and 0=Not Required 160 N TIUCPACT,REQF 161 I '$G(TIUCDA) G REQCPFQ 162 S TIUCPACT=$$CPACTM^GMRCCP(TIUCDA) 163 I TIUCPACT=1!(TIUCPACT=3) S REQF=1 164 REQCPFQ Q +$G(REQF) 1 TIULP ; SLC/JER - Functions determining privilege ;7/29/05 2 ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217**;Jun 20, 1997 3 CANDO(TIUDA,TIUACT,PERSON) ; Can PERSON perform action now 4 ; Receives: TIUDA=Record number in file 8925 5 ; TIUACT=Name of user action in 8930.8 (USR ACTION) 6 ; PERSON=New Person file IFN. 7 ; Assumed to be DUZ if not received. 8 ; New **100** ID param, backward compatible. 9 ; Returns: TIUY=1:yes,0:no_"^"_why not message 10 N TIUI,TIUTYP,TIUROLE,STATUS,TIUY,TIUATYP,MSG,WHO,MODIFIER,TIUD0,TIUACTW 11 S TIUY=0 I '$G(PERSON) S PERSON=DUZ 12 S TIUD0=$G(^TIU(8925,+TIUDA,0)) I 'TIUD0 G CANDOX 13 I $$ISPRFDOC^TIUPRF(TIUDA),((TIUACT="ATTACH ID ENTRY")!(TIUACT="ATTACH TO ID NOTE")) S TIUY="0^Patient Record Flag notes may not be used as Interdisciplinary notes." G CANDOX 14 S TIUACTW=$G(TIUACT) 15 ;**100** was I +TIUACT'>0 S TIUACT etc. 16 S TIUACT=$$USREVNT(TIUACT) I +TIUACT'>0 G CANDOX 17 ; -- Historical Procedures - Prohibit actions detailed in 18 ; HPCAN^TIUCP: P182 19 N HPCAN I $$ISHISTCP^TIUCP(+TIUD0) S HPCAN=$$HPCAN^TIUCP(+TIUACT) I 'HPCAN S TIUY=HPCAN G CANDOX 20 ; **152 Get status to evaluate for completed document. 21 S STATUS=+$P(TIUD0,U,5) 22 ; **152 prevents editing or sending back a completed document. 23 I STATUS>6,(+TIUACT=9)!(+TIUACT=17) D G CANDOX 24 .; **152 Displays message to user 25 . I +TIUACT=9 S TIUY="0^ You may not edit a completed document." 26 . I +TIUACT=17 S TIUY="0^You may not send back this completed document." 27 ; -- In case business rules have changed, & children already existed: 28 I +TIUACT=24,$D(^TIU(8925,"GDAD",TIUDA)) D G CANDOX 29 . S TIUY="0^ This note cannot be attached; it has its own children." 30 I +TIUACT=25,+$G(^TIU(8925,TIUDA,21)) D G CANDOX 31 . S TIUY="0^ This note cannot receive interdisciplinary children; it is itself a child." 32 I +TIUACT=4!(+TIUACT=5),+$$BLANK^TIULC(TIUDA) D G CANDOX 33 . S TIUY="0^ Contains blanks ("_$P(TIUPRM1,U,6)_") which must be filled before "_$P(TIUACT,U,2)_"ATURE." 34 S TIUROLE=$$USRROLE(TIUDA,PERSON) 35 S TIUTYP=+TIUD0 36 I $$ISADDNDM^TIULC1(+TIUDA) S TIUATYP=TIUTYP,TIUTYP=+$G(^TIU(8925,+$P(TIUD0,U,6),0)) 37 I TIUROLE']"" S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON) 38 F TIUI=1:1:($L(TIUROLE,U)-1) D Q:+$G(TIUY)>0 39 . S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON,$P(TIUROLE,U,TIUI)) 40 I +$G(TIUATYP) S TIUTYP=+$G(TIUATYP) 41 ;**100** update for PERSON param; update for verb modifier: 42 I +TIUY'>0 D G CANDOX 43 . S WHO=" You" 44 . ;I PERSON'=DUZ S WHO=$P(^VA(200,PERSON,0),U),WHO=$$NAME^TIULS(WHO,"FIRST LAST") 45 . I PERSON'=DUZ S WHO=$$NAME^TIULS($$GET1^DIQ(200,PERSON,.01),"FIRST LAST") ;P182 46 . S MODIFIER=$P(TIUACT,U,3) I $L(MODIFIER) S MODIFIER=" "_MODIFIER 47 . ;e.g. "You may not ATTACH this UNSIGNED TELEPHONE NOTE TO AN ID NOTE." 48 . S MSG=WHO_" may not "_$P(TIUACT,U,2)_" this "_$P($G(^TIU(8925.6,+STATUS,0)),U)_" "_$$PNAME^TIULC1(TIUTYP)_MODIFIER_"." 49 . S TIUY=TIUY_U_MSG 50 I +TIUACT=15,$$HASIMG^TIURB2(+TIUDA) D G CANDOX 51 . S TIUY="0^ This document contains linked images. You must ""delete"" the Images using the Imaging package before proceeding." 52 ;VMP/ELR P217. Do not allow deletion of a parent with child 53 I $G(TIUACTW)["DELETE RECORD",$$HASIDKID^TIUGBR(+TIUDA) D G CANDOX 54 . S TIUY="0^ "_$$EZBLD^DIALOG(89250013) 55 CANDOX Q TIUY 56 ; 57 CANLINK(TIUTYP) ; Can user (DUZ) link (attach) a document of a particular type 58 ;to an ID note. 59 ; For use in ADD NEW ID NOTE, where docmt is not entered yet. 60 ; Assume most favorable circumstances (user will complete 61 ;the note, so if user still can't attach, can tell them no, 62 ;when they first select title for the new entry. 63 ; Rule out if TIUTYP can be an ID parent, since ID parent 64 ;and ID kid function as mutually exclusive, (regardless of 65 ;business rules). 66 N TIUACT,STATUS,USRROLE,TIUY 67 S TIUACT=$$USREVNT("ATTACH TO ID NOTE"),STATUS=7 ; complete 68 S USRROLE=+$O(^USR(8930.2,"B","COMPLETER",0)) 69 S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE) 70 I '$G(TIUY) S TIUY="0^ You may not use this title for interdisciplinary child entries." Q TIUY 71 ; -- If user can attach a certain note, but note can also receive 72 ; ID entries, don't let user attach it. -- 73 I $$POSSPRNT^TIULP(TIUTYP) S TIUY="0^ This interdisciplinary PARENT title cannot be used for CHILD entries." 74 ; -- If selected type is a CWAD, don't let user attach it: -- 75 I $$ISCWAD^TIULX(TIUTYP) S TIUY="0^ CWAD titles cannot be used for interdisciplinary entries." 76 ; -- If selected type is a PRF, don't let user attach it: -- 77 I $$ISPFTTL^TIUPRFL(TIUTYP) S TIUY="0^ Patient Record Flag titles cannot be used for interdisciplinary entries." 78 ; -- If selected type is a consult, don't let user attach it: -- 79 I $$ISA^TIULX(TIUTYP,+$$CLASS^TIUCNSLT) S TIUY="0^ Consult titles cannot be used for interdisciplinary entries." 80 Q TIUY 81 ; 82 POSSPRNT(TIUTYP) ; Is a docmt intended as a possible ID parent? 83 ;Returns 1^WHYCAN'TATTACH if there are business rules permitting ANYONE 84 ;to attach ID entries to notes of type TIUTYP. 85 ;Else returns 0. 86 N TIUACT,STATUS,TIUY,DADTYP 87 S TIUY=0,TIUACT=+$$USREVNT("ATTACH ID ENTRY") 88 F STATUS=6,7,8 D G:TIUY POSSX 89 . I $O(^USR(8930.1,"AR",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 Q 90 . I $O(^USR(8930.1,"AC",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 91 ; -- If no rules for TIUTYP, try its parent: -- 92 S DADTYP=$O(^TIU(8925.1,"AD",TIUTYP,0)) G:DADTYP'>0 POSSX 93 S TIUY=$$POSSPRNT(DADTYP) 94 POSSX I TIUY S TIUY="1^ Interdisciplinary PARENT notes cannot be attached as CHILD entries." 95 Q TIUY 96 ; 97 CANENTR(TIUTYP) ; Evaluate privilege to enter a document of a particular type 98 N TIUACT,STATUS,USRROLE,TIUY 99 S TIUACT=$$USREVNT("ENTRY"),STATUS=2 ; untranscribed 100 S USRROLE=3 ; transcriber 101 S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE) 102 Q TIUY 103 USRROLE(TIUDA,PERSON) ; Identify the user's role with respect to the document 104 ; 3/20/00 **100** Added role COMPLETER 105 ; 3/20/00 **100** Added PERSON param 106 N TIU0,TIU12,TIU13,TIUY,TIU15,COMPLTR,STATUS 107 S PERSON=$G(PERSON,DUZ) 108 S TIU0=$G(^TIU(8925,+TIUDA,0)),STATUS=$P(TIU0,U,5) 109 S TIU12=$G(^TIU(8925,+TIUDA,12)) 110 S TIU13=$G(^TIU(8925,+TIUDA,13)),TIU15=$G(^TIU(8925,+TIUDA,15)) 111 I PERSON=+$P(TIU13,U,2) S TIUY=+$O(^USR(8930.2,"B","TRANSCRIBER",0))_U 112 I PERSON=+$P(TIU12,U,2) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","AUTHOR/DICTATOR",0))_U 113 I PERSON=+$P(TIU12,U,9) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ATTENDING PHYSICIAN",0))_U 114 I PERSON=+$P(TIU12,U,4) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED SIGNER",0))_U 115 I PERSON=+$P(TIU12,U,8) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED COSIGNER",0))_U 116 I $$ASURG^TIUADSIG(TIUDA) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U ;P157 117 ;Check if the person can be an Interpreter for this document via a Consult API 118 I $$CPINTERP^GMRCCP(+TIUDA,PERSON) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","INTERPRETER",0))_U 119 I STATUS>6 D I COMPLTR S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","COMPLETER",0))_U 120 . S COMPLTR=0 121 . I PERSON=+$P(TIU15,U,8) S COMPLTR=1 Q 122 . I '$P(TIU15,U,8),PERSON=+$P(TIU15,U,2) S COMPLTR=1 123 I +$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) D 124 . N TIUXTRA S TIUXTRA=+$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) 125 . I +$P($G(^TIU(8925.7,+TIUXTRA,0)),U,4) Q 126 . S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ADDITIONAL SIGNER",0))_U 127 Q $G(TIUY) 128 USREVNT(EVENT) ; Given event name, return: 129 ;EVENT = event pointer^user verb^verb modifier 130 ; **100** added verb modifier piece (.07) 131 N TIUY,TIUDA,NODE0 132 S TIUDA=+$O(^USR(8930.8,"B",EVENT,0)) 133 S NODE0=$G(^USR(8930.8,TIUDA,0)) 134 S TIUY=TIUDA_U_$P(NODE0,U,5)_U_$P(NODE0,U,7) 135 Q TIUY 136 CANPICK(TIUTYP) ; Screens selection of title by title status and 137 ;(for status TEST), by owner. 138 N TIUPOWN,TIUCOWN,TIUT0,TIUTSTAT,TIUY S TIUY=0 139 S TIUT0=$G(^TIU(8925.1,+TIUTYP,0)),TIUTSTAT=$P(TIUT0,U,7) 140 I TIUTSTAT']"" S TIUY=0 G CANPIX 141 I TIUTSTAT=13 S TIUY=0 G CANPIX 142 I TIUTSTAT=11 S TIUY=1 G CANPIX 143 S TIUPOWN=$P(TIUT0,U,5),TIUCOWN=+$P(TIUT0,U,6) 144 I TIUTSTAT=10 S TIUY=$S(TIUPOWN=DUZ:1,+$$ISA^USRLM(DUZ,TIUCOWN):1,1:0) 145 CANPIX Q +$G(TIUY) 146 REQCOSIG(TIUTYP,TIUDA,USER,TIUDT) ; Evaluate whether user requires cosignature 147 N TIUI,TIUY,TIUDPRM S USER=$S(+$G(USER):+$G(USER),1:+$G(DUZ)) 148 D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$G(TIUDA)) 149 I $G(TIUDPRM(5))="" G REQCOSX 150 I +$G(TIUDT)'>0 S TIUDT=+$P($P(+$G(^TIU(8925,+$G(TIUDA),13)),U),".") 151 F TIUI=1:1:$L(TIUDPRM(5),U) D Q:+TIUY>0 152 . S TIUY=+$$ISA^USRLM(+USER,+$P(TIUDPRM(5),U,TIUI),,+$G(TIUDT)) 153 REQCOSX Q +$G(TIUY) 154 ; 155 REQCPF(TIUCDA) ;Check if clinical procedure fields are required 156 ; Input -- TIUCDA Request/Consult File (#123) IEN 157 ; Output -- 1=Required and 0=Not Required 158 N TIUCPACT,REQF 159 I '$G(TIUCDA) G REQCPFQ 160 S TIUCPACT=$$CPACTM^GMRCCP(TIUCDA) 161 I TIUCPACT=1!(TIUCPACT=3) S REQF=1 162 REQCPFQ Q +$G(REQF) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULX.m
r613 r623 1 TIULX ; SLC/JER - Cross-reference library functions ;6/21/06 2 ;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136,219**;Jun 20, 1997;Build 11 3 ; File 200 - IA 10060 4 ; ^ORD(101 - IA 872 5 ; ^DISV - IA 510 6 ALOCP(DA) ; Should record be included in daily print queue by location? 7 ; Receives DA = record # in 8925 8 Q +$$ISPN(+$G(^TIU(8925,+DA,0))) 9 APTP(DA) ; Should record be included in daily print queue by patient? 10 ; Receives DA = record # in 8925 11 Q +$$ISPN(+$G(^TIU(8925,+DA,0))) 12 AAUP(DA) ; Should record be included in daily print queue by author? 13 ; Receives DA = record # in 8925 14 Q +$$ISPN(+$G(^TIU(8925,+DA,0))) 15 BELONGS(TIUDA,CLASS) ; Evaluate whether a given document belongs to a 16 ; particular document class 17 N TIUY 18 I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA=+$P($G(^TIU(8925,+TIUDA,0)),U,6) 19 S TIUY=+$$ISA(+$G(^TIU(8925,+TIUDA,0)),CLASS) 20 Q TIUY 21 ISA(DA,CLASS) ; Evaluate whether a given document type is a member of a 22 ; particular document class 23 ; Receives DA = record # in 8925.1, and 24 ; CLASS = record # of class in 8925.1 25 N TIUI,TIUY S (TIUI,TIUY)=0 26 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D 27 . I TIUI=CLASS S TIUY=1 Q 28 . S TIUY=$$ISA(TIUI,CLASS) 29 Q TIUY 30 ISPN(DA) ; Evaluate whether a given document is a Progress Note 31 ; Receives DA = record # in 8925.1 32 N TIUI,TIUY S (TIUI,TIUY)=0 33 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D 34 . I TIUI=3 S TIUY=1 Q 35 . S TIUY=$$ISPN(TIUI) 36 Q TIUY 37 ISCWAD(DA) ; Evaluate whether a given title is a CWAD 38 ;Is the given title in a CWAD document class? 39 ;New for ID notes 40 ; Receives DA = record # in 8925.1 41 Q $S($$ISA(DA,25):1,$$ISA(DA,27):1,$$ISA(DA,30):1,$$ISA(DA,31):1,1:0) 42 ISDS(DA) ; Evaluate whether a given document is a Discharge Summary 43 ; Receives DA = record # in 8925.1 44 N TIUI,TIUY S (TIUI,TIUY)=0 45 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D 46 . I TIUI=244 S TIUY=1 Q 47 . S TIUY=$$ISDS(TIUI) 48 Q TIUY 49 TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field 50 N XFORM 51 S FLD=$O(^TIU(8925.1,+RTYPE("TYPE"),"HEAD","D",+FLD,0)) 52 I +FLD'>0 G TRNSFRMX 53 S XFORM=$G(^TIU(8925.1,+RTYPE("TYPE"),"HEAD",+FLD,1)) 54 I XFORM']"" G TRNSFRMX 55 X XFORM 56 TRNSFRMX Q X 57 MENUS ; Evaluate/enforce user's menu display preference 58 N TIUI,TIUPREF S TIUPREF=$$PERSPRF^TIULE(DUZ),TIUI=0 59 F S TIUI=$O(^DISV(DUZ,"VALMMENU",TIUI)) Q:+TIUI'>0 D 60 . I $P($G(^ORD(101,+TIUI,0)),U)["TIU" S ^DISV(DUZ,"VALMMENU",TIUI)=$S($P(TIUPREF,U,5)=0:0,1:1) 61 Q 62 XTRASIGN(TIUY,TIUDA) ; Get list of extra signers for a document 63 N TIUI,TIUJ,TIUL,DA,DR,DIC,DIQ,TIUXTRA S (TIUI,TIUJ,TIUL)=0 64 S DIC="^TIU(8925.7,",DIQ="TIUXTRA" 65 F S TIUI=$O(^TIU(8925.7,"B",TIUDA,TIUI)) Q:+TIUI'>0 D 66 . N TIUX,TIUSGNR 67 . S DA=TIUI,DR=".03;.04" D EN^DIQ1 Q:+$D(TIUXTRA)'>9 68 . I $L($G(TIUXTRA(8925.7,DA,.04))) Q 69 . S TIUJ=+$G(TIUJ)+1,TIUL=+$G(TIUL)+1 70 . S TIUSGNR=$G(TIUXTRA(8925.7,DA,.03)) 71 . S TIUX=$$SETSTR^VALM1($G(TIUJ)_") "_TIUSGNR,$G(TIUX),1,39) 72 . S TIUY(TIUL)=DA_U_TIUX 73 Q 74 ASKSIGN(TIUY) ; Identify which Signature to edit 75 N I,L,Y 76 W !!,"Please Indicate Which Expected Signer to Change:",! 77 S (I,L,Y)=0 F S I=$O(TIUY(I)) Q:+I'>0!+Y D 78 . W:$P(TIUY(I),U)]"" !,$P(TIUY(I),U,2) 79 . I I#20=0 S Y=$P($$PICK(1,I,"Select Signer","NO"),U) 80 . S L=I 81 I L#20,'+Y S Y=$P($$PICK(1,L,"Select Signer","NO"),U) 82 I +Y,+$G(TIUY(+Y)) S Y=+$G(TIUY(+Y)) 83 Q Y 84 PICK(LOW,HIGH,PROMPT,TYPE) ; List selection 85 N X,Y S PROMPT=$G(PROMPT,"Select Item"),TYPE=$G(TYPE,"LO") 86 W ! 87 S Y=$$READ^TIUU(TYPE_U_LOW_":"_HIGH,PROMPT) 88 W ! 89 Q Y 90 CWAD ; Entry action for CWAD protocol 91 N GMRPALG,GMRPCWAD,GMRPDFN,GMRPOPT,GMRPEN,GMRPAGE,GMRPCWAD,GMRPDOB 92 N GMRPLOC,GMRPRB,GMRPSSN,GMRPQT 93 I $G(TIUGLINK) W !,"Please finish attaching the interdisciplinay note before displaying alerts.",! H 3 Q 94 D FULL^VALM1 95 I '+$G(DFN),'+$G(ORVP) D Q 96 . W !!,"No Patient Selected...",! 97 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 98 . S VALMBCK="R" 99 D PAT^GMRPNOR1 I $D(GMRPQT) S VALMBCK="R" Q 100 S Y=GMRPDFN,GMRPOPT=1,GMRPEN=1 W !!,"** Current Patient: "_$P(Y,U,2) 101 D ENPAT^GMRPNCW S VALMBCK="R" 102 Q 103 IDSIGNRS(TIUY,TIUDA,TIULIST) ; Add list of Add'l Signers for a TIU Document 104 ; TIULIST(TIUI) [By Ref] = array of users to add/remove as signers 105 ; TIUDA = IEN in ^TIU(8925, 106 N TIUI S TIUI=0 107 F S TIUI=$O(TIULIST(TIUI)) Q:+TIUI'>0 D 108 . N DA,DIC,DLAYGO,DIE,DR,X,Y 109 . ; if current user is already an additional signer, and current user 110 . ; is NOT being removed as an additional signer, then QUIT 111 . I +$O(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0)),($P(TIULIST(TIUI),U,3)'="REMOVE") Q 112 . ; if current user is being removed as a cosigner, then remove him 113 . I $P(TIULIST(TIUI),U,3)="REMOVE" D REMSIGNR(TIUDA,+TIULIST(TIUI)) Q 114 . ; otherwise, add the current user as an additional signer 115 . S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.7,DIC(0)="LX" D ^DIC Q:+Y'>0 116 . S DIE=DIC,TIUY=$G(TIUY)_$S($G(TIUY)]"":U,1:"")_+TIULIST(TIUI) 117 . S DR=".02////"_0_";.03////"_+$G(TIULIST(TIUI)) 118 . D ^DIE 119 . D SEND^TIUALRT(TIUDA) 120 Q 121 REMSIGNR(TIUDA,TIUDUZ) ; Remove user from additional signer list 122 N DA,DIE,DR,DIDEL 123 S DA=+$O(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0)) Q:+DA'>0 124 S (DIDEL,DIE)=8925.7,DR=".01///@" D ^DIE 125 D SEND^TIUALRT(TIUDA) 126 Q 127 GETSIGNR(TIUY,TIUDA) ; RPC to Get list of extra signers for a document 128 N TIUI,DA,DR,DIC,DIQ,TIUXTRA,TIUD12,TIUAU,TIUEC S (DA,TIUI)=0 129 S DIC="^TIU(8925.7,",DIQ="TIUXTRA" 130 F S DA=$O(^TIU(8925.7,"B",TIUDA,DA)) Q:+DA'>0 D 131 . N TIUX,TIUSGNR 132 . S DR=".03;.04",DIQ(0)="IE" D EN^DIQ1 Q:+$D(TIUXTRA)'>9 133 . I +$G(TIUXTRA(8925.7,DA,.04,"I")) Q 134 . S TIUI=+$G(TIUI)+1 135 . S TIUY(TIUI)=$G(TIUXTRA(8925.7,DA,.03,"I"))_U_$G(TIUXTRA(8925.7,DA,.03,"E")) 136 S TIUD12=$G(^TIU(8925,TIUDA,12)) 137 S TIUAU=$P(TIUD12,U,4),TIUEC=$P(TIUD12,U,8) 138 S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUAU_U_$$PERSNAME^TIULC1(TIUAU)_U_"AUTHOR" 139 I +TIUEC'>0 Q 140 I '$$FIND1^DIC(200,"","","`"_+TIUEC) D CLEAN^DILF Q 141 S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUEC_U_$$PERSNAME^TIULC1(TIUEC)_U_"EXPECTED COSIGNER" 142 Q 143 HASDS(DFN,VSTR) ; Does an admission have a Discharge Summary? 144 N TITLE,TIUDA S (TIUDA,TITLE)=0 145 F S TITLE=$O(^TIU(8925,"APTLD",DFN,TITLE)) Q:+TITLE'>0 D Q:+TIUDA>0 146 . N STATUS,CONTEXT S TIUDA=0 147 . I '+$$ISDS(TITLE) S TIUDA=0_U_0 Q 148 . F S TIUDA=$O(^TIU(8925,"APTLD",DFN,TITLE,VSTR,+TIUDA)) Q:+TIUDA'>0 D Q:+$P(TIUDA,U,2) 149 . . S STATUS=+$P($G(^TIU(8925,+TIUDA,0)),U,5) 150 . . S CONTEXT=$S(STATUS=0:0,STATUS>13:0,STATUS'>5:2,1:1) 151 . . S TIUDA=TIUDA_U_CONTEXT 152 I '+TIUDA,($L(TIUDA,U)<2) S TIUDA=TIUDA_U_0 153 Q TIUDA 154 NEEDSIG(TIUY,USER,CLASS) ; Get list of documents for which USER is an additional signer 155 N TIUDA,TIUI,TIUJ S (TIUDA,TIUJ)=0 156 S USER=$G(USER,DUZ),CLASS=$G(CLASS,38),TIUY=$NA(^TMP("TIUSIGN",$J)) 157 K @TIUY ; Clear out return array before query 158 F S TIUDA=$O(^TIU(8925.7,"AES",USER,TIUDA)) Q:+TIUDA'>0 D 159 . S TIUI=0 F S TIUI=$O(^TIU(8925.7,"AES",USER,TIUDA,TIUI)) Q:+TIUI'>0 D 160 . . N TIUD0 S TIUD0=$G(^TIU(8925.7,TIUI,0)) Q:+$P(TIUD0,U,4) 161 . . Q:'+$$ISA(+$G(^TIU(8925,TIUDA,0)),CLASS) 162 . . S TIUJ=+$G(TIUJ)+1,@TIUY@(TIUJ)=TIUDA 163 Q 164 TITLIENS ; Get IENs of DDEF entries that have type Title 165 ; in Document Definition file 8925.1 166 ;Creates array ^TMP("TIUTLS,$J,TLIEN)= 167 ;Caller must kill ^TMP("TIUTLS",$J) when finished with the global. 168 N TIUIDX S TIUIDX=0 K ^TMP("TIUTLS",$J) 169 F S TIUIDX=$O(^TIU(8925.1,"AT","DOC",TIUIDX)) Q:TIUIDX'>0 D 170 . S ^TMP("TIUTLS",$J,TIUIDX)="" 171 Q 172 HASDOCMT(DFN) ;Does patient have ANY entries in TIU DOCUMENT file 8925? 173 ;Any entries includes original documents, addenda, components 174 ;(like S in SOAP notes), "deleted" documents, retracted documents, etc! 175 Q $O(^TIU(8925,"C",+$G(DFN),0))>0 176 1 TIULX ; SLC/JER - Cross-reference library functions ;18-JUN-2002 10:18:05 2 ;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136**;Jun 20, 1997 3 ALOCP(DA) ; Should record be included in daily print queue by location? 4 ; Receives DA = record # in 8925 5 Q +$$ISPN(+$G(^TIU(8925,+DA,0))) 6 APTP(DA) ; Should record be included in daily print queue by patient? 7 ; Receives DA = record # in 8925 8 Q +$$ISPN(+$G(^TIU(8925,+DA,0))) 9 AAUP(DA) ; Should record be included in daily print queue by author? 10 ; Receives DA = record # in 8925 11 Q +$$ISPN(+$G(^TIU(8925,+DA,0))) 12 BELONGS(TIUDA,CLASS) ; Evaluate whether a given document belongs to a 13 ; particular document class 14 N TIUY 15 I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA=+$P($G(^TIU(8925,+TIUDA,0)),U,6) 16 S TIUY=+$$ISA(+$G(^TIU(8925,+TIUDA,0)),CLASS) 17 Q TIUY 18 ISA(DA,CLASS) ; Evaluate whether a given document type is a member of a 19 ; particular document class 20 ; Receives DA = record # in 8925.1, and 21 ; CLASS = record # of class in 8925.1 22 N TIUI,TIUY S (TIUI,TIUY)=0 23 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D 24 . I TIUI=CLASS S TIUY=1 Q 25 . S TIUY=$$ISA(TIUI,CLASS) 26 Q TIUY 27 ISPN(DA) ; Evaluate whether a given document is a Progress Note 28 ; Receives DA = record # in 8925.1 29 N TIUI,TIUY S (TIUI,TIUY)=0 30 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D 31 . I TIUI=3 S TIUY=1 Q 32 . S TIUY=$$ISPN(TIUI) 33 Q TIUY 34 ISCWAD(DA) ; Evaluate whether a given title is a CWAD 35 ;Is the given title in a CWAD document class? 36 ;New for ID notes 37 ; Receives DA = record # in 8925.1 38 Q $S($$ISA(DA,25):1,$$ISA(DA,27):1,$$ISA(DA,30):1,$$ISA(DA,31):1,1:0) 39 ISDS(DA) ; Evaluate whether a given document is a Discharge Summary 40 ; Receives DA = record # in 8925.1 41 N TIUI,TIUY S (TIUI,TIUY)=0 42 F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D 43 . I TIUI=244 S TIUY=1 Q 44 . S TIUY=$$ISDS(TIUI) 45 Q TIUY 46 TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field 47 N XFORM 48 S FLD=$O(^TIU(8925.1,+RTYPE("TYPE"),"HEAD","D",+FLD,0)) 49 I +FLD'>0 G TRNSFRMX 50 S XFORM=$G(^TIU(8925.1,+RTYPE("TYPE"),"HEAD",+FLD,1)) 51 I XFORM']"" G TRNSFRMX 52 X XFORM 53 TRNSFRMX Q X 54 MENUS ; Evaluate/enforce user's menu display preference 55 N TIUI,TIUPREF S TIUPREF=$$PERSPRF^TIULE(DUZ),TIUI=0 56 F S TIUI=$O(^DISV(DUZ,"VALMMENU",TIUI)) Q:+TIUI'>0 D 57 . I $P($G(^ORD(101,+TIUI,0)),U)["TIU" S ^DISV(DUZ,"VALMMENU",TIUI)=$S($P(TIUPREF,U,5)=0:0,1:1) 58 Q 59 XTRASIGN(TIUY,TIUDA) ; Get list of extra signers for a document 60 N TIUI,TIUJ,TIUL,DA,DR,DIC,DIQ,TIUXTRA S (TIUI,TIUJ,TIUL)=0 61 S DIC="^TIU(8925.7,",DIQ="TIUXTRA" 62 F S TIUI=$O(^TIU(8925.7,"B",TIUDA,TIUI)) Q:+TIUI'>0 D 63 . N TIUX,TIUSGNR 64 . S DA=TIUI,DR=".03;.04" D EN^DIQ1 Q:+$D(TIUXTRA)'>9 65 . I $L($G(TIUXTRA(8925.7,DA,.04))) Q 66 . S TIUJ=+$G(TIUJ)+1,TIUL=+$G(TIUL)+1 67 . S TIUSGNR=$G(TIUXTRA(8925.7,DA,.03)) 68 . S TIUX=$$SETSTR^VALM1($G(TIUJ)_") "_TIUSGNR,$G(TIUX),1,39) 69 . S TIUY(TIUL)=DA_U_TIUX 70 Q 71 ASKSIGN(TIUY) ; Identify which Signature to edit 72 N I,L,Y 73 W !!,"Please Indicate Which Expected Signer to Change:",! 74 S (I,L,Y)=0 F S I=$O(TIUY(I)) Q:+I'>0!+Y D 75 . W:$P(TIUY(I),U)]"" !,$P(TIUY(I),U,2) 76 . I I#20=0 S Y=$P($$PICK(1,I,"Select Signer","NO"),U) 77 . S L=I 78 I L#20,'+Y S Y=$P($$PICK(1,L,"Select Signer","NO"),U) 79 I +Y,+$G(TIUY(+Y)) S Y=+$G(TIUY(+Y)) 80 Q Y 81 PICK(LOW,HIGH,PROMPT,TYPE) ; List selection 82 N X,Y S PROMPT=$G(PROMPT,"Select Item"),TYPE=$G(TYPE,"LO") 83 W ! 84 S Y=$$READ^TIUU(TYPE_U_LOW_":"_HIGH,PROMPT) 85 W ! 86 Q Y 87 CWAD ; Entry action for CWAD protocol 88 N GMRPALG,GMRPCWAD,GMRPDFN,GMRPOPT,GMRPEN,GMRPAGE,GMRPCWAD,GMRPDOB 89 N GMRPLOC,GMRPRB,GMRPSSN,GMRPQT 90 I $G(TIUGLINK) W !,"Please finish attaching the interdisciplinay note before displaying alerts.",! H 3 Q 91 D FULL^VALM1 92 I '+$G(DFN),'+$G(ORVP) D Q 93 . W !!,"No Patient Selected...",! 94 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 95 . S VALMBCK="R" 96 D PAT^GMRPNOR1 I $D(GMRPQT) S VALMBCK="R" Q 97 S Y=GMRPDFN,GMRPOPT=1,GMRPEN=1 W !!,"** Current Patient: "_$P(Y,U,2) 98 D ENPAT^GMRPNCW S VALMBCK="R" 99 Q 100 IDSIGNRS(TIUY,TIUDA,TIULIST) ; Add list of Add'l Signers for a TIU Document 101 ; TIULIST(TIUI) [By Ref] = array of users to add/remove as signers 102 ; TIUDA = IEN in ^TIU(8925, 103 N TIUI S TIUI=0 104 F S TIUI=$O(TIULIST(TIUI)) Q:+TIUI'>0 D 105 . N DA,DIC,DLAYGO,DIE,DR,X,Y 106 . ; if current user is already an additional signer, and current user 107 . ; is NOT being removed as an additional signer, then QUIT 108 . I +$O(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0)),($P(TIULIST(TIUI),U,3)'="REMOVE") Q 109 . ; if current user is being removed as a cosigner, then remove him 110 . I $P(TIULIST(TIUI),U,3)="REMOVE" D REMSIGNR(TIUDA,+TIULIST(TIUI)) Q 111 . ; otherwise, add the current user as an additional signer 112 . S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.7,DIC(0)="LX" D ^DIC Q:+Y'>0 113 . S DIE=DIC,TIUY=$G(TIUY)_$S($G(TIUY)]"":U,1:"")_+TIULIST(TIUI) 114 . S DR=".02////"_0_";.03////"_+$G(TIULIST(TIUI)) 115 . D ^DIE 116 . D SEND^TIUALRT(TIUDA) 117 Q 118 REMSIGNR(TIUDA,TIUDUZ) ; Remove user from additional signer list 119 N DA,DIE,DR,DIDEL 120 S DA=+$O(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0)) Q:+DA'>0 121 S (DIDEL,DIE)=8925.7,DR=".01///@" D ^DIE 122 D SEND^TIUALRT(TIUDA) 123 Q 124 GETSIGNR(TIUY,TIUDA) ; RPC to Get list of extra signers for a document 125 N TIUI,DA,DR,DIC,DIQ,TIUXTRA,TIUD12,TIUAU,TIUEC S (DA,TIUI)=0 126 S DIC="^TIU(8925.7,",DIQ="TIUXTRA" 127 F S DA=$O(^TIU(8925.7,"B",TIUDA,DA)) Q:+DA'>0 D 128 . N TIUX,TIUSGNR 129 . S DR=".03;.04",DIQ(0)="IE" D EN^DIQ1 Q:+$D(TIUXTRA)'>9 130 . I +$G(TIUXTRA(8925.7,DA,.04,"I")) Q 131 . S TIUI=+$G(TIUI)+1 132 . S TIUY(TIUI)=$G(TIUXTRA(8925.7,DA,.03,"I"))_U_$G(TIUXTRA(8925.7,DA,.03,"E")) 133 S TIUD12=$G(^TIU(8925,TIUDA,12)) 134 S TIUAU=$P(TIUD12,U,4),TIUEC=$P(TIUD12,U,8) 135 S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUAU_U_$$PERSNAME^TIULC1(TIUAU)_U_"AUTHOR" 136 I $S(+TIUEC'>0:1,'$L($G(^VA(200,+TIUEC,0))):1,1:0) Q 137 S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUEC_U_$$PERSNAME^TIULC1(TIUEC)_U_"EXPECTED COSIGNER" 138 Q 139 HASDS(DFN,VSTR) ; Does an admission have a Discharge Summary? 140 N TITLE,TIUDA S (TIUDA,TITLE)=0 141 F S TITLE=$O(^TIU(8925,"APTLD",DFN,TITLE)) Q:+TITLE'>0 D Q:+TIUDA>0 142 . N STATUS,CONTEXT S TIUDA=0 143 . I '+$$ISDS(TITLE) S TIUDA=0_U_0 Q 144 . F S TIUDA=$O(^TIU(8925,"APTLD",DFN,TITLE,VSTR,+TIUDA)) Q:+TIUDA'>0 D Q:+$P(TIUDA,U,2) 145 . . S STATUS=+$P($G(^TIU(8925,+TIUDA,0)),U,5) 146 . . S CONTEXT=$S(STATUS=0:0,STATUS>13:0,STATUS'>5:2,1:1) 147 . . S TIUDA=TIUDA_U_CONTEXT 148 I '+TIUDA,($L(TIUDA,U)<2) S TIUDA=TIUDA_U_0 149 Q TIUDA 150 NEEDSIG(TIUY,USER,CLASS) ; Get list of documents for which USER is an additional signer 151 N TIUDA,TIUI,TIUJ S (TIUDA,TIUJ)=0 152 S USER=$G(USER,DUZ),CLASS=$G(CLASS,38),TIUY=$NA(^TMP("TIUSIGN",$J)) 153 K @TIUY ; Clear out return array before query 154 F S TIUDA=$O(^TIU(8925.7,"AES",USER,TIUDA)) Q:+TIUDA'>0 D 155 . S TIUI=0 F S TIUI=$O(^TIU(8925.7,"AES",USER,TIUDA,TIUI)) Q:+TIUI'>0 D 156 . . N TIUD0 S TIUD0=$G(^TIU(8925.7,TIUI,0)) Q:+$P(TIUD0,U,4) 157 . . Q:'+$$ISA(+$G(^TIU(8925,TIUDA,0)),CLASS) 158 . . S TIUJ=+$G(TIUJ)+1,@TIUY@(TIUJ)=TIUDA 159 Q 160 -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPREL.m
r613 r623 1 TIUPREL ; GENERATED FROM 'TIU PRINT REL/UNV' PRINT TEMPLATE (#1350) ; 12/13/08; (FILE 8925, MARGIN=132)1 TIUPREL ; GENERATED FROM 'TIU RELEASED/UNVERIFIED PRINT' PRINT TEMPLATE (#1115) ; 07/02/04 ; (FILE 8925, MARGIN=132) 2 2 G BEGIN 3 3 CP G CP^DIO2 … … 21 21 BEGIN ; 22 22 S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT) 23 I $D(DXS)<9 M DXS=^DIPT(1 350,"DXS")23 I $D(DXS)<9 M DXS=^DIPT(1115,"DXS") 24 24 S I(0)="^TIU(8925,",J(0)=8925 25 25 S X=$G(^TIU(8925,D0,0)) W ?0 S Y=$P(X,U,2) S Y=$S(Y="":Y,$D(^AUPNPAT(Y,0))#2:$P(^(0),U),1:Y) S Y=$S(Y="":Y,$D(^DPT(Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,30) … … 39 39 W ?44 S DIP(1)=$S($D(^TIU(8925,D0,0)):^(0),1:"") S X=$P(DIP(1),U,7) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) K DIP K:DN Y W X 40 40 W ?55 S DIP(1)=$S($D(^TIU(8925,D0,0)):^(0),1:"") S X=$P(DIP(1),U,8) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) K DIP K:DN Y W X 41 W ?66 X DXS(1,9.2) S X1=DIP(1) X "S X=$$NAME^TIULS(X,X1)"K DIP K:DN Y W $E(X,1,15)41 W ?66 X DXS(1,9.2) S X1=DIP(1) S X=$$NAME^TIULS(X,X1) K DIP K:DN Y W $E(X,1,15) 42 42 S X=$G(^TIU(8925,D0,0)) W ?83 S Y=$P(X,U,9) W:Y]"" $S($D(DXS(2,Y)):DXS(2,Y),1:Y) 43 43 W ?93 S Y=$P(X,U,10),C=1 D A:Y]"" W $E(Y,1,8) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN1.m
r613 r623 1 TIUPRPN1 ;SLC/JER - Print SF 509-Progress Notes ;11/23/072 ;;1.0;TEXT INTEGRATION UTILITIES;**45,52,87,100,162,182,211,222,234**;Jun 20, 1997;Build 6 3 4 PRINT(TIUFLAG,TIUSPG) 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 REPORT(TIUROOT,TIUFOOT,TIUMISC,TIUCONT,TIUIDEND) 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 S TITLE=@TIUROOT@(.01,"E"),LOINCNM=@TIUROOT@(89261,"E")74 75 76 77 78 79 80 81 82 83 84 I SUBJ]"" W !,"SUBJECT: ",^("E"),! ; @TIUROOT@(1701,"E") 85 86 87 88 89 90 91 ..W !,^(TIUI,0) ; @TIUROOT@("PROBLEM",TIUI,0) 92 93 94 95 96 97 98 99 100 101 102 103 104 105 ADDENDA 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 IDKIDS(TIUROOT,TIUFOOT,TIUMISC,TIUCONT1,TIUCONT) 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 GETSIG(TIUROOT,TIUSIG) 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 SETCONT(TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,TIUROOT) 177 178 179 180 1 TIUPRPN1 ;SLC/JER - Print SF 509-Progress Notes ;10/5/04 2 ;;1.0;TEXT INTEGRATION UTILITIES;**45,52,87,100,162,182,211,222**;Jun 20, 1997 3 ; DBIA 908 ^SC(D0,0) 4 PRINT(TIUFLAG,TIUSPG) ; Print Document 5 ; ^TMP("TIUPR",$J) is array of records to be printed 6 ; TIUFLAG=1 --> Chart Copy TIUSPG=1 --> Contiguous 7 ; TIUFLAG=0 --> Work Copy TIUSPG=0 --> Fresh Page- each note 8 ; TIUCONT=1 --> Continue printing 9 ; TIUCONT1=1 --> Write "Continue to next/from previous-page" msgs 10 ; TIUPFNBR ---> Print Form # like vice 509 11 ; TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA 12 N CONT,TIUASK,TIUI,TIUJ,TIUKID,TIUPAGE,TIUFOOT,TIUK,TIUDA,TIUCONT,TIUPGRP,TIUTYP 13 N TIUPFHDR,TIUPFNBR,TIUMISC,TIUCONT1,TIUIDONE,TMP 14 S TIUFLAG=+$G(TIUFLAG),TIUSPG=+$G(TIUSPG) 15 S (CONT,TIUCONT)=1,(TIUASK,TIUCONT1)=0 16 S TIUI=0 F S TIUI=$O(^TMP("TIUPR",$J,TIUI)) Q:TIUI="" D Q:'TIUCONT 17 . N DFN,TIU 18 . ; -- P182 TIUI has form PGRP$PFHDR;DFN with PGRP possibly 0, and 19 . ; PFHDR possibly null (see TIURA): 20 . S TIUPGRP=+$P(TIUI,"$"),TIUPFHDR=$P($P(TIUI,";"),"$",2) 21 . I TIUPFHDR']"" S TIUPFHDR="Progress Notes" 22 . S DFN=$P(TIUI,";",2) 23 . I $G(TIUPGRP)>2 S TIUSPG=0 24 . D PATPN^TIULV(.TIUFOOT,DFN) 25 . I +$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1) 26 . ; Use TIUJ="" (not TIUJ=0), to print "complete" notes w/o sigdt: 27 . S TIUJ="" F S TIUJ=$O(^TMP("TIUPR",$J,TIUI,TIUJ)) Q:TIUJ="" D Q:'TIUCONT 28 . . S TIUK=0 F S TIUK=$O(^TMP("TIUPR",$J,TIUI,TIUJ,TIUK)) Q:'TIUK D Q:'TIUCONT 29 . . . S TIUCONT1=0 S TIUPFNBR=^TMP("TIUPR",$J,TIUI,TIUJ,TIUK) 30 . . . ; Note: TIUPFNBR may be null 31 . . . ;P182 Set TIUMISC BEFORE quitting if deleted 32 . . . S TIUDA=TIUK,TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA 33 . . . ; Quit docmt if deleted: 34 . . . I '$D(^TIU(8925,+TIUDA,0)) D Q 35 . . . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 36 . . . . W !!,"NOTE DATED:",!,"Document #",TIUDA," for ",$G(TIUFOOT("PNMP")),!,"no longer exists in the TIU DOCUMENT file.",!!! 37 . . . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) 38 . . . N TIUROOT 39 . . . I '+$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1) 40 . . . K ^TMP("TIULQ",$J) 41 . . . D EXTRACT^TIULQ(+TIUDA,"^TMP(""TIULQ"",$J)",.TIUERR,"","",1) 42 . . . I +$G(TIUERR) W !,$P(TIUERR,U,2) Q 43 . . . Q:'$D(^TMP("TIULQ",$J)) 44 . . . S TIUROOT="^TMP(""TIULQ"",$J,"_TIUDA_")" 45 . . . D REPORT(TIUROOT,.TIUFOOT,TIUMISC,.TIUCONT) Q:'TIUCONT 46 . . . D IDKIDS(TIUROOT,.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT) Q:'TIUCONT 47 . . . I '+$G(TIUKID),'+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) 48 . Q:'TIUCONT 49 . I $E(IOST,1,2)="C-" S TIUCONT=$$STOP^TIUPRPN2() Q:'TIUCONT 50 . I '+$G(TIUKID),+$G(TIUSPG),$E(IOST,1,2)'="C-" S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) 51 Q 52 ; 53 REPORT(TIUROOT,TIUFOOT,TIUMISC,TIUCONT,TIUIDEND) ; Report Text 54 ; Requires array TIUFOOT, vars TIUMISC, TIUCONT 55 ; Requires TIUROOT = 56 ; ^TMP("TIULQ",$J,NOTEIFN) for parent/stand-alone note, or 57 ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or 58 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN) for ID kid, or 59 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN,"ZADD",KIDADDMIFN) 60 ; for ID kid addm. 61 N DIW,DIWF,DIWL,DIWR,DIWT,TIUERR,TIU,TIUI,X,Z,LOC 62 N REFDT,TITLE,LOINCNM,ADT,HLOC,SUBJ 63 N TIUDA,TIUCONT1,HASIDKID,HASIDDAD 64 S TIUDA=$P(TIUMISC,U,3),TIUCONT1=0 65 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 66 S HASIDKID=$G(^TMP("TIULQ",$J,TIUDA,"ZZID",0)) ;how many ID kids 67 S HASIDDAD=$S(TIUROOT["ZZID":1,1:0) 68 I HASIDKID W "<< Interdisciplinary Note - Begin >>",! 69 I HASIDDAD W "<< Interdisciplinary Note - Cont. >>",! 70 W $S('HASIDKID&'HASIDDAD:"NOTE DATED: ",1:"ENTRY DATED: ") 71 S REFDT=@TIUROOT@(1301,"I") 72 W $$DATE^TIULS(REFDT,"MM/DD/CCYY HR:MIN") 73 S TITLE=@TIUROOT@(.01,"E") ; ,LOINCNM=@TIUROOT@(89261,"E") 74 W !,"LOCAL TITLE: ",$$UP^XLFSTR(TITLE),! 75 ; I $L(LOINCNM)>1 W "STANDARD TITLE: ",$$UP^XLFSTR(LOINCNM),! 76 S LOC=$G(@TIUROOT@(1205,"I")) 77 I +LOC D 78 . W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ") 79 . S ADT=$G(@TIUROOT@(.07,"I")) 80 . W $$DATE^TIULS(ADT,"MM/DD/CCYY HR:MIN") 81 . S HLOC=$G(@TIUROOT@(1205,"E")) 82 . W " ",HLOC 83 S SUBJ=$G(@TIUROOT@(1701,"E")) 84 I SUBJ]"" W !,"SUBJECT: ",^("E"),! 85 S TIUCONT1=1 86 I $D(@TIUROOT@("PROBLEM")) D Q:'TIUCONT 87 . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 88 . W !,"ASSOCIATED PROBLEMS:" 89 . N TIUI S TIUI=0 90 . F S TIUI=$O(@TIUROOT@("PROBLEM",TIUI)) Q:'TIUI D Q:'TIUCONT 91 ..W !,^(TIUI,0) 92 ..S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 93 W ! 94 S TIUI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") 95 F S TIUI=$O(@TIUROOT@("TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT ; D ^DIWW 96 . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 97 . S X=@TIUROOT@("TEXT",TIUI,0) S:X="" X=" " D ^DIWP 98 D ^DIWW K ^UTILITY($J,"W") 99 Q:'TIUCONT 100 D GETSIG(TIUROOT,.TIUSIG) 101 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 102 W ! 103 D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUROOT) 104 Q:'TIUCONT 105 ADDENDA ; Fall through and do Addenda of docmt TIUDA 106 N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,TIUI,TIUADD,ADDMRDT 107 S TIUADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") 108 F S TIUADD=$O(@TIUROOT@("ZADD",TIUADD)) Q:TIUADD'>0 D Q:'TIUCONT 109 . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 110 . S ADDMRDT=@TIUROOT@("ZADD",TIUADD,1301,"I") 111 . W !!,$$DATE^TIULS(ADDMRDT,"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM" 112 . W ?39,"STATUS: ",@TIUROOT@("ZADD",TIUADD,.05,"E") ;P162 113 . S TIUI=0 114 . F S TIUI=$O(@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT 115 . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 116 . . S X=@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI,0) S:X="" X=" " D ^DIWP 117 . D ^DIWW 118 . Q:'TIUCONT 119 . N TIUADRT 120 . S TIUADRT=$P(TIUROOT,")")_",""ZADD"","_TIUADD_")" 121 . D GETSIG(TIUADRT,.TIUSIG) 122 . D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUADRT) 123 ; Need ! in front for amended notes: 124 I $G(TIUIDEND) W !,"<< Interdisciplinary Note - End >>",! 125 K ^UTILITY($J,"W") 126 ; Write 2 linefeeds between records 127 S:$E(IOST,1,2)="C-" TIUCONT=$$STOP^TIUFLP1,TIUASK=1 128 W:TIUCONT !! 129 Q 130 ; 131 IDKIDS(TIUROOT,TIUFOOT,TIUMISC,TIUCONT1,TIUCONT) ; Print ID kids 132 ;of docmt TIUDA (each kid does its own addenda) 133 N TIUL,KIDDA,TIUDA,TIUSORT,TIUIDRT,TIUIDEND 134 S TIUDA=$P(TIUMISC,U,3),TIUIDEND=0 135 S TIUL=0 136 F S TIUL=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) Q:'TIUL D Q:'TIUCONT 137 . S KIDDA=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL,0)) 138 . I +$$MEMBEROF^TIUPR222(+$G(^TIU(8925,+KIDDA,0)),"FORM LETTERS") D Q ; hand off to TIUFLP1 (Form Letter Print) 139 . . I '+$G(TIUKID),'+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) 140 . . I 'TIUCONT!'CONT Q 141 . . I $E(IOST,1,2)="C-",'+TIUASK S CONT=$$STOP^TIUFLP1,TIUCONT=CONT Q:'+CONT 142 . . S TIUASK=0,TIUKID=1 D IDKID^TIUFLP1(TIUDA,KIDDA) 143 . S TIUMISC=TIUFLAG_U_TIUPFNBR_U_KIDDA 144 . S TIUIDRT="^TMP(""TIULQ"",$J,"_TIUDA_",""ZZID"","_TIUL_","_KIDDA_")" 145 . I '$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) S TIUIDEND=1 146 . D REPORT(TIUIDRT,.TIUFOOT,TIUMISC,.TIUCONT,TIUIDEND) 147 Q 148 ; 149 GETSIG(TIUROOT,TIUSIG) ; Get signature info from TIULQ global; 150 ; Set info into TIUSIG array **100** 151 ; Requires array name TIUROOT; passes back array TIUSIG 152 ; TIUROOT = ^TMP("TIULQ",$J,NOTEIFN) for parent note, or 153 ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or 154 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",IDKIDIFN) for ID kid. 155 ; Signature should be on bottom of form, Addenda on Subsequent pages 156 N TIULINE S $P(TIULINE,"-",81)="" 157 S TIUSIG("AUTHOR")=$G(@TIUROOT@(1202,"I"))_";"_$G(^("E")) 158 S TIUSIG("EXPSIGNR")=$G(@TIUROOT@(1204,"I"))_";"_$G(^("E")) 159 S TIUSIG("EXPCOSNR")=$G(@TIUROOT@(1208,"I"))_";"_$G(^("E")) 160 S TIUSIG("SIGNDATE")=$G(@TIUROOT@(1501,"I")) 161 S TIUSIG("SIGNEDBY")=$G(@TIUROOT@(1502,"I"))_";"_$G(^("E")) 162 S TIUSIG("SIGNNAME")=$G(@TIUROOT@(1503,"E")) 163 S TIUSIG("SIGTITL")=$G(@TIUROOT@(1504,"E")) 164 S TIUSIG("SIGNMODE")=$G(@TIUROOT@(1505,"I"))_";"_$G(^("E")) 165 S TIUSIG("COSGDATE")=$G(@TIUROOT@(1507,"I")) 166 S TIUSIG("COSGEDBY")=$G(@TIUROOT@(1508,"I"))_";"_$G(^("E")) 167 S TIUSIG("COSGNAME")=$G(@TIUROOT@(1509,"E")) 168 S TIUSIG("COSGTITL")=$G(@TIUROOT@(1510,"E")) 169 S TIUSIG("COSGMODE")=$G(@TIUROOT@(1511,"I"))_";"_$G(^("E")) 170 S TIUSIG("SIGCHRT")=$G(@TIUROOT@(1512,"I"))_";"_$G(^("E")) 171 S TIUSIG("COSCHRT")=$G(@TIUROOT@(1513,"I"))_";"_$G(^("E")) 172 ; -- P182 Set Admin Clos Date: 173 S TIUSIG("ADMINCDT")=$G(@TIUROOT@(1606,"I"))_";"_$G(^("E")) 174 Q 175 ; 176 SETCONT(TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,TIUROOT) ;Does footer 177 ;and returns TIUCONT 178 ; Requires array TIUFOOT, vars TIUMISC,TIUCONT1; optional TIUHEAD 179 ; Optional TIUROOT 180 Q $$FOOTER^TIUPRPN2(.TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,$G(TIUROOT)) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN8.m
r613 r623 1 TIUPRPN8 ;SLC/MAM - Print SF 509-Progress Notes, Cont ;11/10/04 [1/4/05 12:17pm] 2 ;;1.0;TEXT INTEGRATION UTILITIES;**100,176,157,182,224**;Jun 20, 1997;Build 7 3 ; 4 SIGBLK(TIUFOOT,TIUMISC,TIUCONT1,TIUCONT,TIUSIG,TIUROOT) ; Print signature block info 5 ; Requires array TIUFOOT, requires TIUMISC 6 ; Requires TIUCONT1 7 ; Receives TIUCONT by ref (req'd) 8 ; Receives array TIUSIG by ref, required. 9 ; Requires TIUROOT 10 N TIUDA,TIUFLAG 11 S TIUCONT=1,TIUDA=$P(TIUMISC,U,3),TIUFLAG=$P(TIUMISC,U) 12 ;S TIUGROOT=$NA(^TMP("TIULQ",$J,TIUDA)) 13 ; -- P182 Don't marked admin signed notes as draft: 14 I '+TIUSIG("SIGNDATE"),'+TIUSIG("ADMINCDT") D Q:'TIUCONT 15 . W "**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED--" 16 . W " DRAFT COPY - DRAFT COPY**",! 17 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) 18 ;I TIUSIG("SIGNEDBY")]"",(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D 19 ;. W ?21,"Author: ",$P(TIUSIG("AUTHOR"),";",2),! 20 I +TIUSIG("SIGNDATE") D Q:'TIUCONT 21 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 22 . W ?18,"Signed by:",$S($P(TIUSIG("SIGNMODE"),";")="C":" /s/ ",1:" /es/ "),?34,$S(TIUSIG("SIGNNAME")]"":TIUSIG("SIGNNAME"),1:$P(TIUSIG("SIGNEDBY"),";",2)) 23 . I $L(TIUSIG("SIGTITL"))>45 D 24 . . N TIUFT 25 . . D WRAP^TIUFLD(TIUSIG("SIGTITL"),45) 26 . . W !?34,$G(TIUFT(1)) 27 . . W !?39,$G(TIUFT(2)) 28 . I $L(TIUSIG("SIGTITL"))<46,TIUSIG("SIGTITL")]"" W !?34,TIUSIG("SIGTITL") 29 . W !?34,$$DATE^TIULS(+TIUSIG("SIGNDATE"),"MM/DD/CCYY HR:MIN") 30 . I '+$G(TIUFLAG)!($E(IOST)="C-") D 31 . . I $P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U) W !?34,"Analog Pager: ",$P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U) 32 . . I $P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U,2) W !?34,"Digital Pager: ",$P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U,2) 33 I $P(TIUSIG("SIGNMODE"),";")="C" D Q:'TIUCONT 34 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 35 . N TIUONCH 36 . S TIUONCH=$P(TIUSIG("SIGCHRT"),";",2) 37 . I TIUONCH']"" S TIUONCH=$P(TIUSIG("COSCHRT"),";",2) 38 . W !?2,"Marked signed on chart by:",?34,$G(TIUONCH) 39 ; -- If signer is not author, write "for the author": 40 ; P182 SIGNEDBY may =";" and follow null even when no signer: 41 ;I TIUSIG("SIGNEDBY")]"",(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D 42 I TIUSIG("SIGNEDBY")]"",(TIUSIG("SIGNEDBY")'=";"),(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D 43 . N TIUSIGTL 44 . W !?34,"for ",$P(TIUSIG("AUTHOR"),";",2) 45 . S TIUSIGTL=$$GET1^DIQ(200,$P(TIUSIG("AUTHOR"),";",1),20.3) 46 . I $D(TIUSIGTL) D 47 . . N TIUFT 48 . . D WRAP^TIUFLD(TIUSIGTL,45) 49 . . W !?34,$G(TIUFT(1)) 50 . . W !?39,$G(TIUFT(2)) 51 I $G(@TIUROOT@(.05,"E"))="UNCOSIGNED" D 52 . W !?34,"**REQUIRES COSIGNATURE**",! 53 ;I +$G(TIUADD) S TIUGROOT=$NA(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD)) 54 I +$D(@TIUROOT@("EXTRASGNR")) D Q:'TIUCONT ;**100** added the quit 55 . N TIUI S TIUI=0 56 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 57 . F S TIUI=$O(@TIUROOT@("EXTRASGNR",TIUI)) Q:'TIUI D 58 . . W !!?4,"Receipt Acknowledged By:" 59 . . ;VMP/ELR P224 ADDED code to print awaiting signature and expected additional signer name 60 . . I +$G(@TIUROOT@("EXTRASGNR",TIUI,"DATE"))'>0 D Q 61 . . . W !,?4,"* AWAITING SIGNATURE *",?30,$G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")) 62 . . I TIUI>1 S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 63 . . W !?29,"/es/ ",$G(@TIUROOT@("EXTRASGNR",TIUI,"NAME")) 64 . . I $L($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")))>45 D 65 . . . N TIUFT 66 . . . D WRAP^TIUFLD($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")),45) 67 . . . W !?34,$G(TIUFT(1)) 68 . . . W !?39,$G(TIUFT(2)) 69 . . I $L($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")))<46 W !?34,$G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")) 70 . . I $G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA")),$G(@TIUROOT@("EXTRASGNR",TIUI,"EXPIEN"))'=$G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA")) D 71 . . . W !?30,"for ",$P($G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")),",",2) 72 . . . W " ",$P($G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")),",") 73 . . W !?34,$$DATE^TIULS($G(@TIUROOT@("EXTRASGNR",TIUI,"DATE")),"MM/DD/CCYY HR:MIN") 74 . . I '+$G(TIUFLAG)!($E(IOST)="C-") D 75 . . . N BEEP 76 . . . S BEEP=$$BEEP^TIULC1(+$G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA"))) 77 . . . I +BEEP W !?34,"Analog Pager: ",$P(BEEP,U) 78 . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2) 79 . ;K @TIUROOT@("EXTRASGNR") ;**100** commented out 80 ;I +TIUSIG("COSGDATE"),(+TIUSIG("COSGEDBY")'=+TIUSIG("SIGNEDBY")) D Q:'TIUCONT 81 I +TIUSIG("COSGDATE") D Q:'TIUCONT 82 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 83 . W !!?16,"Cosigned by:",$S($P(TIUSIG("COSGMODE"),";")="C":" /s/ ",1:" /es/ "),?34,$S(TIUSIG("COSGNAME")]"":TIUSIG("COSGNAME"),1:$P(TIUSIG("COSGEDBY"),";",2)) 84 . I $L(TIUSIG("COSGTITL"))>45 D 85 . . N TIUFT 86 . . D WRAP^TIUFLD(TIUSIG("COSGTITL"),45) 87 . . W !?34,$G(TIUFT(1)) 88 . . W !?39,$G(TIUFT(2)) 89 . I $L(TIUSIG("COSGTITL"))<46 W !?34,TIUSIG("COSGTITL") 90 . W !?34,$$DATE^TIULS(+TIUSIG("COSGDATE"),"MM/DD/CCYY HR:MIN") 91 . I '+$G(TIUFLAG)!($E(IOST)="C-") D 92 . . I $P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U) W !?34,"Analog Pager: ",$P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U) 93 . . I $P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U,2) W !?34,"Digital Pager: ",$P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U,2) 94 ;I +TIUSIG("COSCHRT"),$P(TIUSIG("COSGMODE"),";")="C" D Q:'TIUCONT 95 I $P(TIUSIG("COSGMODE"),";")="C" D Q:'TIUCONT 96 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 97 . W !,"Marked cosigned on chart by:",?34,$P(TIUSIG("COSCHRT"),";",2) 98 W ! 99 ;K TIUCONT1 ; kills the cont on next page msgs since no longer in middle 100 ;of a note. **100** moved down to amend code 101 AMEND ; signature blocks of amender 102 ;N TIUY S TIUY=4 ;I don't think we need TIUY anymore **100** 103 I '$G(@TIUROOT@(1601,"I")) K TIUCONT1 Q 104 S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) 105 K TIUCONT1 Q:'TIUCONT 106 I +$G(@TIUROOT@(1601,"I")) D 107 . W !!?12,"Amendment Filed:",?34,$$DATE^TIULS(@TIUROOT@(1601,"I"),"MM/DD/CCYY HR:MIN") 108 . I $G(@TIUROOT@(1603,"E"))']"" D 109 . . W !!?29 F TIUI=1:1:40 W "_" 110 . . W !?29,$$SIGNAME^TIULS(@TIUROOT@(1602,"I")) 111 . . W !?29,$$SIGTITL^TIULS(@TIUROOT@(1602,"I")) 112 . I $G(@TIUROOT@(1604,"E"))]"" D 113 . . W !?29,"/es/",?34,@TIUROOT@(1604,"E") 114 . . W !?34,@TIUROOT@(1605,"E") 115 Q 116 ; 1 TIUPRPN8 ;SLC/MAM - Print SF 509-Progress Notes, Cont ;11/10/04 [1/4/05 12:17pm] 2 ;;1.0;TEXT INTEGRATION UTILITIES;**100,176,157,182**;Jun 20, 1997 3 ; 4 SIGBLK(TIUFOOT,TIUMISC,TIUCONT1,TIUCONT,TIUSIG,TIUROOT) ; Print signature block info 5 ; Requires array TIUFOOT, requires TIUMISC 6 ; Requires TIUCONT1 7 ; Receives TIUCONT by ref (req'd) 8 ; Receives array TIUSIG by ref, required. 9 ; Requires TIUROOT 10 N TIUDA,TIUFLAG 11 S TIUCONT=1,TIUDA=$P(TIUMISC,U,3),TIUFLAG=$P(TIUMISC,U) 12 ;S TIUGROOT=$NA(^TMP("TIULQ",$J,TIUDA)) 13 ; -- P182 Don't marked admin signed notes as draft: 14 I '+TIUSIG("SIGNDATE"),'+TIUSIG("ADMINCDT") D Q:'TIUCONT 15 . W "**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED--" 16 . W " DRAFT COPY - DRAFT COPY**",! 17 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) 18 ;I TIUSIG("SIGNEDBY")]"",(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D 19 ;. W ?21,"Author: ",$P(TIUSIG("AUTHOR"),";",2),! 20 I +TIUSIG("SIGNDATE") D Q:'TIUCONT 21 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 22 . W ?18,"Signed by:",$S($P(TIUSIG("SIGNMODE"),";")="C":" /s/ ",1:" /es/ "),?34,$S(TIUSIG("SIGNNAME")]"":TIUSIG("SIGNNAME"),1:$P(TIUSIG("SIGNEDBY"),";",2)) 23 . I $L(TIUSIG("SIGTITL"))>45 D 24 . . N TIUFT 25 . . D WRAP^TIUFLD(TIUSIG("SIGTITL"),45) 26 . . W !?34,$G(TIUFT(1)) 27 . . W !?39,$G(TIUFT(2)) 28 . I $L(TIUSIG("SIGTITL"))<46,TIUSIG("SIGTITL")]"" W !?34,TIUSIG("SIGTITL") 29 . W !?34,$$DATE^TIULS(+TIUSIG("SIGNDATE"),"MM/DD/CCYY HR:MIN") 30 . I '+$G(TIUFLAG)!($E(IOST)="C-") D 31 . . I $P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U) W !?34,"Analog Pager: ",$P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U) 32 . . I $P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U,2) W !?34,"Digital Pager: ",$P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U,2) 33 I $P(TIUSIG("SIGNMODE"),";")="C" D Q:'TIUCONT 34 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 35 . N TIUONCH 36 . S TIUONCH=$P(TIUSIG("SIGCHRT"),";",2) 37 . I TIUONCH']"" S TIUONCH=$P(TIUSIG("COSCHRT"),";",2) 38 . W !?2,"Marked signed on chart by:",?34,$G(TIUONCH) 39 ; -- If signer is not author, write "for the author": 40 ; P182 SIGNEDBY may =";" and follow null even when no signer: 41 ;I TIUSIG("SIGNEDBY")]"",(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D 42 I TIUSIG("SIGNEDBY")]"",(TIUSIG("SIGNEDBY")'=";"),(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D 43 . N TIUSIGTL 44 . W !?34,"for ",$P(TIUSIG("AUTHOR"),";",2) 45 . S TIUSIGTL=$$GET1^DIQ(200,$P(TIUSIG("AUTHOR"),";",1),20.3) 46 . I $D(TIUSIGTL) D 47 . . N TIUFT 48 . . D WRAP^TIUFLD(TIUSIGTL,45) 49 . . W !?34,$G(TIUFT(1)) 50 . . W !?39,$G(TIUFT(2)) 51 I $G(@TIUROOT@(.05,"E"))="UNCOSIGNED" D 52 . W !?34,"**REQUIRES COSIGNATURE**",! 53 ;I +$G(TIUADD) S TIUGROOT=$NA(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD)) 54 I +$D(@TIUROOT@("EXTRASGNR")) D Q:'TIUCONT ;**100** added the quit 55 . N TIUI S TIUI=0 56 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 57 . W !?4,"Receipt Acknowledged By:" 58 . F S TIUI=$O(@TIUROOT@("EXTRASGNR",TIUI)) Q:'TIUI D 59 . . I +$G(@TIUROOT@("EXTRASGNR",TIUI,"DATE"))'>0 Q 60 . . I TIUI>1 S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 61 . . W !?29,"/es/ ",$G(@TIUROOT@("EXTRASGNR",TIUI,"NAME")) 62 . . I $L($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")))>45 D 63 . . . N TIUFT 64 . . . D WRAP^TIUFLD($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")),45) 65 . . . W !?34,$G(TIUFT(1)) 66 . . . W !?39,$G(TIUFT(2)) 67 . . I $L($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")))<46 W !?34,$G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")) 68 . . I $G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA")),$G(@TIUROOT@("EXTRASGNR",TIUI,"EXPIEN"))'=$G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA")) D 69 . . . W !?30,"for ",$P($G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")),",",2) 70 . . . W " ",$P($G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")),",") 71 . . W !?34,$$DATE^TIULS($G(@TIUROOT@("EXTRASGNR",TIUI,"DATE")),"MM/DD/CCYY HR:MIN") 72 . . I '+$G(TIUFLAG)!($E(IOST)="C-") D 73 . . . N BEEP 74 . . . S BEEP=$$BEEP^TIULC1(+$G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA"))) 75 . . . I +BEEP W !?34,"Analog Pager: ",$P(BEEP,U) 76 . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2) 77 . ;K @TIUROOT@("EXTRASGNR") ;**100** commented out 78 ;I +TIUSIG("COSGDATE"),(+TIUSIG("COSGEDBY")'=+TIUSIG("SIGNEDBY")) D Q:'TIUCONT 79 I +TIUSIG("COSGDATE") D Q:'TIUCONT 80 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 81 . W !!?16,"Cosigned by:",$S($P(TIUSIG("COSGMODE"),";")="C":" /s/ ",1:" /es/ "),?34,$S(TIUSIG("COSGNAME")]"":TIUSIG("COSGNAME"),1:$P(TIUSIG("COSGEDBY"),";",2)) 82 . I $L(TIUSIG("COSGTITL"))>45 D 83 . . N TIUFT 84 . . D WRAP^TIUFLD(TIUSIG("COSGTITL"),45) 85 . . W !?34,$G(TIUFT(1)) 86 . . W !?39,$G(TIUFT(2)) 87 . I $L(TIUSIG("COSGTITL"))<46 W !?34,TIUSIG("COSGTITL") 88 . W !?34,$$DATE^TIULS(+TIUSIG("COSGDATE"),"MM/DD/CCYY HR:MIN") 89 . I '+$G(TIUFLAG)!($E(IOST)="C-") D 90 . . I $P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U) W !?34,"Analog Pager: ",$P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U) 91 . . I $P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U,2) W !?34,"Digital Pager: ",$P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U,2) 92 ;I +TIUSIG("COSCHRT"),$P(TIUSIG("COSGMODE"),";")="C" D Q:'TIUCONT 93 I $P(TIUSIG("COSGMODE"),";")="C" D Q:'TIUCONT 94 . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT 95 . W !,"Marked cosigned on chart by:",?34,$P(TIUSIG("COSCHRT"),";",2) 96 W ! 97 ;K TIUCONT1 ; kills the cont on next page msgs since no longer in middle 98 ;of a note. **100** moved down to amend code 99 AMEND ; signature blocks of amender 100 ;N TIUY S TIUY=4 ;I don't think we need TIUY anymore **100** 101 I '$G(@TIUROOT@(1601,"I")) K TIUCONT1 Q 102 S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) 103 K TIUCONT1 Q:'TIUCONT 104 I +$G(@TIUROOT@(1601,"I")) D 105 . W !!?12,"Amendment Filed:",?34,$$DATE^TIULS(@TIUROOT@(1601,"I"),"MM/DD/CCYY HR:MIN") 106 . I $G(@TIUROOT@(1603,"E"))']"" D 107 . . W !!?29 F TIUI=1:1:40 W "_" 108 . . W !?29,$$SIGNAME^TIULS(@TIUROOT@(1602,"I")) 109 . . W !?29,$$SIGTITL^TIULS(@TIUROOT@(1602,"I")) 110 . I $G(@TIUROOT@(1604,"E"))]"" D 111 . . W !?29,"/es/",?34,@TIUROOT@(1604,"E") 112 . . W !?34,@TIUROOT@(1605,"E") 113 Q 114 ; -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m
r613 r623 1 TIUR ; SLC/JER - Integrated Document Review ;11/01/03 2 ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,112,207,224**;Jun 20, 1997;Build 7 3 ; 11/30/00 Moved PUTLIST & ADDELMNT to TIUR1 4 MAKELIST(TIUCLASS,TIUCHVW) ; Get Search Criteria 5 N DIRUT,DTOUT,DUOUT,TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL 6 N TIUDPRMT,TIUPICT,TIUOUT,STATWORD,STATIFN,NOWFLAG,TIUSC207,TIU1DOC 7 K DIROUT 8 D INITRR^TIULRR(0) 9 ; TIURPN used in Order Entry 2.5, OR OE/RR MENU CLIN: 10 I +$G(ORVP),(+$G(TIUCHVW)'>0) D EN^TIURPN(TIUCLASS,+ORVP) Q 11 STATUS S STATUS=$$STAT 12 ;VMP/ELR changed status ck from <0 TO <1 to account for entering an * p224 13 I +STATUS<1 S VALMQUIT=1 Q 14 S TIUI=0 15 F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI!(+$G(TIUOUT)) D 16 . I $P($G(TIUSTAT(TIUI)),U,3)="" S TIUOUT=1 Q 17 . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0)) 18 . Q:'STATIFN 19 . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";" 20 I +$G(TIUOUT) S VALMQUIT=1 Q 21 S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3)) 22 I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D 23 . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)) 24 I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER") 25 S STATUS("WORDS")=STATWORD 26 DOCTYPE ; Select Document Type(s) 27 ; TIU207-If only 1 docytyp and have been to screen prompt then go back another level to avoid loop with next prompt. 28 I $G(TIUSC207)=1,$G(TIU1DOC)=1 D G STATUS 29 .S (TIUSC207,TIU1DOC)=0 30 S (TIUSC207,TIU1DOC)=0 31 N TIUDCL K TIUPICT 32 I $S(('$D(TIUQUIK)&'$D(ORVP)):1,($D(ORVP)&+$G(TIUCHVW)):1,1:0) D SELTYP^TIULA(TIUCLASS,.TIUTYP,"A","LAST","DOC",0,.TIUDCL,.TIUPICT) 33 S TIU1DOC=+$P($G(^TIU(8925.1,+TIUCLASS,10,0)),U,3) 34 ; SELTYP sets array ^TMP("TIUTYP",$J); 35 ; SELTYP used to set data into TIUTYP array 36 ; Now TIUTYP just ="^TMP("TIUTYP",$J)" 37 I $S($D(TIUQUIK):1,($D(ORVP)&'+$G(TIUCHVW)):1,1:0) D SELTYP^TIULA(TIUCLASS,.TIUTYP,"F","ALL","DOC",0) 38 I +$G(DIROUT) S VALMQUIT=1 Q 39 I +$G(@TIUTYP)'>0,'$D(TIUQUIK) G STATUS 40 SCREEN ; 41 S TIUSC207=1 42 N TIUNAME,TIUOVER 43 S TIUNAME=$P($G(^VA(200,+DUZ,0)),U) 44 I $D(TIUQUIK) D I 1 ; all my unsigned TIUQUIK=1 45 . I $G(TIUQUIK)=3 S SCREEN(1)="ALL^ANY" Q 46 . S SCREEN(1)="AAU^"_DUZ_U_TIUNAME 47 . S:$G(TIUQUIK)=1 SCREEN(2)="ASUP^"_DUZ 48 . S SCREEN="ALL" 49 E I $D(ORVP),'+$G(TIUCHVW) S SCREEN(1)="APT^"_+ORVP_U_$P($G(^DPT(+ORVP,0)),U) I 1 50 S TIUOVER="" 51 E D SELCAT^TIULA1(.SCREEN,"A","AUTHOR",.TIUOVER) 52 I +$G(DIROUT) S VALMQUIT=1 Q 53 I $D(SCREEN)'>9 K @TIUTYP G DOCTYPE 54 I $D(@TIUTYP)'>9 W !,$C(7),"You must select one or more TITLES..." G SCREEN 55 I $G(SCREEN(1))="ALL^ANY",+$G(ORVP) S SCREEN(1)="APT^"_+$G(ORVP)_U_$P($G(^DPT(+$G(ORVP),0)),U) 56 D CHECKADD 57 ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") 58 S TIUDPRMT=$S(TIUCLASS=244:"Discharge",1:"Reference") 59 S TIUEDT=$S($D(TIUQUIK):1,$D(ORVP)&(+$G(TIUCHVW)'>0):$$FMADD^XLFDT(DT,$S($D(^DPT(+$G(ORVP),.1))'>0:-180,1:-30)),1:$P($$EDATE^TIULA(TIUDPRMT,"",TIUEDFLT),U)) 60 I +$G(DIROUT) S VALMQUIT=1 Q 61 I TIUEDT'>0 G SCREEN 62 S TIULDT=$S($D(TIUQUIK):9999999,$D(ORVP)&(+$G(TIUCHVW)'>0):+$$NOW^XLFDT,1:$P($$LDATE^TIULA(TIUDPRMT),U)) 63 I +$G(DIROUT) S VALMQUIT=1 Q 64 I TIULDT'>0 G ERLY 65 I TIUEDT>TIULDT D SWAP(.TIUEDT,.TIULDT) 66 I $L(TIULDT,".")=1 D EXPRANGE(.TIUEDT,.TIULDT) 67 ; -- Reset late date to NOW on rebuild: 68 S NOWFLAG=$S(TIULDT-$$NOW^XLFDT<.0001:1,1:0) 69 I '$G(TIURBLD) W !,"Searching for the documents." 70 D BUILD(TIUCLASS,.STATUS,.SCREEN,TIUEDT,TIULDT,NOWFLAG) ;11/30/00 removed param TIUTYP since BUILD uses global now. 71 ; -- If attaching ID note & changed view, 72 ; update video for line to be attached: -- 73 I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK) 74 ;K @TIUTYP ;11/30/00 keep ^TMP("TIUTYP",$J) for rebuild 75 Q 76 STAT() ; Determine status 77 N TIUY 78 I +$G(TIUQUIK) D G STATX 79 . S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"F",$S(TIUQUIK=1:"UNSIGNED,UNCOSIGNED",TIUQUIK>1:"UNDICTATED,UNTRANSCRIBED")) 80 I $D(ORVP),'+$G(TIUCHVW) D G STATX 81 . S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"F","COMPLETED") 82 S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT^TIURM(DUZ)) 83 STATX Q TIUY 84 CHECKADD ; Checks whether Addendum is included in the list of types 85 N TIUI,HIT,NUMTYPS 86 S (TIUI,HIT)=0 87 F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(^TMP("TIUTYP",$J,TIUI))["ADDENDUM" S HIT=1 88 S NUMTYPS=^TMP("TIUTYP",$J) 89 I +HIT'>0 S ^TMP("TIUTYP",$J,NUMTYPS+1)=+^TMP("TIUTYP",$J,NUMTYPS)+1_U_"81^Addendum^NOT PICKED",^TMP("TIUTYP",$J)=^TMP("TIUTYP",$J)+1 90 Q 91 ; 92 SWAP(TIUX,TIUY) ; Swap variables 93 N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP 94 Q 95 EXPRANGE(TIUX,TIUY) ; Expand late date to include time 96 ;P74 If user entered date/time = T, then numerical date time is FIRST ^ PIECE ONLY of TIUX & TIUY. 97 I $P(TIUY,U)=DT S TIUY=$$NOW^XLFDT I 1 98 E S TIUY=$P(TIUY,U)_"."_235959 ;P74 Add seconds 99 Q 100 BUILD(TIUCLASS,STATUS,SCREEN,EARLY,LATE,NOWFLAG) ; Build List. 101 ;11/30/00 - removed param TYPES. 12/3 added param TIUCLASS 102 ; BUILD (GATHER) uses docmt type info from ^TMP("TIUTYP",$J) 103 N TIUDT,TIUI,TIUK 104 N TIUT,TIUTP,XREF,TIUS,TIUPREF 105 S TIUPREF=$$PERSPRF^TIULE(DUZ),(TIUK,VALMCNT)=0 106 K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J) 107 ; If user entered NOW at first build, update NOW for rebuild; 108 ; Save data in ^TMP("TIURIDX",$J,0) for rebuild: 109 I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT 110 S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG 111 S ^TMP("TIUR",$J,"RTN")="TIUR" 112 S ^TMP("TIUR",$J,"TITLE OVERRIDE")=$G(TIUOVER) 113 I '$D(TIUPRM0) D SETPARM^TIULE 114 S EARLY=9999999-+$G(EARLY),LATE=9999999-$S(+$G(LATE):+$G(LATE),1:3333333) 115 F S TIUK=$O(SCREEN(TIUK)) Q:TIUK'>0 D 116 . I $G(SCREEN)'="ALL" S SCREEN=$G(TIUK) 117 . S XREF=$P(SCREEN(TIUK),U) 118 . I XREF'="ASUB" D 119 . . S TIUI=$S(XREF'="APRB":$P(SCREEN(TIUK),U,2),1:$$UPPER^TIULS($P(SCREEN(TIUK),U,3))) 120 . . D GATHER^TIUR1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF,SCREEN) 121 . I XREF="ASUB" D 122 . . S TIUI=$O(^TIU(8925,XREF,$P(SCREEN(TIUK),U,2)),-1) 123 . . F S TIUI=$O(^TIU(8925,XREF,TIUI)) Q:TIUI=""!(TIUI'[$P(SCREEN(TIUK),U,2)) D GATHER^TIUR1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF,SCREEN) 124 D PUTLIST^TIUR2(TIUPREF,TIUCLASS,.STATUS,.SCREEN) 125 K ^TMP("TIUI",$J) 126 Q 127 ; 128 CLEAN ; Clean up your mess! 129 K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10,KILLRR^TIULRR 130 K VALMY 131 K ^TMP("TIUTYP",$J) 132 Q 133 ; 134 RBLD ; Rebuild list after actions 11/30/00 135 N TIUEXP,TIUR0,TIURIDX0,TIUSCRN,TMP,TIUEDT,TIULDT,TIUSTAT 136 N TIURBLD,TIUI,TIUCLASS,NOWFLAG 137 S TIURBLD=1 138 D FIXLSTNW^TIULM ;restore video for elements added to end of list 139 I +$O(^TMP("TIUR",$J,"EXPAND",0)) D 140 . M TIUEXP=^TMP("TIUR",$J,"EXPAND") 141 S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0) 142 S TIUSCRN=$P(TIUR0,U,3,99),TIUCLASS=^TMP("TIUR",$J,"CLASS") 143 S TIUI=1 144 F S TMP=$P(TIUSCRN,";",TIUI) Q:TMP="" D 145 . S TIUSCRN(TIUI)=TMP,TIUI=TIUI+1 146 S TIUSCRN=$L(TIUSCRN,";") 147 S STATUS("WORDS")=$P(TIUR0,U,2) 148 S STATUS("IFNS")=$P(TIURIDX0,U,3) 149 S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4) 150 ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224 151 S TIUSCRN="ALL" 152 D BUILD(TIUCLASS,.STATUS,.TIUSCRN,TIUEDT,TIULDT,NOWFLAG) 153 ; Reexpand previously expanded items: 154 D RELOAD^TIUROR1(.TIUEXP) 155 D BREATHE^TIUROR1(1) 156 Q 1 TIUR ; SLC/JER - Integrated Document Review ;11/01/03 2 ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,112,207**;Jun 20, 1997 3 ; 11/30/00 Moved PUTLIST & ADDELMNT to TIUR1 4 MAKELIST(TIUCLASS,TIUCHVW) ; Get Search Criteria 5 N DIRUT,DTOUT,DUOUT,TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL 6 N TIUDPRMT,TIUPICT,TIUOUT,STATWORD,STATIFN,NOWFLAG,TIUSC207,TIU1DOC 7 K DIROUT 8 D INITRR^TIULRR(0) 9 ; TIURPN used in Order Entry 2.5, OR OE/RR MENU CLIN: 10 I +$G(ORVP),(+$G(TIUCHVW)'>0) D EN^TIURPN(TIUCLASS,+ORVP) Q 11 STATUS S STATUS=$$STAT 12 I +STATUS<0 S VALMQUIT=1 Q 13 S TIUI=0 14 F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI!(+$G(TIUOUT)) D 15 . I $P($G(TIUSTAT(TIUI)),U,3)="" S TIUOUT=1 Q 16 . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0)) 17 . Q:'STATIFN 18 . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";" 19 I +$G(TIUOUT) S VALMQUIT=1 Q 20 S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3)) 21 I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D 22 . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)) 23 I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER") 24 S STATUS("WORDS")=STATWORD 25 DOCTYPE ; Select Document Type(s) 26 ; TIU207-If only 1 docytyp and have been to screen prompt then go back another level to avoid loop with next prompt. 27 I $G(TIUSC207)=1,$G(TIU1DOC)=1 D G STATUS 28 .S (TIUSC207,TIU1DOC)=0 29 S (TIUSC207,TIU1DOC)=0 30 N TIUDCL K TIUPICT 31 I $S(('$D(TIUQUIK)&'$D(ORVP)):1,($D(ORVP)&+$G(TIUCHVW)):1,1:0) D SELTYP^TIULA(TIUCLASS,.TIUTYP,"A","LAST","DOC",0,.TIUDCL,.TIUPICT) 32 S TIU1DOC=+$P($G(^TIU(8925.1,+TIUCLASS,10,0)),U,3) 33 ; SELTYP sets array ^TMP("TIUTYP",$J); 34 ; SELTYP used to set data into TIUTYP array 35 ; Now TIUTYP just ="^TMP("TIUTYP",$J)" 36 I $S($D(TIUQUIK):1,($D(ORVP)&'+$G(TIUCHVW)):1,1:0) D SELTYP^TIULA(TIUCLASS,.TIUTYP,"F","ALL","DOC",0) 37 I +$G(DIROUT) S VALMQUIT=1 Q 38 I +$G(@TIUTYP)'>0,'$D(TIUQUIK) G STATUS 39 SCREEN ; 40 S TIUSC207=1 41 N TIUNAME,TIUOVER 42 S TIUNAME=$P($G(^VA(200,+DUZ,0)),U) 43 I $D(TIUQUIK) D I 1 ; all my unsigned TIUQUIK=1 44 . I $G(TIUQUIK)=3 S SCREEN(1)="ALL^ANY" Q 45 . S SCREEN(1)="AAU^"_DUZ_U_TIUNAME 46 . S:$G(TIUQUIK)=1 SCREEN(2)="ASUP^"_DUZ 47 . S SCREEN="ALL" 48 E I $D(ORVP),'+$G(TIUCHVW) S SCREEN(1)="APT^"_+ORVP_U_$P($G(^DPT(+ORVP,0)),U) I 1 49 S TIUOVER="" 50 E D SELCAT^TIULA1(.SCREEN,"A","AUTHOR",.TIUOVER) 51 I +$G(DIROUT) S VALMQUIT=1 Q 52 I $D(SCREEN)'>9 K @TIUTYP G DOCTYPE 53 I $D(@TIUTYP)'>9 W !,$C(7),"You must select one or more TITLES..." G SCREEN 54 I $G(SCREEN(1))="ALL^ANY",+$G(ORVP) S SCREEN(1)="APT^"_+$G(ORVP)_U_$P($G(^DPT(+$G(ORVP),0)),U) 55 D CHECKADD 56 ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") 57 S TIUDPRMT=$S(TIUCLASS=244:"Discharge",1:"Reference") 58 S TIUEDT=$S($D(TIUQUIK):1,$D(ORVP)&(+$G(TIUCHVW)'>0):$$FMADD^XLFDT(DT,$S($D(^DPT(+$G(ORVP),.1))'>0:-180,1:-30)),1:$P($$EDATE^TIULA(TIUDPRMT,"",TIUEDFLT),U)) 59 I +$G(DIROUT) S VALMQUIT=1 Q 60 I TIUEDT'>0 G SCREEN 61 S TIULDT=$S($D(TIUQUIK):9999999,$D(ORVP)&(+$G(TIUCHVW)'>0):+$$NOW^XLFDT,1:$P($$LDATE^TIULA(TIUDPRMT),U)) 62 I +$G(DIROUT) S VALMQUIT=1 Q 63 I TIULDT'>0 G ERLY 64 I TIUEDT>TIULDT D SWAP(.TIUEDT,.TIULDT) 65 I $L(TIULDT,".")=1 D EXPRANGE(.TIUEDT,.TIULDT) 66 ; -- Reset late date to NOW on rebuild: 67 S NOWFLAG=$S(TIULDT-$$NOW^XLFDT<.0001:1,1:0) 68 I '$G(TIURBLD) W !,"Searching for the documents." 69 D BUILD(TIUCLASS,.STATUS,.SCREEN,TIUEDT,TIULDT,NOWFLAG) ;11/30/00 removed param TIUTYP since BUILD uses global now. 70 ; -- If attaching ID note & changed view, 71 ; update video for line to be attached: -- 72 I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK) 73 ;K @TIUTYP ;11/30/00 keep ^TMP("TIUTYP",$J) for rebuild 74 Q 75 STAT() ; Determine status 76 N TIUY 77 I +$G(TIUQUIK) D G STATX 78 . S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"F",$S(TIUQUIK=1:"UNSIGNED,UNCOSIGNED",TIUQUIK>1:"UNDICTATED,UNTRANSCRIBED")) 79 I $D(ORVP),'+$G(TIUCHVW) D G STATX 80 . S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"F","COMPLETED") 81 S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT^TIURM(DUZ)) 82 STATX Q TIUY 83 CHECKADD ; Checks whether Addendum is included in the list of types 84 N TIUI,HIT,NUMTYPS 85 S (TIUI,HIT)=0 86 F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(^TMP("TIUTYP",$J,TIUI))["ADDENDUM" S HIT=1 87 S NUMTYPS=^TMP("TIUTYP",$J) 88 I +HIT'>0 S ^TMP("TIUTYP",$J,NUMTYPS+1)=+^TMP("TIUTYP",$J,NUMTYPS)+1_U_"81^Addendum^NOT PICKED",^TMP("TIUTYP",$J)=^TMP("TIUTYP",$J)+1 89 Q 90 ; 91 SWAP(TIUX,TIUY) ; Swap variables 92 N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP 93 Q 94 EXPRANGE(TIUX,TIUY) ; Expand late date to include time 95 ;P74 If user entered date/time = T, then numerical date time is FIRST ^ PIECE ONLY of TIUX & TIUY. 96 I $P(TIUY,U)=DT S TIUY=$$NOW^XLFDT I 1 97 E S TIUY=$P(TIUY,U)_"."_235959 ;P74 Add seconds 98 Q 99 BUILD(TIUCLASS,STATUS,SCREEN,EARLY,LATE,NOWFLAG) ; Build List. 100 ;11/30/00 - removed param TYPES. 12/3 added param TIUCLASS 101 ; BUILD (GATHER) uses docmt type info from ^TMP("TIUTYP",$J) 102 N TIUDT,TIUI,TIUK 103 N TIUT,TIUTP,XREF,TIUS,TIUPREF 104 S TIUPREF=$$PERSPRF^TIULE(DUZ),(TIUK,VALMCNT)=0 105 K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J) 106 ; If user entered NOW at first build, update NOW for rebuild; 107 ; Save data in ^TMP("TIURIDX",$J,0) for rebuild: 108 I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT 109 S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG 110 S ^TMP("TIUR",$J,"RTN")="TIUR" 111 S ^TMP("TIUR",$J,"TITLE OVERRIDE")=$G(TIUOVER) 112 I '$D(TIUPRM0) D SETPARM^TIULE 113 S EARLY=9999999-+$G(EARLY),LATE=9999999-$S(+$G(LATE):+$G(LATE),1:3333333) 114 F S TIUK=$O(SCREEN(TIUK)) Q:TIUK'>0 D 115 . I $G(SCREEN)'="ALL" S SCREEN=$G(TIUK) 116 . S XREF=$P(SCREEN(TIUK),U) 117 . I XREF'="ASUB" D 118 . . S TIUI=$S(XREF'="APRB":$P(SCREEN(TIUK),U,2),1:$$UPPER^TIULS($P(SCREEN(TIUK),U,3))) 119 . . D GATHER^TIUR1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF,SCREEN) 120 . I XREF="ASUB" D 121 . . S TIUI=$O(^TIU(8925,XREF,$P(SCREEN(TIUK),U,2)),-1) 122 . . F S TIUI=$O(^TIU(8925,XREF,TIUI)) Q:TIUI=""!(TIUI'[$P(SCREEN(TIUK),U,2)) D GATHER^TIUR1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF,SCREEN) 123 D PUTLIST^TIUR2(TIUPREF,TIUCLASS,.STATUS,.SCREEN) 124 K ^TMP("TIUI",$J) 125 Q 126 ; 127 CLEAN ; Clean up your mess! 128 K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10,KILLRR^TIULRR 129 K VALMY 130 K ^TMP("TIUTYP",$J) 131 Q 132 ; 133 RBLD ; Rebuild list after actions 11/30/00 134 N TIUEXP,TIUR0,TIURIDX0,TIUSCRN,TMP,TIUEDT,TIULDT,TIUSTAT 135 N TIURBLD,TIUI,TIUCLASS,NOWFLAG 136 S TIURBLD=1 137 D FIXLSTNW^TIULM ;restore video for elements added to end of list 138 I +$O(^TMP("TIUR",$J,"EXPAND",0)) D 139 . M TIUEXP=^TMP("TIUR",$J,"EXPAND") 140 S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0) 141 S TIUSCRN=$P(TIUR0,U,3,99),TIUCLASS=^TMP("TIUR",$J,"CLASS") 142 S TIUI=1 143 F S TMP=$P(TIUSCRN,";",TIUI) Q:TMP="" D 144 . S TIUSCRN(TIUI)=TMP,TIUI=TIUI+1 145 S TIUSCRN=$L(TIUSCRN,";") 146 S STATUS("WORDS")=$P(TIUR0,U,2) 147 S STATUS("IFNS")=$P(TIURIDX0,U,3) 148 S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4) 149 D BUILD(TIUCLASS,.STATUS,.TIUSCRN,TIUEDT,TIULDT,NOWFLAG) 150 ; Reexpand previously expanded items: 151 D RELOAD^TIUROR1(.TIUEXP) 152 D BREATHE^TIUROR1(1) 153 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURA3.m
r613 r623 1 TIURA3 ; 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 5 EDITCOS ; 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 32 EDITCOS1 ; 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 131 COS1X ; 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 1 TIURA3 ; SLC/JER - Review screen actions ; 11/7/06 2 ;;1.0;TEXT INTEGRATION UTILITIES;**220**;Jun 20, 1997;Build 4 3 ; Call to ISA^USRLM supported by DBIA 2324 4 EDITCOS ; Edit Expected Cosigner 5 ; Modeled after EDIT^TIURA 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 32 EDITCOS1 ; Edit expected cosigner/attending for single record 33 ; Receives TIUDA 34 ; Modeled after Input template for document type 35 I '+$G(TIUDA) W !,"No Documents selected." H 2 Q 36 ; Evaluate edit privilege 37 N NODE0,STATUS,OK2CHNG,CANTMSG,NODE12,REQCOSIG,PROBMSG 38 N ECSIGNER,ESIGNER,OKCLASS,TIUISDS,DA,DR,DIE,X 39 N ALTNODE0,ALTTIUDA,NESIGNR,NECSIGNR,ATTEND,NATTEND,CHKSUM 40 S NODE0=^TIU(8925,TIUDA,0),STATUS=$P(NODE0,U,5),(OK2CHNG,OKCLASS)=1 41 S ALTNODE0=NODE0,ALTTIUDA=TIUDA,NODE12=$G(^TIU(8925,TIUDA,12)) 42 I $$ISADDNDM^TIULC1(TIUDA) D 43 . S ALTTIUDA=$P(NODE0,U,6) 44 . S ALTNODE0=^TIU(8925,ALTTIUDA,0) 45 S TIUISDS=$$ISDS^TIULX(+ALTNODE0) 46 I '$$ISPN^TIULX(+ALTNODE0),'TIUISDS,'$$ISA^TIULX(+ALTNODE0,$$CLASS^TIUCNSLT()) S OKCLASS=0 47 I 'OKCLASS S PROBMSG="This action is valid only for Progress Notes, Discharge Summaries, and Consults." G COS1X 48 I STATUS>6 S PROBMSG="This document is already Complete!" G COS1X 49 I STATUS<5 S PROBMSG="This document still needs Release or Verification!" G COS1X 50 ; -- Status = 5 unsigned or 6 uncosigned. 51 ; Try rules for EDIT COSIGNER: 52 S OK2CHNG=$$CANDO^TIULP(TIUDA,"EDIT COSIGNER") 53 I 'OK2CHNG S CANTMSG=OK2CHNG G:STATUS=6 COS1X 54 ; -- If docmt is unsigned and EDIT COSIGNER rules failed, 55 ; try EDIT RECORD rules: 56 I STATUS=5,'OK2CHNG D G:'OK2CHNG COS1X 57 . S OK2CHNG=$$CANDO^TIULP(TIUDA,"EDIT RECORD") 58 . I 'OK2CHNG S CANTMSG="0^You are not authorized to edit this document." 59 ; -- DUZ may change Expected Cosigner/attending. 60 S DA=TIUDA,DIE=8925 61 ; -- If docmt is a Progress Note or Consult: 62 I 'TIUISDS D G COS1X 63 . ; -- Does Expected Signer Require Cosignature? 64 . S ESIGNER=$P(NODE12,U,4) 65 . S ECSIGNER=$P(NODE12,U,8) 66 . I ESIGNER']"" S PROBMSG="This document has no Expected Signer!" Q 67 . S REQCOSIG=$$REQCOSIG^TIULP(+NODE0,+TIUDA,ESIGNER) 68 . ; -- If cosig not required: 69 . I 'REQCOSIG D Q 70 . . ; -- If status is uncosigned, "see IRM" and quit: 71 . . I STATUS=6 S PROBMSG="Cosignature not required! See IRM." Q 72 . . ; -- If (status is unsigned) & has no exp cosgnr, say so and quit: 73 . . I ECSIGNER="" S PROBMSG="Cosignature not required." Q 74 . . ; -- If (status is unsigned), has exp cosgnr, fix it: 75 . . I ECSIGNER]"" D Q 76 . . . S PROBMSG="Cosignature not required. Expected Cosigner deleted." 77 . . . S DR="1208///@;1506///@" D ^DIE 78 . ; --Cosig is required so get it or change it: 79 . W !!,"You may edit the Expected Cosigner:" 80 . S DR="1208R//;1506////1" D ^DIE 81 . S NECSIGNR=$P(^TIU(8925,TIUDA,12),U,8) 82 . I NECSIGNR'=ECSIGNER D Q 83 . . W !!,"Expected Cosigner edited." H 1 S TIUCHNG=1 84 ; -- Docmt is a Discharge Summary: 85 S ATTEND=$P($G(^TIU(8925,TIUDA,12)),U,9) 86 W !!,"You may edit the Attending Physician:" 87 S DR="1209R//" D ^DIE 88 S NATTEND=$P(^TIU(8925,TIUDA,12),U,9) 89 I STATUS=6,NATTEND=$P(NODE12,U,2) D G COS1X 90 . S PROBMSG="You may not change the Attending of a signed" 91 . S PROBMSG=PROBMSG_" summary to the author." 92 . S DR="1209////^S X=ATTEND" D ^DIE 93 S NESIGNR=$$WHOSIGNS^TIULC1(DA),NECSIGNR=$$WHOCOSIG^TIULC1(DA) 94 S DR="1204////^S X=NESIGNR" 95 S DR=DR_";1208////^S X=NECSIGNR" 96 S DR=DR_";1506////^S X=$S(+NESIGNR=+NATTEND:0,1:1)" 97 D ^DIE 98 I NATTEND'=ATTEND D 99 . W !!,"Attending Physician edited" H 1 S TIUCHNG=1 100 COS1X ; 101 I $G(TIUCHNG),$G(STATUS)=6 D ; Audit uncosigned docmts only 102 . S CHKSUM=+$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")") 103 . D AUDIT^TIUEDI1(TIUDA,CHKSUM,CHKSUM) 104 I $D(PROBMSG) W !!,PROBMSG 105 I 'OK2CHNG W !!,$P(CANTMSG,U,2) 106 I $D(PROBMSG)!'OK2CHNG I $$READ^TIUU("EA","RETURN to continue...") 107 D SEND^TIUALRT(TIUDA) 108 Q 109 ; -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURB.m
r613 r623 1 TIURB ; SLC/JER - More Review Screen Actions ;12/11/07 2 ;;1.0;TEXT INTEGRATION UTILITIES;**4,32,52,78,58,100,109,155,184,234**;Jun 20, 1997;Build 6 3 ; DBIA 3473 TIU use of GMRCTIU 4 AMEND ; Amendment action 5 N TIUDA,DFN,DIE,DR,TIU,TIUDATA,TIUI,TIUSIG,TIUY,X,X1,Y 6 N DIROUT,TIUCHNG,TIUDAARY,TIULST 7 I '$D(VALMY) D EN^VALM2(XQORNOD(0)) 8 S TIUI=0 9 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) 10 . N RSTRCTD 11 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) 12 . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) 13 . I RSTRCTD D Q 14 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message 15 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause 16 . W !!,"Amending #",+TIUDATA 17 . S TIUCHNG=0 18 . D AMEND1 19 . I $G(TIUDAARY(TIUI)) D 20 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI 21 ; -- Update or Rebuild list, restore video: 22 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY 23 S VALMBCK="R" 24 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"amended") 25 Q 26 AMEND1 ; Single record amend 27 N TIUCMT,TIUT0,TIUTYP,TIUAMND,TIUSNM,TIUSBLK,TIUCSNM,TIUCSBLK,DIE,DR 28 N DA,DFN,DIWESUB,TIU,TIUODA,TIUTITL,TIUCLSS,TIUCON,TIUCNSLT,TIUPRF,TIUFLAG 29 K ^TMP("TIURTRCT",$J) 30 ; TIU*155 Gets consult data if exists 31 S TIUTITL=$P($G(^TIU(8925,TIUDA,0)),U) 32 S TIUCLSS=$$CLASS^TIUCNSLT() 33 S TIUCON=+$$ISA^TIULX(TIUTITL,TIUCLSS) 34 S TIUCNSLT=+$P($G(^TIU(8925,TIUDA,14)),U,5) 35 S TIUPRF=0,TIUFLAG=0 36 D ISPRFTTL^TIUPRF2(.TIUPRF,TIUTITL) 37 I TIUPRF S TIUFLAG=$$FNDACTIF^TIUPRFL(TIUDA) 38 L +^TIU(8925,+TIUDA):1 39 E D Q 40 . W !?5,$C(7),"Another user is editing this entry." H 3 41 . S TIUCHNG("REFRESH")=1 42 I +$P($G(^TIU(8925,+TIUDA,0)),U,5)'>6 D Q 43 . W !?5,$C(7),"Only SIGNED Documents may be amended." 44 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 45 . S TIUCHNG("REFRESH")=1 46 I '$$ISA^USRLM(+$G(DUZ),"PRIVACY ACT OFFICER"),'$$ISA^USRLM(+$G(DUZ),"CHIEF, MIS"),'$$ISA^USRLM(+$G(DUZ),"CHIEF, HIM") D Q 47 . W !?5,$C(7),"Only Privacy Act Officers or MIS/HIM Chiefs may amend documents." 48 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 49 . S TIUCHNG("REFRESH")=1 50 I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q 51 ;S TIUAMND=$$CANDO^TIULP(TIUDA,"AMENDMENT") 52 ;I +TIUAMND'>0 D Q 53 ;. W !!,$C(7),$C(7),$C(7),$P(TIUAMND,U,2),! 54 ;. S TIUCHNG("REFRESH")=1 55 ;. I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 56 W !!,"Before proceeding, please enter your Electronic Signature Code..." 57 S TIUAMND=$$GETSIG^TIURD2 58 I +TIUAMND'>0 D Q 59 . W !!," Ok, no harm done...",! 60 . S TIUCHNG("REFRESH")=1 61 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 62 W !!,"The ORIGINAL document will be RETRACTED, and a copy will be amended...",! 63 S TIUODA=TIUDA 64 S TIUDA=+$$RETRACT^TIURD2(TIUDA,"",7) 65 I '+TIUDA D Q 66 . W !!,$C(7),$C(7),$C(7),"Retraction of Original Document Failed.",! 67 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 68 . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 69 L +^TIU(8925,TIUDA):1 70 E D Q 71 . W !?5,$C(7),"Another user is editing this entry." 72 . D RECOVER^TIURD4(TIUODA,TIUDA) H 3 73 . S TIUPRF=$$LINK^TIUPRF1(TIUODA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUODA,0)),U,2)) 74 . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 75 S TIUSNM=$$DECRYPT^TIULC1($P(^TIU(8925,TIUDA,15),U,3),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) 76 S TIUSBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,TIUDA,15)),U,4),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) 77 S TIUCSNM=$$DECRYPT^TIULC1($P(^TIU(8925,TIUDA,15),U,9),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) 78 S TIUCSBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,TIUDA,15)),U,10),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) 79 S TIUTYP=+$G(^TIU(8925,+TIUDA,0)),TIUT0=$G(^TIU(8925.1,+TIUTYP,0)) 80 S TIUTYP(1)="1^"_+TIUTYP_U_$P(TIUT0,U,3)_U 81 S DFN=$P($G(^TIU(8925,+TIUDA,0)),U,2) 82 D GETTIU^TIULD(.TIU,TIUDA) 83 S DIWESUB="Patient: "_$G(TIU("PNM")) 84 S TIUCHNG=0 D FULL^VALM1,TEXTEDIT^TIUEDI4(TIUDA,.TIUCMT,.TIUCHNG) 85 I '+$G(TIUCHNG) D Q 86 . L -^TIU(8925,TIUDA) 87 . D RECOVER^TIURD4(TIUODA,TIUDA) 88 . S TIUPRF=$$LINK^TIUPRF1(TIUODA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUODA,0)),U,2)) 89 . L -^TIU(8925,TIUODA) H 3 90 . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 91 I +$G(TIUCHNG) D 92 . S DR=".05///AMENDED;1601////"_$$NOW^XLFDT_";1602////"_DUZ,DA=TIUDA,TIUSIG=0 93 . S DR=DR_";1603////"_$$NOW^XLFDT_";1604///^S X=$$SIGNAME^TIULS(DUZ);1605///^S X=$$SIGTITL^TIULS(DUZ)",TIUSIG=1 94 . S DIE=8925 D ^DIE 95 . ; Refile /es/-block fields 96 . S DR="1503///^S X=TIUSNM;1504///^S X=TIUSBLK;1509///^S X=TIUCSNM;1510///^S X=TIUCSBLK" 97 . D ^DIE 98 ; Drop Locks on both documents 99 L -^TIU(8925,+TIUDA) 100 L -^TIU(8925,+TIUODA) 101 S TIUDAARY(TIUI)=TIUDA 102 S TIUCHNG("RBLD")=1 103 ; if note is associated with a patient record flag - clean up 104 I +TIUFLAG S TIUPRF=$$LINK^TIUPRF1(TIUDA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUDA,0)),U,2)) 105 ; TIU*155 If note is associated with a consult update ^GMR global 106 ; to include the amended note 107 ; Rollback retracted note from ^GMR(123 node 50 108 I $G(TIUCON)=1 D 109 . N STATUS,GMRCSTAT,TIUAUTH 110 . S STATUS=$P($G(^TIU(8925,TIUDA,0)),U,5) 111 . S GMRCSTAT=$S(STATUS>6:"COMPLETED",1:"INCOMPLETE") 112 . S TIUAUTH=$P($G(^TIU(8925,TIUDA,12)),U,2) 113 . D ROLLBACK^TIUCNSLT(TIUODA) 114 . D GET^GMRCTIU(TIUCNSLT,TIUDA,GMRCSTAT,TIUAUTH) 115 Q 116 SENDBACK ; Send back a Document to transcription 117 N TIUDA,DFN,TIU,TIUDATA,TIUCHNG,TIUI,TIUY,Y,DIROUT,TIULST 118 N TIUDAARY 119 I '$D(VALMY) D EN^VALM2(XQORNOD(0)) 120 S TIUI=0 121 I +$O(VALMY(0)) D CLEAR^VALM1 122 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) 123 . N TIU,RSTRCTD 124 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) 125 . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) 126 . I RSTRCTD D Q 127 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message 128 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause 129 . S TIUDAARY(TIUI)=TIUDA 130 . S TIUCHNG=0 131 . D EN^VALM("TIU SEND BACK") 132 . I +$G(TIUCHNG) D 133 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI 134 SENDX ; Revise list and cycle back as appropriate 135 I $G(TIUCHNG("ADDM"))!$G(TIUCHNG("DELETE")) S TIUCHNG("RBLD")=1 136 E S TIUCHNG("UPDATE")=1 137 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY 138 S VALMBCK="R" 139 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"sent back") 140 Q 141 LINK ; Link to problem(s) 142 N TIUCHNG,TIUDA,DFN,TIU,TIUDATA,TIUEDIT,TIUI,TIUY,TIULST,Y,DIROUT 143 N TIUDAARY 144 I '$D(VALMY) D EN^VALM2(XQORNOD(0)) 145 S TIUI=0 146 I +$O(VALMY(0)) D CLEAR^VALM1 147 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) 148 . N TIU,VALMY,XQORM,VA,VADM,GMPDFN,GMPLUSER,RSTRCTD 149 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) 150 . S TIUDA=+$P(TIUDATA,U,2),GMPLUSER=1 151 . I '$D(^TIU(8925,+TIUDA,0)) D Q 152 . . W !,$C(7),"Document no longer exists.",! 153 . . I $$READ^TIUU("EA","Press RETURN to continue...") W "" 154 . S RSTRCTD=$$DOCRES^TIULRR(TIUDA) 155 . I RSTRCTD D Q 156 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message 157 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause 158 . S TIUDAARY(TIUI)=TIUDA 159 . S DFN=+$P($G(^TIU(8925,+TIUDA,0)),U,2) 160 . I +DFN D DEM^VADPT S GMPDFN=DFN_U_VADM(1)_U_$E(VADM(1))_VA("BID") 161 . S TIUCHNG=0 162 . D EN^VALM("TIU LINK TO PROBLEM") 163 . I +$G(TIUCHNG) S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI 164 LINKX ; Revise list and cycle back as appropriate 165 S TIUCHNG("REFRESH")=1 166 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY 167 S VALMBCK="R" 168 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"linked to problems") 169 Q 170 DEL(DA) ; -- Call to DEL for backward compatibility 171 G GODEL^TIURB2 172 Q 1 TIURB ; SLC/JER - More Review Screen Actions ;4/11/05 2 ;;1.0;TEXT INTEGRATION UTILITIES;**4,32,52,78,58,100,109,155,184**;Jun 20, 1997 3 ; **100** Moved DELETE, DEL, DELTEXT, DIK to new rtn TIURB2 4 ; DBIA 3576 TIU use of GMRCTIU 5 AMEND ; Amendment action 6 N TIUDA,DFN,DIE,DR,TIU,TIUDATA,TIUI,TIUSIG,TIUY,X,X1,Y 7 N DIROUT,TIUCHNG,TIUDAARY,TIULST 8 I '$D(VALMY) D EN^VALM2(XQORNOD(0)) 9 S TIUI=0 10 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) 11 . N RSTRCTD 12 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) 13 . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) 14 . I RSTRCTD D Q 15 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message 16 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause 17 . W !!,"Amending #",+TIUDATA 18 . S TIUCHNG=0 19 . D AMEND1 20 . I $G(TIUDAARY(TIUI)) D 21 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI 22 ; -- Update or Rebuild list, restore video: 23 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY 24 S VALMBCK="R" 25 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"amended") 26 Q 27 AMEND1 ; Single record amend 28 N TIUCMT,TIUT0,TIUTYP,TIUAMND,TIUSNM,TIUSBLK,TIUCSNM,TIUCSBLK,DIE,DR 29 N DA,DFN,DIWESUB,TIU,TIUODA,TIUTITL,TIUCLSS,TIUCON,TIUCNSLT,TIUPRF,TIUFLAG 30 K ^TMP("TIURTRCT",$J) 31 ; TIU*155 Gets consult data if exists 32 S TIUTITL=$P($G(^TIU(8925,TIUDA,0)),U) 33 S TIUCLSS=$$CLASS^TIUCNSLT() 34 S TIUCON=+$$ISA^TIULX(TIUTITL,TIUCLSS) 35 S TIUCNSLT=+$P($G(^TIU(8925,TIUDA,14)),U,5) 36 S TIUPRF=0,TIUFLAG=0 37 D ISPRFTTL^TIUPRF2(.TIUPRF,TIUTITL) 38 I TIUPRF S TIUFLAG=$$FNDACTIF^TIUPRFL(TIUDA) 39 L +^TIU(8925,+TIUDA):1 40 E D Q 41 . W !?5,$C(7),"Another user is editing this entry." H 3 42 . S TIUCHNG("REFRESH")=1 43 I +$P($G(^TIU(8925,+TIUDA,0)),U,5)'>6 D Q 44 . W !?5,$C(7),"Only SIGNED Documents may be amended." 45 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 46 . S TIUCHNG("REFRESH")=1 47 I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q 48 S TIUAMND=$$CANDO^TIULP(TIUDA,"AMENDMENT") 49 I +TIUAMND'>0 D Q 50 . W !!,$C(7),$C(7),$C(7),$P(TIUAMND,U,2),! 51 . S TIUCHNG("REFRESH")=1 52 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 53 W !!,"Before proceeding, please enter your Electronic Signature Code..." 54 S TIUAMND=$$GETSIG^TIURD2 55 I +TIUAMND'>0 D Q 56 . W !!," Ok, no harm done...",! 57 . S TIUCHNG("REFRESH")=1 58 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 59 W !!,"The ORIGINAL document will be RETRACTED, and a copy will be amended...",! 60 S TIUODA=TIUDA 61 S TIUDA=+$$RETRACT^TIURD2(TIUDA,"",7) 62 I '+TIUDA D Q 63 . W !!,$C(7),$C(7),$C(7),"Retraction of Original Document Failed.",! 64 . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause 65 . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 66 L +^TIU(8925,TIUDA):1 67 E D Q 68 . W !?5,$C(7),"Another user is editing this entry." 69 . D RECOVER^TIURD4(TIUODA,TIUDA) H 3 70 . S TIUPRF=$$LINK^TIUPRF1(TIUODA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUODA,0)),U,2)) 71 . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 72 S TIUSNM=$$DECRYPT^TIULC1($P(^TIU(8925,TIUDA,15),U,3),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) 73 S TIUSBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,TIUDA,15)),U,4),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) 74 S TIUCSNM=$$DECRYPT^TIULC1($P(^TIU(8925,TIUDA,15),U,9),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) 75 S TIUCSBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,TIUDA,15)),U,10),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) 76 S TIUTYP=+$G(^TIU(8925,+TIUDA,0)),TIUT0=$G(^TIU(8925.1,+TIUTYP,0)) 77 S TIUTYP(1)="1^"_+TIUTYP_U_$P(TIUT0,U,3)_U 78 S DFN=$P($G(^TIU(8925,+TIUDA,0)),U,2) 79 D GETTIU^TIULD(.TIU,TIUDA) 80 S DIWESUB="Patient: "_$G(TIU("PNM")) 81 S TIUCHNG=0 D FULL^VALM1,TEXTEDIT^TIUEDI4(TIUDA,.TIUCMT,.TIUCHNG) 82 I '+$G(TIUCHNG) D Q 83 . L -^TIU(8925,TIUDA) 84 . D RECOVER^TIURD4(TIUODA,TIUDA) 85 . S TIUPRF=$$LINK^TIUPRF1(TIUODA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUODA,0)),U,2)) 86 . L -^TIU(8925,TIUODA) H 3 87 . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 88 I +$G(TIUCHNG) D 89 . S DR=".05///AMENDED;1601////"_$$NOW^XLFDT_";1602////"_DUZ,DA=TIUDA,TIUSIG=0 90 . S DR=DR_";1603////"_$$NOW^XLFDT_";1604///^S X=$$SIGNAME^TIULS(DUZ);1605///^S X=$$SIGTITL^TIULS(DUZ)",TIUSIG=1 91 . S DIE=8925 D ^DIE 92 . ; Refile /es/-block fields 93 . S DR="1503///^S X=TIUSNM;1504///^S X=TIUSBLK;1509///^S X=TIUCSNM;1510///^S X=TIUCSBLK" 94 . D ^DIE 95 ; Drop Locks on both documents 96 L -^TIU(8925,+TIUDA) 97 L -^TIU(8925,+TIUODA) 98 S TIUDAARY(TIUI)=TIUDA 99 S TIUCHNG("RBLD")=1 100 ; if note is associated with a patient record flag - clean up 101 I +TIUFLAG S TIUPRF=$$LINK^TIUPRF1(TIUDA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUDA,0)),U,2)) 102 ; TIU*155 If note is associated with a consult update ^GMR global 103 ; to include the amended note 104 ; Rollback retracted note from ^GMR(123 node 50 105 I $G(TIUCON)=1 D 106 . N STATUS,GMRCSTAT,TIUAUTH 107 . S STATUS=$P($G(^TIU(8925,TIUDA,0)),U,5) 108 . S GMRCSTAT=$S(STATUS>6:"COMPLETED",1:"INCOMPLETE") 109 . S TIUAUTH=$P($G(^TIU(8925,TIUDA,12)),U,2) 110 . D ROLLBACK^TIUCNSLT(TIUODA) 111 . D GET^GMRCTIU(TIUCNSLT,TIUDA,GMRCSTAT,TIUAUTH) 112 Q 113 SENDBACK ; Send back a Document to transcription 114 N TIUDA,DFN,TIU,TIUDATA,TIUCHNG,TIUI,TIUY,Y,DIROUT,TIULST 115 N TIUDAARY 116 I '$D(VALMY) D EN^VALM2(XQORNOD(0)) 117 S TIUI=0 118 I +$O(VALMY(0)) D CLEAR^VALM1 119 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) 120 . N TIU,RSTRCTD 121 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) 122 . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) 123 . I RSTRCTD D Q 124 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message 125 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause 126 . S TIUDAARY(TIUI)=TIUDA 127 . S TIUCHNG=0 128 . D EN^VALM("TIU SEND BACK") 129 . I +$G(TIUCHNG) D 130 . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI 131 SENDX ; Revise list and cycle back as appropriate 132 I $G(TIUCHNG("ADDM"))!$G(TIUCHNG("DELETE")) S TIUCHNG("RBLD")=1 133 E S TIUCHNG("UPDATE")=1 134 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY 135 S VALMBCK="R" 136 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"sent back") 137 Q 138 LINK ; Link to problem(s) 139 N TIUCHNG,TIUDA,DFN,TIU,TIUDATA,TIUEDIT,TIUI,TIUY,TIULST,Y,DIROUT 140 N TIUDAARY 141 I '$D(VALMY) D EN^VALM2(XQORNOD(0)) 142 S TIUI=0 143 I +$O(VALMY(0)) D CLEAR^VALM1 144 F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) 145 . N TIU,VALMY,XQORM,VA,VADM,GMPDFN,GMPLUSER,RSTRCTD 146 . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) 147 . S TIUDA=+$P(TIUDATA,U,2),GMPLUSER=1 148 . I '$D(^TIU(8925,+TIUDA,0)) D Q 149 . . W !,$C(7),"Document no longer exists.",! 150 . . I $$READ^TIUU("EA","Press RETURN to continue...") W "" 151 . S RSTRCTD=$$DOCRES^TIULRR(TIUDA) 152 . I RSTRCTD D Q 153 . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message 154 . . I $$READ^TIUU("EA","RETURN to continue...") ; pause 155 . S TIUDAARY(TIUI)=TIUDA 156 . S DFN=+$P($G(^TIU(8925,+TIUDA,0)),U,2) 157 . I +DFN D DEM^VADPT S GMPDFN=DFN_U_VADM(1)_U_$E(VADM(1))_VA("BID") 158 . S TIUCHNG=0 159 . D EN^VALM("TIU LINK TO PROBLEM") 160 . I +$G(TIUCHNG) S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI 161 LINKX ; Revise list and cycle back as appropriate 162 S TIUCHNG("REFRESH")=1 163 D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY 164 S VALMBCK="R" 165 D VMSG^TIURS1($G(TIULST),.TIUDAARY,"linked to problems") 166 Q 167 DEL(DA) ; -- Call to DEL for backward compatibility 168 G GODEL^TIURB2 169 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m
r613 r623 1 TIURL ; SLC/JER - List Management Library ;2/21/01 2 ;;1.0;TEXT INTEGRATION UTILITIES;**88,100,224**;Jun 20, 1997;Build 7 3 ; 11/14/00 Moved UPDATEID, etc to TIURL1 4 ; 5 UPRBLD(TIUCHNG,ITEMS) ; Refreshes, updates, or rebuilds the list 6 ;after various actions. Also restores video. 7 ; Receives optional arrays TIUCHNG, ITEMS by ref. 8 ; Checks TIUCHNG("RBLD"),TIUCHNG("UPDATE"), & TIUCHNG("REFRESH"); 9 ;does nothing if none of these is defined. 10 ; Items in ITEMS list are updated (depending on TIUCHNG), and 11 ;their video attributes are restored. 12 N TIUI,TIUREC,TIUJ,RTN 13 S RTN=$G(^TMP("TIUR",$J,"RTN")) 14 ; -- Restore video attributes for selected items: 15 ; (Rebuild code, except for TIUROR, does its own video restore) 16 I '$G(TIUCHNG("RBLD"))!(RTN="TIUROR") D 17 . S TIUJ=0 18 . F S TIUJ=$O(ITEMS(TIUJ)) Q:'TIUJ D 19 . . Q:TIUJ=$P($G(TIUGLINK),U,2) ; Don't restore midattach ID child 20 . . D RESTORE^VALM10(TIUJ) 21 ; -- If TIUROR screen needs changes, it is always 22 ; rebuilt, not updated: 23 I RTN="TIUROR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1 24 ;VMP/ELR ADDED THE FOLLOWING 2 LINES IN PATCH 224 25 I RTN="TIUR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1 26 I RTN="TIURM",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1 27 ; -- Rebuild, Update, or Refresh list: 28 ; (In cases (e.g.browse) where more than one action 29 ; was performed, TIUCHNG("RBLD") may coexist w TIUCHNG("UPDATE"), 30 ; etc., so order is important.) 31 I $G(TIUCHNG("RBLD")) D Q 32 . W !,"Rebuilding the list..." 33 . I RTN="TIUROR" D RBLD^TIUROR Q 34 . ; -- If not in 2b, pause for feedback ("Rebuilding", 35 . ; "Entry deleted", etc): 36 . H 2 37 . I RTN="TIURM" D RBLD^TIURM Q 38 . I RTN="TIURPTTL" D RBLD^TIURPTTL Q 39 . I RTN="TIURTITL" D RBLD^TIURTITL Q 40 . I RTN="TIUR" D RBLD^TIUR 41 I $G(TIUCHNG("UPDATE")),$D(ITEMS) D Q 42 . S TIUI="" 43 . W !,"Updating the list..." 44 . F S TIUI=$O(ITEMS(TIUI)) Q:'TIUI D 45 . . D SETREC(TIUI,.TIUREC) 46 . . ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224 47 . . I $G(TIUREC)="" Q 48 . . S ^TMP("TIUR",$J,TIUI,0)=TIUREC 49 I $G(TIUCHNG("REFRESH")) D Q 50 . W !,"Refreshing the list..." 51 Q 52 ; 53 SETREC(LINENO,TIUREC,PFIXFLAG) ; Update line LINENO with [new prefix], new flds 54 ; Combined fields so that SETREC works for MIS as well as 55 ;CLINICIAN LM templates 56 ; PFIXFLAG=1: update prefix (as well as other flds). 57 ; New prefix is for unexpanded state of line. 58 N DIC,DIQ,DA,DR,TIUR,ADT,DDT,LCT,AUT,AMD,EDT,SDT,TIULST4 59 N MOM,DOC,MISEDT,ITEMNODE 60 S ITEMNODE=^TMP("TIURIDX",$J,LINENO) 61 S DA=+$P(ITEMNODE,U,2) 62 S DIQ="TIUR",DIC=8925,DIQ(0)="IE" 63 S DR=".01;.02;.05;.07;.08;.1;1202;1204;1208;1209;1301;1307;1501;1507" 64 D EN^DIQ1 Q:$D(TIUR)'>9 65 S DOC=$$PNAME^TIULC1(+TIUR(8925,DA,.01,"I")) 66 I DOC="Addendum" D 67 . S MOM=+$P(^TIU(8925,DA,0),U,6) 68 . S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,MOM,0))) 69 S TIULST4=$E($P($G(^DPT(TIUR(8925,DA,.02,"I"),0)),U,9),6,9) 70 S TIULST4="("_$E(TIUR(8925,DA,.02,"E"))_TIULST4_")" 71 S ADT=$$DATE^TIULS(TIUR(8925,DA,.07,"I"),"MM/DD/YY") 72 S DDT=$$DATE^TIULS(TIUR(8925,DA,.08,"I"),"MM/DD/YY") 73 S AMD=$$NAME^TIULS(TIUR(8925,DA,1208,"E"),"LAST, FI MI") 74 S AUT=$$NAME^TIULS(TIUR(8925,DA,1202,"E"),"LAST, FI MI") 75 S EDT=$$DATE^TIULS(TIUR(8925,DA,1301,"I"),"MM/DD/YY") 76 S MISEDT=$$DATE^TIULS(TIUR(8925,DA,1307,"I"),"MM/DD/YY") 77 S SDT=$S(+TIUR(8925,DA,1507,"I"):TIUR(8925,DA,1507,"I"),TIUR(8925,DA,.05,"I")'<7:+TIUR(8925,DA,1501,"I"),1:"") 78 S SDT=$$DATE^TIULS(SDT,"MM/DD/YY") 79 S LCT=$G(TIUR(8925,DA,.1,"E")) 80 ; -- Set prefix_patient/title into ^TMP("TIUR",$J,LINENO,0), 81 ; then into TIUREC: -- 82 I $G(PFIXFLAG) D SETPT^TIURL1(LINENO) 83 S TIUREC=^TMP("TIUR",$J,LINENO,0) 84 ; -- Set other fields into TIUREC: -- 85 S TIUREC=$$SETFLD^VALM1(LINENO,TIUREC,"NUMBER") 86 S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(TIUR(8925,DA,.05,"E")),TIUREC,"STATUS") 87 S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4") 88 S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE") 89 S:$D(VALMDDF("ADMISSION DATE")) TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE") 90 S:$D(VALMDDF("DISCH DATE")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"DISCH DATE") 91 S:$D(VALMDDF("DICT DATE")) TIUREC=$$SETFLD^VALM1(MISEDT,TIUREC,"DICT DATE") 92 S:$D(VALMDDF("LINE COUNT")) TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT") 93 S:$D(VALMDDF("REF DATE")) TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE") 94 S:$D(VALMDDF("SIG DATE")) TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE") 95 S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR") 96 S:$D(VALMDDF("COSIGNER")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER") 97 S:$D(VALMDDF("ATTENDING")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING") 98 S ^TMP("TIUR",$J,LINENO,0)=TIUREC 99 Q 1 TIURL ; SLC/JER - List Management Library ;2/21/01 2 ;;1.0;TEXT INTEGRATION UTILITIES;**88,100**;Jun 20, 1997 3 ; 11/14/00 Moved UPDATEID, etc to TIURL1 4 ; 5 UPRBLD(TIUCHNG,ITEMS) ; Refreshes, updates, or rebuilds the list 6 ;after various actions. Also restores video. 7 ; Receives optional arrays TIUCHNG, ITEMS by ref. 8 ; Checks TIUCHNG("RBLD"),TIUCHNG("UPDATE"), & TIUCHNG("REFRESH"); 9 ;does nothing if none of these is defined. 10 ; Items in ITEMS list are updated (depending on TIUCHNG), and 11 ;their video attributes are restored. 12 N TIUI,TIUREC,TIUJ,RTN 13 S RTN=$G(^TMP("TIUR",$J,"RTN")) 14 ; -- Restore video attributes for selected items: 15 ; (Rebuild code, except for TIUROR, does its own video restore) 16 I '$G(TIUCHNG("RBLD"))!(RTN="TIUROR") D 17 . S TIUJ=0 18 . F S TIUJ=$O(ITEMS(TIUJ)) Q:'TIUJ D 19 . . Q:TIUJ=$P($G(TIUGLINK),U,2) ; Don't restore midattach ID child 20 . . D RESTORE^VALM10(TIUJ) 21 ; -- If TIUROR screen needs changes, it is always 22 ; rebuilt, not updated: 23 I RTN="TIUROR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1 24 ; -- Rebuild, Update, or Refresh list: 25 ; (In cases (e.g.browse) where more than one action 26 ; was performed, TIUCHNG("RBLD") may coexist w TIUCHNG("UPDATE"), 27 ; etc., so order is important.) 28 I $G(TIUCHNG("RBLD")) D Q 29 . W !,"Rebuilding the list..." 30 . I RTN="TIUROR" D RBLD^TIUROR Q 31 . ; -- If not in 2b, pause for feedback ("Rebuilding", 32 . ; "Entry deleted", etc): 33 . H 2 34 . I RTN="TIURM" D RBLD^TIURM Q 35 . I RTN="TIURPTTL" D RBLD^TIURPTTL Q 36 . I RTN="TIURTITL" D RBLD^TIURTITL Q 37 . I RTN="TIUR" D RBLD^TIUR 38 I $G(TIUCHNG("UPDATE")),$D(ITEMS) D Q 39 . S TIUI="" 40 . W !,"Updating the list..." 41 . F S TIUI=$O(ITEMS(TIUI)) Q:'TIUI D 42 . . D SETREC(TIUI,.TIUREC) 43 . . S ^TMP("TIUR",$J,TIUI,0)=TIUREC 44 I $G(TIUCHNG("REFRESH")) D Q 45 . W !,"Refreshing the list..." 46 Q 47 ; 48 SETREC(LINENO,TIUREC,PFIXFLAG) ; Update line LINENO with [new prefix], new flds 49 ; Combined fields so that SETREC works for MIS as well as 50 ;CLINICIAN LM templates 51 ; PFIXFLAG=1: update prefix (as well as other flds). 52 ; New prefix is for unexpanded state of line. 53 N DIC,DIQ,DA,DR,TIUR,ADT,DDT,LCT,AUT,AMD,EDT,SDT,TIULST4 54 N MOM,DOC,MISEDT,ITEMNODE 55 S ITEMNODE=^TMP("TIURIDX",$J,LINENO) 56 S DA=+$P(ITEMNODE,U,2) 57 S DIQ="TIUR",DIC=8925,DIQ(0)="IE" 58 S DR=".01;.02;.05;.07;.08;.1;1202;1204;1208;1209;1301;1307;1501;1507" 59 D EN^DIQ1 Q:$D(TIUR)'>9 60 S DOC=$$PNAME^TIULC1(+TIUR(8925,DA,.01,"I")) 61 I DOC="Addendum" D 62 . S MOM=+$P(^TIU(8925,DA,0),U,6) 63 . S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,MOM,0))) 64 S TIULST4=$E($P($G(^DPT(TIUR(8925,DA,.02,"I"),0)),U,9),6,9) 65 S TIULST4="("_$E(TIUR(8925,DA,.02,"E"))_TIULST4_")" 66 S ADT=$$DATE^TIULS(TIUR(8925,DA,.07,"I"),"MM/DD/YY") 67 S DDT=$$DATE^TIULS(TIUR(8925,DA,.08,"I"),"MM/DD/YY") 68 S AMD=$$NAME^TIULS(TIUR(8925,DA,1208,"E"),"LAST, FI MI") 69 S AUT=$$NAME^TIULS(TIUR(8925,DA,1202,"E"),"LAST, FI MI") 70 S EDT=$$DATE^TIULS(TIUR(8925,DA,1301,"I"),"MM/DD/YY") 71 S MISEDT=$$DATE^TIULS(TIUR(8925,DA,1307,"I"),"MM/DD/YY") 72 S SDT=$S(+TIUR(8925,DA,1507,"I"):TIUR(8925,DA,1507,"I"),TIUR(8925,DA,.05,"I")'<7:+TIUR(8925,DA,1501,"I"),1:"") 73 S SDT=$$DATE^TIULS(SDT,"MM/DD/YY") 74 S LCT=$G(TIUR(8925,DA,.1,"E")) 75 ; -- Set prefix_patient/title into ^TMP("TIUR",$J,LINENO,0), 76 ; then into TIUREC: -- 77 I $G(PFIXFLAG) D SETPT^TIURL1(LINENO) 78 S TIUREC=^TMP("TIUR",$J,LINENO,0) 79 ; -- Set other fields into TIUREC: -- 80 S TIUREC=$$SETFLD^VALM1(LINENO,TIUREC,"NUMBER") 81 S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(TIUR(8925,DA,.05,"E")),TIUREC,"STATUS") 82 S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4") 83 S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE") 84 S:$D(VALMDDF("ADMISSION DATE")) TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE") 85 S:$D(VALMDDF("DISCH DATE")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"DISCH DATE") 86 S:$D(VALMDDF("DICT DATE")) TIUREC=$$SETFLD^VALM1(MISEDT,TIUREC,"DICT DATE") 87 S:$D(VALMDDF("LINE COUNT")) TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT") 88 S:$D(VALMDDF("REF DATE")) TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE") 89 S:$D(VALMDDF("SIG DATE")) TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE") 90 S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR") 91 S:$D(VALMDDF("COSIGNER")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER") 92 S:$D(VALMDDF("ATTENDING")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING") 93 S ^TMP("TIUR",$J,LINENO,0)=TIUREC 94 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m
r613 r623 1 TIURM ; SLC/JER - MIS Document Review ;9/24/03 2 ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,216,224**;Jun 20, 1997;Build 7 3 ;12/7/00 split TIURM into TIURM & TIURM1 4 MAKELIST(TIUCLASS) ; Get Search Criteria 5 N DIRUT,DTOUT,DUOUT,TIUI,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL 6 N TIUDPRMT,STATWORD,STATIFN,NOWFLAG,TIUK 7 K DIROUT 8 D INITRR^TIULRR(0) 9 DIVISION ; Select Division(s) 10 D SELDIV^TIULA 11 I SELDIV'>0 S VALMQUIT=1 Q 12 I $D(TIUDI) D 13 . S TIUK=0 F S TIUK=$O(TIUDI(TIUK)) Q:'TIUK D 14 . . S TIUDI("ENTRIES")=$G(TIUDI("ENTRIES"))_TIUK_";" 15 E S TIUDI("ENTRIES")="ALL DIVISIONS" 16 STATUS S STATUS=$S($D(TIUQUIK):$$SELSTAT^TIULA(.TIUSTAT,"F","UNSIGNED,UNCOSIGNED"),1:$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT(DUZ))) 17 ;VMP/ELR changed status ck from <0 TO <1 to account for entering an * p224 18 I +STATUS<1 S VALMQUIT=1 Q 19 S TIUI=0 20 F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI D 21 . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0)) 22 . Q:'STATIFN 23 . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";" 24 S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3)) 25 I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D 26 . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)) 27 I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER") 28 S STATUS("WORDS")=STATWORD 29 DOCTYPE ; Select Document Type(s) 30 N TIUDCL 31 ; -- Ask user for docmt types and set ^TMP("TIUTYP",$J): 32 D SELTYP^TIULA(TIUCLASS,.TIUTYP,"A","LAST","DOC",0,.TIUDCL) 33 I +$G(DIROUT) S VALMQUIT=1 Q 34 I +$G(@TIUTYP)'>0,'$D(TIUQUIK) K @TIUTYP G STATUS 35 D CHECKADD 36 ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") 37 S TIUDPRMT="Entry" 38 S TIUEDT=$S($D(TIUQUIK):1,1:$$EDATE^TIULA(TIUDPRMT,"",TIUEDFLT)) 39 I +$G(DIROUT) S VALMQUIT=1 Q 40 I TIUEDT'>0 K @TIUTYP G DOCTYPE 41 LATE S TIULDT=$S($D(TIUQUIK):9999999,1:$$LDATE^TIULA(TIUDPRMT)) 42 I +$G(DIROUT) S VALMQUIT=1 Q 43 I TIULDT'>0 G ERLY 44 I TIUEDT>TIULDT D SWAP(.TIUEDT,.TIULDT) 45 I $L(TIULDT,".")=1 D EXPRANGE(.TIUEDT,.TIULDT) ; P74. Add late date time whether or not late date is same as early date. 46 ; -- Reset late date to NOW on rebuild: 47 S NOWFLAG=$S(TIULDT-$$NOW^XLFDT<.0001:1,1:0) 48 I '$G(TIURBLD) W !,"Searching for the documents." 49 D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI) 50 ; -- If attaching ID note & changed view, 51 ; update video for line to be attached: -- 52 I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK) 53 K TIUDI,SELDIV 54 Q 55 CHECKADD ; Checks whether Addendum is included in the list of types 56 N TIUI,HIT,NUMTYPS 57 S (TIUI,HIT)=0 58 F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(^TMP("TIUTYP",$J,TIUI))["ADDENDUM" S HIT=1 59 S NUMTYPS=^TMP("TIUTYP",$J) 60 I +HIT'>0 S ^TMP("TIUTYP",$J,NUMTYPS+1)=+^TMP("TIUTYP",$J,NUMTYPS)+1_U_"81^Addendum^NOT PICKED",^TMP("TIUTYP",$J)=^TMP("TIUTYP",$J)+1 61 Q 62 SWAP(TIUX,TIUY) ; Swap any two variables 63 N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP 64 Q 65 EXPRANGE(TIUX,TIUY) ; Expand late date to include time 66 ;P74 If user entered date/time = T, then numerical date time is FIRST ^ PIECE ONLY of TIUX & TIUY. 67 I $P(TIUY,U)=DT S TIUY=$$NOW^XLFDT I 1 68 E S TIUY=$P(TIUY,U)_"."_235959 ;P74 Add seconds 69 Q 70 BUILD(TIUCLASS,STATUS,EARLY,LATE,NOWFLAG,TIUDI) ; Build List 71 N TIUPREF 72 S TIUPREF=$$PERSPRF^TIULE(DUZ) 73 K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J) 74 ; If user entered NOW at first build, update NOW for rebuild; 75 ; Save data in ^TMP("TIURIDX",$J,0) for rebuild: 76 I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT 77 S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG 78 S ^TMP("TIUR",$J,"RTN")="TIURM" 79 I '$D(TIUPRM0)!'$D(TIUPRM0) D SETPARM^TIULE 80 S EARLY=+$G(EARLY,0),LATE=+$G(LATE,3333333) 81 D GATHER^TIURM1(TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,.TIUDI) 82 D PUTLIST^TIURM1(TIUPREF,TIUCLASS,.STATUS,.TIUDI) 83 K ^TMP("TIUI",$J) 84 Q 85 CLEAN ; Clean up your mess! 86 K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10,KILLRR^TIULRR 87 K VALMY 88 K ^TMP("TIUTYP",$J) 89 Q 90 URGENCY(TIUDA) ; What is the urgency of the current document 91 N TIUY,TIUD0,TIUDSTAT,TIUDURG 92 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUDSTAT=$P(TIUD0,U,5) 93 S TIUDURG=$P(TIUD0,U,9) 94 S TIUY=$S(TIUDSTAT<7:$S(TIUDURG="P":1,1:2),1:3) 95 Q TIUY 96 DFLTSTAT(USER) ; Set default STATUS for current user 97 N TIUMIS,TIUMD,TIUY,TIUDPRM D DOCPRM^TIULC1(244,.TIUDPRM) 98 S TIUMIS=$$ISA^USRLM(DUZ,"MEDICAL INFORMATION SECTION") 99 I +TIUMIS,+$P($G(TIUDPRM(0)),U,3) S TIUY="UNVERIFIED" G DFLTX 100 I $$ISA^USRLM(DUZ,"PROVIDER") S TIUY="COMPLETED" G DFLTX 101 S TIUY="COMPLETED" 102 DFLTX Q TIUY 103 ; 104 RBLD ; Rebuild list after actions 11/30/00 105 N TIUEXP,TIUR0,TIURIDX0,TIUEDT,TIULDT 106 N TIURBLD,TIUI,TIUCLASS,TIUDI,TIUSCRN 107 S TIURBLD=1 108 D FIXLSTNW^TIULM ;restore video for elements added to end of list 109 I +$O(^TMP("TIUR",$J,"EXPAND",0)) D 110 . M TIUEXP=^TMP("TIUR",$J,"EXPAND") 111 S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0) 112 S TIUCLASS=^TMP("TIUR",$J,"CLASS") 113 S STATUS("WORDS")=$P(TIUR0,U,2) 114 S STATUS("IFNS")=$P(TIURIDX0,U,3) 115 S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4) 116 M TIUDI=^TMP("TIUR",$J,"DIV") 117 ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224 118 S TIUSCRN="ALL" 119 D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI) 120 ; Reexpand previously expanded items: 121 D RELOAD^TIUROR1(.TIUEXP) 122 D BREATHE^TIUROR1(1) 123 Q 1 TIURM ; SLC/JER - MIS Document Review ;9/24/03 2 ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,216**;Jun 20, 1997 3 ;12/7/00 split TIURM into TIURM & TIURM1 4 MAKELIST(TIUCLASS) ; Get Search Criteria 5 N DIRUT,DTOUT,DUOUT,TIUI,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL 6 N TIUDPRMT,STATWORD,STATIFN,NOWFLAG,TIUK 7 K DIROUT 8 D INITRR^TIULRR(0) 9 DIVISION ; Select Division(s) 10 D SELDIV^TIULA 11 I SELDIV'>0 S VALMQUIT=1 Q 12 I $D(TIUDI) D 13 . S TIUK=0 F S TIUK=$O(TIUDI(TIUK)) Q:'TIUK D 14 . . S TIUDI("ENTRIES")=$G(TIUDI("ENTRIES"))_TIUK_";" 15 E S TIUDI("ENTRIES")="ALL DIVISIONS" 16 STATUS S STATUS=$S($D(TIUQUIK):$$SELSTAT^TIULA(.TIUSTAT,"F","UNSIGNED,UNCOSIGNED"),1:$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT(DUZ))) 17 I +STATUS<0 S VALMQUIT=1 Q 18 S TIUI=0 19 F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI D 20 . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0)) 21 . Q:'STATIFN 22 . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";" 23 S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3)) 24 I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D 25 . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)) 26 I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER") 27 S STATUS("WORDS")=STATWORD 28 DOCTYPE ; Select Document Type(s) 29 N TIUDCL 30 ; -- Ask user for docmt types and set ^TMP("TIUTYP",$J): 31 D SELTYP^TIULA(TIUCLASS,.TIUTYP,"A","LAST","DOC",0,.TIUDCL) 32 I +$G(DIROUT) S VALMQUIT=1 Q 33 I +$G(@TIUTYP)'>0,'$D(TIUQUIK) K @TIUTYP G STATUS 34 D CHECKADD 35 ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") 36 S TIUDPRMT="Entry" 37 S TIUEDT=$S($D(TIUQUIK):1,1:$$EDATE^TIULA(TIUDPRMT,"",TIUEDFLT)) 38 I +$G(DIROUT) S VALMQUIT=1 Q 39 I TIUEDT'>0 K @TIUTYP G DOCTYPE 40 LATE S TIULDT=$S($D(TIUQUIK):9999999,1:$$LDATE^TIULA(TIUDPRMT)) 41 I +$G(DIROUT) S VALMQUIT=1 Q 42 I TIULDT'>0 G ERLY 43 I TIUEDT>TIULDT D SWAP(.TIUEDT,.TIULDT) 44 I $L(TIULDT,".")=1 D EXPRANGE(.TIUEDT,.TIULDT) ; P74. Add late date time whether or not late date is same as early date. 45 ; -- Reset late date to NOW on rebuild: 46 S NOWFLAG=$S(TIULDT-$$NOW^XLFDT<.0001:1,1:0) 47 I '$G(TIURBLD) W !,"Searching for the documents." 48 D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI) 49 ; -- If attaching ID note & changed view, 50 ; update video for line to be attached: -- 51 I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK) 52 K TIUDI,SELDIV 53 Q 54 CHECKADD ; Checks whether Addendum is included in the list of types 55 N TIUI,HIT,NUMTYPS 56 S (TIUI,HIT)=0 57 F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(^TMP("TIUTYP",$J,TIUI))["ADDENDUM" S HIT=1 58 S NUMTYPS=^TMP("TIUTYP",$J) 59 I +HIT'>0 S ^TMP("TIUTYP",$J,NUMTYPS+1)=+^TMP("TIUTYP",$J,NUMTYPS)+1_U_"81^Addendum^NOT PICKED",^TMP("TIUTYP",$J)=^TMP("TIUTYP",$J)+1 60 Q 61 SWAP(TIUX,TIUY) ; Swap any two variables 62 N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP 63 Q 64 EXPRANGE(TIUX,TIUY) ; Expand late date to include time 65 ;P74 If user entered date/time = T, then numerical date time is FIRST ^ PIECE ONLY of TIUX & TIUY. 66 I $P(TIUY,U)=DT S TIUY=$$NOW^XLFDT I 1 67 E S TIUY=$P(TIUY,U)_"."_235959 ;P74 Add seconds 68 Q 69 BUILD(TIUCLASS,STATUS,EARLY,LATE,NOWFLAG,TIUDI) ; Build List 70 N TIUPREF 71 S TIUPREF=$$PERSPRF^TIULE(DUZ) 72 K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J) 73 ; If user entered NOW at first build, update NOW for rebuild; 74 ; Save data in ^TMP("TIURIDX",$J,0) for rebuild: 75 I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT 76 S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG 77 S ^TMP("TIUR",$J,"RTN")="TIURM" 78 I '$D(TIUPRM0)!'$D(TIUPRM0) D SETPARM^TIULE 79 S EARLY=+$G(EARLY,0),LATE=+$G(LATE,3333333) 80 D GATHER^TIURM1(TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,.TIUDI) 81 D PUTLIST^TIURM1(TIUPREF,TIUCLASS,.STATUS,.TIUDI) 82 K ^TMP("TIUI",$J) 83 Q 84 CLEAN ; Clean up your mess! 85 K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10,KILLRR^TIULRR 86 K VALMY 87 K ^TMP("TIUTYP",$J) 88 Q 89 URGENCY(TIUDA) ; What is the urgency of the current document 90 N TIUY,TIUD0,TIUDSTAT,TIUDURG 91 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUDSTAT=$P(TIUD0,U,5) 92 S TIUDURG=$P(TIUD0,U,9) 93 S TIUY=$S(TIUDSTAT<7:$S(TIUDURG="P":1,1:2),1:3) 94 Q TIUY 95 DFLTSTAT(USER) ; Set default STATUS for current user 96 N TIUMIS,TIUMD,TIUY,TIUDPRM D DOCPRM^TIULC1(244,.TIUDPRM) 97 S TIUMIS=$$ISA^USRLM(DUZ,"MEDICAL INFORMATION SECTION") 98 I +TIUMIS,+$P($G(TIUDPRM(0)),U,3) S TIUY="UNVERIFIED" G DFLTX 99 I $$ISA^USRLM(DUZ,"PROVIDER") S TIUY="COMPLETED" G DFLTX 100 S TIUY="COMPLETED" 101 DFLTX Q TIUY 102 ; 103 RBLD ; Rebuild list after actions 11/30/00 104 N TIUEXP,TIUR0,TIURIDX0,TIUEDT,TIULDT 105 N TIURBLD,TIUI,TIUCLASS,TIUDI 106 S TIURBLD=1 107 D FIXLSTNW^TIULM ;restore video for elements added to end of list 108 I +$O(^TMP("TIUR",$J,"EXPAND",0)) D 109 . M TIUEXP=^TMP("TIUR",$J,"EXPAND") 110 S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0) 111 S TIUCLASS=^TMP("TIUR",$J,"CLASS") 112 S STATUS("WORDS")=$P(TIUR0,U,2) 113 S STATUS("IFNS")=$P(TIURIDX0,U,3) 114 S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4) 115 M TIUDI=^TMP("TIUR",$J,"DIV") 116 D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI) 117 ; Reexpand previously expanded items: 118 D RELOAD^TIUROR1(.TIUEXP) 119 D BREATHE^TIUROR1(1) 120 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVA.m
r613 r623 1 TIUSRVA ; SLC/JER,AJB - API's for Authorization ; 11/13/072 ;;1.0;TEXT INTEGRATION UTILITIES;**19,28,47,80,100,116,152,160,178,175,157,236,234**;Jun 20, 1997;Build 6 3 4 5 REQCOS(TIUY,TIUTYP,TIUDA,TIUSER,TIUDT) 6 7 8 9 10 11 12 13 14 URGENCY( TIUY); -- retrieve set values from dd for discharge summary urgency15 N TIUDD,TIUI,TIUX16 17 F TIUI=1:1 S TIUX=$P(TIUDD("POINTER"),";",TIUI) Q:TIUX="" S TIUY(TIUI)=$TR(TIUX,":","^")18 19 CANDO( TIUY,TIUDA,TIUACT); Boolean function to evaluate privilege20 21 ; **152** prevent editing completed [uncosigned] documents.22 I $P($G(^TIU(8925,TIUDA,0)),U,5)>5,(TIUACT="EDIT RECORD") S TIUY="0^ You may not edit uncosigned or completed documents" Q23 24 25 . E S TIUY="0^ Another session is editing this entry.",TIUPOP=126 27 I TIUACT["SIGN",+$$NEEDCS(TIUDA) S TIUY="0^ You must name a cosigner before signing this document." Q28 S TIUY=$$CANDO^TIULP(TIUDA,TIUACT)29 30 NEEDCS(TIUDA) 31 32 33 34 35 36 37 38 USRINACT(TIUY,TIUDA) 39 40 41 AUTHSIGN(TIUY,TIUDA,TIUUSR) 42 43 44 45 46 47 48 49 50 51 52 TIUVISIT(TIUY,DOCTYP,DFN,VISIT) 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 . N TIUX372 . S TIUX3=+$O(^TIU(8925.95,"B",DOCTYP,""))73 . S TIUY=$P($G(^TIU(8925.95,TIUX3,0)),U,10) S TIUY=$S(TIUY=0:1,1:0)74 75 76 77 78 79 80 WHATACT( TIUY,TIUDA); Evaluate/return whether signature or cosignature81 82 83 84 85 86 87 S TIUY=$S(TIUSTAT'>5:"SIGNATURE",+$G(XTRASGNR):"SIGNATURE",1:"COSIGNATURE")88 89 CANCHCOS( TIUY,TIUDA); Evaluate/return whether user can change cosigner90 S TIUY=$$MAYCHNG^TIURA1(TIUDA)91 92 NEEDJUST( TIUY,TIUDA); Is justification required for deletion?93 N TIUD0 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUY=094 I +$P(TIUD0,U,5)'<6 S TIUY=195 96 GETTITLE( TIUY,TIUDA); Get the title from a TIU Document Record97 S TIUY=+$G(^TIU(8925,+TIUDA,0))98 99 CANATTCH( TIUY,TIUDA); Can this document be attached as an ID Child100 101 102 I TITLEDA'>0 S TIUY="0^Document #"_TIUDA_" does not exist." Q103 104 S TIUY=$$POSSPRNT^TIULP(TITLEDA)105 I +TIUY S TIUY="-1"_U_$P(TIUY,U,2) Q106 107 . S TIUY="0^ CWAD Documents may not be Attached as Interdisciplinary Entries."108 109 . S TIUY="0^ Consult Results may not be Attached as Interdisciplinary Entries."110 S TIUY=$$CANDO^TIULP(TIUDA,"ATTACH TO ID NOTE")111 112 . I 'TIUY S TIUY="0^ You may not detach this note from an interdisciplinary note." Q113 . S TIUY=$$CANDO^TIULP(PARENTDA,"ATTACH ID ENTRY")114 . I 'TIUY S TIUY="0^ You may not detach this note from its interdisciplinary note."115 116 CANRCV( TIUY,TIUDA); Can this document receive an ID Child?117 S TIUY=$$CANDO^TIULP(TIUDA,"ATTACH ID ENTRY")118 1 TIUSRVA ; SLC/JER,AJB - API's for Authorization ; 03/18/04 [10/19/04 1:21pm] 2 ;;1.0;TEXT INTEGRATION UTILITIES;**19,28,47,80,100,116,152,160,178,175,157**;Jun 20, 1997 3 ; 4 ;External reference to File ^AUPNVSIT supported by DBIA 3580 5 REQCOS(TIUY,TIUTYP,TIUDA,TIUSER,TIUDT) ; Evaluate cosignature requirement 6 ; Initialize return value 7 N TIUDPRM 8 S TIUY=0 9 I +$G(TIUTYP)'>0,'+$G(TIUDA) Q 10 I +$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+$G(TIUDA),0)) 11 S:'+$G(TIUSER) TIUSER=+$G(DUZ) 12 S TIUY=+$$REQCOSIG^TIULP(TIUTYP,+$G(TIUDA),+$G(TIUSER),+$G(TIUDT)) 13 Q 14 URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency 15 N TIUDD,I,X 16 D FIELD^DID(8925,.09,"","POINTER","TIUDD") 17 F I=1:1 S X=$P(TIUDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^") 18 Q 19 CANDO(Y,TIUDA,TIUACT) ; Boolean function to evaluate privilege 20 N TIUPOP,TIUDPRM S TIUPOP=0 21 ; **152** code added to prevent editing a completed document. 22 I $P($G(^TIU(8925,TIUDA,0)),U,5)>6,(TIUACT="EDIT RECORD") S Y="0^ You may not edit a completed document" Q 23 I $S(TIUACT["SIGN":1,TIUACT="EDIT RECORD":1,TIUACT="DELETE RECORD":1,1:0) D Q:+TIUPOP=1 24 . L +^TIU(8925,+TIUDA):1 25 . E S Y="0^ Another session is editing this entry.",TIUPOP=1 26 . L -^TIU(8925,+TIUDA) 27 I TIUACT["SIGN",+$$NEEDCS(TIUDA) S Y="0^ You must name a cosigner before signing this document." Q 28 S Y=$$CANDO^TIULP(TIUDA,TIUACT) 29 Q 30 NEEDCS(TIUDA) ; Does user need a cosigner? 31 N TIUD0,TIUD12,TIUY,SIGNER,COSIGNER,XTRASGNR 32 S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD12=$G(^(12)) 33 S SIGNER=$P(TIUD12,U,4),COSIGNER=$P(TIUD12,U,8),XTRASGNR=0 34 I (DUZ'=SIGNER),(DUZ'=COSIGNER) S XTRASGNR=+$O(^TIU(8925.7,"AE",+TIUDA,+DUZ,0)) 35 I +XTRASGNR S TIUY=0 36 E I +$$REQCOSIG^TIULP(+TIUD0,TIUDA,DUZ),(+$P(TIUD12,U,8)'>0) S TIUY=1 37 Q +$G(TIUY) 38 USRINACT(TIUY,TIUDA) ; Is user inactive? 39 S TIUY=+$$GET1^DIQ(200,TIUDA_",",7,"I") 40 Q 41 AUTHSIGN(TIUY,TIUDA,TIUUSR) ; Has Author signed? 42 ; if TIUY = 43 ; 0 = Author has NOT signed & TIUUSR = Expected Cosigner 44 ; 1 = Author HAS signed or TIUUSR '= Expected Cosigner 45 ; 46 N TIUD12,TIUD15 47 S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD15=$G(^(15)) 48 S TIUY=1 49 D:$P(TIUD12,U,8)=TIUUSR Q 50 . S:$P(TIUD12,U,2)'=$P(TIUD15,U,2) TIUY=0 51 Q 52 TIUVISIT(TIUY,DOCTYP,DFN,VISIT) ; Check for a 1 time only doc 53 ; TIUY = return value 54 ; = 0 if can add more than one or none already exist 55 ; = 1 if cannot add more than one and one already exists 56 ; DOCTYP = Pointer to ^TUI(8925.1, TIU DOCUMENT DEFINITION 57 ; DFN = Patient IEN 58 ; VISIT = Visit String "LOC;VDATE;VTYP" 59 I $$PATCH^XPDUTL("OR*3.0*195") D 60 . Q:($G(DOCTYP)="")!($G(DFN)="")!($G(VISIT)="") 61 . N TIUDPRM,TIUTEST 62 . D DOCPRM^TIULC1(DOCTYP,.TIUDPRM) 63 . S TIUY=$S($P(TIUDPRM(0),U,10)="":1,1:$P(TIUDPRM(0),U,10)) 64 . I TIUY=1 S TIUY=0 Q 65 . I $L(VISIT,";")=3 D 66 . . S TIUTEST=$$EXIST^TIUEDI3(DFN,DOCTYP,VISIT) 67 . . I TIUTEST S TIUY=1 68 . . I 'TIUTEST S TIUY=0 69 I '$$PATCH^XPDUTL("OR*3.0*195") D 70 . Q:($G(DOCTYP)="")!($G(DFN)="")!($G(VISIT)="") 71 . N X3 72 . S X3=+$O(^TIU(8925.95,"B",DOCTYP,"")) 73 . S TIUY=$P($G(^TIU(8925.95,X3,0)),U,10) S TIUY=$S(TIUY=0:1,1:0) 74 . Q:'TIUY 75 . S VISIT=((9999999-$P(VISIT,"."))_"."_$P(VISIT,".",2)) 76 . S VISIT=+$O(^AUPNVSIT("AA",DFN,VISIT,"")) 77 . S TIUY=$S($D(^TIU(8925,"AV",DFN,DOCTYP,VISIT)):0,1:1) 78 . S TIUY=$S(TIUY=0:1,1:0) 79 Q 80 WHATACT(Y,TIUDA) ; Evaluate/return whether signature or cosignature 81 N TIUD0,TIUD12,TIUSTAT,SIGNER,COSIGNER,XTRASGNR 82 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^TIU(8925,+TIUDA,12)) 83 S SIGNER=$P(TIUD12,U,4),COSIGNER=$P(TIUD12,U,8) 84 I (DUZ'=SIGNER),(DUZ'=COSIGNER) S XTRASGNR=+$O(^TIU(8925.7,"AE",+TIUDA,+DUZ,0)) 85 I '$G(XTRASGNR) S XTRASGNR=$$ASURG^TIUADSIG(TIUDA) 86 S TIUSTAT=+$P(TIUD0,U,5) 87 S Y=$S(TIUSTAT'>5:"SIGNATURE",+$G(XTRASGNR):"SIGNATURE",1:"COSIGNATURE") 88 Q 89 CANCHCOS(Y,TIUDA) ; Evaluate/return whether user can change cosigner 90 S Y=$$MAYCHNG^TIURA1(TIUDA) 91 Q 92 NEEDJUST(Y,TIUDA) ; Is justification required for deletion? 93 N TIUD0 S TIUD0=$G(^TIU(8925,+TIUDA,0)),Y=0 94 I +$P(TIUD0,U,5)'<6 S Y=1 95 Q 96 GETTITLE(Y,TIUDA) ; Get the title from a TIU Document Record 97 S Y=+$G(^TIU(8925,+TIUDA,0)) 98 Q 99 CANATTCH(Y,TIUDA) ; Can this document be attached as an ID Child 100 N TITLEDA,PARENTDA 101 S TITLEDA=+$G(^TIU(8925,TIUDA,0)) 102 I TITLEDA'>0 S Y="0^Document #"_TIUDA_" does not exist." Q 103 S PARENTDA=+$G(^TIU(8925,TIUDA,21)) 104 S Y=$$POSSPRNT^TIULP(TITLEDA) 105 I +Y S Y="-1"_U_$P(Y,U,2) Q 106 I +$$ISCWAD^TIULX(TITLEDA) D Q 107 . S Y="0^ CWAD Documents may not be Attached as Interdisciplinary Entries." 108 I +$$ISA^TIULX(TITLEDA,+$$CLASS^TIUCNSLT) D Q 109 . S Y="0^ Consult Results may not be Attached as Interdisciplinary Entries." 110 S Y=$$CANDO^TIULP(TIUDA,"ATTACH TO ID NOTE") 111 I PARENTDA D ; action must be "detach" 112 . I 'Y S Y="0^ You may not detach this note from an interdisciplinary note." Q 113 . S Y=$$CANDO^TIULP(PARENTDA,"ATTACH ID ENTRY") 114 . I 'Y S Y="0^ You may not detach this note from its interdisciplinary note." 115 Q 116 CANRCV(Y,TIUDA) ; Can this document receive an ID Child? 117 S Y=$$CANDO^TIULP(TIUDA,"ATTACH ID ENTRY") 118 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVP1.m
r613 r623 1 TIUSRVP1 ; SLC/JER - More API's in support of PUT ;8/14/07 2 ;;1.0;TEXT INTEGRATION UTILITIES;**19,59,89,100,109,167,113,112,219**;Jun 20, 1997;Build 11 3 SITEPARM(TIUY) ; Get site parameters for GUI 4 N TIUPRM0,TIUPRM1 5 D SETPARM^TIULE 6 S TIUY=TIUPRM0 7 Q 8 DEFDOC(TIUY,HLOC,USER,TIUDT,TIUIEN) ; Get default primary provider 9 N TIUSPRM,TIUDDOC,TIUAUTH 10 D SITEPARM(.TIUSPRM) 11 S TIUDDOC=+$P(TIUSPRM,U,8) 12 S TIUAUTH=$S((+$G(USER)!('+$G(TIUIEN))):0,1:+$P($G(^TIU(8925,+$G(TIUIEN),12)),U,2)) 13 S USER=$S(+$G(USER):+$G(USER),+$G(TIUAUTH):+$G(TIUAUTH),1:DUZ) 14 S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT) 15 S TIUY=$S(TIUDDOC=1:$$DFLTDOC^TIUPXAPI(HLOC),TIUDDOC=2:$$CURDOC(USER),1:"0^") 16 Q 17 CURDOC(USER,TIUDT) ; Is the current user a known Provider? 18 N TIUY,TIUPROV S TIUY="0^" 19 S USER=$S(+$G(USER):+$G(USER),1:DUZ) 20 S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT) 21 S TIUPROV=$$PROVIDER^TIUPXAP1(USER,TIUDT) 22 I +TIUPROV S TIUY=USER_U_$$PERSNAME^TIULC1(USER) 23 Q TIUY 24 ISAPROV(TIUY,USER,DATE) ; Is user a provider? 25 ; Checks USR CLASS PROVIDER AND 200 Person Class 26 ; DATE must not include time (for ISA^USRLM) 27 S USER=$G(USER,DUZ) 28 S DATE=$G(DATE,DT) 29 S TIUY=$$PROVIDER^TIUPXAP1(USER,DATE) 30 Q 31 USRPROV(TIUY,USER,DATE) ; Is USER a USR CLASS provider? 32 ; Checks USR CLASS PROVIDER only 33 ; DATE must not include time 34 N TIUERR 35 S USER=$G(USER,DUZ) 36 S DATE=$G(DATE,DT),TIUY=0 37 I +$$ISA^USRLM(USER,"PROVIDER",.TIUERR,DATE) S TIUY=1 ; DBIA/ICR 2324 38 Q 39 DOCPARM(TIUY,TIUDA,TIUTYP) ; Get document parameters for GUI 40 I '+$G(TIUTYP),+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+TIUDA,0)) 41 I '+$G(TIUTYP) S TIUY(0)="" Q 42 D DOCPRM^TIULC1(TIUTYP,.TIUY,$G(TIUDA)) 43 I '$D(TIUY) S TIUY(0)="" 44 Q 45 CONSTUB(TIUDA,GMRCVP,DFN) ; Create a stub for a Consult Report 46 N DIE,DR,DA 47 D STUB(.TIUDA,"CONSULT REPORT",DFN) 48 I +TIUDA'>0 Q 49 S DIE=8925,DA=+TIUDA,DR="1405////^S X=GMRCVP" 50 D ^DIE 51 Q 52 STUB(TIUDA,TIUTITL,DFN) ; Create a stub 53 N TIUVSIT,TIUFPRIV,DIC,DIE,DR,DA,DLAYGO,X,Y S TIUFPRIV=1 54 I +$G(TIUTITL)'>0 S TIUTITL=$$WHATITLE^TIUPUTU(TIUTITL) 55 I +TIUTITL'>0 S TIUDA=-1 Q 56 S (DIC,DLAYGO)=8925,DIC(0)="LF" 57 S X=""""_"`"_+TIUTITL_"""" 58 D ^DIC S TIUDA=+Y Q:+Y'>0 59 D EVENT(.TIU,DFN) I $L($G(TIU("VSTR")))'>0 S TIUDA=-1 Q 60 S DIE=DIC,DA=TIUDA 61 S DR=".02////"_+DFN_";.03////"_$P($G(TIU("VISIT")),U)_";.04////"_+$$DOCCLASS^TIULC1(TIUTITL)_";.05///UNDICTATED;.13////E;1301////"_+$$NOW^XLFDT 62 D ^DIE 63 Q 64 EVENT(TIUY,DFN) ; Create an Event-type Visit Entry 65 N VDT,VSTR,DGPM 66 S DGPM=$G(^DPT(DFN,.105)) ;DBIA/ICR 10035 67 I +DGPM'>0 D 68 . S VDT=$$NOW^XLFDT 69 . S VSTR=";"_VDT_";"_"E" 70 D PATVADPT^TIULV(.TIUY,+DFN,DGPM,$G(VSTR)) 71 I $G(TIUY("LOC"))="",+DUZ D 72 .N TIUPREF,IDX 73 .S TIUPREF=$$PERSPRF^TIULE(DUZ) 74 .S IDX=+$P(TIUPREF,U,2) 75 .I IDX S TIUY("LOC")=IDX_U_$P($G(^SC(IDX,0)),U,1) ; DBIA/ICR 10040 76 Q 77 GETPNAME(TIUY,TIUTYPE) ; Get Print Name of a Document 78 S TIUY=$$PNAME^TIULC1(TIUTYPE) 79 Q 80 SAVED(TIUY,TIUDA) ; Was the document committed to the database? 81 N TIUD12,TIUD13,TIUEBY,TIUAUT,TIUECS S TIUY=1 82 S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD13=$G(^(13)) 83 S TIUEBY=$P(TIUD13,U,2),TIUAUT=$P(TIUD12,U,2),TIUECS=$P(TIUD12,U,8) 84 I $D(^TIU(8925,"ASAVE",+DUZ,TIUDA)) D Q 85 . S TIUY="0^You appear to have been disconnected..." 86 I DUZ'=TIUEBY,(TIUEBY'=TIUAUT),$D(^TIU(8925,"ASAVE",+TIUEBY,TIUDA)) D Q 87 . S TIUY="0^The transcriber appears to have been disconnected..." 88 I DUZ'=TIUAUT,$D(^TIU(8925,"ASAVE",+TIUAUT,TIUDA)) D Q 89 . S TIUY="0^The author appears to have been disconnected..." 90 I DUZ'=TIUECS,$D(^TIU(8925,"ASAVE",+TIUECS,TIUDA)) D Q 91 . S TIUY="0^The expected cosigner appears to have been disconnected..." 92 Q 93 STUFREC(TIUDA,TIUREC,DFN,PARENT,TITLE,TIU) ; load TIUREC for create 94 N TIUREQCS,TIUSCAT,TIUSTAT,TIUCPF 95 ;Set a flag to indicate whether or not a Title is a member of the 96 ;Clinical Procedures Class (1=Yes and 0=No) 97 S TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP) 98 S TIUSTAT=$$STATUS(TIUDA,+$G(SUPPRESS),$G(TITLE)) 99 D REQCOS^TIUSRVA(.TIUREQCS,+TITLE,"",$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),1:DUZ)) 100 I +$G(PARENT)'>0 D 101 . S TIUREC(.02)=$G(DFN),TIUREC(.03)=$P($G(TIU("VISIT")),U) 102 . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5) 103 . S TIUREC(.07)=$P($G(TIU("EDT")),U),TIUREC(.08)=$P($G(TIU("LDT")),U) 104 . S TIUREC(1401)=$P($G(TIU("AD#")),U) 105 . S TIUREC(1402)=$P($G(TIU("TS")),U) 106 . S TIUREC(1404)=$P($G(TIU("SVC")),U) 107 I +$G(PARENT)>0 D 108 . S TIUREC(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2) 109 . S TIUREC(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3) 110 . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5) 111 . S TIUREC(.06)=PARENT,TIUREC(.07)=$P(TIU("EDT"),U) 112 . S TIUREC(.08)=$P(TIU("LDT"),U) 113 . S TIUREC(1401)=$P($G(^TIU(8925,+PARENT,14)),U) 114 . S TIUREC(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2) 115 . S TIUREC(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4) 116 . S TIUREC(1405)=$P($G(^TIU(8925,+PARENT,14)),U,5) 117 S TIUREC(.04)=$$DOCCLASS^TIULC1(TITLE) 118 S TIUSCAT=$S(+$L($P($G(TIU("CAT")),U)):$P($G(TIU("CAT")),U),+$L($P($G(TIU("VSTR")),";",3)):$P($G(TIU("VSTR")),";",3),1:"") 119 S TIUREC(.13)=TIUSCAT 120 ;If the document is a member of the Clinical Procedures Class, set the 121 ;Author/Dictator and the Expected Signer fields to Null 122 S (TIUREC(1202),TIUREC(1204))=$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),TIUCPF:"",1:+$G(DUZ)) 123 S TIUREC(1212)=$P($G(TIU("INST")),U) 124 S TIUREC(1205)=$P($G(TIU("LOC")),U) 125 S TIUREC(1211)=$P($G(TIU("VLOC")),U) 126 S TIUREC(1201)=$$NOW^XLFDT 127 S TIUREC(1301)=$S($G(TIUREC(1301))]"":$P(TIUREC(1301),U),1:$$NOW^XLFDT) 128 I +$$ISDS^TIULX(TITLE) D 129 . I +$G(TIU("LDT"))'>0 S TIUREC(.12)=1 130 . S TIUREC(.13)="H" 131 . D REFDT(.TIUREC) 132 ;If the document is a member of the Clinical Procedures Class, set the 133 ;Entered By field to Null 134 S TIUREC(1303)="R",TIUREC(1302)=$S(TIUCPF:"",1:$G(DUZ)) 135 I $S(+$G(TIUREC(1208))&(+$G(TIUREC(1204))'=+$G(TIUREC(1208))):1,+$G(TIUREQCS):1,1:0) S TIUREC(1506)=1 136 Q 137 REFDT(TIUX) ; Hack Ref Date/time for DS's 138 S TIUX(1301)=$S(+$G(TIU("LDT")):+$G(TIU("LDT")),1:$G(TIUX(1301))) 139 Q 140 STATUS(TIUDA,SUPPRESS,TITLE) ; Compute the status of the current record 141 N TIUDPRM,TIUY 142 ; If the document is an addendum, compute status based on processing 143 ; requirements of the Parent document or its ancestors 144 I +$$ISADDNDM^TIULC1(TIUDA) D 145 . S TIUDA=$S(+$P(^TIU(8925,TIUDA,0),U,6):$P(^(0),U,6),1:TIUDA) 146 . S TITLE=+$G(^TIU(8925,TIUDA,0)) 147 D DOCPRM^TIULC1(TITLE,.TIUDPRM,$G(TIUDA)) 148 I +$P(TIUDPRM(0),U,2),+$G(SUPPRESS) S TIUY=3 G STATUX 149 S TIUY=$S(+$$REQVER^TIULC(+TIUDA,+$P($G(TIUDPRM(0)),U,3)):4,1:5) 150 STATUX Q TIUY 151 IDATTCH(TIUY,TIUDA,TIUDAD) ; Attach TIUDA as ID Child entry to TIUDAD 152 N TIUX 153 S TIUX(2101)=TIUDAD 154 D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1) 155 D AUDLINK^TIUGR1(TIUDA,"a",TIUDAD) 156 D SENDID^TIUALRT1(TIUDA) 157 Q 158 IDDTCH(TIUY,TIUDA) ; Detach TIUDA from its ID Parent 159 N TIUX,IDDAD 160 I '+$G(^TIU(8925,TIUDA,21)) D Q 161 . S TIUY="0^Record #"_TIUDA_" is NOT an ID Entry." 162 S IDDAD=+$G(^TIU(8925,TIUDA,21)) 163 S TIUX(2101)="@" 164 D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1) 165 D AUDLINK^TIUGR1(TIUDA,"d",IDDAD) 166 D IDDEL^TIUALRT1(TIUDA) 167 Q 168 CANDEL(TIUDA) ; Boolean function to evaluate delete request 169 Q $S($P(^TIU(8925,TIUDA,0),U,5)>3:0,'+$$EMPTYDOC^TIULF(TIUDA):0,1:1) 1 TIUSRVP1 ; SLC/JER - More API's in support of PUT ;11/01/03 2 ;;1.0;TEXT INTEGRATION UTILITIES;**19,59,89,100,109,167,113,112**;Jun 20, 1997 3 SITEPARM(TIUY) ; Get site parameters for GUI 4 N TIUPRM0,TIUPRM1 5 D SETPARM^TIULE 6 S TIUY=TIUPRM0 7 Q 8 DEFDOC(TIUY,HLOC,USER,TIUDT,TIUIEN) ; Get default primary provider 9 N TIUSPRM,TIUDDOC,TIUAUTH 10 D SITEPARM(.TIUSPRM) 11 S TIUDDOC=+$P(TIUSPRM,U,8) 12 S TIUAUTH=$S((+$G(USER)!('+$G(TIUIEN))):0,1:+$P($G(^TIU(8925,+$G(TIUIEN),12)),U,2)) 13 S USER=$S(+$G(USER):+$G(USER),+$G(TIUAUTH):+$G(TIUAUTH),1:DUZ) 14 S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT) 15 S TIUY=$S(TIUDDOC=1:$$DFLTDOC^TIUPXAPI(HLOC),TIUDDOC=2:$$CURDOC(USER),1:"0^") 16 Q 17 CURDOC(USER,TIUDT) ; Is the current user a known Provider? 18 N TIUY,TIUPROV S TIUY="0^" 19 S USER=$S(+$G(USER):+$G(USER),1:DUZ) 20 S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT) 21 S TIUPROV=$$PROVIDER^TIUPXAP1(USER,TIUDT) 22 I +TIUPROV S TIUY=USER_U_$$PERSNAME^TIULC1(USER) 23 Q TIUY 24 ISAPROV(TIUY,USER,DATE) ; Is user a provider? 25 S USER=$G(USER,DUZ) 26 S DATE=$G(DATE,DT) 27 S TIUY=$$PROVIDER^TIUPXAP1(USER,DATE) 28 Q 29 DOCPARM(TIUY,TIUDA,TIUTYP) ; Get document parameters for GUI 30 I '+$G(TIUTYP),+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+TIUDA,0)) 31 I '+$G(TIUTYP) S TIUY(0)="" Q 32 D DOCPRM^TIULC1(TIUTYP,.TIUY,$G(TIUDA)) 33 I '$D(TIUY) S TIUY(0)="" 34 Q 35 CONSTUB(TIUDA,GMRCVP,DFN) ; Create a stub for a Consult Report 36 N DIE,DR,DA 37 D STUB(.TIUDA,"CONSULT REPORT",DFN) 38 I +TIUDA'>0 Q 39 S DIE=8925,DA=+TIUDA,DR="1405////^S X=GMRCVP" 40 D ^DIE 41 Q 42 STUB(TIUDA,TIUTITL,DFN) ; Create a stub 43 N TIUVSIT,TIUFPRIV,DIC,DIE,DR,DA,DLAYGO,X,Y S TIUFPRIV=1 44 I +$G(TIUTITL)'>0 S TIUTITL=$$WHATITLE^TIUPUTU(TIUTITL) 45 I +TIUTITL'>0 S TIUDA=-1 Q 46 S (DIC,DLAYGO)=8925,DIC(0)="LF" 47 S X=""""_"`"_+TIUTITL_"""" 48 D ^DIC S TIUDA=+Y Q:+Y'>0 49 D EVENT(.TIU,DFN) I $L($G(TIU("VSTR")))'>0 S TIUDA=-1 Q 50 S DIE=DIC,DA=TIUDA 51 S DR=".02////"_+DFN_";.03////"_$P($G(TIU("VISIT")),U)_";.04////"_+$$DOCCLASS^TIULC1(TIUTITL)_";.05///UNDICTATED;.13////E;1301////"_+$$NOW^XLFDT 52 D ^DIE 53 Q 54 EVENT(TIUY,DFN) ; Create an Event-type Visit Entry 55 N VDT,VSTR,DGPM 56 S DGPM=$G(^DPT(DFN,.105)) 57 I +DGPM'>0 D 58 . S VDT=$$NOW^XLFDT 59 . S VSTR=";"_VDT_";"_"E" 60 D PATVADPT^TIULV(.TIUY,+DFN,DGPM,$G(VSTR)) 61 I $G(TIUY("LOC"))="",+DUZ D 62 .N TIUPREF,IDX 63 .S TIUPREF=$$PERSPRF^TIULE(DUZ) 64 .S IDX=+$P(TIUPREF,U,2) 65 .I IDX S TIUY("LOC")=IDX_U_$P($G(^SC(IDX,0)),U,1) 66 Q 67 GETPNAME(TIUY,TIUTYPE) ; Get Print Name of a Document 68 S TIUY=$$PNAME^TIULC1(TIUTYPE) 69 Q 70 SAVED(TIUY,TIUDA) ; Was the document committed to the database? 71 N TIUD12,TIUD13,TIUEBY,TIUAUT,TIUECS S TIUY=1 72 S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD13=$G(^(13)) 73 S TIUEBY=$P(TIUD13,U,2),TIUAUT=$P(TIUD12,U,2),TIUECS=$P(TIUD12,U,8) 74 I $D(^TIU(8925,"ASAVE",+DUZ,TIUDA)) D Q 75 . S TIUY="0^You appear to have been disconnected..." 76 I DUZ'=TIUEBY,(TIUEBY'=TIUAUT),$D(^TIU(8925,"ASAVE",+TIUEBY,TIUDA)) D Q 77 . S TIUY="0^The transcriber appears to have been disconnected..." 78 I DUZ'=TIUAUT,$D(^TIU(8925,"ASAVE",+TIUAUT,TIUDA)) D Q 79 . S TIUY="0^The author appears to have been disconnected..." 80 I DUZ'=TIUECS,$D(^TIU(8925,"ASAVE",+TIUECS,TIUDA)) D Q 81 . S TIUY="0^The expected cosigner appears to have been disconnected..." 82 Q 83 STUFREC(TIUDA,TIUREC,DFN,PARENT,TITLE,TIU) ; load TIUREC for create 84 N TIUREQCS,TIUSCAT,TIUSTAT,TIUCPF 85 ;Set a flag to indicate whether or not a Title is a member of the 86 ;Clinical Procedures Class (1=Yes and 0=No) 87 S TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP) 88 S TIUSTAT=$$STATUS(TIUDA,+$G(SUPPRESS),$G(TITLE)) 89 D REQCOS^TIUSRVA(.TIUREQCS,+TITLE,"",$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),1:DUZ)) 90 I +$G(PARENT)'>0 D 91 . S TIUREC(.02)=$G(DFN),TIUREC(.03)=$P($G(TIU("VISIT")),U) 92 . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5) 93 . S TIUREC(.07)=$P($G(TIU("EDT")),U),TIUREC(.08)=$P($G(TIU("LDT")),U) 94 . S TIUREC(1401)=$P($G(TIU("AD#")),U) 95 . S TIUREC(1402)=$P($G(TIU("TS")),U) 96 . S TIUREC(1404)=$P($G(TIU("SVC")),U) 97 I +$G(PARENT)>0 D 98 . S TIUREC(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2) 99 . S TIUREC(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3) 100 . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5) 101 . S TIUREC(.06)=PARENT,TIUREC(.07)=$P(TIU("EDT"),U) 102 . S TIUREC(.08)=$P(TIU("LDT"),U) 103 . S TIUREC(1401)=$P($G(^TIU(8925,+PARENT,14)),U) 104 . S TIUREC(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2) 105 . S TIUREC(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4) 106 . S TIUREC(1405)=$P($G(^TIU(8925,+PARENT,14)),U,5) 107 S TIUREC(.04)=$$DOCCLASS^TIULC1(TITLE) 108 S TIUSCAT=$S(+$L($P($G(TIU("CAT")),U)):$P($G(TIU("CAT")),U),+$L($P($G(TIU("VSTR")),";",3)):$P($G(TIU("VSTR")),";",3),1:"") 109 S TIUREC(.13)=TIUSCAT 110 ;If the document is a member of the Clinical Procedures Class, set the 111 ;Author/Dictator and the Expected Signer fields to Null 112 S (TIUREC(1202),TIUREC(1204))=$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),TIUCPF:"",1:+$G(DUZ)) 113 S TIUREC(1212)=$P($G(TIU("INST")),U) 114 S TIUREC(1205)=$P($G(TIU("LOC")),U) 115 S TIUREC(1211)=$P($G(TIU("VLOC")),U) 116 S TIUREC(1201)=$$NOW^XLFDT 117 S TIUREC(1301)=$S($G(TIUREC(1301))]"":$P(TIUREC(1301),U),1:$$NOW^XLFDT) 118 I +$$ISDS^TIULX(TITLE) D 119 . I +$G(TIU("LDT"))'>0 S TIUREC(.12)=1 120 . S TIUREC(.13)="H" 121 . D REFDT(.TIUREC) 122 ;If the document is a member of the Clinical Procedures Class, set the 123 ;Entered By field to Null 124 S TIUREC(1303)="R",TIUREC(1302)=$S(TIUCPF:"",1:$G(DUZ)) 125 I $S(+$G(TIUREC(1208))&(+$G(TIUREC(1204))'=+$G(TIUREC(1208))):1,+$G(TIUREQCS):1,1:0) S TIUREC(1506)=1 126 Q 127 REFDT(TIUX) ; Hack Ref Date/time for DS's 128 S TIUX(1301)=$S(+$G(TIU("LDT")):+$G(TIU("LDT")),1:$G(TIUX(1301))) 129 Q 130 STATUS(TIUDA,SUPPRESS,TITLE) ; Compute the status of the current record 131 N TIUDPRM,TIUY 132 ; If the document is an addendum, compute status based on processing 133 ; requirements of the Parent document or its ancestors 134 I +$$ISADDNDM^TIULC1(TIUDA) D 135 . S TIUDA=$S(+$P(^TIU(8925,TIUDA,0),U,6):$P(^(0),U,6),1:TIUDA) 136 . S TITLE=+$G(^TIU(8925,TIUDA,0)) 137 D DOCPRM^TIULC1(TITLE,.TIUDPRM,$G(TIUDA)) 138 I +$P(TIUDPRM(0),U,2),+$G(SUPPRESS) S TIUY=3 G STATUX 139 S TIUY=$S(+$$REQVER^TIULC(+TIUDA,+$P($G(TIUDPRM(0)),U,3)):4,1:5) 140 STATUX Q TIUY 141 IDATTCH(TIUY,TIUDA,TIUDAD) ; Attach TIUDA as ID Child entry to TIUDAD 142 N TIUX 143 S TIUX(2101)=TIUDAD 144 D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1) 145 D AUDLINK^TIUGR1(TIUDA,"a",TIUDAD) 146 D SENDID^TIUALRT1(TIUDA) 147 Q 148 IDDTCH(TIUY,TIUDA) ; Detach TIUDA from its ID Parent 149 N TIUX,IDDAD 150 I '+$G(^TIU(8925,TIUDA,21)) D Q 151 . S TIUY="0^Record #"_TIUDA_" is NOT an ID Entry." 152 S IDDAD=+$G(^TIU(8925,TIUDA,21)) 153 S TIUX(2101)="@" 154 D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1) 155 D AUDLINK^TIUGR1(TIUDA,"d",IDDAD) 156 D IDDEL^TIUALRT1(TIUDA) 157 Q 158 CANDEL(TIUDA) ; Boolean function to evaluate delete request 159 Q $S($P(^TIU(8925,TIUDA,0),U,5)>3:0,'+$$EMPTYDOC^TIULF(TIUDA):0,1:1) -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVR2.m
r613 r623 1 TIUSRVR2 ; SLC/JER - RPC for record-wise GET ; 11/23/072 ;;1.0;TEXT INTEGRATION UTILITIES;**100,109,162,222,234**;Jun 20, 1997;Build 6 3 4 LOADREC(TIUDA,TIUL,TIUGDATA,TIUGWHOL,ACTION) 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 LOADKIDS(TIUDA,TIUL,TIUGDATA,TIUGWHOL) 103 104 105 106 107 108 109 110 111 112 113 114 115 LOADID(TIUDA,TIUL,TIUGDATA,TIUWHOL) 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 INQUIRE(TIUDA,TIUREC,TIUCPF) 131 132 133 S DR=".01;.02;.05;.09;1201;1202;1208;1209;1301;1307;1501;1502;1505;1506;89261"134 135 136 137 138 139 LOADADD(TIUDADD,TIUL) 140 141 142 143 144 145 146 147 148 149 150 151 1 TIUSRVR2 ; SLC/JER - RPC for record-wise GET ; 4/14/03 2 ;;1.0;TEXT INTEGRATION UTILITIES;**100,109,162,222**;Jun 20, 1997 3 ; 4/12/01 Moved signature modules to new rtn TIUSRVR3 4 LOADREC(TIUDA,TIUL,TIUGDATA,TIUGWHOL,ACTION) ; Load ^TMP 5 ;Requires TIUDA, array TIUL, TIUGDATA 6 ;optional TIUGWHOL = 1 if we're mid-load for browse, and we're already 7 ; loading the whole note after the original entry, 8 ; so DON'T load the whole note again. 9 N TIUKID,TIUDADT,TIUI,CANSEE 10 N TIUPARNT,TIUPNAME,TIUPDATE 11 N TIUGPRNT,TIUGPNM,TIUGPDT,TIUPDATA,TIUHASKD 12 S ACTION=$G(ACTION,"VIEW") 13 ; ---- If user cannot view, say so and quit: ---- 14 ; TIU*1*100 15 S CANSEE=$S(+$$ISCOMP^TIUSRVR1(TIUDA)>0:1,1:$$CANDO^TIULP(+TIUDA,ACTION)) 16 I +CANSEE'>0 D Q 17 . S TIUL=TIUL+1,@TIUARR@(TIUL)=$P(CANSEE,U,2) 18 ; ---- Load text of TIUDA: ---- 19 S TIUI=0 20 F S TIUI=$O(^TIU(8925,+TIUDA,"TEXT",TIUI)) Q:+TIUI'>0 D 21 . S TIUL=TIUL+1,@TIUARR@(TIUL)=$G(^TIU(8925,+TIUDA,"TEXT",+TIUI,0)) 22 ; ---- if TIUDA is a COMPONENT, QUIT 23 Q:+$$ISCOMP^TIUSRVR1(TIUDA) 24 ; ---- If TIUDA **IS** an addendum, load addm signature, 25 ; load original document, quit: ---- 26 I +$$ISADDNDM^TIULC1(+TIUDA) D Q 27 . N TIULINE,TIUPARNT S $P(TIULINE,"=",79)="" 28 . D LOADSIG^TIUSRVR3(TIUDA,.TIUL) 29 . S TIUL=TIUL+1,@TIUARR@(TIUL)="" 30 . S TIUL=TIUL+1,@TIUARR@(TIUL)=TIULINE 31 . S TIUL=TIUL+1,@TIUARR@(TIUL)="" 32 . S TIUPARNT=+$P(^TIU(8925,+TIUDA,0),U,6) 33 . S TIUPNAME=$$PNAME^TIULC1(+^TIU(8925,TIUPARNT,0)) 34 . S TIUPDATE=+$G(^TIU(8925,TIUPARNT,13)) 35 . S TIUPDATE=$$DATE^TIULS(TIUPDATE,"MM/DD/YY") 36 . S TIUPDATA=$$IDDATA^TIURECL1(TIUPARNT) 37 . S TIUHASKD=$P(TIUPDATA,U,2),TIUGPRNT=+$P(TIUPDATA,U,3) 38 . S TIUL=+$G(TIUL)+1 39 . I TIUHASKD D 40 . . S @TIUARR@(TIUL)=" --- Original Addended Interdisciplinary Entry ---" 41 . I TIUGPRNT D 42 . . S @TIUARR@(TIUL)=" --- Original Addended Interdisciplinary Entry ---" 43 . . S TIUGPNM=$$PNAME^TIULC1(+^TIU(8925,TIUGPRNT,0)) 44 . . S TIUGPDT=+$G(^TIU(8925,TIUGPRNT,13)) 45 . . S TIUGPDT=$$DATE^TIULS(TIUGPDT,"MM/DD/YY") 46 . I 'TIUHASKD,'TIUGPRNT S @TIUARR@(TIUL)=" --- Original Document ---" 47 . S TIUL=+$G(TIUL)+1,@TIUARR@(TIUL)="" 48 . S TIUL=+$G(TIUL)+1 49 . I TIUHASKD D 50 . . S @TIUARR@(TIUL)=" << Addended Interdisciplinary Entry >>" 51 . . S TIUL=+$G(TIUL)+1 52 . . S @TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" 53 . I TIUGPRNT D 54 . . S @TIUARR@(TIUL)=" << Interdisciplinary Note >>" 55 . . S TIUL=+$G(TIUL)+1 56 . . S @TIUARR@(TIUL)=TIUGPDT_" "_TIUGPNM 57 . . S TIUL=+$G(TIUL)+1 58 . . S @TIUARR@(TIUL)=" << Addended Interdisciplinary Entry >>" 59 . . S TIUL=+$G(TIUL)+1,@TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" 60 . I 'TIUHASKD,'TIUGPRNT D 61 . . S @TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" 62 . D LOADREC(TIUPARNT,.TIUL,TIUGDATA) 63 ; ---- Load components of TIUDA: ---- 64 S TIUKID=0 65 F S TIUKID=$O(^TIU(8925,"DAD",+TIUDA,TIUKID)) Q:+TIUKID'>0 D 66 . I +$$ISADDNDM^TIULC1(TIUKID)'>0 D LOADREC(TIUKID,.TIUL,$G(TIUGDATA)) 67 ; ---- Load signature of TIUDA if TIUDA is not addm 68 ; or comp: ---- 69 ; *222 don't display sig info. for FORM LETTERS 70 I '+$$MEMBEROF^TIUPR222(+$G(^TIU(8925,+TIUDA,0)),"FORM LETTERS") D 71 . I '$$ISCOMP^TIUSRVR1(TIUDA) D LOADSIG^TIUSRVR3(TIUDA,.TIUL) 72 ; ---- Load addenda of TIUDA: ---- 73 S TIUKID=0 74 F S TIUKID=$O(^TIU(8925,"DAD",+TIUDA,TIUKID)) Q:+TIUKID'>0 D 75 . ; If acting on an addendum, don't show it again. 76 . I +TIUKID=+$G(^TMP("TIU FOCUS",$J)) Q 77 . I +$$ISADDNDM^TIULC1(TIUKID) D LOADADD(TIUKID,.TIUL) 78 N IDDAD 79 S IDDAD=+$P(TIUGDATA,U,3) 80 ; ---- If Browsed Record is an ID Note, & this cycle has 81 ; just loaded the parent entry, then load ID kids 82 ; and quit: **100** ---- 83 I $P(TIUGDATA,U,2),TIUDA=+TIUGDATA D LOADKIDS(TIUDA,.TIUL,TIUGDATA) Q 84 ; ---- If Browsed Record is an ID Entry, & this cycle hasn't begun 85 ; loading the whole note, then load the whole ID Note after 86 ; the browsed entry and quit: ---- 87 I IDDAD,'$G(TIUGWHOL) D Q 88 . S TIUGWHOL=1 89 . N TIULINE S $P(TIULINE,"=",79)="" 90 . S TIUL=TIUL+1,@TIUARR@(TIUL)="" 91 . S TIUL=TIUL+1,@TIUARR@(TIUL)=TIULINE 92 . S TIUL=TIUL+1,@TIUARR@(TIUL)="" 93 . S TIUL=TIUL+1,@TIUARR@(TIUL)=" --- Interdisciplinary Note ---" 94 . S TIUL=TIUL+1,@TIUARR@(TIUL)="" 95 . D LOADID(IDDAD,.TIUL,TIUGDATA,TIUGWHOL) 96 ; ---- If Browsed Record is an ID Entry, & this cycle has begun 97 ; loading the whole ID note, and is currently loading the first 98 ; entry of the whole note, then load kids and quit: ---- 99 I IDDAD,$G(TIUGWHOL),TIUDA=IDDAD D LOADKIDS(TIUDA,.TIUL,TIUGDATA,TIUGWHOL) K TIUGWHOL 100 Q 101 ; 102 LOADKIDS(TIUDA,TIUL,TIUGDATA,TIUGWHOL) ; Load ID kids of TIUDA 103 ; Requires TIUDA, array TIUL, TIUGDATA 104 N TIUK,PRMSORT,KIDDA,TIUD0,TIUD21 105 I $G(^TMP("TIUR",$J,"IDDATA",TIUDA)) S PRMSORT=$P(^TMP("TIUR",$J,"IDDATA",TIUDA),U,4) 106 E S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD21=$G(^TIU(8925,TIUDA,21)),PRMSORT=$P($$IDDATA^TIURECL1(TIUDA,TIUD0,TIUD21),U,4) 107 D GETIDKID^TIURECL2(TIUDA,PRMSORT) ; sets array ^TMP("TIUIDKID",$J, 108 S TIUK=0 109 F S TIUK=$O(^TMP("TIUIDKID",$J,TIUDA,TIUK)) Q:+TIUK'>0 D 110 . S KIDDA=^TMP("TIUIDKID",$J,TIUDA,TIUK) 111 . D LOADID(KIDDA,.TIUL,TIUGDATA,$G(TIUGWHOL)) 112 K ^TMP("TIUIDKID",$J) 113 Q 114 ; 115 LOADID(TIUDA,TIUL,TIUGDATA,TIUWHOL) ; Load ID note for browse 116 N TIUREC,TIU 117 I '$D(^TIU(8925,+TIUDA,0)) Q 118 ; ---- If ID Kid has focus, don't show it again ---- 119 ; I TIUDA=+$G(^TMP("TIU FOCUS",$J)) Q 120 S TIUL=TIUL+1,@TIUARR@(TIUL)="" 121 D GETTIU^TIULD(.TIU,+TIUDA) 122 D INQUIRE(TIUDA,.TIUREC) 123 ; ---- Load info missing from header since this is ID note entry: ---- 124 ; ---- Load dictation, transcription data, etc.: ---- 125 D LOADTOP^TIUSRVR1(.TIUREC,TIUDA,.TIUL,$G(TIUGDATA)) 126 ; ---- Load the remainder of the record: ---- 127 D LOADREC(TIUDA,.TIUL,$G(TIUGDATA),$G(TIUWHOL)) 128 Q 129 ; 130 INQUIRE(TIUDA,TIUREC,TIUCPF) ; Inquire to document TIUDA and set TIUREC 131 N DA,DIC,DIQ,DR 132 S DA=TIUDA,DIC=8925,DIQ="TIUREC(" 133 S DR=".01;.02;.05;.09;1201;1202;1208;1209;1301;1307;1501;1502;1505;1506" 134 ;If the document is a member of the Clinical Procedures Class, include the 135 ;Procedure Summary Code field and the Date/Time Performed field 136 I $G(TIUCPF) S DR=DR_";70201;70202" 137 D EN^DIQ1 138 Q 139 LOADADD(TIUDADD,TIUL) ; Load addenda 140 N TIUDAUTH,TIUDATT,TIUJ,TIUSIG,TIUCSIG,TIUVIEW 141 S TIUL=TIUL+1,@TIUARR@(TIUL)="" 142 S TIUDADT=$$DATE^TIULS($P($G(^TIU(8925,+TIUDADD,13)),U),"MM/DD/CCYY") 143 S TIUL=TIUL+1,@TIUARR@(TIUL)=TIUDADT_" ADDENDUM"_" STATUS: "_$$STATUS^TIULF(TIUDADD) ;P162 144 S TIUVIEW=$$CANDO^TIULP(+TIUDADD,"VIEW") 145 I '+TIUVIEW D Q 146 . S TIUL=TIUL+1,@TIUARR@(TIUL)=$P(TIUVIEW,U,2) 147 S TIUJ=0 148 F S TIUJ=$O(^TIU(8925,+TIUDADD,"TEXT",TIUJ)) Q:+TIUJ'>0 D 149 . S TIUL=TIUL+1,@TIUARR@(TIUL)=$G(^TIU(8925,+TIUDADD,"TEXT",TIUJ,0)) 150 D LOADSIG^TIUSRVR3(TIUDADD,.TIUL) 151 Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC.m
r613 r623 1 TIUXRC ; DRIVER FOR COMPILED XREFS FOR FILE #8925 ; 1 1/08/091 TIUXRC ; DRIVER FOR COMPILED XREFS FOR FILE #8925 ; 12/25/06 2 2 ; 3 3 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 … … 7 7 DI S DIKM1=0,DIKUM=0,DA(0)="",DV=0 F S DV=$O(DA(DV)) Q:DV'>0 S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV) 8 8 S:DV="" DV=-1 S DH(1)=8925,DIKUP=DA 9 I $D(DIKKS) D:DIKZ1=DH(1) ^TIUXRC1 S DA=DIKUP D:DIKZ1=DH(1) ^TIUXRC 3D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q9 I $D(DIKKS) D:DIKZ1=DH(1) ^TIUXRC1 S DA=DIKUP D:DIKZ1=DH(1) ^TIUXRC4 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q 10 10 I $D(DIKIL) D:DIKZ1=DH(1) ^TIUXRC1 S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q 11 I $D(DIKST) D:DIKZ1=DH(1) ^TIUXRC 3D:DIKZ1'=DH(1) SET D DA Q11 I $D(DIKST) D:DIKZ1=DH(1) ^TIUXRC4 D:DIKZ1'=DH(1) SET D DA Q 12 12 I $D(DIKSAT) D SET1 D DA Q 13 13 Q … … 17 17 S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK 18 18 C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT K DCNT L:$D(DIKLK) -@DIKLK Q 19 S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^TIUXRC 3D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C19 S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^TIUXRC4 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C 20 20 Q 21 21 C1(A) Q:$P($G(@(DIK_"A,0)")),U)]"" A -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC1.m
r613 r623 1 TIUXRC1 ; COMPILED XREF FOR FILE #8925 ; 1 1/08/091 TIUXRC1 ; COMPILED XREF FOR FILE #8925 ; 12/25/06 2 2 ; 3 3 S DIKZK=2 … … 117 117 S DIKZ(13)=$G(^TIU(8925,DA,13)) 118 118 S X=$P(DIKZ(13),U,1) 119 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)120 S X=$P(DIKZ(13),U,1)121 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)122 S X=$P(DIKZ(13),U,1)123 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)124 S X=$P(DIKZ(13),U,1)125 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)126 S X=$P(DIKZ(13),U,1)127 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)128 S X=$P(DIKZ(13),U,1)129 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)130 S X=$P(DIKZ(13),U,1)131 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA)132 S X=$P(DIKZ(13),U,1)133 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)134 S X=$P(DIKZ(13),U,1)135 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA)136 119 END G ^TIUXRC2 -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC2.m
r613 r623 1 TIUXRC2 ; COMPILED XREF FOR FILE #8925 ; 1 1/08/091 TIUXRC2 ; COMPILED XREF FOR FILE #8925 ; 12/25/06 2 2 ; 3 END G ^TIUXRC2 3 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 4 S X=$P(DIKZ(13),U,1) 5 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 6 S X=$P(DIKZ(13),U,1) 7 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 8 S X=$P(DIKZ(13),U,1) 9 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 10 S X=$P(DIKZ(13),U,1) 11 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 12 S X=$P(DIKZ(13),U,1) 13 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 14 S X=$P(DIKZ(13),U,1) 15 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 16 S X=$P(DIKZ(13),U,1) 17 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) 18 S X=$P(DIKZ(13),U,1) 19 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 20 S X=$P(DIKZ(13),U,1) 4 21 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) 5 22 S X=$P(DIKZ(13),U,1) … … 89 106 I X'="" I $L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) 90 107 S X=$P(DIKZ(0),U,1) 91 I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 92 S X=$P(DIKZ(0),U,1) 93 I X'="" I $L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) K ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA) 94 S X=$P(DIKZ(0),U,1) 95 I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 96 S X=$P(DIKZ(0),U,1) 97 I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) 98 S X=$P(DIKZ(0),U,1) 99 I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA) 100 S X=$P(DIKZ(0),U,1) 101 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA) 102 S X=$P(DIKZ(0),U,1) 103 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA) 104 S X=$P(DIKZ(0),U,1) 105 I X'="" D KACLPT^TIUDD01(.01,X) 106 S X=$P(DIKZ(0),U,1) 107 I X'="" D KACLAU^TIUDD01(.01,X),KACLAU1^TIUDD01(.01,X) 108 S X=$P(DIKZ(0),U,1) 109 I X'="" D KACLEC^TIUDD01(.01,X) 110 S X=$P(DIKZ(0),U,1) 111 I X'="" D KACLSB^TIUDD01(.01,X) 112 S X=$P(DIKZ(0),U,1) 113 I X'="" D KAPTLD^TIUDD01(.01,X) 114 CR1 S DIXR=247 115 K X 116 S X(1)=$P(DIKZ(12),U,12) 117 S X(2)=$P(DIKZ(0),U,1) 118 S X(3)=$P(DIKZ(0),U,5) 119 S X=$P(DIKZ(13),U,1) 120 I $G(X)]"" S X=9999999-X 121 S:$D(X)#2 X(4)=X 122 S X=$G(X(1)) 123 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D 124 . K X1,X2 M X1=X,X2=X 125 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))="" 126 . K ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA) 127 CR2 S DIXR=413 128 K X 129 S DIKZ(12)=$G(^TIU(8925,DA,12)) 130 S X(1)=$P(DIKZ(12),U,7) 131 S X=$G(X(1)) 132 I $G(X(1))]"" D 133 . K X1,X2 M X1=X,X2=X 134 . S:$D(DIKIL) (X2,X2(1))="" 135 . K ^TIU(8925,"VS",X,DA) 136 CR3 K X 137 END Q 108 END G ^TIUXRC3 -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC3.m
r613 r623 1 TIUXRC3 ; COMPILED XREF FOR FILE #8925 ; 1 1/08/091 TIUXRC3 ; COMPILED XREF FOR FILE #8925 ; 12/25/06 2 2 ; 3 S DIKZK=1 4 S DIKZ(0)=$G(^TIU(8925,DA,0)) 3 I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 5 4 S X=$P(DIKZ(0),U,1) 6 I X'="" S ^TIU(8925,"B",$E(X,1,30),DA)=""5 I X'="" I $L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) K ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA) 7 6 S X=$P(DIKZ(0),U,1) 8 I X'="" I +$P( ^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)=""7 I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) 9 8 S X=$P(DIKZ(0),U,1) 10 I X'="" I +$P($G(^TIU(8925,+DA,1 2)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P($G(^TIU(8925,+DA,12)),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""9 I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) 11 10 S X=$P(DIKZ(0),U,1) 12 I X'="" I +$P( $G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P($G(^TIU(8925,+DA,12)),U,8),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""11 I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA) 13 12 S X=$P(DIKZ(0),U,1) 14 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,3),+DA)=""13 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA) 15 14 S X=$P(DIKZ(0),U,1) 16 I X'="" I +$P( $G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P($G(^TIU(8925,+DA,14)),U,2),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""15 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA) 17 16 S X=$P(DIKZ(0),U,1) 18 I X'="" I +$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P($G(^TIU(8925,+DA,13)),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""17 I X'="" D KACLPT^TIUDD01(.01,X) 19 18 S X=$P(DIKZ(0),U,1) 20 I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""19 I X'="" D KACLAU^TIUDD01(.01,X),KACLAU1^TIUDD01(.01,X) 21 20 S X=$P(DIKZ(0),U,1) 22 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U,2)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+$P(^(0),U,2),+X,(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),DA)=""21 I X'="" D KACLEC^TIUDD01(.01,X) 23 22 S X=$P(DIKZ(0),U,1) 24 I X'="" I $L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA)23 I X'="" D KACLSB^TIUDD01(.01,X) 25 24 S X=$P(DIKZ(0),U,1) 26 I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 27 S X=$P(DIKZ(0),U,1) 28 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U,2),(+$P($G(^(0)),U,3)>0) S ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA)="" 29 S X=$P(DIKZ(0),U,1) 30 I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 31 S X=$P(DIKZ(0),U,1) 32 I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) 33 S X=$P(DIKZ(0),U,1) 34 I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 35 S X=$P(DIKZ(0),U,1) 36 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 37 S X=$P(DIKZ(0),U,1) 38 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 39 S X=$P(DIKZ(0),U,1) 40 I X'="" D SACLPT^TIUDD0(.01,X) 41 S X=$P(DIKZ(0),U,1) 42 I X'="" D SACLAU^TIUDD0(.01,X),SACLAU1^TIUDD0(.01,X) 43 S X=$P(DIKZ(0),U,1) 44 I X'="" D SACLEC^TIUDD0(.01,X) 45 S X=$P(DIKZ(0),U,1) 46 I X'="" D SACLSB^TIUDD0(.01,X) 47 S X=$P(DIKZ(0),U,1) 48 I X'="" D SAPTLD^TIUDD0(.01,X) 49 S X=$P(DIKZ(0),U,2) 50 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)="" 51 S X=$P(DIKZ(0),U,2) 52 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 53 S X=$P(DIKZ(0),U,2) 54 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)="" 55 S X=$P(DIKZ(0),U,2) 56 I X'="" S ^TIU(8925,"C",$E(X,1,30),DA)="" 57 S X=$P(DIKZ(0),U,2) 58 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)="" 59 S X=$P(DIKZ(0),U,2) 60 I X'="" I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" 61 S X=$P(DIKZ(0),U,2) 62 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 63 S X=$P(DIKZ(0),U,2) 64 I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 65 S X=$P(DIKZ(0),U,2) 66 I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 67 S X=$P(DIKZ(0),U,2) 68 I X'="" D SACLPT^TIUDD0(.02,X) 69 S X=$P(DIKZ(0),U,2) 70 I X'="" D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X) 71 S X=$P(DIKZ(0),U,2) 72 I X'="" D SACLEC^TIUDD0(.02,X) 73 S X=$P(DIKZ(0),U,2) 74 I X'="" D SACLSB^TIUDD0(.02,X) 75 S X=$P(DIKZ(0),U,2) 76 I X'="" D SAPTLD^TIUDD0(.02,X) 77 S X=$P(DIKZ(0),U,3) 78 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)="" 79 S X=$P(DIKZ(0),U,3) 80 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AE",+$P(^TIU(8925,+DA,0),U,2),(9999999-$P(+$G(^AUPNVSIT(+X,0)),".")),+^TIU(8925,+DA,0),+DA)="" 81 S X=$P(DIKZ(0),U,3) 82 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,2) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,+DA)="" 83 S X=$P(DIKZ(0),U,3) 84 I X'="" D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT 85 S X=$P(DIKZ(0),U,3) 86 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 87 S X=$P(DIKZ(0),U,3) 88 I X'="" S ^TIU(8925,"V",$E(X,1,30),DA)="" 89 S X=$P(DIKZ(0),U,3) 90 I X'="" D 91 .N DIK,DIV,DIU,DIN 92 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^TIU(8925,D0,150)):^(150),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(8925,.03,1,7,1.1) X ^DD(8925,.03,1,7,1.4) 93 S X=$P(DIKZ(0),U,3) 94 I X'="" D SAPTLD^TIUDD0(.03,X) 95 S DIKZ(0)=$G(^TIU(8925,DA,0)) 96 S X=$P(DIKZ(0),U,4) 97 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 98 S X=$P(DIKZ(0),U,5) 99 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+X,(9999999-+$P(^TIU(8925,+DA,13),U)),+DA)="" 100 S X=$P(DIKZ(0),U,5) 101 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" 102 S X=$P(DIKZ(0),U,5) 103 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" 104 S X=$P(DIKZ(0),U,5) 105 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ATC",+$P($G(^TIU(8925,+DA,13)),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 106 S X=$P(DIKZ(0),U,5) 107 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ATS",+$P($G(^TIU(8925,+DA,14)),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 108 S X=$P(DIKZ(0),U,5) 109 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" 110 S X=$P(DIKZ(0),U,5) 111 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),$L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+X,(9999999-+$G(^TIU(8925,+DA,13))),DA) 112 S X=$P(DIKZ(0),U,5) 113 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 114 S X=$P(DIKZ(0),U,5) 115 I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U) S ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 116 S X=$P(DIKZ(0),U,5) 117 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+X,(9999999-+$G(^TIU(8925,+DA,13))),DA) 118 S X=$P(DIKZ(0),U,5) 119 END G ^TIUXRC4 25 I X'="" D KAPTLD^TIUDD01(.01,X) 26 CR1 S DIXR=247 27 K X 28 S X(1)=$P(DIKZ(12),U,12) 29 S X(2)=$P(DIKZ(0),U,1) 30 S X(3)=$P(DIKZ(0),U,5) 31 S X=$P(DIKZ(13),U,1) 32 I $G(X)]"" S X=9999999-X 33 S:$D(X)#2 X(4)=X 34 S X=$G(X(1)) 35 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D 36 . K X1,X2 M X1=X,X2=X 37 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))="" 38 . K ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA) 39 CR2 S DIXR=413 40 K X 41 S DIKZ(12)=$G(^TIU(8925,DA,12)) 42 S X(1)=$P(DIKZ(12),U,7) 43 S X=$G(X(1)) 44 I $G(X(1))]"" D 45 . K X1,X2 M X1=X,X2=X 46 . S:$D(DIKIL) (X2,X2(1))="" 47 . K ^TIU(8925,"VS",X,DA) 48 CR3 K X 49 END Q -
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m
r613 r623 1 TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 1 1/08/091 TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 12/25/06 2 2 ; 3 END G ^TIUXRC4 4 S X=$P(DIKZ(0),U,5) 5 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,4) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+X,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 6 S X=$P(DIKZ(0),U,5) 7 I X'="" D SACLPT^TIUDD0(.05,X) 8 S X=$P(DIKZ(0),U,5) 9 I X'="" D SACLEC^TIUDD0(.05,X) 10 S X=$P(DIKZ(0),U,5) 11 I X'="" D SACLAU^TIUDD0(.05,X),SACLAU1^TIUDD0(.05,X) 12 S X=$P(DIKZ(0),U,6) 13 I X'="" S ^TIU(8925,"DAD",$E(X,1,30),DA)="" 14 S X=$P(DIKZ(0),U,7) 15 I X'="" D SAPTLD^TIUDD0(.07,X) 16 S X=$P(DIKZ(0),U,12) 17 I X'="" S ^TIU(8925,"FIX",$E(X,1,30),DA)="" 18 S X=$P(DIKZ(0),U,13) 19 I X'="" D SAPTLD^TIUDD0(.13,X) 20 S DIKZ(12)=$G(^TIU(8925,DA,12)) 21 S X=$P(DIKZ(12),U,1) 22 I X'="" S ^TIU(8925,"F",$E(X,1,30),DA)="" 23 S X=$P(DIKZ(12),U,2) 24 I X'="" S ^TIU(8925,"CA",$E(X,1,30),DA)="" 25 S X=$P(DIKZ(12),U,2) 26 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" 27 S X=$P(DIKZ(12),U,2) 28 I X'="" I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" 29 S X=$P(DIKZ(12),U,2) 30 I X'="" D SACLAU^TIUDD0(1202,X) 31 S X=$P(DIKZ(12),U,2) 3 S DIKZK=1 4 S DIKZ(0)=$G(^TIU(8925,DA,0)) 5 S X=$P(DIKZ(0),U,1) 6 I X'="" S ^TIU(8925,"B",$E(X,1,30),DA)="" 7 S X=$P(DIKZ(0),U,1) 8 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 9 S X=$P(DIKZ(0),U,1) 10 I X'="" I +$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P($G(^TIU(8925,+DA,12)),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 11 S X=$P(DIKZ(0),U,1) 12 I X'="" I +$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P($G(^TIU(8925,+DA,12)),U,8),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 13 S X=$P(DIKZ(0),U,1) 14 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,3),+DA)="" 15 S X=$P(DIKZ(0),U,1) 16 I X'="" I +$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P($G(^TIU(8925,+DA,14)),U,2),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 17 S X=$P(DIKZ(0),U,1) 18 I X'="" I +$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P($G(^TIU(8925,+DA,13)),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 19 S X=$P(DIKZ(0),U,1) 20 I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 21 S X=$P(DIKZ(0),U,1) 22 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U,2)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+$P(^(0),U,2),+X,(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),DA)="" 23 S X=$P(DIKZ(0),U,1) 24 I X'="" I $L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) 25 S X=$P(DIKZ(0),U,1) 26 I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 27 S X=$P(DIKZ(0),U,1) 28 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U,2),(+$P($G(^(0)),U,3)>0) S ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA)="" 29 S X=$P(DIKZ(0),U,1) 30 I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 31 S X=$P(DIKZ(0),U,1) 32 I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) 33 S X=$P(DIKZ(0),U,1) 34 I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 35 S X=$P(DIKZ(0),U,1) 36 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 37 S X=$P(DIKZ(0),U,1) 38 I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 39 S X=$P(DIKZ(0),U,1) 40 I X'="" D SACLPT^TIUDD0(.01,X) 41 S X=$P(DIKZ(0),U,1) 42 I X'="" D SACLAU^TIUDD0(.01,X),SACLAU1^TIUDD0(.01,X) 43 S X=$P(DIKZ(0),U,1) 44 I X'="" D SACLEC^TIUDD0(.01,X) 45 S X=$P(DIKZ(0),U,1) 46 I X'="" D SACLSB^TIUDD0(.01,X) 47 S X=$P(DIKZ(0),U,1) 48 I X'="" D SAPTLD^TIUDD0(.01,X) 49 S X=$P(DIKZ(0),U,2) 50 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)="" 51 S X=$P(DIKZ(0),U,2) 52 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 53 S X=$P(DIKZ(0),U,2) 54 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)="" 55 S X=$P(DIKZ(0),U,2) 56 I X'="" S ^TIU(8925,"C",$E(X,1,30),DA)="" 57 S X=$P(DIKZ(0),U,2) 58 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)="" 59 S X=$P(DIKZ(0),U,2) 60 I X'="" I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" 61 S X=$P(DIKZ(0),U,2) 62 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 63 S X=$P(DIKZ(0),U,2) 64 I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 65 S X=$P(DIKZ(0),U,2) 66 I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 67 S X=$P(DIKZ(0),U,2) 68 I X'="" D SACLPT^TIUDD0(.02,X) 69 S X=$P(DIKZ(0),U,2) 70 I X'="" D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X) 71 S X=$P(DIKZ(0),U,2) 72 I X'="" D SACLEC^TIUDD0(.02,X) 73 S X=$P(DIKZ(0),U,2) 74 I X'="" D SACLSB^TIUDD0(.02,X) 75 S X=$P(DIKZ(0),U,2) 76 I X'="" D SAPTLD^TIUDD0(.02,X) 77 S X=$P(DIKZ(0),U,3) 78 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)="" 79 S X=$P(DIKZ(0),U,3) 80 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AE",+$P(^TIU(8925,+DA,0),U,2),(9999999-$P(+$G(^AUPNVSIT(+X,0)),".")),+^TIU(8925,+DA,0),+DA)="" 81 S X=$P(DIKZ(0),U,3) 82 I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,2) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,+DA)="" 83 S X=$P(DIKZ(0),U,3) 84 I X'="" D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT 85 S X=$P(DIKZ(0),U,3) 86 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 87 S X=$P(DIKZ(0),U,3) 88 I X'="" S ^TIU(8925,"V",$E(X,1,30),DA)="" 89 S X=$P(DIKZ(0),U,3) 32 90 I X'="" D 33 91 .N DIK,DIV,DIU,DIN 34 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4) 35 S DIKZ(12)=$G(^TIU(8925,DA,12)) 36 S X=$P(DIKZ(12),U,5) 37 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 38 S X=$P(DIKZ(12),U,5) 39 I X'="" I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" 40 S X=$P(DIKZ(12),U,7) 41 I X'="" D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT 42 S X=$P(DIKZ(12),U,8) 43 I X'="" S ^TIU(8925,"CS",$E(X,1,30),DA)="" 44 S X=$P(DIKZ(12),U,8) 45 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 46 S X=$P(DIKZ(12),U,8) 47 I X'="" D SACLEC^TIUDD0(1208,X) 48 S X=$P(DIKZ(12),U,11) 49 I X'="" D SAPTLD^TIUDD0(1211,X) 50 S DIKZ(13)=$G(^TIU(8925,DA,13)) 51 S X=$P(DIKZ(13),U,1) 52 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 53 S X=$P(DIKZ(13),U,1) 54 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 55 S X=$P(DIKZ(13),U,1) 56 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 57 S X=$P(DIKZ(13),U,1) 58 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 59 S X=$P(DIKZ(13),U,1) 60 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 61 S X=$P(DIKZ(13),U,1) 62 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 63 S X=$P(DIKZ(13),U,1) 64 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 65 S X=$P(DIKZ(13),U,1) 66 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 67 S X=$P(DIKZ(13),U,1) 68 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) 69 S X=$P(DIKZ(13),U,1) 70 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" 71 S X=$P(DIKZ(13),U,1) 72 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" 73 S X=$P(DIKZ(13),U,1) 74 I X'="" S ^TIU(8925,"D",$E(X,1,30),DA)="" 75 S X=$P(DIKZ(13),U,1) 76 I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)="" 77 S X=$P(DIKZ(13),U,1) 78 I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)="" 79 S X=$P(DIKZ(13),U,1) 80 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" 81 S X=$P(DIKZ(13),U,1) 82 I X'="" D SACLPT^TIUDD0(1301,X) 83 S X=$P(DIKZ(13),U,1) 84 I X'="" D SACLAU^TIUDD0(1301,X),SACLAU1^TIUDD0(1301,X) 85 S X=$P(DIKZ(13),U,1) 86 I X'="" D SACLEC^TIUDD0(1301,X) 87 S X=$P(DIKZ(13),U,1) 88 I X'="" D SACLSB^TIUDD0(1301,X) 89 S X=$P(DIKZ(13),U,2) 90 I X'="" S ^TIU(8925,"TC",$E(X,1,30),DA)="" 91 S X=$P(DIKZ(13),U,2) 92 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 93 S X=$P(DIKZ(13),U,2) 94 I X'="" D SACLAU1^TIUDD0(1302,X) 95 S X=$P(DIKZ(13),U,4) 96 I X'="" S ^TIU(8925,"E",$E(X,1,30),DA)="" 97 S DIKZ(14)=$G(^TIU(8925,DA,14)) 98 S X=$P(DIKZ(14),U,2) 99 I X'="" S ^TIU(8925,"TS",$E(X,1,30),DA)="" 100 S X=$P(DIKZ(14),U,2) 101 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 102 S X=$P(DIKZ(14),U,4) 103 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" 104 S X=$P(DIKZ(14),U,4) 105 I X'="" S ^TIU(8925,"SVC",$E(X,1,30),DA)="" 106 S X=$P(DIKZ(14),U,5) 107 I X'="" S ^TIU(8925,"G",$E(X,1,30),DA)="" 108 S DIKZ(15)=$G(^TIU(8925,DA,15)) 109 S X=$P(DIKZ(15),U,1) 110 I X'="" I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,12)),U,5) S ^TIU(8925,"ALOCP",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+DA)="" 111 S X=$P(DIKZ(15),U,1) 112 I X'="" I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTP",+$P($G(^TIU(8925,+DA,0)),U,2),+X,+DA)="" 113 S X=$P(DIKZ(15),U,1) 114 I X'="" I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,12)),U,2) S ^TIU(8925,"AAUP",+$P($G(^TIU(8925,+DA,12)),U,2),+X,+DA)="" 115 S X=$P(DIKZ(15),U,1) 116 I X'="" D SACLPT^TIUDD0(1501,X) 117 S X=$P(DIKZ(15),U,1) 118 I X'="" D SACLEC^TIUDD0(1501,X) 119 S X=$P(DIKZ(15),U,1) 120 I X'="" D KACLAU^TIUDD01(1501,X),KACLAU1^TIUDD01(1501,X) 121 S X=$P(DIKZ(15),U,2) 122 I X'="" D SACLSB^TIUDD0(1502,X) 123 S X=$P(DIKZ(15),U,7) 124 I X'="" D KACLEC^TIUDD01(1507,X) 125 S X=$P(DIKZ(15),U,7) 126 I X'="" D SACLPT^TIUDD0(1507,X) 127 S DIKZ(17)=$G(^TIU(8925,DA,17)) 128 S X=$P(DIKZ(17),U,1) 129 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$P($G(^TIU(8925,+DA,13)),U) D ASUBS^TIUDD($G(X),+$G(^TIU(8925,+DA,0)),+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) 130 S DIKZ(21)=$G(^TIU(8925,DA,21)) 131 S X=$P(DIKZ(21),U,1) 132 I X'="" S ^TIU(8925,"GDAD",$E(X,1,30),DA)="" 133 S DIKZ(150)=$G(^TIU(8925,DA,150)) 134 S X=$P(DIKZ(150),U,1) 135 I X'="" S ^TIU(8925,"VID",$E(X,1,30),DA)="" 136 CR1 S DIXR=247 137 K X 138 S X(1)=$P(DIKZ(12),U,12) 92 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^TIU(8925,D0,150)):^(150),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(8925,.03,1,7,1.1) X ^DD(8925,.03,1,7,1.4) 93 S X=$P(DIKZ(0),U,3) 94 I X'="" D SAPTLD^TIUDD0(.03,X) 139 95 S DIKZ(0)=$G(^TIU(8925,DA,0)) 140 S X(2)=$P(DIKZ(0),U,1) 141 S X(3)=$P(DIKZ(0),U,5) 142 S X=$P(DIKZ(13),U,1) 143 I $G(X)]"" S X=9999999-X 144 S:$D(X)#2 X(4)=X 145 S X=$G(X(1)) 146 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D 147 . K X1,X2 M X1=X,X2=X 148 . S ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA)="" 149 CR2 S DIXR=413 150 K X 151 S DIKZ(12)=$G(^TIU(8925,DA,12)) 152 S X(1)=$P(DIKZ(12),U,7) 153 S X=$G(X(1)) 154 I $G(X(1))]"" D 155 . K X1,X2 M X1=X,X2=X 156 . S ^TIU(8925,"VS",X,DA)="" 157 CR3 K X 158 END Q 96 S X=$P(DIKZ(0),U,4) 97 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" 98 S X=$P(DIKZ(0),U,5) 99 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+X,(9999999-+$P(^TIU(8925,+DA,13),U)),+DA)="" 100 S X=$P(DIKZ(0),U,5) 101 END G ^TIUXRC5
Note:
See TracChangeset
for help on using the changeset viewer.
