Routine: BQIGPORD

BQIGPORD ;VNGT/HS/BEE-Group Order Entry ; 17 Jun 2011  12:38 PM

 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59

ORD(DATA,DFN,PARMS) ;EP -- BQI GROUP ORDER ENTRY

 NEW UID,II,HDR,IX,LIST,PC,LST,ORDTEXT,OUTLST,BQIDX,VFIEN

 NEW BQIORD,BQISTDT,BQITEXT,BQIPROV,BQILOC,ORDITM,ORDNAM,BQ

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

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

 K @DATA

 S II=0

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

 ;Define Header

 S HDR="T00001RESULT^T00050ERROR_MESSAGE^I00010DFN^I00010ORDER_NUMBER"_$C(30)

 S @DATA@(II)=HDR

 S VFIEN=$O(^BQI(90506.3,"B","Group Order Entry",""))

 I VFIEN="" S BMXSEC="RPC Call Failed: Group Order Entry" Q

 S DFN=$G(DFN,"")

 S PARMS=$G(PARMS,"")

 I PARMS="" D

 . N LIST,BN

 . S LIST="",BN=""

 . F  S BN=$O(PARMS(BN)) Q:BN=""  S LIST=LIST_PARMS(BN)

 . K PARMS

 . S PARMS=LIST

 . K LIST

 ;Pull Parameter Data

 F BQ=1:1:$L(PARMS,$C(28)) D  Q:$G(BMXSEC)'=""

 . N CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE

 . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""

 . S NAME=$P(PDATA,"=",1) I NAME="" Q

 . S VALUE=$P(PDATA,"=",2,99)

 . S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))

 . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q

 . S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)

 . I VALUE="",FIELD'=".001" S VALUE="@"

 . S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)

 . I PTYP="D"!(PTYP="A") S VALUE=$$DATE^BQIUL1(VALUE)

 . I PTYP="C" D

 .. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q

 .. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)

 . S @NAME=VALUE

 ;Set up information for API call

 S LST(1,"DFN")=DFN

 S LST(1,"PRV")=BQIPROV

 S:$G(BQIDX)]"" LST(1,"CLN")=BQIDX

 S ORDITM=$$GET1^DIQ(90621,BQIORD_",",.11,"I") G DONE:ORDITM=""

 S ORDNAM=$$GET1^DIQ(101.43,ORDITM_",",.01,"E")

 S ORDTEXT(1,0)=ORDNAM_" created from Group Order entry in iCare."

 ;Parse out incoming text

 N CNT,I,LN,CH,LINE

 S CNT=1 F I=1:1 Q:$L(BQITEXT)=0  D

 . S LN=$E(BQITEXT,1,80)

 . F CH=$L(LN):-1:1 I $E(LN,CH)=" " Q

 . I $L(BQITEXT)<81 S BQITEXT="",LINE=LN

 . E  I CH>1 S BQITEXT=$E(BQITEXT,CH+1,999999),LINE=$E(LN,1,CH-1)

 . E  S BQITEXT=$E(BQITEXT,81,999999),LINE=LN

 . S CNT=CNT+1,ORDTEXT(CNT,0)=LINE

 S ORDTEXT(0)="^100.0451^"_CNT_U_CNT_U_DT_U_U

 K CNT,I,LN,CH,LINE

 ;Check for duplicate orders

 ;Pull all active orders

 D AGET^ORWORR("",DFN,2,"","","","")

 I $D(^TMP("ORR",$J)) D

. ;

 . ;Look for duplicate order

 . NEW ORLIST,CNT,ORD

 . S ORLIST="" F  S ORLIST=$O(^TMP("ORR",$J,ORLIST)) Q:ORLIST=""  D  Q:$D(OUTLST)

 .. S CNT=.1 F  S CNT=$O(^TMP("ORR",$J,ORLIST,CNT)) Q:'CNT  D  Q:$D(OUTLST)

 ... S ORD=$P($P($G(^TMP("ORR",$J,ORLIST,CNT)),U),";")

 ... I $D(^OR(100,ORD,.1,"B",ORDITM)) S OUTLST(1)="^^DUPLICATE ORDER - ORIGINAL ORDER #"_ORD

 . K ^TMP("ORR",$J)

 ;Call Group Order API

 I '$D(OUTLST) D GRPORD^BEHOOGP(.OUTLST,.LST,ORDITM,BQISTDT,BQILOC,"",.ORDTEXT)

 ;Return Success/Failure Information

 S II=$G(II)+1

 I $P($G(OUTLST(1)),U,3)="ORDER CREATED" S @DATA@(II)="1^"_U_DFN_U_$P(OUTLST(1),U,2)_$C(30)

 I $G(OUTLST(0))'="" S @DATA@(II)="0^"_$G(OUTLST(0))_U_DFN_U_$C(30)

