Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BWPROF2

BWPROF2.m

Go to the documentation of this file. 
  1. BWPROF2 ;IHS/ANMC/MWR - DISPLAY PATIENT PROFILE; [ 03/27/2002  8:48 AM ]
  1.  ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  RETRIEVE AND SORT PROCEDURES, NOTIFICATIONS, PAP REGIMENS,
  1.  ;;  AND PREGNANCIES FOR PATIENT PROFILE.  CALLED BY BWPROF.
  1.  ;
  1. SORT ;EP
  1.  ;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
  1.  ;
  1.  K ^TMP("BW",$J)
  1.  ;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
  1.  ;---> BWENDDT1=THE LAST SECOND OF END DATE.
  1.  ;S BWBEGDT1=BWBEGDT-.0001,BWENDDT1=BWENDDT+.9999    ;---> XDATES
  1.  ;
  1.  D PATVARS^BWUTL3(BWDFN)
  1.  ;
  1.  ;*******************
  1.  ;---> GET PROCEDURES
  1.  S BWIEN=0
  1.  F  S BWIEN=$O(^BWPCD("C",BWDFN,BWIEN)) Q:'BWIEN  D
  1.  .;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.
  1.  .S Y=^BWPCD(BWIEN,0)
  1.  .;
  1.  .;
  1.  .;===> BEGIN CHANGES - Mike Remillard            ;IHS/ANMC/MWR 3/27/02
  1.  .;---> Commented out this patch.
  1.  .;---> Next line caused any Procedure without a result to drop off
  1.  .;---> the Patient Profile.
  1.  .;Q:'$P(Y,U,4)!'$P(Y,U,5)  ;IHS/CIM/THL PATCH 8
  1.  .Q:'$P(Y,U,4)  ;IHS/CIM/THL PATCH 8
  1.  .;===> END CHANGES - Mike Remillard              ;IHS/ANMC/MWR 3/27/02
  1.  .;
  1.  .;
  1.  .;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".
  1.  .Q:BWERRORS&($P(Y,U,5)=8)
  1.  .;---> QUIT IF NOT WITHIN DATE RANGE.
  1.  .S (BWDATE,BWDATE1)=$P(Y,U,12)
  1.  .;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1)                ;---> XDATES
  1.  .S BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
  1.  .S BWACC=$P(Y,U)                                      ;---> ACCESSION#
  1.  .S BWPCD=$P(^BWPN($P(Y,U,4),0),U,2)                   ;---> PROC TYPE
  1.  .S BWSTAT=$$STATUS^BWUTL4                             ;---> STATUS
  1.  .S BWDIAG=$$DIAG^BWUTL4($P(Y,U,5))                    ;---> RESULT/DIAG
  1.  .S BWPROV=$P(Y,U,7) D                                 ;---> PROVIDER
  1.  ..I 'BWPROV S BWPROV="NOT ENTERED" Q
  1.  ..;
  1.  ..;---> NEXT LINE PATCHED (INSERTED) BY MIKE REMILLARD  1/27/99
  1.  ..I '$D(^VA(200,BWPROV,0)) S BWPROV="BAD POINTER" Q  ;IHS/ANMC/MWR
  1.  ..S BWPROV=$P($P(^VA(200,BWPROV,0),U),",")
  1.  ..;
  1.  .;---> FOR PROCEDURES, SET 1ST PIECE AND 6TH SUBSCRIPT=1.
  1.  .;S X=1_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPCD_U_BWACC_U_BWDIAG
  1.  .S X=1_U_U_U_BWDATE1_U_BWPCD_U_BWACC_U_BWDIAG
  1.  .S X=X_U_BWPROV_U_BWSTAT_U_BWIEN
  1.  .S ^TMP("BW",$J,1,9999999.9999-BWDATE,BWACC,1,BWIEN)=X Q
  1.  ;
  1.  ;**********************
  1.  ;---> GET NOTIFICATIONS
  1.  Q:'BWD
  1.  S BWIEN=0
  1.  F  S BWIEN=$O(^BWNOT("B",BWDFN,BWIEN)) Q:'BWIEN  D
  1.  .S Y=^BWNOT(BWIEN,0)
  1.  .;---> QUIT IF NOT WITHIN DATE RANGE.  BWDATE1 PRESERVES NOTIF DATE.
  1.  .S (BWDATE,BWDATE1)=$P(Y,U,2)
  1.  .;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1)               ;---> XDATE
  1.  .S BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
  1.  .S BWACC=$P(Y,U,6) D                                 ;---> ACCESSION#
  1.  ..I BWACC="" S BWACC="NO ACC#" Q
  1.  ..;---> IF THIS NOTIFICATION PERTAINS TO A PROCEDURE (I.E., IT
  1.  ..;---> HAS AN ACCESSION#), RESET ITS DATE SO THAT IT WILL COLLATE
  1.  ..;---> UNDER ITS PROCEDURE IN THE DISPLAY.
  1.  ..S BWACC=$P(^BWPCD(BWACC,0),U),BWDATE=$P(^(0),U,12)
  1.  .S BWSTAT=$$STATUS^BWUTL4                            ;---> STATUS
  1.  .S BWTYPE=$P(Y,U,3)  D                               ;---> TYPE
  1.  ..I BWTYPE="" S BWTYPE="NOT ENTERED" Q
  1.  ..S BWTYPE=$P(^BWNOTT(BWTYPE,0),U)
  1.  .S BWPURP=$P(Y,U,4)  D                               ;---> PURPOSE
  1.  ..I BWPURP="" S BWPURP="NOT ENTERED" Q
  1.  ..S BWPURP=$P(^BWNOTP(BWPURP,0),U)
  1.  .S BWOUT=$P(Y,U,5)  D                                ;---> OUTCOME
  1.  ..I BWOUT="" S BWOUT="NOT ENTERED" Q
  1.  ..S BWOUT=$P(^BWNOTO(BWOUT,0),U)
  1.  .;---> FOR NOTIFICATIONS, SET 1ST PIECE AND 6TH SUBSCRIPT=2.
  1.  .;S X=2_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWACC_U_BWTYPE_U_BWPURP
  1.  .S X=2_U_U_U_BWDATE1_U_BWACC_U_BWTYPE_U_BWPURP
  1.  .S X=X_U_BWOUT_U_BWSTAT_U_BWIEN
  1.  .S ^TMP("BW",$J,1,9999999.9999-BWDATE,BWACC,2,BWIEN)=X Q
  1.  ;
  1.  ;**********************
  1.  ;---> GET PAP REGIMENS
  1.  S BWIEN=0
  1.  F  S BWIEN=$O(^BWPLOG("C",BWDFN,BWIEN)) Q:'BWIEN  D
  1.  .;---> SET Y=THE ZERO NODE FOR THIS PAP REGIMEN LOG ENTRY.
  1.  .S Y=^BWPLOG(BWIEN,0)
  1.  .;---> PIECE 1=START DATE FOR THE PAP REGIMEN.
  1.  .S (BWDATE,BWDATE1)=$P(Y,U)                           ;---> DATE
  1.  .;---> QUIT IF NOT WITHIN DATE RANGE.
  1.  .;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1)                ;---> XDATES
  1.  .S BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
  1.  .S BWPAPRG1=$$PAPRG1^BWUTL1($P(Y,U,3))                ;---> PAP REGIMEN
  1.  .;---> FOR PAP REGIMENS, SET 1ST PIECE AND 6TH SUBSCRIPT=3.
  1.  .;S X=3_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPAPRG1
  1.  .S X=3_U_U_U_BWDATE1_U_BWPAPRG1
  1.  .S ^TMP("BW",$J,1,9999999.9999-BWDATE,1,3,BWIEN)=X Q
  1.  ;
  1.  ;**********************
  1.  ;---> GET PREGNANCIES
  1.  S BWIEN=0
  1.  F  S BWIEN=$O(^BWEDC("C",BWDFN,BWIEN)) Q:'BWIEN  D
  1.  .;---> SET Y=THE ZERO NODE FOR THIS PREGNANCY LOG ENTRY.
  1.  .S Y=^BWEDC(BWIEN,0)
  1.  .;---> PIECE 1=DATE PREGNANCY LOG ENTRY WAS MADE.
  1.  .S (BWDATE,BWDATE1)=$P(Y,U)                           ;---> DATE
  1.  .;---> QUIT IF NOT WITHIN DATE RANGE.
  1.  .;Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1)                ;---> XDATES
  1.  .S BWDATE1=$$SLDT2^BWUTL5(BWDATE1)
  1.  .S BWPSTAT=$S($P(Y,U,3):"PREGNANT",1:"NOT PREGNANT")  ;---> PREG STATUS
  1.  .S BWEDCL=$S(X:$$SLDT2^BWUTL5($P(Y,U,4)),1:"")        ;---> EDC
  1.  .;---> FOR PREGNANCIES, SET 1ST PIECE AND 6TH SUBSCRIPT=4.
  1.  .;S X=4_U_BWCHRT_U_BWNAME_U_BWDATE1_U_BWPSTAT_U_BWEDCL
  1.  .S X=4_U_U_U_BWDATE1_U_BWPSTAT_U_BWEDCL
  1.  .S ^TMP("BW",$J,1,9999999.9999-BWDATE,1,4,BWIEN)=X Q
  1.  Q