PSAPSI5.m

PSAPSI5 ;BIR/LTL,JMB-Nightly Background Job - CONT'D ;7/23/97

 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**14,25**; 10/24/97

 ;This routine gathers IV and unit dose dispensing data.

 ;

 ;References to ^PS(50.8 are covered by IA 771 (#771)

 ;Reference to ^PS(57.6 are covered by IA #772

 ;

SOL S PSAW=PSADT(3),PSADRUG(3)=$O(^PS(50.8,+PSAIV,2,+PSADT(4),2,"AC",52.7,+PSADRUG(2),0))

 F  S PSAW=$O(^PS(50.8,+PSAIV,2,+PSADT(4),2,+PSADRUG(3),3,PSAW)) Q:'PSAW  S PSAW(1)=PSAW D:$O(^PSD(58.8,"AB",PSAW,0))=PSALOC

 .S PSAQ=$G(PSAQ)+$P($G(^PS(50.8,+PSAIV,2,+PSADT(4),2,+PSADRUG(3),3,PSAW,0)),"^",2)-$P($G(^(0)),"^",5)

 S:PSAQ ^TMP("PSA",$J,+PSADRUG,PSADT(4))=$G(^TMP("PSA",$J,+PSADRUG,PSADT(4)))+PSAQ S (PSAQ,PSAW)=0

 Q

EN ; Entry point Unit Dose dispensing, returns, extras, & pre-exchange

 Q  ;DAVE B (PSA*3*25)

 S X1=DT,X2=1 D C^%DTC S ^XTMP("PSAPL",0)=X

 G:$G(PSGRTN)="PSGPLF" PICKLST

 ;

 ;Call must have came from PSGAMSA then, instead of PSGPLF

 I $D(PSGY) S PSAQTY=PSGY

 ;drug stocked in Drug Acct Location?

 G:'+PSGDRG!('$D(^PSD(58.8,"C",+PSGDRG))) EXIT

 G:'$D(PSGWARD) EXIT

 ;DAVE B (PSA*3*14) Check for more than one pharmacy location

 ;associated with the Ward

 S PSALOC1=""

1 S PSALOC1=$O(^PSD(58.8,"AB",PSGWARD,PSALOC1)) I PSALOC1="" G EXIT

 I 'PSALOC1!('$D(^PSD(58.8,"ADISP","P",+PSALOC1)))!('+$P($G(^PSD(58.8,+PSALOC1,0)),"^",3)) G 1

 I +$G(^PSD(58.8,+PSALOC1,"I")),+^PSD(58.8,+PSALOC1,"I")'>DT G 1

 S PSAIPST=+$P($G(^PSD(58.8,PSALOC1,0)),"^",3)

 D NOW^%DTC

 S ^XTMP("PSAPL",+PSAIPST,+PSGDRG,+$S($D(PSGPLFDT):PSGPLFDT,1:$P(%,".")))=$G(^XTMP("PSAPL",+PSAIPST,+PSGDRG,+$S($D(PSGPLFDT):PSGPLFDT,1:$P(%,"."))))+$G(PSAQTY)

EXIT K PSGBK,PSADA,PSGRTN,PSALOC1,PSAQTY

 Q

PICKLST ;Pick List dispensing and returns.

 I '+D3!('$D(^PSD(58.8,"C",D3))) G EXIT

 S PSAQTY=$P($G(^PS(57.6,D0,1,D1,1,D2,1,D3,0)),"^",2)

 S PSALOC1=""

2 S PSALOC1=$O(^PSD(58.8,"AB",D1,PSALOC1)) I PSALOC1="" G EXIT

 I 'PSALOC1!('$D(^PSD(58.8,"ADISP","P",+PSALOC1)))!('+$P($G(^PSD(58.8,+PSALOC1,0)),"^",3)) G 2

 I +$G(^PSD(58.8,+PSALOC1,"I")) G 2

 S PSAIPST=+$P($G(^PSD(58.8,PSALOC1,0)),"^",3)

 S ^XTMP("PSAPL",+PSAIPST,+D3,+D0)=$G(^XTMP("PSAPL",+PSAIPST,+D3,+D0))+$G(PSAQTY)

 Q

PSAPSI5   ;BIR/LTL,JMB-Nightly Background Job - CONT'D ;7/23/97

 +1       ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**14,25**; 10/24/97

 +2       ;This routine gathers IV and unit dose dispensing data.

 +3       ;

 +4       ;References to ^PS(50.8 are covered by IA 771 (#771)

 +5       ;Reference to ^PS(57.6 are covered by IA #772

 +6       ;

SOL        SET PSAW=PSADT(3)

           SET PSADRUG(3)=$ORDER(^PS(50.8,+PSAIV,2,+PSADT(4),2,"AC",52.7,+PSADRUG(2),0))

 +1        FOR 

               SET PSAW=$ORDER(^PS(50.8,+PSAIV,2,+PSADT(4),2,+PSADRUG(3),3,PSAW))

               IF 'PSAW

                   QUIT 

               SET PSAW(1)=PSAW

               IF $ORDER(^PSD(58.8,"AB",PSAW,0))=PSALOC

                   Begin DoDot:1

 +2                    SET PSAQ=$GET(PSAQ)+$PIECE($GET(^PS(50.8,+PSAIV,2,+PSADT(4),2,+PSADRUG(3),3,PSAW,0)),"^",2)-$PIECE($GET(^(0)),"^",5)

                   End DoDot:1

 +3        IF PSAQ

               SET ^TMP("PSA",$JOB,+PSADRUG,PSADT(4))=$GET(^TMP("PSA",$JOB,+PSADRUG,PSADT(4)))+PSAQ

           SET (PSAQ,PSAW)=0

 +4        QUIT 

EN        ; Entry point Unit Dose dispensing, returns, extras, & pre-exchange

 +1       ;DAVE B (PSA*3*25)

           QUIT 

 +2        SET X1=DT

           SET X2=1

           DO C^%DTC

           SET ^XTMP("PSAPL",0)=X

 +3        IF $GET(PSGRTN)="PSGPLF"

               GOTO PICKLST

 +4       ;

 +5       ;Call must have came from PSGAMSA then, instead of PSGPLF

 +6        IF $DATA(PSGY)

               SET PSAQTY=PSGY

 +7       ;drug stocked in Drug Acct Location?

 +8        IF '+PSGDRG!('$DATA(^PSD(58.8,"C",+PSGDRG)))

               GOTO EXIT

 +9        IF '$DATA(PSGWARD)

               GOTO EXIT

 +10      ;DAVE B (PSA*3*14) Check for more than one pharmacy location

 +11      ;associated with the Ward

 +12       SET PSALOC1=""

1          SET PSALOC1=$ORDER(^PSD(58.8,"AB",PSGWARD,PSALOC1))

           IF PSALOC1=""

               GOTO EXIT

 +1        IF 'PSALOC1!('$DATA(^PSD(58.8,"ADISP","P",+PSALOC1)))!('+$PIECE($GET(^PSD(58.8,+PSALOC1,0)),"^",3))

               GOTO 1

 +2        IF +$GET(^PSD(58.8,+PSALOC1,"I"))

               IF +^PSD(58.8,+PSALOC1,"I")'>DT

                   GOTO 1

 +3        SET PSAIPST=+$PIECE($GET(^PSD(58.8,PSALOC1,0)),"^",3)

 +4        DO NOW^%DTC

 +5        SET ^XTMP("PSAPL",+PSAIPST,+PSGDRG,+$SELECT($DATA(PSGPLFDT):PSGPLFDT,1:$PIECE(%,".")))=$GET(^XTMP("PSAPL",+PSAIPST,+PSGDRG,+$SELECT($DATA(PSGPLFDT):PSGPLFDT,1:$PIECE(%,"."))))+$GET(PSAQTY)

EXIT       KILL PSGBK,PSADA,PSGRTN,PSALOC1,PSAQTY

 +1        QUIT 

PICKLST   ;Pick List dispensing and returns.

 +1        IF '+D3!('$DATA(^PSD(58.8,"C",D3)))

               GOTO EXIT

 +2        SET PSAQTY=$PIECE($GET(^PS(57.6,D0,1,D1,1,D2,1,D3,0)),"^",2)

 +3        SET PSALOC1=""

2          SET PSALOC1=$ORDER(^PSD(58.8,"AB",D1,PSALOC1))

           IF PSALOC1=""

               GOTO EXIT

 +1        IF 'PSALOC1!('$DATA(^PSD(58.8,"ADISP","P",+PSALOC1)))!('+$PIECE($GET(^PSD(58.8,+PSALOC1,0)),"^",3))

               GOTO 2

 +2        IF +$GET(^PSD(58.8,+PSALOC1,"I"))

               GOTO 2

 +3        SET PSAIPST=+$PIECE($GET(^PSD(58.8,PSALOC1,0)),"^",3)

 +4        SET ^XTMP("PSAPL",+PSAIPST,+D3,+D0)=$GET(^XTMP("PSAPL",+PSAIPST,+D3,+D0))+$GET(PSAQTY)

 +5        QUIT