GMRADSP6 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES NOT NENTERED IN ERROR ;07-Dec-2010 15:55;DU
;;4.0;Adverse Reaction Tracking;**8,1002**;Mar 29, 1996;Build 32
;IHS/MSC/MGH Remove inactive allergies from list
EN1 ; Entry to ACTIVE LISTING OF PATIENT REACTIONS option
S GMRAOUT=0
W ! S DIC="^DPT(",DIC(0)="AEQM",DIC("A")="Select PATIENT: " D ^DIC K DIC,DLAYGO S DFN=+Y I +Y'>0 S GMRAOUT=1 G EXIT
EN3 ;Print Active Patient list if patient is known
D DEM^VADPT S GMRAHEAD(2)=$J($E(VADM(1),1,15),1)_$J(VA("PID"),21)_$J($P(VADM(3),"^",2),24)_$J($S(VADM(4):"("_VADM(4)_")",1:""),5) D KVAR^VADPT K VA
S GMRAHEAD(1)=$J("ACTIVE ALLERGY/ADVERSE REACTION LISTING",58),(GMRAHEAD(3),GMRAHEAD(6),GMRAHEAD(7))="",$P(GMRAHEAD(6),"-",81)=""
S GMRAHEAD(4)=$J("OBS/",73),GMRAHEAD(5)=$J("ADVERSE REACTION",17)_$J("VERIFIED",48)_$J("HIST",8)
S GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"2P")
S GMRAHEAD(1.5)=$J("Run Date/Time: "_GMRANOW,55)
I '$D(^GMR(120.86,"B",DFN)) W !!,$C(7),"NO ALLERGY/ADVERSE REACTION DATA EXISTS FOR THIS PATIENT" G EN1
K GMRAZIS D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT
I $D(IO("Q")) D TASK G EXIT
EN2 ; Print Active Patient list if patient and device known
S (GMRAOUT,GMRAPG)=0 D HDR^GMRADSP3
S GMRALIN=$$REPEAT^XLFSTR("=",32)
I $P($G(^GMR(120.86,DFN,0)),U,2)'=1 W !," Patient has answered NKA."
E F GMRAREC=0:0 S GMRAREC=$O(^GMR(120.8,"B",DFN,GMRAREC)) Q:GMRAREC'>0 D EN2A
S GMRAREAC=0 G DISP
Q
EN2A Q:+$G(^GMR(120.8,GMRAREC,"ER")) S GMRATEMP=$G(^GMR(120.8,GMRAREC,0)) Q:'$P(GMRATEMP,"^",12)
;MSC/IHS/MGH Remove inactive allergies from list
N CHK
S CHK=$$INACTIVE(GMRAREC)
Q:CHK
S GMRAKIND=$P(GMRATEMP,"^",20)
S ^TMP($J,"GMRADSP",GMRAKIND,$P(GMRATEMP,"^",2),GMRAREC)=""
Q
DISP ;
S GMRASPAC=53,GMRATONS=""
S (GMRAALL,GMRAKIND,GMRARECN)=""
I '$D(^TMP($J,"GMRADSP")) W !,?33,"No Data Found"
F X=0:0 S GMRAKIND=$O(^TMP($J,"GMRADSP",GMRAKIND)) Q:GMRAKIND=""!GMRAOUT D DISP2
G EXIT
DISP2 D:$Y>(IOSL-4) EOP^GMRADSP3 Q:GMRAOUT
S GMRATYPE=$$OUTTYPE^GMRAUTL(GMRAKIND)
W !!?3,"TYPE: ",GMRATYPE,!?3,$E(GMRALIN,1,$L(GMRATYPE)+6)
F X=0:0 S GMRAALL=$O(^TMP($J,"GMRADSP",GMRAKIND,GMRAALL)) Q:GMRAALL=""!(GMRAOUT) F GMRARECN=0:0 S GMRARECN=$O(^TMP($J,"GMRADSP",GMRAKIND,GMRAALL,GMRARECN)) Q:GMRARECN'>0 D REST Q:GMRAOUT
Q
REST ;
D:$Y>(IOSL-4) EOP^GMRADSP3 Q:GMRAOUT
S GMRATEMP=$G(^GMR(120.8,GMRARECN,0)) W !,GMRAALL,?60,$P("NO^YES","^",1+$P(GMRATEMP,U,16)),?70,$S($P(GMRATEMP,U,6)="h":"HIST",$P(GMRATEMP,U,6)="o":"OBS",1:"")
S GMRSNO=$P($G(^GMR(120.8,GMRARECN,9999999.11)),U,2)
D:$Y>(IOSL-4) EOP^GMRADSP3 Q:GMRAOUT
I +GMRSNO D
.S SNOTXT=$P($G(^BEHOAR(90460.06,GMRSNO,0)),U,1),SNOCODE=$P($G(^BEHOAR(90460.06,GMRSNO,0)),U,2)
.W !?3,"EVENT: ",SNOTXT
.W !?3,"SNOMED CODE: ",SNOCODE
I $D(^GMR(120.8,GMRARECN,10,0)) S GMRAFLG=0,GMRAOTH=$O(^GMRD(120.83,"B","OTHER REACTION",0)) F GMRAX=0:0 S GMRAX=$O(^GMR(120.8,GMRARECN,10,GMRAX)) Q:GMRAX'>0 D
.N GMRALINE,GMRATON,GMRAZ,GMRAFG2
.S GMRATON=$G(^GMR(120.8,GMRARECN,10,GMRAX,0))
.S GMRAFG=$O(^GMR(120.8,GMRARECN,10,GMRAX))
.I +GMRATON'=GMRAOTH S GMRALINE=$E($S($D(^GMRD(120.83,+GMRATON,0)):$P(^(0),U),1:""),1,23)
.E S GMRALINE=$P(GMRATON,U,2)
.S GMRAZ=$S($P(GMRATON,U,4)'="":$$FMTE^XLFDT($P(GMRATON,U,4),1),1:"")
.S:GMRAZ'="" GMRALINE=GMRALINE_" ("_GMRAZ_")"
.I GMRAFG S GMRALINE=GMRALINE_", "
.D WRITG
.Q
Q
WRITG ;
I 'GMRAFLG W !,?5,"Reactions: " S GMRAFLG=1
I $X+$L(GMRALINE)>GMRASPAC W !,?16
W GMRALINE
Q
EXIT ;Quit and kill
K GMRSNO,SNOTXT,SNOCODE
D CLOSE^GMRAUTL
K ^TMP($J,"GMRADSP"),X,Y,Z
D KILL^XUSCLEAN
Q
TASK ;
S ZTDESC="This a print out of the allergies signed off for the patient",ZTRTN="EN2^GMRADSP6",ZTDTH="",ZTIO=ION,ZTSAVE("GMRA*")="",ZTSAVE("DFN")="" D ^%ZTLOAD
W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
K ZTRTN,ZTDH,ZTSAVE,ZTDTH,ZTSK
Q
INACTIVE(LP) ;
N Z,INACT,REACT,IN
S IN=0
S Z=9999999 S Z=$O(^GMR(120.8,LP,9999999.12,Z),-1) I +Z D
.S INACT=$P($G(^GMR(120.8,LP,9999999.12,Z,0)),U,1)
.S REACT=$P($G(^GMR(120.8,LP,9999999.12,Z,0)),U,4)
.I +INACT&(REACT="") S IN=1
Q IN
GMRADSP6 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES NOT NENTERED IN ERROR ;07-Dec-2010 15:55;DU
+1 ;;4.0;Adverse Reaction Tracking;**8,1002**;Mar 29, 1996;Build 32
+2 ;IHS/MSC/MGH Remove inactive allergies from list
EN1 ; Entry to ACTIVE LISTING OF PATIENT REACTIONS option
+1 SET GMRAOUT=0
+2 WRITE !
SET DIC="^DPT("
SET DIC(0)="AEQM"
SET DIC("A")="Select PATIENT: "
DO ^DIC
KILL DIC,DLAYGO
SET DFN=+Y
IF +Y'>0
SET GMRAOUT=1
GOTO EXIT
EN3 ;Print Active Patient list if patient is known
+1 DO DEM^VADPT
SET GMRAHEAD(2)=$JUSTIFY($EXTRACT(VADM(1),1,15),1)_$JUSTIFY(VA("PID"),21)_$JUSTIFY($PIECE(VADM(3),"^",2),24)_$JUSTIFY($SELECT(VADM(4):"("_VADM(4)_")",1:""),5)
DO KVAR^VADPT
KILL VA
+2 SET GMRAHEAD(1)=$JUSTIFY("ACTIVE ALLERGY/ADVERSE REACTION LISTING",58)
SET (GMRAHEAD(3),GMRAHEAD(6),GMRAHEAD(7))=""
SET $PIECE(GMRAHEAD(6),"-",81)=""
+3 SET GMRAHEAD(4)=$JUSTIFY("OBS/",73)
SET GMRAHEAD(5)=$JUSTIFY("ADVERSE REACTION",17)_$JUSTIFY("VERIFIED",48)_$JUSTIFY("HIST",8)
+4 SET GMRANOW=$$NOW^XLFDT
SET GMRANOW=$$FMTE^XLFDT(GMRANOW,"2P")
+5 SET GMRAHEAD(1.5)=$JUSTIFY("Run Date/Time: "_GMRANOW,55)
+6 IF '$DATA(^GMR(120.86,"B",DFN))
WRITE !!,$CHAR(7),"NO ALLERGY/ADVERSE REACTION DATA EXISTS FOR THIS PATIENT"
GOTO EN1
+7 KILL GMRAZIS
DO DEV^GMRAUTL
IF POP
SET GMRAOUT=1
GOTO EXIT
+8 IF $DATA(IO("Q"))
DO TASK
GOTO EXIT
EN2 ; Print Active Patient list if patient and device known
+1 SET (GMRAOUT,GMRAPG)=0
DO HDR^GMRADSP3
+2 SET GMRALIN=$$REPEAT^XLFSTR("=",32)
+3 IF $PIECE($GET(^GMR(120.86,DFN,0)),U,2)'=1
WRITE !," Patient has answered NKA."
+4 IF '$TEST
FOR GMRAREC=0:0
SET GMRAREC=$ORDER(^GMR(120.8,"B",DFN,GMRAREC))
IF GMRAREC'>0
QUIT
DO EN2A
+5 SET GMRAREAC=0
GOTO DISP
+6 QUIT
EN2A IF +$GET(^GMR(120.8,GMRAREC,"ER"))
QUIT
SET GMRATEMP=$GET(^GMR(120.8,GMRAREC,0))
IF '$PIECE(GMRATEMP,"^",12)
QUIT
+1 ;MSC/IHS/MGH Remove inactive allergies from list
+2 NEW CHK
+3 SET CHK=$$INACTIVE(GMRAREC)
+4 IF CHK
QUIT
+5 SET GMRAKIND=$PIECE(GMRATEMP,"^",20)
+6 SET ^TMP($JOB,"GMRADSP",GMRAKIND,$PIECE(GMRATEMP,"^",2),GMRAREC)=""
+7 QUIT
DISP ;
+1 SET GMRASPAC=53
SET GMRATONS=""
+2 SET (GMRAALL,GMRAKIND,GMRARECN)=""
+3 IF '$DATA(^TMP($JOB,"GMRADSP"))
WRITE !,?33,"No Data Found"
+4 FOR X=0:0
SET GMRAKIND=$ORDER(^TMP($JOB,"GMRADSP",GMRAKIND))
IF GMRAKIND=""!GMRAOUT
QUIT
DO DISP2
+5 GOTO EXIT
DISP2 IF $Y>(IOSL-4)
DO EOP^GMRADSP3
IF GMRAOUT
QUIT
+1 SET GMRATYPE=$$OUTTYPE^GMRAUTL(GMRAKIND)
+2 WRITE !!?3,"TYPE: ",GMRATYPE,!?3,$EXTRACT(GMRALIN,1,$LENGTH(GMRATYPE)+6)
+3 FOR X=0:0
SET GMRAALL=$ORDER(^TMP($JOB,"GMRADSP",GMRAKIND,GMRAALL))
IF GMRAALL=""!(GMRAOUT)
QUIT
FOR GMRARECN=0:0
SET GMRARECN=$ORDER(^TMP($JOB,"GMRADSP",GMRAKIND,GMRAALL,GMRARECN))
IF GMRARECN'>0
QUIT
DO REST
IF GMRAOUT
QUIT
+4 QUIT
REST ;
+1 IF $Y>(IOSL-4)
DO EOP^GMRADSP3
IF GMRAOUT
QUIT
+2 SET GMRATEMP=$GET(^GMR(120.8,GMRARECN,0))
WRITE !,GMRAALL,?60,$PIECE("NO^YES","^",1+$PIECE(GMRATEMP,U,16)),?70,$SELECT($PIECE(GMRATEMP,U,6)="h":"HIST",$PIECE(GMRATEMP,U,6)="o":"OBS",1:"")
+3 SET GMRSNO=$PIECE($GET(^GMR(120.8,GMRARECN,9999999.11)),U,2)
+4 IF $Y>(IOSL-4)
DO EOP^GMRADSP3
IF GMRAOUT
QUIT
+5 IF +GMRSNO
Begin DoDot:1
+6 SET SNOTXT=$PIECE($GET(^BEHOAR(90460.06,GMRSNO,0)),U,1)
SET SNOCODE=$PIECE($GET(^BEHOAR(90460.06,GMRSNO,0)),U,2)
+7 WRITE !?3,"EVENT: ",SNOTXT
+8 WRITE !?3,"SNOMED CODE: ",SNOCODE
End DoDot:1
+9 IF $DATA(^GMR(120.8,GMRARECN,10,0))
SET GMRAFLG=0
SET GMRAOTH=$ORDER(^GMRD(120.83,"B","OTHER REACTION",0))
FOR GMRAX=0:0
SET GMRAX=$ORDER(^GMR(120.8,GMRARECN,10,GMRAX))
IF GMRAX'>0
QUIT
Begin DoDot:1
+10 NEW GMRALINE,GMRATON,GMRAZ,GMRAFG2
+11 SET GMRATON=$GET(^GMR(120.8,GMRARECN,10,GMRAX,0))
+12 SET GMRAFG=$ORDER(^GMR(120.8,GMRARECN,10,GMRAX))
+13 IF +GMRATON'=GMRAOTH
SET GMRALINE=$EXTRACT($SELECT($DATA(^GMRD(120.83,+GMRATON,0)):$PIECE(^(0),U),1:""),1,23)
+14 IF '$TEST
SET GMRALINE=$PIECE(GMRATON,U,2)
+15 SET GMRAZ=$SELECT($PIECE(GMRATON,U,4)'="":$$FMTE^XLFDT($PIECE(GMRATON,U,4),1),1:"")
+16 IF GMRAZ'=""
SET GMRALINE=GMRALINE_" ("_GMRAZ_")"
+17 IF GMRAFG
SET GMRALINE=GMRALINE_", "
+18 DO WRITG
+19 QUIT
End DoDot:1
+20 QUIT
WRITG ;
+1 IF 'GMRAFLG
WRITE !,?5,"Reactions: "
SET GMRAFLG=1
+2 IF $X+$LENGTH(GMRALINE)>GMRASPAC
WRITE !,?16
+3 WRITE GMRALINE
+4 QUIT
EXIT ;Quit and kill
+1 KILL GMRSNO,SNOTXT,SNOCODE
+2 DO CLOSE^GMRAUTL
+3 KILL ^TMP($JOB,"GMRADSP"),X,Y,Z
+4 DO KILL^XUSCLEAN
+5 QUIT
TASK ;
+1 SET ZTDESC="This a print out of the allergies signed off for the patient"
SET ZTRTN="EN2^GMRADSP6"
SET ZTDTH=""
SET ZTIO=ION
SET ZTSAVE("GMRA*")=""
SET ZTSAVE("DFN")=""
DO ^%ZTLOAD
+2 WRITE !!,$SELECT($DATA(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
+3 KILL ZTRTN,ZTDH,ZTSAVE,ZTDTH,ZTSK
+4 QUIT
INACTIVE(LP) ;
+1 NEW Z,INACT,REACT,IN
+2 SET IN=0
+3 SET Z=9999999
SET Z=$ORDER(^GMR(120.8,LP,9999999.12,Z),-1)
IF +Z
Begin DoDot:1
+4 SET INACT=$PIECE($GET(^GMR(120.8,LP,9999999.12,Z,0)),U,1)
+5 SET REACT=$PIECE($GET(^GMR(120.8,LP,9999999.12,Z,0)),U,4)
+6 IF +INACT&(REACT="")
SET IN=1
End DoDot:1
+7 QUIT IN
