- PSDTRA1 ;BIR/JPW-Transfer Stock AR/WS AOU to NAOU (cont'd) ; 23 Jun 93
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- TO ;loops through local array to obtain NAOU to
- F LOOP=1:1:($L(NAOUT,",")-1) S NAOU=$P(NAOUT,",",LOOP) D FROM
- MSG ;sends message information
- K XMY,^TMP("PSDTRA",$J)
- S XMDUZ="CONTROLLED SUBSTANCES PHARMACY",XMY(PSDUZ)="",XMSUB="CS PHARM STOCK TRANSFER FROM AR/WS",^TMP("PSDTRA",$J,1,0)="Stock Drugs from AR/WS "_$P(^PSI(58.1,AOU,0),"^")_" have been transferred into:"
- F LOOP=1:1:($L(NAOUT,",")-1) S NAOU=$P(NAOUT,",",LOOP),^TMP("PSDTRA",$J,(LOOP+1),0)=$P(^PSD(58.8,NAOU,0),"^")
- S:'$D(XMY) XMY(.5)="" S XMTEXT="^TMP(""PSDTRA"",$J," D ^XMD K XMY,^TMP("PSDTRA",$J)
- END K AOU,DA,DIC,DIE,DINUM,DR,PSDRG,PSDR,LOC,LOOP,MTR,NAOU,NAOUT,PSDUZ,STK,TYP,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- FROM ;finds drugs and sets data transfer
- F PSDR=0:0 S PSDR=$O(^PSI(58.1,AOU,1,"B",PSDR)) Q:'PSDR S PSDRG=+$O(^PSI(58.1,AOU,1,"B",PSDR,0)) I PSDRG D
- .Q:'$D(^PSI(58.1,AOU,1,PSDRG,0))
- .Q:$P($G(^PSDRUG(PSDR,2)),"^",3)'["N"
- .I $P(^PSI(58.1,AOU,1,PSDRG,0),"^",3)]"",$P(^(0),"^",3)'>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",(DIC,DIE)="^PSD(58.8,"_NAOU_",1,",(X,DINUM)=PSDR K DD,DO D FILE^DICN K DIC
- .I MTR'=1 S LOC=$P(^PSI(58.1,AOU,1,PSDRG,0),"^",8),STK=$P(^(0),"^",2),DA=PSDR,DA(1)=NAOU,DR="1///"_LOC_";2///"_STK D ^DIE K DIE
- .I MTR=3,'$D(^PSI(58.1,AOU,1,PSDRG,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(^PSI(58.1,AOU,1,PSDRG,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[HPSDTRA1 1749 printed Feb 18, 2025@23:15:31 Page 2
- PSDTRA1 ;BIR/JPW-Transfer Stock AR/WS AOU to NAOU (cont'd) ; 23 Jun 93
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- TO ;loops through local array to obtain NAOU to
- +1 FOR LOOP=1:1:($LENGTH(NAOUT,",")-1)
- SET NAOU=$PIECE(NAOUT,",",LOOP)
- DO FROM
- MSG ;sends message information
- +1 KILL XMY,^TMP("PSDTRA",$JOB)
- +2 SET XMDUZ="CONTROLLED SUBSTANCES PHARMACY"
- SET XMY(PSDUZ)=""
- SET XMSUB="CS PHARM STOCK TRANSFER FROM AR/WS"
- SET ^TMP("PSDTRA",$JOB,1,0)="Stock Drugs from AR/WS "_$PIECE(^PSI(58.1,AOU,0),"^")_" have been transferred into:"
- +3 FOR LOOP=1:1:($LENGTH(NAOUT,",")-1)
- SET NAOU=$PIECE(NAOUT,",",LOOP)
- SET ^TMP("PSDTRA",$JOB,(LOOP+1),0)=$PIECE(^PSD(58.8,NAOU,0),"^")
- +4 if '$DATA(XMY)
- SET XMY(.5)=""
- SET XMTEXT="^TMP(""PSDTRA"",$J,"
- DO ^XMD
- KILL XMY,^TMP("PSDTRA",$JOB)
- END KILL AOU,DA,DIC,DIE,DINUM,DR,PSDRG,PSDR,LOC,LOOP,MTR,NAOU,NAOUT,PSDUZ,STK,TYP,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 QUIT
- FROM ;finds drugs and sets data transfer
- +1 FOR PSDR=0:0
- SET PSDR=$ORDER(^PSI(58.1,AOU,1,"B",PSDR))
- if 'PSDR
- QUIT
- SET PSDRG=+$ORDER(^PSI(58.1,AOU,1,"B",PSDR,0))
- IF PSDRG
- Begin DoDot:1
- +2 if '$DATA(^PSI(58.1,AOU,1,PSDRG,0))
- QUIT
- +3 if $PIECE($GET(^PSDRUG(PSDR,2)),"^",3)'["N"
- QUIT
- +4 IF $PIECE(^PSI(58.1,AOU,1,PSDRG,0),"^",3)]""
- IF $PIECE(^(0),"^",3)'>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"
- SET (DIC,DIE)="^PSD(58.8,"_NAOU_",1,"
- SET (X,DINUM)=PSDR
- KILL DD,DO
- DO FILE^DICN
- KILL DIC
- +8 IF MTR'=1
- SET LOC=$PIECE(^PSI(58.1,AOU,1,PSDRG,0),"^",8)
- SET STK=$PIECE(^(0),"^",2)
- SET DA=PSDR
- SET DA(1)=NAOU
- SET DR="1///"_LOC_";2///"_STK
- DO ^DIE
- KILL DIE
- +9 IF MTR=3
- IF '$DATA(^PSI(58.1,AOU,1,PSDRG,2,0))
- QUIT
- +10 IF MTR=3
- IF '$DATA(^PSD(58.8,NAOU,1,PSDR,2,0))
- SET ^(0)="^58.800116PA^^"
- +11 IF MTR=3
- FOR TYP=0:0
- SET TYP=$ORDER(^PSI(58.1,AOU,1,PSDRG,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
- +12 QUIT