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

BQIWHPRF.m

Go to the documentation of this file. 
  1. BQIWHPRF ;VNGT/HS/ALA-Women's Health Brief Profile ; 29 Apr 2010  5:38 PM
  1.  ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
  1.  ;
  1.  Q
  1.  ;
  1. EN(DATA,DFN) ; EP -- BQI WOMENS HEALTH PROFILE
  1.  ;Description
  1.  ;  Generates a Brief Women's Health Profile
  1.  ;
  1.  ;Input
  1.  ;  DFN - Patient Internal ID
  1.  ;
  1.  NEW UID,X,BQII,HSTEXT,HSPATH,HSFN,Y,IOSL,IOST,IOM,BWACC,BWACCP,BWBNEED,BWCHRT,I
  1.  NEW BWCMGR,BWCNEED,BWCRT,BWD,BWDATE,BWDATE1,BWDFN,BWDIAG,BWEDC,BWERRORS,BWIEN,M
  1.  NEW BWNAMAGE,BWNAME,BWPAGE,BWPAPRG,BWPCD,BWPOP,BWPROV,BWSTAT,BWSUBH,BWTAB,BWTITLE
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIWHPRF",UID))
  1.  K @DATA
  1.  ;
  1.  S BQII=0
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIWHPRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S IOSL=999,IOM=80,IOST="P-OTHER80"
  1.  S IOST(0)=$$FIND1^DIC(3.2,,"X",IOST)
  1.  ;
  1.  I $P($G(^DPT(DFN,0)),U,2)'="F" D  Q
  1.  . S @DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$C(30)
  1.  . S BQII=BQII+1,@DATA@(BQII)="-1^RPC Failed: Patient is not Female"_$C(30)
  1.  . S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  I $G(^BWP(DFN,0))="" D  Q
  1.  . S @DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$C(30)
  1.  . S BQII=BQII+1,@DATA@(BQII)="-1^RPC Failed: Patient is not in the Women's Health file"_$C(30)
  1.  . S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  ;
  1.  D HDR
  1.  ;
  1.  I $$TMPFL^BQIUL1("W",UID,DFN) G DONE
  1.  ;
  1.  S BWDFN=DFN
  1.  S BWERRORS=0,BWD=0,BWPAGE=0,BWCRT=1,BWTAB=5
  1.  S BWTITLE="* * *  WOMEN'S HEALTH: PATIENT PROFILE  * * *"
  1.  D SORT^BWPROF2
  1.  D COPYGBL^BWPROF
  1.  S N=0,BWPOP=0
  1.  U IO D DISPLAY
  1.  U IO W $C(9)
  1.  D DISPLAY
  1.  ;
  1.  I $$TMPFL^BQIUL1("C") G DONE
  1.  I $$TMPFL^BQIUL1("R",UID,DFN) G DONE
  1.  ;
  1.  F  U IO R HSTEXT:.1 Q:HSTEXT[$C(9)  D
  1.  . S HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^")
  1.  . I HSTEXT="" S HSTEXT=" "
  1.  . S BQII=BQII+1,@DATA@(BQII)=HSTEXT_$C(13)_$C(10)
  1.  S BQII=BQII+1,@DATA@(BQII)=$C(30)
  1.  ;
  1.  I $$TMPFL^BQIUL1("C") G DONE
  1.  I $$TMPFL^BQIUL1("D",UID,DFN) G DONE
  1.  ;
  1. DONE ;
  1.  ;
  1.  S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  Q
  1.  ;
  1. HDR ;
  1.  S @DATA@(BQII)="T01024REPORT_TEXT"_$C(30)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  I $$TMPFL^BQIUL1("C")
  1.  Q
  1.  ;
  1. DISPLAY ; Copied and modified from BWPROF3
  1.  S BWSUBH="SUBHEAD^BWPROF1"
  1.  D HEADER2^BWUTL7
  1.  S N=0
  1.  F  S N=$O(^TMP("BW",$J,2,N)) Q:'N!(BWPOP)  D
  1.  .S Y=^TMP("BW",$J,2,N),M=N
  1.  .;---> QUIT IF NOT A PROCEDURE (PIECE 1'=1).
  1.  .Q:$P(Y,U)'=1
  1.  .W ! W:BWCRT $J(N,3),")" W ?BWTAB          ;BROWSE SELECTION#
  1.  .W $P(Y,U,4)                               ;DATE OF PROCEDURE
  1.  .W ?17,$P(Y,U,5)                           ;PROCEDURE ABBREVIATION
  1.  .W ?27,$P(Y,U,7)                           ;RESULT
  1.  .W ?71,$P(Y,U,9)                           ;STATUS
  1.  .S BWACCP=$P(Y,U,6)                        ;STORE AS PREVIOUS ACCESS#
  1. END2 ;EP
  1.  ;W:'BWCRT @IOF
  1.  ;---> IF A PROCEDURE HAS BEEN EDITED, SET N=N-1 AND START (GOTO)
  1.  ;---> DISPLAY2 OVER AGAIN FROM 5 RECORDS PREVIOUS.
  1.  ;I BWCRT&('$D(IO("S")))&('BWPOP) D DIRPRMT^BWUTL3 I N S N=N-1 G NOMATCH
  1.  ;D ^%ZISC:'$G(BWEXT) ;IHS/CMI/THL PATCH 8 DON'T CLOSE WHEN EXTERNAL CALL
  1.  K N,Z
  1.  Q