BPCPC2 ; IHS/OIT/MJL - PATIENT CHART GUI ROUTINES ;
;;1.5;BPC;;MAY 26, 2005
;
AGENTS(RESULT,BPCAGENT) ;EP CALL FROM REMOTE PROC: BPC GETAGENTS
S U="^",XWBWRAP=1,BPCSUB=$J K ^BPCRES(BPCSUB),^BPCTMP(BPCSUB)
S RESULT="^BPCRES("_BPCSUB_")",BPCAGENT=$G(BPCAGENT),BPCCTR=0,BPCLIST=0
I BPCAGENT="" S ^BPCRES(BPCSUB,0)=-1,^BPCRES(BPCSUB,1)="No Agent Sent!" D KILL Q
I $E(BPCAGENT)="?" S BPCLIST=1,BPCAGENT=$P(BPCAGENT,"?",2) I BPCAGENT="" S ^BPCRES(BPCSUB,0)=-1,^BPCRES(BPCSUB,1)=""""_"?"_""""_" Cannot Be Entered By Itself" D KILL Q
D:'BPCLIST GETAG1
D:BPCLIST GETAG2
D GETRES,KILL
Q
GETAG1 ;
I $D(^GMRD(120.82,"B",BPCAGENT)) D Q:BPCIEN'=""
.S BPCIEN=$O(^GMRD(120.82,"B",BPCAGENT,""))
.S:BPCIEN'="" BPCDTA=^GMRD(120.82,BPCIEN,0),BPCTYPE=$P(BPCDTA,U,2)
.S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^GMRD(120.82,^GMR ALLERGIES^B"_U_BPCTYPE
I $D(^PS(50.416,"P",BPCAGENT)) D Q:BPCIEN'=""
.S BPCIEN=$O(^PS(50.416,"P",BPCAGENT,""))
.S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^PS(50.416,^DRUG INGREDIENTS^P^D"
I $D(^PS(50.605,"C",BPCAGENT)) D Q:BPCIEN'=""
.S BPCIEN=$O(^PS(50.605,"C",BPCAGENT,""))
.S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^PS(50.605,^VA DRUG CLASS^C^D"
I $D(^PSNDF("B",BPCAGENT)) D Q:BPCIEN'=""
.S BPCIEN=$O(^PSNDF("B",BPCAGENT,""))
.S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^PSNDF(^NATIONAL DRUG^B^D"
I $D(^PSDRUG("B",BPCAGENT)) D Q:BPCIEN'=""
.S BPCIEN=$O(^PSDRUG("B",BPCAGENT,""))
.S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^PSDRUG(^DRUG^B^D"
Q
GETAG2 ;
S BPCX=$O(^GMRD(120.82,"B",BPCAGENT),-1),BPCFLAG=0
F S BPCX=$O(^GMRD(120.82,"B",BPCX)) Q:BPCX="" D Q:BPCFLAG
.I $E(BPCX,1,$L(BPCAGENT))'=BPCAGENT S BPCFLAG=1 Q
.I '$D(^BPCTMP(BPCSUB,BPCX)) D
..S BPCIEN=$O(^GMRD(120.82,"B",BPCX,""))
..S:BPCIEN'="" BPCDTA=^GMRD(120.82,BPCIEN,0),BPCTYPE=$P(BPCDTA,U,2)
..S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^GMRD(120.82,^GMR ALLERGIES^B^"_BPCTYPE
S BPCX=$O(^PS(50.416,"P",BPCAGENT),-1),BPCFLAG=0
F S BPCX=$O(^PS(50.416,"P",BPCX)) Q:BPCX="" D Q:BPCFLAG
.I $E(BPCX,1,$L(BPCAGENT))'=BPCAGENT S BPCFLAG=1 Q
.I '$D(^BPCTMP(BPCSUB,BPCX)) D
..S BPCIEN=$O(^PS(50.416,"P",BPCX,""))
..S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^PS(50.416,^DRUG INGREDIENTS^P^D"
S BPCX=$O(^PS(50.605,"C",BPCAGENT),-1),BPCFLAG=0
F S BPCX=$O(^PS(50.605,"C",BPCX)) Q:BPCX="" D Q:BPCFLAG
.I $E(BPCX,1,$L(BPCAGENT))'=BPCAGENT S BPCFLAG=1 Q
.I '$D(^BPCTMP(BPCSUB,BPCX)) D
..S BPCIEN=$O(^PS(50.605,"C",BPCX,""))
..S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^PS(50.605,^VA DRUG CLASS^C^D"
S BPCX=$O(^PSNDF("B",BPCAGENT),-1),BPCFLAG=0
F S BPCX=$O(^PSNDF("B",BPCX)) Q:BPCX="" D Q:BPCFLAG
.I $E(BPCX,1,$L(BPCAGENT))'=BPCAGENT S BPCFLAG=1 Q
.I '$D(^BPCTMP(BPCSUB,BPCX)) D
..S BPCIEN=$O(^PSNDF("B",BPCX,""))
..S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^PSNDF(^NATIONAL DRUG^B"
S BPCX=$O(^PSDRUG("B",BPCAGENT),-1),BPCFLAG=0
F S BPCX=$O(^PSDRUG("B",BPCX)) Q:BPCX="" D Q:BPCFLAG
.I $E(BPCX,1,$L(BPCAGENT))'=BPCAGENT S BPCFLAG=1 Q
.I '$D(^BPCTMP(BPCSUB,BPCX)) D
..S BPCIEN=$O(^PSDRUG("B",BPCX,""))
..S:BPCIEN'="" ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^PSDRUG(^DRUG^B^D"
Q
GETRES ;
I '$D(^BPCTMP(BPCSUB)) S ^BPCRES(BPCSUB,0)=1,^BPCRES(BPCSUB,1)="NO MATCH" Q
S BPCX="" F S BPCX=$O(^BPCTMP(BPCSUB,BPCX)) Q:BPCX="" D
.S BPCCTR=BPCCTR+1
.S ^BPCRES(BPCSUB,BPCCTR)=^BPCTMP(BPCSUB,BPCX)
S ^BPCRES(BPCSUB,0)=BPCCTR
K ^BPCTMP(BPCSUB)
Q
;
RELLIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETRELIGIONS
S U="^",XWBWRAP=1,BPCSUB=$J K ^BGURES(BPCSUB),RESULT
S RESULT="^BGURES("_BPCSUB_")"
S BPCX=$G(BPCX),BPCMAX=$G(BPCMAX),BPCMORE=$G(BPCMORE),BPCPARAM=$G(BPCPARAM),BPCLEN=$L(BPCX),BPCCTR=0,BPCFLAG=0
S BPCN="" S:BPCX'="" BPCN=$O(^DIC(13,"B",BPCX),-1)
S:'BPCMAX BPCMAX=50
I BPCMORE'="" D MORE I BPCFLAG D KILL Q
D GETREL,KILL
Q
KILL ;
K BPCAGENT,BPCCTR,BPCDTA,BPCFLAG,BPCIEN,BPCLEN,BPCLIST,BPCMAX,BPCMORE,BPCN,BPCPARAM,BPCSUB,BPCTYPE,BPCX
Q
;
MORE ;
S BPCN=$P(BPCMORE,"|",1),BPCIEN=$P(BPCMORE,"|",2),BPCCTR=BPCCTR+1
S ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
I BPCCTR=BPCMAX S BPCFLAG=1
Q
GETREL ;
F S BPCN=$O(^DIC(13,"B",BPCN)) Q:BPCN="" D Q:BPCFLAG
.I BPCX'="",$E(BPCN,1,BPCLEN)'=BPCX S BPCFLAG=1 Q
.S BPCIEN="" F S BPCIEN=$O(^DIC(13,"B",BPCN,BPCIEN)) Q:BPCIEN="" D Q:BPCFLAG
..I BPCCTR=BPCMAX D Q
...S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN
...S BPCFLAG=1
..S BPCCTR=BPCCTR+1,^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
S ^BGURES(BPCSUB,0)=BPCCTR
Q
BPCPC2 ; IHS/OIT/MJL - PATIENT CHART GUI ROUTINES ;
+1 ;;1.5;BPC;;MAY 26, 2005
+2 ;
AGENTS(RESULT,BPCAGENT) ;EP CALL FROM REMOTE PROC: BPC GETAGENTS
+1 SET U="^"
SET XWBWRAP=1
SET BPCSUB=$JOB
KILL ^BPCRES(BPCSUB),^BPCTMP(BPCSUB)
+2 SET RESULT="^BPCRES("_BPCSUB_")"
SET BPCAGENT=$GET(BPCAGENT)
SET BPCCTR=0
SET BPCLIST=0
+3 IF BPCAGENT=""
SET ^BPCRES(BPCSUB,0)=-1
SET ^BPCRES(BPCSUB,1)="No Agent Sent!"
DO KILL
QUIT
+4 IF $EXTRACT(BPCAGENT)="?"
SET BPCLIST=1
SET BPCAGENT=$PIECE(BPCAGENT,"?",2)
IF BPCAGENT=""
SET ^BPCRES(BPCSUB,0)=-1
SET ^BPCRES(BPCSUB,1)=""""_"?"_""""_" Cannot Be Entered By Itself"
DO KILL
QUIT
+5 IF 'BPCLIST
DO GETAG1
+6 IF BPCLIST
DO GETAG2
+7 DO GETRES
DO KILL
+8 QUIT
GETAG1 ;
+1 IF $DATA(^GMRD(120.82,"B",BPCAGENT))
Begin DoDot:1
+2 SET BPCIEN=$ORDER(^GMRD(120.82,"B",BPCAGENT,""))
+3 IF BPCIEN'=""
SET BPCDTA=^GMRD(120.82,BPCIEN,0)
SET BPCTYPE=$PIECE(BPCDTA,U,2)
+4 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^GMRD(120.82,^GMR ALLERGIES^B"_U_BPCTYPE
End DoDot:1
IF BPCIEN'=""
QUIT
+5 IF $DATA(^PS(50.416,"P",BPCAGENT))
Begin DoDot:1
+6 SET BPCIEN=$ORDER(^PS(50.416,"P",BPCAGENT,""))
+7 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^PS(50.416,^DRUG INGREDIENTS^P^D"
End DoDot:1
IF BPCIEN'=""
QUIT
+8 IF $DATA(^PS(50.605,"C",BPCAGENT))
Begin DoDot:1
+9 SET BPCIEN=$ORDER(^PS(50.605,"C",BPCAGENT,""))
+10 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^PS(50.605,^VA DRUG CLASS^C^D"
End DoDot:1
IF BPCIEN'=""
QUIT
+11 IF $DATA(^PSNDF("B",BPCAGENT))
Begin DoDot:1
+12 SET BPCIEN=$ORDER(^PSNDF("B",BPCAGENT,""))
+13 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^PSNDF(^NATIONAL DRUG^B^D"
End DoDot:1
IF BPCIEN'=""
QUIT
+14 IF $DATA(^PSDRUG("B",BPCAGENT))
Begin DoDot:1
+15 SET BPCIEN=$ORDER(^PSDRUG("B",BPCAGENT,""))
+16 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCAGENT)=BPCAGENT_U_BPCIEN_"^PSDRUG(^DRUG^B^D"
End DoDot:1
IF BPCIEN'=""
QUIT
+17 QUIT
GETAG2 ;
+1 SET BPCX=$ORDER(^GMRD(120.82,"B",BPCAGENT),-1)
SET BPCFLAG=0
+2 FOR
SET BPCX=$ORDER(^GMRD(120.82,"B",BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+3 IF $EXTRACT(BPCX,1,$LENGTH(BPCAGENT))'=BPCAGENT
SET BPCFLAG=1
QUIT
+4 IF '$DATA(^BPCTMP(BPCSUB,BPCX))
Begin DoDot:2
+5 SET BPCIEN=$ORDER(^GMRD(120.82,"B",BPCX,""))
+6 IF BPCIEN'=""
SET BPCDTA=^GMRD(120.82,BPCIEN,0)
SET BPCTYPE=$PIECE(BPCDTA,U,2)
+7 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^GMRD(120.82,^GMR ALLERGIES^B^"_BPCTYPE
End DoDot:2
End DoDot:1
IF BPCFLAG
QUIT
+8 SET BPCX=$ORDER(^PS(50.416,"P",BPCAGENT),-1)
SET BPCFLAG=0
+9 FOR
SET BPCX=$ORDER(^PS(50.416,"P",BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+10 IF $EXTRACT(BPCX,1,$LENGTH(BPCAGENT))'=BPCAGENT
SET BPCFLAG=1
QUIT
+11 IF '$DATA(^BPCTMP(BPCSUB,BPCX))
Begin DoDot:2
+12 SET BPCIEN=$ORDER(^PS(50.416,"P",BPCX,""))
+13 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^PS(50.416,^DRUG INGREDIENTS^P^D"
End DoDot:2
End DoDot:1
IF BPCFLAG
QUIT
+14 SET BPCX=$ORDER(^PS(50.605,"C",BPCAGENT),-1)
SET BPCFLAG=0
+15 FOR
SET BPCX=$ORDER(^PS(50.605,"C",BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+16 IF $EXTRACT(BPCX,1,$LENGTH(BPCAGENT))'=BPCAGENT
SET BPCFLAG=1
QUIT
+17 IF '$DATA(^BPCTMP(BPCSUB,BPCX))
Begin DoDot:2
+18 SET BPCIEN=$ORDER(^PS(50.605,"C",BPCX,""))
+19 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^PS(50.605,^VA DRUG CLASS^C^D"
End DoDot:2
End DoDot:1
IF BPCFLAG
QUIT
+20 SET BPCX=$ORDER(^PSNDF("B",BPCAGENT),-1)
SET BPCFLAG=0
+21 FOR
SET BPCX=$ORDER(^PSNDF("B",BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+22 IF $EXTRACT(BPCX,1,$LENGTH(BPCAGENT))'=BPCAGENT
SET BPCFLAG=1
QUIT
+23 IF '$DATA(^BPCTMP(BPCSUB,BPCX))
Begin DoDot:2
+24 SET BPCIEN=$ORDER(^PSNDF("B",BPCX,""))
+25 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^PSNDF(^NATIONAL DRUG^B"
End DoDot:2
End DoDot:1
IF BPCFLAG
QUIT
+26 SET BPCX=$ORDER(^PSDRUG("B",BPCAGENT),-1)
SET BPCFLAG=0
+27 FOR
SET BPCX=$ORDER(^PSDRUG("B",BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+28 IF $EXTRACT(BPCX,1,$LENGTH(BPCAGENT))'=BPCAGENT
SET BPCFLAG=1
QUIT
+29 IF '$DATA(^BPCTMP(BPCSUB,BPCX))
Begin DoDot:2
+30 SET BPCIEN=$ORDER(^PSDRUG("B",BPCX,""))
+31 IF BPCIEN'=""
SET ^BPCTMP(BPCSUB,BPCX)=BPCX_U_BPCIEN_"^PSDRUG(^DRUG^B^D"
End DoDot:2
End DoDot:1
IF BPCFLAG
QUIT
+32 QUIT
GETRES ;
+1 IF '$DATA(^BPCTMP(BPCSUB))
SET ^BPCRES(BPCSUB,0)=1
SET ^BPCRES(BPCSUB,1)="NO MATCH"
QUIT
+2 SET BPCX=""
FOR
SET BPCX=$ORDER(^BPCTMP(BPCSUB,BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+3 SET BPCCTR=BPCCTR+1
+4 SET ^BPCRES(BPCSUB,BPCCTR)=^BPCTMP(BPCSUB,BPCX)
End DoDot:1
+5 SET ^BPCRES(BPCSUB,0)=BPCCTR
+6 KILL ^BPCTMP(BPCSUB)
+7 QUIT
+8 ;
RELLIST(RESULT,BPCX,BPCMAX,BPCMORE,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETRELIGIONS
+1 SET U="^"
SET XWBWRAP=1
SET BPCSUB=$JOB
KILL ^BGURES(BPCSUB),RESULT
+2 SET RESULT="^BGURES("_BPCSUB_")"
+3 SET BPCX=$GET(BPCX)
SET BPCMAX=$GET(BPCMAX)
SET BPCMORE=$GET(BPCMORE)
SET BPCPARAM=$GET(BPCPARAM)
SET BPCLEN=$LENGTH(BPCX)
SET BPCCTR=0
SET BPCFLAG=0
+4 SET BPCN=""
IF BPCX'=""
SET BPCN=$ORDER(^DIC(13,"B",BPCX),-1)
+5 IF 'BPCMAX
SET BPCMAX=50
+6 IF BPCMORE'=""
DO MORE
IF BPCFLAG
DO KILL
QUIT
+7 DO GETREL
DO KILL
+8 QUIT
KILL ;
+1 KILL BPCAGENT,BPCCTR,BPCDTA,BPCFLAG,BPCIEN,BPCLEN,BPCLIST,BPCMAX,BPCMORE,BPCN,BPCPARAM,BPCSUB,BPCTYPE,BPCX
+2 QUIT
+3 ;
MORE ;
+1 SET BPCN=$PIECE(BPCMORE,"|",1)
SET BPCIEN=$PIECE(BPCMORE,"|",2)
SET BPCCTR=BPCCTR+1
+2 SET ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
+3 IF BPCCTR=BPCMAX
SET BPCFLAG=1
+4 QUIT
GETREL ;
+1 FOR
SET BPCN=$ORDER(^DIC(13,"B",BPCN))
IF BPCN=""
QUIT
Begin DoDot:1
+2 IF BPCX'=""
IF $EXTRACT(BPCN,1,BPCLEN)'=BPCX
SET BPCFLAG=1
QUIT
+3 SET BPCIEN=""
FOR
SET BPCIEN=$ORDER(^DIC(13,"B",BPCN,BPCIEN))
IF BPCIEN=""
QUIT
Begin DoDot:2
+4 IF BPCCTR=BPCMAX
Begin DoDot:3
+5 SET BPCCTR=BPCCTR+1
SET ^BGURES(BPCSUB,BPCCTR)="..MORE"_U_BPCN_"|"_BPCIEN
+6 SET BPCFLAG=1
End DoDot:3
QUIT
+7 SET BPCCTR=BPCCTR+1
SET ^BGURES(BPCSUB,BPCCTR)=BPCN_U_BPCIEN
End DoDot:2
IF BPCFLAG
QUIT
End DoDot:1
IF BPCFLAG
QUIT
+8 SET ^BGURES(BPCSUB,0)=BPCCTR
+9 QUIT
