- 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
