PSAOP4.m

PSAOP4 ;BIR/LTL-Outpatient Dispensing (Single Drug) & (All Drugs) - CONT'D ;7/23/97

 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3**; 10/24/97

 ;This routine gathers outpatient dispensing and is called by PSAOP2.

 ;

 N PSADRUGN S PSADRUGN=0

 F  S PSADRUGN=$O(^TMP("PSA",$J,PSADRUGN)),PSADRUG=$O(^PSDRUG("B",PSADRUGN,0)) Q:'PSADRUGN  D

 .S PSA(2)=0 F  S PSA(2)=$O(^TMP("PSA",$J,PSADRUGN,PSA(2))) Q:'PSA(2)  D

 ..S PSA(3)=+^TMP("PSA",$J,PSADRUGN,PSA(2)) D TMP^PSAOP1

 ..K:$D(^XTMP("PSA",PSAS,PSADRUGN)) ^XTMP("PSA",PSAS,PSADRUGN)

QUIT K ^TMP("PSA",$J) S:$D(ZTQUEUED) ZTREQ="@"

 Q

 ;

AM ;Collects partial fills released & returned to stock.

 F  S PSAP=$O(^PSRX("AM",PSAP)) Q:'PSAP  F  S PSAP(1)=$O(^PSRX("AM",+PSAP,PSAP(1))) Q:'PSAP(1)  D:$P($G(^PSRX(+PSAP(1),0)),U,6)=PSADRUG&($P($G(^PSRX(+PSAP(1),2)),U,9)=PSAS)

 .S PSAP(2)="" F  S PSAP(2)=$O(^PSRX("AM",+PSAP,+PSAP(1),PSAP(2))) Q:'PSAP(2)  S $P(^TMP("PSA",$J,+PSADRUG,$E(PSAP,1,7)),U)=$P($G(^TMP("PSA",$J,+PSADRUG,$E(PSAP,1,7))),U)+$P($G(^PSRX(+PSAP(1),"P",+PSAP(2),0)),U,4) D

 ..S $P(^TMP("PSA",$J,+PSADRUG,$E(PSAP,1,7)),U,6)=PSAP,$P(^($E(PSAP,1,7)),U,7)=PSAP(1)

 F  S PSAN=$O(^PSRX("AN",PSAN)) Q:'PSAN  F  S PSAN(1)=$O(^PSRX("AN",+PSAN,PSAN(1))) Q:'PSAN(1)  D:$P($G(^PSRX(+PSAN(1),0)),U,6)=PSADRUG&($P($G(^PSRX(+PSAN(1),2)),U,0)=PSAS)

 .S PSAN(2)="" F  S PSAN(2)=$O(^PSRX("AN",+PSAN,+PSAN(1),PSAN(2))) Q:'PSAN(2)  S $P(^TMP("PSA",$J,+PSADRUG,$E(PSAN,1,7)),U)=$P($G(^($E(PSAN,1,7))),U)-$P($G(^PSRX(+PSAN(1),"P",+PSAN(2),0)),U,4) D

 ..S $P(^TMP("PSA",$J,+PSADRUG,$E(PSAN,1,7)),U,8)=PSAN,$P(^($E(PSAN,1,7)),U,9)=PSAN(1)

 Q

PSAOP4    ;BIR/LTL-Outpatient Dispensing (Single Drug) & (All Drugs) - CONT'D ;7/23/97

 +1       ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3**; 10/24/97

 +2       ;This routine gathers outpatient dispensing and is called by PSAOP2.

 +3       ;

 +4        NEW PSADRUGN

           SET PSADRUGN=0

 +5        FOR 

               SET PSADRUGN=$ORDER(^TMP("PSA",$JOB,PSADRUGN))

               SET PSADRUG=$ORDER(^PSDRUG("B",PSADRUGN,0))

               IF 'PSADRUGN

                   QUIT 

               Begin DoDot:1

 +6                SET PSA(2)=0

                   FOR 

                       SET PSA(2)=$ORDER(^TMP("PSA",$JOB,PSADRUGN,PSA(2)))

                       IF 'PSA(2)

                           QUIT 

                       Begin DoDot:2

 +7                        SET PSA(3)=+^TMP("PSA",$JOB,PSADRUGN,PSA(2))

                           DO TMP^PSAOP1

 +8                        IF $DATA(^XTMP("PSA",PSAS,PSADRUGN))

                               KILL ^XTMP("PSA",PSAS,PSADRUGN)

                       End DoDot:2

               End DoDot:1

QUIT       KILL ^TMP("PSA",$JOB)

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +1        QUIT 

 +2       ;

AM        ;Collects partial fills released & returned to stock.

 +1        FOR 

               SET PSAP=$ORDER(^PSRX("AM",PSAP))

               IF 'PSAP

                   QUIT 

               FOR 

                   SET PSAP(1)=$ORDER(^PSRX("AM",+PSAP,PSAP(1)))

                   IF 'PSAP(1)

                       QUIT 

                   IF $PIECE($GET(^PSRX(+PSAP(1),0)),U,6)=PSADRUG&($PIECE($GET(^PSRX(+PSAP(1),2)),U,9)=PSAS)

                       Begin DoDot:1

 +2                        SET PSAP(2)=""

                           FOR 

                               SET PSAP(2)=$ORDER(^PSRX("AM",+PSAP,+PSAP(1),PSAP(2)))

                               IF 'PSAP(2)

                                   QUIT 

                               SET $PIECE(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSAP,1,7)),U)=$PIECE($GET(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSAP,1,7))),U)+$PIECE($GET(^PSRX(+PSAP(1),"P",+PSAP(2),0)),U,4)

                               Begin DoDot:2

 +3                                SET $PIECE(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSAP,1,7)),U,6)=PSAP

                                   SET $PIECE(^($EXTRACT(PSAP,1,7)),U,7)=PSAP(1)

                               End DoDot:2

                       End DoDot:1

 +4        FOR 

               SET PSAN=$ORDER(^PSRX("AN",PSAN))

               IF 'PSAN

                   QUIT 

               FOR 

                   SET PSAN(1)=$ORDER(^PSRX("AN",+PSAN,PSAN(1)))

                   IF 'PSAN(1)

                       QUIT 

                   IF $PIECE($GET(^PSRX(+PSAN(1),0)),U,6)=PSADRUG&($PIECE($GET(^PSRX(+PSAN(1),2)),U,0)=PSAS)

                       Begin DoDot:1

 +5                        SET PSAN(2)=""

                           FOR 

                               SET PSAN(2)=$ORDER(^PSRX("AN",+PSAN,+PSAN(1),PSAN(2)))

                               IF 'PSAN(2)

                                   QUIT 

                               SET $PIECE(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSAN,1,7)),U)=$PIECE($GET(^($EXTRACT(PSAN,1,7))),U)-$PIECE($GET(^PSRX(+PSAN(1),"P",+PSAN(2),0)),U,4)

                               Begin DoDot:2

 +6                                SET $PIECE(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSAN,1,7)),U,8)=PSAN

                                   SET $PIECE(^($EXTRACT(PSAN,1,7)),U,9)=PSAN(1)

                               End DoDot:2

                       End DoDot:1

 +7        QUIT