BQIRSPR.m

BQIRSPR ;PRXM/HC/ALA-Retrieve Supplement List ; 16 Oct 2007  1:21 PM

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

 ;

EN(DATA,FAKE) ;EP -- BQI SUPPLEMENT TYPE

 ;

 ; Input

 ;  FAKE - extra 'blank' parameter required by BMXNET async 'feature'

 ;  

 NEW UID,BQII,II,SUPP,SUPNM,IEN,DESC,DN

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

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

 ; Initialize global array

 K @DATA

 S BQII=0

 ;

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

 ;

 ; Only register related supplements should be selected

 F II=1:1 S SUPL=$P($T(SUP+II)," ;;",2) Q:SUPL=""  D

 . S SUPP($P(SUPL,"^",1))=$P(SUPL,"^",2)

 ;

 S @DATA@(BQII)="I00010SUPPLEMENT_IEN^T00030SUPPLEMENT_NAME^T00030TAX_CHECK^T01024SUPP_DESC"_$C(30)

 ;

 S SUPNM=""

 F  S SUPNM=$O(^APCHSUP("B",SUPNM)) Q:SUPNM=""  I $D(SUPP(SUPNM)) D

 . S IEN=""

 . F  S IEN=$O(^APCHSUP("B",SUPNM,IEN)) Q:IEN=""  D

 .. S DESC="",DN=0

 .. F  S DN=$O(^APCHSUP(IEN,12,DN)) Q:'DN  D

 ... S DESC=DESC_^APCHSUP(IEN,12,DN,0)_$C(10)

 .. S BQII=BQII+1,@DATA@(BQII)=IEN_"^"_SUPNM_"^"_SUPP(SUPNM)_"^"_DESC_$C(30)

 S BQII=BQII+1,@DATA@(BQII)=$C(31)

 Q

 ;

ERR ;Error trap

 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)

 Q

 ;

SUP ; Valid Supplement names

 ;;ASTHMA^

 ;;ASTHMA PATIENT CARE SUMMARY^

 ;;DIABETIC CARE SUMMARY^

 ;;HMS PATIENT CARE SUPPLEMENT^HMS Register

 ;;PRE-DIABETES CARE SUMMARY^

 ;;WOMEN'S HEALTH PROFILE^

BQIRSPR   ;PRXM/HC/ALA-Retrieve Supplement List ; 16 Oct 2007  1:21 PM

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

 +2       ;

EN(DATA,FAKE) ;EP -- BQI SUPPLEMENT TYPE

 +1       ;

 +2       ; Input

 +3       ;  FAKE - extra 'blank' parameter required by BMXNET async 'feature'

 +4       ;  

 +5        NEW UID,BQII,II,SUPP,SUPNM,IEN,DESC,DN

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

 +7        SET DATA=$NAME(^TMP("BQIRSPR",UID))

 +8       ; Initialize global array

 +9        KILL @DATA

 +10       SET BQII=0

 +11      ;

 +12      ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +13      ;

 +14      ; Only register related supplements should be selected

 +15       FOR II=1:1

               SET SUPL=$PIECE($TEXT(SUP+II)," ;;",2)

               IF SUPL=""

                   QUIT 

               Begin DoDot:1

 +16               SET SUPP($PIECE(SUPL,"^",1))=$PIECE(SUPL,"^",2)

               End DoDot:1

 +17      ;

 +18       SET @DATA@(BQII)="I00010SUPPLEMENT_IEN^T00030SUPPLEMENT_NAME^T00030TAX_CHECK^T01024SUPP_DESC"_$CHAR(30)

 +19      ;

 +20       SET SUPNM=""

 +21       FOR 

               SET SUPNM=$ORDER(^APCHSUP("B",SUPNM))

               IF SUPNM=""

                   QUIT 

               IF $DATA(SUPP(SUPNM))

                   Begin DoDot:1

 +22                   SET IEN=""

 +23                   FOR 

                           SET IEN=$ORDER(^APCHSUP("B",SUPNM,IEN))

                           IF IEN=""

                               QUIT 

                           Begin DoDot:2

 +24                           SET DESC=""

                               SET DN=0

 +25                           FOR 

                                   SET DN=$ORDER(^APCHSUP(IEN,12,DN))

                                   IF 'DN

                                       QUIT 

                                   Begin DoDot:3

 +26                                   SET DESC=DESC_^APCHSUP(IEN,12,DN,0)_$CHAR(10)

                                   End DoDot:3

 +27                           SET BQII=BQII+1

                               SET @DATA@(BQII)=IEN_"^"_SUPNM_"^"_SUPP(SUPNM)_"^"_DESC_$CHAR(30)

                           End DoDot:2

                   End DoDot:1

 +28       SET BQII=BQII+1

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

 +29       QUIT 

 +30      ;

ERR       ;Error trap

 +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        QUIT 

 +7       ;

SUP       ; Valid Supplement names

 +1       ;;ASTHMA^

 +2       ;;ASTHMA PATIENT CARE SUMMARY^

 +3       ;;DIABETIC CARE SUMMARY^

 +4       ;;HMS PATIENT CARE SUPPLEMENT^HMS Register

 +5       ;;PRE-DIABETES CARE SUMMARY^

 +6       ;;WOMEN'S HEALTH PROFILE^