PSXLKUP.m

PSXLKUP ;BIR/BAB,HTW-Prescription Inquiry for Host Facility ;MAR 1,2002@16:11:17

 ;;2.0;CMOP;**23,32,47**;11 Apr 97

 ;;Reference to File #200 supported by DBIA #10060

EN ;

 S DIC("A")="Select Facility Batch Reference # :",DIC=552.4,DIC(0)="AEQMZ" D ^DIC K DIC Q:Y<0!($D(DTOUT))  S REF=+Y

 S BAT=+$G(^PSX(552.4,REF,0)) W !!,?2,"TRANSMITTED :" S Y=$P(^PSX(552.1,BAT,0),U,3) X ^DD("DD") W Y

 W ?40,"RECEIVED   : " S Y=$P(^PSX(552.1,BAT,0),U,4) X ^DD("DD") W Y

 W !,?40,"TO VENDOR  : " S Y=$P(^PSX(552.1,BAT,0),U,6) X ^DD("DD") W Y

 S DIC("A")="RX # :",DIC(0)="AEQMZ",DA(1)=REF,DIC="^PSX(552.4,"_DA(1)_",1," D ^DIC K DIC G:Y<0!($D(DTOUT)) EXIT S DA=+Y

 I $P($G(Y(0)),"^",14)=1 W ?25,"CONTROLLED SUBSTANCE"

 S QRY=+$P($G(Y(0)),U,8) I QRY>0  S QRYN=$O(^PSX(553.1,"B",QRY,0)) I QRYN>0 S Y=$P(^PSX(553.1,QRYN,0),U,4) X ^DD("DD")

 I QRY>0 W !?2,"REC'D FROM VENDOR  : ",Y

 W ! S IND=+$P(Y(0),"^",12) W !,?2,$S(IND=0:"ORIGINAL",IND>0:"REFILL #"_IND,1:"") K IND

 W ?18,"DRUG ID : ",$P(Y(0),"^",4),?40,"QTY : ",$P(Y(0),"^",13),?55,"COST : ",$P(Y(0),"^",11)

 S ST=$P(Y(0),U,10) W !!,?2,"RX STATUS : ",$S(ST=1:"RELEASED",ST=2:"RETURNED",ST=3:"PROCESSED",ST=4:"REJECTED",ST=5:"RECEIVED",1:"UNKNOWN") G:ST=5 EXIT

 S Y=$P(Y(0),U,9) X ^DD("DD") S TYP=+^PSX(552.4,DA(1),1,DA,2)

 W ?30,$S($P(Y(0),U,2)=1:"COMPLETED",$P(Y(0),U,2)=2:"CANCELED",1:"UNKNOWN")_" "_Y_"   "_$S(TYP=1:"AUTOMATED",TYP=2:"MANUAL",1:"")

 I $P(Y(0),U,2)=2 W !,?5,"CANCELLATION REASON : ",$P(Y(0),U,3)

 W !!,?2,"NDC : ",$S($P(Y(0),U,5)]"":$P(Y(0),U,5),1:"")

 W ?30,"BY EMPLOYEE : ",$$GET1^DIQ(200,$P(Y(0),U,6),.01)

 I $P(Y(0),U,7)>0 W !!,?2,"PROCESSED DT/TM : " S Y=$P(Y(0),U,7) X ^DD("DD") W Y

 I $P(Y(0),U,7)'>0 W !!

 I $G(QRY)>0 W ?50,"QUERY ID # ",QRY

 S RELTYPE=$P($G(^PSX(552.4,DA(1),1,DA,2)),"^")

 ;I $G(RELTYPE)]"" W !!,"  RELEASE TYPE:  ",$S(RELTYPE=2:"MANUAL",RELTYPE=1:"AUTOMATED",1:"UNKNOWN")

 S RER=$P($G(^PSX(552.4,DA(1),1,DA,2)),"^",2)

 I $G(RER)]"" W !!,"  REMOTE ERROR CONDITION:  "

 I  W $S(RER=1:"Release date already exists.",RER=2:"Rx entry missing.",RER=3:"Fill mismatch.",RER=4:"Transmission number mismatch.",RER=5:"No CMOP event multiple.",RER=6:"Fill does not exist",1:"UNKNOWN")

 S PSX=0 W ! F  S PSX=$O(^PSX(552.4,DA(1),1,DA,1,PSX)) Q:'PSX  D

 . S LOT=$P(^PSX(552.4,DA(1),1,DA,1,PSX,0),U),Y=$P(^(0),U,2) X ^DD("DD") W !,?10,"LOT # : ",LOT,?30,"EXP DATE : ",Y

 W !!,"  CARRIER: "_$P($G(^PSX(552.4,DA(1),1,DA,2)),"^",5),?25,"PACKAGE ID "_$P($G(^PSX(552.4,DA(1),1,DA,2)),"^",6)

 W !!,"  DATE SHIPPED: " S Y=$P($G(^PSX(552.4,DA(1),1,DA,2)),"^",4) X ^DD("DD") W Y

 G EXIT

