Routine: BQIRPASM

BQIRPASM ;VNGT/HS/ALA-Asthma Patient Care Summary ; 23 Jun 2009  1:43 PM

 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011

EN(DATA,DFN) ; EP -- BQI PATIENT ASTHMA SUMMARY

 ;Description

 ;  Generates a Patient Supplement for a given DFN and Supplement

 ;Input

 ;  DFN  - Patient Internal ID

 ;Output

 ;  DATA - Name of global in which data is stored(^TMP("BQIRPASM"))

 NEW UID,BQII,EXEC,PRGM,%,SUPL

 NEW HSTEXT,HSPATH,HSFN,Y,IOSL,IOST,IOM,I,N

 NEW APCHSPAT,APCHSHDR,APCHSTIM

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)

 S DATA=$NA(^TMP("BQIRPASM",UID))

 K @DATA

 S BQII=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPASM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2

 D HDR

 I $$TMPFL^BQIUL1("W",UID,DFN) G DONE

 S IOSL=999,IOM=80,IOST="P-OTHER80"

 ; APCHSPAT variable is required by APCH routines

 S APCHSPAT=DFN

 ; Sometimes the header needs to be defined

 S Y=DT X ^DD("DD") S APCHSDAT=Y D NOW^%DTC S X=% X ^DD("FUNC",2,1) S APCHSTIM=X

 S APCHSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_$J(APCHSTIM,9)_"  ["_$P(^VA(200,DUZ,0),U,2)_"]"

 S X="",$P(X,"*",((IOM-6-$L(APCHSHDR))\2)+1)="*"

 S APCHSHDR=X_" "_APCHSHDR_" "_X

 S SUPL=$$FIND1^DIC(9001022,"","B","ASTHMA PATIENT CARE SUMMARY","","","ERROR") I 'SUPL G DONE

 S EXEC=$G(^APCHSUP(SUPL,11)) I EXEC="" G DONE

 S PRGM=$P(EXEC,"^",2)

 I PRGM["(" S PRGM=$P(PRGM,"(",1)

 I $T(@("^"_PRGM))="" G DONE

 U IO X EXEC

 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)

HDR ;

 S @DATA@(BQII)="T00120REPORT_TEXT"_$C(30)

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")

BQIRPASM  ;VNGT/HS/ALA-Asthma Patient Care Summary ; 23 Jun 2009  1:43 PM

 +1       ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011

 +2       ;

EN(DATA,DFN) ; EP -- BQI PATIENT ASTHMA SUMMARY

 +1       ;Description

 +2       ;  Generates a Patient Supplement for a given DFN and Supplement

 +3       ;

 +4       ;Input

 +5       ;  DFN  - Patient Internal ID

 +6       ;

 +7       ;Output

 +8       ;  DATA - Name of global in which data is stored(^TMP("BQIRPASM"))

 +9       ;

 +10       NEW UID,BQII,EXEC,PRGM,%,SUPL

 +11       NEW HSTEXT,HSPATH,HSFN,Y,IOSL,IOST,IOM,I,N

 +12       NEW APCHSPAT,APCHSHDR,APCHSTIM

 +13       SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)

 +14       SET DATA=$NAME(^TMP("BQIRPASM",UID))

 +15       KILL @DATA

 +16      ;

 +17       SET BQII=0

 +18      ;

 +19      ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

           SET $ETRAP="D ERR^BQIRPASM D UNWIND^%ZTER"

 +20      ;

 +21       DO HDR

 +22      ;

 +23       IF $$TMPFL^BQIUL1("W",UID,DFN)

               GOTO DONE

 +24      ;

 +25       SET IOSL=999

           SET IOM=80

           SET IOST="P-OTHER80"

 +26      ; APCHSPAT variable is required by APCH routines

 +27       SET APCHSPAT=DFN

 +28      ;

 +29      ; Sometimes the header needs to be defined

 +30       SET Y=DT

           XECUTE ^DD("DD")

           SET APCHSDAT=Y

           DO NOW^%DTC

           SET X=%

           XECUTE ^DD("FUNC",2,1)

           SET APCHSTIM=X

 +31       SET APCHSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_$JUSTIFY(APCHSTIM,9)_"  ["_$PIECE(^VA(200,DUZ,0),U,2)_"]"

 +32       SET X=""

           SET $PIECE(X,"*",((IOM-6-$LENGTH(APCHSHDR))\2)+1)="*"

 +33       SET APCHSHDR=X_" "_APCHSHDR_" "_X

 +34      ;

 +35       SET SUPL=$$FIND1^DIC(9001022,"","B","ASTHMA PATIENT CARE SUMMARY","","","ERROR")

           IF 'SUPL

               GOTO DONE

 +36       SET EXEC=$GET(^APCHSUP(SUPL,11))

           IF EXEC=""

               GOTO DONE

 +37       SET PRGM=$PIECE(EXEC,"^",2)

 +38       IF PRGM["("

               SET PRGM=$PIECE(PRGM,"(",1)

 +39       IF $TEXT(@("^"_PRGM))=""

               GOTO DONE

 +40      ;

 +41       USE IO

           XECUTE EXEC

 +42       USE IO

           WRITE $CHAR(9)

 +43      ;

 +44       IF $$TMPFL^BQIUL1("C")

               GOTO DONE

 +45      ;

 +46       IF $$TMPFL^BQIUL1("R",UID,DFN)

               GOTO DONE

 +47      ;

 +48       FOR

               USE IO

               READ HSTEXT:.1

               IF HSTEXT[$CHAR(9)

                   QUIT

               Begin DoDot:1

 +49               SET HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^")

 +50               IF HSTEXT=""

                       SET HSTEXT=" "

 +51               SET BQII=BQII+1

                   SET @DATA@(BQII)=HSTEXT_$CHAR(13)_$CHAR(10)

               End DoDot:1

 +52       SET BQII=BQII+1

           SET @DATA@(BQII)=$CHAR(30)

 +53      ;

 +54       IF $$TMPFL^BQIUL1("C")

               GOTO DONE

 +55      ;

 +56       IF $$TMPFL^BQIUL1("D",UID,DFN)

               GOTO DONE

 +57      ;

DONE      ;

 +1       ;

 +2        SET BQII=BQII+1

           SET @DATA@(BQII)=$CHAR(31)

 +3        QUIT

 +4       ;

HDR       ;

 +1        SET @DATA@(BQII)="T00120REPORT_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

BQIRPASM.m