PSDTRN1.m

PSDTRN1 ;BIR/JPW-Transfer Stock NAOU to NAOU (cont'd) ; 23 Jun 93

 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

TO ;loops through local array to obtain NAOU transferring to

 F LOOP=1:1:($L(NAOUT,",")-1) S NAOU=$P(NAOUT,",",LOOP) D FROM

MSG ;sends message information

 K XMY,^TMP("PSDNTR",$J)

 S XMDUZ="CONTROLLED SUBSTANCES PHARMACY",XMY(PSDUZ)="",XMSUB="CS PHARM NAOU STOCK TRANSFER",^TMP("PSDNTR",$J,1,0)="Stock Drugs from "_$P(^PSD(58.8,NSF,0),"^")_" have been transferred into: "

 F LOOP=1:1:($L(NAOUT,",")-1) S NAOU=$P(NAOUT,",",LOOP),^TMP("PSDNTR",$J,(LOOP+1),0)=$P(^PSD(58.8,NAOU,0),"^")

 S:'$D(XMY) XMY(.5)="" S XMTEXT="^TMP(""PSDNTR"",$J," D ^XMD K XMY,^TMP("PSDNTR",$J)

END K DA,DIC,DIE,DINUM,LOC,LOOP,MTR,NAOU,NAOUT,NSF,PSDR,PSDUZ,STK,TYP,X,XMDUZ,XMSUB,XMTEXT,Y

 S:$D(ZTQUEUED) ZTREQ="@"

 Q

FROM ;finds drugs and sets data transfer

 F PSDR=0:0 S PSDR=$O(^PSD(58.8,NSF,1,PSDR)) Q:'PSDR  D

 .Q:'$D(^PSD(58.8,NSF,1,PSDR,0))

 .Q:$P($G(^PSDRUG(PSDR,2)),"^",3)'["N"

 .I $P(^PSD(58.8,NSF,1,PSDR,0),"^",14)]"",$P(^(0),"^",14)'>DT Q

 .I '$D(^PSD(58.8,NAOU,1,0)) S ^(0)="^58.8001IP^^"

 .Q:$D(^PSD(58.8,NAOU,1,PSDR,0))

 .K DA,DIC,DIE,DR S DA(1)=NAOU,DIC(0)="L"

 .S (DIC,DIE)="^PSD(58.8,"_NAOU_",1,",(X,DINUM)=PSDR K DD,DO

 .D FILE^DICN K DIC

 .I MTR'=1 S LOC=$P(^PSD(58.8,NSF,1,PSDR,0),"^",2),STK=$P(^(0),"^",3),DA=PSDR,DA(1)=NAOU,DR="1///"_LOC_";2///"_STK D ^DIE K DIE

 .I MTR=3,'$D(^PSD(58.8,NSF,1,PSDR,2,0)) Q

 .I MTR=3,'$D(^PSD(58.8,NAOU,1,PSDR,2,0)) S ^(0)="^58.800116PA^^"

 .I MTR=3 F TYP=0:0 S TYP=$O(^PSD(58.8,NSF,1,PSDR,2,TYP)) Q:'TYP  S DA(1)=PSDR,DA(2)=NAOU,DIC="^PSD(58.8,"_NAOU_",1,"_PSDR_",2,",DIC(0)="L",(X,DINUM)=TYP K DD,DO D FILE^DICN K DIC

 Q

PSDTRN1   ;BIR/JPW-Transfer Stock NAOU to NAOU (cont'd) ; 23 Jun 93

 +1       ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

TO        ;loops through local array to obtain NAOU transferring to

 +1        FOR LOOP=1:1:($LENGTH(NAOUT,",")-1)

               SET NAOU=$PIECE(NAOUT,",",LOOP)

               DO FROM

MSG       ;sends message information

 +1        KILL XMY,^TMP("PSDNTR",$JOB)

 +2        SET XMDUZ="CONTROLLED SUBSTANCES PHARMACY"

           SET XMY(PSDUZ)=""

           SET XMSUB="CS PHARM NAOU STOCK TRANSFER"

           SET ^TMP("PSDNTR",$JOB,1,0)="Stock Drugs from "_$PIECE(^PSD(58.8,NSF,0),"^")_" have been transferred into: "

 +3        FOR LOOP=1:1:($LENGTH(NAOUT,",")-1)

               SET NAOU=$PIECE(NAOUT,",",LOOP)

               SET ^TMP("PSDNTR",$JOB,(LOOP+1),0)=$PIECE(^PSD(58.8,NAOU,0),"^")

 +4        IF '$DATA(XMY)

               SET XMY(.5)=""

           SET XMTEXT="^TMP(""PSDNTR"",$J,"

           DO ^XMD

           KILL XMY,^TMP("PSDNTR",$JOB)

END        KILL DA,DIC,DIE,DINUM,LOC,LOOP,MTR,NAOU,NAOUT,NSF,PSDR,PSDUZ,STK,TYP,X,XMDUZ,XMSUB,XMTEXT,Y

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        QUIT 

FROM      ;finds drugs and sets data transfer

 +1        FOR PSDR=0:0

               SET PSDR=$ORDER(^PSD(58.8,NSF,1,PSDR))

               IF 'PSDR

                   QUIT 

               Begin DoDot:1

 +2                IF '$DATA(^PSD(58.8,NSF,1,PSDR,0))

                       QUIT 

 +3                IF $PIECE($GET(^PSDRUG(PSDR,2)),"^",3)'["N"

                       QUIT 

 +4                IF $PIECE(^PSD(58.8,NSF,1,PSDR,0),"^",14)]""

                       IF $PIECE(^(0),"^",14)'>DT

                           QUIT 

 +5                IF '$DATA(^PSD(58.8,NAOU,1,0))

                       SET ^(0)="^58.8001IP^^"

 +6                IF $DATA(^PSD(58.8,NAOU,1,PSDR,0))

                       QUIT 

 +7                KILL DA,DIC,DIE,DR

                   SET DA(1)=NAOU

                   SET DIC(0)="L"

 +8                SET (DIC,DIE)="^PSD(58.8,"_NAOU_",1,"

                   SET (X,DINUM)=PSDR

                   KILL DD,DO

 +9                DO FILE^DICN

                   KILL DIC

 +10               IF MTR'=1

                       SET LOC=$PIECE(^PSD(58.8,NSF,1,PSDR,0),"^",2)

                       SET STK=$PIECE(^(0),"^",3)

                       SET DA=PSDR

                       SET DA(1)=NAOU

                       SET DR="1///"_LOC_";2///"_STK

                       DO ^DIE

                       KILL DIE

 +11               IF MTR=3

                       IF '$DATA(^PSD(58.8,NSF,1,PSDR,2,0))

                           QUIT 

 +12               IF MTR=3

                       IF '$DATA(^PSD(58.8,NAOU,1,PSDR,2,0))

                           SET ^(0)="^58.800116PA^^"

 +13               IF MTR=3

                       FOR TYP=0:0

                           SET TYP=$ORDER(^PSD(58.8,NSF,1,PSDR,2,TYP))

                           IF 'TYP

                               QUIT 

                           SET DA(1)=PSDR

                           SET DA(2)=NAOU

                           SET DIC="^PSD(58.8,"_NAOU_",1,"_PSDR_",2,"

                           SET DIC(0)="L"

                           SET (X,DINUM)=TYP

                           KILL DD,DO

                           DO FILE^DICN

                           KILL DIC

               End DoDot:1

 +14       QUIT