LOT S LOT=$P(^PSX(552.4,DA(1),1,DA,1,PSX,0),U),Y=$P(^(0),U,2) X ^DD("DD") W !,?10,"LOT # : ",LOT,?30,"EXP DATE : ",Y

 Q

EXIT K DA,DIC,REF,X,Y,TYP,ST,IND,BAT,LOT,PSX,QRY,QRYN,QDT

 K REMOERR,RELTYPE,DUOUT,DTOUT,RER

 W !! G EN

PSXLKUP   ;BIR/BAB,HTW-Prescription Inquiry for Host Facility ;MAR 1,2002@16:11:17

 +1       ;;2.0;CMOP;**23,32,47**;11 Apr 97

 +2       ;;Reference to File #200 supported by DBIA #10060

EN        ;

 +1        SET DIC("A")="Select Facility Batch Reference # :"

           SET DIC=552.4

           SET DIC(0)="AEQMZ"

           DO ^DIC

           KILL DIC

           IF Y<0!($DATA(DTOUT))

               QUIT 

           SET REF=+Y

 +2        SET BAT=+$GET(^PSX(552.4,REF,0))

           WRITE !!,?2,"TRANSMITTED :"

           SET Y=$PIECE(^PSX(552.1,BAT,0),U,3)

           XECUTE ^DD("DD")

           WRITE Y

 +3        WRITE ?40,"RECEIVED   : "

           SET Y=$PIECE(^PSX(552.1,BAT,0),U,4)

           XECUTE ^DD("DD")

           WRITE Y

 +4        WRITE !,?40,"TO VENDOR  : "

           SET Y=$PIECE(^PSX(552.1,BAT,0),U,6)

           XECUTE ^DD("DD")

           WRITE Y

 +5        SET DIC("A")="RX # :"

           SET DIC(0)="AEQMZ"

           SET DA(1)=REF

           SET DIC="^PSX(552.4,"_DA(1)_",1,"

           DO ^DIC

           KILL DIC

           IF Y<0!($DATA(DTOUT))

               GOTO EXIT

           SET DA=+Y

 +6        IF $PIECE($GET(Y(0)),"^",14)=1

               WRITE ?25,"CONTROLLED SUBSTANCE"

 +7        SET QRY=+$PIECE($GET(Y(0)),U,8)

           IF QRY>0

               SET QRYN=$ORDER(^PSX(553.1,"B",QRY,0))

               IF QRYN>0

                   SET Y=$PIECE(^PSX(553.1,QRYN,0),U,4)

                   XECUTE ^DD("DD")

 +8        IF QRY>0

               WRITE !?2,"REC'D FROM VENDOR  : ",Y

 +9        WRITE !

           SET IND=+$PIECE(Y(0),"^",12)

           WRITE !,?2,$SELECT(IND=0:"ORIGINAL",IND>0:"REFILL #"_IND,1:"")

           KILL IND

 +10       WRITE ?18,"DRUG ID : ",$PIECE(Y(0),"^",4),?40,"QTY : ",$PIECE(Y(0),"^",13),?55,"COST : ",$PIECE(Y(0),"^",11)

 +11       SET ST=$PIECE(Y(0),U,10)

           WRITE !!,?2,"RX STATUS : ",$SELECT(ST=1:"RELEASED",ST=2:"RETURNED",ST=3:"PROCESSED",ST=4:"REJECTED",ST=5:"RECEIVED",1:"UNKNOWN")

           IF ST=5

               GOTO EXIT

 +12       SET Y=$PIECE(Y(0),U,9)

           XECUTE ^DD("DD")

           SET TYP=+^PSX(552.4,DA(1),1,DA,2)

 +13       WRITE ?30,$SELECT($PIECE(Y(0),U,2)=1:"COMPLETED",$PIECE(Y(0),U,2)=2:"CANCELED",1:"UNKNOWN")_" "_Y_"   "_$SELECT(TYP=1:"AUTOMATED",TYP=2:"MANUAL",1:"")

 +14       IF $PIECE(Y(0),U,2)=2

               WRITE !,?5,"CANCELLATION REASON : ",$PIECE(Y(0),U,3)

 +15       WRITE !!,?2,"NDC : ",$SELECT($PIECE(Y(0),U,5)]"":$PIECE(Y(0),U,5),1:"")

 +16       WRITE ?30,"BY EMPLOYEE : ",$$GET1^DIQ(200,$PIECE(Y(0),U,6),.01)

 +17       IF $PIECE(Y(0),U,7)>0

               WRITE !!,?2,"PROCESSED DT/TM : "

               SET Y=$PIECE(Y(0),U,7)

               XECUTE ^DD("DD")

               WRITE Y

 +18       IF $PIECE(Y(0),U,7)'>0

               WRITE !!

 +19       IF $GET(QRY)>0

               WRITE ?50,"QUERY ID # ",QRY

 +20       SET RELTYPE=$PIECE($GET(^PSX(552.4,DA(1),1,DA,2)),"^")

 +21      ;I $G(RELTYPE)]"" W !!,"  RELEASE TYPE:  ",$S(RELTYPE=2:"MANUAL",RELTYPE=1:"AUTOMATED",1:"UNKNOWN")

 +22       SET RER=$PIECE($GET(^PSX(552.4,DA(1),1,DA,2)),"^",2)

 +23       IF $GET(RER)]""

               WRITE !!,"  REMOTE ERROR CONDITION:  "

 +24      IF $TEST

               WRITE $SELECT(RER=1:"Release date already exists.",RER=2:"Rx entry missing.",RER=3:"Fill mismatch.",RER=4:"Transmission number mismatch.",RER=5:"No CMOP event multiple.",RER=6:"Fill does not exist",1:"UNKNOWN")

 +25       SET PSX=0

           WRITE !

           FOR 

               SET PSX=$ORDER(^PSX(552.4,DA(1),1,DA,1,PSX))

               IF 'PSX

                   QUIT 

               Begin DoDot:1

 +26               SET LOT=$PIECE(^PSX(552.4,DA(1),1,DA,1,PSX,0),U)

                   SET Y=$PIECE(^(0),U,2)

                   XECUTE ^DD("DD")

                   WRITE !,?10,"LOT # : ",LOT,?30,"EXP DATE : ",Y

               End DoDot:1

 +27       WRITE !!,"  CARRIER: "_$PIECE($GET(^PSX(552.4,DA(1),1,DA,2)),"^",5),?25,"PACKAGE ID "_$PIECE($GET(^PSX(552.4,DA(1),1,DA,2)),"^",6)

 +28       WRITE !!,"  DATE SHIPPED: "

           SET Y=$PIECE($GET(^PSX(552.4,DA(1),1,DA,2)),"^",4)

           XECUTE ^DD("DD")

           WRITE Y

 +29       GOTO EXIT

LOT        SET LOT=$PIECE(^PSX(552.4,DA(1),1,DA,1,PSX,0),U)

           SET Y=$PIECE(^(0),U,2)

           XECUTE ^DD("DD")

           WRITE !,?10,"LOT # : ",LOT,?30,"EXP DATE : ",Y

 +1        QUIT 

EXIT       KILL DA,DIC,REF,X,Y,TYP,ST,IND,BAT,LOT,PSX,QRY,QRYN,QDT

 +1        KILL REMOERR,RELTYPE,DUOUT,DTOUT,RER

 +2        WRITE !!

           GOTO EN