DONE ;

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

MACT(DATA,FAKE) ;EP -- BQI CHK SCR MAMM STS

 NEW UID,II,ACTIVE,DIC,X,IEN,Y

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

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

 K @DATA

 S II=0

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

 S @DATA@(II)="T00001ACTIVE"_$C(30)

 S ACTIVE="Y"

 S DIC="^ORD(101.43,",DIC(0)="X"

 S X="SCREENING MAMMOGRAM"

 D ^DIC

 S IEN=+Y

 I IEN="-1" S ACTIVE="N" G XMACT

 ;Check if INACTIVE

 S X=$$GET1^DIQ(101.43,IEN_",",.1,"I")

 I X]"",X<DT S ACTIVE="N"

XMACT S II=II+1,@DATA@(II)=ACTIVE_$C(30)

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

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(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)

BQIGPORD  ;VNGT/HS/BEE-Group Order Entry ; 17 Jun 2011  12:38 PM

 +1       ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59

 +2       ;

ORD(DATA,DFN,PARMS) ;EP -- BQI GROUP ORDER ENTRY

 +1       ;

 +2        NEW UID,II,HDR,IX,LIST,PC,LST,ORDTEXT,OUTLST,BQIDX,VFIEN

 +3        NEW BQIORD,BQISTDT,BQITEXT,BQIPROV,BQILOC,ORDITM,ORDNAM,BQ

 +4       ;

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

 +6        SET DATA=$NAME(^TMP("BQIGPORD",UID))

 +7        KILL @DATA

 +8        SET II=0

 +9       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +10      ;

 +11      ;Define Header

 +12       SET HDR="T00001RESULT^T00050ERROR_MESSAGE^I00010DFN^I00010ORDER_NUMBER"_$CHAR(30)

 +13       SET @DATA@(II)=HDR

 +14      ;

 +15       SET VFIEN=$ORDER(^BQI(90506.3,"B","Group Order Entry",""))

 +16       IF VFIEN=""

               SET BMXSEC="RPC Call Failed: Group Order Entry"

               QUIT

 +17      ;

 +18       SET DFN=$GET(DFN,"")

 +19      ;

 +20       SET PARMS=$GET(PARMS,"")

 +21       IF PARMS=""

               Begin DoDot:1

 +22               NEW LIST,BN

 +23               SET LIST=""

                   SET BN=""

 +24               FOR

                       SET BN=$ORDER(PARMS(BN))

                       IF BN=""

                           QUIT

                       SET LIST=LIST_PARMS(BN)

 +25               KILL PARMS

 +26               SET PARMS=LIST

 +27               KILL LIST

               End DoDot:1

 +28      ;

 +29      ;Pull Parameter Data

 +30       FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))

               Begin DoDot:1

 +31               NEW CHIEN,FIELD,NAME,PDATA,PFIEN,PTYP,VALUE

 +32               SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)

                   IF PDATA=""

                       QUIT

 +33               SET NAME=$PIECE(PDATA,"=",1)

                   IF NAME=""

                       QUIT

 +34               SET VALUE=$PIECE(PDATA,"=",2,99)

 +35               SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))

 +36               IF PFIEN=""

                       SET BMXSEC=NAME_" not a valid parameter for this update"

                       QUIT

 +37               SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)

 +38               IF VALUE=""

                       IF FIELD'=".001"

                           SET VALUE="@"

 +39               SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)

 +40               IF PTYP="D"!(PTYP="A")

                       SET VALUE=$$DATE^BQIUL1(VALUE)

 +41               IF PTYP="C"

                       Begin DoDot:2

 +42                       SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))

                           IF CHIEN=""

                               QUIT

 +43                       SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)

                       End DoDot:2

 +44               SET @NAME=VALUE

               End DoDot:1

               IF $GET(BMXSEC)'=""

                   QUIT

 +45      ;

 +46      ;Set up information for API call

 +47       SET LST(1,"DFN")=DFN

 +48       SET LST(1,"PRV")=BQIPROV

 +49       IF $GET(BQIDX)]""

               SET LST(1,"CLN")=BQIDX

 +50      ;

 +51       SET ORDITM=$$GET1^DIQ(90621,BQIORD_",",.11,"I")

           IF ORDITM=""

               GOTO DONE

 +52       SET ORDNAM=$$GET1^DIQ(101.43,ORDITM_",",.01,"E")

 +53      ;

 +54       SET ORDTEXT(1,0)=ORDNAM_" created from Group Order entry in iCare."

 +55      ;

 +56      ;Parse out incoming text

 +57       NEW CNT,I,LN,CH,LINE

 +58       SET CNT=1

           FOR I=1:1

               IF $LENGTH(BQITEXT)=0

                   QUIT

               Begin DoDot:1

 +59               SET LN=$EXTRACT(BQITEXT,1,80)

 +60               FOR CH=$LENGTH(LN):-1:1

                       IF $EXTRACT(LN,CH)=" "

                           QUIT

 +61               IF $LENGTH(BQITEXT)<81

                       SET BQITEXT=""

                       SET LINE=LN

 +62              IF '$TEST

                       IF CH>1

                           SET BQITEXT=$EXTRACT(BQITEXT,CH+1,999999)

                           SET LINE=$EXTRACT(LN,1,CH-1)

 +63              IF '$TEST

                       SET BQITEXT=$EXTRACT(BQITEXT,81,999999)

                       SET LINE=LN

 +64               SET CNT=CNT+1

                   SET ORDTEXT(CNT,0)=LINE

               End DoDot:1

 +65       SET ORDTEXT(0)="^100.0451^"_CNT_U_CNT_U_DT_U_U

 +66       KILL CNT,I,LN,CH,LINE

 +67      ;

 +68      ;Check for duplicate orders

 +69      ;

 +70      ;Pull all active orders

 +71       DO AGET^ORWORR("",DFN,2,"","","","")

 +72       IF $DATA(^TMP("ORR",$JOB))

               Begin DoDot:1

 +73      ;

 +74      ;Look for duplicate order

 +75               NEW ORLIST,CNT,ORD

 +76               SET ORLIST=""

