GMRA1005 ;IHS/MSC/PLS - Patch support;05-Jun-2012 15:26;DU
;;4.0;Adverse Reaction Tracking;**1005**;Mar 29, 1996;Build 30
;
ENV ;EP -
N PATCH
S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
;
;Check for the installation of other patches
S PATCH="GMRA*4.0*1004"
I '$$PATCH(PATCH) D Q
. W !,"You must first install "_PATCH_"." S XPDQUIT=2
Q
;
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn
;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb
Q:X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N 0
NEW NUM,I,J
S I=$O(^DIC(9.4,"C",$P(X,"*"),0)) Q:'I 0
S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0
;check if patch is just a number
Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1
S NUM=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
Q (X=+NUM)
PRE ;EP -
Q
POST ;EP -
D DATA,SIGNS
D INACTALL,INACTSGN
D TOP10^GMRAUTL2
Q
;
SIGNS ;EP-
N F,LP,NAM
S F=120.83
;F LP=0:0 S LP=$O(@XPDGREF@("DATA",F,LP)) Q:'LP D
;.S NAM=$P($G(@XPDGREF@("DATA",F,LP,0)),U)
;.I $$EXISTS(NAM) D
;..K @XPDGREF@("DATA",F,LP)
D DATAIN^DIFROMS(F,"","",XPDGREF),DIERR("** ERROR IN DATA FOR FILE # "_F_" **"):$D(DIERR)
Q
;
DATA ; Import Data
N LP,NAM,F,LNAARY,XUMF
; Build array of local national allergies
S LP=0 F S LP=$O(^GMRD(120.82,LP)) Q:'LP D
.;Q:'$P(^GMRD(120.82,LP,0),U,3) ;Must be a National Allergy
.S LNAARY($P(^GMRD(120.82,LP,0),U),LP)=""
S F=120.82,XUMF=1
S LP=0 F S LP=$O(@XPDGREF@("DATA",F,LP)) Q:'LP D
.;Q:'$P(@XPDGREF@("DATA",F,LP,0),U,3) ; Must be marked as National Allergy
.S NAM=$P($G(@XPDGREF@("DATA",F,LP,0)),U)
.D STOREALG(LP)
Q
;
STOREALG(DATAIEN) ;
N FDA,FDAIEN,ERR,IENS,ARY,LP2,CNT,IEN
Q:'$L(DATAIEN)
M ARY=@XPDGREF@("DATA",120.82,DATAIEN)
S IEN=$$ALGIEN(NAM)
S:'IEN IEN="+1"
S IENS=IEN_",",X=IEN
S CNT=0
I X=+X D ;EXISTING ENTRY
.S FDA(F,IENS,1)=$P(ARY(0),U,2)
.S FDA(F,IENS,2)=$P(ARY(0),U,3)
.S FDA(F,IENS,99.99)=$P($G(ARY("VUID")),U,1)
.S FDA(F,IENS,99.98)=$P($G(ARY("VUID")),U,2)
.D FILE^DIE("K","FDA","ERR")
.Q:$D(ERR)
.D SUBDATA(IEN)
E D ;New entry
.S FDA(F,IENS,.01)=$P(ARY(0),U)
.S FDA(F,IENS,1)=$P(ARY(0),U,2)
.S FDA(F,IENS,2)=$P(ARY(0),U,3)
.S FDA(F,IENS,99.99)=$P($G(ARY("VUID")),U,1)
.S FDA(F,IENS,99.98)=$P($G(ARY("VUID")),U,2)
.D UPDATE^DIE("","FDA","IENS","ERR")
.I $D(ERR) W !,IENS W ERR W !! Q
.D SUBDATA(IENS(1))
; Add subfile data
SUBDATA(DIEN) ;EP-
N IENS
S IENS=DIEN_","
; KILL EXISTING SUBFILE DATA
;Synonyms
K ^GMRD(120.82,DIEN,3)
S LP2=0 F S LP2=$O(ARY(3,LP2)) Q:'LP2 D
.S FDA(120.823,"+"_$$INC()_","_IENS,.01)=$P(ARY(3,LP2,0),U)
;Drug Class
K ^GMRD(120.82,DIEN,"CLASS")
S LP2=0 F S LP2=$O(ARY("CLASS",LP2)) Q:'LP2 D
.S FDA(120.8205,"+"_$$INC()_","_IENS,.01)=$P(ARY("CLASS",LP2,0),U)
;Drug Ingredient
K ^GMRD(120.82,DIEN,"ING")
S LP2=0 F S LP2=$O(ARY("ING",LP2)) Q:'LP2 D
.S FDA(120.824,"+"_$$INC()_","_IENS,.01)=$P(ARY("ING",LP2,0),U)
;Effective Date
K ^GMRD(120.82,DIEN,"TERMSTATUS")
S LP2=0 F S LP2=$O(ARY("TERMSTATUS",LP2)) Q:'LP2 D
.S FDA(120.8299,"+"_$$INC()_","_IENS,.01)=$P(ARY("TERMSTATUS",LP2,0),U)
.S FDA(120.8299,"+"_$$INC(0)_","_IENS,.02)=$P(ARY("TERMSTATUS",LP2,0),U,2)
K ERR
D UPDATE^DIE("","FDA","","ERR")
I $D(ERR) W !,IENS W ERR("DIERR",1,"TEXT",1) W !! Q
Q
INACTALL ;Inactivate any local allergies
N IEN,FNUM,AIEN,NIEN
S IEN=0 F S IEN=$O(^GMRD(120.82,IEN)) Q:'+IEN D
.I $P($G(^GMRD(120.82,IEN,0)),U,3)'=1 D
..K ERR,FDA,NIEN
..S FNUM=120.8299
..S AIEN="+1,"_IEN_","
..S FDA(120.8299,AIEN,.01)=$$NOW^XLFDT
..S FDA(120.8299,AIEN,.02)=0
..D UPDATE^DIE(,"FDA","NIEN","ERR")
..I $D(ERR) W !,IENS W ERR("DIERR",1,"TEXT",1) W !
Q
INACTSGN ;Inactivate any local signs
N NIEN,FNUM,AIEN,IEN
S IEN=0 F S IEN=$O(^GMRD(120.83,IEN)) Q:'+IEN D
.I $P($G(^GMRD(120.83,IEN,0)),U,2)'=1 D
..K ERR,FDA,NIEN
..S FNUM=120.8399
..S AIEN="+1,"_IEN_","
..S FDA(120.8399,AIEN,.01)=$$NOW^XLFDT
..S FDA(120.8399,AIEN,.02)=0
..D UPDATE^DIE(,"FDA","NIEN","ERR")
..I $D(ERR) W !,IENS W ERR("DIERR",1,"TEXT",1) W !
Q
; Increment counter
INC(VAL) ;EP-
S VAL=$G(VAL,1)
S CNT=$G(CNT)+VAL
Q CNT
DIERR(XPDI) N XPD
D MSG^DIALOG("AE",.XPD) Q:'$D(XPD)
D BMES^XPDUTL(XPDI),MES^XPDUTL(.XPD)
Q
; Check existence of entry
EXISTS(NAM) ;EP -
Q $O(LNAARY(NAM,0))>0
; Get Allergy IEN from Local National Allergies
ALGIEN(NAM) ;EP-
Q $O(LNAARY(NAM,0))
; Check for Drug Allergy
DRUG(IEN) ;EP-
Q $P($G(^GMRD(120.82,IEN,0)),U,2)["D"
;
PRETRAN ;EP -
D PRELOOP(120.82,"GMR ALLERGIES",""),PRELOOP(120.83,"SIGN/SYMPTOMS","")
Q
PRELOOP(FILE,FNAM,SCRN) ;EP-
D FIA^DIFROMSU(FILE,"",FNAM,XPDGREF,"n^n^f^^n^^y^m^n","",SCRN,4.0)
D DATAOUT^DIFROMS("","","",XPDGREF)
Q
GMRA1005 ;IHS/MSC/PLS - Patch support;05-Jun-2012 15:26;DU
+1 ;;4.0;Adverse Reaction Tracking;**1005**;Mar 29, 1996;Build 30
+2 ;
ENV ;EP -
+1 NEW PATCH
+2 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+3 ;
+4 ;Check for the installation of other patches
+5 SET PATCH="GMRA*4.0*1004"
+6 IF '$$PATCH(PATCH)
Begin DoDot:1
+7 WRITE !,"You must first install "_PATCH_"."
SET XPDQUIT=2
End DoDot:1
QUIT
+8 QUIT
+9 ;
PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn
+1 ;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb
+2 IF X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N
QUIT 0
+3 NEW NUM,I,J
+4 SET I=$ORDER(^DIC(9.4,"C",$PIECE(X,"*"),0))
IF 'I
QUIT 0
+5 SET J=$ORDER(^DIC(9.4,I,22,"B",$PIECE(X,"*",2),0))
SET X=$PIECE(X,"*",3)
IF 'J
QUIT 0
+6 ;check if patch is just a number
+7 IF $ORDER(^DIC(9.4,I,22,J,"PAH","B",X,0))
QUIT 1
+8 SET NUM=$ORDER(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
+9 QUIT (X=+NUM)
PRE ;EP -
+1 QUIT
POST ;EP -
+1 DO DATA
DO SIGNS
+2 DO INACTALL
DO INACTSGN
+3 DO TOP10^GMRAUTL2
+4 QUIT
+5 ;
SIGNS ;EP-
+1 NEW F,LP,NAM
+2 SET F=120.83
+3 ;F LP=0:0 S LP=$O(@XPDGREF@("DATA",F,LP)) Q:'LP D
+4 ;.S NAM=$P($G(@XPDGREF@("DATA",F,LP,0)),U)
+5 ;.I $$EXISTS(NAM) D
+6 ;..K @XPDGREF@("DATA",F,LP)
+7 DO DATAIN^DIFROMS(F,"","",XPDGREF)
IF $DATA(DIERR)
DO DIERR("** ERROR IN DATA FOR FILE # "_F_" **")
+8 QUIT
+9 ;
DATA ; Import Data
+1 NEW LP,NAM,F,LNAARY,XUMF
+2 ; Build array of local national allergies
+3 SET LP=0
FOR
SET LP=$ORDER(^GMRD(120.82,LP))
IF 'LP
QUIT
Begin DoDot:1
+4 ;Q:'$P(^GMRD(120.82,LP,0),U,3) ;Must be a National Allergy
+5 SET LNAARY($PIECE(^GMRD(120.82,LP,0),U),LP)=""
End DoDot:1
+6 SET F=120.82
SET XUMF=1
+7 SET LP=0
FOR
SET LP=$ORDER(@XPDGREF@("DATA",F,LP))
IF 'LP
QUIT
Begin DoDot:1
+8 ;Q:'$P(@XPDGREF@("DATA",F,LP,0),U,3) ; Must be marked as National Allergy
+9 SET NAM=$PIECE($GET(@XPDGREF@("DATA",F,LP,0)),U)
+10 DO STOREALG(LP)
End DoDot:1
+11 QUIT
+12 ;
STOREALG(DATAIEN) ;
+1 NEW FDA,FDAIEN,ERR,IENS,ARY,LP2,CNT,IEN
+2 IF '$LENGTH(DATAIEN)
QUIT
+3 MERGE ARY=@XPDGREF@("DATA",120.82,DATAIEN)
+4 SET IEN=$$ALGIEN(NAM)
+5 IF 'IEN
SET IEN="+1"
+6 SET IENS=IEN_","
SET X=IEN
+7 SET CNT=0
+8 ;EXISTING ENTRY
IF X=+X
Begin DoDot:1
+9 SET FDA(F,IENS,1)=$PIECE(ARY(0),U,2)
+10 SET FDA(F,IENS,2)=$PIECE(ARY(0),U,3)
+11 SET FDA(F,IENS,99.99)=$PIECE($GET(ARY("VUID")),U,1)
+12 SET FDA(F,IENS,99.98)=$PIECE($GET(ARY("VUID")),U,2)
+13 DO FILE^DIE("K","FDA","ERR")
+14 IF $DATA(ERR)
QUIT
+15 DO SUBDATA(IEN)
End DoDot:1
+16 ;New entry
IF '$TEST
Begin DoDot:1
+17 SET FDA(F,IENS,.01)=$PIECE(ARY(0),U)
+18 SET FDA(F,IENS,1)=$PIECE(ARY(0),U,2)
+19 SET FDA(F,IENS,2)=$PIECE(ARY(0),U,3)
+20 SET FDA(F,IENS,99.99)=$PIECE($GET(ARY("VUID")),U,1)
+21 SET FDA(F,IENS,99.98)=$PIECE($GET(ARY("VUID")),U,2)
+22 DO UPDATE^DIE("","FDA","IENS","ERR")
+23 IF $DATA(ERR)
WRITE !,IENS
WRITE ERR
WRITE !!
QUIT
+24 DO SUBDATA(IENS(1))
End DoDot:1
+25 ; Add subfile data
SUBDATA(DIEN) ;EP-
+1 NEW IENS
+2 SET IENS=DIEN_","
+3 ; KILL EXISTING SUBFILE DATA
+4 ;Synonyms
+5 KILL ^GMRD(120.82,DIEN,3)
+6 SET LP2=0
FOR
SET LP2=$ORDER(ARY(3,LP2))
IF 'LP2
QUIT
Begin DoDot:1
+7 SET FDA(120.823,"+"_$$INC()_","_IENS,.01)=$PIECE(ARY(3,LP2,0),U)
End DoDot:1
+8 ;Drug Class
+9 KILL ^GMRD(120.82,DIEN,"CLASS")
+10 SET LP2=0
FOR
SET LP2=$ORDER(ARY("CLASS",LP2))
IF 'LP2
QUIT
Begin DoDot:1
+11 SET FDA(120.8205,"+"_$$INC()_","_IENS,.01)=$PIECE(ARY("CLASS",LP2,0),U)
End DoDot:1
+12 ;Drug Ingredient
+13 KILL ^GMRD(120.82,DIEN,"ING")
+14 SET LP2=0
FOR
SET LP2=$ORDER(ARY("ING",LP2))
IF 'LP2
QUIT
Begin DoDot:1
+15 SET FDA(120.824,"+"_$$INC()_","_IENS,.01)=$PIECE(ARY("ING",LP2,0),U)
End DoDot:1
+16 ;Effective Date
+17 KILL ^GMRD(120.82,DIEN,"TERMSTATUS")
+18 SET LP2=0
FOR
SET LP2=$ORDER(ARY("TERMSTATUS",LP2))
IF 'LP2
QUIT
Begin DoDot:1
+19 SET FDA(120.8299,"+"_$$INC()_","_IENS,.01)=$PIECE(ARY("TERMSTATUS",LP2,0),U)
+20 SET FDA(120.8299,"+"_$$INC(0)_","_IENS,.02)=$PIECE(ARY("TERMSTATUS",LP2,0),U,2)
End DoDot:1
+21 KILL ERR
+22 DO UPDATE^DIE("","FDA","","ERR")
+23 IF $DATA(ERR)
WRITE !,IENS
WRITE ERR("DIERR",1,"TEXT",1)
WRITE !!
QUIT
+24 QUIT
INACTALL ;Inactivate any local allergies
+1 NEW IEN,FNUM,AIEN,NIEN
+2 SET IEN=0
FOR
SET IEN=$ORDER(^GMRD(120.82,IEN))
IF '+IEN
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^GMRD(120.82,IEN,0)),U,3)'=1
Begin DoDot:2
+4 KILL ERR,FDA,NIEN
+5 SET FNUM=120.8299
+6 SET AIEN="+1,"_IEN_","
+7 SET FDA(120.8299,AIEN,.01)=$$NOW^XLFDT
+8 SET FDA(120.8299,AIEN,.02)=0
+9 DO UPDATE^DIE(,"FDA","NIEN","ERR")
+10 IF $DATA(ERR)
WRITE !,IENS
WRITE ERR("DIERR",1,"TEXT",1)
WRITE !
End DoDot:2
End DoDot:1
+11 QUIT
INACTSGN ;Inactivate any local signs
+1 NEW NIEN,FNUM,AIEN,IEN
+2 SET IEN=0
FOR
SET IEN=$ORDER(^GMRD(120.83,IEN))
IF '+IEN
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^GMRD(120.83,IEN,0)),U,2)'=1
Begin DoDot:2
+4 KILL ERR,FDA,NIEN
+5 SET FNUM=120.8399
+6 SET AIEN="+1,"_IEN_","
+7 SET FDA(120.8399,AIEN,.01)=$$NOW^XLFDT
+8 SET FDA(120.8399,AIEN,.02)=0
+9 DO UPDATE^DIE(,"FDA","NIEN","ERR")
+10 IF $DATA(ERR)
WRITE !,IENS
WRITE ERR("DIERR",1,"TEXT",1)
WRITE !
End DoDot:2
End DoDot:1
+11 QUIT
+12 ; Increment counter
INC(VAL) ;EP-
+1 SET VAL=$GET(VAL,1)
+2 SET CNT=$GET(CNT)+VAL
+3 QUIT CNT
DIERR(XPDI) NEW XPD
+1 DO MSG^DIALOG("AE",.XPD)
IF '$DATA(XPD)
QUIT
+2 DO BMES^XPDUTL(XPDI)
DO MES^XPDUTL(.XPD)
+3 QUIT
+4 ; Check existence of entry
EXISTS(NAM) ;EP -
+1 QUIT $ORDER(LNAARY(NAM,0))>0
+2 ; Get Allergy IEN from Local National Allergies
ALGIEN(NAM) ;EP-
+1 QUIT $ORDER(LNAARY(NAM,0))
+2 ; Check for Drug Allergy
DRUG(IEN) ;EP-
+1 QUIT $PIECE($GET(^GMRD(120.82,IEN,0)),U,2)["D"
+2 ;
PRETRAN ;EP -
+1 DO PRELOOP(120.82,"GMR ALLERGIES","")
DO PRELOOP(120.83,"SIGN/SYMPTOMS","")
+2 QUIT
PRELOOP(FILE,FNAM,SCRN) ;EP-
+1 DO FIA^DIFROMSU(FILE,"",FNAM,XPDGREF,"n^n^f^^n^^y^m^n","",SCRN,4.0)
+2 DO DATAOUT^DIFROMS("","","",XPDGREF)
+3 QUIT
