- 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
