LEX2I03P ;IHS/OIT/FCJ - LEXICON UTILITY PATCH 1003 ; 14 Mar 2012 12:44 PM
;;2.0;LEXICON UTILITY;**1003**;Sep 23, 1996;Build 10
;=================================================================
;Original routine from LEX2I02P
;
POST ;EP FROM KERNAL
S %="HIST^LEX2I03P"
I $$NEWCP^XPDUTL("POS4-"_%,%)
S %="UNCD^LEX2I03P"
I $$NEWCP^XPDUTL("POS5-"_%,%)
S %="MAIL^LEX2I03P"
I $$NEWCP^XPDUTL("POS6-"_%,%)
;
Q
MAIL ;
D BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("LEX1003",$J)
D RSLT(" --- LEX v 2.0 Patch 1003, have been installed into this namespace ---")
F %=1:1 D RSLT($P($T(GREET+%),";",3)) Q:$P($T(GREET+%+1),";",3)="###"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% D RSLT(^(%,0))
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""LEX1003"",$J,",XMY(1)="",XMY(DUZ)=""
F %="LEXZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("LEX1003",$J)
D MES^XPDUTL("END Delivering MailMan message to select users.")
Q
;
RSLT(%) S ^(0)=$G(^TMP("LEX1003",$J,0))+1,^(^(0))=%
Q
;
SINGLE(K) ; Get holders of a key
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
;
GREET ;;To add to mail message.
;;
;;Routines and/or data dictionaries on your RPMS system have been updated.
;;
;;You are receiving this message because of the RPMS
;;security keys that you hold. This is for your information.
;;Do not respond to this message.
;;
;;Questions about this patch may be directed to
;;the ITSC Support Center, at 505-248-4371,
;;refer to patch "LEX*2.1*1003".
;;
;;###;NOTE: This line end of text.
;
HIST ;PATCH HISTORY UPDATE
D MES^XPDUTL("Begin adding patches to package file.")
S DDLM=";;",DLM="|",TAG="LEX"
S PKGNM="LEXICON UTILITY"
I '$D(^DIC(9.4,"B",PKGNM)) D MES^XPDUTL("Problem with package name.") Q
S PKGIEN=$O(^DIC(9.4,"B",PKGNM,0))
F I=1:1 D Q:TEXT["END"
.S TEXT=$T(@TAG+I) Q:TEXT["END"
.S DATA=$P(TEXT,DDLM,2)
.S VERSION=$P(DATA,DLM,2),PATCH=$P(DATA,DLM,3)
.S VSB=$O(^DIC(9.4,PKGIEN,22,"B",VERSION,0))
.Q:'VSB
.K FDA
.; Do not update if the patch is already in the patch history
.Q:$D(^DIC(9.4,PKGIEN,22,VSB,"PAH","B",PATCH))
.S FDA(9.4901,"+1,"_VSB_","_PKGIEN_",",.01)=$G(PATCH)
.S FDA(9.4901,"+1,"_VSB_","_PKGIEN_",",.02)=DT
.S FDA(9.4901,"+1,"_VSB_","_PKGIEN_",",.03)=DUZ
.D UPDATE^DIE(,"FDA")
.D:$G(DIERR)'="" MES^XPDUTL("Error adding patch "_PATCH_" to package file.")
D MES^XPDUTL("Completed adding patches to package file.")
Q
UNCD ;ADD UNCODED DX CODES
Q:$D(^LEX(757.02,"CODE",".9999 "))
F UNCD=".9999","ZZZ.999" D
.S DIC="^LEX(757.02,",X="Uncoded Diagnosis",DIC(0)="LI",DLAYGO=757.02,DIADD=1
.S CLS=$S(UNCD=".9999":1,1:30)
.S DIC("DR")="1////"_UNCD_";2////"_CLS_";3////155739;4////0;6////0"
.D ^DIC I +Y<0 W !,"Uable to add the uncoded DX ",UNCD Q
.S DA(1)=+Y,DIC="^LEX(757.02,"_DA(1)_",4,",DIC(0)="LI"
.S ^LEX(757.02,DA(1),4,0)="^757.28DA^0^0"
.I UNCD=".9999" D Q
..S DA=1,X=2781001,DIC("DR")="1////1" D ^DIC I +Y<0 W !,"Uable to add the uncoded DX ",UNCD," active date." Q
..S DA=2,X=3141001,DIC("DR")="1////0" D ^DIC I +Y<0 W !,"Uable to add the uncoded DX ",UNCD," inactive date." Q
.S DA=1,X=3141001,DIC("DR")="1////1" D ^DIC I +Y<0 W !,"Uable to add the uncoded DX ",UNCD," active date."
K UNCD,CLS,DIADD,DIC,DA
Q
;;;;FORMAT - Package name|Version|Patch|Sequence
LEX ;
;;LEXICON UTILITY|2.0|79 SEQ #72
;;LEXICON UTILITY|2.0|82 SEQ #74
;;LEXICON UTILITY|2.0|83 SEQ #75
;;LEXICON UTILITY|2.0|84 SEQ #76
;;LEXICON UTILITY|2.0|51 SEQ #77
;;LEXICON UTILITY|2.0|58 SEQ #78
;;LEXICON UTILITY|2.0|89 SEQ #79
;;LEXICON UTILITY|2.0|90 SEQ #80
;;LEXICON UTILITY|2.0|91 SEQ #81
;;LEXICON UTILITY|2.0|93 SEQ #82
;;LEXICON UTILITY|2.0|94 SEQ #83
;;LEXICON UTILITY|2.0|80
;END
LEX2I03P ;IHS/OIT/FCJ - LEXICON UTILITY PATCH 1003 ; 14 Mar 2012 12:44 PM
+1 ;;2.0;LEXICON UTILITY;**1003**;Sep 23, 1996;Build 10
+2 ;=================================================================
+3 ;Original routine from LEX2I02P
+4 ;
POST ;EP FROM KERNAL
+1 SET %="HIST^LEX2I03P"
+2 IF $$NEWCP^XPDUTL("POS4-"_%,%)
+3 SET %="UNCD^LEX2I03P"
+4 IF $$NEWCP^XPDUTL("POS5-"_%,%)
+5 SET %="MAIL^LEX2I03P"
+6 IF $$NEWCP^XPDUTL("POS6-"_%,%)
+7 ;
+8 QUIT
MAIL ;
+1 DO BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
+2 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+3 KILL ^TMP("LEX1003",$JOB)
+4 DO RSLT(" --- LEX v 2.0 Patch 1003, have been installed into this namespace ---")
+5 FOR %=1:1
DO RSLT($PIECE($TEXT(GREET+%),";",3))
IF $PIECE($TEXT(GREET+%+1),";",3)="###"
QUIT
+6 SET %=0
+7 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
DO RSLT(^(%,0))
+8 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""LEX1003"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+9 FOR %="LEXZMENU","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+10 DO ^XMD
+11 KILL ^TMP("LEX1003",$JOB)
+12 DO MES^XPDUTL("END Delivering MailMan message to select users.")
+13 QUIT
+14 ;
RSLT(%) SET ^(0)=$GET(^TMP("LEX1003",$JOB,0))+1
SET ^(^(0))=%
+1 QUIT
+2 ;
SINGLE(K) ; Get holders of a key
+1 NEW Y
+2 SET Y=0
+3 IF '$DATA(^XUSEC(K))
QUIT
+4 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+5 QUIT
+6 ;
GREET ;;To add to mail message.
+1 ;;
+2 ;;Routines and/or data dictionaries on your RPMS system have been updated.
+3 ;;
+4 ;;You are receiving this message because of the RPMS
+5 ;;security keys that you hold. This is for your information.
+6 ;;Do not respond to this message.
+7 ;;
+8 ;;Questions about this patch may be directed to
+9 ;;the ITSC Support Center, at 505-248-4371,
+10 ;;refer to patch "LEX*2.1*1003".
+11 ;;
+12 ;;###;NOTE: This line end of text.
+13 ;
HIST ;PATCH HISTORY UPDATE
+1 DO MES^XPDUTL("Begin adding patches to package file.")
+2 SET DDLM=";;"
SET DLM="|"
SET TAG="LEX"
+3 SET PKGNM="LEXICON UTILITY"
+4 IF '$DATA(^DIC(9.4,"B",PKGNM))
DO MES^XPDUTL("Problem with package name.")
QUIT
+5 SET PKGIEN=$ORDER(^DIC(9.4,"B",PKGNM,0))
+6 FOR I=1:1
Begin DoDot:1
+7 SET TEXT=$TEXT(@TAG+I)
IF TEXT["END"
QUIT
+8 SET DATA=$PIECE(TEXT,DDLM,2)
+9 SET VERSION=$PIECE(DATA,DLM,2)
SET PATCH=$PIECE(DATA,DLM,3)
+10 SET VSB=$ORDER(^DIC(9.4,PKGIEN,22,"B",VERSION,0))
+11 IF 'VSB
QUIT
+12 KILL FDA
+13 ; Do not update if the patch is already in the patch history
+14 IF $DATA(^DIC(9.4,PKGIEN,22,VSB,"PAH","B",PATCH))
QUIT
+15 SET FDA(9.4901,"+1,"_VSB_","_PKGIEN_",",.01)=$GET(PATCH)
+16 SET FDA(9.4901,"+1,"_VSB_","_PKGIEN_",",.02)=DT
+17 SET FDA(9.4901,"+1,"_VSB_","_PKGIEN_",",.03)=DUZ
+18 DO UPDATE^DIE(,"FDA")
+19 IF $GET(DIERR)'=""
DO MES^XPDUTL("Error adding patch "_PATCH_" to package file.")
End DoDot:1
IF TEXT["END"
QUIT
+20 DO MES^XPDUTL("Completed adding patches to package file.")
+21 QUIT
UNCD ;ADD UNCODED DX CODES
+1 IF $DATA(^LEX(757.02,"CODE",".9999 "))
QUIT
+2 FOR UNCD=".9999","ZZZ.999"
Begin DoDot:1
+3 SET DIC="^LEX(757.02,"
SET X="Uncoded Diagnosis"
SET DIC(0)="LI"
SET DLAYGO=757.02
SET DIADD=1
+4 SET CLS=$SELECT(UNCD=".9999":1,1:30)
+5 SET DIC("DR")="1////"_UNCD_";2////"_CLS_";3////155739;4////0;6////0"
+6 DO ^DIC
IF +Y<0
WRITE !,"Uable to add the uncoded DX ",UNCD
QUIT
+7 SET DA(1)=+Y
SET DIC="^LEX(757.02,"_DA(1)_",4,"
SET DIC(0)="LI"
+8 SET ^LEX(757.02,DA(1),4,0)="^757.28DA^0^0"
+9 IF UNCD=".9999"
Begin DoDot:2
+10 SET DA=1
SET X=2781001
SET DIC("DR")="1////1"
DO ^DIC
IF +Y<0
WRITE !,"Uable to add the uncoded DX ",UNCD," active date."
QUIT
+11 SET DA=2
SET X=3141001
SET DIC("DR")="1////0"
DO ^DIC
IF +Y<0
WRITE !,"Uable to add the uncoded DX ",UNCD," inactive date."
QUIT
End DoDot:2
QUIT
+12 SET DA=1
SET X=3141001
SET DIC("DR")="1////1"
DO ^DIC
IF +Y<0
WRITE !,"Uable to add the uncoded DX ",UNCD," active date."
End DoDot:1
+13 KILL UNCD,CLS,DIADD,DIC,DA
+14 QUIT
+15 ;;;;FORMAT - Package name|Version|Patch|Sequence
LEX ;
+1 ;;LEXICON UTILITY|2.0|79 SEQ #72
+2 ;;LEXICON UTILITY|2.0|82 SEQ #74
+3 ;;LEXICON UTILITY|2.0|83 SEQ #75
+4 ;;LEXICON UTILITY|2.0|84 SEQ #76
+5 ;;LEXICON UTILITY|2.0|51 SEQ #77
+6 ;;LEXICON UTILITY|2.0|58 SEQ #78
+7 ;;LEXICON UTILITY|2.0|89 SEQ #79
+8 ;;LEXICON UTILITY|2.0|90 SEQ #80
+9 ;;LEXICON UTILITY|2.0|91 SEQ #81
+10 ;;LEXICON UTILITY|2.0|93 SEQ #82
+11 ;;LEXICON UTILITY|2.0|94 SEQ #83
+12 ;;LEXICON UTILITY|2.0|80
+13 ;END