FOR

                       SET ORLIST=$ORDER(^TMP("ORR",$JOB,ORLIST))

                       IF ORLIST=""

                           QUIT

                       Begin DoDot:2

 +77                       SET CNT=.1

FOR

                               SET CNT=$ORDER(^TMP("ORR",$JOB,ORLIST,CNT))

                               IF 'CNT

                                   QUIT

                               Begin DoDot:3

 +78                               SET ORD=$PIECE($PIECE($GET(^TMP("ORR",$JOB,ORLIST,CNT)),U),";")

 +79                               IF $DATA(^OR(100,ORD,.1,"B",ORDITM))

                                       SET OUTLST(1)="^^DUPLICATE ORDER - ORIGINAL ORDER #"_ORD

                               End DoDot:3

                               IF $DATA(OUTLST)

                                   QUIT

                       End DoDot:2

                       IF $DATA(OUTLST)

                           QUIT

 +80               KILL ^TMP("ORR",$JOB)

               End DoDot:1

 +81      ;

 +82      ;Call Group Order API

 +83       IF '$DATA(OUTLST)

               DO GRPORD^BEHOOGP(.OUTLST,.LST,ORDITM,BQISTDT,BQILOC,"",.ORDTEXT)

 +84      ;

 +85      ;Return Success/Failure Information

 +86       SET II=$GET(II)+1

 +87       IF $PIECE($GET(OUTLST(1)),U,3)="ORDER CREATED"

               SET @DATA@(II)="1^"_U_DFN_U_$PIECE(OUTLST(1),U,2)_$CHAR(30)

 +88       IF $GET(OUTLST(0))'=""

               SET @DATA@(II)="0^"_$GET(OUTLST(0))_U_DFN_U_$CHAR(30)

 +89      ;

DONE      ;

 +1        SET II=II+1

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

 +2        QUIT

 +3       ;

MACT(DATA,FAKE) ;EP -- BQI CHK SCR MAMM STS

 +1        NEW UID,II,ACTIVE,DIC,X,IEN,Y

 +2       ;

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

 +4        SET DATA=$NAME(^TMP("BQIGPORD",UID))

 +5        KILL @DATA

 +6       ;

 +7        SET II=0

 +8       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +9        SET @DATA@(II)="T00001ACTIVE"_$CHAR(30)

 +10      ;

 +11       SET ACTIVE="Y"

 +12       SET DIC="^ORD(101.43,"

           SET DIC(0)="X"

 +13       SET X="SCREENING MAMMOGRAM"

 +14       DO ^DIC

 +15       SET IEN=+Y

 +16       IF IEN="-1"

               SET ACTIVE="N"

               GOTO XMACT

 +17      ;

 +18      ;Check if INACTIVE

 +19       SET X=$$GET1^DIQ(101.43,IEN_",",.1,"I")

 +20       IF X]""

               IF X<DT

                   SET ACTIVE="N"

 +21      ;

XMACT      SET II=II+1

           SET @DATA@(II)=ACTIVE_$CHAR(30)

 +1        SET II=II+1

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

 +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(II)

               IF $DATA(DATA)

                   SET II=II+1

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

 +6        QUIT

BQIGPORD.m