- 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
