GMRADSP6 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES NOT ENTERED IN ERROR ;9/23/97 09:07
;;4.0;Adverse Reaction Tracking;**8**;Mar 29, 1996
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)
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:"")
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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRADSP6 3422 printed Apr 09, 2024@20:43:50 Page 2
GMRADSP6 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES NOT ENTERED IN ERROR ;9/23/97 09:07
+1 ;;4.0;Adverse Reaction Tracking;**8**;Mar 29, 1996
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 SET GMRAKIND=$PIECE(GMRATEMP,"^",20)
+2 SET ^TMP($JOB,"GMRADSP",GMRAKIND,$PIECE(GMRATEMP,"^",2),GMRAREC)=""
+3 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 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
+4 NEW GMRALINE,GMRATON,GMRAZ,GMRAFG2
+5 SET GMRATON=$GET(^GMR(120.8,GMRARECN,10,GMRAX,0))
+6 SET GMRAFG=$ORDER(^GMR(120.8,GMRARECN,10,GMRAX))
+7 IF +GMRATON'=GMRAOTH
SET GMRALINE=$EXTRACT($SELECT($DATA(^GMRD(120.83,+GMRATON,0)):$PIECE(^(0),U),1:""),1,23)
+8 IF '$TEST
SET GMRALINE=$PIECE(GMRATON,U,2)
+9 SET GMRAZ=$SELECT($PIECE(GMRATON,U,4)'="":$$FMTE^XLFDT($PIECE(GMRATON,U,4),1),1:"")
+10 if GMRAZ'=""
SET GMRALINE=GMRALINE_" ("_GMRAZ_")"
+11 IF GMRAFG
SET GMRALINE=GMRALINE_", "
+12 DO WRITG
+13 QUIT
End DoDot:1
+14 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 DO CLOSE^GMRAUTL
+2 KILL ^TMP($JOB,"GMRADSP"),X,Y,Z
+3 DO KILL^XUSCLEAN
+4 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
