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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDTRN1 1685 printed Apr 09, 2024@20:53:55 Page 2
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
