BWPROF2 ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 03/27/2002 8:48 AM ]
;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; RETRIEVE AND SORT PROCEDURES, NOTIFICATIONS, PAP REGIMENS,
;; AND PREGNANCIES FOR PATIENT PROFILE. CALLED BY BWPROF.
;
SORT ;EP
;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
;
K ^TMP("BW",$J)
;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
;---> BWENDDT1=THE LAST SECOND OF END DATE.
;S BWBEGDT1=BWBEGDT-.0001,BWENDDT1=BWENDDT+.9999 ;---> XDATES
;
D PATVARS^BWUTL3(BWDFN)
;
;*******************
;---> GET PROCEDURES
S BWIEN=0
F S BWIEN=$O(^BWPCD("C",BWDFN,BWIEN)) Q:'BWIEN D
.;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
.S Y=^BWPCD(BWIEN,0)
.;
.;
.;===> BEGIN CHANGES - Mike Remillard ;IHS/ANMC/MWR 3/27/02
.;---> Commented out this patch.
.;---> Next line caused any Procedure without a result to drop off
.;---> the Patient Profile.
.;Q:'$P(Y,U,4)!'$P(Y,U,5) ;IHS/CIM/THL PATCH 8
.Q:'$P(Y,U,4) ;IHS/CIM/THL PATCH 8
.;===> END CHANGES - Mike Remillard ;IHS/ANMC/MWR 3/27/02
.;
.;
.;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
.Q:BWERRORS&($P(Y,U,5)=8)
.;---> QUIT IF NOT WITHIN DATE RANGE.
.S (BWDATE,BWDATE1)=$P(Y,U,12)
.;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1) ;---> XDATES
.S BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
.S BWACC=$P(Y,U) ;---> ACCESSION#
.S BWPCD=$P(^BWPN($P(Y,U,4),0),U,2) ;---> PROC TYPE
.S BWSTAT=$$STATUS^BWUTL4 ;---> STATUS
.S BWDIAG=$$DIAG^BWUTL4($P(Y,U,5)) ;---> RESULT/DIAG
.S BWPROV=$P(Y,U,7) D ;---> PROVIDER
..I 'BWPROV S BWPROV="NOT ENTERED" Q
..;
..;---> NEXT LINE PATCHED (INSERTED) BY MIKE REMILLARD 1/27/99
..I '$D(^VA(200,BWPROV,0)) S BWPROV="BAD POINTER" Q ;IHS/ANMC/MWR
..S BWPROV=$P($P(^VA(200,BWPROV,0),U),",")
..;
.;---> FOR PROCEDURES, SET 1ST PIECE AND 6TH SUBSCRIPT=1.
.;S X=1_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPCD_U_BWACC_U_BWDIAG
.S X=1_U_U_U_BWDATE1_U_BWPCD_U_BWACC_U_BWDIAG
.S X=X_U_BWPROV_U_BWSTAT_U_BWIEN
.S ^TMP("BW",$J,1,9999999.9999-BWDATE,BWACC,1,BWIEN)=X Q
;
;**********************
;---> GET NOTIFICATIONS
Q:'BWD
S BWIEN=0
F S BWIEN=$O(^BWNOT("B",BWDFN,BWIEN)) Q:'BWIEN D
.S Y=^BWNOT(BWIEN,0)
.;---> QUIT IF NOT WITHIN DATE RANGE. BWDATE1 PRESERVES NOTIF DATE.
.S (BWDATE,BWDATE1)=$P(Y,U,2)
.;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1) ;---> XDATE
.S BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
.S BWACC=$P(Y,U,6) D ;---> ACCESSION#
..I BWACC="" S BWACC="NO ACC#" Q
..;---> IF THIS NOTIFICATION PERTAINS TO A PROCEDURE (I.E., IT
..;---> HAS AN ACCESSION#), RESET ITS DATE SO THAT IT WILL COLLATE
..;---> UNDER ITS PROCEDURE IN THE DISPLAY.
..S BWACC=$P(^BWPCD(BWACC,0),U),BWDATE=$P(^(0),U,12)
.S BWSTAT=$$STATUS^BWUTL4 ;---> STATUS
.S BWTYPE=$P(Y,U,3) D ;---> TYPE
..I BWTYPE="" S BWTYPE="NOT ENTERED" Q
..S BWTYPE=$P(^BWNOTT(BWTYPE,0),U)
.S BWPURP=$P(Y,U,4) D ;---> PURPOSE
..I BWPURP="" S BWPURP="NOT ENTERED" Q
..S BWPURP=$P(^BWNOTP(BWPURP,0),U)
.S BWOUT=$P(Y,U,5) D ;---> OUTCOME
..I BWOUT="" S BWOUT="NOT ENTERED" Q
..S BWOUT=$P(^BWNOTO(BWOUT,0),U)
.;---> FOR NOTIFICATIONS, SET 1ST PIECE AND 6TH SUBSCRIPT=2.
.;S X=2_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWACC_U_BWTYPE_U_BWPURP
.S X=2_U_U_U_BWDATE1_U_BWACC_U_BWTYPE_U_BWPURP
.S X=X_U_BWOUT_U_BWSTAT_U_BWIEN
.S ^TMP("BW",$J,1,9999999.9999-BWDATE,BWACC,2,BWIEN)=X Q
;
;**********************
;---> GET PAP REGIMENS
S BWIEN=0
F S BWIEN=$O(^BWPLOG("C",BWDFN,BWIEN)) Q:'BWIEN D
.;---> SET Y=THE ZERO NODE FOR THIS PAP REGIMEN LOG ENTRY.
.S Y=^BWPLOG(BWIEN,0)
.;---> PIECE 1=START DATE FOR THE PAP REGIMEN.
.S (BWDATE,BWDATE1)=$P(Y,U) ;---> DATE
.;---> QUIT IF NOT WITHIN DATE RANGE.
.;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1) ;---> XDATES
.S BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
.S BWPAPRG1=$$PAPRG1^BWUTL1($P(Y,U,3)) ;---> PAP REGIMEN
.;---> FOR PAP REGIMENS, SET 1ST PIECE AND 6TH SUBSCRIPT=3.
.;S X=3_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPAPRG1
.S X=3_U_U_U_BWDATE1_U_BWPAPRG1
.S ^TMP("BW",$J,1,9999999.9999-BWDATE,1,3,BWIEN)=X Q
;
;**********************
;---> GET PREGNANCIES
S BWIEN=0
F S BWIEN=$O(^BWEDC("C",BWDFN,BWIEN)) Q:'BWIEN D
.;---> SET Y=THE ZERO NODE FOR THIS PREGNANCY LOG ENTRY.
.S Y=^BWEDC(BWIEN,0)
.;---> PIECE 1=DATE PREGNANCY LOG ENTRY WAS MADE.
.S (BWDATE,BWDATE1)=$P(Y,U) ;---> DATE
.;---> QUIT IF NOT WITHIN DATE RANGE.
.;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1) ;---> XDATES
.S BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
.S BWPSTAT=$S($P(Y,U,3):"PREGNANT",1:"NOT PREGNANT") ;---> PREG STATUS
.S BWEDCL=$S(X:$$SLDT2^BWUTL5($P(Y,U,4)),1:"") ;---> EDC
.;---> FOR PREGNANCIES, SET 1ST PIECE AND 6TH SUBSCRIPT=4.
.;S X=4_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPSTAT_U_BWEDCL
.S X=4_U_U_U_BWDATE1_U_BWPSTAT_U_BWEDCL
.S ^TMP("BW",$J,1,9999999.9999-BWDATE,1,4,BWIEN)=X Q
Q
BWPROF2 ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 03/27/2002 8:48 AM ]
+1 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; RETRIEVE AND SORT PROCEDURES, NOTIFICATIONS, PAP REGIMENS,
+4 ;; AND PREGNANCIES FOR PATIENT PROFILE. CALLED BY BWPROF.
+5 ;
SORT ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
+2 ;
+3 KILL ^TMP("BW",$JOB)
+4 ;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
+5 ;---> BWENDDT1=THE LAST SECOND OF END DATE.
+6 ;S BWBEGDT1=BWBEGDT-.0001,BWENDDT1=BWENDDT+.9999 ;---> XDATES
+7 ;
+8 DO PATVARS^BWUTL3(BWDFN)
+9 ;
+10 ;*******************
+11 ;---> GET PROCEDURES
+12 SET BWIEN=0
+13 FOR
SET BWIEN=$ORDER(^BWPCD("C",BWDFN,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:1
+14 ;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
+15 SET Y=^BWPCD(BWIEN,0)
+16 ;
+17 ;
+18 ;===> BEGIN CHANGES - Mike Remillard ;IHS/ANMC/MWR 3/27/02
+19 ;---> Commented out this patch.
+20 ;---> Next line caused any Procedure without a result to drop off
+21 ;---> the Patient Profile.
+22 ;Q:'$P(Y,U,4)!'$P(Y,U,5) ;IHS/CIM/THL PATCH 8
+23 ;IHS/CIM/THL PATCH 8
IF '$PIECE(Y,U,4)
QUIT
+24 ;===> END CHANGES - Mike Remillard ;IHS/ANMC/MWR 3/27/02
+25 ;
+26 ;
+27 ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
+28 IF BWERRORS&($PIECE(Y,U,5)=8)
QUIT
+29 ;---> QUIT IF NOT WITHIN DATE RANGE.
+30 SET (BWDATE,BWDATE1)=$PIECE(Y,U,12)
+31 ;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1) ;---> XDATES
+32 SET BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
+33 ;---> ACCESSION#
SET BWACC=$PIECE(Y,U)
+34 ;---> PROC TYPE
SET BWPCD=$PIECE(^BWPN($PIECE(Y,U,4),0),U,2)
+35 ;---> STATUS
SET BWSTAT=$$STATUS^BWUTL4
+36 ;---> RESULT/DIAG
SET BWDIAG=$$DIAG^BWUTL4($PIECE(Y,U,5))
+37 ;---> PROVIDER
SET BWPROV=$PIECE(Y,U,7)
Begin DoDot:2
+38 IF 'BWPROV
SET BWPROV="NOT ENTERED"
QUIT
+39 ;
+40 ;---> NEXT LINE PATCHED (INSERTED) BY MIKE REMILLARD 1/27/99
+41 ;IHS/ANMC/MWR
IF '$DATA(^VA(200,BWPROV,0))
SET BWPROV="BAD POINTER"
QUIT
+42 SET BWPROV=$PIECE($PIECE(^VA(200,BWPROV,0),U),",")
+43 ;
End DoDot:2
+44 ;---> FOR PROCEDURES, SET 1ST PIECE AND 6TH SUBSCRIPT=1.
+45 ;S X=1_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPCD_U_BWACC_U_BWDIAG
+46 SET X=1_U_U_U_BWDATE1_U_BWPCD_U_BWACC_U_BWDIAG
+47 SET X=X_U_BWPROV_U_BWSTAT_U_BWIEN
+48 SET ^TMP("BW",$JOB,1,9999999.9999-BWDATE,BWACC,1,BWIEN)=X
QUIT
End DoDot:1
+49 ;
+50 ;**********************
+51 ;---> GET NOTIFICATIONS
+52 IF 'BWD
QUIT
+53 SET BWIEN=0
+54 FOR
SET BWIEN=$ORDER(^BWNOT("B",BWDFN,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:1
+55 SET Y=^BWNOT(BWIEN,0)
+56 ;---> QUIT IF NOT WITHIN DATE RANGE. BWDATE1 PRESERVES NOTIF DATE.
+57 SET (BWDATE,BWDATE1)=$PIECE(Y,U,2)
+58 ;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1) ;---> XDATE
+59 SET BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
+60 ;---> ACCESSION#
SET BWACC=$PIECE(Y,U,6)
Begin DoDot:2
+61 IF BWACC=""
SET BWACC="NO ACC#"
QUIT
+62 ;---> IF THIS NOTIFICATION PERTAINS TO A PROCEDURE (I.E., IT
+63 ;---> HAS AN ACCESSION#), RESET ITS DATE SO THAT IT WILL COLLATE
+64 ;---> UNDER ITS PROCEDURE IN THE DISPLAY.
+65 SET BWACC=$PIECE(^BWPCD(BWACC,0),U)
SET BWDATE=$PIECE(^(0),U,12)
End DoDot:2
+66 ;---> STATUS
SET BWSTAT=$$STATUS^BWUTL4
+67 ;---> TYPE
SET BWTYPE=$PIECE(Y,U,3)
Begin DoDot:2
+68 IF BWTYPE=""
SET BWTYPE="NOT ENTERED"
QUIT
+69 SET BWTYPE=$PIECE(^BWNOTT(BWTYPE,0),U)
End DoDot:2
+70 ;---> PURPOSE
SET BWPURP=$PIECE(Y,U,4)
Begin DoDot:2
+71 IF BWPURP=""
SET BWPURP="NOT ENTERED"
QUIT
+72 SET BWPURP=$PIECE(^BWNOTP(BWPURP,0),U)
End DoDot:2
+73 ;---> OUTCOME
SET BWOUT=$PIECE(Y,U,5)
Begin DoDot:2
+74 IF BWOUT=""
SET BWOUT="NOT ENTERED"
QUIT
+75 SET BWOUT=$PIECE(^BWNOTO(BWOUT,0),U)
End DoDot:2
+76 ;---> FOR NOTIFICATIONS, SET 1ST PIECE AND 6TH SUBSCRIPT=2.
+77 ;S X=2_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWACC_U_BWTYPE_U_BWPURP
+78 SET X=2_U_U_U_BWDATE1_U_BWACC_U_BWTYPE_U_BWPURP
+79 SET X=X_U_BWOUT_U_BWSTAT_U_BWIEN
+80 SET ^TMP("BW",$JOB,1,9999999.9999-BWDATE,BWACC,2,BWIEN)=X
QUIT
End DoDot:1
+81 ;
+82 ;**********************
+83 ;---> GET PAP REGIMENS
+84 SET BWIEN=0
+85 FOR
SET BWIEN=$ORDER(^BWPLOG("C",BWDFN,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:1
+86 ;---> SET Y=THE ZERO NODE FOR THIS PAP REGIMEN LOG ENTRY.
+87 SET Y=^BWPLOG(BWIEN,0)
+88 ;---> PIECE 1=START DATE FOR THE PAP REGIMEN.
+89 ;---> DATE
SET (BWDATE,BWDATE1)=$PIECE(Y,U)
+90 ;---> QUIT IF NOT WITHIN DATE RANGE.
+91 ;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1) ;---> XDATES
+92 SET BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
+93 ;---> PAP REGIMEN
SET BWPAPRG1=$$PAPRG1^BWUTL1($PIECE(Y,U,3))
+94 ;---> FOR PAP REGIMENS, SET 1ST PIECE AND 6TH SUBSCRIPT=3.
+95 ;S X=3_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPAPRG1
+96 SET X=3_U_U_U_BWDATE1_U_BWPAPRG1
+97 SET ^TMP("BW",$JOB,1,9999999.9999-BWDATE,1,3,BWIEN)=X
QUIT
End DoDot:1
+98 ;
+99 ;**********************
+100 ;---> GET PREGNANCIES
+101 SET BWIEN=0
+102 FOR
SET BWIEN=$ORDER(^BWEDC("C",BWDFN,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:1
+103 ;---> SET Y=THE ZERO NODE FOR THIS PREGNANCY LOG ENTRY.
+104 SET Y=^BWEDC(BWIEN,0)
+105 ;---> PIECE 1=DATE PREGNANCY LOG ENTRY WAS MADE.
+106 ;---> DATE
SET (BWDATE,BWDATE1)=$PIECE(Y,U)
+107 ;---> QUIT IF NOT WITHIN DATE RANGE.
+108 ;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1) ;---> XDATES
+109 SET BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
+110 ;---> PREG STATUS
SET BWPSTAT=$SELECT($PIECE(Y,U,3):"PREGNANT",1:"NOT PREGNANT")
+111 ;---> EDC
SET BWEDCL=$SELECT(X:$$SLDT2^BWUTL5($PIECE(Y,U,4)),1:"")
+112 ;---> FOR PREGNANCIES, SET 1ST PIECE AND 6TH SUBSCRIPT=4.
+113 ;S X=4_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPSTAT_U_BWEDCL
+114 SET X=4_U_U_U_BWDATE1_U_BWPSTAT_U_BWEDCL
+115 SET ^TMP("BW",$JOB,1,9999999.9999-BWDATE,1,4,BWIEN)=X
QUIT
End DoDot:1
+116 QUIT
