BOPBAT.m

BOPBAT ;IHS/ILC/ALG/CIA/PLS - Batch ILC Messages ;06-Apr-2005 13:41;SM

 ;;1.0;AUTOMATED DISPENSING INTERFACE;;Jul 26, 2005

 ;

 Q

START S U="^",DIC="^DIC(42,",DIC(0)="AEQ" D ^DIC G:Y<1 END

 S BOPWDN=$P(Y,U,2)

 S BOPDIV=$P($G(^DIC(42,+Y,0)),U,11) G:'BOPDIV END

 G:'$P($G(^BOP(90355,1,3,BOPDIV,0)),U,6) END

 S ZTRTN="EN1^BOPBAT",ZTIO="",ZTSAVE("BOPDIV")="",ZTSAVE("BOPWDN")=""

 D ^%ZTLOAD G START

EN1 S U="^"

 F BOPPI=0:0 S BOPPI=$O(^DPT("CN",BOPWDN,BOPPI)) Q:BOPPI<1  D

 .S (DFN,PSGP,BOPDFN)=BOPPI

 .D INIT^BOPCAP Q:$D(BOPQ)

 .D PID^BOPCP,PV1^BOPCP,OBXH^BOPCP,OBXW^BOPCP,AL1^BOPCP,DG1^BOPCP

 .S BOP(.02)="A01",BOP(.04)="ADT"

 .S BOP(10.2)=$G(^DPT(DFN,.1)),BOP(10.3)=$P($G(^DPT(DFN,.101)),U)

 .S X=$P($G(^DPT(DFN,.1041)),U),BOP(10.4)=$P($G(^VA(200,+X,0)),U)

 .S X=$P($G(^DPT(DFN,.105)),U),BOP(10.6)=$P($G(^DGPM(+X,0)),U)

 .S BOP(.03)=BOP(10.6)

 .S BOP10=U_BOP(10.2)_U_BOP(10.3)_U_BOP(10.4)_U_U_BOP(10.6)

 .K BOPQ D MSH^BOPCAP Q:$G(BOPQ)  D FLAG^BOPCAP

 .F BOPO=0:0 S BOPO=$O(^PS(55,DFN,5,BOPO)) Q:BOPO<1  D

 ..S BOPN0=$G(^PS(55,DFN,5,BOPO,0)) Q:'BOPN0

 ..S PSGORD=BOPO ;Order Number

 ..Q:$P(BOPN0,U,9)'="A"  ;Status

 ..Q:'$P($G(^PS(55,DFN,5,BOPO,4)),U,9)  ;Verified

 ..D NEW^BOPCAP

 ..Q

 S ZTREQ="@"

END K DFN,DIC,PSGORD,PSGP

 K BOP,BOP10,BOPDFN,BOPDIV,BOPN0,BOPO,BOPPI,BOPWDN,BOPQ Q

 ;

EOR ;BOPBAT - Batch ILC Messages

BOPBAT    ;IHS/ILC/ALG/CIA/PLS - Batch ILC Messages ;06-Apr-2005 13:41;SM

 +1       ;;1.0;AUTOMATED DISPENSING INTERFACE;;Jul 26, 2005

 +2       ;

 +3        QUIT 

START      SET U="^"

           SET DIC="^DIC(42,"

           SET DIC(0)="AEQ"

           DO ^DIC

           IF Y<1

               GOTO END

 +1        SET BOPWDN=$PIECE(Y,U,2)

 +2        SET BOPDIV=$PIECE($GET(^DIC(42,+Y,0)),U,11)

           IF 'BOPDIV

               GOTO END

 +3        IF '$PIECE($GET(^BOP(90355,1,3,BOPDIV,0)),U,6)

               GOTO END

 +4        SET ZTRTN="EN1^BOPBAT"

           SET ZTIO=""

           SET ZTSAVE("BOPDIV")=""

           SET ZTSAVE("BOPWDN")=""

 +5        DO ^%ZTLOAD

           GOTO START

EN1        SET U="^"

 +1        FOR BOPPI=0:0

               SET BOPPI=$ORDER(^DPT("CN",BOPWDN,BOPPI))

               IF BOPPI<1

                   QUIT 

               Begin DoDot:1

 +2                SET (DFN,PSGP,BOPDFN)=BOPPI

 +3                DO INIT^BOPCAP

                   IF $DATA(BOPQ)

                       QUIT 

 +4                DO PID^BOPCP

                   DO PV1^BOPCP

                   DO OBXH^BOPCP

                   DO OBXW^BOPCP

                   DO AL1^BOPCP

                   DO DG1^BOPCP

 +5                SET BOP(.02)="A01"

                   SET BOP(.04)="ADT"

 +6                SET BOP(10.2)=$GET(^DPT(DFN,.1))

                   SET BOP(10.3)=$PIECE($GET(^DPT(DFN,.101)),U)

 +7                SET X=$PIECE($GET(^DPT(DFN,.1041)),U)

                   SET BOP(10.4)=$PIECE($GET(^VA(200,+X,0)),U)

 +8                SET X=$PIECE($GET(^DPT(DFN,.105)),U)

                   SET BOP(10.6)=$PIECE($GET(^DGPM(+X,0)),U)

 +9                SET BOP(.03)=BOP(10.6)

 +10               SET BOP10=U_BOP(10.2)_U_BOP(10.3)_U_BOP(10.4)_U_U_BOP(10.6)

 +11               KILL BOPQ

                   DO MSH^BOPCAP

                   IF $GET(BOPQ)

                       QUIT 

                   DO FLAG^BOPCAP

 +12               FOR BOPO=0:0

                       SET BOPO=$ORDER(^PS(55,DFN,5,BOPO))

                       IF BOPO<1

                           QUIT 

                       Begin DoDot:2

 +13                       SET BOPN0=$GET(^PS(55,DFN,5,BOPO,0))

                           IF 'BOPN0

                               QUIT 

 +14      ;Order Number

                           SET PSGORD=BOPO

 +15      ;Status

                           IF $PIECE(BOPN0,U,9)'="A"

                               QUIT 

 +16      ;Verified

                           IF '$PIECE($GET(^PS(55,DFN,5,BOPO,4)),U,9)

                               QUIT 

 +17                       DO NEW^BOPCAP

 +18                       QUIT 

                       End DoDot:2

               End DoDot:1

 +19       SET ZTREQ="@"

END        KILL DFN,DIC,PSGORD,PSGP

 +1        KILL BOP,BOP10,BOPDFN,BOPDIV,BOPN0,BOPO,BOPPI,BOPWDN,BOPQ

           QUIT 

 +2       ;

EOR       ;BOPBAT - Batch ILC Messages