BQIRWS ;PRXM/HC/ALA - Patient Wellness Summary ; 19 Jul 2006 10:35 AM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
EN(DATA,DFN,TYPE) ; EP -- BQI PATIENT WELLNESS SUMMARY
;Description
; Generates a Patient Wellness Summary for a given DFN
;
;Input
; DFN - Patient Internal ID
;
;Output
; DATA - Name of global in which data is stored(^TMP("BQIRWS"))
;
NEW UID,X,BQII,HSTEXT,HSPATH,HSFN,Y,I,N,ENT,DATAR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRWS",UID))
K @DATA
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRWS D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; Check for patch
I '$$PATCH^XPDUTL("APCH*2.0*15") S BMXSEC="Patch APCH*2.0*15 is not installed. Please contact your system manager." Q
;
D HDR
;
; If BJPC v2.0 is loaded use new Patient Wellness Handout
; *** Note: TYPE must be passed - it corresponds to the HEALTH SUMMARY PWH TYPE ***
;
I $$VERSION^XPDUTL("BJPC")'<2.0 D G DONE
. ; Data is returned from APCHPWH1 in ^TMP($J,"APCHPWH")
. ; This cannot be run asynchronously since $J is used to subscript
. ; temporary globals in APCHPWH1
. ;
. S DATAR=$NA(^TMP($J,"APCHPWH"))
. K @DATAR
. ;
. I $G(TYPE)="" S BMXSEC="RPC Call Failed: Missing Patient Wellness Handout type" Q
. I TYPE'?.N S TYPE=$O(^APCHPWHT("B",TYPE,""))
. I TYPE="" S BMXSEC="RPC Call Failed: Patient Wellness Handout type does not exist in RPMS" Q
. D EP^APCHPWH1(DFN,TYPE)
. I '$O(@DATAR@(0)) Q
. S ENT=0 F S ENT=$O(@DATAR@(ENT)) Q:ENT="" D
.. S BQII=BQII+1,@DATA@(BQII)=@DATAR@(ENT)_$C(13)_$C(10)
. S BQII=BQII+1,@DATA@(BQII)=$C(30)
;
I $$TMPFL^BQIUL1("W",UID,DFN) G DONE
;
NEW IOSL,IOM,IOST
S IOSL=999,IOM=80,IOST="P-OTHER80"
U IO D PRINT^APCHPMH
U IO W $C(9)
;
I $$TMPFL^BQIUL1("C") G DONE
I $$TMPFL^BQIUL1("R",UID,DFN) G DONE
;
F U IO R HSTEXT:.1 Q:HSTEXT[$C(9) D
. S HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^")
. I HSTEXT="" S HSTEXT=" "
. S BQII=BQII+1,@DATA@(BQII)=HSTEXT_$C(13)_$C(10)
S BQII=BQII+1,@DATA@(BQII)=$C(30)
;
I $$TMPFL^BQIUL1("C") G DONE
I $$TMPFL^BQIUL1("D",UID,DFN) G DONE
;
DONE ;
;
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
HDR ;
S @DATA@(BQII)="T01024REPORT_TEXT"_$C(30)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
I $$TMPFL^BQIUL1("C")
Q
BQIRWS ;PRXM/HC/ALA - Patient Wellness Summary ; 19 Jul 2006 10:35 AM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
EN(DATA,DFN,TYPE) ; EP -- BQI PATIENT WELLNESS SUMMARY
+1 ;Description
+2 ; Generates a Patient Wellness Summary for a given DFN
+3 ;
+4 ;Input
+5 ; DFN - Patient Internal ID
+6 ;
+7 ;Output
+8 ; DATA - Name of global in which data is stored(^TMP("BQIRWS"))
+9 ;
+10 NEW UID,X,BQII,HSTEXT,HSPATH,HSFN,Y,I,N,ENT,DATAR
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BQIRWS",UID))
+13 KILL @DATA
+14 ;
+15 SET BQII=0
+16 ;
+17 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRWS D UNWIND^%ZTER"
+18 ;
+19 ; Check for patch
+20 IF '$$PATCH^XPDUTL("APCH*2.0*15")
SET BMXSEC="Patch APCH*2.0*15 is not installed. Please contact your system manager."
QUIT
+21 ;
+22 DO HDR
+23 ;
+24 ; If BJPC v2.0 is loaded use new Patient Wellness Handout
+25 ; *** Note: TYPE must be passed - it corresponds to the HEALTH SUMMARY PWH TYPE ***
+26 ;
+27 IF $$VERSION^XPDUTL("BJPC")'<2.0
Begin DoDot:1
+28 ; Data is returned from APCHPWH1 in ^TMP($J,"APCHPWH")
+29 ; This cannot be run asynchronously since $J is used to subscript
+30 ; temporary globals in APCHPWH1
+31 ;
+32 SET DATAR=$NAME(^TMP($JOB,"APCHPWH"))
+33 KILL @DATAR
+34 ;
+35 IF $GET(TYPE)=""
SET BMXSEC="RPC Call Failed: Missing Patient Wellness Handout type"
QUIT
+36 IF TYPE'?.N
SET TYPE=$ORDER(^APCHPWHT("B",TYPE,""))
+37 IF TYPE=""
SET BMXSEC="RPC Call Failed: Patient Wellness Handout type does not exist in RPMS"
QUIT
+38 DO EP^APCHPWH1(DFN,TYPE)
+39 IF '$ORDER(@DATAR@(0))
QUIT
+40 SET ENT=0
FOR
SET ENT=$ORDER(@DATAR@(ENT))
IF ENT=""
QUIT
Begin DoDot:2
+41 SET BQII=BQII+1
SET @DATA@(BQII)=@DATAR@(ENT)_$CHAR(13)_$CHAR(10)
End DoDot:2
+42 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(30)
End DoDot:1
GOTO DONE
+43 ;
+44 IF $$TMPFL^BQIUL1("W",UID,DFN)
GOTO DONE
+45 ;
+46 NEW IOSL,IOM,IOST
+47 SET IOSL=999
SET IOM=80
SET IOST="P-OTHER80"
+48 USE IO
DO PRINT^APCHPMH
+49 USE IO
WRITE $CHAR(9)
+50 ;
+51 IF $$TMPFL^BQIUL1("C")
GOTO DONE
+52 IF $$TMPFL^BQIUL1("R",UID,DFN)
GOTO DONE
+53 ;
+54 FOR
USE IO
READ HSTEXT:.1
IF HSTEXT[$CHAR(9)
QUIT
Begin DoDot:1
+55 SET HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^")
+56 IF HSTEXT=""
SET HSTEXT=" "
+57 SET BQII=BQII+1
SET @DATA@(BQII)=HSTEXT_$CHAR(13)_$CHAR(10)
End DoDot:1
+58 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(30)
+59 ;
+60 IF $$TMPFL^BQIUL1("C")
GOTO DONE
+61 IF $$TMPFL^BQIUL1("D",UID,DFN)
GOTO DONE
+62 ;
DONE ;
+1 ;
+2 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+3 QUIT
+4 ;
HDR ;
+1 SET @DATA@(BQII)="T01024REPORT_TEXT"_$CHAR(30)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(BQII)
IF $DATA(DATA)
SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+6 IF $$TMPFL^BQIUL1("C")
+7 QUIT
